1
0
mirror of https://github.com/msberends/AMR.git synced 2024-12-25 18:06:12 +01:00

move object assignment to AMR_env

This commit is contained in:
dr. M.S. (Matthijs) Berends 2022-10-14 13:02:50 +02:00
parent dfae4c7e7d
commit 76bcd3528c
18 changed files with 116 additions and 127 deletions

View File

@ -1,6 +1,6 @@
Package: AMR
Version: 1.8.2.9014
Date: 2022-10-11
Version: 1.8.2.9016
Date: 2022-10-14
Title: Antimicrobial Resistance Data Analysis
Description: Functions to simplify and standardise antimicrobial resistance (AMR)
data analysis and to work with microbial and antimicrobial properties by

View File

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

View File

@ -626,7 +626,7 @@ create_eucast_ab_documentation <- function() {
if (paste0("AB_", val) %in% ls(envir = asNamespace("AMR"))) {
# antibiotic group names, as defined in data-raw/_pre_commit_hook.R, such as `CARBAPENEMS`
val <- eval(parse(text = paste0("AB_", val)), envir = asNamespace("AMR"))
} else if (val %in% AB_lookup$ab) {
} else if (val %in% AMR_env$AB_lookup$ab) {
# separate drugs, such as `AMX`
val <- as.ab(val)
} else {

50
R/ab.R
View File

@ -100,7 +100,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
if (is.ab(x)) {
return(x)
}
if (all(x %in% c(AB_lookup$ab, NA))) {
if (all(x %in% c(AMR_env$AB_lookup$ab, NA))) {
# all valid AB codes, but not yet right class
return(set_clean_class(x,
new_class = c("ab", "character")
@ -147,25 +147,25 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
}
# Fill in names, AB codes, CID codes and ATC codes directly (`x` is already clean and uppercase)
known_names <- x %in% AB_lookup$generalised_name
x_new[known_names] <- AB_lookup$ab[match(x[known_names], AB_lookup$generalised_name)]
known_codes_ab <- x %in% AB_lookup$ab
known_codes_atc <- vapply(FUN.VALUE = logical(1), x, function(x_) x_ %in% unlist(AB_lookup$atc), USE.NAMES = FALSE)
known_codes_cid <- x %in% AB_lookup$cid
x_new[known_codes_ab] <- AB_lookup$ab[match(x[known_codes_ab], AB_lookup$ab)]
x_new[known_codes_atc] <- AB_lookup$ab[vapply(
known_names <- x %in% AMR_env$AB_lookup$generalised_name
x_new[known_names] <- AMR_env$AB_lookup$ab[match(x[known_names], AMR_env$AB_lookup$generalised_name)]
known_codes_ab <- x %in% AMR_env$AB_lookup$ab
known_codes_atc <- vapply(FUN.VALUE = logical(1), x, function(x_) x_ %in% unlist(AMR_env$AB_lookup$atc), USE.NAMES = FALSE)
known_codes_cid <- x %in% AMR_env$AB_lookup$cid
x_new[known_codes_ab] <- AMR_env$AB_lookup$ab[match(x[known_codes_ab], AMR_env$AB_lookup$ab)]
x_new[known_codes_atc] <- AMR_env$AB_lookup$ab[vapply(
FUN.VALUE = integer(1),
x[known_codes_atc],
function(x_) {
which(vapply(
FUN.VALUE = logical(1),
AB_lookup$atc,
AMR_env$AB_lookup$atc,
function(atc) x_ %in% atc
))[1L]
},
USE.NAMES = FALSE
)]
x_new[known_codes_cid] <- AB_lookup$ab[match(x[known_codes_cid], AB_lookup$cid)]
x_new[known_codes_cid] <- AMR_env$AB_lookup$ab[match(x[known_codes_cid], AMR_env$AB_lookup$cid)]
previously_coerced <- x %in% AMR_env$ab_previously_coerced$x
x_new[previously_coerced & is.na(x_new)] <- AMR_env$ab_previously_coerced$ab[match(x[is.na(x_new) & x %in% AMR_env$ab_previously_coerced$x], AMR_env$ab_previously_coerced$x)]
already_known <- known_names | known_codes_ab | known_codes_atc | known_codes_cid | previously_coerced
@ -217,10 +217,10 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
# exact LOINC code
loinc_found <- unlist(lapply(
AB_lookup$generalised_loinc,
AMR_env$AB_lookup$generalised_loinc,
function(s) x[i] %in% s
))
found <- AB_lookup$ab[loinc_found == TRUE]
found <- AMR_env$AB_lookup$ab[loinc_found == TRUE]
if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
@ -228,10 +228,10 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
# exact synonym
synonym_found <- unlist(lapply(
AB_lookup$generalised_synonyms,
AMR_env$AB_lookup$generalised_synonyms,
function(s) x[i] %in% s
))
found <- AB_lookup$ab[synonym_found == TRUE]
found <- AMR_env$AB_lookup$ab[synonym_found == TRUE]
if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
@ -239,11 +239,11 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
# exact abbreviation
abbr_found <- unlist(lapply(
AB_lookup$generalised_abbreviations,
AMR_env$AB_lookup$generalised_abbreviations,
# require at least 2 characters for abbreviations
function(s) x[i] %in% s && nchar(x[i]) >= 2
))
found <- AB_lookup$ab[abbr_found == TRUE]
found <- AMR_env$AB_lookup$ab[abbr_found == TRUE]
if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
@ -251,9 +251,9 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
# length of input is quite long, and Levenshtein distance is only max 2
if (nchar(x[i]) >= 10) {
levenshtein <- as.double(utils::adist(x[i], AB_lookup$generalised_name))
levenshtein <- as.double(utils::adist(x[i], AMR_env$AB_lookup$generalised_name))
if (any(levenshtein <= 2)) {
found <- AB_lookup$ab[which(levenshtein <= 2)]
found <- AMR_env$AB_lookup$ab[which(levenshtein <= 2)]
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
}
@ -290,13 +290,13 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
}
# try if name starts with it
found <- AB_lookup[which(AB_lookup$generalised_name %like% paste0("^", x_spelling)), "ab", drop = TRUE]
found <- AMR_env$AB_lookup[which(AMR_env$AB_lookup$generalised_name %like% paste0("^", x_spelling)), "ab", drop = TRUE]
if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
}
# try if name ends with it
found <- AB_lookup[which(AB_lookup$generalised_name %like% paste0(x_spelling, "$")), "ab", drop = TRUE]
found <- AMR_env$AB_lookup[which(AMR_env$AB_lookup$generalised_name %like% paste0(x_spelling, "$")), "ab", drop = TRUE]
if (nchar(x[i]) >= 4 && length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
@ -304,10 +304,10 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
# and try if any synonym starts with it
synonym_found <- unlist(lapply(
AB_lookup$generalised_synonyms,
AMR_env$AB_lookup$generalised_synonyms,
function(s) any(s %like% paste0("^", x_spelling))
))
found <- AB_lookup$ab[synonym_found == TRUE]
found <- AMR_env$AB_lookup$ab[synonym_found == TRUE]
if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
@ -585,7 +585,7 @@ as.data.frame.ab <- function(x, ...) {
"[<-.ab" <- function(i, j, ..., value) {
y <- NextMethod()
attributes(y) <- attributes(i)
return_after_integrity_check(y, "antimicrobial code", AB_lookup$ab)
return_after_integrity_check(y, "antimicrobial code", AMR_env$AB_lookup$ab)
}
#' @method [[<- ab
#' @export
@ -593,7 +593,7 @@ as.data.frame.ab <- function(x, ...) {
"[[<-.ab" <- function(i, j, ..., value) {
y <- NextMethod()
attributes(y) <- attributes(i)
return_after_integrity_check(y, "antimicrobial code", AB_lookup$ab)
return_after_integrity_check(y, "antimicrobial code", AMR_env$AB_lookup$ab)
}
#' @method c ab
#' @export
@ -602,7 +602,7 @@ c.ab <- function(...) {
x <- list(...)[[1L]]
y <- NextMethod()
attributes(y) <- attributes(x)
return_after_integrity_check(y, "antimicrobial code", AB_lookup$ab)
return_after_integrity_check(y, "antimicrobial code", AMR_env$AB_lookup$ab)
}
#' @method unique ab

View File

@ -452,22 +452,22 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale
}
ab_validate <- function(x, property, ...) {
if (tryCatch(all(x[!is.na(x)] %in% AB_lookup$ab), error = function(e) FALSE)) {
if (tryCatch(all(x[!is.na(x)] %in% AMR_env$AB_lookup$ab), error = function(e) FALSE)) {
# special case for ab_* functions where class is already <ab>
x <- AB_lookup[match(x, AB_lookup$ab), property, drop = TRUE]
x <- AMR_env$AB_lookup[match(x, AMR_env$AB_lookup$ab), property, drop = TRUE]
} else {
# try to catch an error when inputting an invalid argument
# so the 'call.' can be set to FALSE
tryCatch(x[1L] %in% AB_lookup[1, property, drop = TRUE],
tryCatch(x[1L] %in% AMR_env$AB_lookup[1, property, drop = TRUE],
error = function(e) stop(e$message, call. = FALSE)
)
if (!all(x %in% AB_lookup[, property, drop = TRUE])) {
if (!all(x %in% AMR_env$AB_lookup[, property, drop = TRUE])) {
x <- as.ab(x, ...)
if (all(is.na(x)) && is.list(AB_lookup[, property, drop = TRUE])) {
if (all(is.na(x)) && is.list(AMR_env$AB_lookup[, property, drop = TRUE])) {
x <- rep(NA_character_, length(x))
} else {
x <- AB_lookup[match(x, AB_lookup$ab), property, drop = TRUE]
x <- AMR_env$AB_lookup[match(x, AMR_env$AB_lookup$ab), property, drop = TRUE]
}
}
}

View File

@ -216,7 +216,7 @@ ab_selector <- function(filter,
sort = FALSE, fn = "ab_selector"
)
call <- substitute(filter)
agents <- tryCatch(AB_lookup[which(eval(call, envir = AB_lookup)), "ab", drop = TRUE],
agents <- tryCatch(AMR_env$AB_lookup[which(eval(call, envir = AMR_env$AB_lookup)), "ab", drop = TRUE],
error = function(e) stop_(e$message, call = -5)
)
agents <- ab_in_data[ab_in_data %in% agents]
@ -424,8 +424,8 @@ administrable_per_os <- function(only_rsi_columns = FALSE, ...) {
info = FALSE, only_rsi_columns = only_rsi_columns,
sort = FALSE, fn = "administrable_per_os"
)
agents_all <- AB_lookup[which(!is.na(AB_lookup$oral_ddd)), "ab", drop = TRUE]
agents <- AB_lookup[which(AB_lookup$ab %in% ab_in_data & !is.na(AB_lookup$oral_ddd)), "ab", drop = TRUE]
agents_all <- AMR_env$AB_lookup[which(!is.na(AMR_env$AB_lookup$oral_ddd)), "ab", drop = TRUE]
agents <- AMR_env$AB_lookup[which(AMR_env$AB_lookup$ab %in% ab_in_data & !is.na(AMR_env$AB_lookup$oral_ddd)), "ab", drop = TRUE]
agents <- ab_in_data[ab_in_data %in% agents]
message_agent_names(
function_name = "administrable_per_os",
@ -462,8 +462,8 @@ administrable_iv <- function(only_rsi_columns = FALSE, ...) {
info = FALSE, only_rsi_columns = only_rsi_columns,
sort = FALSE, fn = "administrable_iv"
)
agents_all <- AB_lookup[which(!is.na(AB_lookup$iv_ddd)), "ab", drop = TRUE]
agents <- AB_lookup[which(AB_lookup$ab %in% ab_in_data & !is.na(AB_lookup$iv_ddd)), "ab", drop = TRUE]
agents_all <- AMR_env$AB_lookup[which(!is.na(AMR_env$AB_lookup$iv_ddd)), "ab", drop = TRUE]
agents <- AMR_env$AB_lookup[which(AMR_env$AB_lookup$ab %in% ab_in_data & !is.na(AMR_env$AB_lookup$iv_ddd)), "ab", drop = TRUE]
agents <- ab_in_data[ab_in_data %in% agents]
message_agent_names(
function_name = "administrable_iv",
@ -544,7 +544,7 @@ ab_select_exec <- function(function_name,
# untreatable drugs
if (only_treatable == TRUE) {
untreatable <- AB_lookup[which(AB_lookup$name %like% "-high|EDTA|polysorbate|macromethod|screening|/nacubactam"), "ab", drop = TRUE]
untreatable <- AMR_env$AB_lookup[which(AMR_env$AB_lookup$name %like% "-high|EDTA|polysorbate|macromethod|screening|/nacubactam"), "ab", drop = TRUE]
if (any(untreatable %in% names(ab_in_data))) {
if (message_not_thrown_before(function_name, "ab_class", "untreatable", entire_session = TRUE)) {
warning_(
@ -571,16 +571,16 @@ ab_select_exec <- function(function_name,
if (is.null(ab_class_args) || isTRUE(function_name %in% c("antifungals", "antimycobacterials"))) {
ab_group <- NULL
if (isTRUE(function_name == "antifungals")) {
abx <- AB_lookup$ab[which(AB_lookup$group == "Antifungals")]
abx <- AMR_env$AB_lookup$ab[which(AMR_env$AB_lookup$group == "Antifungals")]
} else if (isTRUE(function_name == "antimycobacterials")) {
abx <- AB_lookup$ab[which(AB_lookup$group == "Antimycobacterials")]
abx <- AMR_env$AB_lookup$ab[which(AMR_env$AB_lookup$group == "Antimycobacterials")]
} else {
# their upper case equivalent are vectors with class <ab>, created in data-raw/_pre_commit_hook.R
# carbapenems() gets its codes from AMR:::AB_CARBAPENEMS
abx <- get(paste0("AB_", toupper(function_name)), envir = asNamespace("AMR"))
# manually added codes from add_custom_antimicrobials() must also be supported
if (length(AMR_env$custom_ab_codes) > 0) {
custom_ab <- AB_lookup[which(AB_lookup$ab %in% AMR_env$custom_ab_codes), ]
custom_ab <- AMR_env$AB_lookup[which(AMR_env$AB_lookup$ab %in% AMR_env$custom_ab_codes), ]
check_string <- paste0(custom_ab$group, custom_ab$atc_group1, custom_ab$atc_group2)
if (function_name == "betalactams") {
find_group <- "beta-lactams"
@ -602,7 +602,7 @@ ab_select_exec <- function(function_name,
} else {
# this for the 'manual' ab_class() function
abx <- subset(
AB_lookup,
AMR_env$AB_lookup,
group %like% ab_class_args |
atc_group1 %like% ab_class_args |
atc_group2 %like% ab_class_args
@ -792,7 +792,7 @@ is_all <- function(el1) {
find_ab_group <- function(ab_class_args) {
ab_class_args <- gsub("[^a-zA-Z0-9]", ".*", ab_class_args)
AB_lookup %pm>%
AMR_env$AB_lookup %pm>%
subset(group %like% ab_class_args |
atc_group1 %like% ab_class_args |
atc_group2 %like% ab_class_args) %pm>%
@ -807,16 +807,16 @@ find_ab_names <- function(ab_group, n = 3) {
ab_group <- gsub("[^a-zA-Z|0-9]", ".*", ab_group)
# try popular first, they have DDDs
drugs <- AB_lookup[which((!is.na(AB_lookup$iv_ddd) | !is.na(AB_lookup$oral_ddd)) &
AB_lookup$name %unlike% " " &
AB_lookup$group %like% ab_group &
AB_lookup$ab %unlike% "[0-9]$"), ]$name
drugs <- AMR_env$AB_lookup[which((!is.na(AMR_env$AB_lookup$iv_ddd) | !is.na(AMR_env$AB_lookup$oral_ddd)) &
AMR_env$AB_lookup$name %unlike% " " &
AMR_env$AB_lookup$group %like% ab_group &
AMR_env$AB_lookup$ab %unlike% "[0-9]$"), ]$name
if (length(drugs) < n) {
# now try it all
drugs <- AB_lookup[which((AB_lookup$group %like% ab_group |
AB_lookup$atc_group1 %like% ab_group |
AB_lookup$atc_group2 %like% ab_group) &
AB_lookup$ab %unlike% "[0-9]$"), ]$name
drugs <- AMR_env$AB_lookup[which((AMR_env$AB_lookup$group %like% ab_group |
AMR_env$AB_lookup$atc_group1 %like% ab_group |
AMR_env$AB_lookup$atc_group2 %like% ab_group) &
AMR_env$AB_lookup$ab %unlike% "[0-9]$"), ]$name
}
if (length(drugs) == 0) {
return("??")

View File

@ -86,18 +86,18 @@
#'
#' # even antibiotic selectors work
#' x <- data.frame(random_column = "test",
#' coflu = as.rsi("S"),
#' ampicillin = as.rsi("R"))
#' coflu = as.rsi("S"),
#' ampicillin = as.rsi("R"))
#' x
#' x[, betalactams()]
add_custom_antimicrobials <- function(x) {
meet_criteria(x, allow_class = "data.frame")
stop_ifnot(all(c("ab", "name") %in% colnames(x)),
"`x` must contain columns \"ab\" and \"name\".")
stop_if(any(x$ab %in% AB_lookup$ab),
"Antimicrobial code(s) ", vector_and(x$ab[x$ab %in% AB_lookup$ab]), " already exist in the internal `antibiotics` data set.")
stop_if(any(x$ab %in% AMR_env$AB_lookup$ab),
"Antimicrobial code(s) ", vector_and(x$ab[x$ab %in% AMR_env$AB_lookup$ab]), " already exist in the internal `antibiotics` data set.")
x <- x[, colnames(AB_lookup)[colnames(AB_lookup) %in% colnames(x)], drop = FALSE]
x <- x[, colnames(AMR_env$AB_lookup)[colnames(AMR_env$AB_lookup) %in% colnames(x)], drop = FALSE]
x$generalised_name <- generalise_antibiotic_name(x$name)
x$generalised_all <- as.list(x$generalised_name)
if ("atc" %in% colnames(x)) {
@ -108,27 +108,16 @@ add_custom_antimicrobials <- function(x) {
}
AMR_env$custom_ab_codes <- c(AMR_env$custom_ab_codes, x$ab)
bind_rows <- import_fn("bind_rows", "dplyr", error_on_fail = FALSE)
if (!is.null(bind_rows)) {
new_df <- bind_rows(AB_lookup, x)
} else {
new_df <- tryCatch(rbind(AB_lookup, x, stringsAsFactors = FALSE),
error = function(x) stop("Error while adding antimicrobials. Try installing the 'dplyr' package for extended support.", call. = FALSE))
}
new_df <- unique(new_df)
bind_rows <- import_fn("bind_rows", "dplyr", error_on_fail = TRUE)
AMR_env$AB_lookup <- unique(bind_rows(AMR_env$AB_lookup, x))
assignInNamespace(x = "AB_lookup",
value = new_df,
ns = asNamespace("AMR"))
message_("Added ", nr2char(nrow(x)), " record", ifelse(nrow(x) > 1, "s", ""), " to the internal `antibiotics` data set.")
}
#' @rdname add_custom_antimicrobials
#' @export
clear_custom_antimicrobials <- function() {
assignInNamespace(x = "AB_lookup",
value = create_AB_lookup(),
ns = asNamespace("AMR"))
AMR_env$AB_lookup <- create_AB_lookup()
AMR_env$custom_ab_codes <- character(0)
message_("Custom antimicrobials cleared.")
}

View File

@ -435,11 +435,11 @@ eucast_rules <- function(x,
}
if (any(x$genus == "Staphylococcus", na.rm = TRUE)) {
all_staph <- MO_lookup[which(MO_lookup$genus == "Staphylococcus"), , drop = FALSE]
all_staph <- AMR_env$MO_lookup[which(AMR_env$MO_lookup$genus == "Staphylococcus"), , drop = FALSE]
all_staph$CNS_CPS <- suppressWarnings(mo_name(all_staph$mo, Becker = "all", language = NULL, info = FALSE))
}
if (any(x$genus == "Streptococcus", na.rm = TRUE)) {
all_strep <- MO_lookup[which(MO_lookup$genus == "Streptococcus"), , drop = FALSE]
all_strep <- AMR_env$MO_lookup[which(AMR_env$MO_lookup$genus == "Streptococcus"), , drop = FALSE]
all_strep$Lancefield <- suppressWarnings(mo_name(all_strep$mo, Lancefield = TRUE, language = NULL, info = FALSE))
}

View File

@ -173,7 +173,7 @@ get_column_abx <- function(x,
# only check columns that are a valid AB code, ATC code, name, abbreviation or synonym,
# or already have the <rsi> class (as.rsi)
# and that they have no more than 50% invalid values
vectr_antibiotics <- unlist(AB_lookup$generalised_all)
vectr_antibiotics <- unlist(AMR_env$AB_lookup$generalised_all)
vectr_antibiotics <- vectr_antibiotics[!is.na(vectr_antibiotics) & nchar(vectr_antibiotics) >= 3]
x_columns <- vapply(
FUN.VALUE = character(1),
@ -335,7 +335,7 @@ get_ab_from_namespace <- function(x, cols_ab) {
if (paste0("AB_", val) %in% ls(envir = asNamespace("AMR"))) {
# antibiotic group names, as defined in data-raw/_pre_commit_hook.R, such as `AB_CARBAPENEMS`
val <- eval(parse(text = paste0("AB_", val)), envir = asNamespace("AMR"))
} else if (val %in% AB_lookup$ab) {
} else if (val %in% AMR_env$AB_lookup$ab) {
# separate drugs, such as `AMX`
val <- as.ab(val)
} else {

View File

@ -71,7 +71,7 @@ italicise_taxonomy <- function(string, type = c("markdown", "ansi")) {
search_strings <- gsub("[^a-zA-Z-]", "", s_split)
ind_species <- search_strings != "" &
search_strings %in% MO_lookup[which(MO_lookup$rank %in% c(
search_strings %in% AMR_env$MO_lookup[which(AMR_env$MO_lookup$rank %in% c(
"family",
"genus",
"species",
@ -85,7 +85,7 @@ italicise_taxonomy <- function(string, type = c("markdown", "ansi")) {
ind_fullname <- search_strings != "" &
search_strings %in% c(
MO_lookup[which(MO_lookup$rank %in% c(
AMR_env$MO_lookup[which(AMR_env$MO_lookup$rank %in% c(
"family",
"genus",
"species",
@ -96,7 +96,7 @@ italicise_taxonomy <- function(string, type = c("markdown", "ansi")) {
"fullname",
drop = TRUE
],
MO_lookup[which(MO_lookup$rank %in% c(
AMR_env$MO_lookup[which(AMR_env$MO_lookup$rank %in% c(
"family",
"genus",
"species",

View File

@ -145,7 +145,7 @@ join_microorganisms <- function(type, x, by, suffix, ...) {
}
message_('Joining, by = "', by, '"', add_fn = font_black, as_note = FALSE) # message same as dplyr::join functions
}
if (!all(x[, by, drop = TRUE] %in% MO_lookup$mo, na.rm = TRUE)) {
if (!all(x[, by, drop = TRUE] %in% AMR_env$MO_lookup$mo, na.rm = TRUE)) {
x$join.mo <- as.mo(x[, by, drop = TRUE])
by <- c("join.mo" = "mo")
} else {

View File

@ -326,7 +326,7 @@ mdro <- function(x = NULL,
"No column found as input for `col_mo`, ",
font_bold(paste0("assuming all rows contain ", font_italic("Mycobacterium tuberculosis"), "."))
)
x$mo <- as.mo("Mycobacterium tuberculosis") # consider overkill at all times: MO_lookup[which(MO_lookup$fullname == "Mycobacterium tuberculosis"), "mo", drop = TRUE]
x$mo <- as.mo("Mycobacterium tuberculosis") # consider overkill at all times: AMR_env$MO_lookup[which(AMR_env$MO_lookup$fullname == "Mycobacterium tuberculosis"), "mo", drop = TRUE]
col_mo <- "mo"
}
stop_if(is.null(col_mo), "`col_mo` must be set")

32
R/mo.R
View File

@ -163,7 +163,7 @@ as.mo <- function(x,
language <- validate_language(language)
meet_criteria(info, allow_class = "logical", has_length = 1)
if (tryCatch(all(x %in% c(MO_lookup$mo, NA)) &&
if (tryCatch(all(x %in% c(AMR_env$MO_lookup$mo, NA)) &&
isFALSE(Becker) &&
isFALSE(Lancefield), error = function(e) FALSE)) {
# don't look into valid MO codes, just return them
@ -194,9 +194,9 @@ as.mo <- function(x,
out[x %in% reference_df[[1]]] <- reference_df[[2]][match(x[x %in% reference_df[[1]]], reference_df[[1]])]
}
# From MO code ----
out[is.na(out) & x %in% MO_lookup$mo] <- x[is.na(out) & x %in% MO_lookup$mo]
out[is.na(out) & x %in% AMR_env$MO_lookup$mo] <- x[is.na(out) & x %in% AMR_env$MO_lookup$mo]
# From full name ----
out[is.na(out) & x_lower %in% MO_lookup$fullname_lower] <- MO_lookup$mo[match(x_lower[is.na(out) & x_lower %in% MO_lookup$fullname_lower], MO_lookup$fullname_lower)]
out[is.na(out) & x_lower %in% AMR_env$MO_lookup$fullname_lower] <- AMR_env$MO_lookup$mo[match(x_lower[is.na(out) & x_lower %in% AMR_env$MO_lookup$fullname_lower], AMR_env$MO_lookup$fullname_lower)]
# one exception: "Fungi" matches the kingdom, but instead it should return the 'unknown' code for fungi
out[out == "F_[KNG]_FUNGI"] <- "F_FUNGUS"
# From known codes ----
@ -204,7 +204,7 @@ as.mo <- function(x,
# From SNOMED ----
if (any(is.na(out) & !is.na(x)) && any(is.na(out) & x %in% unlist(microorganisms$snomed), na.rm = TRUE)) {
# found this extremely fast gem here: https://stackoverflow.com/a/11002456/4575331
out[is.na(out) & x %in% unlist(microorganisms$snomed)] <- microorganisms$mo[rep(seq_along(microorganisms$snomed), vapply(FUN.VALUE = double(1), microorganisms$snomed, length))[match(x[is.na(out) & x %in% unlist(microorganisms$snomed)], unlist(microorganisms$snomed))]]
out[is.na(out) & x %in% unlist(AMR::microorganisms$snomed)] <- AMR::microorganisms$mo[rep(seq_along(AMR::microorganisms$snomed), vapply(FUN.VALUE = double(1), AMR::microorganisms$snomed, length))[match(x[is.na(out) & x %in% unlist(AMR::microorganisms$snomed)], unlist(AMR::microorganisms$snomed))]]
}
# From other familiar output ----
# such as Salmonella groups, colloquial names, etc.
@ -261,16 +261,16 @@ as.mo <- function(x,
# do a pre-match on first character (and if it contains a space, first chars of first two terms)
if (length(x_parts) %in% c(2, 3)) {
# for genus + species + subspecies
filtr <- which(MO_lookup$full_first == substr(x_parts[1], 1, 1) & MO_lookup$species_first == substr(x_parts[2], 1, 1))
filtr <- which(AMR_env$MO_lookup$full_first == substr(x_parts[1], 1, 1) & AMR_env$MO_lookup$species_first == substr(x_parts[2], 1, 1))
} else if (length(x_parts) > 3) {
first_chars <- paste0("(^| )", "[", paste(substr(x_parts, 1, 1), collapse = ""), "]")
filtr <- which(MO_lookup$full_first %like_case% first_chars)
filtr <- which(AMR_env$MO_lookup$full_first %like_case% first_chars)
} else if (nchar(x_out) == 4) {
# no space and 4 characters - probably a code such as STAU or ESCO!
if (isTRUE(info)) {
message_("Input \"", x_search, "\" is assumed to be a microorganism code - trying to match on ", vector_and(c(substr(x_out, 1, 2), substr(x_out, 3, 4)), sort = FALSE))
}
filtr <- which(MO_lookup$fullname_lower %like_case% paste0("(^| )", substr(x_out, 1, 2), ".* ", substr(x_out, 3, 4)))
filtr <- which(AMR_env$MO_lookup$fullname_lower %like_case% paste0("(^| )", substr(x_out, 1, 2), ".* ", substr(x_out, 3, 4)))
} else if (nchar(x_out) <= 6) {
# no space and 5-6 characters - probably a code such as STAAUR or ESCCOL!
first_part <- paste0(substr(x_out, 1, 2), "[a-z]*", substr(x_out, 3, 3))
@ -278,14 +278,14 @@ as.mo <- function(x,
if (isTRUE(info)) {
message_("Input \"", x_search, "\" is assumed to be a microorganism code - trying to match on ", vector_and(c(gsub("[a-z]*", "(...)", first_part, fixed = TRUE), second_part), sort = FALSE))
}
filtr <- which(MO_lookup$fullname_lower %like_case% paste0("(^| )", first_part, ".* ", second_part))
filtr <- which(AMR_env$MO_lookup$fullname_lower %like_case% paste0("(^| )", first_part, ".* ", second_part))
} else {
filtr <- which(MO_lookup$full_first == substr(x_out, 1, 1))
filtr <- which(AMR_env$MO_lookup$full_first == substr(x_out, 1, 1))
}
if (length(filtr) == 0) {
mo_to_search <- MO_lookup$fullname
mo_to_search <- AMR_env$MO_lookup$fullname
} else {
mo_to_search <- MO_lookup$fullname[filtr]
mo_to_search <- AMR_env$MO_lookup$fullname[filtr]
}
AMR_env$mo_to_search <- mo_to_search
# determine the matching score on the original search value
@ -293,9 +293,9 @@ as.mo <- function(x,
if (is.null(minimum_matching_score)) {
minimum_matching_score_current <- min(0.6, min(10, nchar(x_search_cleaned)) * 0.08)
# correct back for prevalence
minimum_matching_score_current <- minimum_matching_score_current / MO_lookup$prevalence[match(mo_to_search, MO_lookup$fullname)]
minimum_matching_score_current <- minimum_matching_score_current / AMR_env$MO_lookup$prevalence[match(mo_to_search, AMR_env$MO_lookup$fullname)]
# correct back for kingdom
minimum_matching_score_current <- minimum_matching_score_current / MO_lookup$kingdom_index[match(mo_to_search, MO_lookup$fullname)]
minimum_matching_score_current <- minimum_matching_score_current / AMR_env$MO_lookup$kingdom_index[match(mo_to_search, AMR_env$MO_lookup$fullname)]
} else {
minimum_matching_score_current <- minimum_matching_score
}
@ -306,7 +306,7 @@ as.mo <- function(x,
warning_("No hits found for \"", x_search, "\" with minimum_matching_score = ", ifelse(is.null(minimum_matching_score), paste0("NULL (=", round(min(minimum_matching_score_current, na.rm = TRUE), 3), ")"), minimum_matching_score), ". Try setting this value lower or even to 0.")
result_mo <- NA_character_
} else {
result_mo <- MO_lookup$mo[match(top_hits[1], MO_lookup$fullname)]
result_mo <- AMR_env$MO_lookup$mo[match(top_hits[1], AMR_env$MO_lookup$fullname)]
AMR_env$mo_uncertainties <- rbind(AMR_env$mo_uncertainties,
data.frame(
original_input = x_search,
@ -997,8 +997,8 @@ replace_old_mo_codes <- function(x, property) {
name <- tolower(paste0(name, ".*", collapse = ""))
name <- gsub(" .*", " ", name, fixed = TRUE)
name <- paste0("^", name)
results <- MO_lookup$mo[MO_lookup$kingdom %like_case% kingdom &
MO_lookup$fullname_lower %like_case% name]
results <- AMR_env$MO_lookup$mo[AMR_env$MO_lookup$kingdom %like_case% kingdom &
AMR_env$MO_lookup$fullname_lower %like_case% name]
if (length(results) > 1) {
all_direct_matches <<- FALSE
}

View File

@ -109,9 +109,9 @@ mo_matching_score <- function(x, n) {
l_n.lev[lev == l_n] <- lev[lev == l_n]
# human pathogenic prevalence (1 to 3), see ?as.mo
p_n <- MO_lookup[match(n, MO_lookup$fullname), "prevalence", drop = TRUE]
p_n <- AMR_env$MO_lookup[match(n, AMR_env$MO_lookup$fullname), "prevalence", drop = TRUE]
# kingdom index (Bacteria = 1, Fungi = 2, Protozoa = 3, Archaea = 4, others = 5)
k_n <- MO_lookup[match(n, MO_lookup$fullname), "kingdom_index", drop = TRUE]
k_n <- AMR_env$MO_lookup[match(n, AMR_env$MO_lookup$fullname), "kingdom_index", drop = TRUE]
# matching score:
(l_n - 0.5 * l_n.lev) / (l_n * p_n * k_n)

View File

@ -147,8 +147,8 @@ if (utf8_supported && !is_latex) {
# reference data - they have additional columns compared to `antibiotics` and `microorganisms` to improve speed
# they cannot be part of R/sysdata.rda since CRAN thinks it would make the package too large (+3 MB)
assign(x = "AB_lookup", value = create_AB_lookup(), envir = asNamespace("AMR"))
assign(x = "MO_lookup", value = create_MO_lookup(), envir = asNamespace("AMR"))
AMR_env$AB_lookup <- create_AB_lookup()
AMR_env$MO_lookup <- create_MO_lookup()
# for mo_is_intrinsic_resistant() - saves a lot of time when executed on this vector
assign(x = "INTRINSIC_R", value = create_intr_resistance(), envir = asNamespace("AMR"))
}

View File

@ -145,22 +145,22 @@ create_species_cons_cops <- function(type = c("CoNS", "CoPS")) {
}
}
create_MO_fullname_lower <- function() {
MO_lookup <- AMR::microorganisms
AMR_env$MO_lookup <- AMR::microorganisms
# use this paste instead of `fullname` to work with Viridans Group Streptococci, etc.
MO_lookup$fullname_lower <- tolower(trimws(paste(
MO_lookup$genus,
MO_lookup$species,
MO_lookup$subspecies
AMR_env$MO_lookup$fullname_lower <- tolower(trimws(paste(
AMR_env$MO_lookup$genus,
AMR_env$MO_lookup$species,
AMR_env$MO_lookup$subspecies
)))
ind <- MO_lookup$genus == "" | grepl("^[(]unknown ", MO_lookup$fullname, perl = TRUE)
MO_lookup[ind, "fullname_lower"] <- tolower(MO_lookup[ind, "fullname", drop = TRUE])
MO_lookup$fullname_lower <- trimws(gsub("[^.a-z0-9/ \\-]+", "", MO_lookup$fullname_lower, perl = TRUE))
MO_lookup$fullname_lower
ind <- AMR_env$MO_lookup$genus == "" | grepl("^[(]unknown ", AMR_env$MO_lookup$fullname, perl = TRUE)
AMR_env$MO_lookup[ind, "fullname_lower"] <- tolower(AMR_env$MO_lookup[ind, "fullname", drop = TRUE])
AMR_env$MO_lookup$fullname_lower <- trimws(gsub("[^.a-z0-9/ \\-]+", "", AMR_env$MO_lookup$fullname_lower, perl = TRUE))
AMR_env$MO_lookup$fullname_lower
}
MO_CONS <- create_species_cons_cops("CoNS")
MO_COPS <- create_species_cons_cops("CoPS")
MO_STREP_ABCG <- MO_lookup$mo[which(MO_lookup$genus == "Streptococcus" &
MO_lookup$species %in% c(
MO_STREP_ABCG <- AMR_env$MO_lookup$mo[which(AMR_env$MO_lookup$genus == "Streptococcus" &
AMR_env$MO_lookup$species %in% c(
"pyogenes", "agalactiae", "dysgalactiae", "equi", "anginosus", "sanguinis", "salivarius",
"group A", "group B", "group C", "group D", "group F", "group G", "group H", "group K", "group L"
))]
@ -198,10 +198,10 @@ AB_AMINOGLYCOSIDES <- antibiotics %>%
filter(group %like% "aminoglycoside") %>%
pull(ab)
AB_AMINOPENICILLINS <- as.ab(c("AMP", "AMX"))
AB_ANTIFUNGALS <- AB_lookup %>%
AB_ANTIFUNGALS <- AMR_env$AB_lookup %>%
filter(group %like% "antifungal") %>%
pull(ab)
AB_ANTIMYCOBACTERIALS <- AB_lookup %>%
AB_ANTIMYCOBACTERIALS <- AMR_env$AB_lookup %>%
filter(group %like% "antimycobacterial") %>%
pull(ab)
AB_CARBAPENEMS <- antibiotics %>%
@ -268,16 +268,16 @@ AB_BETALACTAMS <- c(AB_PENICILLINS, AB_CEPHALOSPORINS, AB_CARBAPENEMS)
DEFINED_AB_GROUPS <- ls(envir = globalenv())
DEFINED_AB_GROUPS <- DEFINED_AB_GROUPS[!DEFINED_AB_GROUPS %in% globalenv_before_ab]
create_AB_lookup <- function() {
AB_lookup <- AMR::antibiotics
AB_lookup$generalised_name <- generalise_antibiotic_name(AB_lookup$name)
AB_lookup$generalised_synonyms <- lapply(AB_lookup$synonyms, generalise_antibiotic_name)
AB_lookup$generalised_abbreviations <- lapply(AB_lookup$abbreviations, generalise_antibiotic_name)
AB_lookup$generalised_loinc <- lapply(AB_lookup$loinc, generalise_antibiotic_name)
AB_lookup$generalised_all <- unname(lapply(
as.list(as.data.frame(t(AB_lookup[,
AMR_env$AB_lookup <- AMR::antibiotics
AMR_env$AB_lookup$generalised_name <- generalise_antibiotic_name(AMR_env$AB_lookup$name)
AMR_env$AB_lookup$generalised_synonyms <- lapply(AMR_env$AB_lookup$synonyms, generalise_antibiotic_name)
AMR_env$AB_lookup$generalised_abbreviations <- lapply(AMR_env$AB_lookup$abbreviations, generalise_antibiotic_name)
AMR_env$AB_lookup$generalised_loinc <- lapply(AMR_env$AB_lookup$loinc, generalise_antibiotic_name)
AMR_env$AB_lookup$generalised_all <- unname(lapply(
as.list(as.data.frame(t(AMR_env$AB_lookup[,
c(
"ab", "atc", "cid", "name",
colnames(AB_lookup)[colnames(AB_lookup) %like% "generalised"]
colnames(AMR_env$AB_lookup)[colnames(AMR_env$AB_lookup) %like% "generalised"]
),
drop = FALSE
]),
@ -288,7 +288,7 @@ create_AB_lookup <- function() {
x[x != ""]
}
))
AB_lookup[, colnames(AB_lookup)[colnames(AB_lookup) %like% "^generalised"]]
AMR_env$AB_lookup[, colnames(AMR_env$AB_lookup)[colnames(AMR_env$AB_lookup) %like% "^generalised"]]
}
AB_LOOKUP <- create_AB_lookup()

View File

@ -64,7 +64,7 @@ if (AMR:::pkg_is_available("tibble", also_load = FALSE)) {
}
}
df <- AMR:::MO_lookup
df <- AMR:::AMR_env$MO_lookup
expect_true(nrow(df[which(df$prevalence == 1), , drop = FALSE]) < nrow(df[which(df$prevalence == 2), , drop = FALSE]))
expect_true(nrow(df[which(df$prevalence == 2), , drop = FALSE]) < nrow(df[which(df$prevalence == 3), , drop = FALSE]))
expect_true(all(c(

View File

@ -69,8 +69,8 @@ ab_name("J01CR50")
# even antibiotic selectors work
x <- data.frame(random_column = "test",
coflu = as.rsi("S"),
ampicillin = as.rsi("R"))
coflu = as.rsi("S"),
ampicillin = as.rsi("R"))
x
x[, betalactams()]
}