Related
I am trying to create a Shiny app that uses leaflet to display map markers. I want the user to be able to toggle between groups of markers using the UI. With some help from StackOverflow, this has been achieved as follows:
library(shiny)
library(shinyjs)
library(leaflet)
library(dplyr)
ui <- fluidPage(
uiOutput("quakesToggle"),
leafletOutput("mymap",height = '100vh')
)
server <- function(input, output) {
data(quakes)
output$mymap <- renderLeaflet({
leaflet(data = quakes) %>%
setView(lng = quakes[1, 'long'],
lat = quakes[1, 'lat'],
zoom=5) %>%
addTiles() %>%
addCircleMarkers(data = quakes[quakes$mag>=5, ],
~long,
~lat,
radius=3,
group = 'quakes1',
stroke=FALSE,
fillOpacity=0.5,
color = 'red') %>%
addCircleMarkers(data = quakes[quakes$mag<5, ],
~long,
~lat,
radius=3,
group = 'quakes2',
stroke=FALSE,
fillOpacity=0.5,
color = 'green')
})
output$quakesToggle <- renderUI({
checkboxGroupInput('quakesToggle', 'Select magnitude:',
choices = c('Quakes1','Quakes2'),
selected = c('Quakes1','Quakes2')
)
})
observeEvent(input$quakesToggle, {
if('Quakes1' %in% input$quakesToggle) {
leafletProxy('mymap', data = quakes) %>%
showGroup('quakes1')
} else {
leafletProxy('mymap', data = quakes) %>%
hideGroup('quakes1')
}
if('Quakes2' %in% input$quakesToggle) {
leafletProxy('mymap', data = quakes) %>%
showGroup('quakes2')
} else {
leafletProxy('mymap', data = quakes) %>%
hideGroup('quakes2')
}
})
}
shinyApp(ui, server)
However, I would like to add additional toggles for the user to select further groups. In this example say quakes$depth >=350 and also quakes$depth<350.
I have achieved rough functionality by extending the list of options in input$quakesToggle and adding the additional group designations as new addCircleMarkers assignments.
I would prefer to create a new checkboxGroupInput for the new groups though. In doing so I create a new observeEvent but things start to fall down here given the competing conditions.
I recognise that the problem is that I am attempting to assign points to multiple groups which, if I understand thigs correctly, isn't possible.
How then can I create the functionality required?
Some pointers on how/if this can be achieved would be appreciated!
Further Elaboration
The below shows how I already have color assigned to a variable selection, in this instance station (I know this is a silly assignment but it works for the example). Given that color is already assigned as conditional on input$circle_color. How then would the filter and grouping that #gdevaux mentions below work?
library(shiny)
library(shinyjs)
library(leaflet)
library(dplyr)
ui <- fluidPage(
uiOutput('quakesToggle'),
uiOutput('circle_color'),
leafletOutput("mymap",height = '100vh')
)
server <- function(input, output) {
data(quakes)
output$circle_color <- renderUI({
selectInput('circle_color', label = 'Variable to colour by:',
choices = c('stations'), selected = 'stations')
})
output$quakesToggle <- renderUI({
checkboxGroupInput('quakesToggle', 'Select magnitude:',
choices = c('Quakes1','Quakes2'),
selected = c('Quakes1','Quakes2')
)
})
output$mymap <- renderLeaflet({
leaflet(data = quakes) %>%
setView(lng = quakes[1, 'long'],
lat = quakes[1, 'lat'],
zoom=5) %>%
addTiles()
})
observe({
if (is.null(input$circle_color)){return('stations')}
colorBy <- input$circle_color
colorData <- quakes[[input$circle_color]]
pal1 <- c('green', 'yellow1','orange','red1','purple')
color <- colorBin(pal1, colorData)
leafletProxy('mymap',data = quakes)%>%
clearShapes() %>%
addCircleMarkers(data = quakes[quakes$mag>=5, ],
~long,
~lat,
radius=3,
group = 'quakes1',
stroke=FALSE,
fillOpacity=0.5,
color = ~color(colorData)
) %>%
addCircleMarkers(data = quakes[quakes$mag<5, ],
~long,
~lat,
radius=3,
group = 'quakes2',
stroke=FALSE,
fillOpacity=0.5,
color = ~color(colorData)
) %>%
addLegend("topright",
pal=color,
values=colorData,
title=colorBy,
layerId="colorLegend"
)
})
observeEvent(input$quakesToggle, {
if (is.null(input$circle_color)) {
return('stations')
}
if('Quakes1' %in% input$quakesToggle) {
leafletProxy('mymap', data = quakes) %>%
showGroup('quakes1')
} else {
leafletProxy('mymap', data = quakes) %>%
hideGroup('quakes1')
}
if('Quakes2' %in% input$quakesToggle) {
leafletProxy('mymap', data = quakes) %>%
showGroup('quakes2')
} else {
leafletProxy('mymap', data = quakes) %>%
hideGroup('quakes2')
}
}, ignoreNULL = FALSE)
}
shinyApp(ui, server)
A possible solution if you want to have multiple filters is to filter your data first, and reload your map every time.
library(shiny)
library(shinyjs)
library(leaflet)
library(dplyr)
mydata <- quakes %>%
mutate(binary_mag = if_else(mag>=5, 1, 2),
binary_depth = if_else(depth>=350, 1, 2),
colorgroup = paste(binary_mag, binary_depth))
mydata$colorgroup[mydata$colorgroup=="1 1"] <- "red"
mydata$colorgroup[mydata$colorgroup=="1 2"] <- "green"
mydata$colorgroup[mydata$colorgroup=="2 1"] <- "blue"
mydata$colorgroup[mydata$colorgroup=="2 2"] <- "yellow"
ui <- fluidPage(
uiOutput("quakesToggle"),
leafletOutput("mymap",height = '100vh')
)
server <- function(input, output) {
# Make filters input
output$quakesToggle <- renderUI({
tagList(
checkboxGroupInput('quakesToggleM', 'Select magnitude:',
choices = c('mag>=5','mag<5'),
selected = c('mag>=5','mag<5')
),
checkboxGroupInput('quakesToggleD', 'Select depth:',
choices = c('depth>=350','depth<350'),
selected = c('depth>=350','depth<350')
)
)
})
# Filter data depending on inputs, you may have to modify here depending on how you want
# mag and depth inputs to interact (is it mag AND depth ? is it mag OR depth ? etc)
filtred_data <- eventReactive({
input$quakesToggleM
input$quakesToggleD}, {
res <- mydata %>% {
if(!is.null(input$quakesToggleM)){
filter(., eval(parse(text = paste(input$quakesToggleM, collapse = "|"))))
} else {
filter(.,TRUE)
}
} %>%{
if(!is.null(input$quakesToggleD)){
filter(., eval(parse(text = paste(input$quakesToggleD, collapse = "|"))))
} else {
filter(.,TRUE)
}
}
if(is.null(input$quakesToggleM) & is.null(input$quakesToggleD)){
res <- mydata %>% filter(FALSE)
}
return(res)
}, ignoreNULL = FALSE)
# Make base map
output$mymap <- renderLeaflet({
leaflet(data = quakes) %>%
setView(lng = quakes[1, 'long'],
lat = quakes[1, 'lat'],
zoom=5) %>%
addTiles()
})
# Add filtred data markers on map
observeEvent(filtred_data(), {
leafletProxy("mymap") %>%
clearGroup("quakes") %>%
addCircleMarkers(data = filtred_data(),
~long,
~lat,
radius=3,
stroke=FALSE,
group = "quakes",
fillOpacity=0.5,
color = ~colorgroup)
# add a legend would be great
})
}
shinyApp(ui, server)
And to work with a color input just modify the observeEvent
# Add filtred data markers on map
observeEvent({
filtred_data()
input$circle_color
}, {
colorBy <- input$circle_color
colorData <- quakes[[input$circle_color]]
pal1 <- c('green', 'yellow1','orange','red1','purple')
color <- colorBin(pal1, colorData)
leafletProxy("mymap") %>%
clearGroup("quakes") %>%
removeControl("colorLegend") %>%
addCircleMarkers(data = filtred_data(),
~long,
~lat,
radius=3,
stroke=FALSE,
group = "quakes",
fillOpacity=0.5,
color = ~color(colorData)) %>%
addLegend("topright",
pal=color,
values=colorData,
title=colorBy,
layerId="colorLegend"
)
})
Is it possible to split the code of a map so that a part of the map only updates if it's own input is changed?
In the reproducible example below, when selecting the "toner" tile and selecting a new station, the whole leaflet map is executed again because addLegend needs to be updated. Which makes the tile jump back to "OSM (default)" tile. I would like to stay at the tile I selected when I select other stations.
library(leaflet)
library(shiny)
library(dplyr)
pal <- colorFactor(
palette = "YlGnBu",
domain = quakes$stations
)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
checkboxGroupInput("stations",
"Choose a station",
choices=sort(unique(quakes$stations)),
selected = c(10, 11))
),
mainPanel(
leafletOutput("map")
)
)
)
server <- function(input, output) {
points <- reactive({
quakes %>%
filter(stations %in% input$stations)
})
output$map <- renderLeaflet({
leaflet(quakes) %>%
addTiles(group = "OSM (default)") %>%
addProviderTiles(providers$Stamen.Toner, group = "Toner") %>%
addLayersControl(
baseGroups = c("OSM (default)", "Toner"),
options = layersControlOptions(collapsed = FALSE)) %>%
addLegend("Legend", position = "topleft", pal = pal, values = input$stations)
})
observe({
if(nrow(points()) == 0) {
leafletProxy("map", data = points()) %>%
clearMarkers()
} else {
leafletProxy("map", data = points()) %>%
clearMarkers() %>%
addCircleMarkers(radius = 2)
}
})
}
shinyApp(ui, server)
I tried several things, including adding addLegend to the else statement, but that does not go well. I'm new to leaflet/shiny, moving addLegend seemed most logic to me. I really appreciate any suggestions!
As far as I get it you were on the right track by trying to move addLegend to the observer. Doing so worked fine for me.
Move addLegend to observe
Before adding the legend use clearControls to remove any existing legend (otherwise you get multiple legends)
I removed the duplicated code in the observe
As far as I get it the condition nrow(points()) > 0 is only needed to decide whether a legend should be drawn or not. For the markers it doesn't matter.
library(leaflet)
library(shiny)
library(dplyr)
pal <- colorFactor(
palette = "YlGnBu",
domain = quakes$stations
)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
checkboxGroupInput("stations",
"Choose a station",
choices=sort(unique(quakes$stations)),
selected = c(10, 11))
),
mainPanel(
leafletOutput("map")
)
)
)
server <- function(input, output) {
points <- reactive({
quakes %>%
filter(stations %in% input$stations)
})
output$map <- renderLeaflet({
leaflet(quakes) %>%
addTiles(group = "OSM (default)") %>%
addProviderTiles(providers$Stamen.Toner, group = "Toner") %>%
addLayersControl(
baseGroups = c("OSM (default)", "Toner"),
options = layersControlOptions(collapsed = FALSE))
})
observe({
proxy <- leafletProxy("map", data = points()) %>%
clearMarkers() %>%
clearControls() %>%
addCircleMarkers(radius = 2)
if (nrow(points()) > 0)
proxy <- proxy %>% addLegend("Legend", position = "topleft", pal = pal, values = input$stations)
proxy
})
}
shinyApp(ui, server)
I have a radioButtons input with Yes and No :
radioButtons("rd", "3 rotor diameter circles:",list("Yes", "No"))
How should I modify my output in server.R, in a way that if the choice is YES, it consider the addCircles command and if is No ignore that line ?
output$mymap <- renderLeaflet({
infile=input$File
if (is.null(infile))
return(NULL)
df.20 <- Coor1
getColor <- function(Layout) {
sapply(Layout$j1, function(j1) {
if(j1 < 1) {
"red"
} else {
"green"
} })
}
icons <- awesomeIcons(
spin=TRUE,
icon = 'star',
iconColor = 'lightgray',
library = 'fa',
markerColor = getColor(df.20)
)
leaflet() %>%
addProviderTiles("OpenTopoMap", group = "MapQuestOpen.Aerial") %>%
addAwesomeMarkers(data = df.20,~long, ~lat, icon=icons, popup = ~as.character(mag), label = ~as.character(Name))%>%
addCircles(data = df.20,lng=~long, lat=~lat,radius=~rad,weight = 1,fill = FALSE)%>%
addMeasure(primaryLengthUnit='meters',primaryAreaUnit='sqmeters')
})
You should use leaflet's proxy method to do that, and add/remove circles in an observer, consider this example :
library("shiny")
library("leaflet")
df.20 <- quakes[1:20,]
ui <- fluidPage(
radioButtons(inputId = "add_circles", label = "Add circles", choices = c("Yes", "No")),
leafletOutput(outputId = "mymap")
)
server <- function(input, output, session) {
# your initial map
output$mymap <- renderLeaflet({
leaflet(df.20) %>% addTiles() %>% addCircles()
})
# add or remove circles when clicking the radio button
observeEvent(input$add_circles, {
if (input$add_circles == "Yes") {
leafletProxy(mapId = "mymap", data = df.20) %>% addCircles()
} else if (input$add_circles == "No") {
leafletProxy(mapId = "mymap") %>% clearShapes()
}
}, ignoreInit = TRUE)
}
shinyApp(ui = ui, server = server)
Look at https://rstudio.github.io/leaflet/shiny.html
Note : here I used clearShapes, it remove also polygons, rectangles and polylines, you can remove only circles by defining layerId in addCircles and use removeShape.
You could try this:
leaflet() %>%
addProviderTiles("OpenTopoMap", group = "MapQuestOpen.Aerial") %>%
addAwesomeMarkers(data = df.20,~long, ~lat, icon=icons, popup = ~as.character(mag), label = ~as.character(Name))%>%
{if(input$rd == "Yes")addCircles(data = df.20,lng=~long, lat=~lat,radius=~rad,weight = 1,fill = FALSE)}%>%
addMeasure(primaryLengthUnit='meters',primaryAreaUnit='sqmeters')
i have used if statement inside of the leaflet code, saying that if input$rd == "Yes", then addCircles(...) should be considered.
I have a layer of CircleMarkers and I am trying to remove only the markers that have a certain layerId. The id's for these circle markers are in a dataframe.
Below is a simple example:
Suppose I have a dataframe with 3 rows with id's 1, 2 and 3. I tried to make a checkboxInput with the options to delete id's 1 and 2 or 3.
Below the inputs will trigger an ObserveEvent that use the removeMarker function. However, nothing happens. I have tried a million ways to enter the id's into the removeMarker and I have also tried several of the other ways to deletion. Either nothing happens or all disappear. I need a way to delete specific markers.
ui <- shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
checkboxInput("delete1", "Delete ID=1 and 2",value=FALSE),
checkboxInput("delete3", "Delete ID=3",value=FALSE)
),
mainPanel(
leafletOutput("map")
)
)
))
df <- data.frame(id=c(1,2,3),lng = rnorm(3, -106.1039361, 0.5) ,
lat = rnorm(3, 50.543981, 0.5))
server <- shinyServer(function(input, output, session) {
output$map <- renderLeaflet(
leaflet() %>%
addTiles() %>% addCircleMarkers(layerId=df$id,df$lng,df$lat, group='marker', radius=2, fill = TRUE,color='red')
)
observeEvent(input$delete1, {
proxy <- leafletProxy('map')
if (input$delete1){ proxy %>% removeMarker(df[1:2,1])
}
})
observeEvent(input$delete3, {
proxy <- leafletProxy('map')
if (input$delete3){ proxy %>% removeMarker(3)}
})
})
shinyApp(ui, server)
For some reason this works if the layerId in the addCirleMarkers and in the removeMarker are characters, you could try, for the server part:
server <- shinyServer(function(input, output, session) {
output$map <- renderLeaflet(
leaflet() %>%
addTiles() %>% addCircleMarkers(layerId=as.character(df$id),df$lng,df$lat, group='marker', radius=2, fill = TRUE,color='red')
)
observeEvent(input$delete1, {
proxy <- leafletProxy('map')
if (input$delete1){ proxy %>% removeMarker(c("1","2"))
}
})
observeEvent(input$delete3, {
proxy <- leafletProxy('map')
if (input$delete3){ proxy %>% removeMarker("3")}
})
})
I think grouping the IDs is still the way to go. That grouping variable can then be added to your data frame and you can use that to toggle showing/hiding the points as I illustrate below. It's really not any different than what you were trying originally because you still had to specifically identify which IDs you wanted to remove. You still have to do that, but now you have to put them in defined groups.
require(shiny)
require(leaflet)
require(dplyr)
ui <- shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
#Set value = TRUE so points are shown by default
checkboxInput("delete1", "Toggle ID 1 and 2", value = TRUE),
checkboxInput("delete3", "Toggle ID 3", value = TRUE)
),
mainPanel(
leafletOutput("map")
)
)
))
df <- data.frame(
id = c(1,2,3),
#Add grouping variable
group = c("one", "one", "two"),
lng = rnorm(3, -106.1039361, 0.5) ,
lat = rnorm(3, 50.543981, 0.5)
)
server <- shinyServer(function(input, output, session) {
output$map <- renderLeaflet(
leaflet() %>%
addTiles() %>%
#Add markers with group
addCircleMarkers(group = df$group, df$lng, df$lat, radius=2, fill = TRUE, color = 'red')
)
observeEvent(input$delete1, {
proxy <- leafletProxy('map')
#Always clear the group first on the observed event
proxy %>% clearGroup(group = "one")
#If checked
if (input$delete1){
#Filter for the specific group
df <- filter(df, group == "one")
#Add the specific group's markers
proxy %>% addCircleMarkers(group = df$group, df$lng, df$lat, radius=2, fill = TRUE, color = 'red')
}
})
#Repeat for the other groups
observeEvent(input$delete3, {
proxy <- leafletProxy('map')
proxy %>% clearGroup(group = "two")
if (input$delete3){
df <- filter(df, group == "two")
proxy %>% addCircleMarkers(group = df$group, df$lng, df$lat, radius=2, fill = TRUE, color = 'red')
}
})
})
shinyApp(ui, server)
Another idea that you could use is instead of a checkboxInput is a selectInput where you can select multiples at one. That will save having to observeEvents for each group. That's shown below. I set it up so it defaults to all points being shown, and if you select a group it removes it from the plot.
require(shiny)
require(leaflet)
require(dplyr)
df <- data.frame(
id = c(1,2,3),
#Add grouping variable
group = c("one", "one", "two"),
lng = rnorm(3, -106.1039361, 0.5) ,
lat = rnorm(3, 50.543981, 0.5)
)
ui <- shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
#Set value = TRUE so points are shown by default
selectInput("toggle", "Toggle Groups", choices = unique(df$group), multiple = TRUE)
),
mainPanel(
leafletOutput("map")
)
)
))
server <- shinyServer(function(input, output, session) {
output$map <- renderLeaflet(
leaflet() %>%
addTiles() %>%
addCircleMarkers(df$lng, df$lat, radius=2, fill = TRUE, color = 'red')
)
observe({
proxy <- leafletProxy('map')
if(is.null(input$toggle)){
proxy %>% clearMarkers() %>%
addCircleMarkers(df$lng, df$lat, radius=2, fill = TRUE, color = 'red')
} else {
#Always clear the shapes on the observed event
proxy %>% clearMarkers()
#Filter for the specific group
df <- filter(df, !(group %in% input$toggle))
#Add the specific group's markers
proxy %>% addCircleMarkers(group = df$group, df$lng, df$lat, radius=2, fill = TRUE, color = 'red')
}
})
})
shinyApp(ui, server)
You could do something like the following, but they way you have it setup right now doesn't put the markers back if you uncheck the box.
server <- shinyServer(function(input, output, session) {
output$map <- renderLeaflet(
leaflet() %>%
addTiles() %>%
# Add circle markers in different groups
addCircleMarkers(layerId=df$id[1:2], df$lng[1:2], df$lat[1:2], group='one', radius=2, fill = TRUE,color='red') %>%
addCircleMarkers(layerId=df$id[3], df$lng[3], df$lat[3], group='two', radius=2, fill = TRUE,color='red')
)
# Remove group 'one'
observeEvent(input$delete1, {
proxy <- leafletProxy('map')
if (input$delete1){ proxy %>% clearGroup(group = "one")}
})
# Remove group 'two'
observeEvent(input$delete3, {
proxy <- leafletProxy('map')
if (input$delete3){ proxy %>% clearGroup(group = "two")}
})
})
shinyApp(ui, server)
I am developing one app in shiny dashboard in that I want to dynamically populate dropdown box once csv is uploaded. Dropdown will contain top 10 cities by user registrations which I get from following code.
final_data %>%
group_by(registrant_city) %>%
summarise(Total = n()) %>%
arrange(desc(Total)) %>%
top_n(n = 10)
These cities should go into dropdown box.
tabItem("email",
fluidRow(
box(
width = 4, status = "info",solidHeader = TRUE,
title = "Send Emails",
selectInput("email_select",
"Select Email Content",
choices = c("Price" = "price",
"Services" = "service"
)),
selectInput("cities",
"Select City",
choices = ??
))
))
Please help..
Use updateSelectInput in your server like below and set choices = NULL in your ui :
function(input, output, session) {
# If this isn't reactive you can put it in your global
choices_cities <- final_data %>%
group_by(registrant_city) %>%
summarise(Total = n()) %>%
arrange(desc(Total)) %>%
top_n(n = 10)
updateSelectInput(session = session, inputId = "cities", choices = choices_cities$registrant_city)
}
Or if final_data is reactive something like this :
function(input, output, session) {
choices_cities <- reactive({
final_data %>%
group_by(registrant_city) %>%
summarise(Total = n()) %>%
arrange(desc(Total)) %>%
top_n(n = 10)
})
observeEvent(choices_cities(), {
updateSelectInput(session = session, inputId = "cities", choices = choices_cities()$registrant_city)
})
}
A working example :
library("dplyr")
library("shiny")
data("world.cities", package = "maps")
ui <- fluidPage(
sliderInput(inputId = "n", label = "n", min = 10, max = 30, value = 10),
selectInput(inputId = "cities", label = "Select City", choices = NULL)
)
server <- function(input, output, session) {
choices_cities <- reactive({
choices_cities <- world.cities %>%
arrange(desc(pop)) %>%
top_n(n = input$n, wt = pop)
})
observe({
updateSelectInput(session = session, inputId = "cities", choices = choices_cities()$name)
})
}
shinyApp(ui = ui, server = server)
I got the answer for above. Here is what I did.
ui.R
uiOutput("city_dropdown")
And my server.R looks like following
output$city_dropdown <- renderUI({
city <- reg_city(final_data)
city <- city$registrant_city
city <- as.list(city)
selectInput("email_select",
"Select Email Content",
choices = city
)
})
reg_city() gives me the top 10 cities which I want to populate into drop down box,then converting it to a list gives me desired output.