2018-08-28 13:51:13 +02:00
# ==================================================================== #
# TITLE #
2021-02-02 23:57:35 +01:00
# Antimicrobial Resistance (AMR) Data Analysis for R #
2018-08-28 13:51:13 +02:00
# #
2019-01-02 23:24:07 +01:00
# SOURCE #
2020-07-08 14:48:06 +02:00
# https://github.com/msberends/AMR #
2018-08-28 13:51:13 +02:00
# #
# LICENCE #
2020-12-27 00:30:28 +01:00
# (c) 2018-2021 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 #
2020-10-26 12:23:03 +01:00
# Diagnostics & Advice, and University Medical Center Groningen. #
2018-08-28 13:51:13 +02:00
# #
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. #
2020-01-05 17:22:09 +01:00
# 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 #
2021-02-02 23:57:35 +01:00
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
2018-08-28 13:51:13 +02:00
# ==================================================================== #
2021-01-18 16:57:56 +01:00
#' Get Properties of a Microorganism
2018-08-28 13:51:13 +02:00
#'
2021-01-18 16:57:56 +01:00
#' 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. See *Examples*.
#' @inheritSection lifecycle Stable Lifecycle
#' @param x any character (vector) that can be coerced to a valid microorganism code with [as.mo()]. Can be left blank for auto-guessing the column containing microorganism codes if used in a data set, see *Examples*.
2021-02-04 16:48:16 +01:00
#' @param property one of the column names of the [microorganisms] data set: `r vector_or(colnames(microorganisms), sort = FALSE, quotes = TRUE)`, or must be `"shortname"`
2020-10-26 12:23:03 +01:00
#' @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]. Also used to translate text like "no growth". Use `language = NULL` or `language = ""` to prevent translation.
2020-12-22 00:51:17 +01:00
#' @param ... other arguments passed on to [as.mo()], such as 'allow_uncertain' and 'ignore_pattern'
2020-11-16 11:03:24 +01:00
#' @param ab any (vector of) text that can be coerced to a valid antibiotic code with [as.ab()]
2020-12-24 23:29:10 +01:00
#' @param open browse the URL using [`browseURL()`][utils::browseURL()]
2020-06-22 11:18:40 +02:00
#' @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
#'
2020-12-17 16:22:25 +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 (such as *"CoNS"*, Coagulase-Negative Staphylococci) and beta-haemolytic streptococci (such as *"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"`.
2020-10-26 12:23:03 +01:00
#'
2020-06-22 11:18:40 +02:00
#' 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.
2020-04-29 14:33:44 +02:00
#'
2020-11-16 11:03:24 +01:00
#' 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 [mo_is_gram_negative()] and [mo_is_gram_positive()] always return `TRUE` or `FALSE` (except when the input is `NA` or the MO code is `UNKNOWN`), thus always return `FALSE` for species outside the taxonomic kingdom of Bacteria.
#'
2021-02-08 14:18:42 +01:00
#' Determination of yeasts - [mo_is_yeast()] - will be based on the taxonomic kingdom and class. *Budding yeasts* are fungi of the phylum Ascomycetes, class Saccharomycetes (also called Hemiascomycetes). *True yeasts* are aggregated into the underlying order Saccharomycetales. Thus, for all microorganisms that are fungi and member of the taxonomic class Saccharomycetes, the function will return `TRUE`. It returns `FALSE` otherwise (except when the input is `NA` or the MO code is `UNKNOWN`).
2021-01-12 22:08:04 +01:00
#'
2021-02-08 14:18:42 +01:00
#' Intrinsic resistance - [mo_is_intrinsic_resistant()] - will be determined based on the [intrinsic_resistant] data set, which is based on `r format_eucast_version_nr(3.2)`. The [mo_is_intrinsic_resistant()] functions can be vectorised over arguments `x` (input for microorganisms) and over `ab` (input for antibiotics).
2019-02-20 00:04:48 +01:00
#'
2021-02-08 14:18:42 +01:00
#' All output [will be translated][translate] where possible.
2019-05-10 16:44:59 +02:00
#'
2019-11-28 22:32:17 +01: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.
2021-01-18 16:57:56 +01: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
2018-08-28 13:51:13 +02:00
#' @rdname mo_property
2018-09-08 16:06:47 +02:00
#' @name mo_property
2019-11-28 22:32:17 +01:00
#' @return
2020-09-18 16:05:53 +02:00
#' - 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
2018-08-28 13:51:13 +02:00
#' @export
2019-11-28 22:32:17 +01:00
#' @seealso [microorganisms]
2021-01-18 16:57:56 +01:00
#' @inheritSection AMR Reference Data Publicly Available
#' @inheritSection AMR Read more on Our Website!
2018-08-28 13:51:13 +02:00
#' @examples
2019-08-09 14:28:46 +02:00
#' # 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"
2018-09-04 11:33:30 +02:00
#' 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
#'
2019-08-09 14:28:46 +02: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
#'
2019-08-09 14:28:46 +02: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
2019-06-16 21:42:40 +02:00
#' mo_synonyms("E. coli") # get previously accepted taxonomic names
2018-11-09 13:11:54 +01:00
#'
2019-08-09 14:28:46 +02: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
2018-08-28 13:51:13 +02:00
#'
2019-08-09 14:28:46 +02:00
#' # abbreviations known in the field -----------------------------------------
2018-09-04 11:33:30 +02:00
#' mo_genus("MRSA") # "Staphylococcus"
#' mo_species("MRSA") # "aureus"
2019-08-09 14:28:46 +02:00
#' mo_shortname("VISA") # "S. aureus"
#' mo_gramstain("VISA") # "Gram-positive"
2018-08-28 13:51:13 +02:00
#'
2019-08-09 14:28:46 +02:00
#' mo_genus("EHEC") # "Escherichia"
#' mo_species("EHEC") # "coli"
2018-08-28 13:51:13 +02:00
#'
2019-08-09 14:28:46 +02:00
#' # known subspecies ---------------------------------------------------------
2019-05-20 12:00:18 +02:00
#' mo_name("doylei") # "Campylobacter jejuni doylei"
2018-09-04 11:33:30 +02:00
#' mo_genus("doylei") # "Campylobacter"
#' mo_species("doylei") # "jejuni"
2019-05-20 12:00:18 +02:00
#' mo_subspecies("doylei") # "doylei"
2018-09-04 11:33:30 +02:00
#'
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"
2018-08-28 13:51:13 +02:00
#'
2019-08-09 14:28:46 +02:00
#' \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"
2018-09-04 11:33:30 +02:00
#'
2019-08-09 14:28:46 +02:00
#' # 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')
2018-09-08 16:06:47 +02:00
#'
#'
2020-11-09 13:07:02 +01:00
#' # language support --------------------------------------------------------
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-09-08 16:06:47 +02:00
#'
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",
2018-09-08 16:06:47 +02:00
#' Lancefield = TRUE,
#' language = "de") # "Streptococcus Gruppe A"
2018-09-09 12:11:44 +02:00
#' mo_fullname("S. pyogenes",
2018-09-08 16:06:47 +02:00
#' Lancefield = TRUE,
#' language = "nl") # "Streptococcus groep A"
2018-09-17 20:53:32 +02:00
#'
2020-11-16 11:03:24 +01:00
#'
#' # other --------------------------------------------------------------------
#'
2021-01-12 22:08:04 +01:00
#' mo_is_yeast(c("Candida", "E. coli")) # TRUE, FALSE
#'
2020-11-16 11:03:24 +01:00
#' # gram stains and intrinsic resistance can also be used as a filter in dplyr verbs
2020-11-09 15:18:36 +01:00
#' if (require("dplyr")) {
#' example_isolates %>%
2020-11-16 11:03:24 +01:00
#' filter(mo_is_gram_positive())
#'
#' example_isolates %>%
#' filter(mo_is_intrinsic_resistant(ab = "vanco"))
2020-11-09 15:18:36 +01:00
#' }
#'
2020-11-16 11:03:24 +01: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")
2019-11-28 22:32:17 +01:00
#' # 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-08-09 14:28:46 +02:00
#' }
2019-05-13 12:21:57 +02:00
mo_name <- function ( x , language = get_locale ( ) , ... ) {
2020-12-24 23:29:10 +01:00
if ( missing ( x ) ) {
2021-01-03 23:40:05 +01:00
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_name" )
2020-12-24 23:29:10 +01:00
}
2020-10-19 20:44:45 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-19 17:09:19 +02:00
meet_criteria ( language , has_length = 1 , is_in = c ( LANGUAGES_SUPPORTED , " " ) , allow_NULL = TRUE , allow_NA = TRUE )
2020-12-24 23:29:10 +01:00
2021-02-18 23:23:14 +01:00
translate_AMR ( mo_validate ( x = x , property = " fullname" , language = language , ... ) ,
language = language ,
only_unknown = FALSE ,
affect_mo_name = TRUE )
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-08-28 13:51:13 +02:00
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-12-24 23:29:10 +01:00
if ( missing ( x ) ) {
2021-01-03 23:40:05 +01:00
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_shortname" )
2020-12-24 23:29:10 +01:00
}
2020-10-19 20:44:45 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-19 17:09:19 +02:00
meet_criteria ( language , has_length = 1 , is_in = c ( LANGUAGES_SUPPORTED , " " ) , allow_NULL = TRUE , allow_NA = TRUE )
2020-12-24 23:29:10 +01:00
2020-09-14 12:21:23 +02:00
x.mo <- as.mo ( x , language = language , ... )
2020-12-24 23:29:10 +01:00
2019-07-01 14:03:15 +02:00
metadata <- get_mo_failures_uncertainties_renamed ( )
2020-12-24 23:29:10 +01:00
2019-07-10 21:36:51 +02:00
replace_empty <- function ( x ) {
x [x == " " ] <- " spp."
x
}
2020-12-24 23:29:10 +01:00
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-12-24 23:29:10 +01:00
2020-08-26 11:33:54 +02:00
# exceptions for where no species is known
shortnames [shortnames %like% " .[.] spp[.]" ] <- genera [shortnames %like% " .[.] spp[.]" ]
2020-11-09 13:07:02 +01:00
# exceptions for staphylococci
2019-10-11 17:21:02 +02:00
shortnames [shortnames == " S. coagulase-negative" ] <- " CoNS"
shortnames [shortnames == " S. coagulase-positive" ] <- " CoPS"
2020-11-09 13:07:02 +01:00
# exceptions for streptococci: Group A Streptococcus -> 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-12-24 23:29:10 +01:00
shortnames [is.na ( x.mo ) ] <- NA_character_
2019-07-01 14:03:15 +02:00
load_mo_failures_uncertainties_renamed ( metadata )
2021-02-18 23:23:14 +01:00
translate_AMR ( shortnames , language = language , only_unknown = FALSE , affect_mo_name = TRUE )
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-12-24 23:29:10 +01:00
if ( missing ( x ) ) {
2021-01-03 23:40:05 +01:00
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_subspecies" )
2020-12-24 23:29:10 +01:00
}
2020-10-19 20:44:45 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-19 17:09:19 +02:00
meet_criteria ( language , has_length = 1 , is_in = c ( LANGUAGES_SUPPORTED , " " ) , allow_NULL = TRUE , allow_NA = TRUE )
2020-12-24 23:29:10 +01:00
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-12-24 23:29:10 +01:00
if ( missing ( x ) ) {
2021-01-03 23:40:05 +01:00
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_species" )
2020-12-24 23:29:10 +01:00
}
2020-10-19 20:44:45 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-19 17:09:19 +02:00
meet_criteria ( language , has_length = 1 , is_in = c ( LANGUAGES_SUPPORTED , " " ) , allow_NULL = TRUE , allow_NA = TRUE )
2020-12-24 23:29:10 +01:00
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-12-24 23:29:10 +01:00
if ( missing ( x ) ) {
2021-01-03 23:40:05 +01:00
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_genus" )
2020-12-24 23:29:10 +01:00
}
2020-10-19 20:44:45 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-19 17:09:19 +02:00
meet_criteria ( language , has_length = 1 , is_in = c ( LANGUAGES_SUPPORTED , " " ) , allow_NULL = TRUE , allow_NA = TRUE )
2020-12-24 23:29:10 +01:00
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-12-24 23:29:10 +01:00
if ( missing ( x ) ) {
2021-01-03 23:40:05 +01:00
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_family" )
2020-12-24 23:29:10 +01:00
}
2020-10-19 20:44:45 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-19 17:09:19 +02:00
meet_criteria ( language , has_length = 1 , is_in = c ( LANGUAGES_SUPPORTED , " " ) , allow_NULL = TRUE , allow_NA = TRUE )
2020-12-24 23:29:10 +01:00
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-12-24 23:29:10 +01:00
if ( missing ( x ) ) {
2021-01-03 23:40:05 +01:00
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_order" )
2020-12-24 23:29:10 +01:00
}
2020-10-19 20:44:45 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-19 17:09:19 +02:00
meet_criteria ( language , has_length = 1 , is_in = c ( LANGUAGES_SUPPORTED , " " ) , allow_NULL = TRUE , allow_NA = TRUE )
2020-12-24 23:29:10 +01:00
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-12-24 23:29:10 +01:00
if ( missing ( x ) ) {
2021-01-03 23:40:05 +01:00
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_class" )
2020-12-24 23:29:10 +01:00
}
2020-10-19 20:44:45 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-19 17:09:19 +02:00
meet_criteria ( language , has_length = 1 , is_in = c ( LANGUAGES_SUPPORTED , " " ) , allow_NULL = TRUE , allow_NA = TRUE )
2020-12-24 23:29:10 +01:00
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-12-24 23:29:10 +01:00
if ( missing ( x ) ) {
2021-01-03 23:40:05 +01:00
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_phylum" )
2020-12-24 23:29:10 +01:00
}
2020-10-19 20:44:45 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-19 17:09:19 +02:00
meet_criteria ( language , has_length = 1 , is_in = c ( LANGUAGES_SUPPORTED , " " ) , allow_NULL = TRUE , allow_NA = TRUE )
2020-12-24 23:29:10 +01:00
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
2018-08-28 13:51:13 +02:00
#' @rdname mo_property
#' @export
2019-03-09 08:21:00 +01:00
mo_kingdom <- function ( x , language = get_locale ( ) , ... ) {
2020-12-24 23:29:10 +01:00
if ( missing ( x ) ) {
2021-01-03 23:40:05 +01:00
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_kingdom" )
2020-12-24 23:29:10 +01:00
}
2020-10-19 20:44:45 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-19 17:09:19 +02:00
meet_criteria ( language , has_length = 1 , is_in = c ( LANGUAGES_SUPPORTED , " " ) , allow_NULL = TRUE , allow_NA = TRUE )
2020-12-24 23:29:10 +01:00
2020-09-14 12:21:23 +02:00
translate_AMR ( mo_validate ( x = x , property = " kingdom" , language = language , ... ) , language = language , only_unknown = TRUE )
2018-08-28 13:51:13 +02:00
}
2020-06-22 11:18:40 +02:00
#' @rdname mo_property
#' @export
mo_domain <- mo_kingdom
2018-08-28 13:51:13 +02:00
#' @rdname mo_property
#' @export
2018-11-05 13:20:32 +01:00
mo_type <- function ( x , language = get_locale ( ) , ... ) {
2020-12-24 23:29:10 +01:00
if ( missing ( x ) ) {
2021-01-03 23:40:05 +01:00
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_type" )
2020-12-24 23:29:10 +01:00
}
2020-10-19 20:44:45 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-19 17:09:19 +02:00
meet_criteria ( language , has_length = 1 , is_in = c ( LANGUAGES_SUPPORTED , " " ) , allow_NULL = TRUE , allow_NA = TRUE )
2020-12-24 23:29:10 +01:00
2021-01-12 22:08:04 +01:00
x.mo <- as.mo ( x , language = language , ... )
out <- mo_kingdom ( x.mo , language = NULL )
out [which ( mo_is_yeast ( x.mo ) ) ] <- " Yeasts"
translate_AMR ( out , 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-12-24 23:29:10 +01:00
if ( missing ( x ) ) {
2021-01-03 23:40:05 +01:00
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_gramstain" )
2020-12-24 23:29:10 +01:00
}
2020-10-19 20:44:45 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-19 17:09:19 +02:00
meet_criteria ( language , has_length = 1 , is_in = c ( LANGUAGES_SUPPORTED , " " ) , allow_NULL = TRUE , allow_NA = TRUE )
2020-12-24 23:29:10 +01:00
2020-09-14 12:21:23 +02:00
x.mo <- as.mo ( x , language = language , ... )
2019-07-01 14:03:15 +02:00
metadata <- get_mo_failures_uncertainties_renamed ( )
2020-12-24 23:29:10 +01:00
2019-07-01 14:03:15 +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
2019-07-01 14:03:15 +02:00
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-12-24 23:29:10 +01:00
2019-07-01 14:03:15 +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
}
2020-10-19 17:09:19 +02:00
#' @rdname mo_property
#' @export
2020-11-16 11:03:24 +01:00
mo_is_gram_negative <- function ( x , language = get_locale ( ) , ... ) {
2020-11-09 13:07:02 +01:00
if ( missing ( x ) ) {
2021-01-03 23:40:05 +01:00
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_is_gram_negative" )
2020-11-09 13:07:02 +01:00
}
2020-10-19 20:44:45 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-26 12:23:03 +01:00
meet_criteria ( language , has_length = 1 , is_in = c ( LANGUAGES_SUPPORTED , " " ) , allow_NULL = TRUE , allow_NA = TRUE )
2020-12-24 23:29:10 +01:00
2020-10-26 12:23:03 +01:00
x.mo <- as.mo ( x , language = language , ... )
metadata <- get_mo_failures_uncertainties_renamed ( )
grams <- mo_gramstain ( x.mo , language = NULL )
load_mo_failures_uncertainties_renamed ( metadata )
2020-11-09 13:07:02 +01:00
out <- grams == " Gram-negative" & ! is.na ( grams )
2020-11-16 11:03:24 +01:00
out [x.mo %in% c ( NA_character_ , " UNKNOWN" ) ] <- NA
2020-11-09 13:07:02 +01:00
out
2020-10-19 17:09:19 +02:00
}
#' @rdname mo_property
#' @export
2020-11-16 11:03:24 +01:00
mo_is_gram_positive <- function ( x , language = get_locale ( ) , ... ) {
2020-11-09 13:07:02 +01:00
if ( missing ( x ) ) {
2021-01-03 23:40:05 +01:00
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_is_gram_positive" )
2020-11-09 13:07:02 +01:00
}
2020-10-19 20:44:45 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-26 12:23:03 +01:00
meet_criteria ( language , has_length = 1 , is_in = c ( LANGUAGES_SUPPORTED , " " ) , allow_NULL = TRUE , allow_NA = TRUE )
2020-12-24 23:29:10 +01:00
2020-10-26 12:23:03 +01:00
x.mo <- as.mo ( x , language = language , ... )
metadata <- get_mo_failures_uncertainties_renamed ( )
grams <- mo_gramstain ( x.mo , language = NULL )
load_mo_failures_uncertainties_renamed ( metadata )
2020-11-09 13:07:02 +01:00
out <- grams == " Gram-positive" & ! is.na ( grams )
2020-11-16 11:03:24 +01:00
out [x.mo %in% c ( NA_character_ , " UNKNOWN" ) ] <- NA
2020-11-09 13:07:02 +01:00
out
2020-10-19 17:09:19 +02:00
}
2021-01-12 22:08:04 +01:00
#' @rdname mo_property
#' @export
mo_is_yeast <- function ( x , language = get_locale ( ) , ... ) {
if ( missing ( x ) ) {
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_is_yeast" )
}
meet_criteria ( x , allow_NA = TRUE )
meet_criteria ( language , has_length = 1 , is_in = c ( LANGUAGES_SUPPORTED , " " ) , allow_NULL = TRUE , allow_NA = TRUE )
x.mo <- as.mo ( x , language = language , ... )
metadata <- get_mo_failures_uncertainties_renamed ( )
x.kingdom <- mo_kingdom ( x.mo , language = NULL )
x.phylum <- mo_phylum ( x.mo , language = NULL )
x.class <- mo_class ( x.mo , language = NULL )
x.order <- mo_order ( x.mo , language = NULL )
load_mo_failures_uncertainties_renamed ( metadata )
out <- rep ( FALSE , length ( x ) )
2021-02-08 14:18:42 +01:00
out [x.kingdom == " Fungi" & x.class == " Saccharomycetes" ] <- TRUE
2021-01-12 22:08:04 +01:00
out [x.mo %in% c ( NA_character_ , " UNKNOWN" ) ] <- NA
out
}
2020-11-16 11:03:24 +01:00
#' @rdname mo_property
#' @export
mo_is_intrinsic_resistant <- function ( x , ab , language = get_locale ( ) , ... ) {
if ( missing ( x ) ) {
2021-01-03 23:40:05 +01:00
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_is_intrinsic_resistant" )
2020-11-16 11:03:24 +01:00
}
meet_criteria ( x , allow_NA = TRUE )
meet_criteria ( ab , allow_NA = FALSE )
meet_criteria ( language , has_length = 1 , is_in = c ( LANGUAGES_SUPPORTED , " " ) , allow_NULL = TRUE , allow_NA = TRUE )
2020-12-07 16:06:42 +01:00
x <- as.mo ( x , language = language , ... )
ab <- as.ab ( ab , language = NULL , flag_multiple_results = FALSE , info = FALSE )
2020-11-16 11:03:24 +01:00
if ( length ( x ) == 1 & length ( ab ) > 1 ) {
x <- rep ( x , length ( ab ) )
} else if ( length ( ab ) == 1 & length ( x ) > 1 ) {
ab <- rep ( ab , length ( x ) )
}
if ( length ( x ) != length ( ab ) ) {
2020-12-03 16:59:04 +01:00
stop_ ( " length of `x` and `ab` must be equal, or one of them must be of length 1." )
2020-11-16 11:03:24 +01:00
}
2021-01-03 23:40:05 +01:00
# show used version number once per session (pkg_env will reload every session)
if ( message_not_thrown_before ( " intrinsic_resistant_version" , entire_session = TRUE ) ) {
2020-12-03 22:30:14 +01:00
message_ ( " Determining intrinsic resistance based on " ,
2021-01-03 23:40:05 +01:00
format_eucast_version_nr ( 3.2 , markdown = FALSE ) , " . " ,
font_red ( " This note will be shown once per session." ) )
remember_thrown_message ( " intrinsic_resistant_version" , entire_session = TRUE )
2020-12-03 22:30:14 +01:00
}
2020-12-07 16:06:42 +01:00
# runs against internal vector: INTRINSIC_R (see zzz.R)
paste ( x , ab ) %in% INTRINSIC_R
2020-11-16 11:03:24 +01:00
}
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-12-24 23:29:10 +01:00
if ( missing ( x ) ) {
2021-01-03 23:40:05 +01:00
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_snomed" )
2020-12-24 23:29:10 +01:00
}
2020-10-19 20:44:45 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-19 17:09:19 +02:00
meet_criteria ( language , has_length = 1 , is_in = c ( LANGUAGES_SUPPORTED , " " ) , allow_NULL = TRUE , allow_NA = TRUE )
2020-12-24 23:29:10 +01:00
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-12-24 23:29:10 +01:00
if ( missing ( x ) ) {
2021-01-03 23:40:05 +01:00
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_ref" )
2020-12-24 23:29:10 +01:00
}
2020-10-19 20:44:45 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-19 17:09:19 +02:00
meet_criteria ( language , has_length = 1 , is_in = c ( LANGUAGES_SUPPORTED , " " ) , allow_NULL = TRUE , allow_NA = TRUE )
2020-12-24 23:29:10 +01:00
2020-09-14 12:21:23 +02:00
mo_validate ( x = x , property = " ref" , language = language , ... )
2018-08-28 13:51:13 +02:00
}
2018-09-08 16:06:47 +02:00
#' @rdname mo_property
#' @export
2020-09-14 12:21:23 +02:00
mo_authors <- function ( x , language = get_locale ( ) , ... ) {
2020-12-24 23:29:10 +01:00
if ( missing ( x ) ) {
2021-01-03 23:40:05 +01:00
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_authors" )
2020-12-24 23:29:10 +01:00
}
2020-10-19 20:44:45 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-19 17:09:19 +02:00
meet_criteria ( language , has_length = 1 , is_in = c ( LANGUAGES_SUPPORTED , " " ) , allow_NULL = TRUE , allow_NA = TRUE )
2020-12-24 23:29:10 +01:00
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-12-24 23:29:10 +01:00
if ( missing ( x ) ) {
2021-01-03 23:40:05 +01:00
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_year" )
2020-12-24 23:29:10 +01:00
}
2020-10-19 20:44:45 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-19 17:09:19 +02:00
meet_criteria ( language , has_length = 1 , is_in = c ( LANGUAGES_SUPPORTED , " " ) , allow_NULL = TRUE , allow_NA = TRUE )
2020-12-24 23:29:10 +01:00
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-12-24 23:29:10 +01:00
if ( missing ( x ) ) {
2021-01-03 23:40:05 +01:00
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_rank" )
2020-12-24 23:29:10 +01:00
}
2020-10-19 20:44:45 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-19 17:09:19 +02:00
meet_criteria ( language , has_length = 1 , is_in = c ( LANGUAGES_SUPPORTED , " " ) , allow_NULL = TRUE , allow_NA = TRUE )
2020-12-24 23:29:10 +01:00
2020-09-14 12:21:23 +02:00
mo_validate ( x = x , property = " rank" , language = language , ... )
2018-09-08 16:06:47 +02:00
}
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-12-24 23:29:10 +01:00
if ( missing ( x ) ) {
2021-01-03 23:40:05 +01:00
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_taxonomy" )
2020-12-24 23:29:10 +01:00
}
2020-10-19 20:44:45 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-19 17:09:19 +02:00
meet_criteria ( language , has_length = 1 , is_in = c ( LANGUAGES_SUPPORTED , " " ) , allow_NULL = TRUE , allow_NA = TRUE )
2020-12-24 23:29:10 +01:00
2020-09-14 12:21:23 +02:00
x <- as.mo ( x , language = language , ... )
2019-07-01 14:03:15 +02:00
metadata <- get_mo_failures_uncertainties_renamed ( )
2020-12-24 23:29:10 +01:00
2020-09-03 12:31:48 +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-12-24 23:29:10 +01:00
2019-07-01 14:03:15 +02:00
load_mo_failures_uncertainties_renamed ( metadata )
result
2018-09-17 20:53:32 +02:00
}
2019-06-16 21:42:40 +02:00
#' @rdname mo_property
#' @export
2020-09-14 12:21:23 +02:00
mo_synonyms <- function ( x , language = get_locale ( ) , ... ) {
2020-12-24 23:29:10 +01:00
if ( missing ( x ) ) {
2021-01-03 23:40:05 +01:00
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_synonyms" )
2020-12-24 23:29:10 +01:00
}
2020-10-19 20:44:45 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-19 17:09:19 +02:00
meet_criteria ( language , has_length = 1 , is_in = c ( LANGUAGES_SUPPORTED , " " ) , allow_NULL = TRUE , allow_NA = TRUE )
2020-12-24 23:29:10 +01:00
2020-09-14 12:21:23 +02:00
x <- as.mo ( x , language = language , ... )
2019-07-01 14:03:15 +02:00
metadata <- get_mo_failures_uncertainties_renamed ( )
2020-12-24 23:29:10 +01: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 ) {
2019-08-11 19:07:26 +02:00
names ( syns ) <- mo_name ( x )
2019-07-01 14:03:15 +02:00
result <- syns
2019-06-22 14:49:12 +02:00
} else {
2019-07-01 14:03:15 +02:00
result <- unlist ( syns )
2019-06-16 21:42:40 +02:00
}
2020-12-24 23:29:10 +01:00
2019-07-01 14:03:15 +02:00
load_mo_failures_uncertainties_renamed ( metadata )
result
2019-06-16 21:42:40 +02:00
}
2019-06-11 14:18:25 +02:00
#' @rdname mo_property
#' @export
mo_info <- function ( x , language = get_locale ( ) , ... ) {
2020-12-24 23:29:10 +01:00
if ( missing ( x ) ) {
2021-01-03 23:40:05 +01:00
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_info" )
2020-12-24 23:29:10 +01:00
}
2020-10-19 20:44:45 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-19 17:09:19 +02:00
meet_criteria ( language , has_length = 1 , is_in = c ( LANGUAGES_SUPPORTED , " " ) , allow_NULL = TRUE , allow_NA = TRUE )
2020-12-24 23:29:10 +01:00
2020-09-14 12:21:23 +02:00
x <- as.mo ( x , language = language , ... )
2019-07-01 14:03:15 +02:00
metadata <- get_mo_failures_uncertainties_renamed ( )
2020-12-24 23:29:10 +01: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 ) ,
2019-11-28 22:32:17 +01:00
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 ) {
2019-08-11 19:07:26 +02:00
names ( info ) <- mo_name ( x )
2019-07-01 14:03:15 +02:00
result <- info
2019-06-22 14:49:12 +02:00
} else {
2019-07-01 14:03:15 +02:00
result <- info [ [1L ] ]
2019-06-22 14:49:12 +02:00
}
2020-12-24 23:29:10 +01:00
2019-07-01 14:03:15 +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-12-24 23:29:10 +01:00
if ( missing ( x ) ) {
2021-01-03 23:40:05 +01:00
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_url" )
2020-12-24 23:29:10 +01:00
}
2020-10-19 20:44:45 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-19 17:09:19 +02:00
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-12-24 23:29:10 +01:00
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 )
2019-07-01 14:03:15 +02:00
metadata <- get_mo_failures_uncertainties_renamed ( )
2020-12-24 23:29:10 +01:00
2020-09-18 16:05:53 +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-12-24 23:29:10 +01:00
2019-02-22 22:12:10 +01:00
if ( open == TRUE ) {
if ( length ( u ) > 1 ) {
2020-11-10 16:35:56 +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-12-24 23:29:10 +01:00
2019-07-01 14:03:15 +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-12-24 23:29:10 +01:00
if ( missing ( x ) ) {
2021-01-03 23:40:05 +01:00
# this tries to find the data and an <mo> column
x <- find_mo_col ( fn = " mo_property" )
2020-12-24 23:29:10 +01:00
}
2020-10-19 20:44:45 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-19 17:09:19 +02:00
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-12-24 23:29:10 +01:00
2020-09-14 12:21:23 +02:00
translate_AMR ( mo_validate ( x = x , property = property , language = language , ... ) , language = language , only_unknown = TRUE )
2018-09-08 16:06:47 +02:00
}
2018-09-27 23:23:48 +02:00
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 ( )
2018-10-01 11:39:43 +02:00
dots <- list ( ... )
Becker <- dots $ Becker
2021-02-21 22:56:35 +01:00
if ( is.null ( Becker ) | property %in% c ( " kingdom" , " phylum" , " class" , " order" , " family" , " genus" ) ) {
2018-10-01 11:39:43 +02:00
Becker <- FALSE
}
Lancefield <- dots $ Lancefield
2021-02-21 22:56:35 +01:00
if ( is.null ( Lancefield ) | property %in% c ( " kingdom" , " phylum" , " class" , " order" , " family" , " genus" ) ) {
2018-10-01 11:39:43 +02:00
Lancefield <- FALSE
}
2021-02-21 22:56:35 +01:00
has_Becker_or_Lancefield <- Becker %in% c ( TRUE , " all" ) | Lancefield %in% c ( TRUE , " all" )
2020-12-24 23:29:10 +01:00
2021-02-21 22:56:35 +01:00
if ( tryCatch ( all ( x [ ! is.na ( x ) ] %in% MO_lookup $ mo ) & ! has_Becker_or_Lancefield , 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 ] )
}
2020-12-22 00:51:17 +01:00
# try to catch an error when inputting an invalid argument
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 ) )
2020-12-24 23:29:10 +01:00
2020-10-26 12:23:03 +01:00
if ( is.mo ( x )
& ! Becker %in% c ( TRUE , " all" )
2019-08-26 10:03:37 +02:00
& ! 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 ] )
2021-02-21 22:56:35 +01:00
| has_Becker_or_Lancefield ) {
accepted_args <- names ( as.list ( args ( " as.mo" ) ) )
accepted_args <- accepted_args [ ! accepted_args %in% c ( " " , " ..." , " x" , " property" ) ]
stop_if ( ! all ( names ( dots ) %in% names ( as.list ( args ( " as.mo" ) ) ) ) ,
" invalid argument(s): " , vector_and ( names ( dots ) [ ! names ( dots ) %in% names ( as.list ( args ( " as.mo" ) ) ) ] , quotes = " '" ) ,
" .\nAccepted arguments are " , vector_and ( accepted_args , quotes = " '" ) , " ." ,
call = FALSE )
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
}
2020-12-24 23:29:10 +01:00
2019-06-22 14:49:12 +02:00
if ( property == " mo" ) {
2020-11-16 20:02:20 +01:00
return ( set_clean_class ( x , new_class = c ( " mo" , " character" ) ) )
2020-01-27 19:14:23 +01:00
} else if ( property == " snomed" ) {
return ( as.double ( eval ( parse ( text = x ) ) ) )
2018-09-27 23:23:48 +02:00
} else {
2019-06-22 14:49:12 +02:00
return ( x )
2018-09-27 23:23:48 +02:00
}
}
2020-11-16 11:03:24 +01:00
find_mo_col <- function ( fn ) {
2021-01-03 23:40:05 +01:00
# this function tries to find an mo column in the data the function was called in,
2020-11-16 11:03:24 +01:00
# which is useful when functions are used within dplyr verbs
2020-12-24 23:29:10 +01:00
df <- get_current_data ( arg_name = " x" , call = -3 ) # will return an error if not found
2020-12-07 16:06:42 +01:00
mo <- NULL
try ( {
mo <- suppressMessages ( search_type_in_df ( df , " mo" ) )
} , silent = TRUE )
if ( ! is.null ( df ) && ! is.null ( mo ) && is.data.frame ( df ) ) {
2020-12-24 23:29:10 +01:00
if ( message_not_thrown_before ( fn = fn ) ) {
message_ ( " Using column '" , font_bold ( mo ) , " ' as input for " , fn , " ()" )
remember_thrown_message ( fn = fn )
}
2020-12-07 16:06:42 +01:00
return ( df [ , mo , drop = TRUE ] )
2020-11-16 11:03:24 +01:00
} else {
2020-12-07 16:06:42 +01:00
stop_ ( " argument `x` is missing and no column with info about microorganisms could be found." , call = -2 )
2020-11-16 11:03:24 +01:00
}
}