- added hard-coded connection parameters that work with ssh tunnel to bety6

- refactored dplyr code to use lazy eval and semi-joins instead of filter
- removed outline from plot colors
- changed basemap to semi-useful default

Author: dlebauer

experiment-trait-data-visualizer/app.R

@@ -107,7 +107,7 @@ render_trait_plot <- function(season_name, input, output, full_cache_data) {
     title <- ifelse(units == '', selected_variable, paste0(selected_variable, ' (', units, ')'))
 
     trait_plot <- ggplot() + 
-      geom_violin(data = plot_data, scale = 'width', width = 0.75,
+      geom_violin(data = plot_data, scale = 'width', width = 1,
                    aes(x = as.Date(date), y = mean, 
                        group = as.Date(date))) +
       geom_boxplot(data = plot_data, 
@@ -124,7 +124,7 @@ render_trait_plot <- function(season_name, input, output, full_cache_data) {
           geom_point(data = subset(plot_data, cultivar_name == selected_cultivar), 
                      color = 'red', aes(x = as.Date(date), y = mean, group = site_id)) +
           geom_line(data = subset(plot_data, cultivar_name == selected_cultivar), 
-                     size = 0.5, color = 'red', aes(x = as.Date(date), y = mean, group = site_id)) 
+                     size = 0.25, color = 'red', alpha = 0.25, aes(x = as.Date(date), y = mean, group = site_id)) 
     }
 
     trait_plot + 
@@ -133,7 +133,6 @@ render_trait_plot <- function(season_name, input, output, full_cache_data) {
         x = "Date",
         y = units
       ) +
-      
       theme_bw() + 
       theme(text = element_text(size = 20), axis.text.x = element_text(angle = 45, hjust = 1), legend.position = "none") +
       xlim(as.Date(selected_season_data[[ 'start_date' ]]), as.Date(selected_season_data[[ 'end_date' ]])) +
@@ -202,8 +201,10 @@ render_timeline_hover <- function(season_name, input, output, full_cache_data) {
     selected_record <- management_data[ as.numeric(selected), ]
 
     formatted_notes <- ''
-    if (selected_record[[ 'notes' ]] != '')
+    if (selected_record[[ 'notes' ]] != '') {
       formatted_notes <- paste0('<br><br>', selected_record[[ 'notes' ]])
+    }
+      
 
     wellPanel(class = 'mgmt-select-info',
       HTML(paste0(
@@ -238,12 +239,16 @@ render_map <- function(season_name, input, output, full_cache_data) {
 
     traits <- full_cache_data[[ season_name ]][[ 'trait_data' ]][[ selected_variable ]][[ 'traits' ]]
 
-    if (selected_cultivar != 'None')
+    if (selected_cultivar != 'None'){
       traits <- subset(traits, cultivar_name == selected_cultivar)
+    }
+      
 
     units <- full_cache_data[[ season_name ]][[ 'trait_data' ]][[ selected_variable ]][[ 'units' ]]
-    if (units != '')
+    if (units != '') {
       units <- paste0('(', units, ')')
+    }
+      
     legend_title <- paste0(selected_variable, ' ', units)
 
     render_site_map(traits, render_date, legend_title)

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

@@ -13,13 +13,14 @@ options(scipen=999)
 # )
 bety_src <- src_postgres(dbname = "bety", 
                          password = 'bety', 
-                         host = 'terra-bety.default', 
+                         #host = 'terra-bety.default', 
+                         host = 'localhost', 
                          user = 'bety', 
                          port = 5432)
 
 # 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' ]])
@@ -29,50 +30,50 @@ get_data_for_season <- function(season) {
     select(site_id) %>%
     collect() %>% unlist(use.names = FALSE)
 
-  if (is.null(site_ids))
+  if (is.null(site_ids)){
     return()
+  }
 
   # only use trait records associated with the relevant sites
-  traits_table <- tbl(bety_src, 'traits') %>%
+  traits_table <- tbl(bety_src, 'traits', n = Inf) %>%
     filter(date >= season[[ 'start_date' ]] & date <= season[[ 'end_date' ]]) %>%
     filter(site_id %in% site_ids) %>%
     select(date, mean, variable_id, cultivar_id, treatment_id, site_id)
 
+  n_traits <- traits_table %>% summarize(n = n()) %>% collect(n = Inf)
+  if(n_traits == 0) return()
   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)
+    rename(site_id = id)
 
   cultivars_table <- tbl(bety_src, 'cultivars') %>%
-    mutate(cultivar_id = id, cultivar_name = name) %>%
+    rename(cultivar_id = id, cultivar_name = name) %>%
     select(cultivar_id, cultivar_name)
 
   traits <- traits_table %>% 
     left_join(sites_table, by = 'site_id') %>%
-    left_join(cultivars_table, by = 'cultivar_id') %>%
-    collect() %>% as.data.frame()
+    left_join(cultivars_table, by = 'cultivar_id') 
 
-  if (nrow(traits) == 0)
-    return()
+  variables <- tbl(bety_src, 'variables') %>%
+    rename(variable_id = id)  %>% 
+    semi_join(traits, by = 'variable_id')
 
-  variable_ids <- unique(na.omit(
-    traits[[ 'variable_id' ]]
-  ))
+  variable_ids <- variables %>% select(variable_id) %>% collect
 
   trait_data <- list()
-  for (curr_variable_id in variable_ids) {
-    
+  for (curr_variable_id in variable_ids$variable_id) {
+
     variable_data <- list()
 
-    variable_record <- tbl(bety_src, 'variables') %>%
-      filter(id == curr_variable_id) %>%
-      select(id, name, units) %>% collect()
+    variable_record <- variables %>% filter(variable_id == curr_variable_id) %>% 
+      select(variable_id, name, units) %>% collect
 
-    variable_name <- toTitleCase(gsub('_', ' ', variable_record[[ 'name' ]]))
-    variable_traits <- subset(traits, variable_id == curr_variable_id)
+    variable_name <- tools::toTitleCase(gsub('_', ' ', variable_record %>% select(name) %>% collect))
+    variable_traits <- traits %>% filter(variable_id == curr_variable_id) %>% collect(n = Inf)
 
-    variable_data[[ 'units' ]] <- variable_record[[ 'units' ]]
-    variable_data[[ 'id' ]] <- variable_record[[ 'id' ]]
+    variable_data[[ 'units' ]] <- variable_record %>% select(units) 
+    variable_data[[ 'id' ]] <- variable_record %>% select(variable_id)
     variable_data[[ 'traits' ]] <- variable_traits
 
     # subset trait data by variable
@@ -81,13 +82,9 @@ get_data_for_season <- function(season) {
   # save trait data for all variables
   season_data[[ 'trait_data' ]] <- trait_data
 
-  treatment_ids <- unique(na.omit(
-    traits[[ 'treatment_id' ]]
-  ))
-  
   # only use management records associated with the relevant treatments
   management_ids <- tbl(bety_src, 'managements_treatments') %>%
-    filter(treatment_id %in% treatment_ids) %>%
+    semi_join(traits, by = 'treatment_id') %>%
     collect() %>% unlist(use.names = FALSE)
 
   managements <- tbl(bety_src, 'managements') %>%

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

@@ -13,7 +13,8 @@ render_site_map <- function(traits, render_date, legend_title) {
     domain = traits[[ 'mean' ]]
   )
 
-  map <- leaflet(options = leafletOptions(minZoom = 20, maxZoom = 21)) %>% addTiles()
+  map <- leaflet(options = leafletOptions(minZoom = 18, maxZoom = 21))  %>% 
+    addProviderTiles(providers$Esri.WorldImagery) # eventually want to overlay with stitched image from current day
 
   # add polygon for each site, color by trait mean value
   if (nrow(latest_traits) > 0) {
@@ -24,7 +25,10 @@ render_site_map <- function(traits, render_date, legend_title) {
 
       if ('polygons' %in% names(attributes(site_poly))) {
         trait_value <- curr_trait[[ 'mean' ]]
-        map <- addPolygons(map, data = site_poly, color = pal(trait_value))
+        map <- addPolygons(map, data = site_poly, 
+                           color = pal(trait_value), opacity = 0, 
+                           fillColor = pal(trait_value), fillOpacity = 0.8)
+                           #TODO add popup = plot name + trait value for plot 
       }
     }
   }