P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-01-16 00:41:53 +01:00
Code Releases Activity

fixes

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends 2022-09-19 11:57:21 +02:00
parent a20293a0a3
commit 127d8d868d
12 changed files with 221 additions and 176 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
DESCRIPTION
View File

@ -1,6 +1,6 @@
Package: AMR Package: AMR
Version: 1.8.1.9056 Version: 1.8.1.9057
Date: 2022-09-18 Date: 2022-09-19
Title: Antimicrobial Resistance Data Analysis Title: Antimicrobial Resistance Data Analysis
Description: Functions to simplify and standardise antimicrobial resistance (AMR) Description: Functions to simplify and standardise antimicrobial resistance (AMR)
data analysis and to work with microbial and antimicrobial properties by data analysis and to work with microbial and antimicrobial properties by

2
NEWS.md
View File

@ -1,4 +1,4 @@
# AMR 1.8.1.9056 # AMR 1.8.1.9057
This version will eventually become v2.0! We're happy to reach a new major milestone soon! This version will eventually become v2.0! We're happy to reach a new major milestone soon!

8
R/aa_helper_functions.R
View File

@ -960,8 +960,8 @@ unique_call_id <- function(entire_session = FALSE, match_fn = NULL) {
# combination of environment ID (such as "0x7fed4ee8c848") # combination of environment ID (such as "0x7fed4ee8c848")
# and relevant system call (where 'match_fn' is being called in) # and relevant system call (where 'match_fn' is being called in)
calls <- sys.calls() calls <- sys.calls()
if (!identical(Sys.getenv("R_RUN_TINYTEST"), "true") && in_test <- any(as.character(calls[[1]]) %like_case% "run_test_dir|run_test_file|test_all|tinytest|test_package|testthat", na.rm = TRUE)
!any(as.character(calls[[1]]) %like_case% "run_test_dir|run_test_file|test_all|tinytest|test_package|testthat")) { if (!isTRUE(in_test)) {
for (i in seq_len(length(calls))) { for (i in seq_len(length(calls))) {
call_clean <- gsub("[^a-zA-Z0-9_().-]", "", as.character(calls[[i]]), perl = TRUE) call_clean <- gsub("[^a-zA-Z0-9_().-]", "", as.character(calls[[i]]), perl = TRUE)
if (any(call_clean %like% paste0(match_fn, "\\("), na.rm = TRUE)) { if (any(call_clean %like% paste0(match_fn, "\\("), na.rm = TRUE)) {
@ -971,8 +971,6 @@ unique_call_id <- function(entire_session = FALSE, match_fn = NULL) {
)) ))
} }
} }
} else if (identical(Sys.getenv("R_RUN_TINYTEST"), "true")) {
message("NOTE: env R_RUN_TINYTEST is set to 'true', unique_call_id() not working well")
} }
c( c(
envir = paste0(sample(c(0:9, letters[1:6]), size = 32, replace = TRUE), collapse = ""), envir = paste0(sample(c(0:9, letters[1:6]), size = 32, replace = TRUE), collapse = ""),
@ -987,7 +985,7 @@ unique_call_id <- function(entire_session = FALSE, match_fn = NULL) {
message_not_thrown_before <- function(fn, ..., entire_session = FALSE) { message_not_thrown_before <- function(fn, ..., entire_session = FALSE) {
# this is to prevent that messages/notes will be printed for every dplyr group or more than once per session # this is to prevent that messages/notes will be printed for every dplyr group or more than once per session
# e.g. this would show a msg 4 times: example_isolates %>% group_by(ward) %>% filter(mo_is_gram_negative()) # e.g. this would show a msg 4 times: example_isolates %>% group_by(ward) %>% filter(mo_is_gram_negative())
salt <- gsub("[^a-zA-Z0-9|_-]", "?", paste(c(...), sep = "|", collapse = "|"), perl = TRUE) salt <- gsub("[^a-zA-Z0-9|_-]", "?", paste(c(...)[seq_len(min(50, length(c(...))))], sep = "|", collapse = "|"), perl = TRUE)
not_thrown_before <- is.null(pkg_env[[paste0("thrown_msg.", fn, ".", salt)]]) || not_thrown_before <- is.null(pkg_env[[paste0("thrown_msg.", fn, ".", salt)]]) ||
!identical( !identical(
pkg_env[[paste0("thrown_msg.", fn, ".", salt)]], pkg_env[[paste0("thrown_msg.", fn, ".", salt)]],

24
R/custom_eucast_rules.R
View File

@ -35,38 +35,54 @@
#' #'
#' If you are familiar with the [`case_when()`][dplyr::case_when()] function of the `dplyr` package, you will recognise the input method to set your own rules. Rules must be set using what \R considers to be the 'formula notation'. The rule itself is written *before* the tilde (`~`) and the consequence of the rule is written *after* the tilde: #' If you are familiar with the [`case_when()`][dplyr::case_when()] function of the `dplyr` package, you will recognise the input method to set your own rules. Rules must be set using what \R considers to be the 'formula notation'. The rule itself is written *before* the tilde (`~`) and the consequence of the rule is written *after* the tilde:
#' #'
#' ```{r} #' ```r
#' x <- custom_eucast_rules(TZP == "S" ~ aminopenicillins == "S", #' x <- custom_eucast_rules(TZP == "S" ~ aminopenicillins == "S",
#' TZP == "R" ~ aminopenicillins == "R") #' TZP == "R" ~ aminopenicillins == "R")
#' ``` #' ```
#' #'
#' These are two custom EUCAST rules: if TZP (piperacillin/tazobactam) is "S", all aminopenicillins (ampicillin and amoxicillin) must be made "S", and if TZP is "R", aminopenicillins must be made "R". These rules can also be printed to the console, so it is immediately clear how they work: #' These are two custom EUCAST rules: if TZP (piperacillin/tazobactam) is "S", all aminopenicillins (ampicillin and amoxicillin) must be made "S", and if TZP is "R", aminopenicillins must be made "R". These rules can also be printed to the console, so it is immediately clear how they work:
#' #'
#' ```{r} #' ```r
#' x #' x
#' #> A set of custom EUCAST rules:
#' #>
#' #> 1. If TZP is "S" then set to S :
#' #> amoxicillin (AMX), ampicillin (AMP)
#' #>
#' #> 2. If TZP is "R" then set to R :
#' #> amoxicillin (AMX), ampicillin (AMP)
#' ``` #' ```
#' #'
#' The rules (the part *before* the tilde, in above example `TZP == "S"` and `TZP == "R"`) must be evaluable in your data set: it should be able to run as a filter in your data set without errors. This means for the above example that the column `TZP` must exist. We will create a sample data set and test the rules set: #' The rules (the part *before* the tilde, in above example `TZP == "S"` and `TZP == "R"`) must be evaluable in your data set: it should be able to run as a filter in your data set without errors. This means for the above example that the column `TZP` must exist. We will create a sample data set and test the rules set:
#' #'
#' ```{r} #' ```r
#' df <- data.frame(mo = c("Escherichia coli", "Klebsiella pneumoniae"), #' df <- data.frame(mo = c("Escherichia coli", "Klebsiella pneumoniae"),
#' TZP = as.rsi("R"), #' TZP = as.rsi("R"),
#' ampi = as.rsi("S"), #' ampi = as.rsi("S"),
#' cipro = as.rsi("S")) #' cipro = as.rsi("S"))
#' df #' df
#' #> mo TZP ampi cipro
#' #> 1 Escherichia coli R S S
#' #> 2 Klebsiella pneumoniae R S S
#' #'
#' eucast_rules(df, rules = "custom", custom_rules = x, info = FALSE) #' eucast_rules(df, rules = "custom", custom_rules = x, info = FALSE)
#' #> mo TZP ampi cipro
#' #> 1 Escherichia coli R R S
#' #> 2 Klebsiella pneumoniae R R S
#' ``` #' ```
#' #'
#' ### Using taxonomic properties in rules #' ### Using taxonomic properties in rules
#' #'
#' There is one exception in variables used for the rules: all column names of the [microorganisms] data set can also be used, but do not have to exist in the data set. These column names are: `r vector_and(colnames(microorganisms), sort = FALSE)`. Thus, this next example will work as well, despite the fact that the `df` data set does not contain a column `genus`: #' There is one exception in variables used for the rules: all column names of the [microorganisms] data set can also be used, but do not have to exist in the data set. These column names are: `r vector_and(colnames(microorganisms), sort = FALSE)`. Thus, this next example will work as well, despite the fact that the `df` data set does not contain a column `genus`:
#' #'
#' ```{r} #' ```r
#' y <- custom_eucast_rules(TZP == "S" & genus == "Klebsiella" ~ aminopenicillins == "S", #' y <- custom_eucast_rules(TZP == "S" & genus == "Klebsiella" ~ aminopenicillins == "S",
#' TZP == "R" & genus == "Klebsiella" ~ aminopenicillins == "R") #' TZP == "R" & genus == "Klebsiella" ~ aminopenicillins == "R")
#' #'
#' eucast_rules(df, rules = "custom", custom_rules = y, info = FALSE) #' eucast_rules(df, rules = "custom", custom_rules = y, info = FALSE)
#' #> mo TZP ampi cipro
#' #> 1 Escherichia coli R S S
#' #> 2 Klebsiella pneumoniae R R S
#' ``` #' ```
#' #'
#' ### Usage of antibiotic group names #' ### Usage of antibiotic group names

10
R/eucast_rules.R
View File

@ -74,19 +74,18 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
#' #'
#' The file containing all EUCAST rules is located here: <https://github.com/msberends/AMR/blob/main/data-raw/eucast_rules.tsv>. **Note:** Old taxonomic names are replaced with the current taxonomy where applicable. For example, *Ochrobactrum anthropi* was renamed to *Brucella anthropi* in 2020; the original EUCAST rules v3.1 and v3.2 did not yet contain this new taxonomic name. The `AMR` package contains the full microbial taxonomy updated until `r documentation_date(max(TAXONOMY_VERSION$GBIF$accessed_date, TAXONOMY_VERSION$LPSN$accessed_date))`, see [microorganisms]. #' The file containing all EUCAST rules is located here: <https://github.com/msberends/AMR/blob/main/data-raw/eucast_rules.tsv>. **Note:** Old taxonomic names are replaced with the current taxonomy where applicable. For example, *Ochrobactrum anthropi* was renamed to *Brucella anthropi* in 2020; the original EUCAST rules v3.1 and v3.2 did not yet contain this new taxonomic name. The `AMR` package contains the full microbial taxonomy updated until `r documentation_date(max(TAXONOMY_VERSION$GBIF$accessed_date, TAXONOMY_VERSION$LPSN$accessed_date))`, see [microorganisms].
#' #'
#' ## Custom Rules #' ### Custom Rules
#' #'
#' Custom rules can be created using [custom_eucast_rules()], e.g.: #' Custom rules can be created using [custom_eucast_rules()], e.g.:
#' #'
#' ```{r} #' ```r
#' x <- custom_eucast_rules(AMC == "R" & genus == "Klebsiella" ~ aminopenicillins == "R", #' x <- custom_eucast_rules(AMC == "R" & genus == "Klebsiella" ~ aminopenicillins == "R",
#' AMC == "I" & genus == "Klebsiella" ~ aminopenicillins == "I") #' AMC == "I" & genus == "Klebsiella" ~ aminopenicillins == "I")
#' #'
#' eucast_rules(example_isolates, rules = "custom", custom_rules = x, info = FALSE) #' eucast_rules(example_isolates, rules = "custom", custom_rules = x)
#' ``` #' ```
#' #'
#' #' ### 'Other' Rules
#' ## 'Other' Rules
#' #'
#' Before further processing, two non-EUCAST rules about drug combinations can be applied to improve the efficacy of the EUCAST rules, and the reliability of your data (analysis). These rules are: #' Before further processing, two non-EUCAST rules about drug combinations can be applied to improve the efficacy of the EUCAST rules, and the reliability of your data (analysis). These rules are:
#' #'
@ -117,7 +116,6 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
#' - EUCAST Breakpoint tables for interpretation of MICs and zone diameters. Version 11.0, 2021. [(link)](https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Breakpoint_tables/v_11.0_Breakpoint_Tables.xlsx) #' - EUCAST Breakpoint tables for interpretation of MICs and zone diameters. Version 11.0, 2021. [(link)](https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Breakpoint_tables/v_11.0_Breakpoint_Tables.xlsx)
#' - EUCAST Breakpoint tables for interpretation of MICs and zone diameters. Version 12.0, 2022. [(link)](https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Breakpoint_tables/v_12.0_Breakpoint_Tables.xlsx) #' - EUCAST Breakpoint tables for interpretation of MICs and zone diameters. Version 12.0, 2022. [(link)](https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Breakpoint_tables/v_12.0_Breakpoint_Tables.xlsx)
#' @inheritSection AMR Reference Data Publicly Available #' @inheritSection AMR Reference Data Publicly Available
#' @examples #' @examples
#' \donttest{ #' \donttest{
#' a <- data.frame( #' a <- data.frame(

51
R/mo.R
View File

@ -35,7 +35,7 @@
#' This excludes enterococci at default (who are in group D), use `Lancefield = "all"` to also categorise all enterococci as group D. #' This excludes enterococci at default (who are in group D), use `Lancefield = "all"` to also categorise all enterococci as group D.
#' @param minimum_matching_score a numeric value to set as the lower limit for the [MO matching score][mo_matching_score()]. When left blank, this will be determined automatically based on the character length of `x`, its [taxonomic kingdom][microorganisms] and [human pathogenicity][mo_matching_score()]. #' @param minimum_matching_score a numeric value to set as the lower limit for the [MO matching score][mo_matching_score()]. When left blank, this will be determined automatically based on the character length of `x`, its [taxonomic kingdom][microorganisms] and [human pathogenicity][mo_matching_score()].
#' @param allow_uncertain a number between `0` (or `"none"`) and `3` (or `"all"`), or `TRUE` (= `2`) or `FALSE` (= `0`) to indicate whether the input should be checked for less probable results, see *Details* #' @param allow_uncertain a number between `0` (or `"none"`) and `3` (or `"all"`), or `TRUE` (= `2`) or `FALSE` (= `0`) to indicate whether the input should be checked for less probable results, see *Details*
#' @param keep_synonyms a [logical] to indicate if old, previously valid taxonomic names must be preserved and not be corrected to currently accepted names. The default is `FALSE` to always return the currently accepted names. #' @param keep_synonyms a [logical] to indicate if old, previously valid taxonomic names must be preserved and not be corrected to currently accepted names. The default is `TRUE`, which will return a note if old taxonomic names are returned. The default can be set with `options(AMR_keep_synonyms = ...)`.
#' @param reference_df a [data.frame] to be used for extra reference when translating `x` to a valid [`mo`]. See [set_mo_source()] and [get_mo_source()] to automate the usage of your own codes (e.g. used in your analysis or organisation). #' @param reference_df a [data.frame] to be used for extra reference when translating `x` to a valid [`mo`]. See [set_mo_source()] and [get_mo_source()] to automate the usage of your own codes (e.g. used in your analysis or organisation).
#' @param ignore_pattern a regular expression (case-insensitive) of which all matches in `x` must return `NA`. This can be convenient to exclude known non-relevant input and can also be set with the option `AMR_ignore_pattern`, e.g. `options(AMR_ignore_pattern = "(not reported|contaminated flora)")`. #' @param ignore_pattern a regular expression (case-insensitive) of which all matches in `x` must return `NA`. This can be convenient to exclude known non-relevant input and can also be set with the option `AMR_ignore_pattern`, e.g. `options(AMR_ignore_pattern = "(not reported|contaminated flora)")`.
#' @param language language to translate text like "no growth", which defaults to the system language (see [get_AMR_locale()]) #' @param language language to translate text like "no growth", which defaults to the system language (see [get_AMR_locale()])
@ -45,7 +45,7 @@
#' @aliases mo #' @aliases mo
#' @keywords mo Becker becker Lancefield lancefield guess #' @keywords mo Becker becker Lancefield lancefield guess
#' @details #' @details
#' ## General Info #' ### General Info
#' #'
#' A microorganism (MO) code from this package (class: [`mo`]) is human readable and typically looks like these examples: #' A microorganism (MO) code from this package (class: [`mo`]) is human readable and typically looks like these examples:
#' ``` #' ```
@ -77,7 +77,7 @@
#' #'
#' This will lead to the effect that e.g. `"E. coli"` (a microorganism highly prevalent in humans) will return the microbial ID of *Escherichia coli* and not *Entamoeba coli* (a microorganism less prevalent in humans), although the latter would alphabetically come first. #' This will lead to the effect that e.g. `"E. coli"` (a microorganism highly prevalent in humans) will return the microbial ID of *Escherichia coli* and not *Entamoeba coli* (a microorganism less prevalent in humans), although the latter would alphabetically come first.
#' #'
#' ## Coping with Uncertain Results #' ### Coping with Uncertain Results
#' #'
#' In addition, the [as.mo()] function can differentiate four levels of uncertainty to guess valid results: #' In addition, the [as.mo()] function can differentiate four levels of uncertainty to guess valid results:
#' - Uncertainty level 0: no additional rules are applied; #' - Uncertainty level 0: no additional rules are applied;
@ -97,7 +97,7 @@
#' - Use [mo_failures()] to get a [character] [vector] with all values that could not be coerced to a valid value. #' - Use [mo_failures()] to get a [character] [vector] with all values that could not be coerced to a valid value.
#' - Use [mo_renamed()] to get a [data.frame] with all values that could be coerced based on old, previously accepted taxonomic names. #' - Use [mo_renamed()] to get a [data.frame] with all values that could be coerced based on old, previously accepted taxonomic names.
#' #'
#' ## Microbial Prevalence of Pathogens in Humans #' ### Microbial Prevalence of Pathogens in Humans
#' #'
#' The coercion rules consider the prevalence of microorganisms in humans grouped into three groups, which is available as the `prevalence` columns in the [microorganisms] data set. The grouping into human pathogenic prevalence is explained in the section *Matching Score for Microorganisms* below. #' The coercion rules consider the prevalence of microorganisms in humans grouped into three groups, which is available as the `prevalence` columns in the [microorganisms] data set. The grouping into human pathogenic prevalence is explained in the section *Matching Score for Microorganisms* below.
#' @inheritSection mo_matching_score Matching Score for Microorganisms #' @inheritSection mo_matching_score Matching Score for Microorganisms
@ -133,8 +133,8 @@
#' "MRSA", # Methicillin Resistant S. aureus #' "MRSA", # Methicillin Resistant S. aureus
#' "VISA", # Vancomycin Intermediate S. aureus #' "VISA", # Vancomycin Intermediate S. aureus
#' "VRSA", # Vancomycin Resistant S. aureus #' "VRSA", # Vancomycin Resistant S. aureus
#' 115329001 #' 115329001 # SNOMED CT code
#' )) # SNOMED CT code #' ))
#' #'
#' # Dyslexia is no problem - these all work: #' # Dyslexia is no problem - these all work:
#' as.mo(c( #' as.mo(c(
@ -153,25 +153,25 @@
#' as.mo("S. pyogenes", Lancefield = TRUE) # will not remain species: B_STRPT_GRPA #' as.mo("S. pyogenes", Lancefield = TRUE) # will not remain species: B_STRPT_GRPA
#' #'
#' # All mo_* functions use as.mo() internally too (see ?mo_property): #' # All mo_* functions use as.mo() internally too (see ?mo_property):
#' mo_genus("Esch coli") #' mo_genus("E. coli")
#' mo_gramstain("E. coli") #' mo_gramstain("ESCO")
#' mo_is_intrinsic_resistant("E. coli", "vanco") #' mo_is_intrinsic_resistant("ESCCOL", ab = "vanco")
#' } #' }
as.mo <- function(x, as.mo <- function(x,
Becker = FALSE, Becker = FALSE,
Lancefield = FALSE, Lancefield = FALSE,
minimum_matching_score = NULL, minimum_matching_score = NULL,
allow_uncertain = TRUE, allow_uncertain = TRUE,
keep_synonyms = FALSE, keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
reference_df = get_mo_source(), reference_df = get_mo_source(),
ignore_pattern = getOption("AMR_ignore_pattern"), ignore_pattern = getOption("AMR_ignore_pattern", NULL),
language = get_AMR_locale(), language = get_AMR_locale(),
info = interactive(), info = interactive(),
...) { ...) {
meet_criteria(x, allow_class = c("mo", "data.frame", "list", "character", "numeric", "integer", "factor"), allow_NA = TRUE) meet_criteria(x, allow_class = c("mo", "data.frame", "list", "character", "numeric", "integer", "factor"), allow_NA = TRUE)
meet_criteria(Becker, allow_class = c("logical", "character"), has_length = 1) meet_criteria(Becker, allow_class = c("logical", "character"), has_length = 1)
meet_criteria(Lancefield, allow_class = c("logical", "character"), has_length = 1) meet_criteria(Lancefield, allow_class = c("logical", "character"), has_length = 1)
meet_criteria(keep_synonyms, allow_class = c("logical", "character"), has_length = 1) meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
meet_criteria(minimum_matching_score, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE) meet_criteria(minimum_matching_score, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE)
meet_criteria(reference_df, allow_class = "data.frame", allow_NULL = TRUE) meet_criteria(reference_df, allow_class = "data.frame", allow_NULL = TRUE)
meet_criteria(ignore_pattern, allow_class = "character", has_length = 1, allow_NULL = TRUE) meet_criteria(ignore_pattern, allow_class = "character", has_length = 1, allow_NULL = TRUE)
@ -371,18 +371,18 @@ as.mo <- function(x,
} # end of loop over all yet unknowns } # end of loop over all yet unknowns
# Keep or replace synonyms ---- # Keep or replace synonyms ----
gbif_matches <- AMR::microorganisms$gbif_renamed_to[match(out, AMR::microorganisms$mo)]
lpsn_matches <- AMR::microorganisms$lpsn_renamed_to[match(out, AMR::microorganisms$mo)]
if (isFALSE(keep_synonyms)) { if (isFALSE(keep_synonyms)) {
out_old <- out out_old <- out
gbif_matches <- AMR::microorganisms$gbif_renamed_to[match(out, AMR::microorganisms$mo)]
gbif_matches[!gbif_matches %in% AMR::microorganisms$gbif] <- NA gbif_matches[!gbif_matches %in% AMR::microorganisms$gbif] <- NA
out[which(!is.na(gbif_matches))] <- AMR::microorganisms$mo[match(gbif_matches[which(!is.na(gbif_matches))], AMR::microorganisms$gbif)] out[which(!is.na(gbif_matches))] <- AMR::microorganisms$mo[match(gbif_matches[which(!is.na(gbif_matches))], AMR::microorganisms$gbif)]
lpsn_matches <- AMR::microorganisms$lpsn_renamed_to[match(out, AMR::microorganisms$mo)]
lpsn_matches[!lpsn_matches %in% AMR::microorganisms$lpsn] <- NA lpsn_matches[!lpsn_matches %in% AMR::microorganisms$lpsn] <- NA
out[which(!is.na(lpsn_matches))] <- AMR::microorganisms$mo[match(lpsn_matches[which(!is.na(lpsn_matches))], AMR::microorganisms$lpsn)] out[which(!is.na(lpsn_matches))] <- AMR::microorganisms$mo[match(lpsn_matches[which(!is.na(lpsn_matches))], AMR::microorganisms$lpsn)]
if (isTRUE(info) && (any(!is.na(gbif_matches)) || any(!is.na(lpsn_matches))) && message_not_thrown_before("as.mo", gbif_matches[which(!is.na(gbif_matches))][1:5], lpsn_matches[which(!is.na(lpsn_matches))][1:5]) && length(c(lpsn_matches, gbif_matches)) > 0) { if (isTRUE(info) && (any(!is.na(gbif_matches)) || any(!is.na(lpsn_matches))) && message_not_thrown_before("as.mo", gbif_matches[which(!is.na(gbif_matches))], lpsn_matches[which(!is.na(lpsn_matches))]) && length(c(lpsn_matches, gbif_matches)) > 0) {
total_old <- out_old[which(!is.na(gbif_matches) | !is.na(lpsn_matches))] total_old <- out_old[which(!is.na(gbif_matches) | !is.na(lpsn_matches))]
total_new <- out[which(!is.na(gbif_matches) | !is.na(lpsn_matches))] total_new <- out[which(!is.na(gbif_matches) | !is.na(lpsn_matches))]
@ -401,14 +401,19 @@ as.mo <- function(x,
message_( message_(
"The following microorganism", ifelse(length(total_old) > 1, "s were", " was"), " taxonomically renamed (use `keep_synonyms = TRUE` to leave uncorrected):\n", "The following microorganism", ifelse(length(total_old) > 1, "s were", " was"), " taxonomically renamed (use `keep_synonyms = TRUE` to leave uncorrected):\n",
paste0(" ", microorganisms$fullname[match(total_old, microorganisms$mo)], paste0(" ", font_italic(microorganisms$fullname[match(total_old, microorganisms$mo)], collapse = NULL),
refs_old, refs_old,
" -> ", microorganisms$fullname[match(total_new, microorganisms$mo)], " -> ", font_italic(microorganisms$fullname[match(total_new, microorganisms$mo)], collapse = NULL),
refs_new, refs_new,
collapse = "\n" collapse = "\n"
) )
) )
} }
} else {
# keep synonyms is TRUE, so check if any do have synonyms
if (any(!is.na(c(gbif_matches, lpsn_matches))) && message_not_thrown_before("as.mo", unique(c(gbif_matches, lpsn_matches)))) {
warning_("Function `as.mo()` returned some old taxonomic names. Use `as.mo(..., keep_synonyms = FALSE)` to clean the input to currently accepted taxonomic names, or set the R option `AMR_keep_synonyms` to `FALSE`.")
}
} }
# Apply Becker ---- # Apply Becker ----
@ -496,10 +501,10 @@ pillar_shaft.mo <- function(x, ...) {
mo_cols <- NULL mo_cols <- NULL
} }
if (!all(x[!is.na(x)] %in% MO_lookup$mo) | if (!all(x[!is.na(x)] %in% AMR::microorganisms$mo) |
(!is.null(df) && !all(unlist(df[, which(mo_cols), drop = FALSE]) %in% MO_lookup$mo))) { (!is.null(df) && !all(unlist(df[, which(mo_cols), drop = FALSE]) %in% AMR::microorganisms$mo))) {
# markup old mo codes # markup old mo codes
out[!x %in% MO_lookup$mo] <- font_italic(font_na(x[!x %in% MO_lookup$mo], out[!x %in% AMR::microorganisms$mo] <- font_italic(font_na(x[!x %in% AMR::microorganisms$mo],
collapse = NULL collapse = NULL
), ),
collapse = NULL collapse = NULL
@ -596,7 +601,7 @@ print.mo <- function(x, print.shortnames = FALSE, ...) {
} }
x <- as.character(x) x <- as.character(x)
names(x) <- x_names names(x) <- x_names
if (!all(x[!is.na(x)] %in% MO_lookup$mo)) { if (!all(x[!is.na(x)] %in% AMR::microorganisms$mo)) {
warning_( warning_(
"Some MO codes are from a previous AMR package version. ", "Some MO codes are from a previous AMR package version. ",
"Please update the MO codes with `as.mo()`." "Please update the MO codes with `as.mo()`."
@ -629,7 +634,7 @@ summary.mo <- function(object, ...) {
#' @export #' @export
#' @noRd #' @noRd
as.data.frame.mo <- function(x, ...) { as.data.frame.mo <- function(x, ...) {
if (!all(x[!is.na(x)] %in% MO_lookup$mo)) { if (!all(x[!is.na(x)] %in% AMR::microorganisms$mo)) {
warning_( warning_(
"The data contains old MO codes (from a previous AMR package version). ", "The data contains old MO codes (from a previous AMR package version). ",
"Please update your MO codes with `as.mo()`." "Please update your MO codes with `as.mo()`."
@ -960,7 +965,7 @@ parse_and_convert <- function(x) {
replace_old_mo_codes <- function(x, property) { replace_old_mo_codes <- function(x, property) {
# this function transform old MO codes to current codes, such as: # this function transform old MO codes to current codes, such as:
# B_ESCH_COL (AMR v0.5.0) -> B_ESCHR_COLI # B_ESCH_COL (AMR v0.5.0) -> B_ESCHR_COLI
ind <- x %like_case% "^[A-Z]_[A-Z_]+$" & !x %in% MO_lookup$mo ind <- x %like_case% "^[A-Z]_[A-Z_]+$" & !x %in% AMR::microorganisms$mo
if (any(ind)) { if (any(ind)) {
# get the ones that match # get the ones that match
affected <- x[ind] affected <- x[ind]

250
R/mo_property.R
View File

@ -28,11 +28,11 @@
#' 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*. #' 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*.
#' @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*. #' @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*.
#' @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"` #' @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"`
#' @param language language of the returned text, defaults to system language (see [get_AMR_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. #' @inheritParams as.mo
#' @param ... other arguments passed on to [as.mo()], such as 'allow_uncertain' and 'ignore_pattern' #' @param ... other arguments passed on to [as.mo()], such as 'allow_uncertain' and 'ignore_pattern'
#' @param ab any (vector of) text that can be coerced to a valid antibiotic code with [as.ab()] #' @param ab any (vector of) text that can be coerced to a valid antibiotic code with [as.ab()]
#' @param open browse the URL using [`browseURL()`][utils::browseURL()] #' @param open browse the URL using [`browseURL()`][utils::browseURL()]
#' @details All functions will return the most recently known taxonomic property [as included in this package][microorganisms], 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: #' @details All functions will, at default, keep old taxonomic properties. 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_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("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) #' - `mo_ref("Shimwellia blattae")` will return `"Priest et al., 2010"` (without a message)
@ -168,15 +168,16 @@
#' # SNOMED codes, and URL to the online database #' # SNOMED codes, and URL to the online database
#' mo_info("Klebsiella pneumoniae") #' mo_info("Klebsiella pneumoniae")
#' } #' }
mo_name <- function(x, language = get_AMR_locale(), ...) { mo_name <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_name") x <- find_mo_col(fn = "mo_name")
} }
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
translate_into_language(mo_validate(x = x, property = "fullname", language = language, ...), translate_into_language(mo_validate(x = x, property = "fullname", language = language, keep_synonyms = keep_synonyms, ...),
language = language, language = language,
only_unknown = FALSE, only_unknown = FALSE,
only_affect_mo_names = TRUE only_affect_mo_names = TRUE
@ -189,15 +190,16 @@ mo_fullname <- mo_name
#' @rdname mo_property #' @rdname mo_property
#' @export #' @export
mo_shortname <- function(x, language = get_AMR_locale(), ...) { mo_shortname <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_shortname") x <- find_mo_col(fn = "mo_shortname")
} }
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
x.mo <- as.mo(x, language = language, ...) x.mo <- as.mo(x, language = language, keep_synonyms = keep_synonyms, ...)
metadata <- get_mo_failures_uncertainties_renamed() metadata <- get_mo_failures_uncertainties_renamed()
@ -207,8 +209,8 @@ mo_shortname <- function(x, language = get_AMR_locale(), ...) {
} }
# get first char of genus and complete species in English # get first char of genus and complete species in English
genera <- mo_genus(x.mo, language = NULL) genera <- mo_genus(x.mo, language = NULL, keep_synonyms = keep_synonyms)
shortnames <- paste0(substr(genera, 1, 1), ". ", replace_empty(mo_species(x.mo, language = NULL))) shortnames <- paste0(substr(genera, 1, 1), ". ", replace_empty(mo_species(x.mo, language = NULL, keep_synonyms = keep_synonyms)))
# exceptions for where no species is known # exceptions for where no species is known
shortnames[shortnames %like% ".[.] spp[.]"] <- genera[shortnames %like% ".[.] spp[.]"] shortnames[shortnames %like% ".[.] spp[.]"] <- genera[shortnames %like% ".[.] spp[.]"]
@ -229,106 +231,114 @@ mo_shortname <- function(x, language = get_AMR_locale(), ...) {
#' @rdname mo_property #' @rdname mo_property
#' @export #' @export
mo_subspecies <- function(x, language = get_AMR_locale(), ...) { mo_subspecies <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_subspecies") x <- find_mo_col(fn = "mo_subspecies")
} }
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
translate_into_language(mo_validate(x = x, property = "subspecies", language = language, ...), language = language, only_unknown = TRUE) translate_into_language(mo_validate(x = x, property = "subspecies", language = language, keep_synonyms = keep_synonyms, ...), language = language, only_unknown = TRUE)
} }
#' @rdname mo_property #' @rdname mo_property
#' @export #' @export
mo_species <- function(x, language = get_AMR_locale(), ...) { mo_species <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_species") x <- find_mo_col(fn = "mo_species")
} }
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
translate_into_language(mo_validate(x = x, property = "species", language = language, ...), language = language, only_unknown = TRUE) translate_into_language(mo_validate(x = x, property = "species", language = language, keep_synonyms = keep_synonyms, ...), language = language, only_unknown = TRUE)
} }
#' @rdname mo_property #' @rdname mo_property
#' @export #' @export
mo_genus <- function(x, language = get_AMR_locale(), ...) { mo_genus <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_genus") x <- find_mo_col(fn = "mo_genus")
} }
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
translate_into_language(mo_validate(x = x, property = "genus", language = language, ...), language = language, only_unknown = TRUE) translate_into_language(mo_validate(x = x, property = "genus", language = language, keep_synonyms = keep_synonyms, ...), language = language, only_unknown = TRUE)
} }
#' @rdname mo_property #' @rdname mo_property
#' @export #' @export
mo_family <- function(x, language = get_AMR_locale(), ...) { mo_family <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_family") x <- find_mo_col(fn = "mo_family")
} }
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
translate_into_language(mo_validate(x = x, property = "family", language = language, ...), language = language, only_unknown = TRUE) translate_into_language(mo_validate(x = x, property = "family", language = language, keep_synonyms = keep_synonyms, ...), language = language, only_unknown = TRUE)
} }
#' @rdname mo_property #' @rdname mo_property
#' @export #' @export
mo_order <- function(x, language = get_AMR_locale(), ...) { mo_order <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_order") x <- find_mo_col(fn = "mo_order")
} }
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
translate_into_language(mo_validate(x = x, property = "order", language = language, ...), language = language, only_unknown = TRUE) translate_into_language(mo_validate(x = x, property = "order", language = language, keep_synonyms = keep_synonyms, ...), language = language, only_unknown = TRUE)
} }
#' @rdname mo_property #' @rdname mo_property
#' @export #' @export
mo_class <- function(x, language = get_AMR_locale(), ...) { mo_class <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_class") x <- find_mo_col(fn = "mo_class")
} }
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
translate_into_language(mo_validate(x = x, property = "class", language = language, ...), language = language, only_unknown = TRUE) translate_into_language(mo_validate(x = x, property = "class", language = language, keep_synonyms = keep_synonyms, ...), language = language, only_unknown = TRUE)
} }
#' @rdname mo_property #' @rdname mo_property
#' @export #' @export
mo_phylum <- function(x, language = get_AMR_locale(), ...) { mo_phylum <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_phylum") x <- find_mo_col(fn = "mo_phylum")
} }
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
translate_into_language(mo_validate(x = x, property = "phylum", language = language, ...), language = language, only_unknown = TRUE) translate_into_language(mo_validate(x = x, property = "phylum", language = language, keep_synonyms = keep_synonyms, ...), language = language, only_unknown = TRUE)
} }
#' @rdname mo_property #' @rdname mo_property
#' @export #' @export
mo_kingdom <- function(x, language = get_AMR_locale(), ...) { mo_kingdom <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_kingdom") x <- find_mo_col(fn = "mo_kingdom")
} }
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
translate_into_language(mo_validate(x = x, property = "kingdom", language = language, ...), language = language, only_unknown = TRUE) translate_into_language(mo_validate(x = x, property = "kingdom", language = language, keep_synonyms = keep_synonyms, ...), language = language, only_unknown = TRUE)
} }
#' @rdname mo_property #' @rdname mo_property
@ -337,40 +347,41 @@ mo_domain <- mo_kingdom
#' @rdname mo_property #' @rdname mo_property
#' @export #' @export
mo_type <- function(x, language = get_AMR_locale(), ...) { mo_type <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_type") x <- find_mo_col(fn = "mo_type")
} }
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
x.mo <- as.mo(x, language = language, ...) x.mo <- as.mo(x, language = language, keep_synonyms = keep_synonyms, ...)
out <- mo_kingdom(x.mo, language = NULL) out <- mo_kingdom(x.mo, language = NULL, keep_synonyms = keep_synonyms)
out[which(mo_is_yeast(x.mo))] <- "Yeasts" out[which(mo_is_yeast(x.mo, keep_synonyms = keep_synonyms))] <- "Yeasts"
translate_into_language(out, language = language, only_unknown = FALSE) translate_into_language(out, language = language, only_unknown = FALSE)
} }
#' @rdname mo_property #' @rdname mo_property
#' @export #' @export
mo_gramstain <- function(x, language = get_AMR_locale(), ...) { mo_gramstain <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_gramstain") x <- find_mo_col(fn = "mo_gramstain")
} }
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
# keep_synonyms = TRUE to prevent messages - they won't change Gram stain anyway x.mo <- as.mo(x, language = language, keep_synonyms = keep_synonyms, ...)
x.mo <- as.mo(x, language = language, keep_synonyms = TRUE, ...)
metadata <- get_mo_failures_uncertainties_renamed() metadata <- get_mo_failures_uncertainties_renamed()
x <- rep(NA_character_, length(x)) x <- rep(NA_character_, length(x))
# make all bacteria Gram negative # make all bacteria Gram negative
x[mo_kingdom(x.mo, language = NULL, keep_synonyms = TRUE) == "Bacteria"] <- "Gram-negative" x[mo_kingdom(x.mo, language = NULL, keep_synonyms = keep_synonyms) == "Bacteria"] <- "Gram-negative"
# overwrite these 4 phyla with Gram-positives # overwrite these 4 phyla with Gram-positives
# Source: https://itis.gov/servlet/SingleRpt/SingleRpt?search_topic=TSN&search_value=956097 (Cavalier-Smith, 2002) # Source: https://itis.gov/servlet/SingleRpt/SingleRpt?search_topic=TSN&search_value=956097 (Cavalier-Smith, 2002)
x[(mo_phylum(x.mo, language = NULL, keep_synonyms = TRUE) %in% c( x[(mo_phylum(x.mo, language = NULL, keep_synonyms = keep_synonyms) %in% c(
"Actinobacteria", "Actinobacteria",
"Chloroflexi", "Chloroflexi",
"Firmicutes", "Firmicutes",
@ -378,7 +389,7 @@ mo_gramstain <- function(x, language = get_AMR_locale(), ...) {
"Bacillota" # this one is new! It was renamed from Firmicutes by Gibbons et al., 2021 "Bacillota" # this one is new! It was renamed from Firmicutes by Gibbons et al., 2021
) & ) &
# but class Negativicutes (of phylum Firmicutes) are Gram-negative! # but class Negativicutes (of phylum Firmicutes) are Gram-negative!
mo_class(x.mo, language = NULL, keep_synonyms = TRUE) != "Negativicutes") mo_class(x.mo, language = NULL, keep_synonyms = keep_synonyms) != "Negativicutes")
# and of course our own ID for Gram-positives # and of course our own ID for Gram-positives
| x.mo == "B_GRAMP"] <- "Gram-positive" | x.mo == "B_GRAMP"] <- "Gram-positive"
@ -388,17 +399,18 @@ mo_gramstain <- function(x, language = get_AMR_locale(), ...) {
#' @rdname mo_property #' @rdname mo_property
#' @export #' @export
mo_is_gram_negative <- function(x, language = get_AMR_locale(), ...) { mo_is_gram_negative <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_is_gram_negative") x <- find_mo_col(fn = "mo_is_gram_negative")
} }
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
x.mo <- as.mo(x, language = language, ...) x.mo <- as.mo(x, language = language, keep_synonyms = keep_synonyms, ...)
metadata <- get_mo_failures_uncertainties_renamed() metadata <- get_mo_failures_uncertainties_renamed()
grams <- mo_gramstain(x.mo, language = NULL) grams <- mo_gramstain(x.mo, language = NULL, keep_synonyms = keep_synonyms)
load_mo_failures_uncertainties_renamed(metadata) load_mo_failures_uncertainties_renamed(metadata)
out <- grams == "Gram-negative" & !is.na(grams) out <- grams == "Gram-negative" & !is.na(grams)
out[x.mo %in% c(NA_character_, "UNKNOWN")] <- NA out[x.mo %in% c(NA_character_, "UNKNOWN")] <- NA
@ -407,17 +419,18 @@ mo_is_gram_negative <- function(x, language = get_AMR_locale(), ...) {
#' @rdname mo_property #' @rdname mo_property
#' @export #' @export
mo_is_gram_positive <- function(x, language = get_AMR_locale(), ...) { mo_is_gram_positive <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_is_gram_positive") x <- find_mo_col(fn = "mo_is_gram_positive")
} }
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
x.mo <- as.mo(x, language = language, ...) x.mo <- as.mo(x, language = language, keep_synonyms = keep_synonyms, ...)
metadata <- get_mo_failures_uncertainties_renamed() metadata <- get_mo_failures_uncertainties_renamed()
grams <- mo_gramstain(x.mo, language = NULL) grams <- mo_gramstain(x.mo, language = NULL, keep_synonyms = keep_synonyms)
load_mo_failures_uncertainties_renamed(metadata) load_mo_failures_uncertainties_renamed(metadata)
out <- grams == "Gram-positive" & !is.na(grams) out <- grams == "Gram-positive" & !is.na(grams)
out[x.mo %in% c(NA_character_, "UNKNOWN")] <- NA out[x.mo %in% c(NA_character_, "UNKNOWN")] <- NA
@ -426,19 +439,20 @@ mo_is_gram_positive <- function(x, language = get_AMR_locale(), ...) {
#' @rdname mo_property #' @rdname mo_property
#' @export #' @export
mo_is_yeast <- function(x, language = get_AMR_locale(), ...) { mo_is_yeast <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_is_yeast") x <- find_mo_col(fn = "mo_is_yeast")
} }
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
x.mo <- as.mo(x, language = language, ...) x.mo <- as.mo(x, language = language, keep_synonyms = keep_synonyms, ...)
metadata <- get_mo_failures_uncertainties_renamed() metadata <- get_mo_failures_uncertainties_renamed()
x.kingdom <- mo_kingdom(x.mo, language = NULL) x.kingdom <- mo_kingdom(x.mo, language = NULL, keep_synonyms = keep_synonyms)
x.class <- mo_class(x.mo, language = NULL) x.class <- mo_class(x.mo, language = NULL, keep_synonyms = keep_synonyms)
load_mo_failures_uncertainties_renamed(metadata) load_mo_failures_uncertainties_renamed(metadata)
@ -450,7 +464,7 @@ mo_is_yeast <- function(x, language = get_AMR_locale(), ...) {
#' @rdname mo_property #' @rdname mo_property
#' @export #' @export
mo_is_intrinsic_resistant <- function(x, ab, language = get_AMR_locale(), ...) { mo_is_intrinsic_resistant <- function(x, ab, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_is_intrinsic_resistant") x <- find_mo_col(fn = "mo_is_intrinsic_resistant")
@ -458,8 +472,9 @@ mo_is_intrinsic_resistant <- function(x, ab, language = get_AMR_locale(), ...) {
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
meet_criteria(ab, allow_NA = FALSE) meet_criteria(ab, allow_NA = FALSE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
x <- as.mo(x, language = language, ...) x <- as.mo(x, language = language, keep_synonyms = keep_synonyms, ...)
ab <- as.ab(ab, language = NULL, flag_multiple_results = FALSE, info = FALSE) ab <- as.ab(ab, language = NULL, flag_multiple_results = FALSE, info = FALSE)
if (length(x) == 1 & length(ab) > 1) { if (length(x) == 1 & length(ab) > 1) {
@ -486,41 +501,44 @@ mo_is_intrinsic_resistant <- function(x, ab, language = get_AMR_locale(), ...) {
#' @rdname mo_property #' @rdname mo_property
#' @export #' @export
mo_snomed <- function(x, language = get_AMR_locale(), ...) { mo_snomed <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_snomed") x <- find_mo_col(fn = "mo_snomed")
} }
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
mo_validate(x = x, property = "snomed", language = language, ...) mo_validate(x = x, property = "snomed", language = language, keep_synonyms = keep_synonyms, ...)
} }
#' @rdname mo_property #' @rdname mo_property
#' @export #' @export
mo_ref <- function(x, language = get_AMR_locale(), ...) { mo_ref <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_ref") x <- find_mo_col(fn = "mo_ref")
} }
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
mo_validate(x = x, property = "ref", language = language, ...) mo_validate(x = x, property = "ref", language = language, keep_synonyms = keep_synonyms, ...)
} }
#' @rdname mo_property #' @rdname mo_property
#' @export #' @export
mo_authors <- function(x, language = get_AMR_locale(), ...) { mo_authors <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_authors") x <- find_mo_col(fn = "mo_authors")
} }
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
x <- mo_validate(x = x, property = "ref", language = language, ...) x <- mo_validate(x = x, property = "ref", language = language, keep_synonyms = keep_synonyms, ...)
# remove last 4 digits and presumably the comma and space that preceed them # remove last 4 digits and presumably the comma and space that preceed them
x[!is.na(x)] <- gsub(",? ?[0-9]{4}", "", x[!is.na(x)], perl = TRUE) x[!is.na(x)] <- gsub(",? ?[0-9]{4}", "", x[!is.na(x)], perl = TRUE)
suppressWarnings(x) suppressWarnings(x)
@ -528,15 +546,16 @@ mo_authors <- function(x, language = get_AMR_locale(), ...) {
#' @rdname mo_property #' @rdname mo_property
#' @export #' @export
mo_year <- function(x, language = get_AMR_locale(), ...) { mo_year <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_year") x <- find_mo_col(fn = "mo_year")
} }
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
x <- mo_validate(x = x, property = "ref", language = language, ...) x <- mo_validate(x = x, property = "ref", language = language, keep_synonyms = keep_synonyms, ...)
# get last 4 digits # get last 4 digits
x[!is.na(x)] <- gsub(".*([0-9]{4})$", "\\1", x[!is.na(x)], perl = TRUE) x[!is.na(x)] <- gsub(".*([0-9]{4})$", "\\1", x[!is.na(x)], perl = TRUE)
suppressWarnings(as.integer(x)) suppressWarnings(as.integer(x))
@ -544,52 +563,69 @@ mo_year <- function(x, language = get_AMR_locale(), ...) {
#' @rdname mo_property #' @rdname mo_property
#' @export #' @export
mo_lpsn <- function(x, language = get_AMR_locale(), ...) { mo_lpsn <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) {
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_lpsn")
}
meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
mo_validate(x = x, property = "lpsn", language = language, keep_synonyms = keep_synonyms, ...)
}
#' @rdname mo_property
#' @export
mo_gbif <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) {
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_gbif")
}
meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
mo_validate(x = x, property = "gbif", language = language, keep_synonyms = keep_synonyms, ...)
}
#' @rdname mo_property
#' @export
mo_rank <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_rank") x <- find_mo_col(fn = "mo_rank")
} }
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
mo_validate(x = x, property = "species_id", language = language, ...) mo_validate(x = x, property = "rank", language = language, keep_synonyms = keep_synonyms, ...)
} }
#' @rdname mo_property #' @rdname mo_property
#' @export #' @export
mo_rank <- function(x, language = get_AMR_locale(), ...) { mo_taxonomy <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) {
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_rank")
}
meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language)
mo_validate(x = x, property = "rank", language = language, ...)
}
#' @rdname mo_property
#' @export
mo_taxonomy <- function(x, language = get_AMR_locale(), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_taxonomy") x <- find_mo_col(fn = "mo_taxonomy")
} }
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
x <- as.mo(x, language = language, ...) x <- as.mo(x, language = language, keep_synonyms = keep_synonyms, ...)
metadata <- get_mo_failures_uncertainties_renamed() metadata <- get_mo_failures_uncertainties_renamed()
out <- list( out <- list(
kingdom = mo_kingdom(x, language = language), kingdom = mo_kingdom(x, language = language, keep_synonyms = keep_synonyms),
phylum = mo_phylum(x, language = language), phylum = mo_phylum(x, language = language, keep_synonyms = keep_synonyms),
class = mo_class(x, language = language), class = mo_class(x, language = language, keep_synonyms = keep_synonyms),
order = mo_order(x, language = language), order = mo_order(x, language = language, keep_synonyms = keep_synonyms),
family = mo_family(x, language = language), family = mo_family(x, language = language, keep_synonyms = keep_synonyms),
genus = mo_genus(x, language = language), genus = mo_genus(x, language = language, keep_synonyms = keep_synonyms),
species = mo_species(x, language = language), species = mo_species(x, language = language, keep_synonyms = keep_synonyms),
subspecies = mo_subspecies(x, language = language) subspecies = mo_subspecies(x, language = language, keep_synonyms = keep_synonyms)
) )
load_mo_failures_uncertainties_renamed(metadata) load_mo_failures_uncertainties_renamed(metadata)
@ -598,21 +634,22 @@ mo_taxonomy <- function(x, language = get_AMR_locale(), ...) {
#' @rdname mo_property #' @rdname mo_property
#' @export #' @export
mo_synonyms <- function(x, language = get_AMR_locale(), ...) { mo_synonyms <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_synonyms") x <- find_mo_col(fn = "mo_synonyms")
} }
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
x.mo <- as.mo(x, language = language, ...) x.mo <- as.mo(x, language = language, keep_synonyms = keep_synonyms, ...)
metadata <- get_mo_failures_uncertainties_renamed() metadata <- get_mo_failures_uncertainties_renamed()
syns <- lapply(x.mo, function(y) { syns <- lapply(x.mo, function(y) {
gbif <- AMR::microorganisms$gbif[match(y, AMR::microorganisms$mo)] gbif <- AMR::microorganisms$gbif[match(y, AMR::microorganisms$mo)]
lpsn <- AMR::microorganisms$lpsn[match(y, AMR::microorganisms$mo)] lpsn <- AMR::microorganisms$lpsn[match(y, AMR::microorganisms$mo)]
out <- AMR::microorganisms[which(AMR::microorganisms$lpsn_renamed_to %in% c(gbif, lpsn)), "fullname", drop = TRUE] out <- AMR::microorganisms[which(AMR::microorganisms$lpsn_renamed_to %in% lpsn | AMR::microorganisms$gbif_renamed_to %in% gbif), "fullname", drop = TRUE]
if (length(out) == 0) { if (length(out) == 0) {
NULL NULL
} else { } else {
@ -633,26 +670,27 @@ mo_synonyms <- function(x, language = get_AMR_locale(), ...) {
#' @rdname mo_property #' @rdname mo_property
#' @export #' @export
mo_info <- function(x, language = get_AMR_locale(), ...) { mo_info <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_info") x <- find_mo_col(fn = "mo_info")
} }
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
x <- as.mo(x, language = language, ...) x <- as.mo(x, language = language, keep_synonyms = keep_synonyms, ...)
metadata <- get_mo_failures_uncertainties_renamed() metadata <- get_mo_failures_uncertainties_renamed()
info <- lapply(x, function(y) { info <- lapply(x, function(y) {
c( c(
mo_taxonomy(y, language = language), mo_taxonomy(y, language = language, keep_synonyms = keep_synonyms),
list( list(
synonyms = mo_synonyms(y), synonyms = mo_synonyms(y, keep_synonyms = keep_synonyms),
gramstain = mo_gramstain(y, language = language), gramstain = mo_gramstain(y, language = language, keep_synonyms = keep_synonyms),
url = unname(mo_url(y, open = FALSE)), url = unname(mo_url(y, open = FALSE, keep_synonyms = keep_synonyms)),
ref = mo_ref(y), ref = mo_ref(y, keep_synonyms = keep_synonyms),
snomed = unlist(mo_snomed(y)) snomed = unlist(mo_snomed(y, keep_synonyms = keep_synonyms))
) )
) )
}) })
@ -669,7 +707,7 @@ mo_info <- function(x, language = get_AMR_locale(), ...) {
#' @rdname mo_property #' @rdname mo_property
#' @export #' @export
mo_url <- function(x, open = FALSE, language = get_AMR_locale(), ...) { mo_url <- function(x, open = FALSE, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_url") x <- find_mo_col(fn = "mo_url")
@ -677,14 +715,15 @@ mo_url <- function(x, open = FALSE, language = get_AMR_locale(), ...) {
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
meet_criteria(open, allow_class = "logical", has_length = 1) meet_criteria(open, allow_class = "logical", has_length = 1)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
x.mo <- as.mo(x = x, language = language, ... = ...) x.mo <- as.mo(x = x, language = language, keep_synonyms = keep_synonyms, ... = ...)
metadata <- get_mo_failures_uncertainties_renamed() metadata <- get_mo_failures_uncertainties_renamed()
x.rank <- microorganisms$rank[match(x.mo, microorganisms$mo)] x.rank <- AMR::microorganisms$rank[match(x.mo, AMR::microorganisms$mo)]
x.name <- microorganisms$fullname[match(x.mo, microorganisms$mo)] x.name <- AMR::microorganisms$fullname[match(x.mo, AMR::microorganisms$mo)]
x.lpsn <- microorganisms$lpsn[match(x.mo, microorganisms$mo)] x.lpsn <- AMR::microorganisms$lpsn[match(x.mo, AMR::microorganisms$mo)]
x.gbif <- microorganisms$gbif[match(x.mo, microorganisms$mo)] x.gbif <- AMR::microorganisms$gbif[match(x.mo, AMR::microorganisms$mo)]
u <- character(length(x)) u <- character(length(x))
u[!is.na(x.gbif)] <- paste0(TAXONOMY_VERSION$GBIF$url, "/species/", x.gbif[!is.na(x.gbif)]) u[!is.na(x.gbif)] <- paste0(TAXONOMY_VERSION$GBIF$url, "/species/", x.gbif[!is.na(x.gbif)])
@ -707,7 +746,7 @@ mo_url <- function(x, open = FALSE, language = get_AMR_locale(), ...) {
#' @rdname mo_property #' @rdname mo_property
#' @export #' @export
mo_property <- function(x, property = "fullname", language = get_AMR_locale(), ...) { mo_property <- function(x, property = "fullname", language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", TRUE), ...) {
if (missing(x)) { if (missing(x)) {
# this tries to find the data and an <mo> column # this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_property") x <- find_mo_col(fn = "mo_property")
@ -715,11 +754,12 @@ mo_property <- function(x, property = "fullname", language = get_AMR_locale(), .
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
meet_criteria(property, allow_class = "character", has_length = 1, is_in = colnames(AMR::microorganisms)) meet_criteria(property, allow_class = "character", has_length = 1, is_in = colnames(AMR::microorganisms))
language <- validate_language(language) language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
translate_into_language(mo_validate(x = x, property = property, language = language, ...), language = language, only_unknown = TRUE) translate_into_language(mo_validate(x = x, property = property, language = language, keep_synonyms = keep_synonyms, ...), language = language, only_unknown = TRUE)
} }
mo_validate <- function(x, property, language, ...) { mo_validate <- function(x, property, language, keep_synonyms = keep_synonyms, ...) {
# try to catch an error when inputting an invalid argument # try to catch an error when inputting an invalid argument
# so the 'call.' can be set to FALSE # so the 'call.' can be set to FALSE
@ -736,20 +776,20 @@ mo_validate <- function(x, property, language, ...) {
if (is.null(Lancefield) || property %in% c("kingdom", "phylum", "class", "order", "family", "genus")) { if (is.null(Lancefield) || property %in% c("kingdom", "phylum", "class", "order", "family", "genus")) {
Lancefield <- FALSE Lancefield <- FALSE
} }
keep_synonyms <- dots$keep_synonyms has_Becker_or_Lancefield <- Becker %in% c(TRUE, "all") || Lancefield %in% c(TRUE, "all")
has_Becker_or_Lancefield_or_synonyms <- !isFALSE(keep_synonyms) || Becker %in% c(TRUE, "all") || Lancefield %in% c(TRUE, "all")
if (all(x %in% AMR::microorganisms$mo, na.rm = TRUE) && !has_Becker_or_Lancefield_or_synonyms) { if (all(x %in% AMR::microorganisms$mo, na.rm = TRUE) && !has_Becker_or_Lancefield && isTRUE(keep_synonyms)) {
# do nothing, just don't run the other if-else's # do nothing, just don't run the other if-else's
} else if (all(x %in% AMR::microorganisms[[property]], na.rm = TRUE) && !has_Becker_or_Lancefield_or_synonyms) { } else if (all(x %in% AMR::microorganisms[[property]], na.rm = TRUE) && !has_Becker_or_Lancefield && isTRUE(keep_synonyms)) {
# no need to do anything, just return it # no need to do anything, just return it
return(x) return(x)
} else { } else {
x <- as.mo(x, language = language, ...) x <- replace_old_mo_codes(x, property = property)
x <- as.mo(x, language = language, keep_synonyms = keep_synonyms, ...)
} }
# get property reeaaally fast using match() # get property reeaaally fast using match()
x <- microorganisms[[property]][match(x, microorganisms$mo)] x <- AMR::microorganisms[[property]][match(x, AMR::microorganisms$mo)]
if (property == "mo") { if (property == "mo") {
return(set_clean_class(x, new_class = c("mo", "character"))) return(set_clean_class(x, new_class = c("mo", "character")))

6
R/translate.R
View File

@ -120,7 +120,11 @@ set_AMR_locale <- function(language) {
options(AMR_locale = language) options(AMR_locale = language)
if (interactive() || identical(Sys.getenv("IN_PKGDOWN"), "true")) { if (interactive() || identical(Sys.getenv("IN_PKGDOWN"), "true")) {
# show which language to use now # show which language to use now
message_("Using the ", LANGUAGES_SUPPORTED_NAMES[[language]]$exonym, " language (", LANGUAGES_SUPPORTED_NAMES[[language]]$endonym, ") for the AMR package for this session.") message_("Using ", LANGUAGES_SUPPORTED_NAMES[[language]]$exonym,
ifelse(language != "en",
paste0(" (", LANGUAGES_SUPPORTED_NAMES[[language]]$endonym, ")"),
""),
" for the AMR package for this session.")
} }
} }

4
inst/tinytest/test-mo_property.R
View File

@ -107,8 +107,8 @@ expect_identical(
mo_lpsn("Escherichia coli") mo_lpsn("Escherichia coli")
) )
expect_identical(suppressWarnings(mo_ref("Chlamydia psittaci")), "Page, 1968") expect_identical(mo_ref("Chlamydia psittaci"), "Garcia-Lopez et al., 2019")
expect_identical(mo_ref("Chlamydophila psittaci"), "Everett et al., 1999") expect_identical(mo_ref("Chlamydophila psittaci", keep_synonyms = TRUE), "Everett et al., 1999")
expect_true(112283007 %in% mo_snomed("Escherichia coli")) expect_true(112283007 %in% mo_snomed("Escherichia coli"))
# old codes must throw a warning in mo_* family # old codes must throw a warning in mo_* family

10
man/as.mo.Rd
View File

@ -198,8 +198,8 @@ as.mo(c(
"MRSA", # Methicillin Resistant S. aureus "MRSA", # Methicillin Resistant S. aureus
"VISA", # Vancomycin Intermediate S. aureus "VISA", # Vancomycin Intermediate S. aureus
"VRSA", # Vancomycin Resistant S. aureus "VRSA", # Vancomycin Resistant S. aureus
115329001 115329001 # SNOMED CT code
)) # SNOMED CT code ))
# Dyslexia is no problem - these all work: # Dyslexia is no problem - these all work:
as.mo(c( as.mo(c(
@ -218,9 +218,9 @@ as.mo("S. pyogenes") # will remain species: B_STRPT_PYGN
as.mo("S. pyogenes", Lancefield = TRUE) # will not remain species: B_STRPT_GRPA as.mo("S. pyogenes", Lancefield = TRUE) # will not remain species: B_STRPT_GRPA
# All mo_* functions use as.mo() internally too (see ?mo_property): # All mo_* functions use as.mo() internally too (see ?mo_property):
mo_genus("Esch coli") mo_genus("E. coli")
mo_gramstain("E. coli") mo_gramstain("ESCO")
mo_is_intrinsic_resistant("E. coli", "vanco") mo_is_intrinsic_resistant("ESCCOL", ab = "vanco")
} }
} }
\seealso{ \seealso{

22
man/eucast_rules.Rd
View File

@ -82,27 +82,7 @@ Custom rules can be created using \code{\link[=custom_eucast_rules]{custom_eucas
\if{html}{\out{<div class="sourceCode r">}}\preformatted{x <- custom_eucast_rules(AMC == "R" & genus == "Klebsiella" ~ aminopenicillins == "R", \if{html}{\out{<div class="sourceCode r">}}\preformatted{x <- custom_eucast_rules(AMC == "R" & genus == "Klebsiella" ~ aminopenicillins == "R",
AMC == "I" & genus == "Klebsiella" ~ aminopenicillins == "I") AMC == "I" & genus == "Klebsiella" ~ aminopenicillins == "I")
eucast_rules(example_isolates, rules = "custom", custom_rules = x, info = FALSE) eucast_rules(example_isolates, rules = "custom", custom_rules = x)
#> # A tibble: 2,000 x 46
#> date patient age gender ward mo PEN OXA FLC AMX
#> * <date> <chr> <dbl> <chr> <chr> <mo> <rsi> <rsi> <rsi> <rsi>
#> 1 2002-01-02 A77334 65 F Clinical B_ESCHR_COLI R NA NA NA
#> 2 2002-01-03 A77334 65 F Clinical B_ESCHR_COLI R NA NA NA
#> 3 2002-01-07 067927 45 F ICU B_STPHY_EPDR R NA R NA
#> 4 2002-01-07 067927 45 F ICU B_STPHY_EPDR R NA R NA
#> 5 2002-01-13 067927 45 F ICU B_STPHY_EPDR R NA R NA
#> 6 2002-01-13 067927 45 F ICU B_STPHY_EPDR R NA R NA
#> 7 2002-01-14 462729 78 M Clinical B_STPHY_AURS R NA S R
#> 8 2002-01-14 462729 78 M Clinical B_STPHY_AURS R NA S R
#> 9 2002-01-16 067927 45 F ICU B_STPHY_EPDR R NA R NA
#> 10 2002-01-17 858515 79 F ICU B_STPHY_EPDR R NA S NA
#> # ... with 1,990 more rows, and 36 more variables: AMC <rsi>, AMP <rsi>,
#> # TZP <rsi>, CZO <rsi>, FEP <rsi>, CXM <rsi>, FOX <rsi>, CTX <rsi>,
#> # CAZ <rsi>, CRO <rsi>, GEN <rsi>, TOB <rsi>, AMK <rsi>, KAN <rsi>,
#> # TMP <rsi>, SXT <rsi>, NIT <rsi>, FOS <rsi>, LNZ <rsi>, CIP <rsi>,
#> # MFX <rsi>, VAN <rsi>, TEC <rsi>, TCY <rsi>, TGC <rsi>, DOX <rsi>,
#> # ERY <rsi>, CLI <rsi>, AZM <rsi>, IPM <rsi>, MEM <rsi>, MTR <rsi>,
#> # CHL <rsi>, COL <rsi>, MUP <rsi>, RIF <rsi>
}\if{html}{\out{</div>}} }\if{html}{\out{</div>}}
} }

4
tests/tinytest.R
View File

@ -25,6 +25,9 @@
# we use {tinytest} instead of {testthat} because it does not rely on recent R versions - we want to test on R >= 3.0. # we use {tinytest} instead of {testthat} because it does not rely on recent R versions - we want to test on R >= 3.0.
# Run them in RStudio using:
# rstudioapi::jobRunScript("tests/tinytest.R", name = "Tinytest Unit Tests", workingDir = getwd(), exportEnv = "tinytest_results")
# test only on GitHub Actions and at home - not on CRAN as tests are lengthy # test only on GitHub Actions and at home - not on CRAN as tests are lengthy
if (identical(Sys.getenv("R_RUN_TINYTEST"), "true")) { if (identical(Sys.getenv("R_RUN_TINYTEST"), "true")) {
# env var 'R_LIBS_USER' got overwritten during 'R CMD check' in GitHub Actions, so: # env var 'R_LIBS_USER' got overwritten during 'R CMD check' in GitHub Actions, so:
@ -51,3 +54,4 @@ if (identical(Sys.getenv("R_RUN_TINYTEST"), "true")) {
print(summary(out)) print(summary(out))
} }
} }