I am mapping out zip code areas in leaflet and coloring the polygon based on the Dealer.
Dealer Zipcodes geometry
A 32505 list(list(c(.....)))
B 32505 ....
This code is used to create the colors, labels, and the map.
factpal <- colorFactor(topo.colors(5), data$Dealer)
labels <- paste0("Zip Code: ",data$Zipcodes, ", Dealer: ", data$Dealer)
leaflet(data) %>%
addTiles() %>%
addPolygons( color = ~factpal(Dealer),),
label = labels) %>%
leaflet.extras::addSearchOSM(options = searchOptions(collapsed = FALSE)) %>%
addLegend(pal = factpal, values = ~Dealer,
opacity = 0.7,
position = "bottomright")
When the zip code (and thus the geometry) are the same between two dealers, only one label is visible, though it is clear colors are overlapping. All I want is for that label to somehow show the info for both dealers in that zip code. Please let me know if there is code missing you need, or clarification needed.
Not sure whether you could have multiple tooltips but to show all Dealers in the tooltip you could change your labels such that they include all dealer names per zip code, e.g. making use of dplyr you could do:
library(leaflet)
library(dplyr)
factpal <- colorFactor(topo.colors(5), data$Dealer)
data <- data %>%
group_by(Zipcodes) %>%
mutate(labels = paste(Dealer, collapse = ", "),
labels = paste0("Zip Code: ", Zipcodes, ", Dealer: ", labels))
leaflet(data) %>%
addTiles() %>%
addPolygons(
color = ~factpal(Dealer),
label = ~labels,
weight = 1
) %>%
# leaflet.extras::addSearchOSM(options = searchOptions(collapsed = FALSE)) %>%
addLegend(
pal = factpal, values = ~Dealer,
opacity = 0.7,
position = "bottomright"
)
DATA
nycounties <- rgdal::readOGR("https://eric.clst.org/assets/wiki/uploads/Stuff/gz_2010_us_050_00_20m.json")
nycounties_sf <- sf::st_as_sf(nycounties)
nycounties_sf_n <- nycounties_sf %>%
filter(STATE == "01") %>%
select(Zipcodes = COUNTY, geometry)
data <- list(
A = sample_n(nycounties_sf_n, 40),
B = sample_n(nycounties_sf_n, 40),
C = sample_n(nycounties_sf_n, 40),
D = sample_n(nycounties_sf_n, 40)
)
data <- purrr::imap(data, ~ mutate(.x, Dealer = .y))
data <- do.call("rbind", data)
Related
I use Leaflet with R quite frequently, but I've not used addPolylines before.
I have a series of lines with origin and destination locations that I'm attempting to plot on a map, and I'm noticing some weird behaviour:
Polylines and markers mapped to the same dataframe are not appearing in the same location.
Labels are not mapping at all to the dataframe, instead only returning the values in the last row for all lines.
Line weight mapping is not working.
I'm not entirely sure what I'm doing wrong here - any help would be appreciated. I've included a reproducible example below.
dummy <- data.frame(
Line_name = c("line1", "line2", "line3"),
origin_lng = c(145.1234, 147.223, 153.225),
origin_lat = c(-17, -19.4, -27.6),
Destination_lng = c(147.223, 153.225, 156.1123),
Destination_lat = c(-19.4, -27.6, -30.5),
Line_weight = c(1, 2, 5)
)
leaflet() %>%
addProviderTiles(provider = providers$Esri.WorldImagery) %>%
setView(lng = 146.612020, lat = -21.628836, zoom = 5) %>%
addMarkers(lng = dummy$origin_lng, lat = dummy$origin_lat, label = "origins") %>%
addPolylines(
lng = c(dummy$origin_lng, dummy$Destination_lng),
lat = c(dummy$Origin_lat, dummy$Destination_lat),
weight = dummy$Line_weight,
label = paste0(
"Line name: ", dummy$Line_name, "<br>",
"Origin coords: ", dummy$origin_lng, " ", dummy$origin_lat, "<br>",
"Destination coords: ", dummy$Destination_lng, " ", dummy$Destination_lat
) %>% lapply(htmltools::HTML)
)
You have to group the lines. You used the columns of dummy as independent vectors but sent no groups. Leaflet doesn't 'know' which labels go with which line segments. Additionally, you did get a popup, but you have to hover. (You only had one, as well.)
So, in short—grouping the data... There is probably an easier way of doing this, but this works. I pivoted longer to going the lat/long. Then I pivoted wider. Essentially, I needed the longs in a column and the lats in a column.
library(leaflet)
library(tidyverse)
dum2 <- dummy %>% pivot_longer(cols = names(.)[2:5], names_to = c("ft", "val"),
names_sep = "_", values_to = "lng_lat") %>%
pivot_wider(id_cols = c("Line_name", "ft", "Line_weight"),
names_from = "val", values_from = "lng_lat")
Then I separated the call for addPolyLines. You need one call for each group.
mp <- leaflet() %>%
addProviderTiles(provider = providers$Esri.WorldImagery) %>%
setView(lng = 146.612020, lat = -21.628836, zoom = 5) %>%
addMarkers(lng = dummy$origin_lng, lat = dummy$origin_lat, label = "origins")
map(dummy$Line_name,
function(group){
mp <<- addPolylines(
mp,
data = dum2[dum2$Line_name == group, ],
lng = ~lng,
lat = ~lat,
weight = ~Line_weight,
labelOptions = list(noHide = T, sticky = T, permanent = T),
label = paste0(
"Line name: ", group, "<br>",
"Origin coords: ", dummy[dummy$Line_name == group, ]$origin_lng,
" ", dummy[dummy$Line_name == group, ]$origin_lat, "<br>",
"Destination coords: ", dummy[dummy$Line_name == group, ]$Destination_lng,
" ", dummy[dummy$Line_name == group, ]$Destination_lat) %>%
lapply(htmltools::HTML))
}
)
I am in the process of creating an R flexdashboard. The dashboard contains several maps for Bangladesh, which are linked to a (Highcharts) chart that is activated by clicking on a polygon (e.g. region). I am able to make it work for one page. However, if I set it up for two pages, things no longer work.
It seems that flexdashboard (at least how I set it up) is not able to handle two input$map_shape_click operations at the same time. At the moment it only works on the first page, while the map does not react on the second page although a figure is produced. I welcome any suggestions to make this work.
Below a reproducible example. Note that (1) I omitted the flexdashboard yaml in the example and (2) markdown used by stackoverflow automatically renders the first, second and third header level. They render differently when run in flexdasboard (i.e. A Large Header is a new page in flexdashboard).
# Packages
library(tidyverse)
library(raster)
library(sf)
library(highcharter)
library(leaflet)
library(htmltools)
# Get data
adm1 <- getData('GADM', country='BGD', level=1)
adm1 <- st_as_sf(adm1)
# Create dummy data.frames with link to polygon
df1 <- data.frame(NAME_1 = adm1$NAME_1,
value_1 = c(1:7))
df2 <- data.frame(NAME_1 = adm1$NAME_1,
value_2 = c(8:14))
Page 1
Column {data-width=350}
Map 1
# MAIN MAP --------------------------------------------------------------------------------
output$map <- renderLeaflet({
# Base map
leaflet() %>%
addTiles(group = "OpenStreetMap") %>%
clearShapes() %>%
addPolygons(data = adm1,
smoothFactor = 0,
color = "black",
opacity = 1,
fillColor = "transparent",
weight = 0.5,
stroke = TRUE,
label = ~htmlEscape(NAME_1),
layerId = ~NAME_1,
)
})
leafletOutput('map')
# REGION SELECTION -----------------------------------------------------------------------
# Click event for the map to draw chart
click_poly <- eventReactive(input$map_shape_click, {
x <- input$map_shape_click
y <- x$id
return(y)
}, ignoreNULL = TRUE)
observe({
req(click_poly()) # do this if click_poly() is not null
# Add the clicked poly and remove when a new one is clicked
map <- leafletProxy('map') %>%
removeShape('NAME_1') %>%
addPolygons(data = adm1[adm1$NAME_1 == click_poly(), ],
fill = FALSE,
weight = 4,
color = '#d01010',
opacity = 1,
layerId = 'NAME_1')
})
Column {data-width=350}
Plot 1
data <- reactive({
# Fetch data for the click poly
out <- df1[df1$NAME_1 == click_poly(), ]
print("page 1") # print statement to show which click_poly is used
return(out)
})
output$plot <- renderHighchart({
req(data()) # do this if click_poly() is not null
chart <- highchart() %>%
hc_chart(type = 'column') %>%
hc_legend(enabled = FALSE) %>%
hc_xAxis(categories = c('A'),
title = list(text = 'Title 1')) %>%
hc_yAxis(title = list(text = 'Value 1')) %>%
hc_plotOptions(series = list(dataLabels = list(enabled = TRUE))) %>%
hc_add_series(name = 'Series',
data = c(data()$value_1)) %>%
hc_add_theme(hc_theme_smpl()) %>%
hc_colors(c('#d01010'))
})
highchartOutput('plot')
Page 2
Column {data-width=350}
Map 2
# MAIN MAP --------------------------------------------------------------------------------
output$map2 <- renderLeaflet({
# Base map
leaflet() %>%
addTiles(group = "OpenStreetMap") %>%
clearShapes() %>%
addPolygons(data = adm1,
smoothFactor = 0,
color = "black",
opacity = 1,
fillColor = "transparent",
weight = 0.5,
stroke = TRUE,
label = ~htmlEscape(NAME_1),
layerId = ~NAME_1,
)
})
leafletOutput('map2')
# REGION SELECTION -----------------------------------------------------------------------
# Click event for the map to draw chart
click_poly2 <- eventReactive(input$map_shape_click, {
x <- input$map_shape_click
y <- x$id
return(y)
}, ignoreNULL = TRUE)
observe({
req(click_poly2()) # do this if click_poly() is not null
# Add the clicked poly and remove when a new one is clicked
map <- leafletProxy('map2') %>%
removeShape('NAME_1') %>%
addPolygons(data = adm1[adm1$NAME_1 == click_poly2(), ],
fill = FALSE,
weight = 4,
color = '#d01010',
opacity = 1,
layerId = 'NAME_1')
})
Column {data-width=350}
Plot 2
data2 <- reactive({
# Fetch data for the click poly
out <- df2[df2$NAME_1 == click_poly2(), ]
print("page 2") # print statement to show which click_poly is used
return(out)
})
output$plot2 <- renderHighchart({
req(data2()) # do this if click_poly() is not null
chart <- highchart() %>%
hc_chart(type = 'column') %>%
hc_legend(enabled = FALSE) %>%
hc_xAxis(categories = c('A'),
title = list(text = 'Title 2')) %>%
hc_yAxis(title = list(text = 'Value 2')) %>%
hc_plotOptions(series = list(dataLabels = list(enabled = TRUE))) %>%
hc_add_series(name = 'Series',
data = c(data2()$value_2)) %>%
hc_add_theme(hc_theme_smpl()) %>%
hc_colors(c('#d01010'))
})
highchartOutput('plot2')
In your click_poly2 <- eventReactive(input$map_shape_click, you have click_poly2 being the 2nd map, but you have the same map_shape_click, what if you made it map_shape_click2, hopefully flexdashboard will handle it differently as now they are 2 different maps
I figured out the answer myself following a similar question I found somewhere else. As I am quite new to shiny and based my code on examples I found, I did not realize that 'map_shape_click' applies 'shape_click' on 'map' where 'map' corresponds with the map in output$map. As I have two maps: map and map2, the eventReactive statement for page2 should be changed into
click_poly2 <- eventReactive(input$map2_shape_click, {
x <- input$map2_shape_click
y <- x$id
return(y)
}, ignoreNULL = TRUE)
Now responding to a shape_click on map2
I posted this in the plotly community forum but got absolutely no activity! Hope you can help here:
I have map time-series data, some countries don’t have data and plotly does not plot them at all. I can have them outlined and they look different but it appears nowhere that the data is missing there (i.e. I want a legend entry). How can I achieve this? Here is a reprex:
library(plotly)
library(dplyr)
data = read.csv('https://github.com/lc5415/COVID19/raw/master/data.csv')
l <- list(color = toRGB("grey"), width = 0.5)
g <- list(
scope = 'world',
countrycolor = toRGB('grey'),
showframe = T,
showcoastlines = TRUE,
projection = list(type = 'natural earth')
)
map.time = data %>%
plot_geo() %>%
add_trace(z = ~Confirmed, color = ~Confirmed, frame = ~Date, colors = 'Blues',
text = ~Country, locations = ~Alpha.3.code, marker = list(line = l)) %>%
colorbar(title = 'Confirmed') %>%
layout(
title = 'Number of confirmed cases over time',
geo = g
) %>%
animation_opts(redraw = F) %>%
animation_slider(
currentvalue = list(
prefix = paste0("Days from ",
format(StartDate, "%B %dnd"),": "))) %>%
plotly_build()
map.time
Note that the countries with missing data (e.g. Russia) have as many data points as all other countries, the issue is not that they do not appear in the dtaframe passed to plotly.
The obvious way to handle this is to create a separate labels column for the tooltip that reads "No data" for NA values (with the actual value otherwise), then make your actual NA values 0. This will give a uniform appearance to all the countries but correctly tells you when a country has no data.
map.time = data %>%
mutate_if(is.numeric, function(x) {x[is.na(x)] <- -1; x}) %>%
plot_geo() %>%
add_trace(z = ~Confirmed, color = ~Confirmed, frame = ~Date, colors = 'Blues',
text = ~Country, locations = ~Alpha.3.code,
marker = list(line = l)) %>%
colorbar(title = 'Confirmed') %>%
layout(
title = 'Number of confirmed cases over time',
geo = g
) %>%
animation_opts(redraw = F) %>%
animation_slider(
currentvalue = list(
prefix = paste0("Days from ",
format(StartDate, "%B %dnd"),": "))) %>%
plotly_build()
Which gives:
I'm trying to create a choropleth map in county level using leaflet R package and I actually do it. But when I check my data file and the hover text of any county I find that the values are not correct. For example check the Conejos county. Any explanation? Or a better way to process tha data and create this map without the mismatches?
Code:
library(raster)
library(leaflet)
library(tidyverse)
# Get USA polygon data
USA <- getData("GADM", country = "usa", level = 2)
### Get data
mydata <- read.csv("https://www.betydb.org/miscanthus_county_avg_yield.csv",
stringsAsFactors = FALSE) %>%
dplyr::select(COUNTY_NAME, Avg_yield)
### Check counties that exist in USA, but not in mydata
### Create a dummy data frame and bind it with mydata
mydata <- data.frame(COUNTY_NAME = setdiff(USA$NAME_2, mydata$COUNTY_NAME),
Avg_yield = NA,
stringsAsFactors = FALSE) %>%
bind_rows(mydata)
### Create a color palette
mypal <- colorNumeric(palette = "viridis", domain = mydata$Avg_yield)
leaflet() %>%
addProviderTiles("OpenStreetMap.Mapnik") %>%
setView(lat = 39.8283, lng = -98.5795, zoom = 4) %>%
addPolygons(data = USA, stroke = FALSE, smoothFactor = 0.2, fillOpacity = 0.3,
fillColor = ~mypal(mydata$Avg_yield),
popup = paste("Region: ", USA$NAME_2, "<br>",
"Avg_yield: ", mydata$Avg_yield, "<br>")) %>%
addLegend(position = "bottomleft", pal = mypal, values = mydata$Avg_yield,
title = "Avg_yield",
opacity = 1)
I'd like to link a leaflet map and a data table created by DT library by using crosstalk instead of shiny. So when I click any record on table side, the circle in the map will be highlighted. I know the lat and long are required to generate the leaflet map, but is there a way that the table side only have Name and Area columns there (not show lat and long)?
Here are my example code:
library(leaflet)
library(DT)
library(crosstalk)
df <- read.csv(textConnection(
"Name,Lat,Long, area
Samurai Noodle,47.597131,-122.327298,40
Kukai Ramen,47.6154,-122.327157,30
Tsukushinbo,47.59987,-122.326726,10"
))
df$Name <- as.character(df$Name)
sdf <- SharedData$new(df, ~df$Name)
pal <- colorNumeric("RdYlBu", df$area)
labels <- paste(sep = "<br/>",
paste('Name: ', df$Name),
paste('Area: ', df$area))
d1 <- leaflet(sdf) %>%
addTiles() %>%
addCircleMarkers(~Long,
~Lat,
radius = df$area,
color = ~pal(df$area),
fillColor = ~pal(df$area),
popup = labels,
fillOpacity = 1) %>%
addLegend("topright",
title = "AREA",
pal = pal,
values = df$area,
opacity = 1)
d2 <- datatable(sdf, width = "100%")
bscols(d1, d2)
You don't need another SharedData.
A quick solution is in datatable's options.
datatable(sdf, options=list(columnDefs = list(list(visible=FALSE,
targets=c(2,3))))) #positions
I figured out this question today.
What I need to do is create df_2 (remove log and lat), and create another SharedData object by using df_2, and adding group.
sdf_2 <- SharedData$new(df_2, ~df$Name, group = "data_subset")
Use sdf and sdf_2 to create leaflet map and datatable separately:
d1 <- leaflet(sdf) %>% addTiles() %>% addCircleMarkers(~Long,
~Lat,
radius = df$area,
color = ~pal(df$area),
fillColor = ~pal(df$area),
popup = labels,
fillOpacity = 1) %>% addLegend("topright",
title = "AREA",
pal = pal,
values = df$area,
opacity = 1)
d2 <- datatable(sdf_2, width = "100%")
bscols(d1, d2)