Drill Down Maps In R + Shiny - r

I want to implement drill down heat map of USA.
Something like : Highchart link
But I want to display my own data in the given drill down heat map in
R + shiny.
I am unable to understand how to get my data to work with the given example. I was able to implement the given example on R shiny but I don't know how to get my own data for states and county .
I have data in excel format which I want to show on the maps.
I am relatively new to JS and CSS , I think the challenge is in this only.
I have no knowledge of AJAX , and if it can be implemented without it then it would be great.
Someone suggested me to use JSON file to import my own data , but I cannot do it.

There is now an R package "leafdown" available on github, which provides drilldown functionality. It can be found here: https://hoga-it.github.io/leafdown/index.html.
A basic example:
devtools::install_github("hoga-it/leafdown")
library(leafdown)
library(leaflet)
library(shiny)
library(dplyr)
library(shinyjs)
ger1 <- raster::getData(country = "Germany", level = 1)
ger2 <- raster::getData(country = "Germany", level = 2)
ger2#data[c(76, 99, 136, 226), "NAME_2"] <- c(
"Fürth (Kreisfreie Stadt)",
"München (Kreisfreie Stadt)",
"Osnabrück (Kreisfreie Stadt)",
"Würzburg (Kreisfreie Stadt)"
)
spdfs_list <- list(ger1, ger2)
ui <- shiny::fluidPage(
tags$style(HTML(".leaflet-container {background: #ffffff;}")),
useShinyjs(),
actionButton("drill_down", "Drill Down"),
actionButton("drill_up", "Drill Up"),
leafletOutput("leafdown", height = 600),
)
# Little helper function for hover labels
create_labels <- function(data, map_level) {
labels <- sprintf(
"<strong>%s</strong><br/>%g € per capita</sup>",
data[, paste0("NAME_", map_level)], data$GDP_2014
)
labels %>% lapply(htmltools::HTML)
}
server <- function(input, output) {
my_leafdown <- Leafdown$new(spdfs_list, "leafdown", input)
update_leafdown <- reactiveVal(0)
observeEvent(input$drill_down, {
my_leafdown$drill_down()
update_leafdown(update_leafdown() + 1)
})
observeEvent(input$drill_up, {
my_leafdown$drill_up()
update_leafdown(update_leafdown() + 1)
})
output$leafdown <- renderLeaflet({
update_leafdown()
meta_data <- my_leafdown$curr_data
curr_map_level <- my_leafdown$curr_map_level
if (curr_map_level == 1) {
data <- meta_data %>% left_join(gdp_2014_federal_states, by = c("NAME_1" = "Federal_State"))
} else {
data <- meta_data %>% left_join(gdp_2014_admin_districts, by = c("NAME_2" = "Admin_District"))
}
my_leafdown$add_data(data)
labels <- create_labels(data, curr_map_level)
my_leafdown$draw_leafdown(
fillColor = ~ colorNumeric("Blues", GDP_2014)(GDP_2014),
weight = 2, fillOpacity = 0.8, color = "grey", label = labels,
highlight = highlightOptions(weight = 5, color = "#666", fillOpacity = 0.7)
) %>%
addLegend("topright",
pal = colorNumeric("Blues", data$GDP_2014),
values = data$GDP_2014,
title = "GDP per capita (2014)",
labFormat = labelFormat(suffix = "€"),
opacity = 1
)
})
}
shinyApp(ui, server)

Related

Leaflet map crashes on recoloring after translation (Shiny, Leaflet, shiny.i18n)

I'm currently trying to make a Shiny app for Leaflet cards with simple translations. Each leaflet card has several base groups that are linked to different variables. To avoid re-rendering the leaflet maps every time the base group changes, I have adopted a function I found here which only changes the fill of the polygons.
As long as I only use one language, the app works without problems, but when multiple translations options are implemented, the app crashes. The problem seems to occur when I try to link input$map_groups to variables needed for colouring.
My code looks like this:
library(shiny)
library(shinyWidgets)
library(leaflet)
library(sf)
library(dplyr)
library(shiny.i18n)
#--- Loading Generic Shape File For Demonstration
shape <- st_read(system.file("shape/nc.shp", package = "sf"),
stringsAsFactors = FALSE) %>%
#--- Mutating Two Variables To Factors As My Map Uses Factors
mutate(One = as.factor(SID74), Two = as.factor(SID79)) %>%
#--- Keep Just This Three Variables
select(c(CNTY_ID, One, Two))
#--- Color Palette For Filling Polygons
scale.color <- colorFactor(palette = "RdYlBu", levels = seq(1:60))
#--- Loading And Rgistering Translation File
lang <- Translator$new(translation_json_path = "./translations.json")
lang$set_translation_language("gb")
language <- c("English", "Deutsch", "Français" , "Español")
#--- Naming Vector For Base Groups And Related Variables
layer_calls <- setNames(c('One', 'Two'), c("First", "Second"))
#--- A Function For Recoloring An Existing Polygon And Related JS-Code
#----- Source: https://github.com/rstudio/leaflet/issues/496#issuecomment-650122985
setShapeStyle <- function(map, data = getMapData(map), layerId, stroke = NULL, color = NULL, weight = NULL,
opacity = NULL, fill = NULL, fillColor = NULL, fillOpacity = NULL, dashArray = NULL,
smoothFactor = NULL, noClip = NULL, options = NULL){
options <- c(list(layerId = layerId),
options,
filterNULL(list(stroke = stroke, color = color, weight = weight, opacity = opacity,
fill = fill, fillColor = fillColor, fillOpacity = fillOpacity,
dashArray = dashArray, smoothFactor = smoothFactor, noClip = noClip)))
# Evaluate All Options
options <- evalFormula(options, data = data)
options <- do.call(data.frame, c(options, list(stringsAsFactors = FALSE)))
layerId <- options[[1]]
style <- options[-1] # drop layer column
leaflet::invokeMethod(map, data, "setStyle", "shape", layerId, style);
}
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)){ // in case a single layerid is given
layerId = [layerId];
}
//convert columnstore to row store
style = HTMLWidgets.dataframeToD3(style);
//console.log(style);
layerId.forEach(function(d,i){
var layer = map.layerManager.getLayer(category, d);
if (layer){ // or should this raise an error?
layer.setStyle(style[i]);
}
});
};
'
)))
#--- Defining UI
ui <- fluidPage(
leafletjs,
usei18n(lang),
pickerInput(inputId = 'selected_language', width = 125,
choices = c("gb", "de", "fr", "es"),
selected = lang$get_key_translation()),
leafletOutput("map")
)
#--- Defining Server Logic
server <- function(input, output, session){
output$map <- renderLeaflet({
leaflet(data = shape) %>%
#--- Initial Unfilled Polygon Map
addPolygons(layerId = ~CNTY_ID, stroke = TRUE, color = "white", weight = 1.25,
highlightOptions = highlightOptions(stroke = 5, weight = 10)) %>%
#--- Initial Layer Controls
addLayersControl(baseGroups = lang$t(names(layer_calls)))
})
#--- Filling Polygons Based On Base Layer-Variable After Translation
observe({
req(input$selected_language)
update_lang(session, input$selected_language)
leafletProxy("map", data = shape) %>%
#--- This Part Always Crashes Shiny!!!
setShapeStyle(layerId = ~CNTY_ID, fillOpacity = 1)#, fillColor = ~scale.color(get(layer_calls[lang$t(input$map_groups)])))
})
}
# Run the application
shinyApp(ui = ui, server = server)
My basic translation scheme would be provided by a JSON file which looks like this:
{
"languages": [
"gb",
"de",
"fr",
"es"
],
"translation": [
{
"gb": "First",
"de": "Erste",
"fr": "Premier",
"es": "Primera"
},
{
"gb": "Second",
"de": "Zweite",
"fr": "Deuxième",
"es": "Segundo"
}
]
}
In my One-Langue-App I can simply use , fillColor = ~scale.color(get(layer_calls[[input$map_groups]])) to trigger a recoloring after the base group has been changed. Unfortunately, I have no idea how to connect the selected base group to a call of the needed variable to trigger the recoloring. Any kind of help is greatly appreciated!

How can I make the color scale in mapdeck static

I am developing a shiny app which steps through time by each hour and shows the precipitation on a mapdeck map. I read in the weather data for the entire day and using reactivity filtering the data for the hour and plotting them as scatterplot using mapdeck_update to update the data. The color scale changes whenever the map updates based on the range of data in that hour. What I want is a static color scale based on the data range for the day. Is it possible?
I have tried using manual colors but for some reason they are not working
library(mapdeck)
ui <- fluidPage(
fluidRow(sliderInput(inputId = "hr",label = "Hour",min = 1,max = 3,value = 1)),
fluidRow(mapdeckOutput(outputId = "wx"))
)
sr <- function(input, output, session) {
mydata <- read.table(header=TRUE, sep=",",text="
ROW,COL,Center Latitude,Center Longitude,vil_int_36,hr
28,439,23.669885449218786,-97.2498101160108,20,1
41,433,24.37845221074034,-97.59803936272704,21,1
59,441,25.35333762373948,-97.11966878019186,22,1
61,441,25.461905262766468,-97.11878391116397,23,1
62,443,25.515163854569053,-96.99946877404128,24,1
29,439,23.724265738052193,-97.24945283742396,25,2
43,433,24.48713046908765,-97.59764743717052,26,2
59,442,25.35284441116698,-97.06032252207848,27,2
61,442,25.46141127997772,-97.05937801465758,28,2
62,444,25.514605007836384,-96.94003374232112,29,2
29,440,23.723846594719276,-97.19096992696834,30,3
43,434,24.486897474919978,-97.53876699838483,31,3
60,443,25.406603480942334,-97.00047511628769,32,3
62,441,25.516184831702166,-97.11834002241596,33,3
62,449,25.511327212479294,-96.64286546489153,34,3
")
wx_map <- mapdeck(data=NULL,token = Sys.getenv("MAPBOX_API_TOKEN"),style = 'mapbox://styles/mapbox/dark-v9',zoom = 6, location = c(-97,24.5))
observe({
wx_dt <- mydata %>% dplyr::filter(hr == input$hr)
mapdeck_update(map_id = "wx") %>%
add_scatterplot(data=wx_dt,lon = "Center.Longitude",lat = "Center.Latitude",radius = 15000,fill_colour = "vil_int_36",legend = TRUE,layer_id = "wxlyr",update_view = FALSE,focus_layer=FALSE)
})
output$wx <- renderMapdeck(wx_map)
}
shinyApp(ui, sr)
Notice how the range of color scale in the legend changes but the color of the dots stay almost the same. I want the color to represent the min-max of the entire data set (not just the hour) so that I can see change in intensity while stepping through each hour. Thank you.
Good question; you're right you need to create a manual legend so it remains static, otherwise it will update each time the values in the plot update.
The manual legend needs to use the same colours as the map. The map gets coloured by library(colourvalues). So you can use this to make the colours outside of the map, then use the results as the manual legend
l <- colourvalues::colour_values(
x = mydata$vil_int_36
, n_summaries = 5
)
legend <- mapdeck::legend_element(
variables = l$summary_values
, colours = l$summary_colours
, colour_type = "fill"
, variable_type = "category"
)
js_legend <- mapdeck::mapdeck_legend(legend)
Now this js_legend object is in the correct JSON format for the map to render it as a legend
js_legend
# {"fill_colour":{"colour":["#440154FF","#3B528BFF","#21908CFF","#5DC963FF","#FDE725FF"],"variable":["20.00","23.50","27.00","30.50","34.00"],"colourType":["fill_colour"],"type":["category"],"title":[""],"css":[""]}}
Here it is in your shiny
library(mapdeck)
library(shiny)
ui <- fluidPage(
fluidRow(sliderInput(inputId = "hr",label = "Hour",min = 1,max = 3,value = 1)),
fluidRow(mapdeckOutput(outputId = "wx"))
)
sr <- function(input, output, session) {
mydata <- read.table(header=TRUE, sep=",",text="
ROW,COL,Center Latitude,Center Longitude,vil_int_36,hr
28,439,23.669885449218786,-97.2498101160108,20,1
41,433,24.37845221074034,-97.59803936272704,21,1
59,441,25.35333762373948,-97.11966878019186,22,1
61,441,25.461905262766468,-97.11878391116397,23,1
62,443,25.515163854569053,-96.99946877404128,24,1
29,439,23.724265738052193,-97.24945283742396,25,2
43,433,24.48713046908765,-97.59764743717052,26,2
59,442,25.35284441116698,-97.06032252207848,27,2
61,442,25.46141127997772,-97.05937801465758,28,2
62,444,25.514605007836384,-96.94003374232112,29,2
29,440,23.723846594719276,-97.19096992696834,30,3
43,434,24.486897474919978,-97.53876699838483,31,3
60,443,25.406603480942334,-97.00047511628769,32,3
62,441,25.516184831702166,-97.11834002241596,33,3
62,449,25.511327212479294,-96.64286546489153,34,3
")
## create a manual legend
l <- colourvalues::colour_values(
x = mydata$vil_int_36
, n_summaries = 5
)
legend <- mapdeck::legend_element(
variables = l$summary_values
, colours = l$summary_colours
, colour_type = "fill"
, variable_type = "category"
)
js_legend <- mapdeck::mapdeck_legend(legend)
### --------------------------------
wx_map <- mapdeck(
style = 'mapbox://styles/mapbox/dark-v9'
, zoom = 6
, location = c(-97,24.5)
)
observe({
wx_dt <- mydata %>% dplyr::filter(hr == input$hr)
mapdeck_update(map_id = "wx") %>%
add_scatterplot(
data = wx_dt
, lon = "Center.Longitude"
, lat = "Center.Latitude"
, radius = 15000
, fill_colour = "vil_int_36"
, legend = js_legend
, layer_id = "wxlyr"
, update_view = FALSE
, focus_layer = FALSE
)
})
output$wx <- renderMapdeck(wx_map)
}
shinyApp(ui, sr)

Shiny R dynamic heatmap with ggplot. Scale and speed issues

I am attempting to use some public information to produce a heat-map of Canada for some labor statistics. Using the spacial files from the census, and data from Statistics Canada (these are large zip files that are not necessary to dig into). Below is a working example that illustrates both the problems I am having with little relative change between regions( though there may be a big absolute change between periods, and the slow draw time.To get this to work, you need to download the .zip file from the census link and unzip the files to a data folder.
library(shiny)
library(maptools)
library(ggplot2)
require(reshape2)
library(tidyr)
library(maptools)
library(ggplot2)
library(RColorBrewer)
ui <- fluidPage(
titlePanel("heatmap"),
# Sidebar with a slider input for year of interest
sidebarLayout(
sidebarPanel(
sliderInput("year",h3("Select year or push play button"),
min = 2000, max = 2002, step = 1, value = 2000,
animate = TRUE)
),
# Output of the map
mainPanel(
plotOutput("unemployment")
)
)
)
server <- function(input, output) {
#to get the spacial data: from file in link above
provinces<-maptools::readShapeSpatial("data/gpr_000a11a_e.shp")
data.p<- ggplot2::fortify(provinces, region = "PRUID")
data.p<-data.p[which(data.p$id<60),]
#dataframe with same structure as statscan csv after processing
unem <- runif(10,min=0,max=100)
unem1 <- unem+runif(1,-10,10)
unem2 <- unem1+runif(1,-10,10)
unemployment <- c(unem,unem1,unem2)
#dataframe with same structure as statscan csv after processing
X <- data.frame("id" = c(10,11,12,13,24,35,46,47,48,59,
10,11,12,13,24,35,46,47,48,59,
10,11,12,13,24,35,46,47,48,59),
"Unemployment" = unemployment,
"year" = c(rep(2000,10),rep(2001,10),rep(2002,10))
)
plot.data<- reactive({
a<- X[which(X$year == input$year),]
return(merge(data.p,a,by = "id"))
})
output$unemployment <- renderPlot({
ggplot(plot.data(),
aes(x = long, y = lat,
group = group , fill =Unemployment)) +
geom_polygon() +
coord_equal()
})
}
# Run the application
shinyApp(ui = ui, server = server)
Any help with either of the issues would be greatly appreciated
For this type of animation it is much faster to use leaflet instead of ggplot as leaflet allows you to only re-render the polygons, not the entire map.
I use two other tricks to speed up the animation:
I join the data outside of the reactive. Within the reactive it is just a simple subset. Note, the join could be done outside of the app and read in as a pre-processed .rds file.
I simplify the polygons with the rmapshaper package to reduce drawing time by leaflet. Again, this could be done outside the app to reduce loading time at the start.
The animation could likely be even more seamless if you use circles (i.e. centroid of each province) instead of polygons. Circle size could vary with Unemployment value.
Note, you need the leaflet, sf, dplyr and rmapshaper packages for this approach.
library(shiny)
library(dplyr)
library(leaflet)
library(sf)
library(rmapshaper)
ui <- fluidPage(
titlePanel("heatmap"),
# Sidebar with a slider input for year of interest
sidebarLayout(
sidebarPanel(
sliderInput("year",h3("Select year or push play button"),
min = 2000, max = 2002, step = 1, value = 2000,
animate = TRUE)
),
# Output of the map
mainPanel(
leafletOutput("unemployment")
)
)
)
server <- function(input, output) {
#to get the spacial data: from file in link above
data.p <- sf::st_read("input/gpr_000a11a_e.shp") %>%
st_transform(4326) %>%
rmapshaper::ms_simplify()
data.p$PRUID <- as.character(data.p$PRUID) %>% as.numeric
data.p <- data.p[which(data.p$PRUID < 60),]
lng.center <- -99
lat.center <- 60
zoom.def <- 3
#dataframe with same structure as statscan csv after processing
unem <- runif(10,min=0,max=100)
unem1 <- unem+runif(1,-10,10)
unem2 <- unem1+runif(1,-10,10)
unemployment <- c(unem,unem1,unem2)
#dataframe with same structure as statscan csv after processing
X <- data.frame("id" = c(10,11,12,13,24,35,46,47,48,59,
10,11,12,13,24,35,46,47,48,59,
10,11,12,13,24,35,46,47,48,59),
"Unemployment" = unemployment,
"year" = c(rep(2000,10),rep(2001,10),rep(2002,10))
)
data <- left_join(data.p, X, by = c("PRUID"= "id"))
output$unemployment <- renderLeaflet({
leaflet(data = data.p) %>%
addProviderTiles("OpenStreetMap.Mapnik", options = providerTileOptions(opacity = 1), group = "Open Street Map") %>%
setView(lng = lng.center, lat = lat.center, zoom = zoom.def) %>%
addPolygons(group = 'base',
fillColor = 'transparent',
color = 'black',
weight = 1.5) %>%
addLegend(pal = pal(), values = X$Unemployment, opacity = 0.7, title = NULL,
position = "topright")
})
get_data <- reactive({
data[which(data$year == input$year),]
})
pal <- reactive({
colorNumeric("viridis", domain = X$Unemployment)
})
observe({
data <- get_data()
leafletProxy('unemployment', data = data) %>%
clearGroup('polygons') %>%
addPolygons(group = 'polygons',
fillColor = ~pal()(Unemployment),
fillOpacity = 0.9,
color = 'black',
weight = 1.5)
})
}
# Run the application
shinyApp(ui = ui, server = server)
I didn't find the drawing time to be unreasonably long at ~2-3 seconds, which for a 2.4mb shapefile seems about right. It takes just as long outside shiny as it does in the app on my machine, anyway.
To hold a constant colour gradient you can specify limits in scale_fill_gradient which will hold the same gradient despite changes to your maps:
output$unemployment <- renderPlot({
ggplot(plot.data(),
aes(x = long, y = lat,
group = group , fill =Unemployment)) +
geom_polygon() +
scale_fill_gradient(limits=c(0,100)) +
coord_equal()
})

R shiny chorpleth map

I am new in R. now I am creating shiny app. R can read my dataset. with the comand myData <- read.csv("myData.csv"). however shinyServer file cannot read my data. and list no observation.
Could you guys help me what is the problem?
The Shinyapp provides interactive visulization for production of raw material in the world since 1900 to 2010 for every 10 years.
Also I keep getting this error:
"ERROR: 'breaks' are not unique"
The Code is here:
shinyUI(fluidPage(
checkboxInput("type", "Please Select production type:",
c("Aluminium", "Gold",
"Iron", "Silver", "Zinc")
),
sliderInput("year","Choose a Year",
min = 1910,
max = 2010,
value= 2010),
checkboxInput("Economy", "Please Select Economy Factor:",
c("Income Inequallity", "labourers Real Wage", "GDP", "Inflation")),
plotOutput("thisPlot"),
leafletOutput("myMap")
)
)
shinyServer:
myData <- read.csv("myData.csv")
shinyServer<- function(input,output){
output$myMap <- renderLeaflet({
temp <- which(myData$type == input$type &
myData$year == input$year)
myData <- myData[temp,]
pal <- colorQuantile("YlGn", myData$production, n = 9)
country_popup <- paste0("<strong>Estado: </strong>", myData$Country)
leaflet(data = myData) %>%
setView(46.227638, 2.213749, zoom = 2) %>%
addTiles() %>%
addPolygons( lng = ~myData$Long, lat = ~myData$Lat,
fillColor = ~pal(myData$production),
fillOpacity = 0.8,
color = "#BDBDC3",
weight = 1,
popup = country_popup)
})
}
the data is:
Names = c("id",
"Country", "type", "year", "production", "GDP", "Income", "Inflation",
"Laborer", "Lat", "Long"), class = "data.frame", row.names = c(NA,
-10670L))
head(myData)
id Country type year production GDP Income Inflation Laborer Lat
Long
1 1 Guyana Gold 1910 0.000000 0 42.43048 0 154.45527 4.860416
-58.9301
it seems that it does read the data but it does not show it. and i have a problem with creating the choropleth map. which it does not work now in my shiny.
Yeah, leaflet is finicky. I didn't have to make a lot of changes, you almost had it. One of the main problems was that your filter was usually yielding an empty dataframe which caused the markers not to show (of course).
This empty dataframe problem is also the cause for the "ERROR: 'breaks' are not unique" message since colorQuantile is getting a null input for its domain argument, which means it is doing an empty quantile, and all the breaks are zero and thus "not unique". This can also happen with highly skewed data. You should avoid calling it in that case - maybe fallback on colorBin, although detecting that can be a bit complicated.
The following changes were made.
Added some fake data.
Changed addPolygons to addCircleMarkers as addPolygons is for adding arbitray shapes that you specify.
Changed your checkBoxInput to checkBoxGroupInput as you didn't want a checkbox, you wanted a group of them.
Changed the filter clause to use myData$type %in% input$type instead of myData$type == input$type as you probably wanted membership.
truncated the input$year value as it might not give back an integer, but your year values are definitely integers.
Changed the border color to "black" so you could see it on the circle.
Note that the popup does not come on hover, you have to click on the circle.
removed the myData on the marker input as you have specified it on the leaflet call.
commented out the plotOutput as I don't know what you want to plot.
Here is the code - this should get you started:
library(shiny)
library(leaflet)
# fake-up some data
n <- 10000
countrylist <- c("Guyana","Venezuela","Columbia")
typelist <- c("Aluminium", "Gold","Iron", "Silver", "Zinc")
types <- sample(typelist,n,replace=T)
cntrs <- sample(countrylist,n,replace=T)
lat <- 2.2 + 50*runif(n)
long <- -46 + 50*runif(n)
year <- sample(1910:2010,n,replace=T)
prd <- 100*runif(n)
myData <- data.frame(Country=cntrs,type=types,year=year,production=prd,Long=long,Lat=lat)
u <- shinyUI(fluidPage(
checkboxGroupInput("type", "Please Select production type:",
c("Aluminium", "Gold","Iron", "Silver", "Zinc"),
selected=c("Gold","Silver")
),
sliderInput("year","Choose a Year",
min = 1910,
max = 2010,
value= 2010),
checkboxGroupInput("Economy", "Please Select Economy Factor:",
c("Income Inequallity", "labourers Real Wage", "GDP", "Inflation")),
# plotOutput("thisPlot"),
leafletOutput("myMap")
)
)
s <- function(input,output){
output$myMap <- renderLeaflet({
temp <- which(myData$type %in% input$type &
myData$year == trunc(input$year))
print(nrow(myData))
myData <- myData[temp,]
print(nrow(myData))
pal <- colorQuantile("YlGn", myData$production, n = 9)
country_popup <- paste0("<strong>Estado: </strong>", myData$Country)
leaflet(data = myData) %>%
setView(-46.227638, 2.213749, zoom = 2) %>%
addTiles() %>%
addCircleMarkers( lng = ~Long, lat = ~Lat,
fillColor = ~pal(myData$production),
radius = 6, # pixels
fillOpacity = 0.8,
color = "black",
weight = 1,
popup = country_popup)
})
}
shinyApp(u,s)
And this is the result:

Leaflet drill down with RStudio package and Shiny

Is it possible with leaflet.js to create drill-down functionality, i.e. similar to http://jvectormap.com/examples/drill-down/? I imagine there is some plugin that would make this possible. If so, could you point me to an example or provide basic code?
I've done some searching on Google and the leaflet documentation, e.g. http://leafletjs.com/reference.html and http://leafletjs.com/plugins.html, but cannot find anything.
Edit: I found this useful post: https://github.com/rstudio/leaflet/issues/41. I'm using the leaflet package in R provided by RStudio. I've got a drill-down choropleth from country to state with an info control. It still needs a ton of work, though. Anyone who cares to help, see https://github.com/efh0888/leafletDrilldown. The README has all the info you'll need. You can also see a live app at https://efh0888.shinyapps.io/leafletDrilldown. Thanks!
See the Choropleth example for how to do the click⇢fit bounds technique with Leaflet.
There is now an R package "leafdown" available on github, which provides drilldown functionality. It can be found here: https://hoga-it.github.io/leafdown/index.html.
A basic example:
devtools::install_github("hoga-it/leafdown")
library(leafdown)
library(leaflet)
library(shiny)
library(dplyr)
library(shinyjs)
ger1 <- raster::getData(country = "Germany", level = 1)
ger2 <- raster::getData(country = "Germany", level = 2)
ger2#data[c(76, 99, 136, 226), "NAME_2"] <- c(
"Fürth (Kreisfreie Stadt)",
"München (Kreisfreie Stadt)",
"Osnabrück (Kreisfreie Stadt)",
"Würzburg (Kreisfreie Stadt)"
)
spdfs_list <- list(ger1, ger2)
ui <- shiny::fluidPage(
tags$style(HTML(".leaflet-container {background: #ffffff;}")),
useShinyjs(),
actionButton("drill_down", "Drill Down"),
actionButton("drill_up", "Drill Up"),
leafletOutput("leafdown", height = 600),
)
# Little helper function for hover labels
create_labels <- function(data, map_level) {
labels <- sprintf(
"<strong>%s</strong><br/>%g € per capita</sup>",
data[, paste0("NAME_", map_level)], data$GDP_2014
)
labels %>% lapply(htmltools::HTML)
}
server <- function(input, output) {
my_leafdown <- Leafdown$new(spdfs_list, "leafdown", input)
update_leafdown <- reactiveVal(0)
observeEvent(input$drill_down, {
my_leafdown$drill_down()
update_leafdown(update_leafdown() + 1)
})
observeEvent(input$drill_up, {
my_leafdown$drill_up()
update_leafdown(update_leafdown() + 1)
})
output$leafdown <- renderLeaflet({
update_leafdown()
meta_data <- my_leafdown$curr_data
curr_map_level <- my_leafdown$curr_map_level
if (curr_map_level == 1) {
data <- meta_data %>% left_join(gdp_2014_federal_states, by = c("NAME_1" = "Federal_State"))
} else {
data <- meta_data %>% left_join(gdp_2014_admin_districts, by = c("NAME_2" = "Admin_District"))
}
my_leafdown$add_data(data)
labels <- create_labels(data, curr_map_level)
my_leafdown$draw_leafdown(
fillColor = ~ colorNumeric("Blues", GDP_2014)(GDP_2014),
weight = 2, fillOpacity = 0.8, color = "grey", label = labels,
highlight = highlightOptions(weight = 5, color = "#666", fillOpacity = 0.7)
) %>%
addLegend("topright",
pal = colorNumeric("Blues", data$GDP_2014),
values = data$GDP_2014,
title = "GDP per capita (2014)",
labFormat = labelFormat(suffix = "€"),
opacity = 1
)
})
}
shinyApp(ui, server)

Resources