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:[email protected]",
"[email protected]"),
               ")"))),
         easyClose = TRUE,
         footer = NULL
         ))
     })
   }

   shinyApp(ui, server)

You are viewing proxied material from republic.circumlunar.space. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.