In the code below, the leaflet addCircles get drawn twice after a change in zoom. I think this double plotting occurs because the reactive to create a dataframe always updates with a change in zoom. However, I only want the reactive dataframe (race.dots.all.r) to update when a zoom threshold is crossed. Any ideas?
EDIT: I removed even more code to simplify and made it reproducible by adding a dropbox link to the data.
library(shiny)
library(leaflet)
library(dplyr)
load(url("https://www.dropbox.com/s/umhqvoqvbhlkrc6/shiny_app_seg_gap_stackoverflow.RData?dl=1"))
ui <- shinyUI(fluidPage(
leafletOutput("map"),
checkboxInput("togglewhite", "White", value = TRUE)
))
server <- shinyServer(function(input, output, session) {
per.person <- eventReactive(input$map_zoom,{
new_zoom <- 12
if (!is.null(input$map_zoom)) {
new_zoom <- input$map_zoom}
if ( new_zoom < 13 ) {
per.person <- "1000"
} else {
per.person <- "250"
}
return(per.person)
})
race.dots.all.r <- eventReactive(per.person(),{
race.dots.all <- race.dots.all[[per.person()]]
return(race.dots.all)
})
values <- reactiveValues(school = NULL)
output$map <- renderLeaflet({
leaflet(options = leafletOptions(preferCanvas = TRUE)) %>%
addProviderTiles("CartoDB") %>%
setView(lat=40.73771, lng=-74.18958, zoom = 8)
})
observeEvent(c(input$togglewhite, race.dots.all.r()), {
proxy <- leafletProxy('map')
proxy %>% clearGroup(group = "White")
if (input$togglewhite){
race.dots.all.selected.race <- dplyr::filter( race.dots.all.r(), group == "White")
proxy %>% addCircles(group = race.dots.all.selected.race$group,
race.dots.all.selected.race$lng,
race.dots.all.selected.race$lat)
}
},ignoreInit = TRUE)
}) # close server
shinyApp(ui, server)
If I understand your requirement correctly then here's one way to do it. I have set the zoom threshold at 0 for this example just so that it is easy to demo. You can change it to 4 for your app.
library(shiny)
library(leaflet)
shinyApp(
ui = fluidPage(
leafletOutput("map")
),
server = function(input, output, session) {
output$map <- renderLeaflet({
leaflet() %>%
addTiles()
})
map_proxy <- leafletProxy("map")
observeEvent(input$map_zoom, {
if(input$map_zoom > 0) {
map_proxy %>%
addCircleMarkers(lng = 74.0060, lat = 40.7128,
group = "high_zoom_in", radius = 50, color = "red")
} else {
map_proxy %>%
clearGroup("high_zoom_in")
}
})
}
)
Related
I would like to automatically detect which polygon is at the center of the map. And it should update dynamically when the user is moving through the map.
For the moment I could not find a way to reverse find on which polygon are some coordinates.
I think I could simulate a input$map_shape_click with shinyjs or javascript and so get input$map_shape_click$id, but before I go to this solution, I would like to make sure there is no other way.
Here is a minimal example
library(leaflet)
library(shiny)
# data source : https://biogeo.ucdavis.edu/data/gadm3.6/Rsp/gadm36_FRA_2_sp.rds
cities <- readRDS(file = "../gadm36_FRA_2_sf.rds")
ui <- fluidPage(leafletOutput("map"))
server <- function(input, output, session) {
rv <- reactiveValues()
output$map <- renderLeaflet({
leaflet() %>%
addProviderTiles(provider = providers$CartoDB.Positron) %>%
setView(lng = 1, lat = 45, zoom = 8) %>%
addPolygons(data = cities,layerId = ~NAME_2,label = ~NAME_2)
})
observeEvent(input$map_bounds,{
rv$center <- c(mean(input$map_bounds$north, input$map_bounds$south), mean(input$map_bounds$east, input$map_bounds$west))
# how can I detect on which polygon the center is ?
})
}
shinyApp(ui = ui, server = server)
library(leaflet)
library(shiny)
library(sf)
cities <- readRDS(file = "gadm36_FRA_2_sp.rds") %>%
st_as_sf()
ui <- fluidPage(leafletOutput("map"))
server <- function(input, output, session) {
rv <- reactiveValues()
output$map <- renderLeaflet({
leaflet() %>%
addProviderTiles(provider = providers$CartoDB.Positron) %>%
setView(lng = 1, lat = 45, zoom = 8) %>%
addPolygons(data = cities, layerId = ~NAME_2, label = ~NAME_2)
})
observeEvent(input$map_bounds, {
rv$center <- c(mean(input$map_bounds$north, input$map_bounds$south), mean(input$map_bounds$east,
input$map_bounds$west))
pnt <- st_point(c(rv$center[2], rv$center[1]))
rslt <- cities[which(st_intersects(pnt, cities, sparse = FALSE)),]$NAME_1
print(rslt)
})
}
shinyApp(ui = ui, server = server)
So I found a way to do it with the function sf::st_intersects
observeEvent(input$map_bounds,{
rv$center <- data.frame(x = mean(c(input$map_bounds$north, input$map_bounds$south)),
y = mean(c(input$map_bounds$east, input$map_bounds$west)))
res <- sf::st_as_sf(rv$center, coords=c("y","x"), crs=st_crs(cities$geometry))
intersection <- as.integer(st_intersects(res, cities$geometry))
print(if_else(is.na(intersection), '', cities$NAME_2[intersection]))
})
I am trying to visualise a random walk. Not its path, but actually see the marker moving as it wanders around. Something like this.
I have come with this workaround in which I clear all markers and add them again with the new positions at every step.
library(shiny)
library(leaflet)
df <- data.frame(latitude = 10, longitude = 0)
ui <- fluidPage(
sliderInput("time", "date", 0,
1e2,
value = 1,
step = 1,
animate = TRUE
),
leafletOutput("mymap")
)
server <- function(input, output, session) {
points <- eventReactive(input$time, {
df$latitude <- df$latitude + rnorm(1)
df$longitude <- df$longitude + rnorm(1)
df
})
output$mymap <- renderLeaflet({
leaflet() %>%
addTiles()
})
observe({
leafletProxy("mymap") %>%
clearMarkers() %>%
addMarkers(data = points())
})
}
shinyApp(ui, server)
But I found a much more neat solution in this method movingMarker. I was wondering if there's a way to implement it using that javascript code.
I'm trying to add markers on my interactive Leaflet map if the user ticks off a checkbox. However, I can't get the checkbox-appearance to work within the renderLeaflet function, but I can within a renderPlot function.
My code, that works, looks as below:
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
checkboxInput('check1','Show Counties', value = TRUE)),
mainPanel(
# I'm aware that this should be changed to leaftletOutput, when used
# with the in the second code snippet below
plotOutput("mymap")
),
position = 'right'
)
)
server <- function(input, output) {
output$mymap <- renderPlot({
if (input$check1){
hist(rnorm(10))
} else {
hist(rnorm(100))
}
})
}
shinyApp(ui = ui, server = server)
The same logic doesn't work within Leaflet, and I would highly appreciate input on how to modify the below code. I know you don't have access to the two variables, USstates or coor, but I was hoping one could point the error, potentially in terms a syntax error. The output function looks as follows;
output$mymap <- renderLeaflet({
if (input$check1 == TRUE){
leaflet(USstates) %>%
addTiles() %>%
addPolygons(color = 'navy',
opacity = 1.0,
weight = 1) %>%
addMarkers(lng = coor[,1],lat = coor[,2])
} else {
leaflet(USstates) %>%
addTiles() %>%
addPolygons(color = 'navy',
opacity = 1.0,
weight = 1)
}
})
I came up with a solution, of cause right after I created this post. The solution was to wrap the leaflet code in a reactive function and call that one in the renderLeaflet function. The solution is as follows:
server <- function(input, output) {
display <- reactive({
if (input$check1){
leaflet(USstates) %>%
addTiles() %>%
addPolygons(color = 'navy',
opacity = 1.0,
weight = 1) %>%
addMarkers(lng = coor[,1],lat = coor[,2])
} else {
leaflet(USstates) %>%
addTiles() %>%
addPolygons(color = 'navy',
opacity = 1.0,
weight = 1)
}
})
output$mymap <- renderLeaflet({
display()
})
}
I have a shiny app, where I want to plot CircleMarkers on a leaflet map. Additionally a marker should be plotted, controlled over an overlayGroup. When the zoom level is greater than 7 the marker should be plotted otherwise not. This is done by sending code to the server and getting the index of the marker. See also here: Show layer in leaflet map in Shiny only when zoom level > 8 with LayersControl?
It works fine, but when I add the addSearchOSM plugin from leaflet.extras the CircleMarkers will not be plotted anymore when the app starts. So the observe statement will not be rendered until I change an input.
This is the code:
library(leaflet)
library(leaflet.extras)
library(shiny)
data <- data.frame(longitude = c(11.43, 11.55), latitude = c(48, 48.5), label = c("a", "b"))
getInputwithJS <- '
Shiny.addCustomMessageHandler("findInput",
function(message) {
var inputs = document.getElementsByTagName("input");
console.log(inputs);
Shiny.onInputChange("marker1", inputs[1].checked);
}
);
'
ui <- fluidPage(
sidebarPanel(
selectInput("label", "label", selected = "a", choices = data$label)
),
mainPanel(
leafletOutput("map", width = "100%", height = "700"),
tags$head(tags$script(HTML(getInputwithJS)))
)
)
server <- function(input, output, session){
# subset data according to label input
data_subset <- reactive({
data[data$label %in% input$label, ]
})
output$map <- renderLeaflet({
leaflet() %>% addTiles() %>% setView(11, 48.5, 7) %>%
addLayersControl(overlayGroups = c("marker1"),
options = layersControlOptions(collapsed = FALSE)) %>%
addSearchOSM()
})
# does not show points when app starts
observe({
leafletProxy("map") %>% clearGroup("points") %>%
addCircleMarkers(data_subset()$longitude, data_subset()$latitude, group = "points")
})
global <- reactiveValues(DOMRdy = FALSE)
autoInvalidate <- reactiveTimer(1000)
observe({
autoInvalidate()
if(global$DOMRdy){
session$sendCustomMessage(type = "findInput", message = "")
}
})
session$onFlushed(function() {
global$DOMRdy <- TRUE
})
# add marker if marker is clicked in layerscontrol and zoom level of map > 7
observe({
if (!is.null(input$marker1)){
if (input$marker1 == TRUE){
if (input$map_zoom > 7) {
leafletProxy("map") %>% addMarkers(lng = 11.2, lat = 48, group = "marker1")
}else{
leafletProxy("map") %>% clearGroup(group = "marker1")
}
}
}
})
}
shinyApp(ui, server)
I am experimenting with the leaflet package for some maps in Shiny. I would like to be able to have a base map that data will change and subsequently be remapped. However, I am trying to use the leafletProxy function whereby there is a base map and I just change the data points that are added. All of this works however the map doesn't zoom to the datapoints location. It remains at the farthest zoom.
The code to reproduce the problem:
library(shiny)
library(leaflet)
r_colors <- rgb(t(col2rgb(colors()) / 255))
names(r_colors) <- colors()
ui <- fluidPage(
leafletOutput("mymap"),
p(),
actionButton("goButton", "New Points")
)
server <- function(input, output, session) {
output$mymap <- renderLeaflet({
leaflet() %>%
addProviderTiles("Stamen.TonerLite",
options = providerTileOptions(noWrap = TRUE)
)
})
observeEvent(input$goButton, {
points <- cbind(rnorm(40) * 2 + 13, rnorm(40) + 48)
leafletProxy('mymap', session) %>%
clearMarkers() %>%
addMarkers(data = points)
})
}
shinyApp(ui, server)
I would like the map to automatically zoom in once new points have been added.
try to add argument "fitBounds" in leafletProxy()
leafletProxy('mymap', session) %>%
clearMarkers() %>%
addMarkers(data = points) %>%
fitBounds(lng1 = max(points$long),lat1 = max(points$lat),
lng2 = min(points$long),lat2 = min(points$lat))
I revised G. Cocca's answer (mostly by adding a dataframe of "points") to get this:
library(shiny)
library(leaflet)
r_colors <- rgb(t(col2rgb(colors()) / 255))
names(r_colors) <- colors()
ui <- fluidPage(
leafletOutput("mymap"),
p(),
actionButton("goButton", "New Points")
)
server <- function(input, output, session) {
output$mymap <- renderLeaflet({
leaflet() %>%
addProviderTiles("Stamen.TonerLite",
options = providerTileOptions(noWrap = TRUE)
)
})
observeEvent(input$goButton, {
points <- data.frame("long" = rnorm(40) * 2 + 13,
"lat" = rnorm(40) + 48)
leafletProxy('mymap', session) %>%
clearMarkers() %>%
addMarkers(data = points) %>%
fitBounds(lng1 = max(points$long),lat1 = max(points$lat),
lng2 = min(points$long),lat2 = min(points$lat))
})
}
shinyApp(ui, server)