P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-07-08 16:42:10 +02:00
Code Releases Activity

(v1.1.0.9020) updated taxonomy

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2020-05-27 16:37:49 +02:00
parent ae1969b941
commit 86d44054f0
55 changed files with 68063 additions and 70233 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
R/aa_helper_functions.R
View File

@ -78,8 +78,7 @@ check_dataset_integrity <- function() {
check_microorganisms <- all(c("mo", "fullname", "kingdom", "phylum",
"class", "order", "family", "genus",
"species", "subspecies", "rank",
"col_id", "species_id", "source",
"ref", "prevalence", "snomed") %in% colnames(microorganisms),
"species_id", "source", "ref", "prevalence") %in% colnames(microorganisms),
na.rm = TRUE) & NROW(microorganisms) == NROW(MO_lookup)
check_antibiotics <- all(c("ab", "atc", "cid", "name", "group",
"atc_group1", "atc_group2", "abbreviations",

2
R/ab.R
View File

@ -347,7 +347,7 @@ is.ab <- function(x) {
#' @export
#' @noRd
print.ab <- function(x, ...) {
cat("Class 'ab'\n")
cat("Class <ab>\n")
print(as.character(x), quote = FALSE)
}

10
R/catalogue_of_life.R
View File

@ -50,9 +50,9 @@
#'
#'
#' # Get a note when a species was renamed
#' mo_shortname("Chlamydia psittaci")
#' # Note: 'Chlamydia psittaci' (Page, 1968) was renamed
#' # 'Chlamydophila psittaci' (Everett et al., 1999)
#' mo_shortname("Chlamydophila psittaci")
#' # Note: 'Chlamydophila psittaci' (Everett et al., 1999) was renamed back to
#' # 'Chlamydia psittaci' (Page, 1968)
#' # [1] "C. psittaci"
#'
#' # Get any property from the entire taxonomic tree for all included species
@ -70,9 +70,9 @@
#'
#' # Do not get mistaken - this package is about microorganisms
#' mo_kingdom("C. elegans")
#' # [1] "Bacteria" # Bacteria?!
#' # [1] "Fungi" # Fungi?!
#' mo_name("C. elegans")
#' # [1] "Chroococcus limneticus elegans" # Because a microorganism was found
#' # [1] "Cladosporium elegans" # Because a microorganism was found
NULL
#' Version info of included Catalogue of Life

18
R/data.R
View File

@ -82,7 +82,6 @@
#' @inheritSection catalogue_of_life Catalogue of Life
#' @format A [`data.frame`] with `r format(nrow(microorganisms), big.mark = ",")` observations and `r ncol(microorganisms)` variables:
#' - `mo`\cr ID of microorganism as used by this package
#' - `col_id`\cr Catalogue of Life ID
#' - `fullname`\cr Full name, like `"Escherichia coli"`
#' - `kingdom`, `phylum`, `class`, `order`, `family`, `genus`, `species`, `subspecies`\cr Taxonomic rank of the microorganism
#' - `rank`\cr Text of the taxonomic rank of the microorganism, like `"species"` or `"genus"`
@ -113,6 +112,8 @@
#'
#' From: <https://www.dsmz.de/services/online-tools/prokaryotic-nomenclature-up-to-date/complete-list-readme>
#' @source Catalogue of Life: Annual Checklist (public online taxonomic database), <http://www.catalogueoflife.org> (check included annual version with [catalogue_of_life_version()]).
#'
#' Parte, A.C. (2018). LPSN — List of Prokaryotic names with Standing in Nomenclature (bacterio.net), 20 years on. International Journal of Systematic and Evolutionary Microbiology, 68, 1825-1829; doi: 10.1099/ijsem.0.002786
#'
#' Leibniz Institute DSMZ-German Collection of Microorganisms and Cell Cultures, Germany, Prokaryotic Nomenclature Up-to-Date, <https://www.dsmz.de/services/online-tools/prokaryotic-nomenclature-up-to-date> (check included version with [catalogue_of_life_version()]).
#' @inheritSection AMR Read more on our website!
@ -120,11 +121,11 @@
"microorganisms"
catalogue_of_life <- list(
year = 2018,
year = 2019,
version = "Catalogue of Life: {year} Annual Checklist",
url_CoL = "http://www.catalogueoflife.org/annual-checklist/{year}/",
url_DSMZ = "https://www.dsmz.de/services/online-tools/prokaryotic-nomenclature-up-to-date/prokaryotic-nomenclature-up-to-date/genus-search",
yearmonth_DSMZ = "August 2019"
url_CoL = "http://www.catalogueoflife.org/col/",
url_DSMZ = "https://lpsn.dsmz.de",
yearmonth_DSMZ = "May 2020"
)
#' Data set with previously accepted taxonomic names
@ -132,17 +133,18 @@ catalogue_of_life <- list(
#' A data set containing old (previously valid or accepted) taxonomic names according to the Catalogue of Life. This data set is used internally by [as.mo()].
#' @inheritSection catalogue_of_life Catalogue of Life
#' @format A [`data.frame`] with `r format(nrow(microorganisms.old), big.mark = ",")` observations and `r ncol(microorganisms.old)` variables:
#' - `col_id`\cr Catalogue of Life ID that was originally given
#' - `col_id_new`\cr New Catalogue of Life ID that responds to an entry in the [microorganisms] data set
#' - `fullname`\cr Old full taxonomic name of the microorganism
#' - `fullname_new`\cr New full taxonomic name of the microorganism
#' - `ref`\cr Author(s) and year of concerning scientific publication
#' - `prevalence`\cr Prevalence of the microorganism, see [as.mo()]
#' @source Catalogue of Life: Annual Checklist (public online taxonomic database), <http://www.catalogueoflife.org> (check included annual version with [catalogue_of_life_version()]).
#'
#' Parte, A.C. (2018). LPSN — List of Prokaryotic names with Standing in Nomenclature (bacterio.net), 20 years on. International Journal of Systematic and Evolutionary Microbiology, 68, 1825-1829; doi: 10.1099/ijsem.0.002786
#' @inheritSection AMR Read more on our website!
#' @seealso [as.mo()] [mo_property()] [microorganisms]
"microorganisms.old"
#' Translation table for common microorganism codes
#' Translation table with `r format(nrow(microorganisms.codes), big.mark = ",")` common microorganism codes
#'
#' A data set containing commonly used codes for microorganisms, from laboratory systems and WHONET. Define your own with [set_mo_source()]. They will all be searched when using [as.mo()] and consequently all the [`mo_*`][mo_property()] functions.
#' @format A [`data.frame`] with `r format(nrow(microorganisms.codes), big.mark = ",")` observations and `r ncol(microorganisms.codes)` variables:

2
R/disk.R
View File

@ -99,7 +99,7 @@ is.disk <- function(x) {
#' @export
#' @noRd
print.disk <- function(x, ...) {
cat("Class 'disk'\n")
cat("Class <disk>\n")
print(as.integer(x), quote = FALSE)
}

113
R/eucast_rules.R
View File

@ -245,6 +245,7 @@ eucast_rules <- function(x,
}
warned <- FALSE
warn_lacking_rsi_class <- FALSE
txt_error <- function() {
if (info == TRUE) cat("", font_red_bg(font_white(" ERROR ")), "\n\n")
@ -410,6 +411,7 @@ eucast_rules <- function(x,
RID <- cols_ab["RID"]
RIF <- cols_ab["RIF"]
RXT <- cols_ab["RXT"]
SAM <- cols_ab["SAM"]
SIS <- cols_ab["SIS"]
SXT <- cols_ab["SXT"]
TCY <- cols_ab["TCY"]
@ -440,7 +442,9 @@ eucast_rules <- function(x,
cols <- unique(cols[!is.na(cols) & !is.null(cols)])
if (length(rows) > 0 & length(cols) > 0) {
before_df <- x_original
if (any(!sapply(x[, cols, drop = FALSE], is.rsi), na.rm = TRUE)) {
warn_lacking_rsi_class <<- TRUE
}
tryCatch(
# insert into original table
x_original[rows, cols] <<- to,
@ -599,14 +603,79 @@ eucast_rules <- function(x,
}
}
if (info == TRUE & !any(c("other", "all") %in% rules, na.rm = TRUE)) {
cat(font_red("\nSkipping inheritance rules defined by this package, such as setting trimethoprim (TMP) = R where trimethoprim/sulfamethoxazole (SXT) = R.\nUse eucast_rules(..., rules = \"all\") to also apply those rules.\n"))
}
eucast_notification_shown <- FALSE
eucast_rules_df <- eucast_rules_file # internal data file
as.rsi_no_warning <- function(x) suppressWarnings(as.rsi(x))
no_added <- 0
no_changed <- 0
# Other rules: enzyme inhibitors ------------------------------------------
if (any(c("all", "other") %in% rules)) {
if (info == TRUE) {
cat(font_bold(paste0("\nRules by this AMR package (",
font_red(paste0("v", utils::packageVersion("AMR"), ", ",
format(utils::packageDate("AMR"), "%Y"))), ")\n")))
}
ab_enzyme <- subset(antibiotics, name %like% "/")[, c("ab", "name")]
ab_enzyme$base_name <- gsub("^([a-zA-Z0-9]+).*", "\\1", ab_enzyme$name)
ab_enzyme$base_ab <- as.ab(ab_enzyme$base_name)
for (i in seq_len(nrow(ab_enzyme))) {
if (all(c(ab_enzyme[i, ]$ab, ab_enzyme[i, ]$base_ab) %in% names(cols_ab), na.rm = TRUE)) {
ab_name_base <- ab_name(cols_ab[ab_enzyme[i, ]$base_ab], language = NULL, tolower = TRUE)
ab_name_enzyme <- ab_name(cols_ab[ab_enzyme[i, ]$ab], language = NULL, tolower = TRUE)
# Set base to R where base + enzyme inhibitor is R
rule_current <- paste0("Set ", ab_name_base, " (", cols_ab[ab_enzyme[i, ]$base_ab], ") = R where ",
ab_name_enzyme, " (", cols_ab[ab_enzyme[i, ]$ab], ") = R")
if (info == TRUE) {
cat(rule_current)
}
run_changes <- edit_rsi(to = "R",
rule = c(rule_current, "Other rules", ""),
rows = which(as.rsi_no_warning(x[, cols_ab[ab_enzyme[i, ]$ab]]) == "R"),
cols = cols_ab[ab_enzyme[i, ]$base_ab])
no_added <- no_added + run_changes$added
no_changed <- no_changed + run_changes$changed
# Print number of new changes
if (info == TRUE) {
# print only on last one of rules in this group
txt_ok(no_added = no_added, no_changed = no_changed)
# and reset counters
no_added <- 0
no_changed <- 0
}
# Set base + enzyme inhibitor to S where base is S
rule_current <- paste0("Set ", ab_name_enzyme, " (", cols_ab[ab_enzyme[i, ]$ab], ") = S where ",
ab_name_base, " (", cols_ab[ab_enzyme[i, ]$base_ab], ") = S")
if (info == TRUE) {
cat(rule_current)
}
run_changes <- edit_rsi(to = "S",
rule = c(rule_current, "Other rules", ""),
rows = which(as.rsi_no_warning(x[, cols_ab[ab_enzyme[i, ]$base_ab]]) == "S"),
cols = cols_ab[ab_enzyme[i, ]$ab])
no_added <- no_added + run_changes$added
no_changed <- no_changed + run_changes$changed
# Print number of new changes
if (info == TRUE) {
# print only on last one of rules in this group
txt_ok(no_added = no_added, no_changed = no_changed)
# and reset counters
no_added <- 0
no_changed <- 0
}
}
}
} else {
if (info == TRUE) {
cat(font_red("\nSkipping inheritance rules defined by this package, such as setting trimethoprim (TMP) = R where trimethoprim/sulfamethoxazole (SXT) = R.\nUse eucast_rules(..., rules = \"all\") to also apply those rules.\n"))
}
}
# Official EUCAST rules ---------------------------------------------------
eucast_notification_shown <- FALSE
eucast_rules_df <- eucast_rules_file # internal data file
for (i in seq_len(nrow(eucast_rules_df))) {
rule_previous <- eucast_rules_df[max(1, i - 1), "reference.rule"]
@ -637,18 +706,14 @@ eucast_rules <- function(x,
if (rule_group_current %like% "expert" & !any(c("all", "expert") %in% rules)) {
next
}
if (rule_group_current %like% "other" & !any(c("all", "other") %in% rules)) {
next
}
if (info == TRUE & !rule_group_current %like% "other" & eucast_notification_shown == FALSE) {
cat(paste0(
"\n----\nRules by the ", font_bold("European Committee on Antimicrobial Susceptibility Testing (EUCAST)"),
cat(paste0("\n", font_grey(strrep("-", options()$width - 1)),
"\nRules by the ", font_bold("European Committee on Antimicrobial Susceptibility Testing (EUCAST)"),
"\n", font_blue("http://eucast.org/"), "\n"))
eucast_notification_shown <- TRUE
}
if (info == TRUE) {
# Print rule (group) ------------------------------------------------------
if (rule_group_current != rule_group_previous) {
@ -662,7 +727,7 @@ eucast_rules <- function(x,
rule_group_current %like% "expert",
paste0("\nEUCAST Expert Rules, Intrinsic Resistance and Exceptional Phenotypes (",
font_red(paste0("v", EUCAST_VERSION_EXPERT_RULES)), ")\n"),
"\nOther rules by this AMR package\n"))))
""))))
}
# Print rule -------------------------------------------------------------
if (rule_current != rule_previous) {
@ -733,18 +798,18 @@ eucast_rules <- function(x,
rows <- integer(0)
} else if (length(source_antibiotics) == 1) {
rows <- tryCatch(which(x[, col_mo_property] %like% mo_value
& x[, source_antibiotics[1L]] == source_value[1L]),
& as.rsi_no_warning(x[, source_antibiotics[1L]]) == source_value[1L]),
error = function(e) integer(0))
} else if (length(source_antibiotics) == 2) {
rows <- tryCatch(which(x[, col_mo_property] %like% mo_value
& x[, source_antibiotics[1L]] == source_value[1L]
& x[, source_antibiotics[2L]] == source_value[2L]),
& as.rsi_no_warning(x[, source_antibiotics[1L]]) == source_value[1L]
& as.rsi_no_warning(x[, source_antibiotics[2L]]) == source_value[2L]),
error = function(e) integer(0))
} else if (length(source_antibiotics) == 3) {
rows <- tryCatch(which(x[, col_mo_property] %like% mo_value
& x[, source_antibiotics[1L]] == source_value[1L]
& x[, source_antibiotics[2L]] == source_value[2L]
& x[, source_antibiotics[3L]] == source_value[3L]),
& as.rsi_no_warning(x[, source_antibiotics[1L]]) == source_value[1L]
& as.rsi_no_warning(x[, source_antibiotics[2L]]) == source_value[2L]
& as.rsi_no_warning(x[, source_antibiotics[3L]]) == source_value[3L]),
error = function(e) integer(0))
} else {
stop("only 3 antibiotics supported for source_antibiotics ", call. = FALSE)
@ -784,7 +849,7 @@ eucast_rules <- function(x,
arrange(row, rule_group, rule_name, col)
cat(paste0("\n", font_grey(strrep("-", options()$width - 1)), "\n"))
cat(font_bold(paste("EUCAST rules", paste0(wouldve, "affected"),
cat(font_bold(paste("The rules", paste0(wouldve, "affected"),
formatnr(n_distinct(verbose_info$row)),
"out of", formatnr(nrow(x_original)),
"rows, making a total of", formatnr(nrow(verbose_info)), "edits\n")))
@ -846,6 +911,12 @@ eucast_rules <- function(x,
}
}
if (isTRUE(warn_lacking_rsi_class)) {
warning("Not all columns with antimicrobial results are of class <rsi>.\n",
"Transform eligible columns to class <rsi> on beforehand: your_data %>% mutate_if(is.rsi.eligible, as.rsi)",
call. = FALSE)
}
# Return data set ---------------------------------------------------------
if (verbose == TRUE) {
rownames(verbose_info) <- NULL

2
R/join_microorganisms.R
View File

@ -154,7 +154,7 @@ joins_check_df <- function(x, by) {
by <- "mo"
x[, "mo"] <- as.mo(x[, "mo"])
} else {
stop("Cannot join - no column found with name or class `mo`.", call. = FALSE)
stop("Cannot join - no column found with name or class <mo>.", call. = FALSE)
}
}
message('Joining, by = "', by, '"') # message same as dplyr::join functions

2
R/mic.R
View File

@ -174,7 +174,7 @@ droplevels.mic <- function(x, exclude = ifelse(anyNA(levels(x)), NULL, NA), ...)
#' @export
#' @noRd
print.mic <- function(x, ...) {
cat("Class 'mic'\n")
cat("Class <mic>\n")
print(as.character(x), quote = FALSE)
}

96
R/mo.R
View File

@ -126,7 +126,6 @@
#' as.mo("MRSA") # Methicillin Resistant S. aureus
#' as.mo("VISA") # Vancomycin Intermediate S. aureus
#' as.mo("VRSA") # Vancomycin Resistant S. aureus
#' as.mo(22242419) # Catalogue of Life ID
#' as.mo(115329001) # SNOMED CT code
#'
#' # Dyslexia is no problem - these all work:
@ -556,20 +555,44 @@ exec_as.mo <- function(x,
if (initial_search == TRUE) {
progress$tick()
}
if (x_backup[i] %like_case% "\\(unknown [a-z]+\\)" | tolower(x_backup_without_spp[i]) %in% c("other", "none", "unknown")) {
# empty and nonsense values, ignore without warning
x[i] <- lookup(mo == "UNKNOWN")
next
}
# valid MO code ---
# valid MO code ----
found <- lookup(mo == toupper(x_backup[i]))
if (!is.na(found)) {
x[i] <- found[1L]
next
}
# valid fullname ----
found <- lookup(fullname_lower %in% gsub("[^a-zA-Z0-9_. -]", "", tolower(c(x_backup[i], x_backup_without_spp[i]))))
# added the gsub() for "(unknown fungus)", since fullname_lower does not contain brackets
if (!is.na(found)) {
x[i] <- found[1L]
next
}
# old fullname ----
found <- lookup(fullname_lower %in% tolower(c(x_backup[i], x_backup_without_spp[i])),
column = NULL, # all columns
haystack = MO.old_lookup)
if (!all(is.na(found))) {
# when property is "ref" (which is the case in mo_ref, mo_authors and mo_year), return the old value, so:
# mo_ref() of "Chlamydia psittaci" will be "Page, 1968" (with warning)
# mo_ref() of "Chlamydophila psittaci" will be "Everett et al., 1999"
if (property == "ref") {
x[i] <- found["ref"]
} else {
x[i] <- lookup(fullname == found["fullname_new"], haystack = MO_lookup)
}
options(mo_renamed_last_run = found["fullname"])
was_renamed(name_old = found["fullname"],
name_new = lookup(fullname == found["fullname_new"], "fullname", haystack = MO_lookup),
ref_old = found["ref"],
ref_new = lookup(fullname == found["fullname_new"], "ref", haystack = MO_lookup),
mo = lookup(fullname == found["fullname_new"], "mo", haystack = MO_lookup))
next
}
# old mo code, used in previous versions of this package ----
if (x_backup[i] %in% microorganisms.translation$mo_old) {
old_mo_warning <- TRUE
@ -582,10 +605,9 @@ exec_as.mo <- function(x,
}
}
found <- lookup(fullname_lower %in% tolower(c(x_backup[i], x_backup_without_spp[i])))
# most probable: is exact match in fullname
if (!is.na(found)) {
x[i] <- found[1L]
if (x_backup[i] %like_case% "\\(unknown [a-z]+\\)" | tolower(x_backup_without_spp[i]) %in% c("other", "none", "unknown")) {
# empty and nonsense values, ignore without warning
x[i] <- lookup(mo == "UNKNOWN")
next
}
@ -614,13 +636,6 @@ exec_as.mo <- function(x,
next
}
# valid Catalogue of Life ID ---
found <- lookup(col_id == x_backup[i])
if (!is.na(found)) {
x[i] <- found[1L]
next
}
# WHONET and other common LIS codes ----
found <- lookup(code %in% toupper(c(x_backup_untouched[i], x_backup[i], x_backup_without_spp[i])),
column = "mo",
@ -943,21 +958,20 @@ exec_as.mo <- function(x,
column = NULL, # all columns
haystack = data.old_to_check)
if (!all(is.na(found))) {
col_id_new <- found["col_id_new"]
# when property is "ref" (which is the case in mo_ref, mo_authors and mo_year), return the old value, so:
# mo_ref() of "Chlamydia psittaci" will be "Page, 1968" (with warning)
# mo_ref() of "Chlamydophila psittaci" will be "Everett et al., 1999"
if (property == "ref") {
x[i] <- found["ref"]
} else {
x[i] <- lookup(col_id == found["col_id_new"], haystack = MO_lookup)
x[i] <- lookup(fullname == found["fullname_new"], haystack = MO_lookup)
}
options(mo_renamed_last_run = found["fullname"])
was_renamed(name_old = found["fullname"],
name_new = lookup(col_id == found["col_id_new"], "fullname", haystack = MO_lookup),
name_new = lookup(fullname == found["fullname_new"], "fullname", haystack = MO_lookup),
ref_old = found["ref"],
ref_new = lookup(col_id == found["col_id_new"], "ref", haystack = MO_lookup),
mo = lookup(col_id == found["col_id_new"], "mo", haystack = MO_lookup))
ref_new = lookup(fullname == found["fullname_new"], "ref", haystack = MO_lookup),
mo = lookup(fullname == found["fullname_new"], "mo", haystack = MO_lookup))
return(x[i])
}
@ -997,18 +1011,18 @@ exec_as.mo <- function(x,
# mo_ref("Chlamydophila psittaci) = "Everett et al., 1999"
x <- found["ref"]
} else {
x <- lookup(col_id == found["col_id_new"], haystack = MO_lookup)
x <- lookup(fullname == found["fullname_new"], haystack = MO_lookup)
}
was_renamed(name_old = found["fullname"],
name_new = lookup(col_id == found["col_id_new"], "fullname", haystack = MO_lookup),
name_new = lookup(fullname == found["fullname_new"], "fullname", haystack = MO_lookup),
ref_old = found["ref"],
ref_new = lookup(col_id == found["col_id_new"], "ref", haystack = MO_lookup),
mo = lookup(col_id == found["col_id_new"], "mo", haystack = MO_lookup))
ref_new = lookup(fullname == found["fullname_new"], "ref", haystack = MO_lookup),
mo = lookup(fullname == found["fullname_new"], "mo", haystack = MO_lookup))
options(mo_renamed_last_run = found["fullname"])
uncertainties <<- rbind(uncertainties,
format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup,
result_mo = lookup(col_id == found["col_id_new"], "mo", haystack = MO_lookup)))
result_mo = lookup(fullname == found["fullname_new"], "mo", haystack = MO_lookup)))
return(x)
}
@ -1366,6 +1380,10 @@ exec_as.mo <- function(x,
failures <- c(failures, x_backup[i])
}
}
if (initial_search == TRUE) {
close(progress)
}
}
# handling failures ----
@ -1494,7 +1512,7 @@ exec_as.mo <- function(x,
if (property == "mo") {
x <- to_class_mo(x)
}
if (length(mo_renamed()) > 0) {
print(mo_renamed())
}
@ -1552,7 +1570,7 @@ format_uncertainty_as_df <- function(uncertainty_level,
#' @export
#' @noRd
print.mo <- function(x, ...) {
cat("Class 'mo'\n")
cat("Class <mo>\n")
x_names <- names(x)
x <- as.character(x)
names(x) <- x_names
@ -1711,6 +1729,9 @@ print.mo_renamed <- function(x, ...) {
font_italic(x$old_name[i]), ifelse(x$old_ref[i] %in% c("", NA), "",
paste0(" (", gsub("et al.", font_italic("et al."), x$old_ref[i]), ")")),
" was renamed ",
ifelse(as.integer(gsub("[^0-9]", "", x$new_ref[i])) < as.integer(gsub("[^0-9]", "", x$old_ref[i])),
font_bold("back to "),
""),
font_italic(x$new_name[i]), ifelse(x$new_ref[i] %in% c("", NA), "",
paste0(" (", gsub("et al.", font_italic("et al."), x$new_ref[i]), ")")),
" [", x$mo[i], "]")))
@ -1747,9 +1768,14 @@ translate_allow_uncertain <- function(allow_uncertain) {
}
get_mo_failures_uncertainties_renamed <- function() {
list(failures = getOption("mo_failures"),
uncertainties = getOption("mo_uncertainties"),
renamed = getOption("mo_renamed"))
remember <- list(failures = getOption("mo_failures"),
uncertainties = getOption("mo_uncertainties"),
renamed = getOption("mo_renamed"))
# empty them, otherwise mo_shortname("Chlamydophila psittaci") will give 3 notes
options("mo_failures" = NULL)
options("mo_uncertainties" = NULL)
options("mo_renamed" = NULL)
remember
}
load_mo_failures_uncertainties_renamed <- function(metadata) {

18
R/mo_property.R
View File

@ -149,6 +149,7 @@ mo_fullname <- mo_name
#' @export
mo_shortname <- function(x, language = get_locale(), ...) {
x.mo <- as.mo(x, ...)
metadata <- get_mo_failures_uncertainties_renamed()
replace_empty <- function(x) {
@ -158,7 +159,7 @@ mo_shortname <- function(x, language = get_locale(), ...) {
# get first char of genus and complete species in English
shortnames <- paste0(substr(mo_genus(x.mo, language = NULL), 1, 1), ". ", replace_empty(mo_species(x.mo, language = NULL)))
# exceptions for Staphylococci
shortnames[shortnames == "S. coagulase-negative"] <- "CoNS"
shortnames[shortnames == "S. coagulase-positive"] <- "CoPS"
@ -315,9 +316,9 @@ mo_synonyms <- function(x, ...) {
x <- as.mo(x, ...)
metadata <- get_mo_failures_uncertainties_renamed()
IDs <- mo_property(x = x, property = "col_id", language = NULL)
syns <- lapply(IDs, function(col_id) {
res <- sort(microorganisms.old[which(microorganisms.old$col_id_new == col_id), "fullname"])
IDs <- mo_name(x = x, language = NULL)
syns <- lapply(IDs, function(newname) {
res <- sort(microorganisms.old[which(microorganisms.old$fullname_new == newname), "fullname"])
if (length(res) == 0) {
NULL
} else {
@ -368,14 +369,9 @@ mo_url <- function(x, open = FALSE, ...) {
df <- data.frame(mo, stringsAsFactors = FALSE) %>%
left_join(select(microorganisms, mo, source, species_id), by = "mo")
df$url <- ifelse(df$source == "CoL",
paste0(gsub("{year}",
catalogue_of_life$year,
catalogue_of_life$url_CoL,
fixed = TRUE),
"details/species/id/",
df$species_id),
paste0(catalogue_of_life$url_CoL, "details/species/id/", df$species_id, "/"),
ifelse(df$source == "DSMZ",
paste0(catalogue_of_life$url_DSMZ, "/", unlist(lapply(strsplit(mo_names, ""), function(x) x[1]))),
paste0(catalogue_of_life$url_DSMZ, "/advanced_search?adv[taxon-name]=", gsub(" ", "+", mo_names), "/"),
NA_character_))
u <- df$url
names(u) <- mo_names

2
R/rsi.R
View File

@ -533,7 +533,7 @@ is.rsi.eligible <- function(x, threshold = 0.05) {
#' @export
#' @noRd
print.rsi <- function(x, ...) {
cat("Class 'rsi'\n")
cat("Class <rsi>\n")
print(as.character(x), quote = FALSE)
}

4
R/rsi_calc.R
View File

@ -128,7 +128,7 @@ rsi_calc <- function(...,
}
if (print_warning == TRUE) {
warning("Increase speed by transforming to class `rsi` on beforehand: df %>% mutate_if(is.rsi.eligible, as.rsi)",
warning("Increase speed by transforming to class <rsi> on beforehand: your_data %>% mutate_if(is.rsi.eligible, as.rsi)",
call. = FALSE)
}
@ -177,7 +177,7 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
}
if (!any(sapply(data, is.rsi), na.rm = TRUE)) {
stop("No columns with class 'rsi' found. See ?as.rsi.", call. = FALSE)
stop("No columns with class <rsi> found. See ?as.rsi.", call. = FALSE)
}
if (as.character(translate_ab) %in% c("TRUE", "official")) {

BIN
R/sysdata.rda
View File

Binary file not shown.