(v3.0.1.9097) Never remove released taxa; link orthographic variants; registry line in NEWS

- taxonomy build: released taxa (since v2.0.0) that are missing are restored from their
  last release with their old code and last known status, and are exempt from later
  removals (decision by Matthijs S. Berends)
- exceptions are retired on purpose in data-raw/microorganisms_files/mo_code_retirements.csv
  with a reason: other organisms with the same genus name (e.g. the Graphium butterflies,
  wrongly in the Fungi until v3.0.1) and taxa whose genus is now only known in another
  domain; as.mo() translates these codes to NA with that reason
- synonyms without a current name are linked to an accepted name in the same genus that
  only differs by a Latin gender ending (e.g. Candida glabratus -> Nakaseomyces glabratus)
- placeholders such as "(unknown class)" never become records; codes of manually added
  records are matched by domain and name
- integrity rule released_taxon_missing; known defects of the data on main updated

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
This commit is contained in:
dr. M.S. (Matthijs) BerendsandClaude Opus 5.5 committed 2026-10-03 14:15:08 +02:00
1 parent d683b9e7c6
commit 83a4853936
12 files changed
+5326 -23

No files matched your search

+1 -1
View File
@@ -1,5 +1,5 @@
Package: AMR
Version: 3.0.1.9096
Version: 3.0.1.9097
Date: 2026-10-03
Title: Antimicrobial Resistance Data Analysis
Description: Functions to simplify and standardise antimicrobial resistance (AMR)
+2 -2
View File
@@ -1,4 +1,4 @@
# AMR 3.0.1.9096
# AMR 3.0.1.9097
Planned as v3.1.0, mid October 2026.
@@ -42,7 +42,7 @@ Planned as v3.1.0, mid October 2026.
* New `amr_course()` to download and unpack course or webinar materials from GitHub in one call
* Typed missing value constants `NA_ab_` and `NA_mo_`, for use in pipelines that need missing values of a specific class
* New `wisca_plot()` to assess the susceptibility and incidence distributions from the Monte Carlo simulations
* MO codes of all releases since v2.0.0 are now reliably translated to their current code, also for taxa that moved to another domain; a registry guarantees that an MO code never gets another meaning
* A registry of all microbial IDs (MO codes) since v2.0.0 now prevents existing IDs from being reused or mixed up; IDs of earlier releases are translated to the current ID of the same taxon
### Fixed
* Streptomycin breakpoints imported from WHONET were coded as streptoduocin (`STR`) instead of streptomycin (`STR1`)
+3 -1
View File
@@ -1296,9 +1296,11 @@ replace_old_mo_codes <- function(x, property) {
}
if (any(is.na(current))) {
gone <- MO_RETIRED_CODES$fullname[match(retired[is.na(current)], MO_RETIRED_CODES$old_mo)]
reason <- MO_RETIRED_CODES$reason[match(retired[is.na(current)], MO_RETIRED_CODES$old_mo)]
gone <- ifelse(is.na(reason), gone, paste0(gone, ": ", reason))
msg <- paste0(
msg, sum(is.na(current)), ifelse(sum(is.na(current)) == 1, " was", " were"),
" set to NA, as the taxon is not in the current data set anymore (", listing(paste0(retired[is.na(current)], " = ", gone)), "). "
" set to NA, as the taxon is not in the current data set (", listing(paste0(retired[is.na(current)], " = ", gone)), "). "
)
}
warning_(msg, "Please update your MO codes with {.help [{.fun as.mo}](AMR::as.mo)}.")
BIN
View File
Binary file not shown.
+5 -1
View File
@@ -638,13 +638,17 @@ by_rank <- as.character(microorganisms$mo)[match(
paste(mo_name_without_suffix(retired$fullname), retired$rank),
paste(mo_name_without_suffix(microorganisms$fullname), microorganisms$rank)
)]
mo_retirements <- read_mo_retirements(".")
pre_commit_lst$MO_RETIRED_CODES <- data.frame(
old_mo = retired$mo,
mo = ifelse(is.na(current_mo), by_rank, current_mo),
fullname = retired$fullname,
# codes retired on purpose, because their taxon was another organism, never lead to a taxon
reason = mo_retirements$reason[match(retired$mo, mo_retirements$mo)],
stringsAsFactors = FALSE
)
rm(mo_registry, mo_renames, retired, renamed, current_mo, by_rank)
pre_commit_lst$MO_RETIRED_CODES$mo[!is.na(pre_commit_lst$MO_RETIRED_CODES$reason)] <- NA_character_
rm(mo_registry, mo_renames, mo_retirements, retired, renamed, current_mo, by_rank)
# Export to package as internal data ----
# usethis::use_data() must receive unquoted object names, which is not flexible at all.
@@ -454,6 +454,8 @@ add_missing_parents <- function(taxonomy, current_gbif) {
filter(.data[[rank_name]] != "") %>%
distinct(across(all_of(unique(c("domain", rank_levels[seq_len(which(rank_levels == rank_name))]))))) %>%
mutate(fullname = .data[[rank_name]], rank = rank_name) %>%
# placeholders such as "(unknown class)" are no taxa
filter(fullname %unlike% "^[(]unknown") %>%
anti_join(
taxonomy %>% filter(rank == rank_name),
by = unique(c("domain", setNames(rank_name, rank_name), "rank"))
@@ -483,7 +485,8 @@ add_missing_parents <- function(taxonomy, current_gbif) {
}))
# species implied by subspecies but missing as a species-rank row
missing_species <- taxonomy %>%
filter(species != "") %>%
# placeholders such as "(unknown species)" are no taxa
filter(species != "", genus %unlike% "^[(]unknown", species %unlike% "^[(]unknown") %>%
distinct(domain, genus, species, .keep_all = TRUE) %>%
select(domain:species) %>%
mutate(fullname = paste(genus, species), rank = "species") %>%
@@ -1538,6 +1541,16 @@ review(
taxonomy %>% filter(.resolve == "remove") %>% count(genus, domain, best_domain, source, sort = TRUE),
"Records removed as homonyms of a genus in another domain"
)
# these are other organisms with the same genus name, so they may never be restored as released taxa later on
# (e.g. the Graphium butterflies, which were in the Fungi until v3.0.1), saved for 'Restore released taxa'
saveRDS(
taxonomy %>%
filter(.resolve == "remove") %>%
distinct(fullname, .keep_all = TRUE) %>%
transmute(fullname, domain, genus, best_domain),
"data-raw/taxonomy_homonyms_removed.rds",
version = 2
)
taxonomy <- taxonomy %>%
filter(.resolve != "remove") %>%
mutate(
@@ -2527,6 +2540,215 @@ taxonomy <- taxonomy %>%
distinct(fullname, .keep_all = TRUE)
message("Removed ", n_before - nrow(taxonomy), " nonsense names")
# Restore released taxa ---------------------------------------------------------------------------
# A taxon that was part of a release (since v2.0.0) is never removed, since users have stored its MO code
# (decision by Matthijs S. Berends, 3 October 2026). Taxa that are missing now, e.g. because they are not
# validly published or not clinically relevant, are restored from their last release, with their old code and
# their last known status. The only exception: records that were removed as homonyms above, i.e. other organisms
# with the same genus name (such as the Graphium butterflies, which were wrongly in the Fungi until v3.0.1).
# Their codes are retired, with the reason, in data-raw/microorganisms_files/mo_code_retirements.csv, and are
# translated to NA by as.mo() with that reason, so that they never lead to a wrong organism and are never reused.
restore_registry <- read_mo_registry(".")
restore_renames <- read_mo_renames(".")
restore_registry$expected_name <- restore_registry$fullname
renamed <- match(restore_registry$mo, restore_renames$mo)
restore_registry$expected_name[!is.na(renamed)] <- restore_renames$new_name[renamed[!is.na(renamed)]]
missing_released <- restore_registry %>%
filter(
!mo_name_without_suffix(expected_name) %in% mo_name_without_suffix(taxonomy$fullname),
# species groups are added at the end of this script
rank != "species group"
)
homonyms_removed <- if (file.exists("data-raw/taxonomy_homonyms_removed.rds")) {
readRDS("data-raw/taxonomy_homonyms_removed.rds")
} else {
tibble(fullname = character(0), domain = character(0), genus = character(0), best_domain = character(0))
}
# codes to retire: released taxa that are other organisms than the genus with their name
retirements_file <- "data-raw/microorganisms_files/mo_code_retirements.csv"
retirements <- utils::read.csv(retirements_file, colClasses = "character", na.strings = character(0))
new_retirements <- missing_released %>%
inner_join(
homonyms_removed %>% select(fullname, removed_domain = domain, removed_genus = genus, best_domain),
by = c("expected_name" = "fullname")
) %>%
filter(!mo %in% retirements$mo) %>%
transmute(
mo,
fullname = expected_name,
reason = paste0(
"another organism (", removed_domain, ") with the same genus name as ", removed_genus, " (", best_domain, ")"
),
decided_by = "taxonomy build (automatic, homonym of a genus in another domain)",
date = as.character(Sys.Date())
)
review(new_retirements, "Released MO codes that are retired, since their taxon is another organism with the same genus name")
if (nrow(new_retirements) > 0) {
retirements <- bind_rows(retirements, new_retirements) %>% arrange(mo)
utils::write.csv(retirements, retirements_file, row.names = FALSE, na = "")
}
missing_released <- missing_released %>%
filter(!mo %in% retirements$mo)
# get the full records from the releases in which these taxa were last present
read_release_data <- function(tag) {
tmp <- tempfile(fileext = ".rda")
on.exit(unlink(tmp))
if (!identical(system2("git", c("show", paste0(tag, ":data/microorganisms.rda")), stdout = tmp), 0L)) {
stop("Could not read data/microorganisms.rda of release ", tag, call. = FALSE)
}
env <- new.env()
load(tmp, envir = env)
out <- as.data.frame(env$microorganisms, stringsAsFactors = FALSE)
out$mo <- as.character(out$mo)
# until v3.0.1, `kingdom` contained what is now called `domain`
if (!"domain" %in% colnames(out)) {
out$domain <- out$kingdom
out$domain[out$domain == "(unknown kingdom)"] <- "(unknown domain)"
out$kingdom <- NA_character_
}
out
}
released_records <- bind_rows(lapply(unique(missing_released$last_release), function(tag) {
read_release_data(tag) %>%
filter(mo %in% missing_released$mo[missing_released$last_release == tag]) %>%
select(any_of(c(
"mo", "fullname", "status", "domain", "kingdom", "phylum", "class", "order", "family", "genus", "species",
"subspecies", "rank", "ref", "lpsn_renamed_to", "mycobank_renamed_to", "gbif_renamed_to", "prevalence"
))) %>%
mutate(across(c(fullname, domain:subspecies), ascii_names))
}))
# a released taxon of which the genus now only exists in another domain cannot be restored consistently: it may be
# the same organism in a new classification, or another organism (homonym), which cannot be decided automatically.
# Its code is retired (as.mo() then gives NA with this reason, and translates it if the name exists elsewhere).
genus_domains <- taxonomy %>%
filter(rank == "genus") %>%
distinct(genus, domain)
conflicting <- released_records %>%
filter(
genus != "",
!paste(domain, genus) %in% paste(genus_domains$domain, genus_domains$genus),
genus %in% genus_domains$genus
) %>%
left_join(genus_domains %>% group_by(genus) %>% summarise(now_in = toString(domain)), by = "genus")
conflict_retirements <- conflicting %>%
transmute(
mo,
fullname,
reason = paste0("its genus ", genus, " is now only known in another domain (", now_in, ") and could not be restored"),
decided_by = "taxonomy build (automatic, genus in another domain), NEEDS REVIEW",
date = as.character(Sys.Date())
) %>%
filter(!mo %in% read_mo_retirements(".")$mo)
review(conflict_retirements, "Released MO codes that are retired, since their genus is now only known in another domain")
if (nrow(conflict_retirements) > 0) {
utils::write.csv(
bind_rows(read_mo_retirements("."), conflict_retirements) %>% arrange(mo),
retirements_file,
row.names = FALSE, na = ""
)
}
released_records <- released_records %>%
filter(!mo %in% conflicting$mo)
# the current kingdom of prokaryotes (until v3.0.1, the kingdom was the domain) and the current higher taxonomy
# of the genus if it still exists
kingdom_of_phylum <- taxonomy %>%
filter(domain %in% c("Bacteria", "Archaea"), phylum != "", kingdom != "") %>%
count(domain, phylum, kingdom) %>%
arrange(desc(n)) %>%
distinct(domain, phylum, .keep_all = TRUE) %>%
select(domain, phylum, new_kingdom = kingdom)
lineage_of_genus <- taxonomy %>%
filter(rank == "genus") %>%
distinct(domain, genus, .keep_all = TRUE) %>%
select(domain, genus, g_kingdom = kingdom, g_phylum = phylum, g_class = class, g_order = order, g_family = family)
restored <- released_records %>%
left_join(kingdom_of_phylum, by = c("domain", "phylum")) %>%
left_join(lineage_of_genus, by = c("domain", "genus")) %>%
mutate(
kingdom = case_when(
!is.na(g_kingdom) ~ g_kingdom,
domain %in% c("Bacteria", "Archaea") & !is.na(new_kingdom) ~ new_kingdom,
domain %in% c("Bacteria", "Archaea") ~ "(unknown kingdom)",
TRUE ~ coalesce(kingdom, domain)
),
phylum = coalesce(g_phylum, phylum),
class = coalesce(g_class, class),
order = coalesce(g_order, order),
family = coalesce(g_family, family),
across(kingdom:subspecies, function(x) if_else(is.na(x), "", x)),
# older releases used placeholders such as "(unknown class)", which would become records themselves
across(phylum:family, function(x) if_else(x %like% "^[(]unknown", "", x)),
# older releases also had other status values, such as "not validly published"
status = if_else(status %in% c("accepted", "synonym", "unknown"), status, "unknown"),
source = "manually added"
) %>%
select(-mo, -new_kingdom, -starts_with("g_"))
review(
restored %>% count(domain, rank, status, sort = TRUE),
"Released taxa that were missing and are restored (by domain, rank and status)"
)
review(
restored %>% filter(prevalence < 2) %>% select(fullname, domain, rank, status, ref, prevalence),
"Restored released taxa that are clinically relevant"
)
n_before <- nrow(taxonomy)
taxonomy <- taxonomy %>%
bind_rows(restored) %>%
add_missing_parents(current_gbif) %>%
arrange(fullname, source_prio(source)) %>%
distinct(fullname, .keep_all = TRUE) %>%
compute_prevalence()
message("Restored ", nrow(restored), " released taxa (", nrow(taxonomy) - n_before, " records including their parents)")
rm(restore_registry, restore_renames, renamed, missing_released, homonyms_removed, retirements, new_retirements,
released_records, genus_domains, conflicting, conflict_retirements, kingdom_of_phylum, lineage_of_genus, restored)
# Link orthographic variants without a current name ----------------------------------------------
# A synonym without a current name of which the epithet only differs from an accepted name in the same genus by a
# Latin gender ending (e.g. -us, -a, -um) is an orthographic variant of that name: under the nomenclatural codes,
# such epithets are variants of one name, so two valid species in one genus cannot differ only in this way.
# E.g. 'Nakaseomyces glabrata' -> 'Nakaseomyces glabratus' (from Candida glabrata, renamed in 2022).
epithet_stem <- function(x) {
sub("(us|um|a|is|e|er|ra|rum)$", "", x)
}
variant_candidates <- taxonomy %>%
filter(
status == "synonym",
is.na(lpsn_renamed_to), is.na(mycobank_renamed_to), is.na(gbif_renamed_to),
rank %in% c("species", "subspecies")
) %>%
mutate(stem = epithet_stem(if_else(rank == "species", species, subspecies)))
accepted_variants <- taxonomy %>%
filter(status == "accepted", rank %in% c("species", "subspecies")) %>%
mutate(stem = epithet_stem(if_else(rank == "species", species, subspecies))) %>%
select(domain, genus, rank, stem, species_acc = species, target = fullname, t_lpsn = lpsn, t_mycobank = mycobank, t_gbif = gbif)
variant_links <- variant_candidates %>%
inner_join(accepted_variants, by = c("domain", "genus", "rank", "stem")) %>%
# for subspecies, the species must be the same variant too
filter(rank == "species" | epithet_stem(species) == epithet_stem(species_acc)) %>%
# only unambiguous links, and the target must have an identifier to link to
group_by(fullname) %>%
filter(n() == 1) %>%
ungroup() %>%
filter(!is.na(t_lpsn) | !is.na(t_mycobank) | !is.na(t_gbif))
review(variant_links %>% select(fullname, target, source), "Orthographic variants linked to their accepted name")
taxonomy <- taxonomy %>%
left_join(variant_links %>% select(fullname, t_lpsn, t_mycobank, t_gbif), by = "fullname") %>%
mutate(
lpsn_renamed_to = coalesce(lpsn_renamed_to, t_lpsn),
mycobank_renamed_to = coalesce(mycobank_renamed_to, t_mycobank),
gbif_renamed_to = coalesce(gbif_renamed_to, t_gbif)
) %>%
select(-t_lpsn, -t_mycobank, -t_gbif)
rm(variant_candidates, accepted_variants, variant_links)
# Break cycles of synonyms ------------------------------------------------------------------------
# Sources can contradict each other, e.g. in 2026 GBIF listed Capillidium denaeosporus as synonym of
@@ -2972,9 +3194,10 @@ taxonomy %>%
# filter(mo != "")
# keep the codes from manually added ones
# (by domain and name, so that a code can never end up in another domain)
manual_mos <- as.character(existing_mo_tbl$mo)[match(
taxonomy$fullname[taxonomy$source == "manually added"],
existing_mo_tbl$fullname
paste(taxonomy$domain, taxonomy$fullname)[taxonomy$source == "manually added"],
paste(existing_mo_tbl$domain, existing_mo_tbl$fullname)
)]
taxonomy$mo[taxonomy$source == "manually added"][!is.na(manual_mos)] <- manual_mos[!is.na(manual_mos)]
@@ -3595,26 +3818,30 @@ taxonomy %>%
# Remove childless non-bacterial genera -----------------------------------------------------------
# this removes all genera that have no species, except for the domain of Bacteria.
# this removes all genera that have no species, except for the domain of Bacteria, and except for released taxa
# (a taxon that was part of a release is never removed, see 'Restore released taxa')
released_names <- mo_name_without_suffix(read_mo_registry(".")$fullname)
taxonomy <- taxonomy %>%
filter(
rank != "genus" |
domain == "Bacteria" |
genus %in% taxonomy$genus[taxonomy$rank == "species"]
genus %in% taxonomy$genus[taxonomy$rank == "species"] |
mo_name_without_suffix(fullname) %in% released_names
)
# then remove all childless upper taxonomy caused by this
# then remove all childless upper taxonomy caused by this (again except for released taxa)
for (rank_name in c("family", "order", "class", "phylum", "kingdom")) {
has_children <- taxonomy %>%
filter(rank != rank_name, .data[[rank_name]] != "") %>%
distinct(.data[[rank_name]]) %>%
pull()
n_before <- nrow(taxonomy)
taxonomy <- taxonomy %>%
filter(!(rank == rank_name & !fullname %in% has_children))
filter(!(rank == rank_name & !fullname %in% has_children & !mo_name_without_suffix(fullname) %in% released_names))
message("Removed ", n_before - nrow(taxonomy), " childless ", rank_name, " entries")
}
rm(released_names)
# records that were only inferred by this script get the same label as before
taxonomy$source[taxonomy$source == "inferred"] <- "manually added"
@@ -3649,7 +3876,7 @@ review(mo_synonyms_without_current_name(taxonomy), "Synonyms without a current n
# the integrity rules of the data set and the MO code registry (shared with the unit tests in
# tests/testthat/helper-microorganisms.R): these must never fail, as the package and its users rely on them
integrity_issues <- mo_integrity_issues(taxonomy, registry = mo_registry, renames = mo_renames)
integrity_issues <- mo_integrity_issues(taxonomy, registry = mo_registry, renames = mo_renames, retirements = read_mo_retirements("."))
if (!is.null(mo_integrity_report(integrity_issues))) {
stop("The new data set breaks integrity rules, fix the cause in this script:\n",
mo_integrity_report(integrity_issues),
@@ -3727,7 +3954,7 @@ taxonomy <- taxonomy %>%
AMR:::dataset_UTF8_to_ASCII()
# check again after the conversion to ASCII
integrity_issues <- mo_integrity_issues(taxonomy, registry = mo_registry, renames = mo_renames)
integrity_issues <- mo_integrity_issues(taxonomy, registry = mo_registry, renames = mo_renames, retirements = read_mo_retirements("."))
if (!is.null(mo_integrity_report(integrity_issues))) {
stop("The data set breaks integrity rules after the conversion to ASCII:\n",
mo_integrity_report(integrity_issues),
@@ -211,7 +211,10 @@ v2.0.0 may never be given to another taxon. Never weaken a rule to get past this
code may only get another name (e.g. a corrected spelling) if it is listed in
`data-raw/microorganisms_files/mo_code_renames.csv`, and you may only add such rows with an empty
`approved_by`: the build will then stop on it until the human approves it, so list every proposed rename under
"Needs a human". After the build, `tests/testthat/microorganisms_known_defects.csv` (the known defects of the
"Needs a human". The build never removes a released taxon: missing ones are restored, except codes it retires in
`data-raw/microorganisms_files/mo_code_retirements.csv` (other organisms with the same genus name, or a genus that
is now only known in another domain). Every new row in that file needs its own checkbox in the report, and rows
marked `NEEDS REVIEW` also under "Needs a human". After the build, `tests/testthat/microorganisms_known_defects.csv` (the known defects of the
data set before this rebuild) must be emptied: delete the rows that are solved, and the file itself if none
are left. Any remaining row must be explained under "Needs a human".
+7 -2
View File
@@ -11,6 +11,7 @@ the registry that guarantees this.
| `mo_code_registry.csv` | Every MO code that was ever part of a **released** version of the AMR package since v2.0.0, with the taxon it denotes (name, rank, domain, genus, species, subspecies), the first and last release it was in, and older names of the same code (e.g. a corrected spelling). |
| `build_mo_code_registry.R` | Recreates `mo_code_registry.csv` from the git tags of all releases. Run it after every new release. |
| `mo_code_renames.csv` | The only allowed exceptions: registered codes that get another name, because it is the same taxon (e.g. a corrected spelling or a renamed species group). Every row needs `approved_by` and `approved_date`. |
| `mo_code_retirements.csv` | Registered codes that are retired on purpose, because their taxon was another organism (e.g. the *Graphium* butterflies, which were wrongly in the Fungi until v3.0.1). Written by the taxonomy build, with the reason; `as.mo()` translates these codes to `NA` with that reason. Every new row must be reviewed in the git diff. |
## Rules
@@ -24,11 +25,15 @@ the registry that guarantees this.
registry (most recent release first), never gives a registered code to a new taxon, and stops if a
registered code would get another name than in the registry, unless that is listed and approved in
`mo_code_renames.csv`.
4. **A registered code that is no longer in the data still works.** `as.mo()` translates it to the current
4. **A released taxon is never removed.** Decision by Matthijs S. Berends, 3 October 2026. If a released taxon is
missing in a new build (e.g. not validly published or not clinically relevant anymore), the build restores it
from its last release, with its old code and last known status. The only exception are retired codes (see
`mo_code_retirements.csv`).
5. **A registered code that is no longer in the data still works.** `as.mo()` translates it to the current
code of the same taxon (by its name, so also if the taxon moved to another domain), using an internal lookup
table (`MO_RETIRED_CODES`) that is created from the registry in `data-raw/_pre_commit_checks.R`. If the
taxon is no longer in the data at all, the result is `NA` with a warning. The package never guesses.
5. **Tests enforce all of this.** `tests/testthat/test-data-microorganisms.R` checks the current data against
6. **Tests enforce all of this.** `tests/testthat/test-data-microorganisms.R` checks the current data against
the registry and the renames, and checks that every registered code resolves to its own taxon.
## After a release
@@ -0,0 +1 @@
"mo","fullname","reason","decided_by","date"
1 mo fullname reason decided_by date
+20 -1
View File
@@ -61,6 +61,14 @@ read_mo_renames <- function(root = mo_repository_root()) {
# only approved renames count
renames[renames$approved_by != "" & renames$approved_date != "", , drop = FALSE]
}
# MO codes that are retired on purpose, because their taxon was another organism (see the README)
read_mo_retirements <- function(root = mo_repository_root()) {
file <- file.path(root, "data-raw", "microorganisms_files", "mo_code_retirements.csv")
if (is.null(root) || !file.exists(file)) {
return(NULL)
}
utils::read.csv(file, colClasses = "character", na.strings = character(0))
}
mo_repository_root <- function() {
# works from the root of the repository and from tests/testthat
for (path in c(".", "../..", "..")) {
@@ -78,7 +86,7 @@ mo_name_without_suffix <- function(x) {
# Returns a named list with one character vector per rule, each describing the records that break the rule.
# All vectors must be empty.
mo_integrity_issues <- function(df, registry = NULL, renames = NULL) {
mo_integrity_issues <- function(df, registry = NULL, renames = NULL, retirements = NULL) {
df <- as.data.frame(df, stringsAsFactors = FALSE)
df$mo <- as.character(df$mo)
describe <- function(rows) {
@@ -161,6 +169,17 @@ mo_integrity_issues <- function(df, registry = NULL, renames = NULL) {
issues$registered_code_with_other_taxon <- describe(
!is.na(registered_name) & mo_name_without_suffix(registered_name) != mo_name_without_suffix(df$fullname)
)
# a released taxon is never removed, unless its code was retired on purpose
expected <- registry$fullname
if (!is.null(renames) && nrow(renames) > 0) {
renamed <- match(registry$mo, renames$mo)
expected[!is.na(renamed)] <- renames$new_name[renamed[!is.na(renamed)]]
}
missing <- !mo_name_without_suffix(expected) %in% mo_name_without_suffix(df$fullname)
if (!is.null(retirements)) {
missing <- missing & !registry$mo %in% retirements$mo
}
issues$released_taxon_missing <- if (any(missing)) paste0(registry$mo[missing], " (", expected[missing], ")") else character(0)
}
issues
File diff suppressed because it is too large. Load diff
+10 -4
View File
@@ -97,7 +97,7 @@ sentinel_defects <- function() {
test_that("microorganisms: integrity rules", {
skip_on_cran()
issues <- mo_integrity_issues(microorganisms, registry = read_mo_registry(), renames = read_mo_renames())
issues <- mo_integrity_issues(microorganisms, registry = read_mo_registry(), renames = read_mo_renames(), retirements = read_mo_retirements())
for (rule in names(issues)) {
defects <- new_defects(rule, issues[[rule]])
expect_true(length(defects) == 0,
@@ -111,7 +111,7 @@ test_that("microorganisms: known defects are no longer than needed", {
# a known defect that is solved must be removed from the list, so that it cannot come back unnoticed
kd <- known_defects()
skip_if(nrow(kd) == 0)
issues <- mo_integrity_issues(microorganisms, registry = read_mo_registry(), renames = read_mo_renames())
issues <- mo_integrity_issues(microorganisms, registry = read_mo_registry(), renames = read_mo_renames(), retirements = read_mo_retirements())
current <- c(
unlist(lapply(names(issues), function(rule) paste(rule, issues[[rule]], sep = "|"))),
paste("sentinel", sentinel_defects(), sep = "|")
@@ -145,6 +145,12 @@ test_that("MO codes: every code of every release since v2.0.0 still means the sa
expected_name[!is.na(renamed)] <- renames$new_name[renamed[!is.na(renamed)]]
# deliberate in as.mo() since v2.0.0: the kingdom/domain Fungi returns the code for an unknown fungus
expected_name[registry$mo == "F_[KNG]_FUNGI"] <- "(unknown fungus)"
# codes retired on purpose (their taxon was another organism) must lead to NA
retirements <- read_mo_retirements()
retired_on_purpose <- registry$mo %in% retirements$mo
expect_true(all(is.na(suppressWarnings(as.mo(registry$mo[retired_on_purpose], info = FALSE)))))
registry <- registry[!retired_on_purpose, , drop = FALSE]
expected_name <- expected_name[!retired_on_purpose]
result <- suppressWarnings(as.mo(registry$mo, keep_synonyms = TRUE, info = FALSE))
result_name <- microorganisms$fullname[match(result, microorganisms$mo)]
wrong <- !is.na(result) & mo_name_without_suffix(result_name) != mo_name_without_suffix(expected_name)
@@ -154,8 +160,8 @@ test_that("MO codes: every code of every release since v2.0.0 still means the sa
)
# the internal lookup table must be up to date with the registry
retired <- registry$mo[!registry$mo %in% microorganisms$mo]
expect_setequal(AMR:::MO_RETIRED_CODES$old_mo, retired)
full_registry <- read_mo_registry()
expect_setequal(AMR:::MO_RETIRED_CODES$old_mo, full_registry$mo[!full_registry$mo %in% microorganisms$mo])
})
test_that("MO codes: codes of earlier releases are translated, never guessed", {