Remove specific leaflet Markers in R shiny. - r

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)

Related

Resize html widget in Shiny? (echarts4r)

good afternoon/night. Im trying to create a shiny app with leaflet and echarts4r, but i would like to know if it is possible to change the size of the histogram that appears to the side. Anyone have any ideas on how I could do it? Here is a screenshot to indicate the size that I would be interested in having the graphic:
SS of the app
The code of the app is the following:
library(shiny)
library(leaflet)
library(RColorBrewer)
library(htmltools)
library(echarts4r)
ui <- bootstrapPage(
tags$style(type = "text/css", "html, body {width:100%;height:100%}"),
leafletOutput("map", width = "100%", height = "100%"),
absolutePanel(top = 10, right = 10,
sliderInput("range", "Magnitudes", min(quakes$mag), max(quakes$mag),
value = range(quakes$mag), step = 0.1
),
selectInput("colors", "Color Scheme",
rownames(subset(brewer.pal.info, category %in% c("seq", "div")))
),
checkboxInput("legend", "Show legend", TRUE),
p( iris %>%
e_charts() %>%
e_histogram(Sepal.Length, name = "histogram",breaks = "freedman-diaconis") %>%
e_tooltip(trigger = "axis") |>
e_color(color = "#753732")
)
)
)
server <- function(input, output, session) {
# Reactive expression for the data subsetted to what the user selected
filteredData <- reactive({
quakes[quakes$mag >= input$range[1] & quakes$mag <= input$range[2],]
})
# This reactive expression represents the palette function,
# which changes as the user makes selections in UI.
colorpal <- reactive({
colorNumeric(input$colors, quakes$mag)
})
output$map <- renderLeaflet({
# Use leaflet() here, and only include aspects of the map that
# won't need to change dynamically (at least, not unless the
# entire map is being torn down and recreated).
leaflet(quakes) %>% addTiles() %>%
fitBounds(~min(long), ~min(lat), ~max(long), ~max(lat))
})
# Incremental changes to the map (in this case, replacing the
# circles when a new color is chosen) should be performed in
# an observer. Each independent set of things that can change
# should be managed in its own observer.
observe({
pal <- colorpal()
leafletProxy("map", data = filteredData()) %>%
clearShapes() %>%
addCircles(radius = ~10^mag/10, weight = 1, color = "#777777",
fillColor = ~pal(mag), fillOpacity = 0.7, popup = ~paste(mag)
) %>% addTiles("http://{s}.basemaps.cartocdn.com/dark_all/{z}/{x}/{y}.png",
attribution = paste(
"© OpenStreetMap contributors",
"© CartoDB"
)
)
})
# Use a separate observer to recreate the legend as needed.
observe({
proxy <- leafletProxy("map", data = quakes)
# Remove any existing legend, and only if the legend is
# enabled, create a new one.
proxy %>% clearControls()
if (input$legend) {
pal <- colorpal()
proxy %>% addLegend(position = "bottomright",
pal = pal, values = ~mag
)
}
})
}
shinyApp(ui, server)
Here is one option -
Take the histogram plot on server side and use echarts4rOutput in the ui where you can easily adjust height and width according to your choice.
library(shiny)
library(leaflet)
library(RColorBrewer)
library(htmltools)
library(echarts4r)
ui <- bootstrapPage(
tags$style(type = "text/css", "html, body {width:100%;height:100%}"),
leafletOutput("map", width = "100%", height = "100%"),
absolutePanel(top = 10, right = 10,
sliderInput("range", "Magnitudes", min(quakes$mag), max(quakes$mag),
value = range(quakes$mag), step = 0.1
),
selectInput("colors", "Color Scheme",
rownames(subset(brewer.pal.info, category %in% c("seq", "div")))
),
checkboxInput("legend", "Show legend", TRUE),
echarts4rOutput('hist_plot', height = '1000px', width = '500px')
)
)
server <- function(input, output, session) {
# Reactive expression for the data subsetted to what the user selected
filteredData <- reactive({
quakes[quakes$mag >= input$range[1] & quakes$mag <= input$range[2],]
})
# This reactive expression represents the palette function,
# which changes as the user makes selections in UI.
colorpal <- reactive({
colorNumeric(input$colors, quakes$mag)
})
output$map <- renderLeaflet({
# Use leaflet() here, and only include aspects of the map that
# won't need to change dynamically (at least, not unless the
# entire map is being torn down and recreated).
leaflet(quakes) %>% addTiles() %>%
fitBounds(~min(long), ~min(lat), ~max(long), ~max(lat))
})
# Incremental changes to the map (in this case, replacing the
# circles when a new color is chosen) should be performed in
# an observer. Each independent set of things that can change
# should be managed in its own observer.
observe({
pal <- colorpal()
leafletProxy("map", data = filteredData()) %>%
clearShapes() %>%
addCircles(radius = ~10^mag/10, weight = 1, color = "#777777",
fillColor = ~pal(mag), fillOpacity = 0.7, popup = ~paste(mag)
) %>% addTiles("http://{s}.basemaps.cartocdn.com/dark_all/{z}/{x}/{y}.png",
attribution = paste(
"© OpenStreetMap contributors",
"© CartoDB"
)
)
})
# Use a separate observer to recreate the legend as needed.
observe({
proxy <- leafletProxy("map", data = quakes)
# Remove any existing legend, and only if the legend is
# enabled, create a new one.
proxy %>% clearControls()
if (input$legend) {
pal <- colorpal()
proxy %>% addLegend(position = "bottomright",
pal = pal, values = ~mag
)
}
})
output$hist_plot <- renderEcharts4r({
iris %>%
e_charts() %>%
e_histogram(Sepal.Length, name = "histogram",breaks = "freedman-diaconis") %>%
e_tooltip(trigger = "axis") %>%
e_color(color = "#753732")
})
}
shinyApp(ui, server)

Split code of one leaflet map (so that input updates of one part does not affect other part of code)

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)

R shiny checkboxGroup to plot data on map

I am very new to shiny, and I have a question.
I have a simple dataset with observations (Number_Total) of species (Species), in a certain location (X,Y).
I would like to generate a map, that enables you to select the species in a dropdown menu. Shiny then shows you were the species occurs on the map.
I got pretty far (for my experience), but selecting species in the menu does not do anything...
ui <- (fluidPage(titlePanel("Species Checker"),
sidebarLayout(
sidebarPanel(
selectizeInput('species', 'Choose species',
choices = df$Species, multiple = TRUE)
),
mainPanel(
leafletOutput("CountryMap",
width = 1000, height = 500))
)
))
The server side
server <- function(input, output, session){
output$CountryMap <- renderLeaflet({
leaflet() %>% addTiles() %>%
setView(lng = 10, lat = 40, zoom = 5) %>%
addCircles(lng = df$Y, lat = df$X, weight = 10,
radius =sqrt(df$Number_Total)*15000, popup = df$Species)
})
observeEvent(input$species, {
if(input$species != "")
{
leafletProxy("CountryMap") %>% clearShapes()
index = which(df$Species == input$species)
leafletProxy("CountryMap")%>% addCircles(lng = df$X[index],
lat = df$Y[index],
weight = 1,
radius =sqrt(df$Number_Total[index])*30, popup = df$Species[index])
}
})
}
And finally plot it
shinyApp(ui = ui, server = server)
I know my code is probably messy, but again, I blaim my experience =)
I did not manage to get an example dataset in here right away, so here it comes as picture
This is the result of the above code (with slightly different data)
enter image description here
Here's what you need. I think you are skilled enough to understand this but comment if you have any questions.
server <- function(input, output, session) {
# map_data <- reactive({
# req(input$species)
# df[df$Species %in% input$species, ]
# })
output$CountryMap <- renderLeaflet({
leaflet() %>% addTiles() %>%
setView(lng = 10, lat = 40, zoom = 5)
})
map_proxy <- leafletProxy("CountryMap")
observe({
md <- df[df$Species %in% input$species, ]
map_proxy %>%
addCircles(lng = md$Y, lat = md$X, weight = 10,
radius = sqrt(md$Number_Total)*15000, popup = md$Species)
})
}

Clear leaflet markers in shiny app with slider bar

I'm trying to build a shiny app that will only plot points on rows that have a value within the range of a slider bar. If I increase the range of the slider bar, points will be added, but points are never removed when I decrease the range of the slider bar. Below is a reproducible example of my problem.If you increase the slider bar to full range, 3 points will show up on the map. If you then decrease the range enough it will zoom in on one point, but if you zoom out you will see that there are still 3 points being plotted on a map. I thought the clearShapes or clearMarkers function in leaflet would remove these points, but it's not working. Any suggestions?
library(shiny)
library(leaflet)
library(tidyverse)
ui <- fluidPage(
titlePanel("Test"),
sidebarLayout(
sidebarPanel(
radioButtons("choice","Group:",choices = c(1,2), selected = 1),
uiOutput("value"),
verbatimTextOutput("Click_text")
),
mainPanel(
leafletOutput("Map")
)
)
)
server <- function(input, output) {
df <- data.frame(lat = c(42.34,43.65,45.26,48.63,47.65,47.52),
lng = c(-96.43,-97.45,-98.56,-92.35,-94.56,-95.62),
id = c(32,45,65,76,34,12),
grp = c(1,1,1,2,2,2),
val = c(1.75,2.12,3.2,3.32,4.76,4.85))
subsetData1 <- reactive({
df %>% filter(grp == input$choice)
})
output$value <- renderUI({
sliderInput("value",label = h3("value"),
min = min(subsetData1()$val,na.rm = TRUE),
max = max(subsetData1()$val,na.rm=TRUE),
value = c(quantile(subsetData1()$val,.25,na.rm = TRUE),quantile(subsetData1()$val,.75,na.rm=TRUE)))
})
subsetData <- reactive({
df2 <- subsetData1() %>% data.frame()
df2 %>% filter(val >= min(as.numeric(input$value)) & val <= max(as.numeric(input$value)))
})
output$Map <- renderLeaflet({
leaflet(height = 1000) %>%
addTiles() %>%
fitBounds(min(df$lng),min(df$lat),max(df$lng),max(df$lat))
})
observe({
leafletProxy("Map") %>%
clearMarkers() %>%
clearShapes() %>%
addCircleMarkers(data = subsetData(),
lng = ~lng,
lat = ~lat,
layerId = ~id,
radius = 8,
weight = 10) %>%
fitBounds(.,min(subsetData()$lng),min(subsetData()$lat),
max(subsetData()$lng),max(subsetData()$lat))
})
observe({
click<-input$Map_marker_click
if(is.null(click))
return()
text<-paste("Latitude ", click$lat, "Longtitude ", click$lng)
text2<-paste("You've selected point ", click$id)
output$Click_text<-renderText({
text2
})
})
}
# Run the application
shinyApp(ui = ui, server = server)
You can change your observe function where you clear markers to an observeEvent function.
observeEvent(input$value,{
leafletProxy("Map") %>%
clearMarkers() %>%
clearShapes() %>%
addCircleMarkers(data = subsetData(),
lng = ~lng,
lat = ~lat,
layerId = ~id,
radius = 8,
weight = 10) %>%
fitBounds(.,min(subsetData()$lng),min(subsetData()$lat),
max(subsetData()$lng),max(subsetData()$lat))
})
You also have both the uiOutput and sliderInput id's as the same (value). You should make sure every element has a unique id. Rename one of them to something unique.

Leaflet choropleth maps in shiny - unable to use addPolygons function properly

I am new to writing shiny apps and new to using the leaflet package. I am trying to create a shiny app which will get user inputs and plot a choropleth map based on the aggregated values of the selected user variable.
My sample dataset has the following variables: statename latitude longitude countyname medianage asianpopulation otherpopulation
My app would ask the user to select from either username or countyname. Based on this selection, internally I group my dataset using statename or countyname.
Then the user selects either one or many from the variables: medianage asianpopulation otherpopulation.
Based on this, I want to plot the choropleth map on the sum of the values of these variables and show a table below with these values.
I am not able to use the addPolygons method to plot the map. Do I need to use a shape file for this? Where am I going wrong in this code?
library(dplyr)
library(shiny)
library(readr)
library(leaflet)
library(lazyeval)
library(rgdal)
setwd("E:/Data")
ui <- fluidPage(
titlePanel("Filters"),
sidebarLayout(
sidebarPanel(
radioButtons("level", "Select the Level", choices = c("State", "County"),selected = "State" ,inline = TRUE),
selectInput("variable", "Variable Name", choices = NULL, multiple = FALSE, selectize = TRUE, selected = "medianage")
),
mainPanel(
leafletOutput("map"),
dataTableOutput("heatmapdata")
)
)
)
server <- function(input, output, session) {
read_csv(file="Sample.csv") %>%
select(statename, latitude, longitude, countyname, medianage, asianpopulation, otherpopulation) -> heatmapData -> hd
variable = c()
group = c()
heatmapData <- data.frame(heatmapData)
hd <- heatmapData
heatmapdata_1 <- select(heatmapData, -c(latitude, longitude))
heatmapdata_2 <- select(heatmapdata_1, -c(statename, countyname))
updateSelectInput(session, "variable", choices = sort(unique(colnames(heatmapData))), selected = "medianage")
heatmapdata_2 <- heatmapdata_1
datasetLevel.group <- function(df, grp.var) {
df %>% group_by_(grp.var) %>%
summarise_each(funs(sum)) -> df
df
}
datasetLevel <- reactive({
heatmapdata_2 <- heatmapdata_1
inputvariable <- c("medianage")
if (input$level == "State") {
inputlevel = c("statename")
heatmapdata_2 <- select(heatmapdata_2, -c(countyname))
}
if (input$level == "County") {
inputlevel = c("countyname")
heatmapdata_2 <- select(heatmapdata_2, -c(statename))
}
sm <- datasetLevel.group(heatmapdata_2, inputlevel)
group <- inputlevel
variable <- inputvariable
l_hd <- list(sm, inputlevel, input$variable)
l_hd
})
output$map <- renderLeaflet(
{
leaflet() %>% addTiles(options=tileOptions(minZoom = 3, maxZoom = 10)) %>%
setView(lng = -98.35, lat = 39.5, zoom = 4) %>%
setMaxBounds( -180, 5, -52, 73)
}
)
output$heatmapdata <- renderDataTable(
select_(datasetLevel()[[1]], datasetLevel()[[2]], datasetLevel()[[3]]),
options = list(pageLength=5,
scrollX=TRUE,
lengthMenu = c(5, 10, 25, 100),
searching=FALSE)
)
observe({
pal <- colorQuantile("YlOrRd", NULL, n = 20)
leafletProxy("map", data = datasetLevel()[[1]]) %>%
clearMarkers() %>%
clearMarkerClusters() #%>%
# addPolygons(data = datasetLevel()[[1]],
# fillColor = ~pal(variable),
# fillOpacity = 0.8,
# color = "#BDBDC3",
# weight = 1)
})
}
shinyApp(ui = ui, server = server)
I have commented out the addPolygons code as I get an error with that. I have been breaking my head to get the maps color coded based on the aggregated values of the selected variable.
The data file can be found at: https://drive.google.com/file/d/0B4PQcgewfQ3-MF9lNjU4clpUcUk/view?usp=sharing
Any help on this will be really helpful. Thanks.

Resources