shiny leaflet display labels based on zoom level - r

I want to display my marker labels based on zoom level.
Based on (https://rstudio.github.io/leaflet/shiny.html) I tried to use "input$MAPID_zoom". In my example, labels stored in location_name should be displayed when zoom level (mapscale) is lower to 6.
What I tried :
library(shiny)
library(leaflet)
# my data
df <- data.frame(
location_name = c('S1', 'S2'),
lng = c(-1.554136, -2.10401),
lat = c(47.218637, 47.218637),
stringsAsFactors = FALSE)
# UI
ui <- shinyUI(fluidPage(
leafletOutput('map')
))
# server
server <- shinyServer(function(input, output, session) {
mapscale <- observe({
input$map_zoom # get zoom level
})
output$map <- renderLeaflet({
leaflet() %>%
addTiles() %>%
addMarkers(data=df, lng = ~lng, lat = ~lat,
label =~if(mapscale<6, location_name))
})
})
shinyApp(ui = ui, server = server)

A few remarks on your code if you like.
If you wrap the zoom in a reactive function, reference it like mapscale(). Use the normal if statement in R and the ~ in front of the variable. Then you should be fine.
Reproducible example:
library(shiny)
library(leaflet)
df <- data.frame(
location_name = c('S1', 'S2'),
lng = c(-1.554136, -2.10401),
lat = c(47.218637, 47.218637),
stringsAsFactors = FALSE
)
ui <- shinyUI(
fluidPage(
leafletOutput(outputId = 'map')
)
)
server <- shinyServer(function(input, output, session) {
output$map <- renderLeaflet({
leaflet() %>%
addTiles()
})
observeEvent(
eventExpr = input$map_zoom, {
print(input$map_zoom) # Display zoom level in the console
leafletProxy(
mapId = "map",
session = session
) %>%
clearMarkers() %>%
addMarkers(
data = df,
lng = ~lng,
lat = ~lat,
label = if(input$map_zoom < 6) ~location_name
)
}
)
})
shinyApp(
ui = ui,
server = server
)

Related

How to filter the data in shiny using select input?

I wanted to filter the district names in two of the data sets based on the drop-down selection and map them using plots. I get the following error message.
Error : Problem with filter() input ..1. i Input ..1 is
district == input$district. x Can't access reactive value 'district'
outside of reactive consumer. i Do you need to wrap inside reactive()
or observe()?
library(shiny)
library(sf)
library(sp)
library(tidyverse)
library(osrm)
library(leaflet)
library(dplyr)
library(geosphere)
library(readxl)
dst = c('A',
'B',
'C')
raw1 <- read_xlsx("raw_map.xlsx")
clean1 <- read_xlsx("clean_map.xlsx")
ui <- fluidPage(
titlePanel("District data viz"),
sidebarLayout(
sidebarPanel(
selectInput("district",
"Name of the dst:",
choices = dst),
),
mainPanel(
fluidRow(12,leafletOutput("raw")),
fluidRow(12,leafletOutput("clean")),
)
)
)
server <- function(input, output) {
raw <- dplyr::filter(raw1, district == input$district)
clean <- dplyr::filter(clean1, district == input$district)
output$raw <- renderLeaflet({
leaflet(data = raw) %>%
addTiles() %>%
addMarkers(lng = raw$lon, lat = raw$lat,
label = raw$CHE_Village,
popup = raw$CHE_Name,
labelOptions = labelOptions(noHide = T))
})
output$clean <- renderLeaflet({
leaflet(data = clean) %>%
addTiles() %>%
addMarkers(lng = clean$lon, lat = clean$lat,
label = clean$CHE_Village,
popup = clean$CHE_Name,
labelOptions = labelOptions(noHide = T))
})
}
shinyApp(ui = ui, server = server)

Leaflet addMarkers icon not showing in R

I'm attempting to add markers to a map, however for some reason the marker icon no longer renders:
Here's a reproducible example shiny app:
library(shiny)
library(tidyverse)
library(leaflet)
ui <- fluidPage(
# Application title
titlePanel("Leaflet example"),
leafletOutput("example")
)
server <- function(input, output) {
output$example <- renderLeaflet({
leaflet() %>%
addProviderTiles(providers$Esri.WorldGrayCanvas) %>%
setView(lng = -71.0589, lat = 42.3601, zoom = 15) %>%
addMarkers(
lng = -71.0589,
lat = 42.3601
)
})
}
# Run the application
shinyApp(ui = ui, server = server)

Creating interactive Leaflet map in R with shiny

I created a shiny app with leaflet and it works pretty well.
library(shiny)
library(shinythemes)
library(leaflet)
ui2 <- fluidPage(theme = shinytheme("united"), tabsetPanel(
tabPanel(
titlePanel("titel"),
mainPanel(
leafletOutput(outputId = "mymap")),
sidebarPanel(
fluidRow(
dateRangeInput("a", h4("date"),language = "en",separator = " to "),
selectInput("select", h4("location"),
c(data8$city)),
submitButton("search"))
))
)
)
server <- function(input, output) {
popupa <- paste(titel)
output$mymap <- renderLeaflet({
leaflet(data8) %>%
addTiles() %>%
addMarkers(lng = ~lng, lat = ~lat, popup = popupa)
})
}
shinyApp(ui2, server)
But at the moment I am trying to add a dateRangeInput to filter(date_start) on my shown locations. But I don't know how to connect my dateRangeInput and the selectInput to my leaflet-function in the server-part. Furthermore, below the map there should be a table with the filtered locations from the map - is this possible at all?
My used dataframe looks like following:
title=c("Event1","Event2")
lng=c(23.3, 23.3)
lat=c(30, 40)
city=c("Berlin", "Hamburg" )
zip=c(39282, 27373)
date_start=c("2018-05-28","2018-05-28")
date_end=c("2018-06-27","2018-08-03")
data8 <- data.frame(title, lng, lat, city, zip, date_start, date_end)
Does anyone know how to get this done? Thanks for every help!
regards
You could try this:
ui2 <- fluidPage(theme = shinytheme("united"), tabsetPanel(
tabPanel(
titlePanel("titel"),
mainPanel(
leafletOutput(outputId = "mymap"),
dataTableOutput("mytable")),
sidebarPanel(
fluidRow(
dateRangeInput("a", h4("date"),language = "en",separator = " to "),
selectInput("selectLoc", h4("location"),
as.character(data8$city)),
submitButton("search"))
))
)
)
server <- function(input, output) {
popupa <- paste("titel")
datatoPlot <- reactive({
date_start <- as.character(input$a[1])
date_end <- as.character(input$a[2])
data8$date_start <- as.Date(data8$date_start, format = "%Y-%m-%d")
data8 <- data8[as.Date(data8$date_start) >= date_start & as.Date(data8$date_start) <= date_end, ]
data8 <- data8 %>% dplyr::filter(city == input$selectLoc)
})
output$mymap <- renderLeaflet({
leaflet(datatoPlot()) %>%
addTiles() %>%
addMarkers(lng = ~lng, lat = ~lat, popup = popupa)
})
output$mytable <- renderDataTable(datatoPlot())
}
shinyApp(ui2, server)

render leaflet markers across tabs on shiny startup

I'm trying to create two leaflet maps in an R shiny app that are placed in different tabpanels using the tabsetPanel() function. I would like to have a widget (e.g., sliderInput()) that controls the size of markers on both maps. I can create an app that does this but the problem is that features are not initially rendered on the map that is on the second panel on startup. Features are rendered on the second panel only after selecting the panel, then changing the input with a slider. I would like both maps to show their features on startup without having to initialize the second with a slider.
library(shiny)
library(leaflet)
pts <- data.frame(
x = rnorm(10, mean = -93.625),
y = rnorm(10, mean = 42.0285)
)
# Define UI
ui <- fluidPage(
sliderInput("radius",
"Point radius:",
min = 1,
max = 50,
value = 30),
tabsetPanel(
tabPanel('Map1',
leafletOutput('map1')
),
tabPanel('Map2',
leafletOutput('map2')
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$map1 <- renderLeaflet({
leaflet() %>%
addTiles() %>%
setView(-93.65, 42.0285, zoom = 6)
})
output$map2 <- renderLeaflet({
leaflet() %>%
addTiles() %>%
setView(-93.65, 42.0285, zoom = 6)
})
observe({
tab1 <- leafletProxy('map1', data = pts) %>%
clearMarkers() %>%
addCircleMarkers(lng = ~x, lat = ~y, radius = input$radius)
tab2 <- leafletProxy('map2', data = pts) %>%
clearMarkers() %>%
addCircleMarkers(lng = ~x, lat = ~y, radius = input$radius)
})
}
# Run the application
shinyApp(ui = ui, server = server)
As a simple fix, you could give your tabsetPanel an id, and put the corresponding input in your observer, so that the observer also invalidates when you change tabs. Working example is given below, I hope this helps!
library(shiny)
library(leaflet)
pts <- data.frame(
x = rnorm(10, mean = -93.625),
y = rnorm(10, mean = 42.0285)
)
# Define UI
ui <- fluidPage(
sliderInput("radius",
"Point radius:",
min = 1,
max = 50,
value = 30),
tabsetPanel(id='my_tabsetPanel',
tabPanel('Map1',
leafletOutput('map1')
),
tabPanel('Map2',
leafletOutput('map2')
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$map1 <- renderLeaflet({
leaflet() %>%
addTiles() %>%
setView(-93.65, 42.0285, zoom = 6)
})
output$map2 <- renderLeaflet({
leaflet() %>%
addTiles() %>%
setView(-93.65, 42.0285, zoom = 6)
})
observe({
input$my_tabsetPanel
tab1 <- leafletProxy('map1', data = pts) %>%
clearMarkers() %>%
addCircleMarkers(lng = ~x, lat = ~y, radius = input$radius)
tab2 <- leafletProxy('map2', data = pts) %>%
clearMarkers() %>%
addCircleMarkers(lng = ~x, lat = ~y, radius = input$radius)
})
}
# Run the application
shinyApp(ui = ui, server = server)

Get coordinates from a drawing object from an R leaflet map

I am building a shiny app where I would like to get the coordinates of a polygon from a leaflet map. Specifically, the shape is drawn using the Drawtoolbar from the leaflet.extras package. A simple example app is below.
My question is, how can I get the coordinates from the shape drawn on the map by the user? Thank you in advance.
library(shiny)
library(leaflet)
library(leaflet.extras)
# Define UI
ui <- fluidPage(
leafletOutput("mymap",height=800)
)
# Define server logic
server <- function(input, output) {
output$mymap <- renderLeaflet(
leaflet() %>%
addProviderTiles("Esri.OceanBasemap",group = "Ocean Basemap") %>%
setView(lng = -166, lat = 58.0, zoom = 5) %>%
addDrawToolbar(
targetGroup='draw',
editOptions = editToolbarOptions(selectedPathOptions = selectedPathOptions())) %>%
addLayersControl(overlayGroups = c('draw'), options =
layersControlOptions(collapsed=FALSE))
)
observeEvent(input$mymap_shape_click,{
print(input$mymap_shape_click)
})
observeEvent(input$mymap_click,{
print(input$mymap_click)
})
}
# Run the application
shinyApp(ui = ui, server = server)
You need to observe the _draw_new_feature function
library(leaflet.extras)
# Define UI
ui <- fluidPage(
leafletOutput("mymap",height=800)
)
# Define server logic
server <- function(input, output) {
output$mymap <- renderLeaflet(
leaflet() %>%
addProviderTiles("Esri.OceanBasemap",group = "Ocean Basemap") %>%
setView(lng = -166, lat = 58.0, zoom = 5) %>%
addDrawToolbar(
targetGroup='draw',
editOptions = editToolbarOptions(selectedPathOptions = selectedPathOptions())) %>%
addLayersControl(overlayGroups = c('draw'), options =
layersControlOptions(collapsed=FALSE))
)
observeEvent(input$mymap_draw_new_feature,{
feature <- input$mymap_draw_new_feature
print(feature)
})
}
# Run the application
shinyApp(ui = ui, server = server)

Resources