I am working with the R programming language.
Using the "leaflet" library, I made the following map for these 5 cities:
library(dplyr)
library(leaflet)
map_data <- data.frame("Lat" = c(43.6426, 43.6424, 43.6544, 43.6452, 43.6629), "Long" = c(-79.3871, -79.3860, -79.3807, -79.3806,-79.3957 ), type = c(1,2,3,4,5))
map_data$type = as.factor(map_data$type)
leaflet(map_data) %>%
addTiles() %>% addCircleMarkers(stroke = FALSE, label = ~type,fillOpacity = 0.8, labelOptions = labelOptions(direction = "center",style = list('color' = "white"),noHide = TRUE, offset=c(0,0), fill = TRUE, opacity = 1, weight = 10, textOnly = TRUE))
On this above map that I have created, I would now like to "connect" all these "points" (i.e. cities) on the map (in a route) based on their "number" (e.g. connect 1 with 2, 2 with 3, 3 with 4, 4 with 5, 5 with 1), and output the "total distance" of the route. I found a previous post that shows how to do this: How to show path and distance on map with leaflet, shiny apps?
I tried to adapt the code from this post to suit my question:
library(osrm)
route = osrmRoute(c(-79.3871, -79.3860, -79.3807, -79.3806,-79.3957 ), c(43.6426, 43.6424, 43.6544, 43.6452, 43.6629), overview = 'full')
route_summary = osrmRoute(c(-79.3871, -79.3860, -79.3807, -79.3806,-79.3957 ), c(43.6426, 43.6424, 43.6544, 43.6452, 43.6629), overview = FALSE)
leaflet() %>% addTiles() %>%
addCircleMarkers(c(-79.3871, -79.3860, -79.3807, -79.3806,-79.3957 ), c(43.6426, 43.6424, 43.6544, 43.6452, 43.6629), stroke = FALSE, label = ~type,fillOpacity = 0.8,
labelOptions = labelOptions(direction = "center",style = list('color' = "white"),noHide = TRUE, offset=c(0,0), fill = TRUE, opacity = 1, weight = 10, textOnly = TRUE)) %>%
addPolylines(route$lon,route$lat,
label = paste(round(route_summary[1]/60), 'hr - ', round(route_summary[2]), 'km'),
labelOptions = labelOptions(noHide = TRUE))
But this returns the following error:
Error in UseMethod("metaData") :
no applicable method for 'metaData' applied to an object of class "NULL"
Can someone please show me how to fix this problem?
I would like to do this using "leaflet" and not using "rshiny". In the end, I would like the final map to look something like this (this is supposed to represent a "single path" from a Travelling Salesman Problem) :
[![enter image description here][2]][2]
Note: I am starting to think that problem might be that the "osrmRoute()" function might not be able to work for more than 2 points?
https://github.com/riatelab/osrm/issues/41
https://rdrr.io/cran/osrm/man/osrmTrip.html
One way is for you to make API call:
https://github.com/Project-OSRM/osrm-backend/blob/master/docs/http.md
I'll just outline how can you do it:
data
df <- data.frame(
lon = c(-79.3871, -79.3860, -79.3807, -79.3806,-79.3957),
lat = c(43.6426, 43.6424, 43.6544, 43.6452, 43.6629)
)
url call
root <- "http://router.project-osrm.org/route/v1/driving/"
options <- c(
continue_straight = "true",
overview = "full",
annotations = "true",
steps = "true"
)
coords <- df %>%
slice(c(seq_len(n()), 1)) %>%
pmap_chr(str_c, sep = ",") %>% str_c(collapse = ";")
options <- options %>%
imap_chr(~str_c(.y, "=", .x)) %>%
str_c(collapse = "&") %>%
str_c("?", .)
res <- rjson::fromJSON(file = str_c(root, coords, options))
Note that I've added first point as 6th row to make circle route.
map
res$routes[[1]]$geometry %>%
googlePolylines::decode() %>%
.[[1]] %>%
leaflet() %>%
addTiles() %>%
addPolylines(lng = ~lon, lat = ~lat) %>%
addCircleMarkers(
data = df,
stroke = FALSE,
label = seq_len(nrow(df)),
fillOpacity = 0.8,
labelOptions = labelOptions(
direction = "center",
style = list('color' = "white"),
noHide = TRUE,
offset=c(0,0),
fill = TRUE,
opacity = 1,
weight = 10,
textOnly = TRUE
)
)
distance
res$routes[[1]]$distance
This is in meters (documentation)
EDIT
There probably is better way of labeling polyline but I don't have time now:
library(sf)
segment_df <- df %>% rbind(df[1,])
d <- segment_df %>%
st_as_sf(coords = c("lon", "lat"), crs = 4326) %>%
{st_distance(.[-6,], .[-1,], by_element = TRUE)} %>%
as.vector() %>%
round()
m <- leaflet() %>% addTiles()
for(i in seq_len(nrow(segment_df) - 1))
m <- m %>% addPolylines(
data = segment_df[i:(i+1),],
lng = ~lon, lat = ~lat, color = "red", label = paste(d[[i]], "m"),
labelOptions(noHide = TRUE, direction = 'top')
)
m <- m %>% addCircleMarkers(
data = df,
stroke = FALSE,
label = seq_len(nrow(df)),
fillOpacity = 0.8,
labelOptions = labelOptions(
direction = "center",
style = list('color' = "white"),
noHide = TRUE,
offset=c(0,0),
fill = TRUE,
opacity = 1,
weight = 10,
textOnly = TRUE
)
)
If you want only to show total distance then that is easier and does not require loop, just replace loop with:
segment_df %>%
leaflet() %>%
addTiles() %>%
addPolylines(
lng = ~lon, lat = ~lat, color = "red",
label = paste(sum(d), "m"),
labelOptions = labelOptions(noHide = TRUE, direction = 'top')
)
I hope you understand (and see from map) that this is not drivable.
Here is an answer I tried based on #det's answer:
library(sf)
library(geosphere)
library(dplyr)
library(leaflet)
library(data.table)
library(VPF)
#add a 6th row that is equal to the 1st row - so that the path loops back
map_data <- data.frame("Lat" = c(43.6426, 43.6424, 43.6544, 43.6452, 43.6629, 43.6426), "Long" = c(-79.3871, -79.3860, -79.3807, -79.3806,-79.3957, -79.3871 ), type = c(1,2,3,4,5,1))
map_data$type = as.factor(map_data$type)
m1 = leaflet(map_data) %>% addTiles() %>% addCircleMarkers(stroke = FALSE, label = ~type,fillOpacity = 0.8,
color = ~ifelse(type==1,"red","blue"), labelOptions = labelOptions(direction = "center",style = list('color' = "white"),
noHide = TRUE, offset=c(0,0), fill = TRUE, opacity = 1, weight = 10, textOnly = TRUE))
m1 %>% addTiles() %>%
addPolylines(data = map_data, lng = ~Long, lat = ~Lat, group = ~type)
Now, I want to calculate the total distance of the trip and have it displayed on the map:
#distances (https://stackoverflow.com/questions/42119438/calculate-distance-between-two-long-lat-coordinates-in-a-dataframe)
result = rbind(
cbind(map_data[1:nrow(map_data)-1,c(1,2)], map_data[-1,c(1,2)]),
cbind(map_data[nrow(map_data), c(1,2)], map_data[1,c(1,2)])
)
colnames(result) <- c("start_lat", "start_long", "end_lat", "end_long")
result$id = as.factor(c(1,2,3,4,5,1))
result = data.frame(result)
for (i in 1:nrow(result)) {
a<-result$start_long[i]
b<-result$start_lat[i]
c<-result$end_long[i]
d<-result$end_lat[i]
result$distance[i]<-distm(c(a,b),c(c,d), fun = distHaversine)
}
#total distance of trip in meters
d = result$distance
total_d = signif(sum(d),3)
m1 %>% addPolylines(
data = map_data,
lng = ~Long, lat = ~Lat, color = "blue", label = paste0(total_d, " meters"),
labelOptions(noHide = TRUE, direction = 'top')
)
I think I finally got it - thanks so much # Det!
Is it possible to add a pop-label when the user mouse over a certain point in a leaflet heatmap? For example to see depth and stations from the quakes dataset.
library(leaflet)
leaflet(quakes) %>%
addProviderTiles(providers$CartoDB.DarkMatter) %>%
setView( 178, -20, 5 ) %>%
addHeatmap(
lng = ~long, lat = ~lat, intensity = ~mag,
blur = 20, max = 0.05, radius = 15
)
## for more examples see
# browseURL(system.file("examples/heatmaps.R", package = "leaflet.extras"))
kml <- readr::read_file(
system.file("examples/data/kml/crimes.kml.zip", package = "leaflet.extras")
)
leaflet() %>%
setView(-77.0369, 38.9072, 12) %>%
addProviderTiles(providers$CartoDB.Positron) %>%
addKMLHeatmap(kml, radius = 7) %>%
addKML(
kml,
markerType = "circleMarker",
stroke = FALSE, fillColor = "black", fillOpacity = 1,
markerOptions = markerOptions(radius = 1))
I'm not sure this is what you want but you can add marker popups in the usual way:
library(leaflet)
leaflet(quakes) %>%
addProviderTiles(providers$CartoDB.DarkMatter) %>%
setView( 178, -20, 5 ) %>%
addHeatmap(
lng = ~long, lat = ~lat, intensity = ~mag,
blur = 20, max = 0.05, radius = 15
) %>%
addMarkers(lng = quakes$long, lat = quakes$lat,
popup = paste("Depth", quakes$depth, "<br>",
"Stations:", quakes$stations))
if you dont want the dominating markers visible you could add circle markers but set the fillOpacity to zero:
leaflet(quakes) %>%
addProviderTiles(providers$CartoDB.DarkMatter) %>%
setView( 178, -20, 5 ) %>%
addHeatmap(
lng = ~long, lat = ~lat, intensity = ~mag,
blur = 20, max = 0.05, radius = 15
) %>%
addCircleMarkers(lng = quakes$long, lat = quakes$lat,
fillOpacity = 0, weight = 0,
popup = paste("Depth:", quakes$depth, "<br>",
"Stations:", quakes$stations),
labelOptions = labelOptions(noHide = TRUE))
Is it possible, to make the black line thinner?
Here's a reproducible example, see also here:
library(leaflet)
leaflet() %>%
addTiles() %>%
addProviderTiles(providers$OpenStreetMap, group = "OSM") %>%
addProviderTiles(providers$Stamen.TonerLite, group = "Toner Lite") %>%
addLayersControl(baseGroups = c("OSM", "Toner Lite")) %>%
leaflet::addCircleMarkers(lat = 0,
lng = 0,
color = "black",
fillColor = "red",
stroke = TRUE,
popup = "hello",
radius = 10,
fillOpacity = 0.7)
You can specifiy the stroke weight with the weight argument:
library(leaflet)
leaflet() %>%
addTiles() %>%
addProviderTiles(providers$OpenStreetMap, group = "OSM") %>%
addCircleMarkers(lat = 0,
lng = 0,
stroke = TRUE,
weight = 1)
leaflet() %>%
addTiles() %>%
addProviderTiles(providers$OpenStreetMap, group = "OSM") %>%
addCircleMarkers(lat = 0,
lng = 0,
stroke = TRUE,
weight = 100)
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")}
})
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;}"),
...
)