So I just started using R and am trying to make a leaflet app that responds to my user input in the sliders. I have tried to subset the data I am using by using the input from my slider, but it is not working. I get an error 'invalid 'type' (list) of argument'.
I have attached my code below:
titlePanel("Hello Shiny!"),
sidebarLayout(
sidebarPanel(
selectizeInput(inputId = 'lsoa',
label = 'Choose your lsoa',
choices = c('Ealing' = 'ealing',
'Camden' = 'camden') ,
selected = 'camden', multiple = TRUE),
uiOutput(outputId = 'time_var'),
sliderInput("Date_of_year",
"Dates",
min = as.Date("2017-09-01","%Y-%m-%d"),
max = as.Date("2018-07-31","%Y-%m-%d"),
value=as.Date("2017-09-01"),
timeFormat="%Y-%m-%d"),
uiOutput(outputId = 'datevar'),
sliderInput("slider_hours", "Hours:", min=0, max=23, value=0, step = 1),
uiOutput(outputId = 'hour_var')
# sliderInput("slider_mins", "Mins:",min = 0, max = 45, value = 0, step = 15),
#
# uiOutput(outputId = 'min_var')
),
mainPanel(
leafletOutput(outputId = "map")
)
)
)
server <- function(input, output) {
output$map <- renderLeaflet({
m <- leaflet() %>%
addTiles()%>%
setView(lng = -0.1911, lat = 51.5371, zoom = 11)%>%
addMarkers(data = subset(noise_sample, hour_time == input$slider_hours ),
lng = ~longitude,
lat = ~latitude,
popup = ~as.character(lpaeq_T),
label = ~as.character(lsoa11nm))%>%
addPolygons(data = subset(main_shape, grepl(paste(input$lsoa, collapse = '|'),
tolower(lsoa11nm))),
color = "#444444",
weight = 1,
smoothFactor = 0.5,
opacity = 1.0,
fillOpacity = 0.5)
m
})
}
shinyApp(ui, server)
Here 'hour_time' is the name of the column in my noise_sample data. It should just give a number, which should be the same as that selected by my slider_hours.
It's working but you can add a "validate" function in the server part in case your selection is empty :
noise_sample <- tibble("longitude" = c(-0.1914,-0.1943), "latitude"= c(51.5371,51.6),
"lpaeq_T"= c("toto","tata"), "lsoa11nm"= c("toto","tata"),
"hour_time" = c(1,2))
ui <- fluidPage(
titlePanel("Hello Shiny!"),
sidebarLayout(
sidebarPanel(
selectizeInput(inputId = 'lsoa',
label = 'Choose your lsoa',
choices = c('Ealing' = 'ealing',
'Camden' = 'camden') ,
selected = 'camden', multiple = TRUE),
uiOutput(outputId = 'time_var'),
sliderInput("Date_of_year",
"Dates",
min = as.Date("2017-09-01","%Y-%m-%d"),
max = as.Date("2018-07-31","%Y-%m-%d"),
value=as.Date("2017-09-01"),
timeFormat="%Y-%m-%d"),
uiOutput(outputId = 'datevar'),
sliderInput("slider_hours", "Hours:", min=0, max=23, value=1, step = 1),
uiOutput(outputId = 'hour_var')
# sliderInput("slider_mins", "Mins:",min = 0, max = 45, value = 0, step = 15),
#
# uiOutput(outputId = 'min_var')
),
mainPanel(
leafletOutput(outputId = "map")
)
)
)
server <- function(input, output) {
output$map <- renderLeaflet({
data1 <- subset(noise_sample, hour_time == input$slider_hours)
validate(
need(dim(data1)[1] >0, "No data")
)
m <- leaflet() %>%
addTiles()%>%
setView(lng = -0.1911, lat = 51.5371, zoom = 11)%>%
addMarkers(data = data1,
lng = ~longitude,
lat = ~latitude,
popup = ~as.character(lpaeq_T),
label = ~as.character(lsoa11nm))
# %>%
# addPolygons(data = subset(main_shape, grepl(paste(input$lsoa, collapse = '|'),
# tolower(lsoa11nm))),
# color = "#444444",
# weight = 1,
# smoothFactor = 0.5,
# opacity = 1.0,
# fillOpacity = 0.5)
m
})
}
shinyApp(ui, server)
Related
Using the code below, I could create my shiny app. When users select "yes" instead of "No", I would like the map to display only zip codes with at least 500 participants. As shown in the picture, "no" is selected by default.
I think I need some conditional statements to subset the data, but I dont know how to make this possible!
ui <- fluidPage(
fluidRow(
sidebarPanel(width=2,
radioButtons(
inputId = "ProjectID",
label = strong("Project ID"),
selected = "18",
choices = sort(unique(IDD_nhmap$ProjectID))
),
selectInput(
inputId = "Zip",
label = "Zip Codes With atleast 500 participants",
selected = "No",
selectize = TRUE,
multiple = FALSE,
choices = c("Yes", "No")),
),
######################
mainPanel(
fluidRow(
column(width = 6, shinyjs::useShinyjs(), leafletOutput("IDD_int_map1", height = "500px"))
)
), # this closes mainPanel
), # this closes fluidRow
br(),
br()
) # this closes ui
####################################
server <- function(input, output, session) {
#ACS_Blacks
IDD_mapdata_ <- reactive ({
out_map <- IDD_nhmap %>%
filter (ProjectID %in% input$ProjectID)
return(out_map)
list(Zip_Black)
})
IDD_mapdata_1 <- reactive ({
out_map_1 <- lat_long %>%
filter (ProjectID %in% input$ProjectID)
return(out_map_1)
list(lat)
})
output$IDD_int_map1 <- renderLeaflet ({
npal2 <- colorNumeric(palette = "Greens",
domain = IDD_nhmap$Zip_Black)
labels <- sprintf(
"<strong>Zip Code=%s </strong> <br/> Count = %s <br/> Percentage = %s ",
IDD_mapdata_()$Zip,
IDD_mapdata_()$Zip_Black,
IDD_mapdata_()$state_black
) %>%
lapply(htmltools::HTML)
leaflet (IDD_mapdata_(), options = leafletOptions(zoomSnap = 0.25, zoomDelta =
0.25)) %>%
addProviderTiles("CartoDB.Positron",
options = providerTileOptions(opacity = 2)) %>% # you need this and ()to remove the backgroun (Mexico/Canda)
clearControls() %>%
clearShapes() %>%
addPolygons(
fillColor = ~npal2(Zip_Black),
stroke = T,
weight = 1,
smoothFactor = 0.2,
fillOpacity = 1,
color = "black",
label = labels,
labelOptions = labelOptions(
interactive = TRUE,
style = list(
'direction' = 'auto',
'color' =
'black',
'font-family' = 'sans-serif',
# 'font-style'= 'italic',
'box-shadow' = '3px 3px rgba(0,0,0,0.25)',
'font-size' = '14px',
'border-color' = 'rgba(0,0,0,0.5)'
)
),
highlightOptions = highlightOptions(
weight = 2,
bringToFront = T,
# color = "#666",
fillOpacity = 0.7
)
) %>%
setView(lng = IDD_mapdata_1()$long,
lat = IDD_mapdata_1()$lat,
zoom = 8) %>%
addLegend(
position = "topright",
opacity = 1,
values = IDD_nhmap$Zip_Black,
# colors= c("#FFFFE5", "#D9F0A3", "#78C679", "#006837"),
pal = npal2,
#title = (paste("%",input$ProjectID)) ,
#title = (paste("%",input$ProjectID)) ,
title = (paste("African American (ACS)")) ,
labFormat = labelFormat()
) %>%
addTiles(options = tileOptions(opacity = 2)) # you need this to remove the backgroun (Mexico/Canda)
})
}
shinyApp(ui, server)
Approach 1: checkbox input as filter/subset logic
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
checkboxInput("fltr", "Filter mpg above 18", value = TRUE)
),
mainPanel(
plotOutput("plot")
)
)
)
server <- function(input, output, session) {
output$plot <- renderPlot({
subset(mtcars, input$fltr | mpg <= 18) |>
plot(mpg ~ disp, data = _)
})
}
shinyApp(ui, server)
Approach 2: reactive data
This approach might be preferred if multiple components (e.g., plots, tables) use the same optionally-filtered data.
server <- function(input, output, session) {
mydat <- reactive({
dat <- mtcars
if (isTRUE(input$fltr)) {
dat <- subset(dat, mpg <= 18)
}
dat
})
output$plot <- renderPlot({
plot(mpg ~ disp, data = req(mydat()))
})
}
I am putting together an Shiny app to allow users to upload an area of interest (AOI), and calculate the amount of overlap with an administrative boundary (WMU). Everything is working as desired, except that my picker input options do not update. The picker input works, but I would like the choices to only include the WMU that overlap the AOI instead of all possible WMU. I can calculate the WMU ID that should populate the list, shown in the "TEST_TEXT"output below the map frame, but cannot successfully update the pickerInput. This kmz will overlap the several WMU that are loaded at the beginning of the script included below:
library(shiny)
library(sf)
library(tidyverse)
library(bcdata)
library(shinyjs)
library(leaflet)
library(mapview)
library(DT)
library(pals)
library(shinyWidgets)
library(shinymanager)
WMU_DATA <-
bcdc_get_data("wildlife-management-units") %>% st_transform(4326) %>% mutate(Total.WMU.HA =
as.numeric(st_area(.)) / 10000)
##### UI #####
ui <- fluidPage(
tags$head(tags$style(
HTML(
".shiny-notification {
height: 100px;
width: 400px;
position:fixed;
top: calc(25% - 50px);;
left: calc(50% - 200px);;
}
"
)
)),
# Application title
titlePanel("Calculate Overlap With WMU"),
# Inputs
sidebarLayout(
sidebarPanel(
width = 3,
textInput(
inputId = "AOI_NAME",
label = "AOI Name",
value = NULL
),
HTML("<br><br>"),
fileInput(
inputId = "KMZ",
label = "Choose KMZ",
multiple = FALSE,
accept = c('.kmz')
),
h3("or"),
HTML("<br><br>"),
fileInput(
inputId = "SHAPEFILE",
label = "Choose shapefile",
multiple = TRUE,
accept = c('.shp', '.dbf', '.sbn', '.sbx', '.shx', '.prj', '.xml')
),
pickerInput(
inputId = "WMU_FILTER",
label = "Filter Overlapping WMU",
choices = unique(WMU_DATA$WILDLIFE_MGMT_UNIT_ID),
selected = unique(WMU_DATA$WILDLIFE_MGMT_UNIT_ID),
multiple = TRUE,
options = list(`actions-box` = TRUE)
),
HTML("<br><br>")
),
# Display OUtputs
mainPanel(
width = 9,
leafletOutput("OVERLAP_MAP", height = 750),
h3(textOutput("TEST_TEXT")),
DTOutput("AOI_OVERLAP_TABLE")
)
)
)
######server#####
server <- function(input, output, session) {
####reactive data
AOI <-
reactive({
if (is.null(input$SHAPEFILE) & !is.null(input$KMZ)) {
st_read(unzip(input$KMZ$datapath)) %>%
st_zm(drop = T) %>%
mutate(AOI_NAME = input$AOI_NAME) %>%
st_transform(4326) %>%
select(-Name)
}
else if (!is.null(input$SHAPEFILE) & is.null(input$KMZ)) {
SHAPEFILE()
}
else{
return(NULL)
}
})
WMU_OVERLAP <- reactive({
st_filter(WMU_DATA, AOI())
})
AOI_WMU_INTERSECT <-
reactive({
st_intersection(AOI(), WMU_OVERLAP()) %>%
mutate(`HA of Overlap` = round(as.numeric(st_area(.)) / 10000, 0)) %>%
mutate(`Percent of WMU` = round(`HA of Overlap` / `Total.WMU.HA` *
100, 2))
})
observeEvent(AOI_WMU_INTERSECT
,
{
updatePickerInput(
session,
"WMU_FILTER",
choices = unique(AOI_WMU_INTERSECT()$WILDLIFE_MGMT_UNIT_ID),
selected = unique(AOI_WMU_INTERSECT()$WILDLIFE_MGMT_UNIT_ID)
)
},
ignoreInit = TRUE,
ignoreNULL = TRUE)
###outputs
output$OVERLAP_MAP <-
renderLeaflet({
withProgress(message = "Calcualting Overlap", detail = "Should be done soon", {
AOI_SPATIAL <- AOI() %>% mutate(AOI_NAME = input$AOI_NAME)
WMU <-
WMU_OVERLAP() %>% filter(WILDLIFE_MGMT_UNIT_ID %in% input$WMU_FILTER)
Overlap <-
AOI_WMU_INTERSECT() %>% filter(WILDLIFE_MGMT_UNIT_ID %in% input$WMU_FILTER)
MAP <-
mapview(
Overlap,
zcol = "WILDLIFE_MGMT_UNIT_ID",
alpha.regions = 0.2,
map.types = c("Esri.WorldTopoMap", "Esri.WorldImagery"),
col.regions = alphabet(nlevels(
as.factor(WMU$WILDLIFE_MGMT_UNIT_ID)
))
) +
mapview(
WMU,
zcol = "WILDLIFE_MGMT_UNIT_ID",
alpha.regions = 0.2,
lwd = 3,
col.regions = alphabet(nlevels(
as.factor(WMU$WILDLIFE_MGMT_UNIT_ID)
)),
hide = TRUE
) +
mapview(AOI_SPATIAL,
label = "AOI_NAME",
col.regions = "red")
MAP#map %>%
setView(st_coordinates(st_centroid(st_as_sfc(
st_bbox(AOI_SPATIAL)
)))[, 1],
st_coordinates(st_centroid(st_as_sfc(
st_bbox(AOI_SPATIAL)
)))[, 2],
zoom = 9)
})
})
output$AOI_OVERLAP_TABLE <-
renderDT({
AOI_OVERLAP_TABLE <- AOI_WMU_INTERSECT() %>%
st_drop_geometry()
AOI_OVERLAP_TABLE
}, filter = "top", extensions = c("FixedHeader", "Buttons"),
options = list(
pageLength = 100,
fixedHeader = TRUE,
dom = "Bfrtip",
buttons = c('colvis', 'copy', 'excel', 'csv')
))
output$TEST_TEXT <-
renderText(unique(AOI_WMU_INTERSECT()$WILDLIFE_MGMT_UNIT_ID))
}
# Run the application
shinyApp(ui = ui, server = server)
Putting some req() and changing observeEvent() to observe() makes it work. Try this
######server#####
server <- function(input, output, session) {
####reactive data
AOI <-
reactive({
if (is.null(input$SHAPEFILE) & !is.null(input$KMZ)) {
st_read(unzip(input$KMZ$datapath)) %>%
st_zm(drop = T) %>%
mutate(AOI_NAME = input$AOI_NAME) %>%
st_transform(4326) %>%
select(-Name)
}
else if (!is.null(input$SHAPEFILE) & is.null(input$KMZ)) {
SHAPEFILE()
}
else{
return(NULL)
}
})
WMU_OVERLAP <- reactive({
req(AOI())
st_filter(WMU_DATA, AOI())
})
AOI_WMU_INTERSECT <-
reactive({
req(AOI(), WMU_OVERLAP())
st_intersection(AOI(), WMU_OVERLAP()) %>%
dplyr::mutate(`HA of Overlap` = round(as.numeric(st_area(.)) / 10000, 0)) %>%
dplyr::mutate(`Percent of WMU` = round(`HA of Overlap` / `Total.WMU.HA` *100, 2))
})
observe({updatePickerInput(
session,
"WMU_FILTER",
choices = unique(AOI_WMU_INTERSECT()$WILDLIFE_MGMT_UNIT_ID),
selected = unique(AOI_WMU_INTERSECT()$WILDLIFE_MGMT_UNIT_ID)
)
} )#, ignoreInit = TRUE, ignoreNULL = TRUE)
###outputs
output$OVERLAP_MAP <-
renderLeaflet({
req(AOI_WMU_INTERSECT())
withProgress(message = "Calcualting Overlap", detail = "Should be done soon", {
AOI_SPATIAL <- AOI() %>% dplyr::mutate(AOI_NAME = input$AOI_NAME)
WMU <-
WMU_OVERLAP() %>% dplyr::filter(WILDLIFE_MGMT_UNIT_ID %in% input$WMU_FILTER)
Overlap <-
AOI_WMU_INTERSECT() %>% dplyr::filter(WILDLIFE_MGMT_UNIT_ID %in% input$WMU_FILTER)
MAP <-
mapview(
Overlap,
zcol = "WILDLIFE_MGMT_UNIT_ID",
alpha.regions = 0.2,
map.types = c("Esri.WorldTopoMap", "Esri.WorldImagery"),
col.regions = alphabet(nlevels(
as.factor(WMU$WILDLIFE_MGMT_UNIT_ID)
))
) +
mapview(
WMU,
zcol = "WILDLIFE_MGMT_UNIT_ID",
alpha.regions = 0.2,
lwd = 3,
col.regions = alphabet(nlevels(
as.factor(WMU$WILDLIFE_MGMT_UNIT_ID)
)),
hide = TRUE
) +
mapview(AOI_SPATIAL,
label = "AOI_NAME",
col.regions = "red")
MAP#map %>%
setView(st_coordinates(st_centroid(st_as_sfc(
st_bbox(AOI_SPATIAL)
)))[, 1],
st_coordinates(st_centroid(st_as_sfc(
st_bbox(AOI_SPATIAL)
)))[, 2],
zoom = 9)
})
})
output$AOI_OVERLAP_TABLE <-
renderDT({
AOI_OVERLAP_TABLE <- AOI_WMU_INTERSECT() %>% st_drop_geometry()
AOI_OVERLAP_TABLE
}, filter = "top", extensions = c("FixedHeader", "Buttons"),
options = list(
pageLength = 100,
fixedHeader = TRUE,
dom = "Bfrtip",
buttons = c('colvis', 'copy', 'excel', 'csv')
))
output$TEST_TEXT <- renderText(unique(AOI_WMU_INTERSECT()$WILDLIFE_MGMT_UNIT_ID))
}
I'm trying to addlegend feature on my interactive map app based on user input such that when he selects a range of input the color mapping changes based on the conditions selected.
I tried to do this putting colorBin() inside reactive() function in this way:
colorpal <- reactive({
colorBin(palette = "plasma", domain = data_input_ordered()$totale, bins = 6)
})
and than using colorpal() inside renderLeaflet() in this way:
output$mymap <- renderLeaflet(
leaflet() %>%
addProviderTiles(providers$Stamen.Terrain) %>%
setView(lng = 9.768875, lat = 45.619111, zoom = 9) %>%
addPolygons(data = province_lonlat,
weight = 1,
color = "white",
fillOpacity = 0.8,
fillColor = colorpal(data_input_ordered()$totale),
highlight = highlightOptions(weight = 1,
color = "#666666",
fillOpacity = 0.5,
bringToFront = TRUE
),
label = lapply(labels(), HTML)
) %>%
addLegend(pal = colorpal,
values = data_input_ordered()$totale,
position = "topright",
labFormat = labelFormat(big.mark = ".")
)
)
The problem is the app is running but the map tab isn't showing anything but: "Error: argument is of length zero
Anyone has tips to fix my code making my map working properly?
Full code is here:
# APP
library(shiny)
library(shinydashboard)
library(leaflet)
library(rgdal)
library(dplyr)
library(DT)
province <- readOGR("../in/province.shp")
province_lonlat <- spTransform(province, CRS("+proj=longlat +datum=WGS84"))
crimini <- read.csv2("../in/crimini.csv")
### UI
ui <- dashboardPage(
skin = "blue",
dashboardHeader(title = "Crimini denunciati nelle province della Lombardia"),
dashboardSidebar(
sliderInput(
# nome per indicare i valori controllati dallo slider (si utilizza nel SERVER per riferirsi ai dati da controllare)
inputId = "date_range",
label = "Anno",
min = min(crimini$anno),
max = max(crimini$anno),
# valori iniziali dello slider
value = c(min(crimini$anno), max(crimini$anno)),
sep = ".",
step = 1
)
),
dashboardBody(
fluidRow(box(width = 12, leafletOutput(outputId = "mymap"))),
fluidRow(box(width = 12, dataTableOutput(outputId = "summary_table")))
)
)
### SERVER
server <- function(input, output) {
data_input <-
# inserisco una funzione REACTIVE che aggiorna il calcolo ogni volta che i parametri di input vengono modificati
reactive({
crimini %>%
# filtro i valori in base al massimo e al minimo selezionati con lo slider
filter(`anno` >= input$date_range[1]) %>%
filter(`anno` <= input$date_range[2]) %>%
group_by(`provincia`) %>%
summarize("totale" = sum(`n_crimini`),
"media annua" = round(sum(`n_crimini`) / (input$date_range[2] - input$date_range[1]), digits = 2)
)
})
data_input_ordered <- reactive({
data_input()[order(match(data_input()$provincia, province_lonlat$provincia)), ]
})
labels <- reactive({
paste("<p>", data_input_ordered()$provincia, "</p>",
"<p>", "totale crimini: ", data_input_ordered()$totale, "</p>",
"<p>", "media annua: ", round(data_input_ordered()$`media annua`, digits = 2), "</p>"
)
})
colorpal <- reactive({
colorBin(palette = "plasma", domain = data_input_ordered()$totale, bins = 6)
})
output$mymap <- renderLeaflet(
leaflet() %>%
addProviderTiles(providers$Stamen.Terrain) %>%
setView(lng = 9.768875, lat = 45.619111, zoom = 9) %>%
addPolygons(data = province_lonlat,
weight = 1,
color = "white",
fillOpacity = 0.8,
fillColor = colorpal(data_input_ordered()$totale),
highlight = highlightOptions(weight = 1,
color = "#666666",
fillOpacity = 0.5,
bringToFront = TRUE
),
label = lapply(labels(), HTML)
) %>%
addLegend(pal = colorpal,
values = data_input_ordered()$totale,
position = "topright",
labFormat = labelFormat(big.mark = ".")
)
)
output$summary_table <- renderDataTable(data_input())
}
Files are here: https://drive.google.com/drive/folders/1rL3R5W2cRrX34NDi9bpCphnVGTFcu6s7?usp=sharing
I know this question has been asked many times before, but most of those questions seem to be using 'reactive', which I am not using. I don't know whether I should be, I am very new to shiny. Reading some of the other posts I imagine that I should be dealing adding parentheses somewhere, but I don't know where to put them.
I have pasted my code below:
ui <- fluidPage(
titlePanel("Hello Shiny!"),
sidebarLayout(
sidebarPanel(
selectizeInput(inputId = 'lsoa',
label = 'Choose your lsoa',
choices = c('Ealing' = 'ealing',
'Camden' = 'camden') ,
selected = 'camden', multiple = TRUE),
uiOutput(outputId = 'tim')
),
mainPanel(
leafletOutput(outputId = "map")
)
)
)
server <- function(input, output) {
output$map <- renderLeaflet({
l = leaflet(data = noise_lsoa) %>%
addTiles()%>%
setView(lng = -0.083449, lat = 51.512573, zoom = 09)%>%
addMarkers(lng = ~longitude,
lat = ~latitude,
popup = ~as.character(lpaeq_T),
label = ~as.character(lsoa11nm))
#addAwesomeMarkers(
# lng=-0.4, lat=51.078039,
#label='Testing additional labels',
#icon = icon.glyphicon) %>%
if (!is.null(input$lsoa)){
l %>%
addPolygons(data = subset(main_shape, grepl(paste(input$lsoa, collapse = '|'),
tolower(lsoa11nm))),
color = "#444444",
weight = 1,
smoothFactor = 0.5,
opacity = 1.0,
fillOpacity = 0.5)
}else {
l
}
output$tim <- renderUI({
minimum = min(noise_merge$full_date_time, na.rm = TRUE)
maximum = max(noise_merge$full_date_time, na.rm = TRUE)
sliderInput(inputId = 'time', label = 'Select your time',
min = minimum,
max = maximum,
value = minimum,
timeFormat = '%F %T')
})
})
}
Thank you
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(
))
})