diff --git a/.Rbuildignore b/.Rbuildignore index 94a4aac..43b4625 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -10,3 +10,4 @@ ^pkgdown$ ^ignore$ ^austraits$ +^codecov\.yml$ diff --git a/.github/workflows/R-CMD-check.yml b/.github/workflows/R-CMD-check.yml index 91eb0c4..96c9123 100644 --- a/.github/workflows/R-CMD-check.yml +++ b/.github/workflows/R-CMD-check.yml @@ -5,10 +5,10 @@ on: branches: - master - develop - - upgrade pull_request: branches: - master + - develop name: R-CMD-check @@ -25,7 +25,7 @@ jobs: env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v4 - uses: r-lib/actions/setup-r@v2 - uses: r-lib/actions/setup-pandoc@v2 - name: Install dependencies diff --git a/.github/workflows/pkgdown_deploy.yml b/.github/workflows/pkgdown_deploy.yml index 9e11fe0..76f4062 100644 --- a/.github/workflows/pkgdown_deploy.yml +++ b/.github/workflows/pkgdown_deploy.yml @@ -13,7 +13,7 @@ jobs: env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v4 - uses: r-lib/actions/setup-r@v2 diff --git a/.github/workflows/test-coverage.yml b/.github/workflows/test-coverage.yml index 44b164c..52152ec 100644 --- a/.github/workflows/test-coverage.yml +++ b/.github/workflows/test-coverage.yml @@ -7,6 +7,7 @@ on: pull_request: branches: - master + - develop name: test-coverage @@ -16,7 +17,7 @@ jobs: env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v4 - uses: r-lib/actions/setup-r@v2 @@ -30,7 +31,7 @@ jobs: shell: Rscript {0} - name: Restore R package cache - uses: actions/cache@v2 + uses: actions/cache@v3 with: path: ${{ env.R_LIBS_USER }} key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} diff --git a/DESCRIPTION b/DESCRIPTION index 93ec317..06a7531 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: austraits Title: Helpful functions to access, summarise and wrangle austraits data -Version: 2.1.2 +Version: 2.2.2 Authors@R: c(person(given = "Daniel", family = "Falster", @@ -22,7 +22,7 @@ Encoding: UTF-8 Language: en LazyData: true Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.1 +RoxygenNote: 7.2.3 Depends: R (>= 4.0.0), RefManageR @@ -39,20 +39,20 @@ Imports: utils, magrittr, janitor, - lifecycle -Suggests: + lifecycle, ggplot2, - knitr, - rmarkdown, - testthat (>= 3.0.0), - markdown, - ggpointdensity, - ggbeeswarm, + ggpointdensity, + ggbeeswarm (>= 0.7.1), gridExtra, scales, forcats, viridis, - kableExtra + lubridate +Suggests: + knitr, + rmarkdown, + testthat (>= 3.0.0), + markdown VignetteBuilder: knitr Config/testthat/edition: 3 URL: https://traitecoevo.github.io/austraits/ diff --git a/NAMESPACE b/NAMESPACE index 642487b..eea0d50 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -15,12 +15,8 @@ export(join_locations) export(join_methods) export(join_sites) export(join_taxonomy) -export(list1_to_df) export(load_austraits) export(lookup_trait) -export(my_kable_styling_html) -export(my_kable_styling_markdown) -export(my_kable_styling_pdf) export(plot_locations) export(plot_site_locations) export(plot_trait_distribution_beeswarm) @@ -34,6 +30,7 @@ importFrom(dplyr,arrange) importFrom(dplyr,filter) importFrom(dplyr,group_by) importFrom(dplyr,select) +importFrom(dplyr,summarise) importFrom(lifecycle,deprecated) importFrom(magrittr,"%>%") importFrom(stats,family) diff --git a/NEWS.md b/NEWS.md index b184414..8cb589c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,5 @@ -# austraits 2.1.2 -- Minor bug fix in `as_wide_table` -- Minor bug fix in `join_contexts` -- Removed pkgdown docs/ - - +# austraits 2.2.2 +- Upgrades to `as_wide_table`, `join_`, `trait_pivot_` to work with multiple versions of AusTraits +- Minor fixes across all function so `tidyselect` is happy +- Minor changes to documentation +- Minor fixes to `load_austraits` and `get_versions` due to Zenodo changes diff --git a/R/as_wide_table.R b/R/as_wide_table.R index b4cd493..2c097a0 100644 --- a/R/as_wide_table.R +++ b/R/as_wide_table.R @@ -19,20 +19,21 @@ as_wide_table <- function(austraits){ version <- what_version(austraits) switch (version, - 'new' = as_wide_table2(austraits), - 'old' = as_wide_table1(austraits), - ) + "5-series" = as_wide_table3(austraits), + "4-series" = as_wide_table2(austraits), + "3-series-earlier" = as_wide_table1(austraits) + ) } -#' Turning entire AusTraits object into wide table >3.0.2 +#' Turning entire AusTraits object into wide table v5 #' @noRd #' @keywords internal -as_wide_table2 <- function(austraits){ +as_wide_table3 <- function(austraits){ # Function to collapse columns in locations and contexts into single column - process_table2 <- function(data) { + process_table3 <- function(data) { data %>% - tidyr::pivot_wider(names_from = property, values_from = value) %>% + tidyr::pivot_wider(names_from = "property", values_from = "value") %>% tidyr::nest(data=-dplyr::any_of(c("dataset_id", "location_id", "latitude (deg)", "longitude (deg)"))) %>% dplyr::mutate(location = purrr::map_chr(data, collapse_cols)) %>% dplyr::select(-data) @@ -48,61 +49,139 @@ as_wide_table2 <- function(austraits){ # Getting rid of the columns that will soon be deleted in the next austraits release and renaming the description column austraits$methods <- austraits$methods %>% - dplyr::rename(c("dataset_description" = "description")) %>% + dplyr::rename(dataset_description = "description") %>% dplyr::distinct() # collapse into one column austraits$locations <- austraits$locations %>% dplyr::filter(value!="unknown") %>% - dplyr::rename(c("property" = "location_property")) %>% + dplyr::rename("property" = "location_property") %>% split(., .$dataset_id) %>% - purrr::map_dfr(process_table2) + purrr::map_dfr(process_table3) - # rename taxonomic_reference field to reflect the APC/APNI name matching process better + # rename taxonomic_dataset field to reflect the APC/APNI name matching process better austraits$taxa <- austraits$taxa %>% - dplyr::rename(c("taxonNameValidation" = "taxonomic_reference")) %>% dplyr::distinct() austraits_wide <- austraits$traits %>% dplyr::left_join(by=c("dataset_id", "location_id"), austraits$locations) %>% - dplyr::left_join(by=c("dataset_id", "trait_name"), austraits$methods) %>% + dplyr::left_join(by=c("dataset_id", "method_id", "trait_name"), austraits$methods) %>% dplyr::left_join(by=c("taxon_name"), austraits$taxa) # reorder the names to be more intuitive austraits_wide %>% dplyr::select( # The most useful (if you are filtering for just one taxon_name) - dataset_id, observation_id, trait_name, taxon_name, value, unit, - entity_type, population_id, individual_id, - value_type, basis_of_value, - replicates, + "dataset_id", "observation_id", "trait_name", "taxon_name", "value", "unit", + "entity_type", "population_id", "individual_id", + "value_type", "basis_of_value", + "replicates", # tissue, trait_category, # Add after new zenodo release # More stuff you can filter on - collection_date, basis_of_record, life_stage, sampling_strategy, - treatment_id, temporal_id, + "collection_date", "basis_of_record", "life_stage", "sampling_strategy", + "treatment_context_id", "temporal_context_id", #stuff relating to locations - `latitude (deg)`, `longitude (deg)`, location, plot_id, + "latitude (deg)", "longitude (deg)", "location", "plot_context_id", #stuff relating to contexts and methods - context, methods, method_id, original_name, + "context", "methods", "method_id", "method_context_id", "original_name", #the citations - dataset_description, source_primary_citation, source_secondary_citation, + "dataset_description", "source_primary_citation", "source_secondary_citation", #the taxa details - taxonomic_status, taxon_distribution, - taxon_rank, genus, family, #accepted_name_usage_id, - scientific_name_authorship + "taxonomic_status", "taxon_distribution", + "taxon_rank", "genus", "family" ) austraits_wide } +#' Turning entire AusTraits object into wide table v4 +#' @noRd +#' @keywords internal +as_wide_table2 <- function(austraits){ + + # Function to collapse columns in locations and contexts into single column + process_table2 <- function(data) { + data %>% + tidyr::pivot_wider(names_from = "property", values_from = "value") %>% + tidyr::nest(data=-dplyr::any_of(c("dataset_id", "location_id", "latitude (deg)", "longitude (deg)"))) %>% + dplyr::mutate(location = purrr::map_chr(data, collapse_cols)) %>% + dplyr::select(-data) + } + + ################################################################################ + # Define and adapt each table in the list of austraits to prepare for the wide table format + + # The contexts table needs the contexts collapsed to one context name per site + austraits %>% + join_contexts(collapse_context = TRUE) -> austraits + + # Getting rid of the columns that will soon be deleted in the next austraits release and renaming the description column + austraits$methods <- + austraits$methods %>% + dplyr::rename(dataset_description = "description") %>% + dplyr::distinct() + + # collapse into one column + austraits$locations <- + austraits$locations %>% + dplyr::filter(value!="unknown") %>% + dplyr::rename(property = "location_property") %>% + split(., .$dataset_id) %>% + purrr::map_dfr(process_table2) + + # rename taxonomic_dataset field to reflect the APC/APNI name matching process better + austraits$taxa <- + austraits$taxa %>% + dplyr::distinct() + + austraits_wide <- + austraits$traits %>% + dplyr::left_join(by=c("dataset_id", "location_id"), austraits$locations) %>% + dplyr::left_join(by=c("dataset_id", "trait_name"), austraits$methods) %>% + dplyr::left_join(by=c("taxon_name"), austraits$taxa) + + # reorder the names to be more intuitive + austraits_wide %>% dplyr::select(dplyr::any_of(c( + + # The most useful (if you are filtering for just one taxon_name) + "dataset_id", "observation_id", "trait_name", "taxon_name", "value", "unit", + "entity_type", "population_id", "individual_id", + "value_type", "basis_of_value", + "replicates", + # tissue, trait_category, # Add after new zenodo release + + # More stuff you can filter on + "collection_date", "basis_of_record", "life_stage", "sampling_strategy", + "treatment_id", "temporal_id", + + #stuff relating to locations + "latitude (deg)", "longitude (deg)", "location", "plot_id", + + #stuff relating to contexts and methods + "context", "methods", "original_name", + + #the citations + "dataset_description", "source_primary_citation", "source_secondary_citation", + + #the taxa details + "taxonomic_status", "taxon_distribution", + "taxon_rank", "genus", "family" + + ) + ) + ) + + austraits_wide +} + #' Turning entire AusTraits object into wide table <=3.0.2 #' @noRd #' @keywords internal @@ -128,7 +207,7 @@ as_wide_table1 <- function(austraits){ process_table <- function(data) { data %>% - tidyr::pivot_wider(names_from = property, values_from = value) %>% + tidyr::pivot_wider(names_from = "property", values_from = "value") %>% tidyr::nest(data=-dplyr::any_of(c("dataset_id", "site_name", "context_name", "latitude (deg)", "longitude (deg)"))) %>% dplyr::mutate(site = purrr::map_chr(data, collapse_cols)) %>% dplyr::select(-data) @@ -140,15 +219,15 @@ as_wide_table1 <- function(austraits){ # the trait table needs little prep. Rename the value columns as value austraits$traits <- austraits$traits %>% - dplyr::rename(c("trait_value" = "value")) + dplyr::rename(trait_value = "value") # The contexts table needs the contexts collapsed to one context name per site austraits$contexts <- austraits$contexts %>% - dplyr::rename(c("property" = "context_property")) %>% + dplyr::rename(property = "context_property") %>% split(austraits$contexts$dataset_id) %>% purrr::map_dfr(process_table) %>% - dplyr::rename(c("context" = "site")) + dplyr::rename(context = "site") # Getting rid of the columns that will soon be deleted in the next austraits release and renaming the description column austraits$methods <- @@ -161,8 +240,8 @@ as_wide_table1 <- function(austraits){ dplyr::slice(1) %>% dplyr:: ungroup() %>% #------------ - dplyr::select(-year_collected_start, -year_collected_end) %>% - dplyr::rename(c("dataset_description" = "description")) + dplyr::select(-c("year_collected_start", "year_collected_end")) %>% + dplyr::rename(dataset_description = "description") # collapse into one column austraits$sites <- @@ -170,14 +249,14 @@ as_wide_table1 <- function(austraits){ dplyr::filter(value!="unknown") %>% # next line is a fix -- one dataset in 3.0.2 has value "site_name" dplyr::mutate(site_property = gsub("site_name", "name", site_property)) %>% - dplyr::rename(c("property" = "site_property")) %>% + dplyr::rename(property = "site_property") %>% split(., .$dataset_id) %>% purrr::map_dfr(process_table) # rename source data field to reflect the APC/APNI name matching process better austraits$taxa <- austraits$taxa %>% - dplyr::rename(c("taxonNameValidation" = "source")) + dplyr::rename(taxonNameValidation = "source") austraits_wide <- austraits$traits %>% @@ -190,26 +269,26 @@ as_wide_table1 <- function(austraits){ dplyr::select( # The most useful (if you are filtering for just one taxon_name) - dataset_id, observation_id, trait_name, taxon_name, trait_value, unit, - value_type, replicates, + "dataset_id", "observation_id", "trait_name", "taxon_name", "trait_value", "unit", + "value_type", "replicates", # tissue, trait_category, # Add after new zenodo release # More stuff you can filter on - date, collection_type, sample_age_class, sampling_strategy, + "date", "collection_type", "sample_age_class", "sampling_strategy", #stuff relating to sites - `latitude (deg)`, `longitude (deg)`, site_name, site, + "latitude (deg)", "longitude (deg)", "site_name", "site", #stuff relating to contexts and methods - context_name, context, methods, original_name, + "context_name", "context", "methods", "original_name", #the citations - dataset_description, source_primary_citation, source_secondary_citation, + "dataset_description", "source_primary_citation", "source_secondary_citation", #the taxa details - taxonomicStatus, taxonDistribution, - taxonRank, genus, family, acceptedNameUsageID, - scientificNameAuthorship, ccAttributionIRI + "taxonomicStatus", "taxonDistribution", + "taxonRank", "genus", "family", "acceptedNameUsageID", + "scientificNameAuthorship", "ccAttributionIRI" ) austraits_wide diff --git a/R/austraits-package.R b/R/austraits-package.R index ca44dd5..48ded33 100644 --- a/R/austraits-package.R +++ b/R/austraits-package.R @@ -16,3 +16,45 @@ if(getRversion() >= "2.15.1") utils::globalVariables(c(".", "dplyr::n()")) #' @importFrom lifecycle deprecated ## usethis namespace: end NULL + +utils::globalVariables(c("..density..", + ".data", + "Group", + "abort", + "australia", + "colour", + "context", + "context_name", + "context_property", + "dataset_id", + "latitude (deg)", + "link_id", + "link_vals", + "location_name", + "location_property", + "longitude (deg)", + "method_context_id", + "method_id", + "n", + "n_vals", + "n_value_type", + "observation_id", + "original_name", + "percent", + "percent_total", + "repeat_measurements_id", + "replicates", + "shapes", + "site_name", + "site_property", + "source_id", + "taxon_name", + "text", + "trait_name", + "value", + "value_type", + "x", + "y", + "publication_date", + "doi") +) diff --git a/R/bind_trait_values.R b/R/bind_trait_values.R index a3d3e54..147b23a 100644 --- a/R/bind_trait_values.R +++ b/R/bind_trait_values.R @@ -26,7 +26,7 @@ bind_trait_values <- function(trait_data) { if(nrow(.data) > 1) { return( .data %>% - dplyr::mutate(value = bind_x(value), + dplyr::mutate(value = bind_x(.data$value), value_type = bind_x(value_type), replicates = bind_x(replicates)) %>% dplyr::filter(dplyr::row_number()==1) diff --git a/R/extract_dataset.R b/R/extract_dataset.R index e743552..15b903a 100644 --- a/R/extract_dataset.R +++ b/R/extract_dataset.R @@ -18,6 +18,11 @@ extract_dataset <- function(austraits, dataset_id) { # Switch for different versions version <- what_version(austraits) + if(what_version(austraits) %in% c("4-series", "5-series")){ + version <- "new" + } else + version <- "old" + switch (version, 'new' = extract_dataset2(austraits, dataset_id), 'old' = extract_dataset1(austraits, dataset_id), diff --git a/R/extract_taxa.R b/R/extract_taxa.R index 517ca30..d8737ed 100644 --- a/R/extract_taxa.R +++ b/R/extract_taxa.R @@ -19,6 +19,11 @@ extract_taxa <- function(austraits, family = NULL, genus = NULL, taxon_name = NU # Switch for different versions version <- what_version(austraits) + if(what_version(austraits) %in% c("4-series", "5-series")){ + version <- "new" + } else + version <- "old" + switch (version, 'new' = extract_taxa2(austraits, family, genus, taxon_name), 'old' = extract_taxa1(austraits, family, genus, taxon_name), diff --git a/R/extract_trait.R b/R/extract_trait.R index faac7a9..1591c83 100644 --- a/R/extract_trait.R +++ b/R/extract_trait.R @@ -20,6 +20,11 @@ extract_trait <- function(austraits, trait_names, taxon_names=NULL) { # Switch for different versions version <- what_version(austraits) + if(what_version(austraits) %in% c("4-series", "5-series")){ + version <- "new" + } else + version <- "old" + switch (version, 'new' = extract_trait2(austraits, trait_names, taxon_names), 'old' = extract_trait1(austraits, trait_names, taxon_names), diff --git a/R/join_all.R b/R/join_all.R index f32cf61..1ad1a4b 100644 --- a/R/join_all.R +++ b/R/join_all.R @@ -1,7 +1,6 @@ #' @title Join study details into main `traits` dataset #' @description Function to append all study information (method, location, taxonomic, context) variables into trait database #' @param austraits dataframe generated by austraits build -#' @param vars variables to select from the respective table where information is being joined from. Not available for contexts table #' @param ... arguments passed to `vars` to subset the columns #' @return austraits list object, but with additional variables appended to `traits` dataframe #' @rdname join_all @@ -17,7 +16,7 @@ #' (austraits %>% join_contexts)$traits #' #' # Append methods -#' (austraits %>% join_methods)$traits +#' (austraits %>% join_methods(vars = c("method_id")))$traits #' #' #Append taxonomic details #' (austraits %>% join_taxonomy)$traits @@ -45,6 +44,11 @@ join_taxonomy <- function(austraits, ...) { # Switch for different versions version <- what_version(austraits) + if(what_version(austraits) %in% c("4-series", "5-series")){ + version <- "new" + } else + version <- "old" + switch (version, 'new' = join_taxonomy2(austraits, ...), 'old' = join_taxonomy1(austraits, ...), @@ -78,18 +82,51 @@ join_taxonomy2 <- function(austraits, vars = c("family", "genus", "taxon_rank", #' @export #' @rdname join_all -join_methods <- function(austraits, vars = c("methods", "year_collected_start", "year_collected_end", "collection_type")) { +join_methods <- function(austraits, ...) { + + # Switch for different versions + version <- what_version(austraits) + + if(what_version(austraits) == "5-series"){ + version <- "new" + } else + version <- "old" + + switch (version, + 'new' = join_methods2(austraits, ...), + 'old' = join_methods1(austraits, ...), + ) +} + +#' @title Joining methods info for AusTraits versions > 3.0.2 +#' @noRd +#' @keywords internal +join_methods2 <- function(austraits, vars = c("methods", "year_collected_start", "year_collected_end", "collection_type")) { + austraits$methods %>% + dplyr::select(c("dataset_id", "trait_name", "method_id"), tidyselect::any_of(vars)) %>% + dplyr::distinct() -> methods + + austraits$traits <- austraits$traits %>% + dplyr::left_join(by=c("dataset_id", "trait_name", "method_id"), + methods, relationship = "many-to-many") + + austraits +} + +#' @title Joining methods info for AusTraits versions<== 3.0.2 +#' @noRd +#' @keywords internal +join_methods1 <- function(austraits, vars = c("methods", "year_collected_start", "year_collected_end", "collection_type")) { austraits$methods %>% dplyr::select(c("dataset_id", "trait_name"), tidyselect::any_of(vars)) %>% dplyr::distinct() -> methods austraits$traits <- austraits$traits %>% dplyr::left_join(by=c("dataset_id", "trait_name"), - methods) + methods, relationship = "many-to-many") austraits } - #' @title Joining location information to traits table #' @export @@ -99,6 +136,11 @@ join_locations <- function(austraits, ...) { # Switch for different versions version <- what_version(austraits) + if(what_version(austraits) %in% c("4-series", "5-series")){ + version <- "new" + } else + version <- "old" + switch (version, 'new' = join_locations2(austraits, ...), 'old' = join_locations1(austraits, ...), @@ -125,7 +167,8 @@ join_locations1 <- function(austraits, vars = c("longitude (deg)","latitude (de #' @title Joining location info for AusTraits versions <= 3.0.2 #' @description `r lifecycle::badge('deprecated')` #' Joining location info for AusTraits versions <= 3.0.2 -#' @inheritParams join_locations +#' @param austraits austraits object +#' @param vars variables from site table to join #' @export join_sites <- function(austraits, vars = c("longitude (deg)","latitude (deg)")) { @@ -157,6 +200,11 @@ join_contexts <- function(austraits,...){ # Switch for different versions version <- what_version(austraits) + if(what_version(austraits) %in% c("4-series", "5-series")){ + version <- "new" + } else + version <- "old" + switch (version, 'new' = join_contexts2(austraits, ...), 'old' = join_contexts1(austraits, ...), @@ -202,11 +250,11 @@ join_contexts2 <- function(austraits, collapse_context = FALSE){ if(collapse_context == TRUE){ context_text <- traits2[[id]] %>% - dplyr::select(-traits_vars) %>% collapse_cols() + dplyr::select(-dplyr::any_of(traits_vars)) %>% collapse_cols() traits2[[id]] <- traits2[[id]] %>% dplyr::mutate(context = context_text) %>% - dplyr::select(traits_vars, context) + dplyr::select(dplyr::any_of(traits_vars), context) } } } diff --git a/R/load_austraits.R b/R/load_austraits.R index f8a0ad0..80a26a5 100644 --- a/R/load_austraits.R +++ b/R/load_austraits.R @@ -24,7 +24,12 @@ load_austraits <- function(doi = NULL, version = NULL, path = "data/austraits", if(rlang::is_missing(path)){ stop("File path must be supplied!") } - + + #remove v from version + if (!is.null(version)) { + version <- stringr::str_remove_all(version, "v") + } + # Does the path exist? if(! file.exists(path)) { dir.create(path, recursive=TRUE, showWarnings=FALSE) #Create folder @@ -57,21 +62,24 @@ load_austraits <- function(doi = NULL, version = NULL, path = "data/austraits", version_name <- paste0("v", version) # Getting specific version + id <- ret[which(ret$version == version), "id"] |> as.character() + target <- res$hits$hits$files[[version_name]] # Setting up the pars - url <- target$links$self[1] - file_path <- file.path(path, target$key[1]) + url <- target$links$self[grep(".rds", target$links$self, fixed = TRUE)] + file_nm <- file.path(path, target$key[grep(".rds", target$key, fixed = TRUE)]) + #Check if version/doi is download, if not download - if(! file.exists(file_path)){ + if(! file.exists(file_nm)){ # Downloading file - download_austraits(url, file_path, path = path) + download_austraits(url, file_nm, path = path) } # Loading the .rds - message("Loading data from '", file_path,"'") - data <- readRDS(file_path) + message("Loading data from '", file_nm,"'") + data <- readRDS(file_nm) # Assign class attr(data, "class") <- "austraits" @@ -91,7 +99,7 @@ load_json <- function(path, update){ # Does the .json exist? if(! file.exists(file_json) | update == TRUE){ # Retrieve the .json - res <- jsonlite::read_json("https://zenodo.org/api/records/?q=conceptrecid:3568417&all_versions=true", + res <- jsonlite::read_json("https://zenodo.org/api/records/3568418/versions", simplifyVector = T) # Save it jsonlite::write_json(res, file_json) @@ -108,14 +116,18 @@ load_json <- function(path, update){ create_metadata <- function(res){ # Version table - ret <- dplyr::tibble(date = res$hits$hits$metadata$publication_date, - version = stringr::str_extract(res$hits$hits$metadata$version, "[0-9]+\\.[0-9]+\\.[0-9]"), - doi = res$hits$hits$metadata$doi) %>% - dplyr::filter(! version < 1) %>% # Exclude any versions prior to 1.0.0 - as.data.frame() - - # Order by numeric version - ret[order(dplyr::desc(numeric_version(ret$version))),] + ret <- res$hits$hits$metadata |> + select(tidyselect::all_of(c("publication_date", "doi", "version"))) |> + dplyr::mutate(version = gsub("v", "", version) |> numeric_version(), + id = stringr::str_remove_all(doi, stringr::fixed("10.5281/zenodo.")) + )|> # set as numeric version for easier filtering + dplyr::filter(version >= "3.0.2") |> # exclude everything pre 3.0.2 + dplyr::mutate(version = as.character(version), + publication_date = lubridate::ymd(publication_date)) |> # change back as character + dplyr::tibble() |> + arrange(dplyr::desc(publication_date)) + + ret } #' Function for loading .rds AusTraits files @@ -207,13 +219,14 @@ get_version_latest <- function(path = "data/austraits", update = TRUE){ # Load the json res <- load_json(path = path, update = update) - # Get all versions and remove the 'v' - version_numbers <- stringr::str_extract(res$hits$hits$metadata$version, "[0-9]+\\.[0-9]+\\.[0-9]") - - # Order by numeric version - version_numbers <- version_numbers[order(dplyr::desc(numeric_version(version_numbers)))] + # Create version table + metadata <- create_metadata(res) + + # Sort old to new + metadata <- metadata |> + dplyr::arrange(dplyr::desc(publication_date)) - # Return the first value as the version we want - dplyr::first(version_numbers) + # Grab the first version + dplyr::first(metadata$version) |> as.character() } diff --git a/R/plot_locations.R b/R/plot_locations.R index a4121f2..83f6df4 100644 --- a/R/plot_locations.R +++ b/R/plot_locations.R @@ -77,9 +77,9 @@ plot_locations1 <- function(aus_traits, feature, ...){ panel.grid.major = ggplot2::element_blank(), panel.grid.minor = ggplot2::element_blank(), panel.background = ggplot2::element_blank(), - panel.border = ggplot2::element_rect(colour = "black", fill=NA, size=1), + panel.border = ggplot2::element_rect(colour = "black", fill=NA, linewidth=1), axis.ticks.length = ggplot2::unit(1, "mm"), - axis.ticks = ggplot2::element_line(size = 1) + axis.ticks = ggplot2::element_line(linewidth = 1) ) + ggplot2::xlab("") + ggplot2::ylab("") + ggplot2::coord_fixed() @@ -135,9 +135,9 @@ plot_locations2 <- function(aus_traits, feature, ...){ panel.grid.major = ggplot2::element_blank(), panel.grid.minor = ggplot2::element_blank(), panel.background = ggplot2::element_blank(), - panel.border = ggplot2::element_rect(colour = "black", fill=NA, size=1), + panel.border = ggplot2::element_rect(colour = "black", fill=NA, linewidth = 1), axis.ticks.length = ggplot2::unit(1, "mm"), - axis.ticks = ggplot2::element_line(size = 1) + axis.ticks = ggplot2::element_line(linewidth = 1) ) + ggplot2::xlab("") + ggplot2::ylab("") + ggplot2::coord_fixed() diff --git a/R/plot_trait_distribution_beeswarm.R b/R/plot_trait_distribution_beeswarm.R index dce267b..8db9722 100644 --- a/R/plot_trait_distribution_beeswarm.R +++ b/R/plot_trait_distribution_beeswarm.R @@ -100,7 +100,7 @@ plot_trait_distribution_beeswarm <- function(austraits, plant_trait_name, y_axis # Second plot -- dots by groups, using ggbeeswarm package p2 <- ggplot2::ggplot(data, ggplot2::aes(x = value, y = Group, colour = colour, shape = shapes)) + - ggbeeswarm::geom_quasirandom(groupOnX=FALSE) + + ggbeeswarm::geom_quasirandom() + ggplot2::ylab(paste("By ", y_axis_category)) + # inclusion of custom shapes: for min, mean, unknown # NB: this single line of code makes function about 4-5 slower for some reason diff --git a/R/report_utils.R b/R/report_utils.R deleted file mode 100644 index c7ba695..0000000 --- a/R/report_utils.R +++ /dev/null @@ -1,49 +0,0 @@ -#' html styling for kable tables -#' @param ... arguments passed on to kableExtra::kable, kableExtra::kable_styling -#' @keywords internal -#' @export - -my_kable_styling_html <- function(...) { - kableExtra::kable(...) %>% - kableExtra::kable_styling(..., - bootstrap_options = c("striped", "hover", "condensed", "responsive"), - full_width = FALSE, - position = "left" - ) %>% - # hack to add margin to plot - gsub('style="width: auto ', 'style="margin-left:30px; width: auto ', .) #this dot is trigger NOTE in RMD Check -} - -#' pdf styling for kable tables -#' @param ...arguments passed on to kableExtra::kable -#' @keywords internal -#' @export -my_kable_styling_pdf <- function(...) { - kableExtra::kable(...) -} - -#' Format a table with kable and default styling -#' @param ... arguments passed on to kableExtra::kable -#' @keywords internal -#' @export -my_kable_styling_markdown <- function(...) { - kableExtra::kable(...) -} - -#' Convert a list with single entries to dataframe -#' @param my_list a list with single entries -#' @return a tibble with two columns -#' @examples list1_to_df(as.list(iris)[2]) -#' @keywords internal -#' @export -list1_to_df <- function(my_list) { - - for(f in names(my_list)) { - if(is.null(my_list[[f]])) - my_list[[f]] <- NA - } - - tidyr::tibble(key = names(my_list), value = unlist(my_list)) -} - - diff --git a/R/summarise_trait_values.R b/R/summarise_trait_values.R index 2c76011..2b6b2de 100644 --- a/R/summarise_trait_values.R +++ b/R/summarise_trait_values.R @@ -15,8 +15,8 @@ summarise_trait_means <- function(trait_data){ suppressWarnings( trait_data %>% - dplyr::mutate(value = as.numeric(value), - replicates = as.numeric(replicates)) -> trait_data + dplyr::mutate(value = as.numeric(.data$value), + replicates = as.numeric(.data$replicates)) -> trait_data ) # Identify which ones need summarising @@ -24,14 +24,14 @@ summarise_trait_means <- function(trait_data){ dplyr::group_by(trait_name, observation_id) %>% dplyr::summarise(dplyr::n()) %>% dplyr::filter(`dplyr::n()` > 1) %>% - dplyr::select(trait_name, observation_id) + dplyr::select("trait_name", observation_id) # # Identify which ones that don't need to change original <- trait_data %>% dplyr::group_by(trait_name, observation_id) %>% dplyr::summarise(dplyr::n()) %>% dplyr::filter(! `dplyr::n()` > 1) %>% - dplyr::select(trait_name, observation_id) + dplyr::select("trait_name", "observation_id") original_df <- purrr::map2_dfr(original$trait_name, original$observation_id, ~ dplyr::filter(trait_data, trait_name == .x & observation_id == .y)) @@ -57,5 +57,5 @@ summarise_trait_means <- function(trait_data){ ret <- dplyr::bind_rows(original_df, target_bound) # Sort by observation_id and return - ret %>% dplyr::arrange(observation_id) + ret %>% dplyr::arrange(.data$observation_id) } \ No newline at end of file diff --git a/R/sysdata.rda b/R/sysdata.rda index 35c41e8..7fa845b 100644 Binary files a/R/sysdata.rda and b/R/sysdata.rda differ diff --git a/R/trait_pivot_longer.R b/R/trait_pivot_longer.R index b8dc895..582dbca 100644 --- a/R/trait_pivot_longer.R +++ b/R/trait_pivot_longer.R @@ -28,24 +28,39 @@ # trait_pivot_longer <- function(wide_data){ # Determine version using col names of traits table - if(any(str_detect(names(wide_data), "entity"))){ - version = "newer" - } else( - version = "older" - ) + if(any(names(wide_data) %in% "treatment_context_id")){ + version = "5-series" + } + + if(any(str_detect(names(wide_data), "entity")) & any(names(wide_data) %in% "treatment_id")){ + version = "4-series" + } + + if(! any(str_detect(names(wide_data), "entity"))) + version = "3-series-earlier" # Switch how traits are pivoted wider based on version switch (version, - 'newer' = trait_pivot_longer2(wide_data), - 'older' = trait_pivot_longer1(wide_data)) + "5-series" = trait_pivot_longer3(wide_data), + "4-series" = trait_pivot_longer2(wide_data), + "3-series-earlier" = trait_pivot_longer1(wide_data)) + +} + +#' Gathers 'widened' data for >= v5.0.0 +#' @noRd +#' @keywords internal +trait_pivot_longer3 <- function(wide_data) { + wide_data %>% + tidyr::pivot_longer(cols = 20:ncol(.), names_to = "trait_name", values_drop_na = TRUE) } -#' Gathers 'widened' data for > v3.0.2 +#' Gathers 'widened' data for > v3.0.2 < 5.0.0 #' @noRd #' @keywords internal trait_pivot_longer2 <- function(wide_data) { wide_data %>% - pivot_longer(cols = 18:ncol(.), names_to = "trait_name", values_drop_na = TRUE) + tidyr::pivot_longer(cols = 18:ncol(.), names_to = "trait_name", values_drop_na = TRUE) } #' Gathers 'widened' data for <= v3.0.2 @@ -74,7 +89,7 @@ trait_pivot_longer1 <- function(wide_data) { ) ret <- ret %>% - dplyr::mutate(value = dplyr::na_if(value, y = "NA")) %>% + #dplyr::mutate(value = dplyr::na_if(value, y = "NA")) %>% dplyr::filter(!is.na(value)) %>% dplyr::distinct() %>% dplyr::arrange(observation_id, trait_name) %>% diff --git a/R/trait_pivot_wider.R b/R/trait_pivot_wider.R index 284c2dd..b8a92a6 100644 --- a/R/trait_pivot_wider.R +++ b/R/trait_pivot_wider.R @@ -18,57 +18,105 @@ #' } #' @author Daniel Falster - daniel.falster@unsw.edu.au #' @export -#' @importFrom dplyr select group_by arrange filter summarise -#' @importFrom tidyr pivot_wider pivot_longer -#' @importFrom tidyselect all_of -#' @importFrom stringr str_detect trait_pivot_wider <- function(traits){ # Determine version using col names of traits table - if(any(str_detect(names(traits), "entity"))){ - version = "newer" - } else( - version = "older" - ) + if(any(names(traits) %in% "treatment_context_id")){ + version = "5-series" + } + if(any(str_detect(names(traits), "entity")) & any(names(traits) %in% "treatment_id")){ + version = "4-series" + } + + if(! any(str_detect(names(traits), "entity"))) + version = "3-series-earlier" + # Switch how traits are pivoted wider based on version switch (version, - 'newer' = trait_pivot_wider2(traits), - 'older' = trait_pivot_wider1(traits)) + "5-series" = trait_pivot_wider3(traits), + "4-series" = trait_pivot_wider2(traits), + "3-series-earlier" = trait_pivot_wider1(traits)) } -#' Pivot wider for >v3.0.2 +#' Pivot wider for >v5.0.0 #' @noRd #' @keywords internal -trait_pivot_wider2 <- function(traits){ +trait_pivot_wider3 <- function(traits){ data <- traits - meta_data_cols <- c("unit", "replicates", "measurement_remarks", "basis_of_record", "basis_of_value") + meta_data_cols <- c("unit", "replicates", "measurement_remarks", "basis_of_value") # A check for if there are more than 1 value_type for a given taxon_name, observation_id and method data %>% - select(taxon_name, trait_name, value_type, value, observation_id, method_id) %>% - group_by(taxon_name, observation_id, method_id) %>% + select(trait_name, value, dataset_id, observation_id, method_id, method_context_id, repeat_measurements_id, value_type) %>% + group_by(dataset_id, observation_id, method_id, method_context_id, repeat_measurements_id) %>% summarise(n_value_type = length(unique(value_type))) %>% arrange(observation_id) %>% dplyr::filter(n_value_type > 1) -> check_value_type if(nrow(check_value_type) > 1){ - meta_data_cols <- c(meta_data_cols, "value_type") traits %>% select(- all_of(meta_data_cols)) %>% - group_by(dataset_id, source_id, taxon_name, original_name, observation_id, method_id) %>% + group_by(dataset_id, observation_id, method_id, method_context_id, repeat_measurements_id, value_type) %>% pivot_wider(names_from = trait_name, - values_from = value) + values_from = value) |> + dplyr::ungroup() } else{ + meta_data_cols <- c(meta_data_cols, "value_type") + traits %>% select(- all_of(meta_data_cols)) %>% - group_by(dataset_id, source_id, taxon_name, original_name, observation_id, method_id, value_type) %>% + group_by(dataset_id, observation_id, method_id, method_context_id, repeat_measurements_id) %>% pivot_wider(names_from = trait_name, - values_from = value) + values_from = value) |> + dplyr::ungroup() + } +} + +#' Pivot wider for >v3.0.2 & <5.0.0 +#' @noRd +#' @keywords internal +#' @importFrom dplyr select group_by arrange filter summarise +#' @importFrom tidyr pivot_wider pivot_longer +#' @importFrom tidyselect all_of +#' @importFrom stringr str_detect + +trait_pivot_wider2 <- function(traits){ + data <- traits + + meta_data_cols <- c("unit", "replicates", "measurement_remarks", "basis_of_record", "basis_of_value") + + # A check for if there are more than 1 value_type for a given taxon_name, observation_id and method + data %>% + dplyr::select(taxon_name, trait_name, value_type, value, observation_id, method_id) %>% + dplyr::group_by(taxon_name, observation_id, method_id) %>% + dplyr::summarise(n_value_type = length(unique(value_type))) %>% + dplyr::arrange(observation_id) %>% + dplyr::filter(n_value_type > 1) -> check_value_type + + if(nrow(check_value_type) > 1){ + + traits %>% + dplyr::select(-all_of(meta_data_cols)) %>% + dplyr::group_by(dataset_id, source_id, taxon_name, original_name, observation_id, method_id, value_type) %>% + tidyr::pivot_wider(names_from = trait_name, + values_from = value) |> + dplyr::ungroup() + + } else{ + + meta_data_cols <- c(meta_data_cols, "value_type") + + traits %>% + dplyr::select(- all_of(meta_data_cols)) %>% + dplyr::group_by(dataset_id, source_id, taxon_name, original_name, observation_id, method_id) %>% + tidyr::pivot_wider(names_from = trait_name, + values_from = value) |> + dplyr::ungroup() } } diff --git a/R/what_version.R b/R/what_version.R index 42c4e65..b620d40 100644 --- a/R/what_version.R +++ b/R/what_version.R @@ -4,15 +4,20 @@ #' @return binary version for switch statements #' @noRd #' @keywords internal +#' what_version <- function(austraits){ version <- austraits$build_info$version %>% as.character() - + if(package_version(version) <= '3.0.2'){ - ret_version <- "old" - } - - if(package_version(version) > '3.0.2'){ - ret_version <- "new" - } + ret_version <- "3-series-earlier" + } + + if(package_version(version) > '3.0.2' & package_version(version) < '5.0.0'){ + ret_version <- "4-series" + } + + if(package_version(version) >='5.0.0'){ + ret_version <- "5-series" + } ret_version } \ No newline at end of file diff --git a/README.Rmd b/README.Rmd index 1381d95..0036cc7 100644 --- a/README.Rmd +++ b/README.Rmd @@ -29,6 +29,7 @@ library(dplyr) [![codecov](https://codecov.io/gh/traitecoevo/austraits/branch/master/graph/badge.svg?token=JT1M0AMZ44)](https://codecov.io/gh/traitecoevo/austraits) [![](https://img.shields.io/badge/doi-10.1038/s41597--021--01006--6-blue.svg)](https://doi.org/10.1038/s41597-021-01006-6) [![](https://img.shields.io/badge/lifecycle-stable-brightgreen.svg)](https://lifecycle.r-lib.org/articles/stages.html#stable) +[![Codecov test coverage](https://codecov.io/gh/traitecoevo/austraits/branch/master/graph/badge.svg)](https://app.codecov.io/gh/traitecoevo/austraits?branch=master) `austraits` allow users to access, explore and wrangle data from the AusTraits database in `R`. This package includes several functions such as filtering and pivoting the dataset that we expect will come in handy. diff --git a/codecov.yml b/codecov.yml new file mode 100644 index 0000000..4fdf441 --- /dev/null +++ b/codecov.yml @@ -0,0 +1,14 @@ +comment: false + +coverage: + status: + project: + default: + target: auto + threshold: 1% + informational: true + patch: + default: + target: 70% + threshold: 1% + informational: true diff --git a/data-raw/create_data.R b/data-raw/create_data.R index 558c993..e9fe2b7 100644 --- a/data-raw/create_data.R +++ b/data-raw/create_data.R @@ -2,27 +2,33 @@ ## code to prepare an example dataset, that go public devtools::load_all() -set.seed(109) -austraits_all <- load_austraits(version = "3.0.2", path = "ignore/data/austraits") -dataset_id <- c( unique(austraits_all$traits$dataset_id) %>% sample(5), "Falster_2003", "Falster_2005_1", "Falster_2005_2" ) +path = "ignore/data/austraits" + +# 3.0.2 +austraits_3.0.2 <- load_austraits(version = "3.0.2", path = path) -austraits_lite <- extract_dataset(austraits_all, dataset_id) +set.seed(109) +dataset_id <- c( unique(austraits_3.0.2$traits$dataset_id) %>% sample(5), "Falster_2003", "Falster_2005_1", "Falster_2005_2" ) -# updated release -austraits_newrel <- readRDS("ignore/data/austraits/austraits_newrel.rds") -attr(austraits_newrel, "class") <- "austraits" +austraits_3.0.2_lite <- extract_dataset(austraits_3.0.2, dataset_id) +# 4.2.0 datasets <- c("Crous_2013", "Crous_2019", "Buckton_2019", "Kooyman_2011", "Bloomfield_2018", "Wright_2019", "Westoby_2014", "Vesk_2019", "Leigh_2003", "Prior_2003", "Prior_2016", "Choat_2006", "Choat_2012", "ABRS_1981") -austraits_lite_post <- austraits_newrel %>% extract_dataset(dataset_id = datasets) +austraits_4.2.0 <- load_austraits(version = "4.2.0", path = path) +austraits_4.2.0_lite <- austraits_4.2.0 |> extract_dataset(dataset_id = c(dataset_id, datasets)) + +# 5.0.0 +austraits_5.0.0 <- load_austraits(version = "5.0.0", path = path) -## code to prepare `australia_map_raster` dataset goes here +austraits_5.0.0_lite <- austraits_5.0.0 %>% extract_dataset(dataset_id = c(dataset_id, datasets)) +## code to prepare `australia_map_raster` dataset australia_map_raster <- raster::raster("ignore/australia.tif") australia_map_raster <- australia_map_raster %>% raster::as.data.frame(xy = T,na.rm=T) -usethis::use_data(austraits_lite, australia_map_raster, austraits_lite_post, internal = TRUE, overwrite = TRUE) +usethis::use_data(austraits_3.0.2_lite, austraits_4.2.0_lite, austraits_5.0.0_lite, australia_map_raster, internal = TRUE, overwrite = TRUE) diff --git a/man/join_all.Rd b/man/join_all.Rd index cab50b8..ff4dd05 100644 --- a/man/join_all.Rd +++ b/man/join_all.Rd @@ -12,10 +12,7 @@ join_all(austraits) join_taxonomy(austraits, ...) -join_methods( - austraits, - vars = c("methods", "year_collected_start", "year_collected_end", "collection_type") -) +join_methods(austraits, ...) join_locations(austraits, ...) @@ -25,8 +22,6 @@ join_contexts(austraits, ...) \item{austraits}{dataframe generated by austraits build} \item{...}{arguments passed to \code{vars} to subset the columns} - -\item{vars}{variables to select from the respective table where information is being joined from. Not available for contexts table} } \value{ austraits list object, but with additional variables appended to \code{traits} dataframe @@ -45,7 +40,7 @@ austraits$traits (austraits \%>\% join_contexts)$traits # Append methods -(austraits \%>\% join_methods)$traits +(austraits \%>\% join_methods(vars = c("method_id")))$traits #Append taxonomic details (austraits \%>\% join_taxonomy)$traits diff --git a/man/join_sites.Rd b/man/join_sites.Rd index a1e6b30..89f51ff 100644 --- a/man/join_sites.Rd +++ b/man/join_sites.Rd @@ -7,9 +7,9 @@ join_sites(austraits, vars = c("longitude (deg)", "latitude (deg)")) } \arguments{ -\item{austraits}{dataframe generated by austraits build} +\item{austraits}{austraits object} -\item{vars}{variables to select from the respective table where information is being joined from. Not available for contexts table} +\item{vars}{variables from site table to join} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} diff --git a/man/list1_to_df.Rd b/man/list1_to_df.Rd deleted file mode 100644 index ad26fd1..0000000 --- a/man/list1_to_df.Rd +++ /dev/null @@ -1,21 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/report_utils.R -\name{list1_to_df} -\alias{list1_to_df} -\title{Convert a list with single entries to dataframe} -\usage{ -list1_to_df(my_list) -} -\arguments{ -\item{my_list}{a list with single entries} -} -\value{ -a tibble with two columns -} -\description{ -Convert a list with single entries to dataframe -} -\examples{ -list1_to_df(as.list(iris)[2]) -} -\keyword{internal} diff --git a/man/my_kable_styling_html.Rd b/man/my_kable_styling_html.Rd deleted file mode 100644 index 70220ff..0000000 --- a/man/my_kable_styling_html.Rd +++ /dev/null @@ -1,15 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/report_utils.R -\name{my_kable_styling_html} -\alias{my_kable_styling_html} -\title{html styling for kable tables} -\usage{ -my_kable_styling_html(...) -} -\arguments{ -\item{...}{arguments passed on to kableExtra::kable, kableExtra::kable_styling} -} -\description{ -html styling for kable tables -} -\keyword{internal} diff --git a/man/my_kable_styling_markdown.Rd b/man/my_kable_styling_markdown.Rd deleted file mode 100644 index ee9bc6d..0000000 --- a/man/my_kable_styling_markdown.Rd +++ /dev/null @@ -1,15 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/report_utils.R -\name{my_kable_styling_markdown} -\alias{my_kable_styling_markdown} -\title{Format a table with kable and default styling} -\usage{ -my_kable_styling_markdown(...) -} -\arguments{ -\item{...}{arguments passed on to kableExtra::kable} -} -\description{ -Format a table with kable and default styling -} -\keyword{internal} diff --git a/man/my_kable_styling_pdf.Rd b/man/my_kable_styling_pdf.Rd deleted file mode 100644 index d6dff74..0000000 --- a/man/my_kable_styling_pdf.Rd +++ /dev/null @@ -1,15 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/report_utils.R -\name{my_kable_styling_pdf} -\alias{my_kable_styling_pdf} -\title{pdf styling for kable tables} -\usage{ -my_kable_styling_pdf(...) -} -\arguments{ -\item{...arguments}{passed on to kableExtra::kable} -} -\description{ -pdf styling for kable tables -} -\keyword{internal} diff --git a/tests/testthat/test-as_wide_table.R b/tests/testthat/test-as_wide_table.R index 7981734..42d439b 100644 --- a/tests/testthat/test-as_wide_table.R +++ b/tests/testthat/test-as_wide_table.R @@ -1,25 +1,22 @@ -austraits <- austraits_lite -austraits_post <- austraits_lite_post +library(purrr) +austraits <- list(austraits_3.0.2_lite, + austraits_4.2.0_lite, + austraits_5.0.0_lite) + +test_widetable_success <- function(austraits){ test_that("Function is working", { expect_visible(austraits %>% as_wide_table()) - expect_named(austraits %>% as_wide_table()) - expect_type(austraits %>% as_wide_table(), "list") - - expect_visible(austraits_post %>% as_wide_table()) - expect_named(austraits_post %>% as_wide_table()) - expect_type(austraits_post %>% as_wide_table(), "list") - }) - - test_that("Output is correct", { - expect_equal(austraits %>% as_wide_table() %>% nrow(), austraits$traits %>% nrow()) - expect_gt(austraits %>% as_wide_table() %>% ncol(), expected = austraits$traits %>% ncol()) - expect_gt(austraits_post %>% as_wide_table() %>% ncol(), expected = austraits$traits %>% ncol()) + out <- austraits %>% as_wide_table() + expect_named(out) + expect_type(out, "list") + + # "Output is correct" + expect_gt(out %>% ncol(), expected = austraits$traits %>% ncol()) }) - - test_that("Complains at the right time", { - expect_error(as_wide_table()) - }) - +} - \ No newline at end of file +walk(austraits, + test_widetable_success) + +expect_error(as_wide_table()) diff --git a/tests/testthat/test-austraits_load_.R b/tests/testthat/test-austraits_load_.R new file mode 100644 index 0000000..7f1ad54 --- /dev/null +++ b/tests/testthat/test-austraits_load_.R @@ -0,0 +1,42 @@ +library(purrr) + +versions <- c("3.0.2", "4.2.0", "5.0.0") +path = "ignore/data/austraits" + +test_get_versions <- function(version, path){ + test_that("get_versions is working", { + x <- get_versions(path = path, update = TRUE) + + expect_visible(x) + expect_named(x) + expect_type(x, "list") + expect_length(x, ncol(x)) + }) +} + +walk(versions, + ~ test_get_versions(.x, path)) + + +test_load_austraits <- function(version, path){ + test_that("load_austraits is working", { + austraits <- load_austraits(version = version, path = path, update = TRUE) + + expect_visible(austraits) + expect_named(austraits) + expect_type(austraits, "list") + expect_error(load_austrait()) + }) +} + +map(versions, + ~ test_load_austraits(.x, path = path)) + + +test_that("Right errors are tripped", { + expect_error(load_austraits("3.0.6", path = path)) + expect_error(load_austraits(doi = "10.5281/zenodo.5112005", + path = path)) + expect_error(load_austraits(path = NULL)) +}) + diff --git a/tests/testthat/test-extract_.R b/tests/testthat/test-extract_.R index 7a96bdd..66f246a 100644 --- a/tests/testthat/test-extract_.R +++ b/tests/testthat/test-extract_.R @@ -1,59 +1,91 @@ -#Extract a dataset -# data <- list(austraits = austraits_lite, -# austraits_post = austraits_lite_post) -# test_that("Function works", { -# expect_no_error(purrr::map(.x =data, -# .f = ~extract_dataset(., dataset_id = "Falster_2003"))) -# }) - -austraits <- austraits_lite -austraits_post <- austraits_lite_post - -subset <- extract_dataset(austraits, dataset_id = "Falster_2003") -subset_post <- extract_dataset(austraits_post, dataset_id = "Bloomfield_2018") - -#Extract a trait -trait_subset <- extract_trait(austraits, trait_names = "wood_density") -trait_subset_post <- extract_trait(austraits_post, trait_names = "leaf_mass_per_area") - -test_that("extracted dataset has some structure as austraits build", { - expect_s3_class(austraits, "austraits") - expect_equal(length(austraits), length(subset)) - expect_equal(sort(names(austraits)), sort(names(subset))) - - expect_equal(length(austraits), length(trait_subset)) - expect_equal(sort(names(austraits)), sort(names(trait_subset))) - expect_named(austraits, names(trait_subset)) - - expect_s3_class(austraits_post, "austraits") - expect_s3_class(austraits_post, "austraits") - expect_equal(length(austraits_post), length(subset_post)) - expect_equal(sort(names(austraits_post)), sort(names(subset_post))) - - expect_equal(length(austraits_post), length(trait_subset_post)) - expect_equal(sort(names(austraits_post)), sort(names(trait_subset_post))) - expect_named(austraits_post, names(trait_subset_post)) -}) - -test_that("extraction of dataset was successful", { - expect_match("Falster_2003", unique(subset$traits$dataset_id)) - expect_equal(1, dplyr::n_distinct(subset$traits$dataset_id)) - expect_match("wood_density", unique(trait_subset$traits$trait_name)) - expect_equal(1, dplyr::n_distinct(trait_subset$traits$trait_name)) - - expect_match("Falster_2003", unique(subset$traits$dataset_id)) - expect_equal(1, dplyr::n_distinct(subset$traits$dataset_id)) - expect_match("wood_density", unique(trait_subset$traits$trait_name)) - expect_equal(1, dplyr::n_distinct(trait_subset$traits$trait_name)) - - expect_match("Bloomfield_2018", unique(subset_post$traits$dataset_id)) - expect_equal(1, dplyr::n_distinct(subset_post$traits$dataset_id)) - expect_match("leaf_mass_per_area", unique(trait_subset_post$traits$trait_name)) - expect_equal(1, dplyr::n_distinct(trait_subset_post$traits$trait_name)) +library(purrr) +library(stringr) + +austraits <- list(austraits_3.0.2_lite, + austraits_4.2.0_lite, + austraits_5.0.0_lite) + +dataset_id = "Falster_2003" +trait_name = "leaf_area" +family = "Rubiaceae" +genus = "Eucalyptus" + +test_extract_error <- function(austraits){ + test_that("Error triggered", { + expect_error(austraits %>% extract_taxa()) + expect_error(austraits %>% extract_dataset()) + expect_error(austraits %>% extract_trait()) + }) +} + +walk(austraits, + ~ test_extract_error(.x)) + +test_extract_runs <- function(austraits, family, genus, dataset_id, trait_name){ + test_that("Function runs", { + expect_visible(austraits %>% extract_taxa(family = family)) + expect_visible(austraits %>% extract_taxa(genus = genus)) + expect_visible(extract_dataset(austraits, dataset_id = dataset_id)) + expect_visible(extract_trait(austraits, trait_names = trait_name)) + }) +} + +pmap(list(austraits = austraits, + family = family, + genus = genus, + dataset_id = dataset_id, + trait_name = trait_name), + test_extract_runs) + +test_extract_str <- function(austraits, family, genus, dataset_id, trait_name){ + test_that("extracted dataset has some structure as austraits build", { + subset <- extract_dataset(austraits, dataset_id = dataset_id) + trait_subset <- extract_trait(austraits, trait_names = trait_name) + + expect_s3_class(austraits, "austraits") + expect_equal(length(austraits), length(subset)) + expect_equal(sort(names(austraits)), sort(names(subset))) + + expect_equal(length(austraits), length(trait_subset)) + expect_equal(sort(names(austraits)), sort(names(trait_subset))) + expect_named(austraits, names(trait_subset)) + + expect_type(austraits %>% extract_taxa(family = family), "list") + expect_type(austraits %>% extract_taxa(genus = genus), "list") + + test_genus <- austraits %>% extract_taxa(genus = genus) + expect_equal(test_genus$taxa$genus %>% unique(), genus) + expect_equal(word(test_genus$taxa$taxon_name, 1)[1], genus) + expect_equal(word(test_genus$traits$taxon_name, 1)[1], genus) + + test_fam <- austraits %>% extract_taxa(family = family) + expect_equal(test_fam$taxa$family %>% unique(), family) + }) +} + +pmap(list(austraits = austraits, + family = family, + genus = genus, + dataset_id = dataset_id, + trait_name = trait_name), + test_extract_str) + +test_extract_output <- function(austraits, dataset_id, trait_name){ + subset <- extract_dataset(austraits, dataset_id = dataset_id) + trait_subset <- extract_trait(austraits, trait_names = trait_name) - expect_match("Bloomfield_2018", unique(subset_post$traits$dataset_id)) - expect_equal(1, dplyr::n_distinct(subset_post$traits$dataset_id)) - expect_match("leaf_mass_per_area", unique(trait_subset_post$traits$trait_name)) - expect_equal(1, dplyr::n_distinct(trait_subset_post$traits$trait_name)) -}) + test_that("extraction of dataset was successful", { + expect_match(dataset_id, unique(subset$traits$dataset_id)) + expect_equal(1, dplyr::n_distinct(subset$traits$dataset_id)) + expect_match(trait_name, unique(trait_subset$traits$trait_name)) + expect_equal(1, dplyr::n_distinct(trait_subset$traits$trait_name)) + + expect_match(dataset_id, unique(subset$traits$dataset_id)) + expect_equal(1, dplyr::n_distinct(subset$traits$dataset_id)) + expect_match(trait_name, unique(trait_subset$traits$trait_name)) + expect_equal(1, dplyr::n_distinct(trait_subset$traits$trait_name)) + }) +} +walk(austraits, + ~ test_extract_output(.x, dataset_id, trait_name)) diff --git a/tests/testthat/test-get_.R b/tests/testthat/test-get_.R deleted file mode 100644 index d3fb480..0000000 --- a/tests/testthat/test-get_.R +++ /dev/null @@ -1,34 +0,0 @@ -test_that("Function works", { - expect_visible(austraits_lite %>% summarise_austraits("family")) - expect_visible(austraits_lite %>% summarise_austraits("genus")) - expect_visible(austraits_lite %>% summarise_austraits("trait_name")) -}) - -test_that("Throws errors", { - expect_error(austraits_lite %>% summarise_austraits("observation_id")) - expect_error(austraits_lite %>% summarise_austraits("trait")) - expect_error(austraits_lite %>% summarise_austraits("unit")) - expect_error(austraits_lite %>% summarise_austraits("source")) - -}) - -test_that("Output correct", { - family <- austraits_lite %>% summarise_austraits("family") - genus <- austraits_lite %>% summarise_austraits("genus") - trait_nm <- austraits_lite %>% summarise_austraits("trait_name") - - expect_length(family, 5) - expect_length(genus, 5) - expect_length(trait_nm, 5) - - expect_named(family, expected = c("family", "n_records", "n_dataset", "n_taxa", "percent_total")) - expect_named(genus, expected = c("genus", "n_records", "n_dataset", "n_taxa", "percent_total")) - expect_named(trait_nm, expected = c("trait_name", "n_records", "n_dataset", "n_taxa", "percent_total")) - - actual_family <- austraits_lite$taxa$family %>% unique() - actual_genus <- austraits_lite$taxa$genus %>% unique() - - expect_equal(nrow(family), actual_family[! is.na(actual_family)] %>% length()) - expect_equal(nrow(genus), actual_genus[! is.na(actual_genus)] %>% length()) - expect_equal(nrow(trait_nm), austraits_lite$traits$trait_name %>% unique() %>% length()) -}) diff --git a/tests/testthat/test-join_.R b/tests/testthat/test-join_.R index 21cfab9..dd40e47 100644 --- a/tests/testthat/test-join_.R +++ b/tests/testthat/test-join_.R @@ -1,60 +1,51 @@ -austraits <- austraits_lite - -test_that("functions should work without warnings", { - expect_silent(join_locations(austraits)) - expect_silent(join_methods(austraits)) - expect_silent(join_contexts(austraits)) - expect_silent(join_taxonomy(austraits)) - expect_silent(join_all(austraits)) -}) - -test_that("structure doesn't change", { - expect_type((join_locations(austraits)), "list") - expect_type((join_methods(austraits)), "list") - expect_type((join_contexts(austraits)), "list") - expect_type((join_taxonomy(austraits)), "list") - expect_type((join_all(austraits)), "list") -}) - -test_that("variables are added", { - expect_true(ncol(join_locations(austraits)$traits) > ncol(austraits$traits)) - expect_true(ncol(join_methods(austraits)$traits) > ncol(austraits$traits)) - #expect_true(ncol(join_contexts(austraits)$traits) > ncol(austraits$traits)) #Need an example where I have context information to add - expect_true(ncol(join_taxonomy(austraits)$traits) > ncol(austraits$traits)) - expect_true(ncol(join_all(austraits)$traits) > ncol(austraits$traits)) -}) - -test_that("are the right variables added?", { - expect_true(any(names(join_locations(austraits)$traits) == c("latitude (deg)","longitude (deg)"))) - expect_true(any(names(join_taxonomy(austraits)$traits) == c("family", "genus", "taxonRank", "acceptedNameUsageID"))) - expect_true(any(names(join_methods(austraits)$traits) == c("methods", "year_collected_start", "year_collected_end", "collection_type"))) - #expect_true(any(names(join_contexts(austraits)$traits) == c("dataset_id","context_name","context_property","value"))) -}) - - - -austraits <- austraits_lite_post - -test_that("functions should work without warnings", { - expect_silent(join_locations(austraits)) - expect_silent(join_methods(austraits)) - expect_silent(join_contexts(austraits)) - expect_silent(join_taxonomy(austraits)) - expect_silent(join_all(austraits)) -}) - -test_that("structure doesn't change", { - expect_type((join_locations(austraits)), "list") - expect_type((join_methods(austraits)), "list") - expect_type((join_contexts(austraits)), "list") - expect_type((join_taxonomy(austraits)), "list") - expect_type((join_all(austraits)), "list") -}) - -test_that("variables are added", { - expect_true(ncol(join_locations(austraits)$traits) > ncol(austraits$traits)) - expect_true(ncol(join_methods(austraits)$traits) > ncol(austraits$traits)) - #expect_true(ncol(join_contexts(austraits)$traits) > ncol(austraits$traits)) #Need an example where I have context information to add - expect_true(ncol(join_taxonomy(austraits)$traits) > ncol(austraits$traits)) - expect_true(ncol(join_all(austraits)$traits) > ncol(austraits$traits)) -}) +library(purrr) + +austraits <- list(austraits_3.0.2_lite, + austraits_4.2.0_lite, + austraits_5.0.0_lite) + +test_join_success <- function(austraits){ + test_that("functions should work without warnings", { + expect_silent(join_locations(austraits)) + expect_silent(join_methods(austraits)) + expect_silent(join_contexts(austraits)) + expect_silent(join_taxonomy(austraits)) + expect_silent(join_all(austraits)) + }) +} + +map(austraits, + test_join_success) + +test_join_str <- function(austraits){ + test_that("structure doesn't change", { + expect_type((join_locations(austraits)), "list") + expect_type((join_methods(austraits)), "list") + expect_type((join_contexts(austraits)), "list") + expect_type((join_taxonomy(austraits)), "list") + expect_type((join_all(austraits)), "list") + }) +} + +map(austraits, + test_join_str) + +test_join_output <- function(austraits){ + test_that("variables are added", { + expect_true(ncol(join_locations(austraits)$traits) > ncol(austraits$traits)) + expect_true(ncol(join_methods(austraits)$traits) > ncol(austraits$traits)) + expect_true(ncol(join_contexts(austraits)$traits) > ncol(austraits$traits)) #Need an example where I have context information to add + expect_true(ncol(join_taxonomy(austraits)$traits) > ncol(austraits$traits)) + expect_true(ncol(join_all(austraits)$traits) > ncol(austraits$traits)) + + expect_true(any(names(join_locations(austraits)$traits) %in% c("latitude (deg)","longitude (deg)"))) + expect_true(any(names(join_taxonomy(austraits)$traits) %in%c("family", "genus"))) + expect_true(any(names(join_methods(austraits)$traits) %in%c("methods"))) + }) +} + +map(austraits, + test_join_output) + + + diff --git a/tests/testthat/test-load_austraits_.R b/tests/testthat/test-load_austraits_.R index a9df490..405de51 100644 --- a/tests/testthat/test-load_austraits_.R +++ b/tests/testthat/test-load_austraits_.R @@ -21,8 +21,7 @@ test_that("get_versions is working", { test_that("Right errors are tripped", { expect_error(load_austraits("3.0.6", path = path)) - expect_error(load_austraits(doi = "10.5281/zenodo.5112005", - path = path)) + expect_error(load_austraits(doi = "10.5281/zenodo.5112005", path = path)) expect_error(load_austraits(path = NULL)) }) diff --git a/tests/testthat/test-extract_taxa.R b/tests/testthat/test-misc_bugs_.R similarity index 50% rename from tests/testthat/test-extract_taxa.R rename to tests/testthat/test-misc_bugs_.R index 36c5e4f..d9e2892 100644 --- a/tests/testthat/test-extract_taxa.R +++ b/tests/testthat/test-misc_bugs_.R @@ -1,31 +1,6 @@ -library(stringr) - -austraits <- austraits_lite - -test_that("Error triggered", { - expect_error(austraits %>% extract_taxa()) -}) - -test_that("Function runs", { - expect_visible(austraits %>% extract_taxa(family = "Rubiaceae")) - expect_visible(austraits %>% extract_taxa(genus = "Melaleuca")) -}) - - -test_that("Output is correct", { - expect_type(austraits %>% extract_taxa(family = "Rubiaceae"), "list") - - genus = "Melaleuca" - test_aca <- austraits %>% extract_taxa(genus = genus) - expect_equal(test_aca$taxa$genus %>% unique(), genus) - expect_equal(word(test_aca$taxa$taxon_name, 1)[1], genus) - expect_equal(word(test_aca$traits$taxon_name, 1)[1], genus) - - family = "Rubiaceae" - test_prot <- austraits %>% extract_taxa(family = family) - expect_equal(test_prot$taxa$family %>% unique(), family) - }) +# Miscellaneous bugs that have been raised +# Want this file to come after loading so that dataset is available test_that("Dataframe is extracted correctly", { austraits <- load_austraits(version = "3.0.2", path = "ignore/data/austraits") diff --git a/tests/testthat/test-plot_.R b/tests/testthat/test-plot_.R index b9931f4..78db5c5 100644 --- a/tests/testthat/test-plot_.R +++ b/tests/testthat/test-plot_.R @@ -1,14 +1,10 @@ -austraits <- austraits_lite test_that("Function doesn't throw error", { - expect_invisible(austraits %>% plot_trait_distribution_beeswarm("wood_density", "dataset_id", "Westoby_2014")) - expect_invisible((austraits %>% join_locations())$trait %>% plot_locations()) -}) - -# austraits <- austraits_lite_post -# -# test_that("Function doesn't throw error", { -# expect_invisible(austraits %>% plot_trait_distribution_beeswarm("leaf_mass_per_area", "dataset_id", "Bloomfield_2018")) -# expect_invisible((austraits %>% join_locations())$trait %>% plot_locations()) -# }) -# + expect_invisible(austraits_3.0.2_lite %>% plot_trait_distribution_beeswarm("wood_density", "dataset_id", "Westoby_2014")) + expect_invisible(austraits_5.0.0_lite %>% plot_trait_distribution_beeswarm("leaf_mass_per_area", "dataset_id", "Bloomfield_2018")) + + # this function is currently really slow, blokcing effective testing + expect_invisible((austraits_5.0.0_lite %>% extract_trait("wood_density") %>% join_locations())$trait %>% plot_locations()) + expect_invisible((austraits_5.0.0_lite %>% extract_trait("wood_density") %>% join_locations())$trait %>% plot_locations()) + }) + diff --git a/tests/testthat/test-summarise_.R b/tests/testthat/test-summarise_.R deleted file mode 100644 index 6718ed4..0000000 --- a/tests/testthat/test-summarise_.R +++ /dev/null @@ -1,78 +0,0 @@ -austraits <- austraits_lite - -test_that("Function output is correct", { - target <- austraits$traits %>% - dplyr::group_by(trait_name, observation_id) %>% - dplyr::summarise(dplyr::n()) %>% - dplyr::filter(`dplyr::n()` > 1) %>% - dplyr::select(trait_name, observation_id) - - target_ls <- purrr::map2(target$trait_name, target$observation_id, - ~ dplyr::filter(austraits$traits, trait_name == .x & observation_id == .y)) - - original <- austraits$traits %>% - dplyr::group_by(trait_name, observation_id) %>% - dplyr::summarise(dplyr::n()) %>% - dplyr::filter(! `dplyr::n()` > 1) %>% - dplyr::select(trait_name, observation_id) - - original_df <- purrr::map2_dfr(original$trait_name, original$observation_id, - ~ dplyr::filter(austraits$traits, trait_name == .x & observation_id == .y)) - - # Total number of multiple observations minus eventual number of summarised obs - ( target_ls %>% dplyr::bind_rows() %>% nrow() ) - nrow(target) - - # The final output should have nrow as original plus eventual number of summarised obs - expect_equal( summarise_trait_means(austraits$traits) %>% nrow(), ( nrow(original) + nrow(target)) ) - -}) - -test_that("Function throws error", { - expect_error(summarise_trait_means(austraits)) - expect_error(summarise_trait_means(austraits$sites)) - expect_error(summarise_trait_means(austraits$taxa)) -}) - -test_that("Function doesn't complain", { - expect_silent(summarise_trait_means(austraits$traits)) - expect_visible(summarise_trait_means(austraits$traits)) - expect_named(summarise_trait_means(austraits$traits)) - expect_type(summarise_trait_means(austraits$traits), "list") -}) - - -test_that("Function works", { - expect_visible(austraits_lite %>% summarise_austraits("family")) - expect_visible(austraits_lite %>% summarise_austraits("genus")) - expect_visible(austraits_lite %>% summarise_austraits("trait_name")) -}) - -test_that("Throws errors", { - expect_error(austraits_lite %>% summarise_austraits("observation_id")) - expect_error(austraits_lite %>% summarise_austraits("trait")) - expect_error(austraits_lite %>% summarise_austraits("unit")) - expect_error(austraits_lite %>% summarise_austraits("source")) - -}) - -test_that("Output correct", { - family <- austraits_lite %>% summarise_austraits("family") - genus <- austraits_lite %>% summarise_austraits("genus") - trait_nm <- austraits_lite %>% summarise_austraits("trait_name") - - expect_length(family, 5) - expect_length(genus, 5) - expect_length(trait_nm, 5) - - expect_named(family, expected = c("family", "n_records", "n_dataset", "n_taxa", "percent_total")) - expect_named(genus, expected = c("genus", "n_records", "n_dataset", "n_taxa", "percent_total")) - expect_named(trait_nm, expected = c("trait_name", "n_records", "n_dataset", "n_taxa", "percent_total")) - - family_vec <- austraits_lite$taxa$family %>% unique() - genus_vec <- austraits_lite$taxa$genus %>% unique() - - expect_equal(nrow(family), family_vec[!is.na(family_vec)] %>% length()) - expect_equal(nrow(genus), genus_vec[!is.na(genus_vec)] %>% length()) - expect_equal(nrow(trait_nm), austraits_lite$traits$trait_name %>% unique() %>% length()) -}) - diff --git a/tests/testthat/test-summarise_austraits.R b/tests/testthat/test-summarise_austraits.R new file mode 100644 index 0000000..43aa3c4 --- /dev/null +++ b/tests/testthat/test-summarise_austraits.R @@ -0,0 +1,55 @@ +library(purrr) + +austraits <- list(austraits_3.0.2_lite, + austraits_4.2.0_lite, + austraits_5.0.0_lite) + +test_summarise <- function(austraits){ + test_that("Function works", { + expect_visible(austraits %>% summarise_austraits("family")) + expect_visible(austraits %>% summarise_austraits("genus")) + expect_visible(austraits %>% summarise_austraits("trait_name")) + }) +} + +map(austraits, + ~test_summarise(.x)) + +test_summarise_errors <- function(austraits){ + test_that("Throws errors", { + expect_error(austraits %>% summarise_austraits("observation_id")) + expect_error(austraits %>% summarise_austraits("trait")) + expect_error(austraits %>% summarise_austraits("unit")) + expect_error(austraits %>% summarise_austraits("source")) + + }) +} + +map(austraits, + ~test_summarise_errors(.x)) + +test_summarise_output <- function(austraits){ + test_that("Output correct", { + family <- austraits %>% summarise_austraits("family") + genus <- austraits %>% summarise_austraits("genus") + trait_nm <- austraits %>% summarise_austraits("trait_name") + + expect_length(family, 5) + expect_length(genus, 5) + expect_length(trait_nm, 5) + + expect_named(family, expected = c("family", "n_records", "n_dataset", "n_taxa", "percent_total")) + expect_named(genus, expected = c("genus", "n_records", "n_dataset", "n_taxa", "percent_total")) + expect_named(trait_nm, expected = c("trait_name", "n_records", "n_dataset", "n_taxa", "percent_total")) + + actual_family <- austraits$taxa$family %>% unique() + actual_genus <- austraits$taxa$genus %>% unique() + + expect_equal(nrow(family), actual_family[! is.na(actual_family)] %>% length()) + expect_equal(nrow(genus), actual_genus[! is.na(actual_genus)] %>% length()) + expect_equal(nrow(trait_nm), austraits$traits$trait_name %>% unique() %>% length()) + }) +} + +map(austraits, + ~ test_summarise_output(.x)) diff --git a/tests/testthat/test-summarise_trait_means.R b/tests/testthat/test-summarise_trait_means.R new file mode 100644 index 0000000..5a331be --- /dev/null +++ b/tests/testthat/test-summarise_trait_means.R @@ -0,0 +1,35 @@ +austraits <- austraits_3.0.2_lite + +test_that("Function output is correct", { + target <- austraits$traits %>% + dplyr::group_by(trait_name, observation_id) %>% + dplyr::summarise(dplyr::n()) %>% + dplyr::filter(`dplyr::n()` > 1) %>% + dplyr::select(trait_name, observation_id) + + original <- austraits$traits %>% + dplyr::group_by(trait_name, observation_id) %>% + dplyr::summarise(dplyr::n()) %>% + dplyr::filter(! `dplyr::n()` > 1) %>% + dplyr::select(trait_name, observation_id) + + # Total number of multiple observations minus eventual number of summarised obs + # ( target_ls %>% dplyr::bind_rows() %>% nrow() ) - nrow(target) + + # The final output should have nrow as original plus eventual number of summarised obs + expect_silent(out <- summarise_trait_means(austraits$traits)) + expect_visible(out) + expect_equal( out %>% nrow(), ( nrow(original) + nrow(target)) ) + + expect_named(out) + expect_type(out, "list") +}) + +test_that("Function throws error", { + expect_error(summarise_trait_means(austraits)) + expect_error(summarise_trait_means(austraits$sites)) + expect_error(summarise_trait_means(austraits$taxa)) +}) + + + diff --git a/tests/testthat/test-trait_bind_sep.R b/tests/testthat/test-trait_bind_sep.R index deb1ef3..ff4a2c3 100644 --- a/tests/testthat/test-trait_bind_sep.R +++ b/tests/testthat/test-trait_bind_sep.R @@ -1,5 +1,5 @@ #Pull in data -austraits <- austraits_lite +austraits <- austraits_3.0.2_lite #Extract a dataset dataset_id <- c("Falster_2005_2") @@ -16,7 +16,9 @@ test_that("structure of dataframes is what we expect", { expect_equal(nrow(subset$traits), nrow(seperated)) expect_equal(ncol(subset$traits), ncol(seperated)) expect_equal(colnames(subset$traits), colnames(seperated)) - expect_equal(str(subset$traits), str(seperated)) + # Check datasets have the same structure. + #This works for all cols except levels in value type, so we'll remove that for the test + expect_equal(subset$traits %>% select(-value_type) %>% arrange(dataset_id, observation_id, trait_name, value), seperated %>% select(-value_type)%>% arrange(dataset_id, observation_id, trait_name, value)) }) test_that("Errors with incorrect argument inputs", { diff --git a/tests/testthat/test-trait_pivot_.R b/tests/testthat/test-trait_pivot_.R index 213a150..2a133c0 100644 --- a/tests/testthat/test-trait_pivot_.R +++ b/tests/testthat/test-trait_pivot_.R @@ -1,29 +1,50 @@ -#Pull in data -austraits <- austraits_lite -wide_data <- austraits$traits %>% summarise_trait_means() %>% trait_pivot_wider() +library(purrr) -test_that("function shouldn't complain and throw errors", { - expect_silent(austraits$traits %>% summarise_trait_means() %>% trait_pivot_wider()) -}) +# austraits_lite_small <- +# austraits_lite %>% +# extract_dataset(c( "Baker_2019", "Falster_2003")) +# +# +# austraits_lite_post_small <- +# austraits_lite_post %>% +# extract_dataset(c( "Baker_2019", "Falster_2003")) -test_that("functions should throw error when provided wrong input", { -expect_error(trait_pivot_wider(austraits), label = "The austraits object is a list. Try austraits$trait") -expect_error(trait_pivot_wider(austraits$sites), label = "Relevent column names from trait data frame not found") -expect_error(trait_pivot_wider(austraits$methods), label = "Relevent column names from trait data frame not found") -expect_error(trait_pivot_longer(austraits), label = "Cannot gather an already long format dataframe") -}) +austraits <- list(austraits_3.0.2_lite, + austraits_4.2.0_lite, + austraits_5.0.0_lite) -test_that("input and output are of expected structure", { -expect_match(class(wide_data), "list") -expect_equal(class(wide_data), "list") -expect_equal(wide_data %>% length, 5) -}) +test_that("pivot on subset of data", { + + # austraits_lite tests + expect_silent( + wide_data <- austraits_3.0.2_lite %>% + pluck("traits") %>% + summarise_trait_means() %>% trait_pivot_wider() + ) + + expect_type(wide_data, "list") + expect_named(wide_data) -test_that("before and after pivots match", { + # before and after pivots match" + #Checking if widened data has the same length as variables that we are spreading expect_equal(length(wide_data), length(c("value", "unit", "date", "value_type", "replicates"))) #Checking number of columns of widened data matches the number of ID columns + number of traits - expect_equal(ncol(wide_data[[1]]), (austraits$traits %>% dplyr::select(-c(trait_name, value, unit, date, value_type, replicates)) %>% ncol()) + (unique(austraits$traits$trait_name) %>% length()) ) + expect_equal(ncol(wide_data$value), (austraits_3.0.2_lite$traits %>% dplyr::select(-c(trait_name, value, unit, date, value_type, replicates)) %>% ncol()) + (unique(austraits_3.0.2_lite$traits$trait_name) %>% length()) ) #Checking the number of columns matches original data after pivoting wide and then back to long again - expect_equal(ncol(austraits$traits), ncol(trait_pivot_longer(wide_data)) ) + expect_equal(ncol(austraits_3.0.2_lite$traits), ncol(trait_pivot_longer(wide_data)) ) }) + + +# austraits_list and austraits_lite_post +test_pivot_errors <- function(austraits){ + test_that("functions should throw error when provided wrong input", { + expect_error(trait_pivot_wider(austraits), label = "The austraits object is a list. Try austraits$trait") + expect_error(trait_pivot_wider(austraits$taxa), label = "Relevent column names from trait data frame not found") + expect_error(trait_pivot_wider(austraits$methods), label = "Relevent column names from trait data frame not found") + expect_error(trait_pivot_longer(austraits), label = "Cannot gather an already long format dataframe") + }) +} + +walk(austraits, + test_pivot_errors) diff --git a/vignettes/structure.Rmd b/vignettes/structure.Rmd index 2a21bbe..fd5dc0f 100644 --- a/vignettes/structure.Rmd +++ b/vignettes/structure.Rmd @@ -267,12 +267,12 @@ The core components are defined as follows. Name given to taxon in the original data supplied by the authors - cleaned_name + aligned_name Name of the taxon after implementing any changes encoded for this taxon in the metadata file in the specified correpsonding `dataset_id`. taxonIDClean - Where it could be indentified, the `taxonID` of the cleaned_name for this taxon in the APC. + Where it could be indentified, the `taxonID` of the aligned_name for this taxon in the APC. taxonomicStatusClean @@ -280,7 +280,7 @@ The core components are defined as follows. alternativeTaxonomicStatusClean - The status of alternative records with the name `cleaned_name` in the APC. + The status of alternative records with the name `aligned_name` in the APC. acceptedNameUsageID diff --git a/vignettes/structure.Rmd.orig b/vignettes/structure.Rmd.orig index f5bf6ce..b186942 100644 --- a/vignettes/structure.Rmd.orig +++ b/vignettes/structure.Rmd.orig @@ -22,13 +22,48 @@ library(austraits) library(dplyr) library(stringr) +my_kable_styling_html <- function(...) { + kableExtra::kable(...) %>% + kableExtra::kable_styling(..., + bootstrap_options = c("striped", "hover", "condensed", "responsive"), + full_width = FALSE, + position = "left" + ) %>% + # hack to add margin to plot + gsub('style="width: auto ', 'style="margin-left:30px; width: auto ', .) #this dot is trigger NOTE in RMD Check +} + +#' pdf styling for kable tables +#' @param ...arguments passed on to kableExtra::kable +#' @keywords internal +#' @export +my_kable_styling_pdf <- function(...) { + kableExtra::kable(...) +} + # default for table format if(knitr::is_html_output()) { options(knitr.table.format = "html") - my_kable_styling <- austraits::my_kable_styling_html + my_kable_styling <- my_kable_styling_html } else { options(knitr.table.format = "latex") - my_kable_styling <- austraits::my_kable_styling_pdf + my_kable_styling <- my_kable_styling_pdf +} + +#' Convert a list with single entries to dataframe +#' @param my_list a list with single entries +#' @return a tibble with two columns +#' @examples list1_to_df(as.list(iris)[2]) +#' @keywords internal +#' @export +list1_to_df <- function(my_list) { + + for(f in names(my_list)) { + if(is.null(my_list[[f]])) + my_list[[f]] <- NA + } + + tidyr::tibble(key = names(my_list), value = unlist(my_list)) } austraits <- austraits:::austraits_lite