Selecting markers based on characteristics in R - Leaflet - Shiny - r

I am writing a Leaflet map in R and integrating it with shiny. I have three questions to ask and the code will be at the bottom with the problems highlighted:
On this map, I have random markers, each representing an aquatic environment. I also have a drop-down list allowing you to select the specific environment you want, which will only select those markers corresponding to the environment. I have created the absolutePanel which allows you to do this but cannot get the script to select for the markers using the reactive function.
Not an important factor, but will be useful. I have highlighted the countries that contain the markers, but when you move the slider to select for the years and corresponding markers you want to view, "empty" countries still remain. As the markers are removed based on the year, I want the countries no longer containing markers to be highlighted. Also it seems very slow.
Only for interest sake, but is there a map like "OpenStreetMap.Mapink" that is completely in English?
Below is the data file linked, as well as the script for the map:
https://drive.google.com/drive/folders/10anPY-I-B13zTQ7cjUsjQoJDcMK4NCXb?usp=sharing
library(shiny)
library(leaflet)
library(maps)
library(htmltools)
library(htmlwidgets)
library(dplyr)
###############################
map_data <- read.csv("example1.csv", header = TRUE)
countries <- map_data %>%
distinct(DOI, Country.s., .keep_all = TRUE)
area_data <- map_data %>%
filter(Area.Site == "Area")
site_data <- map_data %>%
filter(Area.Site == "Site")
sampling_count <- count(site_data, "Country.s.")
country_count <- count(countries, "Country.s.")
bounds <- map("world", area_data$Country.s., fill = TRUE, plot = FALSE)
bounds$studies <- country_count$freq[match(gsub("\\:.*", "", bounds$names), country_count$Country.s.)]
bounds$sampling_points <- sampling_count$freq[match(gsub("\\:.*", "", bounds$names), sampling_count$Country.s.)]
bounds$year <- site_data$Publication_Year[match(gsub("\\:.*", "", bounds$names), site_data$Country.s.)]
ui <- bootstrapPage(
tags$style(type = "text/css", "html, body {width:100%;height:100%}"),
leafletOutput("map",
width = "100%",
height = "100%"),
################################
#Question 1
################################
absolutePanel(top = 5, right = 320,
selectInput("environment", "Sampling Source: ",
c("All" = "P&C",
"Surface Water" = "SW",
"Wastewater" = "WW",
"Sea Water" = "Sea"))),
################################
#Question 1
################################
absolutePanel(bottom = 5, right = 320,
sliderInput("year", "Publication Year(s)", min(site_data$Publication_Year), max(site_data$Publication_Year),
value = range(site_data$Publication_Year), step = 1, sep = "", width = 500))
)
server <- function(input, output, session) {
marker_data <- reactive({
site_data[site_data$Publication_Year >= input$year[1] & site_data$Publication_Year <= input$year[2],]
})
area_s_data <- reactive({
area_data[area_data$Publication_Year >= input$year[1] & area_data$Publication_Year <= input$year[2],]
})
border_data <- reactive({
bounds[bounds$year >= input$year[1] & bounds$year <= input$year[2],]
})
output$map <- renderLeaflet({
leaflet(map_data, options = leafletOptions(worldCopyJump = TRUE)) %>%
################################
#Question 3
################################
addProviderTiles("OpenStreetMap.Mapnik")
################################
#Question 3
################################
})
observe({
leafletProxy("map", data = marker_data()) %>%
clearMarkers() %>%
addAwesomeMarkers(lat = ~Latitude,
lng = ~Longitude,
label = ~paste(Aquatic_Environment_Type))
})
################################
#Question 2
################################
observe({
leafletProxy("map", data = area_s_data()) %>%
clearShapes() %>%
addCircles(lat = ~Latitude,
lng = ~Longitude,
radius = ~as.numeric(Area_Radius_Meter),
color = "blue",
weight = 1,
highlightOptions = highlightOptions(color = "red",
weight = 2,
bringToFront = TRUE)) %>%
addPolygons(data = bounds,
color = "red",
weight = 2,
fillOpacity = 0.1,
highlightOptions = highlightOptions(color = "black",
weight = 2,
bringToFront = TRUE))
################################
#Question 2
################################
})
}
shinyApp(ui, server)

Related

How to render a leaflet choropleth map in shiny?

I have successfully created an interactive choropleth map using Leaflet in R that projects a single variable across a set of polygons.
library(RSocrata)
library(rgdal)
library(leaflet)
library(sp)
library(dplyr)
#library(mapview)
area_bound <- rgdal::readOGR("https://data.cityofchicago.org/resource/igwz-8jzy.geojson")
area_bound$area_num_1 <- as.numeric(area_bound$area_numbe)
health <- read.socrata("https://data.cityofchicago.org/resource/iqnk-2tcu.json")
data_num <- as.data.frame(apply(health[3:29], 2, as.numeric))
data_num <- bind_cols(health[1:2], data_num)
health_area <- sp::merge(area_bound, data_num, by.x = "area_numbe", by.y = "community_area")
pal <- colorNumeric("viridis", NULL)
leaflet(health_area) %>%
addTiles() %>%
addPolygons(stroke = FALSE, smoothFactor = 0.3, fillOpacity = 1,
fillColor = ~pal(as.numeric(firearm_related)),
label = ~paste0(community, ": ", formatC(firearm_related, big.mark = ",")))
The health data set has multiple variables and I would like to create a shiny app that allows users to choose a different variable to produce a choropleth map. Using the code provided by Kyle Walker as a model for my server, I came up with the code below that allows users to choose from a list of two variables. Unfortunately I am having problems running it, getting a Warning: Error in min: invalid 'type' (list) of argument error. Any help in resolving this would be appreciated. I have also looked at the RStudio, Using Leaflet With Shiny tutorial, but the examples provided are not choropleth maps.
Here is my non-working code:
## app.R ##
library(shiny) # for shiny apps
library(leaflet) # renderLeaflet function
library(RSocrata)
library(rgdal)
library(sp)
library(dplyr)
area_bound <- rgdal::readOGR("https://data.cityofchicago.org/resource/igwz-8jzy.geojson")
area_bound$area_num_1 <- as.numeric(area_bound$area_numbe)
health <- read.socrata("https://data.cityofchicago.org/resource/iqnk-2tcu.json")
data_num <- as.data.frame(apply(health[3:29], 2, as.numeric))
data_num <- bind_cols(health[1:2], data_num)
health_area <- sp::merge(area_bound, data_num, by.x = "area_numbe", by.y = "community_area")
groups <- c("Breast Cancer" = "breast_cancer_in_females", "Firearm" = "firearm_related")
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
radioButtons(
inputId = "group",
label = "Select a group to map",
choices = groups
)
),
mainPanel(
leafletOutput("map", height = "600")
)
)
)
server = function(input, output) {
group_to_map <- reactive({
input$group
})
output$map <- renderLeaflet({
leaflet(options = leafletOptions(zoomControl = FALSE)) %>%
addProviderTiles(providers$Stamen.TonerLite) %>%
setView(lng = -87.623177,
lat = 41.881832,
zoom = 8.5)
})
observeEvent(input$group, {
pal <- colorNumeric("viridis", group_to_map)
leafletProxy("map") %>%
clearShapes() %>%
clearControls() %>%
addPolygons(data = group_to_map,
color = ~pal(),
weight = 0.5,
fillOpacity = 0.5,
smoothFactor = 0.2) %>%
addLegend(
position = "bottomright",
pal = pal,
values = group_to_map,
title = "% of population"
)
})
}
shinyApp(ui, server)
There are several issues with your shiny code. First, to refer to values from a reactive you have to call it like a function, i.e. you have to do group_to_map(). Next, group_to_map() is just a character. To use the data column whose name is stored in group_to_map() you have to do health_area[[group_to_map()]]. I also fixed the issue with your palette functions. Finally, note that I switched to sf for reading the geo data as I'm more familiar with sf objects:
## app.R ##
library(shiny) # for shiny apps
library(leaflet) # renderLeaflet function
library(RSocrata)
library(dplyr)
area_bound <- sf::st_read("https://data.cityofchicago.org/resource/igwz-8jzy.geojson")
health <- read.socrata("https://data.cityofchicago.org/resource/iqnk-2tcu.json")
health[3:29] <- lapply(health[3:29], as.numeric)
#> Warning in lapply(health[3:29], as.numeric): NAs introduced by coercion
health_area <- left_join(area_bound, health, by = c("area_num_1" = "community_area"))
groups <- c("Breast Cancer" = "breast_cancer_in_females", "Firearm" = "firearm_related")
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
radioButtons(
inputId = "group",
label = "Select a group to map",
choices = groups
)
),
mainPanel(
leafletOutput("map", height = "600")
)
)
)
server = function(input, output) {
group_to_map <- reactive({
input$group
})
output$map <- renderLeaflet({
leaflet(options = leafletOptions(zoomControl = FALSE)) %>%
addProviderTiles(providers$Stamen.TonerLite) %>%
setView(lng = -87.623177,
lat = 41.881832,
zoom = 8.5)
})
observeEvent(input$group, {
pal <- colorNumeric("viridis", range(health_area[[group_to_map()]]))
leafletProxy("map") %>%
clearShapes() %>%
clearControls() %>%
addPolygons(data = health_area,
color = ~pal(health_area[[group_to_map()]]),
weight = 0.5,
fillOpacity = 0.5,
smoothFactor = 0.2) %>%
addLegend(
position = "bottomright",
pal = pal,
values = health_area[[group_to_map()]],
title = "% of population"
)
})
}
shinyApp(ui, server)
#>
#> Listening on http://127.0.0.1:5938

Dynamic labels on leaflet map (shiny r)

So I've been trying to add a functionality on my leaflet map in Shiny dashboard where the user would be able to choose what the popup label would show through an input checkbox statement (in this case, they would choose whether they would want to see Area of Land or Area of Water or both - default is set to both). In other words, I would like to have a list of column options that I can choose from to show on the popup label when I hover over the map.
The code I have so far is below
library(dplyr)
library(readxl)
library(shinydashboard)
library(rgdal)
library(leaflet)
library(htmltools)
download.file('https://www2.census.gov/geo/tiger/GENZ2018/shp/cb_2018_us_county_5m.zip',
'cb_2018_us_county_5m.zip')
unzip('cb_2018_us_county_5m.zip',exdir='cb_2018_us_county_5m')
download.file('https://www2.census.gov/programs-surveys/popest/geographies/2019/all-geocodes-v2019.xlsx',
'all-geocodes-v2019.xlsx')
shapes <- rgdal::readOGR("cb_2018_us_county_5m","cb_2018_us_county_5m")
df_geo <- read_excel('all-geocodes-v2019.xlsx',skip=4) %>% # the table starts from row 5
filter(`Summary Level`=='040') %>%
select(`State Code (FIPS)`, `Area Name (including legal/statistical area description)`)
colnames(df_geo) <- c('STATEFP','STATENAME')
shapes#data <- shapes#data %>%
left_join(df_geo) %>%
mutate(ALAND = as.numeric(as.character(ALAND)),
AWATER = as.numeric(as.character(AWATER)),
content = paste0('<b>',NAME,' (',STATENAME,')</b>',
'<br>Area of Land: ', ALAND,
'<br>Area of Water: ', AWATER),
NAME = as.character(NAME))
shapes <- shapes[!is.na(shapes#data$STATENAME),] # remove shapes that are not in a state (e.g., Guam)
names_state <- sort(df_geo$STATENAME)
#### UI ####
header <- dashboardHeader(
title = "Leaflet - Layer Specific Legend",
titleWidth = 300
)
body <- dashboardBody(
fluidRow(
column(width=2,
selectInput("select_state", label='Select State:',
choices = names_state,
selected= 'New York'),
style='margin-left:20px;z-index:100000'
)
),
fluidRow(
column(width = 12,
box(width = NULL, height = 620,
leafletOutput("map",height=595),
status='warning')
)
)
)
ui <- dashboardPage(
title = "Leaflet - Layer Specific Legend",
skin = 'yellow',
header,
dashboardSidebar(disable = TRUE),
body
)
#### Server ####
server <- function(input, output, session) {
#### initialize reactive values ####
rvs <- reactiveValues(poly_state=shapes[shapes#data$STATENAME == 'New York',])
#### output ####
## output: leaflet map
output$map <- renderLeaflet({
rvs$map <- rvs$poly_state %>%
leaflet() %>%
addTiles('http://{s}.tile.openstreetmap.de/tiles/osmde/{z}/{x}/{y}.png') %>%
addPolygons(data = rvs$poly_state,
group = 'Area of Land',
weight=1, opacity = 1.0,color = 'white',
fillOpacity = 0.9, smoothFactor = 0.5,
fillColor = ~colorBin('OrRd',ALAND)(ALAND),
label = lapply(rvs$poly_state$content,HTML)) %>%
addPolygons(data = rvs$poly_state,
group = 'Area of Water',
weight=1, opacity = 1.0,color = 'grey',
fillOpacity = 0.9, smoothFactor = 0.5,
fillColor = ~colorBin('YlGnBu',AWATER)(AWATER),
label = lapply(rvs$poly_state$content,HTML)) %>%
addLayersControl(
position = "bottomright",
baseGroups = c('Area of Land','Area of Water'),
options = layersControlOptions(collapsed = TRUE)) %>%
addLegend(
"topright",
pal = colorBin('OrRd', rvs$poly_state$ALAND),
values = rvs$poly_state$ALAND
) %>%
hideGroup(c('Area of Land','Area of Water')) %>%
showGroup('Area of Land')
})
#### observe mouse events ####
## update rv when the selected state changes
observeEvent(input$select_state, {
rvs$poly_state <- shapes[shapes#data$STATENAME == input$select_state,]
})
## update legend when the selected layer group changes
observeEvent(input$map_groups, {
my_map <- leafletProxy("map") %>% clearControls()
if (input$map_groups == 'Area of Land'){
my_map <- my_map %>%
addLegend(
"topright",
pal = colorBin('OrRd', rvs$poly_state$ALAND),
values = rvs$poly_state$ALAND)
}else{
my_map <- my_map %>%
addLegend(
"topright",
pal = colorBin('YlGnBu', rvs$poly_state$AWATER),
values = rvs$poly_state$AWATER)
}
})
}
#### Run App ####
shinyApp(ui = ui, server = server)
First, you can create a data frame from your spatial data and edit your table. Here I delete the column "content".
shapes_df <- as.data.frame(shapes[,c(1:10)])
Then you create a reactive value that interacts with your input.
popup <- reactive({
return(shapes_df %>% select(input$select_column))
})
Here is a working code for you. I made some changes and commented some lines out.
library(dplyr)
library(readxl)
library(shinydashboard)
library(rgdal)
library(leaflet)
library(htmltools)
download.file('https://www2.census.gov/geo/tiger/GENZ2018/shp/cb_2018_us_county_5m.zip',
'cb_2018_us_county_5m.zip')
unzip('cb_2018_us_county_5m.zip',exdir='cb_2018_us_county_5m')
download.file('https://www2.census.gov/programs-surveys/popest/geographies/2019/all-geocodes-v2019.xlsx',
'all-geocodes-v2019.xlsx')
shapes <- rgdal::readOGR("cb_2018_us_county_5m","cb_2018_us_county_5m")
df_geo <- read_excel('all-geocodes-v2019.xlsx',skip=4) %>% # the table starts from row 5
filter(`Summary Level`=='040') %>%
select(`State Code (FIPS)`, `Area Name (including legal/statistical area description)`)
colnames(df_geo) <- c('STATEFP','STATENAME')
shapes#data <- shapes#data %>%
left_join(df_geo) %>%
mutate(ALAND = as.numeric(as.character(ALAND)),
AWATER = as.numeric(as.character(AWATER)),
content = paste0('<b>',NAME,' (',STATENAME,')</b>',
'<br>Area of Land: ', ALAND,
'<br>Area of Water: ', AWATER),
NAME = as.character(NAME))
shapes <- shapes[!is.na(shapes#data$STATENAME),] # remove shapes that are not in a state (e.g., Guam)
names_state <- sort(df_geo$STATENAME)
# here you can select which columns you want to add to your popup
shapes_df <- as.data.frame(shapes[,c(1:10)])
#### UI ####
header <- dashboardHeader(
title = "Leaflet - Layer Specific Legend",
titleWidth = 300
)
body <- dashboardBody(
fluidRow(
column(width=2,
selectInput("select_state", label='Select State:',
choices = names_state,
selected= 'New York'),
selectInput("select_column", label='Select the column you want to see in pop-up:',
choices = c(colnames(shapes#data))
),
verbatimTextOutput("output"),
style='margin-left:20px;z-index:100000'
)
),
fluidRow(
column(width = 12,
box(width = NULL, height = 620,
leafletOutput("map",height=595),
status='warning')
)
)
)
ui <- dashboardPage(
title = "Leaflet - Layer Specific Legend",
skin = 'yellow',
header,
dashboardSidebar(disable = TRUE),
body
)
#### Server ####
server <- function(input, output, session) {
rvs <- reactive({
shapes[shapes#data$STATENAME %in% input$select_state, ]
})
# we create a reactive value for popup which interacts with the input
popup <- reactive({
return(shapes_df %>% select(input$select_column))
})
#### initialize reactive values ####
#### output ####
## output: leaflet map
output$map <- renderLeaflet({
leaflet() %>%
addTiles('http://{s}.tile.openstreetmap.de/tiles/osmde/{z}/{x}/{y}.png') %>%
addPolygons(data = rvs(),
group = 'Area of Land',
weight=1, opacity = 1.0,color = 'white',
fillOpacity = 0.9, smoothFactor = 0.5,
fillColor = ~colorBin('OrRd',rvs()#data$ALAND)(rvs()#data$ALAND),
label = paste(
colnames(popup()),": ", popup()[,1]
)
)%>%
addPolygons(data = rvs(),
group = 'Area of Water',
weight=1, opacity = 1.0,color = 'grey',
fillOpacity = 0.9, smoothFactor = 0.5,
fillColor = ~colorBin('YlGnBu',rvs()#data$AWATER)(rvs()#data$AWATER),
label = paste(
colnames(popup()),": ", popup()[,1]
)
) %>%
addLayersControl(
position = "bottomright",
baseGroups = c('Area of Land','Area of Water'),
options = layersControlOptions(collapsed = TRUE)) %>%
addLegend(
"topright",
pal = colorBin('OrRd', rvs()#data$ALAND),
values =rvs()#data$ALAND
) %>%
hideGroup(c('Area of Land','Area of Water')) %>%
showGroup('Area of Land')
})
#### observe mouse events ####
## update rv when the selected state changes
# observeEvent(input$select_state, {
# rvs()#data <- shapes[shapes#data$STATENAME == input$select_state,]
# })
## update legend when the selected layer group changes
observeEvent(input$map_groups, {
my_map <- leafletProxy("map") %>% clearControls()
if (input$map_groups == 'Area of Land'){
my_map <- my_map %>%
addLegend(
"topright",
pal = colorBin('OrRd', rvs()#data$ALAND),
values = rvs()#data$ALAND)
}else{
my_map <- my_map %>%
addLegend(
"topright",
pal = colorBin('YlGnBu', rvs()#data$AWATER),
values = rvs()#data$AWATER)
}
})
}
#### Run App ####
shinyApp(ui = ui, server = server)

Chloropleth map shading in Shiny Leaflet Input slider based on column of large spatial polygons Dataframe

I am trying to create a Shiny Leaflet map with slider input based on the years listed in the columns. The data component of the Large SpatialPolygonsDataFrame looks like this with the postcode on the side and years as column names:
I am wanting to create a slider using the P2015 to P2020 columns.
How do I get the map to change the colours when a different input year is selected?
I'm not sure I understand how to use the reactive function properly.
Here is the code that I currently have:
ui <- fillPage(
titlePanel("Title"),
tags$style(type = "text/css", "html, body {width:100%; height:100%}"),
leafletOutput("mymap", width = "100%", height = "100%"),
absolutePanel(top = 10, right = 10,
sliderInput("year", "Year", min = 2015, max = 2020,
value = 2015, step = 1)
)
)
server <- function(input, output, session) {
LargeSpatialPDF <- rgdal::readOGR("~/blah.geojson")
output$mymap <- renderLeaflet({
leaflet(LargeSpatialPDF ) %>%
addMapPane(name="polygons", zIndex = 410) %>%
setView( lat=-32.30, lng=116.5 , zoom=9.45) %>%
addProviderTiles(providers$Esri.WorldGrayCanvas) %>%
addProviderTiles(providers$Stamen.TonerLabels,
options = leafletOptions(pane = "maplabels"),
group = "map labels")
})
#not sure how to use this reactive statement here?
layer <- reactive({LargeSpatialPDF})
observeEvent({input$year}, {
year_column <- paste0('P',input$year)
data=layer()[year_column]
bins <- c(0,1,5, 10,15,20,25,30,Inf)
pal <- colorBin(c("#fff7cf",
"#f7e2af",
"#f2cc91",
"#eeb576",
"#eb9c60",
"#e7824e",
"#e36543",
"#dd433d",
"#d6003d"), domain = LargeSpatialPDF#data[year_column], bins = bins)
leafletProxy("mymap", data = data) %>%
addPolygons(
fillColor = ~pal(x),
weight = 1,
opacity = 1,
color = "white",
dashArray = "3",
fillOpacity = 0.7,
highlight = highlightOptions(
weight = 2,
color = "white",
dashArray = "",
fillOpacity = 1,
bringToFront = TRUE),
label = labels,
labelOptions = labelOptions(
style = list("font-weight" = "normal", padding = "3px 8px"),
textsize = "15px",
direction = "auto"))
})
}
shinyApp(ui = ui, server = server)
reactive isn't necessary because LargeSpatialPDF is static.
I think the problems of your code are:
Whrere does x come from in fillColor = ~pal(x) ??
not df["colname"] but df[["colname"]] gives a vector.
clearShapes() is necessary.
Below is my example:
library(shiny)
library(leaflet)
library(sp)
ui <- fillPage(
titlePanel("Title"),
leafletOutput("mymap", width = "100%", height = "100%"),
absolutePanel(top = 10, right = 10,
sliderInput("year", "Year", min = 1, max = 3,
value = 1, step = 1)
)
)
server <- function(input, output, session) {
# sample_data
dsn <- system.file("vectors/ps_cant_31.MIF", package = "rgdal")[1]
LargeSpatialPDF <- rgdal::readOGR(dsn=dsn, layer="ps_cant_31", stringsAsFactors=FALSE)
set.seed(1); LargeSpatialPDF#data <- cbind(LargeSpatialPDF#data,
data.frame(P1 = sample(44), P2 = sample(44), P3 = sample(44)))
output$mymap <- renderLeaflet({
leaflet() %>%
addMapPane(name="polygons", zIndex = 410) %>%
setView( lat=43.5, lng=1.5 , zoom=8 ) %>%
addProviderTiles(providers$Esri.WorldGrayCanvas) %>%
addProviderTiles(providers$Stamen.TonerLabels,
options = leafletOptions(pane = "maplabels"),
group = "map labels")
})
observeEvent({input$year}, {
year_column <- paste0('P',input$year)
bins <- seq(0, 45, length = 9)
pal <- colorBin(c("#fff7cf",
"#f7e2af",
"#f2cc91",
"#eeb576",
"#eb9c60",
"#e7824e",
"#e36543",
"#dd433d",
"#d6003d"), domain = LargeSpatialPDF#data[[year_column]], bins = bins)
leafletProxy("mymap") %>%
clearShapes() %>% # important
addPolygons(
data = LargeSpatialPDF,
fillColor = ~ pal(LargeSpatialPDF#data[[year_column]]), # use values of the year
options = pathOptions(pane = "polygons")) # my guess
})
}
shinyApp(ui = ui, server = server)

How to change circle marker color in leaflet when I select a row in the table in Shiny?

So I want to change the CircleMarker colour in Leaflet map when I select a row in the table. I didn't get any errors but nothing happens. I don't know how to create and apply the reactive function properly in my Shiny app.
I tried to create a reactive function when a row is selected in the table and apply it to a separate leaflet proxy and leaflet map.
library(shiny)
library(DT)
library(dplyr)
library(leaflet)
library(leaflet.extras)
# Define UI
ui <- fluidPage(
# Application title
titlePanel("Quakes Test"),
# Sidebar with numericInput for quakes depth range
sidebarLayout(
sidebarPanel(
numericInput(inputId = "min_depth", label = "Mininum depth", value = min(quakes$depth), min = min(quakes$depth), max = max(quakes$depth)),
numericInput(inputId = "max_depth", label = "Maximum depth", value = max(quakes$depth), min = min(quakes$depth), max = max(quakes$depth))
),
# Show a map
mainPanel(
fluidRow(
leafletOutput("mymap_occ", width = "98%", height = 500))
)
),
fluidRow(DT::dataTableOutput(outputId = "prop_table"))
)
server <- function(input, output) {
#filter terrains
depth_final <- reactive({
obj <- quakes
if (input$min_depth != "All") {
obj <- quakes %>%
filter(depth >= as.numeric(input$min_depth)) %>%
filter(depth <= as.numeric(input$max_depth))
}
})
#row selected in table
table2_bat <- reactive({
data <- depth_final()
data <- data[input$prop_table, ]
})
output$prop_table <- renderDT({
datatable(depth_final(), extensions = 'Buttons', rownames = FALSE, escape = FALSE, selection = 'single')
})
#row selected map
observe({
leafletProxy("mymap_occ", data = table2_bat()) %>%
clearGroup(group = "FOO") %>%
addCircleMarkers(lng = ~long, lat = ~lat,
color = "white", fillColor = "yellow", opacity = 1, fillOpacity = 1,
radius = 5, weight = 20, group = "FOO")
})
#map
observe({
leafletProxy("mymap_occ", data = depth_final()) %>%
clearGroup(group = "FOO_2") %>%
addCircleMarkers(lng = ~long, lat = ~lat,
color = "white", fillColor = "red", opacity = 1, fillOpacity = 0.75,
radius = 5, weight = 2, group = "FOO_2")
})
output$mymap_occ <- renderLeaflet({
leaflet(table2_bat()) %>%
fitBounds(~min(long), ~min(lat), ~max(long), ~max(lat)) %>%
addProviderTiles(providers$Esri.WorldImagery, group = "Vue satellite") %>%
addProviderTiles(providers$Stamen.TonerLabels, group = "Vue satellite")
})
output$mymap_occ <- renderLeaflet({
leaflet(depth_final()) %>%
fitBounds(~min(long), ~min(lat), ~max(long), ~max(lat)) %>%
addProviderTiles(providers$Esri.WorldImagery, group = "Vue satellite") %>%
addProviderTiles(providers$Stamen.TonerLabels, group = "Vue satellite")
})
}
shinyApp(ui = ui, server = server)
First. You have to use eventReactive instead of reactive to trigger an action based on an event, i.e. when the user selects a row. Second. To get the index of the selected row you have to use input$prop_table_rows_selected (see here) instead of input$prop_table. input$prop_table does not exist, i.e. it returns NULL. Hence, to make your app work try this:
#row selected in table
table2_bat <- eventReactive(input$prop_table_rows_selected, {
data <- depth_final()
data <- data[input$prop_table_rows_selected, ]
})

Leaflet Shiny Integration slow

I am trying to build an interactive Choropleth in Shiny using leaflet. However, the load time and recreate time is really slow. Any way to speed it up.
Here is a link to the entire app folder along with the data:
https://www.dropbox.com/home/Leaflet_Shiny_app
global.R
library(shinydashboard)
library(tidyverse)
library(ggvis)
library(leaflet)
library(WDI)
library(sp)
ui.R
header <- dashboardHeader(
title = "Greenhouse gas (GHG) emissions"
)
## Sidebar content
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Interactive Choropleth", tabName = "choropleth")
)
)
## Body content
body <- dashboardBody(
# First tab content
tabItem("choropleth",
fluidRow(
column(width = 9,
box(width = NULL, solidHeader = TRUE,
title = "Greenhouse gas emissions (kt of CO2 equivalent)",
leafletOutput("choropleth_ghg", height = 500)
)
),
column(width = 3,
box(width = NULL, status = "warning",
selectInput("year", "Year",
choices = seq(1970, 2012, 1),
selected = 2012)
)
)
)
)
)
dashboardPage(
header,
sidebar,
body
)
server.R
# Read the dataset for choropleth
# From http://data.okfn.org/data/core/geo-countries#data
countries <- geojsonio::geojson_read("json/countries.geojson", what = "sp")
# Download the requested data by using the World Bank's API,
# parse the resulting JSON file, and format it in long country-year format.
load("who_ghg.RData")
function(input, output, session) {
# Interactive Choropleth map.........................................................
# Reactive expression for the data subsetted to what the user selected
countries_plus_ghg <- reactive({
# Filter the data to select for the year user selected
who_ghg_subset <- filter(who_ghg, year == input$year)
# Merge a Spatial object having a data.frame for Choropleth map
sp::merge(countries, who_ghg_subset,
by.x = "ISO_A3", by.y = "iso3c")
})
# Create the map
output$choropleth_ghg <- renderLeaflet({
leaflet(countries) %>%
setView(0, 20, zoom = 1) %>%
addTiles()
})
# Observer to change the color of countries, labels and legends
# based on the year user selects in the UI
observe({
dat <- countries_plus_ghg()
# Define numeric vector bins to add some color
bins <- ggplot2:::breaks(c(min(dat$EN.ATM.GHGT.KT.CE, na.rm = TRUE)
,max(dat$EN.ATM.GHGT.KT.CE, na.rm = TRUE)),
"width",n = 5)
# Call colorBin to generate a palette function that maps the RColorBrewer
#"YlOrRd" colors to our bins.
pal <- colorBin("YlOrRd",
domain = dat$EN.ATM.GHGT.KT.CE,
bins = bins)
# Generate the labels with some HTML
labels <- sprintf(
"<strong>%s</strong><br/>%g",
dat$country, dat$EN.ATM.GHGT.KT.CE
) %>% lapply(htmltools::HTML)
leafletProxy("choropleth_ghg", data = dat) %>%
addPolygons(
fillColor = ~pal(EN.ATM.GHGT.KT.CE),
weight = 1,
opacity = 1,
color = "white",
fillOpacity = 0.7,
highlight = highlightOptions(
weight = 2,
color = "#666",
dashArray = "",
fillOpacity = 0.7,
bringToFront = TRUE),
label = labels,
labelOptions = labelOptions(
style = list("font-weight" = "normal", padding = "3px 8px"),
textsize = "15px",
direction = "auto")) %>%
clearControls() %>%
addLegend(pal = pal, values = ~EN.ATM.GHGT.KT.CE, opacity = 0.7, title = NULL,
position = "bottomleft")
})
}
Simplifying geometries using rmapshaper::ms_simplify helped make it a lot faster.
This is what I did-
# Topologically-aware geometry simplification using rmapshaper package,
# keep = proportion of points to retain
countries_simple <- rmapshaper::ms_simplify(countries, keep = 0.05, keep_shapes = TRUE)
I used countries_simple instead of countries in the code then.

Resources