R/02.01_mod_buy_map.R

In CedricMondy/bnvd: Explore French pesticide data

# Module UI
  
#' @title   mod_buy_map_ui and mod_buy_map_server
#' @description  A shiny Module.
#'
#' @param id shiny id
#' @param input internal
#' @param output internal
#' @param session internal
#'
#' @rdname mod_buy_map
#'
#' @keywords internal
#' @export 
#' @importFrom leaflet leaflet addLayersControl addLegend colorBin clearShapes clearControls addTiles fitBounds renderLeaflet leafletOutput addPolygons leafletProxy tileOptions
#' @importFrom shiny NS tagList observe HTML selectInput div absolutePanel
#' @importFrom leaflet.extras addSearchOSM
#' @importFrom sf st_as_sfc st_crs st_intersects
mod_buy_map_ui <- function(id){
  ns <- NS(id)
  
  Surf_Ref <- c("Surface Agricole Utile" = "SAU", "Surface Agricole Utile - Surface Toujours en herbe" = "SAU_STH")
  Periode <- c("2013" = 2013,"2014" = 2014,"2015" = 2015, "2016" = 2016, "2017" = 2017)

  tagList(
    leafletOutput(ns("mymap"), width = "100%", height = "100%"),
    absolutePanel(selectInput(ns("Surf_Ref"), "Surface de reference", Surf_Ref),
                  sliderInput(ns("Periode"), "Annee", 
                              min = min(Periode), max = max(Periode),
                              value = min(Periode), step = 1, ticks = FALSE, 
                              animate = animationOptions(interval = 1500), sep = ""),
                  id = "controls",
                  class = "panel panel-default",
                  fixed = TRUE,
                  top = "auto", 
                  left = 20, 
                  right = 20,
                  bottom = 20,
                  width = 330,
                  height = "auto"
    )
    )
}
    
# Module Server
    
#' @rdname mod_buy_map
#' @export
#' @keywords internal
    
mod_buy_map_server <- function(input, output, session){
  ns <- session$ns
  
  titles <- paste0("Quantité de substances <br>achetées rapportée à <br>la surface agricole utile", 
                   c("<br>(en kg/ha)",
                     ",<br>hors surfaces toujours<br>en herbe (en kg/ha)")) %>% 
    as.list()
  names(titles) <- c("SAU", "SAU_STH")
  
  Title_map <- titles$SAU
  
  data <- DPT_Layer %>% 
    rename(ID = DEP)
  smoothFactor <- 1
  weight <- 1
  
  Var <- paste0('QTE_SUBS_SAU_2013')
  colorData <- data[[Var]]
  bins <- c(0, 1,2.5, 5, Inf)
  pal <- colorBin("YlOrRd", domain = colorData, bins = bins)
  
  #########CARTE AU CHARGEMENT
  output$mymap <- renderLeaflet({
    leaflet() %>%
      addTiles(urlTemplate = 'http://{s}.tiles.wmflabs.org/bw-mapnik/{z}/{x}/{y}.png',
               options = tileOptions(maxZoom = 12)) %>%
      fitBounds(lng1 = -5.14,lat1 = 41.36, lng2 = 9.55, lat2 = 51.09) %>%
      addSearchOSM() %>%
      addPolygons(data = data,
                  fillColor = ~pal(colorData),
                  weight = weight,
                  color = "white",
                  opacity = 1,
                  fillOpacity = 0.7,
                  popup = paste0("<strong>",data$ID,"</strong><br/>",
                                 data[[Var]]," kg/ha"),
                  smoothFactor = smoothFactor) %>%
      addLegend(data = data, pal = pal, values = colorData, 
                opacity = 0.7, title = Title_map)
    }) 

  #########CARTE AU CHANGEMENT DE VALEUR SELECTIONNEES
  observe({

    req(input$mymap_zoom, input$mymap_bounds,
        input$Surf_Ref, input$Periode)
    
    zoom <- input$mymap_zoom
    
    bbox <- input$mymap_bounds
    bbox_rect <- paste0("POLYGON((",
                        bbox$west, " ", bbox$south, ",",
                        bbox$west, " ", bbox$north, ",",
                        bbox$east, " ", bbox$north, ",",
                        bbox$east, " ", bbox$south, ",",
                        bbox$west, " ", bbox$south, "))") %>% 
      st_as_sfc(crs = st_crs(DPT_Layer))
        
    Var <- paste0('QTE_SUBS_',input$Surf_Ref,'_',input$Periode)
    
    if (zoom > 8) {
      cover <- CP_Layer %>% 
        st_intersects(y = bbox_rect)
      
      data <- CP_Layer[lengths(cover) > 0,]
      
    } else {
      cover <- DPT_Layer %>% 
        st_intersects(y = bbox_rect)
      
      data <- DPT_Layer[lengths(cover) > 0,] %>% 
        rename(ID = DEP) 
      
      }

    colorData <- data[[Var]]
    pal <- colorBin("YlOrRd", domain = colorData, bins = bins)
    
    leafletProxy(ns("mymap")) %>%
      clearShapes() %>%
      addPolygons(data = data,
                  fillColor = ~pal(colorData),
                  weight = weight,
                  color = "white",
                  opacity = 1,
                  fillOpacity = 0.7,
                  popup = paste0("<strong>",data$ID,"</strong><br/>",
                                 data[[Var]]," kg/ha"),
                  smoothFactor = smoothFactor)
  })
  
  observe({
    req(input$Surf_Ref)
    
    Title_map <- titles[[input$Surf_Ref]]

    leafletProxy(ns("mymap")) %>% 
      clearControls() %>% 
      addLegend(data = data, pal = pal, values = colorData, 
                opacity = 0.7, title = Title_map)
  })
}
    
## To be copied in the UI
# mod_buy_map_ui("buy_map_ui_1")
    
## To be copied in the server
# callModule(mod_buy_map_server, "buy_map_ui_1")