Observe click event on a synced map in Leaflet/RShiny - r

I'm creating a mapping visualization in RShiny, and I'm trying to detect a map shape click. I know that you can do this by using observeEvent, but my issue is that I'm using leafsync to synchronize my maps, so I have to wrap my Leaflet maps in a renderUI. Here's a simplified version of my code:
ui <- fluidPage(
navbarPage('CS4All and CTE Progress Visualization',
tabPanel('Map',
div(class='outer',
sidebarLayout(
mainPanel(
uiOutput('synced_maps')
)
)
)
)
)
)
server <- function(input, output) {
output$synced_maps <- renderUI({
# --- CS4ALL MAP
cs4all_map <- leaflet() %>%
setView(lat=40.730610, lng=-73.935242, zoom = 10) %>%
addProviderTiles(providers$CartoDB.Positron) %>%
addPolygons(data = ctecscrs_geo,
stroke = TRUE,
color = '#808080',
weight = 1)
# --- CTE MAP
cte_map <- leaflet() %>%
setView(lat=40.730610, lng=-73.935242, zoom = 10) %>%
addProviderTiles(providers$CartoDB.Positron) %>%
addPolygons(data = ctecscrs_geo,
stroke = TRUE,
color = '#808080',
weight = 1)
# --- DEMOGRAPHICS MAP
dem_map <- leaflet() %>%
setView(lat=40.730610, lng=-73.935242, zoom = 10) %>%
addProviderTiles(providers$CartoDB.Positron) %>%
addPolygons(data = csd_dem_geo,
stroke = TRUE,
color = '#808080',
weight = 1)
sync(cs4all_map, cte_map, dem_map)
})
}
I tried adding the following both inside and outside of the renderUI function:
observeEvent(input$cte_map_shape_click, {
click <- input$cte_map_shape_click
print(click$id)
})
and in both instances, nothing printed to the console. Does anyone know if it is possible to observe events on synchronized maps in Leaflet/RShiny?

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)

How to stop Shiny Leaflet map from recentering each time a control widget is changed

I am making a Shiny Leaflet map that shows a set of rivers with water quality data by month. Following is my server code for rendering the leaflet. I would like to change it so that the map is not redrawn and recentered every time the user changes the month control widget. I can't figure out how to do this. I have tried putting the setView statement inside an if() clause using a global variable that tracks whether this is the first run, but I get errors. I have tried removing the setView statement completely, but the map still redraws to the default bounds of the rivers and data.
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput(inputId = "month",
label = "Month (March-November)",
min = 3, max = 11,
step = 1, ticks = FALSE,
value = 9)
)
mainPanel(
leafletOutput("map", width = "100%", height = 480)
)
)
)
server <- function(input, output){
output$map <- renderLeaflet({
map <- leaflet(DFA()) %>% addProviderTiles(providers$Esri.WorldGrayCanvas) %>%
setView(-71.46, 42.42, zoom = 10) %>%
addPolylines(data = majStrm, color = "blue",
weight = 2, smoothFactor = 1) %>%
addCircleMarkers(lng = ~Lon, lat = ~Lat,
fillColor = ~pal(DFA()[,7]),
fillOpacity = 0.9,
radius = 6,
stroke = TRUE, weight = 1,
color = "black", opacity = 1)
map
})
}
It's a normal behavior. renderLeaflet builds a new map each time it is triggered by an embedded reactive value. What you have to do is to use the leafletProxy function.
Use a simple observer to draw the initial map by using leaflet() then use an observeEvent triggered by DFA() and using leafletProxy("map") in place of leaflet() to update the map instead of recreating it.
# create static part of map
output$map <- renderLeaflet({
leaflet() %>%
... whatever to build base map ...
... without reactive part ...
})
# handle the update of the static map with reactive part
observe({
# update map
leafletProxy("map", data=DFA()) %>%
clearMarkers() %>%
addCircleMarkers(...)
})

Leaflet and Shiny "could not find function leafletOutput()"

I have a leaflet map and I want the option of switching from the values of A being mapped to the values of B. Every example I can find says to use shiny and leaflet and all of these examples include something along the lines of:
ui <- fluidPage(
selectInput(inputId = "Data",
label = "Data",
choices = c("A","B"),
leafletProxy(outputId = "map") #or leafletOutput
))
but I keep getting the error that
leafletProxy (or leafletOutput)does not exist
. How do I solve this? My leaflet is created with :
mypal <- colorNumeric(palette = "viridis", domain = d$A)
leaflet() %>%
addProviderTiles("OpenStreetMap.Mapnik") %>%
setView(lat = 39.8283, lng = -98.5795, zoom = 4) %>%
addPolygons(data =
USA, stroke = TRUE, color='black', opacity=1, weight=.5, smoothFactor = 0.2, fillOpacity = 1,
fillColor = ~mypal(d$A),
popup = paste('<b>',d$state, "</b><br>A:", d$A) %>%
addLegend(position = "bottomleft", pal = mypal, values = d$A,
title = "A",
opacity = 1)
It seems from your example that your shiny has no server function, so it is not going to work.
Please, find attached a mock shiny you can start building on:
library(shiny)
library(leaflet)
ui <- fluidPage(
selectInput(inputId = "Data",
label = "Data",
choices = c("A", "B")),
leafletOutput("map")
)
server <- server <- function(input, output, session) {
output$map <- renderLeaflet({
if((input$Data) == "A"){
point = c(42.6525, -73.757222)
}
if((input$Data) == "B"){
point = c(39.283333, -76.616667)
}
leaflet() %>%
addProviderTiles("OpenStreetMap.Mapnik") %>%
addMarkers(lat = point[1], lng = point[2])
})
It will show "Albany" when you select "A" and Baltimore when you select "B"
Basically:
ui is kind of the "interface", what it is going to be shown:
selectInput: you can choose A or B here
leafletOutput: will show the leaflet map
server will do the "hard job" of creating the map and computing actions when you use selecInput:
output$map means that we want to render the leafletOuput (that is why it is called map, as in leafletOutput("map")
Then, according to the input selected (A or B)
if((input$Data) == "A"){
point = c(42.6525, -73.757222)
}
if((input$Data) == "B"){
point = c(39.283333, -76.616667)
}
We assign coordinates of Albany or Baltimore to point.
Finally, we build the map:
leaflet() %>%
addProviderTiles("OpenStreetMap.Mapnik") %>%
addMarkers(lat = point[1], lng = point[2])
PLEASE, take into account that this is a mock shiny, it is far from perfect, it is only illustrative.
Best!

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.

Resources