Using the renderLeaflet (following codes), I am trying to create an interactive map within shiny. I want the map to be updated based on users selections of age group, sex, and year. When age group=60 and sex=both sexes and year= 2010 are selected, everything looks great (please see this screen shot).
However, when the other age groups are selected, the legend remains unchanged and is not rendered (Please see the second screen shot).
Here is my code:
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 = nhmap$Per, bins=4, right =FALSE, 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 = ~pal(Per),
pal = pal,
title = (paste("%",input$Age_Group_map, input$sex_map, "in", input$Year_map)) ,
labFormat = labelFormat())
})
Related
I'm working on a shiny app with basic functionality like this:
library(sf)
library(DT)
library(leaflet)
library(shiny)
library(tidyverse)
nc <- st_read(system.file("shape/nc.shp", package = "sf"), quiet = T) %>%
st_transform(4326) %>%
select(NAME, geometry, id = CNTY_ID) %>%
mutate(x = rnorm(n = nrow(.), mean = 100, sd = 20),
fill = sample(c("green", "red"), n(), replace = T),
fill_2 = if_else(fill == "green", "red", "green"))
# Function to change fill color on click event (taken from https://stackoverflow.com/a/69618323)
change_color <- function(map, id_to_remove, data, colour, new_group){
leafletProxy(map) %>%
removeShape(id_to_remove) %>% # remove previous occurrence
addPolygons(
data = data,
layerId = data$id,
group = new_group, # change group
fillColor = colour,
color = "black",
weight = 1,
fillOpacity = 1)
}
## UI
ui <- fluidPage(
leafletOutput("map"),
DT::dataTableOutput("table")
)
## Server
server <- function(input,output,session){
# Reactives
rv <- reactiveValues(
df = nc,
df.tab = as.data.frame(nc)
)
# Initial map
output$map <- renderLeaflet({
leaflet() %>%
setView(-79.99, 35.52, zoom = 7)
})
observe({
data <- rv$df
leafletProxy("map") %>%
addPolygons(
data = data,
weight = 1, color = "black", fillOpacity = 1, fillColor = ~fill,
layerId = data$id,
group = "unclicked_poly")
})
#first click
observeEvent(input$map_shape_click, {
# execute only if the polygon has never been clicked
req(input$map_shape_click$group == "unclicked_poly")
# filter data
data <- rv$df[rv$df$id==input$map_shape_click$id,]
change_color(map = "map",
id_to_remove = input$map_shape_click$id,
data = data,
colour = ~fill_2,
new_group = "clicked1_poly")
})
#second click: reverse first click
observeEvent(input$map_shape_click, {
req(input$map_shape_click$group == "clicked1_poly")
data <- rv$df[rv$df$id==input$map_shape_click$id,]
leafletProxy("map") %>%
removeShape(input$map_shape_click$id) %>% # remove previous occurrence
addPolygons(
data = data,
weight = 1, color = "black", fillOpacity = 1, fillColor = ~fill,
layerId = data$id,
group = "unclicked_poly") # back to initialize group
})
output$table <- DT::renderDataTable({
rv$df.tab %>%
group_by(fill) %>%
summarise(x = sum(x))
})
}
shinyApp(ui, server)
The idea here is that the user can change the fill color of the polygons with the click of a button. This works as is. However, I also want to dynamically display the fill-specific sum of x in the data tabe below the leaflet map. Currently, the table shows the grouped sums according to the initial data frame. However, when a user changes a polygon from green to red, the calculation should be done anew.
I have tried implementing this idea using a logic similar to the observeEvents() in output(map), but the problem here was that I could only ever access the last click, so previous clicks would not factor into the grouped sums calculation (group_by(fill) %>% summarise(x = sum(x))). Ideally, I would like to have information on whatever the current fill of all polygons is so that the data table reflects the user's input.
I ended up solving this problem in four steps:
Recording each click on a polygon using reactiveValues(Clicks=vector())
Converting vector into data frame, with click frequency determined by table()
Using modulo division on the number of clicks with the %% operator to ascertain current fill color on map (the number of fill options is much higher than two in my real world application)
Merging clicked and unclicked polygons to obtain current map status and using DT::dataTableProxy() to update table
App is now working as intended. Code:
library(sf)
library(DT)
library(leaflet)
library(shiny)
library(tidyverse)
nc <- st_read(system.file("shape/nc.shp", package = "sf"), quiet = T) %>%
st_transform(4326) %>%
select(NAME, geometry, id = CNTY_ID) %>%
mutate(x = rnorm(n = nrow(.), mean = 100, sd = 20),
fill = sample(c("green", "red"), n(), replace = T),
fill_2 = if_else(fill == "green", "red", "green"))
# Function to change fill color on click event (taken from https://stackoverflow.com/a/69618323)
change_color <- function(map, id_to_remove, data, colour, new_group){
leafletProxy(map) %>%
removeShape(id_to_remove) %>% # remove previous occurrence
addPolygons(
data = data,
layerId = data$id,
group = new_group, # change group
fillColor = colour,
color = "black",
weight = 1,
fillOpacity = 1)
}
## UI
ui <- fluidPage(
leafletOutput("map"),
DT::dataTableOutput("table")
)
## Server
server <- function(input,output,session){
# Reactives
rv <- reactiveValues(
df = nc,
df.tab = as.data.frame(nc)
)
# Initial map
output$map <- renderLeaflet({
leaflet() %>%
setView(-79.99, 35.52, zoom = 7)
})
observe({
data <- rv$df
leafletProxy("map") %>%
addPolygons(
data = data,
weight = 1, color = "black", fillOpacity = 1, fillColor = ~fill,
layerId = data$id, label = ~id,
group = "unclicked_poly")
})
#first click
observeEvent(input$map_shape_click, {
# execute only if the polygon has never been clicked
req(input$map_shape_click$group == "unclicked_poly")
# filter data
data <- rv$df[rv$df$id==input$map_shape_click$id,]
change_color(map = "map",
id_to_remove = input$map_shape_click$id,
data = data,
colour = ~fill_2,
new_group = "clicked1_poly")
})
#second click: reverse first click
observeEvent(input$map_shape_click, {
req(input$map_shape_click$group == "clicked1_poly")
data <- rv$df[rv$df$id==input$map_shape_click$id,]
leafletProxy("map") %>%
removeShape(input$map_shape_click$id) %>% # remove previous occurrence
addPolygons(
data = data,
weight = 1, color = "black", fillOpacity = 1, fillColor = ~fill,
layerId = data$id, label = ~id,
group = "unclicked_poly") # back to initialize group
})
output$table <- DT::renderDataTable({
rv$df.tab %>%
group_by(fill) %>%
summarise(x = sum(x)) -> sum
sum
})
proxy <- DT::dataTableProxy("table")
RV<-reactiveValues(Clicks=vector())
observeEvent(input$map_shape_click, {
#create object for clicked polygon
click <- input$map_shape_click
RV$Clicks<- c(RV$Clicks,click$id)
test <- as.data.frame(table(RV$Clicks)) %>%
mutate(current = Freq %% 2,
id = as.double(as.character(Var1)))
rv$df.tab %>%
full_join(test, by = "id") %>%
mutate(fill = case_when(current == 1 ~ fill_2,
TRUE ~ fill)) %>%
group_by(fill) %>%
summarise(x = sum(x)) -> sum
proxy %>% replaceData(sum)
})
}
shinyApp(ui, server)
I am in the process of creating an R flexdashboard. The dashboard contains several maps for Bangladesh, which are linked to a (Highcharts) chart that is activated by clicking on a polygon (e.g. region). I am able to make it work for one page. However, if I set it up for two pages, things no longer work.
It seems that flexdashboard (at least how I set it up) is not able to handle two input$map_shape_click operations at the same time. At the moment it only works on the first page, while the map does not react on the second page although a figure is produced. I welcome any suggestions to make this work.
Below a reproducible example. Note that (1) I omitted the flexdashboard yaml in the example and (2) markdown used by stackoverflow automatically renders the first, second and third header level. They render differently when run in flexdasboard (i.e. A Large Header is a new page in flexdashboard).
# Packages
library(tidyverse)
library(raster)
library(sf)
library(highcharter)
library(leaflet)
library(htmltools)
# Get data
adm1 <- getData('GADM', country='BGD', level=1)
adm1 <- st_as_sf(adm1)
# Create dummy data.frames with link to polygon
df1 <- data.frame(NAME_1 = adm1$NAME_1,
value_1 = c(1:7))
df2 <- data.frame(NAME_1 = adm1$NAME_1,
value_2 = c(8:14))
Page 1
Column {data-width=350}
Map 1
# MAIN MAP --------------------------------------------------------------------------------
output$map <- renderLeaflet({
# Base map
leaflet() %>%
addTiles(group = "OpenStreetMap") %>%
clearShapes() %>%
addPolygons(data = adm1,
smoothFactor = 0,
color = "black",
opacity = 1,
fillColor = "transparent",
weight = 0.5,
stroke = TRUE,
label = ~htmlEscape(NAME_1),
layerId = ~NAME_1,
)
})
leafletOutput('map')
# REGION SELECTION -----------------------------------------------------------------------
# Click event for the map to draw chart
click_poly <- eventReactive(input$map_shape_click, {
x <- input$map_shape_click
y <- x$id
return(y)
}, ignoreNULL = TRUE)
observe({
req(click_poly()) # do this if click_poly() is not null
# Add the clicked poly and remove when a new one is clicked
map <- leafletProxy('map') %>%
removeShape('NAME_1') %>%
addPolygons(data = adm1[adm1$NAME_1 == click_poly(), ],
fill = FALSE,
weight = 4,
color = '#d01010',
opacity = 1,
layerId = 'NAME_1')
})
Column {data-width=350}
Plot 1
data <- reactive({
# Fetch data for the click poly
out <- df1[df1$NAME_1 == click_poly(), ]
print("page 1") # print statement to show which click_poly is used
return(out)
})
output$plot <- renderHighchart({
req(data()) # do this if click_poly() is not null
chart <- highchart() %>%
hc_chart(type = 'column') %>%
hc_legend(enabled = FALSE) %>%
hc_xAxis(categories = c('A'),
title = list(text = 'Title 1')) %>%
hc_yAxis(title = list(text = 'Value 1')) %>%
hc_plotOptions(series = list(dataLabels = list(enabled = TRUE))) %>%
hc_add_series(name = 'Series',
data = c(data()$value_1)) %>%
hc_add_theme(hc_theme_smpl()) %>%
hc_colors(c('#d01010'))
})
highchartOutput('plot')
Page 2
Column {data-width=350}
Map 2
# MAIN MAP --------------------------------------------------------------------------------
output$map2 <- renderLeaflet({
# Base map
leaflet() %>%
addTiles(group = "OpenStreetMap") %>%
clearShapes() %>%
addPolygons(data = adm1,
smoothFactor = 0,
color = "black",
opacity = 1,
fillColor = "transparent",
weight = 0.5,
stroke = TRUE,
label = ~htmlEscape(NAME_1),
layerId = ~NAME_1,
)
})
leafletOutput('map2')
# REGION SELECTION -----------------------------------------------------------------------
# Click event for the map to draw chart
click_poly2 <- eventReactive(input$map_shape_click, {
x <- input$map_shape_click
y <- x$id
return(y)
}, ignoreNULL = TRUE)
observe({
req(click_poly2()) # do this if click_poly() is not null
# Add the clicked poly and remove when a new one is clicked
map <- leafletProxy('map2') %>%
removeShape('NAME_1') %>%
addPolygons(data = adm1[adm1$NAME_1 == click_poly2(), ],
fill = FALSE,
weight = 4,
color = '#d01010',
opacity = 1,
layerId = 'NAME_1')
})
Column {data-width=350}
Plot 2
data2 <- reactive({
# Fetch data for the click poly
out <- df2[df2$NAME_1 == click_poly2(), ]
print("page 2") # print statement to show which click_poly is used
return(out)
})
output$plot2 <- renderHighchart({
req(data2()) # do this if click_poly() is not null
chart <- highchart() %>%
hc_chart(type = 'column') %>%
hc_legend(enabled = FALSE) %>%
hc_xAxis(categories = c('A'),
title = list(text = 'Title 2')) %>%
hc_yAxis(title = list(text = 'Value 2')) %>%
hc_plotOptions(series = list(dataLabels = list(enabled = TRUE))) %>%
hc_add_series(name = 'Series',
data = c(data2()$value_2)) %>%
hc_add_theme(hc_theme_smpl()) %>%
hc_colors(c('#d01010'))
})
highchartOutput('plot2')
In your click_poly2 <- eventReactive(input$map_shape_click, you have click_poly2 being the 2nd map, but you have the same map_shape_click, what if you made it map_shape_click2, hopefully flexdashboard will handle it differently as now they are 2 different maps
I figured out the answer myself following a similar question I found somewhere else. As I am quite new to shiny and based my code on examples I found, I did not realize that 'map_shape_click' applies 'shape_click' on 'map' where 'map' corresponds with the map in output$map. As I have two maps: map and map2, the eventReactive statement for page2 should be changed into
click_poly2 <- eventReactive(input$map2_shape_click, {
x <- input$map2_shape_click
y <- x$id
return(y)
}, ignoreNULL = TRUE)
Now responding to a shape_click on map2
I have a database of medical consultations by cities. I use the leaflet and state_popup function to display the results on a map, as described below:
pal <- colorBin("Blues",domain = DATA$QUANTITY_MEDICAL,bins = c(1, 1000, 5000, 10000, 50000,100000,300000),na.color=NA)
state_popup <- paste0("<strong>CITY: </strong>",
DATA$CITY,
"<br><strong> QUANTITY OF MEDICAL CONSULTATION: </strong>",
DATA$QUANTITY_MEDICAL)
leaflet(data = DATA) %>%
addProviderTiles("CartoDB.Positron") %>%
addPolygons(fillColor = ~pal(QUANTITY_MEDICAL),
fillOpacity = 0.7,
color = "#BDBDC3",
weight = 1,
popup = state_popup) %>%
addLegend("topright","bottomright", pal = pal, values = ~ DATA$QUANTITY_MEDICAL,
title = " QUANTITY OF MEDICAL CONSULTATION ",
opacity = 1)
This script only shows one result at a time (medical consultations). I would like to include information about other medical procedures that I want to include, such as exams or hospitalizations.
I want for each procedure (medical consultation, exams or hospitalization) to include a button that would change the result. In my database (DATA) I already have the columns that separate the procedures I quoted. Is it possible to include this button to change the results on the map?
You are going to have to define groups it seems to me. There is a good link from RStudio on leaflet that may help you.
https://rstudio.github.io/leaflet/showhide.html
Here is some sample code from that site:
quakes <- quakes %>%
dplyr::mutate(mag.level = cut(mag,c(3,4,5,6),
labels = c('>3 & <=4', '>4 & <=5', '>5 & <=6')))
quakes.df <- split(quakes, quakes$mag.level)
l <- leaflet() %>% addTiles()
names(quakes.df) %>%
purrr::walk( function(df) {
l <<- l %>%
addMarkers(data=quakes.df[[df]],
lng=~long, lat=~lat,
label=~as.character(mag),
popup=~as.character(mag),
group = df,
clusterOptions = markerClusterOptions(removeOutsideVisibleBounds = F),
labelOptions = labelOptions(noHide = F,
direction = 'auto'))
})
l %>%
addLayersControl(
overlayGroups = names(quakes.df),
options = layersControlOptions(collapsed = FALSE)
)
I have a map I update monthly that has layers of information and I get it like so:
lsl <- unique(origAddress$LIHN_Line) # Gets unique service lines
# Create color palette
lihnpal <- colorFactor(
palette = 'Dark2'
, domain = origAddress$LIHN_Line
)
# create initial leaflet
LIHNMap <- leaflet() %>%
setView(lng = sv_lng, lat = sv_lat, zoom = sv_zoom) %>%
addTiles(group = "OSM (default)") %>%
addProviderTiles(providers$Stamen.Toner, group = "Toner") %>%
addProviderTiles(providers$Stamen.TonerLite, group = "Toner Lite") %>%
addControl("LIHN Service Line Point Map", position = "topright")
# for loop to cycle through adding layers
for(i in 1:length(lsl)){
LIHNMap <- LIHNMap %>%
addCircles(
data = subset(origAddress, origAddress$LIHN_Line == lsl[i])
, group = lsl[i]
, lat = ~lat
, lng = ~lon
, radius = 3
, fillOpacity = 1
, color = ~lihnpal(LIHN_Line)
, label = ~htmlEscape(LIHN_Line)
, popup = ~as.character(
paste(
"<strong>Hospitalist/Private: </strong>"
, hosim
, "<br><strong>Address: </strong>"
, FullAddress
, "<br><strong>Service Line: </strong>"
, LIHN_Line
, "<br><strong>LOS: </strong>"
, LOS
, "<br><strong>SOI: </strong>"
, SOI
, "<br><strong>Encounter: </strong>"
, pt_id
, "<br><strong>Payer Group:</strong>"
, pyr_group2
)
)
)
}
# add layercontrol
LIHNMap <- LIHNMap %>%
addLayersControl(
baseGroups = c("OSM (default)", "Toner", "Toner Lite"),
overlayGroups = lsl,
options = layersControlOptions(
collapsed = TRUE
, position = "topright"
)
)
LIHNMap <- LIHNMap %>%
addAwesomeMarkers(
lng = sv_lng
, lat = sv_lat
, icon = hospMarker
, label = ""
, popup = HospPopup
)
# print map
LIHNMap
I am making an R leaflet map (not Shiny) and I have two control groups, and based on the selection I would like a different legend to become visible. Currently I only manage to have both legends visible at all time.
Below is the code for the leaflet map, and the output can be seen in the image.
leaflet() %>% addSearchOSM() %>%
addProviderTiles(providers$CartoDB.Positron,
options = providerTileOptions(noWrap = TRUE),
group = "kaart") %>%
# addFullscreenControl() %>%
addCircleMarkers(data = table#data,
lat = ~lng,
lng = ~lat,
color = ~palverbruikplaats(Verbruiksplaats),
label = bepaalPopup(),
group = "Verbruikplaatscircles"
)%>%
addCircleMarkers(data = table#data,
lat = ~lng,
lng = ~lat,
color = ~palstatus(`Status omschrijving`),
label = bepaalPopup(),
group = "statuscircles"
)%>%
leaflet::addLegend("bottomleft", pal = palverbruikplaats, values = verbruikplaatsuniek, title = "Legenda") %>%
leaflet::addLegend("bottomleft", pal = palstatus, values = statusuniek, title = "Legenda") %>%
addLayersControl(baseGroups = c("Verbruikplaatscircles", "statuscircles"),
options = layersControlOptions(collapsed = FALSE))
In your addLayersControl did you mean to set the overlayGroups argument instead of baseGroups?
library(leaflet)
leaflet() %>%
addTiles(group = "OpenStreetMap") %>%
addCircleMarkers(runif(20, -75, -74), runif(20, 41, 42), group = "Markers1", color ="red") %>%
addMarkers(runif(20, -75, -74), runif(20, 41, 42), group = "Markers2") %>%
addLegend(values = 1, group = "Markers1", position = "bottomleft", labels = "1", colors= "red") %>%
addLegend(values = 2, group = "Markers2", position = "bottomleft", labels = "2" ,colors= "blue") %>%
addLayersControl(overlayGroups = c("Markers1", "Markers2"),
options = layersControlOptions(collapsed = FALSE))
what you need to do is, you need to make your legends values reactive
addLegend("bottomright", pal = pal, values = maindata#data[,req_var1()],
you can declare the req_var1() in server before calling
req_var1<-reactive({if(input$`Comparison Metric`=="Current Territory Factors vs GeoProxy Smoothing"){
paste(input$Curr2,"Curr",sep="_")
} else if(input$`Comparison Metric`=="Current Written Premium Vs Indicated Written Premium"){
paste(input$Curr2,"CWP",sep="_")
}
})
and also the pal can be declared as
pal1 <- reactive({if(input$ColorType=="Percentile"){
colorQuantile(
palette = "Spectral",
domain = tempdata()#data[,req_var1()],
probs = if(input$`Comparison Metric`=="Current Territory Factors vs GeoProxy Smoothing"){seq(0,1,by=0.25)
} else if(input$`Comparison Metric`=="Current Written Premium Vs Indicated Written Premium"){
seq(0,1,by=0.5)
}
## In case of Current written premium the variation is very less so while executing color mapping code is throwing error.
## This is because the some of quantiles values are not differentiable.
## So in colorQuantile function we have given two different prob values depending on metric selection.
)
} else if(input$ColorType=="Absolute Value"){colorNumeric(
palette = "Spectral",
domain = tempdata()#data[,req_var1()])
}else{print("Plese select Any one color map")}
})
library(leaflet)
library(htmltools)
library(htmlwidgets)
library(dplyr)
#
df1 <- data.frame(points=c("p1", "p2"), lat=c(49.47259, 49.48095), long=c(-103.7054, -103.6126), value=c(50.34, 100.25))
df2 <- data.frame(points=c("p1", "p2"), lat=c(49.47809, 49.66849), long=c(-103.5614, -103.0224), value=c(300.56, 505.34))
#
pal1 <- colorNumeric(
palette = "PRGn",
domain = df1$value
)
#
pal2 <- colorNumeric(
palette = "PRGn",
domain = df2$value
)
#
n <- leaflet() %>% addTiles(group="1st layer") %>% addTiles(group="2nd layer") %>%
addCircles(data=df1, lng=~long, lat=~lat, weight = 3, radius=250, color = ~pal1(value),
stroke = TRUE, fillOpacity = 0.8,group="1st layer") %>%
addCircles(data=df2, lng=~long, lat=~lat, weight = 3, radius=250, color = ~pal2(value),
stroke = TRUE, fillOpacity = 0.8,group="2nd layer") %>%
addLegend("bottomright", pal = pal1, values = df1$value, title = "legend_df1") %>%
addLegend("topright", pal = pal2, values = df2$value, title = "legend_df2") %>%
addLayersControl(baseGroups=c("1st layer","2nd layer"),
options=layersControlOptions(collapsed = F))
n
I want that when I click on "1st layer" then only "legend_df1" will appear and when I click on "2nd layer" then only "legend_df2" will appear and "legend_df1" will be vanished. Therefore, in each layer different legends will appear, not both legends together. Can anybody please help me out?
This is now possible with overlayGroups
library(leaflet)
df1 <- data.frame(points=c("p1", "p2"), lat=c(49.47259, 49.48095), long=c(-103.7054, -103.6126), value=c(50.34, 100.25))
df2 <- data.frame(points=c("p1", "p2"), lat=c(49.47809, 49.66849), long=c(-103.5614, -103.0224), value=c(300.56, 505.34))
pal1 <- colorNumeric(
palette = "inferno",
domain = df1$value
)
pal2 <- colorNumeric(
palette = "viridis",
domain = df2$value
)
leaflet() %>%
addProviderTiles(providers$CartoDB.DarkMatter) %>%
addCircleMarkers(data=df1, lng=~long, lat=~lat,
color = ~pal1(value),
group="group_1") %>%
addCircleMarkers(data=df2, lng=~long, lat=~lat,
color = ~pal2(value),
group="group_2") %>%
addLegend("bottomright", pal = pal1, title="grp1",
values = df1$value, group="group_1") %>%
addLegend("bottomright", pal = pal2, title="grp2",
values = df2$value, group="group_2") %>%
addLayersControl(overlayGroups = c("group_1","group_2"),
options = layersControlOptions(collapsed = FALSE))