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()
})
Related
I am looking to replicate one of those maps where you can guesstimate the state-level results of the next presidential election and have the results of your scenario shown to you by way of changing color backgrounds. An example of what I mean can be found here.
The first step is to provide a default setting as a starting point for the user's input. One way to achieve this would be:
library(maps)
library(tidyverse)
usa <- map_data("state")
probs <- c(0.30,0.40,0.30)
results <- c("Rep", "Dem", "Toss-Up")
usa %>%
group_by(region) %>%
mutate(result = sample(results, size = n(), prob = probs, replace = T)) > electoral_map
ggplot() +
geom_map(data = electoral_map, map = usa, aes(long, lat, map_id = region,
fill = result), color = "black") +
scale_fill_manual(values=c("blue", "red", "grey"))
The next - and most crucial - step would be to make this map interactive by letting the result column change with a click of a button. For instance, a click on California would switch the fill color to blue and the resultcoding to Dem.
Obvious candidates for this for me were the plotly and leaflet packages, but neither of them seem to offer the functionality I require for this case. I got the closest using the selectFeatures function from mapedit, but this only lets me select regions, not change their associated coding.
For subsequent calculations, it is important that changes made by the user are recorded for further use. The end goal is to have shiny app akin to the link provided above, with inputs by the user changing the overall count of electoral college votes secured by each side.
Does anyone have pointers on a possible solution?
(For the record, my actual objective has nothing to do with elections, but I figured this was the most understandable way to communicate my problem)
I fabricated a simple shiny app for you as a starting point for your project.
You can test it at:
https://wietze314.shinyapps.io/stackoverflow-rig-the-election/
#
# This is a Shiny web application. You can run the application by clicking
# the 'Run App' button above.
#
# Find out more about building applications with Shiny here:
#
# http://shiny.rstudio.com/
#
library(shiny)
library(maps)
library(ggplot2)
library(dplyr)
library(sp)
# Define UI for application that draws a map
ui <- fluidPage(
# Application title
titlePanel("Rig the election of the USA"),
# Show a plot of the generated distribution
mainPanel(
plotOutput("usaPlot", click = "usaPlot_click"),
textOutput("debug")
)
)
usa <- map_data("state")
probs <- c(0.30,0.40,0.30)
results <- c("Rep", "Dem", "Toss-Up")
start_map <- usa
# Define server logic required to change the election results
server <- function(input, output) {
# make a variable to store the election results in
electoral_map <- reactiveValues(
regions = start_map %>% select(region) %>%
distinct() %>% mutate(result = sample(results, size = n(), prob = probs, replace = T))
)
# render the map
output$usaPlot <- renderPlot({
# generate bins based on input$bins from ui.R
ggplot() +
geom_map(data = start_map %>% inner_join(electoral_map$regions, by = 'region'),
map = usa,
aes(long, lat, map_id = region, fill = result), color = "black") +
scale_fill_manual(values=c("blue", "red", "grey"))
})
# find the region that was clicked (point.in.polygon)
# change the result of the election
observeEvent(input$usaPlot_click,{
x <- input$usaPlot_click$x
y <- input$usaPlot_click$y
selectedregion <- usa %>%
group_by(region) %>%
mutate(selected = point.in.polygon( x,y,long,lat)) %>%
filter(selected == 1) %>%
select(region) %>% distinct() %>% unlist()
if(length(selectedregion)==1){
currentresult <- electoral_map$regions[electoral_map$regions == selectedregion,'result']
nextresult <- if_else(currentresult == "Dem","Rep","Dem")
electoral_map$regions[electoral_map$regions == selectedregion,'result'] <- nextresult
# report what you have done
output$debug <- renderText(paste0("You visited at ",
round(x),", ",round(y),
" and rigged the election results of ",selectedregion, " and changed it to ",
nextresult))
} else {
# if no region has been selected
output$debug <- renderText("Fish don't vote!!!")
}
})
}
# Run the application
shinyApp(ui = ui, server = server)
I'm having trouble using columns from data originating in wide format as dynamic inputs to a Shiny map app.
In the app I'm hoping to be able to:
select a parameter of point data (sample data below: 16 locations, 6 parameters) in a drop down type menu and adjust the symbol size to represent the selected parameter's absolute values with a slider (to help visualize positive and negative differences from zero)
with any parameter selected, retain ability to see all parameters (the columns) in mapview's popup feature (mapview turns the columns into rows for the popup). It seems a filtered long format data.frame would be missing data from the popup/viewing perspective
retain the (non absolute) original value on the mouseover hover label (eg the -7.3 in the image)
In addition to having those features, I don't know if/where I need to set reactive wrapper(s)? Or, maybe I could do everything more easily with another map-centric library (even though mapview is awesome for many things)?
My attempts are commented out below - the UI works as intended except without drop down selectability - the app is limited to only one working dropdown parameter with mapview(df["param1"] and cex = param1 * input$cex.
Here's the reproducible app.r:
library(tidyverse)
library(sf)
library(shiny)
library(shinydashboard)
library(leaflet)
library(mapview)
## sample earthquake data ##
set.seed(6)
lat <- rnorm(16,-34, 9)
lon <- rnorm(16,-67,.3)
param1 <- rnorm(16, 10, 40) %>% round(1)
param2 <- rnorm(16, 25, 3) %>% round(1)
param3 <- rnorm(16, -18, 10) %>% round(1)
param4 <- rnorm(16, -200, 93) %>% round(1)
param5 <- rnorm(16, 0.1, .09) %>% round(1)
param6 <- rnorm(16, 417, 33) %>% round(1)
df <- data.frame(lat, lon, param1, param2, param3, param4, param5,
param6)
df <- st_as_sf(df, coords = c("lon", "lat"), crs = 4326)
paramchoices <- colnames(df) %>% .[.!="geometry"]
colorpal = mapviewPalette("mapviewSpectralColors")
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sliderInput("cex", "Symbol Size",
min = 0.000001, max = 10, value = 1, step = 0.000001
),
selectizeInput(
"parameter", "Earthquake Parameter", choices = paramchoices,
selected = c("param1"),
multiple = FALSE)
),
dashboardBody(
tags$style(type = "text/css", "#mapplot {height: calc(100vh - 80px) !important;}"),
leafletOutput("mapplot")
)
)
server <- function(input, output) {
# df <- reactive ({
# df %>% mutate(selectedparameter = input$parameter,
# selectedparameter_abs = abs(selectedparameter))
# })
output$mapplot <- renderLeaflet({
m <- mapview(df["param1"], #mouseover column
#m <- mapview(df["selectedparameter"],
cex = param1 * input$cex, #marker size column
#cex = df$selectedparameter_abs * input$cex,
col.regions = colorpal(100),
alpha.regions = 0.3,
legend = TRUE,
popup = popupTable(df),
layer.name = "selectedparam[unit]")
m#map
}
)}
shinyApp(ui, server)
more info related to the absolute value part - Point color and symbol size based on different variables in mapview
thank you.
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:
I am trying to make the radius of my circle markers in this Shiny leaflet app be driven by the selectInput variable.
The dropdown has three values, "Week.1", "Week.2" and "Week.3", which are all numeric vectors (of large dollar revenue values in millions) in the d at the bottom of this question.
selectInput("weekView", "Week's Revenue:",
c("1" = "Week.1",
"2" = "Week.2",
"3" = "Week.3")),
I am currently loading Week.1 and get thr result. I wNt the input to change the weeks and react with the corresponding $ on the map.
When I try and use input$weekView instead of the static ~(Week.1), I get errors as it is "Week.1". I've tried using quote = False in place to remove them before the radius is calculated but I'm failing to find the right place to do so...
leaflet(data = P) %>%
addTiles() %>% # Add default OpenStreetMap map tiles
addCircleMarkers(~Long, ~Lat, popup = ~Week.1,
radius = ~(Week.1)/40000,
stroke = FALSE,
fillOpacity = 0.5)
Can any one advise on how best to go about this? What I want to say is
radius = input$weekView/40000
All the script:
library(shiny)
library(leaflet)
ui <- fluidPage(
selectInput("weekView", "Week's Revenue:",
c("1" = "Week.1",
"2" = "Week.2",
"3" = "Week.3")),
leafletOutput("mymap"),
p()
)
server <- function(input, output, session) {
output$mymap <- renderLeaflet({
x <- input$weekView
P<- read.csv("Lebara_weeks_rev4.csv")
as.numeric(P$Long)
as.numeric(P$Lat)
as.character(P$Week.1)
P$Week.1 <- as.numeric(gsub(",","",P$Week.1))
P$Week.2 <- as.numeric(gsub(",","",P$Week.2))
P$Week.3 <- as.numeric(gsub(",","",P$Week.3))
long <- P$Long
Lat <- P$Lat
leaflet(data = P) %>%
addTiles() %>% # Add default OpenStreetMap map tiles
addCircleMarkers(~Long, ~Lat, popup = ~Week.1,
radius = ~(Week.1)/40000,
stroke = FALSE,
fillOpacity = 0.5)
})
}
shinyApp(ui, server)
Head of the df = P
> head(P)
group Lat Long Country Week.1 Week.2 Week.3 Week.4
1 178.100 55.37805 -3.435973 United Kingdom 649,613 665,147 640,732 649,642
2 174.890 51.16569 10.451526 Germany 117,766 120,402 104,167 91,157
3 144.100 46.22764 2.213749 France 135,784 117,759 109,337 101,873
4 174.211 52.13263 5.291266 Netherlands 403,950 397,438 377,855 389,345
5 174.990 40.46367 -3.749220 Spain 94,472 95,742 88,313 86,400
6 178.600 56.26392 9.501785 Denmark 70,094 72,487 67,597 66,769
Thanks!
Pete
I used tidyr and subsetWeek1 <- P[1:7,] then made variables for the subsetWeek1$value/40000 to make them small enough for the radius values) of those subsets. I tried to make the selectInput 1 = subsetWeek1$value, 2 = subsetWeek2$value and 3 = subsetWeek3$value...
library(tidyr)
P <- tidyr::gather(P, week, value, Week.1:Week.3)
subsetWeek1 <- P[1:7,]
subsetWeek2 <- P[8:14,]
subsetWeek3 <- P[15:21,]
Week1val <- subsetWeek1$value
Week2val <- subsetWeek2$value
Week3val <- subsetWeek3$value
This doesn't seem to pick up the selectInput value and change the map. There are no markers on the map and no errors provided. Could it be the scale of the circles makes them invisible? In the non-app version they are OK.
You're close, you just need to update variable names and clean up a bit. Generally, if you're repeating the same line with a slightly different parameter, there's a better way. An option, using tidyr for gather and extract_numeric:
library(shiny)
library(tidyr)
library(leaflet)
P <- read.csv("Lebara_weeks_rev4.csv")
# do munging that won't change based on input here
P2 <- gather(P, week, value, Week.1:Week.4) # gather to long form
P2$value <- extract_numeric(P2$value) # convert to numeric
ui <- fluidPage(
selectInput("weekView", "Week's Revenue:",
c("1" = "Week.1",
"2" = "Week.2",
"3" = "Week.3",
"4" = "Week.4")),
leafletOutput("mymap")
)
server <- function(input, output, session) {
output$mymap <- renderLeaflet({
# do munging dependent on input here
P3 <- P2[P2$week == input$weekView, ] # subset based on input
leaflet(data = P3) %>%
addTiles() %>% # Add default OpenStreetMap map tiles
addCircleMarkers(lng = ~Long, lat = ~Lat,
popup = ~format(value, big.mark = ','), # reinsert commas
radius = ~value/40000,
stroke = FALSE,
fillOpacity = 0.5)
})
}
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)