I'm building a Shiny app that visualizes rainfall data using a Leaflet map. Here's what I want to achieve:
1. Zoom to a Province When Selected When a province is selected from a dropdown, I want the map to automatically zoom to that province's boundary. I have a shapefile of Indonesian provinces loaded as provinsi_sf. I’m using leafletProxy() and st_bbox() to get bounding boxes, but I’m unsure how to set the correct zoom and center.
2. Add Polylines from Shapefiles I have three shapefiles:
shp_gambut (peat areas),
provinsi_sf (provinces),
kabupaten_sf (districts).
How can I overlay these on the Leaflet map as polylines or polygons in different colors?
3. Highlight Clicked Station : I’m plotting weather stations as markers.
When one is clicked, I want:
Data:
https://drive.google.com/drive/folders/19R9cVcBbLOvzzlxwkIEYc4V51e6it6gu?usp=drive_link
library(shiny)
library(leaflet)
library(leaflet.extras)
library(dplyr)
library(ggplot2)
library(plotly)
library(sf)
## -------------------------------
## Data
## -------------------------------
shp_gambut <- readRDS("Gambut/gambut.rds")
provinsi_sf <- readRDS("indonesia.rds")
kabupaten_sf <- readRDS("kab.rds")
bmkg_st <- readRDS("bmkg_st.rds")
## -------------------------------
## UI
## -------------------------------
ui <- fluidPage(
titlePanel("Monitoring Stasiun Cuaca"),
sidebarLayout(
sidebarPanel(
selectInput("prov", "Select Province", choices = unique(bmkg_st$provinsi)),
uiOutput("kabupaten_ui"),
selectInput("scale_id", "Skala Waktu:",
choices = c("Harian" = "Daily",
"Bulanan" = "Monthly",
"Tahunan" = "Yearly"),
selected = "Daily")
),
mainPanel(
leafletOutput("mymap", height = "500px"),
plotlyOutput("rainPlot", height = "300px")
)
)
)
## -------------------------------
## Server
## -------------------------------
server <- function(input, output, session) {
# Update pilihan kabupaten berdasarkan provinsi
output$kabupaten_ui <- renderUI({
req(input$prov) # Ensure that the prov input is available
kab <- bmkg_st %>% filter(provinsi == input$prov)
selectInput("kab", "Pilih Kabupaten:", choices = unique(kab$kabupaten))
})
# Ambil geometri provinsi yang dipilih
selected_prov_geom <- reactive({
provinsi_sf %>% filter(name == input$prov)
})
# Render peta awal
output$mymap <- renderLeaflet({
leaflet() %>%
addProviderTiles(providers$CartoDB.Positron) %>%
setView(lng = 108, lat = -2, zoom = 5.5)
})
# Update peta ketika provinsi berubah
observe({
prov_geom <- selected_prov_geom()
leafletProxy("mymap") %>%
clearShapes() %>%
clearMarkers() %>%
addPolygons(data = prov_geom,
fillColor = "lightgrey",
color = "brown", weight = 2, fillOpacity = 0.3) %>%
addMarkers(data = bmkg_st %>% filter(provinsi == input$prov),
lng = ~x, lat = ~y,
popup = ~ID,
layerId = ~WMO,
icon = awesomeIcons(icon = 'cloud', markerColor = 'blue'))
})
# Filter dan agregasi data sesuai skala waktu
filtered_scaled_data <- reactive({
req(input$prov) # Ensure prov input is available
data <- bmkg_st %>%
filter(provinsi == input$prov)
if (input$scale_id == "Daily") {
return(data)
} else if (input$scale_id == "Monthly") {
return(data %>%
mutate(Year = format(date, "%Y"),
Month = format(date, "%m"),
Month = factor(Month, levels = sprintf("%02d", 1:12))) %>%
group_by(Year, Month, WMO, ID) %>%
summarise(rain = sum(rain, na.rm = TRUE), .groups = 'drop'))
} else {
return(data %>%
mutate(Year = format(date, "%Y")) %>%
group_by(Year, WMO, ID) %>%
summarise(rain = sum(rain, na.rm = TRUE), .groups = 'drop'))
}
})
# Tampilkan plot ketika marker diklik
observeEvent(input$mymap_marker_click, {
click <- input$mymap_marker_click
req(click$id)
data <- filtered_scaled_data() %>%
filter(WMO == as.numeric(click$id))
output$rainPlot <- renderPlotly({
if (input$scale_id == "Daily") {
p <- ggplot(data, aes(x = date, y = rain)) +
geom_line() +
labs(title = "Curah Hujan Harian", x = "Tanggal", y = "Curah Hujan (mm)") +
theme_minimal()
} else if (input$scale_id == "Monthly") {
p <- ggplot(data, aes(x = Month, y = rain, group = Year, color = Year)) +
geom_line() +
labs(title = "Curah Hujan Bulanan", x = "Bulan", y = "Curah Hujan (mm)") +
theme_minimal()
} else {
p <- ggplot(data, aes(x = Year, y = rain)) +
geom_col(fill = "steelblue") +
labs(title = "Curah Hujan Tahunan", x = "Tahun", y = "Curah Hujan (mm)") +
theme_minimal()
}
# Explicitly define the trace type and mode to avoid warnings
ggplotly(p, tooltip = "text") %>%
layout(
title = list(text = "Rainfall Plot"),
showlegend = FALSE,
xaxis = list(title = "Date"),
yaxis = list(title = "Rainfall (mm)")
) %>%
config(displayModeBar = FALSE) # To hide modebar if not needed
})
})
}
shinyApp(ui, server)
fitBoundary() to zoom in. For example: prov_geom <- selected_prov_geom()
z <- unname(st_bbox(prov_geom))
leafletProxy("mymap") %>%
clearShapes() %>%
clearMarkers() %>%
addPolygons(data = prov_geom,
fillColor = "lightgrey",
color = "brown", weight = 2, fillOpacity = 0.3) %>%
addMarkers(data = bmkg_st %>% filter(provinsi == input$prov) %>% slice_head(n=1),
lng = ~x, lat = ~y,
popup = ~ID,
layerId = ~WMO,
icon = list(iconUrl = "www/blue_cloud.svg", iconSize=c(15,15))) %>%
fitBounds(lng1 = z[1], lat1 = z[2], lng2 = z[3], lat2 = z[4])
When you pick a province, it will zoom into that one.
checkboxGroupInput("boundaries",
"Boundaries to Show",
choices = c("Province", "District", "Peat Area"),
selected = NULL)
output$mymap <- renderLeaflet({
map <- leaflet() %>%
addProviderTiles(providers$CartoDB.Positron) %>%
setView(lng = 108, lat = -2, zoom = 5.5)
if("Province" %in% input$boundaries){
map <- map %>%
addPolygons(data=provinsi_sf, weight=2, fill=FALSE, color="green")
}
if("District" %in% input$boundaries){
map <- map %>%
addPolygons(data=kabupaten_sf, weight=2, fill=FALSE, color="red")
}
if("Peat Area" %in% input$boundaries){
map <- map %>%
addPolygons(data=shp_gambut, weight=2, fill=FALSE, color="blue")
}
map
})
blue_cloud.svg and red_cloud.svg. I have the markers print as blue initially. addMarkers(data = bmkg_st %>% filter(provinsi == input$prov),
lng = ~x, lat = ~y,
popup = ~ID,
layerId = ~WMO,
icon = list(iconUrl = "www/blue_cloud.svg", iconSize=c(15,15)))
However, when you select one, I have it change that marker to the red cloud:
observeEvent(input$mymap_marker_click, {
leafletProxy("mymap") %>%
removeMarker(layerId = input$mymap_marker_click$id) %>%
addMarkers(data = bmkg_st %>% filter(provinsi == input$prov) %>% filter(WMO == input$mymap_marker_click$id),
lng = ~x, lat = ~y,
popup = ~ID,
layerId = ~WMO,
icon = list(iconUrl = "www/red_cloud.svg", iconSize=c(15,15)))
})
Note, in the code below, I used slice_head(n=1) to have the map render faster for debugging. You'll have to make sure all this works with the full data as you intend. One potential problem is that the data you're plotting have lots of days for the same station. If you're just using it for people to select a station, perhaps plotting the markers as one one observation per station would speed up the process.
library(shiny)
library(leaflet)
library(leaflet.extras)
library(dplyr)
library(ggplot2)
library(plotly)
library(sf)
## -------------------------------
## Data
## -------------------------------
shp_gambut <- readRDS("gambut.rds")
provinsi_sf <- readRDS("indonesia.rds")
kabupaten_sf <- readRDS("kab.rds")
bmkg_st <- readRDS("bmkg_st.rds")
# input <- list(prov = "Bengkulu", scalse_id = "Yearly", kab = "Bengkulu")
## -------------------------------
## UI
## -------------------------------
ui <- fluidPage(
titlePanel("Monitoring Stasiun Cuaca"),
actionButton("browser", "Browse"),
sidebarLayout(
sidebarPanel(
selectInput("prov", "Select Province", choices = unique(bmkg_st$provinsi)),
uiOutput("kabupaten_ui"),
selectInput("scale_id", "Skala Waktu:",
choices = c("Harian" = "Daily",
"Bulanan" = "Monthly",
"Tahunan" = "Yearly"),
selected = "Daily"),
checkboxGroupInput("boundaries",
"Boundaries to Show",
choices = c("Province", "District", "Peat Area"),
selected = NULL)
),
mainPanel(
leafletOutput("mymap", height = "500px"),
plotlyOutput("rainPlot", height = "300px")
)
)
)
## -------------------------------
## Server
## -------------------------------
server <- function(input, output, session) {
observeEvent(input$browser, {
browser()
})
# Update pilihan kabupaten berdasarkan provinsi
output$kabupaten_ui <- renderUI({
req(input$prov) # Ensure that the prov input is available
kab <- bmkg_st %>% filter(provinsi == input$prov)
selectInput("kab", "Pilih Kabupaten:", choices = unique(kab$kabupaten))
})
# Ambil geometri provinsi yang dipilih
selected_prov_geom <- reactive({
provinsi_sf %>% filter(name == input$prov)
})
# Render peta awal
output$mymap <- renderLeaflet({
map <- leaflet() %>%
addProviderTiles(providers$CartoDB.Positron) %>%
setView(lng = 108, lat = -2, zoom = 5.5)
if("Province" %in% input$boundaries){
map <- map %>%
addPolygons(data=provinsi_sf, weight=2, fill=FALSE, color="green")
}
if("District" %in% input$boundaries){
map <- map %>%
addPolygons(data=kabupaten_sf, weight=2, fill=FALSE, color="red")
}
if("Peat Area" %in% input$boundaries){
map <- map %>%
addPolygons(data=shp_gambut, weight=2, fill=FALSE, color="blue")
}
map
})
# observeEvent()
# Update peta ketika provinsi berubah
observe({
prov_geom <- selected_prov_geom()
z <- unname(st_bbox(prov_geom))
leafletProxy("mymap") %>%
clearShapes() %>%
clearMarkers() %>%
addPolygons(data = prov_geom,
fillColor = "lightgrey",
color = "brown", weight = 2, fillOpacity = 0.3) %>%
addMarkers(data = bmkg_st %>% filter(provinsi == input$prov) %>% slice_head(n=1),
lng = ~x, lat = ~y,
popup = ~ID,
layerId = ~WMO,
icon = list(iconUrl = "www/blue_cloud.svg", iconSize=c(15,15))) %>%
fitBounds(lng1 = z[1], lat1 = z[2], lng2 = z[3], lat2 = z[4])
})
observeEvent(input$mymap_marker_click, {
leafletProxy("mymap") %>%
removeMarker(layerId = input$mymap_marker_click$id) %>%
addMarkers(data = bmkg_st %>% filter(provinsi == input$prov) %>% slice_head(n=1) %>% filter(WMO == input$mymap_marker_click$id),
lng = ~x, lat = ~y,
popup = ~ID,
layerId = ~WMO,
icon = list(iconUrl = "www/red_cloud.svg", iconSize=c(15,15)))
})
# Filter dan agregasi data sesuai skala waktu
filtered_scaled_data <- reactive({
req(input$prov) # Ensure prov input is available
data <- bmkg_st %>%
filter(provinsi == input$prov)
if (input$scale_id == "Daily") {
return(data)
} else if (input$scale_id == "Monthly") {
return(data %>%
mutate(Year = format(date, "%Y"),
Month = format(date, "%m"),
Month = factor(Month, levels = sprintf("%02d", 1:12))) %>%
group_by(Year, Month, WMO, ID) %>%
summarise(rain = sum(rain, na.rm = TRUE), .groups = 'drop'))
} else {
return(data %>%
mutate(Year = format(date, "%Y")) %>%
group_by(Year, WMO, ID) %>%
summarise(rain = sum(rain, na.rm = TRUE), .groups = 'drop'))
}
})
# Tampilkan plot ketika marker diklik
observeEvent(input$mymap_marker_click, {
click <- input$mymap_marker_click
req(click$id)
data <- filtered_scaled_data() %>%
filter(WMO == as.numeric(click$id))
output$rainPlot <- renderPlotly({
if (input$scale_id == "Daily") {
p <- ggplot(data, aes(x = date, y = rain)) +
geom_line() +
labs(title = "Curah Hujan Harian", x = "Tanggal", y = "Curah Hujan (mm)") +
theme_minimal()
} else if (input$scale_id == "Monthly") {
p <- ggplot(data, aes(x = Month, y = rain, group = Year, color = Year)) +
geom_line() +
labs(title = "Curah Hujan Bulanan", x = "Bulan", y = "Curah Hujan (mm)") +
theme_minimal()
} else {
p <- ggplot(data, aes(x = Year, y = rain)) +
geom_col(fill = "steelblue") +
labs(title = "Curah Hujan Tahunan", x = "Tahun", y = "Curah Hujan (mm)") +
theme_minimal()
}
# Explicitly define the trace type and mode to avoid warnings
ggplotly(p, tooltip = "text") %>%
layout(
title = list(text = "Rainfall Plot"),
showlegend = FALSE,
xaxis = list(title = "Date"),
yaxis = list(title = "Rainfall (mm)")
) %>%
config(displayModeBar = FALSE) # To hide modebar if not needed
})
})
}
shinyApp(ui, server)