Map render use cache

Author: Nick Heyek

CONTRIBUTING.md

@@ -2,7 +2,7 @@
 
 This repository is for discussing the format and content of data products that the TERRA Reference team will produce.
 
-Most of the discussions occur in the form of [GitHub issues](https://github.com/terraref/reference-data/issues). You can ask questions, request new or updated data products, and propose new formats to support there by contacting us in our [chat room](https://gitter.im/terraref/reference-data) or creating a [new issue](https://github.com/terraref/reference-data/issues/new).
+Most of the discussions occur in the form of [GitHub issues](https://github.com/terraref/reference-data/issues). You can ask questions, request new or updated data products, and propose new formats to support there by creating a [new issue](https://github.com/terraref/reference-data/issues/new).
 
 ## Proposing new data products
 

README.md

@@ -8,12 +8,10 @@ Reference data encompasses clear definitions of data formats, semantics, and int
 * [Website](https://terraref.ncsa.illinois.edu)
 * email: dlebauer@illinois.edu
 * [GitHub Issues](https://github.com/terraref/reference-data/issues)
-* [Chat Room](https://gitter.im/terraref/reference-data)
 
 To provide input on the computing pipeline, please visit the [Reference Data GitHub repository](https://github.com/terraref/reference-data).
 
 * [GitHub Issues](https://github.com/terraref/computing-pipeline/issues)
-* [Chat Room](https://gitter.im/terraref/computing-pipeline)
 
 
 

experiment-trait-data-visualizer/app.R

@@ -1,5 +1,4 @@
 library(shiny)
-library(traits)
 library(ggplot2)
 library(lubridate)
 library(timevis)
@@ -11,8 +10,8 @@ source('render-site-map.R')
 
 # 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'))
+# 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'),
@@ -233,7 +232,7 @@ render_map <- function(season_name, input, output, full_cache_data) {
       units <- paste0('(', units, ')')
     legend_title <- paste0(selected_variable, ' ', units)
 
-    render_site_map(traits, legend_title, render_date)
+    render_site_map(traits, render_date, legend_title)
   })
 }
 

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

@@ -19,36 +19,43 @@ get_data_for_season <- function(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') %>% 
+  site_ids <- tbl(bety_src, 'experiments_sites') %>% 
     filter(experiment_id == season[[ 'id' ]]) %>%
     select(site_id) %>%
     collect() %>% unlist(use.names = FALSE)
 
-  if (is.null(season_site_ids))
+  if (is.null(site_ids))
     return()
 
   # only use trait records associated with the relevant sites
-  season_traits_table <- tbl(bety_src, 'traits') %>%
+  traits_table <- tbl(bety_src, 'traits') %>%
     filter(date >= season[[ 'start_date' ]] & date <= season[[ 'end_date' ]]) %>%
-    filter(site_id %in% season_site_ids) %>%
+    filter(site_id %in% site_ids) %>%
     select(date, mean, variable_id, cultivar_id, treatment_id, site_id)
 
-  trait_cultivars <- tbl(bety_src, 'cultivars') %>%
+  sites_table <- tbl(bety_src, sql("select ST_AsText(sites.geometry) AS geometry, id from sites")) %>% 
+    filter(!is.na(geometry)) %>% 
+    filter(id %in% site_ids) %>%
+    mutate(site_id = id)
+  
+  cultivars_table <- tbl(bety_src, 'cultivars') %>%
     mutate(cultivar_id = id, cultivar_name = name) %>%
     select(cultivar_id, cultivar_name)
 
-  season_traits <- season_traits_table %>% left_join(trait_cultivars, by = 'cultivar_id') %>%
+  traits <- traits_table %>% 
+    left_join(sites_table, by = 'site_id') %>%
+    left_join(cultivars_table, by = 'cultivar_id') %>%
     collect() %>% as.data.frame()
 
-  if (nrow(season_traits) == 0)
+  if (nrow(traits) == 0)
     return()
 
-  season_variable_ids <- unique(na.omit(
-    season_traits[[ 'variable_id' ]]
+  variable_ids <- unique(na.omit(
+    traits[[ 'variable_id' ]]
   ))
 
-  season_trait_data <- list()
-  for (curr_variable_id in season_variable_ids) {
+  trait_data <- list()
+  for (curr_variable_id in variable_ids) {
 
     variable_data <- list()
 
@@ -57,35 +64,35 @@ get_data_for_season <- function(season) {
       select(id, name, units) %>% collect()
 
     variable_name <- toTitleCase(gsub('_', ' ', variable_record[[ 'name' ]]))
-    variable_traits <- subset(season_traits, variable_id == curr_variable_id)
+    variable_traits <- subset(traits, variable_id == curr_variable_id)
 
     variable_data[[ 'units' ]] <- variable_record[[ 'units' ]]
     variable_data[[ 'id' ]] <- variable_record[[ 'id' ]]
     variable_data[[ 'traits' ]] <- variable_traits
 
     # subset trait data by variable
-    season_trait_data[[ variable_name ]] <- variable_data
+    trait_data[[ variable_name ]] <- variable_data
   }
   # save trait data for all variables
-  season_data[[ 'trait_data' ]] <- season_trait_data
+  season_data[[ 'trait_data' ]] <- trait_data
 
-  season_treatment_ids <- unique(na.omit(
-    season_traits[[ 'treatment_id' ]]
+  treatment_ids <- unique(na.omit(
+    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) %>%
+  management_ids <- tbl(bety_src, 'managements_treatments') %>%
+    filter(treatment_id %in% treatment_ids) %>%
     collect() %>% unlist(use.names = FALSE)
 
-  season_managements <- tbl(bety_src, 'managements') %>%
+  managements <- tbl(bety_src, 'managements') %>%
     filter(date >= season[[ 'start_date' ]] & date <= season[[ 'end_date' ]]) %>%
-    filter(id %in% season_management_ids) %>%
+    filter(id %in% management_ids) %>%
     select(id, date, mgmttype, notes) %>%
     collect()
 
   # save management data
-  season_data[[ 'managements' ]] <- season_managements
+  season_data[[ 'managements' ]] <- managements
 
   # load existing full_cache_data object if exists, otherwise use empty list object
   full_cache_data <- list()

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

@@ -1,27 +1,12 @@
 library(rgeos)
 library(dplyr)
 
-# 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')
-)
-
 # render leaflet map from traits for a given date
-render_site_map <- function(traits, legend_title, render_date) {
+render_site_map <- function(traits, render_date, legend_title) {
 
-  # 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)
+  latest_traits <- subset(traits, date <= render_date & !is.na(geometry)) %>% 
+    group_by(geometry) %>% top_n(1, date)
 
   pal <- colorNumeric(
     palette = 'Greens',
@@ -31,14 +16,16 @@ render_site_map <- function(traits, legend_title, render_date) {
   map <- leaflet(options = leafletOptions(minZoom = 20, maxZoom = 21)) %>% addTiles()
 
   # 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))) {
+  if (nrow(latest_traits) > 0) {
+    for (i in 1:nrow(latest_traits)){
+      curr_trait <- latest_traits[i,]
 
-      trait <- subset(latest_traits, site_id == site[[ 'id' ]])
-      map <- addPolygons(map, data = geo_object, color = pal(trait[['mean']]))
+      site_poly <- readWKT(curr_trait[[ 'geometry' ]])
+  
+      if ('polygons' %in% names(attributes(site_poly))) {
+        trait_value <- curr_trait[[ 'mean' ]]
+        map <- addPolygons(map, data = site_poly, color = pal(trait_value))
+      }
     }
   }