Bivariate map within Shiny r - 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))
})

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.

Leaflet ZoomSnap create gridline on map

I am using zoomSnap in my r script for leaflet. When I put a value for zoomSnap in the option and render the leaflet map I see gridlines on the map. How can I remove those gridlines?
leaflet(options = leafletOptions(zoomDelta= 0.05,
zoomSnap= 0)) %>%
addTiles() %>%
setView(lng = 10,lat = 10, zoom = 2.2) %>%
addPolygons(data=sPDF, weight = 1.5, fillColor = ~pal(n) ,color="white", fillOpacity = 1, highlight = highlightOptions(
fillColor = '#1c5d99'),label=~as.character(tooltip)) %>%
addLegendNumeric(
pal = pal,
values = z$n,
position = 'bottomleft',
title = 'Number of agreements',
orientation = 'horizontal',
shape = 'rect',
decreasing = FALSE,
height = 10,
width = 200,
tickLength = 0,
tickWidth = 0
)
I am getting gridlines like this:

Leaflet with Shiny - how to ensure maximum zoom in option for the user

For one of the map use case , need to provide maximum zoom in option for the user in shiny app. Have tried to explore some of the options as per below code. Wanted to understand if this is the maximum limit we can have in shiny app using leaflet or I am missing something , really appreciate some guidance here.
One of the reactjs web application , Zoom In is possible even further - Here we are using bing / google map license though.
field <- raster::shapefile("sampleShapleFile.shp") # shapefile (field) imported
library(leaflet)
library(leaflet.extras)
leaflet(data = field ,
options = leafletOptions(zoomSnap = 0.25, zoomDelta = 0.25)) %>%
addFullscreenControl(position = "topleft", pseudoFullscreen = FALSE) %>%
addBingTiles(
"Aq4GyoG8kzfeKO7Nsav5_BcjVVA_d1ULSTeXeW2zM0aPuANIqhvV5IrFtMjOGX3s",
imagerySet = c("AerialWithLabels"),
group = "AerialWithLabels",
options = tileOptions(minZoom = 0, maxZoom = 18)
) %>%
addPolygons(
fill = FALSE,
stroke = TRUE,
weight = 5,
opacity = 1,
color = "#FFFFFF"
) %>%
addLegend("bottomright", color = "#FFFFFF", labels = "Test") %>%
addMeasure(
position = "bottomleft",
primaryLengthUnit = "meters",
primaryAreaUnit = "sqmeters",
activeColor = "#10bae0",
completedColor = "#241ad9"
) %>%
addDrawToolbar(
targetGroup = 'draw',
polygonOptions = FALSE,
circleOptions = FALSE,
rectangleOptions = FALSE,
markerOptions = FALSE,
circleMarkerOptions = FALSE,
editOptions = editToolbarOptions(selectedPathOptions = selectedPathOptions())
) %>%
addScaleBar(position = "topright",
options = scaleBarOptions(
maxWidth = 1,
metric = TRUE,
imperial = FALSE
))
"maxNativeZoom" with "maxZoom" Option in "addTiles" can be utilized to enhance zoom in level for Google / Bing Map
Useful Reference Links :
https://gis.stackexchange.com/questions/78843/zoom-further-in-than-level-19-with-leaflet-javascript-api
https://github.com/digidem/leaflet-bing-layer/issues/8
## app.R ##
library(shiny)
library(shinydashboard)
library(leaflet)
library(leaflet.extras)
ui <- dashboardPage(dashboardHeader(),
dashboardSidebar(),
dashboardBody(leafletOutput("map")))
server <- function(input, output) {
field <-
raster::shapefile("sample.shp") # shapefile (field) imported
output$map <- renderLeaflet({
leaflet(data = field) %>%
addFullscreenControl(position = "topleft", pseudoFullscreen = FALSE) %>%
# addTiles(
# group = "Satellite",
# urlTemplate = "http://mt0.google.com/vt/lyrs=s&hl=en&x={x}&y={y}&z={z}&s=Ga",
# options = tileOptions(maxZoom = 21 , maxNativeZoom = 18)
# ) %>%
addBingTiles("Aq4GyoG8kzfeKO7Nsav5_BcjVVA_d1ULSTeXeW2zM0aPuANIqhvV5IrFtMjOGX3s",
imagerySet = c("AerialWithLabels"),group = "AerialWithLabels",
maxNativeZoom = 18,maxZoom = 21
) %>%
addPolygons(
fill = FALSE,
stroke = TRUE,
weight = 5,
opacity = 1,
color = "#FFFFFF"
) %>%
addLegend("bottomright", color = "#FFFFFF", labels = "Test") %>%
addMeasure(
position = "bottomleft",
primaryLengthUnit = "meters",
primaryAreaUnit = "sqmeters",
activeColor = "#10bae0",
completedColor = "#241ad9"
) %>%
addDrawToolbar(
targetGroup = 'draw',
polygonOptions = FALSE,
circleOptions = FALSE,
rectangleOptions = FALSE,
markerOptions = FALSE,
circleMarkerOptions = FALSE,
editOptions = editToolbarOptions(selectedPathOptions = selectedPathOptions())
) %>%
addScaleBar(
position = "topright",
options = scaleBarOptions(
maxWidth = 10,
metric = TRUE,
imperial = FALSE
)
)
})
}
shinyApp(ui, server)

Is there a way to conditionally vary opacity of polygons using Leaflet?

I am using the R leaflet package to plot data for California counties. I would like the polygons of each county to vary in opacity based on the number of parcels in that county. Counties with more parcels should be more opaque, and counties with fewer parcels should be more transparent. Is this possible?
I have tried changing the fillOpacity option similar to how fillColor varies with number of parcels:
fillOpacity = ~num.parcels
Sample of my data:
packages <- c('dplyr','leaflet','sf','USAboundaries')
lapply(packages, library, character.only = TRUE)
ca_counties <- USAboundaries::us_counties(states = 'CA')
parcels <- structure(list(county = c("Yuba", "Sacramento", "Inyo", "Los Angeles", "Sierra"),
num.parcels = c(27797L, 452890L, 6432L, 15830L, 54291L)), row.names = c(NA, -5L), class = "data.frame")
parcels <- st_as_sf(left_join(parcels, ca_counties[,c('name')], by = c("county" = "name")))
Leaflet map:
labels <- sprintf(
"<strong>%s County</strong><br/>
Parcels: %g<br/>",
parcels$county, parcels$num.parcels
) %>% lapply(htmltools::HTML)
leaflet(parcels) %>%
setView(-119, 37.9, 6) %>%
addTiles() %>%
addPolygons(
fillColor = ~pal(num.parcels),
weight = 2,
opacity = 1,
color = 'black',
dashArray = '2',
fillOpacity = 0.7,
highlightOptions = highlightOptions(color = "red", weight = 3,
bringToFront = TRUE),
label = labels,
labelOptions = labelOptions(
style = list("font-weight" = "normal", padding = "4px 8px"),
textsize = "15px",
direction = 'auto')) %>%
addLegend(pal = pal, values = ~num.parcels, opacity = 0.7, title = "Number of Parcels",
position = "bottomleft")
try setting fillOpacity = ~num.parcels / max(num.parcels),
I also included a pal-function.. it seemed to be missing from your code..
# Create a continuous palette function
pal <- colorNumeric( palette = "Reds", domain = parcels$num.parcels )
#calculate fillopacity
labels <- sprintf(
"<strong>%s County</strong><br/>
Parcels: %g<br/>",
parcels$county, parcels$num.parcels
) %>% lapply(htmltools::HTML)
leaflet(parcels) %>%
setView(-119, 37.9, 6) %>%
addTiles() %>%
addPolygons(
fillColor = ~pal(num.parcels),
weight = 2,
opacity = 1,
color = 'black',
dashArray = '2',
fillOpacity = ~num.parcels / max(num.parcels),
highlightOptions = highlightOptions(color = "red", weight = 3,
bringToFront = TRUE),
label = labels,
labelOptions = labelOptions(
style = list("font-weight" = "normal", padding = "4px 8px"),
textsize = "15px",
direction = 'auto')) %>%
addLegend(pal = pal, values = ~num.parcels, opacity = 1, title = "Number of Parcels",
position = "bottomleft")

loops in leaflet R

I want to make a loop to add polygons to a leaflet map according to different columns of a data frame.
for (i in 18:22)
createMap = lapply((concello_wgs84_Datos#data[,i]),function(x){
data <- concello_wgs84_Datos#data[,i]
nombre <- names(concello_wgs84_Datos#data[,i])
pal3 <- leaflet::colorBin("YlOrRd", domain = data, 20, pretty = TRUE)
m = leaflet(data=concello_wgs84_Datos[1:17 & concello_wgs84_Datos#data[,i] == x], options = leafletOptions(minZoom = 8, maxZoom = 18)) %>%
addProviderTiles(providers$Esri.WorldImagery) %>% setView(-8.00, 42.80, zoom = 8.3) %>%
addPolygons(data=datos,
fill= TRUE,
fillColor = ~pal3(data),
stroke = FALSE,
color = "#0000CD",
smoothFactor = 0.5,
opacity = 1.0,
fillOpacity = 1,
weight = 0.5,
label = ~as.character(datos$CONCELLO),
labelOptions = labelOptions(noHide = F,
textsize = "7px",
direction = "topright"),
highlightOptions = highlightOptions(color = "white",
weight = 1,
bringToFront = TRUE)) %>%
addCircles(data = coordenadasOAC,
lat = ~ coordenadasOAC$LAT,
lng = ~ coordenadasOAC$LONG,radius =0.3,
color="#CD3333",
fillOpacity = 0.8,
popup = ~as.character(coordenadasOAC$OAC)) %>%
addLegend("bottomleft",
pal = pal3,
values = data,
title = nombre,
labFormat = labelFormat(prefix = ""),opacity = 1)})
htmltools::tagList(createMap)
but I have the following error: Error in`[.data.frameĀ“(x#data,i,j,...,drop=False): undefined columns selected.
Could you help me?

Resources