💾 Archived View for republic.circumlunar.space › users › johngodlee › posts › 2021-11-26-seosaw_shin… captured on 2021-12-17 at 13:26:06. Gemini links have been rewritten to link to archived content
⬅️ Previous capture (2021-12-04)
-=-=-=-=-=-=-
DATE: 2021-11-26
AUTHOR: John L. Godlee
I have built a web app[1] to make it easier to quickly filter plots in the SEOSAW network[2] based on plot metadata and attributes of the plot. I built the app using Shiny[3], which offers a neat solution for creating simple HTML5 web apps in R.
1: https://johngodlee.shinyapps.io/shiny_data_explorer/
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[4], and pulls background tiles from mapbox[5]. Below the map is a table showing the selected plots with their metadata values.
4: https://rstudio.github.io/leaflet/
# 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)