Related
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)
My shapefile has columns mean, median and sd and i want to draw a choropleth map in R Shiny. I have a sidebar that controls if tiles of map should display mean, median or sd. But I am not able to do it in Shiny. I tried using the reactive funtions but I keep getting the error below
Error: Polygon data not found; please provide addPolygons with data and/or lng/lat arguments
My code is below
library(shiny)
library(leaflet)
library(rgdal)
library(RColorBrewer)
val <- readOGR('exampleshapefile.shp')
mybins <- c(24,270,470,555,770,2000,Inf)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
radioButtons("stat", "Stat Type:",
c("Mean" = "mean",
"Median" = "q0_50",
"Standard Deviation" = "sd"
)
)
),
mainPanel("mainpanel",
leafletOutput("distSAM")
)
)
)
server <- function(input, output) {
###################### dist-wise
data <- eventReactive(input$stat,{
val#data$input$stat
})
pal <- reactive({
colorBin(palette="RdYlGn", domain = data(), na.color = "transparent", bins=mybins, reverse = TRUE)
})
labels <- reactive({
sprintf(
"<strong>%s<br/>%s</strong>%.1f",
val#data[["NAME_2"]], "SAM: ", data()
) %>% lapply(htmltools::HTML)
})
output$distSAM <- renderLeaflet({
df <- data()
pal <- pal()
lab <- labels()
leaflet() %>% addTiles() %>%
addPolygons(data = df,
fillColor = ~pal(mean),
weight = 2,
opacity = 1,
color = "white",
dashArray = "3",
fillOpacity = 0.7,
highlight = highlightOptions(
weight = 5,
color = "#666",
dashArray = "",
fillOpacity = 0.7,
bringToFront = TRUE),
label = lab,
labelOptions = labelOptions(
style = list("font-weight" = "normal", padding = "3px 8px"),
textsize = "15px",
direction = "auto")) %>%
addLegend(pal = pal, values = ~df$mean,
title = "SAM </br> Prevalence",
position = "bottomleft")
}
)
}
shinyApp(ui, server)
val#data$input$stat is not a valid data selection. Instead you can use:
selected_stat <- val[[input$stat]]
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)
I have the following R codes within the shiny framework. Everything looks good, but the legend (Plese see this screenshot).
I want the legend to be updated on the basis of the users' selection of age group (60+, 65+, 85+), sex, or year. But it is not the case. That is, the legend's values remain unchanged, no matter what is selected from the left menu (Please see this screenshot). This makes the map useless if the 85+ is selected. Following is my entire codes.
I appreciate your help.
Nader
load("/Users/nadermehri/Desktop/map codes/nhmap.RData")
library(shiny)
library(leaflet)
ui <- fluidPage(
tabPanel(
"Interactive Maps",
tags$h5 (
)),
br(),
sidebarLayout(
sidebarPanel(
selectInput(
inputId = "Age_Group_map",
label = "Select the Age Group:",
selected = "60+",
selectize = F,
multiple = F,
choices = sort(unique(nhmap$Age_Group))
),
radioButtons(
inputId = "sex_map",
label = strong("Select Sex:"),
selected = "Both Sexes",
choices = sort(unique(nhmap$Sex))
),
sliderInput(
inputId = "Year_map",
label = "Year",
min = 2010,
max = 2050,
value = 2010,
step = 10,
sep = "",
pre = "",
animate = animationOptions(
interval = 1000,
loop = F,
playButton = tags$button("Play", style =
"background-color: #B61E2E ; color:white; margin-top: 10px; border:solid"),
pauseButton = tags$button("Pause", style =
"background-color: #B61E2E !important; color:white; margin-top: 10px; border:solid")
),
round = T,
width = "150%",
ticks = T
)),
mainPanel("Interactive", leafletOutput("int_map", height=500))))
server <- function(input, output) {
mapdata_ <- reactive ({
nhmap$Per <- round(nhmap$Per, 1)
out_map <- nhmap %>%
filter (
Age_Group %in% input$Age_Group_map,
Sex %in% input$sex_map,
Year %in% input$Year_map)
return(out_map)
})
output$int_map <- renderLeaflet ({
leaflet (mapdata_(),
pal8 <- c("#FFFFE5", "#D9F0A3", "#78C679", "#006837") ,
pal <- colorBin(palette = pal8, domain = NULL, bins=quantile(nhmap$Per), na.color = "#808080", alpha = FALSE, reverse = F)) %>%
addProviderTiles("CartoDB.Positron") %>%
clearControls() %>%
clearShapes()%>%
addPolygons(fillColor = ~pal(Per),
stroke=T,
weight=1,
smoothFactor=0.2,
fillOpacity = 1,
color="black",
popup=~paste(NAME,"<br>",input$sex_map,
input$Age_Group_map,"=",Per,"%"),
highlightOptions = highlightOptions(color = "red",
weight = T,
bringToFront = T),
label=~NAME) %>%
addTiles() %>%
setView(-82.706838, 40.358615, zoom=7) %>%
addLegend(position = "bottomright",
values = ~Per,
pal = pal,
title = (paste("%",input$Age_Group_map, input$sex_map, "in", input$Year_map)) ,
labFormat = labelFormat(
))
})
}
shinyApp(ui = ui, server = server)
You have to define the bins in colorBin, at which you want to cut the data in the different color sections. Something like:
pal <- colorBin(palette = pal8, domain = NULL, bins=quantile(mapdata_()$Per),
na.color = "#808080", alpha = FALSE, reverse = F)
And you also have to remove bins= 4 from the addLegend call, as it will get the information from the color palette.
I created some random data for nhmap and it is working for me with this code:
library(shiny)
library(leaflet)
library(sf)
library(sp)
## Random Data #############
data(meuse, package = "sp")
nhmap <- st_as_sf(meuse, coords = c("x", "y"))
st_crs(nhmap) <- "+init=epsg:28992"
nhmap <- st_buffer(nhmap, 100)
n = length(nhmap$cadmium)
nhmap$Age_Group <- sample(c(15,19,25), size = n, T)
nhmap$Sex <- sample(c("m","f"), size = n, T)
nhmap$Per <- runif(n, 1, 150)
nhmap$NAME <- sample(c("a","b","c"), size = n, T)
nhmap$Age_Group <- sample(c(15,19,25), size = n, T)
nhmap$Year <- sample(c(2010,2020,2030, 2040, 2050), size = n, T)
nhmap <- st_transform(nhmap, 4326)
## UI ###########
ui <- {fluidPage(
tabPanel(
"Interactive Maps",
tags$h5 ()),
br(),
sidebarLayout(
sidebarPanel(
selectInput(
inputId = "Age_Group_map",
label = "Select the Age Group:",
# selected = "60+",
selectize = F,
multiple = F,
choices = sort(unique(nhmap$Age_Group))
),
radioButtons(
inputId = "sex_map",
label = strong("Select Sex:"),
# selected = "Both Sexes",
choices = sort(unique(nhmap$Sex))
),
sliderInput(
inputId = "Year_map",
label = "Year",
min = 2010,
max = 2050,
value = 2010,
step = 10,
sep = "",
pre = "",
animate = animationOptions(
interval = 1000,
loop = F,
playButton = tags$button("Play", style =
"background-color: #B61E2E ; color:white; margin-top: 10px; border:solid"),
pauseButton = tags$button("Pause", style =
"background-color: #B61E2E !important; color:white; margin-top: 10px; border:solid")
),
round = T,
width = "150%",
ticks = T
)),
mainPanel("Interactive", leafletOutput("int_map", height=500)))
)}
## SERVER ###########
server <- function(input, output) {
mapdata_ <- reactive ({
nhmap$Per <- round(nhmap$Per, 1)
# nhmap
nhmap %>%
filter (
Age_Group %in% input$Age_Group_map,
Sex %in% input$sex_map,
Year %in% input$Year_map)
})
output$int_map <- renderLeaflet ({
req(mapdata_())
pal8 <- c("#FFFFE5", "#D9F0A3", "#78C679", "#006837")
# pal <- colorBin(palette = pal8, domain = NULL, bins=quantile(mapdata_()$Per),
pal <- colorBin(palette = pal8, domain = NULL, bins=quantile(nhmap$Per),
na.color = "#808080", alpha = FALSE, reverse = F)
leaflet(data = mapdata_()) %>%
# leaflet(data = nhmap) %>%
clearControls() %>%
clearShapes()%>%
addProviderTiles("CartoDB.Positron") %>%
addTiles() %>%
addPolygons(fillColor = ~pal(Per),
stroke=T,
weight=1,
smoothFactor=0.2,
fillOpacity = 1,
color="black",
label=~NAME,
popup=~paste(NAME,"<br>",input$sex_map,
input$Age_Group_map,"=",Per,"%"),
highlightOptions = highlightOptions(color = "red",
weight = T,
bringToFront = T)) %>%
# setView(-82.706838, 40.358615, zoom=7) %>%
addLegend(position = "bottomright",
values = ~Per,
title = (paste("%",input$Age_Group_map, input$sex_map, "in", input$Year_map)),
pal = pal
)
})
}
shinyApp(ui = ui, server = server)
Here is the answer. As I mentioned in my the last comment, the pal needs to be reactive:
mapdata_ <- reactive ({
nhmap$Per <- round(nhmap$Per, 1)
out_map <- nhmap %>%
filter (
Age_Group %in% input$Age_Group_map,
Sex %in% input$sex_map,
Year %in% input$Year_map)
return(out_map)
list(Per)
})
mapdata_1 <- reactive ({
nhmap$Per <- round(nhmap$Per, 1)
out_map_1 <- nhmap %>%
filter (
Age_Group %in% input$Age_Group_map
)
return(out_map_1)
list(Per)
})
output$int_map <- renderLeaflet ({
pal8 <- c("#FFFFE5", "#D9F0A3", "#78C679", "#006837")
pal <- colorBin(palette = pal8, domain =NULL, bins=quantile(mapdata_1()$Per), na.color = "#808080", alpha = FALSE, reverse = F)
leaflet (mapdata_()) %>%
addProviderTiles("CartoDB.Positron") %>%
clearControls() %>%
clearShapes()%>%
addPolygons(fillColor = ~pal(Per),
stroke=T,
weight=1,
smoothFactor=0.2,
fillOpacity = 1,
color="black",
popup=~paste(NAME,"<br>",input$sex_map,
input$Age_Group_map,"=",Per,"%"),
highlightOptions = highlightOptions(color = "red",
weight = T,
bringToFront = T),
label=~NAME) %>%
addTiles() %>%
setView(-82.706838, 40.358615, zoom=7) %>%
addLegend(position = "bottomright",
values = ~Per,
pal = pal,
title = (paste("%",input$Age_Group_map, input$sex_map, "in", input$Year_map)) ,
labFormat = labelFormat(
))
})
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)