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)