Add comments

Author: Nick Heyek

experiment-trait-data-visualizer/app.R

@@ -9,26 +9,28 @@ library(shinythemes)
 
 source('render-site-map.R')
 
-# set up scheduled execution of cache update
-#cache_update_cmd <- cron_rscript('cache-refresh.R')
-#try(cron_add(command = cache_update_cmd, frequency = 'daily', 
-#            id = 'cache-update', description = 'daily update of BETYdb cache'))
+# schedule daily execution of cache refresh
+cache_update_cmd <- cron_rscript('cache-refresh.R')
+try(cron_add(command = cache_update_cmd, frequency = 'daily', 
+            id = 'cache-update', description = 'daily update of BETYdb cache'))
 
 # set page UI
-ui <- fluidPage( theme = shinytheme('flatly'),
+ui <- fluidPage(theme = shinytheme('flatly'),
 
   tags$link(rel = 'stylesheet', type = 'text/css', href = 'style.css'),
   title = 'TERRA-REF Experiment Data',
 
   tags$img(src = 'logo.png', class = 'push-out'),
 
+  # destination for all dynamic UI elements
   uiOutput('page_content')
 )
 
+# render UI for a given season
 render_season_ui <- function(season_name) {
 
   tabPanel(season_name,
-           
+    
     sidebarPanel(class = 'push-down',
       uiOutput(paste0('variable_select_', season_name)),
       uiOutput(paste0('cultivar_select_', season_name))
@@ -58,6 +60,7 @@ render_season_ui <- function(season_name) {
   )
 }
 
+# render selection menu from available variables in a given season
 render_variable_menu <- function(season_name, output, full_cache_data) {
 
   variable_names <- names(full_cache_data[[ season_name ]][[ 'trait_data' ]])
@@ -67,6 +70,7 @@ render_variable_menu <- function(season_name, output, full_cache_data) {
   })
 }
 
+# render selection menu from available cultivars in a given season, for the selected variable
 render_cultivar_menu <- function(season_name, input, output, full_cache_data) {
 
   output[[ paste0('cultivar_select_', season_name) ]] <- renderUI({
@@ -80,6 +84,8 @@ render_cultivar_menu <- function(season_name, input, output, full_cache_data) {
   })
 }
 
+# render box plot time series from trait records in a given season, for the selected variable
+# if a cultivar is selected, render line plot from trait records for that cultivar
 render_trait_plot <- function(season_name, input, output, full_cache_data) {
 
   output[[ paste0('trait_plot_', season_name) ]] <- renderPlot({
@@ -99,7 +105,6 @@ render_trait_plot <- function(season_name, input, output, full_cache_data) {
     if (units != '')
       title <- paste0(selected_variable, ' (', units, ')')
 
-    # generate timeseries of boxplots from mean value
     ggplot(plot_data, aes(as.Date(date), mean)) + 
     geom_boxplot(aes(group = cut_width(as.Date(date), 1)), outlier.alpha = 0.1) +
 
@@ -123,6 +128,7 @@ render_trait_plot <- function(season_name, input, output, full_cache_data) {
   })
 }
 
+# render timeline from management records in a given season
 render_mgmt_timeline <- function(season_name, input, output, full_cache_data) {
 
   output[[ paste0('mgmt_timeline_', season_name) ]] <- renderTimevis({
@@ -148,6 +154,7 @@ render_mgmt_timeline <- function(season_name, input, output, full_cache_data) {
   })
 }
 
+# render info box for date and value of cursor when hovering box/line plot
 render_plot_hover <- function(season_name, input, output, full_cache_data) {
 
   output[[ paste0('plot_hover_info_', season_name) ]] <- renderUI({
@@ -170,6 +177,7 @@ render_plot_hover <- function(season_name, input, output, full_cache_data) {
   })
 }
 
+# render info box for date, type, and notes of selected (clicked) timeline item
 render_timeline_hover <- function(season_name, input, output, full_cache_data) {
 
   output[[ paste0('mgmt_select_info_', season_name) ]] <- renderUI({
@@ -196,13 +204,15 @@ render_timeline_hover <- function(season_name, input, output, full_cache_data) {
 
 render_map <- function(season_name, input, output, full_cache_data) {
 
+  # render slider input from dates in a given season
   output[[ paste0('map_date_slider_', season_name) ]] <- renderUI({
     sliderInput(paste0('map_date_', season_name), 'Date', 
                 as.Date(full_cache_data[[ season_name ]][[ 'start_date']]), 
                 as.Date(full_cache_data[[ season_name ]][[ 'end_date' ]]),
                 as.Date(full_cache_data[[ season_name ]][[ 'end_date' ]]))
   })
 
+  # render heat map of sites from trait records in a given season, for the selected date, variable and cultivar
   output[[ paste0('site_map_', season_name) ]] <- renderLeaflet({
 
     req(input[[ paste0('selected_variable_', season_name) ]])
@@ -227,7 +237,7 @@ render_map <- function(season_name, input, output, full_cache_data) {
   })
 }
 
-
+# render outputs for a given season
 render_season_output <- function(season_name, input, output, full_cache_data) {
 
   render_variable_menu(season_name, output, full_cache_data)
@@ -243,20 +253,20 @@ render_season_output <- function(season_name, input, output, full_cache_data) {
   render_timeline_hover(season_name, input, output, full_cache_data)
 
   render_map(season_name, input, output, full_cache_data)
-
 }
 
-# render page elements
 server <- function(input, output) {
 
+  # load 'full_cache_data' object from cache file
   load('cache.RData')
 
+  # render UI for all available seasons
   output$page_content <- renderUI({
-    
     season_tabs <- lapply(names(full_cache_data), render_season_ui)
     do.call(tabsetPanel, season_tabs)
   })
 
+  # render outputs for all available seasons
   lapply(names(full_cache_data), render_season_output, input, output, full_cache_data)
 }
 

experiment-trait-data-visualizer/cache-refresh.R

@@ -3,8 +3,20 @@ library(tools)
 library(lubridate)
 options(scipen=999)
 
-get_data_for_season <- function(season, bety_src) {
+# set up remote connection to BETYdb
+bety_src <- src_postgres(
+  dbname = Sys.getenv('bety_dbname'),
+  password = Sys.getenv('bety_password'),
+  host = Sys.getenv('bety_host'),
+  port = Sys.getenv('bety_port'),
+  user = Sys.getenv('bety_user')
+)
+
+# get all relevant data from BETYdb for a given season, write to cache file
+get_data_for_season <- function(season) {
 
+  # destination for all data for given season
+  # save season start date and end date
   season_data <- list(start_date = season[[ 'start_date' ]], end_date = season[[ 'end_date' ]])
 
   season_site_ids <- tbl(bety_src, 'experiments_sites') %>% 
@@ -15,8 +27,7 @@ get_data_for_season <- function(season, bety_src) {
   if (is.null(season_site_ids))
     return()
 
-  season_data[[ 'site_ids' ]] <- season_site_ids
-  
+  # only use trait records associated with the relevant sites
   season_traits_table <- tbl(bety_src, 'traits') %>%
     filter(date >= season[[ 'start_date' ]] & date <= season[[ 'end_date' ]]) %>%
     filter(site_id %in% season_site_ids) %>%
@@ -52,14 +63,17 @@ get_data_for_season <- function(season, bety_src) {
     variable_data[[ 'id' ]] <- variable_record[[ 'id' ]]
     variable_data[[ 'traits' ]] <- variable_traits
 
+    # subset trait data by variable
     season_trait_data[[ variable_name ]] <- variable_data
   }
+  # save trait data for all variables
   season_data[[ 'trait_data' ]] <- season_trait_data
 
   season_treatment_ids <- unique(na.omit(
     season_traits[[ 'treatment_id' ]]
   ))
 
+  # only use management records associated with the relevant treatments
   season_management_ids <- tbl(bety_src, 'managements_treatments') %>%
     filter(treatment_id %in% season_treatment_ids) %>%
     collect() %>% unlist(use.names = FALSE)
@@ -70,24 +84,20 @@ get_data_for_season <- function(season, bety_src) {
     select(id, date, mgmttype, notes) %>%
     collect()
 
+  # save management data
   season_data[[ 'managements' ]] <- season_managements
 
+  # load existing full_cache_data object if exists, otherwise use empty list object
   full_cache_data <- list()
   if (file.exists("cache.RData"))
     load("cache.RData")
-  full_cache_data[[ toString(season[[ 'name' ]]) ]] <- season_data
 
+  # save data for given season
+  full_cache_data[[ toString(season[[ 'name' ]]) ]] <- season_data
   save(full_cache_data, file = "cache.RData", compress = FALSE)
 }
 
-bety_src <- src_postgres(
-  dbname = Sys.getenv('bety_dbname'),
-  password = Sys.getenv('bety_password'),
-  host = Sys.getenv('bety_host'),
-  port = Sys.getenv('bety_port'),
-  user = Sys.getenv('bety_user')
-)
-
+# get all experiments in BETYdb
 experiments <- tbl(bety_src, 'experiments') %>% 
   select(id, name, start_date, end_date) %>% 
   collect() %>% as.data.frame()
@@ -100,4 +110,5 @@ seasons <- experiments[
 
 seasons[[ 'name' ]] <- gsub(":.*$","", seasons[[ 'name' ]])
 
-apply(seasons, 1, get_data_for_season, bety_src)
+# get data for all seasons
+apply(seasons, 1, get_data_for_season)

experiment-trait-data-visualizer/render-site-map.R

@@ -1,6 +1,7 @@
 library(rgeos)
 library(dplyr)
 
+# set up remote connection to BETYdb
 bety_src <- src_postgres(
   dbname = Sys.getenv('bety_dbname'),
   password = Sys.getenv('bety_password'),
@@ -9,14 +10,17 @@ bety_src <- src_postgres(
   user = Sys.getenv('bety_user')
 )
 
+# render leaflet map from traits for a given date
 render_site_map <- function(traits, legend_title, render_date) {
 
+  # get associated sites
   site_ids <- na.omit(unique(traits[[ 'site_id' ]]))
   sites <- tbl(bety_src, sql("select ST_AsText(sites.geometry) AS geometry, id from sites")) %>% 
     filter(!is.na(geometry)) %>% 
     filter(id %in% site_ids) %>% 
     collect() %>% data.frame()
 
+  # get most recent traits for each site
   latest_traits <- subset(traits, date <= render_date) %>% group_by(site_id) %>% top_n(1, date)
 
   pal <- colorNumeric(
@@ -25,17 +29,16 @@ render_site_map <- function(traits, legend_title, render_date) {
   )
 
   map <- leaflet(options = leafletOptions(minZoom = 20, maxZoom = 21)) %>% addTiles()
-  
-  if (nrow(sites) > 0) {
-    for (i in 1:nrow(sites)){
-      site <- sites[i,]
+
+  # add polygon for each site, color by trait mean value
+  for (i in 1:nrow(sites)){
+    site <- sites[i,]
+    
+    geo_object <- readWKT(site[['geometry']])
+    if ('polygons' %in% names(attributes(geo_object))) {
 
-      geo_object <- readWKT(site[['geometry']])
-      if ('polygons' %in% names(attributes(geo_object))) {
-        
-        trait <- subset(latest_traits, site_id == site[[ 'id' ]])
-        map <- addPolygons(map, data = geo_object, color = pal(trait[['mean']]))
-      }
+      trait <- subset(latest_traits, site_id == site[[ 'id' ]])
+      map <- addPolygons(map, data = geo_object, color = pal(trait[['mean']]))
     }
   }