I have set up a simply leaflet map in shiny where the shiny server.R looks like this:
(please get the RDS-Data from Dropbox for a reproducible example)
Server.R
test_polygons <- readRDS('test_polygons.RDS') # Sind die Polygon-Shapefiles transformiert auf WGS84 für Bezirke
#some merging....
#we use sample data instead
test_polygons#data$sample <- runif(nrow(test_polygons#data))
#Create some nice popups
world_popup <- function(modell){
niveau <- test_polygons#data[, modell]
probs <- seq(0, 1, length.out = 5 + 1)
niveau <- cut(niveau, breaks=quantile(niveau, probs, na.rm = TRUE, names = FALSE), labels=paste('level', 0:4), include.lowest = TRUE)
niveau <- as.character(niveau)
niveau <- factor(niveau, labels=)
paste0("<strong>Bezirk: </strong>",
as.character(test_polygons#data$ID),
"<br><strong><br>",
"</strong>",
"<strong>Level: </strong>",
niveau
)
}
tiles <- "http://{s}.tile.stamen.com/toner-lite/{z}/{x}/{y}.png"
attribution <- 'Map tiles by <a target="_blank" href="http://stamen.com">Stamen Design</a>, under <a target="_blank" href="http://creativecommons.org/licenses/by/3.0">CC BY 3.0</a>. Map data by <a target="_blank" href="http://www.naturalearthdata.com/">Natural Earth</a>.'
# produce the leaflet map ====
pal <- colorQuantile("YlOrRd", NULL, n = 5)
m.sample <- leaflet(data = test_polygons) %>%
addTiles(urlTemplate = tiles,
attribution = attribution) %>%
setView(13.782778, 47.61, zoom = 7) %>%
addPolygons(fillColor = ~pal(test_polygons$sample),
fillOpacity = 0.8,
color = "#000000",
weight = 1,
popup = world_popup('sample'))
# start the server part
server <- function(input, output, session) {
output$query <- renderText({
as.character(parseQueryString(session$clientData$url_search))
})
output$mymap <- renderLeaflet({
m.sample
})
}
ui.R
Whilst the UI is fairly simple:
require(leaflet)
require(shiny)
ui <- fluidPage(
column(width=12,
leafletOutput("mymap", height="200px")#, height="700px")
)
)
This works okay on my desktop computer. However, as soon as I try to access it on my server the leaflet-map loads awfully slowly. Especially if I alter the height to, say, 100 % it stops loading at all. So here are my questions:
How do I speed up the loading process.
Is it possible to load some parts in advance since anything is reactive in this context.
Can I create a map that is independent from shiny -- probably this one's loading faster.
Is it possible that my polygons have to many details?
Thank you very much for your help!
Starting from the comments simplifying the SP-Object did the trick. I imported the underlying shapefile in QGis and adjusted it by
Vector => Geometry Tools => Simplify geometries
Works much faster now. More info can be found via:
Qgis-Stackexchange or the Documentation.
Thanks for your help!
Related
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"})
}
})
})
}
How can i find correct leaflet tile on Server give longitude / latitude.
I follow the Formula on slide 19 of this presentation: https://www.tu-chemnitz.de/urz/stammtisch/rsrc/vortrag-stammtisch.pdf (sry German).
Goal:
Calculate (zoom, x and y) given longitude and latitude
Additional Information:
I found this docu https://mapserver.org/mapcache/services.html, which states that x is column number in zxy naming scheme and y the tow number.
What i tried:
#London
long = 51.52
lat = -0.18
zoom = 5
lambda = pi/180*long
phi = pi/180*lat
x = 2^zoom*(lambda + pi)/(2*pi)
y = 2^zoom*(pi - log(tan(phi) + 1/(cos(phi))))/(2*pi)
x
y
glue("https://tile.openstreetmap.org/{zoom}/{x}/{y}.png")
You can wrap the leaflet map in a really simple shiny app, and calculate on the fly the tile using leaflet shiny map events (info in the Inputs/Events section)
library(shiny)
library(leaflet)
library(glue)
ui <- fluidPage(
leafletOutput('map'),
textOutput('tile')
)
server <- function(input, output, session) {
output$map <- renderLeaflet({
leaflet() %>%
addTiles(options = tileOptions(noWrap = TRUE))
})
tile_finder <- eventReactive(input$map_click, {
long <- input$map_click$lng
lat <- input$map_click$lat
zoom <- input$map_zoom
lambda <- pi/180*long
phi <- pi/180*lat
x <- (2^zoom*(lambda + pi)/(2*pi))%/%1
y <- (2^zoom*(pi - log(tan(phi) + 1/(cos(phi))))/(2*pi))%/%1
glue("https://tile.openstreetmap.org/{zoom}/{x}/{y}.png")
})
output$tile <- renderText({
tile_finder()
})
}
shinyApp(ui, server)
You will get the tile info when clicking over the map, and the info appears below
The result for Paris, give this link https://tile.openstreetmap.org/8/129/88.png
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()
})
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 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)