TITLE: SEOSAW plot metadata Shiny app
DATE: 2021-11-26
AUTHOR: John L. Godlee
====================================================================
I have built a web app to make it easier to quickly filter plots in
the SEOSAW network based on plot metadata and attributes of the
plot. I built the app using Shiny, which offers a neat solution for
creating simple HTML5 web apps in R.
[web app]: https://johngodlee.shinyapps.io/shiny_data_explorer/
[SEOSAW network]: https://seosaw.github.io/
[Shiny]: https://shiny.rstudio.com/
I've pasted the code for the app below. The app is actually fairly
simple. It has a sidebar with a bunch of sliders and dropdown
checkbox options to filter a dataframe of plot metadata. The main
panel has a map displaying the plot locations, with the points
optionally shaded according to one of the fields of plot metadata.
The map is built using leaflet, and pulls background tiles from
mapbox. Below the map is a table showing the selected plots with
their metadata values.
[leaflet]: https://rstudio.github.io/leaflet/
[mapbox]: https://www.mapbox.com/
# Packages
library(shiny)
library(dplyr)
library(sf)
library(leaflet)
library(shinyWidgets)
library(DT)
library(scico)
# Import data
plots_clean_sf <- readRDS("plots_clean_sf.rds")
species <- readRDS("species.rds")
# Country names lookup
africa_lookup <- readRDS("africa_lookup.rds")
# Column names lookup
column_lookup <- readRDS("column_lookup.rds")
# Construct mapbox URL
mbox_base <- "https://api.mapbox.com/"
mbox_id <-
"styles/v1/mapbox/streets-v11/tiles/{z}/{x}/{y}?access_token="
mbox_token <- "redacted"
mapbox_url <- paste0(mbox_base, mbox_id, mbox_token)
# Define some functions for inputs to cut down on code
replication
pickerInputFunc <- function(id, name, choices, rem_na = FALSE) {
out <- list(
pickerInput(id,
column_lookup[[name]]$html,
choices,
options = list(`actions-box` = TRUE, `live-search` =
TRUE),
selected = choices, multiple = TRUE)
)
if (rem_na == TRUE) {
out[[2]] <- checkboxInput(paste0(id, "NA"),
label = paste("Include NA values?"), value = TRUE)
}
return(out)
}
sliderInputFunc <- function(id, name, x, rem_na = FALSE) {
lo <- floor(min(x, na.rm = TRUE))
hi <- ceiling(max(x, na.rm = TRUE))
out <- list(
numericRangeInput(id,
column_lookup[[name]]$html,
min = lo,
max = hi,
value = c(lo, hi)
)
)
if (rem_na == TRUE) {
out[[2]] <- checkboxInput(paste0(id, "NA"),
label = paste("Include NA values?"), value = TRUE)
}
return(out)
}
# UI
ui <- fluidPage(
tags$head(
tags$style(HTML(".leaflet-container { background: white;
border-radius: 5px; border: 1px solid black; }"))
),
titlePanel(
tagList(span("SEOSAW plot data explorer",
span(actionButton('more_info', 'More information'),
style = "position: absolute; right: 2em;")
)
),
windowTitle = "SEOSAW plot data explorer"),
sidebarLayout(
sidebarPanel(
style = "overflow-y: auto; height: 90vh;",
selectInput("pointHiSel", "Shade points",
c("None", unname(unlist(lapply(column_lookup, "[[",
"label")))),
selected = "None"),
pickerInput("speciesSel", "Species",
unique(species$species),
options = list(`actions-box` = TRUE, `live-search` =
TRUE),
selected = unique(species$species), multiple = TRUE),
pickerInputFunc("siteSel", "site",
unique(plots_clean_sf$site)),
pickerInputFunc("country_iso3Sel", "country_iso3",
africa_lookup),
pickerInputFunc("prinvSel", "prinv",
unique(plots_clean_sf$prinv)),
pickerInputFunc("permanentSel", "permanent",
unique(plots_clean_sf$permanent)),
pickerInputFunc("plot_shapeSel", "plot_shape",
unique(plots_clean_sf$plot_shape)),
pickerInputFunc("teow_biomeSel", "teow_biome",
unique(plots_clean_sf$teow_biome), rem_na = TRUE),
pickerInputFunc("whites_veg_minorSel",
"whites_veg_minor", unique(plots_clean_sf$whites_veg_minor), rem_na
= TRUE),
sliderInputFunc("plot_areaSel", "plot_area",
plots_clean_sf$plot_area),
sliderInputFunc("longitudeSel", "longitude",
plots_clean_sf$longitude),
sliderInputFunc("latitudeSel", "latitude",
plots_clean_sf$latitude),
sliderInputFunc("elevationSel", "elevation",
plots_clean_sf$elevation, rem_na = TRUE),
sliderInputFunc("min_diam_threshSel", "min_diam_thresh",
plots_clean_sf$min_diam_thresh, rem_na = TRUE),
sliderInputFunc("ba_haSel", "ba_ha",
plots_clean_sf$ba_ha),
sliderInputFunc("agb_haSel", "agb_ha",
plots_clean_sf$agb_ha, rem_na = TRUE),
sliderInputFunc("n_stems_ge5Sel", "n_stems_ge5",
plots_clean_sf$n_stems_ge5),
sliderInputFunc("richnessSel", "richness",
plots_clean_sf$richness),
sliderInputFunc("n_censusSel", "n_census",
plots_clean_sf$n_census),
sliderInputFunc("bio1Sel", "bio1", plots_clean_sf$bio1,
rem_na = TRUE),
sliderInputFunc("bio12Sel", "bio12",
plots_clean_sf$bio12, rem_na = TRUE),
sliderInputFunc("travel_time_citySel",
"travel_time_city", plots_clean_sf$travel_time_city, rem_na = TRUE),
sliderInputFunc("forest_heightSel", "forest_height",
plots_clean_sf$forest_height, rem_na = TRUE),
sliderInputFunc("soil_org_c_densitSel",
"soil_org_c_densit", plots_clean_sf$soil_org_c_densit, rem_na =
TRUE),
sliderInputFunc("soil_sandSel", "soil_sand",
plots_clean_sf$soil_sand, rem_na = TRUE)
),
mainPanel(
leafletOutput("mapOutput"),
pickerInput("tableColSel", "Select columns",
choices = unname(unlist(lapply(column_lookup, "[[",
"label"))),
selected = unlist(unname(lapply(column_lookup[c(
"plot_id", "country_iso3", "prinv", "permanent",
"plot_area",
"plot_shape", "min_diam_thresh", "n_census",
"agb_ha",
"ba_ha", "n_stems_ge5", "richness")], "[[",
"label"))),
multiple = TRUE,
options = list(`actions-box` = TRUE, `live-search` =
TRUE)),
DTOutput("tableOutput")
)
)
)
# Server
server <- function(input, output, session) {
plotsFil <- reactive({
plots_clean_sf %>%
filter(
plot_id %in% unique(species$plot_id[species$species
%in% input$speciesSel]),
site %in% na_if(input$siteSel, "NA"),
country_iso3 %in% na_if(input$country_iso3Sel, "NA"),
prinv %in% na_if(input$prinvSel, "NA"),
permanent %in% na_if(input$permanentSel, "NA"),
plot_shape %in% na_if(input$plot_shapeSel, "NA"),
teow_biome %in% na_if(input$teow_biomeSel, "NA"),
whites_veg_minor %in% na_if(input$whites_veg_minorSel,
"NA"),
between(plot_area,
input$plot_areaSel[1],input$plot_areaSel[2]) | is.na(plot_area),
between(longitude,
input$longitudeSel[1],input$longitudeSel[2]) | is.na(longitude),
between(latitude,
input$latitudeSel[1],input$latitudeSel[2]) | is.na(latitude),
between(min_diam_thresh,
input$min_diam_threshSel[1],input$min_diam_threshSel[2]) |
is.na(min_diam_thresh),
between(ba_ha, input$ba_haSel[1], input$ba_haSel[2]) |
is.na(ba_ha),
between(agb_ha, input$agb_haSel[1], input$agb_haSel[2])
| is.na(agb_ha),
between(n_stems_ge5, input$n_stems_ge5Sel[1],
input$n_stems_ge5Sel[2]) | is.na(n_stems_ge5),
between(richness, input$richnessSel[1],
input$richnessSel[2]) | is.na(richness),
between(n_census, input$n_censusSel[1],
input$n_censusSel[2]) | is.na(n_census),
between(bio1, input$bio1Sel[1], input$bio1Sel[2]) |
is.na(bio1),
between(bio12, input$bio12Sel[1], input$bio12Sel[2]) |
is.na(bio12),
between(travel_time_city, input$travel_time_citySel[1],
input$travel_time_citySel[2]) | is.na(travel_time_city),
between(elevation, input$elevationSel[1],
input$elevationSel[2]) | is.na(elevation),
between(forest_height, input$forest_heightSel[1],
input$forest_heightSel[2]) | is.na(forest_height),
between(soil_org_c_densit,
input$soil_org_c_densitSel[1], input$soil_org_c_densitSel[2]) |
is.na(soil_org_c_densit),
between(soil_sand, input$soil_sandSel[1],
input$soil_sandSel[2]) | is.na(soil_sand)
) %>%
filter(if (!input$teow_biomeSelNA) !is.na(teow_biome)
else TRUE) %>%
filter(if (!input$whites_veg_minorSelNA)
!is.na(whites_veg_minor) else TRUE) %>%
filter(if (!input$min_diam_threshSelNA)
!is.na(min_diam_thresh) else TRUE) %>%
filter(if (!input$bio1SelNA) !is.na(bio1) else TRUE) %>%
filter(if (!input$bio12SelNA) !is.na(bio12) else TRUE) %>%
filter(if (!input$travel_time_citySelNA)
!is.na(travel_time_city) else TRUE) %>%
filter(if (!input$elevationSelNA) !is.na(elevation) else
TRUE) %>%
filter(if (!input$forest_heightSelNA)
!is.na(forest_height) else TRUE) %>%
filter(if (!input$soil_org_c_densitSelNA)
!is.na(soil_org_c_densit) else TRUE) %>%
filter(if (!input$soil_sandSelNA) !is.na(soil_sand) else
TRUE)
})
output$mapOutput <- renderLeaflet({
leaflet() %>%
addTiles(urlTemplate = mapbox_url,
options = tileOptions(
maxZoom = 18
)
) %>%
setView(lng = 30, lat = -15, zoom = 4)
})
toListen <- reactive({
list(
input$speciesSel,
input$tableColSel,
input$pointHiSel,
input$siteSel,
input$country_iso3Sel,
input$prinvSel,
input$plot_areaSel,
input$permanentSel,
input$plot_shapeSel,
input$teow_biomeSel,
input$teow_biomeSelNA,
input$whites_veg_minorSel,
input$whites_veg_minorSelNA,
input$longitudeSel,
input$latitudeSel,
input$elevationSel,
input$elevationSelNA,
input$min_diam_threshSel,
input$min_diam_threshSelNA,
input$ba_haSel,
input$agb_haSel,
input$n_stems_ge5Sel,
input$richnessSel,
input$n_censusSel,
input$bio1Sel,
input$bio1SelNA,
input$bio12Sel,
input$bio12SelNA,
input$travel_time_citySel,
input$travel_time_citySelNA,
input$forest_heightSel,
input$forest_heightSelNA,
input$soil_org_c_densitSel,
input$soil_org_c_densitSelNA,
input$soil_sandSel,
input$soil_sandSelNA
)
})
observeEvent(toListen(), {
leafletProxy("mapOutput") %>%
clearMarkers() %>%
clearControls()
if (nrow(plotsFil()) > 0) {
if (input$pointHiSel != "None") {
if (is.numeric(plotsFil()[[names(column_lookup)[
unname(unlist(lapply(column_lookup, "[[",
"label"))) == input$pointHiSel]]])) {
pal <- colorNumeric(
palette = scico(n = 100, palette = "imola"),
domain = plotsFil()[[names(column_lookup)[
unname(unlist(lapply(column_lookup, "[[",
"label"))) == input$pointHiSel]]],
na.color = "darkgrey"
)
} else {
pal <- colorFactor(
palette = scico(n =
length(unique(plotsFil()[[names(column_lookup)[
unname(unlist(lapply(column_lookup, "[[",
"label"))) == input$pointHiSel]]])),
palette = "imola"),
domain = plotsFil()[[names(column_lookup)[
unname(unlist(lapply(column_lookup, "[[",
"label"))) == input$pointHiSel]]]
)
}
leafletProxy("mapOutput") %>%
addCircleMarkers(data = plotsFil(),
popup = ~label,
radius = 4, color = "black", opacity = 1, weight =
1,
fillOpacity = 1,
fillColor = ~pal(plotsFil()[[names(column_lookup)[
unname(unlist(lapply(column_lookup, "[[",
"label"))) == input$pointHiSel]]])) %>%
addLegend(position = "bottomright", pal = pal,
values = plotsFil()[[names(column_lookup)[
unname(unlist(lapply(column_lookup, "[[",
"label"))) == input$pointHiSel]]],
title = unname(unlist(lapply(column_lookup, "[[",
"html")))[
unname(unlist(lapply(column_lookup, "[[",
"label"))) == input$pointHiSel],
opacity = 1)
} else {
leafletProxy("mapOutput") %>%
addCircleMarkers(data = plotsFil(),
popup = ~label,
radius = 4, color = "black", opacity = 1, weight =
1,
fillOpacity = 1, fillColor = "tomato")
}
}
})
observeEvent(toListen(), {
plots_df <- plotsFil() %>%
st_drop_geometry() %>%
dplyr::select(names(column_lookup)[
unlist(lapply(column_lookup, "[[", "label")) %in%
input$tableColSel])
names(plots_df) <- unlist(lapply(column_lookup, "[[",
"label"))[
match(names(plots_df), names(column_lookup))]
output$tableOutput <- renderDT({
datatable(plots_df, rownames = FALSE,
options=list(autoWidth = TRUE, scrollX = TRUE)
)
})
})
observeEvent(input$more_info, {
showModal(modalDialog(
title = "",
HTML(paste0(
tags$p("This app is designed to provide quick
filtering of the plot data in the SEOSAW network, based on various
plot attributes and metadata."),
tags$p("For more information on SEOSAW, visit: ",
tags$a(href = "https://seosaw.github.io",
"https://seosaw.github.io", target="_blank")
),
tags$p("Created by John L. Godlee (",
tags$a(href = "mailto:john.godlee@ed.ac.uk",
"john.godlee@ed.ac.uk"),
")"))),
easyClose = TRUE,
footer = NULL
))
})
}
shinyApp(ui, server)