Plot improvements, heatmap improvements

Author: Nick Heyek

experiment-trait-data-visualizer/app.R

@@ -49,6 +49,7 @@ render_season_ui <- function(season_name) {
         ),
         tabPanel('Map',
           div(class = 'map-container push-out',
+            p(class = 'map-message', 'Showing data from latest recorded observation date'),
             leafletOutput(paste0('site_map_', season_name), width = '750px', height = '1000px')
           )
         )
@@ -93,21 +94,25 @@ 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, ')')
 
     # 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) +
 
     { 
       if (selected_cultivar != 'None') {
-        geom_point(data = subset(plot_data, cultivar_name == selected_cultivar), 
-                   size = 1, color = "red", aes(x = as.Date(date), y = mean))
+        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))
       }
     } +
 
     labs(
-      title = paste0(selected_variable, '\n'),
+      title = paste0(title, '\n'),
       x = "Observation Dates",
       y = units
     ) +
@@ -194,11 +199,22 @@ render_map <- function(season_name, input, output, full_cache_data) {
   output[[ paste0('site_map_', season_name) ]] <- renderLeaflet({
 
     req(input[[ paste0('selected_variable_', season_name) ]])
+    req(input[[ paste0('selected_cultivar_', season_name) ]])
+    
     selected_variable <- input[[ paste0('selected_variable_', season_name) ]]
+    selected_cultivar <- input[[ paste0('selected_cultivar_', season_name) ]]
 
     traits <- full_cache_data[[ season_name ]][[ 'trait_data' ]][[ selected_variable ]][[ 'traits' ]]
 
-    render_site_map(traits)
+    if (selected_cultivar != 'None')
+      traits <- subset(traits, cultivar_name == selected_cultivar)
+    
+    units <- full_cache_data[[ season_name ]][[ 'trait_data' ]][[ selected_variable ]][[ 'units' ]]
+    if (units != '')
+      units <- paste0('(', units, ')')
+    legend_title <- paste0(selected_variable, ' ', units)
+    
+    render_site_map(traits, legend_title)
   })
 }
 

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

@@ -0,0 +1,49 @@
+library(rgeos)
+library(dplyr)
+
+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_site_map <- function(traits, legend_title) {
+
+  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()
+  
+  latest_date <- max(as.Date(traits[['date']]))
+  latest_traits <- subset(traits, as.Date(date) == latest_date)
+
+  map <- leaflet(options = leafletOptions(minZoom = 20, maxZoom = 22)) %>% addTiles()
+  
+  pal <- colorNumeric(
+    palette = "GnBu",
+    domain = latest_traits[[ 'mean' ]]
+  )
+  
+  if (nrow(sites) > 0) {
+    for (i in 1:nrow(sites)){
+      site <- sites[i,]
+      
+      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']]), smoothFactor = 0.5)
+      }
+    }
+  }
+  
+  legend_title <- paste0(legend_title, '<br>', latest_date)
+  
+  map <- addLegend(map, "topright", pal = pal, 
+                   title = legend_title,
+                   values = traits[[ 'mean' ]])
+  map
+}

experiment-trait-data-visualizer/www/style.css

@@ -24,4 +24,8 @@ html, body {
   width: 750px;
   margin-left: auto;
   margin-right: auto;
+}
+.map-message {
+  font-style: italic;
+  font-size: 18px;
 }