traitvis-webapp/render-site-map.R at master · terraref/traitvis-webapp · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
library(rgeos)
library(dplyr)
library(raster)
library(mapview)
library(sf)
library(leafem)


# render leaflet map from traits for a given date
# overlay fullfield image if thumb avaiable for selected date
render_site_map <- function(selected_variable, traits, render_date, legend_title, overlay_image = 0) {

  # get most recent traits for each site
  # convert each site's geometry to a sfc object # will coerce polygons into multipolygon
  latest_traits <- subset(traits, as.Date(date) <= render_date & !is.na(geometry)) %>%
    mutate(site_poly = st_as_sfc(geometry)) %>%
    group_by(geometry) %>%
    top_n(1, date) %>%
    mutate(hover_label = paste0('<p>Cultivar: ',
                                cultivar_name,
                                '</p><p>Plot: ',
                                gsub('MAC Field Scanner Season [0-9]{1,2} ',
                                     '',
                                     sitename),
                                '</p><p>',
                                selected_variable,
                                ': ',
                                signif(mean, 3),
                                '</p>'))

  pal <- colorNumeric(
    palette = 'Greens',
    domain = traits[[ 'mean' ]]
  )

  map <- leaflet(options = leafletOptions(minZoom = 18, maxZoom = 21))  %>%
    addProviderTiles(providers$Esri.WorldImagery)

  if(nrow(latest_traits) > 0){
    # color sites by trait mean value
    # coerce site polygons to multipolygon
    map <- addFeatures(map,
                       data = st_cast(latest_traits[[ 'site_poly' ]], "MULTIPOLYGON"),
                       color = pal(latest_traits[[ 'mean' ]]),
                       opacity = 0,
                       fillColor = pal(latest_traits[[ 'mean' ]]),
                       fillOpacity = 0.8,
                       group = 'Heat map',
                       label = lapply(latest_traits[[ 'hover_label' ]], HTML))

    map <- addLayersControl(map,
                            overlayGroups = "Heat map",
                            position = "topleft")

    map <- addLegend(map,
                     "bottomright",
                     pal = pal,
                     title = legend_title,
                     values = traits[[ 'mean' ]])

    if(overlay_image == 1){

      image_dir <- 'rgb_fullfield/_thumbs'
      image_paths <- list.files(image_dir, pattern = as.character(render_date))
      full_image_paths <- file.path(image_dir, image_paths)

      for(path in full_image_paths){
        scan_number <- which(full_image_paths == path)
        scan_name <- paste0('scan ', scan_number)
        fullfield_image <- brick(path)
        map <- viewRGB(x = fullfield_image,
                       r = 1, g = 2, b = 3,
                       quantiles = NULL,
                       map = map,
                       layer.name = scan_name)
        map <- removeHomeButton(map@map)
      }
    }
  }

  map

}