Merge pull request #170 from terraref/shiny-app-edits

dlebauer · web-flow · commit bdd3d4739951 · 2017-08-16T09:55:00.000-05:00
Shiny app edits
diff --git a/experiment-trait-data-visualizer/README.md b/experiment-trait-data-visualizer/README.md
@@ -29,7 +29,8 @@ apt-get install cron
 #### Setup and Notes
 
 * Data are cached in a file `cache.RData` and updated using the cronR R interface to cron
-* Access to BETYdb remote access requires ssh tunnel `ssh -Nf -L 5432:localhost:5432 bety6.ncsa.illinois.edu`
+* Access to BETYdb remote access requires ssh tunnel 
+  * `ssh -Nf -L 5432:localhost:5432 bety6.ncsa.illinois.edu`
   * requires access, which can be [requested here](https://identity.ncsa.illinois.edu/join/TU49BUUEDM)
 * Set the following environment variables
 
diff --git a/experiment-trait-data-visualizer/app.R b/experiment-trait-data-visualizer/app.R
@@ -11,11 +11,9 @@ source('render-site-map.R')
 # schedule daily execution of cache refresh
 cache_update_cmd <- cron_rscript('cache-refresh.R')
 
-if(!grepl('cache-update', cronR::cron_ls())){
-  cron_add(command = cache_update_cmd, frequency = 'daily', 
-           id = 'cache-update', description = 'daily update of BETYdb cache')
-}
-
+cron_clear(ask = FALSE)
+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'),
@@ -103,31 +101,40 @@ render_trait_plot <- function(season_name, input, output, full_cache_data) {
     plot_data <- selected_season_data[[ 'trait_data' ]][[ selected_variable ]][[ 'traits' ]]
     data_max <- max(plot_data[[ 'mean' ]])
     
-    title <- selected_variable
     units <- selected_season_data[[ 'trait_data' ]][[ selected_variable ]][[ 'units' ]]
-    if (units != '')
-      title <- paste0(selected_variable, ' (', units, ')')
-    
-    ggplot(plot_data, aes(as.Date(date), mean)) + 
-    geom_boxplot(aes(group = cut_width(as.Date(date), 1)), outlier.alpha = 0.1) +
-    
-    { 
-      if (selected_cultivar != 'None') {
-        title <- paste0(title, ' for ', selected_cultivar)
-        geom_line(data = subset(plot_data, cultivar_name == selected_cultivar), 
-                   size = 0.5, color = '#00C49F', aes(x = as.Date(date), y = mean, group = site_id))
-      }
-    } +
+    title <- ifelse(units == '', selected_variable, paste0(selected_variable, ' (', units, ')'))
     
-    labs(
-      title = paste0(title, '\n'),
-      x = "Observation Dates",
-      y = units
-    ) +
+    trait_plot <- ggplot() + 
+      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, 
+                  aes(x = as.Date(date), y = mean, 
+                      group = as.Date(date)), 
+                  outlier.alpha = 0.25, width = 0.2)  
+#      geom_point(data = plot_data, 
+#                 aes(x = as.Date(date), y = mean), 
+#                 alpha = 0.1, size = 0.1, position = position_jitter(width = 0.1))
+      
+    if (selected_cultivar != 'None') {
+        title <- paste0(title, '\nCultivar ', selected_cultivar, ' in red')
+        trait_plot <- trait_plot + 
+          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.25, color = 'red', alpha = 0.25, aes(x = as.Date(date), y = mean, group = site_id)) 
+    }
     
-    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' ]])) +
-    ylim(0, data_max)
+    trait_plot + 
+      labs(
+        title = paste0(title, '\n'),
+        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' ]])) +
+      ylim(0, data_max)
   })
 }
 
@@ -192,8 +199,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(
@@ -228,12 +237,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)
@@ -261,8 +274,10 @@ render_season_output <- function(season_name, input, output, full_cache_data) {
 server <- function(input, output) {
   
   # load 'full_cache_data' object from cache file
-  if (!file.exists('cache.RData'))
+  if (!file.exists('cache.RData')){
     source('cache-refresh.R')
+  }
+    
   load('cache.RData')
   
   # render UI for all available seasons
@@ -275,4 +290,4 @@ server <- function(input, output) {
   lapply(names(full_cache_data), render_season_output, input, output, full_cache_data)
 }
 
-shinyApp(ui = ui, server = server)
+shinyApp(ui = ui, server = server)
diff --git a/experiment-trait-data-visualizer/cache-refresh.R b/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,52 @@ 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 +84,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') %>%
diff --git a/experiment-trait-data-visualizer/render-site-map.R b/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 
       }
     }
   }
diff --git a/scripts/experimental_design.Rmd b/scripts/experimental_design.Rmd
@@ -0,0 +1,57 @@
+# Experimental Design
+
+
+```{r setup, echo=FALSE, message = FALSE}
+library(googlesheets)
+library(knitr)
+library(dplyr)
+
+opts_knit$set(echo = FALSE, message = FALSE, cache = TRUE)
+
+```
+## Accessions
+
+```{r accessions, echo = FALSE, message = FALSE}
+ss <- gs_key("1Nfabx_n1rNlO6NW3olD8MAibJ3KHnOMmMwOYYw4wwGc")
+accessions <- gs_read(ss, ws = "Accessions")
+a <- accessions %>% mutate_each( funs_( lazyeval::interp( ~replace(., is.na(.), "") ) ) ) %>% select(Entry, Code, Source,  Pedigree, Pedigree2)  
+
+a[1:193,] %>% kable
+
+a[195:201,] %>% kable(caption = a[194,'Entry'])
+
+a[204:252,] %>% kable(caption = a[203,'Entry'])
+
+```
+
+https://docs.google.com/spreadsheets/d/1Nfabx_n1rNlO6NW3olD8MAibJ3KHnOMmMwOYYw4wwGc/pubhtml?gid=239932660&amp;single=true
+
+## Experiments
+
+```{r experiments, echo = FALSE, message = FALSE}
+experiments <- gs_read(ss, ws = "Experiments")
+experiments %>% kable 
+```
+
+https://docs.google.com/spreadsheets/d/1Nfabx_n1rNlO6NW3olD8MAibJ3KHnOMmMwOYYw4wwGc/pubhtml?gid=890543376&amp;single=true
+
+## 2016 Field Layout 
+
+### Under Gantry
+
+```{r gantry-plot-layout, echo = FALSE, message = FALSE}
+gantry_plot_layout <- gs_read(ss, ws = "Gantry Plot Layout")
+gantry_plot_layout %>% kable 
+```
+
+https://docs.google.com/spreadsheets/d/1Nfabx_n1rNlO6NW3olD8MAibJ3KHnOMmMwOYYw4wwGc/pubhtml?gid=1231399646&amp;single=true
+
+### West of Gantry 
+
+```{r west-of-gantry-plot-layout, echo = FALSE, message = FALSE}
+west_of_gantry_plot_layout <- gs_read(ss, ws = "West of Gantry Plot Layout")
+west_of_gantry_plot_layout %>% kable 
+```
+
+https://docs.google.com/spreadsheets/d/1Nfabx_n1rNlO6NW3olD8MAibJ3KHnOMmMwOYYw4wwGc/pubhtml?gid=728631369&amp;single=true
+

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