Creating interactive Leaflet map in R with shiny - r

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)

Related

Distinguish between input$map_click and input$map_shape_click in Leaflet R Shiny

What I would like to do is that if a user clicks on a line, it displays the line name in the box to the right of the map, and if a user clicks somewhere else on the map, it 'deselects' that line:
The problem is that when a user clicks the polyline, leaflet fires both a map_shape_click (the polyline) and map_click (the map) event. Even more annoyingly, it fires the map_shape_click event before the map_click event.
How can I distinguish whether the user has clicked a line, or just the base map, so that my select/deselect works? Reproducible example:
library(shiny)
library(tidyverse)
library(leaflet)
ui <- fluidPage(
fluidRow(
column(
width = 8,
leafletOutput("map")
),
column(
width = 4,
uiOutput("info")
)
)
)
server <- function(input, output) {
output$map <- renderLeaflet({
leaflet() %>%
addTiles() %>%
setView(lng = -71.03165, lat = 42.37595, zoom = 13) %>%
addPolylines(lng = c(-71.05884, -71.02), lat = c(42.360081, 42.359),
layerId = "line1") %>%
addPolylines(lng = c(-71.05884, -71.05), lat = c(42.360081, 42.4),
layerId = "line2")
})
observeEvent(input$map_shape_click, {
x <- input$map_shape_click
output$info <- renderUI({
div(
"Line: ", x$id
)
})
})
observeEvent(input$map_click, {
output$info <- renderUI({
div(
"Nothing selected"
)
})
})
}
shinyApp(ui = ui, server = server)
library(shiny)
library(tidyverse)
library(leaflet)
ui <- fluidPage(
fluidRow(
column(
width = 8,
leafletOutput("map")
),
column(
width = 4,
uiOutput("info")
)
)
)
server <- function(input, output) {
output$map <- renderLeaflet({
leaflet() %>%
addTiles() %>%
setView(lng = -71.03165, lat = 42.37595, zoom = 13) %>%
addPolylines(lng = c(-71.05884, -71.02), lat = c(42.360081, 42.359),
layerId = "line1") %>%
addPolylines(lng = c(-71.05884, -71.05), lat = c(42.360081, 42.4),
layerId = "line2")
})
clicked <- reactiveVal()
observeEvent(input$map_shape_click, {
freezeReactiveValue(input, 'map_click')
clicked(input$map_shape_click)
})
observeEvent(input$map_click, {
clicked(input$map_click)
})
output$info <- renderUI({
req(clicked())
if(is.null(clicked()[['id']])) return(div("Nothing selected"))
div("Line: ", clicked()$id)
})
}
shinyApp(ui = ui, server = server)
Things are a little tricky here. we use freezeReactiveValue to freeze the map click, meaning if there is any shape click event, we do not update the value of map_click. This is a little advanced shiny. I recommend you read the help file and read this chapter: https://mastering-shiny.org/action-dynamic.html#freezing-reactive-inputs

How to render Data Table in R Shiny using Dropdown input to filter Dataframe?

In continuation to my previous post where this was applied on map, I am trying to filter a table in R Shiny using Dropdown input: How to build dynamic Leaflet Map in RShiny?
Code:
library(shiny)
library(shinydashboard)
library(tidyverse)
library(leaflet)
library(readxl)
library(RCurl)
library(DT)
URL <- "https://www.mohfw.gov.in/pdf/PMJAYPRIVATEHOSPITALSCONSOLIDATED.xlsx"
download.file(URL, destfile = "../../timesnow_PMJAYPRIVATEHOSPITALSCONSOLIDATED.xlsx",method = "curl")
# Data
ind_vaccination_center <- readxl::read_xlsx(path = "../../timesnow_PMJAYPRIVATEHOSPITALSCONSOLIDATED.xlsx",
sheet = 1)
ind_vaccination_leaflet <- ind_vaccination_center %>%
mutate(label_display = paste(
"<h2>", ind_vaccination_center$`Name of the Vaccination Site*`, "</h2>",
"<h4>",ind_vaccination_center$`District*`,",", ind_vaccination_center$`State*`, "</h4>",
"<p>", "Address: ", ind_vaccination_center$Address,",", ind_vaccination_center$`PinCode*`, "</p>",
"<p>", "Mobile: ", ind_vaccination_center$`Mobile Number`, "</p>",
"<p>", "Contact Person: ", ind_vaccination_center$`Contact Person`, "</p>"
)
)
# Define UI for application
ui <- fluidPage(
# Application title
titlePanel("Covid19 Vaccination Centers in India"),
# Sidebar with a Dropdown
sidebarLayout(
sidebarPanel(
selectInput(inputId = "state_selection",
label = "Select State",
choices = ind_vaccination_center$`State*`),
h3("List of Vaccination Centers is plotted on Map & also listed in searchable table."),
"source of list:",
a("https://www.timesnownews.com/india/article/covid-19-vaccination-in-uttar-pradesh-check-complete-list-of-govt-and-private-hospitals-for-jab/726412"),
br(),
br(),
a("https://www.oneindia.com/india/full-list-of-private-hospitals-where-the-covid-19-vaccine-will-be-administered-3223706.html"),
br(),
br(),
"P.S - There might be more center's added to this list, kindly recheck from other sources as well like:",
br(),
a("https://www.cowin.gov.in/home")
),
# Show Map & table
mainPanel(
tabsetPanel(type = "tabs",
tabPanel("Map", leafletOutput("map",height = 800, width = "100%")),
tabPanel("Data Table", tableOutput("mytable"))
)
)
)
)
# Define server logic
server <- function(input, output) {
# solution from: https://stackoverflow.com/questions/66732758/how-to-build-dynamic-leaflet-map-in-rshiny/66733086#66733086
output$map <- renderLeaflet({
req(input$state_selection)
data <- ind_vaccination_leaflet %>%
filter(`State*` == input$state_selection)
# Creating map object & adding layers
leaflet(data) %>%
setView(lat = 26.64510, lng = 80.17012, zoom = 4) %>%
addTiles(group = "OSM") %>%
addProviderTiles(providers$CartoDB.DarkMatter, group = "Dark") %>%
addProviderTiles(providers$CartoDB.Positron, group = "Light") %>%
addProviderTiles("Stamen.Terrain", group = "Terrain") %>%
addProviderTiles("Esri.WorldImagery", group = "WorldImagery") %>%
addLayersControl(baseGroups = c("OSM","WorldImagery","Dark","Light","Terrain")) %>%
addCircleMarkers(
lng = ~`Longitude*`,
lat = ~`Latitude*`,
label = lapply(data$label_display, htmltools::HTML),
color = "midnightblue",
weight = 1,
radius = 8
)%>%
addMiniMap(tiles = providers$OpenStreetMap, width = 120, height=80)
})
output$mytable = DT::renderDataTable({
req(input$state_selection)
data <- ind_vaccination_leaflet %>%
filter(`State*` == input$state_selection)
data
})
}
# Run the application
shinyApp(ui = ui, server = server)
You need to do two changes.
tabPanel("Data Table", dataTableOutput("mytable"))
and
output$mytable = DT::renderDataTable({
req(input$state_selection)
data <- ind_vaccination_leaflet %>%
filter(`State*` == input$state_selection)
datatable(data)
})

shiny leaflet display labels based on zoom level

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
)

R Shiny with leaflet: create a modal window on clicking an icon

I want to create a modal window when I click an icon in a leaflet map in shiny. Is this doable? I tried the code below, but the bsModal is not doing anything.
library(shiny)
library(leaflet)
library(shinyBS)
points <- data.frame(cbind(latitude = rnorm(40) * 2 + 13, longitude =
rnorm(40) + 48))
ui <- fluidPage(
leafletOutput("mymap"),
bsModal("modalExample", "This will open a modal", "assign_task", size =
"large",
HTML(""))
)
server <- function(input, output, session) {
output$mymap <- renderLeaflet({
leaflet(options = leafletOptions(maxZoom = 18)) %>% addTiles() %>%
addMarkers(lat = ~ latitude, lng = ~ longitude,
data = points,
popup=~ sprintf(
'<button type="button" id="assign_task">Open Modal </button>'
))
})
}
shinyApp(ui, server)
I'll post two possible solutions. The first one is the solution that I think would suit your needs best, the second one more cosely matches your current code. Hope this helps!
Solution 1:
library(shiny)
library(leaflet)
points <- data.frame(cbind(id=seq(1,40),latitude = rnorm(40) * 2 + 13, longitude =
rnorm(40) + 48))
ui <- fluidPage(
leafletOutput("mymap"),
actionButton("action1","Show modal")
)
server <- function(input, output, session) {
observeEvent(input$mymap_marker_click, {
id = input$mymap_marker_click$id
showModal(modalDialog(
title = "You selected a marker!",
paste0("ID: ", id, ", lat: ", round(points$latitude[id==id],2),", lon: ", round(points$longitude[id==id],2))
))
})
output$mymap <- renderLeaflet({
leaflet(options = leafletOptions(maxZoom = 18)) %>% addTiles() %>%
addMarkers(layerId = ~ id,lat = ~ latitude, lng = ~ longitude,
data = points
)
})
}
shinyApp(ui, server)
Solution 2:
library(shiny)
library(leaflet)
library(shinyBS)
points <- data.frame(cbind(latitude = rnorm(40) * 2 + 13, longitude =
rnorm(40) + 48))
ui <- fluidPage(
leafletOutput("mymap"),
actionButton("action1","Show modal")
)
server <- function(input, output, session) {
observeEvent(input$button_click, {
showModal(modalDialog(
title = "Important message",
"This is an important message!"
))
})
output$mymap <- renderLeaflet({
leaflet(options = leafletOptions(maxZoom = 18)) %>% addTiles() %>%
addMarkers(lat = ~ latitude, lng = ~ longitude,
data = points,
popup= ~paste("<b>", latitude, longitude, "</b></br>", actionButton("showmodal", "Show modal", onclick = 'Shiny.onInputChange(\"button_click\", Math.random())')))
})
}
shinyApp(ui, server)

R Auto Zoom Updated leafletProxy Map object in Shiny

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)

Resources