mirror of
https://github.com/msberends/AMR.git
synced 2025-07-08 14:01:55 +02:00
(v1.5.0.9028) Updated taxonomy until March 2021
This commit is contained in:
@ -46,7 +46,7 @@ format_included_data_number <- function(data) {
|
||||
#' \if{html}{\figure{logo_col.png}{options: height=40px style=margin-bottom:5px} \cr}
|
||||
#' This package contains the complete taxonomic tree of almost all microorganisms (~70,000 species) from the authoritative and comprehensive Catalogue of Life (CoL, <http://www.catalogueoflife.org>). The CoL is the most comprehensive and authoritative global index of species currently available. Nonetheless, we supplemented the CoL data with data from the List of Prokaryotic names with Standing in Nomenclature (LPSN, [lpsn.dsmz.de](https://lpsn.dsmz.de)). This supplementation is needed until the [CoL+ project](https://github.com/CatalogueOfLife/general) is finished, which we await.
|
||||
#'
|
||||
#' [Click here][catalogue_of_life] for more information about the included taxa. Check which versions of the CoL and LSPN were included in this package with [catalogue_of_life_version()].
|
||||
#' [Click here][catalogue_of_life] for more information about the included taxa. Check which versions of the CoL and LPSN were included in this package with [catalogue_of_life_version()].
|
||||
#' @section Included Taxa:
|
||||
#' Included are:
|
||||
#' - All `r format_included_data_number(microorganisms[which(microorganisms$kingdom %in% c("Archeae", "Bacteria", "Chromista", "Protozoa")), ])` (sub)species from the kingdoms of Archaea, Bacteria, Chromista and Protozoa
|
||||
@ -99,7 +99,7 @@ NULL
|
||||
#'
|
||||
#' This function returns information about the included data from the Catalogue of Life.
|
||||
#' @seealso [microorganisms]
|
||||
#' @details For DSMZ, see [microorganisms].
|
||||
#' @details For LPSN, see [microorganisms].
|
||||
#' @return a [list], which prints in pretty format
|
||||
#' @inheritSection catalogue_of_life Catalogue of Life
|
||||
#' @inheritSection AMR Read more on Our Website!
|
||||
@ -109,15 +109,15 @@ catalogue_of_life_version <- function() {
|
||||
check_dataset_integrity()
|
||||
|
||||
# see the `catalogue_of_life` list in R/data.R
|
||||
lst <- list(catalogue_of_life =
|
||||
lst <- list(CoL =
|
||||
list(version = gsub("{year}", catalogue_of_life$year, catalogue_of_life$version, fixed = TRUE),
|
||||
url = gsub("{year}", catalogue_of_life$year, catalogue_of_life$url_CoL, fixed = TRUE),
|
||||
n = nrow(pm_filter(microorganisms, source == "CoL"))),
|
||||
deutsche_sammlung_von_mikroorganismen_und_zellkulturen =
|
||||
list(version = "Prokaryotic Nomenclature Up-to-Date from DSMZ",
|
||||
url = catalogue_of_life$url_DSMZ,
|
||||
yearmonth = catalogue_of_life$yearmonth_DSMZ,
|
||||
n = nrow(pm_filter(microorganisms, source == "DSMZ"))),
|
||||
LPSN =
|
||||
list(version = "List of Prokaryotic names with Standing in Nomenclature",
|
||||
url = catalogue_of_life$url_LPSN,
|
||||
yearmonth = catalogue_of_life$yearmonth_LPSN,
|
||||
n = nrow(pm_filter(microorganisms, source == "LPSN"))),
|
||||
total_included =
|
||||
list(
|
||||
n_total_species = nrow(microorganisms),
|
||||
@ -132,14 +132,14 @@ catalogue_of_life_version <- function() {
|
||||
#' @noRd
|
||||
print.catalogue_of_life_version <- function(x, ...) {
|
||||
lst <- x
|
||||
cat(paste0(font_bold("Included in this AMR package are:\n\n"),
|
||||
font_underline(lst$catalogue_of_life$version), "\n",
|
||||
" Available at: ", lst$catalogue_of_life$url, "\n",
|
||||
" Number of included species: ", format(lst$catalogue_of_life$n, big.mark = ","), "\n",
|
||||
font_underline(paste0(lst$deutsche_sammlung_von_mikroorganismen_und_zellkulturen$version, " (",
|
||||
lst$deutsche_sammlung_von_mikroorganismen_und_zellkulturen$yearmonth, ")")), "\n",
|
||||
" Available at: ", lst$deutsche_sammlung_von_mikroorganismen_und_zellkulturen$url, "\n",
|
||||
" Number of included species: ", format(lst$deutsche_sammlung_von_mikroorganismen_und_zellkulturen$n, big.mark = ","), "\n\n",
|
||||
cat(paste0(font_bold("Included in this AMR package (v", utils::packageDescription("AMR")$Version, ") are:\n\n", collapse = ""),
|
||||
font_underline(lst$CoL$version), "\n",
|
||||
" Available at: ", lst$CoL$url, "\n",
|
||||
" Number of included species: ", format(lst$CoL$n, big.mark = ","), "\n",
|
||||
font_underline(paste0(lst$LPSN$version, " (",
|
||||
lst$LPSN$yearmonth, ")")), "\n",
|
||||
" Available at: ", lst$LPSN$url, "\n",
|
||||
" Number of included species: ", format(lst$LPSN$n, big.mark = ","), "\n\n",
|
||||
"=> Total number of species included: ", format(lst$total_included$n_total_species, big.mark = ","), "\n",
|
||||
"=> Total number of synonyms included: ", format(lst$total_included$n_total_synonyms, big.mark = ","), "\n\n",
|
||||
"See for more info ?microorganisms and ?catalogue_of_life.\n"))
|
||||
|
||||
36
R/data.R
36
R/data.R
@ -83,7 +83,7 @@
|
||||
|
||||
#' Data Set with `r format(nrow(microorganisms), big.mark = ",")` Microorganisms
|
||||
#'
|
||||
#' A data set containing the microbial taxonomy of six kingdoms from the Catalogue of Life. MO codes can be looked up using [as.mo()].
|
||||
#' A data set containing the microbial taxonomy, last updated in `r catalogue_of_life$yearmonth_LPSN`, of six kingdoms from the Catalogue of Life (CoL) and the List of Prokaryotic names with Standing in Nomenclature (LPSN). MO codes can be looked up using [as.mo()].
|
||||
#' @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
|
||||
@ -92,15 +92,15 @@
|
||||
#' - `rank`\cr Text of the taxonomic rank of the microorganism, like `"species"` or `"genus"`
|
||||
#' - `ref`\cr Author(s) and year of concerning scientific publication
|
||||
#' - `species_id`\cr ID of the species as used by the Catalogue of Life
|
||||
#' - `source`\cr Either "CoL", "DSMZ" (see *Source*) or "manually added"
|
||||
#' - `source`\cr Either `r vector_or(microorganisms$source)` (see *Source*)
|
||||
#' - `prevalence`\cr Prevalence of the microorganism, see [as.mo()]
|
||||
#' - `snomed`\cr SNOMED code of the microorganism. Use [mo_snomed()] to retrieve it quickly, see [mo_property()].
|
||||
#' @details
|
||||
#' Please note that entries are only based on the Catalogue of Life and the LPSN (see below). Since these sources incorporate entries based on (recent) publications in the International Journal of Systematic and Evolutionary Microbiology (IJSEM), it can happen that the year of publication is sometimes later than one might expect.
|
||||
#'
|
||||
#' For example, *Staphylococcus pettenkoferi* was newly named in Diagnostic Microbiology and Infectious Disease in 2002 (PMID 12106949), but it was not before 2007 that a publication in IJSEM followed (PMID 17625191). Consequently, the AMR package returns 2007 for `mo_year("S. pettenkoferi")`.
|
||||
#' For example, *Staphylococcus pettenkoferi* was described for the first time in Diagnostic Microbiology and Infectious Disease in 2002 (\doi{10.1016/s0732-8893(02)00399-1}), but it was not before 2007 that a publication in IJSEM followed (\doi{10.1099/ijs.0.64381-0}). Consequently, the AMR package returns 2007 for `mo_year("S. pettenkoferi")`.
|
||||
#'
|
||||
#' ## Manually additions
|
||||
#' ## Manual additions
|
||||
#' For convenience, some entries were added manually:
|
||||
#'
|
||||
#' - 11 entries of *Streptococcus* (beta-haemolytic: groups A, B, C, D, F, G, H, K and unspecified; other: viridans, milleri)
|
||||
@ -110,7 +110,6 @@
|
||||
#' - 1 entry of *Blastocystis* (*Blastocystis hominis*), although it officially does not exist (Noel *et al.* 2005, PMID 15634993)
|
||||
#' - 5 other 'undefined' entries (unknown, unknown Gram negatives, unknown Gram positives, unknown yeast and unknown fungus)
|
||||
#' - 6 families under the Enterobacterales order, according to Adeolu *et al.* (2016, PMID 27620848), that are not (yet) in the Catalogue of Life
|
||||
#' - `r format(nrow(subset(microorganisms, source == "DSMZ")), big.mark = ",")` species from the DSMZ (Deutsche Sammlung von Mikroorganismen und Zellkulturen) since the DSMZ contain the latest taxonomic information based on recent publications
|
||||
#'
|
||||
#' ## Direct download
|
||||
#' This data set is available as 'flat file' for use even without \R - you can find the file here:
|
||||
@ -120,16 +119,21 @@
|
||||
#' The file in \R format (with preserved data structure) can be found here:
|
||||
#'
|
||||
#' * <https://github.com/msberends/AMR/raw/master/data/microorganisms.rda>
|
||||
#' @section About the Records from DSMZ (see *Source*):
|
||||
#' Names of prokaryotes are defined as being validly published by the International Code of Nomenclature of Bacteria. Validly published are all names which are included in the Approved Lists of Bacterial Names and the names subsequently published in the International Journal of Systematic Bacteriology (IJSB) and, from January 2000, in the International Journal of Systematic and Evolutionary Microbiology (IJSEM) as original articles or in the validation lists.
|
||||
#' *(from <https://www.dsmz.de/services/online-tools/prokaryotic-nomenclature-up-to-date>)*
|
||||
#' @section About the Records from LPSN (see *Source*):
|
||||
#' The List of Prokaryotic names with Standing in Nomenclature (LPSN) provides comprehensive information on the nomenclature of prokaryotes. LPSN is a free to use service founded by Jean P. Euzeby in 1997 and later on maintained by Aidan C. Parte.
|
||||
#'
|
||||
#' In February 2020, the DSMZ records were merged with the List of Prokaryotic names with Standing in Nomenclature (LPSN).
|
||||
#' @source Catalogue of Life: Annual Checklist (public online taxonomic database), <http://www.catalogueoflife.org> (check included annual version with [catalogue_of_life_version()]).
|
||||
#' As of February 2020, the regularly augmented LPSN database at DSMZ is the basis of the new LPSN service. The new database was implemented for the Type-Strain Genome Server and augmented in 2018 to store all kinds of nomenclatural information. Data from the previous version of LPSN and from the Prokaryotic Nomenclature Up-to-date (PNU) service were imported into the new system. PNU had been established in 1993 as a service of the Leibniz Institute DSMZ, and was curated by Norbert Weiss, Manfred Kracht and Dorothea Gleim.
|
||||
#' @source
|
||||
#' `r gsub("{year}", catalogue_of_life$year, catalogue_of_life$version, fixed = TRUE)`
|
||||
#'
|
||||
#' 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> and <https://lpsn.dsmz.de> (check included version with [catalogue_of_life_version()]).
|
||||
#' * Annual Checklist (public online taxonomic database), <http://www.catalogueoflife.org>
|
||||
#'
|
||||
#' List of Prokaryotic names with Standing in Nomenclature: `r catalogue_of_life$yearmonth_LPSN`
|
||||
#'
|
||||
#' * Parte, A.C., Sarda Carbasse, J., Meier-Kolthoff, J.P., Reimer, L.C. and Goker, M. (2020). List of Prokaryotic names with Standing in Nomenclature (LPSN) moves to the DSMZ. International Journal of Systematic and Evolutionary Microbiology, 70, 5607-5612; \doi{10.1099/ijsem.0.004332}
|
||||
#' * 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}
|
||||
#' * Parte, A.C. (2014). LPSN — List of Prokaryotic names with Standing in Nomenclature. Nucleic Acids Research, 42, Issue D1, D613–D616; \doi{10.1093/nar/gkt1111}
|
||||
#' * Euzeby, J.P. (1997). List of Bacterial Names with Standing in Nomenclature: a Folder Available on the Internet. International Journal of Systematic Bacteriology, 47, 590-592; \doi{10.1099/00207713-47-2-590}
|
||||
#' @inheritSection AMR Reference Data Publicly Available
|
||||
#' @inheritSection AMR Read more on Our Website!
|
||||
#' @seealso [as.mo()], [mo_property()], [microorganisms.codes], [intrinsic_resistant]
|
||||
@ -139,8 +143,8 @@ catalogue_of_life <- list(
|
||||
year = 2019,
|
||||
version = "Catalogue of Life: {year} Annual Checklist",
|
||||
url_CoL = "http://www.catalogueoflife.org/col/",
|
||||
url_DSMZ = "https://lpsn.dsmz.de",
|
||||
yearmonth_DSMZ = "May 2020"
|
||||
url_LPSN = "https://lpsn.dsmz.de",
|
||||
yearmonth_LPSN = "March 2021"
|
||||
)
|
||||
|
||||
#' Data Set with Previously Accepted Taxonomic Names
|
||||
@ -242,7 +246,7 @@ catalogue_of_life <- list(
|
||||
#' Data set to interpret MIC and disk diffusion to R/SI values. Included guidelines are CLSI (`r min(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`) and EUCAST (`r min(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))`). Use [as.rsi()] to transform MICs or disks measurements to R/SI values.
|
||||
#' @format A [data.frame] with `r format(nrow(rsi_translation), big.mark = ",")` observations and `r ncol(rsi_translation)` variables:
|
||||
#' - `guideline`\cr Name of the guideline
|
||||
#' - `method`\cr Either "MIC" or "DISK"
|
||||
#' - `method`\cr Either `r vector_or(rsi_translation$method)`
|
||||
#' - `site`\cr Body site, e.g. "Oral" or "Respiratory"
|
||||
#' - `mo`\cr Microbial ID, see [as.mo()]
|
||||
#' - `ab`\cr Antibiotic ID, see [as.ab()]
|
||||
|
||||
@ -100,11 +100,20 @@
|
||||
#' size = 1,
|
||||
#' linetype = 2,
|
||||
#' alpha = 0.25)
|
||||
#'
|
||||
#'
|
||||
#' # you can alter the colours with colour names:
|
||||
#' example_isolates %>%
|
||||
#' select(AMX) %>%
|
||||
#' ggplot_rsi(colours = c(SI = "yellow"))
|
||||
#'
|
||||
#'
|
||||
#' # but you can also use the built-in colour-blind friendly colours for
|
||||
#' # your plots, where "S" is green, "I" is yellow and "R" is red:
|
||||
#' data.frame(x = c("Value1", "Value2", "Value3"),
|
||||
#' y = c(1, 2, 3),
|
||||
#' z = c("Value4", "Value5", "Value6")) %>%
|
||||
#' ggplot() +
|
||||
#' geom_col(aes(x = x, y = y, fill = z)) +
|
||||
#' scale_rsi_colours(Value4 = "S", Value5 = "I", Value6 = "R")
|
||||
#' }
|
||||
#'
|
||||
#' \donttest{
|
||||
@ -360,7 +369,7 @@ scale_y_percent <- function(breaks = seq(0, 1, 0.1), limits = NULL) {
|
||||
scale_rsi_colours <- function(...,
|
||||
aesthetics = "fill") {
|
||||
stop_ifnot_installed("ggplot2")
|
||||
meet_criteria(aesthetics, allow_class = c("character"), has_length = c(1, 2), is_in = c("alpha", "colour", "color", "fill", "linetype", "shape", "size"))
|
||||
meet_criteria(aesthetics, allow_class = "character", is_in = c("alpha", "colour", "color", "fill", "linetype", "shape", "size"))
|
||||
|
||||
# behaviour until AMR pkg v1.5.0 and also when coming from ggplot_rsi()
|
||||
if ("colours" %in% names(list(...))) {
|
||||
@ -376,14 +385,16 @@ scale_rsi_colours <- function(...,
|
||||
return(invisible())
|
||||
}
|
||||
|
||||
names_susceptible <- c("S", "SI", "IS", "S+I", "I+S", "susceptible",
|
||||
unique(translations_file[which(translations_file$pattern == "susceptible"),
|
||||
names_susceptible <- c("S", "SI", "IS", "S+I", "I+S", "susceptible", "Susceptible",
|
||||
unique(translations_file[which(translations_file$pattern == "Susceptible"),
|
||||
"replacement", drop = TRUE]))
|
||||
names_incr_exposure <- c("I", "intermediate", "increased exposure", "incr. exposure",
|
||||
unique(translations_file[which(translations_file$pattern == "intermediate"),
|
||||
names_incr_exposure <- c("I", "intermediate", "increased exposure", "incr. exposure", "Increased exposure", "Incr. exposure",
|
||||
unique(translations_file[which(translations_file$pattern == "Intermediate"),
|
||||
"replacement", drop = TRUE]),
|
||||
unique(translations_file[which(translations_file$pattern == "Incr. exposure"),
|
||||
"replacement", drop = TRUE]))
|
||||
names_resistant <- c("R", "IR", "RI", "R+I", "I+R", "resistant",
|
||||
unique(translations_file[which(translations_file$pattern == "resistant"),
|
||||
names_resistant <- c("R", "IR", "RI", "R+I", "I+R", "resistant", "Resistant",
|
||||
unique(translations_file[which(translations_file$pattern == "Resistant"),
|
||||
"replacement", drop = TRUE]))
|
||||
|
||||
susceptible <- rep("#3CAEA3", length(names_susceptible))
|
||||
@ -399,8 +410,8 @@ scale_rsi_colours <- function(...,
|
||||
dots[dots == "S"] <- "#3CAEA3"
|
||||
dots[dots == "I"] <- "#F6D55C"
|
||||
dots[dots == "R"] <- "#ED553B"
|
||||
colours <- replace(original_cols, names(dots), dots)
|
||||
ggplot2::scale_discrete_manual(aesthetics = aesthetics, values = colours)
|
||||
cols <- replace(original_cols, names(dots), dots)
|
||||
ggplot2::scale_discrete_manual(aesthetics = aesthetics, values = cols)
|
||||
}
|
||||
|
||||
#' @rdname ggplot_rsi
|
||||
|
||||
13
R/like.R
13
R/like.R
@ -100,13 +100,12 @@ like <- function(x, pattern, ignore.case = TRUE) {
|
||||
} else if (length(pattern) != length(x)) {
|
||||
stop_("arguments `x` and `pattern` must be of same length, or either one must be 1")
|
||||
}
|
||||
mapply(FUN = grepl,
|
||||
pattern,
|
||||
x,
|
||||
MoreArgs = list(ignore.case = FALSE, fixed = fixed, perl = !fixed),
|
||||
SIMPLIFY = TRUE,
|
||||
USE.NAMES = FALSE)
|
||||
|
||||
unlist(
|
||||
Map(f = grepl,
|
||||
pattern,
|
||||
x,
|
||||
MoreArgs = list(ignore.case = FALSE, fixed = fixed, perl = !fixed)),
|
||||
use.names = FALSE)
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
28
R/mo.R
28
R/mo.R
@ -463,16 +463,22 @@ exec_as.mo <- function(x,
|
||||
# translate 'unknown' names back to English
|
||||
if (any(x %like% "unbekannt|onbekend|desconocid|sconosciut|iconnu|desconhecid", na.rm = TRUE)) {
|
||||
trns <- subset(translations_file, pattern %like% "unknown" | affect_mo_name == TRUE)
|
||||
lapply(seq_len(nrow(trns)),
|
||||
function(i) x <<- gsub(pattern = trns$replacement[i],
|
||||
replacement = trns$pattern[i],
|
||||
x = x,
|
||||
ignore.case = TRUE,
|
||||
perl = TRUE))
|
||||
langs <- LANGUAGES_SUPPORTED[LANGUAGES_SUPPORTED != "en"]
|
||||
for (l in langs) {
|
||||
for (i in seq_len(nrow(trns))) {
|
||||
if (!is.na(trns[i, l, drop = TRUE])) {
|
||||
x <- gsub(pattern = trns[i, l, drop = TRUE],
|
||||
replacement = trns$pattern[i],
|
||||
x = x,
|
||||
ignore.case = TRUE,
|
||||
perl = TRUE)
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
x_backup <- x
|
||||
|
||||
|
||||
# from here on case-insensitive
|
||||
x <- tolower(x)
|
||||
|
||||
@ -1551,6 +1557,9 @@ exec_as.mo <- function(x,
|
||||
if (property == "mo") {
|
||||
x <- set_clean_class(x, new_class = c("mo", "character"))
|
||||
}
|
||||
|
||||
# keep track of time
|
||||
end_time <- Sys.time()
|
||||
|
||||
if (length(mo_renamed()) > 0) {
|
||||
print(mo_renamed())
|
||||
@ -1571,10 +1580,9 @@ exec_as.mo <- function(x,
|
||||
x <- structure(x, uncertainties = uncertainties)
|
||||
} else {
|
||||
# keep track of time - give some hints to improve speed if it takes a long time
|
||||
end_time <- Sys.time()
|
||||
delta_time <- difftime(end_time, start_time, units = "secs")
|
||||
if (delta_time >= 30) {
|
||||
message_("Using `as.mo()` took ", delta_time, " seconds, which is a long time. Some suggestions to improve speed include:")
|
||||
message_("Using `as.mo()` took ", round(delta_time), " seconds, which is a long time. Some suggestions to improve speed include:")
|
||||
message_(word_wrap("- Try to use as many valid taxonomic names as possible for your input.",
|
||||
extra_indent = 2),
|
||||
as_note = FALSE)
|
||||
@ -1922,7 +1930,7 @@ print.mo_renamed <- function(x, ...) {
|
||||
"",
|
||||
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])),
|
||||
ifelse(!x$new_ref[i] %in% c("", NA) && 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]),
|
||||
|
||||
@ -660,10 +660,20 @@ mo_url <- function(x, open = FALSE, language = get_locale(), ...) {
|
||||
pm_left_join(pm_select(microorganisms, mo, source, species_id), by = "mo")
|
||||
df$url <- ifelse(df$source == "CoL",
|
||||
paste0(catalogue_of_life$url_CoL, "details/species/id/", df$species_id, "/"),
|
||||
ifelse(df$source == "DSMZ",
|
||||
paste0(catalogue_of_life$url_DSMZ, "/advanced_search?adv[taxon-name]=", gsub(" ", "+", mo_names), "/"),
|
||||
NA_character_))
|
||||
NA_character_)
|
||||
u <- df$url
|
||||
u[mo_kingdom(mo) == "Bacteria"] <- paste0(catalogue_of_life$url_LPSN, "/species/", gsub(" ", "-", tolower(mo_names), fixed = TRUE))
|
||||
u[mo_kingdom(mo) == "Bacteria" & mo_rank(mo) == "genus"] <- gsub("/species/",
|
||||
"/genus/",
|
||||
u[mo_kingdom(mo) == "Bacteria" & mo_rank(mo) == "genus"],
|
||||
fixed = TRUE)
|
||||
u[mo_kingdom(mo) == "Bacteria" &
|
||||
mo_rank(mo) %in% c("subsp.", "infraspecies")] <- gsub("/species/",
|
||||
"/subspecies/",
|
||||
u[mo_kingdom(mo) == "Bacteria" &
|
||||
mo_rank(mo) %in% c("subsp.", "infraspecies")],
|
||||
fixed = TRUE)
|
||||
|
||||
names(u) <- mo_names
|
||||
|
||||
if (open == TRUE) {
|
||||
|
||||
113
R/plot.R
113
R/plot.R
@ -36,6 +36,7 @@
|
||||
#' @param ab any (vector of) text that can be coerced to a valid antimicrobial code with [as.ab()]
|
||||
#' @param guideline interpretation guideline to use, defaults to the latest included EUCAST guideline, see *Details*
|
||||
#' @param colours_RSI colours to use for filling in the bars, must be a vector of three values (in the order R, S and I). The default colours are colour-blind friendly.
|
||||
#' @param language language to be used to translate 'Susceptible', 'Increased exposure'/'Intermediate' and 'Resistant', defaults to system language (see [get_locale()]) and can be overwritten by setting the option `AMR_locale`, e.g. `options(AMR_locale = "de")`, see [translate]. Use `language = NULL` or `language = ""` to prevent translation.
|
||||
#' @param expand logical to indicate whether the range on the x axis should be expanded between the lowest and highest value. For MIC values, intermediate values will be factors of 2 starting from the highest MIC value. For disk diameters, the whole diameter range will be filled.
|
||||
#' @details
|
||||
#' The interpretation of "I" will be named "Increased exposure" for all EUCAST guidelines since 2019, and will be named "Intermediate" in all other cases.
|
||||
@ -79,15 +80,19 @@ plot.mic <- function(x,
|
||||
ab = NULL,
|
||||
guideline = "EUCAST",
|
||||
colours_RSI = c("#ED553B", "#3CAEA3", "#F6D55C"),
|
||||
language = get_locale(),
|
||||
expand = TRUE,
|
||||
...) {
|
||||
meet_criteria(main, allow_class = "character")
|
||||
meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(ylab, allow_class = "character", has_length = 1)
|
||||
meet_criteria(xlab, allow_class = "character", has_length = 1)
|
||||
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
|
||||
meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
|
||||
meet_criteria(guideline, allow_class = "character", has_length = 1)
|
||||
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(expand, allow_class = "logical", has_length = 1)
|
||||
|
||||
if (length(colours_RSI) == 1) {
|
||||
colours_RSI <- rep(colours_RSI, 3)
|
||||
}
|
||||
@ -101,6 +106,7 @@ plot.mic <- function(x,
|
||||
guideline = guideline,
|
||||
colours_RSI = colours_RSI,
|
||||
fn = as.mic,
|
||||
language = language,
|
||||
...)
|
||||
|
||||
barplot(x,
|
||||
@ -132,7 +138,7 @@ plot.mic <- function(x,
|
||||
}
|
||||
legend("top",
|
||||
x.intersp = 0.5,
|
||||
legend = legend_txt,
|
||||
legend = translate_AMR(legend_txt, language = language),
|
||||
fill = legend_col,
|
||||
horiz = TRUE,
|
||||
cex = 0.75,
|
||||
@ -152,15 +158,19 @@ barplot.mic <- function(height,
|
||||
ab = NULL,
|
||||
guideline = "EUCAST",
|
||||
colours_RSI = c("#ED553B", "#3CAEA3", "#F6D55C"),
|
||||
language = get_locale(),
|
||||
expand = TRUE,
|
||||
...) {
|
||||
meet_criteria(main, allow_class = "character")
|
||||
meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(ylab, allow_class = "character", has_length = 1)
|
||||
meet_criteria(xlab, allow_class = "character", has_length = 1)
|
||||
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
|
||||
meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
|
||||
meet_criteria(guideline, allow_class = "character", has_length = 1)
|
||||
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(expand, allow_class = "logical", has_length = 1)
|
||||
|
||||
main <- gsub(" +", " ", paste0(main, collapse = " "))
|
||||
|
||||
plot(x = height,
|
||||
@ -186,18 +196,26 @@ ggplot.mic <- function(data,
|
||||
ab = NULL,
|
||||
guideline = "EUCAST",
|
||||
colours_RSI = c("#ED553B", "#3CAEA3", "#F6D55C"),
|
||||
language = get_locale(),
|
||||
expand = TRUE,
|
||||
...) {
|
||||
stop_ifnot_installed("ggplot2")
|
||||
meet_criteria(title, allow_class = "character")
|
||||
meet_criteria(title, allow_class = "character", allow_NULL = TRUE)
|
||||
meet_criteria(ylab, allow_class = "character", has_length = 1)
|
||||
meet_criteria(xlab, allow_class = "character", has_length = 1)
|
||||
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
|
||||
meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
|
||||
meet_criteria(guideline, allow_class = "character", has_length = 1)
|
||||
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(expand, allow_class = "logical", has_length = 1)
|
||||
|
||||
title <- gsub(" +", " ", paste0(title, collapse = " "))
|
||||
if ("main" %in% names(list(...))) {
|
||||
title <- list(...)$main
|
||||
}
|
||||
if (!is.null(title)) {
|
||||
title <- gsub(" +", " ", paste0(title, collapse = " "))
|
||||
}
|
||||
|
||||
x <- plot_prepare_table(data, expand = expand)
|
||||
cols_sub <- plot_colours_subtitle_guideline(x = x,
|
||||
@ -206,6 +224,7 @@ ggplot.mic <- function(data,
|
||||
guideline = guideline,
|
||||
colours_RSI = colours_RSI,
|
||||
fn = as.mic,
|
||||
language = language,
|
||||
...)
|
||||
df <- as.data.frame(x, stringsAsFactors = TRUE)
|
||||
colnames(df) <- c("mic", "count")
|
||||
@ -213,8 +232,9 @@ ggplot.mic <- function(data,
|
||||
df$cols[df$cols == colours_RSI[1]] <- "Resistant"
|
||||
df$cols[df$cols == colours_RSI[2]] <- "Susceptible"
|
||||
df$cols[df$cols == colours_RSI[3]] <- plot_name_of_I(cols_sub$guideline)
|
||||
df$cols <- factor(df$cols,
|
||||
levels = c("Susceptible", plot_name_of_I(cols_sub$guideline), "Resistant"),
|
||||
df$cols <- factor(translate_AMR(df$cols, language = language),
|
||||
levels = translate_AMR(c("Susceptible", plot_name_of_I(cols_sub$guideline), "Resistant"),
|
||||
language = language),
|
||||
ordered = TRUE)
|
||||
if (!is.null(mapping)) {
|
||||
p <- ggplot2::ggplot(df, mapping = mapping)
|
||||
@ -223,12 +243,14 @@ ggplot.mic <- function(data,
|
||||
}
|
||||
|
||||
if (any(colours_RSI %in% cols_sub$cols)) {
|
||||
vals <- c("Resistant" = colours_RSI[1],
|
||||
"Susceptible" = colours_RSI[2],
|
||||
"Incr. exposure" = colours_RSI[3],
|
||||
"Intermediate" = colours_RSI[3])
|
||||
names(vals) <- translate_AMR(names(vals), language = language)
|
||||
p <- p +
|
||||
ggplot2::geom_col(ggplot2::aes(x = mic, y = count, fill = cols)) +
|
||||
ggplot2::scale_fill_manual(values = c("Resistant" = colours_RSI[1],
|
||||
"Susceptible" = colours_RSI[2],
|
||||
"Incr. exposure" = colours_RSI[3],
|
||||
"Intermediate" = colours_RSI[3]),
|
||||
ggplot2::scale_fill_manual(values = vals,
|
||||
name = NULL)
|
||||
} else {
|
||||
p <- p +
|
||||
@ -252,15 +274,19 @@ plot.disk <- function(x,
|
||||
ab = NULL,
|
||||
guideline = "EUCAST",
|
||||
colours_RSI = c("#ED553B", "#3CAEA3", "#F6D55C"),
|
||||
language = get_locale(),
|
||||
expand = TRUE,
|
||||
...) {
|
||||
meet_criteria(main, allow_class = "character")
|
||||
meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(ylab, allow_class = "character", has_length = 1)
|
||||
meet_criteria(xlab, allow_class = "character", has_length = 1)
|
||||
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
|
||||
meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
|
||||
meet_criteria(guideline, allow_class = "character", has_length = 1)
|
||||
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(expand, allow_class = "logical", has_length = 1)
|
||||
|
||||
if (length(colours_RSI) == 1) {
|
||||
colours_RSI <- rep(colours_RSI, 3)
|
||||
}
|
||||
@ -274,6 +300,7 @@ plot.disk <- function(x,
|
||||
guideline = guideline,
|
||||
colours_RSI = colours_RSI,
|
||||
fn = as.disk,
|
||||
language = language,
|
||||
...)
|
||||
|
||||
barplot(x,
|
||||
@ -305,7 +332,7 @@ plot.disk <- function(x,
|
||||
}
|
||||
legend("top",
|
||||
x.intersp = 0.5,
|
||||
legend = legend_txt,
|
||||
legend = translate_AMR(legend_txt, language = language),
|
||||
fill = legend_col,
|
||||
horiz = TRUE,
|
||||
cex = 0.75,
|
||||
@ -325,15 +352,18 @@ barplot.disk <- function(height,
|
||||
ab = NULL,
|
||||
guideline = "EUCAST",
|
||||
colours_RSI = c("#ED553B", "#3CAEA3", "#F6D55C"),
|
||||
language = get_locale(),
|
||||
expand = TRUE,
|
||||
...) {
|
||||
meet_criteria(main, allow_class = "character")
|
||||
meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(ylab, allow_class = "character", has_length = 1)
|
||||
meet_criteria(xlab, allow_class = "character", has_length = 1)
|
||||
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
|
||||
meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
|
||||
meet_criteria(guideline, allow_class = "character", has_length = 1)
|
||||
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(expand, allow_class = "logical", has_length = 1)
|
||||
|
||||
main <- gsub(" +", " ", paste0(main, collapse = " "))
|
||||
|
||||
@ -360,18 +390,26 @@ ggplot.disk <- function(data,
|
||||
ab = NULL,
|
||||
guideline = "EUCAST",
|
||||
colours_RSI = c("#ED553B", "#3CAEA3", "#F6D55C"),
|
||||
language = get_locale(),
|
||||
expand = TRUE,
|
||||
...) {
|
||||
stop_ifnot_installed("ggplot2")
|
||||
meet_criteria(title, allow_class = "character")
|
||||
meet_criteria(title, allow_class = "character", allow_NULL = TRUE)
|
||||
meet_criteria(ylab, allow_class = "character", has_length = 1)
|
||||
meet_criteria(xlab, allow_class = "character", has_length = 1)
|
||||
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
|
||||
meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
|
||||
meet_criteria(guideline, allow_class = "character", has_length = 1)
|
||||
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(expand, allow_class = "logical", has_length = 1)
|
||||
|
||||
title <- gsub(" +", " ", paste0(title, collapse = " "))
|
||||
if ("main" %in% names(list(...))) {
|
||||
title <- list(...)$main
|
||||
}
|
||||
if (!is.null(title)) {
|
||||
title <- gsub(" +", " ", paste0(title, collapse = " "))
|
||||
}
|
||||
|
||||
x <- plot_prepare_table(data, expand = expand)
|
||||
cols_sub <- plot_colours_subtitle_guideline(x = x,
|
||||
@ -380,15 +418,18 @@ ggplot.disk <- function(data,
|
||||
guideline = guideline,
|
||||
colours_RSI = colours_RSI,
|
||||
fn = as.disk,
|
||||
language = language,
|
||||
...)
|
||||
df <- as.data.frame(x, stringsAsFactors = TRUE)
|
||||
colnames(df) <- c("disk", "count")
|
||||
df$cols <- cols_sub$cols
|
||||
|
||||
df$cols[df$cols == colours_RSI[1]] <- "Resistant"
|
||||
df$cols[df$cols == colours_RSI[2]] <- "Susceptible"
|
||||
df$cols[df$cols == colours_RSI[3]] <- plot_name_of_I(cols_sub$guideline)
|
||||
df$cols <- factor(df$cols,
|
||||
levels = c("Resistant", plot_name_of_I(cols_sub$guideline), "Susceptible"),
|
||||
df$cols <- factor(translate_AMR(df$cols, language = language),
|
||||
levels = translate_AMR(c("Susceptible", plot_name_of_I(cols_sub$guideline), "Resistant"),
|
||||
language = language),
|
||||
ordered = TRUE)
|
||||
if (!is.null(mapping)) {
|
||||
p <- ggplot2::ggplot(df, mapping = mapping)
|
||||
@ -397,12 +438,14 @@ ggplot.disk <- function(data,
|
||||
}
|
||||
|
||||
if (any(colours_RSI %in% cols_sub$cols)) {
|
||||
vals <- c("Resistant" = colours_RSI[1],
|
||||
"Susceptible" = colours_RSI[2],
|
||||
"Incr. exposure" = colours_RSI[3],
|
||||
"Intermediate" = colours_RSI[3])
|
||||
names(vals) <- translate_AMR(names(vals), language = language)
|
||||
p <- p +
|
||||
ggplot2::geom_col(ggplot2::aes(x = disk, y = count, fill = cols)) +
|
||||
ggplot2::scale_fill_manual(values = c("Resistant" = colours_RSI[1],
|
||||
"Susceptible" = colours_RSI[2],
|
||||
"Incr. exposure" = colours_RSI[3],
|
||||
"Intermediate" = colours_RSI[3]),
|
||||
ggplot2::scale_fill_manual(values = vals,
|
||||
name = NULL)
|
||||
} else {
|
||||
p <- p +
|
||||
@ -457,7 +500,7 @@ plot_name_of_I <- function(guideline) {
|
||||
}
|
||||
}
|
||||
|
||||
plot_colours_subtitle_guideline <- function(x, mo, ab, guideline, colours_RSI, fn, ...) {
|
||||
plot_colours_subtitle_guideline <- function(x, mo, ab, guideline, colours_RSI, fn, language, ...) {
|
||||
guideline <- get_guideline(guideline, AMR::rsi_translation)
|
||||
if (!is.null(mo) && !is.null(ab)) {
|
||||
# interpret and give colour based on MIC values
|
||||
@ -469,14 +512,14 @@ plot_colours_subtitle_guideline <- function(x, mo, ab, guideline, colours_RSI, f
|
||||
cols[rsi == "R"] <- colours_RSI[1]
|
||||
cols[rsi == "S"] <- colours_RSI[2]
|
||||
cols[rsi == "I"] <- colours_RSI[3]
|
||||
moname <- mo_name(mo, language = NULL)
|
||||
abname <- ab_name(ab, language = NULL)
|
||||
moname <- mo_name(mo, language = language)
|
||||
abname <- ab_name(ab, language = language)
|
||||
if (all(cols == "#BEBEBE")) {
|
||||
message_("No ", guideline, " interpretations found for ",
|
||||
ab_name(ab, language = NULL, tolower = TRUE), " in ", moname)
|
||||
guideline_txt <- ""
|
||||
} else {
|
||||
guideline_txt <- paste0("(following ", guideline, ")")
|
||||
guideline_txt <- paste0("(", guideline, ")")
|
||||
}
|
||||
sub <- bquote(.(abname)~"in"~italic(.(moname))~.(guideline_txt))
|
||||
} else {
|
||||
@ -498,7 +541,7 @@ plot.rsi <- function(x,
|
||||
...) {
|
||||
meet_criteria(ylab, allow_class = "character", has_length = 1)
|
||||
meet_criteria(xlab, allow_class = "character", has_length = 1)
|
||||
meet_criteria(main, allow_class = "character", has_length = 1)
|
||||
meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||
|
||||
data <- as.data.frame(table(x), stringsAsFactors = FALSE)
|
||||
colnames(data) <- c("x", "n")
|
||||
@ -549,12 +592,16 @@ barplot.rsi <- function(height,
|
||||
xlab = "Antimicrobial Interpretation",
|
||||
ylab = "Frequency",
|
||||
colours_RSI = c("#ED553B", "#3CAEA3", "#F6D55C"),
|
||||
language = get_locale(),
|
||||
expand = TRUE,
|
||||
...) {
|
||||
meet_criteria(xlab, allow_class = "character", has_length = 1)
|
||||
meet_criteria(main, allow_class = "character", has_length = 1)
|
||||
meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(ylab, allow_class = "character", has_length = 1)
|
||||
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(expand, allow_class = "logical", has_length = 1)
|
||||
|
||||
if (length(colours_RSI) == 1) {
|
||||
colours_RSI <- rep(colours_RSI, 3)
|
||||
}
|
||||
@ -582,10 +629,18 @@ ggplot.rsi <- function(data,
|
||||
colours_RSI = c("#ED553B", "#3CAEA3", "#F6D55C"),
|
||||
...) {
|
||||
stop_ifnot_installed("ggplot2")
|
||||
meet_criteria(title, allow_class = "character")
|
||||
meet_criteria(title, allow_class = "character", allow_NULL = TRUE)
|
||||
meet_criteria(ylab, allow_class = "character", has_length = 1)
|
||||
meet_criteria(xlab, allow_class = "character", has_length = 1)
|
||||
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
|
||||
|
||||
if ("main" %in% names(list(...))) {
|
||||
title <- list(...)$main
|
||||
}
|
||||
if (!is.null(title)) {
|
||||
title <- gsub(" +", " ", paste0(title, collapse = " "))
|
||||
}
|
||||
|
||||
if (length(colours_RSI) == 1) {
|
||||
colours_RSI <- rep(colours_RSI, 3)
|
||||
}
|
||||
|
||||
BIN
R/sysdata.rda
BIN
R/sysdata.rda
Binary file not shown.
@ -142,7 +142,8 @@ translate_AMR <- function(from, language = get_locale(), only_unknown = FALSE, a
|
||||
vector_or(LANGUAGES_SUPPORTED, quotes = TRUE),
|
||||
call = FALSE)
|
||||
|
||||
df_trans <- subset(df_trans, lang == language)
|
||||
# only keep lines where translation is available for this language
|
||||
df_trans <- df_trans[which(!is.na(df_trans[, language, drop = TRUE])), , drop = FALSE]
|
||||
if (only_unknown == TRUE) {
|
||||
df_trans <- subset(df_trans, pattern %like% "unknown")
|
||||
}
|
||||
@ -150,10 +151,10 @@ translate_AMR <- function(from, language = get_locale(), only_unknown = FALSE, a
|
||||
df_trans <- subset(df_trans, affect_mo_name == TRUE)
|
||||
}
|
||||
|
||||
# default: case sensitive if value if 'ignore.case' is missing:
|
||||
df_trans$ignore.case[is.na(df_trans$ignore.case)] <- FALSE
|
||||
# default: not using regular expressions (fixed = TRUE) if 'fixed' is missing:
|
||||
df_trans$fixed[is.na(df_trans$fixed)] <- TRUE
|
||||
# default: case sensitive if value if 'case_sensitive' is missing:
|
||||
df_trans$case_sensitive[is.na(df_trans$case_sensitive)] <- TRUE
|
||||
# default: not using regular expressions if 'regular_expr' is missing:
|
||||
df_trans$regular_expr[is.na(df_trans$regular_expr)] <- FALSE
|
||||
|
||||
# check if text to look for is in one of the patterns
|
||||
any_form_in_patterns <- tryCatch(any(from_unique %like% paste0("(", paste(df_trans$pattern, collapse = "|"), ")")),
|
||||
@ -167,11 +168,11 @@ translate_AMR <- function(from, language = get_locale(), only_unknown = FALSE, a
|
||||
|
||||
lapply(seq_len(nrow(df_trans)),
|
||||
function(i) from_unique_translated <<- gsub(pattern = df_trans$pattern[i],
|
||||
replacement = df_trans$replacement[i],
|
||||
replacement = df_trans[i, language, drop = TRUE],
|
||||
x = from_unique_translated,
|
||||
ignore.case = df_trans$ignore.case[i],
|
||||
fixed = df_trans$fixed[i],
|
||||
perl = !df_trans$fixed[i]))
|
||||
ignore.case = !df_trans$case_sensitive[i],
|
||||
fixed = !df_trans$regular_expr[i],
|
||||
perl = df_trans$regular_expr[i]))
|
||||
|
||||
# force UTF-8 for diacritics
|
||||
from_unique_translated <- enc2utf8(from_unique_translated)
|
||||
|
||||
Reference in New Issue
Block a user