Changing Leaflet map according to input without redrawing - r

I'm wondering how I can change Shiny and Leaflet to plot points according to the change in input without redrawing the whole map.
The code i'm using is:
library(leaflet)
library(shiny)
library(dplyr)
library(readr)
ui <- fluidPage(
titlePanel("Melbourne Urban Tree Visualisation"),
leafletOutput("treedat"),
uiOutput("precinct")
#Giving an input name and listing out types to choose in the Shiny app
)
server <- function(input, output){
#td <- read.csv("treedata.csv", header = TRUE)
#pal <- colorNumeric(
#palette = "RdYlGn",
#domain = td$LifeExpectencyValue
#)
output$precinct <- renderUI({
choices <- as.character(unique(td$Precinct))
choices <- c('All', choices)
selectInput(inputId = "precinct", label = "Precinct", choices = choices, selected = "CBD")
})
output$treedat <- renderLeaflet({
#if(is.null(td)) return()
## get the choice from teh drop-down box
PRECINCT = input$precinct
## supbset the data based on the choice
if(PRECINCT != 'All'){
td2 <- td[td$Precinct == PRECINCT, ]
}else{
td2 <- td
}
## plot the subsetted ata
td2 <- leafletProxy(td2) %>% addTiles(
urlTemplate = 'http://{s}.basemaps.cartocdn.com/dark_all/{z}/{x}/{y}.png',
attribution='Map tiles by Stamen Design, CC BY 3.0 — Map data © OpenStreetMap') %>%
addCircleMarkers(radius= 5,
fillOpacity = 0.5,
stroke = FALSE,
color=~pal(LifeExpectencyValue),
popup=paste("<b>", td$CommonName,"</b>", "<br>",
"<b>","Years Left:", "</b>", td$LifeExpectency, "<br>",
"<b>","Genus:","</b>", td$Genus)) %>% addLegend(pal = pal,
values = ~LifeExpectencyValue,
opacity = 1,
title = "Life Expectency")
return(td2)
})
}
shinyApp(ui = ui, server = server)
The dataset used for the code is available at this link - Melbourne Urban Forest Data
There are a lot of points so I wouldn't want to re-draw each time the input is changed. The input is based on the "Precinct" column in the dataset. Any help here is deeply appreciated.

Okay, there you go: leafletProxy is used to add layers to an existing leaflet map. The usage ist just like normal leaflet additions, but you don't need the rendering part, since the map is already rendered in your document.
The first and easiest part is to render the leaflet map on a basic level, that is tiles, legend, static drawings, everything that you want to do just once. This is your starting point. From there on, altering the map is only done by direct commands instead of re-renderings.
This map can now be accessed via its shiny output id. In out case, we had leafletOutput("treedat"), so if we want to address this map, we use leafletProxy("treedat"). We use the same syntax as in regular leaflet modifications. E.g. leafletProxy("treedat") %>% addMarkers(lat = 1, lng = 1) adds a marker to the existing map without re-rendering it.
Thus, every modification to the map can / has to happen from inside some observe statement and not from inside the renderLeaflet. Note that every command is an addition to the original map, which is why I had to use clearMarkers in the example below.
Code:
library(leaflet)
library(shiny)
library(dplyr)
library(readr)
ui <- fluidPage(
titlePanel("Melbourne Urban Tree Visualisation"),
leafletOutput("treedat"),
uiOutput("precinct")
#Giving an input name and listing out types to choose in the Shiny app
)
server <- function(input, output){
td <- data.frame(
LifeExpectencyValue = sample(20:100, 10),
Precinct = c(rep("CBD", 3), rep("ABC", 4), rep("XYZ", 3)),
CommonName = sapply(1:10, function(x){paste(sample(LETTERS, 10, replace = TRUE), collapse = "")}),
Genus = rep(c("m","f"), each = 5),
lat = seq(5, 50, 5),
lng = seq(2, 65, 7)
)
pal <- colorNumeric(palette = "RdYlGn", domain = td$LifeExpectencyValue)
output$precinct <- renderUI({
choices <- as.character(unique(td$Precinct))
choices <- c('All', choices)
selectInput(inputId = "precinct", label = "Precinct", choices = choices, selected = "CBD")
})
output$treedat <- renderLeaflet({
leaflet() %>%
addTiles(
urlTemplate = 'http://{s}.basemaps.cartocdn.com/dark_all/{z}/{x}/{y}.png',
attribution='Map tiles by Stamen Design, CC BY 3.0 — Map data © OpenStreetMap'
) %>%
addLegend(pal = pal, values = td$LifeExpectencyValue, opacity = 1, title = "Life Expectency")
})
observeEvent(input$precinct, {
#if(is.null(td)) return()
## get the choice from teh drop-down box
PRECINCT = input$precinct
## supbset the data based on the choice
if(PRECINCT != 'All'){
td2 <- td[td$Precinct == PRECINCT, ]
}else{
td2 <- td
}
## plot the subsetted ata
leafletProxy("treedat") %>%
clearMarkers() %>%
addCircleMarkers(lat = td2$lat, lng = td2$lng,
radius= 5, fillOpacity = 0.5, stroke = FALSE, color=pal(td2$LifeExpectencyValue),
popup = paste("<b>", td2$CommonName,"</b>", "<br>",
"<b>","Years Left:", "</b>", td2$LifeExpectency, "<br>",
"<b>","Genus:","</b>", td2$Genus))
})
}
shinyApp(ui = ui, server = server)

Related

Issue with displaying Leaflet map with multiple filtering layers in R shiny app

I am working with R Shiny to produce an interactive Leaflet map that includes multiple drop-down menus for users to drill down the data. There are 3 main layers: geographical type (which inlcudes county level, city level, and census tract level), GEOID (names of locations of each layer), and population target (population in the selected location). The geographical type and thepopulation target each has a single selection while the GEOID has multiple selection options (for the situation to display all city locations or all census tract at the beginning before the users select a specific location).
I used pickerInput and the example codes from the Issue with selecting multiple filter options in R Shiny with Leaflet
However, the map was not displayed. The options of each drop-down menu were grayed out and there was an error "Warning: Error in sum: invalid 'type' (list) of argument"
## app.R ##
# Load in the necessary libraries
library(shinydashboard)
library(shinydashboardPlus)
library(shiny)
library(shinyjs)
library(shinythemes)
library(shinyWidgets)
library(tidyverse) # data manipulation
library(leaflet) # interactive maps
library(sf) # spatial data
library(tigris) # geojoin
library(htmlwidgets) # interactive map labels
library(openxlsx) # open xlsx file
options(tigris_use_cache = TRUE)
# Load in the service+geo dataset
df <- read_sf("...//data_r.shp")
#colnames(df)
#glimpse(df)
#levels(as.factor(df$type))
df <- unique(df) %>%
mutate(GEOID = if_else(type=="tract", sub(", San Diego County, California","",NAME), GEOID)) %>%
mutate(GEOID = if_else(type=="county", "San Diego County", GEOID))
df <- df %>% filter(!is.na(GEOID))
label_type <- as.character(sort(unique(df$type)))
label_geoid <- as.character(sort(unique(df$GEOID)))
label_pop1 <- as.character(sort(unique(df$pop_1)))
ui <- dashboardPage(
dashboardHeader(title = "BHEI Map"),
dashboardSidebar(
pickerInput("typeInput","Geographical Type:", choices=label_type, options = list(`actions-box` = FALSE), multiple = FALSE),
pickerInput("geoidInput","Location", choices=c("Select location...", label_geoid), selected = "Select location...", options = list(`actions-box` = TRUE),multiple = TRUE),
pickerInput("pop1Input","Main Topic", choices=c("Select topic...", label_pop1), selected = "Select topic...", options = list(`actions-box` = FALSE),multiple = FALSE)
),
dashboardBody(leafletOutput(outputId = 'map1', height = 930)
))
server <- function(input, output, session) {
observeEvent(
# define pickerinputs to be observed
c(
input$typeInput,
input$geoidInput,
input$pop1Input
),
{
## filter the data based on the pickerinputs
# include an ifelse condition first to check wheter at least one value is choosen in all of the filters.
df2 <-
if (!is.null(input$typeInput)&
!is.null(input$geoidInput) &
!is.null(input$pop1Input)) {
df %>%
filter(type %in% input$typeInput) %>% # filters
filter(GEOID %in% input$geoidInput) %>%
filter(pop_1 %in% input$pop1Input)
}
else{
df
}
## update PickerInput based on a condition that requires the user to choose at least one input, else reset all filters
# for type
if (!is.null(input$typeInput)) {
updatePickerInput(
session,
"typeInput",
choices = levels(factor(df$type)),
selected = unique(df2$type))
} else{
}
# for GEOID
if (!is.null(input$geoidInput)) {
updatePickerInput(
session,
"geoidInput",
choices = levels(factor(df$GEOID)),
selected = unique(df2$GEOID)
)
}
# for pop_1
if (!is.null(input$pop1Input)) {
updatePickerInput(
session,
"pop1Input",
choices = levels(factor(df$pop_1)),
selected = unique(df2$pop_1)
)
}
},
ignoreInit = TRUE,
ignoreNULL = TRUE
)
# (2) Create reactive object with filtered data
# update df table based on filters
df.reactive <-
reactive({
if (!is.null(input$typeInput))
# one condition should be enough.
{
df %>% # filters
filter(
type %in% input$typeInput &
GEOID %in% input$geoidInput &
pop_1 %in% input$pop1Input
)
} else
{
df
}
})
# Map popup
mappopup <- reactive ({
paste(sep = "<br/>",
"<b>Location: </b>",df.reactive()$GEOID,
"<i>Proportion</i>",df.reactive()$proprtn)
})
# Interactive map
output$map1 <- renderLeaflet({
labels <- sprintf(
"<strong>%s</strong><br/>%g (%g out of %g)",
df.reactive()$GEOID, df.reactive()$proprtn, df.reactive()$smst_nm, df.reactive()$smst_dn) %>%
lapply(htmltools::HTML)
pal <- colorBin(palette="YlGn", 5, domain = df$proprtn)
df.reactive() %>%
leaflet() %>%
setView(lng = "-116.756412149", lat="32.715736", zoom = 9) %>%
addProviderTiles(provider = "CartoDB.Positron") %>%
addPolygons(label = labels,
stroke = FALSE,
smoothFactor = 0.5,
opacity = 1,
fillOpacity = 0.7,
popup = mappopup(),
fillColor = ~ pal(proprtn),
highlightOptions = highlightOptions(weight = 5,
fillOpacity = 1,
color = "black",
opacity = 1,
bringToFront = TRUE))
addLegend("bottomright",
pal = pal,
values = ~df$proprtn,
title = "Proportion",
opacity = 1)
})
}
shinyApp(ui, server)

Select multiple items using map_click in leaflet, linked to selectizeInput() in shiny app (R)

I would like to create a leaflet map where you can select multiple polygons and this will update the selectizeInput() in a shiny app. This would including removing a selected polygon, when it is removed in the selectizeInput().
I have slightly changed/updated the code from the answer here (use of sf instead of sp and more dplyr where I could work out what the base R was).
The polygons could probably be updated with an observeEvent tied in with input$clicked_locations, but not sure exactly how.
Here is the code:
library(shiny)
library(leaflet)
library(sf)
library(dplyr)
#load shapefile
nc <- st_read(system.file("shape/nc.shp", package="sf")) %>%
st_transform(4326)
shinyApp(
ui = fluidPage(
"Update selectize input by clicking on the map",
leafletOutput("map"),
"I would like the selectize input to update to show all the locations clicked,",
"but also when items are removed here, they are removed on the map too, so linked to the map.",
selectizeInput(inputId = "clicked_locations",
label = "Clicked",
choices = nc$NAME,
selected = NULL,
multiple = TRUE)
),
server <- function(input, output, session){
#create empty vector to hold all click ids
clicked_ids <- reactiveValues(ids = vector())
#initial map output
output$map <- renderLeaflet({
leaflet() %>%
addTiles() %>%
addPolygons(data = nc,
fillColor = "white",
fillOpacity = 0.5,
color = "black",
stroke = TRUE,
weight = 1,
layerId = ~NAME,
group = "regions",
label = ~NAME)
}) #END RENDER LEAFLET
observeEvent(input$map_shape_click, {
#create object for clicked polygon
click <- input$map_shape_click
#define leaflet proxy for second regional level map
proxy <- leafletProxy("map")
#append all click ids in empty vector
clicked_ids$ids <- c(clicked_ids$ids, click$id) # name when clicked, id when unclicked
#shapefile with all clicked polygons - original shapefile subsetted by all admin names from the click list
clicked_polys <- nc %>%
filter(NAME %in% clicked_ids$ids)
#if the current click ID [from CNTY_ID] exists in the clicked polygon (if it has been clicked twice)
if(click$id %in% clicked_polys$CNTY_ID){
#define vector that subsets NAME that matches CNTY_ID click ID - needs to be different to above
name_match <- clicked_polys$NAME[clicked_polys$CNTY_ID == click$id]
#remove the current click$id AND its name match from the clicked_polys shapefile
clicked_ids$ids <- clicked_ids$ids[!clicked_ids$ids %in% click$id]
clicked_ids$ids <- clicked_ids$ids[!clicked_ids$ids %in% name_match]
# just to see
print(clicked_ids$ids)
# update
updateSelectizeInput(session,
inputId = "clicked_locations",
label = "",
choices = nc$NAME,
selected = clicked_ids$ids)
#remove that highlighted polygon from the map
proxy %>% removeShape(layerId = click$id)
} else {
#map highlighted polygons
proxy %>% addPolygons(data = clicked_polys,
fillColor = "red",
fillOpacity = 0.5,
weight = 1,
color = "black",
stroke = TRUE,
layerId = clicked_polys$CNTY_ID)
# just to see
print(clicked_ids$ids)
# update
updateSelectizeInput(session,
inputId = "clicked_locations",
label = "",
choices = nc$NAME,
selected = clicked_ids$ids)
} #END CONDITIONAL
}) #END OBSERVE EVENT
}) #END SHINYAPP
This is also posted here where you can also find the edited version of the code from the answer (originally an sp dataset), that works. This code for the nc data set seems to be the same to me, but doesn't seem to work, although updating the polygons based on the selectizeInput() isn't in there.
Any ideas on this?
Please see the following workaround:
I'm adding all polygons on rendering the map and hiding the red overlay. Furthermore each of the red polygons is assigned to it's own group. On click the according group and therefore the polygon is shown/hidden.
library(shiny)
library(leaflet)
library(sf)
library(dplyr)
#load shapefile
nc <- st_read(system.file("shape/nc.shp", package="sf")) %>%
st_transform(4326)
shinyApp(
ui = fluidPage(
"Update selectize input by clicking on the map",
leafletOutput("map"),
"I would like the selectize input to update to show all the locations selected,",
"but also when items are removed here, they are removed on the map too, so linked to the map.",
selectizeInput(inputId = "selected_locations",
label = "Selected:",
choices = nc$NAME,
selected = NULL,
multiple = TRUE)
),
server <- function(input, output, session){
#create empty vector to hold all click ids
selected_ids <- reactiveValues(ids = vector())
#initial map output
output$map <- renderLeaflet({
leaflet() %>%
addTiles() %>%
addPolygons(data = nc,
fillColor = "white",
fillOpacity = 0.5,
color = "black",
stroke = TRUE,
weight = 1,
layerId = ~NAME,
group = "regions",
label = ~NAME) %>%
addPolygons(data = nc,
fillColor = "red",
fillOpacity = 0.5,
weight = 1,
color = "black",
stroke = TRUE,
layerId = ~CNTY_ID,
group = ~NAME) %>%
hideGroup(group = nc$NAME) # nc$CNTY_ID
}) #END RENDER LEAFLET
#define leaflet proxy for second regional level map
proxy <- leafletProxy("map")
#create empty vector to hold all click ids
selected <- reactiveValues(groups = vector())
observeEvent(input$map_shape_click, {
if(input$map_shape_click$group == "regions"){
selected$groups <- c(selected$groups, input$map_shape_click$id)
proxy %>% showGroup(group = input$map_shape_click$id)
} else {
selected$groups <- setdiff(selected$groups, input$map_shape_click$group)
proxy %>% hideGroup(group = input$map_shape_click$group)
}
updateSelectizeInput(session,
inputId = "selected_locations",
choices = nc$NAME,
selected = selected$groups)
})
observeEvent(input$selected_locations, {
removed_via_selectInput <- setdiff(selected$groups, input$selected_locations)
added_via_selectInput <- setdiff(input$selected_locations, selected$groups)
if(length(removed_via_selectInput) > 0){
selected$groups <- input$selected_locations
proxy %>% hideGroup(group = removed_via_selectInput)
}
if(length(added_via_selectInput) > 0){
selected$groups <- input$selected_locations
proxy %>% showGroup(group = added_via_selectInput)
}
}, ignoreNULL = FALSE)
})
Edit: regarding your initial approach adapting this answer you would need to pass the layerId as character to make things work again:
proxy %>% removeShape(layerId = as.character(click$id))
proxy %>% addPolygons(data = clicked_polys,
fillColor = "red",
fillOpacity = 0.5,
weight = 1,
color = "black",
stroke = TRUE,
layerId = as.character(clicked_polys$CNTY_ID))
I filed an issue regarding this.
However, I'd still prefer the above show/hide approach as I guess it's more performant than adding and removing polygons.

Selecting fillColor based on user input

I have a function in R that I'm using for creating a map of demographic information.
draw_demographics <- function(map, input, data) {
pal <- colorQuantile("YlGnBu", domain = NULL, n = 7)
#browser()
map %>%
clearShapes() %>%
addPolygons(data = data,
fillColor = ~pal(input$population),
fillOpacity = 0.4,
color = "#BDBDC3",
weight = 1)
}
It's a pure function that takes the map data from Leaflet, the input from the user, and the data from a shapefile to create the map layers. The columns of the shapefile include information like population density, total population, and so on, and I'd like to fill the polygons based on the column name. But where I'm a bit lost is figuring out how to pass selectInput() properly to Leaflet.
Here's a very basic example:
library(shiny)
library(leaflet)
ui <- bootstrapPage(
fluidRow(
column(12, leafletOutput("map"))
),
fluidRow(
column(12, uiOutput("select_population"))
)
)
server <- function(input, output, session) {
output$select_population <- renderUI({
choices <- list("None" = "None",
"All population" = "totalPop",
"Population density" = "totalDens",
"Black population" = "totalAfAm",
"Asian population" = "totalAsian",
"Latino population" = "totalHispanic",
"Native population" = "totalIndian")
selectInput(inputId = "population", label = "Demographics",
choices = choices, selected = "totalDens")
})
output$map <- renderLeaflet({
map <- leaflet() %>%
addProviderTiles(provider = "CartoDB.Positron",
providerTileOptions(detectRetina = FALSE,
reuseTiles = TRUE,
minZoom = 4,
maxZoom = 8)) %>%
setView(lat = 43.25, lng = -94.30, zoom = 6)
map %>% draw_demographics(input, counties[["1890"]])
})
}
## Helper functions
# draw_demographics draws the choropleth
draw_demographics <- function(map, input, data) {
pal <- colorQuantile("YlGnBu", domain = NULL, n = 7)
#browser()
map %>%
clearShapes() %>%
addPolygons(data = data,
fillColor = ~pal(input$population),
fillOpacity = 0.4,
color = "#BDBDC3",
weight = 1)
}
shinyApp(ui, server)
Where I'm a bit lost is how to pass the vector values from the column totalDens from the user's input of totalDens from the dropdown (or, pass whichever column of data they choose to map) to Leaflet. In other words, if a user selects totalPop instead, how can I tell Leaflet to reapply the color palette to this new set of data and re-render the polygons? I attempted using a reactive to get the results of input$population, but to no avail.
Any suggestions, or ways I could troubleshoot? Thanks!
With the data you posted on the github I redid it. The central problem seems to be the generation of the color palette. This is pretty fragile as it assumes that you have selected a good values for the cuts.
It needs a function that tries out various methods, see the code for details The really challenging case (that I found) was the Asian population for 1890, that was very skewed but definitely had values, and the median method always mapped everything to one color.
The following changes were made:
Added some code to download and save the counties data
Read in the data you provided
Added a field to select the year
added a req(input$population) to stop the typical shiny initialization NULL errors.
Created a getpal that tries out a different values starting on equally space quantiles.
If the number of quantiles reduces to 2, then it falls back to colorBin as colorQuantile colors everything the same in that case - probably a bug.
If there is no population data it does not draw the county shapes as that takes a lot of time, and there are a lot of those cases.
Here is the code:
library(shiny)
library(leaflet)
library(sf)
ui <- bootstrapPage(
fluidRow(
column(12, leafletOutput("map"))
),
fluidRow(
column(12, uiOutput("select_year")),
column(12, uiOutput("select_population"))
)
)
choices <- list("None" = "None",
"All population" = "totalPop",
"Population density" = "totalDens",
"Black population" = "totalAfAm",
"Asian population" = "totalAsian",
"Latino population" = "totalHispanic",
"Native population" = "totalIndian")
fn <- Sys.glob("shp/*.shp")
counties <- lapply(fn, read_sf)
names(counties) <- c("1810", "1820","1830","1840","1850","1860","1870","1880","1890","1900",
"1910","1920","1930","1940","1950","1960","1970","1980","1990","2000","2010")
server <- function(input, output, session) {
output$select_population <- renderUI({
selectInput(inputId = "population", label = "Demographics",
choices = choices, selected = "totalDens")
})
output$select_year <- renderUI({
selectInput(inputId = "year", label = "Year",
choices = names(counties))
})
output$map <- renderLeaflet({
req(input$population)
req(input$year)
map <- leaflet() %>%
addProviderTiles(provider = "CartoDB.Positron",
providerTileOptions(detectRetina = FALSE,
reuseTiles = TRUE,
minZoom = 4,
maxZoom = 8)) %>%
setView(lat = 43.25, lng = -94.30, zoom = 6)
map %>% draw_demographics(input, counties[[input$year]])
})
}
# try out various ways to get an acceptable color palette function
getpal <- function(cpop,nmax){
if (length(cpop)>1){
# try out value from nmax down to 1
for (n in nmax:1){
qpct <- 0:n/n
cpopcuts <- quantile(cpop,qpct)
# here we test to see if all the cuts are unique
if (length(unique(cpopcuts))==length(cpopcuts)){
if (n==1){
# The data is very very skewed.
# using quantiles will make everything one color in this case (bug?)
# so fall back to colorBin method
return(colorBin("YlGnBu",cpop, bins=nmax))
}
return(colorQuantile("YlGnBu", cpop, probs=qpct))
}
}
}
# if all values and methods fail make everything white
pal <- function(x) { return("white") }
}
draw_demographics <- function(map, input, data) {
cpop <- data[[input$population]]
if (length(cpop)==0) return(map) # no pop data so just return (much faster)
pal <- getpal(cpop,7)
map %>%
clearShapes() %>%
addPolygons(data = data,
fillColor = ~pal(cpop),
fillOpacity = 0.4,
color = "#BDBDC3",
weight = 1)
}
shinyApp(ui, server)
Here is the output:
The challenging case of Asian population distribution in 1890 - very highly skewed data with the population concentrated in three counties. This means that the getpal function will be forced to give up on colorQuantile and fall back on colorBin in order to show anything:

Leaflet popups not updating with input in R

I'm building a shinydashboard with a leaflet map display and am having difficulty showing popup text based on a user input. Here is the code so far (the "output$bar" part can be ignored as I haven't started working on that yet):
## app.R ##
library(shinydashboard)
library(shiny)
library(leaflet)
library(ggplot2)
refs <- read.csv('./BSAProjects/HurricaneModel/Data/monthlyrefinerymeanprod.csv', stringsAsFactors = FALSE)
hurs <- read.csv('./BSAProjects/HurricaneModel/Data/hurrdates.csv', stringsAsFactors = FALSE)
huricon <- makeIcon('http://www.youngsvillepolice.com/wp-content/uploads/2015/11/action-icon-HURRICANE.png',
iconWidth = 70,
iconHeight = 70)
ui <- dashboardPage(
dashboardHeader(title = 'Hurricane Model'),
dashboardSidebar(disable = TRUE),
dashboardBody(
fluidRow(
box(leafletOutput('leaflet'),
width = '100%')),
fluidRow(
box(selectInput('menu','Hurricane', choices = hurs$hurricane)),
box(plotOutput('bar', 'Production Levels'))
)
)
)
server <- function(input, output) {
colors <- colorFactor(rainbow(length(refs$SPRRegion)), refs$SPRRegion)
output$leaflet <- renderLeaflet({
map <- leaflet() %>%
addTiles(urlTemplate = 'http://server.arcgisonline.com/ArcGIS/rest/services/World_Street_Map/MapServer/tile/{z}/{y}/{x}') %>%
addCircleMarkers(~Longitude,
~Latitude,
popup = paste('<b>EIAID:</b>', refs$EIAID, '<br>',
'<b>SPR Refinery Group:</b>', refs$Refinery.Group, '<br>',
'<b>Refinery:</b>', refs$SprRespondentName, '<br>',
'<b>Capacity:</b>', refs$Capacity, 'MBbl/day'),
clusterOptions = markerClusterOptions(),
color = ~colors(SPRRegion),
data = refs) %>%
addMarkers(~longitude,
~latitude,
icon = huricon,
popup = paste('<b>Hurricane:</b>', hurs$hurricane,'<br>',
'<b>Date:</b>', hurs$date,'<br>',
'<b>HSI:</b>', hurs$hsi),
data = hurs[hurs$hurricane == input$menu,])
})
output$bar <- renderPlot({
bar <- ggplot(hurs, aes())
})
}
shinyApp(ui, server)
What I'm attempting to do is to allow the user to select a hurricane by the drop down menu created with "selectInput" in the UI object. That will then add a marker to the leaflet map with a popup containing the information I have in "addMarkers(popup =...)"
I can successfully get the functionality to place the marker on the leaflet map based on the drop down menu selection, but the popup text is always for the same hurricane that appears in the last row of the "hurs" data file. If I remove the line:
data = hurs[hurs$hurricane == input$menu,]
and have all the hurricanes plotted instead
data = hurs
then I have no problems. I don't have any problems with the labels updating in my "addCircleMarkers" object either so I suspect this has something to do with how the data set is being filtered based on the drop down menu.
Any ideas?
Figured this out after seeing a similar post here (How to subset a dataframe and plot with leaflet depending on inputselect in shiny).
It seems the issue is that the subsetted data needs to be produced outside of the call to "addMarkers." I was trying to subset within and was receiving this issue, but merely pulling it out and placing it immediately following the call to "renderLeaflet" worked:
server <- function(input, output) {
colors <- colorFactor(rainbow(length(refs$SPRRegion)), refs$SPRRegion)
output$leaflet <- renderLeaflet({
hur.subset <- subset(hurs, hurs$hurricane == input$menu) ##PLACED IT HERE
map <- leaflet() %>%
addTiles(urlTemplate = 'http://server.arcgisonline.com/ArcGIS/rest/services/World_Street_Map/MapServer/tile/{z}/{y}/{x}') %>%
addCircleMarkers(~Longitude,
~Latitude,
popup = paste('<b>EIAID:</b>', refs$EIAID, '<br>',
'<b>SPR Refinery Group:</b>', refs$Refinery.Group, '<br>',
'<b>Refinery:</b>', refs$SprRespondentName, '<br>',
'<b>Capacity:</b>', refs$Capacity, 'MBbl/day'),
clusterOptions = markerClusterOptions(),
color = ~colors(SPRRegion),
data = refs) %>%
addMarkers(~longitude,
~latitude,
icon = huricon,
popup = paste('<b>Hurricane:</b>', hur.subset$hurricane,'<br>',
'<b>Date:</b>', hur.subset$date,'<br>',
'<b>HSI:</b>', hur.subset$hsi),
data = hur.subset)
})
}

Leaflet choropleth maps in shiny - unable to use addPolygons function properly

I am new to writing shiny apps and new to using the leaflet package. I am trying to create a shiny app which will get user inputs and plot a choropleth map based on the aggregated values of the selected user variable.
My sample dataset has the following variables: statename latitude longitude countyname medianage asianpopulation otherpopulation
My app would ask the user to select from either username or countyname. Based on this selection, internally I group my dataset using statename or countyname.
Then the user selects either one or many from the variables: medianage asianpopulation otherpopulation.
Based on this, I want to plot the choropleth map on the sum of the values of these variables and show a table below with these values.
I am not able to use the addPolygons method to plot the map. Do I need to use a shape file for this? Where am I going wrong in this code?
library(dplyr)
library(shiny)
library(readr)
library(leaflet)
library(lazyeval)
library(rgdal)
setwd("E:/Data")
ui <- fluidPage(
titlePanel("Filters"),
sidebarLayout(
sidebarPanel(
radioButtons("level", "Select the Level", choices = c("State", "County"),selected = "State" ,inline = TRUE),
selectInput("variable", "Variable Name", choices = NULL, multiple = FALSE, selectize = TRUE, selected = "medianage")
),
mainPanel(
leafletOutput("map"),
dataTableOutput("heatmapdata")
)
)
)
server <- function(input, output, session) {
read_csv(file="Sample.csv") %>%
select(statename, latitude, longitude, countyname, medianage, asianpopulation, otherpopulation) -> heatmapData -> hd
variable = c()
group = c()
heatmapData <- data.frame(heatmapData)
hd <- heatmapData
heatmapdata_1 <- select(heatmapData, -c(latitude, longitude))
heatmapdata_2 <- select(heatmapdata_1, -c(statename, countyname))
updateSelectInput(session, "variable", choices = sort(unique(colnames(heatmapData))), selected = "medianage")
heatmapdata_2 <- heatmapdata_1
datasetLevel.group <- function(df, grp.var) {
df %>% group_by_(grp.var) %>%
summarise_each(funs(sum)) -> df
df
}
datasetLevel <- reactive({
heatmapdata_2 <- heatmapdata_1
inputvariable <- c("medianage")
if (input$level == "State") {
inputlevel = c("statename")
heatmapdata_2 <- select(heatmapdata_2, -c(countyname))
}
if (input$level == "County") {
inputlevel = c("countyname")
heatmapdata_2 <- select(heatmapdata_2, -c(statename))
}
sm <- datasetLevel.group(heatmapdata_2, inputlevel)
group <- inputlevel
variable <- inputvariable
l_hd <- list(sm, inputlevel, input$variable)
l_hd
})
output$map <- renderLeaflet(
{
leaflet() %>% addTiles(options=tileOptions(minZoom = 3, maxZoom = 10)) %>%
setView(lng = -98.35, lat = 39.5, zoom = 4) %>%
setMaxBounds( -180, 5, -52, 73)
}
)
output$heatmapdata <- renderDataTable(
select_(datasetLevel()[[1]], datasetLevel()[[2]], datasetLevel()[[3]]),
options = list(pageLength=5,
scrollX=TRUE,
lengthMenu = c(5, 10, 25, 100),
searching=FALSE)
)
observe({
pal <- colorQuantile("YlOrRd", NULL, n = 20)
leafletProxy("map", data = datasetLevel()[[1]]) %>%
clearMarkers() %>%
clearMarkerClusters() #%>%
# addPolygons(data = datasetLevel()[[1]],
# fillColor = ~pal(variable),
# fillOpacity = 0.8,
# color = "#BDBDC3",
# weight = 1)
})
}
shinyApp(ui = ui, server = server)
I have commented out the addPolygons code as I get an error with that. I have been breaking my head to get the maps color coded based on the aggregated values of the selected variable.
The data file can be found at: https://drive.google.com/file/d/0B4PQcgewfQ3-MF9lNjU4clpUcUk/view?usp=sharing
Any help on this will be really helpful. Thanks.

Resources