From 3a44d7a8185299d7ec7115abdac1530f6a9d39c8 Mon Sep 17 00:00:00 2001 From: Stijn Van Hoey Date: Thu, 26 Apr 2018 16:08:01 +0200 Subject: [PATCH 001/183] Merge pull request #11 from inbo/loadings Provide blueprint for the package functionalities --- R/get_animals.R | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 R/get_animals.R diff --git a/R/get_animals.R b/R/get_animals.R new file mode 100644 index 0000000..aacdf3b --- /dev/null +++ b/R/get_animals.R @@ -0,0 +1,15 @@ + +get_animals <- function(connection, + netwerk_project = NULL, + animal_project = NULL, + species = NULL) { + NULL + + # mainquery <- " + # SELECT * from vliz.detections_view + # WHERE datetime >= ? and datetime <= ? + # " + # data <- data.frame(start_date, end_date) + # sqlExecute(connection, mainquery, data, fetch = TRUE) + +} From da1997ef191228db17ed08b029eb3659baff1a5f Mon Sep 17 00:00:00 2001 From: Stijn Van Hoey Date: Fri, 27 Apr 2018 10:40:08 +0200 Subject: [PATCH 002/183] Merge pull request #13 from inbo/setup-connection Setup connection --- R/get_animals.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/get_animals.R b/R/get_animals.R index aacdf3b..67d6d24 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -1,3 +1,4 @@ +# vliz.animals_view get_animals <- function(connection, netwerk_project = NULL, @@ -6,7 +7,7 @@ get_animals <- function(connection, NULL # mainquery <- " - # SELECT * from vliz.detections_view + # SELECT * from vliz.animals_view # or animals table? # WHERE datetime >= ? and datetime <= ? # " # data <- data.frame(start_date, end_date) From ffa247918a53d95d7a751f77a91549fe29b962d4 Mon Sep 17 00:00:00 2001 From: Damiano Oldoni Date: Fri, 27 Apr 2018 17:31:16 +0200 Subject: [PATCH 003/183] Merge pull request #22 from inbo/animals Animals --- R/get_animals.R | 96 +++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 85 insertions(+), 11 deletions(-) diff --git a/R/get_animals.R b/R/get_animals.R index 67d6d24..b90f023 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -1,16 +1,90 @@ -# vliz.animals_view - +#' Get animals data +#' +#' This function retrieves all or a subset of animals data. +#' +#' @param connection A valid connection to ETN database. +#' @param network_project (string) One or more network projects. +#' @param animal_project (string) One or more animal projects. +#' @param scientific_name (string) One or more scientific names. +#' +#' @return A data.frame. +#' @export +#' +#' @examples +#' \dontrun{ +#' # all animals +#' animals <- get_animals(con) +#' +#' # all animals of the Demer project with given scientific name +#' animals <- get_animals(con, network_project = "demer", +#' scientific_name = c("Rutilus rutilus", +#' "Squalius cephalus")) +#' } get_animals <- function(connection, - netwerk_project = NULL, + network_project = NULL, animal_project = NULL, - species = NULL) { - NULL + scientific_name = NULL) { + + check_connection(connection) + + # valid inputs on network projects + valid_network_projects <- get_projects(connection, + project_type = "network") %>% + pull(projectcode) + check_null_or_value(network_project, valid_network_projects, + "network_project") + + # valid inputs on animal projects + valid_animals_projects <- get_projects(connection, + project_type = "animal") %>% + pull(projectcode) + check_null_or_value(animal_project, valid_animals_projects, + "animal_project") + + # valid scientific names + valid_animals <- scientific_names(connection) + check_null_or_value(scientific_name, valid_animals, "scientific_name") + + if (is.null(network_project)) { + network_project = valid_network_projects + } + if (is.null(animal_project)) { + animal_project = valid_animals_projects + } + project_names <- unique(c(network_project, animal_project)) - # mainquery <- " - # SELECT * from vliz.animals_view # or animals table? - # WHERE datetime >= ? and datetime <= ? - # " - # data <- data.frame(start_date, end_date) - # sqlExecute(connection, mainquery, data, fetch = TRUE) + if (is.null(scientific_name)) { + scientific_name = valid_animals + } + animals_query <- glue_sql( + "SELECT * FROM vliz.animals_view + WHERE projectcode IN ({projects*}) + AND scientific_name IN ({animals*})", + projects = project_names, + animals = scientific_name, + .con = connection + ) + + animals <- dbGetQuery(connection, animals_query) + animals + +} + +#' Support function to get unique set of scientific names +#' +#' This function retrieves all unique scientific names +#' @param connection A valid connection to ETN database. +#' +#' @return A vector of all scientific names present in vliz.animals_view. +scientific_names <- function(connection) { + + query <- glue_sql( + "SELECT DISTINCT scientific_name FROM vliz.animals_view ", + .con = connection + ) + data <- dbGetQuery(connection, query) + data %>% + pull(scientific_name) } + From 625c366552ca68b88ea86a18da1467832e7c1bb3 Mon Sep 17 00:00:00 2001 From: Damiano Oldoni Date: Mon, 30 Apr 2018 16:42:58 +0200 Subject: [PATCH 004/183] Merge pull request #31 from inbo/documentation Documentation --- R/get_animals.R | 25 ++++++++++++++++++++----- 1 file changed, 20 insertions(+), 5 deletions(-) diff --git a/R/get_animals.R b/R/get_animals.R index b90f023..461322b 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -1,6 +1,7 @@ #' Get animals data #' -#' This function retrieves all or a subset of animals data. +#' Get all or a subset of animals data. Filter options are the network +#' project(s), the animal project(s) and/or the scientific name of the animals. #' #' @param connection A valid connection to ETN database. #' @param network_project (string) One or more network projects. @@ -8,13 +9,25 @@ #' @param scientific_name (string) One or more scientific names. #' #' @return A data.frame. +#' #' @export #' +#' @importFrom glue glue_sql +#' @importFrom DBI dbGetQuery +#' @importFrom dplyr pull %>% +#' #' @examples #' \dontrun{ #' # all animals #' animals <- get_animals(con) #' +#' # all animals of the Demer project +#' animals <- get_animals(con, network_project = "demer") +#' +#' # all animals of all projects with given scientific name +#' animals <- get_animals(con, scientific_name = c("Rutilus rutilus", +#' "Squalius cephalus")) +#' #' # all animals of the Demer project with given scientific name #' animals <- get_animals(con, network_project = "demer", #' scientific_name = c("Rutilus rutilus", @@ -30,14 +43,14 @@ get_animals <- function(connection, # valid inputs on network projects valid_network_projects <- get_projects(connection, project_type = "network") %>% - pull(projectcode) + pull("projectcode") check_null_or_value(network_project, valid_network_projects, "network_project") # valid inputs on animal projects valid_animals_projects <- get_projects(connection, project_type = "animal") %>% - pull(projectcode) + pull("projectcode") check_null_or_value(animal_project, valid_animals_projects, "animal_project") @@ -76,6 +89,9 @@ get_animals <- function(connection, #' This function retrieves all unique scientific names #' @param connection A valid connection to ETN database. #' +#' @importFrom glue glue_sql +#' @importFrom DBI dbGetQuery +#' #' @return A vector of all scientific names present in vliz.animals_view. scientific_names <- function(connection) { @@ -84,7 +100,6 @@ scientific_names <- function(connection) { .con = connection ) data <- dbGetQuery(connection, query) - data %>% - pull(scientific_name) + data$scientific_name } From ec62a56c2876012a61aec4259aa1e3c51acb6f3e Mon Sep 17 00:00:00 2001 From: Stijn Van Hoey Date: Mon, 30 Apr 2018 17:25:47 +0200 Subject: [PATCH 005/183] Merge pull request #32 from inbo/quick-fix-nse Quick fix nse --- R/get_animals.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/get_animals.R b/R/get_animals.R index 461322b..dd64e31 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -18,6 +18,8 @@ #' #' @examples #' \dontrun{ +#' con <- connect_to_etn(your_username, your_password) +#' #' # all animals #' animals <- get_animals(con) #' From c5c22c4f92af50c232d2c91558d953ecae568261 Mon Sep 17 00:00:00 2001 From: Stijn Van Hoey Date: Tue, 22 May 2018 14:41:59 +0200 Subject: [PATCH 006/183] Merge pull request #49 from inbo/unit_tests Unit tests for etn package functionalities --- R/get_animals.R | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/R/get_animals.R b/R/get_animals.R index dd64e31..d13b2d2 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -23,17 +23,26 @@ #' # all animals #' animals <- get_animals(con) #' -#' # all animals of the Demer project -#' animals <- get_animals(con, network_project = "demer") +#' # all animals of the 2012_leopoldkanaal project +#' animals <- get_animals(con, animal_project = "2012_leopoldkanaal") +#' +#' # all animals of the 2012_leopoldkanaal and phd_reubens +#' get_animals(con, animal_project = c("2012_leopoldkanaal", "phd_reubens")) +#' +#' #all animals of the thornton network project +#' get_animals(con, network_project = "thornton") +#' +#' #all animals of the thornton and leopold network project +#' get_animals(con, network_project = c("thornton", "leopold")) #' #' # all animals of all projects with given scientific name -#' animals <- get_animals(con, scientific_name = c("Rutilus rutilus", -#' "Squalius cephalus")) +#' animals <- get_animals(con, +#' scientific_name = c("Gadus morhua", +#' "Sentinel")) #' -#' # all animals of the Demer project with given scientific name -#' animals <- get_animals(con, network_project = "demer", -#' scientific_name = c("Rutilus rutilus", -#' "Squalius cephalus")) +#' # all animals of the phd_reubens project with given scientific name +#' animals <- get_animals(con, animal_project = "phd_reubens", +#' scientific_name = "Gadus morhua") #' } get_animals <- function(connection, network_project = NULL, From ff816eab4c759235d4636541fc9fe4364a5c2d63 Mon Sep 17 00:00:00 2001 From: Stijn Van Hoey Date: Thu, 20 Sep 2018 16:13:50 +0200 Subject: [PATCH 007/183] Merge pull request #39 from inbo/frame-to-tibble Frame to tibble --- R/get_animals.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/R/get_animals.R b/R/get_animals.R index d13b2d2..29de9d4 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -8,13 +8,14 @@ #' @param animal_project (string) One or more animal projects. #' @param scientific_name (string) One or more scientific names. #' -#' @return A data.frame. +#' @return A tibble (tidyverse data.frame). #' #' @export #' #' @importFrom glue glue_sql #' @importFrom DBI dbGetQuery #' @importFrom dplyr pull %>% +#' @importFrom tibble as_tibble #' #' @examples #' \dontrun{ @@ -91,7 +92,7 @@ get_animals <- function(connection, ) animals <- dbGetQuery(connection, animals_query) - animals + as_tibble(animals) } From 27dac0e47e943df20b82507f48ce0e34d24b476c Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Fri, 6 Dec 2019 17:54:55 +0100 Subject: [PATCH 008/183] Merge pull request #76 from inbo/no-ntwk_prjct-in-get_animals Remove network_project argument in get_animals function --- R/get_animals.R | 25 +++---------------------- 1 file changed, 3 insertions(+), 22 deletions(-) diff --git a/R/get_animals.R b/R/get_animals.R index 29de9d4..557b229 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -1,10 +1,9 @@ #' Get animals data #' -#' Get all or a subset of animals data. Filter options are the network -#' project(s), the animal project(s) and/or the scientific name of the animals. +#' Get all or a subset of animals data. Filter options are the animal project(s) +#' and/or the scientific name of the animals. #' #' @param connection A valid connection to ETN database. -#' @param network_project (string) One or more network projects. #' @param animal_project (string) One or more animal projects. #' @param scientific_name (string) One or more scientific names. #' @@ -30,12 +29,6 @@ #' # all animals of the 2012_leopoldkanaal and phd_reubens #' get_animals(con, animal_project = c("2012_leopoldkanaal", "phd_reubens")) #' -#' #all animals of the thornton network project -#' get_animals(con, network_project = "thornton") -#' -#' #all animals of the thornton and leopold network project -#' get_animals(con, network_project = c("thornton", "leopold")) -#' #' # all animals of all projects with given scientific name #' animals <- get_animals(con, #' scientific_name = c("Gadus morhua", @@ -46,19 +39,11 @@ #' scientific_name = "Gadus morhua") #' } get_animals <- function(connection, - network_project = NULL, animal_project = NULL, scientific_name = NULL) { check_connection(connection) - # valid inputs on network projects - valid_network_projects <- get_projects(connection, - project_type = "network") %>% - pull("projectcode") - check_null_or_value(network_project, valid_network_projects, - "network_project") - # valid inputs on animal projects valid_animals_projects <- get_projects(connection, project_type = "animal") %>% @@ -70,13 +55,9 @@ get_animals <- function(connection, valid_animals <- scientific_names(connection) check_null_or_value(scientific_name, valid_animals, "scientific_name") - if (is.null(network_project)) { - network_project = valid_network_projects - } if (is.null(animal_project)) { animal_project = valid_animals_projects } - project_names <- unique(c(network_project, animal_project)) if (is.null(scientific_name)) { scientific_name = valid_animals @@ -86,7 +67,7 @@ get_animals <- function(connection, "SELECT * FROM vliz.animals_view WHERE projectcode IN ({projects*}) AND scientific_name IN ({animals*})", - projects = project_names, + projects = animal_project, animals = scientific_name, .con = connection ) From 1c80a6fe1ba5bcc0ac19e851ff0c621fbe4d8c25 Mon Sep 17 00:00:00 2001 From: Damiano Oldoni Date: Mon, 17 Feb 2020 17:44:45 +0100 Subject: [PATCH 009/183] Merge pull request #84 from inbo/Remove-doc-helper-functions Remove doc helper functions --- R/get_animals.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/R/get_animals.R b/R/get_animals.R index 557b229..7f72817 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -82,6 +82,10 @@ get_animals <- function(connection, #' This function retrieves all unique scientific names #' @param connection A valid connection to ETN database. #' +#' @keywords internal +#' +#' @noRd +#' #' @importFrom glue glue_sql #' @importFrom DBI dbGetQuery #' From a1001f84065573ffbb18626d047713820916b646 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Fri, 21 Feb 2020 17:06:48 +0100 Subject: [PATCH 010/183] Merge pull request #93 from inbo/new_views Use new views --- R/get_animals.R | 108 +++++++++++++++++------------------------------- 1 file changed, 38 insertions(+), 70 deletions(-) diff --git a/R/get_animals.R b/R/get_animals.R index 7f72817..5c21201 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -1,10 +1,10 @@ -#' Get animals data +#' Get animal metadata #' -#' Get all or a subset of animals data. Filter options are the animal project(s) -#' and/or the scientific name of the animals. +#' Get metadata for animals, with options to filter on animal project and/or +#' scientific name. #' -#' @param connection A valid connection to ETN database. -#' @param animal_project (string) One or more animal projects. +#' @param connection A valid connection to the ETN database. +#' @param animal_project_code (string) One or more animal projects. #' @param scientific_name (string) One or more scientific names. #' #' @return A tibble (tidyverse data.frame). @@ -20,83 +20,51 @@ #' \dontrun{ #' con <- connect_to_etn(your_username, your_password) #' -#' # all animals -#' animals <- get_animals(con) +#' # Get all animals +#' get_animals(con) #' -#' # all animals of the 2012_leopoldkanaal project -#' animals <- get_animals(con, animal_project = "2012_leopoldkanaal") +#' # Get animals from specific animal project(s) +#' get_animals(con, animal_project_code = "2012_leopoldkanaal") +#' get_animals(con, animal_project_code = c("2012_leopoldkanaal", "phd_reubens")) #' -#' # all animals of the 2012_leopoldkanaal and phd_reubens -#' get_animals(con, animal_project = c("2012_leopoldkanaal", "phd_reubens")) +#' # Get animals of specific species (across all projects) +#' get_animals(con, scientific_name = c("Gadus morhua", "Sentinel")) #' -#' # all animals of all projects with given scientific name -#' animals <- get_animals(con, -#' scientific_name = c("Gadus morhua", -#' "Sentinel")) -#' -#' # all animals of the phd_reubens project with given scientific name -#' animals <- get_animals(con, animal_project = "phd_reubens", -#' scientific_name = "Gadus morhua") +#' # Get animals of a specific species from a specific project +#' get_animals(con, animal_project_code = "phd_reubens", scientific_name = "Gadus morhua") #' } get_animals <- function(connection, - animal_project = NULL, + animal_project_code = NULL, scientific_name = NULL) { - + # Check connection check_connection(connection) - # valid inputs on animal projects - valid_animals_projects <- get_projects(connection, - project_type = "animal") %>% - pull("projectcode") - check_null_or_value(animal_project, valid_animals_projects, - "animal_project") - - # valid scientific names - valid_animals <- scientific_names(connection) - check_null_or_value(scientific_name, valid_animals, "scientific_name") - - if (is.null(animal_project)) { - animal_project = valid_animals_projects + # Check animal_project_code + if (is.null(animal_project_code)) { + animal_project_code_query <- "True" + } else { + valid_animal_project_codes <- list_animal_project_codes(connection) + check_value(animal_project_code, valid_animal_project_codes, "animal_project_code") + animal_project_code_query <- glue_sql("animal_project_code IN ({animal_project_code*})", .con = connection) } + # Check scientific_name if (is.null(scientific_name)) { - scientific_name = valid_animals + scientific_name_query <- "True" + } else { + scientific_name_ids <- list_scientific_names(connection) + check_value(scientific_name, scientific_name_ids, "scientific_name") + scientific_name_query <- glue_sql("scientific_name IN ({scientific_name*})", .con = connection) } - animals_query <- glue_sql( - "SELECT * FROM vliz.animals_view - WHERE projectcode IN ({projects*}) - AND scientific_name IN ({animals*})", - projects = animal_project, - animals = scientific_name, - .con = connection - ) - - animals <- dbGetQuery(connection, animals_query) + # Build query + query <- glue_sql(" + SELECT * + FROM vliz.animals_view2 + WHERE + {animal_project_code_query} + AND {scientific_name_query} + ", .con = connection) + animals <- dbGetQuery(connection, query) as_tibble(animals) - } - -#' Support function to get unique set of scientific names -#' -#' This function retrieves all unique scientific names -#' @param connection A valid connection to ETN database. -#' -#' @keywords internal -#' -#' @noRd -#' -#' @importFrom glue glue_sql -#' @importFrom DBI dbGetQuery -#' -#' @return A vector of all scientific names present in vliz.animals_view. -scientific_names <- function(connection) { - - query <- glue_sql( - "SELECT DISTINCT scientific_name FROM vliz.animals_view ", - .con = connection - ) - data <- dbGetQuery(connection, query) - data$scientific_name -} - From 69ddffcaed21d3a3e7be49a6bb2f51bb8a40de69 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 26 Feb 2020 14:38:06 +0100 Subject: [PATCH 011/183] Merge pull request #101 from inbo/update_parameters Update parameters for get_tags and get_receivers --- R/get_animals.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/get_animals.R b/R/get_animals.R index 5c21201..10745a6 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -33,7 +33,7 @@ #' # Get animals of a specific species from a specific project #' get_animals(con, animal_project_code = "phd_reubens", scientific_name = "Gadus morhua") #' } -get_animals <- function(connection, +get_animals <- function(connection = con, animal_project_code = NULL, scientific_name = NULL) { # Check connection From 40250bd3d707c263401d323d53f327698382bb96 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 18 Mar 2020 12:43:12 +0100 Subject: [PATCH 012/183] Merge pull request #106 from inbo/solve-animal-tag-relationship Solve animal tag relationship --- R/get_animals.R | 22 ++++++++++++++++++---- 1 file changed, 18 insertions(+), 4 deletions(-) diff --git a/R/get_animals.R b/R/get_animals.R index 10745a6..0118fbc 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -1,7 +1,9 @@ #' Get animal metadata #' #' Get metadata for animals, with options to filter on animal project and/or -#' scientific name. +#' scientific name. Associated tag information is available in columns starting +#' with `tag`. If multiple tags are associated with a single animal, the +#' information is comma-separated. #' #' @param connection A valid connection to the ETN database. #' @param animal_project_code (string) One or more animal projects. @@ -13,8 +15,7 @@ #' #' @importFrom glue glue_sql #' @importFrom DBI dbGetQuery -#' @importFrom dplyr pull %>% -#' @importFrom tibble as_tibble +#' @importFrom dplyr pull %>% vars group_by_at summarize_at ungroup mutate_at select #' #' @examples #' \dontrun{ @@ -66,5 +67,18 @@ get_animals <- function(connection = con, AND {scientific_name_query} ", .con = connection) animals <- dbGetQuery(connection, query) - as_tibble(animals) + + # Collapse tag information, to obtain one row = one animal + tag_cols <- animals %>% select(starts_with("tag")) %>% names() + other_cols <- animals %>% select(-starts_with("tag")) %>% names() + + animals <- + animals %>% + group_by_at(other_cols) %>% + summarize_at(tag_cols, paste, collapse = ",") %>% # Collapse multiple tags by comma + ungroup() %>% + mutate_at(tag_cols, gsub, pattern = "NA", replacement = "") %>% # Use "" instead of "NA" + select(names(animals)) # Use the original column order + + animals } From c1c89b253773449aef78d622e9158a0890c56a49 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 25 Mar 2020 15:29:49 +0100 Subject: [PATCH 013/183] Merge pull request #116 from inbo/animal_id Implement animal_id parameter --- R/get_animals.R | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/R/get_animals.R b/R/get_animals.R index 0118fbc..82cbec3 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -6,6 +6,7 @@ #' information is comma-separated. #' #' @param connection A valid connection to the ETN database. +#' @param animal_id (integer) One or more animal ids. #' @param animal_project_code (string) One or more animal projects. #' @param scientific_name (string) One or more scientific names. #' @@ -24,6 +25,11 @@ #' # Get all animals #' get_animals(con) #' +#' # Get specific animals +#' get_animals(con, animal_id = 2824) +#' get_animals(con, animal_id = "2824") # String values work as well +#' get_animals(con, animal_id = c(2824, 2825, 2827)) +#' #' # Get animals from specific animal project(s) #' get_animals(con, animal_project_code = "2012_leopoldkanaal") #' get_animals(con, animal_project_code = c("2012_leopoldkanaal", "phd_reubens")) @@ -35,11 +41,22 @@ #' get_animals(con, animal_project_code = "phd_reubens", scientific_name = "Gadus morhua") #' } get_animals <- function(connection = con, + animal_id = NULL, animal_project_code = NULL, scientific_name = NULL) { # Check connection check_connection(connection) + # Check animal_id + if (is.null(animal_id)) { + animal_id_query <- "True" + } else { + valid_animal_ids <- list_animal_ids(connection) + check_value(animal_id, valid_animal_ids, "animal_id") + animal_id_query <- glue_sql("animal_id IN ({animal_id*})", .con = connection) + # animal_id_query seems to work correctly with integers or strings: 'animal_id IN (\'304\')' + } + # Check animal_project_code if (is.null(animal_project_code)) { animal_project_code_query <- "True" @@ -63,7 +80,8 @@ get_animals <- function(connection = con, SELECT * FROM vliz.animals_view2 WHERE - {animal_project_code_query} + {animal_id_query} + AND {animal_project_code_query} AND {scientific_name_query} ", .con = connection) animals <- dbGetQuery(connection, query) From d9abe95e7bd4032b5521550527afb7a0947d5bab Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 2 Sep 2020 10:42:20 +0200 Subject: [PATCH 014/183] Merge pull request #123 from inbo/order_by Order returned results --- R/get_animals.R | 23 +++++++++++++++++------ 1 file changed, 17 insertions(+), 6 deletions(-) diff --git a/R/get_animals.R b/R/get_animals.R index 82cbec3..ecdec49 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -10,13 +10,14 @@ #' @param animal_project_code (string) One or more animal projects. #' @param scientific_name (string) One or more scientific names. #' -#' @return A tibble (tidyverse data.frame). +#' @return A tibble (tidyverse data.frame) with metadata for animals, sorted by +#' `animal_project_code`, `release_date_time` and `tag_id`. #' #' @export #' #' @importFrom glue glue_sql #' @importFrom DBI dbGetQuery -#' @importFrom dplyr pull %>% vars group_by_at summarize_at ungroup mutate_at select +#' @importFrom dplyr %>% arrange as_tibble group_by_at mutate_at select summarize_at ungroup #' #' @examples #' \dontrun{ @@ -77,8 +78,10 @@ get_animals <- function(connection = con, # Build query query <- glue_sql(" - SELECT * - FROM vliz.animals_view2 + SELECT + * + FROM + vliz.animals_view2 WHERE {animal_id_query} AND {animal_project_code_query} @@ -89,7 +92,6 @@ get_animals <- function(connection = con, # Collapse tag information, to obtain one row = one animal tag_cols <- animals %>% select(starts_with("tag")) %>% names() other_cols <- animals %>% select(-starts_with("tag")) %>% names() - animals <- animals %>% group_by_at(other_cols) %>% @@ -98,5 +100,14 @@ get_animals <- function(connection = con, mutate_at(tag_cols, gsub, pattern = "NA", replacement = "") %>% # Use "" instead of "NA" select(names(animals)) # Use the original column order - animals + # Sort data + animals <- + animals %>% + arrange( + animal_project_code, + release_date_time, + factor(tag_id, levels = list_tag_ids(connection)) + ) + + as_tibble(animals) # Is already a tibble, but added if code above changes } From efe0846f08d8e8252e7afa64144e67597006884e Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Mon, 12 Oct 2020 15:11:32 +0200 Subject: [PATCH 015/183] Merge pull request #131 from inbo/receiver_status Move (receiver_)status from get_deployments() to get_receivers() --- R/get_animals.R | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/R/get_animals.R b/R/get_animals.R index ecdec49..a0593b1 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -1,9 +1,8 @@ #' Get animal metadata #' -#' Get metadata for animals, with options to filter on animal project and/or -#' scientific name. Associated tag information is available in columns starting -#' with `tag`. If multiple tags are associated with a single animal, the -#' information is comma-separated. +#' Get metadata for animals, with options to filter results. Associated tag +#' information is available in columns starting with `tag`. If multiple tags +#' are associated with a single animal, the information is comma-separated. #' #' @param connection A valid connection to the ETN database. #' @param animal_id (integer) One or more animal ids. @@ -90,8 +89,12 @@ get_animals <- function(connection = con, animals <- dbGetQuery(connection, query) # Collapse tag information, to obtain one row = one animal - tag_cols <- animals %>% select(starts_with("tag")) %>% names() - other_cols <- animals %>% select(-starts_with("tag")) %>% names() + tag_cols <- animals %>% + select(starts_with("tag")) %>% + names() + other_cols <- animals %>% + select(-starts_with("tag")) %>% + names() animals <- animals %>% group_by_at(other_cols) %>% From 999e2401e92014ebfa97ef31138e2487b520dad8 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Thu, 15 Oct 2020 12:03:25 +0200 Subject: [PATCH 016/183] Merge pull request #132 from inbo/download_dataset Create function to download dataset --- R/get_animals.R | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/R/get_animals.R b/R/get_animals.R index a0593b1..1ed5e5f 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -1,16 +1,17 @@ -#' Get animal metadata +#' Get animal data #' -#' Get metadata for animals, with options to filter results. Associated tag -#' information is available in columns starting with `tag`. If multiple tags +#' Get data for animals, with options to filter results. Associated tag +#' information is available in columns starting with `tag`. If multiple tags #' are associated with a single animal, the information is comma-separated. #' -#' @param connection A valid connection to the ETN database. -#' @param animal_id (integer) One or more animal ids. -#' @param animal_project_code (string) One or more animal projects. -#' @param scientific_name (string) One or more scientific names. +#' @param connection A connection to the ETN database. Defaults to `con`. +#' @param animal_id Integer (vector). One or more animal ids. +#' @param animal_project_code Character (vector). One or more animal projects. +#' @param scientific_name Character (vector). One or more scientific names. #' -#' @return A tibble (tidyverse data.frame) with metadata for animals, sorted by -#' `animal_project_code`, `release_date_time` and `tag_id`. +#' @return A tibble with animals data, sorted by `animal_project_code`, +#' `release_date_time` and `tag_id`. See also +#' [field definitions](https://inbo.github.io/etn/articles/etn_fields.html). #' #' @export #' @@ -89,10 +90,12 @@ get_animals <- function(connection = con, animals <- dbGetQuery(connection, query) # Collapse tag information, to obtain one row = one animal - tag_cols <- animals %>% + tag_cols <- + animals %>% select(starts_with("tag")) %>% names() - other_cols <- animals %>% + other_cols <- + animals %>% select(-starts_with("tag")) %>% names() animals <- From 52a97f9e23373391583ca1eebe376818c34e04fd Mon Sep 17 00:00:00 2001 From: Damiano Oldoni Date: Mon, 23 Nov 2020 20:24:21 +0100 Subject: [PATCH 017/183] Merge pull request #142 from inbo/add-test-download_dataset Add test download dataset --- R/get_animals.R | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/R/get_animals.R b/R/get_animals.R index 1ed5e5f..702752f 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -17,7 +17,8 @@ #' #' @importFrom glue glue_sql #' @importFrom DBI dbGetQuery -#' @importFrom dplyr %>% arrange as_tibble group_by_at mutate_at select summarize_at ungroup +#' @importFrom dplyr %>% arrange as_tibble group_by_at mutate_at select +#' starts_with summarize_at ungroup #' #' @examples #' \dontrun{ @@ -110,9 +111,9 @@ get_animals <- function(connection = con, animals <- animals %>% arrange( - animal_project_code, - release_date_time, - factor(tag_id, levels = list_tag_ids(connection)) + .data$animal_project_code, + .data$release_date_time, + factor(.data$tag_id, levels = list_tag_ids(connection)) ) as_tibble(animals) # Is already a tibble, but added if code above changes From c785509a0a6666a5aaeecb443c2461f797756bc9 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Mon, 4 Jan 2021 17:01:27 +0100 Subject: [PATCH 018/183] Merge pull request #144 from inbo/issue_140 Allow case-insensitive animal_project_code, network_project_code, station_name --- R/get_animals.R | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/R/get_animals.R b/R/get_animals.R index 702752f..ab04520 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -1,12 +1,13 @@ #' Get animal data #' -#' Get data for animals, with options to filter results. Associated tag -#' information is available in columns starting with `tag`. If multiple tags +#' Get data for animals, with options to filter results. Associated tag +#' information is available in columns starting with `tag`. If multiple tags #' are associated with a single animal, the information is comma-separated. #' #' @param connection A connection to the ETN database. Defaults to `con`. #' @param animal_id Integer (vector). One or more animal ids. #' @param animal_project_code Character (vector). One or more animal projects. +#' Case-insensitive. #' @param scientific_name Character (vector). One or more scientific names. #' #' @return A tibble with animals data, sorted by `animal_project_code`, @@ -34,13 +35,13 @@ #' #' # Get animals from specific animal project(s) #' get_animals(con, animal_project_code = "2012_leopoldkanaal") -#' get_animals(con, animal_project_code = c("2012_leopoldkanaal", "phd_reubens")) +#' get_animals(con, animal_project_code = c("2012_leopoldkanaal", "2010_phd_reubens")) #' #' # Get animals of specific species (across all projects) -#' get_animals(con, scientific_name = c("Gadus morhua", "Sentinel")) +#' get_animals(con, scientific_name = c("Gadus morhua", "Sync tag")) #' #' # Get animals of a specific species from a specific project -#' get_animals(con, animal_project_code = "phd_reubens", scientific_name = "Gadus morhua") +#' get_animals(con, animal_project_code = "2010_phd_reubens", scientific_name = "Gadus morhua") #' } get_animals <- function(connection = con, animal_id = NULL, @@ -63,9 +64,13 @@ get_animals <- function(connection = con, if (is.null(animal_project_code)) { animal_project_code_query <- "True" } else { - valid_animal_project_codes <- list_animal_project_codes(connection) + animal_project_code <- tolower(animal_project_code) + valid_animal_project_codes <- tolower(list_animal_project_codes(connection)) check_value(animal_project_code, valid_animal_project_codes, "animal_project_code") - animal_project_code_query <- glue_sql("animal_project_code IN ({animal_project_code*})", .con = connection) + animal_project_code_query <- glue_sql( + "LOWER(animal_project_code) IN ({animal_project_code*})", + .con = connection + ) } # Check scientific_name From 5967617845cbc4331661072d3cc13c40a2638f47 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Mon, 17 May 2021 15:49:06 +0200 Subject: [PATCH 019/183] Merge pull request #154 from inbo/old_db Restore functionality with old database --- R/get_animals.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/get_animals.R b/R/get_animals.R index ab04520..ea96b2e 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -87,7 +87,7 @@ get_animals <- function(connection = con, SELECT * FROM - vliz.animals_view2 + acoustic.animals_view2 WHERE {animal_id_query} AND {animal_project_code_query} From bffe996cb213cfcc8afb4c4a37fb708cac5edde8 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Tue, 5 Oct 2021 14:55:12 +0200 Subject: [PATCH 020/183] Merge pull request #191 from inbo/sql_views New functions (part 1) --- R/get_animals.R | 143 +++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 123 insertions(+), 20 deletions(-) diff --git a/R/get_animals.R b/R/get_animals.R index ea96b2e..31b79e3 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -5,48 +5,59 @@ #' are associated with a single animal, the information is comma-separated. #' #' @param connection A connection to the ETN database. Defaults to `con`. -#' @param animal_id Integer (vector). One or more animal ids. +#' @param animal_id Integer (vector). One or more animal identifiers. #' @param animal_project_code Character (vector). One or more animal projects. #' Case-insensitive. +#' @param tag_serial_number Character (vector). One or more tag serial numbers. #' @param scientific_name Character (vector). One or more scientific names. +#' @param exclude_non_animals Logical. Exclude records with non-animal +#' scientific names such as "Built-in" or "Sync tag". Defaults to `FALSE`. #' #' @return A tibble with animals data, sorted by `animal_project_code`, -#' `release_date_time` and `tag_id`. See also +#' `release_date_time` and `tag_serial_number`. See also #' [field definitions](https://inbo.github.io/etn/articles/etn_fields.html). #' #' @export #' #' @importFrom glue glue_sql #' @importFrom DBI dbGetQuery -#' @importFrom dplyr %>% arrange as_tibble group_by_at mutate_at select +#' @importFrom dplyr %>% arrange as_tibble filter group_by_at mutate_at select #' starts_with summarize_at ungroup #' #' @examples #' \dontrun{ -#' con <- connect_to_etn(your_username, your_password) +#' # Set default connection variable +#' con <- connect_to_etn() #' #' # Get all animals -#' get_animals(con) +#' get_animals() #' #' # Get specific animals -#' get_animals(con, animal_id = 2824) -#' get_animals(con, animal_id = "2824") # String values work as well -#' get_animals(con, animal_id = c(2824, 2825, 2827)) +#' get_animals(animal_id = 305) # Or string value "305" +#' get_animals(animal_id = c(304, 305, 2827)) #' #' # Get animals from specific animal project(s) -#' get_animals(con, animal_project_code = "2012_leopoldkanaal") -#' get_animals(con, animal_project_code = c("2012_leopoldkanaal", "2010_phd_reubens")) +#' get_animals(animal_project_code = "2014_demer") +#' get_animals(animal_project_code = c("2014_demer", "2015_dijle")) +#' +#' # Get animals associated with a specific tag_serial_number +#' get_animals(tag_serial_number = "1187450") #' #' # Get animals of specific species (across all projects) -#' get_animals(con, scientific_name = c("Gadus morhua", "Sync tag")) +#' get_animals(scientific_name = c("Rutilus rutilus", "Silurus glanis")) #' #' # Get animals of a specific species from a specific project -#' get_animals(con, animal_project_code = "2010_phd_reubens", scientific_name = "Gadus morhua") +#' get_animals(animal_project_code = "2014_demer", scientific_name = "Rutilus rutilus") +#' +#' # Exclude non-animals (e.g. Sync tag) +#' get_animals(exclude_non_animals = TRUE) #' } get_animals <- function(connection = con, animal_id = NULL, + tag_serial_number = NULL, animal_project_code = NULL, - scientific_name = NULL) { + scientific_name = NULL, + exclude_non_animals = FALSE) { # Check connection check_connection(connection) @@ -56,7 +67,7 @@ get_animals <- function(connection = con, } else { valid_animal_ids <- list_animal_ids(connection) check_value(animal_id, valid_animal_ids, "animal_id") - animal_id_query <- glue_sql("animal_id IN ({animal_id*})", .con = connection) + animal_id_query <- glue_sql("animal.id_pk IN ({animal_id*})", .con = connection) # animal_id_query seems to work correctly with integers or strings: 'animal_id IN (\'304\')' } @@ -68,33 +79,125 @@ get_animals <- function(connection = con, valid_animal_project_codes <- tolower(list_animal_project_codes(connection)) check_value(animal_project_code, valid_animal_project_codes, "animal_project_code") animal_project_code_query <- glue_sql( - "LOWER(animal_project_code) IN ({animal_project_code*})", + "LOWER(animal_project.projectcode) IN ({animal_project_code*})", .con = connection ) } + # Check tag_serial_number + if (is.null(tag_serial_number)) { + tag_serial_number_query <- "True" + } else { + valid_tag_serial_numbers <- list_tag_serial_numbers(connection) + tag_serial_number <- as.character(tag_serial_number) # Cast to character + check_value(tag_serial_number, valid_tag_serial_numbers, "tag_serial_number") + tag_serial_number_query <- glue_sql("tag.serial_number IN ({tag_serial_number*})", .con = connection) + } + # Check scientific_name if (is.null(scientific_name)) { scientific_name_query <- "True" } else { scientific_name_ids <- list_scientific_names(connection) check_value(scientific_name, scientific_name_ids, "scientific_name") - scientific_name_query <- glue_sql("scientific_name IN ({scientific_name*})", .con = connection) + scientific_name_query <- glue_sql("animal.scientific_name IN ({scientific_name*})", .con = connection) } # Build query query <- glue_sql(" SELECT - * - FROM - acoustic.animals_view2 + animal.id_pk AS animal_id, + animal_project.projectcode AS animal_project_code, + tag.serial_number AS tag_serial_number, + CASE + WHEN tag_type.name = 'id-tag' THEN 'acoustic' + WHEN tag_type.name = 'sensor-tag' THEN 'archival' + END AS tag_type, + tag_subtype.name AS tag_subtype, + animal.scientific_name AS scientific_name, + animal.common_name AS common_name, + animal.aphia_id AS aphia_id, + animal.animal_id AS animal_label, + animal.animal_nickname AS animal_nickname, + animal.tagger AS tagger, + animal.catched_date_time AS capture_date_time, + animal.capture_location AS capture_location, + animal.capture_latitude AS capture_latitude, + animal.capture_longitude AS capture_longitude, + animal.capture_method AS capture_method, + animal.capture_depth AS capture_depth, + animal.temperature_change AS capture_temperature_change, + animal.utc_release_date_time AS release_date_time, + animal.release_location AS release_location, + animal.release_latitude AS release_latitude, + animal.release_longitude AS release_longitude, + animal.recapture_date AS recapture_date_time, + animal.length_type AS length1_type, + animal.length AS length1, + animal.length_units AS length1_unit, + animal.length2_type AS length2_type, + animal.length2 AS length2, + animal.length2_units AS length2_unit, + animal.length3_type AS length3_type, + animal.length3 AS length3, + animal.length3_units AS length3_unit, + animal.length4_type AS length4_type, + animal.length4 AS length4, + animal.length4_units AS length4_unit, + animal.weight AS weight, + animal.weight_units AS weight_unit, + animal.age AS age, + animal.age_units AS age_unit, + animal.sex AS sex, + animal.life_stage AS life_stage, + animal.wild_or_hatchery AS wild_or_hatchery, + animal.stock AS stock, + animal.date_of_surgery AS surgery_date_time, + animal.surgery_Location AS surgery_location, + animal.surgery_latitude AS surgery_latitude, + animal.surgery_longitude AS surgery_longitude, + animal.treatment_type AS treatment_type, + animal.implant_type AS tagging_type, + animal.implant_method AS tagging_methodology, + animal.dna_sample_taken AS dna_sample, + animal.sedative AS sedative, + animal.sedative_concentration AS sedative_concentration, + animal.anaesthetic AS anaesthetic, + animal.buffer AS buffer, + animal.anaesthetic_concentration AS anaesthetic_concentration, + animal.buffer_concentration_in_anaesthetic AS buffer_concentration_in_anaesthetic, + animal.anesthetic_concentration_In_recirculation AS anaesthetic_concentration_in_recirculation, + animal.buffer_concentration_in_recirculation AS buffer_concentration_in_recirculation, + animal.dissolved_oxygen AS dissolved_oxygen, + animal.preop_holding_period AS pre_surgery_holding_period, + animal.post_op_holding_period AS post_surgery_holding_period, + animal.holding_temperature AS holding_temperature, + animal.comments AS comments + FROM common.animal_release AS animal + LEFT JOIN common.animal_release_tag_device AS animal_with_tag + ON animal.id_pk = animal_with_tag.animal_release_fk + LEFT JOIN common.tag_device AS tag + ON animal_with_tag.tag_device_fk = tag.id_pk + LEFT JOIN common.tag_device_type AS tag_type + ON tag.tag_device_type_fk = tag_type.id_pk + LEFT JOIN acoustic.acoustic_tag_subtype AS tag_subtype + ON tag.acoustic_tag_subtype_fk = tag_subtype.id_pk + LEFT JOIN common.projects AS animal_project + ON animal.project_fk = animal_project.id WHERE {animal_id_query} AND {animal_project_code_query} + AND {tag_serial_number_query} AND {scientific_name_query} ", .con = connection) animals <- dbGetQuery(connection, query) + # Exclude non animals (not the default) + non_animals <- c("Built-in", "Plastic", "Range tag", "Sync tag") + if (exclude_non_animals) { + animals <- animals %>% filter(!.data$scientific_name %in% non_animals) + } + # Collapse tag information, to obtain one row = one animal tag_cols <- animals %>% @@ -118,7 +221,7 @@ get_animals <- function(connection = con, arrange( .data$animal_project_code, .data$release_date_time, - factor(.data$tag_id, levels = list_tag_ids(connection)) + factor(.data$tag_serial_number, levels = list_tag_serial_numbers(connection)) ) as_tibble(animals) # Is already a tibble, but added if code above changes From 76c765e3dd455ab3b17c39a0211e5393dda13506 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 6 Oct 2021 15:38:54 +0200 Subject: [PATCH 021/183] Merge pull request #196 from inbo/get_tags Create single get_tags() function --- R/get_animals.R | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/R/get_animals.R b/R/get_animals.R index 31b79e3..5190c04 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -113,7 +113,12 @@ get_animals <- function(connection = con, WHEN tag_type.name = 'id-tag' THEN 'acoustic' WHEN tag_type.name = 'sensor-tag' THEN 'archival' END AS tag_type, - tag_subtype.name AS tag_subtype, + CASE + WHEN tag_subtype.name = 'animal' THEN 'animal' + WHEN tag_subtype.name = 'built-in tag' THEN 'built-in' + WHEN tag_subtype.name = 'range tag' THEN 'range' + WHEN tag_subtype.name = 'sentinel tag' THEN 'sentinel' + END AS tag_subtype, animal.scientific_name AS scientific_name, animal.common_name AS common_name, animal.aphia_id AS aphia_id, From 0e51aa8278673614a30493a7ecf69ae0be8533a6 Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Wed, 6 Oct 2021 16:28:56 +0200 Subject: [PATCH 022/183] Remove exclude_non_animals for get_animals() This parameter was based on scientific name, but this field has issues #197 and is uncontrolled. It is better to let the user tackle this after data is returned --- R/get_animals.R | 14 +------------- 1 file changed, 1 insertion(+), 13 deletions(-) diff --git a/R/get_animals.R b/R/get_animals.R index 5190c04..1939d73 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -10,8 +10,6 @@ #' Case-insensitive. #' @param tag_serial_number Character (vector). One or more tag serial numbers. #' @param scientific_name Character (vector). One or more scientific names. -#' @param exclude_non_animals Logical. Exclude records with non-animal -#' scientific names such as "Built-in" or "Sync tag". Defaults to `FALSE`. #' #' @return A tibble with animals data, sorted by `animal_project_code`, #' `release_date_time` and `tag_serial_number`. See also @@ -48,16 +46,12 @@ #' #' # Get animals of a specific species from a specific project #' get_animals(animal_project_code = "2014_demer", scientific_name = "Rutilus rutilus") -#' -#' # Exclude non-animals (e.g. Sync tag) -#' get_animals(exclude_non_animals = TRUE) #' } get_animals <- function(connection = con, animal_id = NULL, tag_serial_number = NULL, animal_project_code = NULL, - scientific_name = NULL, - exclude_non_animals = FALSE) { + scientific_name = NULL) { # Check connection check_connection(connection) @@ -197,12 +191,6 @@ get_animals <- function(connection = con, ", .con = connection) animals <- dbGetQuery(connection, query) - # Exclude non animals (not the default) - non_animals <- c("Built-in", "Plastic", "Range tag", "Sync tag") - if (exclude_non_animals) { - animals <- animals %>% filter(!.data$scientific_name %in% non_animals) - } - # Collapse tag information, to obtain one row = one animal tag_cols <- animals %>% From 4d36c1954fa641f3fb2011aa1613332d302ba91f Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 6 Oct 2021 22:46:43 +0200 Subject: [PATCH 023/183] Merge pull request #200 from inbo/combined_tag Create a combined tag view (tag.sql) that is used in multiple functions --- R/get_animals.R | 27 +++++++++------------------ 1 file changed, 9 insertions(+), 18 deletions(-) diff --git a/R/get_animals.R b/R/get_animals.R index 1939d73..80257a9 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -21,6 +21,7 @@ #' @importFrom DBI dbGetQuery #' @importFrom dplyr %>% arrange as_tibble filter group_by_at mutate_at select #' starts_with summarize_at ungroup +#' @importFrom readr read_file #' #' @examples #' \dontrun{ @@ -85,7 +86,7 @@ get_animals <- function(connection = con, valid_tag_serial_numbers <- list_tag_serial_numbers(connection) tag_serial_number <- as.character(tag_serial_number) # Cast to character check_value(tag_serial_number, valid_tag_serial_numbers, "tag_serial_number") - tag_serial_number_query <- glue_sql("tag.serial_number IN ({tag_serial_number*})", .con = connection) + tag_serial_number_query <- glue_sql("tag.tag_serial_number IN ({tag_serial_number*})", .con = connection) } # Check scientific_name @@ -97,22 +98,16 @@ get_animals <- function(connection = con, scientific_name_query <- glue_sql("animal.scientific_name IN ({scientific_name*})", .con = connection) } + tag_query <- glue_sql(read_file(system.file("sql", "tag.sql", package = "etn")), .con = connection) + # Build query query <- glue_sql(" SELECT animal.id_pk AS animal_id, animal_project.projectcode AS animal_project_code, - tag.serial_number AS tag_serial_number, - CASE - WHEN tag_type.name = 'id-tag' THEN 'acoustic' - WHEN tag_type.name = 'sensor-tag' THEN 'archival' - END AS tag_type, - CASE - WHEN tag_subtype.name = 'animal' THEN 'animal' - WHEN tag_subtype.name = 'built-in tag' THEN 'built-in' - WHEN tag_subtype.name = 'range tag' THEN 'range' - WHEN tag_subtype.name = 'sentinel tag' THEN 'sentinel' - END AS tag_subtype, + tag.tag_serial_number AS tag_serial_number, + tag.tag_type AS tag_type, + tag.tag_subtype AS tag_subtype, animal.scientific_name AS scientific_name, animal.common_name AS common_name, animal.aphia_id AS aphia_id, @@ -175,12 +170,8 @@ get_animals <- function(connection = con, FROM common.animal_release AS animal LEFT JOIN common.animal_release_tag_device AS animal_with_tag ON animal.id_pk = animal_with_tag.animal_release_fk - LEFT JOIN common.tag_device AS tag - ON animal_with_tag.tag_device_fk = tag.id_pk - LEFT JOIN common.tag_device_type AS tag_type - ON tag.tag_device_type_fk = tag_type.id_pk - LEFT JOIN acoustic.acoustic_tag_subtype AS tag_subtype - ON tag.acoustic_tag_subtype_fk = tag_subtype.id_pk + LEFT JOIN ({tag_query}) AS tag + ON animal_with_tag.tag_device_fk = tag.tag_device_fk LEFT JOIN common.projects AS animal_project ON animal.project_fk = animal_project.id WHERE From b2a2839c13a6cb0275546813989174c0841e92b3 Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Wed, 6 Oct 2021 23:05:39 +0200 Subject: [PATCH 024/183] Include (collapsed) acoustic_tag_id in get_animals() --- R/get_animals.R | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/R/get_animals.R b/R/get_animals.R index 80257a9..79e39df 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -1,8 +1,9 @@ #' Get animal data #' #' Get data for animals, with options to filter results. Associated tag -#' information is available in columns starting with `tag`. If multiple tags -#' are associated with a single animal, the information is comma-separated. +#' information is available in columns starting with `tag` and +#' `acoustic_tag_id`. If multiple tags are associated with a single animal, +#' the information is comma-separated. #' #' @param connection A connection to the ETN database. Defaults to `con`. #' @param animal_id Integer (vector). One or more animal identifiers. @@ -108,6 +109,7 @@ get_animals <- function(connection = con, tag.tag_serial_number AS tag_serial_number, tag.tag_type AS tag_type, tag.tag_subtype AS tag_subtype, + tag.acoustic_tag_id AS acoustic_tag_id, animal.scientific_name AS scientific_name, animal.common_name AS common_name, animal.aphia_id AS aphia_id, @@ -185,11 +187,11 @@ get_animals <- function(connection = con, # Collapse tag information, to obtain one row = one animal tag_cols <- animals %>% - select(starts_with("tag")) %>% + select(starts_with("tag"), acoustic_tag_id) %>% names() other_cols <- animals %>% - select(-starts_with("tag")) %>% + select(-starts_with("tag"), -acoustic_tag_id) %>% names() animals <- animals %>% From 044049a3a80bc4144113d2f4ea691fc33e2a9b83 Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Fri, 8 Oct 2021 09:27:51 +0200 Subject: [PATCH 025/183] Include get_acoustic_deployments in namespace --- R/get_animals.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/get_animals.R b/R/get_animals.R index 79e39df..77b551c 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -94,8 +94,8 @@ get_animals <- function(connection = con, if (is.null(scientific_name)) { scientific_name_query <- "True" } else { - scientific_name_ids <- list_scientific_names(connection) - check_value(scientific_name, scientific_name_ids, "scientific_name") + valid_scientific_name_ids <- list_scientific_names(connection) + check_value(scientific_name, valid_scientific_name_ids, "scientific_name") scientific_name_query <- glue_sql("animal.scientific_name IN ({scientific_name*})", .con = connection) } From 8b4eaa7c7b9a1aefd8d7c12a184b67a0a695ccb6 Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Fri, 8 Oct 2021 10:21:31 +0200 Subject: [PATCH 026/183] Include acoustic_tag_id_alternative in get_animals() Fix ##162 --- R/get_animals.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/R/get_animals.R b/R/get_animals.R index 77b551c..058b0f0 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -110,6 +110,7 @@ get_animals <- function(connection = con, tag.tag_type AS tag_type, tag.tag_subtype AS tag_subtype, tag.acoustic_tag_id AS acoustic_tag_id, + tag.thelma_converted_code AS acoustic_tag_id_alternative, animal.scientific_name AS scientific_name, animal.common_name AS common_name, animal.aphia_id AS aphia_id, @@ -187,11 +188,11 @@ get_animals <- function(connection = con, # Collapse tag information, to obtain one row = one animal tag_cols <- animals %>% - select(starts_with("tag"), acoustic_tag_id) %>% + select(starts_with("tag"), starts_with("acoustic_tag_id")) %>% names() other_cols <- animals %>% - select(-starts_with("tag"), -acoustic_tag_id) %>% + select(-starts_with("tag"), -starts_with("acoustic_tag_id")) %>% names() animals <- animals %>% From 76196cfc22e530ff7095ed2fd9f2ef2b650499bc Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Fri, 8 Oct 2021 12:50:39 +0200 Subject: [PATCH 027/183] Consistently use .data and import it from dplyr --- R/get_animals.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/get_animals.R b/R/get_animals.R index 058b0f0..91b8e3c 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -20,7 +20,7 @@ #' #' @importFrom glue glue_sql #' @importFrom DBI dbGetQuery -#' @importFrom dplyr %>% arrange as_tibble filter group_by_at mutate_at select +#' @importFrom dplyr .data %>% arrange as_tibble group_by_at mutate_at select #' starts_with summarize_at ungroup #' @importFrom readr read_file #' From 629f334cedf75f25a511653ab1bd3cf32bfdda6d Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Fri, 8 Oct 2021 22:21:01 +0200 Subject: [PATCH 028/183] Merge pull request #214 from inbo/get_projects Split get_projects() in 3 functions --- R/get_animals.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/get_animals.R b/R/get_animals.R index 91b8e3c..1a46144 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -7,8 +7,8 @@ #' #' @param connection A connection to the ETN database. Defaults to `con`. #' @param animal_id Integer (vector). One or more animal identifiers. -#' @param animal_project_code Character (vector). One or more animal projects. -#' Case-insensitive. +#' @param animal_project_code Character (vector). One or more animal project +#' codes. Case-insensitive. #' @param tag_serial_number Character (vector). One or more tag serial numbers. #' @param scientific_name Character (vector). One or more scientific names. #' From 0a785961f278c3db5189aa0fb386d8074fa7ec74 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Mon, 11 Oct 2021 19:10:02 +0200 Subject: [PATCH 029/183] Merge pull request #217 from inbo/use_views Use 3 of the 4 moratorium views --- R/get_animals.R | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/R/get_animals.R b/R/get_animals.R index 1a46144..4c9d4e4 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -99,7 +99,7 @@ get_animals <- function(connection = con, scientific_name_query <- glue_sql("animal.scientific_name IN ({scientific_name*})", .con = connection) } - tag_query <- glue_sql(read_file(system.file("sql", "tag.sql", package = "etn")), .con = connection) + tag_sql <- glue_sql(read_file(system.file("sql", "tag.sql", package = "etn")), .con = connection) # Build query query <- glue_sql(" @@ -150,7 +150,7 @@ get_animals <- function(connection = con, animal.wild_or_hatchery AS wild_or_hatchery, animal.stock AS stock, animal.date_of_surgery AS surgery_date_time, - animal.surgery_Location AS surgery_location, + animal.surgery_location AS surgery_location, animal.surgery_latitude AS surgery_latitude, animal.surgery_longitude AS surgery_longitude, animal.treatment_type AS treatment_type, @@ -163,17 +163,25 @@ get_animals <- function(connection = con, animal.buffer AS buffer, animal.anaesthetic_concentration AS anaesthetic_concentration, animal.buffer_concentration_in_anaesthetic AS buffer_concentration_in_anaesthetic, - animal.anesthetic_concentration_In_recirculation AS anaesthetic_concentration_in_recirculation, + animal.anesthetic_concentration_in_recirculation AS anaesthetic_concentration_in_recirculation, animal.buffer_concentration_in_recirculation AS buffer_concentration_in_recirculation, animal.dissolved_oxygen AS dissolved_oxygen, animal.preop_holding_period AS pre_surgery_holding_period, animal.post_op_holding_period AS post_surgery_holding_period, animal.holding_temperature AS holding_temperature, animal.comments AS comments - FROM common.animal_release AS animal + -- animal.project: animal.project_fk instead + -- animal.person_id + -- animal.est_tag_life + -- animal.date_modified + -- animal.date_created + -- animal.end_date_tag + -- animal.post_op_holding_period_new + -- animal.external_id + FROM common.animal_release_limited AS animal LEFT JOIN common.animal_release_tag_device AS animal_with_tag ON animal.id_pk = animal_with_tag.animal_release_fk - LEFT JOIN ({tag_query}) AS tag + LEFT JOIN ({tag_sql}) AS tag ON animal_with_tag.tag_device_fk = tag.tag_device_fk LEFT JOIN common.projects AS animal_project ON animal.project_fk = animal_project.id From 178a01e008caf7968b9cac660443333ca478dba4 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Tue, 12 Oct 2021 16:02:31 +0200 Subject: [PATCH 030/183] Merge pull request #221 from inbo/download_acoustic_dataset Add download_acoustic_dataset() --- R/get_animals.R | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/R/get_animals.R b/R/get_animals.R index 4c9d4e4..587ccf0 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -63,7 +63,10 @@ get_animals <- function(connection = con, } else { valid_animal_ids <- list_animal_ids(connection) check_value(animal_id, valid_animal_ids, "animal_id") - animal_id_query <- glue_sql("animal.id_pk IN ({animal_id*})", .con = connection) + animal_id_query <- glue_sql( + "animal.id_pk IN ({animal_id*})", + .con = connection + ) # animal_id_query seems to work correctly with integers or strings: 'animal_id IN (\'304\')' } @@ -87,16 +90,22 @@ get_animals <- function(connection = con, valid_tag_serial_numbers <- list_tag_serial_numbers(connection) tag_serial_number <- as.character(tag_serial_number) # Cast to character check_value(tag_serial_number, valid_tag_serial_numbers, "tag_serial_number") - tag_serial_number_query <- glue_sql("tag.tag_serial_number IN ({tag_serial_number*})", .con = connection) + tag_serial_number_query <- glue_sql( + "tag.tag_serial_number IN ({tag_serial_number*})", + .con = connection + ) } # Check scientific_name if (is.null(scientific_name)) { scientific_name_query <- "True" } else { - valid_scientific_name_ids <- list_scientific_names(connection) - check_value(scientific_name, valid_scientific_name_ids, "scientific_name") - scientific_name_query <- glue_sql("animal.scientific_name IN ({scientific_name*})", .con = connection) + valid_scientific_names <- list_scientific_names(connection) + check_value(scientific_name, valid_scientific_names, "scientific_name") + scientific_name_query <- glue_sql( + "animal.scientific_name IN ({scientific_name*})", + .con = connection + ) } tag_sql <- glue_sql(read_file(system.file("sql", "tag.sql", package = "etn")), .con = connection) From aec2a4a95a446ce037a37170ca8f4b7214179ae0 Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Wed, 13 Oct 2021 11:20:47 +0200 Subject: [PATCH 031/183] Run examples for website #227 --- R/get_animals.R | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) diff --git a/R/get_animals.R b/R/get_animals.R index 587ccf0..c1524ed 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -25,30 +25,28 @@ #' @importFrom readr read_file #' #' @examples -#' \dontrun{ #' # Set default connection variable #' con <- connect_to_etn() #' #' # Get all animals -#' get_animals() +#' get_animals(con) #' #' # Get specific animals -#' get_animals(animal_id = 305) # Or string value "305" -#' get_animals(animal_id = c(304, 305, 2827)) +#' get_animals(con, animal_id = 305) # Or string value "305" +#' get_animals(con, animal_id = c(304, 305, 2827)) #' #' # Get animals from specific animal project(s) -#' get_animals(animal_project_code = "2014_demer") -#' get_animals(animal_project_code = c("2014_demer", "2015_dijle")) +#' get_animals(con, animal_project_code = "2014_demer") +#' get_animals(con, animal_project_code = c("2014_demer", "2015_dijle")) #' #' # Get animals associated with a specific tag_serial_number -#' get_animals(tag_serial_number = "1187450") +#' get_animals(con, tag_serial_number = "1187450") #' #' # Get animals of specific species (across all projects) -#' get_animals(scientific_name = c("Rutilus rutilus", "Silurus glanis")) +#' get_animals(con, scientific_name = c("Rutilus rutilus", "Silurus glanis")) #' #' # Get animals of a specific species from a specific project -#' get_animals(animal_project_code = "2014_demer", scientific_name = "Rutilus rutilus") -#' } +#' get_animals(con, animal_project_code = "2014_demer", scientific_name = "Rutilus rutilus") get_animals <- function(connection = con, animal_id = NULL, tag_serial_number = NULL, From 4f2a97ff7898caba6b5e942e3952afa0e3cd9045 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Tue, 30 Nov 2021 10:11:23 +0100 Subject: [PATCH 032/183] Merge pull request #241 from inbo/importFrom Fix #240: use :: over importFrom --- R/get_animals.R | 41 +++++++++++++++++++---------------------- 1 file changed, 19 insertions(+), 22 deletions(-) diff --git a/R/get_animals.R b/R/get_animals.R index c1524ed..f6285d8 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -18,12 +18,6 @@ #' #' @export #' -#' @importFrom glue glue_sql -#' @importFrom DBI dbGetQuery -#' @importFrom dplyr .data %>% arrange as_tibble group_by_at mutate_at select -#' starts_with summarize_at ungroup -#' @importFrom readr read_file -#' #' @examples #' # Set default connection variable #' con <- connect_to_etn() @@ -61,7 +55,7 @@ get_animals <- function(connection = con, } else { valid_animal_ids <- list_animal_ids(connection) check_value(animal_id, valid_animal_ids, "animal_id") - animal_id_query <- glue_sql( + animal_id_query <- glue::glue_sql( "animal.id_pk IN ({animal_id*})", .con = connection ) @@ -75,7 +69,7 @@ get_animals <- function(connection = con, animal_project_code <- tolower(animal_project_code) valid_animal_project_codes <- tolower(list_animal_project_codes(connection)) check_value(animal_project_code, valid_animal_project_codes, "animal_project_code") - animal_project_code_query <- glue_sql( + animal_project_code_query <- glue::glue_sql( "LOWER(animal_project.projectcode) IN ({animal_project_code*})", .con = connection ) @@ -88,7 +82,7 @@ get_animals <- function(connection = con, valid_tag_serial_numbers <- list_tag_serial_numbers(connection) tag_serial_number <- as.character(tag_serial_number) # Cast to character check_value(tag_serial_number, valid_tag_serial_numbers, "tag_serial_number") - tag_serial_number_query <- glue_sql( + tag_serial_number_query <- glue::glue_sql( "tag.tag_serial_number IN ({tag_serial_number*})", .con = connection ) @@ -100,16 +94,19 @@ get_animals <- function(connection = con, } else { valid_scientific_names <- list_scientific_names(connection) check_value(scientific_name, valid_scientific_names, "scientific_name") - scientific_name_query <- glue_sql( + scientific_name_query <- glue::glue_sql( "animal.scientific_name IN ({scientific_name*})", .con = connection ) } - tag_sql <- glue_sql(read_file(system.file("sql", "tag.sql", package = "etn")), .con = connection) + tag_sql <- glue::glue_sql( + readr::read_file(system.file("sql", "tag.sql", package = "etn")), + .con = connection + ) # Build query - query <- glue_sql(" + query <- glue::glue_sql(" SELECT animal.id_pk AS animal_id, animal_project.projectcode AS animal_project_code, @@ -198,33 +195,33 @@ get_animals <- function(connection = con, AND {tag_serial_number_query} AND {scientific_name_query} ", .con = connection) - animals <- dbGetQuery(connection, query) + animals <- DBI::dbGetQuery(connection, query) # Collapse tag information, to obtain one row = one animal tag_cols <- animals %>% - select(starts_with("tag"), starts_with("acoustic_tag_id")) %>% + dplyr::select(dplyr::starts_with("tag"), dplyr::starts_with("acoustic_tag_id")) %>% names() other_cols <- animals %>% - select(-starts_with("tag"), -starts_with("acoustic_tag_id")) %>% + dplyr::select(-dplyr::starts_with("tag"), -dplyr::starts_with("acoustic_tag_id")) %>% names() animals <- animals %>% - group_by_at(other_cols) %>% - summarize_at(tag_cols, paste, collapse = ",") %>% # Collapse multiple tags by comma - ungroup() %>% - mutate_at(tag_cols, gsub, pattern = "NA", replacement = "") %>% # Use "" instead of "NA" - select(names(animals)) # Use the original column order + dplyr::group_by_at(other_cols) %>% + dplyr::summarize_at(tag_cols, paste, collapse = ",") %>% # Collapse multiple tags by comma + dplyr::ungroup() %>% + dplyr::mutate_at(tag_cols, gsub, pattern = "NA", replacement = "") %>% # Use "" instead of "NA" + dplyr::select(names(animals)) # Use the original column order # Sort data animals <- animals %>% - arrange( + dplyr::arrange( .data$animal_project_code, .data$release_date_time, factor(.data$tag_serial_number, levels = list_tag_serial_numbers(connection)) ) - as_tibble(animals) # Is already a tibble, but added if code above changes + dplyr::as_tibble(animals) # Is already a tibble, but added if code above changes } From a8027ec31a7d6ffd3bf1f6d7f7495ee2cd91f7ad Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Fri, 9 Dec 2022 16:44:01 +0100 Subject: [PATCH 033/183] Merge pull request #257 from inbo/dwc Add `write_dwc()` function --- R/get_animals.R | 31 +++++++++++++++++++++---------- 1 file changed, 21 insertions(+), 10 deletions(-) diff --git a/R/get_animals.R b/R/get_animals.R index f6285d8..000e17e 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -53,8 +53,11 @@ get_animals <- function(connection = con, if (is.null(animal_id)) { animal_id_query <- "True" } else { - valid_animal_ids <- list_animal_ids(connection) - check_value(animal_id, valid_animal_ids, "animal_id") + animal_id <- check_value( + animal_id, + list_animal_ids(connection), + "animal_id" + ) animal_id_query <- glue::glue_sql( "animal.id_pk IN ({animal_id*})", .con = connection @@ -66,9 +69,12 @@ get_animals <- function(connection = con, if (is.null(animal_project_code)) { animal_project_code_query <- "True" } else { - animal_project_code <- tolower(animal_project_code) - valid_animal_project_codes <- tolower(list_animal_project_codes(connection)) - check_value(animal_project_code, valid_animal_project_codes, "animal_project_code") + animal_project_code <- check_value( + animal_project_code, + list_animal_project_codes(connection), + "animal_project_code", + lowercase = TRUE + ) animal_project_code_query <- glue::glue_sql( "LOWER(animal_project.projectcode) IN ({animal_project_code*})", .con = connection @@ -79,9 +85,11 @@ get_animals <- function(connection = con, if (is.null(tag_serial_number)) { tag_serial_number_query <- "True" } else { - valid_tag_serial_numbers <- list_tag_serial_numbers(connection) - tag_serial_number <- as.character(tag_serial_number) # Cast to character - check_value(tag_serial_number, valid_tag_serial_numbers, "tag_serial_number") + tag_serial_number <- check_value( + as.character(tag_serial_number), # Cast to character + list_tag_serial_numbers(connection), + "tag_serial_number" + ) tag_serial_number_query <- glue::glue_sql( "tag.tag_serial_number IN ({tag_serial_number*})", .con = connection @@ -92,8 +100,11 @@ get_animals <- function(connection = con, if (is.null(scientific_name)) { scientific_name_query <- "True" } else { - valid_scientific_names <- list_scientific_names(connection) - check_value(scientific_name, valid_scientific_names, "scientific_name") + scientific_name <- check_value( + scientific_name, + list_scientific_names(connection), + "scientific_name" + ) scientific_name_query <- glue::glue_sql( "animal.scientific_name IN ({scientific_name*})", .con = connection From f3b951e87538964a1842f5cad134fd22d988a3c5 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Fri, 21 Feb 2020 17:06:48 +0100 Subject: [PATCH 034/183] Merge pull request #93 from inbo/new_views Use new views --- tests/testthat/test-get_animals.R | 138 ++++++++++++++++++++++++++++++ 1 file changed, 138 insertions(+) create mode 100644 tests/testthat/test-get_animals.R diff --git a/tests/testthat/test-get_animals.R b/tests/testthat/test-get_animals.R new file mode 100644 index 0000000..f722727 --- /dev/null +++ b/tests/testthat/test-get_animals.R @@ -0,0 +1,138 @@ +con <- connect_to_etn( + username = Sys.getenv("userid"), + password = Sys.getenv("pwd") +) + +# Expected column names +expected_col_names_animals <- c( + "pk", + "animal_id", + "animal_project_code", + "tag_id", + "tag_fk", + "scientific_name", + "common_name", + "aphia_id", + "animal_nickname", + "tagger", + "capture_date_time", + "capture_location", + "capture_latitude", + "capture_longitude", + "capture_method", + "capture_depth", + "capture_temperature_change", + "release_date_time", + "release_location", + "release_latitude", + "release_longitude", + "recapture_date_time", + "length1_type", + "length1", + "length1_unit", + "length2_type", + "length2", + "length2_unit", + "length3_type", + "length3", + "length3_unit", + "length4_type", + "length4", + "length4_unit", + "weight", + "weight_unit", + "age", + "age_unit", + "sex", + "life_stage", + "wild_or_hatchery", + "stock", + "surgery_date_time", + "surgery_location", + "surgery_latitude", + "surgery_longitude", + "treatment_type", + "tagging_type", + "tagging_methodology", + "dna_sample", + "sedative", + "sedative_concentration", + "anaesthetic", + "buffer", + "anaesthetic_concentration", + "buffer_concentration_in_anaesthetic", + "anaesthetic_concentration_in_recirculation", + "buffer_concentration_in_recirculation", + "dissolved_oxygen", + "pre_surgery_holding_period", + "post_surgery_holding_period", + "holding_temperature", + "comments" +) + +project1 <- "phd_reubens" +project2 <- "2013_albertkanaal" +projects_multiple <- c("phd_reubens", "2013_albertkanaal") +name1 <- "Gadus morhua" +names_multiple <- c("Gadus morhua", "Sentinel", "Anguilla anguilla") + +animals_all <- get_animals(con) +animals_project1 <- get_animals(con, animal_project_code = project1) +animals_project2 <- get_animals(con, animal_project_code = project2) +animals_projects_multiple <- get_animals(con, animal_project_code = projects_multiple) +animals_names_multiple <- get_animals(con, scientific_name = names_multiple) +animals_project1_name1 <- get_animals(con, + animal_project_code = project1, + scientific_name = name1 +) + +testthat::test_that("test_input_get_animals", { + expect_error( + get_animals("I am not a connection"), + "Not a connection object to database." + ) +}) + + +testthat::test_that("test_output_get_animals", { + library(dplyr) + expect_is(animals_all, "data.frame") + expect_is(animals_project1, "data.frame") + expect_is(animals_project2, "data.frame") + expect_is(animals_projects_multiple, "data.frame") + expect_is(animals_names_multiple, "data.frame") + expect_is(animals_project1_name1, "data.frame") + expect_true(all(names(animals_all) %in% expected_col_names_animals)) + expect_true(all(expected_col_names_animals %in% names(animals_all))) + expect_gte(nrow(animals_all), nrow(animals_project1)) + expect_gte(nrow(animals_all), nrow(animals_project2)) + expect_gte(nrow(animals_all), nrow(animals_projects_multiple)) + expect_gte(nrow(animals_all), nrow(animals_names_multiple)) + expect_gte(nrow(animals_all), nrow(animals_project1_name1)) + expect_equal(nrow(animals_project2), 309) + expect_equal(names(animals_all), names(animals_project1)) + expect_equal(names(animals_all), names(animals_project2)) + expect_equal(names(animals_all), names(animals_projects_multiple)) + expect_equal(names(animals_all), names(animals_names_multiple)) + expect_equal(names(animals_all), names(animals_project1_name1)) + expect_gte( + animals_all %>% distinct(scientific_name) %>% pull() %>% length(), + animals_projects_multiple %>% distinct(scientific_name) %>% pull() %>% length() + ) + expect_lte( + animals_projects_multiple %>% distinct(scientific_name) %>% pull() %>% length(), + (animals_project1 %>% distinct(scientific_name) %>% pull() %>% length() + + animals_project2 %>% distinct(scientific_name) %>% pull() %>% length()) + ) + expect_true(all(projects_multiple %in% + (animals_names_multiple %>% distinct(animal_project_code) %>% pull()))) + expect_identical( + animals_project1_name1 %>% distinct(scientific_name) %>% pull(scientific_name), + c(name1) + ) + expect_identical( + animals_project1_name1 %>% distinct(animal_project_code) %>% pull(animal_project_code), + c(project1) + ) + # expect_equal(nrow(animals_all), nrow(animals_all %>% distinct(pk))) +}) From 2acbea31ea6a9babb00686c05a9c1037aa264940 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 26 Feb 2020 14:38:06 +0100 Subject: [PATCH 035/183] Merge pull request #101 from inbo/update_parameters Update parameters for get_tags and get_receivers --- tests/testthat/test-get_animals.R | 102 ++++++++++++++++++------------ 1 file changed, 61 insertions(+), 41 deletions(-) diff --git a/tests/testthat/test-get_animals.R b/tests/testthat/test-get_animals.R index f722727..6855fc4 100644 --- a/tests/testthat/test-get_animals.R +++ b/tests/testthat/test-get_animals.R @@ -72,67 +72,87 @@ expected_col_names_animals <- c( project1 <- "phd_reubens" project2 <- "2013_albertkanaal" -projects_multiple <- c("phd_reubens", "2013_albertkanaal") -name1 <- "Gadus morhua" -names_multiple <- c("Gadus morhua", "Sentinel", "Anguilla anguilla") +project_multiple <- c("2013_albertkanaal", "phd_reubens") +sciname1 <- "Gadus morhua" +sciname_multiple <- c("Anguilla anguilla", "Gadus morhua", "Sentinel") animals_all <- get_animals(con) animals_project1 <- get_animals(con, animal_project_code = project1) animals_project2 <- get_animals(con, animal_project_code = project2) -animals_projects_multiple <- get_animals(con, animal_project_code = projects_multiple) -animals_names_multiple <- get_animals(con, scientific_name = names_multiple) -animals_project1_name1 <- get_animals(con, - animal_project_code = project1, - scientific_name = name1 -) +animals_project_multiple <- get_animals(con, animal_project_code = project_multiple) +animals_sciname_multiple <- get_animals(con, scientific_name = sciname_multiple) +animals_project1_sciname1 <- get_animals(con, animal_project_code = project1, scientific_name = sciname1) -testthat::test_that("test_input_get_animals", { +testthat::test_that("Test input", { expect_error( - get_animals("I am not a connection"), + get_animals("not_a_connection"), "Not a connection object to database." ) + expect_error( + get_animals(con, network_project_code = "not_a_project") + ) + expect_error( + get_animals(con, network_project_code = c("thornton", "not_a_project")) + ) }) - -testthat::test_that("test_output_get_animals", { - library(dplyr) +testthat::test_that("Test output type", { expect_is(animals_all, "data.frame") expect_is(animals_project1, "data.frame") expect_is(animals_project2, "data.frame") - expect_is(animals_projects_multiple, "data.frame") - expect_is(animals_names_multiple, "data.frame") - expect_is(animals_project1_name1, "data.frame") + expect_is(animals_project_multiple, "data.frame") + expect_is(animals_sciname_multiple, "data.frame") + expect_is(animals_project1_sciname1, "data.frame") +}) + +testthat::test_that("Test column names", { expect_true(all(names(animals_all) %in% expected_col_names_animals)) expect_true(all(expected_col_names_animals %in% names(animals_all))) - expect_gte(nrow(animals_all), nrow(animals_project1)) - expect_gte(nrow(animals_all), nrow(animals_project2)) - expect_gte(nrow(animals_all), nrow(animals_projects_multiple)) - expect_gte(nrow(animals_all), nrow(animals_names_multiple)) - expect_gte(nrow(animals_all), nrow(animals_project1_name1)) - expect_equal(nrow(animals_project2), 309) expect_equal(names(animals_all), names(animals_project1)) expect_equal(names(animals_all), names(animals_project2)) - expect_equal(names(animals_all), names(animals_projects_multiple)) - expect_equal(names(animals_all), names(animals_names_multiple)) - expect_equal(names(animals_all), names(animals_project1_name1)) - expect_gte( - animals_all %>% distinct(scientific_name) %>% pull() %>% length(), - animals_projects_multiple %>% distinct(scientific_name) %>% pull() %>% length() + expect_equal(names(animals_all), names(animals_project_multiple)) + expect_equal(names(animals_all), names(animals_sciname_multiple)) + expect_equal(names(animals_all), names(animals_project1_sciname1)) +}) + +testthat::test_that("Test number of records", { + expect_equal(nrow(animals_project2), 309) + expect_gt(nrow(animals_all), nrow(animals_project1)) + expect_gt(nrow(animals_all), nrow(animals_project2)) + expect_gt(nrow(animals_all), nrow(animals_project_multiple)) + expect_equal(nrow(animals_project_multiple), nrow(animals_project1) + nrow(animals_project2)) + expect_gt(nrow(animals_all), nrow(animals_sciname_multiple)) + expect_gt(nrow(animals_all), nrow(animals_project1_sciname1)) + expect_gt(nrow(animals_project1), nrow(animals_project1_sciname1)) +}) + +testthat::test_that("Test if data is filtered on paramater", { + expect_equal( + animals_project1 %>% distinct(animal_project_code) %>% pull(), + c(project1) + ) + expect_equal( + animals_project2 %>% distinct(animal_project_code) %>% pull(), + c(project2) ) - expect_lte( - animals_projects_multiple %>% distinct(scientific_name) %>% pull() %>% length(), - (animals_project1 %>% distinct(scientific_name) %>% pull() %>% length() + - animals_project2 %>% distinct(scientific_name) %>% pull() %>% length()) + expect_equal( + animals_project_multiple %>% distinct(animal_project_code) %>% arrange(animal_project_code) %>% pull(), + c(project_multiple) ) - expect_true(all(projects_multiple %in% - (animals_names_multiple %>% distinct(animal_project_code) %>% pull()))) - expect_identical( - animals_project1_name1 %>% distinct(scientific_name) %>% pull(scientific_name), - c(name1) + expect_equal( + animals_sciname_multiple %>% distinct(scientific_name) %>% arrange(scientific_name) %>% pull(), + c(sciname_multiple) ) - expect_identical( - animals_project1_name1 %>% distinct(animal_project_code) %>% pull(animal_project_code), + expect_equal( + animals_project1_sciname1 %>% distinct(animal_project_code) %>% pull(), c(project1) ) - # expect_equal(nrow(animals_all), nrow(animals_all %>% distinct(pk))) + expect_equal( + animals_project1_sciname1 %>% distinct(scientific_name) %>% pull(), + c(sciname1) + ) }) + +# testthat::test_that("Test unique ids", { +# expect_equal(nrow(animals_all), nrow(animals_all %>% distinct(pk))) +# }) From b26b5ee94adf5946d47a4880748b3a6de01afcd0 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 18 Mar 2020 12:43:12 +0100 Subject: [PATCH 036/183] Merge pull request #106 from inbo/solve-animal-tag-relationship Solve animal tag relationship --- tests/testthat/test-get_animals.R | 37 ++++++++++++++++++++++--------- 1 file changed, 26 insertions(+), 11 deletions(-) diff --git a/tests/testthat/test-get_animals.R b/tests/testthat/test-get_animals.R index 6855fc4..b4fab87 100644 --- a/tests/testthat/test-get_animals.R +++ b/tests/testthat/test-get_animals.R @@ -4,7 +4,7 @@ con <- connect_to_etn( ) # Expected column names -expected_col_names_animals <- c( +expected_col_names <- c( "pk", "animal_id", "animal_project_code", @@ -69,10 +69,18 @@ expected_col_names_animals <- c( "holding_temperature", "comments" ) +tag_col_names <- c( + "tag_id", + "tag_fk", + "tagger", + "tagging_type", + "tagging_methodology" +) project1 <- "phd_reubens" project2 <- "2013_albertkanaal" project_multiple <- c("2013_albertkanaal", "phd_reubens") +animal_pk_multiple_tags <- 2369 sciname1 <- "Gadus morhua" sciname_multiple <- c("Anguilla anguilla", "Gadus morhua", "Sentinel") @@ -82,6 +90,7 @@ animals_project2 <- get_animals(con, animal_project_code = project2) animals_project_multiple <- get_animals(con, animal_project_code = project_multiple) animals_sciname_multiple <- get_animals(con, scientific_name = sciname_multiple) animals_project1_sciname1 <- get_animals(con, animal_project_code = project1, scientific_name = sciname1) +animals_tag_multiple <- animals_all %>% filter(pk == 2827) testthat::test_that("Test input", { expect_error( @@ -106,13 +115,12 @@ testthat::test_that("Test output type", { }) testthat::test_that("Test column names", { - expect_true(all(names(animals_all) %in% expected_col_names_animals)) - expect_true(all(expected_col_names_animals %in% names(animals_all))) - expect_equal(names(animals_all), names(animals_project1)) - expect_equal(names(animals_all), names(animals_project2)) - expect_equal(names(animals_all), names(animals_project_multiple)) - expect_equal(names(animals_all), names(animals_sciname_multiple)) - expect_equal(names(animals_all), names(animals_project1_sciname1)) + expect_equal(names(animals_all), expected_col_names) + expect_equal(names(animals_project1), expected_col_names) + expect_equal(names(animals_project2), expected_col_names) + expect_equal(names(animals_project_multiple), expected_col_names) + expect_equal(names(animals_sciname_multiple), expected_col_names) + expect_equal(names(animals_project1_sciname1), expected_col_names) }) testthat::test_that("Test number of records", { @@ -153,6 +161,13 @@ testthat::test_that("Test if data is filtered on paramater", { ) }) -# testthat::test_that("Test unique ids", { -# expect_equal(nrow(animals_all), nrow(animals_all %>% distinct(pk))) -# }) +testthat::test_that("Test unique ids and collapsed tag information", { + expect_equal(nrow(animals_all), nrow(animals_all %>% distinct(pk))) + + has_comma <- apply( + animals_tag_multiple %>% select(tag_col_names), + MARGIN = 2, + function(x) grepl(pattern = ",", x = x) + ) + expect_true(all(has_comma)) +}) From 6ed6c480c8aaed5828ca59236d860e5332cd4966 Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Tue, 24 Mar 2020 16:50:02 +0100 Subject: [PATCH 037/183] Update fields in animals_view2 #109 --- tests/testthat/test-get_animals.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tests/testthat/test-get_animals.R b/tests/testthat/test-get_animals.R index b4fab87..ab3a6e4 100644 --- a/tests/testthat/test-get_animals.R +++ b/tests/testthat/test-get_animals.R @@ -13,6 +13,7 @@ expected_col_names <- c( "scientific_name", "common_name", "aphia_id", + "animal_label", "animal_nickname", "tagger", "capture_date_time", @@ -163,6 +164,7 @@ testthat::test_that("Test if data is filtered on paramater", { testthat::test_that("Test unique ids and collapsed tag information", { expect_equal(nrow(animals_all), nrow(animals_all %>% distinct(pk))) + expect_equal(nrow(animals_all), nrow(animals_all %>% distinct(animal_id))) has_comma <- apply( animals_tag_multiple %>% select(tag_col_names), From ccd1ebc5435c71bc743e8984981c78df4c9a1f81 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 25 Mar 2020 15:29:49 +0100 Subject: [PATCH 038/183] Merge pull request #116 from inbo/animal_id Implement animal_id parameter --- tests/testthat/test-get_animals.R | 59 +++++++++++++++++++++++-------- 1 file changed, 44 insertions(+), 15 deletions(-) diff --git a/tests/testthat/test-get_animals.R b/tests/testthat/test-get_animals.R index ab3a6e4..e7d5e54 100644 --- a/tests/testthat/test-get_animals.R +++ b/tests/testthat/test-get_animals.R @@ -78,26 +78,36 @@ tag_col_names <- c( "tagging_methodology" ) +animal1 <- 2824 +animal_multiple <- c(2824, 2825) +animal_multiple_text <- c(2824, "2825") +animal_tag_multiple <- 2827 # Has 2 associated tags project1 <- "phd_reubens" -project2 <- "2013_albertkanaal" project_multiple <- c("2013_albertkanaal", "phd_reubens") -animal_pk_multiple_tags <- 2369 sciname1 <- "Gadus morhua" sciname_multiple <- c("Anguilla anguilla", "Gadus morhua", "Sentinel") animals_all <- get_animals(con) +animals_animal1 <- get_animals(con, animal_id = animal1) +animals_animal_multiple <- get_animals(con, animal_id = animal_multiple) +animals_animal_multiple_text <- get_animals(con, animal_id = animal_multiple_text) +animals_animal_tag_multiple <- get_animals(con, animal_id = animal_tag_multiple) animals_project1 <- get_animals(con, animal_project_code = project1) -animals_project2 <- get_animals(con, animal_project_code = project2) animals_project_multiple <- get_animals(con, animal_project_code = project_multiple) animals_sciname_multiple <- get_animals(con, scientific_name = sciname_multiple) animals_project1_sciname1 <- get_animals(con, animal_project_code = project1, scientific_name = sciname1) -animals_tag_multiple <- animals_all %>% filter(pk == 2827) testthat::test_that("Test input", { expect_error( get_animals("not_a_connection"), "Not a connection object to database." ) + expect_error( + get_animals(con, animal_id = "not_an_animal") + ) + expect_error( + get_animals(con, animal_id = 20.2) # Not an integer + ) expect_error( get_animals(con, network_project_code = "not_a_project") ) @@ -108,8 +118,11 @@ testthat::test_that("Test input", { testthat::test_that("Test output type", { expect_is(animals_all, "data.frame") + expect_is(animals_animal1, "data.frame") + expect_is(animals_animal_multiple, "data.frame") + expect_is(animals_animal_multiple_text, "data.frame") + expect_is(animals_animal_tag_multiple, "data.frame") expect_is(animals_project1, "data.frame") - expect_is(animals_project2, "data.frame") expect_is(animals_project_multiple, "data.frame") expect_is(animals_sciname_multiple, "data.frame") expect_is(animals_project1_sciname1, "data.frame") @@ -117,19 +130,23 @@ testthat::test_that("Test output type", { testthat::test_that("Test column names", { expect_equal(names(animals_all), expected_col_names) + expect_equal(names(animals_animal1), expected_col_names) + expect_equal(names(animals_animal_multiple), expected_col_names) + expect_equal(names(animals_animal_multiple_text), expected_col_names) + expect_equal(names(animals_animal_tag_multiple), expected_col_names) expect_equal(names(animals_project1), expected_col_names) - expect_equal(names(animals_project2), expected_col_names) expect_equal(names(animals_project_multiple), expected_col_names) expect_equal(names(animals_sciname_multiple), expected_col_names) expect_equal(names(animals_project1_sciname1), expected_col_names) }) testthat::test_that("Test number of records", { - expect_equal(nrow(animals_project2), 309) - expect_gt(nrow(animals_all), nrow(animals_project1)) - expect_gt(nrow(animals_all), nrow(animals_project2)) + expect_equal(nrow(animals_animal1), 1) + expect_equal(nrow(animals_animal_multiple), 2) + expect_equal(nrow(animals_animal_multiple_text), 2) + expect_equal(nrow(animals_animal_tag_multiple), 1) # Rows should be collapsed + expect_equal(nrow(animals_project1), 68) expect_gt(nrow(animals_all), nrow(animals_project_multiple)) - expect_equal(nrow(animals_project_multiple), nrow(animals_project1) + nrow(animals_project2)) expect_gt(nrow(animals_all), nrow(animals_sciname_multiple)) expect_gt(nrow(animals_all), nrow(animals_project1_sciname1)) expect_gt(nrow(animals_project1), nrow(animals_project1_sciname1)) @@ -137,12 +154,24 @@ testthat::test_that("Test number of records", { testthat::test_that("Test if data is filtered on paramater", { expect_equal( - animals_project1 %>% distinct(animal_project_code) %>% pull(), - c(project1) + animals_animal1 %>% distinct(animal_id) %>% pull(), + c(animal1) + ) + expect_equal( + animals_animal_multiple %>% distinct(animal_id) %>% pull(), + c(animal_multiple) + ) + expect_equal( + animals_animal_multiple_text %>% distinct(animal_id) %>% pull(), + c(animal_multiple) # animal_id in data.frame expected to be integers, so not animal_multiple_text ) expect_equal( - animals_project2 %>% distinct(animal_project_code) %>% pull(), - c(project2) + animals_animal_tag_multiple %>% distinct(animal_id) %>% pull(), + c(animal_tag_multiple) + ) + expect_equal( + animals_project1 %>% distinct(animal_project_code) %>% pull(), + c(project1) ) expect_equal( animals_project_multiple %>% distinct(animal_project_code) %>% arrange(animal_project_code) %>% pull(), @@ -167,7 +196,7 @@ testthat::test_that("Test unique ids and collapsed tag information", { expect_equal(nrow(animals_all), nrow(animals_all %>% distinct(animal_id))) has_comma <- apply( - animals_tag_multiple %>% select(tag_col_names), + animals_animal_tag_multiple %>% select(tag_col_names), MARGIN = 2, function(x) grepl(pattern = ",", x = x) ) From 8c5aa79868bed55d5e8ac42f4de486f64892d1fe Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Wed, 1 Apr 2020 13:32:41 +0200 Subject: [PATCH 039/183] Fix typo --- tests/testthat/test-get_animals.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-get_animals.R b/tests/testthat/test-get_animals.R index e7d5e54..0e37cae 100644 --- a/tests/testthat/test-get_animals.R +++ b/tests/testthat/test-get_animals.R @@ -152,7 +152,7 @@ testthat::test_that("Test number of records", { expect_gt(nrow(animals_project1), nrow(animals_project1_sciname1)) }) -testthat::test_that("Test if data is filtered on paramater", { +testthat::test_that("Test if data is filtered on parameter", { expect_equal( animals_animal1 %>% distinct(animal_id) %>% pull(), c(animal1) From 0782aca94b6cf6fb5ff23021cb25f0213a18f751 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 2 Sep 2020 10:42:20 +0200 Subject: [PATCH 040/183] Merge pull request #123 from inbo/order_by Order returned results --- tests/testthat/test-get_animals.R | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/tests/testthat/test-get_animals.R b/tests/testthat/test-get_animals.R index 0e37cae..939dc3e 100644 --- a/tests/testthat/test-get_animals.R +++ b/tests/testthat/test-get_animals.R @@ -117,15 +117,15 @@ testthat::test_that("Test input", { }) testthat::test_that("Test output type", { - expect_is(animals_all, "data.frame") - expect_is(animals_animal1, "data.frame") - expect_is(animals_animal_multiple, "data.frame") - expect_is(animals_animal_multiple_text, "data.frame") - expect_is(animals_animal_tag_multiple, "data.frame") - expect_is(animals_project1, "data.frame") - expect_is(animals_project_multiple, "data.frame") - expect_is(animals_sciname_multiple, "data.frame") - expect_is(animals_project1_sciname1, "data.frame") + expect_is(animals_all, "tbl_df") + expect_is(animals_animal1, "tbl_df") + expect_is(animals_animal_multiple, "tbl_df") + expect_is(animals_animal_multiple_text, "tbl_df") + expect_is(animals_animal_tag_multiple, "tbl_df") + expect_is(animals_project1, "tbl_df") + expect_is(animals_project_multiple, "tbl_df") + expect_is(animals_sciname_multiple, "tbl_df") + expect_is(animals_project1_sciname1, "tbl_df") }) testthat::test_that("Test column names", { From 37f7015ca30419c316dc7ae145d0d9af0a69a0a3 Mon Sep 17 00:00:00 2001 From: Damiano Oldoni Date: Mon, 23 Nov 2020 20:24:21 +0100 Subject: [PATCH 041/183] Merge pull request #142 from inbo/add-test-download_dataset Add test download dataset --- tests/testthat/test-get_animals.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-get_animals.R b/tests/testthat/test-get_animals.R index 939dc3e..3d2f811 100644 --- a/tests/testthat/test-get_animals.R +++ b/tests/testthat/test-get_animals.R @@ -82,8 +82,8 @@ animal1 <- 2824 animal_multiple <- c(2824, 2825) animal_multiple_text <- c(2824, "2825") animal_tag_multiple <- 2827 # Has 2 associated tags -project1 <- "phd_reubens" -project_multiple <- c("2013_albertkanaal", "phd_reubens") +project1 <- "2010_phd_reubens" +project_multiple <- c("2010_phd_reubens", "2013_albertkanaal") sciname1 <- "Gadus morhua" sciname_multiple <- c("Anguilla anguilla", "Gadus morhua", "Sentinel") @@ -145,11 +145,11 @@ testthat::test_that("Test number of records", { expect_equal(nrow(animals_animal_multiple), 2) expect_equal(nrow(animals_animal_multiple_text), 2) expect_equal(nrow(animals_animal_tag_multiple), 1) # Rows should be collapsed - expect_equal(nrow(animals_project1), 68) + expect_equal(nrow(animals_project1), 41) expect_gt(nrow(animals_all), nrow(animals_project_multiple)) expect_gt(nrow(animals_all), nrow(animals_sciname_multiple)) expect_gt(nrow(animals_all), nrow(animals_project1_sciname1)) - expect_gt(nrow(animals_project1), nrow(animals_project1_sciname1)) + expect_gte(nrow(animals_project1), nrow(animals_project1_sciname1)) }) testthat::test_that("Test if data is filtered on parameter", { From 221f7af733fd915e98a5271c531f9c7eeb96ddc6 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Mon, 4 Jan 2021 17:01:27 +0100 Subject: [PATCH 042/183] Merge pull request #144 from inbo/issue_140 Allow case-insensitive animal_project_code, network_project_code, station_name --- tests/testthat/test-get_animals.R | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-get_animals.R b/tests/testthat/test-get_animals.R index 3d2f811..ba6c7ef 100644 --- a/tests/testthat/test-get_animals.R +++ b/tests/testthat/test-get_animals.R @@ -85,7 +85,7 @@ animal_tag_multiple <- 2827 # Has 2 associated tags project1 <- "2010_phd_reubens" project_multiple <- c("2010_phd_reubens", "2013_albertkanaal") sciname1 <- "Gadus morhua" -sciname_multiple <- c("Anguilla anguilla", "Gadus morhua", "Sentinel") +sciname_multiple <- c("Anguilla anguilla", "Gadus morhua") animals_all <- get_animals(con) animals_animal1 <- get_animals(con, animal_id = animal1) @@ -93,6 +93,7 @@ animals_animal_multiple <- get_animals(con, animal_id = animal_multiple) animals_animal_multiple_text <- get_animals(con, animal_id = animal_multiple_text) animals_animal_tag_multiple <- get_animals(con, animal_id = animal_tag_multiple) animals_project1 <- get_animals(con, animal_project_code = project1) +animals_project1_uppercase <- get_animals(con, animal_project_code = toupper(project1)) animals_project_multiple <- get_animals(con, animal_project_code = project_multiple) animals_sciname_multiple <- get_animals(con, scientific_name = sciname_multiple) animals_project1_sciname1 <- get_animals(con, animal_project_code = project1, scientific_name = sciname1) @@ -152,6 +153,10 @@ testthat::test_that("Test number of records", { expect_gte(nrow(animals_project1), nrow(animals_project1_sciname1)) }) +testthat::test_that("Argument animal_project_code is case-insensitive", { + expect_equal(animals_project1, animals_project1_uppercase) +}) + testthat::test_that("Test if data is filtered on parameter", { expect_equal( animals_animal1 %>% distinct(animal_id) %>% pull(), From 4c31879fbd7664043f23888665468b4b64f122bd Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Tue, 5 Oct 2021 14:55:12 +0200 Subject: [PATCH 043/183] Merge pull request #191 from inbo/sql_views New functions (part 1) --- tests/testthat/test-get_animals.R | 371 ++++++++++++++++-------------- 1 file changed, 201 insertions(+), 170 deletions(-) diff --git a/tests/testthat/test-get_animals.R b/tests/testthat/test-get_animals.R index ba6c7ef..c34506d 100644 --- a/tests/testthat/test-get_animals.R +++ b/tests/testthat/test-get_animals.R @@ -1,207 +1,238 @@ -con <- connect_to_etn( - username = Sys.getenv("userid"), - password = Sys.getenv("pwd") -) - -# Expected column names -expected_col_names <- c( - "pk", - "animal_id", - "animal_project_code", - "tag_id", - "tag_fk", - "scientific_name", - "common_name", - "aphia_id", - "animal_label", - "animal_nickname", - "tagger", - "capture_date_time", - "capture_location", - "capture_latitude", - "capture_longitude", - "capture_method", - "capture_depth", - "capture_temperature_change", - "release_date_time", - "release_location", - "release_latitude", - "release_longitude", - "recapture_date_time", - "length1_type", - "length1", - "length1_unit", - "length2_type", - "length2", - "length2_unit", - "length3_type", - "length3", - "length3_unit", - "length4_type", - "length4", - "length4_unit", - "weight", - "weight_unit", - "age", - "age_unit", - "sex", - "life_stage", - "wild_or_hatchery", - "stock", - "surgery_date_time", - "surgery_location", - "surgery_latitude", - "surgery_longitude", - "treatment_type", - "tagging_type", - "tagging_methodology", - "dna_sample", - "sedative", - "sedative_concentration", - "anaesthetic", - "buffer", - "anaesthetic_concentration", - "buffer_concentration_in_anaesthetic", - "anaesthetic_concentration_in_recirculation", - "buffer_concentration_in_recirculation", - "dissolved_oxygen", - "pre_surgery_holding_period", - "post_surgery_holding_period", - "holding_temperature", - "comments" -) -tag_col_names <- c( - "tag_id", - "tag_fk", - "tagger", - "tagging_type", - "tagging_methodology" -) - -animal1 <- 2824 -animal_multiple <- c(2824, 2825) -animal_multiple_text <- c(2824, "2825") -animal_tag_multiple <- 2827 # Has 2 associated tags -project1 <- "2010_phd_reubens" -project_multiple <- c("2010_phd_reubens", "2013_albertkanaal") -sciname1 <- "Gadus morhua" -sciname_multiple <- c("Anguilla anguilla", "Gadus morhua") - -animals_all <- get_animals(con) -animals_animal1 <- get_animals(con, animal_id = animal1) -animals_animal_multiple <- get_animals(con, animal_id = animal_multiple) -animals_animal_multiple_text <- get_animals(con, animal_id = animal_multiple_text) -animals_animal_tag_multiple <- get_animals(con, animal_id = animal_tag_multiple) -animals_project1 <- get_animals(con, animal_project_code = project1) -animals_project1_uppercase <- get_animals(con, animal_project_code = toupper(project1)) -animals_project_multiple <- get_animals(con, animal_project_code = project_multiple) -animals_sciname_multiple <- get_animals(con, scientific_name = sciname_multiple) -animals_project1_sciname1 <- get_animals(con, animal_project_code = project1, scientific_name = sciname1) - -testthat::test_that("Test input", { +con <- connect_to_etn() + +test_that("get_animals() returns error for incorrect connection", { expect_error( - get_animals("not_a_connection"), + get_animals(con = "not_a_connection"), "Not a connection object to database." ) - expect_error( - get_animals(con, animal_id = "not_an_animal") - ) - expect_error( - get_animals(con, animal_id = 20.2) # Not an integer - ) - expect_error( - get_animals(con, network_project_code = "not_a_project") - ) - expect_error( - get_animals(con, network_project_code = c("thornton", "not_a_project")) - ) }) -testthat::test_that("Test output type", { - expect_is(animals_all, "tbl_df") - expect_is(animals_animal1, "tbl_df") - expect_is(animals_animal_multiple, "tbl_df") - expect_is(animals_animal_multiple_text, "tbl_df") - expect_is(animals_animal_tag_multiple, "tbl_df") - expect_is(animals_project1, "tbl_df") - expect_is(animals_project_multiple, "tbl_df") - expect_is(animals_sciname_multiple, "tbl_df") - expect_is(animals_project1_sciname1, "tbl_df") +test_that("get_animals() returns a tibble", { + df <- get_animals() + expect_s3_class(df, "data.frame") + expect_s3_class(df, "tbl") }) -testthat::test_that("Test column names", { - expect_equal(names(animals_all), expected_col_names) - expect_equal(names(animals_animal1), expected_col_names) - expect_equal(names(animals_animal_multiple), expected_col_names) - expect_equal(names(animals_animal_multiple_text), expected_col_names) - expect_equal(names(animals_animal_tag_multiple), expected_col_names) - expect_equal(names(animals_project1), expected_col_names) - expect_equal(names(animals_project_multiple), expected_col_names) - expect_equal(names(animals_sciname_multiple), expected_col_names) - expect_equal(names(animals_project1_sciname1), expected_col_names) +test_that("get_animals() returns unique animal_id", { + df <- get_animals() + expect_equal(nrow(df), nrow(df %>% distinct(animal_id))) }) -testthat::test_that("Test number of records", { - expect_equal(nrow(animals_animal1), 1) - expect_equal(nrow(animals_animal_multiple), 2) - expect_equal(nrow(animals_animal_multiple_text), 2) - expect_equal(nrow(animals_animal_tag_multiple), 1) # Rows should be collapsed - expect_equal(nrow(animals_project1), 41) - expect_gt(nrow(animals_all), nrow(animals_project_multiple)) - expect_gt(nrow(animals_all), nrow(animals_sciname_multiple)) - expect_gt(nrow(animals_all), nrow(animals_project1_sciname1)) - expect_gte(nrow(animals_project1), nrow(animals_project1_sciname1)) +test_that("get_animals() returns the expected columns", { + df <- get_animals() + expected_col_names <- c( + "animal_id", + "animal_project_code", + "tag_serial_number", + "tag_type", + "tag_subtype", + "scientific_name", + "common_name", + "aphia_id", + "animal_label", + "animal_nickname", + "tagger", + "capture_date_time", + "capture_location", + "capture_latitude", + "capture_longitude", + "capture_method", + "capture_depth", + "capture_temperature_change", + "release_date_time", + "release_location", + "release_latitude", + "release_longitude", + "recapture_date_time", + "length1_type", + "length1", + "length1_unit", + "length2_type", + "length2", + "length2_unit", + "length3_type", + "length3", + "length3_unit", + "length4_type", + "length4", + "length4_unit", + "weight", + "weight_unit", + "age", + "age_unit", + "sex", + "life_stage", + "wild_or_hatchery", + "stock", + "surgery_date_time", + "surgery_location", + "surgery_latitude", + "surgery_longitude", + "treatment_type", + "tagging_type", + "tagging_methodology", + "dna_sample", + "sedative", + "sedative_concentration", + "anaesthetic", + "buffer", + "anaesthetic_concentration", + "buffer_concentration_in_anaesthetic", + "anaesthetic_concentration_in_recirculation", + "buffer_concentration_in_recirculation", + "dissolved_oxygen", + "pre_surgery_holding_period", + "post_surgery_holding_period", + "holding_temperature", + "comments" + ) + expect_equal(names(df), expected_col_names) }) -testthat::test_that("Argument animal_project_code is case-insensitive", { - expect_equal(animals_project1, animals_project1_uppercase) -}) +test_that("get_animals() allows selecting on animal_id", { + # Errors + expect_error(get_animals(animal_id = 0)) # Not an existing value + expect_error(get_animals(animal_id = c(305, 0))) + expect_error(get_animals(animal_id = 20.2)) # Not an integer -testthat::test_that("Test if data is filtered on parameter", { + # Select single value + single_select <- 305 + single_select_df <- get_animals(animal_id = single_select) expect_equal( - animals_animal1 %>% distinct(animal_id) %>% pull(), - c(animal1) + single_select_df %>% distinct(animal_id) %>% pull(), + c(single_select) ) + expect_equal(nrow(single_select_df), 1) + + # Select multiple values + multi_select <- c(304, "305") # Characters are allowed + multi_select_df <- get_animals(animal_id = multi_select) expect_equal( - animals_animal_multiple %>% distinct(animal_id) %>% pull(), - c(animal_multiple) + multi_select_df %>% distinct(animal_id) %>% pull() %>% sort(), + c(as.integer(multi_select)) # Output will be all integer ) + expect_equal(nrow(multi_select_df), 2) +}) + +test_that("get_animals() allows selecting on animal_project_code", { + # Errors + expect_error(get_animals(animal_project_code = "not_a_project")) + expect_error(get_animals(animal_project_code = c("2014_demer", "not_a_project"))) + + # Select single value + single_select <- "2014_demer" + single_select_df <- get_animals(animal_project_code = single_select) expect_equal( - animals_animal_multiple_text %>% distinct(animal_id) %>% pull(), - c(animal_multiple) # animal_id in data.frame expected to be integers, so not animal_multiple_text + single_select_df %>% distinct(animal_project_code) %>% pull(), + c(single_select) ) + expect_gt(nrow(single_select_df), 0) + + # Selection is case insensitive expect_equal( - animals_animal_tag_multiple %>% distinct(animal_id) %>% pull(), - c(animal_tag_multiple) + get_animals(animal_project_code = "2014_demer"), + get_animals(animal_project_code = "2014_DEMER") ) + + # Select multiple values + multi_select <- c("2014_demer", "2015_dijle") + multi_select_df <- get_animals(animal_project_code = multi_select) expect_equal( - animals_project1 %>% distinct(animal_project_code) %>% pull(), - c(project1) + multi_select_df %>% distinct(animal_project_code) %>% pull() %>% sort(), + c(multi_select) ) + expect_gt(nrow(multi_select_df), nrow(single_select_df)) +}) + +test_that("get_animals() allows selecting on tag_serial_number", { + # Errors + expect_error(get_animals(tag_serial_number = "0")) # Not an existing value + expect_error(get_animals(tag_serial_number = c("1187450", "0"))) + + # Select single value + single_select <- "1187450" # From 2014_demer + single_select_df <- get_animals(tag_serial_number = single_select) expect_equal( - animals_project_multiple %>% distinct(animal_project_code) %>% arrange(animal_project_code) %>% pull(), - c(project_multiple) + single_select_df %>% distinct(tag_serial_number) %>% pull(), + c(single_select) ) + expect_equal(nrow(single_select_df), 1) + # Note that not all tag_serial_number return a single row, e.g. "1119796" + + # Select multiple values + multi_select <- c(1187449, "1187450") # Integers are allowed + multi_select_df <- get_animals(tag_serial_number = multi_select) expect_equal( - animals_sciname_multiple %>% distinct(scientific_name) %>% arrange(scientific_name) %>% pull(), - c(sciname_multiple) + multi_select_df %>% distinct(tag_serial_number) %>% pull() %>% sort(), + c(as.character(multi_select)) # Output will be all character ) + expect_equal(nrow(multi_select_df), 2) +}) + +test_that("get_animals() allows selecting on scientific_name", { + # Errors + expect_error(get_animals(scientific_name = "not_a_sciname")) + expect_error(get_animals(scientific_name = "rutilus rutilus")) # Case sensitive + expect_error(get_animals(scientific_name = c("Rutilus rutilus", "not_a_sciname"))) + + # Select single value + single_select <- "Rutilus rutilus" + single_select_df <- get_animals(scientific_name = single_select) expect_equal( - animals_project1_sciname1 %>% distinct(animal_project_code) %>% pull(), - c(project1) + single_select_df %>% distinct(scientific_name) %>% pull(), + c(single_select) ) + expect_gt(nrow(single_select_df), 0) + + # Select multiple values + multi_select <- c("Rutilus rutilus", "Silurus glanis") + multi_select_df <- get_animals(scientific_name = multi_select) expect_equal( - animals_project1_sciname1 %>% distinct(scientific_name) %>% pull(), - c(sciname1) + multi_select_df %>% distinct(scientific_name) %>% pull() %>% sort(), + c(multi_select) ) + expect_gt(nrow(multi_select_df), nrow(single_select_df)) }) -testthat::test_that("Test unique ids and collapsed tag information", { - expect_equal(nrow(animals_all), nrow(animals_all %>% distinct(pk))) - expect_equal(nrow(animals_all), nrow(animals_all %>% distinct(animal_id))) +test_that("get_animals() allows to exclude non-animals", { + # Errors + expect_error(get_animals(exclude_non_animals = "not_a_logical")) + # Non-animals do are excluded from results + non_animals <- c("Built-in", "Plastic", "Range tag", "Sync tag") + expect_equal( + get_animals(exclude_non_animals = TRUE) %>% + filter(scientific_name %in% non_animals) %>% + nrow(), + 0 + ) +}) + +test_that("get_animals() allows selecting on multiple parameters", { + multiple_parameters_df <- get_animals( + animal_project_code = "2014_demer", + scientific_name = "Rutilus rutilus" + ) + # There are 2 Rutilus rutilus records in 2014_demer + expect_equal(nrow(multiple_parameters_df), 2) +}) + +test_that("get_animals() collapses multiple associated tags to one row", { + # Animal 5841 (project SPAWNSEIS) has 2 associated tags (1280688,1280688) + animal_two_tags_df <- get_animals(animal_id = 5841) + + expect_equal(nrow(animal_two_tags_df), 1) # Rows should be collapsed + + # Columns starting with tag_ are collapsed with comma + tag_col_names <- c( + "tag_serial_number", + "tag_type", + "tagger", + "tagging_type", + "tagging_methodology" + ) has_comma <- apply( - animals_animal_tag_multiple %>% select(tag_col_names), + animal_two_tags_df %>% select(tag_col_names), MARGIN = 2, function(x) grepl(pattern = ",", x = x) ) From f669332ad7b4ab30d4cbfaa0fb0340dbfcc52029 Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Wed, 6 Oct 2021 16:28:56 +0200 Subject: [PATCH 044/183] Remove exclude_non_animals for get_animals() This parameter was based on scientific name, but this field has issues #197 and is uncontrolled. It is better to let the user tackle this after data is returned --- tests/testthat/test-get_animals.R | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/tests/testthat/test-get_animals.R b/tests/testthat/test-get_animals.R index c34506d..d88f3cd 100644 --- a/tests/testthat/test-get_animals.R +++ b/tests/testthat/test-get_animals.R @@ -194,20 +194,6 @@ test_that("get_animals() allows selecting on scientific_name", { expect_gt(nrow(multi_select_df), nrow(single_select_df)) }) -test_that("get_animals() allows to exclude non-animals", { - # Errors - expect_error(get_animals(exclude_non_animals = "not_a_logical")) - - # Non-animals do are excluded from results - non_animals <- c("Built-in", "Plastic", "Range tag", "Sync tag") - expect_equal( - get_animals(exclude_non_animals = TRUE) %>% - filter(scientific_name %in% non_animals) %>% - nrow(), - 0 - ) -}) - test_that("get_animals() allows selecting on multiple parameters", { multiple_parameters_df <- get_animals( animal_project_code = "2014_demer", From c8f658bc70e519987cc8562300dcccc4ea79eabf Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Wed, 6 Oct 2021 16:51:12 +0200 Subject: [PATCH 045/183] Add tests for tag_type, tag_subtype --- tests/testthat/test-get_animals.R | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/tests/testthat/test-get_animals.R b/tests/testthat/test-get_animals.R index d88f3cd..9696675 100644 --- a/tests/testthat/test-get_animals.R +++ b/tests/testthat/test-get_animals.R @@ -224,3 +224,16 @@ test_that("get_animals() collapses multiple associated tags to one row", { ) expect_true(all(has_comma)) }) + +test_that("get_animals() returns correct tag_type and tag_subtype", { + df <- get_animals(con) + df <- df %>% filter(!str_detect(tag_type, ",")) # Remove multiple associated tags + expect_equal( + df %>% distinct(tag_type) %>% pull() %>% sort(), + c("", "acoustic", "acoustic-archival", "archival") + ) + expect_equal( + df %>% distinct(tag_subtype) %>% pull() %>% sort(), + c("", "animal", "built-in", "sentinel") # "range" not yet in data + ) +}) From c46144a28b97c80346bcb04c4e42b7c622b1e91b Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 6 Oct 2021 16:55:38 +0200 Subject: [PATCH 046/183] Merge pull request #199 from inbo/get_tags Remove unused get_archival_tags() function --- tests/testthat/test-get_animals.R | 49 ++++++++++++++++--------------- 1 file changed, 25 insertions(+), 24 deletions(-) diff --git a/tests/testthat/test-get_animals.R b/tests/testthat/test-get_animals.R index 9696675..33eed7f 100644 --- a/tests/testthat/test-get_animals.R +++ b/tests/testthat/test-get_animals.R @@ -8,18 +8,18 @@ test_that("get_animals() returns error for incorrect connection", { }) test_that("get_animals() returns a tibble", { - df <- get_animals() + df <- get_animals(con) expect_s3_class(df, "data.frame") expect_s3_class(df, "tbl") }) test_that("get_animals() returns unique animal_id", { - df <- get_animals() + df <- get_animals(con) expect_equal(nrow(df), nrow(df %>% distinct(animal_id))) }) test_that("get_animals() returns the expected columns", { - df <- get_animals() + df <- get_animals(con) expected_col_names <- c( "animal_id", "animal_project_code", @@ -91,13 +91,13 @@ test_that("get_animals() returns the expected columns", { test_that("get_animals() allows selecting on animal_id", { # Errors - expect_error(get_animals(animal_id = 0)) # Not an existing value - expect_error(get_animals(animal_id = c(305, 0))) - expect_error(get_animals(animal_id = 20.2)) # Not an integer + expect_error(get_animals(con, animal_id = 0)) # Not an existing value + expect_error(get_animals(con, animal_id = c(305, 0))) + expect_error(get_animals(con, animal_id = 20.2)) # Not an integer # Select single value single_select <- 305 - single_select_df <- get_animals(animal_id = single_select) + single_select_df <- get_animals(con, animal_id = single_select) expect_equal( single_select_df %>% distinct(animal_id) %>% pull(), c(single_select) @@ -106,7 +106,7 @@ test_that("get_animals() allows selecting on animal_id", { # Select multiple values multi_select <- c(304, "305") # Characters are allowed - multi_select_df <- get_animals(animal_id = multi_select) + multi_select_df <- get_animals(con, animal_id = multi_select) expect_equal( multi_select_df %>% distinct(animal_id) %>% pull() %>% sort(), c(as.integer(multi_select)) # Output will be all integer @@ -116,12 +116,12 @@ test_that("get_animals() allows selecting on animal_id", { test_that("get_animals() allows selecting on animal_project_code", { # Errors - expect_error(get_animals(animal_project_code = "not_a_project")) - expect_error(get_animals(animal_project_code = c("2014_demer", "not_a_project"))) + expect_error(get_animals(con, animal_project_code = "not_a_project")) + expect_error(get_animals(con, animal_project_code = c("2014_demer", "not_a_project"))) # Select single value single_select <- "2014_demer" - single_select_df <- get_animals(animal_project_code = single_select) + single_select_df <- get_animals(con, animal_project_code = single_select) expect_equal( single_select_df %>% distinct(animal_project_code) %>% pull(), c(single_select) @@ -130,13 +130,13 @@ test_that("get_animals() allows selecting on animal_project_code", { # Selection is case insensitive expect_equal( - get_animals(animal_project_code = "2014_demer"), - get_animals(animal_project_code = "2014_DEMER") + get_animals(con, animal_project_code = "2014_demer"), + get_animals(con, animal_project_code = "2014_DEMER") ) # Select multiple values multi_select <- c("2014_demer", "2015_dijle") - multi_select_df <- get_animals(animal_project_code = multi_select) + multi_select_df <- get_animals(con, animal_project_code = multi_select) expect_equal( multi_select_df %>% distinct(animal_project_code) %>% pull() %>% sort(), c(multi_select) @@ -146,12 +146,12 @@ test_that("get_animals() allows selecting on animal_project_code", { test_that("get_animals() allows selecting on tag_serial_number", { # Errors - expect_error(get_animals(tag_serial_number = "0")) # Not an existing value - expect_error(get_animals(tag_serial_number = c("1187450", "0"))) + expect_error(get_animals(con, tag_serial_number = "0")) # Not an existing value + expect_error(get_animals(con, tag_serial_number = c("1187450", "0"))) # Select single value single_select <- "1187450" # From 2014_demer - single_select_df <- get_animals(tag_serial_number = single_select) + single_select_df <- get_animals(con, tag_serial_number = single_select) expect_equal( single_select_df %>% distinct(tag_serial_number) %>% pull(), c(single_select) @@ -161,7 +161,7 @@ test_that("get_animals() allows selecting on tag_serial_number", { # Select multiple values multi_select <- c(1187449, "1187450") # Integers are allowed - multi_select_df <- get_animals(tag_serial_number = multi_select) + multi_select_df <- get_animals(con, tag_serial_number = multi_select) expect_equal( multi_select_df %>% distinct(tag_serial_number) %>% pull() %>% sort(), c(as.character(multi_select)) # Output will be all character @@ -171,13 +171,13 @@ test_that("get_animals() allows selecting on tag_serial_number", { test_that("get_animals() allows selecting on scientific_name", { # Errors - expect_error(get_animals(scientific_name = "not_a_sciname")) - expect_error(get_animals(scientific_name = "rutilus rutilus")) # Case sensitive - expect_error(get_animals(scientific_name = c("Rutilus rutilus", "not_a_sciname"))) + expect_error(get_animals(con, scientific_name = "not_a_sciname")) + expect_error(get_animals(con, scientific_name = "rutilus rutilus")) # Case sensitive + expect_error(get_animals(con, scientific_name = c("Rutilus rutilus", "not_a_sciname"))) # Select single value single_select <- "Rutilus rutilus" - single_select_df <- get_animals(scientific_name = single_select) + single_select_df <- get_animals(con, scientific_name = single_select) expect_equal( single_select_df %>% distinct(scientific_name) %>% pull(), c(single_select) @@ -186,7 +186,7 @@ test_that("get_animals() allows selecting on scientific_name", { # Select multiple values multi_select <- c("Rutilus rutilus", "Silurus glanis") - multi_select_df <- get_animals(scientific_name = multi_select) + multi_select_df <- get_animals(con, scientific_name = multi_select) expect_equal( multi_select_df %>% distinct(scientific_name) %>% pull() %>% sort(), c(multi_select) @@ -196,6 +196,7 @@ test_that("get_animals() allows selecting on scientific_name", { test_that("get_animals() allows selecting on multiple parameters", { multiple_parameters_df <- get_animals( + con, animal_project_code = "2014_demer", scientific_name = "Rutilus rutilus" ) @@ -205,7 +206,7 @@ test_that("get_animals() allows selecting on multiple parameters", { test_that("get_animals() collapses multiple associated tags to one row", { # Animal 5841 (project SPAWNSEIS) has 2 associated tags (1280688,1280688) - animal_two_tags_df <- get_animals(animal_id = 5841) + animal_two_tags_df <- get_animals(con, animal_id = 5841) expect_equal(nrow(animal_two_tags_df), 1) # Rows should be collapsed From 4a8a47fd3d9a690c66da44b83fb1d7a2ae8cb799 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 6 Oct 2021 22:46:43 +0200 Subject: [PATCH 047/183] Merge pull request #200 from inbo/combined_tag Create a combined tag view (tag.sql) that is used in multiple functions --- tests/testthat/test-get_animals.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-get_animals.R b/tests/testthat/test-get_animals.R index 33eed7f..2f0a600 100644 --- a/tests/testthat/test-get_animals.R +++ b/tests/testthat/test-get_animals.R @@ -231,10 +231,10 @@ test_that("get_animals() returns correct tag_type and tag_subtype", { df <- df %>% filter(!str_detect(tag_type, ",")) # Remove multiple associated tags expect_equal( df %>% distinct(tag_type) %>% pull() %>% sort(), - c("", "acoustic", "acoustic-archival", "archival") + c("", "acoustic", "acoustic-archival") # "archival" currently not in data ) expect_equal( df %>% distinct(tag_subtype) %>% pull() %>% sort(), - c("", "animal", "built-in", "sentinel") # "range" not yet in data + c("", "animal", "built-in", "sentinel") # "range" currently not in data ) }) From ed2b19aa7e366162c2eef5e63027cefd880ff2c4 Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Wed, 6 Oct 2021 23:05:39 +0200 Subject: [PATCH 048/183] Include (collapsed) acoustic_tag_id in get_animals() --- tests/testthat/test-get_animals.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-get_animals.R b/tests/testthat/test-get_animals.R index 2f0a600..54d0da8 100644 --- a/tests/testthat/test-get_animals.R +++ b/tests/testthat/test-get_animals.R @@ -26,6 +26,7 @@ test_that("get_animals() returns the expected columns", { "tag_serial_number", "tag_type", "tag_subtype", + "acoustic_tag_id", "scientific_name", "common_name", "aphia_id", @@ -210,10 +211,11 @@ test_that("get_animals() collapses multiple associated tags to one row", { expect_equal(nrow(animal_two_tags_df), 1) # Rows should be collapsed - # Columns starting with tag_ are collapsed with comma + # Columns starting with tag_ and acoustic_tag_id are collapsed with comma tag_col_names <- c( "tag_serial_number", "tag_type", + "acoustic_tag_id", "tagger", "tagging_type", "tagging_methodology" From b4a553d32da80c2ce423bf5aca3002f8ccf9dd9e Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Fri, 8 Oct 2021 10:21:31 +0200 Subject: [PATCH 049/183] Include acoustic_tag_id_alternative in get_animals() Fix ##162 --- tests/testthat/test-get_animals.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tests/testthat/test-get_animals.R b/tests/testthat/test-get_animals.R index 54d0da8..4df7cb9 100644 --- a/tests/testthat/test-get_animals.R +++ b/tests/testthat/test-get_animals.R @@ -27,6 +27,7 @@ test_that("get_animals() returns the expected columns", { "tag_type", "tag_subtype", "acoustic_tag_id", + "acoustic_tag_id_alternative", "scientific_name", "common_name", "aphia_id", @@ -216,6 +217,7 @@ test_that("get_animals() collapses multiple associated tags to one row", { "tag_serial_number", "tag_type", "acoustic_tag_id", + "acoustic_tag_id_alternative", "tagger", "tagging_type", "tagging_methodology" From 1bf02d3cfe1b6374081e905cd52d4c619761ed4f Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Fri, 8 Oct 2021 23:42:49 +0200 Subject: [PATCH 050/183] Include stringr:: for str_detect in test --- tests/testthat/test-get_animals.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-get_animals.R b/tests/testthat/test-get_animals.R index 4df7cb9..7b8c1dd 100644 --- a/tests/testthat/test-get_animals.R +++ b/tests/testthat/test-get_animals.R @@ -232,7 +232,7 @@ test_that("get_animals() collapses multiple associated tags to one row", { test_that("get_animals() returns correct tag_type and tag_subtype", { df <- get_animals(con) - df <- df %>% filter(!str_detect(tag_type, ",")) # Remove multiple associated tags + df <- df %>% filter(!stringr::str_detect(tag_type, ",")) # Remove multiple associated tags expect_equal( df %>% distinct(tag_type) %>% pull() %>% sort(), c("", "acoustic", "acoustic-archival") # "archival" currently not in data From c1784a2c3237aa39bb658105a2a497715cbaa0ee Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Tue, 12 Oct 2021 16:02:31 +0200 Subject: [PATCH 051/183] Merge pull request #221 from inbo/download_acoustic_dataset Add download_acoustic_dataset() --- tests/testthat/test-get_animals.R | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-get_animals.R b/tests/testthat/test-get_animals.R index 7b8c1dd..cb9638b 100644 --- a/tests/testthat/test-get_animals.R +++ b/tests/testthat/test-get_animals.R @@ -235,10 +235,16 @@ test_that("get_animals() returns correct tag_type and tag_subtype", { df <- df %>% filter(!stringr::str_detect(tag_type, ",")) # Remove multiple associated tags expect_equal( df %>% distinct(tag_type) %>% pull() %>% sort(), - c("", "acoustic", "acoustic-archival") # "archival" currently not in data + c("acoustic", "acoustic-archival") # "archival" currently not in data ) expect_equal( df %>% distinct(tag_subtype) %>% pull() %>% sort(), - c("", "animal", "built-in", "sentinel") # "range" currently not in data + c("animal", "built-in", "sentinel") # "range" currently not in data ) }) + +test_that("get_animals() does not return animals without tags", { + # All animals should be related with a tag + df <- get_animals(con) + expect_equal(df %>% filter(is.na(tag_serial_number)) %>% nrow(), 0) +}) From 907340fc80fbb74919a1d7da1e2d31c3640a612f Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Fri, 4 Nov 2022 12:33:16 +0100 Subject: [PATCH 052/183] Merge branch 'main' of https://github.com/inbo/etn into main --- tests/testthat/test-get_animals.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-get_animals.R b/tests/testthat/test-get_animals.R index cb9638b..c2e9f8a 100644 --- a/tests/testthat/test-get_animals.R +++ b/tests/testthat/test-get_animals.R @@ -223,7 +223,7 @@ test_that("get_animals() collapses multiple associated tags to one row", { "tagging_methodology" ) has_comma <- apply( - animal_two_tags_df %>% select(tag_col_names), + animal_two_tags_df %>% dplyr::select(tag_col_names), MARGIN = 2, function(x) grepl(pattern = ",", x = x) ) @@ -233,13 +233,14 @@ test_that("get_animals() collapses multiple associated tags to one row", { test_that("get_animals() returns correct tag_type and tag_subtype", { df <- get_animals(con) df <- df %>% filter(!stringr::str_detect(tag_type, ",")) # Remove multiple associated tags + df <- df %>% filter(tag_type != "") # TODO: remove after https://github.com/inbo/etn/issues/249 expect_equal( df %>% distinct(tag_type) %>% pull() %>% sort(), c("acoustic", "acoustic-archival") # "archival" currently not in data ) expect_equal( df %>% distinct(tag_subtype) %>% pull() %>% sort(), - c("animal", "built-in", "sentinel") # "range" currently not in data + c("animal", "built-in", "range", "sentinel") ) }) From 629de897b51ec46956a8860e6cc50300f5dd58e9 Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Mon, 21 Nov 2022 13:17:34 +0100 Subject: [PATCH 053/183] Avoid tidyselect warning --- tests/testthat/test-get_animals.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-get_animals.R b/tests/testthat/test-get_animals.R index c2e9f8a..38159a3 100644 --- a/tests/testthat/test-get_animals.R +++ b/tests/testthat/test-get_animals.R @@ -223,7 +223,7 @@ test_that("get_animals() collapses multiple associated tags to one row", { "tagging_methodology" ) has_comma <- apply( - animal_two_tags_df %>% dplyr::select(tag_col_names), + animal_two_tags_df %>% dplyr::select(dplyr::all_of(tag_col_names)), MARGIN = 2, function(x) grepl(pattern = ",", x = x) ) From 35a6f4ecfa7346825a2fb6e14fa8512fada243e3 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Fri, 8 Oct 2021 22:21:01 +0200 Subject: [PATCH 054/183] Merge pull request #214 from inbo/get_projects Split get_projects() in 3 functions --- R/get_cpod_projects.R | 69 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 69 insertions(+) create mode 100644 R/get_cpod_projects.R diff --git a/R/get_cpod_projects.R b/R/get_cpod_projects.R new file mode 100644 index 0000000..929d511 --- /dev/null +++ b/R/get_cpod_projects.R @@ -0,0 +1,69 @@ +#' Get cpod project data +#' +#' Get data for cpod projects, with options to filter results. +#' +#' @param connection A connection to the ETN database. Defaults to `con`. +#' @param cpod_project_code Character (vector). One or more cpod project +#' codes. Case-insensitive. +#' +#' @return A tibble with animal project data, sorted by `project_code`. See +#' also +#' [field definitions](https://inbo.github.io/etn/articles/etn_fields.html). +#' +#' @export +#' +#' @importFrom glue glue_sql +#' @importFrom DBI dbGetQuery +#' @importFrom dplyr .data %>% arrange as_tibble +#' @importFrom readr read_file +#' +#' @examples +#' \dontrun{ +#' # Set default connection variable +#' con <- connect_to_etn() +#' +#' # Get all animal projects +#' get_cpod_projects() +#' +#' # Get a specific animal project +#' get_animal_projects(cpod_project_code = "cpod-lifewatch") +#' } +get_cpod_projects <- function(connection = con, + cpod_project_code = NULL) { + # Check connection + check_connection(connection) + + # Check cpod_project_code + if (is.null(cpod_project_code)) { + cpod_project_code_query <- "True" + } else { + cpod_project_code <- tolower(cpod_project_code) + valid_cpod_project_codes <- tolower(list_cpod_project_codes(connection)) + check_value(cpod_project_code, valid_cpod_project_codes, "cpod_project_code") + cpod_project_code_query <- glue_sql( + "LOWER(project.project_code) IN ({cpod_project_code*})", + .con = connection + ) + } + + project_query <- glue_sql(read_file(system.file("sql", "project.sql", package = "etn")), .con = connection) + + # Build query + query <- glue_sql(" + SELECT + project.* + FROM + ({project_query}) AS project + WHERE + project_type = 'cpod' + AND {cpod_project_code_query} + ", .con = connection) + projects <- dbGetQuery(connection, query) + + # Sort data + projects <- + projects %>% + arrange(.data$project_code) + + as_tibble(projects) +} From 5fd7f745baf12e85f9c480d398f3858cb1eea75d Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Mon, 11 Oct 2021 19:10:02 +0200 Subject: [PATCH 055/183] Merge pull request #217 from inbo/use_views Use 3 of the 4 moratorium views --- R/get_cpod_projects.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/get_cpod_projects.R b/R/get_cpod_projects.R index 929d511..df2b48b 100644 --- a/R/get_cpod_projects.R +++ b/R/get_cpod_projects.R @@ -46,14 +46,14 @@ get_cpod_projects <- function(connection = con, ) } - project_query <- glue_sql(read_file(system.file("sql", "project.sql", package = "etn")), .con = connection) + project_sql <- glue_sql(read_file(system.file("sql", "project.sql", package = "etn")), .con = connection) # Build query query <- glue_sql(" SELECT project.* FROM - ({project_query}) AS project + ({project_sql}) AS project WHERE project_type = 'cpod' AND {cpod_project_code_query} From ceb84b592d4981a0b54095e4c838b0ce8dac5055 Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Wed, 13 Oct 2021 11:20:47 +0200 Subject: [PATCH 056/183] Run examples for website #227 --- R/get_cpod_projects.R | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/R/get_cpod_projects.R b/R/get_cpod_projects.R index df2b48b..abf76c9 100644 --- a/R/get_cpod_projects.R +++ b/R/get_cpod_projects.R @@ -18,16 +18,14 @@ #' @importFrom readr read_file #' #' @examples -#' \dontrun{ #' # Set default connection variable #' con <- connect_to_etn() #' #' # Get all animal projects -#' get_cpod_projects() +#' get_cpod_projects(con) #' #' # Get a specific animal project -#' get_animal_projects(cpod_project_code = "cpod-lifewatch") -#' } +#' get_cpod_projects(con, cpod_project_code = "cpod-lifewatch") get_cpod_projects <- function(connection = con, cpod_project_code = NULL) { # Check connection From d1eb6102a723fe7796edb927a5142f19b7b4a07a Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Tue, 30 Nov 2021 10:11:23 +0100 Subject: [PATCH 057/183] Merge pull request #241 from inbo/importFrom Fix #240: use :: over importFrom --- R/get_cpod_projects.R | 20 +++++++++----------- 1 file changed, 9 insertions(+), 11 deletions(-) diff --git a/R/get_cpod_projects.R b/R/get_cpod_projects.R index abf76c9..7499dad 100644 --- a/R/get_cpod_projects.R +++ b/R/get_cpod_projects.R @@ -12,11 +12,6 @@ #' #' @export #' -#' @importFrom glue glue_sql -#' @importFrom DBI dbGetQuery -#' @importFrom dplyr .data %>% arrange as_tibble -#' @importFrom readr read_file -#' #' @examples #' # Set default connection variable #' con <- connect_to_etn() @@ -38,16 +33,19 @@ get_cpod_projects <- function(connection = con, cpod_project_code <- tolower(cpod_project_code) valid_cpod_project_codes <- tolower(list_cpod_project_codes(connection)) check_value(cpod_project_code, valid_cpod_project_codes, "cpod_project_code") - cpod_project_code_query <- glue_sql( + cpod_project_code_query <- glue::glue_sql( "LOWER(project.project_code) IN ({cpod_project_code*})", .con = connection ) } - project_sql <- glue_sql(read_file(system.file("sql", "project.sql", package = "etn")), .con = connection) + project_sql <- glue::glue_sql( + readr::read_file(system.file("sql", "project.sql", package = "etn")), + .con = connection + ) # Build query - query <- glue_sql(" + query <- glue::glue_sql(" SELECT project.* FROM @@ -56,12 +54,12 @@ get_cpod_projects <- function(connection = con, project_type = 'cpod' AND {cpod_project_code_query} ", .con = connection) - projects <- dbGetQuery(connection, query) + projects <- DBI::dbGetQuery(connection, query) # Sort data projects <- projects %>% - arrange(.data$project_code) + dplyr::arrange(.data$project_code) - as_tibble(projects) + dplyr::as_tibble(projects) } From b66b01fdf41e7a3893c96d89e0d4b12c0ce945ae Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Fri, 9 Dec 2022 16:44:01 +0100 Subject: [PATCH 058/183] Merge pull request #257 from inbo/dwc Add `write_dwc()` function --- R/get_cpod_projects.R | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/R/get_cpod_projects.R b/R/get_cpod_projects.R index 7499dad..d1c214c 100644 --- a/R/get_cpod_projects.R +++ b/R/get_cpod_projects.R @@ -30,9 +30,12 @@ get_cpod_projects <- function(connection = con, if (is.null(cpod_project_code)) { cpod_project_code_query <- "True" } else { - cpod_project_code <- tolower(cpod_project_code) - valid_cpod_project_codes <- tolower(list_cpod_project_codes(connection)) - check_value(cpod_project_code, valid_cpod_project_codes, "cpod_project_code") + cpod_project_code <- check_value( + cpod_project_code, + list_cpod_project_codes(connection), + "cpod_project_code", + lowercase = TRUE + ) cpod_project_code_query <- glue::glue_sql( "LOWER(project.project_code) IN ({cpod_project_code*})", .con = connection From 05e065d270d6af04451b4bf6903f9496a1e39857 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Fri, 8 Oct 2021 22:21:01 +0200 Subject: [PATCH 059/183] Merge pull request #214 from inbo/get_projects Split get_projects() in 3 functions --- tests/testthat/test-get_cpod_projects.R | 77 +++++++++++++++++++++++++ 1 file changed, 77 insertions(+) create mode 100644 tests/testthat/test-get_cpod_projects.R diff --git a/tests/testthat/test-get_cpod_projects.R b/tests/testthat/test-get_cpod_projects.R new file mode 100644 index 0000000..be42fc2 --- /dev/null +++ b/tests/testthat/test-get_cpod_projects.R @@ -0,0 +1,77 @@ +con <- connect_to_etn() + +test_that("get_cpod_projects() returns error for incorrect connection", { + expect_error( + get_cpod_projects(con = "not_a_connection"), + "Not a connection object to database." + ) +}) + +test_that("get_cpod_projects() returns a tibble", { + df <- get_cpod_projects(con) + expect_s3_class(df, "data.frame") + expect_s3_class(df, "tbl") +}) + +test_that("get_cpod_projects() returns unique project_id", { + df <- get_cpod_projects(con) + expect_equal(nrow(df), nrow(df %>% distinct(project_id))) +}) + +test_that("get_cpod_projects() returns the expected columns", { + df <- get_cpod_projects(con) + expected_col_names <- c( + "project_id", + "project_code", + "project_type", + "telemetry_type", + "project_name", + # "coordinating_organization", + # "principal_investigator", + # "principal_investigator_email", + "start_date", + "end_date", + "latitude", + "longitude", + "moratorium", + "imis_dataset_id" + ) + expect_equal(names(df), expected_col_names) +}) + +test_that("get_cpod_projects() allows selecting on cpod_project_code", { + # Errors + expect_error(get_cpod_projects(con, cpod_project_code = "not_a_project")) + expect_error(get_cpod_projects(con, cpod_project_code = c("cpod-lifewatch", "not_a_project"))) + + # Select single value + single_select <- "cpod-lifewatch" + single_select_df <- get_cpod_projects(con, cpod_project_code = single_select) + expect_equal( + single_select_df %>% distinct(project_code) %>% pull(), + c(single_select) + ) + expect_equal(nrow(single_select_df), 1) + + # Selection is case insensitive + expect_equal( + get_cpod_projects(con, cpod_project_code = "cpod-lifewatch"), + get_cpod_projects(con, cpod_project_code = "CPOD-LIFEWATCH") + ) + + # Select multiple values + multi_select <- c("cpod-lifewatch", "cpod-od-natuur") + multi_select_df <- get_cpod_projects(con, cpod_project_code = multi_select) + expect_equal( + multi_select_df %>% distinct(project_code) %>% pull() %>% sort(), + c(multi_select) + ) + expect_equal(nrow(multi_select_df), 2) +}) + +test_that("get_cpod_projects() returns projects of type 'cpod'", { + expect_equal( + get_cpod_projects(con) %>% distinct(project_type) %>% pull(), + "cpod" + ) +}) From 803a92117fda12586ebc1a960934e89d4df77415 Mon Sep 17 00:00:00 2001 From: Stijn Van Hoey Date: Thu, 26 Apr 2018 16:08:01 +0200 Subject: [PATCH 060/183] Merge pull request #11 from inbo/loadings Provide blueprint for the package functionalities --- R/get_tags.R | 5 +++++ 1 file changed, 5 insertions(+) create mode 100644 R/get_tags.R diff --git a/R/get_tags.R b/R/get_tags.R new file mode 100644 index 0000000..b5fcd6f --- /dev/null +++ b/R/get_tags.R @@ -0,0 +1,5 @@ + +get_tags <- function(connection, + animal_project = NULL) { + NULL +} From 62bd94547c051775b746bcc7ad6fe1fe1929e3e5 Mon Sep 17 00:00:00 2001 From: Stijn Van Hoey Date: Fri, 27 Apr 2018 10:40:08 +0200 Subject: [PATCH 061/183] Merge pull request #13 from inbo/setup-connection Setup connection --- R/get_tags.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/get_tags.R b/R/get_tags.R index b5fcd6f..720b69d 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -1,3 +1,4 @@ +# tags (no view?) get_tags <- function(connection, animal_project = NULL) { From e4c64ae51b952a68e58f98f6e95073ec101ad18c Mon Sep 17 00:00:00 2001 From: stijnvanhoey Date: Fri, 27 Apr 2018 16:57:58 +0200 Subject: [PATCH 062/183] Create tags query functionality --- R/get_tags.R | 27 ++++++++++++++++++++++++--- 1 file changed, 24 insertions(+), 3 deletions(-) diff --git a/R/get_tags.R b/R/get_tags.R index 720b69d..3430e9b 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -1,6 +1,27 @@ -# tags (no view?) - get_tags <- function(connection, animal_project = NULL) { - NULL + + check_connection(connection) + + # valid inputs on animal projects + valid_animals_projects <- + get_projects(connection, project_type = "animal") %>% + pull(projectcode) + check_null_or_value(animal_project, valid_animals_projects, "animal_project") + if (is.null(animal_project)) { + animal_project = valid_animals_projects + } + + tags_query <- glue_sql(" + SELECT tags.*, animals.projectcode + FROM vliz.tags + LEFT JOIN vliz.animal_tag_release ON (animal_tag_release.tag_fk = tags.id_pk) + LEFT JOIN vliz.animals_view animals ON (animals.id_pk = animal_tag_release.animal_fk) + WHERE projectcode IN ({project*})", + project = animal_project, + .con = connection + ) + tags <- dbGetQuery(connection, tags_query) + tags + } From 392bb883e14c9091c75bf593a23ecd28c0e260ac Mon Sep 17 00:00:00 2001 From: stijnvanhoey Date: Fri, 27 Apr 2018 17:08:25 +0200 Subject: [PATCH 063/183] Exclude the projectcode IS NULL and only show tags linked to project --- R/get_tags.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/get_tags.R b/R/get_tags.R index 3430e9b..c7634a9 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -17,7 +17,7 @@ get_tags <- function(connection, FROM vliz.tags LEFT JOIN vliz.animal_tag_release ON (animal_tag_release.tag_fk = tags.id_pk) LEFT JOIN vliz.animals_view animals ON (animals.id_pk = animal_tag_release.animal_fk) - WHERE projectcode IN ({project*})", + WHERE projectcode IN ({project*}) OR projectcode IS NULL", project = animal_project, .con = connection ) From e84f125f109a1234b96dc903cb9bc0f89760e113 Mon Sep 17 00:00:00 2001 From: stijnvanhoey Date: Fri, 27 Apr 2018 17:09:18 +0200 Subject: [PATCH 064/183] Exclude the projectcode IS NULL and only show tags linked to project --- R/get_tags.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/get_tags.R b/R/get_tags.R index c7634a9..3430e9b 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -17,7 +17,7 @@ get_tags <- function(connection, FROM vliz.tags LEFT JOIN vliz.animal_tag_release ON (animal_tag_release.tag_fk = tags.id_pk) LEFT JOIN vliz.animals_view animals ON (animals.id_pk = animal_tag_release.animal_fk) - WHERE projectcode IN ({project*}) OR projectcode IS NULL", + WHERE projectcode IN ({project*})", project = animal_project, .con = connection ) From 6c1d6b3697f2c1db09c0f0098dc712ad7e1b85ed Mon Sep 17 00:00:00 2001 From: Stijn Van Hoey Date: Mon, 30 Apr 2018 15:04:56 +0200 Subject: [PATCH 065/183] Merge pull request #25 from inbo/tags Provide draft roxygent header for tags --- R/get_tags.R | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/R/get_tags.R b/R/get_tags.R index 3430e9b..2f58421 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -1,3 +1,25 @@ +#' Get tags metadata +#' +#' At the moment, only tags that can be linked to a projectcode are returned to +#' the user. +#' +#' @param connection A valid connection with the ETN database. +#' @param animal_project (string) One or more animal projects. +#' +#' @return A data.frame. +#' +#' @export +#' +#' @importFrom glue glue_sql +#' @importFrom DBI dbGetQuery +#' @importFrom dplyr pull +#' +#' @examples +#' \dontrun{ +#' get_tags(con) +#' get_tags(con, animal_project = c("phd_reubens")) +#' } + get_tags <- function(connection, animal_project = NULL) { From fa6b44b5aed70fbfd3953c709a4c71645e9349f0 Mon Sep 17 00:00:00 2001 From: Damiano Oldoni Date: Mon, 30 Apr 2018 16:42:58 +0200 Subject: [PATCH 066/183] Merge pull request #31 from inbo/documentation Documentation --- R/get_tags.R | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/R/get_tags.R b/R/get_tags.R index 2f58421..c9f9384 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -1,7 +1,7 @@ #' Get tags metadata #' -#' At the moment, only tags that can be linked to a projectcode are returned to -#' the user. +#' Get the metadata about the transmitter tags. At the moment, only tags that +#' can be linked to a projectcode are returned to the user. #' #' @param connection A valid connection with the ETN database. #' @param animal_project (string) One or more animal projects. @@ -12,14 +12,17 @@ #' #' @importFrom glue glue_sql #' @importFrom DBI dbGetQuery -#' @importFrom dplyr pull +#' @importFrom dplyr pull %>% #' #' @examples #' \dontrun{ -#' get_tags(con) -#' get_tags(con, animal_project = c("phd_reubens")) +#' # Get the metadata of all transmitter tags +#' get_tags(con) +#' +#' # Get the metadata of the tags linked to specific project(s) +#' get_tags(con, animal_project = "phd_reubens") +#' get_tags(con, animal_project = c("phd_reubens", "2013_albertkanaal")) #' } - get_tags <- function(connection, animal_project = NULL) { @@ -28,7 +31,7 @@ get_tags <- function(connection, # valid inputs on animal projects valid_animals_projects <- get_projects(connection, project_type = "animal") %>% - pull(projectcode) + pull("projectcode") check_null_or_value(animal_project, valid_animals_projects, "animal_project") if (is.null(animal_project)) { animal_project = valid_animals_projects From 05c9222fed09f17d5b69a54029192adf7c825164 Mon Sep 17 00:00:00 2001 From: Stijn Van Hoey Date: Mon, 30 Apr 2018 17:25:47 +0200 Subject: [PATCH 067/183] Merge pull request #32 from inbo/quick-fix-nse Quick fix nse --- R/get_tags.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/get_tags.R b/R/get_tags.R index c9f9384..354b580 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -13,9 +13,12 @@ #' @importFrom glue glue_sql #' @importFrom DBI dbGetQuery #' @importFrom dplyr pull %>% +#' @importFrom rlang .data #' #' @examples #' \dontrun{ +#' con <- connect_to_etn(your_username, your_password) +#' #' # Get the metadata of all transmitter tags #' get_tags(con) #' @@ -31,7 +34,7 @@ get_tags <- function(connection, # valid inputs on animal projects valid_animals_projects <- get_projects(connection, project_type = "animal") %>% - pull("projectcode") + pull(.data$projectcode) check_null_or_value(animal_project, valid_animals_projects, "animal_project") if (is.null(animal_project)) { animal_project = valid_animals_projects From c943e92a16861107007b362e81cffdc94d1ced8a Mon Sep 17 00:00:00 2001 From: Stijn Van Hoey Date: Mon, 30 Apr 2018 21:29:03 +0200 Subject: [PATCH 068/183] Merge pull request #35 from inbo/tag-to-transmitter Tag to transmitter --- R/get_tags.R | 55 ---------------------------------------------------- 1 file changed, 55 deletions(-) delete mode 100644 R/get_tags.R diff --git a/R/get_tags.R b/R/get_tags.R deleted file mode 100644 index 354b580..0000000 --- a/R/get_tags.R +++ /dev/null @@ -1,55 +0,0 @@ -#' Get tags metadata -#' -#' Get the metadata about the transmitter tags. At the moment, only tags that -#' can be linked to a projectcode are returned to the user. -#' -#' @param connection A valid connection with the ETN database. -#' @param animal_project (string) One or more animal projects. -#' -#' @return A data.frame. -#' -#' @export -#' -#' @importFrom glue glue_sql -#' @importFrom DBI dbGetQuery -#' @importFrom dplyr pull %>% -#' @importFrom rlang .data -#' -#' @examples -#' \dontrun{ -#' con <- connect_to_etn(your_username, your_password) -#' -#' # Get the metadata of all transmitter tags -#' get_tags(con) -#' -#' # Get the metadata of the tags linked to specific project(s) -#' get_tags(con, animal_project = "phd_reubens") -#' get_tags(con, animal_project = c("phd_reubens", "2013_albertkanaal")) -#' } -get_tags <- function(connection, - animal_project = NULL) { - - check_connection(connection) - - # valid inputs on animal projects - valid_animals_projects <- - get_projects(connection, project_type = "animal") %>% - pull(.data$projectcode) - check_null_or_value(animal_project, valid_animals_projects, "animal_project") - if (is.null(animal_project)) { - animal_project = valid_animals_projects - } - - tags_query <- glue_sql(" - SELECT tags.*, animals.projectcode - FROM vliz.tags - LEFT JOIN vliz.animal_tag_release ON (animal_tag_release.tag_fk = tags.id_pk) - LEFT JOIN vliz.animals_view animals ON (animals.id_pk = animal_tag_release.animal_fk) - WHERE projectcode IN ({project*})", - project = animal_project, - .con = connection - ) - tags <- dbGetQuery(connection, tags_query) - tags - -} From fa3a5d757ae706b6819bd0398133f6d6f140e9f0 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Fri, 21 Feb 2020 17:06:48 +0100 Subject: [PATCH 069/183] Merge pull request #93 from inbo/new_views Use new views --- R/get_tags.R | 69 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 69 insertions(+) create mode 100644 R/get_tags.R diff --git a/R/get_tags.R b/R/get_tags.R new file mode 100644 index 0000000..baec188 --- /dev/null +++ b/R/get_tags.R @@ -0,0 +1,69 @@ +#' Get tag metadata +#' +#' Get metadata for tags. Only returns tags that can be linked to an animal (and +#' thus an animal project). By default, reference tags are excluded. +#' +#' @param connection A valid connection with the ETN database. +#' @param animal_project_code (string) One or more animal projects. +#' @param include_reference_tags (logical) Include reference tags. Default: +#' `FALSE`. +#' +#' @return A tibble (tidyverse data.frame). +#' +#' @export +#' +#' @importFrom glue glue_sql +#' @importFrom DBI dbGetQuery +#' @importFrom dplyr pull %>% +#' @importFrom rlang .data +#' @importFrom tibble as_tibble +#' +#' @examples +#' \dontrun{ +#' con <- connect_to_etn(your_username, your_password) +#' +#' # Get all (animal) tags +#' get_tags(con) +#' +#' # Get all tags, including reference tags +#' get_tags(con, include_reference_tags = TRUE) +#' +#' # Get tags linked to specific animal project(s) +#' get_tags(con, animal_project_code = "phd_reubens") +#' get_tags(con, animal_project_code = c("phd_reubens", "2012_leopoldkanaal")) +#' } +get_tags <- function(connection, + animal_project_code = NULL, + include_reference_tags = FALSE) { + # Check connection + check_connection(connection) + + # Check animal_project_code + if (is.null(animal_project_code)) { + animal_project_code_query <- "True" + } else { + valid_animal_project_codes <- list_animal_project_codes(connection) + check_value(animal_project_code, valid_animal_project_codes, "animal_project_code") + animal_project_code_query <- glue_sql("animal_project_code IN ({animal_project_code*})", .con = connection) + } + + # Build query + query <- glue_sql(" + SELECT tags.* + FROM vliz.tags_view2 AS tags + LEFT JOIN vliz.animals_view2 AS animals + ON animals.tag_fk = tags.pk + WHERE + {animal_project_code_query} + ", .con = connection) + tags <- dbGetQuery(connection, query) + + # Filter on reference tags + if (include_reference_tags) { + tags + } else { + tags %>% filter(.data$type == "animal") + } + + as_tibble(tags) +} From f9e163e5581728360bb57499fa2d72f87b1d40b1 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 26 Feb 2020 14:38:06 +0100 Subject: [PATCH 070/183] Merge pull request #101 from inbo/update_parameters Update parameters for get_tags and get_receivers --- R/get_tags.R | 47 +++++++++++++++++++++++------------------------ 1 file changed, 23 insertions(+), 24 deletions(-) diff --git a/R/get_tags.R b/R/get_tags.R index baec188..8503088 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -1,11 +1,11 @@ #' Get tag metadata #' -#' Get metadata for tags. Only returns tags that can be linked to an animal (and -#' thus an animal project). By default, reference tags are excluded. +#' Get metadata for tags, with option to filter on tag id. By default, reference +#' tags are excluded. #' #' @param connection A valid connection with the ETN database. -#' @param animal_project_code (string) One or more animal projects. -#' @param include_reference_tags (logical) Include reference tags. Default: +#' @param tag_id (string) One or more tag ids. +#' @param include_ref_tags (logical) Include reference tags. Default: #' `FALSE`. #' #' @return A tibble (tidyverse data.frame). @@ -26,43 +26,42 @@ #' get_tags(con) #' #' # Get all tags, including reference tags -#' get_tags(con, include_reference_tags = TRUE) +#' get_tags(con, include_ref_tags = TRUE) #' -#' # Get tags linked to specific animal project(s) -#' get_tags(con, animal_project_code = "phd_reubens") -#' get_tags(con, animal_project_code = c("phd_reubens", "2012_leopoldkanaal")) +#' # Get specific tags (will automatically set include_ref_tags = TRUE) +#' get_tags(con, tag_id = "A69-1303-65313") +#' get_tags(con, tag_id = c("A69-1601-1705", "A69-1601-1707")) #' } -get_tags <- function(connection, - animal_project_code = NULL, - include_reference_tags = FALSE) { +get_tags <- function(connection = con, + tag_id = NULL, + include_ref_tags = FALSE) { # Check connection check_connection(connection) - # Check animal_project_code - if (is.null(animal_project_code)) { - animal_project_code_query <- "True" + # Check tag_id + if (is.null(tag_id)) { + tag_id_query <- "True" } else { - valid_animal_project_codes <- list_animal_project_codes(connection) - check_value(animal_project_code, valid_animal_project_codes, "animal_project_code") - animal_project_code_query <- glue_sql("animal_project_code IN ({animal_project_code*})", .con = connection) + valid_tag_ids <- list_tag_ids(connection) + check_value(tag_id, valid_tag_ids, "tag_id") + tag_id_query <- glue_sql("tag_id IN ({tag_id*})", .con = connection) + include_ref_tags <- TRUE } # Build query query <- glue_sql(" - SELECT tags.* - FROM vliz.tags_view2 AS tags - LEFT JOIN vliz.animals_view2 AS animals - ON animals.tag_fk = tags.pk + SELECT * + FROM vliz.tags_view2 WHERE - {animal_project_code_query} + {tag_id_query} ", .con = connection) tags <- dbGetQuery(connection, query) # Filter on reference tags - if (include_reference_tags) { + if (include_ref_tags) { tags } else { - tags %>% filter(.data$type == "animal") + tags <- tags %>% filter(.data$type == "animal") } as_tibble(tags) From e1aceb67207cfc03d36e65ec969cbf309429c504 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 18 Mar 2020 12:43:12 +0100 Subject: [PATCH 071/183] Merge pull request #106 from inbo/solve-animal-tag-relationship Solve animal tag relationship --- R/get_tags.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/R/get_tags.R b/R/get_tags.R index 8503088..2d13302 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -14,9 +14,8 @@ #' #' @importFrom glue glue_sql #' @importFrom DBI dbGetQuery -#' @importFrom dplyr pull %>% +#' @importFrom dplyr pull %>% as_tibble #' @importFrom rlang .data -#' @importFrom tibble as_tibble #' #' @examples #' \dontrun{ From 161098fdf7b288caf5cd63eaadfcebbe48970c0a Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 2 Sep 2020 10:42:20 +0200 Subject: [PATCH 072/183] Merge pull request #123 from inbo/order_by Order returned results --- R/get_tags.R | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/R/get_tags.R b/R/get_tags.R index 2d13302..c8682ef 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -8,14 +8,14 @@ #' @param include_ref_tags (logical) Include reference tags. Default: #' `FALSE`. #' -#' @return A tibble (tidyverse data.frame). +#' @return A tibble (tidyverse data.frame) with metadata for tags, sorted by +#' `tag_id`. #' #' @export #' #' @importFrom glue glue_sql #' @importFrom DBI dbGetQuery -#' @importFrom dplyr pull %>% as_tibble -#' @importFrom rlang .data +#' @importFrom dplyr %>% arrange as_tibble filter #' #' @examples #' \dontrun{ @@ -38,10 +38,10 @@ get_tags <- function(connection = con, check_connection(connection) # Check tag_id + valid_tag_ids <- list_tag_ids(connection) if (is.null(tag_id)) { tag_id_query <- "True" } else { - valid_tag_ids <- list_tag_ids(connection) check_value(tag_id, valid_tag_ids, "tag_id") tag_id_query <- glue_sql("tag_id IN ({tag_id*})", .con = connection) include_ref_tags <- TRUE @@ -49,8 +49,10 @@ get_tags <- function(connection = con, # Build query query <- glue_sql(" - SELECT * - FROM vliz.tags_view2 + SELECT + * + FROM + vliz.tags_view2 WHERE {tag_id_query} ", .con = connection) @@ -63,5 +65,10 @@ get_tags <- function(connection = con, tags <- tags %>% filter(.data$type == "animal") } + # Sort data + tags <- + tags %>% + arrange(factor(tag_id, levels = valid_tag_ids)) # valid_tag_ids defined above + as_tibble(tags) } From 7226abb49482bd966620124a7b91a5f5a169b50b Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Mon, 12 Oct 2020 15:11:32 +0200 Subject: [PATCH 073/183] Merge pull request #131 from inbo/receiver_status Move (receiver_)status from get_deployments() to get_receivers() --- R/get_tags.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/get_tags.R b/R/get_tags.R index c8682ef..abb6367 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -1,6 +1,6 @@ #' Get tag metadata #' -#' Get metadata for tags, with option to filter on tag id. By default, reference +#' Get metadata for tags, with options to filter results. By default, reference #' tags are excluded. #' #' @param connection A valid connection with the ETN database. From 39b02008d1bef3860796d90895811d249917ae60 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Thu, 15 Oct 2020 12:03:25 +0200 Subject: [PATCH 074/183] Merge pull request #132 from inbo/download_dataset Create function to download dataset --- R/get_tags.R | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/R/get_tags.R b/R/get_tags.R index abb6367..ce67d9d 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -1,15 +1,15 @@ -#' Get tag metadata +#' Get tag data #' -#' Get metadata for tags, with options to filter results. By default, reference +#' Get data for tags, with options to filter results. By default, reference #' tags are excluded. #' -#' @param connection A valid connection with the ETN database. -#' @param tag_id (string) One or more tag ids. -#' @param include_ref_tags (logical) Include reference tags. Default: +#' @param connection A connection to the ETN database. Defaults to `con`. +#' @param tag_id Character (vector). One or more tag ids. +#' @param include_ref_tags Logical. Include reference tags. Defaults to #' `FALSE`. #' -#' @return A tibble (tidyverse data.frame) with metadata for tags, sorted by -#' `tag_id`. +#' @return A tibble with tags data, sorted by `tag_id`. See also +#' [field definitions](https://inbo.github.io/etn/articles/etn_fields.html). #' #' @export #' From 6721697011621c63e70e9f948db51c97ddbefb56 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Mon, 17 May 2021 15:49:06 +0200 Subject: [PATCH 075/183] Merge pull request #154 from inbo/old_db Restore functionality with old database --- R/get_tags.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/get_tags.R b/R/get_tags.R index ce67d9d..2ff2879 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -52,7 +52,7 @@ get_tags <- function(connection = con, SELECT * FROM - vliz.tags_view2 + acoustic.tags_view2 WHERE {tag_id_query} ", .con = connection) From a7f77ce3aea6fec9c3104403122768823ea585fc Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Tue, 5 Oct 2021 14:55:12 +0200 Subject: [PATCH 076/183] Merge pull request #191 from inbo/sql_views New functions (part 1) --- R/get_tags.R | 74 ---------------------------------------------------- 1 file changed, 74 deletions(-) delete mode 100644 R/get_tags.R diff --git a/R/get_tags.R b/R/get_tags.R deleted file mode 100644 index 2ff2879..0000000 --- a/R/get_tags.R +++ /dev/null @@ -1,74 +0,0 @@ -#' Get tag data -#' -#' Get data for tags, with options to filter results. By default, reference -#' tags are excluded. -#' -#' @param connection A connection to the ETN database. Defaults to `con`. -#' @param tag_id Character (vector). One or more tag ids. -#' @param include_ref_tags Logical. Include reference tags. Defaults to -#' `FALSE`. -#' -#' @return A tibble with tags data, sorted by `tag_id`. See also -#' [field definitions](https://inbo.github.io/etn/articles/etn_fields.html). -#' -#' @export -#' -#' @importFrom glue glue_sql -#' @importFrom DBI dbGetQuery -#' @importFrom dplyr %>% arrange as_tibble filter -#' -#' @examples -#' \dontrun{ -#' con <- connect_to_etn(your_username, your_password) -#' -#' # Get all (animal) tags -#' get_tags(con) -#' -#' # Get all tags, including reference tags -#' get_tags(con, include_ref_tags = TRUE) -#' -#' # Get specific tags (will automatically set include_ref_tags = TRUE) -#' get_tags(con, tag_id = "A69-1303-65313") -#' get_tags(con, tag_id = c("A69-1601-1705", "A69-1601-1707")) -#' } -get_tags <- function(connection = con, - tag_id = NULL, - include_ref_tags = FALSE) { - # Check connection - check_connection(connection) - - # Check tag_id - valid_tag_ids <- list_tag_ids(connection) - if (is.null(tag_id)) { - tag_id_query <- "True" - } else { - check_value(tag_id, valid_tag_ids, "tag_id") - tag_id_query <- glue_sql("tag_id IN ({tag_id*})", .con = connection) - include_ref_tags <- TRUE - } - - # Build query - query <- glue_sql(" - SELECT - * - FROM - acoustic.tags_view2 - WHERE - {tag_id_query} - ", .con = connection) - tags <- dbGetQuery(connection, query) - - # Filter on reference tags - if (include_ref_tags) { - tags - } else { - tags <- tags %>% filter(.data$type == "animal") - } - - # Sort data - tags <- - tags %>% - arrange(factor(tag_id, levels = valid_tag_ids)) # valid_tag_ids defined above - - as_tibble(tags) -} From edb4a2389363f8cf15d8d6ea52c5d3e51f4939a0 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 6 Oct 2021 15:38:54 +0200 Subject: [PATCH 077/183] Merge pull request #196 from inbo/get_tags Create single get_tags() function --- R/get_tags.R | 269 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 269 insertions(+) create mode 100644 R/get_tags.R diff --git a/R/get_tags.R b/R/get_tags.R new file mode 100644 index 0000000..b854d67 --- /dev/null +++ b/R/get_tags.R @@ -0,0 +1,269 @@ +#' Get tag data +#' +#' Get data for tags, with options to filter results. Note that there +#' can be multiple records (`acoustic_tag_id`) per tag device +#' (`tag_serial_number`). +#' +#' @param connection A connection to the ETN database. Defaults to `con`. +#' @param tag_serial_number Character (vector). One or more tag serial numbers. +#' @param tag_type Character (vector). `acoustic` or `archival`. Some tags are +#' both, find those with `acoustic-archival`. +#' @param tag_subtype Character (vector). `animal`, `built-in`, `range` or +#' `sentinel`. +#' @param acoustic_tag_id Character (vector). One or more acoustic tag +#' identifiers. These are the identifiers found in acoustic detections. +#' +#' @return A tibble with tags data, sorted by `tag_serial_number`. See also +#' [field definitions](https://inbo.github.io/etn/articles/etn_fields.html). +#' +#' @export +#' +#' @importFrom glue glue_sql +#' @importFrom DBI dbGetQuery +#' @importFrom dplyr %>% arrange as_tibble +#' +#' @examples +#' \dontrun{ +#' # Set default connection variable +#' con <- connect_to_etn() +#' +#' # Get all tags +#' get_tags() +#' +#' # Get archival tags, including acoustic-archival +#' get_tags(tag_type = c("archival", "acoustic-archival")) +#' +#' # Get tags of specific subtype +#' get_tags(tag_subtype = c("built-in", "range")) +#' +#' # Get specific tags +#' get_tags(tag_serial_number = "1187450") +#' get_tags(acoustic_tag_id = "A69-1601-16130") +#' get_tags(acoustic_tag_id = c("A69-1601-16129", "A69-1601-16130")) +#' } +get_tags <- function(connection = con, + tag_type = NULL, + tag_subtype = NULL, + tag_serial_number = NULL, + acoustic_tag_id = NULL) { + # Check connection + check_connection(connection) + + # Check tag_serial_number + if (is.null(tag_serial_number)) { + tag_serial_number_query <- "True" + } else { + valid_tag_serial_numbers <- list_tag_serial_numbers(connection) + tag_serial_number <- as.character(tag_serial_number) # Cast to character + check_value(tag_serial_number, valid_tag_serial_numbers, "tag_serial_number") + tag_serial_number_query <- glue_sql("tag_serial_number IN ({tag_serial_number*})", .con = connection) + } + + # Check tag_type + if (is.null(tag_type)) { + tag_type_query <- "True" + } else { + valid_tag_types <- c("acoustic", "archival", "acoustic-archival") + check_value(tag_type, valid_tag_types, "tag_type") + tag_type_query <- glue_sql("tag_type IN ({tag_type*})", .con = connection) + } + + # Check tag_subtype + if (is.null(tag_subtype)) { + tag_subtype_query <- "True" + } else { + valid_tag_subtypes <- c("animal", "built-in", "range", "sentinel") + check_value(tag_subtype, valid_tag_subtypes, "tag_subtype") + tag_subtype_query <- glue_sql("tag_subtype IN ({tag_subtype*})", .con = connection) + } + + # Check acoustic_tag_id + if (is.null(acoustic_tag_id)) { + acoustic_tag_id_query <- "True" + } else { + valid_acoustic_tag_ids <- list_acoustic_tag_ids(connection) + check_value(acoustic_tag_id, valid_acoustic_tag_ids, "acoustic_tag_id") + acoustic_tag_id_query <- glue_sql("acoustic_tag_id IN ({acoustic_tag_id*})", .con = connection) + } + + # Build query + query <- glue_sql(" + WITH + combined_tag AS ( + SELECT + -- id_pk, + tag_device_fk, + sensor_type, + tag_full_id, + thelma_converted_code, + -- tag_code_space AS protocol, + -- id_code, + frequency, + slope, + intercept, + range, + sensor_transmit_ratio, + accelerometer_algoritm, + accelerometer_samples_per_second, + min_delay, + max_delay, + power, + duration_step1, + acceleration_on_sec_step1, + min_delay_step2, + max_delay_step2, + power_step2, + duration_step2, + acceleration_on_sec_step2, + min_delay_step3, + max_delay_step3, + power_step3, + duration_step3, + acceleration_on_sec_step3, + min_delay_step4, + max_delay_step4, + power_step4, + duration_step4, + acceleration_on_sec_step4 + -- file, + -- units, + -- external_id + FROM + acoustic.tags + + UNION + + SELECT + -- id_pk, + device_tag_fk AS tag_device_fk, + sensor_type.description AS sensor_type, + CASE + WHEN sensor_full_id IS NOT NULL THEN sensor_full_id + WHEN protocol IS NOT NULL AND id_code IS NOT NULL THEN CONCAT(protocol, '-', id_code) + END AS tag_full_id, + NULL AS thelma_converted_code, + -- protocol, + -- id_code, + frequency, + slope, + intercept, + range, + sensor_transmit_ratio, + accelerometer_algoritm, + accelerometer_samples_per_second, + min_delay, + max_delay, + power, + duration_step1, + acceleration_on_sec_step1, + min_delay_step2, + max_delay_step2, + power_step2, + duration_step2, + acceleration_on_sec_step2, + min_delay_step3, + max_delay_step3, + power_step3, + duration_step3, + acceleration_on_sec_step3, + min_delay_step4, + max_delay_step4, + power_step4, + duration_step4, + acceleration_on_sec_step4 + -- resolution + -- unit + -- accurency + -- range_min + -- range_max + FROM + archive.sensor AS archival_tag + LEFT JOIN archive.sensor_type AS sensor_type + ON archival_tag.sensor_type_fk = sensor_type.id_pk + ) + + SELECT * FROM ( + SELECT + tag.serial_number AS tag_serial_number, + CASE + WHEN tag_type.name = 'id-tag' THEN 'acoustic' + WHEN tag_type.name = 'sensor-tag' AND tag_full_id IS NOT NULL THEN 'acoustic-archival' + WHEN tag_type.name = 'sensor-tag' THEN 'archival' + END AS tag_type, + CASE + WHEN tag_subtype.name = 'animal' THEN 'animal' + WHEN tag_subtype.name = 'built-in tag' THEN 'built-in' + WHEN tag_subtype.name = 'range tag' THEN 'range' + WHEN tag_subtype.name = 'sentinel tag' THEN 'sentinel' + END AS tag_subtype, + combined_tag.sensor_type AS sensor_type, + combined_tag.tag_full_id AS acoustic_tag_id, + combined_tag.thelma_converted_code AS acoustic_tag_id_alternative, + manufacturer.project AS manufacturer, + tag.model AS model, + combined_tag.frequency AS frequency, + tag_status.name AS status, + tag.activation_date AS activation_date, + tag.battery_estimated_lifetime AS battery_estimated_life, + tag.battery_estimated_end_date AS battery_estimated_end_date, + combined_tag.slope AS sensor_slope, + combined_tag.intercept AS sensor_intercept, + combined_tag.range AS sensor_range, + combined_tag.sensor_transmit_ratio AS sensor_transmit_ratio, + combined_tag.accelerometer_algoritm AS accelerometer_algorithm, + combined_tag.accelerometer_samples_per_second AS accelerometer_samples_per_second, + owner_organization.name AS owner_organization, + tag.owner_pi AS owner_pi, + financing_project.projectcode AS financing_project, + combined_tag.min_delay AS step1_min_delay, + combined_tag.max_delay AS step1_max_delay, + combined_tag.power AS step1_power, + combined_tag.duration_step1 AS step1_duration, + combined_tag.acceleration_on_sec_step1 AS step1_acceleration_duration, + combined_tag.min_delay_step2 AS step2_min_delay, + combined_tag.max_delay_step2 AS step2_max_delay, + combined_tag.power_step2 AS step2_power, + combined_tag.duration_step2 AS step2_duration, + combined_tag.acceleration_on_sec_step2 AS step2_acceleration_duration, + combined_tag.min_delay_step3 AS step3_min_delay, + combined_tag.max_delay_step3 AS step3_max_delay, + combined_tag.power_step3 AS step3_power, + combined_tag.duration_step3 AS step3_duration, + combined_tag.acceleration_on_sec_step3 AS step3_acceleration_duration, + combined_tag.min_delay_step4 AS step4_min_delay, + combined_tag.max_delay_step4 AS step4_max_delay, + combined_tag.power_step4 AS step4_power, + combined_tag.duration_step4 AS step4_duration, + combined_tag.acceleration_on_sec_step4 AS step4_acceleration_duration, + tag.id_pk AS tag_device_id + FROM common.tag_device AS tag + LEFT JOIN combined_tag + ON tag.id_pk = combined_tag.tag_device_fk + LEFT JOIN common.manufacturer AS manufacturer + ON tag.manufacturer_fk = manufacturer.id_pk + LEFT JOIN common.tag_device_type AS tag_type + ON tag.tag_device_type_fk = tag_type.id_pk + LEFT JOIN acoustic.acoustic_tag_subtype AS tag_subtype + ON tag.acoustic_tag_subtype_fk = tag_subtype.id_pk + LEFT JOIN common.tag_device_status AS tag_status + ON tag.tag_device_status_fk = tag_status.id_pk + LEFT JOIN common.etn_group AS owner_organization + ON tag.owner_group_fk = owner_organization.id_pk + LEFT JOIN common.projects AS financing_project + ON tag.financing_project_fk = financing_project.id + ) AS tag -- Subquery needed to allow where clause on tag_type, tag_subtype + WHERE + {tag_serial_number_query} + AND {tag_type_query} + AND {tag_subtype_query} + AND {acoustic_tag_id_query} + ", .con = connection) + tags <- dbGetQuery(connection, query) + + # Sort data + tags <- + tags %>% + arrange(factor(tag_serial_number, levels = list_tag_serial_numbers(connection))) + + as_tibble(tags) +} From f5e9ea498a7210aeef14b29fc9a7628221d37223 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 6 Oct 2021 22:46:43 +0200 Subject: [PATCH 078/183] Merge pull request #200 from inbo/combined_tag Create a combined tag view (tag.sql) that is used in multiple functions --- R/get_tags.R | 220 +++++++++++++-------------------------------------- 1 file changed, 57 insertions(+), 163 deletions(-) diff --git a/R/get_tags.R b/R/get_tags.R index b854d67..0e860a2 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -21,6 +21,7 @@ #' @importFrom glue glue_sql #' @importFrom DBI dbGetQuery #' @importFrom dplyr %>% arrange as_tibble +#' @importFrom readr read_file #' #' @examples #' \dontrun{ @@ -56,7 +57,7 @@ get_tags <- function(connection = con, valid_tag_serial_numbers <- list_tag_serial_numbers(connection) tag_serial_number <- as.character(tag_serial_number) # Cast to character check_value(tag_serial_number, valid_tag_serial_numbers, "tag_serial_number") - tag_serial_number_query <- glue_sql("tag_serial_number IN ({tag_serial_number*})", .con = connection) + tag_serial_number_query <- glue_sql("tag.tag_serial_number IN ({tag_serial_number*})", .con = connection) } # Check tag_type @@ -65,7 +66,7 @@ get_tags <- function(connection = con, } else { valid_tag_types <- c("acoustic", "archival", "acoustic-archival") check_value(tag_type, valid_tag_types, "tag_type") - tag_type_query <- glue_sql("tag_type IN ({tag_type*})", .con = connection) + tag_type_query <- glue_sql("tag.tag_type IN ({tag_type*})", .con = connection) } # Check tag_subtype @@ -74,7 +75,7 @@ get_tags <- function(connection = con, } else { valid_tag_subtypes <- c("animal", "built-in", "range", "sentinel") check_value(tag_subtype, valid_tag_subtypes, "tag_subtype") - tag_subtype_query <- glue_sql("tag_subtype IN ({tag_subtype*})", .con = connection) + tag_subtype_query <- glue_sql("tag.tag_subtype IN ({tag_subtype*})", .con = connection) } # Check acoustic_tag_id @@ -83,175 +84,68 @@ get_tags <- function(connection = con, } else { valid_acoustic_tag_ids <- list_acoustic_tag_ids(connection) check_value(acoustic_tag_id, valid_acoustic_tag_ids, "acoustic_tag_id") - acoustic_tag_id_query <- glue_sql("acoustic_tag_id IN ({acoustic_tag_id*})", .con = connection) + acoustic_tag_id_query <- glue_sql("tag.acoustic_tag_id IN ({acoustic_tag_id*})", .con = connection) } + tag_query <- glue_sql(read_file(system.file("sql", "tag.sql", package = "etn")), .con = connection) + # Build query query <- glue_sql(" - WITH - combined_tag AS ( - SELECT - -- id_pk, - tag_device_fk, - sensor_type, - tag_full_id, - thelma_converted_code, - -- tag_code_space AS protocol, - -- id_code, - frequency, - slope, - intercept, - range, - sensor_transmit_ratio, - accelerometer_algoritm, - accelerometer_samples_per_second, - min_delay, - max_delay, - power, - duration_step1, - acceleration_on_sec_step1, - min_delay_step2, - max_delay_step2, - power_step2, - duration_step2, - acceleration_on_sec_step2, - min_delay_step3, - max_delay_step3, - power_step3, - duration_step3, - acceleration_on_sec_step3, - min_delay_step4, - max_delay_step4, - power_step4, - duration_step4, - acceleration_on_sec_step4 - -- file, - -- units, - -- external_id - FROM - acoustic.tags - - UNION - - SELECT - -- id_pk, - device_tag_fk AS tag_device_fk, - sensor_type.description AS sensor_type, - CASE - WHEN sensor_full_id IS NOT NULL THEN sensor_full_id - WHEN protocol IS NOT NULL AND id_code IS NOT NULL THEN CONCAT(protocol, '-', id_code) - END AS tag_full_id, - NULL AS thelma_converted_code, - -- protocol, - -- id_code, - frequency, - slope, - intercept, - range, - sensor_transmit_ratio, - accelerometer_algoritm, - accelerometer_samples_per_second, - min_delay, - max_delay, - power, - duration_step1, - acceleration_on_sec_step1, - min_delay_step2, - max_delay_step2, - power_step2, - duration_step2, - acceleration_on_sec_step2, - min_delay_step3, - max_delay_step3, - power_step3, - duration_step3, - acceleration_on_sec_step3, - min_delay_step4, - max_delay_step4, - power_step4, - duration_step4, - acceleration_on_sec_step4 - -- resolution - -- unit - -- accurency - -- range_min - -- range_max - FROM - archive.sensor AS archival_tag - LEFT JOIN archive.sensor_type AS sensor_type - ON archival_tag.sensor_type_fk = sensor_type.id_pk - ) - - SELECT * FROM ( SELECT - tag.serial_number AS tag_serial_number, - CASE - WHEN tag_type.name = 'id-tag' THEN 'acoustic' - WHEN tag_type.name = 'sensor-tag' AND tag_full_id IS NOT NULL THEN 'acoustic-archival' - WHEN tag_type.name = 'sensor-tag' THEN 'archival' - END AS tag_type, - CASE - WHEN tag_subtype.name = 'animal' THEN 'animal' - WHEN tag_subtype.name = 'built-in tag' THEN 'built-in' - WHEN tag_subtype.name = 'range tag' THEN 'range' - WHEN tag_subtype.name = 'sentinel tag' THEN 'sentinel' - END AS tag_subtype, - combined_tag.sensor_type AS sensor_type, - combined_tag.tag_full_id AS acoustic_tag_id, - combined_tag.thelma_converted_code AS acoustic_tag_id_alternative, + tag.tag_serial_number AS tag_serial_number, + tag.tag_type AS tag_type, + tag.tag_subtype AS tag_subtype, + tag.sensor_type AS sensor_type, + tag.acoustic_tag_id AS acoustic_tag_id, + tag.thelma_converted_code AS acoustic_tag_id_alternative, manufacturer.project AS manufacturer, - tag.model AS model, - combined_tag.frequency AS frequency, + tag_device.model AS model, + tag.frequency AS frequency, tag_status.name AS status, - tag.activation_date AS activation_date, - tag.battery_estimated_lifetime AS battery_estimated_life, - tag.battery_estimated_end_date AS battery_estimated_end_date, - combined_tag.slope AS sensor_slope, - combined_tag.intercept AS sensor_intercept, - combined_tag.range AS sensor_range, - combined_tag.sensor_transmit_ratio AS sensor_transmit_ratio, - combined_tag.accelerometer_algoritm AS accelerometer_algorithm, - combined_tag.accelerometer_samples_per_second AS accelerometer_samples_per_second, + tag_device.activation_date AS activation_date, + tag_device.battery_estimated_lifetime AS battery_estimated_life, + tag_device.battery_estimated_end_date AS battery_estimated_end_date, + tag.slope AS sensor_slope, + tag.intercept AS sensor_intercept, + tag.range AS sensor_range, + tag.sensor_transmit_ratio AS sensor_transmit_ratio, + tag.accelerometer_algoritm AS accelerometer_algorithm, + tag.accelerometer_samples_per_second AS accelerometer_samples_per_second, owner_organization.name AS owner_organization, - tag.owner_pi AS owner_pi, + tag_device.owner_pi AS owner_pi, financing_project.projectcode AS financing_project, - combined_tag.min_delay AS step1_min_delay, - combined_tag.max_delay AS step1_max_delay, - combined_tag.power AS step1_power, - combined_tag.duration_step1 AS step1_duration, - combined_tag.acceleration_on_sec_step1 AS step1_acceleration_duration, - combined_tag.min_delay_step2 AS step2_min_delay, - combined_tag.max_delay_step2 AS step2_max_delay, - combined_tag.power_step2 AS step2_power, - combined_tag.duration_step2 AS step2_duration, - combined_tag.acceleration_on_sec_step2 AS step2_acceleration_duration, - combined_tag.min_delay_step3 AS step3_min_delay, - combined_tag.max_delay_step3 AS step3_max_delay, - combined_tag.power_step3 AS step3_power, - combined_tag.duration_step3 AS step3_duration, - combined_tag.acceleration_on_sec_step3 AS step3_acceleration_duration, - combined_tag.min_delay_step4 AS step4_min_delay, - combined_tag.max_delay_step4 AS step4_max_delay, - combined_tag.power_step4 AS step4_power, - combined_tag.duration_step4 AS step4_duration, - combined_tag.acceleration_on_sec_step4 AS step4_acceleration_duration, - tag.id_pk AS tag_device_id - FROM common.tag_device AS tag - LEFT JOIN combined_tag - ON tag.id_pk = combined_tag.tag_device_fk - LEFT JOIN common.manufacturer AS manufacturer - ON tag.manufacturer_fk = manufacturer.id_pk - LEFT JOIN common.tag_device_type AS tag_type - ON tag.tag_device_type_fk = tag_type.id_pk - LEFT JOIN acoustic.acoustic_tag_subtype AS tag_subtype - ON tag.acoustic_tag_subtype_fk = tag_subtype.id_pk - LEFT JOIN common.tag_device_status AS tag_status - ON tag.tag_device_status_fk = tag_status.id_pk - LEFT JOIN common.etn_group AS owner_organization - ON tag.owner_group_fk = owner_organization.id_pk - LEFT JOIN common.projects AS financing_project - ON tag.financing_project_fk = financing_project.id - ) AS tag -- Subquery needed to allow where clause on tag_type, tag_subtype + tag.min_delay AS step1_min_delay, + tag.max_delay AS step1_max_delay, + tag.power AS step1_power, + tag.duration_step1 AS step1_duration, + tag.acceleration_on_sec_step1 AS step1_acceleration_duration, + tag.min_delay_step2 AS step2_min_delay, + tag.max_delay_step2 AS step2_max_delay, + tag.power_step2 AS step2_power, + tag.duration_step2 AS step2_duration, + tag.acceleration_on_sec_step2 AS step2_acceleration_duration, + tag.min_delay_step3 AS step3_min_delay, + tag.max_delay_step3 AS step3_max_delay, + tag.power_step3 AS step3_power, + tag.duration_step3 AS step3_duration, + tag.acceleration_on_sec_step3 AS step3_acceleration_duration, + tag.min_delay_step4 AS step4_min_delay, + tag.max_delay_step4 AS step4_max_delay, + tag.power_step4 AS step4_power, + tag.duration_step4 AS step4_duration, + tag.acceleration_on_sec_step4 AS step4_acceleration_duration, + tag_device.id_pk AS tag_device_id + FROM ({tag_query}) AS tag + LEFT JOIN common.tag_device AS tag_device + ON tag.tag_device_fk = tag_device.id_pk + LEFT JOIN common.manufacturer AS manufacturer + ON tag_device.manufacturer_fk = manufacturer.id_pk + LEFT JOIN common.tag_device_status AS tag_status + ON tag_device.tag_device_status_fk = tag_status.id_pk + LEFT JOIN common.etn_group AS owner_organization + ON tag_device.owner_group_fk = owner_organization.id_pk + LEFT JOIN common.projects AS financing_project + ON tag_device.financing_project_fk = financing_project.id WHERE {tag_serial_number_query} AND {tag_type_query} From c5fd6fd6c04bf32b871f793b72ce51caadea4bee Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Fri, 8 Oct 2021 10:11:03 +0200 Subject: [PATCH 079/183] Add 5 fields to get_tags(), see #208 --- R/get_tags.R | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/R/get_tags.R b/R/get_tags.R index 0e860a2..4f6cdb6 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -105,6 +105,11 @@ get_tags <- function(connection = con, tag_device.activation_date AS activation_date, tag_device.battery_estimated_lifetime AS battery_estimated_life, tag_device.battery_estimated_end_date AS battery_estimated_end_date, + tag.resolution AS resolution, + tag.unit AS unit, + tag.accurency AS accuracy, + tag.range_min AS range_min, + tag.range_max AS range_max, tag.slope AS sensor_slope, tag.intercept AS sensor_intercept, tag.range AS sensor_range, From 343838c63c2265df6ce89a767f03a65a19f116b9 Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Fri, 8 Oct 2021 12:50:39 +0200 Subject: [PATCH 080/183] Consistently use .data and import it from dplyr --- R/get_tags.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/get_tags.R b/R/get_tags.R index 4f6cdb6..7d902e7 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -20,7 +20,7 @@ #' #' @importFrom glue glue_sql #' @importFrom DBI dbGetQuery -#' @importFrom dplyr %>% arrange as_tibble +#' @importFrom dplyr .data %>% arrange as_tibble #' @importFrom readr read_file #' #' @examples @@ -162,7 +162,7 @@ get_tags <- function(connection = con, # Sort data tags <- tags %>% - arrange(factor(tag_serial_number, levels = list_tag_serial_numbers(connection))) + arrange(factor(.data$tag_serial_number, levels = list_tag_serial_numbers(connection))) as_tibble(tags) } From 65b0528dd8c691329818744043c9cfb0051a082e Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Mon, 11 Oct 2021 19:10:02 +0200 Subject: [PATCH 081/183] Merge pull request #217 from inbo/use_views Use 3 of the 4 moratorium views --- R/get_tags.R | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/R/get_tags.R b/R/get_tags.R index 7d902e7..957d64a 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -87,7 +87,7 @@ get_tags <- function(connection = con, acoustic_tag_id_query <- glue_sql("tag.acoustic_tag_id IN ({acoustic_tag_id*})", .con = connection) } - tag_query <- glue_sql(read_file(system.file("sql", "tag.sql", package = "etn")), .con = connection) + tag_sql <- glue_sql(read_file(system.file("sql", "tag.sql", package = "etn")), .con = connection) # Build query query <- glue_sql(" @@ -140,7 +140,15 @@ get_tags <- function(connection = con, tag.duration_step4 AS step4_duration, tag.acceleration_on_sec_step4 AS step4_acceleration_duration, tag_device.id_pk AS tag_device_id - FROM ({tag_query}) AS tag + -- tag_device.qc_migration + -- tag_device.archive_floating + -- tag_device.archive_weight + -- tag_device.archive_length + -- tag_device.archive_diameter + -- tag_device.order_number + -- tag_device.device_internal_memory + -- tag_device.external_id + FROM ({tag_sql}) AS tag LEFT JOIN common.tag_device AS tag_device ON tag.tag_device_fk = tag_device.id_pk LEFT JOIN common.manufacturer AS manufacturer From dfbd74c80abb3d43318cafd3c956226ea9d935f7 Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Mon, 11 Oct 2021 19:25:16 +0200 Subject: [PATCH 082/183] Fix #208 --- R/get_tags.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/get_tags.R b/R/get_tags.R index 957d64a..a15f73a 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -105,14 +105,14 @@ get_tags <- function(connection = con, tag_device.activation_date AS activation_date, tag_device.battery_estimated_lifetime AS battery_estimated_life, tag_device.battery_estimated_end_date AS battery_estimated_end_date, - tag.resolution AS resolution, - tag.unit AS unit, - tag.accurency AS accuracy, - tag.range_min AS range_min, - tag.range_max AS range_max, tag.slope AS sensor_slope, tag.intercept AS sensor_intercept, tag.range AS sensor_range, + tag.range_min AS sensor_range_min, + tag.range_max AS sensor_range_max, + tag.resolution AS sensor_resolution, + tag.unit AS sensor_unit, + tag.accurency AS sensor_accuracy, tag.sensor_transmit_ratio AS sensor_transmit_ratio, tag.accelerometer_algoritm AS accelerometer_algorithm, tag.accelerometer_samples_per_second AS accelerometer_samples_per_second, From 7cd9b1085b4fd31c5ce81d83069c16f89853eb7e Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Tue, 12 Oct 2021 16:02:31 +0200 Subject: [PATCH 083/183] Merge pull request #221 from inbo/download_acoustic_dataset Add download_acoustic_dataset() --- R/get_tags.R | 23 ++++++++++++++++++----- 1 file changed, 18 insertions(+), 5 deletions(-) diff --git a/R/get_tags.R b/R/get_tags.R index a15f73a..9d4bc3e 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -11,7 +11,7 @@ #' @param tag_subtype Character (vector). `animal`, `built-in`, `range` or #' `sentinel`. #' @param acoustic_tag_id Character (vector). One or more acoustic tag -#' identifiers. These are the identifiers found in acoustic detections. +#' identifiers, i.e. identifiers found in [get_acoustic_detections()]. #' #' @return A tibble with tags data, sorted by `tag_serial_number`. See also #' [field definitions](https://inbo.github.io/etn/articles/etn_fields.html). @@ -57,7 +57,10 @@ get_tags <- function(connection = con, valid_tag_serial_numbers <- list_tag_serial_numbers(connection) tag_serial_number <- as.character(tag_serial_number) # Cast to character check_value(tag_serial_number, valid_tag_serial_numbers, "tag_serial_number") - tag_serial_number_query <- glue_sql("tag.tag_serial_number IN ({tag_serial_number*})", .con = connection) + tag_serial_number_query <- glue_sql( + "tag.tag_serial_number IN ({tag_serial_number*})", + .con = connection + ) } # Check tag_type @@ -66,7 +69,10 @@ get_tags <- function(connection = con, } else { valid_tag_types <- c("acoustic", "archival", "acoustic-archival") check_value(tag_type, valid_tag_types, "tag_type") - tag_type_query <- glue_sql("tag.tag_type IN ({tag_type*})", .con = connection) + tag_type_query <- glue_sql( + "tag.tag_type IN ({tag_type*})", + .con = connection + ) } # Check tag_subtype @@ -75,7 +81,10 @@ get_tags <- function(connection = con, } else { valid_tag_subtypes <- c("animal", "built-in", "range", "sentinel") check_value(tag_subtype, valid_tag_subtypes, "tag_subtype") - tag_subtype_query <- glue_sql("tag.tag_subtype IN ({tag_subtype*})", .con = connection) + tag_subtype_query <- glue_sql( + "tag.tag_subtype IN ({tag_subtype*})", + .con = connection + ) } # Check acoustic_tag_id @@ -84,7 +93,10 @@ get_tags <- function(connection = con, } else { valid_acoustic_tag_ids <- list_acoustic_tag_ids(connection) check_value(acoustic_tag_id, valid_acoustic_tag_ids, "acoustic_tag_id") - acoustic_tag_id_query <- glue_sql("tag.acoustic_tag_id IN ({acoustic_tag_id*})", .con = connection) + acoustic_tag_id_query <- glue_sql( + "tag.acoustic_tag_id IN ({acoustic_tag_id*})", + .con = connection + ) } tag_sql <- glue_sql(read_file(system.file("sql", "tag.sql", package = "etn")), .con = connection) @@ -139,6 +151,7 @@ get_tags <- function(connection = con, tag.power_step4 AS step4_power, tag.duration_step4 AS step4_duration, tag.acceleration_on_sec_step4 AS step4_acceleration_duration, + tag.tag_id AS tag_id, tag_device.id_pk AS tag_device_id -- tag_device.qc_migration -- tag_device.archive_floating From 9bac912d5c8024d309d49616aa73a96e4d4641a7 Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Wed, 13 Oct 2021 11:20:47 +0200 Subject: [PATCH 084/183] Run examples for website #227 --- R/get_tags.R | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/R/get_tags.R b/R/get_tags.R index 9d4bc3e..265f252 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -24,24 +24,22 @@ #' @importFrom readr read_file #' #' @examples -#' \dontrun{ #' # Set default connection variable #' con <- connect_to_etn() #' #' # Get all tags -#' get_tags() +#' get_tags(con) #' #' # Get archival tags, including acoustic-archival -#' get_tags(tag_type = c("archival", "acoustic-archival")) +#' get_tags(con, tag_type = c("archival", "acoustic-archival")) #' #' # Get tags of specific subtype -#' get_tags(tag_subtype = c("built-in", "range")) +#' get_tags(con, tag_subtype = c("built-in", "range")) #' -#' # Get specific tags -#' get_tags(tag_serial_number = "1187450") -#' get_tags(acoustic_tag_id = "A69-1601-16130") -#' get_tags(acoustic_tag_id = c("A69-1601-16129", "A69-1601-16130")) -#' } +#' # Get specific tags (note that these can return multiple records) +#' get_tags(con, tag_serial_number = "1187450") +#' get_tags(con, acoustic_tag_id = "A69-1601-16130") +#' get_tags(con, acoustic_tag_id = c("A69-1601-16129", "A69-1601-16130")) get_tags <- function(connection = con, tag_type = NULL, tag_subtype = NULL, From 5c50a808ccb7a6626e7b6834f85b55928acb07e1 Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Mon, 18 Oct 2021 14:10:57 +0200 Subject: [PATCH 085/183] Add 5 fields to get_tags() Closes #215 --- R/get_tags.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/get_tags.R b/R/get_tags.R index 265f252..7dacf32 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -115,6 +115,11 @@ get_tags <- function(connection = con, tag_device.activation_date AS activation_date, tag_device.battery_estimated_lifetime AS battery_estimated_life, tag_device.battery_estimated_end_date AS battery_estimated_end_date, + tag_device.archive_length AS length, + tag_device.archive_diameter AS diameter, + tag_device.archive_weight AS weight, + tag_device.archive_floating AS floating, + tag_device.device_internal_memory AS archive_memory, tag.slope AS sensor_slope, tag.intercept AS sensor_intercept, tag.range AS sensor_range, @@ -152,12 +157,7 @@ get_tags <- function(connection = con, tag.tag_id AS tag_id, tag_device.id_pk AS tag_device_id -- tag_device.qc_migration - -- tag_device.archive_floating - -- tag_device.archive_weight - -- tag_device.archive_length - -- tag_device.archive_diameter -- tag_device.order_number - -- tag_device.device_internal_memory -- tag_device.external_id FROM ({tag_sql}) AS tag LEFT JOIN common.tag_device AS tag_device From f064333d89f6bf6b4d7d013fc0088999e9fb041f Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Wed, 10 Nov 2021 13:36:19 +0100 Subject: [PATCH 086/183] Hide owner_organization, owner_pi when user is not member of group --- R/get_tags.R | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/R/get_tags.R b/R/get_tags.R index 7dacf32..3903f3b 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -15,6 +15,8 @@ #' #' @return A tibble with tags data, sorted by `tag_serial_number`. See also #' [field definitions](https://inbo.github.io/etn/articles/etn_fields.html). +#' Values for `owner_organization` and `owner_pi` will only be visible if you +#' are member of the group. #' #' @export #' @@ -131,8 +133,14 @@ get_tags <- function(connection = con, tag.sensor_transmit_ratio AS sensor_transmit_ratio, tag.accelerometer_algoritm AS accelerometer_algorithm, tag.accelerometer_samples_per_second AS accelerometer_samples_per_second, - owner_organization.name AS owner_organization, - tag_device.owner_pi AS owner_pi, + CASE + WHEN tag_device.owner_group_fk_limited IS NOT NULL THEN owner_organization.name + ELSE NULL + END AS owner_organization, + CASE + WHEN tag_device.owner_group_fk_limited IS NOT NULL THEN tag_device.owner_pi + ELSE NULL + END AS owner_pi, financing_project.projectcode AS financing_project, tag.min_delay AS step1_min_delay, tag.max_delay AS step1_max_delay, @@ -160,14 +168,14 @@ get_tags <- function(connection = con, -- tag_device.order_number -- tag_device.external_id FROM ({tag_sql}) AS tag - LEFT JOIN common.tag_device AS tag_device + LEFT JOIN common.tag_device_limited AS tag_device ON tag.tag_device_fk = tag_device.id_pk LEFT JOIN common.manufacturer AS manufacturer ON tag_device.manufacturer_fk = manufacturer.id_pk LEFT JOIN common.tag_device_status AS tag_status ON tag_device.tag_device_status_fk = tag_status.id_pk LEFT JOIN common.etn_group AS owner_organization - ON tag_device.owner_group_fk = owner_organization.id_pk + ON tag_device.owner_group_fk_limited = owner_organization.id_pk LEFT JOIN common.projects AS financing_project ON tag_device.financing_project_fk = financing_project.id WHERE From 6871f8d4986ac2d5d9ce6968dc98a23bee473075 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Tue, 30 Nov 2021 10:11:23 +0100 Subject: [PATCH 087/183] Merge pull request #241 from inbo/importFrom Fix #240: use :: over importFrom --- R/get_tags.R | 26 ++++++++++++-------------- 1 file changed, 12 insertions(+), 14 deletions(-) diff --git a/R/get_tags.R b/R/get_tags.R index 3903f3b..3429ab0 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -20,11 +20,6 @@ #' #' @export #' -#' @importFrom glue glue_sql -#' @importFrom DBI dbGetQuery -#' @importFrom dplyr .data %>% arrange as_tibble -#' @importFrom readr read_file -#' #' @examples #' # Set default connection variable #' con <- connect_to_etn() @@ -57,7 +52,7 @@ get_tags <- function(connection = con, valid_tag_serial_numbers <- list_tag_serial_numbers(connection) tag_serial_number <- as.character(tag_serial_number) # Cast to character check_value(tag_serial_number, valid_tag_serial_numbers, "tag_serial_number") - tag_serial_number_query <- glue_sql( + tag_serial_number_query <- glue::glue_sql( "tag.tag_serial_number IN ({tag_serial_number*})", .con = connection ) @@ -69,7 +64,7 @@ get_tags <- function(connection = con, } else { valid_tag_types <- c("acoustic", "archival", "acoustic-archival") check_value(tag_type, valid_tag_types, "tag_type") - tag_type_query <- glue_sql( + tag_type_query <- glue::glue_sql( "tag.tag_type IN ({tag_type*})", .con = connection ) @@ -81,7 +76,7 @@ get_tags <- function(connection = con, } else { valid_tag_subtypes <- c("animal", "built-in", "range", "sentinel") check_value(tag_subtype, valid_tag_subtypes, "tag_subtype") - tag_subtype_query <- glue_sql( + tag_subtype_query <- glue::glue_sql( "tag.tag_subtype IN ({tag_subtype*})", .con = connection ) @@ -93,16 +88,19 @@ get_tags <- function(connection = con, } else { valid_acoustic_tag_ids <- list_acoustic_tag_ids(connection) check_value(acoustic_tag_id, valid_acoustic_tag_ids, "acoustic_tag_id") - acoustic_tag_id_query <- glue_sql( + acoustic_tag_id_query <- glue::glue_sql( "tag.acoustic_tag_id IN ({acoustic_tag_id*})", .con = connection ) } - tag_sql <- glue_sql(read_file(system.file("sql", "tag.sql", package = "etn")), .con = connection) + tag_sql <- glue::glue_sql( + readr::read_file(system.file("sql", "tag.sql", package = "etn")), + .con = connection + ) # Build query - query <- glue_sql(" + query <- glue::glue_sql(" SELECT tag.tag_serial_number AS tag_serial_number, tag.tag_type AS tag_type, @@ -184,12 +182,12 @@ get_tags <- function(connection = con, AND {tag_subtype_query} AND {acoustic_tag_id_query} ", .con = connection) - tags <- dbGetQuery(connection, query) + tags <- DBI::dbGetQuery(connection, query) # Sort data tags <- tags %>% - arrange(factor(.data$tag_serial_number, levels = list_tag_serial_numbers(connection))) + dplyr::arrange(factor(.data$tag_serial_number, levels = list_tag_serial_numbers(connection))) - as_tibble(tags) + dplyr::as_tibble(tags) } From 95ab0afec80fc397766d7f34ba22e24fd140b704 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Fri, 9 Dec 2022 16:44:01 +0100 Subject: [PATCH 088/183] Merge pull request #257 from inbo/dwc Add `write_dwc()` function --- R/get_tags.R | 29 ++++++++++++++++++++--------- 1 file changed, 20 insertions(+), 9 deletions(-) diff --git a/R/get_tags.R b/R/get_tags.R index 3429ab0..c136fb6 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -49,9 +49,11 @@ get_tags <- function(connection = con, if (is.null(tag_serial_number)) { tag_serial_number_query <- "True" } else { - valid_tag_serial_numbers <- list_tag_serial_numbers(connection) - tag_serial_number <- as.character(tag_serial_number) # Cast to character - check_value(tag_serial_number, valid_tag_serial_numbers, "tag_serial_number") + tag_serial_number <- check_value( + as.character(tag_serial_number), # Cast to character + list_tag_serial_numbers(connection), + "tag_serial_number" + ) tag_serial_number_query <- glue::glue_sql( "tag.tag_serial_number IN ({tag_serial_number*})", .con = connection @@ -62,8 +64,11 @@ get_tags <- function(connection = con, if (is.null(tag_type)) { tag_type_query <- "True" } else { - valid_tag_types <- c("acoustic", "archival", "acoustic-archival") - check_value(tag_type, valid_tag_types, "tag_type") + tag_type <- check_value( + tag_type, + c("acoustic", "archival", "acoustic-archival"), + "tag_type" + ) tag_type_query <- glue::glue_sql( "tag.tag_type IN ({tag_type*})", .con = connection @@ -74,8 +79,11 @@ get_tags <- function(connection = con, if (is.null(tag_subtype)) { tag_subtype_query <- "True" } else { - valid_tag_subtypes <- c("animal", "built-in", "range", "sentinel") - check_value(tag_subtype, valid_tag_subtypes, "tag_subtype") + tag_subtype <- check_value( + tag_subtype, + c("animal", "built-in", "range", "sentinel"), + "tag_subtype" + ) tag_subtype_query <- glue::glue_sql( "tag.tag_subtype IN ({tag_subtype*})", .con = connection @@ -86,8 +94,11 @@ get_tags <- function(connection = con, if (is.null(acoustic_tag_id)) { acoustic_tag_id_query <- "True" } else { - valid_acoustic_tag_ids <- list_acoustic_tag_ids(connection) - check_value(acoustic_tag_id, valid_acoustic_tag_ids, "acoustic_tag_id") + check_value( + acoustic_tag_id, + list_acoustic_tag_ids(connection), + "acoustic_tag_id" + ) acoustic_tag_id_query <- glue::glue_sql( "tag.acoustic_tag_id IN ({acoustic_tag_id*})", .con = connection From c634704f649775b9d568ba3f685efcec0bcc161c Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Fri, 21 Feb 2020 17:06:48 +0100 Subject: [PATCH 089/183] Merge pull request #93 from inbo/new_views Use new views --- tests/testthat/test-get_tags.R | 100 +++++++++++++++++++++++++++++++++ 1 file changed, 100 insertions(+) create mode 100644 tests/testthat/test-get_tags.R diff --git a/tests/testthat/test-get_tags.R b/tests/testthat/test-get_tags.R new file mode 100644 index 0000000..90f8213 --- /dev/null +++ b/tests/testthat/test-get_tags.R @@ -0,0 +1,100 @@ +con <- connect_to_etn( + username = Sys.getenv("userid"), + password = Sys.getenv("pwd") +) + +# Expected column names +expected_col_names_tags <- c( + "pk", + "tag_id", + "tag_id_alternative", + "telemetry_type", + "manufacturer", + "model", + "frequency", + "type", + "serial_number", + "tag_id_protocol", + "tag_id_code", + "status", + "activation_date", + "battery_estimated_life", + "battery_estimated_end_date", + "sensor_type", + "sensor_slope", + "sensor_intercept", + "sensor_range", + "sensor_transmit_ratio", + "accelerometer_algorithm", + "accelerometer_samples_per_second", + "owner_organization", + "owner_pi", + "financing_project", + "step1_min_delay", + "step1_max_delay", + "step1_power", + "step1_duration", + "step1_acceleration_duration", + "step2_min_delay", + "step2_max_delay", + "step2_power", + "step2_duration", + "step2_acceleration_duration", + "step3_min_delay", + "step3_max_delay", + "step3_power", + "step3_duration", + "step3_acceleration_duration", + "step4_min_delay", + "step4_max_delay", + "step4_power", + "step4_duration", + "step4_acceleration_duration" +) + +tags_all <- get_tags(con) +tags_project1 <- get_tags(con, animal_project_code = "phd_reubens") +tags_projects_multiple <- get_tags(con, animal_project_code = c( + "phd_reubens", + "2012_leopoldkanaal" +)) +tags_project1_ref <- get_tags(con, + animal_project_code = "phd_reubens", + include_reference_tags = TRUE +) + +testthat::test_that("test_input_get_tags", { + expect_error( + get_tags("I am not a connection"), + "Not a connection object to database." + ) + expect_error(get_tags(con, animal_project_code = "very_bad_project")) + expect_error(get_tags(con, animal_project_code = c( + "phd_reubens", + "very_bad_project" + ))) + expect_error(get_tags(con, include_reference_tags = "not logical")) +}) + +testthat::test_that("test_output_get_tags", { + library(dplyr) + expect_is(tags_all, "data.frame") + expect_is(tags_project1, "data.frame") + expect_is(tags_projects_multiple, "data.frame") + expect_is(tags_project1_ref, "data.frame") + expect_true(all(names(tags_all) %in% expected_col_names_tags)) + expect_true(all(expected_col_names_tags %in% names(tags_all))) + expect_gte(nrow(tags_all), nrow(tags_project1)) + expect_gte(nrow(tags_all), nrow(tags_projects_multiple)) + expect_gte(nrow(tags_projects_multiple), nrow(tags_project1)) + expect_gte(nrow(tags_project1_ref), nrow(tags_project1)) + expect_equal(names(tags_all), names(tags_project1)) + expect_equal(names(tags_all), names(tags_projects_multiple)) + expect_equal(names(tags_all), names(tags_project1_ref)) + expect_equal( + tags_project1 %>% distinct(type) %>% arrange() %>% pull(), + c("animal", "sentinel") + ) + # expect_equal(nrow(tags_all), nrow(tags_all %>% distinct(pk))) + # expect_equal(nrow(tags_all), nrow(tags_all %>% distinct(tag_id))) +}) From da6ce769b5b85e6b475831a841450f2c5ba04b17 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 26 Feb 2020 14:38:06 +0100 Subject: [PATCH 090/183] Merge pull request #101 from inbo/update_parameters Update parameters for get_tags and get_receivers --- tests/testthat/test-get_tags.R | 80 ++++++++++++++++++++-------------- 1 file changed, 47 insertions(+), 33 deletions(-) diff --git a/tests/testthat/test-get_tags.R b/tests/testthat/test-get_tags.R index 90f8213..c451c2c 100644 --- a/tests/testthat/test-get_tags.R +++ b/tests/testthat/test-get_tags.R @@ -52,49 +52,63 @@ expected_col_names_tags <- c( "step4_acceleration_duration" ) +tag1 <- "A69-1303-65313" # A sentinel tag with 2 records +tag_multiple <- c("A69-1601-1705", "A69-1601-1707") + tags_all <- get_tags(con) -tags_project1 <- get_tags(con, animal_project_code = "phd_reubens") -tags_projects_multiple <- get_tags(con, animal_project_code = c( - "phd_reubens", - "2012_leopoldkanaal" -)) -tags_project1_ref <- get_tags(con, - animal_project_code = "phd_reubens", - include_reference_tags = TRUE -) +tags_all_ref <- get_tags(con, include_ref_tags = TRUE) +tags_tag1 <- get_tags(con, tag_id = tag1) +tags_tag_multiple <- get_tags(con, tag_id = tag_multiple) -testthat::test_that("test_input_get_tags", { +testthat::test_that("Test input", { expect_error( - get_tags("I am not a connection"), + get_tags("not_a_connection"), "Not a connection object to database." ) - expect_error(get_tags(con, animal_project_code = "very_bad_project")) - expect_error(get_tags(con, animal_project_code = c( - "phd_reubens", - "very_bad_project" - ))) - expect_error(get_tags(con, include_reference_tags = "not logical")) + expect_error( + get_tags(con, tag_id = "not_a_tag_id") + ) + expect_error( + get_tags(con, tag_id = c("A69-1601-1705", "not_a_tag_id")) + ) + expect_error( + get_tags(con, include_ref_tags = "not_a_logical") + ) }) -testthat::test_that("test_output_get_tags", { - library(dplyr) +testthat::test_that("Test output type", { expect_is(tags_all, "data.frame") - expect_is(tags_project1, "data.frame") - expect_is(tags_projects_multiple, "data.frame") - expect_is(tags_project1_ref, "data.frame") + expect_is(tags_all_ref, "data.frame") + expect_is(tags_tag1, "data.frame") + expect_is(tags_tag_multiple, "data.frame") +}) + +testthat::test_that("Test column names", { expect_true(all(names(tags_all) %in% expected_col_names_tags)) expect_true(all(expected_col_names_tags %in% names(tags_all))) - expect_gte(nrow(tags_all), nrow(tags_project1)) - expect_gte(nrow(tags_all), nrow(tags_projects_multiple)) - expect_gte(nrow(tags_projects_multiple), nrow(tags_project1)) - expect_gte(nrow(tags_project1_ref), nrow(tags_project1)) - expect_equal(names(tags_all), names(tags_project1)) - expect_equal(names(tags_all), names(tags_projects_multiple)) - expect_equal(names(tags_all), names(tags_project1_ref)) + expect_equal(names(tags_all), names(tags_all_ref)) + expect_equal(names(tags_all), names(tags_tag1)) + expect_equal(names(tags_all), names(tags_tag_multiple)) +}) + +testthat::test_that("Test number of records", { + expect_gt(nrow(tags_all_ref), nrow(tags_all)) + expect_equal(nrow(tags_tag1), 2) + expect_equal(nrow(tags_tag_multiple), 2) +}) + +testthat::test_that("Test if data is filtered on paramater", { expect_equal( - tags_project1 %>% distinct(type) %>% arrange() %>% pull(), - c("animal", "sentinel") + tags_tag1 %>% distinct(tag_id) %>% pull(), + c(tag1) ) - # expect_equal(nrow(tags_all), nrow(tags_all %>% distinct(pk))) - # expect_equal(nrow(tags_all), nrow(tags_all %>% distinct(tag_id))) + expect_equal( + tags_tag_multiple %>% distinct(tag_id) %>% arrange(tag_id) %>% pull(), + tag_multiple + ) +}) + +testthat::test_that("Test unique ids", { + expect_equal(nrow(tags_all), nrow(tags_all %>% distinct(pk))) + # expect_equal(nrow(tags_all), nrow(tags_all %>% distinct(tag_id))) # This is not the case }) From 547b1bced6b69276c49878e1100f03826d66c19a Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 18 Mar 2020 12:43:12 +0100 Subject: [PATCH 091/183] Merge pull request #106 from inbo/solve-animal-tag-relationship Solve animal tag relationship --- tests/testthat/test-get_tags.R | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/tests/testthat/test-get_tags.R b/tests/testthat/test-get_tags.R index c451c2c..a5c8428 100644 --- a/tests/testthat/test-get_tags.R +++ b/tests/testthat/test-get_tags.R @@ -4,7 +4,7 @@ con <- connect_to_etn( ) # Expected column names -expected_col_names_tags <- c( +expected_col_names <- c( "pk", "tag_id", "tag_id_alternative", @@ -84,11 +84,10 @@ testthat::test_that("Test output type", { }) testthat::test_that("Test column names", { - expect_true(all(names(tags_all) %in% expected_col_names_tags)) - expect_true(all(expected_col_names_tags %in% names(tags_all))) - expect_equal(names(tags_all), names(tags_all_ref)) - expect_equal(names(tags_all), names(tags_tag1)) - expect_equal(names(tags_all), names(tags_tag_multiple)) + expect_equal(names(tags_all), expected_col_names) + expect_equal(names(tags_all_ref), expected_col_names) + expect_equal(names(tags_tag1), expected_col_names) + expect_equal(names(tags_tag_multiple), expected_col_names) }) testthat::test_that("Test number of records", { From fdc90fb5134a8d6ba2ca5c2e37f285f6577d75f6 Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Wed, 1 Apr 2020 13:32:41 +0200 Subject: [PATCH 092/183] Fix typo --- tests/testthat/test-get_tags.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-get_tags.R b/tests/testthat/test-get_tags.R index a5c8428..6b2cc5b 100644 --- a/tests/testthat/test-get_tags.R +++ b/tests/testthat/test-get_tags.R @@ -96,7 +96,7 @@ testthat::test_that("Test number of records", { expect_equal(nrow(tags_tag_multiple), 2) }) -testthat::test_that("Test if data is filtered on paramater", { +testthat::test_that("Test if data is filtered on parameter", { expect_equal( tags_tag1 %>% distinct(tag_id) %>% pull(), c(tag1) From 298f6da2331e1c3f1da481e473139815b01edb95 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 2 Sep 2020 10:42:20 +0200 Subject: [PATCH 093/183] Merge pull request #123 from inbo/order_by Order returned results --- tests/testthat/test-get_tags.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-get_tags.R b/tests/testthat/test-get_tags.R index 6b2cc5b..3064d3c 100644 --- a/tests/testthat/test-get_tags.R +++ b/tests/testthat/test-get_tags.R @@ -77,10 +77,10 @@ testthat::test_that("Test input", { }) testthat::test_that("Test output type", { - expect_is(tags_all, "data.frame") - expect_is(tags_all_ref, "data.frame") - expect_is(tags_tag1, "data.frame") - expect_is(tags_tag_multiple, "data.frame") + expect_is(tags_all, "tbl_df") + expect_is(tags_all_ref, "tbl_df") + expect_is(tags_tag1, "tbl_df") + expect_is(tags_tag_multiple, "tbl_df") }) testthat::test_that("Test column names", { From c1dfa2ffe4786c1fe3fb7ab736c2004a61a02c6a Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Fri, 8 Oct 2021 22:21:01 +0200 Subject: [PATCH 094/183] Merge pull request #214 from inbo/get_projects Split get_projects() in 3 functions --- R/list_cpod_project_codes.R | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) create mode 100644 R/list_cpod_project_codes.R diff --git a/R/list_cpod_project_codes.R b/R/list_cpod_project_codes.R new file mode 100644 index 0000000..ba5fa8a --- /dev/null +++ b/R/list_cpod_project_codes.R @@ -0,0 +1,22 @@ +#' List all available cpod project codes +#' +#' @param connection A connection to the ETN database. Defaults to `con`. +#' +#' @export +#' +#' @importFrom glue glue_sql +#' @importFrom DBI dbGetQuery +#' @importFrom readr read_file +#' +#' @return A vector of all unique `project_code` of `type = "cpod"` in +#' `project.sql`. +list_cpod_project_codes <- function(connection = con) { + project_query <- glue_sql(read_file(system.file("sql", "project.sql", package = "etn")), .con = connection) + query <- glue_sql( + "SELECT DISTINCT project_code FROM ({project_query}) AS project WHERE project_type = 'cpod'", + .con = connection + ) + data <- dbGetQuery(connection, query) + + sort(data$project_code) +} From 4486182a9fcd666c14204582c3ea9cb70419e90c Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Tue, 12 Oct 2021 19:24:16 +0200 Subject: [PATCH 095/183] Move @return above @export for list_ functions --- R/list_cpod_project_codes.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/list_cpod_project_codes.R b/R/list_cpod_project_codes.R index ba5fa8a..b69c604 100644 --- a/R/list_cpod_project_codes.R +++ b/R/list_cpod_project_codes.R @@ -2,14 +2,14 @@ #' #' @param connection A connection to the ETN database. Defaults to `con`. #' +#' @return A vector of all unique `project_code` of `type = "cpod"` in +#' `project.sql`. +#' #' @export #' #' @importFrom glue glue_sql #' @importFrom DBI dbGetQuery #' @importFrom readr read_file -#' -#' @return A vector of all unique `project_code` of `type = "cpod"` in -#' `project.sql`. list_cpod_project_codes <- function(connection = con) { project_query <- glue_sql(read_file(system.file("sql", "project.sql", package = "etn")), .con = connection) query <- glue_sql( From 6052c7de2f6bb8f47ae91efbd1701d08d94fa6a6 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Tue, 30 Nov 2021 10:11:23 +0100 Subject: [PATCH 096/183] Merge pull request #241 from inbo/importFrom Fix #240: use :: over importFrom --- R/list_cpod_project_codes.R | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/R/list_cpod_project_codes.R b/R/list_cpod_project_codes.R index b69c604..07d2740 100644 --- a/R/list_cpod_project_codes.R +++ b/R/list_cpod_project_codes.R @@ -6,17 +6,16 @@ #' `project.sql`. #' #' @export -#' -#' @importFrom glue glue_sql -#' @importFrom DBI dbGetQuery -#' @importFrom readr read_file list_cpod_project_codes <- function(connection = con) { - project_query <- glue_sql(read_file(system.file("sql", "project.sql", package = "etn")), .con = connection) - query <- glue_sql( + project_query <- glue::glue_sql( + readr::read_file(system.file("sql", "project.sql", package = "etn")), + .con = connection + ) + query <- glue::glue_sql( "SELECT DISTINCT project_code FROM ({project_query}) AS project WHERE project_type = 'cpod'", .con = connection ) - data <- dbGetQuery(connection, query) + data <- DBI::dbGetQuery(connection, query) sort(data$project_code) } From 457a71720a0fad5adc2a3b56daaaea342cb73e8d Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Fri, 8 Oct 2021 22:21:01 +0200 Subject: [PATCH 097/183] Merge pull request #214 from inbo/get_projects Split get_projects() in 3 functions --- tests/testthat/test-list_cpod_project_codes.R | 11 +++++++++++ 1 file changed, 11 insertions(+) create mode 100644 tests/testthat/test-list_cpod_project_codes.R diff --git a/tests/testthat/test-list_cpod_project_codes.R b/tests/testthat/test-list_cpod_project_codes.R new file mode 100644 index 0000000..46f7f67 --- /dev/null +++ b/tests/testthat/test-list_cpod_project_codes.R @@ -0,0 +1,11 @@ +con <- connect_to_etn() + +test_that("list_cpod_project_codes() returns unique list of values", { + expect_is(list_cpod_project_codes(con), "character") + expect_false(any(duplicated(list_cpod_project_codes(con)))) + expect_true("cpod-lifewatch" %in% list_cpod_project_codes(con)) + + # Should not include animal or network projects + expect_false("2014_demer" %in% list_cpod_project_codes(con)) + expect_false("demer" %in% list_cpod_project_codes(con)) +}) From ca8f465d2a7a9dd4595b929f1a42cffcb4bbf19f Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Tue, 12 Oct 2021 16:02:31 +0200 Subject: [PATCH 098/183] Merge pull request #221 from inbo/download_acoustic_dataset Add download_acoustic_dataset() --- tests/testthat/test-list_cpod_project_codes.R | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/tests/testthat/test-list_cpod_project_codes.R b/tests/testthat/test-list_cpod_project_codes.R index 46f7f67..e25d490 100644 --- a/tests/testthat/test-list_cpod_project_codes.R +++ b/tests/testthat/test-list_cpod_project_codes.R @@ -1,11 +1,14 @@ con <- connect_to_etn() test_that("list_cpod_project_codes() returns unique list of values", { - expect_is(list_cpod_project_codes(con), "character") - expect_false(any(duplicated(list_cpod_project_codes(con)))) - expect_true("cpod-lifewatch" %in% list_cpod_project_codes(con)) + vector <- list_cpod_project_codes(con) + expect_is(vector, "character") + expect_false(any(duplicated(vector))) + expect_true(all(!is.na(vector))) + + expect_true("cpod-lifewatch" %in% vector) # Should not include animal or network projects - expect_false("2014_demer" %in% list_cpod_project_codes(con)) - expect_false("demer" %in% list_cpod_project_codes(con)) + expect_false("2014_demer" %in% vector) + expect_false("demer" %in% vector) }) From 19318482523d2dd70c8a1d9bfe9dbe89438aa412 Mon Sep 17 00:00:00 2001 From: Pieter Huybrechts <48065851+PietrH@users.noreply.github.com> Date: Mon, 12 Jun 2023 09:15:11 +0200 Subject: [PATCH 099/183] Clarify README.md --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 8ac7404..5cf3151 100644 --- a/README.md +++ b/README.md @@ -73,7 +73,7 @@ response %>% jsonlite::fromJSON(simplifyVector = TRUE) ``` -However, a fork of the [etn package](https://github.com/inbo/etn) is +However, a branch of the [etn package](https://github.com/inbo/etn) is currently in development that will allow you to do this using built in functions. From f822532abe0daa19f60491e34c53356b5adf1e36 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Tue, 5 Oct 2021 14:55:12 +0200 Subject: [PATCH 100/183] Merge pull request #191 from inbo/sql_views New functions (part 1) --- R/list_tag_serial_numbers.R | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) create mode 100644 R/list_tag_serial_numbers.R diff --git a/R/list_tag_serial_numbers.R b/R/list_tag_serial_numbers.R new file mode 100644 index 0000000..27e3a0a --- /dev/null +++ b/R/list_tag_serial_numbers.R @@ -0,0 +1,20 @@ +#' List all available tag serial numbers +#' +#' @param connection A connection to the ETN database. Defaults to `con`. +#' +#' @export +#' +#' @importFrom glue glue_sql +#' @importFrom DBI dbGetQuery +#' @importFrom stringr str_sort +#' +#' @return A vector of all unique `tag_serial_numbers` present in `common.tag_device`. +list_tag_serial_numbers <- function(connection = con) { + query <- glue_sql( + "SELECT DISTINCT serial_number FROM common.tag_device", + .con = connection + ) + data <- dbGetQuery(connection, query) + + str_sort(data$serial_number, numeric = TRUE) +} From 1bcb6c923f53ef0dd254977188aef692f3186251 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Tue, 5 Oct 2021 14:55:12 +0200 Subject: [PATCH 101/183] Merge pull request #191 from inbo/sql_views New functions (part 1) --- R/list_values.R | 92 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 92 insertions(+) create mode 100644 R/list_values.R diff --git a/R/list_values.R b/R/list_values.R new file mode 100644 index 0000000..efcb8d9 --- /dev/null +++ b/R/list_values.R @@ -0,0 +1,92 @@ +#' List all unique values from a data.frame column +#' +#' Get a vector with all unique values found in a given column of a data.frame. +#' Concatenated values (`A,B`) in the column can be returned as single values +#' (`A` and `B`). +#' +#' @param .data Data frame. Data.frame to select column from. +#' @param column Character or integer. Quoted or unqoted column name or column +#' position. +#' @param split Character (vector). Character or regular expression(s) passed +#' to [strsplit()] to split column values before returning unique values. +#' Defaults to `,`. +#' +#' @return A vector of the same type as the given column. +#' +#' @export +#' +#' @importFrom assertthat assert_that +#' @importFrom glue glue +#' +#' @examples +#' \dontrun{ +#' # List unique scientific_name from a dataframe containing animal information +#' df <- get_animals(animal_project_code = "2014_demer") +#' list_values(df, "scientific_name") +#' +#' # Or using pipe and unquoted column name +#' df %>% list_values(scientific_name) +#' +#' # Or using column position +#' df %>% list_values(6) +#' +#' # tag_serial_number can contain comma-separated values +#' df <- get_animals(animal_id = 5841) +#' df$tag_serial_number +#' +#' # list_values() will split those and return unique values +#' list_values(df, tag_serial_number) +#' +#' # Another expression can be defined to split values (here ".") +#' list_values(df, tag_serial_number, split = "\\.") +#' } +list_values <- function(.data, column, split = ",") { + # check .data + assert_that(is.data.frame(.data)) + # check split + assert_that(is.character(split)) + + arguments <- as.list(match.call()) + + if (is.numeric(arguments$column)){ + col_number <- arguments$column + n_col_df <- ncol(.data) + assert_that(as.integer(col_number) == col_number, + msg = "column number must be an integer") + assert_that(col_number <= ncol(.data), + msg = glue("column number exceeds the number of columns ", + "of .data ({n_col_df})")) + # extract values + values <- .data[,col_number] + # extract column name + col_name <- names(.data)[col_number] + } else { + #check column name + col_name <- as.character(arguments$column) + assert_that(length(col_name) == 1, + msg = "invalid column value") + assert_that(col_name %in% names(.data), + msg = glue("column {col_name} not found in .data")) + + # extract values + if (class(arguments$column) == "name") { + values <- eval(arguments$column, .data) + } else { + if (is.character(arguments$column)) { + values <- .data[[arguments$column]] + } + } + } + + if (is.character(values)) + # extract all values by splitting strings using split value + values <- unlist(strsplit(x = values, split = split)) + + # remove duplicates, unique values only + values <- unique(values) + + # return a message on console + message(glue("{length(values)} unique {col_name} values")) + + return(values) +} From 57afc9f0c5b632b8404b3642dd2832cf5526c0c5 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Tue, 5 Oct 2021 14:55:12 +0200 Subject: [PATCH 102/183] Merge pull request #191 from inbo/sql_views New functions (part 1) --- tests/testthat/test-get_tags.R | 113 --------------------------------- 1 file changed, 113 deletions(-) delete mode 100644 tests/testthat/test-get_tags.R diff --git a/tests/testthat/test-get_tags.R b/tests/testthat/test-get_tags.R deleted file mode 100644 index 3064d3c..0000000 --- a/tests/testthat/test-get_tags.R +++ /dev/null @@ -1,113 +0,0 @@ -con <- connect_to_etn( - username = Sys.getenv("userid"), - password = Sys.getenv("pwd") -) - -# Expected column names -expected_col_names <- c( - "pk", - "tag_id", - "tag_id_alternative", - "telemetry_type", - "manufacturer", - "model", - "frequency", - "type", - "serial_number", - "tag_id_protocol", - "tag_id_code", - "status", - "activation_date", - "battery_estimated_life", - "battery_estimated_end_date", - "sensor_type", - "sensor_slope", - "sensor_intercept", - "sensor_range", - "sensor_transmit_ratio", - "accelerometer_algorithm", - "accelerometer_samples_per_second", - "owner_organization", - "owner_pi", - "financing_project", - "step1_min_delay", - "step1_max_delay", - "step1_power", - "step1_duration", - "step1_acceleration_duration", - "step2_min_delay", - "step2_max_delay", - "step2_power", - "step2_duration", - "step2_acceleration_duration", - "step3_min_delay", - "step3_max_delay", - "step3_power", - "step3_duration", - "step3_acceleration_duration", - "step4_min_delay", - "step4_max_delay", - "step4_power", - "step4_duration", - "step4_acceleration_duration" -) - -tag1 <- "A69-1303-65313" # A sentinel tag with 2 records -tag_multiple <- c("A69-1601-1705", "A69-1601-1707") - -tags_all <- get_tags(con) -tags_all_ref <- get_tags(con, include_ref_tags = TRUE) -tags_tag1 <- get_tags(con, tag_id = tag1) -tags_tag_multiple <- get_tags(con, tag_id = tag_multiple) - -testthat::test_that("Test input", { - expect_error( - get_tags("not_a_connection"), - "Not a connection object to database." - ) - expect_error( - get_tags(con, tag_id = "not_a_tag_id") - ) - expect_error( - get_tags(con, tag_id = c("A69-1601-1705", "not_a_tag_id")) - ) - expect_error( - get_tags(con, include_ref_tags = "not_a_logical") - ) -}) - -testthat::test_that("Test output type", { - expect_is(tags_all, "tbl_df") - expect_is(tags_all_ref, "tbl_df") - expect_is(tags_tag1, "tbl_df") - expect_is(tags_tag_multiple, "tbl_df") -}) - -testthat::test_that("Test column names", { - expect_equal(names(tags_all), expected_col_names) - expect_equal(names(tags_all_ref), expected_col_names) - expect_equal(names(tags_tag1), expected_col_names) - expect_equal(names(tags_tag_multiple), expected_col_names) -}) - -testthat::test_that("Test number of records", { - expect_gt(nrow(tags_all_ref), nrow(tags_all)) - expect_equal(nrow(tags_tag1), 2) - expect_equal(nrow(tags_tag_multiple), 2) -}) - -testthat::test_that("Test if data is filtered on parameter", { - expect_equal( - tags_tag1 %>% distinct(tag_id) %>% pull(), - c(tag1) - ) - expect_equal( - tags_tag_multiple %>% distinct(tag_id) %>% arrange(tag_id) %>% pull(), - tag_multiple - ) -}) - -testthat::test_that("Test unique ids", { - expect_equal(nrow(tags_all), nrow(tags_all %>% distinct(pk))) - # expect_equal(nrow(tags_all), nrow(tags_all %>% distinct(tag_id))) # This is not the case -}) From 16af4215a12bd99df124489f82caa439d5680614 Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Thu, 7 Oct 2021 22:09:46 +0200 Subject: [PATCH 103/183] Don't use view2 for list_ functions --- R/list_tag_serial_numbers.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/list_tag_serial_numbers.R b/R/list_tag_serial_numbers.R index 27e3a0a..c7bffdb 100644 --- a/R/list_tag_serial_numbers.R +++ b/R/list_tag_serial_numbers.R @@ -8,7 +8,8 @@ #' @importFrom DBI dbGetQuery #' @importFrom stringr str_sort #' -#' @return A vector of all unique `tag_serial_numbers` present in `common.tag_device`. +#' @return A vector of all unique `tag_serial_numbers` present in +#' `common.tag_device`. list_tag_serial_numbers <- function(connection = con) { query <- glue_sql( "SELECT DISTINCT serial_number FROM common.tag_device", From 5d6fbdac9e87679a90820ee3e985913422ccf961 Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Tue, 12 Oct 2021 19:24:16 +0200 Subject: [PATCH 104/183] Move @return above @export for list_ functions --- R/list_tag_serial_numbers.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/list_tag_serial_numbers.R b/R/list_tag_serial_numbers.R index c7bffdb..bd3c652 100644 --- a/R/list_tag_serial_numbers.R +++ b/R/list_tag_serial_numbers.R @@ -2,14 +2,14 @@ #' #' @param connection A connection to the ETN database. Defaults to `con`. #' +#' @return A vector of all unique `tag_serial_numbers` present in +#' `common.tag_device`. +#' #' @export #' #' @importFrom glue glue_sql #' @importFrom DBI dbGetQuery #' @importFrom stringr str_sort -#' -#' @return A vector of all unique `tag_serial_numbers` present in -#' `common.tag_device`. list_tag_serial_numbers <- function(connection = con) { query <- glue_sql( "SELECT DISTINCT serial_number FROM common.tag_device", From 24918c90691457480ac5aefa8f3edd9f500c140b Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Tue, 30 Nov 2021 10:11:23 +0100 Subject: [PATCH 105/183] Merge pull request #241 from inbo/importFrom Fix #240: use :: over importFrom --- R/list_tag_serial_numbers.R | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/R/list_tag_serial_numbers.R b/R/list_tag_serial_numbers.R index bd3c652..3730167 100644 --- a/R/list_tag_serial_numbers.R +++ b/R/list_tag_serial_numbers.R @@ -6,16 +6,12 @@ #' `common.tag_device`. #' #' @export -#' -#' @importFrom glue glue_sql -#' @importFrom DBI dbGetQuery -#' @importFrom stringr str_sort list_tag_serial_numbers <- function(connection = con) { - query <- glue_sql( + query <- glue::glue_sql( "SELECT DISTINCT serial_number FROM common.tag_device", .con = connection ) - data <- dbGetQuery(connection, query) + data <- DBI::dbGetQuery(connection, query) - str_sort(data$serial_number, numeric = TRUE) + stringr::str_sort(data$serial_number, numeric = TRUE) } From f6fbb25c57fb1b20082341b20538815752a34e1e Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Tue, 5 Oct 2021 14:55:12 +0200 Subject: [PATCH 106/183] Merge pull request #191 from inbo/sql_views New functions (part 1) --- tests/testthat/test-list_tag_serial_numbers.R | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 tests/testthat/test-list_tag_serial_numbers.R diff --git a/tests/testthat/test-list_tag_serial_numbers.R b/tests/testthat/test-list_tag_serial_numbers.R new file mode 100644 index 0000000..dd646b2 --- /dev/null +++ b/tests/testthat/test-list_tag_serial_numbers.R @@ -0,0 +1,7 @@ +con <- connect_to_etn() + +testthat::test_that("Test output", { + expect_is(list_tag_serial_numbers(con), "character") + expect_false(any(duplicated(list_tag_serial_numbers(con)))) + expect_true("1157779" %in% list_tag_serial_numbers(con)) +}) From ab5113eb238481442dfc43f8eec1d9fb20a3939b Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Wed, 13 Oct 2021 11:20:47 +0200 Subject: [PATCH 107/183] Run examples for website #227 --- R/list_values.R | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/R/list_values.R b/R/list_values.R index efcb8d9..08fb289 100644 --- a/R/list_values.R +++ b/R/list_values.R @@ -19,19 +19,22 @@ #' @importFrom glue glue #' #' @examples -#' \dontrun{ +#' # Set default connection variable +#' con <- connect_to_etn() +#' library(dplyr) # For %>% +#' #' # List unique scientific_name from a dataframe containing animal information -#' df <- get_animals(animal_project_code = "2014_demer") +#' df <- get_animals(con, animal_project_code = "2014_demer") #' list_values(df, "scientific_name") #' #' # Or using pipe and unquoted column name #' df %>% list_values(scientific_name) #' #' # Or using column position -#' df %>% list_values(6) +#' df %>% list_values(8) #' #' # tag_serial_number can contain comma-separated values -#' df <- get_animals(animal_id = 5841) +#' df <- get_animals(con, animal_id = 5841) #' df$tag_serial_number #' #' # list_values() will split those and return unique values @@ -39,7 +42,6 @@ #' #' # Another expression can be defined to split values (here ".") #' list_values(df, tag_serial_number, split = "\\.") -#' } list_values <- function(.data, column, split = ",") { # check .data assert_that(is.data.frame(.data)) From 755b79eabf0583e2d8f13896f689ab31ac29ab58 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Tue, 30 Nov 2021 10:11:23 +0100 Subject: [PATCH 108/183] Merge pull request #241 from inbo/importFrom Fix #240: use :: over importFrom --- R/list_values.R | 23 ++++++++++------------- 1 file changed, 10 insertions(+), 13 deletions(-) diff --git a/R/list_values.R b/R/list_values.R index 08fb289..9b4b728 100644 --- a/R/list_values.R +++ b/R/list_values.R @@ -15,9 +15,6 @@ #' #' @export #' -#' @importFrom assertthat assert_that -#' @importFrom glue glue -#' #' @examples #' # Set default connection variable #' con <- connect_to_etn() @@ -44,20 +41,20 @@ #' list_values(df, tag_serial_number, split = "\\.") list_values <- function(.data, column, split = ",") { # check .data - assert_that(is.data.frame(.data)) + assertthat::assert_that(is.data.frame(.data)) # check split - assert_that(is.character(split)) + assertthat::assert_that(is.character(split)) arguments <- as.list(match.call()) if (is.numeric(arguments$column)){ col_number <- arguments$column n_col_df <- ncol(.data) - assert_that(as.integer(col_number) == col_number, + assertthat::assert_that(as.integer(col_number) == col_number, msg = "column number must be an integer") - assert_that(col_number <= ncol(.data), - msg = glue("column number exceeds the number of columns ", - "of .data ({n_col_df})")) + assertthat::assert_that(col_number <= ncol(.data), + msg = glue::glue("column number exceeds the number of columns ", + "of .data ({n_col_df})")) # extract values values <- .data[,col_number] # extract column name @@ -65,10 +62,10 @@ list_values <- function(.data, column, split = ",") { } else { #check column name col_name <- as.character(arguments$column) - assert_that(length(col_name) == 1, + assertthat::assert_that(length(col_name) == 1, msg = "invalid column value") - assert_that(col_name %in% names(.data), - msg = glue("column {col_name} not found in .data")) + assertthat::assert_that(col_name %in% names(.data), + msg = glue::glue("column {col_name} not found in .data")) # extract values if (class(arguments$column) == "name") { @@ -88,7 +85,7 @@ list_values <- function(.data, column, split = ",") { values <- unique(values) # return a message on console - message(glue("{length(values)} unique {col_name} values")) + message(glue::glue("{length(values)} unique {col_name} values")) return(values) } From 0a187ba8593cf66f6b765f8f9809445fb97acb86 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Tue, 5 Oct 2021 14:55:12 +0200 Subject: [PATCH 109/183] Merge pull request #191 from inbo/sql_views New functions (part 1) --- tests/testthat/test-list_values.R | 71 +++++++++++++++++++++++++++++++ 1 file changed, 71 insertions(+) create mode 100644 tests/testthat/test-list_values.R diff --git a/tests/testthat/test-list_values.R b/tests/testthat/test-list_values.R new file mode 100644 index 0000000..3e98709 --- /dev/null +++ b/tests/testthat/test-list_values.R @@ -0,0 +1,71 @@ +df <- data.frame( + chr_col = c("A", "B,C", "C,A", "D"), + num_col = c(1, 2, 2, 3), + dot_sep_col = c("A", "B.C", "C.A", "D"), + stringsAsFactors = FALSE +) + +test_that("list_values() returns error for incorrect input", { + # .data must be a data.frame + expect_error(list_values(1, "num_col"), ".data is not a data.frame") + + # column must be a character, a column name or a column position + expect_error( + list_values(df, TRUE), "column TRUE not found in .data" + ) + # column must be the name of a valid column of .data + expect_error( + list_values(df, strange_col), "column strange_col not found in .data" + ) + # column must be the character version of the name of a valid column of .data + expect_error( + list_values(df, "strange_col"), "column strange_col not found in .data" + ) + # Not more than one column allowed + expect_error( + list_values(df, c(chr_col, dot_col)), "invalid column value" + ) + # column must be an integer (decimal part = 0) + expect_error( + list_values(df, .1), "column number must be an integer" + ) + # column must be an integer higher than 0 + expect_error( + list_values(df, -2), "invalid column value" + ) + # column must be an integer equal or less than number of columns + expect_error( + list_values(df, 5), + "column number exceeds the number of columns of .data (3)", + fixed = TRUE + ) + + # split must be a character + expect_error( + list_values(df, chr_col, split = 1), + "split is not a character vector" + ) +}) + +testthat::test_that("list_values() returns a vector with unique values", { + # Output has right class + expect_is(list_values(df, chr_col), class = "character") + expect_is(list_values(df, num_col), class = "numeric") + + # Output value is correct with default split value (comma) + expect_equal(list_values(df, chr_col), c("A", "B", "C", "D")) + + # Output value is correct with non default split value + expect_equal(list_values(df, dot_sep_col, "\\."), c("A", "B", "C", "D")) + + # Output value doesn't depend on the way column is passed + expect_equal(list_values(df, column = chr_col), list_values(df, "chr_col")) + expect_equal(list_values(df, column = chr_col), list_values(df, 1)) + expect_equal(list_values(df, "num_col"), c(1, 2, 3)) + + # If the split value is not present in column, return a copy of the column + expect_equal( + list_values(df, "dot_sep_col", split = ","), + df$dot_sep_col + ) +}) From 183171134c7f639d356e279fdaeb66da80a376ec Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 6 Oct 2021 15:38:54 +0200 Subject: [PATCH 110/183] Merge pull request #196 from inbo/get_tags Create single get_tags() function --- tests/testthat/test-get_tags.R | 162 +++++++++++++++++++++++++++++++++ 1 file changed, 162 insertions(+) create mode 100644 tests/testthat/test-get_tags.R diff --git a/tests/testthat/test-get_tags.R b/tests/testthat/test-get_tags.R new file mode 100644 index 0000000..f89e303 --- /dev/null +++ b/tests/testthat/test-get_tags.R @@ -0,0 +1,162 @@ +con <- connect_to_etn() + +test_that("get_tags() returns error for incorrect connection", { + expect_error( + get_tags(con = "not_a_connection"), + "Not a connection object to database." + ) +}) + +test_that("get_tags() returns a tibble", { + df <- get_tags(con) + expect_s3_class(df, "data.frame") + expect_s3_class(df, "tbl") +}) + +test_that("get_tags() returns the expected columns", { + df <- get_tags(con) + expected_col_names <- c( + "tag_serial_number", + "tag_type", + "tag_subtype", + "sensor_type", + "acoustic_tag_id", + "acoustic_tag_id_alternative", + "manufacturer", + "model", + "frequency", + "status", + "activation_date", + "battery_estimated_life", + "battery_estimated_end_date", + "sensor_slope", + "sensor_intercept", + "sensor_range", + "sensor_transmit_ratio", + "accelerometer_algorithm", + "accelerometer_samples_per_second", + "owner_organization", + "owner_pi", + "financing_project", + "step1_min_delay", + "step1_max_delay", + "step1_power", + "step1_duration", + "step1_acceleration_duration", + "step2_min_delay", + "step2_max_delay", + "step2_power", + "step2_duration", + "step2_acceleration_duration", + "step3_min_delay", + "step3_max_delay", + "step3_power", + "step3_duration", + "step3_acceleration_duration", + "step4_min_delay", + "step4_max_delay", + "step4_power", + "step4_duration", + "step4_acceleration_duration", + "tag_device_id" + ) + expect_equal(names(df), expected_col_names) +}) + +test_that("get_tags() allows selecting on tag_serial_number", { + # Errors + expect_error(get_tags(con, tag_serial_number = "0")) # Not an existing value + expect_error(get_tags(con, tag_serial_number = c("1187450", "0"))) + + # Select single value + single_select <- "1187450" # From 2014_demer + single_select_df <- get_tags(con, tag_serial_number = single_select) + expect_equal( + single_select_df %>% distinct(tag_serial_number) %>% pull(), + c(single_select) + ) + expect_equal(nrow(single_select_df), 1) + # Note that not all tag_serial_number return a single row, e.g. "461076" + + # Select multiple values + multi_select <- c(1187449, "1187450") # Integers are allowed + multi_select_df <- get_tags(con, tag_serial_number = multi_select) + expect_equal( + multi_select_df %>% distinct(tag_serial_number) %>% pull() %>% sort(), + c(as.character(multi_select)) # Output will be all character + ) + expect_equal(nrow(multi_select_df), 2) +}) + +test_that("get_tags() allows selecting on tag_type", { + # Errors + expect_error(get_tags(con, tag_type = "not_a_tag_type")) + expect_error(get_tags(con, tag_type = c("archival", "not_a_tag_type"))) + + # Select single value + single_select <- "archival" + single_select_df <- get_tags(con, tag_type = single_select) + expect_equal( + single_select_df %>% distinct(tag_type) %>% pull(), + c(single_select) + ) + expect_gt(nrow(single_select_df), 0) + + # Select multiple values + multi_select <- c("acoustic-archival", "archival") + multi_select_df <- get_tags(con, tag_type = multi_select) + expect_equal( + multi_select_df %>% distinct(tag_type) %>% pull() %>% sort(), + c(multi_select) + ) + expect_gt(nrow(multi_select_df), nrow(single_select_df)) +}) + +test_that("get_tags() allows selecting on tag_subtype", { + # Errors + expect_error(get_tags(con, tag_subtype = "not_a_tag_subtype")) + expect_error(get_tags(con, tag_subtype = c("archival", "not_a_tag_subtype"))) + + # Select single value + single_select <- "built-in" + single_select_df <- get_tags(con, tag_subtype = single_select) + expect_equal( + single_select_df %>% distinct(tag_subtype) %>% pull(), + c(single_select) + ) + expect_gt(nrow(single_select_df), 0) + + # Select multiple values + multi_select <- c("built-in", "range") + multi_select_df <- get_tags(con, tag_subtype = multi_select) + expect_equal( + multi_select_df %>% distinct(tag_subtype) %>% pull() %>% sort(), + c(multi_select) + ) + expect_gt(nrow(multi_select_df), nrow(single_select_df)) +}) + +test_that("get_tags() allows selecting on acoustic_tag_id", { + # Errors + expect_error(get_tags(con, acoustic_tag_id = "not_a_tag_id")) + expect_error(get_tags(con, acoustic_tag_id = c("A69-1601-16130", "not_a_tag_id"))) + + # Select single value + single_select <- "A69-1601-16130" # From 2014_demer + single_select_df <- get_tags(con, acoustic_tag_id = single_select) + expect_equal( + single_select_df %>% distinct(acoustic_tag_id) %>% pull(), + c(single_select) + ) + expect_equal(nrow(single_select_df), 1) + # Note that not all acoustic_tag_id return a single row, e.g. "A180-1702-48973" + + # Select multiple values + multi_select <- c("A69-1601-16129", "A69-1601-16130") + multi_select_df <- get_tags(con, acoustic_tag_id = multi_select) + expect_equal( + multi_select_df %>% distinct(acoustic_tag_id) %>% pull() %>% sort(), + c(multi_select) + ) + expect_equal(nrow(multi_select_df), 2) +}) From 2f728e97c096a05aedc57e84292c450f6c21dd53 Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Wed, 6 Oct 2021 16:07:04 +0200 Subject: [PATCH 111/183] Add test for tags returning two rows --- tests/testthat/test-get_tags.R | 32 +++++++++++++++++++++++++++++++- 1 file changed, 31 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-get_tags.R b/tests/testthat/test-get_tags.R index f89e303..9e4cd6f 100644 --- a/tests/testthat/test-get_tags.R +++ b/tests/testthat/test-get_tags.R @@ -76,7 +76,7 @@ test_that("get_tags() allows selecting on tag_serial_number", { c(single_select) ) expect_equal(nrow(single_select_df), 1) - # Note that not all tag_serial_number return a single row, e.g. "461076" + # Note that not all tag_serial_number return a single row, see further test # Select multiple values multi_select <- c(1187449, "1187450") # Integers are allowed @@ -160,3 +160,33 @@ test_that("get_tags() allows selecting on acoustic_tag_id", { ) expect_equal(nrow(multi_select_df), 2) }) + +test_that("get_tags() can return multiple rows for a single tag", { + # A sentinel tag with temp + pressure sensor + tag_1_df <- get_tags(con, tag_serial_number = 1292638) + expect_equal(nrow(tag_1_df), 2) # 2 rows: temp + pressure + expect_equal( + tag_1_df %>% distinct(tag_type, tag_subtype, sensor_type, acoustic_tag_id), + as_tibble(data.frame( + tag_type = "acoustic-archival", + tag_subtype = "sentinel", + sensor_type = c("temperature", "pressure"), + acoustic_tag_id = c("A69-9006-3638", "A69-9006-3639"), + stringsAsFactors = FALSE + )) + ) + + # A built-in tag with two protocols: https://github.com/inbo/etn/issues/177#issuecomment-925578186 + tag_2_df <- get_tags(con, tag_serial_number = 461076) + expect_equal(nrow(tag_2_df), 2) # 2 rows: H170 + A180 + expect_equal( + tag_2_df %>% distinct(tag_type, tag_subtype, sensor_type, acoustic_tag_id), + as_tibble(data.frame( + tag_type = "acoustic", + tag_subtype = "built-in", + sensor_type = NA_character_, + acoustic_tag_id = c("H170-1802-62076", "A180-1702-62076"), + stringsAsFactors = FALSE + )) + ) +}) From 040277b12f5c50604ff33777326df7071e083ed5 Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Wed, 6 Oct 2021 16:51:12 +0200 Subject: [PATCH 112/183] Add tests for tag_type, tag_subtype --- tests/testthat/test-get_tags.R | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/tests/testthat/test-get_tags.R b/tests/testthat/test-get_tags.R index 9e4cd6f..57b7123 100644 --- a/tests/testthat/test-get_tags.R +++ b/tests/testthat/test-get_tags.R @@ -190,3 +190,15 @@ test_that("get_tags() can return multiple rows for a single tag", { )) ) }) + +test_that("get_tags() returns correct tag_type and tag_subtype", { + df <- get_tags(con) + expect_equal( + df %>% distinct(tag_type) %>% pull() %>% sort(), + c("acoustic", "acoustic-archival", "archival") + ) + expect_equal( + df %>% distinct(tag_subtype) %>% pull() %>% sort(), + c("animal", "built-in", "range", "sentinel") + ) +}) From 490d702c9aa901f1cbf180d9315e15ba7805c80d Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 6 Oct 2021 16:55:38 +0200 Subject: [PATCH 113/183] Merge pull request #199 from inbo/get_tags Remove unused get_archival_tags() function --- tests/testthat/test-get_tags.R | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/tests/testthat/test-get_tags.R b/tests/testthat/test-get_tags.R index 57b7123..83a4edc 100644 --- a/tests/testthat/test-get_tags.R +++ b/tests/testthat/test-get_tags.R @@ -161,6 +161,17 @@ test_that("get_tags() allows selecting on acoustic_tag_id", { expect_equal(nrow(multi_select_df), 2) }) +test_that("get_tags() allows selecting on multiple parameters", { + multiple_parameters_df <- get_tags( + con, + tag_serial_number = "1187450", + tag_type = "acoustic", + tag_subtype = "animal", + acoustic_tag_id = "A69-1601-16130" + ) + expect_equal(nrow(multiple_parameters_df), 1) +}) + test_that("get_tags() can return multiple rows for a single tag", { # A sentinel tag with temp + pressure sensor tag_1_df <- get_tags(con, tag_serial_number = 1292638) From 0c4397e3faae642f3d7dd171a682737ac0f682b9 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 6 Oct 2021 16:55:38 +0200 Subject: [PATCH 114/183] Merge pull request #199 from inbo/get_tags Remove unused get_archival_tags() function --- tests/testthat/test-list_tag_serial_numbers.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-list_tag_serial_numbers.R b/tests/testthat/test-list_tag_serial_numbers.R index dd646b2..772507d 100644 --- a/tests/testthat/test-list_tag_serial_numbers.R +++ b/tests/testthat/test-list_tag_serial_numbers.R @@ -1,7 +1,7 @@ con <- connect_to_etn() -testthat::test_that("Test output", { - expect_is(list_tag_serial_numbers(con), "character") +test_that("list_tag_serial_numbers() returns unique list of values", { + expect_is(list_tag_serial_numbers(con), "character") # Even though the DB values are integer expect_false(any(duplicated(list_tag_serial_numbers(con)))) - expect_true("1157779" %in% list_tag_serial_numbers(con)) + expect_true("1187450" %in% list_tag_serial_numbers(con)) }) From 8fa45b44d82132c7e9003d593fe9381607ec6f49 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 6 Oct 2021 16:55:38 +0200 Subject: [PATCH 115/183] Merge pull request #199 from inbo/get_tags Remove unused get_archival_tags() function --- tests/testthat/test-list_values.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-list_values.R b/tests/testthat/test-list_values.R index 3e98709..637dd2c 100644 --- a/tests/testthat/test-list_values.R +++ b/tests/testthat/test-list_values.R @@ -47,7 +47,7 @@ test_that("list_values() returns error for incorrect input", { ) }) -testthat::test_that("list_values() returns a vector with unique values", { +test_that("list_values() returns a vector with unique values", { # Output has right class expect_is(list_values(df, chr_col), class = "character") expect_is(list_values(df, num_col), class = "numeric") From 0b5fe4c5fafb28f8cca86000c008b7dd87fad42d Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 6 Oct 2021 22:46:43 +0200 Subject: [PATCH 116/183] Merge pull request #200 from inbo/combined_tag Create a combined tag view (tag.sql) that is used in multiple functions --- tests/testthat/test-get_tags.R | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/tests/testthat/test-get_tags.R b/tests/testthat/test-get_tags.R index 83a4edc..ef15d60 100644 --- a/tests/testthat/test-get_tags.R +++ b/tests/testthat/test-get_tags.R @@ -173,21 +173,21 @@ test_that("get_tags() allows selecting on multiple parameters", { }) test_that("get_tags() can return multiple rows for a single tag", { - # A sentinel tag with temp + pressure sensor - tag_1_df <- get_tags(con, tag_serial_number = 1292638) - expect_equal(nrow(tag_1_df), 2) # 2 rows: temp + pressure + # A sentinel acoustic-archival tag with pressure + temperature sensor + tag_1_df <- get_tags(con, tag_serial_number = 1400185) + expect_equal(nrow(tag_1_df), 2) # 2 rows: presure + temperature expect_equal( tag_1_df %>% distinct(tag_type, tag_subtype, sensor_type, acoustic_tag_id), as_tibble(data.frame( tag_type = "acoustic-archival", tag_subtype = "sentinel", - sensor_type = c("temperature", "pressure"), - acoustic_tag_id = c("A69-9006-3638", "A69-9006-3639"), + sensor_type = c("pressure", "temperature"), + acoustic_tag_id = c("A69-9006-11100", "A69-9006-11099"), stringsAsFactors = FALSE )) ) - # A built-in tag with two protocols: https://github.com/inbo/etn/issues/177#issuecomment-925578186 + # A built-in acoustic tag with two protocols: https://github.com/inbo/etn/issues/177#issuecomment-925578186 tag_2_df <- get_tags(con, tag_serial_number = 461076) expect_equal(nrow(tag_2_df), 2) # 2 rows: H170 + A180 expect_equal( From 9d475bd47478ccfc1dd0deb6a12034c7ba42bcdb Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Wed, 6 Oct 2021 22:46:43 +0200 Subject: [PATCH 117/183] Merge pull request #200 from inbo/combined_tag Create a combined tag view (tag.sql) that is used in multiple functions --- tests/testthat/test-list_tag_serial_numbers.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-list_tag_serial_numbers.R b/tests/testthat/test-list_tag_serial_numbers.R index 772507d..c180bee 100644 --- a/tests/testthat/test-list_tag_serial_numbers.R +++ b/tests/testthat/test-list_tag_serial_numbers.R @@ -1,7 +1,7 @@ con <- connect_to_etn() test_that("list_tag_serial_numbers() returns unique list of values", { - expect_is(list_tag_serial_numbers(con), "character") # Even though the DB values are integer + expect_is(list_tag_serial_numbers(con), "character") expect_false(any(duplicated(list_tag_serial_numbers(con)))) expect_true("1187450" %in% list_tag_serial_numbers(con)) }) From f407cb59fed6985264ff767ff66f3e3eb08be727 Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Fri, 8 Oct 2021 10:11:03 +0200 Subject: [PATCH 118/183] Add 5 fields to get_tags(), see #208 --- tests/testthat/test-get_tags.R | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/tests/testthat/test-get_tags.R b/tests/testthat/test-get_tags.R index ef15d60..1288c58 100644 --- a/tests/testthat/test-get_tags.R +++ b/tests/testthat/test-get_tags.R @@ -29,6 +29,11 @@ test_that("get_tags() returns the expected columns", { "activation_date", "battery_estimated_life", "battery_estimated_end_date", + "resolution", + "unit", + "accuracy", + "range_min", + "range_max", "sensor_slope", "sensor_intercept", "sensor_range", From 87fc8696e6ddf797264c338f68848e86e61a3bc9 Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Mon, 11 Oct 2021 19:25:16 +0200 Subject: [PATCH 119/183] Fix #208 --- tests/testthat/test-get_tags.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/tests/testthat/test-get_tags.R b/tests/testthat/test-get_tags.R index 1288c58..14c67ee 100644 --- a/tests/testthat/test-get_tags.R +++ b/tests/testthat/test-get_tags.R @@ -29,14 +29,14 @@ test_that("get_tags() returns the expected columns", { "activation_date", "battery_estimated_life", "battery_estimated_end_date", - "resolution", - "unit", - "accuracy", - "range_min", - "range_max", "sensor_slope", "sensor_intercept", "sensor_range", + "sensor_range_min", + "sensor_range_max", + "sensor_resolution", + "sensor_unit", + "sensor_accuracy", "sensor_transmit_ratio", "accelerometer_algorithm", "accelerometer_samples_per_second", From 01f9450675d48fd3e5b65c1c5119e988010f76fd Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Tue, 12 Oct 2021 16:02:31 +0200 Subject: [PATCH 120/183] Merge pull request #221 from inbo/download_acoustic_dataset Add download_acoustic_dataset() --- tests/testthat/test-get_tags.R | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/tests/testthat/test-get_tags.R b/tests/testthat/test-get_tags.R index 14c67ee..e485e3f 100644 --- a/tests/testthat/test-get_tags.R +++ b/tests/testthat/test-get_tags.R @@ -63,6 +63,7 @@ test_that("get_tags() returns the expected columns", { "step4_power", "step4_duration", "step4_acceleration_duration", + "tag_id", "tag_device_id" ) expect_equal(names(df), expected_col_names) @@ -178,30 +179,30 @@ test_that("get_tags() allows selecting on multiple parameters", { }) test_that("get_tags() can return multiple rows for a single tag", { - # A sentinel acoustic-archival tag with pressure + temperature sensor + # A sentinel acoustic-archival tag with temperature + pressure sensor tag_1_df <- get_tags(con, tag_serial_number = 1400185) - expect_equal(nrow(tag_1_df), 2) # 2 rows: presure + temperature + expect_equal(nrow(tag_1_df), 2) # 2 rows: temperature + presure expect_equal( - tag_1_df %>% distinct(tag_type, tag_subtype, sensor_type, acoustic_tag_id), + tag_1_df %>% arrange(acoustic_tag_id) %>% distinct(tag_type, tag_subtype, sensor_type, acoustic_tag_id), as_tibble(data.frame( tag_type = "acoustic-archival", tag_subtype = "sentinel", - sensor_type = c("pressure", "temperature"), - acoustic_tag_id = c("A69-9006-11100", "A69-9006-11099"), + sensor_type = c("temperature", "pressure"), + acoustic_tag_id = c("A69-9006-11099", "A69-9006-11100"), stringsAsFactors = FALSE )) ) # A built-in acoustic tag with two protocols: https://github.com/inbo/etn/issues/177#issuecomment-925578186 tag_2_df <- get_tags(con, tag_serial_number = 461076) - expect_equal(nrow(tag_2_df), 2) # 2 rows: H170 + A180 + expect_equal(nrow(tag_2_df), 2) # 2 rows: A180 + H170 expect_equal( - tag_2_df %>% distinct(tag_type, tag_subtype, sensor_type, acoustic_tag_id), + tag_2_df %>% arrange(acoustic_tag_id) %>% distinct(tag_type, tag_subtype, sensor_type, acoustic_tag_id), as_tibble(data.frame( tag_type = "acoustic", tag_subtype = "built-in", sensor_type = NA_character_, - acoustic_tag_id = c("H170-1802-62076", "A180-1702-62076"), + acoustic_tag_id = c("A180-1702-62076", "H170-1802-62076"), stringsAsFactors = FALSE )) ) From e3d475b70aeb6dd9c2e873a98796857d6e1226c4 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Tue, 12 Oct 2021 16:02:31 +0200 Subject: [PATCH 121/183] Merge pull request #221 from inbo/download_acoustic_dataset Add download_acoustic_dataset() --- tests/testthat/test-list_tag_serial_numbers.R | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-list_tag_serial_numbers.R b/tests/testthat/test-list_tag_serial_numbers.R index c180bee..acf9515 100644 --- a/tests/testthat/test-list_tag_serial_numbers.R +++ b/tests/testthat/test-list_tag_serial_numbers.R @@ -1,7 +1,11 @@ con <- connect_to_etn() test_that("list_tag_serial_numbers() returns unique list of values", { - expect_is(list_tag_serial_numbers(con), "character") - expect_false(any(duplicated(list_tag_serial_numbers(con)))) - expect_true("1187450" %in% list_tag_serial_numbers(con)) + vector <- list_tag_serial_numbers(con) + + expect_is(vector, "character") + expect_false(any(duplicated(vector))) + expect_true(all(!is.na(vector))) + + expect_true("1187450" %in% vector) }) From 169acebaf430ca7bb366f578b30954326407f42e Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Mon, 18 Oct 2021 14:10:57 +0200 Subject: [PATCH 122/183] Add 5 fields to get_tags() Closes #215 --- tests/testthat/test-get_tags.R | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/tests/testthat/test-get_tags.R b/tests/testthat/test-get_tags.R index e485e3f..821ca66 100644 --- a/tests/testthat/test-get_tags.R +++ b/tests/testthat/test-get_tags.R @@ -29,6 +29,11 @@ test_that("get_tags() returns the expected columns", { "activation_date", "battery_estimated_life", "battery_estimated_end_date", + "length", + "diameter", + "weight", + "floating", + "archive_memory", "sensor_slope", "sensor_intercept", "sensor_range", From 776e7228a70593d282b5d1a754782cbfb4f54dad Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Tue, 30 Nov 2021 10:11:23 +0100 Subject: [PATCH 123/183] Merge pull request #241 from inbo/importFrom Fix #240: use :: over importFrom --- tests/testthat/test-get_tags.R | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-get_tags.R b/tests/testthat/test-get_tags.R index 821ca66..c114c8d 100644 --- a/tests/testthat/test-get_tags.R +++ b/tests/testthat/test-get_tags.R @@ -188,8 +188,10 @@ test_that("get_tags() can return multiple rows for a single tag", { tag_1_df <- get_tags(con, tag_serial_number = 1400185) expect_equal(nrow(tag_1_df), 2) # 2 rows: temperature + presure expect_equal( - tag_1_df %>% arrange(acoustic_tag_id) %>% distinct(tag_type, tag_subtype, sensor_type, acoustic_tag_id), - as_tibble(data.frame( + tag_1_df %>% + dplyr::arrange(acoustic_tag_id) %>% + distinct(tag_type, tag_subtype, sensor_type, acoustic_tag_id), + dplyr::as_tibble(data.frame( tag_type = "acoustic-archival", tag_subtype = "sentinel", sensor_type = c("temperature", "pressure"), @@ -202,8 +204,10 @@ test_that("get_tags() can return multiple rows for a single tag", { tag_2_df <- get_tags(con, tag_serial_number = 461076) expect_equal(nrow(tag_2_df), 2) # 2 rows: A180 + H170 expect_equal( - tag_2_df %>% arrange(acoustic_tag_id) %>% distinct(tag_type, tag_subtype, sensor_type, acoustic_tag_id), - as_tibble(data.frame( + tag_2_df %>% + dplyr::arrange(acoustic_tag_id) %>% + distinct(tag_type, tag_subtype, sensor_type, acoustic_tag_id), + dplyr::as_tibble(data.frame( tag_type = "acoustic", tag_subtype = "built-in", sensor_type = NA_character_, From 1bad0035dae9149f1cf15c3ce94a9fc63d52b3bb Mon Sep 17 00:00:00 2001 From: peterdesmet Date: Fri, 4 Nov 2022 12:33:16 +0100 Subject: [PATCH 124/183] Merge branch 'main' of https://github.com/inbo/etn into main --- tests/testthat/test-get_tags.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-get_tags.R b/tests/testthat/test-get_tags.R index c114c8d..570915a 100644 --- a/tests/testthat/test-get_tags.R +++ b/tests/testthat/test-get_tags.R @@ -193,7 +193,7 @@ test_that("get_tags() can return multiple rows for a single tag", { distinct(tag_type, tag_subtype, sensor_type, acoustic_tag_id), dplyr::as_tibble(data.frame( tag_type = "acoustic-archival", - tag_subtype = "sentinel", + tag_subtype = "animal", sensor_type = c("temperature", "pressure"), acoustic_tag_id = c("A69-9006-11099", "A69-9006-11100"), stringsAsFactors = FALSE From 441dbd2cdfdff8f0918a9a269fce48affe4a2f87 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Fri, 9 Dec 2022 16:44:01 +0100 Subject: [PATCH 125/183] Merge pull request #257 from inbo/dwc Add `write_dwc()` function --- inst/sql/dwc_occurrence.sql | 252 ++++++++++++++++++++++++++++++++++++ 1 file changed, 252 insertions(+) create mode 100644 inst/sql/dwc_occurrence.sql diff --git a/inst/sql/dwc_occurrence.sql b/inst/sql/dwc_occurrence.sql new file mode 100644 index 0000000..9cc9237 --- /dev/null +++ b/inst/sql/dwc_occurrence.sql @@ -0,0 +1,252 @@ +/* +Schema: https://rs.gbif.org/core/dwc_occurrence_2022-02-02.xml +*/ + +/* HELPER TABLES */ + +WITH +-- ANIMALS +-- Select animals from animal_project_code +animals AS ( + SELECT * + FROM common.animal_release_limited AS animal + LEFT JOIN common.projects AS animal_project + ON animal.project_fk = animal_project.id + WHERE + LOWER(animal_project.projectcode) = {animal_project_code} +), +-- EVENTS +-- Animals contain multiple events (capture, release, surgery, recapture) as columns +-- Transpose events to rows and exclude those without date information +events AS ( + SELECT * + FROM + ( + SELECT + animal.id_pk AS animal_id_pk, + 'capture' AS protocol, + animal.catched_date_time AS date, + animal.capture_location AS locality, + animal.capture_latitude AS latitude, + animal.capture_longitude AS longitude + FROM animals AS animal + UNION + SELECT + animal.id_pk AS animal_id_pk, + 'surgery' AS protocol, + animal.date_of_surgery AS date, + animal.surgery_location AS locality, + animal.surgery_latitude AS latitude, + animal.surgery_longitude AS longitude + FROM animals AS animal + UNION + SELECT + animal.id_pk AS animal_id_pk, + 'release' AS protocol, + animal.utc_release_date_time AS date, + animal.release_location AS locality, + animal.release_latitude AS latitude, + animal.release_longitude AS longitude + FROM animals AS animal + UNION + SELECT + animal.id_pk AS animal_id_pk, + 'recapture' AS protocol, + animal.recapture_date AS date, + NULL AS locality, + NULL AS latitude, + NULL AS longitude + FROM animals AS animal + ) AS events + WHERE + date IS NOT NULL + ORDER BY + animal_id_pk, + date +), +-- HOURLY DETECTION GROUPS +-- Select detections from animal_project_code +-- Group detections by animal+tag+date+hour combination and get first timestamp and count +detection_groups AS ( + SELECT + det.animal_id_pk || det.tag_serial_number || DATE_TRUNC('hour', det.datetime) AS det_group, + det.animal_id_pk, + det.tag_serial_number, + min(det.datetime) AS datetime, + count(*) AS det_group_count + FROM acoustic.detections_limited AS det + WHERE LOWER(animal_project_code) = {animal_project_code} + GROUP BY + det_group, + det.animal_id_pk, + det.tag_serial_number +), +-- SUBSAMPLED DETECTIONS +-- Join hour_groups with detections to get all fields +-- Exclude animal+tag+timestamp duplicates with DISTINCT ON +detections AS ( + SELECT DISTINCT ON (det_group.det_group) + det_group.det_group_count, + det.* + FROM detection_groups AS det_group + LEFT JOIN ( + SELECT * + FROM acoustic.detections_limited AS det + WHERE LOWER(det.animal_project_code) = {animal_project_code} + ) AS det + -- Joining on these 3 fields is faster than creating det_group again + ON + det_group.animal_id_pk = det.animal_id_pk + AND det_group.tag_serial_number = det.tag_serial_number + AND det_group.datetime = det.datetime +) + +/* DATASET-LEVEL */ + +SELECT + 'Event' AS "type", + {license} AS "license", + {rights_holder} AS "rightsHolder", + {dataset_id} AS "datasetID", + 'VLIZ' AS "institutionCode", + 'ETN' AS "collectionCode", + {dataset_name} AS "datasetName", + * +FROM ( + +/* HUMAN OBSERVATIONS */ + +SELECT +-- RECORD LEVEL + 'HumanObservation' AS "basisOfRecord", + NULL AS "dataGeneralizations", +-- OCCURRENCE + animal.id_pk || '_' || tag_device.serial_number || '_' || event.protocol AS "occurrenceID", -- Same as EventID + CASE + WHEN TRIM(LOWER(animal.sex)) IN ('male', 'm') THEN 'male' + WHEN TRIM(LOWER(animal.sex)) IN ('female', 'f') THEN 'female' + WHEN TRIM(LOWER(animal.sex)) IN ('hermaphrodite') THEN 'hermaphrodite' + WHEN TRIM(LOWER(animal.sex)) IN ('unknown', 'u') THEN 'unknown' + -- Exclude transitional, na, ... + END AS "sex", + CASE + WHEN event.protocol = 'release' THEN -- Only at release, can change over time + CASE + -- Follows http://vocab.nerc.ac.uk/collection/S11/current/, see https://github.com/inbo/etn/issues/262 + WHEN TRIM(LOWER(animal.life_stage)) IN ('juvenile', 'i', 'fii', 'fiii') THEN 'juvenile' + WHEN TRIM(LOWER(animal.life_stage)) IN ('sub-adult', 'fiv', 'fv', 'mii', 'silver') THEN 'sub-adult' + WHEN TRIM(LOWER(animal.life_stage)) IN ('adult', 'mature') THEN 'adult' + WHEN TRIM(LOWER(animal.life_stage)) IN ('immature', 'imature') THEN 'immature' + WHEN TRIM(LOWER(animal.life_stage)) IN ('smolt') THEN 'smolt' + -- Exclude unknown, and other values + END + END AS "lifeStage", + 'present' AS "occurrenceStatus", + animal.id_pk AS "organismID", + animal.animal_nickname AS "organismName", +-- EVENT + animal.id_pk || '_' || tag_device.serial_number || '_' || event.protocol AS "eventID", + animal.id_pk || '_' || tag_device.serial_number AS "parentEventID", + TO_CHAR(event.date, 'YYYY-MM-DD"T"HH24:MI:SS"Z"') AS "eventDate", + event.protocol AS "samplingProtocol", + CASE + WHEN event.protocol = 'capture' THEN + 'Caugth using ' || TRIM(LOWER(animal.capture_method)) + WHEN event.protocol = 'release' THEN + manufacturer.project || ' ' || tag_device.model || ' tag ' || + CASE + WHEN LOWER(animal.implant_type) = 'internal' THEN 'implanted in ' + WHEN LOWER(animal.implant_type) = 'external' THEN 'attached to ' + ELSE 'implanted in or attached to ' -- Includes `Acoutic and pit`, ... + END || + CASE + WHEN TRIM(LOWER(animal.wild_or_hatchery)) IN ('wild', 'w') THEN 'free-ranging animal' + WHEN TRIM(LOWER(animal.wild_or_hatchery)) IN ('hatchery', 'h') THEN 'hatched animal' + ELSE 'likely free-ranging animal' + END + END AS "eventRemarks", +-- LOCATION + NULL AS "locationID", + event.locality AS "locality", + event.latitude AS "decimalLatitude", + event.longitude AS "decimalLongitude", + CASE + WHEN event.latitude IS NOT NULL THEN 'EPSG:4326' + END AS "geodeticDatum", + CASE + -- Assume coordinate precision of 0.001 degree (157m) and recording by GPS (30m) + WHEN event.latitude IS NOT NULL THEN 187 + END AS "coordinateUncertaintyInMeters", +-- TAXON + 'urn:lsid:marinespecies.org:taxname:' || animal.aphia_id AS "scientificNameID", + animal.scientific_name AS "scientificName", + 'Animalia' AS "kingdom" +FROM + events AS event + LEFT JOIN animals AS animal + ON event.animal_id_pk = animal.id_pk + LEFT JOIN common.animal_release_tag_device AS animal_with_tag + ON animal.id_pk = animal_with_tag.animal_release_fk + LEFT JOIN common.tag_device_limited AS tag_device + ON animal_with_tag.tag_device_fk = tag_device.id_pk + LEFT JOIN common.tag_device_type AS tag_type + ON tag_device.tag_device_type_fk = tag_type.id_pk + LEFT JOIN common.manufacturer AS manufacturer + ON tag_device.manufacturer_fk = manufacturer.id_pk + +UNION + +/* DETECTIONS */ + +SELECT +-- RECORD LEVEL + 'MachineObservation' AS "basisOfRecord", + 'subsampled by hour: first of ' || det.det_group_count || ' record(s)' AS "dataGeneralizations", +-- OCCURRENCE + det.id_pk::text AS "occurrenceID", -- Same as EventID + CASE + WHEN TRIM(LOWER(animal.sex)) IN ('male', 'm') THEN 'male' + WHEN TRIM(LOWER(animal.sex)) IN ('female', 'f') THEN 'female' + WHEN TRIM(LOWER(animal.sex)) IN ('hermaphrodite') THEN 'hermaphrodite' + WHEN TRIM(LOWER(animal.sex)) IN ('unknown', 'u') THEN 'unknown' + -- Exclude transitional, na, ... + END AS "sex", + NULL AS "lifeStage", -- Value at release might not apply to all records + 'present' AS "occurrenceStatus", + animal.id_pk AS "organismID", + animal.animal_nickname AS "organismName", +-- EVENT + det.id_pk::text AS "eventID", + animal.id_pk || '_' || det.tag_serial_number AS "parentEventID", + TO_CHAR(det.datetime, 'YYYY-MM-DD"T"HH24:MI:SS"Z"') AS "eventDate", + 'acoustic telemetry' AS "samplingProtocol", + 'detected on receiver ' || det.receiver AS "eventRemarks", +-- LOCATION + det.deployment_station_name AS "locationID", + dep.location_name AS "locality", + det.deployment_latitude AS "decimalLatitude", + det.deployment_longitude AS "decimalLongitude", + CASE + WHEN det.deployment_latitude IS NOT NULL THEN 'EPSG:4326' + END AS "geodeticDatum", + CASE + -- Assume coordinate precision of 0.001 degree (157m), recording by GPS (30m) and detection range of around 800m ≈ 1000m + -- See https://github.com/inbo/etn/issues/256#issuecomment-1332224935 + WHEN det.deployment_latitude IS NOT NULL THEN 1000 + END AS "coordinateUncertaintyInMeters", +-- TAXON + 'urn:lsid:marinespecies.org:taxname:' || animal.aphia_id AS "scientificNameID", + animal.scientific_name AS "scientificName", + 'Animalia' AS "kingdom" +FROM + detections AS det + LEFT JOIN animals AS animal + ON det.animal_id_pk = animal.id_pk + LEFT JOIN acoustic.deployments AS dep + ON det.deployment_fk = dep.id_pk +) AS occurrences + +ORDER BY + "parentEventID", + "eventDate", + "samplingProtocol" -- capture, surgery, release, rerelease From 716cdb6e014c714623ffa01c0e1734d74518fa46 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Fri, 9 Dec 2022 16:44:01 +0100 Subject: [PATCH 126/183] Merge pull request #257 from inbo/dwc Add `write_dwc()` function --- R/write_dwc.R | 107 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 107 insertions(+) create mode 100644 R/write_dwc.R diff --git a/R/write_dwc.R b/R/write_dwc.R new file mode 100644 index 0000000..942e22e --- /dev/null +++ b/R/write_dwc.R @@ -0,0 +1,107 @@ +#' Transform ETN data to Darwin Core +#' +#' Transforms and downloads data from a European Tracking Network +#' **animal project** to [Darwin Core](https://dwc.tdwg.org/). +#' The resulting CSV file(s) can be uploaded to an [IPT]( +#' https://www.gbif.org/ipt) for publication to OBIS and/or GBIF. +#' A `meta.xml` or `eml.xml` file are not created. +#' +#' @param connection Connection to the ETN database. +#' @param animal_project_code Animal project code. +#' @param directory Path to local directory to write file(s) to. +#' If `NULL`, then a list of data frames is returned instead, which can be +#' useful for extending/adapting the Darwin Core mapping before writing with +#' [readr::write_csv()]. +#' @param rights_holder Acronym of the organization owning or managing the +#' rights over the data. +#' @param license Identifier of the license under which the data will be +#' published. +#' - [`CC-BY`](https://creativecommons.org/licenses/by/4.0/legalcode) (default). +#' - [`CC0`](https://creativecommons.org/publicdomain/zero/1.0/legalcode). +#' @return CSV file(s) written to disk. +#' @export +#' @section Transformation details: +#' Data are transformed into an +#' [Occurrence core](https://rs.gbif.org/core/dwc_occurrence_2022-02-02.xml). +#' This **follows recommendations** discussed and created by Peter Desmet, +#' Jonas Mortelmans, Jonathan Pye, John Wieczorek and others. +#' See the [SQL file(s)](https://github.com/inbo/etn/tree/main/inst/sql) +#' used by this function for details. +#' +#' Key features of the Darwin Core transformation: +#' - Deployments (animal+tag associations) are parent events, with capture, +#' surgery, release, recapture (human observations) and acoustic detections +#' (machine observations) as child events. +#' No information about the parent event is provided other than its ID, +#' meaning that data can be expressed in an Occurrence Core with one row per +#' observation and `parentEventID` shared by all occurrences in a deployment. +#' - The release event often contains metadata about the animal (sex, +#' lifestage, comments) and deployment as a whole. +#' - Acoustic detections are downsampled to the **first detection per hour**, +#' to reduce the size of high-frequency data. +#' Duplicate detections (same animal, tag and timestamp) are excluded. +#' It is possible for a deployment to contain no detections, e.g. if the +#' tag malfunctioned right after deployment. +write_dwc <- function(connection = con, + animal_project_code, + directory = ".", + rights_holder = NULL, + license = "CC-BY") { + # Check connection + check_connection(connection) + + # Check animal_project_code + assertthat::assert_that( + length(animal_project_code) == 1, + msg = "`animal_project_code` must be a single value." + ) + + # Check license + licenses <- c("CC-BY", "CC0") + assertthat::assert_that( + license %in% licenses, + msg = glue::glue( + "`license` must be `{licenses}`.", + licenses = glue::glue_collapse(licenses, sep = "`, `", last = "` or `") + ) + ) + license <- switch( + license, + "CC-BY" = "https://creativecommons.org/licenses/by/4.0/legalcode", + "CC0" = "https://creativecommons.org/publicdomain/zero/1.0/legalcode" + ) + + # Get imis dataset id and title + project <- get_animal_projects(connection, animal_project_code) + imis_dataset_id <- project$imis_dataset_id + imis_url <- "https://www.vliz.be/en/imis?module=dataset&dasid=" + imis_json <- jsonlite::read_json(paste0(imis_url, imis_dataset_id, "&show=json")) + dataset_id <- paste0(imis_url, imis_dataset_id) + dataset_name <- imis_json$datasetrec$StandardTitle + + # Query database + message("Reading data and transforming to Darwin Core.") + dwc_occurrence_sql <- glue::glue_sql( + readr::read_file(system.file("sql/dwc_occurrence.sql", package = "etn")), + .con = connection + ) + dwc_occurrence <- DBI::dbGetQuery(connection, dwc_occurrence_sql) + + # Return object or write files + if (is.null(directory)) { + list( + dwc_occurrence = dplyr::as_tibble(dwc_occurrence) + ) + } else { + dwc_occurrence_path <- file.path(directory, "dwc_occurrence.csv") + message(glue::glue( + "Writing data to:", + dwc_occurrence_path, + .sep = "\n" + )) + if (!dir.exists(directory)) { + dir.create(directory, recursive = TRUE) + } + readr::write_csv(dwc_occurrence, dwc_occurrence_path, na = "") + } +} From b0ce22d1c29f63642ab2f2b5f47c816092732f22 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Mon, 12 Dec 2022 10:09:07 +0100 Subject: [PATCH 127/183] Merge pull request #269 from inbo/dwc_correction Update return value for `write_dwc()` --- R/write_dwc.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/write_dwc.R b/R/write_dwc.R index 942e22e..17882d0 100644 --- a/R/write_dwc.R +++ b/R/write_dwc.R @@ -18,7 +18,8 @@ #' published. #' - [`CC-BY`](https://creativecommons.org/licenses/by/4.0/legalcode) (default). #' - [`CC0`](https://creativecommons.org/publicdomain/zero/1.0/legalcode). -#' @return CSV file(s) written to disk. +#' @return CSV file(s) written to disk or list of data frames when +#' `directory = NULL`. #' @export #' @section Transformation details: #' Data are transformed into an From 7ffb29692b843e0de766a29e7d8852330c973f39 Mon Sep 17 00:00:00 2001 From: Peter Desmet Date: Fri, 9 Dec 2022 16:44:01 +0100 Subject: [PATCH 128/183] Merge pull request #257 from inbo/dwc Add `write_dwc()` function --- tests/testthat/test-write_dwc.R | 65 +++++++++++++++++++++++++++++++++ 1 file changed, 65 insertions(+) create mode 100644 tests/testthat/test-write_dwc.R diff --git a/tests/testthat/test-write_dwc.R b/tests/testthat/test-write_dwc.R new file mode 100644 index 0000000..1e98d60 --- /dev/null +++ b/tests/testthat/test-write_dwc.R @@ -0,0 +1,65 @@ +con <- connect_to_etn() + +test_that("write_dwc() can write csv files to a path", { + out_dir <- file.path(tempdir(), "dwc") + unlink(out_dir, recursive = TRUE) + dir.create(out_dir) + suppressMessages( + write_dwc(con, animal_project_code = "2014_demer", directory = out_dir) + ) + + expect_identical( + list.files(out_dir, pattern = "*.csv"), + "dwc_occurrence.csv" + ) +}) + +test_that("write_dwc() can return data as list of tibbles rather than files", { + result <- suppressMessages( + write_dwc(con, animal_project_code = "2014_demer", directory = NULL) + ) + + expect_identical(names(result), "dwc_occurrence") + expect_s3_class(result$dwc_occurrence, "tbl") +}) + +test_that("write_dwc() returns the expected Darwin Core terms as columns", { + result <- suppressMessages( + write_dwc(con, animal_project_code = "2014_demer", directory = NULL) + ) + + expect_identical( + colnames(result$dwc_occurrence), + c( + "type", + "license", + "rightsHolder", + "datasetID", + "institutionCode", + "collectionCode", + "datasetName", + "basisOfRecord", + "dataGeneralizations", + "occurrenceID", + "sex", + "lifeStage", + "occurrenceStatus", + "organismID", + "organismName", + "eventID", + "parentEventID", + "eventDate", + "samplingProtocol", + "eventRemarks", + "locationID", + "locality", + "decimalLatitude", + "decimalLongitude", + "geodeticDatum", + "coordinateUncertaintyInMeters", + "scientificNameID", + "scientificName", + "kingdom" + ) + ) +}) From 7ef8796904988be2cf2a6a3cb9258bde306ee428 Mon Sep 17 00:00:00 2001 From: PietrH Date: Mon, 12 Jun 2023 10:23:17 +0200 Subject: [PATCH 129/183] set list_animal_project_codes() to use credentials --- R/get_animal_projects.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/get_animal_projects.R b/R/get_animal_projects.R index 6049fee..a70a687 100644 --- a/R/get_animal_projects.R +++ b/R/get_animal_projects.R @@ -38,7 +38,7 @@ get_animal_projects <- function(credentials = list( } else { animal_project_code <- check_value( animal_project_code, - list_animal_project_codes(connection), + list_animal_project_codes(credentials), "animal_project_code", lowercase = TRUE ) From 2b1c658dbccb76c815e31a67b68a61a49f58ffd3 Mon Sep 17 00:00:00 2001 From: PietrH Date: Mon, 12 Jun 2023 10:24:58 +0200 Subject: [PATCH 130/183] adapt `list_tag_serial_numbers()` for use by OpenCPU --- R/list_tag_serial_numbers.R | 13 +++++++++++-- tests/testthat/test-list_tag_serial_numbers.R | 7 +++++-- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/R/list_tag_serial_numbers.R b/R/list_tag_serial_numbers.R index 3730167..ccdf9c4 100644 --- a/R/list_tag_serial_numbers.R +++ b/R/list_tag_serial_numbers.R @@ -1,12 +1,21 @@ #' List all available tag serial numbers #' -#' @param connection A connection to the ETN database. Defaults to `con`. +#' @param credentials A list with the username and password to connect to the ETN database. #' #' @return A vector of all unique `tag_serial_numbers` present in #' `common.tag_device`. #' #' @export -list_tag_serial_numbers <- function(connection = con) { +list_tag_serial_numbers <- function(credentials = list( + username = Sys.getenv("userid"), + password = Sys.getenv("pwd") +)) { + # Create connection object + connection <- connect_to_etn(credentials$username, credentials$password) + + # Check if we can make a connection + check_connection(connection) + query <- glue::glue_sql( "SELECT DISTINCT serial_number FROM common.tag_device", .con = connection diff --git a/tests/testthat/test-list_tag_serial_numbers.R b/tests/testthat/test-list_tag_serial_numbers.R index acf9515..f917699 100644 --- a/tests/testthat/test-list_tag_serial_numbers.R +++ b/tests/testthat/test-list_tag_serial_numbers.R @@ -1,7 +1,10 @@ -con <- connect_to_etn() +credentials <- list( + username = Sys.getenv("userid"), + password = Sys.getenv("pwd") +) test_that("list_tag_serial_numbers() returns unique list of values", { - vector <- list_tag_serial_numbers(con) + vector <- list_tag_serial_numbers(credentials) expect_is(vector, "character") expect_false(any(duplicated(vector))) From cebec1881631d409db0b9b3709b9b78280cd767f Mon Sep 17 00:00:00 2001 From: PietrH Date: Mon, 12 Jun 2023 10:25:27 +0200 Subject: [PATCH 131/183] adapt `list_cpod_project_codes()` for use by OpenCPU --- R/list_cpod_project_codes.R | 14 ++++++++++++-- tests/testthat/test-list_cpod_project_codes.R | 7 +++++-- 2 files changed, 17 insertions(+), 4 deletions(-) diff --git a/R/list_cpod_project_codes.R b/R/list_cpod_project_codes.R index 07d2740..14a4734 100644 --- a/R/list_cpod_project_codes.R +++ b/R/list_cpod_project_codes.R @@ -1,12 +1,22 @@ #' List all available cpod project codes #' -#' @param connection A connection to the ETN database. Defaults to `con`. +#' @param credentials A list with the username and password to connect to the ETN database. #' #' @return A vector of all unique `project_code` of `type = "cpod"` in #' `project.sql`. #' #' @export -list_cpod_project_codes <- function(connection = con) { +list_cpod_project_codes <- function(credentials = list( + username = Sys.getenv("userid"), + password = Sys.getenv("pwd") +)) { + + # Create connection object + connection <- connect_to_etn(credentials$username, credentials$password) + + # Check if we can make a connection + check_connection(connection) + project_query <- glue::glue_sql( readr::read_file(system.file("sql", "project.sql", package = "etn")), .con = connection diff --git a/tests/testthat/test-list_cpod_project_codes.R b/tests/testthat/test-list_cpod_project_codes.R index e25d490..6a947f1 100644 --- a/tests/testthat/test-list_cpod_project_codes.R +++ b/tests/testthat/test-list_cpod_project_codes.R @@ -1,7 +1,10 @@ -con <- connect_to_etn() +credentials <- list( + username = Sys.getenv("userid"), + password = Sys.getenv("pwd") +) test_that("list_cpod_project_codes() returns unique list of values", { - vector <- list_cpod_project_codes(con) + vector <- list_cpod_project_codes(credentials) expect_is(vector, "character") expect_false(any(duplicated(vector))) From 34239d22a27f38328c39cc804fb038597909d831 Mon Sep 17 00:00:00 2001 From: PietrH Date: Mon, 12 Jun 2023 10:53:41 +0200 Subject: [PATCH 132/183] devtools::document() --- NAMESPACE | 3 ++ man/list_cpod_project_codes.Rd | 20 +++++++++++++ man/list_tag_serial_numbers.Rd | 20 +++++++++++++ man/list_values.Rd | 51 ++++++++++++++++++++++++++++++++++ 4 files changed, 94 insertions(+) create mode 100644 man/list_cpod_project_codes.Rd create mode 100644 man/list_tag_serial_numbers.Rd create mode 100644 man/list_values.Rd diff --git a/NAMESPACE b/NAMESPACE index c0ece93..0b2786d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -10,10 +10,13 @@ export(list_acoustic_project_codes) export(list_acoustic_tag_ids) export(list_animal_ids) export(list_animal_project_codes) +export(list_cpod_project_codes) export(list_deployment_ids) export(list_receiver_ids) export(list_scientific_names) export(list_station_names) +export(list_tag_serial_numbers) +export(list_values) importFrom(dplyr,"%>%") importFrom(dplyr,.data) importFrom(dplyr,distinct) diff --git a/man/list_cpod_project_codes.Rd b/man/list_cpod_project_codes.Rd new file mode 100644 index 0000000..acd1cba --- /dev/null +++ b/man/list_cpod_project_codes.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/list_cpod_project_codes.R +\name{list_cpod_project_codes} +\alias{list_cpod_project_codes} +\title{List all available cpod project codes} +\usage{ +list_cpod_project_codes( + credentials = list(username = Sys.getenv("userid"), password = Sys.getenv("pwd")) +) +} +\arguments{ +\item{credentials}{A list with the username and password to connect to the ETN database.} +} +\value{ +A vector of all unique \code{project_code} of \code{type = "cpod"} in +\code{project.sql}. +} +\description{ +List all available cpod project codes +} diff --git a/man/list_tag_serial_numbers.Rd b/man/list_tag_serial_numbers.Rd new file mode 100644 index 0000000..d79b7bd --- /dev/null +++ b/man/list_tag_serial_numbers.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/list_tag_serial_numbers.R +\name{list_tag_serial_numbers} +\alias{list_tag_serial_numbers} +\title{List all available tag serial numbers} +\usage{ +list_tag_serial_numbers( + credentials = list(username = Sys.getenv("userid"), password = Sys.getenv("pwd")) +) +} +\arguments{ +\item{credentials}{A list with the username and password to connect to the ETN database.} +} +\value{ +A vector of all unique \code{tag_serial_numbers} present in +\code{common.tag_device}. +} +\description{ +List all available tag serial numbers +} diff --git a/man/list_values.Rd b/man/list_values.Rd new file mode 100644 index 0000000..716af09 --- /dev/null +++ b/man/list_values.Rd @@ -0,0 +1,51 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/list_values.R +\name{list_values} +\alias{list_values} +\title{List all unique values from a data.frame column} +\usage{ +list_values(.data, column, split = ",") +} +\arguments{ +\item{.data}{Data frame. Data.frame to select column from.} + +\item{column}{Character or integer. Quoted or unqoted column name or column +position.} + +\item{split}{Character (vector). Character or regular expression(s) passed +to \code{\link[=strsplit]{strsplit()}} to split column values before returning unique values. +Defaults to \verb{,}.} +} +\value{ +A vector of the same type as the given column. +} +\description{ +Get a vector with all unique values found in a given column of a data.frame. +Concatenated values (\verb{A,B}) in the column can be returned as single values +(\code{A} and \code{B}). +} +\examples{ +# Set default connection variable +con <- connect_to_etn() +library(dplyr) # For \%>\% + +# List unique scientific_name from a dataframe containing animal information +df <- get_animals(con, animal_project_code = "2014_demer") +list_values(df, "scientific_name") + +# Or using pipe and unquoted column name +df \%>\% list_values(scientific_name) + +# Or using column position +df \%>\% list_values(8) + +# tag_serial_number can contain comma-separated values +df <- get_animals(con, animal_id = 5841) +df$tag_serial_number + +# list_values() will split those and return unique values +list_values(df, tag_serial_number) + +# Another expression can be defined to split values (here ".") +list_values(df, tag_serial_number, split = "\\\\.") +} From 6e29f27d41f496977688e999a8944673d4044c23 Mon Sep 17 00:00:00 2001 From: PietrH Date: Mon, 12 Jun 2023 11:45:12 +0200 Subject: [PATCH 133/183] Adapt `get_animals()` for use by OpenCPU --- NAMESPACE | 1 + R/get_animals.R | 20 ++++++---- man/get_animals.Rd | 61 +++++++++++++++++++++++++++++++ tests/testthat/test-get_animals.R | 61 ++++++++++++++++--------------- 4 files changed, 107 insertions(+), 36 deletions(-) create mode 100644 man/get_animals.Rd diff --git a/NAMESPACE b/NAMESPACE index 0b2786d..dc43f06 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,6 +6,7 @@ export(get_acoustic_detections) export(get_acoustic_projects) export(get_acoustic_receivers) export(get_animal_projects) +export(get_animals) export(list_acoustic_project_codes) export(list_acoustic_tag_ids) export(list_animal_ids) diff --git a/R/get_animals.R b/R/get_animals.R index 000e17e..fd18f58 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -5,7 +5,7 @@ #' `acoustic_tag_id`. If multiple tags are associated with a single animal, #' the information is comma-separated. #' -#' @param connection A connection to the ETN database. Defaults to `con`. +#' @param credentials A list with the username and password to connect to the ETN database. #' @param animal_id Integer (vector). One or more animal identifiers. #' @param animal_project_code Character (vector). One or more animal project #' codes. Case-insensitive. @@ -41,11 +41,17 @@ #' #' # Get animals of a specific species from a specific project #' get_animals(con, animal_project_code = "2014_demer", scientific_name = "Rutilus rutilus") -get_animals <- function(connection = con, +get_animals <- function(credentials = list( + username = Sys.getenv("userid"), + password = Sys.getenv("pwd") + ), animal_id = NULL, tag_serial_number = NULL, animal_project_code = NULL, scientific_name = NULL) { + # Create connection object + connection <- connect_to_etn(credentials$username, credentials$password) + # Check connection check_connection(connection) @@ -55,7 +61,7 @@ get_animals <- function(connection = con, } else { animal_id <- check_value( animal_id, - list_animal_ids(connection), + list_animal_ids(credentials), "animal_id" ) animal_id_query <- glue::glue_sql( @@ -71,7 +77,7 @@ get_animals <- function(connection = con, } else { animal_project_code <- check_value( animal_project_code, - list_animal_project_codes(connection), + list_animal_project_codes(credentials), "animal_project_code", lowercase = TRUE ) @@ -87,7 +93,7 @@ get_animals <- function(connection = con, } else { tag_serial_number <- check_value( as.character(tag_serial_number), # Cast to character - list_tag_serial_numbers(connection), + list_tag_serial_numbers(credentials), "tag_serial_number" ) tag_serial_number_query <- glue::glue_sql( @@ -102,7 +108,7 @@ get_animals <- function(connection = con, } else { scientific_name <- check_value( scientific_name, - list_scientific_names(connection), + list_scientific_names(credentials), "scientific_name" ) scientific_name_query <- glue::glue_sql( @@ -231,7 +237,7 @@ get_animals <- function(connection = con, dplyr::arrange( .data$animal_project_code, .data$release_date_time, - factor(.data$tag_serial_number, levels = list_tag_serial_numbers(connection)) + factor(.data$tag_serial_number, levels = list_tag_serial_numbers(credentials)) ) dplyr::as_tibble(animals) # Is already a tibble, but added if code above changes diff --git a/man/get_animals.Rd b/man/get_animals.Rd new file mode 100644 index 0000000..c683dd2 --- /dev/null +++ b/man/get_animals.Rd @@ -0,0 +1,61 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/get_animals.R +\name{get_animals} +\alias{get_animals} +\title{Get animal data} +\usage{ +get_animals( + credentials = list(username = Sys.getenv("userid"), password = Sys.getenv("pwd")), + animal_id = NULL, + tag_serial_number = NULL, + animal_project_code = NULL, + scientific_name = NULL +) +} +\arguments{ +\item{credentials}{A list with the username and password to connect to the ETN database.} + +\item{animal_id}{Integer (vector). One or more animal identifiers.} + +\item{tag_serial_number}{Character (vector). One or more tag serial numbers.} + +\item{animal_project_code}{Character (vector). One or more animal project +codes. Case-insensitive.} + +\item{scientific_name}{Character (vector). One or more scientific names.} +} +\value{ +A tibble with animals data, sorted by \code{animal_project_code}, +\code{release_date_time} and \code{tag_serial_number}. See also +\href{https://inbo.github.io/etn/articles/etn_fields.html}{field definitions}. +} +\description{ +Get data for animals, with options to filter results. Associated tag +information is available in columns starting with \code{tag} and +\code{acoustic_tag_id}. If multiple tags are associated with a single animal, +the information is comma-separated. +} +\examples{ +# Set default connection variable +con <- connect_to_etn() + +# Get all animals +get_animals(con) + +# Get specific animals +get_animals(con, animal_id = 305) # Or string value "305" +get_animals(con, animal_id = c(304, 305, 2827)) + +# Get animals from specific animal project(s) +get_animals(con, animal_project_code = "2014_demer") +get_animals(con, animal_project_code = c("2014_demer", "2015_dijle")) + +# Get animals associated with a specific tag_serial_number +get_animals(con, tag_serial_number = "1187450") + +# Get animals of specific species (across all projects) +get_animals(con, scientific_name = c("Rutilus rutilus", "Silurus glanis")) + +# Get animals of a specific species from a specific project +get_animals(con, animal_project_code = "2014_demer", scientific_name = "Rutilus rutilus") +} diff --git a/tests/testthat/test-get_animals.R b/tests/testthat/test-get_animals.R index 38159a3..6ddab45 100644 --- a/tests/testthat/test-get_animals.R +++ b/tests/testthat/test-get_animals.R @@ -1,25 +1,28 @@ -con <- connect_to_etn() +credentials <- list( + username = Sys.getenv("userid"), + password = Sys.getenv("pwd") +) test_that("get_animals() returns error for incorrect connection", { expect_error( - get_animals(con = "not_a_connection"), + get_animals(credentials = "not_a_connection"), "Not a connection object to database." ) }) test_that("get_animals() returns a tibble", { - df <- get_animals(con) + df <- get_animals(credentials) expect_s3_class(df, "data.frame") expect_s3_class(df, "tbl") }) test_that("get_animals() returns unique animal_id", { - df <- get_animals(con) + df <- get_animals(credentials) expect_equal(nrow(df), nrow(df %>% distinct(animal_id))) }) test_that("get_animals() returns the expected columns", { - df <- get_animals(con) + df <- get_animals(credentials) expected_col_names <- c( "animal_id", "animal_project_code", @@ -93,13 +96,13 @@ test_that("get_animals() returns the expected columns", { test_that("get_animals() allows selecting on animal_id", { # Errors - expect_error(get_animals(con, animal_id = 0)) # Not an existing value - expect_error(get_animals(con, animal_id = c(305, 0))) - expect_error(get_animals(con, animal_id = 20.2)) # Not an integer + expect_error(get_animals(credentials, animal_id = 0)) # Not an existing value + expect_error(get_animals(credentials, animal_id = c(305, 0))) + expect_error(get_animals(credentials, animal_id = 20.2)) # Not an integer # Select single value single_select <- 305 - single_select_df <- get_animals(con, animal_id = single_select) + single_select_df <- get_animals(credentials, animal_id = single_select) expect_equal( single_select_df %>% distinct(animal_id) %>% pull(), c(single_select) @@ -108,7 +111,7 @@ test_that("get_animals() allows selecting on animal_id", { # Select multiple values multi_select <- c(304, "305") # Characters are allowed - multi_select_df <- get_animals(con, animal_id = multi_select) + multi_select_df <- get_animals(credentials, animal_id = multi_select) expect_equal( multi_select_df %>% distinct(animal_id) %>% pull() %>% sort(), c(as.integer(multi_select)) # Output will be all integer @@ -118,12 +121,12 @@ test_that("get_animals() allows selecting on animal_id", { test_that("get_animals() allows selecting on animal_project_code", { # Errors - expect_error(get_animals(con, animal_project_code = "not_a_project")) - expect_error(get_animals(con, animal_project_code = c("2014_demer", "not_a_project"))) + expect_error(get_animals(credentials, animal_project_code = "not_a_project")) + expect_error(get_animals(credentials, animal_project_code = c("2014_demer", "not_a_project"))) # Select single value single_select <- "2014_demer" - single_select_df <- get_animals(con, animal_project_code = single_select) + single_select_df <- get_animals(credentials, animal_project_code = single_select) expect_equal( single_select_df %>% distinct(animal_project_code) %>% pull(), c(single_select) @@ -132,13 +135,13 @@ test_that("get_animals() allows selecting on animal_project_code", { # Selection is case insensitive expect_equal( - get_animals(con, animal_project_code = "2014_demer"), - get_animals(con, animal_project_code = "2014_DEMER") + get_animals(credentials, animal_project_code = "2014_demer"), + get_animals(credentials, animal_project_code = "2014_DEMER") ) # Select multiple values multi_select <- c("2014_demer", "2015_dijle") - multi_select_df <- get_animals(con, animal_project_code = multi_select) + multi_select_df <- get_animals(credentials, animal_project_code = multi_select) expect_equal( multi_select_df %>% distinct(animal_project_code) %>% pull() %>% sort(), c(multi_select) @@ -148,12 +151,12 @@ test_that("get_animals() allows selecting on animal_project_code", { test_that("get_animals() allows selecting on tag_serial_number", { # Errors - expect_error(get_animals(con, tag_serial_number = "0")) # Not an existing value - expect_error(get_animals(con, tag_serial_number = c("1187450", "0"))) + expect_error(get_animals(credentials, tag_serial_number = "0")) # Not an existing value + expect_error(get_animals(credentials, tag_serial_number = c("1187450", "0"))) # Select single value single_select <- "1187450" # From 2014_demer - single_select_df <- get_animals(con, tag_serial_number = single_select) + single_select_df <- get_animals(credentials, tag_serial_number = single_select) expect_equal( single_select_df %>% distinct(tag_serial_number) %>% pull(), c(single_select) @@ -163,7 +166,7 @@ test_that("get_animals() allows selecting on tag_serial_number", { # Select multiple values multi_select <- c(1187449, "1187450") # Integers are allowed - multi_select_df <- get_animals(con, tag_serial_number = multi_select) + multi_select_df <- get_animals(credentials, tag_serial_number = multi_select) expect_equal( multi_select_df %>% distinct(tag_serial_number) %>% pull() %>% sort(), c(as.character(multi_select)) # Output will be all character @@ -173,13 +176,13 @@ test_that("get_animals() allows selecting on tag_serial_number", { test_that("get_animals() allows selecting on scientific_name", { # Errors - expect_error(get_animals(con, scientific_name = "not_a_sciname")) - expect_error(get_animals(con, scientific_name = "rutilus rutilus")) # Case sensitive - expect_error(get_animals(con, scientific_name = c("Rutilus rutilus", "not_a_sciname"))) + expect_error(get_animals(credentials, scientific_name = "not_a_sciname")) + expect_error(get_animals(credentials, scientific_name = "rutilus rutilus")) # Case sensitive + expect_error(get_animals(credentials, scientific_name = c("Rutilus rutilus", "not_a_sciname"))) # Select single value single_select <- "Rutilus rutilus" - single_select_df <- get_animals(con, scientific_name = single_select) + single_select_df <- get_animals(credentials, scientific_name = single_select) expect_equal( single_select_df %>% distinct(scientific_name) %>% pull(), c(single_select) @@ -188,7 +191,7 @@ test_that("get_animals() allows selecting on scientific_name", { # Select multiple values multi_select <- c("Rutilus rutilus", "Silurus glanis") - multi_select_df <- get_animals(con, scientific_name = multi_select) + multi_select_df <- get_animals(credentials, scientific_name = multi_select) expect_equal( multi_select_df %>% distinct(scientific_name) %>% pull() %>% sort(), c(multi_select) @@ -198,7 +201,7 @@ test_that("get_animals() allows selecting on scientific_name", { test_that("get_animals() allows selecting on multiple parameters", { multiple_parameters_df <- get_animals( - con, + credentials, animal_project_code = "2014_demer", scientific_name = "Rutilus rutilus" ) @@ -208,7 +211,7 @@ test_that("get_animals() allows selecting on multiple parameters", { test_that("get_animals() collapses multiple associated tags to one row", { # Animal 5841 (project SPAWNSEIS) has 2 associated tags (1280688,1280688) - animal_two_tags_df <- get_animals(con, animal_id = 5841) + animal_two_tags_df <- get_animals(credentials, animal_id = 5841) expect_equal(nrow(animal_two_tags_df), 1) # Rows should be collapsed @@ -231,7 +234,7 @@ test_that("get_animals() collapses multiple associated tags to one row", { }) test_that("get_animals() returns correct tag_type and tag_subtype", { - df <- get_animals(con) + df <- get_animals(credentials) df <- df %>% filter(!stringr::str_detect(tag_type, ",")) # Remove multiple associated tags df <- df %>% filter(tag_type != "") # TODO: remove after https://github.com/inbo/etn/issues/249 expect_equal( @@ -246,6 +249,6 @@ test_that("get_animals() returns correct tag_type and tag_subtype", { test_that("get_animals() does not return animals without tags", { # All animals should be related with a tag - df <- get_animals(con) + df <- get_animals(credentials) expect_equal(df %>% filter(is.na(tag_serial_number)) %>% nrow(), 0) }) From 98b12aca732a180da38cc90606fa57d9a85d62ce Mon Sep 17 00:00:00 2001 From: PietrH Date: Mon, 12 Jun 2023 11:49:33 +0200 Subject: [PATCH 134/183] Adapt `get_cpod_projects()` for use by OpenCPU --- NAMESPACE | 1 + R/get_cpod_projects.R | 12 ++++++--- man/get_cpod_projects.Rd | 35 +++++++++++++++++++++++++ tests/testthat/test-get_cpod_projects.R | 27 ++++++++++--------- 4 files changed, 60 insertions(+), 15 deletions(-) create mode 100644 man/get_cpod_projects.Rd diff --git a/NAMESPACE b/NAMESPACE index dc43f06..3c23a5a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -7,6 +7,7 @@ export(get_acoustic_projects) export(get_acoustic_receivers) export(get_animal_projects) export(get_animals) +export(get_cpod_projects) export(list_acoustic_project_codes) export(list_acoustic_tag_ids) export(list_animal_ids) diff --git a/R/get_cpod_projects.R b/R/get_cpod_projects.R index d1c214c..176656e 100644 --- a/R/get_cpod_projects.R +++ b/R/get_cpod_projects.R @@ -2,7 +2,7 @@ #' #' Get data for cpod projects, with options to filter results. #' -#' @param connection A connection to the ETN database. Defaults to `con`. +#' @param credentials A list with the username and password to connect to the ETN database. #' @param cpod_project_code Character (vector). One or more cpod project #' codes. Case-insensitive. #' @@ -21,8 +21,14 @@ #' #' # Get a specific animal project #' get_cpod_projects(con, cpod_project_code = "cpod-lifewatch") -get_cpod_projects <- function(connection = con, +get_cpod_projects <- function(credentials = list( + username = Sys.getenv("userid"), + password = Sys.getenv("pwd") + ), cpod_project_code = NULL) { + # Create connection object + connection <- connect_to_etn(credentials$username, credentials$password) + # Check connection check_connection(connection) @@ -32,7 +38,7 @@ get_cpod_projects <- function(connection = con, } else { cpod_project_code <- check_value( cpod_project_code, - list_cpod_project_codes(connection), + list_cpod_project_codes(credentials), "cpod_project_code", lowercase = TRUE ) diff --git a/man/get_cpod_projects.Rd b/man/get_cpod_projects.Rd new file mode 100644 index 0000000..899890e --- /dev/null +++ b/man/get_cpod_projects.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/get_cpod_projects.R +\name{get_cpod_projects} +\alias{get_cpod_projects} +\title{Get cpod project data} +\usage{ +get_cpod_projects( + credentials = list(username = Sys.getenv("userid"), password = Sys.getenv("pwd")), + cpod_project_code = NULL +) +} +\arguments{ +\item{credentials}{A list with the username and password to connect to the ETN database.} + +\item{cpod_project_code}{Character (vector). One or more cpod project +codes. Case-insensitive.} +} +\value{ +A tibble with animal project data, sorted by \code{project_code}. See +also +\href{https://inbo.github.io/etn/articles/etn_fields.html}{field definitions}. +} +\description{ +Get data for cpod projects, with options to filter results. +} +\examples{ +# Set default connection variable +con <- connect_to_etn() + +# Get all animal projects +get_cpod_projects(con) + +# Get a specific animal project +get_cpod_projects(con, cpod_project_code = "cpod-lifewatch") +} diff --git a/tests/testthat/test-get_cpod_projects.R b/tests/testthat/test-get_cpod_projects.R index be42fc2..09f835f 100644 --- a/tests/testthat/test-get_cpod_projects.R +++ b/tests/testthat/test-get_cpod_projects.R @@ -1,25 +1,28 @@ -con <- connect_to_etn() +credentials <- list( + username = Sys.getenv("userid"), + password = Sys.getenv("pwd") +) test_that("get_cpod_projects() returns error for incorrect connection", { expect_error( - get_cpod_projects(con = "not_a_connection"), + get_cpod_projects(credentials = "not_a_connection"), "Not a connection object to database." ) }) test_that("get_cpod_projects() returns a tibble", { - df <- get_cpod_projects(con) + df <- get_cpod_projects(credentials) expect_s3_class(df, "data.frame") expect_s3_class(df, "tbl") }) test_that("get_cpod_projects() returns unique project_id", { - df <- get_cpod_projects(con) + df <- get_cpod_projects(credentials) expect_equal(nrow(df), nrow(df %>% distinct(project_id))) }) test_that("get_cpod_projects() returns the expected columns", { - df <- get_cpod_projects(con) + df <- get_cpod_projects(credentials) expected_col_names <- c( "project_id", "project_code", @@ -41,12 +44,12 @@ test_that("get_cpod_projects() returns the expected columns", { test_that("get_cpod_projects() allows selecting on cpod_project_code", { # Errors - expect_error(get_cpod_projects(con, cpod_project_code = "not_a_project")) - expect_error(get_cpod_projects(con, cpod_project_code = c("cpod-lifewatch", "not_a_project"))) + expect_error(get_cpod_projects(credentials, cpod_project_code = "not_a_project")) + expect_error(get_cpod_projects(credentials, cpod_project_code = c("cpod-lifewatch", "not_a_project"))) # Select single value single_select <- "cpod-lifewatch" - single_select_df <- get_cpod_projects(con, cpod_project_code = single_select) + single_select_df <- get_cpod_projects(credentials, cpod_project_code = single_select) expect_equal( single_select_df %>% distinct(project_code) %>% pull(), c(single_select) @@ -55,13 +58,13 @@ test_that("get_cpod_projects() allows selecting on cpod_project_code", { # Selection is case insensitive expect_equal( - get_cpod_projects(con, cpod_project_code = "cpod-lifewatch"), - get_cpod_projects(con, cpod_project_code = "CPOD-LIFEWATCH") + get_cpod_projects(credentials, cpod_project_code = "cpod-lifewatch"), + get_cpod_projects(credentials, cpod_project_code = "CPOD-LIFEWATCH") ) # Select multiple values multi_select <- c("cpod-lifewatch", "cpod-od-natuur") - multi_select_df <- get_cpod_projects(con, cpod_project_code = multi_select) + multi_select_df <- get_cpod_projects(credentials, cpod_project_code = multi_select) expect_equal( multi_select_df %>% distinct(project_code) %>% pull() %>% sort(), c(multi_select) @@ -71,7 +74,7 @@ test_that("get_cpod_projects() allows selecting on cpod_project_code", { test_that("get_cpod_projects() returns projects of type 'cpod'", { expect_equal( - get_cpod_projects(con) %>% distinct(project_type) %>% pull(), + get_cpod_projects(credentials) %>% distinct(project_type) %>% pull(), "cpod" ) }) From b545a213c73d987bac05426e23063e7665d4b8fc Mon Sep 17 00:00:00 2001 From: PietrH Date: Mon, 12 Jun 2023 12:51:13 +0200 Subject: [PATCH 135/183] Adapt `get_tags()` for use by OpenCPU --- NAMESPACE | 1 + R/get_tags.R | 17 +++++++--- man/get_tags.Rd | 57 ++++++++++++++++++++++++++++++++++ tests/testthat/test-get_tags.R | 51 ++++++++++++++++-------------- 4 files changed, 97 insertions(+), 29 deletions(-) create mode 100644 man/get_tags.Rd diff --git a/NAMESPACE b/NAMESPACE index 3c23a5a..ec59ca2 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -8,6 +8,7 @@ export(get_acoustic_receivers) export(get_animal_projects) export(get_animals) export(get_cpod_projects) +export(get_tags) export(list_acoustic_project_codes) export(list_acoustic_tag_ids) export(list_animal_ids) diff --git a/R/get_tags.R b/R/get_tags.R index c136fb6..34bd907 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -4,7 +4,7 @@ #' can be multiple records (`acoustic_tag_id`) per tag device #' (`tag_serial_number`). #' -#' @param connection A connection to the ETN database. Defaults to `con`. +#' @param credentials A list with the username and password to connect to the ETN database. #' @param tag_serial_number Character (vector). One or more tag serial numbers. #' @param tag_type Character (vector). `acoustic` or `archival`. Some tags are #' both, find those with `acoustic-archival`. @@ -37,11 +37,18 @@ #' get_tags(con, tag_serial_number = "1187450") #' get_tags(con, acoustic_tag_id = "A69-1601-16130") #' get_tags(con, acoustic_tag_id = c("A69-1601-16129", "A69-1601-16130")) -get_tags <- function(connection = con, +get_tags <- function(credentials = list( + username = Sys.getenv("userid"), + password = Sys.getenv("pwd") + ), tag_type = NULL, tag_subtype = NULL, tag_serial_number = NULL, acoustic_tag_id = NULL) { + + # Create connection object + connection <- connect_to_etn(credentials$username, credentials$password) + # Check connection check_connection(connection) @@ -51,7 +58,7 @@ get_tags <- function(connection = con, } else { tag_serial_number <- check_value( as.character(tag_serial_number), # Cast to character - list_tag_serial_numbers(connection), + list_tag_serial_numbers(credentials), "tag_serial_number" ) tag_serial_number_query <- glue::glue_sql( @@ -96,7 +103,7 @@ get_tags <- function(connection = con, } else { check_value( acoustic_tag_id, - list_acoustic_tag_ids(connection), + list_acoustic_tag_ids(credentials), "acoustic_tag_id" ) acoustic_tag_id_query <- glue::glue_sql( @@ -198,7 +205,7 @@ get_tags <- function(connection = con, # Sort data tags <- tags %>% - dplyr::arrange(factor(.data$tag_serial_number, levels = list_tag_serial_numbers(connection))) + dplyr::arrange(factor(.data$tag_serial_number, levels = list_tag_serial_numbers(credentials))) dplyr::as_tibble(tags) } diff --git a/man/get_tags.Rd b/man/get_tags.Rd new file mode 100644 index 0000000..60a32ed --- /dev/null +++ b/man/get_tags.Rd @@ -0,0 +1,57 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/get_tags.R +\name{get_tags} +\alias{get_tags} +\title{Get tag data} +\usage{ +get_tags( + credentials = list(username = Sys.getenv("userid"), password = Sys.getenv("pwd")), + tag_type = NULL, + tag_subtype = NULL, + tag_serial_number = NULL, + acoustic_tag_id = NULL +) +} +\arguments{ +\item{credentials}{A list with the username and password to connect to the ETN database.} + +\item{tag_type}{Character (vector). \code{acoustic} or \code{archival}. Some tags are +both, find those with \code{acoustic-archival}.} + +\item{tag_subtype}{Character (vector). \code{animal}, \verb{built-in}, \code{range} or +\code{sentinel}.} + +\item{tag_serial_number}{Character (vector). One or more tag serial numbers.} + +\item{acoustic_tag_id}{Character (vector). One or more acoustic tag +identifiers, i.e. identifiers found in \code{\link[=get_acoustic_detections]{get_acoustic_detections()}}.} +} +\value{ +A tibble with tags data, sorted by \code{tag_serial_number}. See also +\href{https://inbo.github.io/etn/articles/etn_fields.html}{field definitions}. +Values for \code{owner_organization} and \code{owner_pi} will only be visible if you +are member of the group. +} +\description{ +Get data for tags, with options to filter results. Note that there +can be multiple records (\code{acoustic_tag_id}) per tag device +(\code{tag_serial_number}). +} +\examples{ +# Set default connection variable +con <- connect_to_etn() + +# Get all tags +get_tags(con) + +# Get archival tags, including acoustic-archival +get_tags(con, tag_type = c("archival", "acoustic-archival")) + +# Get tags of specific subtype +get_tags(con, tag_subtype = c("built-in", "range")) + +# Get specific tags (note that these can return multiple records) +get_tags(con, tag_serial_number = "1187450") +get_tags(con, acoustic_tag_id = "A69-1601-16130") +get_tags(con, acoustic_tag_id = c("A69-1601-16129", "A69-1601-16130")) +} diff --git a/tests/testthat/test-get_tags.R b/tests/testthat/test-get_tags.R index 570915a..19aeb22 100644 --- a/tests/testthat/test-get_tags.R +++ b/tests/testthat/test-get_tags.R @@ -1,20 +1,23 @@ -con <- connect_to_etn() +credentials <- list( + username = Sys.getenv("userid"), + password = Sys.getenv("pwd") +) test_that("get_tags() returns error for incorrect connection", { expect_error( - get_tags(con = "not_a_connection"), + get_tags(credentials = "not_a_connection"), "Not a connection object to database." ) }) test_that("get_tags() returns a tibble", { - df <- get_tags(con) + df <- get_tags(credentials) expect_s3_class(df, "data.frame") expect_s3_class(df, "tbl") }) test_that("get_tags() returns the expected columns", { - df <- get_tags(con) + df <- get_tags(credentials) expected_col_names <- c( "tag_serial_number", "tag_type", @@ -76,12 +79,12 @@ test_that("get_tags() returns the expected columns", { test_that("get_tags() allows selecting on tag_serial_number", { # Errors - expect_error(get_tags(con, tag_serial_number = "0")) # Not an existing value - expect_error(get_tags(con, tag_serial_number = c("1187450", "0"))) + expect_error(get_tags(credentials, tag_serial_number = "0")) # Not an existing value + expect_error(get_tags(credentials, tag_serial_number = c("1187450", "0"))) # Select single value single_select <- "1187450" # From 2014_demer - single_select_df <- get_tags(con, tag_serial_number = single_select) + single_select_df <- get_tags(credentials, tag_serial_number = single_select) expect_equal( single_select_df %>% distinct(tag_serial_number) %>% pull(), c(single_select) @@ -91,7 +94,7 @@ test_that("get_tags() allows selecting on tag_serial_number", { # Select multiple values multi_select <- c(1187449, "1187450") # Integers are allowed - multi_select_df <- get_tags(con, tag_serial_number = multi_select) + multi_select_df <- get_tags(credentials, tag_serial_number = multi_select) expect_equal( multi_select_df %>% distinct(tag_serial_number) %>% pull() %>% sort(), c(as.character(multi_select)) # Output will be all character @@ -101,12 +104,12 @@ test_that("get_tags() allows selecting on tag_serial_number", { test_that("get_tags() allows selecting on tag_type", { # Errors - expect_error(get_tags(con, tag_type = "not_a_tag_type")) - expect_error(get_tags(con, tag_type = c("archival", "not_a_tag_type"))) + expect_error(get_tags(credentials, tag_type = "not_a_tag_type")) + expect_error(get_tags(credentials, tag_type = c("archival", "not_a_tag_type"))) # Select single value single_select <- "archival" - single_select_df <- get_tags(con, tag_type = single_select) + single_select_df <- get_tags(credentials, tag_type = single_select) expect_equal( single_select_df %>% distinct(tag_type) %>% pull(), c(single_select) @@ -115,7 +118,7 @@ test_that("get_tags() allows selecting on tag_type", { # Select multiple values multi_select <- c("acoustic-archival", "archival") - multi_select_df <- get_tags(con, tag_type = multi_select) + multi_select_df <- get_tags(credentials, tag_type = multi_select) expect_equal( multi_select_df %>% distinct(tag_type) %>% pull() %>% sort(), c(multi_select) @@ -125,12 +128,12 @@ test_that("get_tags() allows selecting on tag_type", { test_that("get_tags() allows selecting on tag_subtype", { # Errors - expect_error(get_tags(con, tag_subtype = "not_a_tag_subtype")) - expect_error(get_tags(con, tag_subtype = c("archival", "not_a_tag_subtype"))) + expect_error(get_tags(credentials, tag_subtype = "not_a_tag_subtype")) + expect_error(get_tags(credentials, tag_subtype = c("archival", "not_a_tag_subtype"))) # Select single value single_select <- "built-in" - single_select_df <- get_tags(con, tag_subtype = single_select) + single_select_df <- get_tags(credentials, tag_subtype = single_select) expect_equal( single_select_df %>% distinct(tag_subtype) %>% pull(), c(single_select) @@ -139,7 +142,7 @@ test_that("get_tags() allows selecting on tag_subtype", { # Select multiple values multi_select <- c("built-in", "range") - multi_select_df <- get_tags(con, tag_subtype = multi_select) + multi_select_df <- get_tags(credentials, tag_subtype = multi_select) expect_equal( multi_select_df %>% distinct(tag_subtype) %>% pull() %>% sort(), c(multi_select) @@ -149,12 +152,12 @@ test_that("get_tags() allows selecting on tag_subtype", { test_that("get_tags() allows selecting on acoustic_tag_id", { # Errors - expect_error(get_tags(con, acoustic_tag_id = "not_a_tag_id")) - expect_error(get_tags(con, acoustic_tag_id = c("A69-1601-16130", "not_a_tag_id"))) + expect_error(get_tags(credentials, acoustic_tag_id = "not_a_tag_id")) + expect_error(get_tags(credentials, acoustic_tag_id = c("A69-1601-16130", "not_a_tag_id"))) # Select single value single_select <- "A69-1601-16130" # From 2014_demer - single_select_df <- get_tags(con, acoustic_tag_id = single_select) + single_select_df <- get_tags(credentials, acoustic_tag_id = single_select) expect_equal( single_select_df %>% distinct(acoustic_tag_id) %>% pull(), c(single_select) @@ -164,7 +167,7 @@ test_that("get_tags() allows selecting on acoustic_tag_id", { # Select multiple values multi_select <- c("A69-1601-16129", "A69-1601-16130") - multi_select_df <- get_tags(con, acoustic_tag_id = multi_select) + multi_select_df <- get_tags(credentials, acoustic_tag_id = multi_select) expect_equal( multi_select_df %>% distinct(acoustic_tag_id) %>% pull() %>% sort(), c(multi_select) @@ -174,7 +177,7 @@ test_that("get_tags() allows selecting on acoustic_tag_id", { test_that("get_tags() allows selecting on multiple parameters", { multiple_parameters_df <- get_tags( - con, + credentials, tag_serial_number = "1187450", tag_type = "acoustic", tag_subtype = "animal", @@ -185,7 +188,7 @@ test_that("get_tags() allows selecting on multiple parameters", { test_that("get_tags() can return multiple rows for a single tag", { # A sentinel acoustic-archival tag with temperature + pressure sensor - tag_1_df <- get_tags(con, tag_serial_number = 1400185) + tag_1_df <- get_tags(credentials, tag_serial_number = 1400185) expect_equal(nrow(tag_1_df), 2) # 2 rows: temperature + presure expect_equal( tag_1_df %>% @@ -201,7 +204,7 @@ test_that("get_tags() can return multiple rows for a single tag", { ) # A built-in acoustic tag with two protocols: https://github.com/inbo/etn/issues/177#issuecomment-925578186 - tag_2_df <- get_tags(con, tag_serial_number = 461076) + tag_2_df <- get_tags(credentials, tag_serial_number = 461076) expect_equal(nrow(tag_2_df), 2) # 2 rows: A180 + H170 expect_equal( tag_2_df %>% @@ -218,7 +221,7 @@ test_that("get_tags() can return multiple rows for a single tag", { }) test_that("get_tags() returns correct tag_type and tag_subtype", { - df <- get_tags(con) + df <- get_tags(credentials) expect_equal( df %>% distinct(tag_type) %>% pull() %>% sort(), c("acoustic", "acoustic-archival", "archival") From f8e3e6329282d086e14097770916aaef45b443f7 Mon Sep 17 00:00:00 2001 From: PietrH Date: Mon, 12 Jun 2023 14:58:32 +0200 Subject: [PATCH 136/183] remove test for writing to file --- tests/testthat/test-write_dwc.R | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/tests/testthat/test-write_dwc.R b/tests/testthat/test-write_dwc.R index 1e98d60..5805dee 100644 --- a/tests/testthat/test-write_dwc.R +++ b/tests/testthat/test-write_dwc.R @@ -1,18 +1,18 @@ con <- connect_to_etn() -test_that("write_dwc() can write csv files to a path", { - out_dir <- file.path(tempdir(), "dwc") - unlink(out_dir, recursive = TRUE) - dir.create(out_dir) - suppressMessages( - write_dwc(con, animal_project_code = "2014_demer", directory = out_dir) - ) - - expect_identical( - list.files(out_dir, pattern = "*.csv"), - "dwc_occurrence.csv" - ) -}) +# test_that("write_dwc() can write csv files to a path", { +# out_dir <- file.path(tempdir(), "dwc") +# unlink(out_dir, recursive = TRUE) +# dir.create(out_dir) +# suppressMessages( +# write_dwc(con, animal_project_code = "2014_demer", directory = out_dir) +# ) +# +# expect_identical( +# list.files(out_dir, pattern = "*.csv"), +# "dwc_occurrence.csv" +# ) +# }) test_that("write_dwc() can return data as list of tibbles rather than files", { result <- suppressMessages( From 3e6bd610cbed2953ee5053d0af4b6e03667c321f Mon Sep 17 00:00:00 2001 From: PietrH Date: Mon, 12 Jun 2023 14:58:48 +0200 Subject: [PATCH 137/183] adapt test to use credentials argument --- tests/testthat/test-write_dwc.R | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-write_dwc.R b/tests/testthat/test-write_dwc.R index 5805dee..637dc0f 100644 --- a/tests/testthat/test-write_dwc.R +++ b/tests/testthat/test-write_dwc.R @@ -1,4 +1,7 @@ -con <- connect_to_etn() +credentials <- list( + username = Sys.getenv("userid"), + password = Sys.getenv("pwd") +) # test_that("write_dwc() can write csv files to a path", { # out_dir <- file.path(tempdir(), "dwc") @@ -16,7 +19,7 @@ con <- connect_to_etn() test_that("write_dwc() can return data as list of tibbles rather than files", { result <- suppressMessages( - write_dwc(con, animal_project_code = "2014_demer", directory = NULL) + write_dwc(credentials, animal_project_code = "2014_demer", directory = NULL) ) expect_identical(names(result), "dwc_occurrence") @@ -25,7 +28,7 @@ test_that("write_dwc() can return data as list of tibbles rather than files", { test_that("write_dwc() returns the expected Darwin Core terms as columns", { result <- suppressMessages( - write_dwc(con, animal_project_code = "2014_demer", directory = NULL) + write_dwc(credentials, animal_project_code = "2014_demer", directory = NULL) ) expect_identical( From e1a51802f91c81e7ce1f4c7bfa7a039ffa7d0476 Mon Sep 17 00:00:00 2001 From: PietrH Date: Mon, 12 Jun 2023 15:02:36 +0200 Subject: [PATCH 138/183] add jsonlite dep from write_dwc() --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index b3e548a..b26c7ab 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -22,6 +22,7 @@ Imports: dplyr, glue, httr, + jsonlite, lubridate, methods, odbc, From 24bc758bdbb9f8055fcf7b1c49ed04d0e367cf75 Mon Sep 17 00:00:00 2001 From: PietrH Date: Mon, 12 Jun 2023 15:14:58 +0200 Subject: [PATCH 139/183] remove commented out code for test that wrote to local file --- tests/testthat/test-write_dwc.R | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/tests/testthat/test-write_dwc.R b/tests/testthat/test-write_dwc.R index 637dc0f..4b0eddd 100644 --- a/tests/testthat/test-write_dwc.R +++ b/tests/testthat/test-write_dwc.R @@ -3,20 +3,6 @@ credentials <- list( password = Sys.getenv("pwd") ) -# test_that("write_dwc() can write csv files to a path", { -# out_dir <- file.path(tempdir(), "dwc") -# unlink(out_dir, recursive = TRUE) -# dir.create(out_dir) -# suppressMessages( -# write_dwc(con, animal_project_code = "2014_demer", directory = out_dir) -# ) -# -# expect_identical( -# list.files(out_dir, pattern = "*.csv"), -# "dwc_occurrence.csv" -# ) -# }) - test_that("write_dwc() can return data as list of tibbles rather than files", { result <- suppressMessages( write_dwc(credentials, animal_project_code = "2014_demer", directory = NULL) From bdf69ccde66d7902589bc489f2c92c96c052b221 Mon Sep 17 00:00:00 2001 From: PietrH Date: Mon, 12 Jun 2023 15:15:26 +0200 Subject: [PATCH 140/183] Adapt to only output list of dataframes, for use by OpenCPU --- R/write_dwc.R | 45 +++++++++++++++++++-------------------------- 1 file changed, 19 insertions(+), 26 deletions(-) diff --git a/R/write_dwc.R b/R/write_dwc.R index 17882d0..2b9ac0d 100644 --- a/R/write_dwc.R +++ b/R/write_dwc.R @@ -6,20 +6,15 @@ #' https://www.gbif.org/ipt) for publication to OBIS and/or GBIF. #' A `meta.xml` or `eml.xml` file are not created. #' -#' @param connection Connection to the ETN database. +#' @param credentials A list with the username and password to connect to the ETN database. #' @param animal_project_code Animal project code. -#' @param directory Path to local directory to write file(s) to. -#' If `NULL`, then a list of data frames is returned instead, which can be -#' useful for extending/adapting the Darwin Core mapping before writing with -#' [readr::write_csv()]. #' @param rights_holder Acronym of the organization owning or managing the #' rights over the data. #' @param license Identifier of the license under which the data will be #' published. #' - [`CC-BY`](https://creativecommons.org/licenses/by/4.0/legalcode) (default). #' - [`CC0`](https://creativecommons.org/publicdomain/zero/1.0/legalcode). -#' @return CSV file(s) written to disk or list of data frames when -#' `directory = NULL`. +#' @return list of data frames #' @export #' @section Transformation details: #' Data are transformed into an @@ -43,11 +38,18 @@ #' Duplicate detections (same animal, tag and timestamp) are excluded. #' It is possible for a deployment to contain no detections, e.g. if the #' tag malfunctioned right after deployment. -write_dwc <- function(connection = con, +write_dwc <- function(credentials = list( + username = Sys.getenv("userid"), + password = Sys.getenv("pwd") + ), animal_project_code, directory = ".", rights_holder = NULL, license = "CC-BY") { + + # Create connection object + connection <- connect_to_etn(credentials$username, credentials$password) + # Check connection check_connection(connection) @@ -73,7 +75,7 @@ write_dwc <- function(connection = con, ) # Get imis dataset id and title - project <- get_animal_projects(connection, animal_project_code) + project <- get_animal_projects(credentials, animal_project_code) imis_dataset_id <- project$imis_dataset_id imis_url <- "https://www.vliz.be/en/imis?module=dataset&dasid=" imis_json <- jsonlite::read_json(paste0(imis_url, imis_dataset_id, "&show=json")) @@ -81,7 +83,11 @@ write_dwc <- function(connection = con, dataset_name <- imis_json$datasetrec$StandardTitle # Query database - message("Reading data and transforming to Darwin Core.") + + ## NOTE this message could be retained if moved to the client together with + ## above get_animal_projects() call + # message("Reading data and transforming to Darwin Core.") + dwc_occurrence_sql <- glue::glue_sql( readr::read_file(system.file("sql/dwc_occurrence.sql", package = "etn")), .con = connection @@ -89,20 +95,7 @@ write_dwc <- function(connection = con, dwc_occurrence <- DBI::dbGetQuery(connection, dwc_occurrence_sql) # Return object or write files - if (is.null(directory)) { - list( - dwc_occurrence = dplyr::as_tibble(dwc_occurrence) - ) - } else { - dwc_occurrence_path <- file.path(directory, "dwc_occurrence.csv") - message(glue::glue( - "Writing data to:", - dwc_occurrence_path, - .sep = "\n" - )) - if (!dir.exists(directory)) { - dir.create(directory, recursive = TRUE) - } - readr::write_csv(dwc_occurrence, dwc_occurrence_path, na = "") - } + return( + list(dwc_occurrence = dplyr::as_tibble(dwc_occurrence)) + ) } From 863e157fb16dbb20b1a2df34a5a80f3b7b4f48c5 Mon Sep 17 00:00:00 2001 From: PietrH Date: Mon, 12 Jun 2023 15:17:07 +0200 Subject: [PATCH 141/183] devtools::document() --- NAMESPACE | 1 + man/write_dwc.Rd | 65 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 66 insertions(+) create mode 100644 man/write_dwc.Rd diff --git a/NAMESPACE b/NAMESPACE index ec59ca2..1343507 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -20,6 +20,7 @@ export(list_scientific_names) export(list_station_names) export(list_tag_serial_numbers) export(list_values) +export(write_dwc) importFrom(dplyr,"%>%") importFrom(dplyr,.data) importFrom(dplyr,distinct) diff --git a/man/write_dwc.Rd b/man/write_dwc.Rd new file mode 100644 index 0000000..92a8b8c --- /dev/null +++ b/man/write_dwc.Rd @@ -0,0 +1,65 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/write_dwc.R +\name{write_dwc} +\alias{write_dwc} +\title{Transform ETN data to Darwin Core} +\usage{ +write_dwc( + credentials = list(username = Sys.getenv("userid"), password = Sys.getenv("pwd")), + animal_project_code, + directory = ".", + rights_holder = NULL, + license = "CC-BY" +) +} +\arguments{ +\item{credentials}{A list with the username and password to connect to the ETN database.} + +\item{animal_project_code}{Animal project code.} + +\item{rights_holder}{Acronym of the organization owning or managing the +rights over the data.} + +\item{license}{Identifier of the license under which the data will be +published. +\itemize{ +\item \href{https://creativecommons.org/licenses/by/4.0/legalcode}{\code{CC-BY}} (default). +\item \href{https://creativecommons.org/publicdomain/zero/1.0/legalcode}{\code{CC0}}. +}} +} +\value{ +list of data frames +} +\description{ +Transforms and downloads data from a European Tracking Network +\strong{animal project} to \href{https://dwc.tdwg.org/}{Darwin Core}. +The resulting CSV file(s) can be uploaded to an \href{https://www.gbif.org/ipt}{IPT} for publication to OBIS and/or GBIF. +A \code{meta.xml} or \code{eml.xml} file are not created. +} +\section{Transformation details}{ + +Data are transformed into an +\href{https://rs.gbif.org/core/dwc_occurrence_2022-02-02.xml}{Occurrence core}. +This \strong{follows recommendations} discussed and created by Peter Desmet, +Jonas Mortelmans, Jonathan Pye, John Wieczorek and others. +See the \href{https://github.com/inbo/etn/tree/main/inst/sql}{SQL file(s)} +used by this function for details. + +Key features of the Darwin Core transformation: +\itemize{ +\item Deployments (animal+tag associations) are parent events, with capture, +surgery, release, recapture (human observations) and acoustic detections +(machine observations) as child events. +No information about the parent event is provided other than its ID, +meaning that data can be expressed in an Occurrence Core with one row per +observation and \code{parentEventID} shared by all occurrences in a deployment. +\item The release event often contains metadata about the animal (sex, +lifestage, comments) and deployment as a whole. +\item Acoustic detections are downsampled to the \strong{first detection per hour}, +to reduce the size of high-frequency data. +Duplicate detections (same animal, tag and timestamp) are excluded. +It is possible for a deployment to contain no detections, e.g. if the +tag malfunctioned right after deployment. +} +} + From 1718c22842a59f552942cfeff93f143a322df674 Mon Sep 17 00:00:00 2001 From: PietrH Date: Mon, 12 Jun 2023 15:34:34 +0200 Subject: [PATCH 142/183] remove directory argument --- R/write_dwc.R | 1 - man/write_dwc.Rd | 1 - tests/testthat/test-write_dwc.R | 4 ++-- 3 files changed, 2 insertions(+), 4 deletions(-) diff --git a/R/write_dwc.R b/R/write_dwc.R index 2b9ac0d..f2a3f3f 100644 --- a/R/write_dwc.R +++ b/R/write_dwc.R @@ -43,7 +43,6 @@ write_dwc <- function(credentials = list( password = Sys.getenv("pwd") ), animal_project_code, - directory = ".", rights_holder = NULL, license = "CC-BY") { diff --git a/man/write_dwc.Rd b/man/write_dwc.Rd index 92a8b8c..8596db4 100644 --- a/man/write_dwc.Rd +++ b/man/write_dwc.Rd @@ -7,7 +7,6 @@ write_dwc( credentials = list(username = Sys.getenv("userid"), password = Sys.getenv("pwd")), animal_project_code, - directory = ".", rights_holder = NULL, license = "CC-BY" ) diff --git a/tests/testthat/test-write_dwc.R b/tests/testthat/test-write_dwc.R index 4b0eddd..0e0fd10 100644 --- a/tests/testthat/test-write_dwc.R +++ b/tests/testthat/test-write_dwc.R @@ -5,7 +5,7 @@ credentials <- list( test_that("write_dwc() can return data as list of tibbles rather than files", { result <- suppressMessages( - write_dwc(credentials, animal_project_code = "2014_demer", directory = NULL) + write_dwc(credentials, animal_project_code = "2014_demer") ) expect_identical(names(result), "dwc_occurrence") @@ -14,7 +14,7 @@ test_that("write_dwc() can return data as list of tibbles rather than files", { test_that("write_dwc() returns the expected Darwin Core terms as columns", { result <- suppressMessages( - write_dwc(credentials, animal_project_code = "2014_demer", directory = NULL) + write_dwc(credentials, animal_project_code = "2014_demer") ) expect_identical( From 44ee684862820a82e77b54e0ee05aef6fc31ce0d Mon Sep 17 00:00:00 2001 From: PietrH Date: Mon, 12 Jun 2023 16:04:03 +0200 Subject: [PATCH 143/183] replace references to connection in examples --- R/get_acoustic_deployments.R | 19 +++++++++++-------- R/get_acoustic_projects.R | 11 +++++++---- R/get_acoustic_receivers.R | 13 ++++++++----- R/get_animal_projects.R | 11 +++++++---- R/get_animals.R | 23 +++++++++++++---------- R/get_cpod_projects.R | 11 +++++++---- R/get_tags.R | 19 +++++++++++-------- R/list_values.R | 11 +++++++---- man/get_acoustic_deployments.Rd | 19 +++++++++++-------- man/get_acoustic_projects.Rd | 11 +++++++---- man/get_acoustic_receivers.Rd | 13 ++++++++----- man/get_animal_projects.Rd | 11 +++++++---- man/get_animals.Rd | 23 +++++++++++++---------- man/get_cpod_projects.Rd | 11 +++++++---- man/get_tags.Rd | 19 +++++++++++-------- man/list_values.Rd | 11 +++++++---- 16 files changed, 142 insertions(+), 94 deletions(-) diff --git a/R/get_acoustic_deployments.R b/R/get_acoustic_deployments.R index 4bd708b..0bc8495 100644 --- a/R/get_acoustic_deployments.R +++ b/R/get_acoustic_deployments.R @@ -20,26 +20,29 @@ #' @export #' #' @examples -#' # Set default connection variable -#' con <- connect_to_etn() +#' # Set credentials +#' credentials <- list( +#' username = Sys.getenv("userid"), +#' password = Sys.getenv("pwd") +#' ) #' #' # Get all acoustic deployments -#' get_acoustic_deployments(con) +#' get_acoustic_deployments(credentials) #' #' # Get specific acoustic deployment -#' get_acoustic_deployments(con, deployment_id = 1437) +#' get_acoustic_deployments(credentials, deployment_id = 1437) #' #' # Get acoustic deployments for a specific receiver -#' get_acoustic_deployments(con, receiver_id = "VR2W-124070") +#' get_acoustic_deployments(credentials, receiver_id = "VR2W-124070") #' #' # Get open acoustic deployments for a specific receiver -#' get_acoustic_deployments(con, receiver_id = "VR2W-124070", open_only = TRUE) +#' get_acoustic_deployments(credentials, receiver_id = "VR2W-124070", open_only = TRUE) #' #' # Get acoustic deployments for a specific acoustic project -#' get_acoustic_deployments(con, acoustic_project_code = "demer") +#' get_acoustic_deployments(credentials, acoustic_project_code = "demer") #' #' # Get acoustic deployments for two specific stations -#' get_acoustic_deployments(con, station_name = c("de-9", "de-10")) +#' get_acoustic_deployments(credentials, station_name = c("de-9", "de-10")) get_acoustic_deployments <- function( credentials = list(username = Sys.getenv("userid"), password = Sys.getenv("pwd")), diff --git a/R/get_acoustic_projects.R b/R/get_acoustic_projects.R index 456875e..d8becae 100644 --- a/R/get_acoustic_projects.R +++ b/R/get_acoustic_projects.R @@ -13,14 +13,17 @@ #' @export #' #' @examples -#' # Set default connection variable -#' con <- connect_to_etn() +#' # Set credentials +#' credentials <- list( +#' username = Sys.getenv("userid"), +#' password = Sys.getenv("pwd") +#' ) #' #' # Get all acoustic projects -#' get_acoustic_projects(con) +#' get_acoustic_projects(credentials) #' #' # Get a specific acoustic project -#' get_acoustic_projects(con, acoustic_project_code = "demer") +#' get_acoustic_projects(credentials, acoustic_project_code = "demer") get_acoustic_projects <- function(credentials = list( username = Sys.getenv("userid"), password = Sys.getenv("pwd") diff --git a/R/get_acoustic_receivers.R b/R/get_acoustic_receivers.R index 7e7c5f3..fa3b174 100644 --- a/R/get_acoustic_receivers.R +++ b/R/get_acoustic_receivers.R @@ -15,17 +15,20 @@ #' @export #' #' @examples -#' # Set default connection variable -#' con <- connect_to_etn() +#' # Set credentials +#' credentials <- list( +#' username = Sys.getenv("userid"), +#' password = Sys.getenv("pwd") +#' ) #' #' # Get all acoustic receivers -#' get_acoustic_receivers(con) +#' get_acoustic_receivers(credentials) #' #' # Get lost and broken acoustic receivers -#' get_acoustic_receivers(con, status = c("lost", "broken")) +#' get_acoustic_receivers(credentials, status = c("lost", "broken")) #' #' # Get a specific acoustic receiver -#' get_acoustic_receivers(con, receiver_id = "VR2W-124070") +#' get_acoustic_receivers(credentials, receiver_id = "VR2W-124070") get_acoustic_receivers <- function(credentials = list( username = Sys.getenv("userid"), password = Sys.getenv("pwd") diff --git a/R/get_animal_projects.R b/R/get_animal_projects.R index a70a687..2767418 100644 --- a/R/get_animal_projects.R +++ b/R/get_animal_projects.R @@ -13,14 +13,17 @@ #' @export #' #' @examples -#' # Set default connection variable -#' con <- connect_to_etn() +#' # Set credentials +#' credentials <- list( +#' username = Sys.getenv("userid"), +#' password = Sys.getenv("pwd") +#' ) #' #' # Get all animal projects -#' get_animal_projects(con) +#' get_animal_projects(credentials) #' #' # Get a specific animal project -#' get_animal_projects(con, animal_project_code = "2014_demer") +#' get_animal_projects(credentials, animal_project_code = "2014_demer") get_animal_projects <- function(credentials = list( username = Sys.getenv("userid"), password = Sys.getenv("pwd") diff --git a/R/get_animals.R b/R/get_animals.R index fd18f58..86a3b29 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -19,28 +19,31 @@ #' @export #' #' @examples -#' # Set default connection variable -#' con <- connect_to_etn() +#' # Set credentials +#' credentials <- list( +#' username = Sys.getenv("userid"), +#' password = Sys.getenv("pwd") +#' ) #' #' # Get all animals -#' get_animals(con) +#' get_animals(credentials) #' #' # Get specific animals -#' get_animals(con, animal_id = 305) # Or string value "305" -#' get_animals(con, animal_id = c(304, 305, 2827)) +#' get_animals(credentials, animal_id = 305) # Or string value "305" +#' get_animals(credentials, animal_id = c(304, 305, 2827)) #' #' # Get animals from specific animal project(s) -#' get_animals(con, animal_project_code = "2014_demer") -#' get_animals(con, animal_project_code = c("2014_demer", "2015_dijle")) +#' get_animals(credentials, animal_project_code = "2014_demer") +#' get_animals(credentials, animal_project_code = c("2014_demer", "2015_dijle")) #' #' # Get animals associated with a specific tag_serial_number -#' get_animals(con, tag_serial_number = "1187450") +#' get_animals(credentials, tag_serial_number = "1187450") #' #' # Get animals of specific species (across all projects) -#' get_animals(con, scientific_name = c("Rutilus rutilus", "Silurus glanis")) +#' get_animals(credentials, scientific_name = c("Rutilus rutilus", "Silurus glanis")) #' #' # Get animals of a specific species from a specific project -#' get_animals(con, animal_project_code = "2014_demer", scientific_name = "Rutilus rutilus") +#' get_animals(credentials, animal_project_code = "2014_demer", scientific_name = "Rutilus rutilus") get_animals <- function(credentials = list( username = Sys.getenv("userid"), password = Sys.getenv("pwd") diff --git a/R/get_cpod_projects.R b/R/get_cpod_projects.R index 176656e..359a6d2 100644 --- a/R/get_cpod_projects.R +++ b/R/get_cpod_projects.R @@ -13,14 +13,17 @@ #' @export #' #' @examples -#' # Set default connection variable -#' con <- connect_to_etn() +#' # Set credentials +#' credentials <- list( +#' username = Sys.getenv("userid"), +#' password = Sys.getenv("pwd") +#' ) #' #' # Get all animal projects -#' get_cpod_projects(con) +#' get_cpod_projects(credentials) #' #' # Get a specific animal project -#' get_cpod_projects(con, cpod_project_code = "cpod-lifewatch") +#' get_cpod_projects(credentials, cpod_project_code = "cpod-lifewatch") get_cpod_projects <- function(credentials = list( username = Sys.getenv("userid"), password = Sys.getenv("pwd") diff --git a/R/get_tags.R b/R/get_tags.R index 34bd907..4d94bc7 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -21,22 +21,25 @@ #' @export #' #' @examples -#' # Set default connection variable -#' con <- connect_to_etn() +#' # Set credentials +#' credentials <- list( +#' username = Sys.getenv("userid"), +#' password = Sys.getenv("pwd") +#' ) #' #' # Get all tags -#' get_tags(con) +#' get_tags(credentials) #' #' # Get archival tags, including acoustic-archival -#' get_tags(con, tag_type = c("archival", "acoustic-archival")) +#' get_tags(credentials, tag_type = c("archival", "acoustic-archival")) #' #' # Get tags of specific subtype -#' get_tags(con, tag_subtype = c("built-in", "range")) +#' get_tags(credentials, tag_subtype = c("built-in", "range")) #' #' # Get specific tags (note that these can return multiple records) -#' get_tags(con, tag_serial_number = "1187450") -#' get_tags(con, acoustic_tag_id = "A69-1601-16130") -#' get_tags(con, acoustic_tag_id = c("A69-1601-16129", "A69-1601-16130")) +#' get_tags(credentials, tag_serial_number = "1187450") +#' get_tags(credentials, acoustic_tag_id = "A69-1601-16130") +#' get_tags(credentials, acoustic_tag_id = c("A69-1601-16129", "A69-1601-16130")) get_tags <- function(credentials = list( username = Sys.getenv("userid"), password = Sys.getenv("pwd") diff --git a/R/list_values.R b/R/list_values.R index 9b4b728..b497569 100644 --- a/R/list_values.R +++ b/R/list_values.R @@ -16,12 +16,15 @@ #' @export #' #' @examples -#' # Set default connection variable -#' con <- connect_to_etn() +#' # Set credentials +#' credentials <- list( +#' username = Sys.getenv("userid"), +#' password = Sys.getenv("pwd") +#' ) #' library(dplyr) # For %>% #' #' # List unique scientific_name from a dataframe containing animal information -#' df <- get_animals(con, animal_project_code = "2014_demer") +#' df <- get_animals(credentials, animal_project_code = "2014_demer") #' list_values(df, "scientific_name") #' #' # Or using pipe and unquoted column name @@ -31,7 +34,7 @@ #' df %>% list_values(8) #' #' # tag_serial_number can contain comma-separated values -#' df <- get_animals(con, animal_id = 5841) +#' df <- get_animals(credentials, animal_id = 5841) #' df$tag_serial_number #' #' # list_values() will split those and return unique values diff --git a/man/get_acoustic_deployments.Rd b/man/get_acoustic_deployments.Rd index d6ba9d2..b62b1d4 100644 --- a/man/get_acoustic_deployments.Rd +++ b/man/get_acoustic_deployments.Rd @@ -39,24 +39,27 @@ Get data for deployments of acoustic receivers, with options to filter results. } \examples{ -# Set default connection variable -con <- connect_to_etn() +# Set credentials +credentials <- list( + username = Sys.getenv("userid"), + password = Sys.getenv("pwd") + ) # Get all acoustic deployments -get_acoustic_deployments(con) +get_acoustic_deployments(credentials) # Get specific acoustic deployment -get_acoustic_deployments(con, deployment_id = 1437) +get_acoustic_deployments(credentials, deployment_id = 1437) # Get acoustic deployments for a specific receiver -get_acoustic_deployments(con, receiver_id = "VR2W-124070") +get_acoustic_deployments(credentials, receiver_id = "VR2W-124070") # Get open acoustic deployments for a specific receiver -get_acoustic_deployments(con, receiver_id = "VR2W-124070", open_only = TRUE) +get_acoustic_deployments(credentials, receiver_id = "VR2W-124070", open_only = TRUE) # Get acoustic deployments for a specific acoustic project -get_acoustic_deployments(con, acoustic_project_code = "demer") +get_acoustic_deployments(credentials, acoustic_project_code = "demer") # Get acoustic deployments for two specific stations -get_acoustic_deployments(con, station_name = c("de-9", "de-10")) +get_acoustic_deployments(credentials, station_name = c("de-9", "de-10")) } diff --git a/man/get_acoustic_projects.Rd b/man/get_acoustic_projects.Rd index f50a12e..43e220d 100644 --- a/man/get_acoustic_projects.Rd +++ b/man/get_acoustic_projects.Rd @@ -24,12 +24,15 @@ also Get data for acoustic projects, with options to filter results. } \examples{ -# Set default connection variable -con <- connect_to_etn() +# Set credentials +credentials <- list( + username = Sys.getenv("userid"), + password = Sys.getenv("pwd") + ) # Get all acoustic projects -get_acoustic_projects(con) +get_acoustic_projects(credentials) # Get a specific acoustic project -get_acoustic_projects(con, acoustic_project_code = "demer") +get_acoustic_projects(credentials, acoustic_project_code = "demer") } diff --git a/man/get_acoustic_receivers.Rd b/man/get_acoustic_receivers.Rd index 98a45f0..f69e123 100644 --- a/man/get_acoustic_receivers.Rd +++ b/man/get_acoustic_receivers.Rd @@ -28,15 +28,18 @@ the group. Get data for acoustic receivers, with options to filter results. } \examples{ -# Set default connection variable -con <- connect_to_etn() +# Set credentials +credentials <- list( + username = Sys.getenv("userid"), + password = Sys.getenv("pwd") + ) # Get all acoustic receivers -get_acoustic_receivers(con) +get_acoustic_receivers(credentials) # Get lost and broken acoustic receivers -get_acoustic_receivers(con, status = c("lost", "broken")) +get_acoustic_receivers(credentials, status = c("lost", "broken")) # Get a specific acoustic receiver -get_acoustic_receivers(con, receiver_id = "VR2W-124070") +get_acoustic_receivers(credentials, receiver_id = "VR2W-124070") } diff --git a/man/get_animal_projects.Rd b/man/get_animal_projects.Rd index c17342a..68933ee 100644 --- a/man/get_animal_projects.Rd +++ b/man/get_animal_projects.Rd @@ -24,12 +24,15 @@ also Get data for animal projects, with options to filter results. } \examples{ -# Set default connection variable -con <- connect_to_etn() +# Set credentials +credentials <- list( + username = Sys.getenv("userid"), + password = Sys.getenv("pwd") + ) # Get all animal projects -get_animal_projects(con) +get_animal_projects(credentials) # Get a specific animal project -get_animal_projects(con, animal_project_code = "2014_demer") +get_animal_projects(credentials, animal_project_code = "2014_demer") } diff --git a/man/get_animals.Rd b/man/get_animals.Rd index c683dd2..5dd7694 100644 --- a/man/get_animals.Rd +++ b/man/get_animals.Rd @@ -36,26 +36,29 @@ information is available in columns starting with \code{tag} and the information is comma-separated. } \examples{ -# Set default connection variable -con <- connect_to_etn() +# Set credentials +credentials <- list( + username = Sys.getenv("userid"), + password = Sys.getenv("pwd") + ) # Get all animals -get_animals(con) +get_animals(credentials) # Get specific animals -get_animals(con, animal_id = 305) # Or string value "305" -get_animals(con, animal_id = c(304, 305, 2827)) +get_animals(credentials, animal_id = 305) # Or string value "305" +get_animals(credentials, animal_id = c(304, 305, 2827)) # Get animals from specific animal project(s) -get_animals(con, animal_project_code = "2014_demer") -get_animals(con, animal_project_code = c("2014_demer", "2015_dijle")) +get_animals(credentials, animal_project_code = "2014_demer") +get_animals(credentials, animal_project_code = c("2014_demer", "2015_dijle")) # Get animals associated with a specific tag_serial_number -get_animals(con, tag_serial_number = "1187450") +get_animals(credentials, tag_serial_number = "1187450") # Get animals of specific species (across all projects) -get_animals(con, scientific_name = c("Rutilus rutilus", "Silurus glanis")) +get_animals(credentials, scientific_name = c("Rutilus rutilus", "Silurus glanis")) # Get animals of a specific species from a specific project -get_animals(con, animal_project_code = "2014_demer", scientific_name = "Rutilus rutilus") +get_animals(credentials, animal_project_code = "2014_demer", scientific_name = "Rutilus rutilus") } diff --git a/man/get_cpod_projects.Rd b/man/get_cpod_projects.Rd index 899890e..302994f 100644 --- a/man/get_cpod_projects.Rd +++ b/man/get_cpod_projects.Rd @@ -24,12 +24,15 @@ also Get data for cpod projects, with options to filter results. } \examples{ -# Set default connection variable -con <- connect_to_etn() +# Set credentials +credentials <- list( + username = Sys.getenv("userid"), + password = Sys.getenv("pwd") + ) # Get all animal projects -get_cpod_projects(con) +get_cpod_projects(credentials) # Get a specific animal project -get_cpod_projects(con, cpod_project_code = "cpod-lifewatch") +get_cpod_projects(credentials, cpod_project_code = "cpod-lifewatch") } diff --git a/man/get_tags.Rd b/man/get_tags.Rd index 60a32ed..df32dfa 100644 --- a/man/get_tags.Rd +++ b/man/get_tags.Rd @@ -38,20 +38,23 @@ can be multiple records (\code{acoustic_tag_id}) per tag device (\code{tag_serial_number}). } \examples{ -# Set default connection variable -con <- connect_to_etn() +# Set credentials +credentials <- list( + username = Sys.getenv("userid"), + password = Sys.getenv("pwd") + ) # Get all tags -get_tags(con) +get_tags(credentials) # Get archival tags, including acoustic-archival -get_tags(con, tag_type = c("archival", "acoustic-archival")) +get_tags(credentials, tag_type = c("archival", "acoustic-archival")) # Get tags of specific subtype -get_tags(con, tag_subtype = c("built-in", "range")) +get_tags(credentials, tag_subtype = c("built-in", "range")) # Get specific tags (note that these can return multiple records) -get_tags(con, tag_serial_number = "1187450") -get_tags(con, acoustic_tag_id = "A69-1601-16130") -get_tags(con, acoustic_tag_id = c("A69-1601-16129", "A69-1601-16130")) +get_tags(credentials, tag_serial_number = "1187450") +get_tags(credentials, acoustic_tag_id = "A69-1601-16130") +get_tags(credentials, acoustic_tag_id = c("A69-1601-16129", "A69-1601-16130")) } diff --git a/man/list_values.Rd b/man/list_values.Rd index 716af09..490656b 100644 --- a/man/list_values.Rd +++ b/man/list_values.Rd @@ -25,12 +25,15 @@ Concatenated values (\verb{A,B}) in the column can be returned as single values (\code{A} and \code{B}). } \examples{ -# Set default connection variable -con <- connect_to_etn() +# Set credentials +credentials <- list( + username = Sys.getenv("userid"), + password = Sys.getenv("pwd") + ) library(dplyr) # For \%>\% # List unique scientific_name from a dataframe containing animal information -df <- get_animals(con, animal_project_code = "2014_demer") +df <- get_animals(credentials, animal_project_code = "2014_demer") list_values(df, "scientific_name") # Or using pipe and unquoted column name @@ -40,7 +43,7 @@ df \%>\% list_values(scientific_name) df \%>\% list_values(8) # tag_serial_number can contain comma-separated values -df <- get_animals(con, animal_id = 5841) +df <- get_animals(credentials, animal_id = 5841) df$tag_serial_number # list_values() will split those and return unique values From 7982cc4c8d9a53981c966f1ee0f919c8a3a1f435 Mon Sep 17 00:00:00 2001 From: PietrH Date: Mon, 12 Jun 2023 16:19:27 +0200 Subject: [PATCH 144/183] #36 close connection when done --- R/get_acoustic_deployments.R | 3 +++ R/get_acoustic_detections.R | 3 +++ R/get_acoustic_projects.R | 3 +++ R/get_acoustic_receivers.R | 4 ++++ R/get_animal_projects.R | 3 +++ R/get_animals.R | 4 ++++ R/get_cpod_projects.R | 3 +++ R/get_tags.R | 3 +++ R/list_acoustic_project_codes.R | 4 ++++ R/list_acoustic_tag_ids.R | 4 ++++ R/list_animal_ids.R | 3 +++ R/list_animal_project_codes.R | 3 +++ R/list_cpod_project_codes.R | 3 +++ R/list_deployment_ids.R | 3 +++ R/list_receiver_ids.R | 4 ++++ R/list_scientific_names.R | 3 +++ R/list_station_names.R | 3 +++ R/list_tag_serial_numbers.R | 4 ++++ R/write_dwc.R | 3 +++ tests/testthat/test-connect_to_etn.R | 1 + 20 files changed, 64 insertions(+) diff --git a/R/get_acoustic_deployments.R b/R/get_acoustic_deployments.R index 0bc8495..6e07dea 100644 --- a/R/get_acoustic_deployments.R +++ b/R/get_acoustic_deployments.R @@ -192,6 +192,9 @@ get_acoustic_deployments <- function( ", .con = connection) deployments <- DBI::dbGetQuery(connection, query) + # Close connection + DBI::dbDisconnect(connection) + # Filter on open deployments if (open_only) { deployments <- filter(deployments, is.na(.data$recover_date_time)) diff --git a/R/get_acoustic_detections.R b/R/get_acoustic_detections.R index f014f22..f35f96d 100644 --- a/R/get_acoustic_detections.R +++ b/R/get_acoustic_detections.R @@ -272,6 +272,9 @@ get_acoustic_detections <- function(credentials = list( factor(.data$acoustic_tag_id, levels = list_acoustic_tag_ids(credentials)), .data$date_time ) + # Close connection + DBI::dbDisconnect(connection) + # Return detections dplyr::as_tibble(detections) } diff --git a/R/get_acoustic_projects.R b/R/get_acoustic_projects.R index d8becae..082f27e 100644 --- a/R/get_acoustic_projects.R +++ b/R/get_acoustic_projects.R @@ -69,6 +69,9 @@ get_acoustic_projects <- function(credentials = list( ", .con = connection) projects <- DBI::dbGetQuery(connection, query) + # Close connection + DBI::dbDisconnect(connection) + # Sort data projects <- projects %>% diff --git a/R/get_acoustic_receivers.R b/R/get_acoustic_receivers.R index fa3b174..d6570ab 100644 --- a/R/get_acoustic_receivers.R +++ b/R/get_acoustic_receivers.R @@ -127,5 +127,9 @@ get_acoustic_receivers <- function(credentials = list( receivers %>% dplyr::arrange(.data$receiver_id) + # Close connection + DBI::dbDisconnect(connection) + + # Return receivers dplyr::as_tibble(receivers) } diff --git a/R/get_animal_projects.R b/R/get_animal_projects.R index 2767418..c552644 100644 --- a/R/get_animal_projects.R +++ b/R/get_animal_projects.R @@ -68,6 +68,9 @@ get_animal_projects <- function(credentials = list( ", .con = connection) projects <- DBI::dbGetQuery(connection, query) + # Close connection + DBI::dbDisconnect(connection) + # Sort data projects <- projects %>% diff --git a/R/get_animals.R b/R/get_animals.R index 86a3b29..4317be2 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -243,5 +243,9 @@ get_animals <- function(credentials = list( factor(.data$tag_serial_number, levels = list_tag_serial_numbers(credentials)) ) + # Close connection + DBI::dbDisconnect(connection) + + # Return animals dplyr::as_tibble(animals) # Is already a tibble, but added if code above changes } diff --git a/R/get_cpod_projects.R b/R/get_cpod_projects.R index 359a6d2..459b17c 100644 --- a/R/get_cpod_projects.R +++ b/R/get_cpod_projects.R @@ -72,6 +72,9 @@ get_cpod_projects <- function(credentials = list( projects <- projects %>% dplyr::arrange(.data$project_code) + # Close connection + DBI::dbDisconnect(connection) + # Return data dplyr::as_tibble(projects) } diff --git a/R/get_tags.R b/R/get_tags.R index 4d94bc7..a370801 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -205,6 +205,9 @@ get_tags <- function(credentials = list( ", .con = connection) tags <- DBI::dbGetQuery(connection, query) + # Close connection + DBI::dbDisconnect(connection) + # Sort data tags <- tags %>% diff --git a/R/list_acoustic_project_codes.R b/R/list_acoustic_project_codes.R index a46634c..0289c76 100644 --- a/R/list_acoustic_project_codes.R +++ b/R/list_acoustic_project_codes.R @@ -22,5 +22,9 @@ list_acoustic_project_codes <- function(credentials = list( ) data <- DBI::dbGetQuery(connection, query) + # Close connection + DBI::dbDisconnect(connection) + + # Return acoustic_project_codes sort(data$project_code) } diff --git a/R/list_acoustic_tag_ids.R b/R/list_acoustic_tag_ids.R index b8a21e0..a98e4f0 100644 --- a/R/list_acoustic_tag_ids.R +++ b/R/list_acoustic_tag_ids.R @@ -21,5 +21,9 @@ list_acoustic_tag_ids <- function(credentials = list( ", .con = connection) data <- DBI::dbGetQuery(connection, query) + # Close connection + DBI::dbDisconnect(connection) + + # Return acoustic_tag_ids stringr::str_sort(data$acoustic_tag_id, numeric = TRUE) } diff --git a/R/list_animal_ids.R b/R/list_animal_ids.R index 9155fd1..5f3a72a 100644 --- a/R/list_animal_ids.R +++ b/R/list_animal_ids.R @@ -20,5 +20,8 @@ list_animal_ids <- function(credentials = list( ) data <- DBI::dbGetQuery(connection, query) + # Close connection + DBI::dbDisconnect(connection) + sort(data$id_pk) } diff --git a/R/list_animal_project_codes.R b/R/list_animal_project_codes.R index 19455ea..ce58c15 100644 --- a/R/list_animal_project_codes.R +++ b/R/list_animal_project_codes.R @@ -22,5 +22,8 @@ list_animal_project_codes <- function(credentials = list( ) data <- DBI::dbGetQuery(connection, query) + # Close connection + DBI::dbDisconnect(connection) + sort(data$project_code) } diff --git a/R/list_cpod_project_codes.R b/R/list_cpod_project_codes.R index 14a4734..b7085e0 100644 --- a/R/list_cpod_project_codes.R +++ b/R/list_cpod_project_codes.R @@ -27,5 +27,8 @@ list_cpod_project_codes <- function(credentials = list( ) data <- DBI::dbGetQuery(connection, query) + # Close connection + DBI::dbDisconnect(connection) + sort(data$project_code) } diff --git a/R/list_deployment_ids.R b/R/list_deployment_ids.R index 24ac77e..24994a2 100644 --- a/R/list_deployment_ids.R +++ b/R/list_deployment_ids.R @@ -18,5 +18,8 @@ list_deployment_ids <- function(credentials = list( ) data <- DBI::dbGetQuery(connection, query) + # Close connection + DBI::dbDisconnect(connection) + stringr::str_sort(data$id, numeric = TRUE) } diff --git a/R/list_receiver_ids.R b/R/list_receiver_ids.R index d4cabbe..c64f019 100644 --- a/R/list_receiver_ids.R +++ b/R/list_receiver_ids.R @@ -16,5 +16,9 @@ list_receiver_ids <- function(credentials = list( ) data <- DBI::dbGetQuery(connection, query) + # Close connection + DBI::dbDisconnect(connection) + + # Return receiver_ids stringr::str_sort(data$receiver, numeric = TRUE) } diff --git a/R/list_scientific_names.R b/R/list_scientific_names.R index b298be3..37e815d 100644 --- a/R/list_scientific_names.R +++ b/R/list_scientific_names.R @@ -17,5 +17,8 @@ list_scientific_names <- function(credentials = list( ) data <- DBI::dbGetQuery(connection, query) + # Close connection + DBI::dbDisconnect(connection) + sort(data$scientific_name) } diff --git a/R/list_station_names.R b/R/list_station_names.R index 3d89a3c..a6f038d 100644 --- a/R/list_station_names.R +++ b/R/list_station_names.R @@ -18,5 +18,8 @@ list_station_names <- function(credentials = list( ) data <- DBI::dbGetQuery(connection, query) + # Close connection + DBI::dbDisconnect(connection) + stringr::str_sort(data$station_name, numeric = TRUE) } diff --git a/R/list_tag_serial_numbers.R b/R/list_tag_serial_numbers.R index ccdf9c4..92b53fa 100644 --- a/R/list_tag_serial_numbers.R +++ b/R/list_tag_serial_numbers.R @@ -22,5 +22,9 @@ list_tag_serial_numbers <- function(credentials = list( ) data <- DBI::dbGetQuery(connection, query) + # Close connection + DBI::dbDisconnect(connection) + + # Return vector stringr::str_sort(data$serial_number, numeric = TRUE) } diff --git a/R/write_dwc.R b/R/write_dwc.R index f2a3f3f..20d6521 100644 --- a/R/write_dwc.R +++ b/R/write_dwc.R @@ -93,6 +93,9 @@ write_dwc <- function(credentials = list( ) dwc_occurrence <- DBI::dbGetQuery(connection, dwc_occurrence_sql) + # Close connection + DBI::dbDisconnect(connection) + # Return object or write files return( list(dwc_occurrence = dplyr::as_tibble(dwc_occurrence)) diff --git a/tests/testthat/test-connect_to_etn.R b/tests/testthat/test-connect_to_etn.R index bffef61..c31fbb9 100644 --- a/tests/testthat/test-connect_to_etn.R +++ b/tests/testthat/test-connect_to_etn.R @@ -6,4 +6,5 @@ test_that("connect_to_etn() allows to create a connection with passed credential connection <- connect_to_etn(credentials$username, credentials$password) expect_true(check_connection(connection)) expect_true(isClass(connection, "PostgreSQL")) + DBI::dbDisconnect(connection) }) From f96e960174f165ae28d06a80ca4bde4152e6198b Mon Sep 17 00:00:00 2001 From: PietrH Date: Mon, 12 Jun 2023 16:47:04 +0200 Subject: [PATCH 145/183] remove list_values() from API https://github.com/inbo/etnservice/issues/26#issuecomment-1586826387 #27 --- NAMESPACE | 1 - R/list_values.R | 94 ---------------------------------------------- man/list_values.Rd | 54 -------------------------- 3 files changed, 149 deletions(-) delete mode 100644 R/list_values.R delete mode 100644 man/list_values.Rd diff --git a/NAMESPACE b/NAMESPACE index 1343507..e4cfe9d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -19,7 +19,6 @@ export(list_receiver_ids) export(list_scientific_names) export(list_station_names) export(list_tag_serial_numbers) -export(list_values) export(write_dwc) importFrom(dplyr,"%>%") importFrom(dplyr,.data) diff --git a/R/list_values.R b/R/list_values.R deleted file mode 100644 index b497569..0000000 --- a/R/list_values.R +++ /dev/null @@ -1,94 +0,0 @@ -#' List all unique values from a data.frame column -#' -#' Get a vector with all unique values found in a given column of a data.frame. -#' Concatenated values (`A,B`) in the column can be returned as single values -#' (`A` and `B`). -#' -#' @param .data Data frame. Data.frame to select column from. -#' @param column Character or integer. Quoted or unqoted column name or column -#' position. -#' @param split Character (vector). Character or regular expression(s) passed -#' to [strsplit()] to split column values before returning unique values. -#' Defaults to `,`. -#' -#' @return A vector of the same type as the given column. -#' -#' @export -#' -#' @examples -#' # Set credentials -#' credentials <- list( -#' username = Sys.getenv("userid"), -#' password = Sys.getenv("pwd") -#' ) -#' library(dplyr) # For %>% -#' -#' # List unique scientific_name from a dataframe containing animal information -#' df <- get_animals(credentials, animal_project_code = "2014_demer") -#' list_values(df, "scientific_name") -#' -#' # Or using pipe and unquoted column name -#' df %>% list_values(scientific_name) -#' -#' # Or using column position -#' df %>% list_values(8) -#' -#' # tag_serial_number can contain comma-separated values -#' df <- get_animals(credentials, animal_id = 5841) -#' df$tag_serial_number -#' -#' # list_values() will split those and return unique values -#' list_values(df, tag_serial_number) -#' -#' # Another expression can be defined to split values (here ".") -#' list_values(df, tag_serial_number, split = "\\.") -list_values <- function(.data, column, split = ",") { - # check .data - assertthat::assert_that(is.data.frame(.data)) - # check split - assertthat::assert_that(is.character(split)) - - arguments <- as.list(match.call()) - - if (is.numeric(arguments$column)){ - col_number <- arguments$column - n_col_df <- ncol(.data) - assertthat::assert_that(as.integer(col_number) == col_number, - msg = "column number must be an integer") - assertthat::assert_that(col_number <= ncol(.data), - msg = glue::glue("column number exceeds the number of columns ", - "of .data ({n_col_df})")) - # extract values - values <- .data[,col_number] - # extract column name - col_name <- names(.data)[col_number] - } else { - #check column name - col_name <- as.character(arguments$column) - assertthat::assert_that(length(col_name) == 1, - msg = "invalid column value") - assertthat::assert_that(col_name %in% names(.data), - msg = glue::glue("column {col_name} not found in .data")) - - # extract values - if (class(arguments$column) == "name") { - values <- eval(arguments$column, .data) - } else { - if (is.character(arguments$column)) { - values <- .data[[arguments$column]] - } - } - } - - if (is.character(values)) - # extract all values by splitting strings using split value - values <- unlist(strsplit(x = values, split = split)) - - # remove duplicates, unique values only - values <- unique(values) - - # return a message on console - message(glue::glue("{length(values)} unique {col_name} values")) - - return(values) -} diff --git a/man/list_values.Rd b/man/list_values.Rd deleted file mode 100644 index 490656b..0000000 --- a/man/list_values.Rd +++ /dev/null @@ -1,54 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/list_values.R -\name{list_values} -\alias{list_values} -\title{List all unique values from a data.frame column} -\usage{ -list_values(.data, column, split = ",") -} -\arguments{ -\item{.data}{Data frame. Data.frame to select column from.} - -\item{column}{Character or integer. Quoted or unqoted column name or column -position.} - -\item{split}{Character (vector). Character or regular expression(s) passed -to \code{\link[=strsplit]{strsplit()}} to split column values before returning unique values. -Defaults to \verb{,}.} -} -\value{ -A vector of the same type as the given column. -} -\description{ -Get a vector with all unique values found in a given column of a data.frame. -Concatenated values (\verb{A,B}) in the column can be returned as single values -(\code{A} and \code{B}). -} -\examples{ -# Set credentials -credentials <- list( - username = Sys.getenv("userid"), - password = Sys.getenv("pwd") - ) -library(dplyr) # For \%>\% - -# List unique scientific_name from a dataframe containing animal information -df <- get_animals(credentials, animal_project_code = "2014_demer") -list_values(df, "scientific_name") - -# Or using pipe and unquoted column name -df \%>\% list_values(scientific_name) - -# Or using column position -df \%>\% list_values(8) - -# tag_serial_number can contain comma-separated values -df <- get_animals(credentials, animal_id = 5841) -df$tag_serial_number - -# list_values() will split those and return unique values -list_values(df, tag_serial_number) - -# Another expression can be defined to split values (here ".") -list_values(df, tag_serial_number, split = "\\\\.") -} From 078b2a120dc47572d1f6cfe3ccc2441b4b6225cf Mon Sep 17 00:00:00 2001 From: Pieter Huybrechts <48065851+PietrH@users.noreply.github.com> Date: Thu, 22 Jun 2023 13:19:29 +0200 Subject: [PATCH 146/183] update postman tests --- tests/postman/test-get_acoustic_deployments.js | 7 +++++++ tests/postman/test-get_acoustic_detections REQUEST.js | 4 ++-- tests/postman/test-get_acoustic_detections.js | 4 ++-- tests/postman/test-get_acoustic_projects.js | 9 +++++++++ tests/postman/test-get_acoustic_receivers.js | 9 +++++++++ tests/postman/test-get_animal_projects.js | 7 +++++++ tests/postman/test-get_animals.js | 7 +++++++ tests/postman/test-get_cpod_projects.js | 7 +++++++ tests/postman/test-get_tags.js | 7 +++++++ tests/postman/test-list_ functions.js | 1 + tests/postman/test-list_cpod_project_codes.js | 8 ++++++++ tests/postman/test-list_tag_serial_numbers.js | 8 ++++++++ 12 files changed, 74 insertions(+), 4 deletions(-) create mode 100644 tests/postman/test-get_acoustic_deployments.js create mode 100644 tests/postman/test-get_acoustic_projects.js create mode 100644 tests/postman/test-get_acoustic_receivers.js create mode 100644 tests/postman/test-get_animal_projects.js create mode 100644 tests/postman/test-get_animals.js create mode 100644 tests/postman/test-get_cpod_projects.js create mode 100644 tests/postman/test-get_tags.js create mode 100644 tests/postman/test-list_ functions.js create mode 100644 tests/postman/test-list_cpod_project_codes.js create mode 100644 tests/postman/test-list_tag_serial_numbers.js diff --git a/tests/postman/test-get_acoustic_deployments.js b/tests/postman/test-get_acoustic_deployments.js new file mode 100644 index 0000000..4564adb --- /dev/null +++ b/tests/postman/test-get_acoustic_deployments.js @@ -0,0 +1,7 @@ +pm.test("Status code is 201", function () { + pm.response.to.have.status(201); + }); + +pm.test("Response time is less than 10s", function () { + pm.expect(pm.response.responseTime).to.be.below(10000); + }); diff --git a/tests/postman/test-get_acoustic_detections REQUEST.js b/tests/postman/test-get_acoustic_detections REQUEST.js index f95797c..222b91c 100644 --- a/tests/postman/test-get_acoustic_detections REQUEST.js +++ b/tests/postman/test-get_acoustic_detections REQUEST.js @@ -7,6 +7,6 @@ savedData = responsePaths.split("\n")[0]; savedData = savedData.slice(6) pm.collectionVariables.set("savedData", savedData); -pm.test("Response time is less than 3s", function () { - pm.expect(pm.response.responseTime).to.be.below(3000); +pm.test("Response time is less than 6s", function () { + pm.expect(pm.response.responseTime).to.be.below(6000); }); diff --git a/tests/postman/test-get_acoustic_detections.js b/tests/postman/test-get_acoustic_detections.js index fe4b1ec..2dfa8ed 100644 --- a/tests/postman/test-get_acoustic_detections.js +++ b/tests/postman/test-get_acoustic_detections.js @@ -2,6 +2,6 @@ pm.test("Status code is 201", function () { pm.response.to.have.status(201); }); -pm.test("Response time is less than 3s", function () { - pm.expect(pm.response.responseTime).to.be.below(3000); +pm.test("Response time is less than 6s", function () { + pm.expect(pm.response.responseTime).to.be.below(6000); }); diff --git a/tests/postman/test-get_acoustic_projects.js b/tests/postman/test-get_acoustic_projects.js new file mode 100644 index 0000000..4bb210e --- /dev/null +++ b/tests/postman/test-get_acoustic_projects.js @@ -0,0 +1,9 @@ +pm.test("Status code is 201", function () { + pm.response.to.have.status(201); + }); + + +pm.test("Response time is less than 6s", function () { + pm.expect(pm.response.responseTime).to.be.below(6000); + }); + diff --git a/tests/postman/test-get_acoustic_receivers.js b/tests/postman/test-get_acoustic_receivers.js new file mode 100644 index 0000000..4bb210e --- /dev/null +++ b/tests/postman/test-get_acoustic_receivers.js @@ -0,0 +1,9 @@ +pm.test("Status code is 201", function () { + pm.response.to.have.status(201); + }); + + +pm.test("Response time is less than 6s", function () { + pm.expect(pm.response.responseTime).to.be.below(6000); + }); + diff --git a/tests/postman/test-get_animal_projects.js b/tests/postman/test-get_animal_projects.js new file mode 100644 index 0000000..2dfa8ed --- /dev/null +++ b/tests/postman/test-get_animal_projects.js @@ -0,0 +1,7 @@ +pm.test("Status code is 201", function () { + pm.response.to.have.status(201); + }); + +pm.test("Response time is less than 6s", function () { + pm.expect(pm.response.responseTime).to.be.below(6000); + }); diff --git a/tests/postman/test-get_animals.js b/tests/postman/test-get_animals.js new file mode 100644 index 0000000..4564adb --- /dev/null +++ b/tests/postman/test-get_animals.js @@ -0,0 +1,7 @@ +pm.test("Status code is 201", function () { + pm.response.to.have.status(201); + }); + +pm.test("Response time is less than 10s", function () { + pm.expect(pm.response.responseTime).to.be.below(10000); + }); diff --git a/tests/postman/test-get_cpod_projects.js b/tests/postman/test-get_cpod_projects.js new file mode 100644 index 0000000..2dfa8ed --- /dev/null +++ b/tests/postman/test-get_cpod_projects.js @@ -0,0 +1,7 @@ +pm.test("Status code is 201", function () { + pm.response.to.have.status(201); + }); + +pm.test("Response time is less than 6s", function () { + pm.expect(pm.response.responseTime).to.be.below(6000); + }); diff --git a/tests/postman/test-get_tags.js b/tests/postman/test-get_tags.js new file mode 100644 index 0000000..2dfa8ed --- /dev/null +++ b/tests/postman/test-get_tags.js @@ -0,0 +1,7 @@ +pm.test("Status code is 201", function () { + pm.response.to.have.status(201); + }); + +pm.test("Response time is less than 6s", function () { + pm.expect(pm.response.responseTime).to.be.below(6000); + }); diff --git a/tests/postman/test-list_ functions.js b/tests/postman/test-list_ functions.js new file mode 100644 index 0000000..8b13789 --- /dev/null +++ b/tests/postman/test-list_ functions.js @@ -0,0 +1 @@ + diff --git a/tests/postman/test-list_cpod_project_codes.js b/tests/postman/test-list_cpod_project_codes.js new file mode 100644 index 0000000..2ff29e0 --- /dev/null +++ b/tests/postman/test-list_cpod_project_codes.js @@ -0,0 +1,8 @@ +pm.test("Status code is 201", function () { + pm.response.to.have.status(201); + }); + +pm.test("Response time is less than 3s", function () { + pm.expect(pm.response.responseTime).to.be.below(3000); + }); + diff --git a/tests/postman/test-list_tag_serial_numbers.js b/tests/postman/test-list_tag_serial_numbers.js new file mode 100644 index 0000000..2ff29e0 --- /dev/null +++ b/tests/postman/test-list_tag_serial_numbers.js @@ -0,0 +1,8 @@ +pm.test("Status code is 201", function () { + pm.response.to.have.status(201); + }); + +pm.test("Response time is less than 3s", function () { + pm.expect(pm.response.responseTime).to.be.below(3000); + }); + From fb3f2268789376633c28a5e01fc43e79b22e227c Mon Sep 17 00:00:00 2001 From: Pieter Huybrechts <48065851+PietrH@users.noreply.github.com> Date: Mon, 23 Oct 2023 11:37:32 +0200 Subject: [PATCH 147/183] Create test-get_acoustic_detections demer Rutilus.js --- .../postman/test-get_acoustic_detections demer Rutilus.js | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 tests/postman/test-get_acoustic_detections demer Rutilus.js diff --git a/tests/postman/test-get_acoustic_detections demer Rutilus.js b/tests/postman/test-get_acoustic_detections demer Rutilus.js new file mode 100644 index 0000000..2dfa8ed --- /dev/null +++ b/tests/postman/test-get_acoustic_detections demer Rutilus.js @@ -0,0 +1,7 @@ +pm.test("Status code is 201", function () { + pm.response.to.have.status(201); + }); + +pm.test("Response time is less than 6s", function () { + pm.expect(pm.response.responseTime).to.be.below(6000); + }); From c771563d4b4dcd5e3a756c0f6dbc2dff8b5f3c89 Mon Sep 17 00:00:00 2001 From: Pieter Huybrechts <48065851+PietrH@users.noreply.github.com> Date: Tue, 24 Oct 2023 10:58:26 +0200 Subject: [PATCH 148/183] #38 remove `V2LDBS` from expectation, suspect removed from source db --- tests/postman/test-list_acoustic_project_codes.js | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/postman/test-list_acoustic_project_codes.js b/tests/postman/test-list_acoustic_project_codes.js index 987d8d3..bf224f6 100644 --- a/tests/postman/test-list_acoustic_project_codes.js +++ b/tests/postman/test-list_acoustic_project_codes.js @@ -7,7 +7,7 @@ pm.test("returns the right animal ids", () => { //array is not empty pm.expect(jsonData).to.not.be.empty; //ids include number of known values - pm.expect(jsonData).to.include.members(["Mobula_IMAR","Sudle_IMPULS","SVNL-FISH-WATCH","SwanseaBristolArray","2019_Grotenete","Inforbiomares","BOOGMR","ws2","V2LDBS","zeeschelde","LESPUR","ws3","RESBIO","ST08SWE","PTN-Silver-eel-Mondego","Jersey_Coastal","Deveron","KBTN","FISHINTEL","Siganid_Gulf_Aqaba","Danube_Sturgeons","VVV","Walloneel","V2LCASP","BOOPIRATA","2015_PhD_Gutmann_Roberts","OTN_UPLOAD","NTNU-Gaulosen","BTN-IMEDEA","Reelease","AZO","PhD_Marrocco","2017_Fremur","mepnsw","paintedcomber","none","ARAISOLA03","PhysFish","life4fish","GIBRALTRACK_pilot","Artevigo","SEM","V2LGOL","SWIMWAY_2021","PhD_Jeremy_Pastor","PTN/PROTECT2012","MIGRATOEBRE","MOPP","V2LNR","eemskanaal_III"]); + pm.expect(jsonData).to.include.members(["Mobula_IMAR","Sudle_IMPULS","SVNL-FISH-WATCH","SwanseaBristolArray","2019_Grotenete","Inforbiomares","BOOGMR","ws2","zeeschelde","LESPUR","ws3","RESBIO","ST08SWE","PTN-Silver-eel-Mondego","Jersey_Coastal","Deveron","KBTN","FISHINTEL","Siganid_Gulf_Aqaba","Danube_Sturgeons","VVV","Walloneel","V2LCASP","BOOPIRATA","2015_PhD_Gutmann_Roberts","OTN_UPLOAD","NTNU-Gaulosen","BTN-IMEDEA","Reelease","AZO","PhD_Marrocco","2017_Fremur","mepnsw","paintedcomber","none","ARAISOLA03","PhysFish","life4fish","GIBRALTRACK_pilot","Artevigo","SEM","V2LGOL","SWIMWAY_2021","PhD_Jeremy_Pastor","PTN/PROTECT2012","MIGRATOEBRE","MOPP","V2LNR","eemskanaal_III"]); }); pm.test("Response time is less than 3s", function () { From ff5e6fe873c0b31458671c41267d375e3ab01774 Mon Sep 17 00:00:00 2001 From: Pieter Huybrechts <48065851+PietrH@users.noreply.github.com> Date: Tue, 24 Oct 2023 10:58:49 +0200 Subject: [PATCH 149/183] update test titles to include function names --- tests/postman/test-list_acoustic_project_codes.js | 2 +- tests/postman/test-list_acoustic_tag_ids.js | 2 +- tests/postman/test-list_animal_project_codes.js | 2 +- tests/postman/test-list_receiver_ids.js | 2 +- tests/postman/test-list_scientific_names.js | 2 +- tests/postman/test-list_station_names.js | 2 +- 6 files changed, 6 insertions(+), 6 deletions(-) diff --git a/tests/postman/test-list_acoustic_project_codes.js b/tests/postman/test-list_acoustic_project_codes.js index bf224f6..00773fd 100644 --- a/tests/postman/test-list_acoustic_project_codes.js +++ b/tests/postman/test-list_acoustic_project_codes.js @@ -3,7 +3,7 @@ pm.test("Status code is 201", function () { }); const jsonData = pm.response.json(); -pm.test("returns the right animal ids", () => { +pm.test("returns the right acoustic project codes", () => { //array is not empty pm.expect(jsonData).to.not.be.empty; //ids include number of known values diff --git a/tests/postman/test-list_acoustic_tag_ids.js b/tests/postman/test-list_acoustic_tag_ids.js index 9c9df2a..cb83b06 100644 --- a/tests/postman/test-list_acoustic_tag_ids.js +++ b/tests/postman/test-list_acoustic_tag_ids.js @@ -3,7 +3,7 @@ pm.test("Status code is 201", function () { }); const jsonData = pm.response.json(); -pm.test("returns the right animal ids", () => { +pm.test("returns the right acoustic tag ids", () => { //array is not empty pm.expect(jsonData).to.not.be.empty; //ids include number of known values diff --git a/tests/postman/test-list_animal_project_codes.js b/tests/postman/test-list_animal_project_codes.js index 51e32f5..1d463e5 100644 --- a/tests/postman/test-list_animal_project_codes.js +++ b/tests/postman/test-list_animal_project_codes.js @@ -3,7 +3,7 @@ pm.test("Status code is 201", function () { }); const jsonData = pm.response.json(); -pm.test("returns the right animal ids", () => { +pm.test("returns the right animal project codes", () => { //array is not empty pm.expect(jsonData).to.not.be.empty; //ids include number of known values diff --git a/tests/postman/test-list_receiver_ids.js b/tests/postman/test-list_receiver_ids.js index f3b1cc8..a518585 100644 --- a/tests/postman/test-list_receiver_ids.js +++ b/tests/postman/test-list_receiver_ids.js @@ -3,7 +3,7 @@ pm.test("Status code is 201", function () { }); const jsonData = pm.response.json(); -pm.test("returns the right animal ids", () => { +pm.test("returns the right receiver ids", () => { //array is not empty pm.expect(jsonData).to.not.be.empty; //ids include number of known values diff --git a/tests/postman/test-list_scientific_names.js b/tests/postman/test-list_scientific_names.js index ed2ec0f..e246bd2 100644 --- a/tests/postman/test-list_scientific_names.js +++ b/tests/postman/test-list_scientific_names.js @@ -3,7 +3,7 @@ pm.test("Status code is 201", function () { }); const jsonData = pm.response.json(); -pm.test("returns the right animal ids", () => { +pm.test("returns the right scientific names", () => { //array is not empty pm.expect(jsonData).to.not.be.empty; //ids include number of known values diff --git a/tests/postman/test-list_station_names.js b/tests/postman/test-list_station_names.js index df0cc15..5380c27 100644 --- a/tests/postman/test-list_station_names.js +++ b/tests/postman/test-list_station_names.js @@ -3,7 +3,7 @@ pm.test("Status code is 201", function () { }); const jsonData = pm.response.json(); -pm.test("returns the right animal ids", () => { +pm.test("returns the right station names", () => { //array is not empty pm.expect(jsonData).to.not.be.empty; //ids include number of known values From 2437f840d93d215608e5c88d89e0e6c1afb28606 Mon Sep 17 00:00:00 2001 From: Pieter Huybrechts <48065851+PietrH@users.noreply.github.com> Date: Tue, 24 Oct 2023 10:59:05 +0200 Subject: [PATCH 150/183] add test with response content expectation --- tests/postman/test-list_cpod_project_codes.js | 21 +++++++++++++++++++ tests/postman/test-list_tag_serial_numbers.js | 8 +++++++ 2 files changed, 29 insertions(+) diff --git a/tests/postman/test-list_cpod_project_codes.js b/tests/postman/test-list_cpod_project_codes.js index 2ff29e0..c915de0 100644 --- a/tests/postman/test-list_cpod_project_codes.js +++ b/tests/postman/test-list_cpod_project_codes.js @@ -6,3 +6,24 @@ pm.test("Response time is less than 3s", function () { pm.expect(pm.response.responseTime).to.be.below(3000); }); +const jsonData = pm.response.json(); +pm.test("returns the right cpod project codes", () => { + //array is not empty + pm.expect(jsonData).to.not.be.empty; + //ids include number of known values + pm.expect(jsonData).to.include.members([ + "Apelafico_acoustics", + "Apelafico_underwater", + "cpod-lifewatch", + "cpod-od-natuur", + "PAM-Borssele", + "PelFish", + "PhD_Parcerisas", + "SEAWave", + "SMGMIT", + "STRAITS_PAM", + "VLIZ-MRC-AMUC-001", + "VLIZ-MRC-AMUC-002", + "WaveHub" +]); + }); diff --git a/tests/postman/test-list_tag_serial_numbers.js b/tests/postman/test-list_tag_serial_numbers.js index 2ff29e0..1243638 100644 --- a/tests/postman/test-list_tag_serial_numbers.js +++ b/tests/postman/test-list_tag_serial_numbers.js @@ -6,3 +6,11 @@ pm.test("Response time is less than 3s", function () { pm.expect(pm.response.responseTime).to.be.below(3000); }); +const jsonData = pm.response.json(); +pm.test("returns the right tag serial numbers", () => { + //array is not empty + pm.expect(jsonData).to.not.be.empty; + //ids include number of known values + pm.expect(jsonData).to.include.members(["04C6", "1734024", "20169187","A69-1602-30050", "1290765", "21293183", "JS031725", "A17665" +]); + }); From e0ef007522e57a31d61ee5e6e9dedea996293ba0 Mon Sep 17 00:00:00 2001 From: PietrH Date: Wed, 4 Sep 2024 10:41:23 +0200 Subject: [PATCH 151/183] refer to own package, instead of etn --- R/write_dwc.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/write_dwc.R b/R/write_dwc.R index 20d6521..ae16e93 100644 --- a/R/write_dwc.R +++ b/R/write_dwc.R @@ -88,8 +88,9 @@ write_dwc <- function(credentials = list( # message("Reading data and transforming to Darwin Core.") dwc_occurrence_sql <- glue::glue_sql( - readr::read_file(system.file("sql/dwc_occurrence.sql", package = "etn")), .con = connection + readr::read_file(system.file("sql/dwc_occurrence.sql", + package = "etnservice")), ) dwc_occurrence <- DBI::dbGetQuery(connection, dwc_occurrence_sql) From fdc4c3af82b2163a83c4c76ec60b82f01d19c0d0 Mon Sep 17 00:00:00 2001 From: PietrH Date: Wed, 4 Sep 2024 10:42:42 +0200 Subject: [PATCH 152/183] replace NULL values with `NULL` See https://github.com/inbo/etn/pull/294 --- R/write_dwc.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/write_dwc.R b/R/write_dwc.R index ae16e93..6e601f3 100644 --- a/R/write_dwc.R +++ b/R/write_dwc.R @@ -88,9 +88,10 @@ write_dwc <- function(credentials = list( # message("Reading data and transforming to Darwin Core.") dwc_occurrence_sql <- glue::glue_sql( - .con = connection readr::read_file(system.file("sql/dwc_occurrence.sql", package = "etnservice")), + .con = connection, + .null = "NULL" ) dwc_occurrence <- DBI::dbGetQuery(connection, dwc_occurrence_sql) From 48869422f06d14c0a7dfe079d2dd06589213fd19 Mon Sep 17 00:00:00 2001 From: PietrH Date: Wed, 4 Sep 2024 10:44:25 +0200 Subject: [PATCH 153/183] Allow uppercase animal project codes --- R/write_dwc.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/write_dwc.R b/R/write_dwc.R index 6e601f3..a33c7f4 100644 --- a/R/write_dwc.R +++ b/R/write_dwc.R @@ -57,6 +57,8 @@ write_dwc <- function(credentials = list( length(animal_project_code) == 1, msg = "`animal_project_code` must be a single value." ) + ## Set animal project code to lowercase for sql + animal_project_code <- stringr::str_to_lower(animal_project_code) # Check license licenses <- c("CC-BY", "CC0") From d64a660e407b9a3d116d05e6479f925bde71ce9f Mon Sep 17 00:00:00 2001 From: PietrH Date: Wed, 4 Sep 2024 10:45:40 +0200 Subject: [PATCH 154/183] update docs to reflect no csv is written --- R/write_dwc.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/write_dwc.R b/R/write_dwc.R index a33c7f4..36bfd6a 100644 --- a/R/write_dwc.R +++ b/R/write_dwc.R @@ -2,7 +2,7 @@ #' #' Transforms and downloads data from a European Tracking Network #' **animal project** to [Darwin Core](https://dwc.tdwg.org/). -#' The resulting CSV file(s) can be uploaded to an [IPT]( +#' The resulting tibble can be saved as a CSV and be uploaded to an [IPT]( #' https://www.gbif.org/ipt) for publication to OBIS and/or GBIF. #' A `meta.xml` or `eml.xml` file are not created. #' From 71d6ad0d9143b59e01422eef2f884576ff84c367 Mon Sep 17 00:00:00 2001 From: PietrH Date: Wed, 4 Sep 2024 10:46:25 +0200 Subject: [PATCH 155/183] refer to dataframe instead of tibble --- R/write_dwc.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/write_dwc.R b/R/write_dwc.R index 36bfd6a..201c9b8 100644 --- a/R/write_dwc.R +++ b/R/write_dwc.R @@ -2,7 +2,7 @@ #' #' Transforms and downloads data from a European Tracking Network #' **animal project** to [Darwin Core](https://dwc.tdwg.org/). -#' The resulting tibble can be saved as a CSV and be uploaded to an [IPT]( +#' The resulting dataframe can be saved as a CSV and be uploaded to an [IPT]( #' https://www.gbif.org/ipt) for publication to OBIS and/or GBIF. #' A `meta.xml` or `eml.xml` file are not created. #' @@ -14,7 +14,7 @@ #' published. #' - [`CC-BY`](https://creativecommons.org/licenses/by/4.0/legalcode) (default). #' - [`CC0`](https://creativecommons.org/publicdomain/zero/1.0/legalcode). -#' @return list of data frames +#' @return list of dataframes #' @export #' @section Transformation details: #' Data are transformed into an From cc6dcc041e46e14bc09b12cfaa62da5e7c1f94bf Mon Sep 17 00:00:00 2001 From: PietrH Date: Thu, 12 Sep 2024 10:40:21 +0200 Subject: [PATCH 156/183] update postman tests --- tests/postman/test-get_tags.js | 4 ++-- tests/postman/test-list_animal_project_codes.js | 6 +++--- tests/postman/test-list_deployment_ids.js | 15 +++++++++++++++ tests/postman/test-list_station_names.js | 2 +- tests/postman/test-write_dwc.js | 15 +++++++++++++++ 5 files changed, 36 insertions(+), 6 deletions(-) create mode 100644 tests/postman/test-list_deployment_ids.js create mode 100644 tests/postman/test-write_dwc.js diff --git a/tests/postman/test-get_tags.js b/tests/postman/test-get_tags.js index 2dfa8ed..85e21d6 100644 --- a/tests/postman/test-get_tags.js +++ b/tests/postman/test-get_tags.js @@ -2,6 +2,6 @@ pm.test("Status code is 201", function () { pm.response.to.have.status(201); }); -pm.test("Response time is less than 6s", function () { - pm.expect(pm.response.responseTime).to.be.below(6000); +pm.test("Response time is less than 7.5s", function () { + pm.expect(pm.response.responseTime).to.be.below(7500); }); diff --git a/tests/postman/test-list_animal_project_codes.js b/tests/postman/test-list_animal_project_codes.js index 1d463e5..f0feb85 100644 --- a/tests/postman/test-list_animal_project_codes.js +++ b/tests/postman/test-list_animal_project_codes.js @@ -7,10 +7,10 @@ pm.test("returns the right animal project codes", () => { //array is not empty pm.expect(jsonData).to.not.be.empty; //ids include number of known values - pm.expect(jsonData).to.include.members(["GIBRALTRACK_pilot","FISHINTEL","LamYorOus18-20","SMUCC","2016_Diaccia_Botrona","2015_fint","2013_albertkanaal","Rijke_Noordzee","mepnsw","VMLSOCBS","ASMOP2","Top-Predator","2014_Nene","Noordzeekanaal","2015_phd_verhelst_eel","CESB","Fish_Mig_Wad_Sea","2015_phd_verhelst_cod","MIGRATOEBRE","RNP","SARTELZINGARO","VVV","SVNL-WS","MBA_Massmo","Skye","FISHOWF","RAS","MICHIMIT","V2LNR","PTN/PROTECT2012/whiteseabream","PLASTIBE","2015_Albertkanaal_VPS_Ham","SU.MO.ELASMO.Adriatic","2021_Gudena","BFTDK","OP-Test","amsterdam","BTN-DeepWater-IMEDEA","KBTN_FISH","2012_leopoldkanaal","SEMP","BlueCrab2022Algarve","Eel-source-to-sea","SwanseaSeaTroutAdult","kornwerderzand","2015_dijle","codnoise","CONNECT-MED","FISHGAL","2013_Foyle"]); + pm.expect(jsonData).to.include.members(["GIBRALTRACK_pilot","FISHINTEL","LamYorOus18-20","SMUCC","2016_Diaccia_Botrona","2015_fint","2013_albertkanaal","Rijke_Noordzee","mepnsw","VMLSOCBS","ASMOP2","2014_Nene","Noordzeekanaal","2015_phd_verhelst_eel","CESB","Fish_Mig_Wad_Sea","2015_phd_verhelst_cod","MIGRATOEBRE","RNP","SARTELZINGARO","VVV","SVNL-WS","MBA_Massmo","Skye","FISHOWF","RAS","MICHIMIT","V2LNR","PTN/PROTECT2012/whiteseabream","PLASTIBE","2015_Albertkanaal_VPS_Ham","SU.MO.ELASMO.Adriatic","2021_Gudena","BFTDK","OP-Test","amsterdam","BTN-DeepWater-IMEDEA","KBTN_FISH","2012_leopoldkanaal","SEMP","BlueCrab2022Algarve","Eel-source-to-sea","SwanseaSeaTroutAdult","kornwerderzand","2015_dijle","codnoise","CONNECT-MED","FISHGAL","2013_Foyle"]); }); -pm.test("Response time is less than 3s", function () { - pm.expect(pm.response.responseTime).to.be.below(3000); +pm.test("Response time is less than 5s", function () { + pm.expect(pm.response.responseTime).to.be.below(5000); }); diff --git a/tests/postman/test-list_deployment_ids.js b/tests/postman/test-list_deployment_ids.js new file mode 100644 index 0000000..5c81024 --- /dev/null +++ b/tests/postman/test-list_deployment_ids.js @@ -0,0 +1,15 @@ +pm.test("Status code is 201", function () { + pm.response.to.have.status(201); + }); + +pm.test("Response time is less than 3s", function () { + pm.expect(pm.response.responseTime).to.be.below(3000); + }); + +const jsonData = pm.response.json(); +pm.test("returns the right deployment ids", () => { + //array is not empty + pm.expect(jsonData).to.not.be.empty; + //ids include number of known values + pm.expect(jsonData).to.include.members(["35375", "33373", "14999", "38605", "15228", "59021", "48695", "39014", "48628", "1489", "39591", "29737", "1553", "49270", "39151"]); + }); diff --git a/tests/postman/test-list_station_names.js b/tests/postman/test-list_station_names.js index 5380c27..5245cdb 100644 --- a/tests/postman/test-list_station_names.js +++ b/tests/postman/test-list_station_names.js @@ -7,7 +7,7 @@ pm.test("returns the right station names", () => { //array is not empty pm.expect(jsonData).to.not.be.empty; //ids include number of known values - pm.expect(jsonData).to.include.members(["GARD5","ABDN Bay-4","PLANIER_EST","IMFSTP019","R1-0m-Sonotronics","101 CORVO","F36","84-PONTA-CEDROS-FUNDO","bpns-HD17","C2","OM 3","LOM28","D1.11","SN_E12_C","I27","2021-O53","O32","Vossemeer","PTN_#78","LOM 37","IMFSTP035","CoastNet_PTN_Tejo_071","Pedra do Leao","NB028","ngOudm","gn-14","VB14","F22","SB45","Ler15","IM11","HVALPSUND5","FSUS","APPA E","L5","PREVOST_MER","Sound6","FRASERBURGH12","r02","s-12","Nene25","76 127 w ","gm_2017_13","Rt2","SB14","113582","R 15","NB014","MR 23","G4"]); + pm.expect(jsonData).to.include.members(["GARD5","ABDN Bay-4","PLANIER_EST","IMFSTP019","101 CORVO","F36","84-PONTA-CEDROS-FUNDO","bpns-HD17","C2","OM 3","LOM28","D1.11","SN_E12_C","I27","2021-O53","O32","Vossemeer","PTN_#78","LOM 37","IMFSTP035","CoastNet_PTN_Tejo_071","Pedra do Leao","NB028","ngOudm","gn-14","VB14","F22","SB45","Ler15","IM11","HVALPSUND5","FSUS","APPA E","L5","PREVOST_MER","Sound6","FRASERBURGH12","r02","s-12","Nene25","76 127 w ","gm_2017_13","Rt2","SB14","R 15","NB014","MR 23","G4"]); }); pm.test("Response time is less than 3s", function () { diff --git a/tests/postman/test-write_dwc.js b/tests/postman/test-write_dwc.js new file mode 100644 index 0000000..9ad497c --- /dev/null +++ b/tests/postman/test-write_dwc.js @@ -0,0 +1,15 @@ +pm.test("Status code is 201", function () { + pm.response.to.have.status(201); + }); + +pm.test("Response time is less than 30s", function () { + pm.expect(pm.response.responseTime).to.be.below(30000); + }); + +pm.test("Response body contains the expected fields for the created record", function () { + const responseData = pm.response.json(); + + pm.expect(responseData).to.be.an('object'); + pm.expect(responseData).to.have.property('dwc_occurrence'); +}); + From d924f1f6cc9113269f51500d3f62bfbdfdfa9f26 Mon Sep 17 00:00:00 2001 From: PietrH Date: Thu, 12 Sep 2024 11:05:32 +0200 Subject: [PATCH 157/183] devtools::document() --- man/write_dwc.Rd | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/man/write_dwc.Rd b/man/write_dwc.Rd index 8596db4..4477d64 100644 --- a/man/write_dwc.Rd +++ b/man/write_dwc.Rd @@ -27,12 +27,12 @@ published. }} } \value{ -list of data frames +list of dataframes } \description{ Transforms and downloads data from a European Tracking Network \strong{animal project} to \href{https://dwc.tdwg.org/}{Darwin Core}. -The resulting CSV file(s) can be uploaded to an \href{https://www.gbif.org/ipt}{IPT} for publication to OBIS and/or GBIF. +The resulting dataframe can be saved as a CSV and be uploaded to an \href{https://www.gbif.org/ipt}{IPT} for publication to OBIS and/or GBIF. A \code{meta.xml} or \code{eml.xml} file are not created. } \section{Transformation details}{ From b013e6e709ddfa64a19781c7ba77a2f0f741067d Mon Sep 17 00:00:00 2001 From: Pieter Huybrechts <48065851+PietrH@users.noreply.github.com> Date: Fri, 13 Sep 2024 14:04:44 +0200 Subject: [PATCH 158/183] Clarify what is returned --- R/write_dwc.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/write_dwc.R b/R/write_dwc.R index 201c9b8..a8c8208 100644 --- a/R/write_dwc.R +++ b/R/write_dwc.R @@ -100,7 +100,7 @@ write_dwc <- function(credentials = list( # Close connection DBI::dbDisconnect(connection) - # Return object or write files + # Return list of dataframes return( list(dwc_occurrence = dplyr::as_tibble(dwc_occurrence)) ) From 3b64a1e32666704fb13360154b9a6b2c4d8643bd Mon Sep 17 00:00:00 2001 From: PietrH Date: Wed, 2 Oct 2024 10:58:05 +0200 Subject: [PATCH 159/183] save script for testing for postman api test mismatches --- .../find-postman-test-mismatch.R | 92 +++++++++++++++++++ 1 file changed, 92 insertions(+) create mode 100644 inst/postman-helpers/find-postman-test-mismatch.R diff --git a/inst/postman-helpers/find-postman-test-mismatch.R b/inst/postman-helpers/find-postman-test-mismatch.R new file mode 100644 index 0000000..021bea0 --- /dev/null +++ b/inst/postman-helpers/find-postman-test-mismatch.R @@ -0,0 +1,92 @@ +# check mismatch between js test and api response for list_acoustic_project_codes + + +# load libraries ---------------------------------------------------------- + +library(httr2) + + + +# set function to test ---------------------------------------------------- + +fn_to_test <- "list_station_names" + +# get reponse ------------------------------------------------------------- + + +## build request ---------------------------------------------------------- + +equest <- + request( + glue::glue( + "https://opencpu.lifewatch.be/library/etnservice/R/{fn_to_test}/json" + ) + ) + +response <- + request %>% + req_headers( + "Content-Type" = "application/json", + "Cookie" = "vliz_webc=vliz_webc2" + ) %>% + req_body_json(list( + credentials = list( + username = "pieter.huybrechts@inbo.be", + password = askpass::askpass("Please provide ETN db pwd") + ) + )) %>% + req_method("POST") %>% + req_perform() + +request <- request %>% + req_headers( + "Content-Type" = "application/json", + "Cookie" = "vliz_webc=vliz_webc2" + ) %>% + req_body_json(list( + credentials = list( + username = "pieter.huybrechts@inbo.be", + password = askpass::askpass("Please provide ETN db pwd") + ) + )) %>% + req_method("POST") + +# check against expectation ----------------------------------------------- + +# Make sure we didn't get a HTTP error +assertthat::assert_that(!httr2::resp_is_error(response)) + + +## extract current expectation -------------------------------------------- +expectation <- readr::read_lines( + glue::glue("tests/postman/test-{fn_to_test}.js") +) %>% + grep("pm.expect(jsonData).to.include.members(", + ., + fixed = TRUE, + value = TRUE) %>% + stringr::str_extract_all('(?<=")[^,]*?(?=\\")') %>% + unlist() + + +## extract response -------------------------------------------------------- + +api_response_values <- httr2::resp_body_json(response) %>% unlist() + +# report mismatch --------------------------------------------------------- + +# missing expected project codes: +api_response_values[ + !expectation %in% api_response_values] + +# Values from expectation that are not in the values the api responded +expectation[!expectation %in% api_response_values] + +# check if the response is always the same -------------------------------- +library(furrr) +plan("multisession", workers = 10) +furrr::future_map(rep(list(request), 100), ~resp_body_json(req_perform(.x))) %>% + purrr::map(digest::digest) %>% + unlist %>% + unique %>% + length(.) == 1 From ec75cabee5c9f0b8d02d63c347665469017c3c0f Mon Sep 17 00:00:00 2001 From: PietrH Date: Wed, 2 Oct 2024 11:03:18 +0200 Subject: [PATCH 160/183] copy sql files from etn f1125f0 --- inst/sql/acoustic_tag_id.sql | 18 +++++++++++ inst/sql/project.sql | 24 ++++++++++++++ inst/sql/receiver.sql | 13 ++++++++ inst/sql/tag.sql | 62 ++++++++++++++++++++++++++++++++++++ 4 files changed, 117 insertions(+) create mode 100644 inst/sql/acoustic_tag_id.sql create mode 100644 inst/sql/project.sql create mode 100644 inst/sql/receiver.sql create mode 100644 inst/sql/tag.sql diff --git a/inst/sql/acoustic_tag_id.sql b/inst/sql/acoustic_tag_id.sql new file mode 100644 index 0000000..5cb0346 --- /dev/null +++ b/inst/sql/acoustic_tag_id.sql @@ -0,0 +1,18 @@ +/* Unified acoustic_tag_id and acoustic_tag_id_alternative */ + SELECT + tag_device_fk, + tag_full_id AS acoustic_tag_id + FROM acoustic.tags + WHERE tag_full_id IS NOT NULL +UNION + SELECT + tag_device_fk, + thelma_converted_code AS acoustic_tag_id + FROM acoustic.tags + WHERE thelma_converted_code IS NOT NULL +UNION + SELECT + device_tag_fk AS tag_device_fk, + sensor_full_id AS acoustic_tag_id + FROM archive.sensor + WHERE sensor_full_id IS NOT NULL diff --git a/inst/sql/project.sql b/inst/sql/project.sql new file mode 100644 index 0000000..05846a8 --- /dev/null +++ b/inst/sql/project.sql @@ -0,0 +1,24 @@ +/* Projects with controlled type */ +SELECT + project.id AS project_id, + project.projectcode AS project_code, + CASE + WHEN project.type = 'animal' THEN 'animal' + WHEN project.type = 'network' AND project.context_type = 'acoustic_telemetry' THEN 'acoustic' + WHEN project.type = 'network' AND project.context_type = 'cpod' THEN 'cpod' + END AS project_type, + project.telemtry_type AS telemetry_type, + project.name AS project_name, + -- ADD coordinating_organization + -- ADD principal_investigator + -- ADD principal_investigator_email + project.startdate AS start_date, + project.enddate AS end_date, + project.latitude AS latitude, + project.longitude AS longitude, + project.moratorium AS moratorium, + project.imis_dataset_id AS imis_dataset_id + -- project.mrgid + -- project.mda_folder_id +FROM + common.projects AS project diff --git a/inst/sql/receiver.sql b/inst/sql/receiver.sql new file mode 100644 index 0000000..51a8209 --- /dev/null +++ b/inst/sql/receiver.sql @@ -0,0 +1,13 @@ +/* Receivers with controlled status */ +SELECT + *, + CASE + WHEN status = 'Active' THEN 'active' + WHEN status = 'Available' OR status = 'available' THEN 'available' + WHEN status = 'Broken' THEN 'broken' + WHEN status = 'Inactive' THEN 'inactive' + WHEN status = 'Lost' THEN 'lost' + WHEN status = 'Returned to manufacturer' THEN 'returned' + END AS controlled_status +FROM + acoustic.receivers_limited diff --git a/inst/sql/tag.sql b/inst/sql/tag.sql new file mode 100644 index 0000000..7a5fc3f --- /dev/null +++ b/inst/sql/tag.sql @@ -0,0 +1,62 @@ +/* Unified tags with controlled tag_type, tag_subtype */ +SELECT + tag_device.serial_number AS tag_serial_number, + CASE + WHEN tag_type.name = 'id-tag' THEN 'acoustic' + WHEN tag_type.name = 'sensor-tag' AND acoustic_tag_id IS NOT NULL THEN 'acoustic-archival' + WHEN tag_type.name = 'sensor-tag' THEN 'archival' + END AS tag_type, + CASE + WHEN tag_subtype.name = 'animal' THEN 'animal' + WHEN tag_subtype.name = 'built-in tag' THEN 'built-in' + WHEN tag_subtype.name = 'range tag' THEN 'range' + WHEN tag_subtype.name = 'sentinel tag' THEN 'sentinel' + END AS tag_subtype, + tag_union.* +FROM + common.tag_device_limited AS tag_device + LEFT JOIN common.tag_device_type AS tag_type + ON tag_device.tag_device_type_fk = tag_type.id_pk + LEFT JOIN acoustic.acoustic_tag_subtype AS tag_subtype + ON tag_device.acoustic_tag_subtype_fk = tag_subtype.id_pk + LEFT JOIN ( + SELECT + 'acoustic:' || acoustic_tag.id_pk AS tag_id, + tag_device_fk, + sensor_type, + tag_full_id AS acoustic_tag_id, + thelma_converted_code, + frequency, + NULL AS resolution, NULL AS unit, NULL AS accurency, NULL AS range_min, NULL AS range_max, + slope, intercept, range, sensor_transmit_ratio, accelerometer_algoritm, accelerometer_samples_per_second, + min_delay, max_delay, power, duration_step1, acceleration_on_sec_step1, + min_delay_step2, max_delay_step2, power_step2, duration_step2, acceleration_on_sec_step2, + min_delay_step3, max_delay_step3, power_step3, duration_step3, acceleration_on_sec_step3, + min_delay_step4, max_delay_step4, power_step4, duration_step4, acceleration_on_sec_step4 + -- serial_number_tbd, type_tbd, model_tbd, owner_pi_tbd, activation_date_tbd, + -- end_date_tbd, estimated_lifetime_tbd, acoustic_tag_type_tbd, manufacturer_fk_tbd, + -- owner_group_fk_tbd, financing_project_fk_tbd, status_tbd + -- id_code, tag_code_space AS protocol, id_pk, file, units, external_id + FROM + acoustic.tags AS acoustic_tag + UNION + SELECT + 'archive:' || archival_tag.id_pk AS tag_id, + device_tag_fk AS tag_device_fk, + sensor_type.description AS sensor_type, + sensor_full_id AS acoustic_tag_id, + NULL AS thelma_converted_code, + frequency, + resolution, unit, accurency, range_min, range_max, + slope, intercept, range, sensor_transmit_ratio, accelerometer_algoritm, accelerometer_samples_per_second, + min_delay, max_delay, power, duration_step1, acceleration_on_sec_step1, + min_delay_step2, max_delay_step2, power_step2, duration_step2, acceleration_on_sec_step2, + min_delay_step3, max_delay_step3, power_step3, duration_step3, acceleration_on_sec_step3, + min_delay_step4, max_delay_step4, power_step4, duration_step4, acceleration_on_sec_step4 + -- id_pk, id_code protocol + FROM + archive.sensor AS archival_tag + LEFT JOIN archive.sensor_type AS sensor_type + ON archival_tag.sensor_type_fk = sensor_type.id_pk + ) AS tag_union + ON tag_device.id_pk = tag_union.tag_device_fk From 4fab76bc89cda92ce0f16bc1949960fa18443e25 Mon Sep 17 00:00:00 2001 From: PietrH Date: Wed, 2 Oct 2024 11:09:48 +0200 Subject: [PATCH 161/183] replace call to etn with call to self --- R/get_acoustic_detections.R | 2 +- R/get_acoustic_projects.R | 2 +- R/get_acoustic_receivers.R | 4 ++-- R/get_animal_projects.R | 2 +- R/get_animals.R | 2 +- R/get_cpod_projects.R | 2 +- R/get_tags.R | 2 +- R/list_acoustic_project_codes.R | 2 +- R/list_acoustic_tag_ids.R | 2 +- R/list_animal_project_codes.R | 2 +- R/list_cpod_project_codes.R | 2 +- 11 files changed, 12 insertions(+), 12 deletions(-) diff --git a/R/get_acoustic_detections.R b/R/get_acoustic_detections.R index f35f96d..8b85442 100644 --- a/R/get_acoustic_detections.R +++ b/R/get_acoustic_detections.R @@ -215,7 +215,7 @@ get_acoustic_detections <- function(credentials = list( } acoustic_tag_id_sql <- glue::glue_sql( - readr::read_file(system.file("sql", "acoustic_tag_id.sql", package = "etn")), + readr::read_file(system.file("sql", "acoustic_tag_id.sql", package = "etnservice")), .con = connection ) diff --git a/R/get_acoustic_projects.R b/R/get_acoustic_projects.R index 082f27e..2354708 100644 --- a/R/get_acoustic_projects.R +++ b/R/get_acoustic_projects.R @@ -53,7 +53,7 @@ get_acoustic_projects <- function(credentials = list( } project_sql <- glue::glue_sql( - readr::read_file(system.file("sql", "project.sql", package = "etn")), + readr::read_file(system.file("sql", "project.sql", package = "etnservice")), .con = connection ) diff --git a/R/get_acoustic_receivers.R b/R/get_acoustic_receivers.R index d6570ab..dfdca3d 100644 --- a/R/get_acoustic_receivers.R +++ b/R/get_acoustic_receivers.R @@ -66,11 +66,11 @@ get_acoustic_receivers <- function(credentials = list( } receiver_sql <- glue::glue_sql( - readr::read_file(system.file("sql", "receiver.sql", package = "etn")), + readr::read_file(system.file("sql", "receiver.sql", package = "etnservice")), .con = connection ) acoustic_tag_id_sql <- glue::glue_sql( - readr::read_file(system.file("sql", "acoustic_tag_id.sql", package = "etn")), + readr::read_file(system.file("sql", "acoustic_tag_id.sql", package = "etnservice")), .con = connection ) diff --git a/R/get_animal_projects.R b/R/get_animal_projects.R index c552644..17c0c60 100644 --- a/R/get_animal_projects.R +++ b/R/get_animal_projects.R @@ -52,7 +52,7 @@ get_animal_projects <- function(credentials = list( } project_sql <- glue::glue_sql( - readr::read_file(system.file("sql", "project.sql", package = "etn")), + readr::read_file(system.file("sql", "project.sql", package = "etnservice")), .con = connection ) diff --git a/R/get_animals.R b/R/get_animals.R index 4317be2..ec2518b 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -121,7 +121,7 @@ get_animals <- function(credentials = list( } tag_sql <- glue::glue_sql( - readr::read_file(system.file("sql", "tag.sql", package = "etn")), + readr::read_file(system.file("sql", "tag.sql", package = "etnservice")), .con = connection ) diff --git a/R/get_cpod_projects.R b/R/get_cpod_projects.R index 459b17c..5bb6cd4 100644 --- a/R/get_cpod_projects.R +++ b/R/get_cpod_projects.R @@ -52,7 +52,7 @@ get_cpod_projects <- function(credentials = list( } project_sql <- glue::glue_sql( - readr::read_file(system.file("sql", "project.sql", package = "etn")), + readr::read_file(system.file("sql", "project.sql", package = "etnservice")), .con = connection ) diff --git a/R/get_tags.R b/R/get_tags.R index a370801..5d8466d 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -116,7 +116,7 @@ get_tags <- function(credentials = list( } tag_sql <- glue::glue_sql( - readr::read_file(system.file("sql", "tag.sql", package = "etn")), + readr::read_file(system.file("sql", "tag.sql", package = "etnservice")), .con = connection ) diff --git a/R/list_acoustic_project_codes.R b/R/list_acoustic_project_codes.R index 0289c76..cc6d181 100644 --- a/R/list_acoustic_project_codes.R +++ b/R/list_acoustic_project_codes.R @@ -13,7 +13,7 @@ list_acoustic_project_codes <- function(credentials = list( connection <- connect_to_etn(credentials$username, credentials$password) project_sql <- glue::glue_sql( - readr::read_file(system.file("sql", "project.sql", package = "etn")), + readr::read_file(system.file("sql", "project.sql", package = "etnservice")), .con = connection ) query <- glue::glue_sql( diff --git a/R/list_acoustic_tag_ids.R b/R/list_acoustic_tag_ids.R index a98e4f0..ab4d4bd 100644 --- a/R/list_acoustic_tag_ids.R +++ b/R/list_acoustic_tag_ids.R @@ -11,7 +11,7 @@ list_acoustic_tag_ids <- function(credentials = list( )) { connection <- connect_to_etn(credentials$username, credentials$password) acoustic_tag_id_sql <- glue::glue_sql( - readr::read_file(system.file("sql", "acoustic_tag_id.sql", package = "etn")), + readr::read_file(system.file("sql", "acoustic_tag_id.sql", package = "etnservice")), .con = connection ) query <- glue::glue_sql(" diff --git a/R/list_animal_project_codes.R b/R/list_animal_project_codes.R index ce58c15..e8328ad 100644 --- a/R/list_animal_project_codes.R +++ b/R/list_animal_project_codes.R @@ -13,7 +13,7 @@ list_animal_project_codes <- function(credentials = list( connection <- connect_to_etn(credentials$username, credentials$password) project_sql <- glue::glue_sql( - readr::read_file(system.file("sql", "project.sql", package = "etn")), + readr::read_file(system.file("sql", "project.sql", package = "etnservice")), .con = connection ) query <- glue::glue_sql( diff --git a/R/list_cpod_project_codes.R b/R/list_cpod_project_codes.R index b7085e0..7d20681 100644 --- a/R/list_cpod_project_codes.R +++ b/R/list_cpod_project_codes.R @@ -18,7 +18,7 @@ list_cpod_project_codes <- function(credentials = list( check_connection(connection) project_query <- glue::glue_sql( - readr::read_file(system.file("sql", "project.sql", package = "etn")), + readr::read_file(system.file("sql", "project.sql", package = "etnservice")), .con = connection ) query <- glue::glue_sql( From 59ff0ae1183154b36f2be0be6322d3257f0668bf Mon Sep 17 00:00:00 2001 From: PietrH Date: Wed, 2 Oct 2024 13:31:52 +0200 Subject: [PATCH 162/183] Remove test for unported function: only used in vignette in etn --- tests/testthat/test-list_values.R | 71 ------------------------------- 1 file changed, 71 deletions(-) delete mode 100644 tests/testthat/test-list_values.R diff --git a/tests/testthat/test-list_values.R b/tests/testthat/test-list_values.R deleted file mode 100644 index 637dd2c..0000000 --- a/tests/testthat/test-list_values.R +++ /dev/null @@ -1,71 +0,0 @@ -df <- data.frame( - chr_col = c("A", "B,C", "C,A", "D"), - num_col = c(1, 2, 2, 3), - dot_sep_col = c("A", "B.C", "C.A", "D"), - stringsAsFactors = FALSE -) - -test_that("list_values() returns error for incorrect input", { - # .data must be a data.frame - expect_error(list_values(1, "num_col"), ".data is not a data.frame") - - # column must be a character, a column name or a column position - expect_error( - list_values(df, TRUE), "column TRUE not found in .data" - ) - # column must be the name of a valid column of .data - expect_error( - list_values(df, strange_col), "column strange_col not found in .data" - ) - # column must be the character version of the name of a valid column of .data - expect_error( - list_values(df, "strange_col"), "column strange_col not found in .data" - ) - # Not more than one column allowed - expect_error( - list_values(df, c(chr_col, dot_col)), "invalid column value" - ) - # column must be an integer (decimal part = 0) - expect_error( - list_values(df, .1), "column number must be an integer" - ) - # column must be an integer higher than 0 - expect_error( - list_values(df, -2), "invalid column value" - ) - # column must be an integer equal or less than number of columns - expect_error( - list_values(df, 5), - "column number exceeds the number of columns of .data (3)", - fixed = TRUE - ) - - # split must be a character - expect_error( - list_values(df, chr_col, split = 1), - "split is not a character vector" - ) -}) - -test_that("list_values() returns a vector with unique values", { - # Output has right class - expect_is(list_values(df, chr_col), class = "character") - expect_is(list_values(df, num_col), class = "numeric") - - # Output value is correct with default split value (comma) - expect_equal(list_values(df, chr_col), c("A", "B", "C", "D")) - - # Output value is correct with non default split value - expect_equal(list_values(df, dot_sep_col, "\\."), c("A", "B", "C", "D")) - - # Output value doesn't depend on the way column is passed - expect_equal(list_values(df, column = chr_col), list_values(df, "chr_col")) - expect_equal(list_values(df, column = chr_col), list_values(df, 1)) - expect_equal(list_values(df, "num_col"), c(1, 2, 3)) - - # If the split value is not present in column, return a copy of the column - expect_equal( - list_values(df, "dot_sep_col", split = ","), - df$dot_sep_col - ) -}) From bff56587449b22fcdd5a5c4b231e52f2d211fcdb Mon Sep 17 00:00:00 2001 From: PietrH Date: Wed, 2 Oct 2024 14:50:26 +0200 Subject: [PATCH 163/183] add helper to check if credentials are of right form --- R/utils.R | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) diff --git a/R/utils.R b/R/utils.R index 5e723f6..7ecd887 100644 --- a/R/utils.R +++ b/R/utils.R @@ -110,6 +110,44 @@ get_credentials <- stringr::str_glue('list(username = "{username}", password = "{password}")') } +#' Check if the provided credentials are valid. +#' +#' This function checks if the provided credentials contain a "username" and "password" field, +#' and if both fields are of type character. It also verifies that the credentials object has a length of 2. +#' +#' @param credentials A list or data frame containing the credentials to be checked. +#' +#' @return TRUE if the credentials are valid, an error otherwise +#' +#' @examples +#' credentials <- list(username = "john_doe", password = "password123") +#' check_credentials(credentials) +#' #> [1] TRUE +check_credentials <- function(credentials) { + + assertthat::assert_that( + assertthat::has_name(credentials, "username") + ) + + assertthat::assert_that( + assertthat::has_name(credentials, "password") + ) + + assertthat::assert_that( + length(credentials) == 2 + ) + + assertthat::assert_that( + assertthat::is.string(credentials$username) + ) + + assertthat::assert_that( + assertthat::is.string(credentials$password) + ) + + return(TRUE) +} + #' Extract the OCPU temp key from a response object #' #' When posting a request to the opencpu api service without the json flag, a From 264eb3edaf9c6f2f4ce8147b1a9ec1bad28f5dcb Mon Sep 17 00:00:00 2001 From: PietrH Date: Wed, 2 Oct 2024 14:51:37 +0200 Subject: [PATCH 164/183] Improve error messaging --- R/utils.R | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/R/utils.R b/R/utils.R index 7ecd887..426206a 100644 --- a/R/utils.R +++ b/R/utils.R @@ -126,15 +126,18 @@ get_credentials <- check_credentials <- function(credentials) { assertthat::assert_that( - assertthat::has_name(credentials, "username") + assertthat::has_name(credentials, "username"), + msg = "The credentials need to contain a 'username' field." ) assertthat::assert_that( - assertthat::has_name(credentials, "password") + assertthat::has_name(credentials, "password"), + msg = "The credentials need to contain a 'password' field." ) assertthat::assert_that( - length(credentials) == 2 + length(credentials) == 2, + msg = "The credentials object should have a length of 2." ) assertthat::assert_that( From a1ff9276ebc7c08f711bceb520a2d236fb049263 Mon Sep 17 00:00:00 2001 From: PietrH Date: Fri, 4 Oct 2024 10:50:10 +0200 Subject: [PATCH 165/183] Check if the credentials at least have the right shape --- R/get_tags.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/R/get_tags.R b/R/get_tags.R index 5d8466d..53e5193 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -49,6 +49,9 @@ get_tags <- function(credentials = list( tag_serial_number = NULL, acoustic_tag_id = NULL) { + # Check credentials + check_credentials(credentials) + # Create connection object connection <- connect_to_etn(credentials$username, credentials$password) From 30301e249721f53f9f5237f5035345e2c594b46a Mon Sep 17 00:00:00 2001 From: PietrH Date: Fri, 4 Oct 2024 10:50:32 +0200 Subject: [PATCH 166/183] Provide a more informative error message when creating the database connection fails --- R/connect_to_etn.R | 29 +++++++++++++++++++++++------ tests/testthat/test-get_tags.R | 3 ++- 2 files changed, 25 insertions(+), 7 deletions(-) diff --git a/R/connect_to_etn.R b/R/connect_to_etn.R index f3a955f..3cdfe91 100644 --- a/R/connect_to_etn.R +++ b/R/connect_to_etn.R @@ -19,11 +19,28 @@ #' con <- connect_to_etn(username = "my_username", password = "my_password") #' } connect_to_etn <- function(username, password) { - connection <- DBI::dbConnect( - odbc::odbc(), - "ETN", - uid = paste("", tolower(username), "", sep = ""), - pwd = paste("", password, "", sep = "") + tryCatch( + { + # Attempt to connect to the database with the provided credentials + connection <- DBI::dbConnect( + odbc::odbc(), + "ETN", + uid = paste("", tolower(username), "", sep = ""), + pwd = paste("", password, "", sep = "") + ) + return(connection) + }, + error = function(e) { + # When the database connection fails, return the error message and some + # directions to try again. This is usually due to a wrong password, so + # let's include that as a clue in the error message. + stop(glue::glue(e$message, + "Failed to connect to the database.", + "Did you enter the right username/password?", + "Please try again.", + .sep = "\n"), + call. = FALSE) + + } ) - return(connection) } diff --git a/tests/testthat/test-get_tags.R b/tests/testthat/test-get_tags.R index 19aeb22..ec24298 100644 --- a/tests/testthat/test-get_tags.R +++ b/tests/testthat/test-get_tags.R @@ -5,7 +5,8 @@ credentials <- list( test_that("get_tags() returns error for incorrect connection", { expect_error( - get_tags(credentials = "not_a_connection"), + get_tags(credentials = list(username = "not a username", + password = "not a password")), "Not a connection object to database." ) }) From c9eaf12531e8fbcafee9c9c46f7fcd42f2bc4bf5 Mon Sep 17 00:00:00 2001 From: PietrH Date: Fri, 4 Oct 2024 11:11:52 +0200 Subject: [PATCH 167/183] use skip() instead of comments to disable tests: more explicit, harder to miss --- tests/testthat/test-get_acoustic_detections.R | 30 ++++++++++--------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/tests/testthat/test-get_acoustic_detections.R b/tests/testthat/test-get_acoustic_detections.R index ab1b37a..01d53e2 100644 --- a/tests/testthat/test-get_acoustic_detections.R +++ b/tests/testthat/test-get_acoustic_detections.R @@ -281,19 +281,20 @@ test_that("get_acoustic_detections() returns acoustic and acoustic-archival tags }) # TODO: re-enable after https://github.com/inbo/etn/issues/252 -# test_that("get_acoustic_detections() returns detections from acoustic_tag_id_alternative", { -# # The following acoustic_tag_ids only occur as acoustic_tag_id_alternative -# -# # A69-1105-26 (tag_serial_number = 1734026) is associated with animal -# # - 5902 (2017_Fremur) from 2017-12-01 00:00 to open -# # Almost all its detections are from after the release date -# expect_gt(nrow(get_acoustic_detections(credentials, acoustic_tag_id = "A69-1105-26")), 0) -# -# # A69-1105-155 (tag_serial_number = 1712155) is associated with animal -# # - 4140 (OTN-Skjerstadfjorden) from 2017-05-31 01:00 to open -# # All detections are from before the release date, so it should return 0 -# expect_equal(nrow(get_acoustic_detections(credentials, acoustic_tag_id = "A69-1105-155")), 0) -# }) +test_that("get_acoustic_detections() returns detections from acoustic_tag_id_alternative", { + skip("TODO: re-enable after https://github.com/inbo/etn/issues/252") + # The following acoustic_tag_ids only occur as acoustic_tag_id_alternative + + # A69-1105-26 (tag_serial_number = 1734026) is associated with animal + # - 5902 (2017_Fremur) from 2017-12-01 00:00 to open + # Almost all its detections are from after the release date + expect_gt(nrow(get_acoustic_detections(credentials, acoustic_tag_id = "A69-1105-26")), 0) + + # A69-1105-155 (tag_serial_number = 1712155) is associated with animal + # - 4140 (OTN-Skjerstadfjorden) from 2017-05-31 01:00 to open + # All detections are from before the release date, so it should return 0 + expect_equal(nrow(get_acoustic_detections(credentials, acoustic_tag_id = "A69-1105-155")), 0) +}) test_that("get_acoustic_detections() does not return duplicate detections across acoustic_id and acoustic_id_alternative", { # A69-1105-100 is used as acoustic_tag_id once and acoustic_tag_id_alternative twice: @@ -304,7 +305,8 @@ test_that("get_acoustic_detections() does not return duplicate detections across # Expect no duplicates df <- get_acoustic_detections(credentials, acoustic_tag_id = "A69-1105-100") - # expect_equal(nrow(df), nrow(df %>% distinct(detection_id))) # TODO: https://github.com/inbo/etn/issues/216 + skip("TODO: https://github.com/inbo/etn/issues/216") + expect_equal(nrow(df), nrow(df %>% distinct(detection_id))) # TODO: https://github.com/inbo/etn/issues/216 }) test_that("get_acoustic_detections() does not return duplicate detections when tags are reused", { From f2fb3e53aac1de9813d6196d761315ab61c2c0ec Mon Sep 17 00:00:00 2001 From: PietrH Date: Fri, 4 Oct 2024 11:12:23 +0200 Subject: [PATCH 168/183] Check if the credentials have the right shape before trying to connect to the database --- R/get_acoustic_deployments.R | 3 +++ R/get_acoustic_projects.R | 4 ++++ R/get_animal_projects.R | 4 ++++ R/get_animals.R | 4 ++++ R/list_cpod_project_codes.R | 3 +++ 5 files changed, 18 insertions(+) diff --git a/R/get_acoustic_deployments.R b/R/get_acoustic_deployments.R index 6e07dea..cd9e049 100644 --- a/R/get_acoustic_deployments.R +++ b/R/get_acoustic_deployments.R @@ -52,6 +52,9 @@ get_acoustic_deployments <- function( station_name = NULL, open_only = FALSE) { + # Check if credentials object has right shape + check_credentials(credentials) + # create connection object connection <- connect_to_etn(credentials$username, credentials$password) diff --git a/R/get_acoustic_projects.R b/R/get_acoustic_projects.R index 2354708..8bb5e92 100644 --- a/R/get_acoustic_projects.R +++ b/R/get_acoustic_projects.R @@ -29,6 +29,10 @@ get_acoustic_projects <- function(credentials = list( password = Sys.getenv("pwd") ), acoustic_project_code = NULL) { + + # Check if credentials object has right shape + check_credentials(credentials) + # create connection object connection <- connect_to_etn(credentials$username, credentials$password) diff --git a/R/get_animal_projects.R b/R/get_animal_projects.R index 17c0c60..96571b2 100644 --- a/R/get_animal_projects.R +++ b/R/get_animal_projects.R @@ -29,6 +29,10 @@ get_animal_projects <- function(credentials = list( password = Sys.getenv("pwd") ), animal_project_code = NULL) { + + # Check if credentials object has right shape + check_credentials(credentials) + # Create connection object connection <- connect_to_etn(credentials$username, credentials$password) diff --git a/R/get_animals.R b/R/get_animals.R index ec2518b..18ee4e3 100644 --- a/R/get_animals.R +++ b/R/get_animals.R @@ -52,6 +52,10 @@ get_animals <- function(credentials = list( tag_serial_number = NULL, animal_project_code = NULL, scientific_name = NULL) { + + # Check if credentials object has right shape + check_credentials(credentials) + # Create connection object connection <- connect_to_etn(credentials$username, credentials$password) diff --git a/R/list_cpod_project_codes.R b/R/list_cpod_project_codes.R index 7d20681..445267c 100644 --- a/R/list_cpod_project_codes.R +++ b/R/list_cpod_project_codes.R @@ -11,6 +11,9 @@ list_cpod_project_codes <- function(credentials = list( password = Sys.getenv("pwd") )) { + # Check if credentials object has right shape + check_credentials(credentials) + # Create connection object connection <- connect_to_etn(credentials$username, credentials$password) From db5ca3e4e43e5e4948b2a02cd7eb15c24bc25fe2 Mon Sep 17 00:00:00 2001 From: PietrH Date: Fri, 4 Oct 2024 11:38:48 +0200 Subject: [PATCH 169/183] Check the shape of the credentials, not their validity --- R/get_tags.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/get_tags.R b/R/get_tags.R index 53e5193..23886e4 100644 --- a/R/get_tags.R +++ b/R/get_tags.R @@ -49,7 +49,7 @@ get_tags <- function(credentials = list( tag_serial_number = NULL, acoustic_tag_id = NULL) { - # Check credentials + # Check if credentials object has right shape check_credentials(credentials) # Create connection object From c50f85cd286b09c0e6a726edbcd2923c471b9595 Mon Sep 17 00:00:00 2001 From: PietrH Date: Fri, 4 Oct 2024 11:39:07 +0200 Subject: [PATCH 170/183] Check if the credentials are provided in the right shape --- R/get_acoustic_detections.R | 2 ++ R/get_cpod_projects.R | 4 ++++ 2 files changed, 6 insertions(+) diff --git a/R/get_acoustic_detections.R b/R/get_acoustic_detections.R index 8b85442..4d978f6 100644 --- a/R/get_acoustic_detections.R +++ b/R/get_acoustic_detections.R @@ -90,6 +90,8 @@ get_acoustic_detections <- function(credentials = list( station_name = NULL, limit = FALSE) { + # Check if credentials object has right shape + check_credentials(credentials) # Create connection object connection <- connect_to_etn(credentials$username, credentials$password) diff --git a/R/get_cpod_projects.R b/R/get_cpod_projects.R index 5bb6cd4..ef31e30 100644 --- a/R/get_cpod_projects.R +++ b/R/get_cpod_projects.R @@ -29,6 +29,10 @@ get_cpod_projects <- function(credentials = list( password = Sys.getenv("pwd") ), cpod_project_code = NULL) { + + # Check if credentials object has right shape + check_credentials(credentials) + # Create connection object connection <- connect_to_etn(credentials$username, credentials$password) From 7233da0ca779ad5b19af6fa8fb80722941fe7f2a Mon Sep 17 00:00:00 2001 From: PietrH Date: Fri, 4 Oct 2024 11:39:35 +0200 Subject: [PATCH 171/183] Test error messages for failing to connect to the database --- .../testthat/test-get_acoustic_deployments.R | 8 +++++++- tests/testthat/test-get_acoustic_detections.R | 19 +++++++++++++++++-- tests/testthat/test-get_acoustic_projects.R | 7 ++++++- tests/testthat/test-get_acoustic_receivers.R | 7 ++++++- tests/testthat/test-get_animal_projects.R | 7 ++++++- tests/testthat/test-get_animals.R | 7 ++++++- tests/testthat/test-get_cpod_projects.R | 7 ++++++- tests/testthat/test-get_tags.R | 2 +- 8 files changed, 55 insertions(+), 9 deletions(-) diff --git a/tests/testthat/test-get_acoustic_deployments.R b/tests/testthat/test-get_acoustic_deployments.R index 81a7552..f181c10 100644 --- a/tests/testthat/test-get_acoustic_deployments.R +++ b/tests/testthat/test-get_acoustic_deployments.R @@ -6,7 +6,13 @@ credentials <- list( test_that("get_acoustic_deployments() returns error for incorrect connection", { expect_error( get_acoustic_deployments(credentials = "not_a_credentials"), - "Not a credentials object to database." + "The credentials need to contain a 'username' field", + fixed = TRUE + ) + expect_error( + get_acoustic_deployments(credentials = list(username = "not a username", + password = "the wrong password")), + "Failed to connect to the database." ) }) diff --git a/tests/testthat/test-get_acoustic_detections.R b/tests/testthat/test-get_acoustic_detections.R index 01d53e2..198f3fb 100644 --- a/tests/testthat/test-get_acoustic_detections.R +++ b/tests/testthat/test-get_acoustic_detections.R @@ -6,11 +6,26 @@ credentials <- list( test_that("get_acoustic_detections() returns error for incorrect connection", { expect_error( get_acoustic_detections(credentials = "not_a_connection"), - "Not a connection object to database." + "The credentials need to contain a 'username' field." + ) + expect_error( + get_acoustic_detections(credentials = list(username = "username")), + "The credentials need to contain a 'password' field." + ) + expect_error( + get_acoustic_detections(credentials = list(unexpected_field = 4, + username = "username", + password = "not a password")), + "The credentials object should have a length of 2." + ) + expect_error( + get_acoustic_detections(credentials = list(username = "not a username", + password = "the wrong pwd")), + "Failed to connect to the database." ) }) -test_that("get_acoustic_detections() returns a tibble", { + test_that("get_acoustic_detections() returns a tibble", { df <- get_acoustic_detections(credentials, limit = TRUE) expect_s3_class(df, "data.frame") expect_s3_class(df, "tbl") diff --git a/tests/testthat/test-get_acoustic_projects.R b/tests/testthat/test-get_acoustic_projects.R index b850c58..32a34e9 100644 --- a/tests/testthat/test-get_acoustic_projects.R +++ b/tests/testthat/test-get_acoustic_projects.R @@ -6,7 +6,12 @@ credentials <- list( test_that("get_acoustic_projects() returns error for incorrect connection", { expect_error( get_acoustic_projects(credentials = "not_a_credentials"), - "Not a connection object to database." + "The credentials need to contain a 'username' field." + ) + expect_error( + get_acoustic_projects(credentials = list(username = "not a username", + password = "the wrong pwd")), + "Failed to connect to the database." ) }) diff --git a/tests/testthat/test-get_acoustic_receivers.R b/tests/testthat/test-get_acoustic_receivers.R index 5c13f8b..847698b 100644 --- a/tests/testthat/test-get_acoustic_receivers.R +++ b/tests/testthat/test-get_acoustic_receivers.R @@ -6,7 +6,12 @@ credentials <- list( test_that("get_acoustic_receivers() returns error for incorrect credentials", { expect_error( get_acoustic_receivers(credentials = "not_a_credentials"), - "Not a connection object to database." + "Failed to connect to the database." + ) + expect_error( + get_acoustic_receivers(credentials = list(username = "not a username", + password = "the wrong pwd")), + "Failed to connect to the database." ) }) diff --git a/tests/testthat/test-get_animal_projects.R b/tests/testthat/test-get_animal_projects.R index 71f0dbf..2cffc64 100644 --- a/tests/testthat/test-get_animal_projects.R +++ b/tests/testthat/test-get_animal_projects.R @@ -6,7 +6,12 @@ credentials <- list( test_that("get_animal_projects() returns error for incorrect connection", { expect_error( get_animal_projects(credentials = "not_a_connection"), - "Not a connection object to database." + "The credentials need to contain a 'username' field." + ) + expect_error( + get_animal_projects(credentials = list(username = "not a username", + password = "the wrong pwd")), + "Failed to connect to the database." ) }) diff --git a/tests/testthat/test-get_animals.R b/tests/testthat/test-get_animals.R index 6ddab45..bc000e7 100644 --- a/tests/testthat/test-get_animals.R +++ b/tests/testthat/test-get_animals.R @@ -6,7 +6,12 @@ credentials <- list( test_that("get_animals() returns error for incorrect connection", { expect_error( get_animals(credentials = "not_a_connection"), - "Not a connection object to database." + "The credentials need to contain a 'username' field." + ) + expect_error( + get_animals(credentials = list(username = "not a username", + password = "the wrong pwd")), + "Failed to connect to the database." ) }) diff --git a/tests/testthat/test-get_cpod_projects.R b/tests/testthat/test-get_cpod_projects.R index 09f835f..a9e2d0b 100644 --- a/tests/testthat/test-get_cpod_projects.R +++ b/tests/testthat/test-get_cpod_projects.R @@ -6,7 +6,12 @@ credentials <- list( test_that("get_cpod_projects() returns error for incorrect connection", { expect_error( get_cpod_projects(credentials = "not_a_connection"), - "Not a connection object to database." + "The credentials need to contain a 'username' field." + ) + expect_error( + get_cpod_projects(credentials = list(username = "not a username", + password = "the wrong pwd")), + "Failed to connect to the database." ) }) diff --git a/tests/testthat/test-get_tags.R b/tests/testthat/test-get_tags.R index ec24298..1a1bced 100644 --- a/tests/testthat/test-get_tags.R +++ b/tests/testthat/test-get_tags.R @@ -7,7 +7,7 @@ test_that("get_tags() returns error for incorrect connection", { expect_error( get_tags(credentials = list(username = "not a username", password = "not a password")), - "Not a connection object to database." + "Failed to connect to the database." ) }) From 59f209a874f82b5c3512e4a86a75bcee2cc249a0 Mon Sep 17 00:00:00 2001 From: PietrH Date: Fri, 18 Oct 2024 10:44:02 +0200 Subject: [PATCH 172/183] update tests, some values got removed from etn --- tests/postman/test-list_acoustic_tag_ids.js | 2 +- tests/postman/test-list_receiver_ids.js | 2 +- tests/postman/test-list_station_names.js | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/postman/test-list_acoustic_tag_ids.js b/tests/postman/test-list_acoustic_tag_ids.js index cb83b06..6c9dd86 100644 --- a/tests/postman/test-list_acoustic_tag_ids.js +++ b/tests/postman/test-list_acoustic_tag_ids.js @@ -7,7 +7,7 @@ pm.test("returns the right acoustic tag ids", () => { //array is not empty pm.expect(jsonData).to.not.be.empty; //ids include number of known values - pm.expect(jsonData).to.include.members(["A69-1601-38746","R64K-0691","A69-1303-3966","A69-1602-20523","A69-9001-62964","A69-1602-24986","OPI-748","A69-1602-13430","A69-1105-72","A69-1602-35388","A69-9006-1852","A69-1601-2719","R64K-108","A180-1702-48915","OPI-494","A69-1602-20572","R64K-41143","A69-1303-12067","R64K-9396","A69-1602-13167","A69-1303-9363","A69-1602-37125","A69-1303-4120","A69-1008-210","A69-1303-9509","A69-1303-328","R64K-5037","A69-1303-6997","R64K-0701","R64K-0738","A69-1303-26461","A69-1602-13427","R64K-1094","A69-1602-25135","A69-1303-4095","A69-1602-3082","R64K-4167","A180-1702-51826","A69-1303-4194","A69-1303-0709","A69-1303-33684","A69-1303-4591","A69-1303-6478","A69-9007-2438","OPI-640","A69-1601-9609","A69-1303-12644","A69-1604-3342","A69-9006-4742","A69-1602-13493"]); + pm.expect(jsonData).to.include.members(["A69-1008-210","A69-1105-72","A69-1303-328","A69-1303-0709","A69-1303-3966","A69-1303-4095","A69-1303-4120","A69-1303-4194","A69-1303-4591","A69-1303-6478","A69-1303-6997","A69-1303-9363","A69-1303-9509","A69-1303-12067","A69-1303-12644","A69-1303-26461","A69-1303-33684","A69-1601-2719","A69-1601-9609","A69-1601-38746","A69-1602-3082","A69-1602-13167","A69-1602-13427","A69-1602-13430","A69-1602-13493","A69-1602-20523","A69-1602-20572","A69-1602-24986","A69-1602-25135","A69-9001-62964","A69-9006-1852","A69-9006-4742","A69-9007-2438","A180-1702-48915","A180-1702-51826","OPI-494","OPI-640","OPI-748","R64K-108","R64K-0691","R64K-0701","R64K-0738","R64K-1094","R64K-4167","R64K-5037","R64K-9396","R64K-41143"]); }); pm.test("Response time is less than 3s", function () { diff --git a/tests/postman/test-list_receiver_ids.js b/tests/postman/test-list_receiver_ids.js index a518585..2ebdccd 100644 --- a/tests/postman/test-list_receiver_ids.js +++ b/tests/postman/test-list_receiver_ids.js @@ -7,7 +7,7 @@ pm.test("returns the right receiver ids", () => { //array is not empty pm.expect(jsonData).to.not.be.empty; //ids include number of known values - pm.expect(jsonData).to.include.members(["TBR700-001198","VR2W-113584","VR2TX-481233","VR2W-134861","VR2W-122356","VR2TX-480264","VR2W-126317","VR2AR-547510","VR2W-125699","VR2W-134234","HR2-180K-100-LI-461548","VR2TX-481427","VR2TX-482997","TBR700-33","VR2TX-482289","VR2TX-482923","VR2W-120630","VR2W-135891","VR2TX-482914","TBR700R-1441","VR2TX-480410","VR2W-112220","VR2W-125463","VR2W-135353","WHS 3250D-MAP6001500101","VR2W-136585","VR2W-134016","VR2TX-486358","VR2W-127720","VR2-5528","VR2TX-482938","VR2-7333c","VR2-5531","VR2W-130679","VR2W-130998","VR2AR-547670","VR2W-127562","VR2W-112364","VR2W-120448","VR2W-135804","VR2W-137075","TBR700L-1360","VR2AR-551407","VR2TX-482979","VR2W-134532","VR2W-115447","VR2W-135649","VR2W-134524","VR2W-126196","VR2W-134359"]); + pm.expect(jsonData).to.include.members(["HR2-180K-100-LI-461548","TBR700-33","TBR700-001198","TBR700L-1360","TBR700R-1441","VR2-5528","VR2-5531","VR2-7333c","VR2AR-547670","VR2AR-551407","VR2TX-480264","VR2TX-480410","VR2TX-481233","VR2TX-481427","VR2TX-482289","VR2TX-482914","VR2TX-482923","VR2TX-482938","VR2TX-482979","VR2TX-482997","VR2TX-486358","VR2W-112220","VR2W-112364","VR2W-115447","VR2W-120448","VR2W-120630","VR2W-122356","VR2W-125463","VR2W-125699","VR2W-126196","VR2W-126317","VR2W-127562","VR2W-127720","VR2W-130679","VR2W-130998","VR2W-134016","VR2W-134234","VR2W-134359","VR2W-134524","VR2W-134532","VR2W-134861","VR2W-135353","VR2W-135649","VR2W-135804","VR2W-135891","VR2W-136585","VR2W-137075","WHS 3250D-MAP6001500101"]); }); pm.test("Response time is less than 3s", function () { diff --git a/tests/postman/test-list_station_names.js b/tests/postman/test-list_station_names.js index 5245cdb..de4f70d 100644 --- a/tests/postman/test-list_station_names.js +++ b/tests/postman/test-list_station_names.js @@ -7,7 +7,7 @@ pm.test("returns the right station names", () => { //array is not empty pm.expect(jsonData).to.not.be.empty; //ids include number of known values - pm.expect(jsonData).to.include.members(["GARD5","ABDN Bay-4","PLANIER_EST","IMFSTP019","101 CORVO","F36","84-PONTA-CEDROS-FUNDO","bpns-HD17","C2","OM 3","LOM28","D1.11","SN_E12_C","I27","2021-O53","O32","Vossemeer","PTN_#78","LOM 37","IMFSTP035","CoastNet_PTN_Tejo_071","Pedra do Leao","NB028","ngOudm","gn-14","VB14","F22","SB45","Ler15","IM11","HVALPSUND5","FSUS","APPA E","L5","PREVOST_MER","Sound6","FRASERBURGH12","r02","s-12","Nene25","76 127 w ","gm_2017_13","Rt2","SB14","R 15","NB014","MR 23","G4"]); + pm.expect(jsonData).to.include.members(["76 127 w ","84-PONTA-CEDROS-FUNDO","101 CORVO","ABDN Bay-4","APPA E","bpns-HD17","C2","CoastNet_PTN_Tejo_071","D1.11","F22","F36","FSUS","G4","GARD5","gm_2017_13","gn-14","HVALPSUND5","I27","IMFSTP019","IMFSTP035","L5","Ler15","LOM28","MR 23","NB014","NB028","Nene25","ngOudm","O32","OM 3","Pedra do Leao","PLANIER_EST","PREVOST_MER","PTN_#78","R 15","r02","Rt2","s-12","SB14","SN_E12_C","Sound6","VB14","Vossemeer"]); }); pm.test("Response time is less than 3s", function () { From 3082dff48809f284ed6b2d1fac2784a573ea33c8 Mon Sep 17 00:00:00 2001 From: PietrH Date: Fri, 18 Oct 2024 10:44:39 +0200 Subject: [PATCH 173/183] Script to find mismatch in postman tests: expectation to api reponse --- .../find-postman-test-mismatch.R | 95 +++++++++++++++++++ 1 file changed, 95 insertions(+) create mode 100644 inst/postman-helpers/find-postman-test-mismatch.R diff --git a/inst/postman-helpers/find-postman-test-mismatch.R b/inst/postman-helpers/find-postman-test-mismatch.R new file mode 100644 index 0000000..5b26aba --- /dev/null +++ b/inst/postman-helpers/find-postman-test-mismatch.R @@ -0,0 +1,95 @@ +# check mismatch between js test and api response for list_acoustic_project_codes + + +# load libraries ---------------------------------------------------------- + +library(httr2) + + + +# set function to test ---------------------------------------------------- + +fn_to_test <- "list_acoustic_tag_ids" + +# get reponse ------------------------------------------------------------- + + +## build request ---------------------------------------------------------- + +request <- + request( + glue::glue( + "https://opencpu.lifewatch.be/library/etnservice/R/{fn_to_test}/json" + ) + ) + +response <- + request %>% + req_headers( + "Content-Type" = "application/json", + "Cookie" = "vliz_webc=vliz_webc2" + ) %>% + req_body_json(list( + credentials = list( + username = "pieter.huybrechts@inbo.be", + password = askpass::askpass("Please provide ETN db pwd") + ) + )) %>% + req_method("POST") %>% + req_perform() + +request <- request %>% + req_headers( + "Content-Type" = "application/json", + "Cookie" = "vliz_webc=vliz_webc2" + ) %>% + req_body_json(list( + credentials = list( + username = "pieter.huybrechts@inbo.be", + password = askpass::askpass("Please provide ETN db pwd") + ) + )) %>% + req_method("POST") + +# check against expectation ----------------------------------------------- + +# Make sure we didn't get a HTTP error +assertthat::assert_that(!httr2::resp_is_error(response)) + + +## extract current expectation -------------------------------------------- +expectation <- readr::read_lines( + glue::glue("tests/postman/test-{fn_to_test}.js") +) %>% + grep("pm.expect(jsonData).to.include.members(", + ., + fixed = TRUE, + value = TRUE) %>% + stringr::str_extract_all('(?<=")[^,]*?(?=\\")') %>% + unlist() + + +## extract response -------------------------------------------------------- + +api_response_values <- httr2::resp_body_json(response) %>% unlist() + +# report mismatch --------------------------------------------------------- + +# missing expected project codes: +api_response_values[ + !expectation %in% api_response_values] + +# Values from expectation that are not in the values the api responded +expectation[!expectation %in% api_response_values] + +# Values from the api response that are in the values form the expectation +api_response_values[api_response_values %in% expectation] + +# check if the response is always the same -------------------------------- +library(furrr) +plan("multisession", workers = 10) +furrr::future_map(rep(list(request), 100), ~resp_body_json(req_perform(.x))) %>% + purrr::map(digest::digest) %>% + unlist %>% + unique %>% + length(.) == 1 From 8fc16d36bdf6740d7956d64afb9c9fa38f162629 Mon Sep 17 00:00:00 2001 From: PietrH Date: Tue, 22 Oct 2024 12:02:38 +0200 Subject: [PATCH 174/183] devtools::document() --- DESCRIPTION | 2 +- R/utils.R | 2 ++ man/check_credentials.Rd | 25 +++++++++++++++++++++++++ 3 files changed, 28 insertions(+), 1 deletion(-) create mode 100644 man/check_credentials.Rd diff --git a/DESCRIPTION b/DESCRIPTION index b26c7ab..9bc39e2 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -15,7 +15,7 @@ Description: Provides API endpoints to the European Tracking Network. Designed License: MIT + file LICENSE Encoding: UTF-8 Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.3 +RoxygenNote: 7.3.2 Imports: assertthat, DBI, diff --git a/R/utils.R b/R/utils.R index 426206a..62e5ab3 100644 --- a/R/utils.R +++ b/R/utils.R @@ -120,9 +120,11 @@ get_credentials <- #' @return TRUE if the credentials are valid, an error otherwise #' #' @examples +#' \dontrun{ #' credentials <- list(username = "john_doe", password = "password123") #' check_credentials(credentials) #' #> [1] TRUE +#' } check_credentials <- function(credentials) { assertthat::assert_that( diff --git a/man/check_credentials.Rd b/man/check_credentials.Rd new file mode 100644 index 0000000..72838d0 --- /dev/null +++ b/man/check_credentials.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{check_credentials} +\alias{check_credentials} +\title{Check if the provided credentials are valid.} +\usage{ +check_credentials(credentials) +} +\arguments{ +\item{credentials}{A list or data frame containing the credentials to be checked.} +} +\value{ +TRUE if the credentials are valid, an error otherwise +} +\description{ +This function checks if the provided credentials contain a "username" and "password" field, +and if both fields are of type character. It also verifies that the credentials object has a length of 2. +} +\examples{ +\dontrun{ +credentials <- list(username = "john_doe", password = "password123") +check_credentials(credentials) +#> [1] TRUE +} +} From bea8a24e48317f5f145898d628f1919c9c62f3b7 Mon Sep 17 00:00:00 2001 From: PietrH Date: Tue, 22 Oct 2024 12:08:39 +0200 Subject: [PATCH 175/183] usethis::use_tidy_description() --- DESCRIPTION | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 9bc39e2..bebb54d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -9,13 +9,11 @@ Authors@R: c( person("Research Institute for Nature and Forest (INBO)", role = "cph", comment = "https://www.vlaanderen.be/inbo/en-gb/"), person("LifeWatch Belgium", role = "fnd", - comment = "https://lifewatch.be")) -Description: Provides API endpoints to the European Tracking Network. Designed - to be used with OpenCPU and the 'etn' package. + comment = "https://lifewatch.be") + ) +Description: Provides API endpoints to the European Tracking Network. + Designed to be used with OpenCPU and the 'etn' package. License: MIT + file LICENSE -Encoding: UTF-8 -Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.2 Imports: assertthat, DBI, @@ -28,3 +26,6 @@ Imports: odbc, readr, stringr +Encoding: UTF-8 +Roxygen: list(markdown = TRUE) +RoxygenNote: 7.3.2 From eb5496184a2f8c60d7bdbae4a8f88e746739ffa3 Mon Sep 17 00:00:00 2001 From: PietrH Date: Tue, 22 Oct 2024 12:08:54 +0200 Subject: [PATCH 176/183] remove incorrect dubble assignment --- R/list_scientific_names.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/list_scientific_names.R b/R/list_scientific_names.R index 37e815d..0780fd8 100644 --- a/R/list_scientific_names.R +++ b/R/list_scientific_names.R @@ -10,7 +10,7 @@ list_scientific_names <- function(credentials = list( username = Sys.getenv("userid"), password = Sys.getenv("pwd") )) { - connection <- connection <- connect_to_etn(credentials$username, credentials$password) + connection <- connect_to_etn(credentials$username, credentials$password) query <- glue::glue_sql( "SELECT DISTINCT scientific_name FROM common.animal_release", .con = connection From 2b6ef69518bebf71adac0e8f8d9ad3f811d6e2ad Mon Sep 17 00:00:00 2001 From: PietrH Date: Tue, 22 Oct 2024 14:16:46 +0200 Subject: [PATCH 177/183] Add tests for error message --- tests/testthat/test-connect_to_etn.R | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/tests/testthat/test-connect_to_etn.R b/tests/testthat/test-connect_to_etn.R index c31fbb9..3bb4558 100644 --- a/tests/testthat/test-connect_to_etn.R +++ b/tests/testthat/test-connect_to_etn.R @@ -8,3 +8,14 @@ test_that("connect_to_etn() allows to create a connection with passed credential expect_true(isClass(connection, "PostgreSQL")) DBI::dbDisconnect(connection) }) + +test_that("connect_to_etn() returns a clear error when connecting to db fails",{ + expect_error(connect_to_etn("only one argument"), + regexp = "Failed to connect to the database.") + expect_error(connect_to_etn(password = "missing username"), + regexp = "Failed to connect to the database.") + expect_error(connect_to_etn(username = "missing password"), + regexp = "Failed to connect to the database.") + expect_error(connect_to_etn(username = "", password = ""), + regexp = "Failed to connect to the database.") +}) From db456066a81d4454321398ecf3194c9ac5f176ef Mon Sep 17 00:00:00 2001 From: PietrH Date: Tue, 22 Oct 2024 14:49:13 +0200 Subject: [PATCH 178/183] usethis::use_testthat() --- DESCRIPTION | 3 +++ tests/testthat.R | 12 ++++++++++++ 2 files changed, 15 insertions(+) create mode 100644 tests/testthat.R diff --git a/DESCRIPTION b/DESCRIPTION index bebb54d..07291f8 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -29,3 +29,6 @@ Imports: Encoding: UTF-8 Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.2 +Suggests: + testthat (>= 3.0.0) +Config/testthat/edition: 3 diff --git a/tests/testthat.R b/tests/testthat.R new file mode 100644 index 0000000..622aa33 --- /dev/null +++ b/tests/testthat.R @@ -0,0 +1,12 @@ +# This file is part of the standard setup for testthat. +# It is recommended that you do not modify it. +# +# Where should you do additional test configuration? +# Learn more about the roles of various files in: +# * https://r-pkgs.org/tests.html +# * https://testthat.r-lib.org/reference/test_package.html#special-files + +library(testthat) +library(etnservice) + +test_check("etnservice") From 75c4d83b1ebfffde4a6b247ab7d381f31b32df33 Mon Sep 17 00:00:00 2001 From: PietrH Date: Tue, 22 Oct 2024 15:09:06 +0200 Subject: [PATCH 179/183] split up expectations into tests, add skip for known issue --- tests/testthat/test-list_receiver_ids.R | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-list_receiver_ids.R b/tests/testthat/test-list_receiver_ids.R index a657d73..2f93201 100644 --- a/tests/testthat/test-list_receiver_ids.R +++ b/tests/testthat/test-list_receiver_ids.R @@ -3,12 +3,21 @@ credentials <- list( password = Sys.getenv("pwd") ) +vector <- list_receiver_ids(credentials) + test_that("list_receiver_ids() returns unique list of values", { - vector <- list_receiver_ids(credentials) + expect_false(any(duplicated(vector))) +}) +test_that("list_receiver_ids() returns a character vector", { expect_is(vector, "character") - expect_false(any(duplicated(vector))) +}) + +test_that("list_receiver_ids() does not return NA values", { + skip("Empty receiver value in acoustic.receivers, ISSUE https://github.com/inbo/etn/issues/333") expect_true(all(!is.na(vector))) +}) +test_that("list_receiver_ids() returns known value", { expect_true("VR2W-124070" %in% vector) }) From 61d66b83d9d9e1fa9d27fbcebf7bc68d7073d5aa Mon Sep 17 00:00:00 2001 From: PietrH Date: Tue, 22 Oct 2024 15:09:21 +0200 Subject: [PATCH 180/183] add skip for known issue --- tests/testthat/test-get_acoustic_detections.R | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/testthat/test-get_acoustic_detections.R b/tests/testthat/test-get_acoustic_detections.R index 198f3fb..450fd64 100644 --- a/tests/testthat/test-get_acoustic_detections.R +++ b/tests/testthat/test-get_acoustic_detections.R @@ -32,6 +32,7 @@ test_that("get_acoustic_detections() returns error for incorrect connection", { }) test_that("get_acoustic_detections() returns unique detection_id", { + skip("duplicate detection ids: https://github.com/inbo/etn/issues/283") df <- get_acoustic_detections(credentials, limit = TRUE) expect_equal(nrow(df), nrow(df %>% distinct(detection_id))) }) From 53e07616ada1b8aa307211f0590183fdfa052748 Mon Sep 17 00:00:00 2001 From: PietrH Date: Wed, 6 Nov 2024 13:22:22 +0100 Subject: [PATCH 181/183] tidy description --- DESCRIPTION | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 07291f8..e0dc691 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -26,9 +26,9 @@ Imports: odbc, readr, stringr -Encoding: UTF-8 -Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.2 Suggests: testthat (>= 3.0.0) Config/testthat/edition: 3 +Encoding: UTF-8 +Roxygen: list(markdown = TRUE) +RoxygenNote: 7.3.2 From 8855c1e03ffb9288d33c269cb9881ba8066c0609 Mon Sep 17 00:00:00 2001 From: PietrH Date: Wed, 6 Nov 2024 13:23:21 +0100 Subject: [PATCH 182/183] Increment version number to 0.1.0 --- DESCRIPTION | 2 +- NEWS.md | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) create mode 100644 NEWS.md diff --git a/DESCRIPTION b/DESCRIPTION index e0dc691..3fc48a9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: etnservice Title: Serve Data from the European Tracking Network -Version: 0.0.0.9000 +Version: 0.1.0 Authors@R: c( person("Pieter", "Huybrechts", , "pieter.huybrechts@inbo.be", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-6658-6062")), diff --git a/NEWS.md b/NEWS.md new file mode 100644 index 0000000..0383623 --- /dev/null +++ b/NEWS.md @@ -0,0 +1,3 @@ +# etnservice 0.1.0 + +# etnservice v0.1- From f3c69ded9184e3ef1802d58b12fb2399b2ba437b Mon Sep 17 00:00:00 2001 From: PietrH Date: Wed, 6 Nov 2024 13:26:22 +0100 Subject: [PATCH 183/183] Add NEWS file with info about this etnservice release --- NEWS.md | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/NEWS.md b/NEWS.md index 0383623..8ed05a5 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,5 @@ -# etnservice 0.1.0 +# etnservice v0.1.0 + +- This is the first version of etnservice used in the beta of etn v2.3.0. +- This version is still lagging behind it's contemporary version of etn v2.2.1, which means that database queries made via etnservice, or via the OpenCPU API are not guaranteed to be identical as the results of the same queries made via the etn R package. -# etnservice v0.1-