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

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.

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)

R Shiny & Leaflet, Create a shiny filter that can iterate through a list within a dataframe column

I have an input dataframe whose column values may contain a comma separated list. Is there a way to create a filter for shiny that can iterate through list within a dataframe?
Ideally a user should be able to view all three points, and filter through those points who have a PointUse of either farm, house, or even both.
Going back and creating a 'both' option in the source data is not an option.
Must stick with the just the two filter options, farm or house.
#############################################
# Needed Libraries & Input Files
library(shiny)
library(shinydashboard)
library(leaflet)
library(dplyr)
##The Data
Point_ID = c("A1", "B1", "C3")
Latitude = c(38.05, 39.08, 40.05)
Longitude = c(-107.00, -107.05, -108.00)
PointUse = I(list("farm", c("farm", "house"), "house")) # <- the column with the list entries
Map_DF <- data.frame(Point_ID, Latitude, Longitude, PointUse)
choiseList <- c("farm", "house")
#############################################
# UI
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(checkboxGroupInput(inputId = "PointUseInput", label = "Select Point Use", choices = choiseList, selected = choiseList)),
dashboardBody(fluidRow(leafletOutput(outputId = 'mapA')))
)
#############################################
# SERVER
server <- function(input, output, session) {
## The Filter
filter_df <- reactive({
Map_DF %>% filter(for(p in PointUse){p} %in% input$PointUseInput) # <- the filter
})
## Base Map Creation
output$mapA <- renderLeaflet({
leaflet() %>%
addProviderTiles(
providers$Esri.DeLorme,
options = providerTileOptions(
updateWhenZooming = FALSE,
updateWhenIdle = TRUE)
) %>%
setView(lng = -107.50, lat = 39.00, zoom = 7)
})
## Update Map with Filter Selection
observe({
leafletProxy("mapA", session) %>%
clearMarkers() %>%
addCircleMarkers(
data = filter_df(),
radius = 10,
color = "red",
lat = ~Latitude,
lng = ~Longitude,
popupOptions(autoPan = FALSE),
popup = ~paste("PointUse: ", filter_df()$PointUse))
})
}
############################################
shinyApp(ui = ui, server = server)
What about using a logical vector as an index instead of filter? See the code below where sapply is used to create a logical vector of the rows that match the input$PointUseInput value.
library(shiny)
library(shinydashboard)
library(leaflet)
##The Data
Point_ID = c("A1", "B1", "C3")
Latitude = c(38.05, 39.08, 40.05)
Longitude = c(-107.00, -107.05, -108.00)
PointUse = I(list("farm", c("farm", "house"), "house")) # <- the column with the list entries
Map_DF <- data.frame(Point_ID, Latitude, Longitude, PointUse)
choiseList <- c("farm", "house")
#############################################
# UI
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(checkboxGroupInput(inputId = "PointUseInput", label = "Select Point Use", choices = choiseList, selected = choiseList)),
dashboardBody(fluidRow(leafletOutput(outputId = 'mapA')))
)
#############################################
# SERVER
server <- function(input, output, session) {
## The Filter
filter_df <- reactive({
Map_DF[sapply(Map_DF$PointUse, function(p) {any(input$PointUseInput %in% p)}), ]
})
## Base Map Creation
output$mapA <- renderLeaflet({
leaflet() %>%
addProviderTiles(
providers$Esri.DeLorme,
options = providerTileOptions(
updateWhenZooming = FALSE,
updateWhenIdle = TRUE)
) %>%
setView(lng = -107.50, lat = 39.00, zoom = 7)
})
## Update Map with Filter Selection
observe({
leafletProxy("mapA", session) %>%
clearMarkers() %>%
addCircleMarkers(
data = filter_df(),
radius = 10,
color = "red",
lat = ~Latitude,
lng = ~Longitude,
popupOptions(autoPan = FALSE),
popup = ~paste("PointUse: ", filter_df()$PointUse))
})
}
############################################
shinyApp(ui = ui, server = server)
filter function expects a logical vector as an input. We can use map_lgl to map through the list column and any to show if at least one value in each row is equal to the input value.
Map_DF %>% filter(map_lgl(PointUse, ~any(. %in% input$PointUseInput)))

Double calls to plot/load functions in shiny app

I have an app with a map, dropdown, calendar and line plot (my real app is much bigger but I have simplified as much as I can). The problem with it is that when I modify any of the uicontrol features, the data loading and plotting routines run twice (as evidenced from the print statements). In the full app the plots display a reasonable amount of data so running them twice leads to poor performance.
The app is structured so that I can select 1 of 2 predefined points on the map and it will change the dropdown and graph. A new location can also be selected with the dropdown menu (which in turn updates the map). There is also a checkbox to lock the timeframe and when this is not selected the timeframe gets reset to the extents of the timeseries for the new location.
I have isolated the problem to the updateDateRangeInput that is called in the server.R file (line 35). I can comment this out and the problem goes away, but then I lose the functionality to reset the calendar to the new timeframe. Does anyone know how I can keep that functionality but stop the data loading and plotting code from running twice?
Example app below:
app.R
library(shiny)
library(rsconnect)
source('ui.R')
source('server.R')
ui <- ui_page()
server <- server_page(input, output, session)
shinyApp(ui=ui, server=server)
ui.R
library(shiny)
library(leaflet)
library(dygraphs)
inc_level <- 5
ui_page <- function(){
fluidPage(
titlePanel("TEST APP"),
sidebarLayout(
sidebarPanel(
leafletOutput('region_map'),
selectInput(inputId = "Site",label = "Pick a site",choices = c("A","B"), selected = "A"),
fluidRow(
column(6,
dateRangeInput(inputId = "timeframe",label="Select time range", start ="2015-07-01", end = "2016-07-01")),
column(4,checkboxInput(inputId = "lock_timeframe",label = "Lock Time Range"))
)
),
mainPanel(
tabsetPanel(
tabPanel("Plot 1", dygraphOutput(outputId = "plot1"))
)
)
)
)
}
server.R
library(shiny)
library(ggplot2)
library(dygraphs)
library(xts)
server_page <- function(input, output, session){
# Create Data -------------------------------------------------------------
Y1 <- c(21000, 23400, 26800)
Time1 <- startdate <- as.Date(c('2007-11-1','2008-3-25','2010-3-14'))
Y2 <- c(11000, 11400, 16800)
Time2 <- startdate <- as.Date(c('2001-11-1','2003-3-25','2005-3-14'))
Lat <-c(-39.095980, -39.605823)
Lon <- c(173.887903, 173.824561)
Site <- c("A","B")
# Extract Data -------------------------------------------------------
df1 <- reactive({
print("load data")
if (input$Site=="A"){
df1 <- data.frame(Time1, Y1)
}
else if (input$Site=="B"){
df1 <- data.frame(Time2, Y2)
}
names(df1) <- c("Time","Y")
if (1){ # IF YOU CHANGE THIS TO A 0 FUNCTIONLITY IS LOST BUT PROBLEM GOES AWAY
lockTest <- input$lock_timeframe
if (lockTest==FALSE){
updateDateRangeInput(session, "timeframe",
start = df1$Time[1],
end =df1$Time[length(df1$Time)])
}
}
df1 <- df1[df1$Time >= format(input$timeframe[1]) & df1$Time <= format(input$timeframe[2]),]
validate(need(nrow(df1)!=0, "No Data In Range"))
return(df1)
}) #%>% bindCache(input$Site) # I woudl like to cache based on location to stop reloading of data from file in the full app
# Line Plot --------------------------------------------------------
output$plot1 <- renderDygraph({
print("Plotting")
data <- df1()
data <- xts(x = data$Y, order.by = data$Time)
dyPlt <- dygraph(data,width = 800, height = 400)
})
# Plot Map -----------------------------------------------------
output$region_map <- renderLeaflet({
y <- Lat
x <- Lon
id <- Site
leaflet() %>%
addProviderTiles(providers$OpenStreetMap, options = providerTileOptions(noWrap = TRUE)) %>%
setView(lng = 174.051515, lat = -39.301619, zoom = 8) %>%
addCircleMarkers(lng = x, lat = y ,color="green", radius = 2, layerId = id, label = id,
labelOptions = labelOptions(noHide = F, direction = "bottom",
style = list("color" = "green","border-color" = "rgba(0,0,0,0.5)"))
)
})
# Map Click Behaviour -----------------------------------------------------
#When map is clicked: update map and change dropdown value
observeEvent(input$region_map_marker_click, {
event <- input$region_map_marker_click
updateSelectInput(session,
inputId = "Site",
label = "Pick a site",
choices = Site,
selected = event$id)
})
# Update map when a new site is selected from the dropdown
observeEvent(input$Site, {
update_markers()
})
# Function to redraw markers and highlight the selected location
update_markers <- function(){
y <- Lat
x <- Lon
id <- Site
sitInd <- id == input$Site
leafletProxy("region_map") %>% clearMarkers() %>% addCircleMarkers(lng = x, lat = y ,color="green", radius = 2, layerId = id, label = id,
labelOptions = labelOptions(noHide = F, direction = "bottom",
style = list("color" = "green","border-color" = "rgba(0,0,0,0.5)")),
options = list(zIndex = 200)) %>%
addCircleMarkers(lng = x[sitInd], lat = y[sitInd] ,color="blue", radius = 4, layerId = id[sitInd], label = id[sitInd],
labelOptions = labelOptions(noHide = F, direction = "bottom",
style = list("color" = "blue","border-color" = "rgba(0,0,0,0.5)")),
options = list(zIndex = 300) )
}
}

Reactive Shiny Application

I am trying to create an interactive shiny application that displays a leaflet plot based on a user's date and plot type specification. Ideally, I would like the user to specify whether they would like to view a state-wide or a county-wide plot. Then, based on their answers, I would like them to decide whether to use the regular data or the standardized data. After this, they would hit a submit button and the plot would render. I don't want the plot to render until the user presses the "Submit" action button. This is my idea so far, but it fails whenever I try to implement.
library(ggplot2)
library(shapefiles)
library(sp)
library(CARBayes)
library(leaflet)
library(rgdal)
library(leaflet)
library(shiny)
## County Data
dta <- read.csv()
## County Data (percentage)
perc <-read.csv()
## Date Specification Function
selectdates <- function(data, start, end){
keep <- data[, 1:5]
data <- data[, -c(1:5)]
tmp1 <- as.Date(names(data))
tmp2 <- which(tmp1 >= as.Date(start) & tmp1 <= as.Date(end))
tmp <- data[, tmp2]
Sum <- rowSums(tmp)
tmp <- cbind(keep, Sum)
return(tmp)
}
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("Mapping"),
tags$em(""),
tags$hr(),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
dateRangeInput("daterange", "Date Range:",
start = as.character(Sys.Date() - 6),
end = as.character(Sys.Date())),
selectInput("ptChoice", "Type of Plot:", choices = c("", "County-Wise", "State-Wise")),
selectInput("typeChoice", "Data Type:", choices = c("", "Raw", "Percentage")),
actionButton("submitButton", "Submit", class = "btn btn-primary")
),
# Display leaflet plot of cases
mainPanel(
leafletOutput("countyPlot"),
leafletOutput("statePlot")
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
observeEvent(input$ptChoice, {
req(input$ptchoice)
if(input$ptChoice == "County-Wide"){
hide("statePlot")
show("countyPlot")
}
else{
hide("countyPlot")
show("statePlot")
}
})
fdta <- eventReactive(input$typeChoice, {
if (input$typeChoice == "Raw"){
df <- selectdates(data = tmp, start = input$daterange[1], end = input$daterange[2])
row.names(df) <- df$FIPS
}else if (input$typeChoice == "Percentage"){
df <- selectdates(data = perc, start = input$daterange[1], end = input$daterange[2])
}else {return(NULL)}
df
})
observeEvent(input$submitButton, {
output$statePlot <- renderLeaflet({
## INSERT STATE PLOT CODE HERE
})
output$countyPlot <- renderLeaflet({
## Loads SHP and DBF File
shp <- read.shp()
dbf <- read.dbf()
sp <- combine.data.shapefile(data = fdta, shp = shp, dbf = dbf)
proj4string(sp) <- CRS("+proj=longlat +datum=WGS84 +no_defs")
sp <- spTransform(sp, CRS("+proj=longlat +datum=WGS84 +no_defs"))
colours <- colorNumeric(palette = "YlOrRd", domain = sp#data$Sum)
leaflet(sp) %>%
addTiles() %>%
addPolygons(
fillColor = ~ colours(Sum),
weight = 1,
opacity = 0.7,
color = "white",
dashArray = '3',
fillOpacity = 0.7,
highlight = highlightOptions(
weight = 5,
color = "#666",
dashArray = "",
fillOpacity = 0.7,
bringToFront = TRUE
)
) %>%
addLegend(
pal = colours,
values = sp#data$Sum,
opacity = 1,
title = "Count"
) %>%
addScaleBar(position = "bottomleft")
})
})
}
# Run the application
shinyApp(ui = ui, server = server)
You can put the two plots inside an observeEvent, if you want it only after someone clicks on submit button. To use the appropriate dataframe, create a reactive dataframe and then use it as dfa() to generate the appropriate plot. Try this
server = function(input, output) {
observeEvent(input$ptChoice,{
req(input$ptChoice)
if(input$ptChoice == "County-Wide"){
hide("statePlot")
show("countyPlot")
}else{
hide("countyPlot")
show("statePlot")
}
})
dfa <- eventReactive(input$typechoice, {
if (input$typechoice == "Regular") {
df <- dta
}else if (input$typechoice == "Standardized") {
df <- dta2
}else {return(NULL)}
df
})
observeEvent(input$submitButton,{
output$stateplot <- renderLeaflet({
state <- CODE FOR STATE PLOT
})
output$countyPlot <- renderLeaflet({
county <- CODE FOR COUNTY PLOT
})
})
}
You might want to have your leaflet plot be stored in reactiveValues (rv) - then, you can have one output for your plot, and show what is stored in rv.
To change the plot when the submit button is pressed, be sure to reference the input$submitButton with your observeEvent.
Here is a working example that can be adapted. You could use an additional function to generate the plots based on your input values.
library(ggplot2)
library(leaflet)
library(shiny)
ui = fluidPage(
titlePanel("Leaflet Plot"),
tags$em(""),
tags$hr(),
sidebarLayout(
sidebarPanel(
selectInput("plotChoice", "Type of Plot:", choices = c("", "Boston", "Chicago")),
actionButton("submitButton", "Submit", class = "btn btn-primary")
),
# Display leaflet plot of cases
mainPanel(
leafletOutput("leafletPlot")
)
)
)
server = function(input, output) {
rv <- reactiveValues(plot = NULL)
output$leafletPlot <- renderLeaflet({
rv$plot
})
observeEvent(input$submitButton, {
if (input$plotChoice == "Boston") {
rv$plot <- leaflet() %>% setView(lng = -71.0589, lat = 42.3601, zoom = 12) %>% addTiles()
} else {
rv$plot <- leaflet() %>% setView(lng = -87.6298, lat = 41.8781, zoom = 12) %>% addTiles()
}
})
}
shinyApp(ui = ui, server = server)

Changing Leaflet map according to input without redrawing

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)

Resources