review #76 + R CMD check

alienSpecies/NAMESPACE

@@ -5,6 +5,7 @@ export(barplotLenteNesten)
 export(checkS3)
 export(combineActiveData)
 export(combineNestenData)
+export(combineVespaData)
 export(comboTreeInput)
 export(countNestenServer)
 export(countNestenUI)
@@ -47,6 +48,9 @@ export(mapHeatServer)
 export(mapHeatUI)
 export(mapOccurrence)
 export(mapPopup)
+export(mapRaster)
+export(mapRasterServer)
+export(mapRasterUI)
 export(mapRegions)
 export(mapRegionsServer)
 export(mapRegionsUI)
@@ -65,6 +69,7 @@ export(runShiny)
 export(setupS3)
 export(simpleCap)
 export(summarizeTimeSeries)
+export(summarizeYearGroupData)
 export(tableIndicators)
 export(tableIndicatorsServer)
 export(tableIndicatorsUI)
@@ -119,6 +124,7 @@ importFrom(data.table,setDT)
 importFrom(data.table,setkey)
 importFrom(data.table,setkeyv)
 importFrom(data.table,setnames)
+importFrom(data.table,year)
 importFrom(dplyr,all_of)
 importFrom(dplyr,case_when)
 importFrom(dplyr,filter)
@@ -168,11 +174,13 @@ importFrom(shiny,singleton)
 importFrom(shinycssloaders,withSpinner)
 importFrom(stats,aggregate)
 importFrom(stats,as.formula)
+importFrom(stats,complete.cases)
 importFrom(terra,rast)
 importFrom(terra,values)
 importFrom(testthat,test_file)
 importFrom(tidyr,pivot_wider)
 importFrom(utils,capture.output)
+importFrom(utils,download.file)
 importFrom(utils,read.csv)
 importFrom(utils,read.table)
 importFrom(utils,tail)

alienSpecies/R/countYearGroup.R

@@ -1,24 +1,31 @@
 #' Summarize Vespa Velutina data for the plot \code{countYearGroup}
 #' 
 #' @param df data.frame with nesten data 
+#' @param gewest character, which region(s) to filter on
 #' @return data.table with summarized nesten data, as input for \code{codeYearGroup}
 #' 
 #' @author mvarewyck
-#' @importFrom dplyr mutate group_by summarise rename
+#' @importFrom dplyr mutate group_by summarise rename filter
 #' @importFrom data.table as.data.table
 #' @importFrom sf st_drop_geometry
 #' @export
-summarizeYearGroupData <- function(df) {
+summarizeYearGroupData <- function(df, gewest) {
 
-  df %>%
+  # For R CMD check
+  result <- GEWEST <- observation_time <- NULL
+
+  toReturn <- df %>%
     st_drop_geometry() %>%
     mutate(year = as.integer(format(observation_time, "%Y")),
-      result = ifelse(is.na(result), "onbekend", result)) %>% 
+      result = ifelse(is.na(result), "onbekend", result)) %>%
+    filter(GEWEST %in% gewest) %>%
     group_by(year, result, GEWEST) %>%
     summarise(count = n()) %>% 
     rename(Behandeling = result)  %>%
     as.data.table()  
 
+  toReturn
+
 }
 
 
@@ -168,8 +175,7 @@ countYearGroupUI <- function(id) {
 
       uiOutput(ns("descriptionCountYearGroup")),
 
-      optionsModuleUI(id = ns("countYearGroup"), showSummary = TRUE,
-        showGewest = TRUE),
+      optionsModuleUI(id = ns("countYearGroup"), showSummary = TRUE),
       plotModuleUI(id = ns("countYearGroup")),
       tags$hr()
 

alienSpecies/R/data_create.R

@@ -252,6 +252,7 @@ createShapeData <- function(
 #' and attribute 'Date', the date that this data file was created
 #' @importFrom data.table fread :=
 #' @importFrom utils tail
+#' @importFrom stats complete.cases
 #' @export
 
 createTabularData <- function(
@@ -264,6 +265,7 @@ createTabularData <- function(
   scientificName <- NULL
   i.scientificName <- NULL
   i.classKey <- NULL
+  taxonKey <- variable <- eea_cell_code <- NULL
 
   warningMessage <- NULL
 

alienSpecies/R/data_load.R

@@ -203,7 +203,7 @@ translate <- function(data = loadMetaData(type = "ui"), id) {
   # can be turned of in production
   if (!is.null(data) & !all(id %in% data$id)) {
     if (!all(is.na(id[!id %in% data$id])))
-      warning("Not in translation file: ", vectorToTitleString(id[!id %in% data$id]))
+      message("Not in translation file: ", vectorToTitleString(id[!id %in% data$id]))
   }
 
   data <- rbind(

alienSpecies/R/mapHeat.R

@@ -48,18 +48,21 @@ combineActiveData <- function(activeData, untreatedData, managedData = NULL) {
 #' 
 #' @param pointsData sf data.frame, points observations for individuals
 #' @param nestenData sf data.frame, points observations for nests
+#' @param currentYear integer, current year for selecting nest data
 #' @inheritParams mapHeat
 #' @return sf data.frame, combining both data sources
 #' 
 #' @author mvarewyck
 #' @importFrom dplyr select filter mutate group_by summarise rename case_when
+#' @importFrom data.table year
 #' @export
-combineNestenData <- function(pointsData, nestenData, currentYear = year(Sys.Date()),
+combineNestenData <- function(pointsData, nestenData, 
+  currentYear = data.table::year(Sys.Date()),
   uiText = NULL) {
 
   # For R CMD check
   type <- eventDate <- popup <- institutionCode <- id <- observation_time <- NULL
-  geometry <- NULL
+  geometry <- nest_type <- result <- NULL
 
   points_redux <- pointsData %>% 
     dplyr::filter(year == currentYear) %>%
@@ -123,8 +126,7 @@ mapHeat <- function(combinedData, baseMap = addBaseMap(), colors, blur = NULL, s
 
 
   # Base map
-  ah_map <- baseMap %>%
-    addScaleBar(position = "bottomleft")
+  ah_map <- baseMap
 
   if (addGlobe)
     ah_map <- addTiles(ah_map)

alienSpecies/R/mapRaster.R

@@ -10,6 +10,7 @@
 #' Create leaflet raster map for the climate risk maps
 #' 
 #' @param rasterInput SpatRaster object, as returned by \code{terra::rast}
+#' @param legendScale character, scale to be mentioned in the legend
 #' @inheritParams mapHeat
 #' 
 #' @return leaflet map
@@ -81,6 +82,7 @@ mapRaster <- function(rasterInput, baseMap = addBaseMap(), colors = "Spectral",
 #' @importFrom webshot webshot
 #' @importFrom terra values rast
 #' @importFrom httr http_status GET
+#' @importFrom utils download.file
 #' @export
 mapRasterServer <- function(id, uiText, species, gewest, taxonKey) {
 

alienSpecies/R/mapRegions.R

@@ -1,4 +1,49 @@
 
+
+#' Combine all nesten data for regions summary
+#' 
+#' Returned object can be used as `data` in \code{\link{createSummaryRegions}}
+#' @inheritParams combineNestenData
+#' @param nestenBeheerdData sf data.frame, beheerde nesten data 
+#' @return data.frame
+#' 
+#' @author mvarewyck
+#' @export
+combineVespaData <- function(pointsData, nestenData, nestenBeheerdData) {
+
+  ## Individual data
+  pointsData$type <- "individual"
+  # Columns
+  regionVariables <- list(level3Name = "NAAM", level2Name = "provincie", level1Name = "GEWEST")
+  for (iName in names(regionVariables))
+    names(pointsData)[match(iName, names(pointsData))] <- regionVariables[[iName]]
+  # Gewest
+  pointsData$GEWEST <- ifelse(pointsData$GEWEST == "Vlaanderen", "flanders", 
+    ifelse(pointsData$GEWEST == "Bruxelles", "brussels", 
+      ifelse(pointsData$GEWEST == "Wallonie", "wallonia", "")))
+  # Provincie
+  pointsData$provincie <- ifelse(pointsData$provincie == "Vlaams Brabant", "Vlaams-Brabant",
+    ifelse(pointsData$provincie == "Bruxelles", "HoofdstedelijkGewest", 
+      ifelse(pointsData$provincie == "Liège", "Luik", 
+        ifelse(pointsData$provincie == "Brabant Wallon", "Waals-Brabant",
+          ifelse(pointsData$provincie == "Hainaut", "Henegouwen", pointsData$provincie)))))
+  pointsData$nest_type <- "individual"
+  pointsData$isBeheerd <- FALSE
+
+  ## Nest data
+  nestenData$type <- "nest"
+  nestenData$isBeheerd <- nestenData$geometry %in% nestenBeheerdData$geometry
+
+  keepColumns <- c("year", "type", "nest_type", "NAAM", "provincie", "GEWEST", "isBeheerd", "geometry")
+  vespaBoth <- rbind(pointsData[, keepColumns], nestenData[, keepColumns])
+  vespaBoth$nest_type[vespaBoth$nest_type %in% c("NA", "NULL")] <- NA 
+
+  vespaBoth
+
+}
+
+
+
 #' Create summary data per region
 #' @param data data.table with management data
 #' @param shapeData list, each object is \code{SpatialPolygonsDataFrame}. 
@@ -148,6 +193,7 @@ createSummaryRegions <- function(data, shapeData,
 #' @param managementData data.frame, management data
 #' @param occurrenceData data.frame, occurrence data
 #' @param shapeData list with spatial data (grid and regions)
+#' @inheritParams mapHeat
 #' @param uiText data.frame, for translations
 #' @param regionLevel character, region level to color polygons
 #' @param palette character, color palette to be used, see also \code{\link[leaflet]{colorFactor}}
@@ -158,7 +204,8 @@ createSummaryRegions <- function(data, shapeData,
 #' @author mvarewyck
 #' @import leaflet
 #' @export
-mapRegions <- function(managementData, occurrenceData = NULL, shapeData, uiText = NULL, 
+mapRegions <- function(managementData, occurrenceData = NULL, shapeData, 
+  baseMap = addBaseMap(), uiText = NULL,
   regionLevel = c("communes", "provinces"), palette = "YlOrBr",
   legend = "topright", addGlobe = FALSE) {
 
@@ -169,9 +216,29 @@ mapRegions <- function(managementData, occurrenceData = NULL, shapeData, uiText
     reverse = (palette != "YlOrBr"))
   valuesPalette <- managementData$group[match(spatialData$NAAM, managementData$region)]
 
+  # Add borders
+  if (regionLevel == "communes") {
+
+    # TODO include in addBaseMap()
+    myMap <- leaflet() %>% 
+      addPolylines(
+        data = shapeData$provinces, 
+        weight = 3,
+        color = "black",
+        opacity = 0.8,
+        group = "borderRegion"
+      ) 
+
+  } else if (regionLevel == "provinces") {
+
+    myMap <- baseMap
+
+  }
+
 
-  myMap <- leaflet(spatialData) %>% 
+  myMap <- myMap %>% 
     addPolygons(
+      data = spatialData,
       weight = 1,
       color = "gray",
       fillColor = ~ paletteFunction(valuesPalette),
@@ -192,23 +259,7 @@ mapRegions <- function(managementData, occurrenceData = NULL, shapeData, uiText
 
   }
 
-  # Add borders
-  if (regionLevel == "communes") {
-
-    myMap <- myMap %>% 
-      addPolylines(
-        data = shapeData$provinces, 
-        weight = 3,
-        color = "black",
-        opacity = 0.8,
-        group = "borderRegion"
-      ) 
-
-  } else if (regionLevel == "provinces") {
-
-    myMap <- myMap %>% addBaseMap()
-
-  }
+
 
   # Add legend
   if (legend != "none") { 
@@ -431,11 +482,11 @@ mapRegionsServer <- function(id, uiText, species, gewest, df, occurrenceData, sh
           lapply(shapeData, function(iData) {
               if ("GEWEST" %in% colnames(iData)){
                 iData$GEWEST <- dplyr::recode(iData$GEWEST, "Brussels" = "brussels", "Vlaams"="flanders", "Waals" =  "wallonia")
-                iData[iData$GEWEST %in% gewest(), ]}else{
+                iData[iData$GEWEST %in% gewest(), ]
+              }else{
                 iData[apply(sf::st_drop_geometry(iData[, paste0("is", simpleCap(gewest())), drop = FALSE]), 1, sum) > 0, ]
-          }
-                })
-
+              }
+            })
 
         })
 
@@ -521,6 +572,7 @@ mapRegionsServer <- function(id, uiText, species, gewest, df, occurrenceData, sh
 
           mapRegions(managementData = summaryData(), occurrenceData = subOccurrence(), 
             shapeData = subShape(), uiText = uiText(), regionLevel = input$regionLevel,
+            baseMap = addBaseMap(regions = gewest()),
             addGlobe = isolate(input$globe %% 2 == 1),
             palette = if (!is.null(input$unit) && input$unit == "difference") "RdYlGn" else "YlOrBr")
 
@@ -702,7 +754,9 @@ mapRegionsServer <- function(id, uiText, species, gewest, df, occurrenceData, sh
       finalMap <- reactive({
 
           newMap <- mapRegions(managementData = summaryData(), occurrenceData = subOccurrence(), 
-            shapeData = subShape(), uiText = uiText(), regionLevel = input$regionLevel,
+            shapeData = subShape(), 
+            baseMap = addBaseMap(regions = gewest()),
+            uiText = uiText(), regionLevel = input$regionLevel,
             legend = input$legend, addGlobe = input$globe %% 2 == 1,
             palette = if (input$unit == "difference") "RdYlGn" else "YlOrBr")
 

alienSpecies/R/plot_trias.R

@@ -121,12 +121,15 @@ plotTriasServer <- function(id, uiText, data, triasFunction, triasArgs = NULL,
       output$filters <- renderUI({
 
           if (!is.null(filters)) 
-            lapply(filters, function(iFilter) {
-                checkboxInput(inputId = ns(iFilter), label = switch(iFilter,
-                    bias = translate(uiText(), "correctBias")$title,
-                    protected = translate(uiText(), "protectAreas")$title)
-                )
-              })
+            wellPanel(
+              lapply(filters, function(iFilter) {
+                  checkboxInput(inputId = ns(iFilter), label = switch(iFilter,
+                      bias = translate(uiText(), "correctBias")$title,
+                      protected = translate(uiText(), "protectAreas")$title)
+                  )
+                })
+            )
+
         })
 
 
@@ -184,7 +187,7 @@ plotTriasUI <- function(id, outputType = c("plot", "table")) {
     conditionalPanel("input.linkPlotTrias % 2 == 1", ns = ns,
 
       uiOutput(ns("descriptionPlotTrias")),
-      wellPanel(uiOutput(ns("filters"))),
+      uiOutput(ns("filters")),
 
       if (outputType == "plot")
           plotModuleUI(id = ns("plotTrias")) else