Merge pull request #51 from BiodiversiteQuebec/feature/validate-teledetection-data

✨ refactor for teledetection data validation #49

Author: vcameron1

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: rcoleo
 Title: rcoleo
-Version: 3.0.0
+Version: 3.1.0
 Authors@R: c(
     person("Steve", "Vissault", , "steve.vissault@usherbrooke.ca", role = "aut",
            comment = c(ORCID = "0000-0002-0866-4376")),
@@ -14,8 +14,8 @@ Description: Injection et retrait des données collectées dans le cadre du
     programme de suivi de la biodiversité via l'API de Coléo, un système
     d'information sur la biodiversité du Québec.
 License: MIT + file LICENSE
-URL: https://github.com/ReseauBiodiversiteQuebec/rcoleo
-BugReports: https://github.com/ReseauBiodiversiteQuebec/rcoleo/issues
+URL: https://github.com/biodiversitequebec/rcoleo
+BugReports: https://github.com/biodiversitequebec/rcoleo/issues
 Depends: 
     R (>= 4.1.0)
 Imports: 

NAMESPACE

@@ -20,6 +20,7 @@ export(coleo_request_by_code)
 export(coleo_request_data)
 export(coleo_request_general)
 export(coleo_resp_df)
+export(coleo_return_campaign_type)
 export(coleo_return_cols)
 export(coleo_return_required_tables)
 export(coleo_return_valid_campaigns)

R/coleo_format_utils.R

@@ -8,10 +8,8 @@
 #' @export
 #' 
 coleo_format <- function(dataFrame) {
-  # DataFrame infos
-  campaign_type <- unique(dataFrame$campaigns_type)
-  assertthat::assert_that(length(campaign_type) == 1,
-    msg = "Le type de campagne doit être unique")
+  # Get required columns for the campaign type
+  campaign_type <- coleo_return_campaign_type(dataFrame)
   data_cols <- coleo_return_cols(campaign_type)
 
   # Format columns

R/coleo_get_required_tables.R

@@ -20,16 +20,17 @@ coleo_prep_input_data <- function(df, db_table, schema = "public") {
   # Convert character NAs to actual NAs
   # df[df == "NA"] <- NA
 
-  # Add cell_id to sites table
-  if (db_table == "sites") {
+  # Add cell_id to required table
+  if (db_table == "sites" | db_table == "remote_sensing_events") {
     df <- df |>
       dplyr::nest_by(cells_cell_code) |>
       dplyr::mutate(coleo_id = list(coleo_request_by_code(human_code = cells_cell_code, table = "cells", schema = schema)),
             cell_id = coleo_extract_id(coleo_id)) |>
       dplyr::select(-cells_cell_code, -coleo_id) |>
       dplyr::relocate(cell_id) |>
       tidyr::unnest(cols = c(data)) |>
-      dplyr::ungroup()
+      dplyr::ungroup() |>
+      suppressMessages()
   }
 
   # Campaigns table specific manipulations

R/coleo_prep_input_data.R

@@ -16,6 +16,11 @@ coleo_read <- function(filePath) {
   # Catch the file extension
   ex <- strsplit(basename(filePath), split="\\.")[[1]][2]
 
+  # Test that the extension is acceptable
+  if (!ex %in% c("csv", "xls", "xlsx", "shp")) {
+    stop("Seuls les documents csv, shp et les gabarits coleo sont pris en charge au moment. Veuillez soumettre les donn\u00e9es dans un format support\u00e9.")
+  }
+
   # Read the data
   if (ex == "csv") dataFile <- coleo_read_csv(filePath)
   else if (ex %in% c("xls", "xlsx")) dataFile <- coleo_read_template(filePath)
@@ -29,20 +34,15 @@ coleo_read <- function(filePath) {
   # Format the data
   # - Except for shapefiles
   #-----------------------------------------------------------------------------
-  # Test that the extension is acceptable
-  if (!ex %in% c("csv", "xls", "xlsx")) stop("Seuls les documents csv, shp et les gabarits coleo sont pris en charge au moment. Veuillez soumettre les donn\u00e9es dans un format support\u00e9.")
-  else if ("campaigns_type" %in% names(dataFile)) {
-    # Format dataset
-    dataFile <- coleo_format(dataFile)
-
-    return(dataFile)
-  } else if ("sites_type" %in% colnames(dataFile)) {
+  if ("sites_type" %in% colnames(dataFile)) {
     # Format sites dataset
     dataFile$sites_lat <- as.numeric(dataFile$sites_lat)
     dataFile$sites_lon <- as.numeric(dataFile$sites_lon)
 
-    return(dataFile)
-  }
+  } else {
+    # Format dataset
+    dataFile <- coleo_format(dataFile)
+  } 
 
   return(dataFile)
 }

R/coleo_read.R

@@ -51,14 +51,14 @@ coleo_return_required_name_table <- function(db_table) {
 
 
 
-#' Retourne un vecteur contenant les noms valides de campagnes
+#' Retourne un vecteur contenant les noms valides de campagnes incluant les indicateurs de télédétection
 #'
 #'
 #' @return vecteur de charactères contenant tous les types de capagnes valides
 #' @export
 #'
 coleo_return_valid_campaigns <- function(){
-  campaigns <- coleo_get_enum_values("enum_campaigns_type")
+  campaigns <- c(coleo_get_enum_values("enum_campaigns_type"), coleo_get_enum_values("enum_remote_sensing_indicators_name"))
 
   return(campaigns)
 }
@@ -97,3 +97,28 @@ coleo_return_required_tables <- function(camp_type) {
 
   return(tbls)
 }
+
+
+#' Retourne le 'campaign_type' d'un jeu de données pour tous types d'inventaires.
+#' 
+#' @param data un jeu de données
+#' 
+#' @return le 'campaign_type' du jeu de données
+#' 
+#' @export
+#' 
+coleo_return_campaign_type <- function(data) {
+  # Get required columns for the campaign type
+  if (is.null(data$campaigns_type)) {
+    # Remote sensing campaigns
+    campaign_type <- unique(data$remote_sensing_indicators_name)
+  } else {
+    campaign_type <- unique(data$campaigns_type)
+  }
+
+  # Check if there is a single campaign type
+  if (length(campaign_type) > 1) stop("V\u00E9rifiez que toutes les valeurs de la colonne campaigns_type (ou remote_sensing_indicators_name) sont identiques et que la valeur est un type de campagne valide. \nLe type de campagne est n\u00E9cessaire pour les prochaines \u00E9tapes de validation.\n\n")
+  if (length(campaign_type) == 0) stop("V\u00E9rifiez qu'une colonne contient le type d'inventaire (campaigns_type ou remote_sensing_indicators_name) et que son nom de colonne correspond \u00e0 campaigns_type \nLe type de campagne est n\u00E9cessaire pour les prochaines \u00E9tapes de validation.\n\n")
+
+  return(campaign_type)
+}

R/coleo_return.R

@@ -10,11 +10,8 @@ coleo_return_cols <- function(campaign_type, required.columns = FALSE) {
   #-------------------------------------------------------------------------------
   # Vérifier que campaign_type est un choix valide
   #-------------------------------------------------------------------------------
-  all_camp_types <- coleo_request_general("rpc/get_enum_values",
-    'enum_type' = "enum_campaigns_type", response_as_df = TRUE) |>
-    unlist(use.names = FALSE)
-  assertthat::assert_that(campaign_type %in% all_camp_types,
-                          msg = "Entrez un type de campagne valide")
+  campaigns <- coleo_return_valid_campaigns()
+  if (!campaign_type %in% campaigns) stop("Entrez un type de campagne valide")
   #-------------------------------------------------------------------------------
   # Tables requises pour un type de campagne
   #-------------------------------------------------------------------------------
@@ -63,14 +60,26 @@ coleo_return_cols <- function(campaign_type, required.columns = FALSE) {
                                      classe = classe,
                                      valeurs_acceptees = valeurs_acceptees))
   #-------------------------------------------------------------------------------
-  # site_code est requis pour l'injection
+  # site_code ou cell_code est requis pour l'injection
   #-------------------------------------------------------------------------------
-  site_code_row <- data.frame(table = "sites",
-                              noms_de_champs = "site_code",
+  is_remote_sensing <- campaign_type %in% coleo_get_enum_values("enum_remote_sensing_indicators_name")
+  location_code_row <- data.frame(table = ifelse(is_remote_sensing, "cells", "sites"),
+                              noms_de_champs = ifelse(is_remote_sensing, "cell_code", "site_code"),
                               colonne_requise = "TRUE",
                               classe = "character",
                               valeurs_acceptees = NA_character_)
-  df <- rbind(df,site_code_row)
+  df <- rbind(df, location_code_row)
+    #-------------------------------------------------------------------------------
+  # remote_sensing_indicators_name est requis pour l'injection des inventaires de télédétection
+  #-------------------------------------------------------------------------------
+  if (is_remote_sensing) {
+    remote_sensing_row <- data.frame(table = "remote_sensing_indicators",
+                                     noms_de_champs = "name",
+                                     colonne_requise = "TRUE",
+                                     classe = "character",
+                                     valeurs_acceptees = coleo_get_enum_values("enum_remote_sensing_indicators_name"))
+    df <- rbind(df, remote_sensing_row)
+  }
   #-------------------------------------------------------------------------------
   # Special column class pour injection
   #-------------------------------------------------------------------------------

R/coleo_return_cols.R

@@ -18,13 +18,9 @@ coleo_validate <- function(data, media_path = NULL) {
   #------------------------------------------------------------------------
   # Check that there is a campaign type column and that it contains a unique value
   #------------------------------------------------------------------------
-  # Pursue only if there is a campaign type column
-  if(!assertthat::has_name(data, "campaigns_type")) stop("V\u00E9rifiez qu'une colonne contient le type de campagne et que son nom de colonne correspond \u00e0 campaigns_type \nLe type de campagne est n\u00E9cessaire pour les prochaines \u00E9tapes de validation.\n\n")
-
-  # Pursue only if there is a campaign type value
-  campaign_type <- unique(data$campaigns_type)
+  campaign_type <- coleo_return_campaign_type(data)
   campaigns <- coleo_return_valid_campaigns()
-  if(!(length(campaign_type) == 1 && campaign_type %in% campaigns)) stop("V\u00E9rifiez que toutes les valeurs de la colonne campaigns_type sont identiques et que la valeur est un type de campagne valide. \nLe type de campagne est n\u00E9cessaire pour les prochaines \u00E9tapes de validation.\n\n")
+  if(!campaign_type %in% campaigns) stop("V\u00E9rifiez que toutes les valeurs de la colonne campaigns_type sont identiques et que la valeur est un type de campagne valide. \nLe type de campagne est n\u00E9cessaire pour les prochaines \u00E9tapes de validation.\n\n")
 
 
   #------------------------------------------------------------------------
@@ -65,7 +61,7 @@ coleo_validate <- function(data, media_path = NULL) {
   # Check that the imported data has all of the required columns
   #------------------------------------------------------------------------
   # Compare required column names to present columns ----------------------
-  req_columns <- coleo_return_cols(campaign_type, required.columns = TRUE)$noms_de_colonnes
+  req_columns <- tbl[tbl$colonne_requise==TRUE,]$noms_de_colonnes
   req_col_diff <- setdiff(req_columns, true_nms)
   # Remove media table names from required columns
   media_names <- grepl("media_", req_col_diff, fixed = TRUE)
@@ -143,6 +139,23 @@ coleo_validate <- function(data, media_path = NULL) {
   erroneous_cols <- dat_names[!class_of_col]
   if(!all(class_of_col)) warning("--------------------------------------------------\nV\u00E9rifiez la classe des colonnes. Ces colonnes sont ", paste0("probl","\U00E9","matiques "), " : \n", paste0(erroneous_cols, collapse = ", "), "\n\n")
 
+  #------------------------------------------------------------------------
+  # Check that all cells exists in coleo
+  #------------------------------------------------------------------------
+  if ("cells_cell_code" %in% dat_names) {
+    existing_cells <- coleo_request_general(endpoint = "cells", response_as_df = TRUE, schema = 'public')
+    
+    are_cells_exists <- all(unique(data$cells_cell_code) %in% existing_cells$cell_code)
+    # Missing cells ---------------------------------------------------------
+    cells_x <- which(!unique(data$cells_cell_code) %in% existing_cells$cell_code)
+    if (length(cells_x) > 10) {
+      missing_cells <- paste0(paste0(unique(data$cells_cell_code)[cells_x[1:10]], collapse = ", "), " [...",length(cells_x)-10," tronquées]")
+    } else {
+      missing_cells <- paste0(unique(data$cells_cell_code)[cells_x], collapse = ", ")
+    }
+
+    if(!are_cells_exists) warning("--------------------------------------------------\n", paste0("V","\U00E9","rifiez")," les cellules ", missing_cells, " de la colonne cells_cell_code ou injectez ces cellules dans la table cells de coleo. Ces cellules n'existent pas dans coleo.\n\n")
+  }
 
   #------------------------------------------------------------------------
   # Check that all sites exists in coleo
@@ -152,8 +165,13 @@ coleo_validate <- function(data, media_path = NULL) {
   are_sites_exists <- all(unique(data$sites_site_code) %in% existing_sites$site_code)
   # Missing sites ---------------------------------------------------------
   sites_x <- which(!unique(data$sites_site_code) %in% existing_sites$site_code)
+  if (length(sites_x) > 10) {
+    missing_sites <- paste0(paste0(unique(data$sites_site_code)[sites_x[1:10]], collapse = ", ")," [...",length(sites_x)-10," tronqués]")
+  } else {
+    missing_sites <- paste0(unique(data$sites_site_code)[sites_x], collapse = ", ")
+  }
 
-  if(!are_sites_exists) warning("--------------------------------------------------\n", paste0("V","\U00E9","rifiez")," les sites ", paste0(unique(data$sites_site_code)[sites_x], collapse = ", "), " de la colonne sites_site_code ou injectez ces sites dans la table sites de coleo. Ces sites n'existent pas dans coleo.\n\n")
+  if(!are_sites_exists) warning("--------------------------------------------------\n", paste0("V","\U00E9","rifiez")," les sites ", missing_sites, " de la colonne sites_site_code ou injectez ces sites dans la table sites de coleo. Ces sites n'existent pas dans coleo.\n\n")
 
 
   #------------------------------------------------------------------------
@@ -460,7 +478,15 @@ coleo_validate <- function(data, media_path = NULL) {
     })
 
     is_ndigits_valid <- all(cols_ndigits)
-    is_na <- any(is.na(data[cols_date]))
+
+    ## Remove columns with all NA
+    all_na = sapply(cols_date, function(x) {
+      dates <- data[[x]]
+      non_na_dates <- dates[!is.na(dates)]
+      length(non_na_dates) == 0
+    })
+    non_na_date_cols <- cols_date[!all_na]
+    is_na <- any(is.na(data[cols_date[cols_date %in% req_columns]])) | any(is.na(data[non_na_date_cols]))
 
     if(!is_ndigits_valid) warning("--------------------------------------------------\nV\u00E9rifiez le format des valeurs de dates. Les dates doivent \u00EAtre du format YYYY-MM-DD.\n\n")
     if(is_na) warning("--------------------------------------------------\nCertaines valeurs de date sont manquantes ou NA. Les lignes sans valeurs dans les colonnes campaigns_opened_at et observations_date_obs ne seront pas injectées dans leurs tables respectives.\n\n")
@@ -475,23 +501,23 @@ coleo_validate <- function(data, media_path = NULL) {
   # - Check number of campaigns, empty campaigns, observations
   #------------------------------------------------------------------------
   # Check that the values are within a decent range -----------------------
-  if(length(cols_date) > 0) {
+  if(length(non_na_date_cols) > 0) {
     # Year
-    range_year <- sapply(data[cols_date], function(x) {
+    range_year <- sapply(data[non_na_date_cols], function(x) {
       split <- strsplit(unlist(x), "-", fixed = TRUE)
       split <- split[!is.na(split)]
       range(as.numeric(sapply(split, `[[`, 1)))
     }) |>
       range()
     # Month
-    range_month <- sapply(data[cols_date], function(x) {
+    range_month <- sapply(data[non_na_date_cols], function(x) {
       split <- strsplit(unlist(x), "-", fixed = TRUE)
       split <- split[!is.na(split)]
       range(as.numeric(sapply(split, `[[`, 2)))
     }) |>
       range()
     # Day
-    range_day <- sapply(data[cols_date], function(x) {
+    range_day <- sapply(data[non_na_date_cols], function(x) {
       split <- strsplit(unlist(x), "-", fixed = TRUE)
       split <- split[!is.na(split)]
       range(as.numeric(sapply(split, `[[`, 3)))

R/coleo_validate.R

@@ -2,6 +2,8 @@ test_that("coleo_return_* functions return object of the right type", {
 
   # coleo_return_valid_campaigns
   expect_vector(coleo_return_valid_campaigns())
+  valid_campaigns <- coleo_return_valid_campaigns()
+  expect_true(all(c("ADNe", "NDSI") %in% valid_campaigns))
 
   # coleo_return_valid_site_types
   expect_vector(coleo_return_valid_site_types())
@@ -23,4 +25,15 @@ test_that("coleo_return_* functions return object of the right type", {
   names(df_col_names) <- coleo_get_column_names(table)$column_name
   expect_mapequal(coleo_return_rename_vec_input_to_db(table), df_col_names)
 
+  # Test coleo_return_campaign_type
+  ## Returns the campaign type from a data frame
+  c_type <- coleo_return_campaign_type(data.frame(campaigns_type = "ADNe", campaigns_date_start = "2020-07-22"))
+  expect_equal(c_type, "ADNe")
+  ## Returns the remote sensing indicator from a data frame
+  rs_type <- coleo_return_campaign_type(data.frame(remote_sensing_indicators_name = "NDSI", remote_sensing_events_date_start = "2020-07-22"))
+  expect_equal(rs_type, "NDSI")
+  ## Throws an error if the campaign type is not present in the data frame  
+  expect_error(coleo_return_campaign_type(data.frame(campaigns_date_start = "2020-07-22")), "Vérifiez qu'une colonne contient le type d'inventaire")
+  ## Throws an error if more than one campaign type is present in the data frame
+  expect_error(coleo_return_campaign_type(data.frame(campaigns_type = c("ADNe", "NDSI"), campaigns_date_start = "2020-07-22")), "Vérifiez que toutes les valeurs de la colonne campaigns_type*")
 })

man/coleo_return_campaign_type.Rd

@@ -21,13 +21,21 @@ test_that("coleo_validate", {
   ## Test for missing campaign_type column
   dat_test <- subset(dat, select = -c(campaigns_type))
   testthat::expect_error(coleo_validate(dat_test),
-                         regexp = "V\U00E9rifiez qu'une colonne contient le type de campagne.*")
+                         regexp = "V\U00E9rifiez qu'une colonne contient le type d'inventaire*")
 
   ## Test for multiple values within the campaign_type column
   dat_test <- dat
   dat_test$campaigns_type <- c("sol", "insectes_sol","insectes_sol","insectes_sol","insectes_sol","insectes_sol")
   testthat::expect_error(coleo_validate(dat_test),
-                         regexp = "V\U00E9rifiez que toutes les valeurs de la colonne campaigns_type sont identiques.*")
+                         regexp = "V\U00E9rifiez que toutes les valeurs de la colonne campaigns_type.*")
+
+  ## Test that remote_sensing indicators are recognized as campaigns types (1.e., 1 entry in remote_sensing_events table)
+  dat_test <- data.frame(remote_sensing_indicators_name = c("NDSI", "NDSI"),
+                         cells_cell_code = c("105_101", "105_101"),
+                         remote_sensing_events_date_start = c("2020-07-22", "2020-07-22"),
+                         remote_sensing_obs_metric = c("max", "min"),
+                         remote_sensing_obs_value = c(0.5, 0.2))
+  testthat::expect_message(coleo_validate(dat_test), regexp = "*remote_sensing_events : 1*")
 
   ## Test that the imported data has all of the required columns
   dat_test <- subset(dat, select = -c(observations_date_obs))