I have some large shapefiles that I want to run some intersect analysis on using user input on a leaflet map. My shiny page displays a map that a user can draw a polygon on and I want to see if that polygon intersects either of the two shapefiles. I built a working version of this where the server reads in the shapefiles each time a user connects to the server, but obviously that isn't a great user experience. So I have been trying to move the shapefile reading to global variables that the server loads once, and the user just has to run the intersect on. I'll skip posting my 3 lines of UI for now but this app works locally, it's only when I run it on a dedicated Shiny server that is crashes after the user "closes" the polygon. I have a feeling it's an issue with the global variable declarations, but there is no log file generated so I'm having a really hard time debugging it.
App.R
library(shiny)
source("/ui.R")
source("/server.R")
shpfile1 <- st_read("path_to_shpfile1")
shpfile2 <- st_read("path_to_shpfile2")
ui <- ui()
server <- server()
shinyApp(ui = ui, server = server)
Server.R
# a number of libraries
server <- function(input, output, session) {
output$s1 <- renderText({"Define project area..."})
output$s2 <- renderText({"Define project area..."})
print("Reading New Jersey boundary...")
mapStates = map("state", "New Jersey", fill = FALSE, plot = FALSE)
output$map <- renderLeaflet({
leaflet(data = mapStates) %>% addTiles() %>% addPolygons(fillColor = topo.colors(10, alpha=0.8), stroke=FALSE) %>%
addDrawToolbar(targetGroup = "projectArea",
rectangleOptions = F,
polylineOptions = F,
markerOptions = F,
circleMarkerOptions = F,
editOptions = editToolbarOptions(edit = FALSE, remove = TRUE, selectedPathOptions = selectedPathOptions()),
circleOptions = F)
})
observeEvent(input$drawPoints, {
proxy %>% clearShapes()
for (i in seq_along(data)) {
proxy %>% addPolygons(
data[[i]][,"lon"],
data[[i]][,"lat"],
layerId=i,
opacity=0.4,
color = c('red','green')[i]
)
Sys.sleep(2) # - this is to see first (red) polygon
}
})
observeEvent(input$map_draw_new_feature, {
withProgress(message = "Please wait...", value = 0, {
# capture project area and convert to usable format for intersecting
feat <- input$map_draw_new_feature
coords <- unlist(feat$geometry$coordinates)
coords <- matrix(coords, ncol=2, byrow=TRUE)
poly <- st_sf(st_sfc(st_polygon(list(coords))), crs = "+proj=longlat +datum=WGS84")
# intersect project area with constraint layers
incProgress(1/3, detail = "Analyzing shapefile1...")
i_shp1 <- st_intersects(poly, shpfile1)
c_shp1 <- sapply(i_shp1, length)
incProgress(2/3, detail = "Analyzing shapefile2...")
i_shp2 <- st_intersects(poly, shpfile2)
c_shp2 <- sapply(i_shp2, length)
if(c_streams > 0) {
output$s1 <- renderText({"does intersect shapefile 1"})
} else {
output$s1 <- renderText({"does not intersect shapefile 1"})
}
if(c_wetlands > 0) {
output$s2 <- renderText({"does intersect shapefile 2"})
} else {
output$s2 <- renderText({"does not intersect shapefile 2"})
}
})
})
}
Related
I created an application in R-shiny, using the leaflet.extra package, I put a map in which my users can draw polygons, my goal is to be able to download the polygons that my users drew as a GeoJson or Shapefil (.shp) .
My application looks like this:
ui <- fluidPage(
textOutput("text"),leafletOutput("mymap") )
and server:
poly<-reactiveValues(poligonos=list()) #save reactiveValues
output$mymap <- renderLeaflet({
leaflet("mymap") %>%
addProviderTiles(providers$Stamen.TonerLite, #map type or map theme. -default($Stame.TonerLite)
options = providerTileOptions(noWrap = TRUE)
)%>% addDrawToolbar(
targetGroup='draw',
editOptions = editToolbarOptions(selectedPathOptions = selectedPathOptions())) %>%
addLayersControl(overlayGroups = c('draw'), options =
layersControlOptions(collapsed=FALSE)) %>%
addStyleEditor()
})
polygons<- eventReactive(input$mymap_draw_all_features, {
features<-input$mymap_draw_all_features
poly$poligonos<-c(poly$poligonos,features)
return(poly$poligonos)
})
The eventReactive function called "polygons" is responsible for recording the polygons (coordinates) that are drawn, but i din't know how to save them or convert into a GeoJson or shapefile format.
What you can do is take the coordinates of the polygons you made with the DrawToolbar and use them to create polygons in a reactiveValues SpatialPolygonsDataFrame. You can export that SPDF as a shapefile (with the example below you have to publish to the server to make the download option work. It will not work from R Studio).
ui <- fluidPage(
textOutput("text"),leafletOutput("mymap"),
downloadButton('downloadData', 'Download Shp'))
--
server<- function(input, output, session) {
output$mymap <- renderLeaflet({
leaflet("mymap") %>%
addProviderTiles(providers$Stamen.TonerLite, #map type or map theme. -default($Stame.TonerLite)
options = providerTileOptions(noWrap = TRUE)) %>%
addDrawToolbar(targetGroup = "drawnPoly",
rectangleOptions = F,
polylineOptions = F,
markerOptions = F,
editOptions = editToolbarOptions(selectedPathOptions = selectedPathOptions()),
circleOptions=F,
polygonOptions=drawPolygonOptions(showArea=TRUE, repeatMode=F , shapeOptions=drawShapeOptions( fillColor="red",clickable = TRUE))) %>%
addStyleEditor()
})
latlongs<-reactiveValues() #temporary to hold coords
latlongs$df2 <- data.frame(Longitude = numeric(0), Latitude = numeric(0))
#########
#empty reactive spdf
value<-reactiveValues()
SpatialPolygonsDataFrame(SpatialPolygons(list()), data=data.frame (notes=character(0), stringsAsFactors = F))->value$drawnPoly
#fix the polygon to start another
observeEvent(input$mymap_draw_new_feature, {
coor<-unlist(input$mymap_draw_new_feature$geometry$coordinates)
Longitude<-coor[seq(1,length(coor), 2)]
Latitude<-coor[seq(2,length(coor), 2)]
isolate(latlongs$df2<-rbind(latlongs$df2, cbind(Longitude, Latitude)))
poly<-Polygon(cbind(latlongs$df2$Longitude, latlongs$df2$Latitude))
polys<-Polygons(list(poly), ID=input$mymap_draw_new_feature$properties$`_leaflet_id`)
spPolys<-SpatialPolygons(list(polys))
#
value$drawnPoly<-rbind(value$drawnPoly,SpatialPolygonsDataFrame(spPolys,
data=data.frame(notes=NA, row.names=
row.names(spPolys))))
###plot upon ending draw
observeEvent(input$mymap_draw_stop, {
#replot it - take off the DrawToolbar to clear the features and add it back and use the values from the SPDF to plot the polygons
leafletProxy('mymap') %>% removeDrawToolbar(clearFeatures=TRUE) %>% removeShape('temp') %>% clearGroup('drawnPoly') %>% addPolygons(data=value$drawnPoly, popup="poly", group='drawnPoly', color="blue", layerId=row.names(value$drawnPoly)) %>%
addDrawToolbar(targetGroup = "drawnPoly",
rectangleOptions = F,
polylineOptions = F,
markerOptions = F,
editOptions = editToolbarOptions(selectedPathOptions = selectedPathOptions()),
circleOptions=F,
polygonOptions=drawPolygonOptions(showArea=TRUE, repeatMode=F , shapeOptions=drawShapeOptions( fillColor="red",clickable = TRUE)))
})
latlongs$df2 <- data.frame(Longitude = numeric(0), Latitude = numeric(0)) #clear df
})
########################
### edit polygons / delete polygons
observeEvent(input$mymap_draw_edited_features, {
f <- input$mymap_draw_edited_features
coordy<-lapply(f$features, function(x){unlist(x$geometry$coordinates)})
Longitudes<-lapply(coordy, function(coor) {coor[seq(1,length(coor), 2)] })
Latitudes<-lapply(coordy, function(coor) { coor[seq(2,length(coor), 2)] })
polys<-list()
for (i in 1:length(Longitudes)){polys[[i]]<- Polygons(
list(Polygon(cbind(Longitudes[[i]], Latitudes[[i]]))), ID=f$features[[i]]$properties$layerId
)}
spPolys<-SpatialPolygons(polys)
SPDF<-SpatialPolygonsDataFrame(spPolys,
data=data.frame(notes=value$drawnPoly$notes[row.names(value$drawnPoly) %in% row.names(spPolys)], row.names=row.names(spPolys)))
value$drawnPoly<-value$drawnPoly[!row.names(value$drawnPoly) %in% row.names(SPDF),]
value$drawnPoly<-rbind(value$drawnPoly, SPDF)
})
observeEvent(input$mymap_draw_deleted_features, {
f <- input$mymap_draw_deleted_features
ids<-lapply(f$features, function(x){unlist(x$properties$layerId)})
value$drawnPoly<-value$drawnPoly[!row.names(value$drawnPoly) %in% ids ,]
})
#write the polys to .shp
output$downloadData<-downloadHandler(
filename = 'shpExport.zip',
content = function(file) {
if (length(Sys.glob("shpExport.*"))>0){
file.remove(Sys.glob("shpExport.*"))
}
proj4string(value$drawnPoly)<-"+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0"
writeOGR(value$drawnPoly, dsn="shpExport.shp", layer="shpExport", driver="ESRI Shapefile")
zip(zipfile='shpExport.zip', files=Sys.glob("shpExport.*"))
file.copy("shpExport.zip", file)
if (length(Sys.glob("shpExport.*"))>0){
file.remove(Sys.glob("shpExport.*"))
}
}
)
}
--
shinyApp(ui=ui,server=server)
I am working on a shinydashboard (using leaflet) that takes National Weather Service (NWS) Doppler radar data (through WMS), NWS hazard shapefile data, and NWS warning shapefile data.
I have with it, a reactive poll that refreshes the radar, hazard, and warning data every 60 seconds. I store all data in a temporary directory, and clear the temp directory after every refresh cycle before ingesting the most recent data. I append the system time to each file to prevent data caching.
The issue I am having is that whenever I zoom into a location, the reactive poll refresh resets the zoom level and zoom location as well. How can I maintain the zoom level/zoom location during a data refresh?
Attached below is my Server.R script
library(shiny)
library(ggplot2)
library(leaflet)
library(maptools)
library(RColorBrewer)
library(readr)
library(rgeos)
library(RMySQL)
library(rangeMapper)
library(rgdal)
library(utils)
tmpdir <- tempdir()
subDir <- paste(tmpdir,'shapefile',sep = '/')
if (dir.exists(subDir) == FALSE){
dir.create(subDir, showWarnings = FALSE)
}
wgs84 <-"+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs "
#Location of NWS hazard/warning polygons I want to download
baseurl <- 'http://www.srh.noaa.gov/ridge2/shapefiles/'
#Shiny Server start: the server represents the computational side of a shiny app.
server <- function(input, output, session) {
# reactive poll will refresh all data every 60 seconds.
pollData <- reactivePoll(60000, session,
checkFunc = function() {
#I clear out the temp directory with every reactive data refresh.
i <- 0
del <- list.files(subDir)
delcount <- length(del)
if(delcount > 0){
for (i in 1:delcount){
delfile <- del[i]
delfile <- paste(subDir,delfile,sep = '/')
if (file.exists(delfile)){
file.remove(delfile)
}
}
}
#The two NWS compressed shapefiles I want to download.
tar.files <- c('CurrentWarnings.tar.gz', 'CurrentHazards.tar.gz')
tar.count <- length(tar.files)
i <- 0
for (i in 1:tar.count){
#Downloads and untars the NWS shapefiles.
tar.file <- tar.files[i]
url <- paste(baseurl,tar.file,sep = '/')
tempfile <- paste(subDir,tar.file, sep = '/')
download.file(url, tempfile)
untar(tarfile = tempfile, exdir = subDir)
}
file.string <- 'current'
all.files <- list.files(path=subDir, pattern = paste(file.string,'_*',sep = ''))
all.files.no <- length(all.files)
system.time <- Sys.time()
i <- 0
for (i in 1:all.files.no){
#What I do here is append the system time to each NWS shapefile, for both the hazard shapefile and the warning shapefile.
file.name.ch <- all.files[i]
file.replace <- paste(file.string,system.time,sep = '_')
file.name.new <- gsub(file.string,file.replace,file.name.ch)
file.name.ch <- paste(subDir,file.name.ch,sep = '/')
file.name.new <- paste(subDir,file.name.new,sep = '/')
file.rename(file.name.ch,file.name.new)
}
layer.warning <- paste('current', system.time,'warnings',sep = '_')
layer.hazard <- paste('current', system.time,'hazards',sep = '_')
#I query the information behind the hazard and warning shapefiles, to extract a row count.
warning.rowc <- ogrInfo(dsn=subDir,layer= layer.warning)[[1]]
hazard.rowc <- ogrInfo(dsn=subDir,layer= layer.hazard)[[1]]
#If the shapefile is empty (no active warning polygons), then this is skipped. ReadOGR generates an error with an empty shapefile.
if (warning.rowc > 0){
warning.shape <- readOGR(dsn=subDir,layer=layer.warning)
warning.popup <- paste0("<strong>Warning Type: </strong>",
warning.shape$PROD_TYPE,
"<br><strong>Warning Issue Time: </strong>",
warning.shape$ISSUANCE,
"<br><strong>Warning Expiration: </strong>",
warning.shape$EXPIRATION)
}
#If the shapefile is empty (no active hazard polygons), then this is skipped. ReadOGR generates an error with an empty shapefile.
if (hazard.rowc > 0){
hazard.shape <- readOGR(dsn=subDir,layer= layer.hazard)
hazard.popup <- paste0("<strong>Hazard Type: </strong>",
hazard.shape$PROD_TYPE,
"<br><strong>Hazard Issue Time: </strong>",
hazard.shape$ISSUANCE,
"<br><strong>Hazard Expiration: </strong>",
hazard.shape$EXPIRATION)
}
#WMS tiling source is from Iowa State's agronomy department, and is rendering a nexrad radar image.
#If both the hazard and the warning shapefiles are non-empty, run this option.
output$map <- renderLeaflet({
if(warning.rowc > 0 & hazard.rowc > 0){
leaflet() %>% addTiles() %>% #setView(-75.75, 43.7, zoom = 8) %>%
addPolygons(data = hazard.shape, color = 'orange',opacity = 0.30, fillOpacity = 0.30, popup = hazard.popup) %>%
addPolygons(data = warning.shape, color = 'red',opacity = 1.0, fillOpacity = 0.30, popup = warning.popup) %>%
addWMSTiles(
paste("http://mesonet.agron.iastate.edu/cgi-bin/wms/nexrad/n0r.cgi",system.time,sep = ''),
layers = "nexrad-n0r-900913",
options = tileOptions(format = "image/png", transparent = TRUE,reuseTiles = FALSE),
attribution = "Weather data © 2017 IEM Nexrad",)
#If the hazard shapefile is non-empty and the wanring shapefile is empty, run this option.
}else if(warning.rowc < 1 & hazard.rowc > 0){
leaflet() %>% addTiles() %>% #setView(-75.75, 43.7, zoom = 8) %>%
addPolygons(data = hazard.shape, color = 'orange',opacity = 0.30, fillOpacity = 0.30, popup = hazard.popup) %>%
addWMSTiles(
paste("http://mesonet.agron.iastate.edu/cgi-bin/wms/nexrad/n0r.cgi",system.time,sep = ''),
layers = "nexrad-n0r-900913",
options = tileOptions(format = "image/png", transparent = TRUE,reuseTiles = FALSE),
attribution = "Weather data © 2017 IEM Nexrad",)
#If the hazard shapefile is empty and the warning shapefile is non-empty, run this option.
}else if(warning.rowc > 0 & hazard.rowc < 1){
leaflet() %>% addTiles() %>% #setView(-75.75, 43.7, zoom = 8) %>%
addPolygons(data = warning.shape, color = 'red',opacity = 1.0, fillOpacity = 0.30, popup = warning.popup) %>%
addWMSTiles(
paste("http://mesonet.agron.iastate.edu/cgi-bin/wms/nexrad/n0r.cgi",system.time,sep = ''),
layers = "nexrad-n0r-900913",
options = tileOptions(format = "image/png", transparent = TRUE,reuseTiles = FALSE),
attribution = "Weather data © 2017 IEM Nexrad",)
#If both the hazard and the warning shapefile are empty, run this option.
}else{
leaflet() %>% addTiles() %>% #setView(-75.75, 43.7, zoom = 8) %>%
addWMSTiles(
paste("http://mesonet.agron.iastate.edu/cgi-bin/wms/nexrad/n0r.cgi",system.time,sep = ''),
layers = "nexrad-n0r-900913",
options = tileOptions(format = "image/png", transparent = TRUE,reuseTiles = FALSE),
attribution = "Weather data © 2017 IEM Nexrad")
}
})
})
}
And my ui.R script:
library(shiny)
library(leaflet)
library(RColorBrewer)
ui <- bootstrapPage(
tags$style(type = "text/css", "html, body {width:100%;height:100%}"),
leafletOutput("map", width = "100%", height = "100%"),
absolutePanel(top = 10, right = 10
)
)
I am currently struggling to map multiple polygons in a shiny app. The purpose of the shiny app is to take some data pertaining to disease spread in a number of states and map the areas of highest risk. The app must be able to map multiple states at the click of the "Start!" button.
(Note: This app is very large (6000+ lines in total) so only relevant code will be shown here, I don't want to burden the ones trying to help me)
Excerpts from:
Server.R
#The purpose of col_inputs and col_names is to create a two-dimensional array with all of the input parameters for the function. This was done to maintain compatibility with some legacy code. Catted_states on the other hand combines all states selected into a list.
(Example: c("AZ","FL","VA")
output$gm <- renderLeaflet({
global_map(ARG_1, ARG_2, ARG_3)
})
Global_Map.R
The only real concerns with this code is that 'M' isn't being drawn at all after the for loop finishes.
global_map <- function(col_names, col_inputs, catted_states) {
User_para <- array(0, dim = c(16, 2))
for( I in 1:length(states) {
if (state_num > 10) {
read.csv(Loop specific file)
}
if (state_num < 10) {
read.csv(Loop specific file)
}
state_num * Loop specific calculation[I]
pal <- colorNumeric(palette = "Purples", domain = state_output$risk)
pal_sR <- pal(state_output$risk)
m <- addProviderTiles(m, "CartoDB.Positron")
m <- addLegend(m, title = "Risk", pal = pal, values = ~state_output$risk,
opacity = 0.7)
m <- addPolygons(m, stroke = FALSE, smoothFactor = 0, fillOpacity = 0.5,
color = ~pal_sR)
}
}
How can I get this code to map the multiple states? What is incorrect about my leaflet calls? I need this code to load multiple shape files into shiny and draw polygons once on each shape file and map them accordingly
I am not really sure if that solves your problem, but your example is absolutely not reproducible and also has several errors. If you want to produce several polygons inside a for loop and then add them to a leaflet map, here is the code:
library(shiny)
library(leaflet)
ui <- fluidPage(
sliderInput("nPolys", "How many Loops", min = 1, max = 20, value = 3),
## Map
leafletOutput("gm")
)
server <- function(input, output) {
## Initialize map
m = leaflet() %>% addTiles()
## Render Map
output$gm <- renderLeaflet({
## Loop
for (I in 1:input$nPolys) {
## Create dummy polygons
Sr1 = Polygon(cbind(c(2,4,4,1,2)*runif(1,1,10),c(2,3,5,4,2)*runif(1,1,10)))
Sr2 = Polygon(cbind(c(5,4,2,5)*runif(1,1,10),c(2,3,2,2)*runif(1,1,10)))
Srs1 = Polygons(list(Sr1), "s1"); Srs2 = Polygons(list(Sr2), "s2")
SpP = SpatialPolygons(list(Srs1,Srs2), 1:2)
## add Polygons to map
m <- addPolygons(m, data=SpP, stroke = FALSE, smoothFactor = 0, fillOpacity = 0.5)
}
## Call map !
m
})
}
shinyApp(ui, server)
I want to draw several things on a leaflet map (through Shiny/R)
I initialize the map like this
map = leaflet() %>% addProviderTiles("Stamen.TonerLite") %>% setView(-1.5, 53.4, 9)
output$myMap = renderLeaflet(map)
Then, depending on what is clicked in the App I ether want to draw Markers or a Polygon
sp <- reactiveValues()
ep <- reactiveValues()
area <- reactiveValues()
area$mp <- matrix(...) # empty matrix with 2 cols named lat/lng
observeEvent(input$map_click, {
coords <- input$map_click
if ( (!is.null(as.integer(input$button)) && (!is.null(coords))) ) {
if (as.integer(input$button) == 1) {
sp[["lat"]] <- coords$lat
sp[["lng"]] <- coords$lng
} else if (as.integer(input$button) == 2) {
ep[["lat"]] <- coords$lat
ep[["lng"]] <- coords$lng
} else if (as.integer(input$button) == 3) {
cm <- matrix(data = c(coords$lat, coords$lng), nrow = 1, ncol = 2)
area$mp <- rbind(area$mp, cm)
} else {
print("Kawum!")
}
})
What I cannot get into my head is how to draw something now on the leaflet map.
What is group ID, what is layer ID. Where comes leafletProxy into play?
How would I, depending on which if else statement kicks in, send the data to leaflet and add a marker or a polygon?
Any help or pointing into the right direction is highly appreciated!
Maybe this can clarify things:
library(shiny)
library(leaflet)
ui <- shinyUI(fluidPage(
actionButton("button", "Change style!"),
leafletOutput("myMap")
))
server <- function(input, output){
map = leaflet() %>% addProviderTiles("Stamen.TonerLite") %>% setView(-1.5, 53.4, 9)
output$myMap = renderLeaflet(map)
sp <- reactiveValues()
ep <- reactiveValues()
area <- reactiveValues()
observeEvent(sp$lat, {
leafletProxy("myMap") %>% addMarkers(lat = sp$lat, lng = sp$lng)
})
observeEvent(ep$lat, {
leafletProxy("myMap") %>% addCircles(lat = ep$lat, lng = ep$lng)
})
observeEvent(area$mp, {
leafletProxy("myMap") %>% addPolygons(lat = area$mp[ , 1], lng = area$mp[ , 2])
})
observeEvent(input$myMap_click, {
coords <- input$myMap_click
if ( (!is.null(input$button) && (!is.null(coords))) ) {
if (input$button %% 4 == 1) {
sp[["lat"]] <- coords$lat
sp[["lng"]] <- coords$lng
} else if (input$button %% 4 == 2) {
ep[["lat"]] <- coords$lat
ep[["lng"]] <- coords$lng
} else if (input$button %% 4 == 3) {
cm <- matrix(data = c(coords$lat, coords$lng), nrow = 1, ncol = 2)
area$mp <- if(!is.null(area$mp)){rbind(area$mp, cm)}else{cm}
} else {
print("Kawum!")
}
}
})
}
shinyApp(ui, server)
First thing, the click event needs to be named after the output element. So input$myMap_click gives you the coords. Second, the leaflet proxy is designed to draw points, things etc. into existing maps. Imagine you'd always re-render the map to do leaflet() %>% addMarkers(...). leafletProxy just needs the output element's name and draws the markers on top of it.
The code above shows some things you can do with that. E.g. using the polygons.
Try using it and comment, if there is something unclear.
I have data/results that contain both a geocode location (latitude/longitude) and a date/time stamp that I would like to interact with using R shiny. I have created R shiny apps that contain several leaflet maps (leaflet R package) and also contain time series graphs (dygraphs R package). I know how to synchronize different dygraphs (https://rstudio.github.io/dygraphs/gallery-synchronization.html), but not sure how to synchronize it to a leaflet map too. My question is how best to link all the graphs together, so when I select a region on a leaflet map or period of time on a dygraph time series graph the other graphs are all updated to show only that filtered data?
One thought I had was to use a leaflet plugin, but not sure how to do this with R/shiny? For example, I see some leaflet plugins offer the capability to animate a map that contains date/time information (http://apps.socib.es/Leaflet.TimeDimension/examples/). Another question is there any documentation/examples showing how to work with leaflet plugins using R shiny?
I think it is possible to extract the time/date that is selected from a time series graph (dygraph), but not sure if/how to extract the region that is displayed on the leaflet map in R shiny. My last question is whether if it is possible how I could extract the region over which the leaflet map is displayed, so I can update the time series graph.
Thanks in advance for any suggestions on how to couple leaflet maps with a time series graphs (i.e., dygraph) using R shiny!
This will probably be more of a continuous discussion than a single answer.
Fortunately, your question involves htmlwidgets created by RStudio who also made Shiny. They have taken extra effort to integrate Shiny communication into both dygraphs and leaflet. This is not the case for many other htmlwidgets. For a broader discussion of intra-htmlwidget communication outside of Shiny, I would recommend following this Github issue.
part 1 - leaflet control dygraph
As my first example, we'll let leaflet control dygraphs, so clicking on a state in Mexico will limit the dygraph plot to just that state. I should give credit to these three examples.
Kyle Walker's Rpub Mexico Choropleth Leaflet
Shiny example included in leaflet
Diego Valle Crime in Mexico project
R Code
# one piece of an answer to this StackOverflow question
# http://stackoverflow.com/questions/31814037/integrating-time-series-graphs-and-leaflet-maps-using-r-shiny
# for this we'll use Kyle Walker's rpubs example
# http://rpubs.com/walkerke/leaflet_choropleth
# combined with data from Diego Valle's crime in Mexico project
# https://github.com/diegovalle/mxmortalitydb
# we'll also build on the shiny example included in leaflet
# https://github.com/rstudio/leaflet/blob/master/inst/examples/shiny.R
library(shiny)
library(leaflet)
library(dygraphs)
library(rgdal)
# let's build this in advance so we don't download the
# data every time
tmp <- tempdir()
url <- "http://personal.tcu.edu/kylewalker/data/mexico.zip"
file <- basename(url)
download.file(url, file)
unzip(file, exdir = tmp)
mexico <- {
readOGR(dsn = tmp, layer = "mexico", encoding = "UTF-8")
#delete our files since no longer need
on.exit({unlink(tmp);unlink(file)})
}
pal <- colorQuantile("YlGn", NULL, n = 5)
leaf_mexico <- leaflet(data = mexico) %>%
addTiles() %>%
addPolygons(fillColor = ~pal(gdp08),
fillOpacity = 0.8,
color = "#BDBDC3",
weight = 1,
layerId = ~id)
# now let's get our time series data from Diego Valle
crime_mexico <- jsonlite::fromJSON(
"https://rawgit.com/diegovalle/crimenmexico.diegovalle.net/master/assets/json/states.json"
)
ui <- fluidPage(
leafletOutput("map1"),
dygraphOutput("dygraph1",height = 200),
textOutput("message", container = h3)
)
server <- function(input, output, session) {
v <- reactiveValues(msg = "")
output$map1 <- renderLeaflet({
leaf_mexico
})
output$dygraph1 <- renderDygraph({
# start dygraph with all the states
crime_wide <- reshape(
crime_mexico$hd[,c("date","rate","state_code"),drop=F],
v.names="rate",
idvar = "date",
timevar="state_code",
direction="wide"
)
colnames(crime_wide) <- c("date",as.character(mexico$state))
rownames(crime_wide) <- as.Date(crime_wide$date)
dygraph(
crime_wide[,-1]
)
})
observeEvent(input$map1_shape_mouseover, {
v$msg <- paste("Mouse is over shape", input$map1_shape_mouseover$id)
})
observeEvent(input$map1_shape_mouseout, {
v$msg <- ""
})
observeEvent(input$map1_shape_click, {
v$msg <- paste("Clicked shape", input$map1_shape_click$id)
# on our click let's update the dygraph to only show
# the time series for the clicked
state_crime_data <- subset(crime_mexico$hd,state_code == input$map1_shape_click$id)
rownames(state_crime_data) <- as.Date(state_crime_data$date)
output$dygraph1 <- renderDygraph({
dygraph(
xts::as.xts(state_crime_data[,"rate",drop=F]),
ylab = paste0(
"homicide rate ",
as.character(mexico$state[input$map1_shape_click$id])
)
)
})
})
observeEvent(input$map1_zoom, {
v$msg <- paste("Zoom changed to", input$map1_zoom)
})
observeEvent(input$map1_bounds, {
v$msg <- paste("Bounds changed to", paste(input$map1_bounds, collapse = ", "))
})
output$message <- renderText(v$msg)
}
shinyApp(ui, server)
part 2 dygraph control leaflet + part 1 leaflet control dygraph
# one piece of an answer to this StackOverflow question
# http://stackoverflow.com/questions/31814037/integrating-time-series-graphs-and-leaflet-maps-using-r-shiny
# for this we'll use Kyle Walker's rpubs example
# http://rpubs.com/walkerke/leaflet_choropleth
# combined with data from Diego Valle's crime in Mexico project
# https://github.com/diegovalle/mxmortalitydb
# we'll also build on the shiny example included in dygraphs
# https://github.com/rstudio/leaflet/blob/master/inst/examples/shiny.R
library(shiny)
library(leaflet)
library(dygraphs)
library(dplyr)
library(rgdal)
# let's build this in advance so we don't download the
# data every time
tmp <- tempdir()
url <- "http://personal.tcu.edu/kylewalker/data/mexico.zip"
file <- basename(url)
download.file(url, file)
unzip(file, exdir = tmp)
mexico <- {
#delete our files since no longer need
on.exit({unlink(tmp);unlink(file)})
readOGR(dsn = tmp, layer = "mexico", encoding = "UTF-8")
}
# now let's get our time series data from Diego Valle
crime_mexico <- jsonlite::fromJSON(
"https://rawgit.com/diegovalle/crimenmexico.diegovalle.net/master/assets/json/states.json"
)
# instead of the gdp data, let's use mean homicide_rate
# for our choropleth
mexico$homicide <- crime_mexico$hd %>%
group_by( state_code ) %>%
summarise( homicide = mean(rate) ) %>%
ungroup() %>%
select( homicide ) %>%
unlist
pal <- colorBin(
palette = RColorBrewer::brewer.pal(n=9,"YlGn")[-(1:2)]
, domain = c(0,50)
, bins =7
)
popup <- paste0("<strong>Estado: </strong>",
mexico$name,
"<br><strong>Homicide Rate: </strong>",
round(mexico$homicide,2)
)
leaf_mexico <- leaflet(data = mexico) %>%
addTiles() %>%
addPolygons(fillColor = ~pal(homicide),
fillOpacity = 0.8,
color = "#BDBDC3",
weight = 1,
layerId = ~id,
popup = popup
)
ui <- fluidPage(
leafletOutput("map1"),
dygraphOutput("dygraph1",height = 200),
textOutput("message", container = h3)
)
server <- function(input, output, session) {
v <- reactiveValues(msg = "")
output$map1 <- renderLeaflet({
leaf_mexico
})
output$dygraph1 <- renderDygraph({
# start dygraph with all the states
crime_wide <- reshape(
crime_mexico$hd[,c("date","rate","state_code"),drop=F],
v.names="rate",
idvar = "date",
timevar="state_code",
direction="wide"
)
colnames(crime_wide) <- c("date",as.character(mexico$state))
rownames(crime_wide) <- as.Date(crime_wide$date)
dygraph( crime_wide[,-1]) %>%
dyLegend( show = "never" )
})
observeEvent(input$dygraph1_date_window, {
if(!is.null(input$dygraph1_date_window)){
# get the new mean based on the range selected by dygraph
mexico$filtered_rate <- crime_mexico$hd %>%
filter(
as.Date(date) >= as.Date(input$dygraph1_date_window[[1]]),
as.Date(date) <= as.Date(input$dygraph1_date_window[[2]])
) %>%
group_by( state_code ) %>%
summarise( homicide = mean(rate) ) %>%
ungroup() %>%
select( homicide ) %>%
unlist
# leaflet comes with this nice feature leafletProxy
# to avoid rebuilding the whole map
# let's use it
leafletProxy( "map1", data = mexico ) %>%
removeShape( layerId = ~id ) %>%
addPolygons( fillColor = ~pal( filtered_rate ),
fillOpacity = 0.8,
color = "#BDBDC3",
weight = 1,
layerId = ~id,
popup = paste0("<strong>Estado: </strong>",
mexico$name,
"<br><strong>Homicide Rate: </strong>",
round(mexico$filtered_rate,2)
)
)
}
})
observeEvent(input$map1_shape_click, {
v$msg <- paste("Clicked shape", input$map1_shape_click$id)
# on our click let's update the dygraph to only show
# the time series for the clicked
state_crime_data <- subset(crime_mexico$hd,state_code == input$map1_shape_click$id)
rownames(state_crime_data) <- as.Date(state_crime_data$date)
output$dygraph1 <- renderDygraph({
dygraph(
xts::as.xts(state_crime_data[,"rate",drop=F]),
ylab = paste0(
"homicide rate ",
as.character(mexico$state[input$map1_shape_click$id])
)
)
})
})
}
shinyApp(ui, server)