Heatmap improvements

Author: Nick Heyek

experiment-trait-data-visualizer/app.R

@@ -49,8 +49,8 @@ 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')
+            uiOutput(paste0('map_date_slider_', season_name)),
+            leafletOutput(paste0('site_map_', season_name), width = '600px', height = '600px')
           )
         )
       )
@@ -107,7 +107,7 @@ render_trait_plot <- function(season_name, input, output, full_cache_data) {
       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))
+                   size = 0.5, color = '#00C49F', aes(x = as.Date(date), y = mean, group = site_id))
       }
     } +
 
@@ -196,13 +196,22 @@ render_timeline_hover <- function(season_name, input, output, full_cache_data) {
 
 render_map <- function(season_name, input, output, full_cache_data) {
 
+  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' ]]))
+  })
+  
   output[[ paste0('site_map_', season_name) ]] <- renderLeaflet({
 
     req(input[[ paste0('selected_variable_', season_name) ]])
     req(input[[ paste0('selected_cultivar_', season_name) ]])
+    req(input[[ paste0('map_date_', season_name) ]])
 
     selected_variable <- input[[ paste0('selected_variable_', season_name) ]]
     selected_cultivar <- input[[ paste0('selected_cultivar_', season_name) ]]
+    render_date <- input [[ paste0('map_date_', season_name) ]]
 
     traits <- full_cache_data[[ season_name ]][[ 'trait_data' ]][[ selected_variable ]][[ 'traits' ]]
 
@@ -214,10 +223,11 @@ 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_site_map(traits, legend_title, render_date)
   })
 }
 
+
 render_season_output <- function(season_name, input, output, full_cache_data) {
 
   render_variable_menu(season_name, output, full_cache_data)
@@ -233,6 +243,7 @@ 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

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

@@ -9,24 +9,23 @@ bety_src <- src_postgres(
   user = Sys.getenv('bety_user')
 )
 
-render_site_map <- function(traits, legend_title) {
+render_site_map <- function(traits, legend_title, render_date) {
 
   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)
+  latest_traits <- subset(traits, date <= render_date) %>% group_by(site_id) %>% top_n(1, date)
 
-  map <- leaflet(options = leafletOptions(minZoom = 20, maxZoom = 22)) %>% addTiles()
-  
   pal <- colorNumeric(
-    palette = "GnBu",
-    domain = latest_traits[[ 'mean' ]]
+    palette = 'Greens',
+    domain = traits[[ 'mean' ]]
   )
 
+  map <- leaflet(options = leafletOptions(minZoom = 20, maxZoom = 21)) %>% addTiles()
+  
   if (nrow(sites) > 0) {
     for (i in 1:nrow(sites)){
       site <- sites[i,]
@@ -35,14 +34,12 @@ render_site_map <- function(traits, legend_title) {
       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)
+        map <- addPolygons(map, data = geo_object, color = pal(trait[['mean']]))
       }
     }
   }
 
-  legend_title <- paste0(legend_title, '<br>', latest_date)
-  
-  map <- addLegend(map, "topright", pal = pal, 
+  map <- addLegend(map, "bottomright", pal = pal, 
                    title = legend_title,
                    values = traits[[ 'mean' ]])
   map

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

@@ -21,7 +21,7 @@ html, body {
 	height: auto;
 }
 .map-container {
-  width: 750px;
+  width: 600px;
   margin-left: auto;
   margin-right: auto;
 }