AMR/R/mo_property.R

541 lines
24 KiB
R
Raw Normal View History

# ==================================================================== #
# TITLE #
2020-10-08 11:16:03 +02:00
# Antimicrobial Resistance (AMR) Analysis for R #
# #
2019-01-02 23:24:07 +01:00
# SOURCE #
2020-07-08 14:48:06 +02:00
# https://github.com/msberends/AMR #
# #
# LICENCE #
# (c) 2018-2020 Berends MS, Luz CF et al. #
2020-10-08 11:16:03 +02:00
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
2019-01-02 23:24:07 +01:00
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
# GNU General Public License version 2.0 (GNU GPL-2), as published by #
# the Free Software Foundation. #
# We created this package for both routine data analysis and academic #
# research and it was publicly released in the hope that it will be #
# useful, but it comes WITHOUT ANY WARRANTY OR LIABILITY. #
2020-10-08 11:16:03 +02:00
# #
# Visit our website for the full manual and a complete tutorial about #
# how to conduct AMR analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
#' Get properties of a microorganism
#'
#' Use these functions to return a specific property of a microorganism based on the latest accepted taxonomy. All input values will be evaluated internally with [as.mo()], which makes it possible to use microbial abbreviations, codes and names as input. Please see *Examples*.
2020-05-25 01:01:14 +02:00
#' @inheritSection lifecycle Stable lifecycle
#' @param x any character (vector) that can be coerced to a valid microorganism code with [as.mo()]
#' @param property one of the column names of the [microorganisms] data set or `"shortname"`
#' @param language language of the returned text, 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 ... other parameters passed on to [as.mo()], such as 'allow_uncertain' and 'ignore_pattern'
#' @param open browse the URL using [utils::browseURL()]
#' @details All functions will return the most recently known taxonomic property according to the Catalogue of Life, except for [mo_ref()], [mo_authors()] and [mo_year()]. Please refer to this example, knowing that *Escherichia blattae* was renamed to *Shimwellia blattae* in 2010:
#' - `mo_name("Escherichia blattae")` will return `"Shimwellia blattae"` (with a message about the renaming)
#' - `mo_ref("Escherichia blattae")` will return `"Burgess et al., 1973"` (with a message about the renaming)
#' - `mo_ref("Shimwellia blattae")` will return `"Priest et al., 2010"` (without a message)
2019-02-20 00:04:48 +01:00
#'
#' The short name - [mo_shortname()] - almost always returns the first character of the genus and the full species, like `"E. coli"`. Exceptions are abbreviations of staphylococci (like *"CoNS"*, Coagulase-Negative Staphylococci) and beta-haemolytic streptococci (like *"GBS"*, Group B Streptococci). Please bear in mind that e.g. *E. coli* could mean *Escherichia coli* (kingdom of Bacteria) as well as *Entamoeba coli* (kingdom of Protozoa). Returning to the full name will be done using [as.mo()] internally, giving priority to bacteria and human pathogens, i.e. `"E. coli"` will be considered *Escherichia coli*. In other words, `mo_fullname(mo_shortname("Entamoeba coli"))` returns `"Escherichia coli"`.
#'
#' Since the top-level of the taxonomy is sometimes referred to as 'kingdom' and sometimes as 'domain', the functions [mo_kingdom()] and [mo_domain()] return the exact same results.
#'
#' The Gram stain - [mo_gramstain()] - will be determined based on the taxonomic kingdom and phylum. According to Cavalier-Smith (2002, [PMID 11837318](https://pubmed.ncbi.nlm.nih.gov/11837318)), who defined subkingdoms Negibacteria and Posibacteria, only these phyla are Posibacteria: Actinobacteria, Chloroflexi, Firmicutes and Tenericutes. These bacteria are considered Gram-positive - all other bacteria are considered Gram-negative. Species outside the kingdom of Bacteria will return a value `NA`. Functions [is_gram_negative()] and [is_gram_positive()] always return `TRUE` or `FALSE`, even for species outside the kingdom of Bacteria.
2019-02-20 00:04:48 +01:00
#'
#' All output will be [translate]d where possible.
2019-05-10 16:44:59 +02:00
#'
#' The function [mo_url()] will return the direct URL to the online database entry, which also shows the scientific reference of the concerned species.
2020-09-26 16:26:01 +02:00
#' @inheritSection mo_matching_score Matching score for microorganisms
2019-02-20 00:04:48 +01:00
#' @inheritSection catalogue_of_life Catalogue of Life
2018-09-24 23:33:29 +02:00
#' @inheritSection as.mo Source
#' @rdname mo_property
#' @name mo_property
#' @return
#' - An [integer] in case of [mo_year()]
#' - A [list] in case of [mo_taxonomy()] and [mo_info()]
#' - A named [character] in case of [mo_url()]
#' - A [double] in case of [mo_snomed()]
#' - A [character] in all other cases
#' @export
#' @seealso [microorganisms]
2020-08-21 11:40:13 +02:00
#' @inheritSection AMR Reference data publicly available
2019-01-02 23:24:07 +01:00
#' @inheritSection AMR Read more on our website!
#' @examples
#' # taxonomic tree -----------------------------------------------------------
2018-11-09 13:11:54 +01:00
#' mo_kingdom("E. coli") # "Bacteria"
2018-09-17 20:53:32 +02:00
#' mo_phylum("E. coli") # "Proteobacteria"
#' mo_class("E. coli") # "Gammaproteobacteria"
2019-11-24 22:48:56 +01:00
#' mo_order("E. coli") # "Enterobacterales"
#' mo_family("E. coli") # "Enterobacteriaceae"
#' mo_genus("E. coli") # "Escherichia"
#' mo_species("E. coli") # "coli"
2019-02-20 00:04:48 +01:00
#' mo_subspecies("E. coli") # ""
2018-11-09 13:11:54 +01:00
#'
#' # colloquial properties ----------------------------------------------------
2019-05-13 12:21:57 +02:00
#' mo_name("E. coli") # "Escherichia coli"
2020-01-27 19:14:23 +01:00
#' mo_fullname("E. coli") # "Escherichia coli" - same as mo_name()
2018-09-05 10:51:46 +02:00
#' mo_shortname("E. coli") # "E. coli"
2018-11-09 13:11:54 +01:00
#'
#' # other properties ---------------------------------------------------------
2019-06-11 14:18:25 +02:00
#' mo_gramstain("E. coli") # "Gram-negative"
2020-01-27 19:14:23 +01:00
#' mo_snomed("E. coli") # 112283007, 116395006, ... (SNOMED codes)
2019-06-11 14:18:25 +02:00
#' mo_type("E. coli") # "Bacteria" (equal to kingdom, but may be translated)
2019-02-22 22:12:10 +01:00
#' mo_rank("E. coli") # "species"
2019-05-10 16:44:59 +02:00
#' mo_url("E. coli") # get the direct url to the online database entry
#' mo_synonyms("E. coli") # get previously accepted taxonomic names
2018-11-09 13:11:54 +01:00
#'
#' # scientific reference -----------------------------------------------------
2019-02-22 22:12:10 +01:00
#' mo_ref("E. coli") # "Castellani et al., 1919"
#' mo_authors("E. coli") # "Castellani et al."
2018-11-09 13:11:54 +01:00
#' mo_year("E. coli") # 1919
#'
#' # abbreviations known in the field -----------------------------------------
#' mo_genus("MRSA") # "Staphylococcus"
#' mo_species("MRSA") # "aureus"
#' mo_shortname("VISA") # "S. aureus"
#' mo_gramstain("VISA") # "Gram-positive"
#'
#' mo_genus("EHEC") # "Escherichia"
#' mo_species("EHEC") # "coli"
#'
#' # known subspecies ---------------------------------------------------------
#' mo_name("doylei") # "Campylobacter jejuni doylei"
#' mo_genus("doylei") # "Campylobacter"
#' mo_species("doylei") # "jejuni"
#' mo_subspecies("doylei") # "doylei"
#'
2018-09-24 23:33:29 +02:00
#' mo_fullname("K. pneu rh") # "Klebsiella pneumoniae rhinoscleromatis"
2018-09-05 10:51:46 +02:00
#' mo_shortname("K. pneu rh") # "K. pneumoniae"
#'
#' \donttest{
#' # Becker classification, see ?as.mo ----------------------------------------
2018-09-05 12:21:27 +02:00
#' mo_fullname("S. epi") # "Staphylococcus epidermidis"
2019-03-18 14:29:41 +01:00
#' mo_fullname("S. epi", Becker = TRUE) # "Coagulase-negative Staphylococcus (CoNS)"
2018-09-05 12:21:27 +02:00
#' mo_shortname("S. epi") # "S. epidermidis"
#' mo_shortname("S. epi", Becker = TRUE) # "CoNS"
#'
#' # Lancefield classification, see ?as.mo ------------------------------------
2018-09-05 12:21:27 +02:00
#' mo_fullname("S. pyo") # "Streptococcus pyogenes"
#' mo_fullname("S. pyo", Lancefield = TRUE) # "Streptococcus group A"
#' mo_shortname("S. pyo") # "S. pyogenes"
2019-06-27 11:57:45 +02:00
#' mo_shortname("S. pyo", Lancefield = TRUE) # "GAS" (='Group A Streptococci')
#'
#'
2019-02-22 22:12:10 +01:00
#' # language support for German, Dutch, Spanish, Portuguese, Italian and French
2018-09-24 23:33:29 +02:00
#' mo_gramstain("E. coli", language = "de") # "Gramnegativ"
#' mo_gramstain("E. coli", language = "nl") # "Gram-negatief"
#' mo_gramstain("E. coli", language = "es") # "Gram negativo"
#'
2018-11-09 13:11:54 +01:00
#' # mo_type is equal to mo_kingdom, but mo_kingdom will remain official
#' mo_kingdom("E. coli") # "Bacteria" on a German system
#' mo_type("E. coli") # "Bakterien" on a German system
#' mo_type("E. coli") # "Bacteria" on an English system
#'
2018-09-09 12:11:44 +02:00
#' mo_fullname("S. pyogenes",
#' Lancefield = TRUE,
#' language = "de") # "Streptococcus Gruppe A"
2018-09-09 12:11:44 +02:00
#' mo_fullname("S. pyogenes",
#' Lancefield = TRUE,
#' language = "nl") # "Streptococcus groep A"
2018-09-17 20:53:32 +02:00
#'
#'
2019-05-10 16:44:59 +02:00
#' # get a list with the complete taxonomy (from kingdom to subspecies)
2018-09-17 20:53:32 +02:00
#' mo_taxonomy("E. coli")
#' # get a list with the taxonomy, the authors, Gram-stain and URL to the online database
2019-06-11 14:18:25 +02:00
#' mo_info("E. coli")
#' }
2019-05-13 12:21:57 +02:00
mo_name <- function(x, language = get_locale(), ...) {
2020-10-19 20:44:45 +02:00
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
2020-09-14 12:21:23 +02:00
translate_AMR(mo_validate(x = x, property = "fullname", language = language, ...), language = language, only_unknown = FALSE)
2019-05-13 12:21:57 +02:00
}
#' @rdname mo_property
#' @export
2019-06-11 14:18:25 +02:00
mo_fullname <- mo_name
2018-09-05 10:51:46 +02:00
#' @rdname mo_property
#' @export
2018-11-05 13:20:32 +01:00
mo_shortname <- function(x, language = get_locale(), ...) {
2020-10-19 20:44:45 +02:00
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
2020-09-14 12:21:23 +02:00
x.mo <- as.mo(x, language = language, ...)
2020-07-13 09:17:24 +02:00
metadata <- get_mo_failures_uncertainties_renamed()
2020-07-13 09:17:24 +02:00
2019-07-10 21:36:51 +02:00
replace_empty <- function(x) {
x[x == ""] <- "spp."
x
}
2019-06-27 11:57:45 +02:00
# get first char of genus and complete species in English
2020-08-26 11:33:54 +02:00
genera <- mo_genus(x.mo, language = NULL)
shortnames <- paste0(substr(genera, 1, 1), ". ", replace_empty(mo_species(x.mo, language = NULL)))
2020-07-13 09:17:24 +02:00
2020-08-26 11:33:54 +02:00
# exceptions for where no species is known
shortnames[shortnames %like% ".[.] spp[.]"] <- genera[shortnames %like% ".[.] spp[.]"]
2019-06-27 11:57:45 +02:00
# exceptions for Staphylococci
2019-10-11 17:21:02 +02:00
shortnames[shortnames == "S. coagulase-negative"] <- "CoNS"
shortnames[shortnames == "S. coagulase-positive"] <- "CoPS"
2019-07-09 11:22:46 +02:00
# exceptions for Streptococci: Streptococcus Group A -> GAS
2019-06-27 11:57:45 +02:00
shortnames[shortnames %like% "S. group [ABCDFGHK]"] <- paste0("G", gsub("S. group ([ABCDFGHK])", "\\1", shortnames[shortnames %like% "S. group [ABCDFGHK]"]), "S")
2020-08-26 11:33:54 +02:00
# unknown species etc.
shortnames[shortnames %like% "unknown"] <- paste0("(", trimws(gsub("[^a-zA-Z -]", "", shortnames[shortnames %like% "unknown"])), ")")
2020-07-13 09:17:24 +02:00
load_mo_failures_uncertainties_renamed(metadata)
2019-06-27 11:57:45 +02:00
translate_AMR(shortnames, language = language, only_unknown = FALSE)
2018-09-05 10:51:46 +02:00
}
2018-09-17 20:53:32 +02:00
#' @rdname mo_property
#' @export
2018-11-05 13:20:32 +01:00
mo_subspecies <- function(x, language = get_locale(), ...) {
2020-10-19 20:44:45 +02:00
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
2020-09-14 12:21:23 +02:00
translate_AMR(mo_validate(x = x, property = "subspecies", language = language, ...), language = language, only_unknown = TRUE)
2018-09-17 20:53:32 +02:00
}
#' @rdname mo_property
#' @export
2018-11-05 13:20:32 +01:00
mo_species <- function(x, language = get_locale(), ...) {
2020-10-19 20:44:45 +02:00
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
2020-09-14 12:21:23 +02:00
translate_AMR(mo_validate(x = x, property = "species", language = language, ...), language = language, only_unknown = TRUE)
2018-09-17 20:53:32 +02:00
}
#' @rdname mo_property
#' @export
2018-11-05 13:20:32 +01:00
mo_genus <- function(x, language = get_locale(), ...) {
2020-10-19 20:44:45 +02:00
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
2020-09-14 12:21:23 +02:00
translate_AMR(mo_validate(x = x, property = "genus", language = language, ...), language = language, only_unknown = TRUE)
2018-09-17 20:53:32 +02:00
}
#' @rdname mo_property
#' @export
2019-03-09 08:21:00 +01:00
mo_family <- function(x, language = get_locale(), ...) {
2020-10-19 20:44:45 +02:00
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
2020-09-14 12:21:23 +02:00
translate_AMR(mo_validate(x = x, property = "family", language = language, ...), language = language, only_unknown = TRUE)
2018-09-17 20:53:32 +02:00
}
#' @rdname mo_property
#' @export
2019-03-09 08:21:00 +01:00
mo_order <- function(x, language = get_locale(), ...) {
2020-10-19 20:44:45 +02:00
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
2020-09-14 12:21:23 +02:00
translate_AMR(mo_validate(x = x, property = "order", language = language, ...), language = language, only_unknown = TRUE)
2018-09-17 20:53:32 +02:00
}
#' @rdname mo_property
#' @export
2019-03-09 08:21:00 +01:00
mo_class <- function(x, language = get_locale(), ...) {
2020-10-19 20:44:45 +02:00
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
2020-09-14 12:21:23 +02:00
translate_AMR(mo_validate(x = x, property = "class", language = language, ...), language = language, only_unknown = TRUE)
2018-09-17 20:53:32 +02:00
}
#' @rdname mo_property
#' @export
2019-03-09 08:21:00 +01:00
mo_phylum <- function(x, language = get_locale(), ...) {
2020-10-19 20:44:45 +02:00
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
2020-09-14 12:21:23 +02:00
translate_AMR(mo_validate(x = x, property = "phylum", language = language, ...), language = language, only_unknown = TRUE)
2018-09-17 20:53:32 +02:00
}
2018-09-05 10:51:46 +02:00
#' @rdname mo_property
#' @export
2019-03-09 08:21:00 +01:00
mo_kingdom <- function(x, language = get_locale(), ...) {
2020-10-19 20:44:45 +02:00
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
2020-09-14 12:21:23 +02:00
translate_AMR(mo_validate(x = x, property = "kingdom", language = language, ...), language = language, only_unknown = TRUE)
}
#' @rdname mo_property
#' @export
mo_domain <- mo_kingdom
#' @rdname mo_property
#' @export
2018-11-05 13:20:32 +01:00
mo_type <- function(x, language = get_locale(), ...) {
2020-10-19 20:44:45 +02:00
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
2020-09-14 12:21:23 +02:00
translate_AMR(mo_validate(x = x, property = "kingdom", language = language, ...), language = language, only_unknown = FALSE)
2018-11-09 13:11:54 +01:00
}
#' @rdname mo_property
#' @export
mo_gramstain <- function(x, language = get_locale(), ...) {
2020-10-19 20:44:45 +02:00
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
2020-09-14 12:21:23 +02:00
x.mo <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
2020-07-13 09:17:24 +02:00
x.phylum <- mo_phylum(x.mo)
2019-06-11 14:18:25 +02:00
# DETERMINE GRAM STAIN FOR BACTERIA
# Source: https://itis.gov/servlet/SingleRpt/SingleRpt?search_topic=TSN&search_value=956097
# It says this:
# Kingdom Bacteria (Cavalier-Smith, 2002)
# Subkingdom Posibacteria (Cavalier-Smith, 2002)
# Direct Children:
# Phylum Actinobacteria (Cavalier-Smith, 2002)
# Phylum Chloroflexi (Garrity and Holt, 2002)
# Phylum Firmicutes (corrig. Gibbons and Murray, 1978)
# Phylum Tenericutes (Murray, 1984)
x <- NA_character_
# make all bacteria Gram negative
x[mo_kingdom(x.mo) == "Bacteria"] <- "Gram-negative"
2019-06-11 14:18:25 +02:00
# overwrite these phyla with Gram positive
2019-02-28 13:56:28 +01:00
x[x.phylum %in% c("Actinobacteria",
"Chloroflexi",
"Firmicutes",
2019-06-11 14:18:25 +02:00
"Tenericutes")
| x.mo == "B_GRAMP"] <- "Gram-positive"
2020-07-13 09:17:24 +02:00
load_mo_failures_uncertainties_renamed(metadata)
2019-06-11 14:18:25 +02:00
translate_AMR(x, language = language, only_unknown = FALSE)
2018-10-01 11:39:43 +02:00
}
#' @rdname mo_property
#' @export
is_gram_negative <- function(x, ...) {
2020-10-19 20:44:45 +02:00
meet_criteria(x, allow_NA = TRUE)
grams <- mo_gramstain(x, language = NULL, ...)
"Gram-negative" == grams & !is.na(grams)
}
#' @rdname mo_property
#' @export
is_gram_positive <- function(x, ...) {
2020-10-19 20:44:45 +02:00
meet_criteria(x, allow_NA = TRUE)
grams <- mo_gramstain(x, language = NULL, ...)
"Gram-positive" == grams & !is.na(grams)
}
2020-01-27 19:14:23 +01:00
#' @rdname mo_property
#' @export
2020-09-14 12:21:23 +02:00
mo_snomed <- function(x, language = get_locale(), ...) {
2020-10-19 20:44:45 +02:00
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
2020-09-14 12:21:23 +02:00
mo_validate(x = x, property = "snomed", language = language, ...)
2020-01-27 19:14:23 +01:00
}
2018-10-01 11:39:43 +02:00
#' @rdname mo_property
#' @export
2020-09-14 12:21:23 +02:00
mo_ref <- function(x, language = get_locale(), ...) {
2020-10-19 20:44:45 +02:00
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
2020-09-14 12:21:23 +02:00
mo_validate(x = x, property = "ref", language = language, ...)
}
#' @rdname mo_property
#' @export
2020-09-14 12:21:23 +02:00
mo_authors <- function(x, language = get_locale(), ...) {
2020-10-19 20:44:45 +02:00
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
2020-09-14 12:21:23 +02:00
x <- mo_validate(x = x, property = "ref", language = language, ...)
2019-06-22 14:49:12 +02:00
# remove last 4 digits and presumably the comma and space that preceed them
2018-11-09 13:11:54 +01:00
x[!is.na(x)] <- gsub(",? ?[0-9]{4}", "", x[!is.na(x)])
2019-02-22 22:12:10 +01:00
suppressWarnings(x)
2018-11-09 13:11:54 +01:00
}
2018-09-24 23:33:29 +02:00
2018-11-09 13:11:54 +01:00
#' @rdname mo_property
#' @export
2020-09-14 12:21:23 +02:00
mo_year <- function(x, language = get_locale(), ...) {
2020-10-19 20:44:45 +02:00
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
2020-09-14 12:21:23 +02:00
x <- mo_validate(x = x, property = "ref", language = language, ...)
2018-11-09 13:11:54 +01:00
# get last 4 digits
x[!is.na(x)] <- gsub(".*([0-9]{4})$", "\\1", x[!is.na(x)])
2019-02-22 22:12:10 +01:00
suppressWarnings(as.integer(x))
}
#' @rdname mo_property
#' @export
2020-09-14 12:21:23 +02:00
mo_rank <- function(x, language = get_locale(), ...) {
2020-10-19 20:44:45 +02:00
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
2020-09-14 12:21:23 +02:00
mo_validate(x = x, property = "rank", language = language, ...)
}
2018-09-17 20:53:32 +02:00
#' @rdname mo_property
#' @export
2019-03-09 08:21:00 +01:00
mo_taxonomy <- function(x, language = get_locale(), ...) {
2020-10-19 20:44:45 +02:00
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
2020-09-14 12:21:23 +02:00
x <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
2020-07-13 09:17:24 +02:00
result <- list(kingdom = mo_kingdom(x, language = language),
2020-10-19 20:44:45 +02:00
phylum = mo_phylum(x, language = language),
class = mo_class(x, language = language),
order = mo_order(x, language = language),
family = mo_family(x, language = language),
genus = mo_genus(x, language = language),
species = mo_species(x, language = language),
subspecies = mo_subspecies(x, language = language))
2020-07-13 09:17:24 +02:00
load_mo_failures_uncertainties_renamed(metadata)
result
2018-09-17 20:53:32 +02:00
}
#' @rdname mo_property
#' @export
2020-09-14 12:21:23 +02:00
mo_synonyms <- function(x, language = get_locale(), ...) {
2020-10-19 20:44:45 +02:00
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
2020-09-14 12:21:23 +02:00
x <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
2020-07-13 09:17:24 +02:00
2020-05-27 16:37:49 +02:00
IDs <- mo_name(x = x, language = NULL)
syns <- lapply(IDs, function(newname) {
res <- sort(microorganisms.old[which(microorganisms.old$fullname_new == newname), "fullname"])
2019-06-22 14:49:12 +02:00
if (length(res) == 0) {
NULL
} else {
res
}
})
if (length(syns) > 1) {
names(syns) <- mo_name(x)
result <- syns
2019-06-22 14:49:12 +02:00
} else {
result <- unlist(syns)
}
2020-07-13 09:17:24 +02:00
load_mo_failures_uncertainties_renamed(metadata)
result
}
2019-06-11 14:18:25 +02:00
#' @rdname mo_property
#' @export
mo_info <- function(x, language = get_locale(), ...) {
2020-10-19 20:44:45 +02:00
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
2020-09-14 12:21:23 +02:00
x <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
2020-07-13 09:17:24 +02:00
2019-06-22 14:49:12 +02:00
info <- lapply(x, function(y)
c(mo_taxonomy(y, language = language),
list(synonyms = mo_synonyms(y),
gramstain = mo_gramstain(y, language = language),
2019-06-22 14:49:12 +02:00
url = unname(mo_url(y, open = FALSE)),
ref = mo_ref(y))))
if (length(info) > 1) {
names(info) <- mo_name(x)
result <- info
2019-06-22 14:49:12 +02:00
} else {
result <- info[[1L]]
2019-06-22 14:49:12 +02:00
}
2020-07-13 09:17:24 +02:00
load_mo_failures_uncertainties_renamed(metadata)
result
2019-06-11 14:18:25 +02:00
}
2019-02-20 00:04:48 +01:00
#' @rdname mo_property
#' @export
2020-09-14 12:21:23 +02:00
mo_url <- function(x, open = FALSE, language = get_locale(), ...) {
2020-10-19 20:44:45 +02:00
meet_criteria(x, allow_NA = TRUE)
meet_criteria(open, allow_class = "logical", has_length = 1)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
2020-09-14 12:21:23 +02:00
mo <- as.mo(x = x, language = language, ... = ...)
2020-02-14 19:54:13 +01:00
mo_names <- mo_name(mo)
metadata <- get_mo_failures_uncertainties_renamed()
2020-05-16 13:05:47 +02:00
df <- data.frame(mo, stringsAsFactors = FALSE) %pm>%
2020-10-19 20:44:45 +02:00
pm_left_join(pm_select(microorganisms, mo, source, species_id), by = "mo")
2020-05-16 13:05:47 +02:00
df$url <- ifelse(df$source == "CoL",
2020-05-27 16:37:49 +02:00
paste0(catalogue_of_life$url_CoL, "details/species/id/", df$species_id, "/"),
2020-05-16 13:05:47 +02:00
ifelse(df$source == "DSMZ",
2020-05-27 16:37:49 +02:00
paste0(catalogue_of_life$url_DSMZ, "/advanced_search?adv[taxon-name]=", gsub(" ", "+", mo_names), "/"),
2020-05-16 13:05:47 +02:00
NA_character_))
2019-03-18 14:29:41 +01:00
u <- df$url
2019-09-20 12:33:05 +02:00
names(u) <- mo_names
2020-05-16 13:05:47 +02:00
2019-02-22 22:12:10 +01:00
if (open == TRUE) {
if (length(u) > 1) {
2019-03-18 14:29:41 +01:00
warning("only the first URL will be opened, as `browseURL()` only suports one string.")
2019-02-22 22:12:10 +01:00
}
2020-05-16 13:05:47 +02:00
utils::browseURL(u[1L])
2019-02-22 22:12:10 +01:00
}
2020-07-13 09:17:24 +02:00
load_mo_failures_uncertainties_renamed(metadata)
2019-02-20 00:04:48 +01:00
u
}
2018-11-09 13:11:54 +01:00
#' @rdname mo_property
#' @export
2019-10-11 17:21:02 +02:00
mo_property <- function(x, property = "fullname", language = get_locale(), ...) {
2020-10-19 20:44:45 +02:00
meet_criteria(x, allow_NA = TRUE)
meet_criteria(property, allow_class = "character", has_length = 1, is_in = colnames(microorganisms))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
2020-10-19 20:44:45 +02:00
2020-09-14 12:21:23 +02:00
translate_AMR(mo_validate(x = x, property = property, language = language, ...), language = language, only_unknown = TRUE)
}
2020-09-14 12:21:23 +02:00
mo_validate <- function(x, property, language, ...) {
2020-02-14 19:54:13 +01:00
check_dataset_integrity()
2020-07-13 09:17:24 +02:00
2020-10-04 19:26:43 +02:00
if (tryCatch(all(x[!is.na(x)] %in% MO_lookup$mo) & length(list(...)) == 0, error = function(e) FALSE)) {
# special case for mo_* functions where class is already <mo>
return(MO_lookup[match(x, MO_lookup$mo), property, drop = TRUE])
}
2018-10-01 11:39:43 +02:00
dots <- list(...)
Becker <- dots$Becker
if (is.null(Becker)) {
Becker <- FALSE
}
Lancefield <- dots$Lancefield
if (is.null(Lancefield)) {
Lancefield <- FALSE
}
2020-07-13 09:17:24 +02:00
2019-03-26 14:24:03 +01:00
# try to catch an error when inputting an invalid parameter
2019-05-10 16:44:59 +02:00
# so the 'call.' can be set to FALSE
2020-05-16 13:05:47 +02:00
tryCatch(x[1L] %in% MO_lookup[1, property, drop = TRUE],
2019-03-26 14:24:03 +01:00
error = function(e) stop(e$message, call. = FALSE))
2019-08-26 10:03:37 +02:00
if (is.mo(x)
& !Becker %in% c(TRUE, "all")
& !Lancefield %in% c(TRUE, "all")) {
# this will not reset mo_uncertainties and mo_failures
# because it's already a valid MO
2020-09-14 12:21:23 +02:00
x <- exec_as.mo(x, property = property, initial_search = FALSE, language = language, ...)
2020-05-16 13:05:47 +02:00
} else if (!all(x %in% MO_lookup[, property, drop = TRUE])
2019-08-26 10:03:37 +02:00
| Becker %in% c(TRUE, "all")
| Lancefield %in% c(TRUE, "all")) {
2020-09-14 12:21:23 +02:00
x <- exec_as.mo(x, property = property, language = language, ...)
2019-06-22 14:49:12 +02:00
}
2019-08-26 10:03:37 +02:00
2019-06-22 14:49:12 +02:00
if (property == "mo") {
2019-08-07 15:37:39 +02:00
return(to_class_mo(x))
2020-01-27 19:14:23 +01:00
} else if (property == "snomed") {
return(as.double(eval(parse(text = x))))
} else {
2019-06-22 14:49:12 +02:00
return(x)
}
}