I have a Shiny app with a leaflet showing ~9,000 points on a grid (each point representing a 100 m x 100 m square). The app is animated, so that each point changes colour over time. The first version of the app used addPolygons() with the setShapeStyle() function from here to allow the polygons to change colour over time, while accounting for area that each point accounts for. The polygon app was great but super slow, so I changed to addCircleMarkers instead, coupled with setCircleMarkerStyle() from the same GitHub page. This is way faster and works well, BUT I have 2 problems - 1) at low zooms, my points overlap, and 2) at high zooms, my points are separated by space.
Can anyway help me apply the same animation solutions offered by the change of style as here, but applied to addCircles() so that I can use a set radius, or a similar solution? Ideas for making the points square, so that I don't end up with empty spaces at high zooms are also welcome.
libraries and fake data:
library(plyr)
library(dplyr)
library(tidyr)
library(lubridate)
library(shiny)
library(leaflet)
library(viridisLite)
nodes <- structure(list(node = 1:9, Lon = c(-60.1760758677342, -60.1768617891598,
-60.1664512653477, -60.1672369749724, -60.1680228296767, -60.1688085769102,
-60.1695943435806, -60.170380129055, -60.1711659327049), Lat = c(43.316878317912,
43.317580709354, 43.309714197049,43.310416744826, 43.311119197611,
43.311821734546, 43.312524176034, 43.3132266121, 43.31392913277
)), row.names = c(NA, -9L), class = "data.frame")
data <- nodes %>%
crossing(Date = seq(as_date("2020-01-01"), as_date("2020-03-15"), "1 day")) %>%
mutate(Density = abs(rnorm(675, 10, 10)),
Exceed = ifelse(Density > 20, 1, 0),
Layer = paste(node, "Tile", sep = "_"))
FirstDay <- data %>%
filter(Date == min(Date))
Helper functions (based on the Github page referenced):
leafletjs <- tags$head(
tags$script(HTML('
window.LeafletWidget.methods.setStyle = function(category, layerId, style){
var map = this;
if (!layerId){
return;
} else if (!(typeof(layerId) === "object" && layerId.length)){
layerId = [layerId];
}
style = HTMLWidgets.dataframeToD3(style);
layerId.forEach(function(d,i){
var layer = map.layerManager.getLayer(category, d);
if (layer){
layer.setStyle(style[i]);
}
});
};
')))
setCircleMarkerStyle <- function(map, layerId
, radius = NULL
, stroke = NULL
, color = NULL
, weight = NULL
, opacity = NULL
, fill = NULL
, fillColor = NULL
, fillOpacity = NULL
, dashArray = NULL
, options = NULL
, data = getMapData(map)
){
options <- c(list(layerId = layerId),
options,
filterNULL(list(stroke = stroke, color = color,
weight = weight, opacity = opacity,
fill = fill, fillColor = fillColor,
fillOpacity = fillOpacity, dashArray = dashArray
)))
if (length(options) < 2) { # no style options set
return()
}
# evaluate all options
options <- evalFormula(options, data = data)
# make them the same length (by building a data.frame)
options <- do.call(data.frame, c(options, list(stringsAsFactors=FALSE)))
layerId <- options[[1]]
style <- options[-1] # drop layer column
#print(list(style=style))
leaflet::invokeMethod(map, data, "setStyle", "marker", layerId, style);
}
UI and server
ui <- fluidPage(
leafletjs,
sidebarLayout(
sidebarPanel(sliderInput("dateSel", "Date",
min = min(data$Date), max = max(data$Date),
value = min(data$Date), step = 1, timeFormat = "%d %b %y",
animate = animationOptions(interval = 100, loop = FALSE))),
mainPanel(leafletOutput("MapAnimate"))))
server <- function(input, output, session) {
filteredData <- reactive({
data %>% filter(Date == input$dateSel)
})
output$MapAnimate <- renderLeaflet({
range <- range(data$Density)
palette <- colorNumeric(palette = viridis(100), domain = range)
leaflet(FirstDay) %>%
addTiles() %>%
addCircleMarkers(lng = ~Lon, lat = ~Lat, layerId = ~Layer,
fillColor = "lightgray", fill = TRUE,
color = "white", stroke = TRUE,
fillOpacity = 1, opacity = 1, weight = 2) %>%
leaflet::addLegend(pal = palette, values = range, opacity = 0.9, position = "topleft")
})
observe({
df.in <- filteredData()
range <- range(data$Density)
palette <- colorNumeric(palette = viridis(100), domain = range)
leafletProxy("MapAnimate", data = df.in) %>%
setCircleMarkerStyle(layerId = ~Layer,
fillColor = ~palette(Density),
color = ~ifelse(Exceed == 1, "red", "white"))
})
}
shinyApp(ui = ui, server = server)
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)
this is my first time working with R shiny and I am attempting to integrate shiny features with a leaflet map I have made. The idea is that I would like to have radio buttons which toggle between four different polygons layers generated by shapefile data, and a slider which controls the opacity of the polygon layer. I used code from several different tutorials on shiny and leaflet but when I attempt to generate the map I get the following warning:
Warning: Error in google_dispatch: Invalid map parameter
[No stack trace available]
the panel with my buttons and slider appear but not my map. I believe this issue is with this section of my code:
opacityf <- reactive({
opacity[opacity$value == input$slider, ]
})
layerf <- reactive({
switch(input$layer,
countiesr = counties,
regionsr = regions,
triber = tribe,
publicr = public,
selected = NULL)
})
observe({
leafletProxy(mapId = "Intensity_Map", data = layerf()) %>%
clear_polygons() %>%
addPolygons(fillOpacity = opacityf(),
weight = 1,
color = "purple4")
})
}
I created a data frame with values between 0.0 and 1.0 for the opacity slider and I am attempting to direct shiny to change to opacity value to be whatever the slider value is. For the buttons I am trying to direct shiny to plot one of the four spatial polygon objects I created using the shapefiles. I believe I have a mistake in here somewhere but I cannot seem to figure out what it is.
Here is the rest of my code for reference:
ui <- fluidPage(
titlePanel("Cyano-Toxin Concentration in Relation
to OEHHA Action Levels for Acute Toxicity in Dogs"),
sliderInput(inputId = "slider",
label = "Opacity",
min = 0,
max = 1,
value = NULL,
step = 0.1),
radioButtons(inputId = "layer",
label = "Map Layer",
choices = c("Counties" = "countiesr",
"Regional Boards" = "regionsr",
"Tribal Lands" = "triber",
"Public Lands" = "publicr")),
leafletOutput("Intensity_Map")
)
opacity <- data.frame(value = c(0.0,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0))
server <- function(input, output, session){
output$Intensity_Map <- renderLeaflet({
leaflet() %>% setView(lat = 36.778259, lng = -119.417931, zoom = 5) %>% addTiles(group = "None") %>%
addCircleMarkers(
data = ws_ND,
radius = 4,
color = "grey",
stroke = FALSE, fillOpacity = 0.7,
label = ~as.character(label),
popup = ~as.character(popup),
group = "None Detected"
)%>%
addCircleMarkers(
data = ws_M,
radius = ws_M$Radius,
color = ~pala(Percent.of.AL),
stroke = FALSE, fillOpacity = 0.7,
label = ~as.character(label),
popup = ~as.character(popup),
group = "Microcystin/Nod."
)%>%
addCircleMarkers(
data = ws_C,
radius = ws_C$Radius,
color = ~palc(Percent.of.AL),
stroke = FALSE, fillOpacity = 0.7,
label = ~as.character(label),
popup = ~as.character(popup),
group = "Cylindrospermopsin"
)%>%
addCircleMarkers(
data = ws_A,
radius = ws_C$Radius,
color = ~palb(Percent.of.AL),
stroke = FALSE, fillOpacity = 0.7,
label = ~as.character(label),
popup = ~as.character(popup),
group = "Anatoxin-a"
)%>%
addCircleMarkers(
data = ws_S,
color = "yellow",
radius = 8,
stroke = FALSE, fillOpacity = 0.7,
label = ~as.character(label),
popup = ~as.character(popup),
group = "Saxitoxin"
)%>%
addLayersControl(
overlayGroups = c("None Detected", "Microcystin/Nod.","Cylindrospermopsin","Anatoxin-a","Saxitoxin"),
options = layersControlOptions(collapsed = FALSE),
position = "topright"
)%>%
addLegend("bottomright", pal = palab, values = (labels = c("1. < 25%","2. 25% - 49%","3. 50% - 99%", "4. ≥ 100%")),
title = "Microcystin/Nod.",
opacity = 1,
group = "Microcystin/Nod."
)%>%
addLegend("bottomright", pal = palbb, values = (labels = c("1. < 25%","2. 25% - 49%","3. 50% - 99%", "4. ≥ 100%")),
title = "Anatoxin-a",
opacity = 1,
group = "Anatoxin-a"
)%>%
addLegend("bottomright", pal = palcb, values = (labels = c("1. < 25%","2. 25% - 49%","3. 50% - 99%", "4. ≥ 100%")),
title = "Cylindrospermopsin",
opacity = 1,
group = "Cylindrospermopsin") })
opacityf <- reactive({
opacity[opacity$value == input$slider, ]
})
layerf <- reactive({
switch(input$layer,
countiesr = counties,
regionsr = regions,
triber = tribe,
publicr = public,
selected = NULL)
})
observe({
leafletProxy(mapId = "Intensity_Map", data = layerf()) %>%
clear_polygons() %>%
addPolygons(fillOpacity = opacityf(),
weight = 1,
color = "purple4")
})
}
shinyApp(ui, server)
Any thoughts would be greatly appreciated!
The variable I am trying to plot on a leaflet map is binary but I can't manage to have two distinct colors for each value (1 and 0). When the map loads, missing values are plotted in red, but the actual values are of the same color (something in between green and yellow). The 1 values should be green and 0 should be yellow. Here is the content of my server.R:
server <- function(input, output) {
colorpalette1 <- c("#3EA055", "#C68E17")
output$mymap1 <- renderLeaflet({
leaflet() %>%
setView(0, 28, 2)
})
selected <- reactive({
data2 <- shape_data[[input$year]]
data2
})
observeEvent(input$year, {
bins1 <- c(1, 0)
pal1 <- colorBin(colorpalette1, domain = selected(), bins = bins1, na.color = "#8C001A")
leafletProxy("mymap1") %>%
clearShapes() %>%
addPolygons(data = shape_data,
fillColor = ~pal1(selected()),
weight = 1,
opacity = 1,
color = "black",
fillOpacity = 0.7
)
})
}
input$year is a selectInput that selects the variable to plot on the map.
It would be good to provide a minimally reproducible example, so that we can verify the issue and test the solution. You can try the following:
observeEvent(input$year, {
if (!is.null(input$year)){
bins1 <- c(1, 0)
pal1 <- colorBin(colorpalette1, domain = selected(), bins = bins1, na.color = "#8C001A")
leafletProxy("mymap1") %>%
clearShapes() %>%
addPolygons(data = shape_data,
fillColor = ~pal1(selected()),
weight = 1,
opacity = 1,
color = "black",
fillOpacity = 0.7
)
}else{return(NULL)}
})
I found the answer, colorNumeric() was more suitable than colorBin().
pal1 <- colorNumeric(colorpalette1, domain = shape_data[[input$year]], na.color = "#8C001A")
I am building an app that displays circles for different coordinates.
If I select (Manager == Robert_ZZZ and Days == 'Wednesday') then this will show all the circles of Robert on a Wednesday. In my reproducible example below, when I select Manager == Robert_ZZZ and Days == Wednesday, I see 8 circles, which doesn't make sense. I should only see 4 circles since Robert_ZZZZ appears 4 times with different coordinates on a Wednesday. So why are the 4 extra circles showing up?
I added two radioButtons and I want to display the intersection of the different variables on my map and looked at
# Load libraries
library(dplyr)
library(shiny)
library(leaflet)
## Data
Latitude = c(33.79053,34.31533,21.44848,33.89115, 29.54777, 29.64597, 30.21765, 29.90082)
Longitude = c(-84.0348,-83.8166,-158.003, -117.295,-95.101,-95.5768,-95.341,-95.6294)
Worker = c('A','A','B','B','C','D','E','F')
Max.Distance.from.C.or.HB = c(35,55,75,100,25,15,18,17)
Manager = c('Andrew_XXXXX','Andrew_XXXXX','Andy_YYYY', 'Andy_YYYY', 'Robert_ZZZ','Robert_ZZZ','Robert_ZZZ','Robert_ZZZ')
Days = c('Tuesday','Monday','Monday','Tuesday', 'Wednesday', 'Wednesday','Wednesday','Wednesday')
coverage_data <- data.frame(Latitude,Longitude,Worker, Max.Distance.from.C.or.HB, Manager,
Days)
# Convert to miles
coverage_data <- coverage_data %>%
mutate(Radius = coverage_data$Max.Distance.from.C.or.HB * 1609.34)
# App
ui <- bootstrapPage(
tags$style(type = "text/css", "html, body {width:100%;height:100%}"),
leafletOutput("map", width = "100%", height = "100%"),
absolutePanel(bottom = 6, left = 6,
# sliderInput("range","Radius", min(coverage_data$Radius), max(coverage_data$Radius),
# value = range(coverage_data$Radius), step = 10
# ),
radioButtons(inputId = "selection_days", label = "Days:",
choices = c("Monday" = "Monday",
"Tuesday" = "Tuesday",
"Wednesday" = "Wednesday"
)),
radioButtons(inputId = "selection_manager", label = "Manager:",
choices = c("Andrew_XXXXX" = "Andrew_XXXXX",
"Andy_YYYY" = "Andy_YYYY",
"Robert_ZZZ" = "Robert_ZZZ"
))#,
# checkboxGroupInput("checkGroup", label = h3("Days"),
# choices = list("Monday" = 1, "Tuesday" = 2),
# selected = 1)
)
)
server <- function(input, output, session) {
filteredData2 <- reactive({
coverage_data[coverage_data$Days == input$selection_days
& coverage_data$Manager == input$selection_manager, ]
})
pal <- colorFactor(
palette = 'Set1', #Dark2 is another palette option
domain = coverage_data$Worker
)
output$map <- renderLeaflet({
leaflet(coverage_data) %>%
setView(lng = -95.7129, lat = 34.0902, zoom = 4.499) %>%
addProviderTiles(providers$OpenStreetMap.France) # %>%
#fitBounds(~min(Longitude),~min(Latitude), ~max(Longitude),~max(Latitude))
})
observe({
leafletProxy("map", data = filteredData2()) %>%
clearShapes() %>%
addCircles(#lng = coverage_data$Longitude,
#lat = coverage_data$Latitude,
#color = ~factpal(category),
color = ~pal(coverage_data$Worker),
weight = 1,
radius = coverage_data$Radius,
opacity = 0.5,
#label = lapply(coverage_data$label, HTML),
fillOpacity = 0.5
)
})
}
shinyApp(ui,server)
I appreciate any help correcting my logic.
Here's the change you need -
observe({
leafletProxy("map", data = filteredData2()) %>%
clearShapes() %>%
addCircles(
#lng = coverage_data$Longitude,
#lat = coverage_data$Latitude,
#color = ~factpal(category),
color = ~pal(Worker), ################### changed
weight = 1,
radius = ~Radius, ####################### changed
opacity = 0.5,
#label = lapply(coverage_data$label, HTML),
fillOpacity = 0.5
)
})
Also, leaflet(coverage_data) is not needed in output$map; simply leaflet() will do since you are not plotting anything there.
I added points on a map using shiny and leaflet.
Each point is a different type of transit option.
I want to distinguish the different types by color and couldn't figure this out.
Tried using "if" which doesn't work.
Thanks!
This is the basic code I have
library(leaflet)
ui <- fluidPage(
leafletOutput("map"),
headerPanel("Example"),
sidebarPanel(checkboxGroupInput(inputId = "Type", label = "Data
Layer",choices = c("Bike", "Muni", "Bus", "BART"), selected = "Bike")))
server <- function(input, output) {
output$map <- renderLeaflet({
rownumber = which(Stops_and_stations$Type == input$Type)
x <- Stops_and_stations[rownumber,]
leaflet(width = 1000, height = 500) %>%
addTiles() %>%
addCircleMarkers(lng = x$stop_lon,
lat = x$stop_lat,
radius= 3, color = '#ff6633') %>%
setView(lng = -122.4000,
lat = 37.79500,
zoom = 13)
})
}
shinyApp(ui, server)
And this is what I tried to add
.....
if(input$Type == "Bike"){
leaflet(width = 1000, height = 500) %>%
addTiles() %>%
addCircleMarkers(lng = x$stop_lon,
lat = x$stop_lat,
radius= 3, color = '#ff6633') %>%
setView(lng = -122.4000,
lat = 37.79500,
zoom = 13)
}
if(input$Type == "Muni"){
leaflet(width = 1000, height = 500) %>%
addTiles() %>%
addCircleMarkers(lng = x$stop_lon,
lat = x$stop_lat,
radius= 3, color = '#0033ff') %>%
setView(lng = -122.4000,
lat = 37.79500,
zoom = 13)
}
.....
It would be much easier to answer to your question if you provided Stops_and_stations and thus made it a reproducible example..
One approach to use distinct colors for different groups is to add a color column to your data.frame:
Since we don't know your data, I created some random dataset.
Stops_and_stations <- data.frame(
Type = rep(c("Bike", "Muni", "Bus", "BART"), each = 10),
stop_lon = -runif(40, 122.4200, 122.4500),
stop_lat = runif(40, 37.76800, 37.78900),
color = rep(c("Red", "Blue", "Green", "Yellow"), each = 10)
)
Then instead of specifying a concrete color such as #ff6633, you can use the color column.
addCircleMarkers(lng = x$stop_lon,
lat = x$stop_lat,
radius= 3, color = x$color)
I would also like to point out that your subsetting is not right: you are using checkboxGroupInput which can have more values, so you need to use the %in% operator to filter.
x <- Stops_and_stations[Stops_and_stations$Type %in% input$Type,]