mirror of
https://github.com/msberends/AMR.git
synced 2024-12-24 19:26:12 +01:00
sort sir history
This commit is contained in:
parent
af139a3c82
commit
19fd0ef121
@ -1,6 +1,6 @@
|
||||
Package: AMR
|
||||
Version: 1.8.2.9096
|
||||
Date: 2023-01-21
|
||||
Version: 1.8.2.9098
|
||||
Date: 2023-01-23
|
||||
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
|
||||
|
2
NEWS.md
2
NEWS.md
@ -1,4 +1,4 @@
|
||||
# AMR 1.8.2.9096
|
||||
# AMR 1.8.2.9098
|
||||
|
||||
*(this beta version will eventually become v2.0! We're happy to reach a new major milestone soon!)*
|
||||
|
||||
|
@ -33,11 +33,11 @@
|
||||
#' Welcome to the `AMR` package.
|
||||
#'
|
||||
#' The `AMR` package is a [free and open-source](https://msberends.github.io/AMR/#copyright) R package with [zero dependencies](https://en.wikipedia.org/wiki/Dependency_hell) to simplify the analysis and prediction of Antimicrobial Resistance (AMR) and to work with microbial and antimicrobial data and properties, by using evidence-based methods. **Our aim is to provide a standard** for clean and reproducible AMR data analysis, that can therefore empower epidemiological analyses to continuously enable surveillance and treatment evaluation in any setting. [Many different researchers](https://msberends.github.io/AMR/authors.html) from around the globe are continually helping us to make this a successful and durable project!
|
||||
#'
|
||||
#'
|
||||
#' This work was published in the Journal of Statistical Software (Volume 104(3); [DOI 10.18637/jss.v104.i03](https://doi.org/10.18637/jss.v104.i03)) and formed the basis of two PhD theses ([DOI 10.33612/diss.177417131](https://doi.org/10.33612/diss.177417131) and [DOI 10.33612/diss.192486375](https://doi.org/10.33612/diss.192486375)).
|
||||
#'
|
||||
#'
|
||||
#' After installing this package, R knows [**`r format_included_data_number(AMR::microorganisms)`**](https://msberends.github.io/AMR/reference/microorganisms.html) (updated December 2022) and all [**~600 antibiotic, antimycotic and antiviral drugs**](https://msberends.github.io/AMR/reference/antibiotics.html) by name and code (including ATC, EARS-Net, ASIARS-Net, PubChem, LOINC and SNOMED CT), and knows all about valid SIR and MIC values. The integral breakpoint guidelines from CLSI and EUCAST are included from the last 10 years. It supports and can read any data format, including WHONET data. This package works on Windows, macOS and Linux with all versions of R since R-3.0 (April 2013). **It was designed to work in any setting, including those with very limited resources**. It was created for both routine data analysis and academic research at the Faculty of Medical Sciences of the [University of Groningen](https://www.rug.nl), in collaboration with non-profit organisations [Certe Medical Diagnostics and Advice Foundation](https://www.certe.nl) and [University Medical Center Groningen](https://www.umcg.nl).
|
||||
#'
|
||||
#'
|
||||
#' The `AMR` package is available in English, Chinese, Danish, Dutch, French, German, Greek, Italian, Japanese, Polish, Portuguese, Russian, Spanish, Swedish, Turkish and Ukrainian. Antimicrobial drug (group) names and colloquial microorganism names are provided in these languages.
|
||||
#' @section Reference Data Publicly Available:
|
||||
#' All data sets in this `AMR` package (about microorganisms, antibiotics, SIR interpretation, EUCAST rules, etc.) are publicly and freely available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. We also provide tab-separated plain text files that are machine-readable and suitable for input in any software program, such as laboratory information systems. Please visit [our website for the download links](https://msberends.github.io/AMR/articles/datasets.html). The actual files are of course available on [our GitHub repository](https://github.com/msberends/AMR/tree/main/data-raw).
|
||||
|
@ -49,12 +49,13 @@ pm_left_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
|
||||
|
||||
merged <- cbind(
|
||||
x,
|
||||
y[match(
|
||||
x[, by[1], drop = TRUE],
|
||||
y[, by[2], drop = TRUE]
|
||||
),
|
||||
colnames(y)[!colnames(y) %in% colnames(x) & !colnames(y) == by[2]],
|
||||
drop = FALSE
|
||||
y[
|
||||
match(
|
||||
x[, by[1], drop = TRUE],
|
||||
y[, by[2], drop = TRUE]
|
||||
),
|
||||
colnames(y)[!colnames(y) %in% colnames(x) & !colnames(y) == by[2]],
|
||||
drop = FALSE
|
||||
]
|
||||
)
|
||||
|
||||
@ -190,12 +191,13 @@ addin_insert_like <- function() {
|
||||
)
|
||||
}
|
||||
replace_pos <- function(old, with) {
|
||||
modifyRange(document_range(
|
||||
document_position(current_row, current_col - nchar(old)),
|
||||
document_position(current_row, current_col)
|
||||
),
|
||||
text = with,
|
||||
id = context$id
|
||||
modifyRange(
|
||||
document_range(
|
||||
document_position(current_row, current_col - nchar(old)),
|
||||
document_position(current_row, current_col)
|
||||
),
|
||||
text = with,
|
||||
id = context$id
|
||||
)
|
||||
}
|
||||
|
||||
@ -226,7 +228,7 @@ search_type_in_df <- function(x, type, info = TRUE) {
|
||||
# -- mo
|
||||
if (type == "mo") {
|
||||
add_MO_lookup_to_AMR_env()
|
||||
|
||||
|
||||
if (any(vapply(FUN.VALUE = logical(1), x, is.mo))) {
|
||||
# take first 'mo' column
|
||||
found <- colnames(x)[vapply(FUN.VALUE = logical(1), x, is.mo)]
|
||||
@ -253,11 +255,12 @@ search_type_in_df <- function(x, type, info = TRUE) {
|
||||
# WHONET support
|
||||
found <- sort(colnames(x)[colnames_formatted %like_case% "^(specimen date|specimen_date|spec_date)"])
|
||||
if (!inherits(pm_pull(x, found), c("Date", "POSIXct"))) {
|
||||
stop(font_red(paste0(
|
||||
"Found column '", font_bold(found), "' to be used as input for `col_", type,
|
||||
"`, but this column contains no valid dates. Transform its values to valid dates first."
|
||||
)),
|
||||
call. = FALSE
|
||||
stop(
|
||||
font_red(paste0(
|
||||
"Found column '", font_bold(found), "' to be used as input for `col_", type,
|
||||
"`, but this column contains no valid dates. Transform its values to valid dates first."
|
||||
)),
|
||||
call. = FALSE
|
||||
)
|
||||
}
|
||||
} else if (any(vapply(FUN.VALUE = logical(1), x, function(x) inherits(x, c("Date", "POSIXct"))))) {
|
||||
@ -319,21 +322,23 @@ search_type_in_df <- function(x, type, info = TRUE) {
|
||||
}
|
||||
|
||||
is_valid_regex <- function(x) {
|
||||
regex_at_all <- tryCatch(vapply(
|
||||
FUN.VALUE = logical(1),
|
||||
X = strsplit(x, "", fixed = TRUE),
|
||||
FUN = function(y) {
|
||||
any(y %in% c(
|
||||
"$", "(", ")", "*", "+", "-",
|
||||
".", "?", "[", "]", "^", "{",
|
||||
"|", "}", "\\"
|
||||
),
|
||||
na.rm = TRUE
|
||||
)
|
||||
},
|
||||
USE.NAMES = FALSE
|
||||
),
|
||||
error = function(e) rep(TRUE, length(x))
|
||||
regex_at_all <- tryCatch(
|
||||
vapply(
|
||||
FUN.VALUE = logical(1),
|
||||
X = strsplit(x, "", fixed = TRUE),
|
||||
FUN = function(y) {
|
||||
any(
|
||||
y %in% c(
|
||||
"$", "(", ")", "*", "+", "-",
|
||||
".", "?", "[", "]", "^", "{",
|
||||
"|", "}", "\\"
|
||||
),
|
||||
na.rm = TRUE
|
||||
)
|
||||
},
|
||||
USE.NAMES = FALSE
|
||||
),
|
||||
error = function(e) rep(TRUE, length(x))
|
||||
)
|
||||
regex_valid <- vapply(
|
||||
FUN.VALUE = logical(1),
|
||||
@ -410,16 +415,17 @@ word_wrap <- function(...,
|
||||
|
||||
if (msg %like% "\n") {
|
||||
# run word_wraps() over every line here, bind them and return again
|
||||
return(paste0(vapply(
|
||||
FUN.VALUE = character(1),
|
||||
trimws(unlist(strsplit(msg, "\n", fixed = TRUE)), which = "right"),
|
||||
word_wrap,
|
||||
add_fn = add_fn,
|
||||
as_note = FALSE,
|
||||
width = width,
|
||||
extra_indent = extra_indent
|
||||
),
|
||||
collapse = "\n"
|
||||
return(paste0(
|
||||
vapply(
|
||||
FUN.VALUE = character(1),
|
||||
trimws(unlist(strsplit(msg, "\n", fixed = TRUE)), which = "right"),
|
||||
word_wrap,
|
||||
add_fn = add_fn,
|
||||
as_note = FALSE,
|
||||
width = width,
|
||||
extra_indent = extra_indent
|
||||
),
|
||||
collapse = "\n"
|
||||
))
|
||||
}
|
||||
|
||||
@ -429,11 +435,12 @@ word_wrap <- function(...,
|
||||
# we need to correct for already applied style, that adds text like "\033[31m\"
|
||||
msg_stripped <- font_stripstyle(msg)
|
||||
# where are the spaces now?
|
||||
msg_stripped_wrapped <- paste0(strwrap(msg_stripped,
|
||||
simplify = TRUE,
|
||||
width = width
|
||||
),
|
||||
collapse = "\n"
|
||||
msg_stripped_wrapped <- paste0(
|
||||
strwrap(msg_stripped,
|
||||
simplify = TRUE,
|
||||
width = width
|
||||
),
|
||||
collapse = "\n"
|
||||
)
|
||||
msg_stripped_wrapped <- paste0(unlist(strsplit(msg_stripped_wrapped, "(\n|\\*\\|\\*)")),
|
||||
collapse = "\n"
|
||||
@ -487,11 +494,12 @@ message_ <- function(...,
|
||||
appendLF = TRUE,
|
||||
add_fn = list(font_blue),
|
||||
as_note = TRUE) {
|
||||
message(word_wrap(...,
|
||||
add_fn = add_fn,
|
||||
as_note = as_note
|
||||
),
|
||||
appendLF = appendLF
|
||||
message(
|
||||
word_wrap(...,
|
||||
add_fn = add_fn,
|
||||
as_note = as_note
|
||||
),
|
||||
appendLF = appendLF
|
||||
)
|
||||
}
|
||||
|
||||
@ -499,12 +507,13 @@ warning_ <- function(...,
|
||||
add_fn = list(),
|
||||
immediate = FALSE,
|
||||
call = FALSE) {
|
||||
warning(word_wrap(...,
|
||||
add_fn = add_fn,
|
||||
as_note = FALSE
|
||||
),
|
||||
immediate. = immediate,
|
||||
call. = call
|
||||
warning(
|
||||
word_wrap(...,
|
||||
add_fn = add_fn,
|
||||
as_note = FALSE
|
||||
),
|
||||
immediate. = immediate,
|
||||
call. = call
|
||||
)
|
||||
}
|
||||
|
||||
@ -836,17 +845,18 @@ meet_criteria <- function(object,
|
||||
)
|
||||
}
|
||||
if (!is.null(contains_column_class)) {
|
||||
stop_ifnot(any(vapply(
|
||||
FUN.VALUE = logical(1),
|
||||
object,
|
||||
function(col, columns_class = contains_column_class) {
|
||||
inherits(col, columns_class)
|
||||
}
|
||||
), na.rm = TRUE),
|
||||
"the data provided in argument `", obj_name,
|
||||
"` must contain at least one column of class <", contains_column_class, ">. ",
|
||||
"See ?as.", contains_column_class, ".",
|
||||
call = call_depth
|
||||
stop_ifnot(
|
||||
any(vapply(
|
||||
FUN.VALUE = logical(1),
|
||||
object,
|
||||
function(col, columns_class = contains_column_class) {
|
||||
inherits(col, columns_class)
|
||||
}
|
||||
), na.rm = TRUE),
|
||||
"the data provided in argument `", obj_name,
|
||||
"` must contain at least one column of class <", contains_column_class, ">. ",
|
||||
"See ?as.", contains_column_class, ".",
|
||||
call = call_depth
|
||||
)
|
||||
}
|
||||
return(invisible())
|
||||
@ -1314,7 +1324,6 @@ round2 <- function(x, digits = 1, force_zero = TRUE) {
|
||||
|
||||
# percentage from our other package: 'cleaner'
|
||||
percentage <- function(x, digits = NULL, ...) {
|
||||
|
||||
# getdecimalplaces() function
|
||||
getdecimalplaces <- function(x, minimum = 0, maximum = 3) {
|
||||
if (maximum < minimum) {
|
||||
@ -1330,12 +1339,13 @@ percentage <- function(x, digits = NULL, ...) {
|
||||
), ".", fixed = TRUE),
|
||||
function(y) ifelse(length(y) == 2, nchar(y[2]), 0)
|
||||
)), na.rm = TRUE)
|
||||
max(min(max_places,
|
||||
maximum,
|
||||
max(
|
||||
min(max_places,
|
||||
maximum,
|
||||
na.rm = TRUE
|
||||
),
|
||||
minimum,
|
||||
na.rm = TRUE
|
||||
),
|
||||
minimum,
|
||||
na.rm = TRUE
|
||||
)
|
||||
}
|
||||
|
||||
@ -1366,11 +1376,12 @@ percentage <- function(x, digits = NULL, ...) {
|
||||
# max one digit if undefined
|
||||
digits <- getdecimalplaces(x, minimum = 0, maximum = 1)
|
||||
}
|
||||
format_percentage(structure(
|
||||
.Data = as.double(x),
|
||||
class = c("percentage", "numeric")
|
||||
),
|
||||
digits = digits, ...
|
||||
format_percentage(
|
||||
structure(
|
||||
.Data = as.double(x),
|
||||
class = c("percentage", "numeric")
|
||||
),
|
||||
digits = digits, ...
|
||||
)
|
||||
}
|
||||
|
||||
@ -1385,7 +1396,7 @@ add_MO_lookup_to_AMR_env <- function() {
|
||||
# for all MO functions, saves a lot of time on package load and in package size
|
||||
if (is.null(AMR_env$MO_lookup)) {
|
||||
MO_lookup <- AMR::microorganisms
|
||||
|
||||
|
||||
MO_lookup$kingdom_index <- NA_real_
|
||||
MO_lookup[which(MO_lookup$kingdom == "Bacteria" | MO_lookup$mo == "UNKNOWN"), "kingdom_index"] <- 1
|
||||
MO_lookup[which(MO_lookup$kingdom == "Fungi"), "kingdom_index"] <- 2
|
||||
@ -1393,7 +1404,7 @@ add_MO_lookup_to_AMR_env <- function() {
|
||||
MO_lookup[which(MO_lookup$kingdom == "Archaea"), "kingdom_index"] <- 4
|
||||
# all the rest
|
||||
MO_lookup[which(is.na(MO_lookup$kingdom_index)), "kingdom_index"] <- 5
|
||||
|
||||
|
||||
# the fullname lowercase, important for the internal algorithms in as.mo()
|
||||
MO_lookup$fullname_lower <- tolower(trimws(paste(
|
||||
MO_lookup$genus,
|
||||
@ -1405,7 +1416,7 @@ add_MO_lookup_to_AMR_env <- function() {
|
||||
MO_lookup$fullname_lower <- trimws(gsub("[^.a-z0-9/ \\-]+", "", MO_lookup$fullname_lower, perl = TRUE))
|
||||
# special for Salmonella - they have cities as subspecies but not the species (enterica) in the fullname:
|
||||
MO_lookup$fullname_lower[which(MO_lookup$subspecies %like_case% "^[A-Z]")] <- gsub(" enterica ", " ", MO_lookup$fullname_lower[which(MO_lookup$subspecies %like_case% "^[A-Z]")], fixed = TRUE)
|
||||
|
||||
|
||||
MO_lookup$full_first <- substr(MO_lookup$fullname_lower, 1, 1)
|
||||
MO_lookup$species_first <- tolower(substr(MO_lookup$species, 1, 1)) # tolower for groups (Streptococcus, Salmonella)
|
||||
MO_lookup$subspecies_first <- tolower(substr(MO_lookup$subspecies, 1, 1)) # tolower for Salmonella serovars
|
||||
|
69
R/ab.R
69
R/ab.R
@ -87,7 +87,6 @@
|
||||
#'
|
||||
#' \donttest{
|
||||
#' if (require("dplyr")) {
|
||||
#'
|
||||
#' # you can quickly rename 'sir' columns using set_ab_names() with dplyr:
|
||||
#' example_isolates %>%
|
||||
#' set_ab_names(where(is.sir), property = "atc")
|
||||
@ -338,22 +337,23 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
}
|
||||
|
||||
# transform back from other languages and try again
|
||||
x_translated <- paste(lapply(
|
||||
strsplit(x[i], "[^A-Z0-9]"),
|
||||
function(y) {
|
||||
for (i in seq_len(length(y))) {
|
||||
for (lang in LANGUAGES_SUPPORTED[LANGUAGES_SUPPORTED != "en"]) {
|
||||
y[i] <- ifelse(tolower(y[i]) %in% tolower(TRANSLATIONS[, lang, drop = TRUE]),
|
||||
TRANSLATIONS[which(tolower(TRANSLATIONS[, lang, drop = TRUE]) == tolower(y[i]) &
|
||||
!isFALSE(TRANSLATIONS$fixed)), "pattern"],
|
||||
y[i]
|
||||
)
|
||||
x_translated <- paste(
|
||||
lapply(
|
||||
strsplit(x[i], "[^A-Z0-9]"),
|
||||
function(y) {
|
||||
for (i in seq_len(length(y))) {
|
||||
for (lang in LANGUAGES_SUPPORTED[LANGUAGES_SUPPORTED != "en"]) {
|
||||
y[i] <- ifelse(tolower(y[i]) %in% tolower(TRANSLATIONS[, lang, drop = TRUE]),
|
||||
TRANSLATIONS[which(tolower(TRANSLATIONS[, lang, drop = TRUE]) == tolower(y[i]) &
|
||||
!isFALSE(TRANSLATIONS$fixed)), "pattern"],
|
||||
y[i]
|
||||
)
|
||||
}
|
||||
}
|
||||
generalise_antibiotic_name(y)
|
||||
}
|
||||
generalise_antibiotic_name(y)
|
||||
}
|
||||
)[[1]],
|
||||
collapse = "/"
|
||||
)[[1]],
|
||||
collapse = "/"
|
||||
)
|
||||
x_translated_guess <- suppressWarnings(as.ab(x_translated, initial_search = FALSE))
|
||||
if (!is.na(x_translated_guess)) {
|
||||
@ -362,20 +362,21 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
}
|
||||
|
||||
# now also try to coerce brandname combinations like "Amoxy/clavulanic acid"
|
||||
x_translated <- paste(lapply(
|
||||
strsplit(x_translated, "[^A-Z0-9 ]"),
|
||||
function(y) {
|
||||
for (i in seq_len(length(y))) {
|
||||
y_name <- suppressWarnings(ab_name(y[i], language = NULL, initial_search = FALSE))
|
||||
y[i] <- ifelse(!is.na(y_name),
|
||||
y_name,
|
||||
y[i]
|
||||
)
|
||||
x_translated <- paste(
|
||||
lapply(
|
||||
strsplit(x_translated, "[^A-Z0-9 ]"),
|
||||
function(y) {
|
||||
for (i in seq_len(length(y))) {
|
||||
y_name <- suppressWarnings(ab_name(y[i], language = NULL, initial_search = FALSE))
|
||||
y[i] <- ifelse(!is.na(y_name),
|
||||
y_name,
|
||||
y[i]
|
||||
)
|
||||
}
|
||||
generalise_antibiotic_name(y)
|
||||
}
|
||||
generalise_antibiotic_name(y)
|
||||
}
|
||||
)[[1]],
|
||||
collapse = "/"
|
||||
)[[1]],
|
||||
collapse = "/"
|
||||
)
|
||||
x_translated_guess <- suppressWarnings(as.ab(x_translated, initial_search = FALSE))
|
||||
if (!is.na(x_translated_guess)) {
|
||||
@ -513,8 +514,10 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
)
|
||||
}
|
||||
x_unknown <- x_unknown[!x_unknown %in% x_unknown_ATCs]
|
||||
x_unknown <- c(x_unknown,
|
||||
AMR_env$ab_previously_coerced$x_bak[which(AMR_env$ab_previously_coerced$x %in% x & is.na(AMR_env$ab_previously_coerced$ab))])
|
||||
x_unknown <- c(
|
||||
x_unknown,
|
||||
AMR_env$ab_previously_coerced$x_bak[which(AMR_env$ab_previously_coerced$x %in% x & is.na(AMR_env$ab_previously_coerced$ab))]
|
||||
)
|
||||
if (length(x_unknown) > 0 && fast_mode == FALSE) {
|
||||
warning_(
|
||||
"in `as.ab()`: these values could not be coerced to a valid antimicrobial ID: ",
|
||||
@ -660,9 +663,9 @@ get_translate_ab <- function(translate_ab) {
|
||||
} else {
|
||||
translate_ab <- tolower(translate_ab)
|
||||
stop_ifnot(translate_ab %in% colnames(AMR::antibiotics),
|
||||
"invalid value for 'translate_ab', this must be a column name of the antibiotics data set\n",
|
||||
"or TRUE (equals 'name') or FALSE to not translate at all.",
|
||||
call = FALSE
|
||||
"invalid value for 'translate_ab', this must be a column name of the antibiotics data set\n",
|
||||
"or TRUE (equals 'name') or FALSE to not translate at all.",
|
||||
call = FALSE
|
||||
)
|
||||
translate_ab
|
||||
}
|
||||
|
@ -95,20 +95,17 @@
|
||||
#' # dplyr -------------------------------------------------------------------
|
||||
#' \donttest{
|
||||
#' if (require("dplyr")) {
|
||||
#'
|
||||
#' # get AMR for all aminoglycosides e.g., per ward:
|
||||
#' example_isolates %>%
|
||||
#' group_by(ward) %>%
|
||||
#' summarise(across(aminoglycosides(), resistance))
|
||||
#' }
|
||||
#' if (require("dplyr")) {
|
||||
#'
|
||||
#' # You can combine selectors with '&' to be more specific:
|
||||
#' example_isolates %>%
|
||||
#' select(penicillins() & administrable_per_os())
|
||||
#' }
|
||||
#' if (require("dplyr")) {
|
||||
#'
|
||||
#' # get AMR for only drugs that matter - no intrinsic resistance:
|
||||
#' example_isolates %>%
|
||||
#' filter(mo_genus() %in% c("Escherichia", "Klebsiella")) %>%
|
||||
@ -116,7 +113,6 @@
|
||||
#' summarise(across(not_intrinsic_resistant(), resistance))
|
||||
#' }
|
||||
#' if (require("dplyr")) {
|
||||
#'
|
||||
#' # get susceptibility for antibiotics whose name contains "trim":
|
||||
#' example_isolates %>%
|
||||
#' filter(first_isolate()) %>%
|
||||
@ -124,19 +120,16 @@
|
||||
#' summarise(across(ab_selector(name %like% "trim"), susceptibility))
|
||||
#' }
|
||||
#' if (require("dplyr")) {
|
||||
#'
|
||||
#' # this will select columns 'IPM' (imipenem) and 'MEM' (meropenem):
|
||||
#' example_isolates %>%
|
||||
#' select(carbapenems())
|
||||
#' }
|
||||
#' if (require("dplyr")) {
|
||||
#'
|
||||
#' # this will select columns 'mo', 'AMK', 'GEN', 'KAN' and 'TOB':
|
||||
#' example_isolates %>%
|
||||
#' select(mo, aminoglycosides())
|
||||
#' }
|
||||
#' if (require("dplyr")) {
|
||||
#'
|
||||
#' # any() and all() work in dplyr's filter() too:
|
||||
#' example_isolates %>%
|
||||
#' filter(
|
||||
@ -145,25 +138,21 @@
|
||||
#' )
|
||||
#' }
|
||||
#' if (require("dplyr")) {
|
||||
#'
|
||||
#' # also works with c():
|
||||
#' example_isolates %>%
|
||||
#' filter(any(c(carbapenems(), aminoglycosides()) == "R"))
|
||||
#' }
|
||||
#' if (require("dplyr")) {
|
||||
#'
|
||||
#' # not setting any/all will automatically apply all():
|
||||
#' example_isolates %>%
|
||||
#' filter(aminoglycosides() == "R")
|
||||
#' }
|
||||
#' if (require("dplyr")) {
|
||||
#'
|
||||
#' # this will select columns 'mo' and all antimycobacterial drugs ('RIF'):
|
||||
#' example_isolates %>%
|
||||
#' select(mo, ab_class("mycobact"))
|
||||
#' }
|
||||
#' if (require("dplyr")) {
|
||||
#'
|
||||
#' # get bug/drug combinations for only glycopeptides in Gram-positives:
|
||||
#' example_isolates %>%
|
||||
#' filter(mo_is_gram_positive()) %>%
|
||||
@ -179,7 +168,6 @@
|
||||
#' select(penicillins()) # only the 'J01CA01' column will be selected
|
||||
#' }
|
||||
#' if (require("dplyr")) {
|
||||
#'
|
||||
#' # with recent versions of dplyr this is all equal:
|
||||
#' x <- example_isolates[carbapenems() == "R", ]
|
||||
#' y <- example_isolates %>% filter(carbapenems() == "R")
|
||||
@ -433,14 +421,16 @@ administrable_per_os <- function(only_sir_columns = FALSE, ...) {
|
||||
ab_group = "administrable_per_os",
|
||||
examples = paste0(
|
||||
" (such as ",
|
||||
vector_or(ab_name(sample(agents_all,
|
||||
size = min(5, length(agents_all)),
|
||||
replace = FALSE
|
||||
),
|
||||
tolower = TRUE,
|
||||
language = NULL
|
||||
),
|
||||
quotes = FALSE
|
||||
vector_or(
|
||||
ab_name(
|
||||
sample(agents_all,
|
||||
size = min(5, length(agents_all)),
|
||||
replace = FALSE
|
||||
),
|
||||
tolower = TRUE,
|
||||
language = NULL
|
||||
),
|
||||
quotes = FALSE
|
||||
),
|
||||
")"
|
||||
)
|
||||
@ -491,20 +481,21 @@ not_intrinsic_resistant <- function(only_sir_columns = FALSE, col_mo = NULL, ver
|
||||
sort = FALSE, fn = "not_intrinsic_resistant"
|
||||
)
|
||||
# intrinsic vars
|
||||
vars_df_R <- tryCatch(sapply(
|
||||
eucast_rules(vars_df,
|
||||
col_mo = col_mo,
|
||||
version_expertrules = version_expertrules,
|
||||
rules = "expert",
|
||||
info = FALSE
|
||||
vars_df_R <- tryCatch(
|
||||
sapply(
|
||||
eucast_rules(vars_df,
|
||||
col_mo = col_mo,
|
||||
version_expertrules = version_expertrules,
|
||||
rules = "expert",
|
||||
info = FALSE
|
||||
),
|
||||
function(col) {
|
||||
tryCatch(!any(is.na(col)) && all(col == "R"),
|
||||
error = function(e) FALSE
|
||||
)
|
||||
}
|
||||
),
|
||||
function(col) {
|
||||
tryCatch(!any(is.na(col)) && all(col == "R"),
|
||||
error = function(e) FALSE
|
||||
)
|
||||
}
|
||||
),
|
||||
error = function(e) stop_("in not_intrinsic_resistant(): ", e$message, call = FALSE)
|
||||
error = function(e) stop_("in not_intrinsic_resistant(): ", e$message, call = FALSE)
|
||||
)
|
||||
|
||||
agents <- ab_in_data[ab_in_data %in% names(vars_df_R[which(vars_df_R)])]
|
||||
@ -549,12 +540,13 @@ ab_select_exec <- function(function_name,
|
||||
if (message_not_thrown_before(function_name, "ab_class", "untreatable", entire_session = TRUE)) {
|
||||
warning_(
|
||||
"in `", function_name, "()`: some drugs were ignored since they cannot be used for treating patients: ",
|
||||
vector_and(ab_name(names(ab_in_data)[names(ab_in_data) %in% untreatable],
|
||||
language = NULL,
|
||||
tolower = TRUE
|
||||
),
|
||||
quotes = FALSE,
|
||||
sort = TRUE
|
||||
vector_and(
|
||||
ab_name(names(ab_in_data)[names(ab_in_data) %in% untreatable],
|
||||
language = NULL,
|
||||
tolower = TRUE
|
||||
),
|
||||
quotes = FALSE,
|
||||
sort = TRUE
|
||||
), ". They can be included using `", function_name, "(only_treatable = FALSE)`. ",
|
||||
"This warning will be shown once per session."
|
||||
)
|
||||
@ -593,11 +585,12 @@ ab_select_exec <- function(function_name,
|
||||
}
|
||||
ab_group <- function_name
|
||||
}
|
||||
examples <- paste0(" (such as ", vector_or(ab_name(sample(abx, size = min(2, length(abx)), replace = FALSE),
|
||||
tolower = TRUE,
|
||||
language = NULL
|
||||
),
|
||||
quotes = FALSE
|
||||
examples <- paste0(" (such as ", vector_or(
|
||||
ab_name(sample(abx, size = min(2, length(abx)), replace = FALSE),
|
||||
tolower = TRUE,
|
||||
language = NULL
|
||||
),
|
||||
quotes = FALSE
|
||||
), ")")
|
||||
} else {
|
||||
# this for the 'manual' ab_class() function
|
||||
@ -821,11 +814,12 @@ find_ab_names <- function(ab_group, n = 3) {
|
||||
if (length(drugs) == 0) {
|
||||
return("??")
|
||||
}
|
||||
vector_or(ab_name(sample(drugs, size = min(n, length(drugs)), replace = FALSE),
|
||||
tolower = TRUE,
|
||||
language = NULL
|
||||
),
|
||||
quotes = FALSE
|
||||
vector_or(
|
||||
ab_name(sample(drugs, size = min(n, length(drugs)), replace = FALSE),
|
||||
tolower = TRUE,
|
||||
language = NULL
|
||||
),
|
||||
quotes = FALSE
|
||||
)
|
||||
}
|
||||
|
||||
|
11
R/age.R
11
R/age.R
@ -83,11 +83,12 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
|
||||
# add decimals
|
||||
if (exact == TRUE) {
|
||||
# get dates of `x` when `x` would have the year of `reference`
|
||||
x_in_reference_year <- as.POSIXlt(paste0(
|
||||
format(as.Date(reference), "%Y"),
|
||||
format(as.Date(x), "-%m-%d")
|
||||
),
|
||||
format = "%Y-%m-%d"
|
||||
x_in_reference_year <- as.POSIXlt(
|
||||
paste0(
|
||||
format(as.Date(reference), "%Y"),
|
||||
format(as.Date(x), "-%m-%d")
|
||||
),
|
||||
format = "%Y-%m-%d"
|
||||
)
|
||||
# get differences in days
|
||||
n_days_x_rest <- as.double(difftime(as.Date(reference),
|
||||
|
68
R/av.R
68
R/av.R
@ -308,22 +308,23 @@ as.av <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
}
|
||||
|
||||
# transform back from other languages and try again
|
||||
x_translated <- paste(lapply(
|
||||
strsplit(x[i], "[^A-Z0-9]"),
|
||||
function(y) {
|
||||
for (i in seq_len(length(y))) {
|
||||
for (lang in LANGUAGES_SUPPORTED[LANGUAGES_SUPPORTED != "en"]) {
|
||||
y[i] <- ifelse(tolower(y[i]) %in% tolower(TRANSLATIONS[, lang, drop = TRUE]),
|
||||
TRANSLATIONS[which(tolower(TRANSLATIONS[, lang, drop = TRUE]) == tolower(y[i]) &
|
||||
!isFALSE(TRANSLATIONS$fixed)), "pattern"],
|
||||
y[i]
|
||||
)
|
||||
x_translated <- paste(
|
||||
lapply(
|
||||
strsplit(x[i], "[^A-Z0-9]"),
|
||||
function(y) {
|
||||
for (i in seq_len(length(y))) {
|
||||
for (lang in LANGUAGES_SUPPORTED[LANGUAGES_SUPPORTED != "en"]) {
|
||||
y[i] <- ifelse(tolower(y[i]) %in% tolower(TRANSLATIONS[, lang, drop = TRUE]),
|
||||
TRANSLATIONS[which(tolower(TRANSLATIONS[, lang, drop = TRUE]) == tolower(y[i]) &
|
||||
!isFALSE(TRANSLATIONS$fixed)), "pattern"],
|
||||
y[i]
|
||||
)
|
||||
}
|
||||
}
|
||||
generalise_antibiotic_name(y)
|
||||
}
|
||||
generalise_antibiotic_name(y)
|
||||
}
|
||||
)[[1]],
|
||||
collapse = "/"
|
||||
)[[1]],
|
||||
collapse = "/"
|
||||
)
|
||||
x_translated_guess <- suppressWarnings(as.av(x_translated, initial_search = FALSE))
|
||||
if (!is.na(x_translated_guess)) {
|
||||
@ -332,20 +333,21 @@ as.av <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
}
|
||||
|
||||
# now also try to coerce brandname combinations like "Amoxy/clavulanic acid"
|
||||
x_translated <- paste(lapply(
|
||||
strsplit(x_translated, "[^A-Z0-9 ]"),
|
||||
function(y) {
|
||||
for (i in seq_len(length(y))) {
|
||||
y_name <- suppressWarnings(av_name(y[i], language = NULL, initial_search = FALSE))
|
||||
y[i] <- ifelse(!is.na(y_name),
|
||||
y_name,
|
||||
y[i]
|
||||
)
|
||||
x_translated <- paste(
|
||||
lapply(
|
||||
strsplit(x_translated, "[^A-Z0-9 ]"),
|
||||
function(y) {
|
||||
for (i in seq_len(length(y))) {
|
||||
y_name <- suppressWarnings(av_name(y[i], language = NULL, initial_search = FALSE))
|
||||
y[i] <- ifelse(!is.na(y_name),
|
||||
y_name,
|
||||
y[i]
|
||||
)
|
||||
}
|
||||
generalise_antibiotic_name(y)
|
||||
}
|
||||
generalise_antibiotic_name(y)
|
||||
}
|
||||
)[[1]],
|
||||
collapse = "/"
|
||||
)[[1]],
|
||||
collapse = "/"
|
||||
)
|
||||
x_translated_guess <- suppressWarnings(as.av(x_translated, initial_search = FALSE))
|
||||
if (!is.na(x_translated_guess)) {
|
||||
@ -478,8 +480,10 @@ as.av <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
)
|
||||
}
|
||||
x_unknown <- x_unknown[!x_unknown %in% x_unknown_ATCs]
|
||||
x_unknown <- c(x_unknown,
|
||||
AMR_env$av_previously_coerced$x_bak[which(AMR_env$av_previously_coerced$x %in% x & is.na(AMR_env$av_previously_coerced$av))])
|
||||
x_unknown <- c(
|
||||
x_unknown,
|
||||
AMR_env$av_previously_coerced$x_bak[which(AMR_env$av_previously_coerced$x %in% x & is.na(AMR_env$av_previously_coerced$av))]
|
||||
)
|
||||
if (length(x_unknown) > 0 && fast_mode == FALSE) {
|
||||
warning_(
|
||||
"in `as.av()`: these values could not be coerced to a valid antiviral drug ID: ",
|
||||
@ -604,9 +608,9 @@ get_translate_av <- function(translate_av) {
|
||||
} else {
|
||||
translate_av <- tolower(translate_av)
|
||||
stop_ifnot(translate_av %in% colnames(AMR::antivirals),
|
||||
"invalid value for 'translate_av', this must be a column name of the antivirals data set\n",
|
||||
"or TRUE (equals 'name') or FALSE to not translate at all.",
|
||||
call = FALSE
|
||||
"invalid value for 'translate_av', this must be a column name of the antivirals data set\n",
|
||||
"or TRUE (equals 'name') or FALSE to not translate at all.",
|
||||
call = FALSE
|
||||
)
|
||||
translate_av
|
||||
}
|
||||
|
@ -69,26 +69,26 @@ av_from_text <- function(text,
|
||||
if (missing(type)) {
|
||||
type <- type[1L]
|
||||
}
|
||||
|
||||
|
||||
meet_criteria(text)
|
||||
meet_criteria(type, allow_class = "character", has_length = 1)
|
||||
meet_criteria(collapse, has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(translate_av, allow_NULL = FALSE) # get_translate_av() will be more informative about what's allowed
|
||||
meet_criteria(thorough_search, allow_class = "logical", has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(info, allow_class = "logical", has_length = 1)
|
||||
|
||||
|
||||
type <- tolower(trimws2(type))
|
||||
|
||||
|
||||
text <- tolower(as.character(text))
|
||||
text_split_all <- strsplit(text, "[ ;.,:\\|]")
|
||||
progress <- progress_ticker(n = length(text_split_all), n_min = 5, print = info)
|
||||
on.exit(close(progress))
|
||||
|
||||
|
||||
if (type %like% "(drug|ab|anti)") {
|
||||
translate_av <- get_translate_av(translate_av)
|
||||
|
||||
|
||||
if (isTRUE(thorough_search) ||
|
||||
(isTRUE(is.null(thorough_search)) && max(vapply(FUN.VALUE = double(1), text_split_all, length), na.rm = TRUE) <= 3)) {
|
||||
(isTRUE(is.null(thorough_search)) && max(vapply(FUN.VALUE = double(1), text_split_all, length), na.rm = TRUE) <= 3)) {
|
||||
text_split_all <- text_split_all[nchar(text_split_all) >= 4 & grepl("[a-z]+", text_split_all)]
|
||||
result <- lapply(text_split_all, function(text_split) {
|
||||
progress$tick()
|
||||
@ -125,9 +125,9 @@ av_from_text <- function(text,
|
||||
)
|
||||
})
|
||||
}
|
||||
|
||||
|
||||
close(progress)
|
||||
|
||||
|
||||
result <- lapply(result, function(out) {
|
||||
out <- out[!is.na(out)]
|
||||
if (length(out) == 0) {
|
||||
@ -149,7 +149,7 @@ av_from_text <- function(text,
|
||||
text_split <- as.double(gsub("[^0-9.]", "", text_split))
|
||||
# minimal 100 units/mg and no years that unlikely doses
|
||||
text_split <- text_split[text_split >= 100 & !text_split %in% c(1951:1999, 2001:2049)]
|
||||
|
||||
|
||||
if (length(text_split) > 0) {
|
||||
text_split
|
||||
} else {
|
||||
@ -170,7 +170,7 @@ av_from_text <- function(text,
|
||||
} else {
|
||||
stop_("`type` must be either 'drug', 'dose' or 'administration'")
|
||||
}
|
||||
|
||||
|
||||
# collapse text if needed
|
||||
if (!is.null(collapse)) {
|
||||
result <- vapply(FUN.VALUE = character(1), result, function(x) {
|
||||
@ -181,6 +181,6 @@ av_from_text <- function(text,
|
||||
}
|
||||
})
|
||||
}
|
||||
|
||||
|
||||
result
|
||||
}
|
||||
|
@ -84,7 +84,7 @@ av_name <- function(x, language = get_AMR_locale(), tolower = FALSE, ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
language <- validate_language(language)
|
||||
meet_criteria(tolower, allow_class = "logical", has_length = 1)
|
||||
|
||||
|
||||
x <- translate_into_language(av_validate(x = x, property = "name", ...), language = language, only_affect_ab_names = TRUE)
|
||||
if (tolower == TRUE) {
|
||||
# use perl to only transform the first character
|
||||
@ -155,11 +155,11 @@ av_loinc <- function(x, ...) {
|
||||
av_ddd <- function(x, administration = "oral", ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(administration, is_in = c("oral", "iv"), has_length = 1)
|
||||
|
||||
|
||||
x <- as.av(x, ...)
|
||||
ddd_prop <- paste0(administration, "_ddd")
|
||||
out <- av_validate(x = x, property = ddd_prop)
|
||||
|
||||
|
||||
if (any(av_name(x, language = NULL) %like% "/" & is.na(out))) {
|
||||
warning_(
|
||||
"in `av_ddd()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
|
||||
@ -175,11 +175,11 @@ av_ddd <- function(x, administration = "oral", ...) {
|
||||
av_ddd_units <- function(x, administration = "oral", ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(administration, is_in = c("oral", "iv"), has_length = 1)
|
||||
|
||||
|
||||
x <- as.av(x, ...)
|
||||
ddd_prop <- paste0(administration, "_units")
|
||||
out <- av_validate(x = x, property = ddd_prop)
|
||||
|
||||
|
||||
if (any(av_name(x, language = NULL) %like% "/" & is.na(out))) {
|
||||
warning_(
|
||||
"in `av_ddd_units()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
|
||||
@ -195,7 +195,7 @@ av_ddd_units <- function(x, administration = "oral", ...) {
|
||||
av_info <- function(x, language = get_AMR_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
language <- validate_language(language)
|
||||
|
||||
|
||||
x <- as.av(x, ...)
|
||||
list(
|
||||
av = as.character(x),
|
||||
@ -224,18 +224,18 @@ av_info <- function(x, language = get_AMR_locale(), ...) {
|
||||
av_url <- function(x, open = FALSE, ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(open, allow_class = "logical", has_length = 1)
|
||||
|
||||
|
||||
av <- as.av(x = x, ...)
|
||||
atcs <- av_atc(av, only_first = TRUE)
|
||||
u <- paste0("https://www.whocc.no/atc_ddd_index/?code=", atcs, "&showdescription=no")
|
||||
u[is.na(atcs)] <- NA_character_
|
||||
names(u) <- av_name(av)
|
||||
|
||||
|
||||
NAs <- av_name(av, tolower = TRUE, language = NULL)[!is.na(av) & is.na(atcs)]
|
||||
if (length(NAs) > 0) {
|
||||
warning_("in `av_url()`: no ATC code available for ", vector_and(NAs, quotes = FALSE), ".")
|
||||
}
|
||||
|
||||
|
||||
if (open == TRUE) {
|
||||
if (length(u) > 1 && !is.na(u[1L])) {
|
||||
warning_("in `av_url()`: only the first URL will be opened, as `browseURL()` only suports one string.")
|
||||
@ -264,9 +264,9 @@ av_validate <- function(x, property, ...) {
|
||||
# try to catch an error when inputting an invalid argument
|
||||
# so the 'call.' can be set to FALSE
|
||||
tryCatch(x[1L] %in% AMR_env$AV_lookup[1, property, drop = TRUE],
|
||||
error = function(e) stop(e$message, call. = FALSE)
|
||||
error = function(e) stop(e$message, call. = FALSE)
|
||||
)
|
||||
|
||||
|
||||
if (!all(x %in% AMR_env$AV_lookup[, property, drop = TRUE])) {
|
||||
x <- as.av(x, ...)
|
||||
if (all(is.na(x)) && is.list(AMR_env$AV_lookup[, property, drop = TRUE])) {
|
||||
@ -276,7 +276,7 @@ av_validate <- function(x, property, ...) {
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
if (property == "av") {
|
||||
return(set_clean_class(x, new_class = c("av", "character")))
|
||||
} else if (property == "cid") {
|
||||
|
@ -31,25 +31,25 @@
|
||||
#'
|
||||
#' With [add_custom_antimicrobials()] you can add your own custom antimicrobial drug names and codes.
|
||||
#' @param x a [data.frame] resembling the [antibiotics] data set, at least containing columns "ab" and "name"
|
||||
#' @details **Important:** Due to how \R works, the [add_custom_antimicrobials()] function has to be run in every \R session - added antimicrobials are not stored between sessions and are thus lost when \R is exited.
|
||||
#'
|
||||
#' @details **Important:** Due to how \R works, the [add_custom_antimicrobials()] function has to be run in every \R session - added antimicrobials are not stored between sessions and are thus lost when \R is exited.
|
||||
#'
|
||||
#' There are two ways to automate this process:
|
||||
#'
|
||||
#'
|
||||
#' **Method 1:** Save the antimicrobials to a local or remote file (can even be the internet). To use this method:
|
||||
#'
|
||||
#'
|
||||
#' 1. Create a data set in the structure of the [antibiotics] data set (containing at the very least columns "ab" and "name") and save it with [saveRDS()] to a location of choice, e.g. `"~/my_custom_ab.rds"`, or any remote location.
|
||||
#'
|
||||
#'
|
||||
#' 2. Set the file location to the `AMR_custom_ab` \R option: `options(AMR_custom_ab = "~/my_custom_ab.rds")`. This can even be a remote file location, such as an https URL. Since options are not saved between \R sessions, it is best to save this option to the `.Rprofile` file so that it will loaded on start-up of \R. To do this, open the `.Rprofile` file using e.g. `utils::file.edit("~/.Rprofile")`, add this text and save the file:
|
||||
#'
|
||||
#' ```r
|
||||
#' # Add custom antibiotic drug codes:
|
||||
#' options(AMR_custom_ab = "~/my_custom_ab.rds")
|
||||
#' ```
|
||||
#'
|
||||
#'
|
||||
#' Upon package load, this file will be loaded and run through the [add_custom_antimicrobials()] function.
|
||||
#'
|
||||
#'
|
||||
#' **Method 2:** Save the antimicrobial additions directly to your `.Rprofile` file. An important downside is that this requires to load the `AMR` package at every start-up. To use this method:
|
||||
#'
|
||||
#'
|
||||
#' 1. Edit the `.Rprofile` file using e.g. `utils::file.edit("~/.Rprofile")`.
|
||||
#'
|
||||
#' 2. Add a text like below and save the file:
|
||||
@ -139,10 +139,10 @@ add_custom_antimicrobials <- function(x) {
|
||||
x[, col] <- as.list(x[, col, drop = TRUE])
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
AMR_env$custom_ab_codes <- c(AMR_env$custom_ab_codes, x$ab)
|
||||
class(AMR_env$AB_lookup$ab) <- "character"
|
||||
|
||||
|
||||
new_df <- AMR_env$AB_lookup[0, , drop = FALSE][seq_len(NROW(x)), , drop = FALSE]
|
||||
rownames(new_df) <- NULL
|
||||
list_cols <- vapply(FUN.VALUE = logical(1), new_df, is.list)
|
||||
@ -155,7 +155,7 @@ add_custom_antimicrobials <- function(x) {
|
||||
new_df[, col] <- x[, col, drop = TRUE]
|
||||
}
|
||||
AMR_env$AB_lookup <- unique(rbind(AMR_env$AB_lookup, new_df))
|
||||
|
||||
|
||||
AMR_env$ab_previously_coerced <- AMR_env$ab_previously_coerced[which(!AMR_env$ab_previously_coerced$ab %in% x$ab), , drop = FALSE]
|
||||
class(AMR_env$AB_lookup$ab) <- c("ab", "character")
|
||||
message_("Added ", nr2char(nrow(x)), " record", ifelse(nrow(x) > 1, "s", ""), " to the internal `antibiotics` data set.")
|
||||
|
@ -240,11 +240,12 @@ print.custom_eucast_rules <- function(x, ...) {
|
||||
" (", rule$result_group, ")"
|
||||
)
|
||||
agents <- sort(agents)
|
||||
rule_if <- word_wrap(paste0(
|
||||
i, ". ", font_bold("If "), font_blue(rule$query), font_bold(" then "),
|
||||
"set to {result}:"
|
||||
),
|
||||
extra_indent = 5
|
||||
rule_if <- word_wrap(
|
||||
paste0(
|
||||
i, ". ", font_bold("If "), font_blue(rule$query), font_bold(" then "),
|
||||
"set to {result}:"
|
||||
),
|
||||
extra_indent = 5
|
||||
)
|
||||
rule_if <- gsub("{result}", val, rule_if, fixed = TRUE)
|
||||
rule_then <- paste0(" ", word_wrap(paste0(agents, collapse = ", "), extra_indent = 5))
|
||||
|
@ -32,26 +32,26 @@
|
||||
#' With [add_custom_microorganisms()] you can add your own custom microorganisms, such the non-taxonomic outcome of laboratory analysis.
|
||||
#' @param x a [data.frame] resembling the [microorganisms] data set, at least containing column "genus" (case-insensitive)
|
||||
#' @details This function will fill in missing taxonomy for you, if specific taxonomic columns are missing, see *Examples*.
|
||||
#'
|
||||
#' **Important:** Due to how \R works, the [add_custom_microorganisms()] function has to be run in every \R session - added microorganisms are not stored between sessions and are thus lost when \R is exited.
|
||||
#'
|
||||
#'
|
||||
#' **Important:** Due to how \R works, the [add_custom_microorganisms()] function has to be run in every \R session - added microorganisms are not stored between sessions and are thus lost when \R is exited.
|
||||
#'
|
||||
#' There are two ways to automate this process:
|
||||
#'
|
||||
#'
|
||||
#' **Method 1:** Using the option [`AMR_custom_mo`][AMR-options], which is the preferred method. To use this method:
|
||||
#'
|
||||
#'
|
||||
#' 1. Create a data set in the structure of the [microorganisms] data set (containing at the very least column "genus") and save it with [saveRDS()] to a location of choice, e.g. `"~/my_custom_mo.rds"`, or any remote location.
|
||||
#'
|
||||
#'
|
||||
#' 2. Set the file location to the `AMR_custom_mo` \R option: `options(AMR_custom_mo = "~/my_custom_mo.rds")`. This can even be a remote file location, such as an https URL. Since options are not saved between \R sessions, it is best to save this option to the `.Rprofile` file so that it will be loaded on start-up of \R. To do this, open the `.Rprofile` file using e.g. `utils::file.edit("~/.Rprofile")`, add this text and save the file:
|
||||
#'
|
||||
#' ```r
|
||||
#' # Add custom microorganism codes:
|
||||
#' options(AMR_custom_mo = "~/my_custom_mo.rds")
|
||||
#' ```
|
||||
#'
|
||||
#'
|
||||
#' Upon package load, this file will be loaded and run through the [add_custom_microorganisms()] function.
|
||||
#'
|
||||
#'
|
||||
#' **Method 2:** Loading the microorganism directly from your `.Rprofile` file. An important downside is that this requires the `AMR` package to be installed or else this method will fail. To use this method:
|
||||
#'
|
||||
#'
|
||||
#' 1. Edit the `.Rprofile` file using e.g. `utils::file.edit("~/.Rprofile")`.
|
||||
#'
|
||||
#' 2. Add a text like below and save the file:
|
||||
@ -77,44 +77,49 @@
|
||||
#' # now add a custom entry - it will be considered by as.mo() and
|
||||
#' # all mo_*() functions
|
||||
#' add_custom_microorganisms(
|
||||
#' data.frame(genus = "Enterobacter",
|
||||
#' species = "asburiae/cloacae"
|
||||
#' data.frame(
|
||||
#' genus = "Enterobacter",
|
||||
#' species = "asburiae/cloacae"
|
||||
#' )
|
||||
#' )
|
||||
#'
|
||||
#' # E. asburiae/cloacae is now a new microorganism:
|
||||
#' mo_name("Enterobacter asburiae/cloacae")
|
||||
#'
|
||||
#'
|
||||
#' # its code:
|
||||
#' as.mo("Enterobacter asburiae/cloacae")
|
||||
#'
|
||||
#'
|
||||
#' # all internal algorithms will work as well:
|
||||
#' mo_name("Ent asburia cloacae")
|
||||
#'
|
||||
#'
|
||||
#' # and even the taxonomy was added based on the genus!
|
||||
#' mo_family("E. asburiae/cloacae")
|
||||
#' mo_gramstain("Enterobacter asburiae/cloacae")
|
||||
#'
|
||||
#' mo_info("Enterobacter asburiae/cloacae")
|
||||
#'
|
||||
#'
|
||||
#'
|
||||
#'
|
||||
#' # the function tries to be forgiving:
|
||||
#' add_custom_microorganisms(
|
||||
#' data.frame(GENUS = "BACTEROIDES / PARABACTEROIDES SLASHLINE",
|
||||
#' SPECIES = "SPECIES")
|
||||
#' data.frame(
|
||||
#' GENUS = "BACTEROIDES / PARABACTEROIDES SLASHLINE",
|
||||
#' SPECIES = "SPECIES"
|
||||
#' )
|
||||
#' )
|
||||
#' mo_name("BACTEROIDES / PARABACTEROIDES")
|
||||
#' mo_rank("BACTEROIDES / PARABACTEROIDES")
|
||||
#'
|
||||
#'
|
||||
#' # taxonomy still works, although a slashline genus was given as input:
|
||||
#' mo_family("Bacteroides/Parabacteroides")
|
||||
#'
|
||||
#'
|
||||
#'
|
||||
#'
|
||||
#' # for groups and complexes, set them as species or subspecies:
|
||||
#' add_custom_microorganisms(
|
||||
#' data.frame(genus = "Citrobacter",
|
||||
#' species = c("freundii", "braakii complex"),
|
||||
#' subspecies = c("complex", ""))
|
||||
#' data.frame(
|
||||
#' genus = "Citrobacter",
|
||||
#' species = c("freundii", "braakii complex"),
|
||||
#' subspecies = c("complex", "")
|
||||
#' )
|
||||
#' )
|
||||
#' mo_name(c("C. freundii complex", "C. braakii complex"))
|
||||
#' mo_species(c("C. freundii complex", "C. braakii complex"))
|
||||
@ -123,9 +128,9 @@
|
||||
add_custom_microorganisms <- function(x) {
|
||||
meet_criteria(x, allow_class = "data.frame")
|
||||
stop_ifnot("genus" %in% tolower(colnames(x)), paste0("`x` must contain column 'genus'."))
|
||||
|
||||
|
||||
add_MO_lookup_to_AMR_env()
|
||||
|
||||
|
||||
# remove any extra class/type, such as grouped tbl, or data.table:
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||
colnames(x) <- tolower(colnames(x))
|
||||
@ -135,7 +140,7 @@ add_custom_microorganisms <- function(x) {
|
||||
}
|
||||
# keep only columns available in the microorganisms data set
|
||||
x <- x[, colnames(AMR_env$MO_lookup)[colnames(AMR_env$MO_lookup) %in% colnames(x)], drop = FALSE]
|
||||
|
||||
|
||||
# clean the input ----
|
||||
for (col in c("genus", "species", "subspecies")) {
|
||||
if (!col %in% colnames(x)) {
|
||||
@ -152,7 +157,7 @@ add_custom_microorganisms <- function(x) {
|
||||
col_ <- gsub(" *([/-]) *", "\\1", col_, perl = TRUE)
|
||||
# groups are in our taxonomic table with a capital G
|
||||
col_ <- gsub(" group( |$)", " Group\\1", col_, perl = TRUE)
|
||||
|
||||
|
||||
col_[is.na(col_)] <- ""
|
||||
if (col == "genus") {
|
||||
substr(col_, 1, 1) <- toupper(substr(col_, 1, 1))
|
||||
@ -163,19 +168,27 @@ add_custom_microorganisms <- function(x) {
|
||||
x[, col] <- col_
|
||||
}
|
||||
# if subspecies is a group or complex, add it to the species and empty the subspecies
|
||||
x$species[which(x$subspecies %in% c("group", "Group", "complex"))] <- paste(x$species[which(x$subspecies %in% c("group", "Group", "complex"))],
|
||||
x$subspecies[which(x$subspecies %in% c("group", "Group", "complex"))])
|
||||
x$species[which(x$subspecies %in% c("group", "Group", "complex"))] <- paste(
|
||||
x$species[which(x$subspecies %in% c("group", "Group", "complex"))],
|
||||
x$subspecies[which(x$subspecies %in% c("group", "Group", "complex"))]
|
||||
)
|
||||
x$subspecies[which(x$subspecies %in% c("group", "Group", "complex"))] <- ""
|
||||
|
||||
|
||||
if ("rank" %in% colnames(x)) {
|
||||
stop_ifnot(all(x$rank %in% AMR_env$MO_lookup$rank),
|
||||
"the 'rank' column can only contain these values: ", vector_or(AMR_env$MO_lookup$rank))
|
||||
stop_ifnot(
|
||||
all(x$rank %in% AMR_env$MO_lookup$rank),
|
||||
"the 'rank' column can only contain these values: ", vector_or(AMR_env$MO_lookup$rank)
|
||||
)
|
||||
} else {
|
||||
x$rank <- ifelse(x$subspecies != "", "subspecies",
|
||||
ifelse(x$species != "", "species",
|
||||
ifelse(x$genus != "", "genus",
|
||||
stop("in add_custom_microorganisms(): only microorganisms up to the genus level can be added",
|
||||
call. = FALSE))))
|
||||
ifelse(x$species != "", "species",
|
||||
ifelse(x$genus != "", "genus",
|
||||
stop("in add_custom_microorganisms(): only microorganisms up to the genus level can be added",
|
||||
call. = FALSE
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
}
|
||||
x$source <- "Added by user"
|
||||
if (!"fullname" %in% colnames(x)) {
|
||||
@ -191,7 +204,7 @@ add_custom_microorganisms <- function(x) {
|
||||
x$class[is.na(x$class)] <- ""
|
||||
x$order[is.na(x$order)] <- ""
|
||||
x$family[is.na(x$family)] <- ""
|
||||
|
||||
|
||||
for (col in colnames(x)) {
|
||||
if (is.factor(x[, col, drop = TRUE])) {
|
||||
x[, col] <- as.character(x[, col, drop = TRUE])
|
||||
@ -200,7 +213,7 @@ add_custom_microorganisms <- function(x) {
|
||||
x[, col] <- as.list(x[, col, drop = TRUE])
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# fill in taxonomy based on genus
|
||||
genus_to_check <- gsub("^(.*)[^a-zA-Z].*", "\\1", x$genus, perl = TRUE)
|
||||
x$kingdom[which(x$kingdom == "" & genus_to_check != "")] <- AMR_env$MO_lookup$kingdom[match(genus_to_check[which(x$kingdom == "" & genus_to_check != "")], AMR_env$MO_lookup$genus)]
|
||||
@ -208,7 +221,7 @@ add_custom_microorganisms <- function(x) {
|
||||
x$class[which(x$class == "" & genus_to_check != "")] <- AMR_env$MO_lookup$class[match(genus_to_check[which(x$class == "" & genus_to_check != "")], AMR_env$MO_lookup$genus)]
|
||||
x$order[which(x$order == "" & genus_to_check != "")] <- AMR_env$MO_lookup$order[match(genus_to_check[which(x$order == "" & genus_to_check != "")], AMR_env$MO_lookup$genus)]
|
||||
x$family[which(x$family == "" & genus_to_check != "")] <- AMR_env$MO_lookup$family[match(genus_to_check[which(x$family == "" & genus_to_check != "")], AMR_env$MO_lookup$genus)]
|
||||
|
||||
|
||||
# fill in other columns that are used in internal algorithms
|
||||
x$prevalence <- NA_real_
|
||||
x$prevalence[which(genus_to_check != "")] <- AMR_env$MO_lookup$prevalence[match(genus_to_check[which(genus_to_check != "")], AMR_env$MO_lookup$genus)]
|
||||
@ -222,7 +235,7 @@ add_custom_microorganisms <- function(x) {
|
||||
x$full_first <- substr(x$fullname_lower, 1, 1)
|
||||
x$species_first <- tolower(substr(x$species, 1, 1))
|
||||
x$subspecies_first <- tolower(substr(x$subspecies, 1, 1))
|
||||
|
||||
|
||||
if (!"mo" %in% colnames(x)) {
|
||||
# create the mo code
|
||||
x$mo <- NA_character_
|
||||
@ -230,19 +243,27 @@ add_custom_microorganisms <- function(x) {
|
||||
x$mo <- trimws2(as.character(x$mo))
|
||||
x$mo[x$mo == ""] <- NA_character_
|
||||
current <- sum(AMR_env$MO_lookup$source == "Added by user", na.rm = TRUE)
|
||||
x$mo[is.na(x$mo)] <- paste0("CUSTOM",
|
||||
seq.int(from = current + 1, to = current + nrow(x), by = 1),
|
||||
"_",
|
||||
toupper(unname(abbreviate(gsub(" +", " _ ",
|
||||
gsub("[^A-Za-z0-9-]", " ",
|
||||
trimws2(paste(x$genus, x$species, x$subspecies)))),
|
||||
minlength = 10))))
|
||||
x$mo[is.na(x$mo)] <- paste0(
|
||||
"CUSTOM",
|
||||
seq.int(from = current + 1, to = current + nrow(x), by = 1),
|
||||
"_",
|
||||
toupper(unname(abbreviate(
|
||||
gsub(
|
||||
" +", " _ ",
|
||||
gsub(
|
||||
"[^A-Za-z0-9-]", " ",
|
||||
trimws2(paste(x$genus, x$species, x$subspecies))
|
||||
)
|
||||
),
|
||||
minlength = 10
|
||||
)))
|
||||
)
|
||||
stop_if(anyDuplicated(c(as.character(AMR_env$MO_lookup$mo), x$mo)), "MO codes must be unique and not match existing MO codes of the AMR package")
|
||||
|
||||
|
||||
# add to package ----
|
||||
AMR_env$custom_mo_codes <- c(AMR_env$custom_mo_codes, x$mo)
|
||||
class(AMR_env$MO_lookup$mo) <- "character"
|
||||
|
||||
|
||||
new_df <- AMR_env$MO_lookup[0, , drop = FALSE][seq_len(NROW(x)), , drop = FALSE]
|
||||
rownames(new_df) <- NULL
|
||||
list_cols <- vapply(FUN.VALUE = logical(1), new_df, is.list)
|
||||
@ -254,10 +275,10 @@ add_custom_microorganisms <- function(x) {
|
||||
# assign new values
|
||||
new_df[, col] <- x[, col, drop = TRUE]
|
||||
}
|
||||
|
||||
|
||||
# clear previous coercions
|
||||
suppressMessages(mo_reset_session())
|
||||
|
||||
|
||||
AMR_env$MO_lookup <- unique(rbind(AMR_env$MO_lookup, new_df))
|
||||
class(AMR_env$MO_lookup$mo) <- c("mo", "character")
|
||||
if (nrow(x) <= 3) {
|
||||
@ -271,11 +292,11 @@ add_custom_microorganisms <- function(x) {
|
||||
#' @export
|
||||
clear_custom_microorganisms <- function() {
|
||||
n <- nrow(AMR_env$MO_lookup)
|
||||
|
||||
|
||||
# reset
|
||||
AMR_env$MO_lookup <- NULL
|
||||
add_MO_lookup_to_AMR_env()
|
||||
|
||||
|
||||
n2 <- nrow(AMR_env$MO_lookup)
|
||||
AMR_env$custom_mo_codes <- character(0)
|
||||
AMR_env$mo_previously_coerced <- AMR_env$mo_previously_coerced[which(AMR_env$mo_previously_coerced$mo %in% AMR_env$MO_lookup$mo), , drop = FALSE]
|
||||
|
10
R/data.R
10
R/data.R
@ -65,10 +65,10 @@
|
||||
#'
|
||||
#' ### Direct download
|
||||
#' Like all data sets in this package, these data sets are publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. Please visit [our website for the download links](https://msberends.github.io/AMR/articles/datasets.html). The actual files are of course available on [our GitHub repository](https://github.com/msberends/AMR/tree/main/data-raw).
|
||||
#' @source
|
||||
#'
|
||||
#' @source
|
||||
#'
|
||||
#' * World Health Organization (WHO) Collaborating Centre for Drug Statistics Methodology (WHOCC): <https://www.whocc.no/atc_ddd_index/>
|
||||
#'
|
||||
#'
|
||||
#' * `r TAXONOMY_VERSION$LOINC$citation` Accessed from <`r TAXONOMY_VERSION$LOINC$url`> on `r documentation_date(TAXONOMY_VERSION$LOINC$accessed_date)`.
|
||||
#'
|
||||
#' * European Commission Public Health PHARMACEUTICALS - COMMUNITY REGISTER: <https://ec.europa.eu/health/documents/community-register/html/reg_hum_atc.htm>
|
||||
@ -141,9 +141,9 @@
|
||||
#' * `r TAXONOMY_VERSION$GBIF$citation` Accessed from <`r TAXONOMY_VERSION$GBIF$url`> on `r documentation_date(TAXONOMY_VERSION$GBIF$accessed_date)`.
|
||||
#'
|
||||
#' * `r TAXONOMY_VERSION$SNOMED$citation` URL: <`r TAXONOMY_VERSION$SNOMED$url`>
|
||||
#'
|
||||
#'
|
||||
#' * Grimont *et al.* (2007). Antigenic Formulae of the Salmonella Serovars, 9th Edition. WHO Collaborating Centre for Reference and Research on *Salmonella* (WHOCC-SALM).
|
||||
#'
|
||||
#'
|
||||
#' * Bartlett *et al.* (2022). **A comprehensive list of bacterial pathogens infecting humans** *Microbiology* 168:001269; \doi{10.1099/mic.0.001269}
|
||||
#' @seealso [as.mo()], [mo_property()], [microorganisms.codes], [intrinsic_resistant]
|
||||
#' @examples
|
||||
|
14
R/disk.R
14
R/disk.R
@ -120,13 +120,13 @@ as.disk <- function(x, na.rm = FALSE) {
|
||||
vector_and(quotes = TRUE)
|
||||
cur_col <- get_current_column()
|
||||
warning_("in `as.disk()`: ", na_after - na_before, " result",
|
||||
ifelse(na_after - na_before > 1, "s", ""),
|
||||
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
|
||||
" truncated (",
|
||||
round(((na_after - na_before) / length(x)) * 100),
|
||||
"%) that were invalid disk zones: ",
|
||||
list_missing,
|
||||
call = FALSE
|
||||
ifelse(na_after - na_before > 1, "s", ""),
|
||||
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
|
||||
" truncated (",
|
||||
round(((na_after - na_before) / length(x)) * 100),
|
||||
"%) that were invalid disk zones: ",
|
||||
list_missing,
|
||||
call = FALSE
|
||||
)
|
||||
}
|
||||
}
|
||||
|
13
R/episode.R
13
R/episode.R
@ -57,11 +57,12 @@
|
||||
#' df[which(get_episode(df$date, 60) == 3), ]
|
||||
#'
|
||||
#' # the functions also work for less than a day, e.g. to include one per hour:
|
||||
#' get_episode(c(
|
||||
#' Sys.time(),
|
||||
#' Sys.time() + 60 * 60
|
||||
#' ),
|
||||
#' episode_days = 1 / 24
|
||||
#' get_episode(
|
||||
#' c(
|
||||
#' Sys.time(),
|
||||
#' Sys.time() + 60 * 60
|
||||
#' ),
|
||||
#' episode_days = 1 / 24
|
||||
#' )
|
||||
#'
|
||||
#' \donttest{
|
||||
@ -98,7 +99,6 @@
|
||||
#' )
|
||||
#' }
|
||||
#' if (require("dplyr")) {
|
||||
#'
|
||||
#' # grouping on patients and microorganisms leads to the same
|
||||
#' # results as first_isolate() when using 'episode-based':
|
||||
#' x <- df %>%
|
||||
@ -115,7 +115,6 @@
|
||||
#' identical(x, y)
|
||||
#' }
|
||||
#' if (require("dplyr")) {
|
||||
#'
|
||||
#' # but is_new_episode() has a lot more flexibility than first_isolate(),
|
||||
#' # since you can now group on anything that seems relevant:
|
||||
#' df %>%
|
||||
|
@ -702,11 +702,12 @@ eucast_rules <- function(x,
|
||||
# Print rule -------------------------------------------------------------
|
||||
if (rule_current != rule_previous) {
|
||||
# is new rule within group, print its name
|
||||
cat(italicise_taxonomy(word_wrap(rule_current,
|
||||
width = getOption("width") - 30,
|
||||
extra_indent = 6
|
||||
),
|
||||
type = "ansi"
|
||||
cat(italicise_taxonomy(
|
||||
word_wrap(rule_current,
|
||||
width = getOption("width") - 30,
|
||||
extra_indent = 6
|
||||
),
|
||||
type = "ansi"
|
||||
))
|
||||
warned <- FALSE
|
||||
}
|
||||
@ -721,21 +722,23 @@ eucast_rules <- function(x,
|
||||
if (mo_value %like% "coagulase" && any(x$genus == "Staphylococcus", na.rm = TRUE)) {
|
||||
if (mo_value %like% "negative") {
|
||||
eucast_rules_df[i, "this_value"] <- paste0(
|
||||
"^(", paste0(all_staph[which(all_staph$CNS_CPS %like% "negative"),
|
||||
"fullname",
|
||||
drop = TRUE
|
||||
],
|
||||
collapse = "|"
|
||||
"^(", paste0(
|
||||
all_staph[which(all_staph$CNS_CPS %like% "negative"),
|
||||
"fullname",
|
||||
drop = TRUE
|
||||
],
|
||||
collapse = "|"
|
||||
),
|
||||
")$"
|
||||
)
|
||||
} else {
|
||||
eucast_rules_df[i, "this_value"] <- paste0(
|
||||
"^(", paste0(all_staph[which(all_staph$CNS_CPS %like% "positive"),
|
||||
"fullname",
|
||||
drop = TRUE
|
||||
],
|
||||
collapse = "|"
|
||||
"^(", paste0(
|
||||
all_staph[which(all_staph$CNS_CPS %like% "positive"),
|
||||
"fullname",
|
||||
drop = TRUE
|
||||
],
|
||||
collapse = "|"
|
||||
),
|
||||
")$"
|
||||
)
|
||||
@ -745,11 +748,12 @@ eucast_rules <- function(x,
|
||||
# be sure to comprise all beta-haemolytic Streptococci (Lancefield groups A, B, C and G) when they are mentioned
|
||||
if (mo_value %like% "group [ABCG]" && any(x$genus == "Streptococcus", na.rm = TRUE)) {
|
||||
eucast_rules_df[i, "this_value"] <- paste0(
|
||||
"^(", paste0(all_strep[which(all_strep$Lancefield %like% "group [ABCG]"),
|
||||
"fullname",
|
||||
drop = TRUE
|
||||
],
|
||||
collapse = "|"
|
||||
"^(", paste0(
|
||||
all_strep[which(all_strep$Lancefield %like% "group [ABCG]"),
|
||||
"fullname",
|
||||
drop = TRUE
|
||||
],
|
||||
collapse = "|"
|
||||
),
|
||||
")$"
|
||||
)
|
||||
@ -789,15 +793,17 @@ eucast_rules <- function(x,
|
||||
if (length(source_antibiotics) == 0) {
|
||||
rows <- integer(0)
|
||||
} else if (length(source_antibiotics) == 1) {
|
||||
rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like% mo_value &
|
||||
as.sir_no_warning(x[, source_antibiotics[1L]]) == source_value[1L]),
|
||||
error = function(e) integer(0)
|
||||
rows <- tryCatch(
|
||||
which(x[, if_mo_property, drop = TRUE] %like% mo_value &
|
||||
as.sir_no_warning(x[, source_antibiotics[1L]]) == source_value[1L]),
|
||||
error = function(e) integer(0)
|
||||
)
|
||||
} else if (length(source_antibiotics) == 2) {
|
||||
rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like% mo_value &
|
||||
as.sir_no_warning(x[, source_antibiotics[1L]]) == source_value[1L] &
|
||||
as.sir_no_warning(x[, source_antibiotics[2L]]) == source_value[2L]),
|
||||
error = function(e) integer(0)
|
||||
rows <- tryCatch(
|
||||
which(x[, if_mo_property, drop = TRUE] %like% mo_value &
|
||||
as.sir_no_warning(x[, source_antibiotics[1L]]) == source_value[1L] &
|
||||
as.sir_no_warning(x[, source_antibiotics[2L]]) == source_value[2L]),
|
||||
error = function(e) integer(0)
|
||||
)
|
||||
# nolint start
|
||||
# } else if (length(source_antibiotics) == 3) {
|
||||
@ -872,11 +878,12 @@ eucast_rules <- function(x,
|
||||
)
|
||||
if (isTRUE(info)) {
|
||||
# print rule
|
||||
cat(italicise_taxonomy(word_wrap(format_custom_query_rule(rule$query, colours = FALSE),
|
||||
width = getOption("width") - 30,
|
||||
extra_indent = 6
|
||||
),
|
||||
type = "ansi"
|
||||
cat(italicise_taxonomy(
|
||||
word_wrap(format_custom_query_rule(rule$query, colours = FALSE),
|
||||
width = getOption("width") - 30,
|
||||
extra_indent = 6
|
||||
),
|
||||
type = "ansi"
|
||||
))
|
||||
warned <- FALSE
|
||||
}
|
||||
@ -1117,14 +1124,15 @@ edit_sir <- function(x,
|
||||
},
|
||||
error = function(e) {
|
||||
txt_error()
|
||||
stop(paste0(
|
||||
"In row(s) ", paste(rows[seq_len(min(length(rows), 10))], collapse = ","),
|
||||
ifelse(length(rows) > 10, "...", ""),
|
||||
" while writing value '", to,
|
||||
"' to column(s) `", paste(cols, collapse = "`, `"),
|
||||
"`:\n", e$message
|
||||
),
|
||||
call. = FALSE
|
||||
stop(
|
||||
paste0(
|
||||
"In row(s) ", paste(rows[seq_len(min(length(rows), 10))], collapse = ","),
|
||||
ifelse(length(rows) > 10, "...", ""),
|
||||
" while writing value '", to,
|
||||
"' to column(s) `", paste(cols, collapse = "`, `"),
|
||||
"`:\n", e$message
|
||||
),
|
||||
call. = FALSE
|
||||
)
|
||||
}
|
||||
)
|
||||
|
@ -144,13 +144,11 @@
|
||||
#' filter(first_isolate())
|
||||
#' }
|
||||
#' if (require("dplyr")) {
|
||||
#'
|
||||
#' # short-hand version:
|
||||
#' example_isolates %>%
|
||||
#' filter_first_isolate(info = FALSE)
|
||||
#' }
|
||||
#' if (require("dplyr")) {
|
||||
#'
|
||||
#' # flag the first isolates per group:
|
||||
#' example_isolates %>%
|
||||
#' group_by(ward) %>%
|
||||
@ -244,18 +242,19 @@ first_isolate <- function(x = NULL,
|
||||
method <- "episode-based"
|
||||
}
|
||||
if (isTRUE(info) && message_not_thrown_before("first_isolate", "method")) {
|
||||
message_(paste0(
|
||||
"Determining first isolates ",
|
||||
ifelse(method %in% c("episode-based", "phenotype-based"),
|
||||
ifelse(is.infinite(episode_days),
|
||||
"without a specified episode length",
|
||||
paste("using an episode length of", episode_days, "days")
|
||||
),
|
||||
""
|
||||
)
|
||||
),
|
||||
as_note = FALSE,
|
||||
add_fn = font_black
|
||||
message_(
|
||||
paste0(
|
||||
"Determining first isolates ",
|
||||
ifelse(method %in% c("episode-based", "phenotype-based"),
|
||||
ifelse(is.infinite(episode_days),
|
||||
"without a specified episode length",
|
||||
paste("using an episode length of", episode_days, "days")
|
||||
),
|
||||
""
|
||||
)
|
||||
),
|
||||
as_note = FALSE,
|
||||
add_fn = font_black
|
||||
)
|
||||
}
|
||||
|
||||
@ -469,15 +468,17 @@ first_isolate <- function(x = NULL,
|
||||
x$other_pat_or_mo <- !(x$newvar_patient_id == pm_lag(x$newvar_patient_id) & x$newvar_genus_species == pm_lag(x$newvar_genus_species))
|
||||
|
||||
x$episode_group <- paste(x$newvar_patient_id, x$newvar_genus_species)
|
||||
x$more_than_episode_ago <- unlist(lapply(split(
|
||||
x$newvar_date,
|
||||
x$episode_group
|
||||
),
|
||||
exec_episode, # this will skip meet_criteria() in is_new_episode(), saving time
|
||||
type = "logical",
|
||||
episode_days = episode_days
|
||||
),
|
||||
use.names = FALSE
|
||||
x$more_than_episode_ago <- unlist(
|
||||
lapply(
|
||||
split(
|
||||
x$newvar_date,
|
||||
x$episode_group
|
||||
),
|
||||
exec_episode, # this will skip meet_criteria() in is_new_episode(), saving time
|
||||
type = "logical",
|
||||
episode_days = episode_days
|
||||
),
|
||||
use.names = FALSE
|
||||
)
|
||||
|
||||
if (!is.null(col_keyantimicrobials)) {
|
||||
@ -606,21 +607,22 @@ first_isolate <- function(x = NULL,
|
||||
}
|
||||
# mark up number of found
|
||||
n_found <- format(n_found, big.mark = big.mark, decimal.mark = decimal.mark)
|
||||
message_(paste0(
|
||||
"=> Found ",
|
||||
font_bold(paste0(
|
||||
n_found,
|
||||
ifelse(method == "isolate-based", "", paste0(" '", method, "'")),
|
||||
" first isolates"
|
||||
)),
|
||||
" (",
|
||||
ifelse(p_found_total != p_found_scope,
|
||||
paste0(p_found_scope, " within scope and "),
|
||||
""
|
||||
message_(
|
||||
paste0(
|
||||
"=> Found ",
|
||||
font_bold(paste0(
|
||||
n_found,
|
||||
ifelse(method == "isolate-based", "", paste0(" '", method, "'")),
|
||||
" first isolates"
|
||||
)),
|
||||
" (",
|
||||
ifelse(p_found_total != p_found_scope,
|
||||
paste0(p_found_scope, " within scope and "),
|
||||
""
|
||||
),
|
||||
p_found_total, " of total where a microbial ID was available)"
|
||||
),
|
||||
p_found_total, " of total where a microbial ID was available)"
|
||||
),
|
||||
add_fn = font_black, as_note = FALSE
|
||||
add_fn = font_black, as_note = FALSE
|
||||
)
|
||||
}
|
||||
|
||||
|
@ -414,13 +414,14 @@ pca_calculations <- function(pca_model,
|
||||
sigma <- var(cbind(x$xvar, x$yvar))
|
||||
mu <- c(mean(x$xvar), mean(x$yvar))
|
||||
ed <- sqrt(qchisq(ellipse_prob, df = 2))
|
||||
data.frame(sweep(circle %*% chol(sigma) * ed,
|
||||
MARGIN = 2,
|
||||
STATS = mu,
|
||||
FUN = "+"
|
||||
),
|
||||
groups = x$groups[1],
|
||||
stringsAsFactors = FALSE
|
||||
data.frame(
|
||||
sweep(circle %*% chol(sigma) * ed,
|
||||
MARGIN = 2,
|
||||
STATS = mu,
|
||||
FUN = "+"
|
||||
),
|
||||
groups = x$groups[1],
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
})
|
||||
ell <- do.call(rbind, df.groups)
|
||||
|
@ -71,13 +71,11 @@
|
||||
#' @examples
|
||||
#' \donttest{
|
||||
#' if (require("ggplot2") && require("dplyr")) {
|
||||
#'
|
||||
#' # get antimicrobial results for drugs against a UTI:
|
||||
#' ggplot(example_isolates %>% select(AMX, NIT, FOS, TMP, CIP)) +
|
||||
#' geom_sir()
|
||||
#' }
|
||||
#' if (require("ggplot2") && require("dplyr")) {
|
||||
#'
|
||||
#' # prettify the plot using some additional functions:
|
||||
#' df <- example_isolates %>% select(AMX, NIT, FOS, TMP, CIP)
|
||||
#' ggplot(df) +
|
||||
@ -88,21 +86,18 @@
|
||||
#' theme_sir()
|
||||
#' }
|
||||
#' if (require("ggplot2") && require("dplyr")) {
|
||||
#'
|
||||
#' # or better yet, simplify this using the wrapper function - a single command:
|
||||
#' example_isolates %>%
|
||||
#' select(AMX, NIT, FOS, TMP, CIP) %>%
|
||||
#' ggplot_sir()
|
||||
#' }
|
||||
#' if (require("ggplot2") && require("dplyr")) {
|
||||
#'
|
||||
#' # get only proportions and no counts:
|
||||
#' example_isolates %>%
|
||||
#' select(AMX, NIT, FOS, TMP, CIP) %>%
|
||||
#' ggplot_sir(datalabels = FALSE)
|
||||
#' }
|
||||
#' if (require("ggplot2") && require("dplyr")) {
|
||||
#'
|
||||
#' # add other ggplot2 arguments as you like:
|
||||
#' example_isolates %>%
|
||||
#' select(AMX, NIT, FOS, TMP, CIP) %>%
|
||||
@ -115,14 +110,12 @@
|
||||
#' )
|
||||
#' }
|
||||
#' if (require("ggplot2") && require("dplyr")) {
|
||||
#'
|
||||
#' # you can alter the colours with colour names:
|
||||
#' example_isolates %>%
|
||||
#' select(AMX) %>%
|
||||
#' ggplot_sir(colours = c(SI = "yellow"))
|
||||
#' }
|
||||
#' if (require("ggplot2") && require("dplyr")) {
|
||||
#'
|
||||
#' # but you can also use the built-in colour-blind friendly colours for
|
||||
#' # your plots, where "S" is green, "I" is yellow and "R" is red:
|
||||
#' data.frame(
|
||||
@ -135,7 +128,6 @@
|
||||
#' scale_sir_colours(Value4 = "S", Value5 = "I", Value6 = "R")
|
||||
#' }
|
||||
#' if (require("ggplot2") && require("dplyr")) {
|
||||
#'
|
||||
#' # resistance of ciprofloxacine per age group
|
||||
#' example_isolates %>%
|
||||
#' mutate(first_isolate = first_isolate()) %>%
|
||||
@ -149,14 +141,12 @@
|
||||
#' ggplot_sir(x = "age_group")
|
||||
#' }
|
||||
#' if (require("ggplot2") && require("dplyr")) {
|
||||
#'
|
||||
#' # a shorter version which also adjusts data label colours:
|
||||
#' example_isolates %>%
|
||||
#' select(AMX, NIT, FOS, TMP, CIP) %>%
|
||||
#' ggplot_sir(colours = FALSE)
|
||||
#' }
|
||||
#' if (require("ggplot2") && require("dplyr")) {
|
||||
#'
|
||||
#' # it also supports groups (don't forget to use the group var on `x` or `facet`):
|
||||
#' example_isolates %>%
|
||||
#' filter(mo_is_gram_negative(), ward != "Outpatient") %>%
|
||||
|
@ -274,14 +274,15 @@ get_column_abx <- function(x,
|
||||
}
|
||||
if (names(out[i]) %in% names(duplicates)) {
|
||||
already_set_as <- out[unname(out) == unname(out[i])][1L]
|
||||
warning_(paste0(
|
||||
"Column '", font_bold(out[i]), "' will not be used for ",
|
||||
names(out)[i], " (", ab_name(names(out)[i], tolower = TRUE, language = NULL), ")",
|
||||
", as it is already set for ",
|
||||
names(already_set_as), " (", ab_name(names(already_set_as), tolower = TRUE, language = NULL), ")"
|
||||
),
|
||||
add_fn = font_red,
|
||||
immediate = verbose
|
||||
warning_(
|
||||
paste0(
|
||||
"Column '", font_bold(out[i]), "' will not be used for ",
|
||||
names(out)[i], " (", ab_name(names(out)[i], tolower = TRUE, language = NULL), ")",
|
||||
", as it is already set for ",
|
||||
names(already_set_as), " (", ab_name(names(already_set_as), tolower = TRUE, language = NULL), ")"
|
||||
),
|
||||
add_fn = font_red,
|
||||
immediate = verbose
|
||||
)
|
||||
}
|
||||
}
|
||||
@ -307,11 +308,12 @@ get_column_abx <- function(x,
|
||||
if (isTRUE(info) && !all(soft_dependencies %in% names(out))) {
|
||||
# missing a soft dependency may lower the reliability
|
||||
missing <- soft_dependencies[!soft_dependencies %in% names(out)]
|
||||
missing_msg <- vector_and(paste0(
|
||||
ab_name(missing, tolower = TRUE, language = NULL),
|
||||
" (", font_bold(missing, collapse = NULL), ")"
|
||||
),
|
||||
quotes = FALSE
|
||||
missing_msg <- vector_and(
|
||||
paste0(
|
||||
ab_name(missing, tolower = TRUE, language = NULL),
|
||||
" (", font_bold(missing, collapse = NULL), ")"
|
||||
),
|
||||
quotes = FALSE
|
||||
)
|
||||
message_(
|
||||
"Reliability would be improved if these antimicrobial results would be available too: ",
|
||||
@ -355,10 +357,11 @@ generate_warning_abs_missing <- function(missing, any = FALSE) {
|
||||
} else {
|
||||
any_txt <- c("", "are")
|
||||
}
|
||||
warning_(paste0(
|
||||
"Introducing NAs since", any_txt[1], " these antimicrobials ", any_txt[2], " required: ",
|
||||
vector_and(missing, quotes = FALSE)
|
||||
),
|
||||
immediate = TRUE
|
||||
warning_(
|
||||
paste0(
|
||||
"Introducing NAs since", any_txt[1], " these antimicrobials ", any_txt[2], " required: ",
|
||||
vector_and(missing, quotes = FALSE)
|
||||
),
|
||||
immediate = TRUE
|
||||
)
|
||||
}
|
||||
|
@ -73,41 +73,44 @@ italicise_taxonomy <- function(string, type = c("markdown", "ansi")) {
|
||||
search_strings <- gsub("[^a-zA-Z-]", "", s_split)
|
||||
|
||||
ind_species <- search_strings != "" &
|
||||
search_strings %in% AMR_env$MO_lookup[which(AMR_env$MO_lookup$rank %in% c(
|
||||
"family",
|
||||
"genus",
|
||||
search_strings %in% AMR_env$MO_lookup[
|
||||
which(AMR_env$MO_lookup$rank %in% c(
|
||||
"family",
|
||||
"genus",
|
||||
"species",
|
||||
"subspecies",
|
||||
"infraspecies",
|
||||
"subsp."
|
||||
)),
|
||||
"species",
|
||||
"subspecies",
|
||||
"infraspecies",
|
||||
"subsp."
|
||||
)),
|
||||
"species",
|
||||
drop = TRUE
|
||||
drop = TRUE
|
||||
]
|
||||
|
||||
ind_fullname <- search_strings != "" &
|
||||
search_strings %in% c(
|
||||
AMR_env$MO_lookup[which(AMR_env$MO_lookup$rank %in% c(
|
||||
"family",
|
||||
"genus",
|
||||
"species",
|
||||
"subspecies",
|
||||
"infraspecies",
|
||||
"subsp."
|
||||
)),
|
||||
"fullname",
|
||||
drop = TRUE
|
||||
AMR_env$MO_lookup[
|
||||
which(AMR_env$MO_lookup$rank %in% c(
|
||||
"family",
|
||||
"genus",
|
||||
"species",
|
||||
"subspecies",
|
||||
"infraspecies",
|
||||
"subsp."
|
||||
)),
|
||||
"fullname",
|
||||
drop = TRUE
|
||||
],
|
||||
AMR_env$MO_lookup[which(AMR_env$MO_lookup$rank %in% c(
|
||||
"family",
|
||||
"genus",
|
||||
"species",
|
||||
AMR_env$MO_lookup[
|
||||
which(AMR_env$MO_lookup$rank %in% c(
|
||||
"family",
|
||||
"genus",
|
||||
"species",
|
||||
"subspecies",
|
||||
"infraspecies",
|
||||
"subsp."
|
||||
)),
|
||||
"subspecies",
|
||||
"infraspecies",
|
||||
"subsp."
|
||||
)),
|
||||
"subspecies",
|
||||
drop = TRUE
|
||||
drop = TRUE
|
||||
]
|
||||
)
|
||||
|
||||
|
@ -128,7 +128,7 @@ anti_join_microorganisms <- function(x, by = NULL, ...) {
|
||||
|
||||
join_microorganisms <- function(type, x, by, suffix, ...) {
|
||||
add_MO_lookup_to_AMR_env()
|
||||
|
||||
|
||||
if (!is.data.frame(x)) {
|
||||
if (pkg_is_available("tibble", also_load = FALSE)) {
|
||||
x <- import_fn("tibble", "tibble")(mo = x)
|
||||
|
448
R/mdro.R
448
R/mdro.R
@ -193,17 +193,17 @@ mdro <- function(x = NULL,
|
||||
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(verbose, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
|
||||
|
||||
|
||||
if (!any(is_sir_eligible(x))) {
|
||||
stop_("There were no possible SIR columns found in the data set. Transform columns with `as.sir()` for valid antimicrobial interpretations.")
|
||||
}
|
||||
|
||||
|
||||
info.bak <- info
|
||||
# don't thrown info's more than once per call
|
||||
if (isTRUE(info)) {
|
||||
info <- message_not_thrown_before("mdro")
|
||||
}
|
||||
|
||||
|
||||
if (interactive() && isTRUE(verbose) && isTRUE(info)) {
|
||||
txt <- paste0(
|
||||
"WARNING: In Verbose mode, the mdro() function does not return the MDRO results, but instead returns a data set in logbook form with extensive info about which isolates would be MDRO-positive, or why they are not.",
|
||||
@ -221,7 +221,7 @@ mdro <- function(x = NULL,
|
||||
return(x)
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
group_msg <- ""
|
||||
if (isTRUE(info.bak)) {
|
||||
# print group name if used in dplyr::group_by()
|
||||
@ -243,15 +243,15 @@ mdro <- function(x = NULL,
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# force regular [data.frame], not a tibble or data.table
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||
|
||||
|
||||
if (pct_required_classes > 1) {
|
||||
# allow pct_required_classes = 75 -> pct_required_classes = 0.75
|
||||
pct_required_classes <- pct_required_classes / 100
|
||||
}
|
||||
|
||||
|
||||
guideline.bak <- guideline
|
||||
if (is.list(guideline)) {
|
||||
# Custom MDRO guideline ---------------------------------------------------
|
||||
@ -260,8 +260,8 @@ mdro <- function(x = NULL,
|
||||
txt <- paste0(
|
||||
"Determining MDROs based on custom rules",
|
||||
ifelse(isTRUE(attributes(guideline)$as_factor),
|
||||
paste0(", resulting in factor levels: ", paste0(attributes(guideline)$values, collapse = " < ")),
|
||||
""
|
||||
paste0(", resulting in factor levels: ", paste0(attributes(guideline)$values, collapse = " < ")),
|
||||
""
|
||||
),
|
||||
"."
|
||||
)
|
||||
@ -314,7 +314,7 @@ mdro <- function(x = NULL,
|
||||
"invalid guideline: ", guideline.bak
|
||||
)
|
||||
guideline <- list(code = guideline)
|
||||
|
||||
|
||||
# try to find columns based on type
|
||||
# -- mo
|
||||
if (is.null(col_mo)) {
|
||||
@ -329,7 +329,7 @@ mdro <- function(x = NULL,
|
||||
col_mo <- "mo"
|
||||
}
|
||||
stop_if(is.null(col_mo), "`col_mo` must be set")
|
||||
|
||||
|
||||
if (guideline$code == "cmi2012") {
|
||||
guideline$name <- "Multidrug-resistant, extensively drug-resistant and pandrug-resistant bacteria: an international expert proposal for interim standard definitions for acquired resistance."
|
||||
guideline$author <- "Magiorakos AP, Srinivasan A, Carey RB, ..., Vatopoulos A, Weber JT, Monnet DL"
|
||||
@ -360,7 +360,7 @@ mdro <- function(x = NULL,
|
||||
guideline$version <- "WHO/HTM/TB/2014.11, 2014"
|
||||
guideline$source_url <- font_url("https://www.who.int/publications/i/item/9789241548809", "Direct download")
|
||||
guideline$type <- "MDR-TB's"
|
||||
|
||||
|
||||
# support per country:
|
||||
} else if (guideline$code == "mrgn") {
|
||||
guideline$name <- "Cross-border comparison of the Dutch and German guidelines on multidrug-resistant Gram-negative microorganisms"
|
||||
@ -377,7 +377,7 @@ mdro <- function(x = NULL,
|
||||
} else {
|
||||
stop("This guideline is currently unsupported: ", guideline$code, call. = FALSE)
|
||||
}
|
||||
|
||||
|
||||
if (guideline$code == "cmi2012") {
|
||||
cols_ab <- get_column_abx(
|
||||
x = x,
|
||||
@ -456,7 +456,7 @@ mdro <- function(x = NULL,
|
||||
}
|
||||
cols_ab <- c(cols_ab, c(AMP = unname(cols_ab[names(cols_ab) == "AMX"])))
|
||||
}
|
||||
|
||||
|
||||
# nolint start
|
||||
AMC <- cols_ab["AMC"]
|
||||
AMK <- cols_ab["AMK"]
|
||||
@ -601,13 +601,13 @@ mdro <- function(x = NULL,
|
||||
abx_tb <- abx_tb[!is.na(abx_tb)]
|
||||
stop_if(guideline$code == "tb" & length(abx_tb) == 0, "no antimycobacterials found in data set")
|
||||
# nolint end
|
||||
|
||||
|
||||
if (isTRUE(combine_SI)) {
|
||||
search_result <- "R"
|
||||
} else {
|
||||
search_result <- c("R", "I")
|
||||
}
|
||||
|
||||
|
||||
if (isTRUE(info)) {
|
||||
if (isTRUE(combine_SI)) {
|
||||
cat(font_red("\nOnly results with 'R' are considered as resistance. Use `combine_SI = FALSE` to also consider 'I' as resistance.\n"))
|
||||
@ -615,18 +615,18 @@ mdro <- function(x = NULL,
|
||||
cat(font_red("\nResults with 'R' or 'I' are considered as resistance. Use `combine_SI = TRUE` to only consider 'R' as resistance.\n"))
|
||||
}
|
||||
cat("\n", word_wrap("Determining multidrug-resistant organisms (MDRO), according to:"), "\n",
|
||||
word_wrap(paste0(font_bold("Guideline: "), font_italic(guideline$name)), extra_indent = 11, as_note = FALSE), "\n",
|
||||
word_wrap(paste0(font_bold("Author(s): "), guideline$author), extra_indent = 11, as_note = FALSE), "\n",
|
||||
ifelse(!is.na(guideline$version),
|
||||
paste0(word_wrap(paste0(font_bold("Version: "), guideline$version), extra_indent = 11, as_note = FALSE), "\n"),
|
||||
""
|
||||
),
|
||||
paste0(font_bold("Source: "), guideline$source_url),
|
||||
"\n\n",
|
||||
sep = ""
|
||||
word_wrap(paste0(font_bold("Guideline: "), font_italic(guideline$name)), extra_indent = 11, as_note = FALSE), "\n",
|
||||
word_wrap(paste0(font_bold("Author(s): "), guideline$author), extra_indent = 11, as_note = FALSE), "\n",
|
||||
ifelse(!is.na(guideline$version),
|
||||
paste0(word_wrap(paste0(font_bold("Version: "), guideline$version), extra_indent = 11, as_note = FALSE), "\n"),
|
||||
""
|
||||
),
|
||||
paste0(font_bold("Source: "), guideline$source_url),
|
||||
"\n\n",
|
||||
sep = ""
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
ab_missing <- function(ab) {
|
||||
isTRUE(ab %in% c(NULL, NA)) | length(ab) == 0
|
||||
}
|
||||
@ -638,7 +638,7 @@ mdro <- function(x = NULL,
|
||||
out[is.na(out)] <- FALSE
|
||||
out
|
||||
}
|
||||
|
||||
|
||||
# antibiotic classes
|
||||
# nolint start
|
||||
aminoglycosides <- c(TOB, GEN)
|
||||
@ -649,17 +649,18 @@ mdro <- function(x = NULL,
|
||||
carbapenems <- c(DOR, ETP, IPM, MEM, MEV)
|
||||
fluoroquinolones <- c(CIP, ENX, FLE, GAT, GEM, GRX, LVX, LOM, MFX, NOR, OFX, PAZ, PEF, PRU, RFL, SPX, TMX, TVA)
|
||||
# nolint end
|
||||
|
||||
|
||||
# helper function for editing the table
|
||||
trans_tbl <- function(to, rows, cols, any_all) {
|
||||
cols <- cols[!ab_missing(cols)]
|
||||
cols <- cols[!is.na(cols)]
|
||||
if (length(rows) > 0 && length(cols) > 0) {
|
||||
x[, cols] <- as.data.frame(lapply(
|
||||
x[, cols, drop = FALSE],
|
||||
function(col) as.sir(col)
|
||||
),
|
||||
stringsAsFactors = FALSE
|
||||
x[, cols] <- as.data.frame(
|
||||
lapply(
|
||||
x[, cols, drop = FALSE],
|
||||
function(col) as.sir(col)
|
||||
),
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
x[rows, "columns_nonsusceptible"] <<- vapply(
|
||||
FUN.VALUE = character(1),
|
||||
@ -670,22 +671,23 @@ mdro <- function(x = NULL,
|
||||
x[row, group_vct, drop = FALSE],
|
||||
function(y) y %in% search_result
|
||||
)
|
||||
paste(sort(c(
|
||||
unlist(strsplit(x[row, "columns_nonsusceptible", drop = TRUE], ", ", fixed = TRUE)),
|
||||
names(cols_nonsus)[cols_nonsus]
|
||||
)),
|
||||
collapse = ", "
|
||||
paste(
|
||||
sort(c(
|
||||
unlist(strsplit(x[row, "columns_nonsusceptible", drop = TRUE], ", ", fixed = TRUE)),
|
||||
names(cols_nonsus)[cols_nonsus]
|
||||
)),
|
||||
collapse = ", "
|
||||
)
|
||||
}
|
||||
)
|
||||
|
||||
|
||||
if (any_all == "any") {
|
||||
search_function <- any
|
||||
} else if (any_all == "all") {
|
||||
search_function <- all
|
||||
}
|
||||
x_transposed <- as.list(as.data.frame(t(x[, cols, drop = FALSE]),
|
||||
stringsAsFactors = FALSE
|
||||
stringsAsFactors = FALSE
|
||||
))
|
||||
rows_affected <- vapply(
|
||||
FUN.VALUE = logical(1),
|
||||
@ -704,7 +706,7 @@ mdro <- function(x = NULL,
|
||||
)
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
trans_tbl2 <- function(txt, rows, lst) {
|
||||
if (isTRUE(info)) {
|
||||
message_(txt, "...", appendLF = FALSE, as_note = FALSE)
|
||||
@ -714,12 +716,13 @@ mdro <- function(x = NULL,
|
||||
lst_vector <- unlist(lst)[!is.na(unlist(lst))]
|
||||
# keep only unique ones:
|
||||
lst_vector <- lst_vector[!duplicated(paste(lst_vector, names(lst_vector)))]
|
||||
|
||||
x[, lst_vector] <- as.data.frame(lapply(
|
||||
x[, lst_vector, drop = FALSE],
|
||||
function(col) as.sir(col)
|
||||
),
|
||||
stringsAsFactors = FALSE
|
||||
|
||||
x[, lst_vector] <- as.data.frame(
|
||||
lapply(
|
||||
x[, lst_vector, drop = FALSE],
|
||||
function(col) as.sir(col)
|
||||
),
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
x[rows, "classes_in_guideline"] <<- length(lst)
|
||||
x[rows, "classes_available"] <<- vapply(
|
||||
@ -733,7 +736,7 @@ mdro <- function(x = NULL,
|
||||
))
|
||||
}
|
||||
)
|
||||
|
||||
|
||||
if (isTRUE(verbose)) {
|
||||
x[rows, "columns_nonsusceptible"] <<- vapply(
|
||||
FUN.VALUE = character(1),
|
||||
@ -748,30 +751,31 @@ mdro <- function(x = NULL,
|
||||
FUN.VALUE = double(1),
|
||||
rows,
|
||||
function(row, group_tbl = lst) {
|
||||
sum(vapply(
|
||||
FUN.VALUE = logical(1),
|
||||
group_tbl,
|
||||
function(group) {
|
||||
any(unlist(x[row, group[!is.na(group)], drop = TRUE]) %in% search_result, na.rm = TRUE)
|
||||
}
|
||||
),
|
||||
na.rm = TRUE
|
||||
sum(
|
||||
vapply(
|
||||
FUN.VALUE = logical(1),
|
||||
group_tbl,
|
||||
function(group) {
|
||||
any(unlist(x[row, group[!is.na(group)], drop = TRUE]) %in% search_result, na.rm = TRUE)
|
||||
}
|
||||
),
|
||||
na.rm = TRUE
|
||||
)
|
||||
}
|
||||
)
|
||||
# for PDR; all drugs are R (or I if combine_SI = FALSE)
|
||||
x_transposed <- as.list(as.data.frame(t(x[rows, lst_vector, drop = FALSE]),
|
||||
stringsAsFactors = FALSE
|
||||
stringsAsFactors = FALSE
|
||||
))
|
||||
row_filter <- vapply(FUN.VALUE = logical(1), x_transposed, function(y) all(y %in% search_result, na.rm = TRUE))
|
||||
x[which(row_filter), "classes_affected"] <<- 999
|
||||
}
|
||||
|
||||
|
||||
if (isTRUE(info)) {
|
||||
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
x[, col_mo] <- as.mo(as.character(x[, col_mo, drop = TRUE]))
|
||||
# rename col_mo to prevent interference with joined columns
|
||||
colnames(x)[colnames(x) == col_mo] <- ".col_mo"
|
||||
@ -782,12 +786,12 @@ mdro <- function(x = NULL,
|
||||
x$row_number <- seq_len(nrow(x))
|
||||
x$reason <- paste0("not covered by ", toupper(guideline$code), " guideline")
|
||||
x$columns_nonsusceptible <- ""
|
||||
|
||||
|
||||
if (guideline$code == "cmi2012") {
|
||||
# CMI, 2012 ---------------------------------------------------------------
|
||||
# Non-susceptible = R and I
|
||||
# (see header 'Approaches to Creating Definitions for MDR, XDR and PDR' in paper)
|
||||
|
||||
|
||||
# take amoxicillin if ampicillin is unavailable
|
||||
if (is.na(AMP) && !is.na(AMX)) {
|
||||
if (isTRUE(verbose)) {
|
||||
@ -808,87 +812,87 @@ mdro <- function(x = NULL,
|
||||
}
|
||||
CTX <- CRO
|
||||
}
|
||||
|
||||
|
||||
# intrinsic resistant must not be considered for the determination of MDR,
|
||||
# so let's just remove them, meticulously following the paper
|
||||
x[which(x$genus == "Enterococcus" & x$species == "faecium"), ab_NA(IPM)] <- NA
|
||||
x[which(x$genus == "Enterococcus" & x$species == "faecalis"), ab_NA(QDA)] <- NA
|
||||
x[which((x$genus == "Providencia" & x$species == "rettgeri") |
|
||||
(x$genus == "Providencia" & x$species == "stuartii")), ab_NA(c(GEN, TOB, NET))] <- NA
|
||||
(x$genus == "Providencia" & x$species == "stuartii")), ab_NA(c(GEN, TOB, NET))] <- NA
|
||||
x[which(x$genus == "Escherichia" & x$species == "hermannii"), ab_NA(c(TCC, TZP))] <- NA
|
||||
x[which((x$genus == "Citrobacter" & x$species == "freundii") |
|
||||
(x$genus == "Enterobacter" & x$species == "aerogenes") |
|
||||
(x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017)
|
||||
| (x$genus == "Enterobacter" & x$species == "cloacae") |
|
||||
(x$genus == "Hafnia" & x$species == "alvei") |
|
||||
(x$genus == "Morganella" & x$species == "morganii") |
|
||||
(x$genus == "Proteus" & x$species == "penneri") |
|
||||
(x$genus == "Proteus" & x$species == "vulgaris") |
|
||||
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(CZO)] <- NA
|
||||
(x$genus == "Enterobacter" & x$species == "aerogenes") |
|
||||
(x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017)
|
||||
| (x$genus == "Enterobacter" & x$species == "cloacae") |
|
||||
(x$genus == "Hafnia" & x$species == "alvei") |
|
||||
(x$genus == "Morganella" & x$species == "morganii") |
|
||||
(x$genus == "Proteus" & x$species == "penneri") |
|
||||
(x$genus == "Proteus" & x$species == "vulgaris") |
|
||||
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(CZO)] <- NA
|
||||
x[which((x$genus == "Morganella" & x$species == "morganii") |
|
||||
(x$genus == "Proteus" & x$species == "penneri") |
|
||||
(x$genus == "Proteus" & x$species == "vulgaris") |
|
||||
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(CXM)] <- NA
|
||||
(x$genus == "Proteus" & x$species == "penneri") |
|
||||
(x$genus == "Proteus" & x$species == "vulgaris") |
|
||||
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(CXM)] <- NA
|
||||
x[which((x$genus == "Morganella" & x$species == "morganii") |
|
||||
(x$genus == "Proteus" & x$species == "mirabilis") |
|
||||
(x$genus == "Proteus" & x$species == "penneri") |
|
||||
(x$genus == "Proteus" & x$species == "vulgaris") |
|
||||
(x$genus == "Providencia" & x$species == "rettgeri") |
|
||||
(x$genus == "Providencia" & x$species == "stuartii")), ab_NA(TGC)] <- NA
|
||||
(x$genus == "Proteus" & x$species == "mirabilis") |
|
||||
(x$genus == "Proteus" & x$species == "penneri") |
|
||||
(x$genus == "Proteus" & x$species == "vulgaris") |
|
||||
(x$genus == "Providencia" & x$species == "rettgeri") |
|
||||
(x$genus == "Providencia" & x$species == "stuartii")), ab_NA(TGC)] <- NA
|
||||
x[which((x$genus == "Citrobacter" & x$species == "koseri") |
|
||||
(x$genus == "Citrobacter" & x$species == "freundii") |
|
||||
(x$genus == "Enterobacter" & x$species == "aerogenes") |
|
||||
(x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017)
|
||||
| (x$genus == "Enterobacter" & x$species == "cloacae") |
|
||||
(x$genus == "Escherichia" & x$species == "hermannii") |
|
||||
(x$genus == "Hafnia" & x$species == "alvei") |
|
||||
(x$genus == "Klebsiella") |
|
||||
(x$genus == "Morganella" & x$species == "morganii") |
|
||||
(x$genus == "Proteus" & x$species == "penneri") |
|
||||
(x$genus == "Proteus" & x$species == "vulgaris") |
|
||||
(x$genus == "Providencia" & x$species == "rettgeri") |
|
||||
(x$genus == "Providencia" & x$species == "stuartii") |
|
||||
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(AMP)] <- NA
|
||||
(x$genus == "Citrobacter" & x$species == "freundii") |
|
||||
(x$genus == "Enterobacter" & x$species == "aerogenes") |
|
||||
(x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017)
|
||||
| (x$genus == "Enterobacter" & x$species == "cloacae") |
|
||||
(x$genus == "Escherichia" & x$species == "hermannii") |
|
||||
(x$genus == "Hafnia" & x$species == "alvei") |
|
||||
(x$genus == "Klebsiella") |
|
||||
(x$genus == "Morganella" & x$species == "morganii") |
|
||||
(x$genus == "Proteus" & x$species == "penneri") |
|
||||
(x$genus == "Proteus" & x$species == "vulgaris") |
|
||||
(x$genus == "Providencia" & x$species == "rettgeri") |
|
||||
(x$genus == "Providencia" & x$species == "stuartii") |
|
||||
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(AMP)] <- NA
|
||||
x[which((x$genus == "Citrobacter" & x$species == "freundii") |
|
||||
(x$genus == "Enterobacter" & x$species == "aerogenes") |
|
||||
(x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017)
|
||||
| (x$genus == "Enterobacter" & x$species == "cloacae") |
|
||||
(x$genus == "Hafnia" & x$species == "alvei") |
|
||||
(x$genus == "Morganella" & x$species == "morganii") |
|
||||
(x$genus == "Providencia" & x$species == "rettgeri") |
|
||||
(x$genus == "Providencia" & x$species == "stuartii") |
|
||||
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(AMC)] <- NA
|
||||
(x$genus == "Enterobacter" & x$species == "aerogenes") |
|
||||
(x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017)
|
||||
| (x$genus == "Enterobacter" & x$species == "cloacae") |
|
||||
(x$genus == "Hafnia" & x$species == "alvei") |
|
||||
(x$genus == "Morganella" & x$species == "morganii") |
|
||||
(x$genus == "Providencia" & x$species == "rettgeri") |
|
||||
(x$genus == "Providencia" & x$species == "stuartii") |
|
||||
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(AMC)] <- NA
|
||||
x[which((x$genus == "Citrobacter" & x$species == "freundii") |
|
||||
(x$genus == "Citrobacter" & x$species == "koseri") |
|
||||
(x$genus == "Enterobacter" & x$species == "aerogenes") |
|
||||
(x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017)
|
||||
| (x$genus == "Enterobacter" & x$species == "cloacae") |
|
||||
(x$genus == "Hafnia" & x$species == "alvei") |
|
||||
(x$genus == "Providencia" & x$species == "rettgeri") |
|
||||
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(SAM)] <- NA
|
||||
(x$genus == "Citrobacter" & x$species == "koseri") |
|
||||
(x$genus == "Enterobacter" & x$species == "aerogenes") |
|
||||
(x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017)
|
||||
| (x$genus == "Enterobacter" & x$species == "cloacae") |
|
||||
(x$genus == "Hafnia" & x$species == "alvei") |
|
||||
(x$genus == "Providencia" & x$species == "rettgeri") |
|
||||
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(SAM)] <- NA
|
||||
x[which((x$genus == "Morganella" & x$species == "morganii") |
|
||||
(x$genus == "Proteus" & x$species == "mirabilis") |
|
||||
(x$genus == "Proteus" & x$species == "penneri") |
|
||||
(x$genus == "Proteus" & x$species == "vulgaris") |
|
||||
(x$genus == "Providencia" & x$species == "rettgeri") |
|
||||
(x$genus == "Providencia" & x$species == "stuartii") |
|
||||
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(COL)] <- NA
|
||||
(x$genus == "Proteus" & x$species == "mirabilis") |
|
||||
(x$genus == "Proteus" & x$species == "penneri") |
|
||||
(x$genus == "Proteus" & x$species == "vulgaris") |
|
||||
(x$genus == "Providencia" & x$species == "rettgeri") |
|
||||
(x$genus == "Providencia" & x$species == "stuartii") |
|
||||
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(COL)] <- NA
|
||||
x[which((x$genus == "Morganella" & x$species == "morganii") |
|
||||
(x$genus == "Proteus" & x$species == "mirabilis") |
|
||||
(x$genus == "Proteus" & x$species == "penneri") |
|
||||
(x$genus == "Proteus" & x$species == "vulgaris") |
|
||||
(x$genus == "Providencia" & x$species == "rettgeri") |
|
||||
(x$genus == "Providencia" & x$species == "stuartii")), ab_NA(TCY)] <- NA
|
||||
(x$genus == "Proteus" & x$species == "mirabilis") |
|
||||
(x$genus == "Proteus" & x$species == "penneri") |
|
||||
(x$genus == "Proteus" & x$species == "vulgaris") |
|
||||
(x$genus == "Providencia" & x$species == "rettgeri") |
|
||||
(x$genus == "Providencia" & x$species == "stuartii")), ab_NA(TCY)] <- NA
|
||||
x[which((x$genus == "Morganella" & x$species == "morganii") |
|
||||
(x$genus == "Proteus" & x$species == "penneri") |
|
||||
(x$genus == "Proteus" & x$species == "vulgaris") |
|
||||
(x$genus == "Providencia" & x$species == "rettgeri") |
|
||||
(x$genus == "Providencia" & x$species == "stuartii")), ab_NA(c(DOX, MNO))] <- NA
|
||||
|
||||
(x$genus == "Proteus" & x$species == "penneri") |
|
||||
(x$genus == "Proteus" & x$species == "vulgaris") |
|
||||
(x$genus == "Providencia" & x$species == "rettgeri") |
|
||||
(x$genus == "Providencia" & x$species == "stuartii")), ab_NA(c(DOX, MNO))] <- NA
|
||||
|
||||
x$classes_in_guideline <- NA_integer_
|
||||
x$classes_available <- NA_integer_
|
||||
x$classes_affected <- NA_integer_
|
||||
|
||||
|
||||
# now add the MDR levels to the data
|
||||
trans_tbl(
|
||||
2,
|
||||
@ -990,7 +994,7 @@ mdro <- function(x = NULL,
|
||||
c(TCY, DOX, MNO)
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
# now set MDROs:
|
||||
# MDR (=2): >=3 classes affected
|
||||
x[which(x$classes_affected >= 3), "MDRO"] <- 2
|
||||
@ -1002,7 +1006,7 @@ mdro <- function(x = NULL,
|
||||
" out of ", x$classes_available[which(x$classes_affected >= 3)], " available classes"
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
# XDR (=3): all but <=2 classes affected
|
||||
x[which((x$classes_in_guideline - x$classes_affected) <= 2), "MDRO"] <- 3
|
||||
if (isTRUE(verbose)) {
|
||||
@ -1011,7 +1015,7 @@ mdro <- function(x = NULL,
|
||||
" out of ", x$classes_in_guideline[which(x$MDRO == 3)], " classes)"
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
# PDR (=4): all drugs are R
|
||||
x[which(x$classes_affected == 999 & x$classes_in_guideline == x$classes_available), "MDRO"] <- 4
|
||||
if (isTRUE(verbose)) {
|
||||
@ -1022,7 +1026,7 @@ mdro <- function(x = NULL,
|
||||
ifelse(!isTRUE(combine_SI), " or I", "")
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
# not enough classes available
|
||||
x[which(x$MDRO %in% c(1, 3) & x$classes_available < floor(x$classes_in_guideline * pct_required_classes)), "MDRO"] <- -1
|
||||
if (isTRUE(verbose)) {
|
||||
@ -1032,18 +1036,18 @@ mdro <- function(x = NULL,
|
||||
" (~", percentage(pct_required_classes), " of ", x$classes_in_guideline[which(x$MDRO == -1)], ")"
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
# add antibiotic names of resistant ones to verbose output
|
||||
}
|
||||
|
||||
|
||||
if (guideline$code == "eucast3.1") {
|
||||
# EUCAST 3.1 --------------------------------------------------------------
|
||||
# Table 5
|
||||
trans_tbl(
|
||||
3,
|
||||
which(x$order == "Enterobacterales" |
|
||||
(x$genus == "Pseudomonas" & x$species == "aeruginosa") |
|
||||
x$genus == "Acinetobacter"),
|
||||
(x$genus == "Pseudomonas" & x$species == "aeruginosa") |
|
||||
x$genus == "Acinetobacter"),
|
||||
COL,
|
||||
"all"
|
||||
)
|
||||
@ -1128,17 +1132,17 @@ mdro <- function(x = NULL,
|
||||
"any"
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
if (guideline$code == "eucast3.2") {
|
||||
# EUCAST 3.2 --------------------------------------------------------------
|
||||
# Table 6
|
||||
trans_tbl(
|
||||
3,
|
||||
which((x$order == "Enterobacterales" &
|
||||
!x$family == "Morganellaceae" &
|
||||
!(x$genus == "Serratia" & x$species == "marcescens")) |
|
||||
(x$genus == "Pseudomonas" & x$species == "aeruginosa") |
|
||||
x$genus == "Acinetobacter"),
|
||||
!x$family == "Morganellaceae" &
|
||||
!(x$genus == "Serratia" & x$species == "marcescens")) |
|
||||
(x$genus == "Pseudomonas" & x$species == "aeruginosa") |
|
||||
x$genus == "Acinetobacter"),
|
||||
COL,
|
||||
"all"
|
||||
)
|
||||
@ -1229,7 +1233,7 @@ mdro <- function(x = NULL,
|
||||
"any"
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
if (guideline$code == "eucast3.3") {
|
||||
# EUCAST 3.3 --------------------------------------------------------------
|
||||
# note: this guideline is equal to EUCAST 3.2 - no MDRO insights changed
|
||||
@ -1237,10 +1241,10 @@ mdro <- function(x = NULL,
|
||||
trans_tbl(
|
||||
3,
|
||||
which((x$order == "Enterobacterales" &
|
||||
!x$family == "Morganellaceae" &
|
||||
!(x$genus == "Serratia" & x$species == "marcescens")) |
|
||||
(x$genus == "Pseudomonas" & x$species == "aeruginosa") |
|
||||
x$genus == "Acinetobacter"),
|
||||
!x$family == "Morganellaceae" &
|
||||
!(x$genus == "Serratia" & x$species == "marcescens")) |
|
||||
(x$genus == "Pseudomonas" & x$species == "aeruginosa") |
|
||||
x$genus == "Acinetobacter"),
|
||||
COL,
|
||||
"all"
|
||||
)
|
||||
@ -1331,72 +1335,72 @@ mdro <- function(x = NULL,
|
||||
"any"
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
if (guideline$code == "mrgn") {
|
||||
# Germany -----------------------------------------------------------------
|
||||
|
||||
|
||||
# Table 1
|
||||
trans_tbl(
|
||||
2, # 3MRGN
|
||||
which((x$order == "Enterobacterales" | # following in fact the old Enterobacteriaceae classification
|
||||
(x$genus == "Acinetobacter" & x$species == "baumannii")) &
|
||||
try_ab(x[, PIP, drop = TRUE] == "R") &
|
||||
(try_ab(x[, CTX, drop = TRUE] == "R") | try_ab(x[, CAZ, drop = TRUE] == "R")) &
|
||||
(try_ab(x[, IPM, drop = TRUE] != "R") | try_ab(x[, MEM, drop = TRUE] != "R")) &
|
||||
try_ab(x[, CIP, drop = TRUE] == "R")),
|
||||
(x$genus == "Acinetobacter" & x$species == "baumannii")) &
|
||||
try_ab(x[, PIP, drop = TRUE] == "R") &
|
||||
(try_ab(x[, CTX, drop = TRUE] == "R") | try_ab(x[, CAZ, drop = TRUE] == "R")) &
|
||||
(try_ab(x[, IPM, drop = TRUE] != "R") | try_ab(x[, MEM, drop = TRUE] != "R")) &
|
||||
try_ab(x[, CIP, drop = TRUE] == "R")),
|
||||
c(PIP, CTX, CAZ, IPM, MEM, CIP),
|
||||
"any"
|
||||
)
|
||||
|
||||
|
||||
trans_tbl(
|
||||
3, # 4MRGN, overwrites 3MRGN if applicable
|
||||
which((x$order == "Enterobacterales" | # following in fact the old Enterobacteriaceae classification
|
||||
(x$genus == "Acinetobacter" & x$species == "baumannii")) &
|
||||
try_ab(x[, PIP, drop = TRUE] == "R") &
|
||||
(try_ab(x[, CTX, drop = TRUE] == "R") | try_ab(x[, CAZ, drop = TRUE] == "R")) &
|
||||
(try_ab(x[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R")) &
|
||||
try_ab(x[, CIP, drop = TRUE] == "R")),
|
||||
(x$genus == "Acinetobacter" & x$species == "baumannii")) &
|
||||
try_ab(x[, PIP, drop = TRUE] == "R") &
|
||||
(try_ab(x[, CTX, drop = TRUE] == "R") | try_ab(x[, CAZ, drop = TRUE] == "R")) &
|
||||
(try_ab(x[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R")) &
|
||||
try_ab(x[, CIP, drop = TRUE] == "R")),
|
||||
c(PIP, CTX, CAZ, IPM, MEM, CIP),
|
||||
"any"
|
||||
)
|
||||
|
||||
|
||||
trans_tbl(
|
||||
3, # 4MRGN, overwrites 3MRGN if applicable
|
||||
which((x$order == "Enterobacterales" | # following in fact the old Enterobacteriaceae classification
|
||||
(x$genus == "Acinetobacter" & x$species == "baumannii")) &
|
||||
(try_ab(x[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R"))),
|
||||
(x$genus == "Acinetobacter" & x$species == "baumannii")) &
|
||||
(try_ab(x[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R"))),
|
||||
c(IPM, MEM),
|
||||
"any"
|
||||
)
|
||||
|
||||
|
||||
trans_tbl(
|
||||
2, # 3MRGN, if only 1 group is S
|
||||
which(x$genus == "Pseudomonas" & x$species == "aeruginosa" &
|
||||
try_ab(x[, PIP, drop = TRUE] == "S") +
|
||||
try_ab(x[, CTX, drop = TRUE] == "S") +
|
||||
try_ab(x[, CAZ, drop = TRUE] == "S") +
|
||||
try_ab(x[, IPM, drop = TRUE] == "S") +
|
||||
try_ab(x[, MEM, drop = TRUE] == "S") +
|
||||
try_ab(x[, CIP, drop = TRUE] == "S") == 1),
|
||||
try_ab(x[, PIP, drop = TRUE] == "S") +
|
||||
try_ab(x[, CTX, drop = TRUE] == "S") +
|
||||
try_ab(x[, CAZ, drop = TRUE] == "S") +
|
||||
try_ab(x[, IPM, drop = TRUE] == "S") +
|
||||
try_ab(x[, MEM, drop = TRUE] == "S") +
|
||||
try_ab(x[, CIP, drop = TRUE] == "S") == 1),
|
||||
c(PIP, CTX, CAZ, IPM, MEM, CIP),
|
||||
"any"
|
||||
)
|
||||
|
||||
|
||||
trans_tbl(
|
||||
3, # 4MRGN otherwise
|
||||
which((x$genus == "Pseudomonas" & x$species == "aeruginosa") &
|
||||
try_ab(x[, PIP, drop = TRUE] == "R") &
|
||||
(try_ab(x[, CTX, drop = TRUE] == "R") | try_ab(x[, CAZ, drop = TRUE] == "R")) &
|
||||
(try_ab(x[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R")) &
|
||||
try_ab(x[, CIP, drop = TRUE] == "R")),
|
||||
try_ab(x[, PIP, drop = TRUE] == "R") &
|
||||
(try_ab(x[, CTX, drop = TRUE] == "R") | try_ab(x[, CAZ, drop = TRUE] == "R")) &
|
||||
(try_ab(x[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R")) &
|
||||
try_ab(x[, CIP, drop = TRUE] == "R")),
|
||||
c(PIP, CTX, CAZ, IPM, MEM, CIP),
|
||||
"any"
|
||||
)
|
||||
|
||||
|
||||
x[which(x$MDRO == 2), "reason"] <- "3MRGN"
|
||||
x[which(x$MDRO == 3), "reason"] <- "4MRGN"
|
||||
}
|
||||
|
||||
|
||||
if (guideline$code == "brmo") {
|
||||
# Netherlands -------------------------------------------------------------
|
||||
aminoglycosides <- aminoglycosides[!is.na(aminoglycosides)]
|
||||
@ -1409,7 +1413,7 @@ mdro <- function(x = NULL,
|
||||
if (length(ESBLs) != 2) {
|
||||
ESBLs <- character(0)
|
||||
}
|
||||
|
||||
|
||||
# Table 1
|
||||
trans_tbl(
|
||||
3,
|
||||
@ -1417,21 +1421,21 @@ mdro <- function(x = NULL,
|
||||
c(aminoglycosides, fluoroquinolones),
|
||||
"all"
|
||||
)
|
||||
|
||||
|
||||
trans_tbl(
|
||||
2,
|
||||
which(x$order == "Enterobacterales"), # following in fact the old Enterobacteriaceae classification
|
||||
carbapenems,
|
||||
"any"
|
||||
)
|
||||
|
||||
|
||||
trans_tbl(
|
||||
2,
|
||||
which(x$order == "Enterobacterales"), # following in fact the old Enterobacteriaceae classification
|
||||
ESBLs,
|
||||
"all"
|
||||
)
|
||||
|
||||
|
||||
# Table 2
|
||||
trans_tbl(
|
||||
2,
|
||||
@ -1445,19 +1449,19 @@ mdro <- function(x = NULL,
|
||||
c(aminoglycosides, fluoroquinolones),
|
||||
"all"
|
||||
)
|
||||
|
||||
|
||||
trans_tbl(
|
||||
3,
|
||||
which(x$genus == "Stenotrophomonas" & x$species == "maltophilia"),
|
||||
SXT,
|
||||
"all"
|
||||
)
|
||||
|
||||
|
||||
if (!ab_missing(MEM) && !ab_missing(IPM) &&
|
||||
!ab_missing(GEN) && !ab_missing(TOB) &&
|
||||
!ab_missing(CIP) &&
|
||||
!ab_missing(CAZ) &&
|
||||
!ab_missing(TZP)) {
|
||||
!ab_missing(GEN) && !ab_missing(TOB) &&
|
||||
!ab_missing(CIP) &&
|
||||
!ab_missing(CAZ) &&
|
||||
!ab_missing(TZP)) {
|
||||
x$psae <- 0
|
||||
x[which(x[, MEM, drop = TRUE] == "R" | x[, IPM, drop = TRUE] == "R"), "psae"] <- 1 + x[which(x[, MEM, drop = TRUE] == "R" | x[, IPM, drop = TRUE] == "R"), "psae"]
|
||||
x[which(x[, GEN, drop = TRUE] == "R" & x[, TOB, drop = TRUE] == "R"), "psae"] <- 1 + x[which(x[, GEN, drop = TRUE] == "R" & x[, TOB, drop = TRUE] == "R"), "psae"]
|
||||
@ -1477,7 +1481,7 @@ mdro <- function(x = NULL,
|
||||
x$genus == "Pseudomonas" & x$species == "aeruginosa" &
|
||||
x$psae >= 3
|
||||
), "reason"] <- paste0("at least 3 classes contain R", ifelse(!isTRUE(combine_SI), " or I", ""))
|
||||
|
||||
|
||||
# Table 3
|
||||
trans_tbl(
|
||||
3,
|
||||
@ -1498,7 +1502,7 @@ mdro <- function(x = NULL,
|
||||
"all"
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
if (guideline$code == "tb") {
|
||||
# Tuberculosis ------------------------------------------------------------
|
||||
prepare_drug <- function(ab) {
|
||||
@ -1535,7 +1539,7 @@ mdro <- function(x = NULL,
|
||||
ab != "R"
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
x$mono_count <- 0
|
||||
x[drug_is_R(INH), "mono_count"] <- x[drug_is_R(INH), "mono_count", drop = TRUE] + 1
|
||||
x[drug_is_R(RIF), "mono_count"] <- x[drug_is_R(RIF), "mono_count", drop = TRUE] + 1
|
||||
@ -1543,7 +1547,7 @@ mdro <- function(x = NULL,
|
||||
x[drug_is_R(PZA), "mono_count"] <- x[drug_is_R(PZA), "mono_count", drop = TRUE] + 1
|
||||
x[drug_is_R(RIB), "mono_count"] <- x[drug_is_R(RIB), "mono_count", drop = TRUE] + 1
|
||||
x[drug_is_R(RFP), "mono_count"] <- x[drug_is_R(RFP), "mono_count", drop = TRUE] + 1
|
||||
|
||||
|
||||
x$mono <- x$mono_count > 0
|
||||
x$poly <- x$mono_count > 1 & drug_is_not_R(RIF) & drug_is_not_R(INH)
|
||||
x$mdr <- drug_is_R(RIF) & drug_is_R(INH)
|
||||
@ -1551,19 +1555,19 @@ mdro <- function(x = NULL,
|
||||
x$second <- drug_is_R(CAP) | drug_is_R(KAN) | drug_is_R(AMK)
|
||||
x$xdr <- x$mdr & x$xdr & x$second
|
||||
x$MDRO <- ifelse(x$xdr, 5,
|
||||
ifelse(x$mdr, 4,
|
||||
ifelse(x$poly, 3,
|
||||
ifelse(x$mono, 2,
|
||||
1
|
||||
)
|
||||
)
|
||||
)
|
||||
ifelse(x$mdr, 4,
|
||||
ifelse(x$poly, 3,
|
||||
ifelse(x$mono, 2,
|
||||
1
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
# keep all real TB, make other species NA
|
||||
x$MDRO <- ifelse(x$fullname == "Mycobacterium tuberculosis", x$MDRO, NA_real_)
|
||||
x$reason <- "PDR/MDR/XDR criteria were met"
|
||||
}
|
||||
|
||||
|
||||
# some more info on negative results
|
||||
if (isTRUE(verbose)) {
|
||||
if (guideline$code == "cmi2012") {
|
||||
@ -1579,7 +1583,7 @@ mdro <- function(x = NULL,
|
||||
x[which(x$MDRO == 1), "reason"] <- "too few antibiotics are R"
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
if (isTRUE(info.bak)) {
|
||||
cat(group_msg)
|
||||
if (sum(!is.na(x$MDRO)) == 0) {
|
||||
@ -1591,11 +1595,11 @@ mdro <- function(x = NULL,
|
||||
)))
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# Fill in blanks ----
|
||||
# for rows that have no results
|
||||
x_transposed <- as.list(as.data.frame(t(x[, cols_ab, drop = FALSE]),
|
||||
stringsAsFactors = FALSE
|
||||
stringsAsFactors = FALSE
|
||||
))
|
||||
rows_empty <- which(vapply(
|
||||
FUN.VALUE = logical(1),
|
||||
@ -1609,7 +1613,7 @@ mdro <- function(x = NULL,
|
||||
} else {
|
||||
cat("\n")
|
||||
}
|
||||
|
||||
|
||||
# Results ----
|
||||
if (guideline$code == "cmi2012") {
|
||||
if (any(x$MDRO == -1, na.rm = TRUE)) {
|
||||
@ -1656,7 +1660,7 @@ mdro <- function(x = NULL,
|
||||
ordered = TRUE
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
if (isTRUE(verbose)) {
|
||||
colnames(x)[colnames(x) == col_mo] <- "microorganism"
|
||||
x$microorganism <- mo_name(x$microorganism, language = NULL)
|
||||
@ -1678,9 +1682,9 @@ mdro <- function(x = NULL,
|
||||
#' @export
|
||||
custom_mdro_guideline <- function(..., as_factor = TRUE) {
|
||||
meet_criteria(as_factor, allow_class = "logical", has_length = 1)
|
||||
|
||||
|
||||
dots <- tryCatch(list(...),
|
||||
error = function(e) "error"
|
||||
error = function(e) "error"
|
||||
)
|
||||
stop_if(
|
||||
identical(dots, "error"),
|
||||
@ -1694,7 +1698,7 @@ custom_mdro_guideline <- function(..., as_factor = TRUE) {
|
||||
inherits(dots[[i]], "formula"),
|
||||
"rule ", i, " must be a valid formula input (e.g., using '~'), see `?mdro`"
|
||||
)
|
||||
|
||||
|
||||
# Query
|
||||
qry <- dots[[i]][[2]]
|
||||
if (inherits(qry, "call")) {
|
||||
@ -1710,14 +1714,14 @@ custom_mdro_guideline <- function(..., as_factor = TRUE) {
|
||||
qry <- gsub(" *([&|+-/*^><==]+) *", " \\1 ", qry)
|
||||
qry <- gsub("'", "\"", qry, fixed = TRUE)
|
||||
out[[i]]$query <- as.expression(qry)
|
||||
|
||||
|
||||
# Value
|
||||
val <- tryCatch(eval(dots[[i]][[3]]), error = function(e) NULL)
|
||||
stop_if(is.null(val), "rule ", i, " must return a valid value, it now returns an error: ", tryCatch(eval(dots[[i]][[3]]), error = function(e) e$message))
|
||||
stop_if(length(val) > 1, "rule ", i, " must return a value of length 1, not ", length(val))
|
||||
out[[i]]$value <- as.character(val)
|
||||
}
|
||||
|
||||
|
||||
names(out) <- paste0("rule", seq_len(n_dots))
|
||||
out <- set_clean_class(out, new_class = c("custom_mdro_guideline", "list"))
|
||||
attr(out, "values") <- unname(c("Negative", vapply(FUN.VALUE = character(1), unclass(out), function(x) x$value)))
|
||||
@ -1739,8 +1743,8 @@ c.custom_mdro_guideline <- function(x, ..., as_factor = NULL) {
|
||||
}
|
||||
for (g in list(...)) {
|
||||
stop_ifnot(inherits(g, "custom_mdro_guideline"),
|
||||
"for combining custom MDRO guidelines, all rules must be created with `custom_mdro_guideline()`",
|
||||
call = FALSE
|
||||
"for combining custom MDRO guidelines, all rules must be created with `custom_mdro_guideline()`",
|
||||
call = FALSE
|
||||
)
|
||||
vals <- attributes(x)$values
|
||||
if (!all(attributes(g)$values %in% vals)) {
|
||||
@ -1790,28 +1794,28 @@ run_custom_mdro_guideline <- function(df, guideline, info) {
|
||||
reasons <- character(length = NROW(df))
|
||||
for (i in seq_len(n_dots)) {
|
||||
qry <- tryCatch(eval(parse(text = guideline[[i]]$query), envir = df, enclos = parent.frame()),
|
||||
error = function(e) {
|
||||
AMR_env$err_msg <- e$message
|
||||
return("error")
|
||||
}
|
||||
error = function(e) {
|
||||
AMR_env$err_msg <- e$message
|
||||
return("error")
|
||||
}
|
||||
)
|
||||
if (identical(qry, "error")) {
|
||||
warning_("in `custom_mdro_guideline()`: rule ", i,
|
||||
" (`", as.character(guideline[[i]]$query), "`) was ignored because of this error message: ",
|
||||
AMR_env$err_msg,
|
||||
call = FALSE,
|
||||
add_fn = font_red
|
||||
" (`", as.character(guideline[[i]]$query), "`) was ignored because of this error message: ",
|
||||
AMR_env$err_msg,
|
||||
call = FALSE,
|
||||
add_fn = font_red
|
||||
)
|
||||
next
|
||||
}
|
||||
stop_ifnot(is.logical(qry), "in custom_mdro_guideline(): rule ", i, " (`", guideline[[i]]$query,
|
||||
"`) must return `TRUE` or `FALSE`, not ",
|
||||
format_class(class(qry), plural = FALSE),
|
||||
call = FALSE
|
||||
"`) must return `TRUE` or `FALSE`, not ",
|
||||
format_class(class(qry), plural = FALSE),
|
||||
call = FALSE
|
||||
)
|
||||
|
||||
|
||||
new_mdros <- which(qry == TRUE & out == "")
|
||||
|
||||
|
||||
if (isTRUE(info)) {
|
||||
cat(word_wrap(
|
||||
"- Custom MDRO rule ", i, ": `", as.character(guideline[[i]]$query),
|
||||
@ -1827,11 +1831,11 @@ run_custom_mdro_guideline <- function(df, guideline, info) {
|
||||
}
|
||||
out[out == ""] <- "Negative"
|
||||
reasons[out == "Negative"] <- "no rules matched"
|
||||
|
||||
|
||||
if (isTRUE(attributes(guideline)$as_factor)) {
|
||||
out <- factor(out, levels = attributes(guideline)$values, ordered = TRUE)
|
||||
}
|
||||
|
||||
|
||||
columns_nonsusceptible <- as.data.frame(t(df[, is.sir(df), drop = FALSE] == "R"))
|
||||
columns_nonsusceptible <- vapply(
|
||||
FUN.VALUE = character(1),
|
||||
@ -1839,7 +1843,7 @@ run_custom_mdro_guideline <- function(df, guideline, info) {
|
||||
function(x) paste0(rownames(columns_nonsusceptible)[which(x)], collapse = " ")
|
||||
)
|
||||
columns_nonsusceptible[is.na(out)] <- NA_character_
|
||||
|
||||
|
||||
data.frame(
|
||||
row_number = seq_len(NROW(df)),
|
||||
MDRO = out,
|
||||
|
@ -49,13 +49,13 @@
|
||||
#' sir <- random_sir(10)
|
||||
#' sir
|
||||
#' mean_amr_distance(sir)
|
||||
#'
|
||||
#'
|
||||
#' mic <- random_mic(10)
|
||||
#' mic
|
||||
#' mean_amr_distance(mic)
|
||||
#' # equal to the Z-score of their log2:
|
||||
#' (log2(mic) - mean(log2(mic))) / sd(log2(mic))
|
||||
#'
|
||||
#'
|
||||
#' disk <- random_disk(10)
|
||||
#' disk
|
||||
#' mean_amr_distance(disk)
|
||||
@ -143,7 +143,7 @@ mean_amr_distance.data.frame <- function(x, ..., combine_SI = TRUE) {
|
||||
df_classes <- colnames(df)[vapply(FUN.VALUE = logical(1), df, function(x) is.disk(x) | is.mic(x) | is.disk(x), USE.NAMES = FALSE)]
|
||||
df_antibiotics <- unname(get_column_abx(df, info = FALSE))
|
||||
df <- df[, colnames(df)[colnames(df) %in% union(df_classes, df_antibiotics)], drop = FALSE]
|
||||
|
||||
|
||||
stop_if(ncol(df) < 2,
|
||||
"data set must contain at least two variables",
|
||||
call = -2
|
||||
@ -151,7 +151,7 @@ mean_amr_distance.data.frame <- function(x, ..., combine_SI = TRUE) {
|
||||
if (message_not_thrown_before("mean_amr_distance", "groups")) {
|
||||
message_("Calculating mean AMR distance based on columns ", vector_and(colnames(df), sort = FALSE))
|
||||
}
|
||||
|
||||
|
||||
res <- vapply(
|
||||
FUN.VALUE = double(nrow(df)),
|
||||
df,
|
||||
|
14
R/mic.R
14
R/mic.R
@ -230,13 +230,13 @@ as.mic <- function(x, na.rm = FALSE) {
|
||||
vector_and(quotes = TRUE)
|
||||
cur_col <- get_current_column()
|
||||
warning_("in `as.mic()`: ", na_after - na_before, " result",
|
||||
ifelse(na_after - na_before > 1, "s", ""),
|
||||
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
|
||||
" truncated (",
|
||||
round(((na_after - na_before) / length(x)) * 100),
|
||||
"%) that were invalid MICs: ",
|
||||
list_missing,
|
||||
call = FALSE
|
||||
ifelse(na_after - na_before > 1, "s", ""),
|
||||
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
|
||||
" truncated (",
|
||||
round(((na_after - na_before) / length(x)) * 100),
|
||||
"%) that were invalid MICs: ",
|
||||
list_missing,
|
||||
call = FALSE
|
||||
)
|
||||
}
|
||||
|
||||
|
98
R/mo.R
98
R/mo.R
@ -183,12 +183,12 @@ as.mo <- function(x,
|
||||
x <- replace_ignore_pattern(x, ignore_pattern)
|
||||
|
||||
x_lower <- tolower(x)
|
||||
|
||||
|
||||
complexes <- x[trimws2(x_lower) %like_case% " (complex|group)$"]
|
||||
if (length(complexes) > 0 && identical(remove_from_input, mo_cleaning_regex()) && !any(AMR_env$MO_lookup$fullname[which(AMR_env$MO_lookup$source == "Added by user")] %like% "(group|complex)", na.rm = TRUE)) {
|
||||
warning_("in `as.mo()`: 'complex' and 'group' were ignored from the input in ", length(complexes), " case", ifelse(length(complexes) > 1, "s", ""), ", as they are currently not supported.\nYou can add your own microorganism with `add_custom_microorganisms()`.", call = FALSE)
|
||||
}
|
||||
|
||||
|
||||
# WHONET: xxx = no growth
|
||||
x[x_lower %in% c("", "xxx", "na", "nan")] <- NA_character_
|
||||
|
||||
@ -274,7 +274,7 @@ as.mo <- function(x,
|
||||
|
||||
# take out the parts, split by space
|
||||
x_parts <- strsplit(gsub("-", " ", x_out, fixed = TRUE), " ", fixed = TRUE)[[1]]
|
||||
|
||||
|
||||
# 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
|
||||
@ -313,13 +313,13 @@ as.mo <- function(x,
|
||||
} else {
|
||||
minimum_matching_score_current <- minimum_matching_score
|
||||
}
|
||||
|
||||
|
||||
if (sum(m >= minimum_matching_score_current) > 10) {
|
||||
# at least 10 are left over, make the ones under `m` NA
|
||||
m[m < minimum_matching_score_current] <- NA_real_
|
||||
m[m < minimum_matching_score_current] <- NA_real_
|
||||
}
|
||||
|
||||
top_hits <- mo_to_search[order(m, decreasing = TRUE, na.last = NA)] # na.last = NA will remove the NAs
|
||||
|
||||
top_hits <- mo_to_search[order(m, decreasing = TRUE, na.last = NA)] # na.last = NA will remove the NAs
|
||||
if (length(top_hits) == 0) {
|
||||
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.", call = FALSE)
|
||||
result_mo <- NA_character_
|
||||
@ -365,18 +365,19 @@ as.mo <- function(x,
|
||||
plural <- c("s", "these uncertainties")
|
||||
}
|
||||
if (length(AMR_env$mo_uncertainties$original_input) <= 3) {
|
||||
examples <- vector_and(paste0(
|
||||
'"', AMR_env$mo_uncertainties$original_input,
|
||||
'" (assumed ', italicise(AMR_env$mo_uncertainties$fullname), ")"
|
||||
),
|
||||
quotes = FALSE
|
||||
examples <- vector_and(
|
||||
paste0(
|
||||
'"', AMR_env$mo_uncertainties$original_input,
|
||||
'" (assumed ', italicise(AMR_env$mo_uncertainties$fullname), ")"
|
||||
),
|
||||
quotes = FALSE
|
||||
)
|
||||
} else {
|
||||
examples <- paste0(nr2char(length(AMR_env$mo_uncertainties$original_input)), " microorganism", plural[1])
|
||||
}
|
||||
msg <- c(msg, paste0(
|
||||
"Microorganism translation was uncertain for ", examples,
|
||||
". Run `mo_uncertainties()` to review ", plural[2], ", or use `add_custom_microorganisms()` to add own entries."
|
||||
". Run `mo_uncertainties()` to review ", plural[2], ", or use `add_custom_microorganisms()` to add custom entries."
|
||||
))
|
||||
|
||||
for (m in msg) {
|
||||
@ -442,7 +443,7 @@ as.mo <- function(x,
|
||||
# Apply Lancefield ----
|
||||
if (isTRUE(Lancefield) || Lancefield == "all") {
|
||||
# (using `%like_case%` to also match subspecies)
|
||||
|
||||
|
||||
# group A - S. pyogenes
|
||||
out[out %like_case% "^B_STRPT_PYGN(_|$)"] <- "B_STRPT_GRPA"
|
||||
# group B - S. agalactiae
|
||||
@ -560,7 +561,7 @@ pillar_shaft.mo <- function(x, ...) {
|
||||
# markup NA and UNKNOWN
|
||||
out[is.na(x)] <- font_na(" NA")
|
||||
out[x == "UNKNOWN"] <- font_na(" UNKNOWN")
|
||||
|
||||
|
||||
# markup manual codes
|
||||
out[x %in% AMR_env$MO_lookup$mo & !x %in% AMR::microorganisms$mo] <- font_blue(out[x %in% AMR_env$MO_lookup$mo & !x %in% AMR::microorganisms$mo], collapse = NULL)
|
||||
|
||||
@ -577,10 +578,11 @@ pillar_shaft.mo <- function(x, ...) {
|
||||
if (!all(x %in% all_mos) ||
|
||||
(!is.null(df) && !all(unlist(df[, which(mo_cols), drop = FALSE]) %in% all_mos))) {
|
||||
# markup old mo codes
|
||||
out[!x %in% all_mos] <- font_italic(font_na(x[!x %in% all_mos],
|
||||
out[!x %in% all_mos] <- font_italic(
|
||||
font_na(x[!x %in% all_mos],
|
||||
collapse = NULL
|
||||
),
|
||||
collapse = NULL
|
||||
),
|
||||
collapse = NULL
|
||||
)
|
||||
# throw a warning with the affected column name(s)
|
||||
if (!is.null(mo_cols)) {
|
||||
@ -797,7 +799,7 @@ print.mo_uncertainties <- function(x, ...) {
|
||||
cat(word_wrap("No uncertainties to show. Only uncertainties of the last call of `as.mo()` or any `mo_*()` function are stored.\n\n", add_fn = font_blue))
|
||||
return(invisible(NULL))
|
||||
}
|
||||
|
||||
|
||||
add_MO_lookup_to_AMR_env()
|
||||
|
||||
cat(word_wrap("Matching scores are based on the resemblance between the input and the full taxonomic name, and the pathogenicity in humans. See `?mo_matching_score`.\n\n", add_fn = font_blue))
|
||||
@ -819,7 +821,7 @@ print.mo_uncertainties <- function(x, ...) {
|
||||
text[scores < 0.5] <- font_red_bg(text[scores < 0.5], collapse = NULL)
|
||||
text
|
||||
}
|
||||
|
||||
|
||||
txt <- ""
|
||||
for (i in seq_len(nrow(x))) {
|
||||
if (x[i, ]$candidates != "") {
|
||||
@ -835,21 +837,23 @@ print.mo_uncertainties <- function(x, ...) {
|
||||
candidates_formatted <- candidates_formatted[order(1 - scores)]
|
||||
scores_formatted <- scores_formatted[order(1 - scores)]
|
||||
|
||||
candidates <- word_wrap(paste0(
|
||||
"Also matched: ",
|
||||
vector_and(paste0(
|
||||
candidates_formatted,
|
||||
font_blue(paste0(" (", scores_formatted, ")"), collapse = NULL)
|
||||
candidates <- word_wrap(
|
||||
paste0(
|
||||
"Also matched: ",
|
||||
vector_and(
|
||||
paste0(
|
||||
candidates_formatted,
|
||||
font_blue(paste0(" (", scores_formatted, ")"), collapse = NULL)
|
||||
),
|
||||
quotes = FALSE, sort = FALSE
|
||||
),
|
||||
ifelse(n_candidates == 25,
|
||||
font_grey(" [showing first 25]"),
|
||||
""
|
||||
)
|
||||
),
|
||||
quotes = FALSE, sort = FALSE
|
||||
),
|
||||
ifelse(n_candidates == 25,
|
||||
font_grey(" [showing first 25]"),
|
||||
""
|
||||
)
|
||||
),
|
||||
extra_indent = nchar("Also matched: "),
|
||||
width = 0.9 * getOption("width", 100)
|
||||
extra_indent = nchar("Also matched: "),
|
||||
width = 0.9 * getOption("width", 100)
|
||||
)
|
||||
} else {
|
||||
candidates <- ""
|
||||
@ -954,17 +958,17 @@ convert_colloquial_input <- function(x) {
|
||||
out[x %like_case% "mil+er+i gr"] <- "B_STRPT_MILL"
|
||||
out[x %like_case% "((strepto|^s).* viridans|^vgs[^a-z]*$)"] <- "B_STRPT_VIRI"
|
||||
out[x %like_case% "(viridans.* (strepto|^s).*|^vgs[^a-z]*$)"] <- "B_STRPT_VIRI"
|
||||
|
||||
|
||||
# Salmonella in different languages, like "Salmonella grupo B"
|
||||
out[x %like_case% "salmonella.* [bcd]$"] <- gsub(".*salmonella.* ([bcd])$",
|
||||
"B_SLMNL_GRP\\U\\1",
|
||||
x[x %like_case% "salmonella.* [bcd]$"],
|
||||
perl = TRUE
|
||||
"B_SLMNL_GRP\\U\\1",
|
||||
x[x %like_case% "salmonella.* [bcd]$"],
|
||||
perl = TRUE
|
||||
)
|
||||
out[x %like_case% "group [bcd] salmonella"] <- gsub(".*group ([bcd]) salmonella*",
|
||||
"B_SLMNL_GRP\\U\\1",
|
||||
x[x %like_case% "group [bcd] salmonella"],
|
||||
perl = TRUE
|
||||
"B_SLMNL_GRP\\U\\1",
|
||||
x[x %like_case% "group [bcd] salmonella"],
|
||||
perl = TRUE
|
||||
)
|
||||
|
||||
# CoNS/CoPS in different languages (support for German, Dutch, Spanish, Portuguese)
|
||||
@ -999,10 +1003,14 @@ convert_colloquial_input <- function(x) {
|
||||
|
||||
italicise <- function(x) {
|
||||
out <- font_italic(x, collapse = NULL)
|
||||
out[x %like_case% "Salmonella [A-Z]"] <- paste(font_italic("Salmonella"),
|
||||
gsub("Salmonella ", "", x[x %like_case% "Salmonella [A-Z]"]))
|
||||
out[x %like_case% "Streptococcus [A-Z]"] <- paste(font_italic("Streptococcus"),
|
||||
gsub("Streptococcus ", "", x[x %like_case% "Streptococcus [A-Z]"]))
|
||||
out[x %like_case% "Salmonella [A-Z]"] <- paste(
|
||||
font_italic("Salmonella"),
|
||||
gsub("Salmonella ", "", x[x %like_case% "Salmonella [A-Z]"])
|
||||
)
|
||||
out[x %like_case% "Streptococcus [A-Z]"] <- paste(
|
||||
font_italic("Streptococcus"),
|
||||
gsub("Streptococcus ", "", x[x %like_case% "Streptococcus [A-Z]"])
|
||||
)
|
||||
if (has_colour()) {
|
||||
out <- gsub("(Group|group|Complex|complex)(\033\\[23m)?", "\033[23m\\1", out, perl = TRUE)
|
||||
}
|
||||
|
@ -34,13 +34,13 @@
|
||||
#' @param x Any user input value(s)
|
||||
#' @param n A full taxonomic name, that exists in [`microorganisms$fullname`][microorganisms]
|
||||
#' @note This algorithm was originally described in: Berends MS *et al.* (2022). **AMR: An R Package for Working with Antimicrobial Resistance Data**. *Journal of Statistical Software*, 104(3), 1-31; \doi{10.18637/jss.v104.i03}.
|
||||
#'
|
||||
#'
|
||||
#' Later, the work of Bartlett A *et al.* about bacterial pathogens infecting humans (2022, \doi{10.1099/mic.0.001269}) was incorporated.
|
||||
#' @section Matching Score for Microorganisms:
|
||||
#' With ambiguous user input in [as.mo()] and all the [`mo_*`][mo_property()] functions, the returned results are chosen based on their matching score using [mo_matching_score()]. This matching score \eqn{m}, is calculated as:
|
||||
#'
|
||||
#' \ifelse{latex}{\deqn{m_{(x, n)} = \frac{l_{n} - 0.5 \cdot \min \begin{cases}l_{n} \\ \textrm{lev}(x, n)\end{cases}}{l_{n} \cdot p_{n} \cdot k_{n}}}}{
|
||||
#'
|
||||
#'
|
||||
#' \ifelse{html}{\figure{mo_matching_score.png}{options: width="300" alt="mo matching score"}}{m(x, n) = ( l_n * min(l_n, lev(x, n) ) ) / ( l_n * p_n * k_n )}}
|
||||
#'
|
||||
#' where:
|
||||
@ -53,12 +53,12 @@
|
||||
#' * \eqn{k_n} is the taxonomic kingdom of \eqn{n}, set as Bacteria = 1, Fungi = 2, Protozoa = 3, Archaea = 4, others = 5.
|
||||
#'
|
||||
#' The grouping into human pathogenic prevalence \eqn{p} is based on recent work from Bartlett *et al.* (2022, \doi{10.1099/mic.0.001269}) who extensively studied medical-scientific literature to categorise all bacterial species into these groups:
|
||||
#'
|
||||
#'
|
||||
#' - **Established**, if a taxonomic species has infected at least three persons in three or more references. These records have `prevalence = 1.0` in the [microorganisms] data set;
|
||||
#' - **Putative**, if a taxonomic species has fewer than three known cases. These records have `prevalence = 1.25` in the [microorganisms] data set.
|
||||
#'
|
||||
#'
|
||||
#' Furthermore,
|
||||
#'
|
||||
#'
|
||||
#' - Any genus present in the **established** list also has `prevalence = 1.0` in the [microorganisms] data set;
|
||||
#' - Any other genus present in the **putative** list has `prevalence = 1.25` in the [microorganisms] data set;
|
||||
#' - Any other species or subspecies of which the genus is present in the two aforementioned groups, has `prevalence = 1.5` in the [microorganisms] data set;
|
||||
@ -72,7 +72,7 @@
|
||||
#' @inheritSection AMR Reference Data Publicly Available
|
||||
#' @examples
|
||||
#' mo_reset_session()
|
||||
#'
|
||||
#'
|
||||
#' as.mo("E. coli")
|
||||
#' mo_uncertainties()
|
||||
#'
|
||||
@ -95,7 +95,7 @@ mo_matching_score <- function(x, n) {
|
||||
|
||||
# force a capital letter, so this conversion will not count as a substitution
|
||||
substr(x, 1, 1) <- toupper(substr(x, 1, 1))
|
||||
|
||||
|
||||
# n is always a taxonomically valid full name
|
||||
if (length(n) == 1) {
|
||||
n <- rep(n, length(x))
|
||||
@ -103,7 +103,7 @@ mo_matching_score <- function(x, n) {
|
||||
if (length(x) == 1) {
|
||||
x <- rep(x, length(n))
|
||||
}
|
||||
|
||||
|
||||
# length of fullname
|
||||
l_n <- nchar(n)
|
||||
lev <- double(length = length(x))
|
||||
@ -126,7 +126,7 @@ mo_matching_score <- function(x, n) {
|
||||
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 <- 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)
|
||||
}
|
||||
|
@ -133,7 +133,6 @@
|
||||
#' mo_fullname("K. pneu rh")
|
||||
#' mo_shortname("K. pneu rh")
|
||||
#'
|
||||
#'
|
||||
#' \donttest{
|
||||
#' # Becker classification, see ?as.mo ----------------------------------------
|
||||
#'
|
||||
@ -158,7 +157,7 @@
|
||||
#' mo_gramstain("Klebsiella pneumoniae", language = "es") # Spanish
|
||||
#' mo_gramstain("Klebsiella pneumoniae", language = "el") # Greek
|
||||
#' mo_gramstain("Klebsiella pneumoniae", language = "uk") # Ukrainian
|
||||
#'
|
||||
#'
|
||||
#' # mo_type is equal to mo_kingdom, but mo_kingdom will remain untranslated
|
||||
#' mo_kingdom("Klebsiella pneumoniae")
|
||||
#' mo_type("Klebsiella pneumoniae")
|
||||
@ -426,17 +425,23 @@ mo_pathogenicity <- function(x, language = get_AMR_locale(), keep_synonyms = get
|
||||
kngd <- AMR_env$MO_lookup$kingdom[match(x.mo, AMR_env$MO_lookup$mo)]
|
||||
rank <- AMR_env$MO_lookup$rank[match(x.mo, AMR_env$MO_lookup$mo)]
|
||||
|
||||
out <- factor(ifelse(prev == 1 & kngd == "Bacteria" & rank != "genus",
|
||||
"Pathogenic",
|
||||
ifelse(prev < 2 & kngd == "Fungi",
|
||||
"Potentially pathogenic",
|
||||
ifelse(prev == 2 & kngd == "Bacteria",
|
||||
"Non-pathogenic",
|
||||
ifelse(kngd == "Bacteria",
|
||||
"Potentially pathogenic",
|
||||
"Unknown")))),
|
||||
levels = c("Pathogenic", "Potentially pathogenic", "Non-pathogenic", "Unknown"),
|
||||
ordered = TRUE)
|
||||
out <- factor(
|
||||
ifelse(prev == 1 & kngd == "Bacteria" & rank != "genus",
|
||||
"Pathogenic",
|
||||
ifelse(prev < 2 & kngd == "Fungi",
|
||||
"Potentially pathogenic",
|
||||
ifelse(prev == 2 & kngd == "Bacteria",
|
||||
"Non-pathogenic",
|
||||
ifelse(kngd == "Bacteria",
|
||||
"Potentially pathogenic",
|
||||
"Unknown"
|
||||
)
|
||||
)
|
||||
)
|
||||
),
|
||||
levels = c("Pathogenic", "Potentially pathogenic", "Non-pathogenic", "Unknown"),
|
||||
ordered = TRUE
|
||||
)
|
||||
|
||||
load_mo_uncertainties(metadata)
|
||||
out
|
||||
@ -727,7 +732,7 @@ mo_synonyms <- function(x, language = get_AMR_locale(), keep_synonyms = getOptio
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
language <- validate_language(language)
|
||||
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
|
||||
|
||||
|
||||
add_MO_lookup_to_AMR_env()
|
||||
|
||||
x.mo <- as.mo(x, language = language, keep_synonyms = keep_synonyms, ...)
|
||||
@ -815,7 +820,7 @@ mo_url <- function(x, open = FALSE, language = get_AMR_locale(), keep_synonyms =
|
||||
meet_criteria(open, allow_class = "logical", has_length = 1)
|
||||
language <- validate_language(language)
|
||||
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
|
||||
|
||||
|
||||
add_MO_lookup_to_AMR_env()
|
||||
|
||||
x.mo <- as.mo(x = x, language = language, keep_synonyms = keep_synonyms, ... = ...)
|
||||
@ -862,7 +867,7 @@ mo_property <- function(x, property = "fullname", language = get_AMR_locale(), k
|
||||
|
||||
mo_validate <- function(x, property, language, keep_synonyms = keep_synonyms, ...) {
|
||||
add_MO_lookup_to_AMR_env()
|
||||
|
||||
|
||||
# try to catch an error when inputting an invalid argument
|
||||
# so the 'call.' can be set to FALSE
|
||||
tryCatch(x[1L] %in% unlist(AMR_env$MO_lookup[1, property, drop = TRUE]),
|
||||
|
@ -262,7 +262,7 @@ get_mo_source <- function(destination = getOption("AMR_mo_source", "~/mo_source.
|
||||
|
||||
check_validity_mo_source <- function(x, refer_to_name = "`reference_df`", stop_on_error = TRUE) {
|
||||
add_MO_lookup_to_AMR_env()
|
||||
|
||||
|
||||
if (paste(deparse(substitute(x)), collapse = "") == "get_mo_source()") {
|
||||
return(TRUE)
|
||||
}
|
||||
|
@ -140,7 +140,6 @@
|
||||
#' )
|
||||
#' }
|
||||
#' if (require("dplyr")) {
|
||||
#'
|
||||
#' # scoped dplyr verbs with antibiotic selectors
|
||||
#' # (you could also use across() of course)
|
||||
#' example_isolates %>%
|
||||
|
@ -274,7 +274,7 @@ resistance_predict <- function(x,
|
||||
df_prediction$value <- ifelse(df_prediction$value > 1, 1, pmax(df_prediction$value, 0))
|
||||
df_prediction <- df_prediction[order(df_prediction$year), , drop = FALSE]
|
||||
|
||||
out <- as_original_data_class(df_prediction, class(x.bak)) # will remove tibble groups
|
||||
out <- as_original_data_class(df_prediction, class(x.bak)) # will remove tibble groups
|
||||
structure(out,
|
||||
class = c("resistance_predict", class(out)),
|
||||
I_as_S = I_as_S,
|
||||
|
98
R/sir.R
98
R/sir.R
@ -64,16 +64,16 @@
|
||||
#' ```
|
||||
#' 4. For **interpreting a complete data set**, with automatic determination of MIC values, disk diffusion diameters, microorganism names or codes, and antimicrobial test results. This is done very simply by running `as.sir(your_data)`.
|
||||
#'
|
||||
#' For points 2, 3 and 4: Use [sir_interpretation_history()] to retrieve a [data.frame] (or [tibble][tibble::tibble()] if the `tibble` package is installed) with all results of the last [as.sir()] call.
|
||||
#' **For points 2, 3 and 4: Use [sir_interpretation_history()]** to retrieve a [data.frame] (or [tibble][tibble::tibble()] if the `tibble` package is installed) with all results of the last [as.sir()] call.
|
||||
#'
|
||||
#' ### Supported Guidelines
|
||||
#'
|
||||
#' For interpreting MIC values as well as disk diffusion diameters, currently implemented guidelines are EUCAST (`r min(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`) and CLSI (`r min(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "CLSI")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "CLSI")$guideline)))`).
|
||||
#'
|
||||
#' Thus, the `guideline` argument must be set to e.g., ``r paste0('"', subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline[1], '"')`` or ``r paste0('"', subset(clinical_breakpoints, guideline %like% "CLSI")$guideline[1], '"')``. By simply using `"EUCAST"` (the default) or `"CLSI"` as input, the latest included version of that guideline will automatically be selected. You can set your own data set using the `reference_data` argument. The `guideline` argument will then be ignored.
|
||||
#'
|
||||
#'
|
||||
#' You can set the default guideline with the `AMR_guideline` [option][options()] (e.g. in your `.Rprofile` file), such as:
|
||||
#'
|
||||
#'
|
||||
#' ```
|
||||
#' options(AMR_guideline = "CLSI")
|
||||
#' options(AMR_guideline = "CLSI 2018")
|
||||
@ -104,7 +104,7 @@
|
||||
#' A microorganism is categorised as "Susceptible, Increased exposure*" when there is a high likelihood of therapeutic success because exposure to the agent is increased by adjusting the dosing regimen or by its concentration at the site of infection.
|
||||
#' - **R = Resistant**\cr
|
||||
#' A microorganism is categorised as "Resistant" when there is a high likelihood of therapeutic failure even when there is increased exposure.
|
||||
#'
|
||||
#'
|
||||
#' * *Exposure* is a function of how the mode of administration, dose, dosing interval, infusion time, as well as distribution and excretion of the antimicrobial agent will influence the infecting organism at the site of infection.
|
||||
#'
|
||||
#' This AMR package honours this insight. Use [susceptibility()] (equal to [proportion_SI()]) to determine antimicrobial susceptibility and [count_susceptible()] (equal to [count_SI()]) to count susceptible isolates.
|
||||
@ -297,7 +297,7 @@ as.sir.default <- function(x, ...) {
|
||||
|
||||
x.bak <- x
|
||||
x <- as.character(x) # this is needed to prevent the vctrs pkg from throwing an error
|
||||
|
||||
|
||||
if (inherits(x.bak, c("integer", "numeric", "double")) && all(x %in% c(1:3, NA))) {
|
||||
# support haven package for importing e.g., from SPSS - it adds the 'labels' attribute
|
||||
lbls <- attributes(x.bak)$labels
|
||||
@ -328,7 +328,7 @@ as.sir.default <- function(x, ...) {
|
||||
x <- trimws2(as.character(unlist(x)))
|
||||
x[x %in% c(NA, "", "-", "NULL")] <- NA_character_
|
||||
x.bak <- x
|
||||
|
||||
|
||||
na_before <- length(x[is.na(x)])
|
||||
|
||||
# correct for translations
|
||||
@ -768,13 +768,13 @@ as_sir_method <- function(method_short,
|
||||
if (length(uti) == 1) {
|
||||
uti <- rep(uti, length(x))
|
||||
}
|
||||
|
||||
|
||||
if (isTRUE(add_intrinsic_resistance) && guideline_coerced %unlike% "EUCAST") {
|
||||
if (message_not_thrown_before("as.sir", "intrinsic")) {
|
||||
warning_("in `as.sir()`: using 'add_intrinsic_resistance' is only useful when using EUCAST guidelines, since the rules for intrinsic resistance are based on EUCAST.")
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
agent_formatted <- paste0("'", font_bold(ab.bak), "'")
|
||||
agent_name <- ab_name(ab, tolower = TRUE, language = NULL)
|
||||
if (generalise_antibiotic_name(ab.bak) == generalise_antibiotic_name(agent_name)) {
|
||||
@ -801,27 +801,31 @@ as_sir_method <- function(method_short,
|
||||
appendLF = FALSE,
|
||||
as_note = FALSE
|
||||
)
|
||||
|
||||
|
||||
msg_note <- function(messages) {
|
||||
for (i in seq_len(length(messages))) {
|
||||
messages[i] <- word_wrap(extra_indent = 5, messages[i])
|
||||
}
|
||||
message(font_green(font_bold(" Note:\n")),
|
||||
paste0(" ", font_black(AMR_env$bullet_icon)," ", font_black(messages, collapse = NULL) , collapse = "\n"))
|
||||
message(
|
||||
font_green(font_bold(" Note:\n")),
|
||||
paste0(" ", font_black(AMR_env$bullet_icon), " ", font_black(messages, collapse = NULL), collapse = "\n")
|
||||
)
|
||||
}
|
||||
|
||||
method <- method_short
|
||||
|
||||
metadata_mo <- get_mo_uncertainties()
|
||||
|
||||
df <- data.frame(values = x,
|
||||
mo = mo,
|
||||
result = NA_sir_,
|
||||
uti = uti,
|
||||
stringsAsFactors = FALSE)
|
||||
df <- data.frame(
|
||||
values = x,
|
||||
mo = mo,
|
||||
result = NA_sir_,
|
||||
uti = uti,
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
if (method == "mic") {
|
||||
# when as.sir.mic is called directly
|
||||
df$values <- as.mic(df$values)
|
||||
df$values <- as.mic(df$values)
|
||||
} else if (method == "disk") {
|
||||
# when as.sir.disk is called directly
|
||||
df$values <- as.disk(df$values)
|
||||
@ -832,7 +836,7 @@ as_sir_method <- function(method_short,
|
||||
method_coerced <- toupper(method)
|
||||
ab_coerced <- ab
|
||||
mo_coerced <- mo
|
||||
|
||||
|
||||
if (identical(reference_data, AMR::clinical_breakpoints)) {
|
||||
breakpoints <- reference_data %pm>%
|
||||
subset(guideline == guideline_coerced & method == method_coerced & ab == ab_coerced)
|
||||
@ -845,30 +849,31 @@ as_sir_method <- function(method_short,
|
||||
breakpoints <- reference_data %pm>%
|
||||
subset(method == method_coerced & ab == ab_coerced)
|
||||
}
|
||||
|
||||
|
||||
msgs <- character(0)
|
||||
if (nrow(breakpoints) == 0) {
|
||||
# apparently no breakpoints found
|
||||
msg_note(paste0("No ", method_coerced, " breakpoints available for ",
|
||||
suppressMessages(suppressWarnings(ab_name(ab_coerced, language = NULL, tolower = TRUE))),
|
||||
" (", ab_coerced, ")"))
|
||||
msg_note(paste0(
|
||||
"No ", method_coerced, " breakpoints available for ",
|
||||
suppressMessages(suppressWarnings(ab_name(ab_coerced, language = NULL, tolower = TRUE))),
|
||||
" (", ab_coerced, ")"
|
||||
))
|
||||
load_mo_uncertainties(metadata_mo)
|
||||
return(rep(NA_sir_, nrow(df)))
|
||||
}
|
||||
|
||||
|
||||
if (guideline_coerced %like% "EUCAST") {
|
||||
any_is_intrinsic_resistant <- FALSE
|
||||
add_intrinsic_resistance_to_AMR_env()
|
||||
}
|
||||
|
||||
|
||||
# run the rules
|
||||
for (mo_unique in unique(df$mo)) {
|
||||
|
||||
rows <- which(df$mo == mo_unique)
|
||||
values <- df[rows, "values", drop = TRUE]
|
||||
uti <- df[rows, "uti", drop = TRUE]
|
||||
new_sir <- rep(NA_sir_, length(rows))
|
||||
|
||||
|
||||
# find different mo properties
|
||||
mo_current_genus <- as.mo(mo_genus(mo_unique, language = NULL))
|
||||
mo_current_family <- as.mo(mo_family(mo_unique, language = NULL))
|
||||
@ -890,17 +895,21 @@ as_sir_method <- function(method_short,
|
||||
if (!mo_rank(mo_unique) %in% c("kingdom", "phylum", "class", "order")) {
|
||||
mo_formatted <- font_italic(mo_formatted)
|
||||
}
|
||||
ab_formatted <- paste0(suppressMessages(suppressWarnings(ab_name(ab_coerced, language = NULL, tolower = TRUE))),
|
||||
" (", ab_coerced, ")")
|
||||
|
||||
# gather all available breakpoints for current MO and sort on taxonomic rank
|
||||
ab_formatted <- paste0(
|
||||
suppressMessages(suppressWarnings(ab_name(ab_coerced, language = NULL, tolower = TRUE))),
|
||||
" (", ab_coerced, ")"
|
||||
)
|
||||
|
||||
# gather all available breakpoints for current MO and sort on taxonomic rank
|
||||
# (this will prefer species breakpoints over order breakpoints)
|
||||
breakpoints_current <- breakpoints %pm>%
|
||||
subset(mo %in% c(mo_current_genus, mo_current_family,
|
||||
mo_current_order, mo_current_class,
|
||||
mo_current_becker, mo_current_lancefield,
|
||||
mo_current_other))
|
||||
|
||||
subset(mo %in% c(
|
||||
mo_current_genus, mo_current_family,
|
||||
mo_current_order, mo_current_class,
|
||||
mo_current_becker, mo_current_lancefield,
|
||||
mo_current_other
|
||||
))
|
||||
|
||||
if (any(df[rows, "uti", drop = TRUE], na.rm = TRUE)) {
|
||||
breakpoints_current <- breakpoints_current %pm>%
|
||||
# be as specific as possible (i.e. prefer species over genus):
|
||||
@ -911,7 +920,7 @@ as_sir_method <- function(method_short,
|
||||
# sort UTI = FALSE first, then UTI = TRUE
|
||||
pm_arrange(rank_index, uti)
|
||||
}
|
||||
|
||||
|
||||
# throw notes for different body sites
|
||||
if (nrow(breakpoints_current) == 1 && all(breakpoints_current$uti == TRUE) && any(uti %in% c(FALSE, NA)) && message_not_thrown_before("as.sir", "uti", ab_coerced)) {
|
||||
# only UTI breakpoints available
|
||||
@ -932,16 +941,15 @@ as_sir_method <- function(method_short,
|
||||
}
|
||||
msgs <- c(msgs, paste0("Multiple breakpoints available for ", ab_formatted, " in ", mo_formatted, " - assuming ", site, "."))
|
||||
}
|
||||
|
||||
|
||||
# first check if mo is intrinsic resistant
|
||||
if (isTRUE(add_intrinsic_resistance) && guideline_coerced %like% "EUCAST" && paste(mo_unique, ab_coerced) %in% AMR_env$intrinsic_resistant) {
|
||||
msgs <- c(msgs, paste0("Intrinsic resistance applied for ", ab_formatted, " in ", mo_formatted, ""))
|
||||
new_sir <- rep(as.sir("R"), length(rows))
|
||||
|
||||
} else {
|
||||
# then run the rules
|
||||
breakpoints_current <- breakpoints_current[1L, , drop = FALSE]
|
||||
|
||||
|
||||
if (method == "mic") {
|
||||
new_sir <- quick_case_when(
|
||||
is.na(values) ~ NA_sir_,
|
||||
@ -953,7 +961,6 @@ as_sir_method <- function(method_short,
|
||||
# and NA otherwise
|
||||
TRUE ~ NA_sir_
|
||||
)
|
||||
|
||||
} else if (method == "disk") {
|
||||
new_sir <- quick_case_when(
|
||||
is.na(values) ~ NA_sir_,
|
||||
@ -988,10 +995,10 @@ as_sir_method <- function(method_short,
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
df[rows, "result"] <- new_sir
|
||||
}
|
||||
|
||||
|
||||
if (isTRUE(rise_warning)) {
|
||||
message(font_yellow(font_bold(" * WARNING *")))
|
||||
} else if (length(msgs) == 0) {
|
||||
@ -999,9 +1006,9 @@ as_sir_method <- function(method_short,
|
||||
} else {
|
||||
msg_note(sort(msgs))
|
||||
}
|
||||
|
||||
|
||||
load_mo_uncertainties(metadata_mo)
|
||||
|
||||
|
||||
df$result
|
||||
}
|
||||
|
||||
@ -1027,6 +1034,9 @@ sir_interpretation_history <- function(clean = FALSE) {
|
||||
AMR_env$sir_interpretation_history <- out.bak
|
||||
}
|
||||
|
||||
# sort descending on time
|
||||
out <- out[order(out$datetime, decreasing = TRUE), , drop = FALSE]
|
||||
|
||||
if (pkg_is_available("tibble", also_load = FALSE)) {
|
||||
import_fn("as_tibble", "tibble")(out)
|
||||
} else {
|
||||
|
BIN
R/sysdata.rda
BIN
R/sysdata.rda
Binary file not shown.
@ -141,10 +141,11 @@ reset_AMR_locale <- function() {
|
||||
#' @export
|
||||
translate_AMR <- function(x, language = get_AMR_locale()) {
|
||||
translate_into_language(x,
|
||||
language = language,
|
||||
only_unknown = FALSE,
|
||||
only_affect_ab_names = FALSE,
|
||||
only_affect_mo_names = FALSE)
|
||||
language = language,
|
||||
only_unknown = FALSE,
|
||||
only_affect_ab_names = FALSE,
|
||||
only_affect_mo_names = FALSE
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
@ -170,14 +171,15 @@ find_language <- function(language, fallback = TRUE) {
|
||||
language <- Map(LANGUAGES_SUPPORTED_NAMES,
|
||||
LANGUAGES_SUPPORTED,
|
||||
f = function(l, n, check = language) {
|
||||
grepl(paste0(
|
||||
"^(", l[1], "|", l[2], "|",
|
||||
n, "(_|$)|", toupper(n), "(_|$))"
|
||||
),
|
||||
check,
|
||||
ignore.case = TRUE,
|
||||
perl = TRUE,
|
||||
useBytes = FALSE
|
||||
grepl(
|
||||
paste0(
|
||||
"^(", l[1], "|", l[2], "|",
|
||||
n, "(_|$)|", toupper(n), "(_|$))"
|
||||
),
|
||||
check,
|
||||
ignore.case = TRUE,
|
||||
perl = TRUE,
|
||||
useBytes = FALSE
|
||||
)
|
||||
},
|
||||
USE.NAMES = TRUE
|
||||
@ -196,7 +198,6 @@ translate_into_language <- function(from,
|
||||
only_unknown = FALSE,
|
||||
only_affect_ab_names = FALSE,
|
||||
only_affect_mo_names = FALSE) {
|
||||
|
||||
# get ISO-639-1 of language
|
||||
lang <- validate_language(language)
|
||||
if (lang == "en") {
|
||||
@ -260,10 +261,10 @@ translate_into_language <- function(from,
|
||||
|
||||
# force UTF-8 for diacritics
|
||||
from_unique_translated <- enc2utf8(from_unique_translated)
|
||||
|
||||
|
||||
# a kind of left join to get all results back
|
||||
out <- from_unique_translated[match(from.bak, from_unique)]
|
||||
|
||||
|
||||
if (!identical(from.bak, out) && get_AMR_locale() == lang && message_not_thrown_before("translation", entire_session = TRUE) && interactive()) {
|
||||
message(word_wrap(
|
||||
"Assuming the ", LANGUAGES_SUPPORTED_NAMES[[lang]]$exonym, " language (",
|
||||
@ -271,6 +272,6 @@ translate_into_language <- function(from,
|
||||
add_fn = list(font_blue), as_note = TRUE
|
||||
))
|
||||
}
|
||||
|
||||
|
||||
out
|
||||
}
|
||||
|
@ -35,7 +35,8 @@
|
||||
#' @rdname AMR-deprecated
|
||||
#' @export
|
||||
NA_rsi_ <- set_clean_class(factor(NA_character_, levels = c("S", "I", "R"), ordered = TRUE),
|
||||
new_class = c("rsi", "ordered", "factor"))
|
||||
new_class = c("rsi", "ordered", "factor")
|
||||
)
|
||||
#' @rdname AMR-deprecated
|
||||
#' @export
|
||||
as.rsi <- function(x, ...) {
|
||||
@ -197,14 +198,18 @@ deprecation_warning <- function(old = NULL, new = NULL, extra_msg = NULL) {
|
||||
env <- paste0("deprecated_", old)
|
||||
if (!env %in% names(AMR_env)) {
|
||||
AMR_env[[paste0("deprecated_", old)]] <- 1
|
||||
warning_(ifelse(is.null(new),
|
||||
paste0("The `", old, "()` function is no longer in use"),
|
||||
paste0("The `", old, "()` function has been replaced with `", new, "()`")),
|
||||
", see `?AMR-deprecated`.",
|
||||
ifelse(!is.null(extra_msg),
|
||||
paste0(" ", extra_msg),
|
||||
""),
|
||||
"\nThis warning will be shown once per session.")
|
||||
warning_(
|
||||
ifelse(is.null(new),
|
||||
paste0("The `", old, "()` function is no longer in use"),
|
||||
paste0("The `", old, "()` function has been replaced with `", new, "()`")
|
||||
),
|
||||
", see `?AMR-deprecated`.",
|
||||
ifelse(!is.null(extra_msg),
|
||||
paste0(" ", extra_msg),
|
||||
""
|
||||
),
|
||||
"\nThis warning will be shown once per session."
|
||||
)
|
||||
}
|
||||
}
|
||||
}
|
||||
|
22
R/zzz.R
22
R/zzz.R
@ -192,18 +192,24 @@ if (utf8_supported && !is_latex) {
|
||||
if (!is.null(getOption("AMR_custom_ab")) && file.exists(getOption("AMR_custom_ab", default = ""))) {
|
||||
packageStartupMessage("Adding custom antimicrobials from '", getOption("AMR_custom_ab"), "'...", appendLF = FALSE)
|
||||
x <- readRDS2(getOption("AMR_custom_ab"))
|
||||
tryCatch({
|
||||
suppressWarnings(suppressMessages(add_custom_antimicrobials(x)))
|
||||
packageStartupMessage("OK.")
|
||||
}, error = function(e) packageStartupMessage("Failed: ", e$message))
|
||||
tryCatch(
|
||||
{
|
||||
suppressWarnings(suppressMessages(add_custom_antimicrobials(x)))
|
||||
packageStartupMessage("OK.")
|
||||
},
|
||||
error = function(e) packageStartupMessage("Failed: ", e$message)
|
||||
)
|
||||
}
|
||||
# if custom mo option is available, load it
|
||||
if (!is.null(getOption("AMR_custom_mo")) && file.exists(getOption("AMR_custom_mo", default = ""))) {
|
||||
packageStartupMessage("Adding custom microorganisms from '", getOption("AMR_custom_mo"), "'...", appendLF = FALSE)
|
||||
x <- readRDS2(getOption("AMR_custom_mo"))
|
||||
tryCatch({
|
||||
suppressWarnings(suppressMessages(add_custom_microorganisms(x)))
|
||||
packageStartupMessage("OK.")
|
||||
}, error = function(e) packageStartupMessage("Failed: ", e$message))
|
||||
tryCatch(
|
||||
{
|
||||
suppressWarnings(suppressMessages(add_custom_microorganisms(x)))
|
||||
packageStartupMessage("OK.")
|
||||
},
|
||||
error = function(e) packageStartupMessage("Failed: ", e$message)
|
||||
)
|
||||
}
|
||||
}
|
||||
|
@ -101,46 +101,48 @@ create_species_cons_cops <- function(type = c("CoNS", "CoPS")) {
|
||||
MO_staph <- AMR::microorganisms
|
||||
MO_staph <- MO_staph[which(MO_staph$genus == "Staphylococcus"), , drop = FALSE]
|
||||
if (type == "CoNS") {
|
||||
MO_staph[which(MO_staph$species %in% c(
|
||||
"coagulase-negative", "argensis", "arlettae",
|
||||
"auricularis", "borealis", "caeli", "capitis", "caprae",
|
||||
"carnosus", "casei", "caseolyticus", "chromogenes", "cohnii", "condimenti",
|
||||
"croceilyticus",
|
||||
"debuckii", "devriesei", "edaphicus", "epidermidis",
|
||||
"equorum", "felis", "fleurettii", "gallinarum",
|
||||
"haemolyticus", "hominis", "jettensis", "kloosii",
|
||||
"lentus", "lugdunensis", "massiliensis", "microti",
|
||||
"muscae", "nepalensis", "pasteuri", "petrasii",
|
||||
"pettenkoferi", "piscifermentans", "pragensis", "pseudoxylosus",
|
||||
"pulvereri", "rostri", "saccharolyticus", "saprophyticus",
|
||||
"sciuri", "simulans", "stepanovicii", "succinus",
|
||||
"ureilyticus",
|
||||
"vitulinus", "vitulus", "warneri", "xylosus",
|
||||
"caledonicus", "canis",
|
||||
"durrellii", "lloydii",
|
||||
"ratti", "taiwanensis", "veratri", "urealyticus"
|
||||
) |
|
||||
# old, now renamed to S. schleiferi (but still as synonym in our data of course):
|
||||
(MO_staph$species == "schleiferi" & MO_staph$subspecies %in% c("schleiferi", ""))),
|
||||
"mo",
|
||||
drop = TRUE
|
||||
MO_staph[
|
||||
which(MO_staph$species %in% c(
|
||||
"coagulase-negative", "argensis", "arlettae",
|
||||
"auricularis", "borealis", "caeli", "capitis", "caprae",
|
||||
"carnosus", "casei", "caseolyticus", "chromogenes", "cohnii", "condimenti",
|
||||
"croceilyticus",
|
||||
"debuckii", "devriesei", "edaphicus", "epidermidis",
|
||||
"equorum", "felis", "fleurettii", "gallinarum",
|
||||
"haemolyticus", "hominis", "jettensis", "kloosii",
|
||||
"lentus", "lugdunensis", "massiliensis", "microti",
|
||||
"muscae", "nepalensis", "pasteuri", "petrasii",
|
||||
"pettenkoferi", "piscifermentans", "pragensis", "pseudoxylosus",
|
||||
"pulvereri", "rostri", "saccharolyticus", "saprophyticus",
|
||||
"sciuri", "simulans", "stepanovicii", "succinus",
|
||||
"ureilyticus",
|
||||
"vitulinus", "vitulus", "warneri", "xylosus",
|
||||
"caledonicus", "canis",
|
||||
"durrellii", "lloydii",
|
||||
"ratti", "taiwanensis", "veratri", "urealyticus"
|
||||
) |
|
||||
# old, now renamed to S. schleiferi (but still as synonym in our data of course):
|
||||
(MO_staph$species == "schleiferi" & MO_staph$subspecies %in% c("schleiferi", ""))),
|
||||
"mo",
|
||||
drop = TRUE
|
||||
]
|
||||
} else if (type == "CoPS") {
|
||||
MO_staph[which(MO_staph$species %in% c(
|
||||
"coagulase-positive", "coagulans",
|
||||
"agnetis", "argenteus",
|
||||
"cornubiensis",
|
||||
"delphini", "lutrae",
|
||||
"hyicus", "intermedius",
|
||||
"pseudintermedius", "pseudointermedius",
|
||||
"schweitzeri", "simiae",
|
||||
"roterodami",
|
||||
"singaporensis"
|
||||
) |
|
||||
# old, now renamed to S. coagulans (but still as synonym in our data of course):
|
||||
(MO_staph$species == "schleiferi" & MO_staph$subspecies == "coagulans")),
|
||||
"mo",
|
||||
drop = TRUE
|
||||
MO_staph[
|
||||
which(MO_staph$species %in% c(
|
||||
"coagulase-positive", "coagulans",
|
||||
"agnetis", "argenteus",
|
||||
"cornubiensis",
|
||||
"delphini", "lutrae",
|
||||
"hyicus", "intermedius",
|
||||
"pseudintermedius", "pseudointermedius",
|
||||
"schweitzeri", "simiae",
|
||||
"roterodami",
|
||||
"singaporensis"
|
||||
) |
|
||||
# old, now renamed to S. coagulans (but still as synonym in our data of course):
|
||||
(MO_staph$species == "schleiferi" & MO_staph$subspecies == "coagulans")),
|
||||
"mo",
|
||||
drop = TRUE
|
||||
]
|
||||
}
|
||||
}
|
||||
@ -254,14 +256,15 @@ create_AB_AV_lookup <- function(df) {
|
||||
}
|
||||
new_df$generalised_loinc <- lapply(new_df$loinc, generalise_antibiotic_name)
|
||||
new_df$generalised_all <- unname(lapply(
|
||||
as.list(as.data.frame(t(new_df[,
|
||||
c(
|
||||
colnames(new_df)[colnames(new_df) %in% c("ab", "av", "atc", "cid", "name")],
|
||||
colnames(new_df)[colnames(new_df) %like% "generalised"]
|
||||
),
|
||||
drop = FALSE
|
||||
]),
|
||||
stringsAsFactors = FALSE
|
||||
as.list(as.data.frame(
|
||||
t(new_df[,
|
||||
c(
|
||||
colnames(new_df)[colnames(new_df) %in% c("ab", "av", "atc", "cid", "name")],
|
||||
colnames(new_df)[colnames(new_df) %like% "generalised"]
|
||||
),
|
||||
drop = FALSE
|
||||
]),
|
||||
stringsAsFactors = FALSE
|
||||
)),
|
||||
function(x) {
|
||||
x <- generalise_antibiotic_name(unname(unlist(x)))
|
||||
@ -472,7 +475,7 @@ suppressMessages(devtools::document(quiet = TRUE))
|
||||
if (!"styler" %in% rownames(utils::installed.packages())) {
|
||||
message("Package 'styler' not installed!")
|
||||
} else if (interactive()) {
|
||||
# # only when sourcing this file ourselves
|
||||
# only when sourcing this file ourselves
|
||||
# usethis::ui_info("Styling package")
|
||||
# styler::style_pkg(
|
||||
# style = styler::tidyverse_style,
|
||||
|
@ -1,4 +1,3 @@
|
||||
|
||||
license_text <- readLines("docs/LICENSE-text.html")
|
||||
license_text <- paste(license_text, collapse = "|||")
|
||||
license_text <- gsub("licen(s|c)e", "Survey", license_text, ignore.case = TRUE)
|
||||
|
@ -66,33 +66,36 @@ read_EUCAST <- function(sheet, file, guideline_name) {
|
||||
|
||||
# in the info header in the Excel file, EUCAST mentions which genera are targeted
|
||||
if (sheet %like% "anaerob.*Gram.*posi") {
|
||||
sheet <- paste0(c(
|
||||
"Actinomyces", "Bifidobacterium", "Clostridioides",
|
||||
"Clostridium", "Cutibacterium", "Eggerthella",
|
||||
"Eubacterium", "Lactobacillus", "Propionibacterium",
|
||||
"Staphylococcus saccharolyticus"
|
||||
),
|
||||
collapse = "_"
|
||||
sheet <- paste0(
|
||||
c(
|
||||
"Actinomyces", "Bifidobacterium", "Clostridioides",
|
||||
"Clostridium", "Cutibacterium", "Eggerthella",
|
||||
"Eubacterium", "Lactobacillus", "Propionibacterium",
|
||||
"Staphylococcus saccharolyticus"
|
||||
),
|
||||
collapse = "_"
|
||||
)
|
||||
} else if (sheet %like% "anaerob.*Gram.*nega") {
|
||||
sheet <- paste0(c(
|
||||
"Bacteroides",
|
||||
"Bilophila",
|
||||
"Fusobacterium",
|
||||
"Mobiluncus",
|
||||
"Parabacteroides",
|
||||
"Porphyromonas",
|
||||
"Prevotella"
|
||||
),
|
||||
collapse = "_"
|
||||
sheet <- paste0(
|
||||
c(
|
||||
"Bacteroides",
|
||||
"Bilophila",
|
||||
"Fusobacterium",
|
||||
"Mobiluncus",
|
||||
"Parabacteroides",
|
||||
"Porphyromonas",
|
||||
"Prevotella"
|
||||
),
|
||||
collapse = "_"
|
||||
)
|
||||
} else if (sheet == "Streptococcus A,B,C,G") {
|
||||
sheet <- paste0(microorganisms %>%
|
||||
filter(genus == "Streptococcus") %>%
|
||||
mutate(lancefield = mo_name(mo, Lancefield = TRUE)) %>%
|
||||
filter(lancefield %like% "^Streptococcus group") %>%
|
||||
pull(fullname),
|
||||
collapse = "_"
|
||||
sheet <- paste0(
|
||||
microorganisms %>%
|
||||
filter(genus == "Streptococcus") %>%
|
||||
mutate(lancefield = mo_name(mo, Lancefield = TRUE)) %>%
|
||||
filter(lancefield %like% "^Streptococcus group") %>%
|
||||
pull(fullname),
|
||||
collapse = "_"
|
||||
)
|
||||
} else if (sheet %like% "PK.*PD") {
|
||||
sheet <- "UNKNOWN"
|
||||
|
@ -142,14 +142,15 @@ abx2 <- bind_rows(abx_atc1, abx_atc2)
|
||||
rm(abx_atc1)
|
||||
rm(abx_atc2)
|
||||
|
||||
abx2$ab[is.na(abx2$ab)] <- toupper(abbreviate(gsub(
|
||||
"[/0-9-]",
|
||||
" ",
|
||||
abx2$name[is.na(abx2$ab)]
|
||||
),
|
||||
minlength = 3,
|
||||
method = "left.kept",
|
||||
strict = TRUE
|
||||
abx2$ab[is.na(abx2$ab)] <- toupper(abbreviate(
|
||||
gsub(
|
||||
"[/0-9-]",
|
||||
" ",
|
||||
abx2$name[is.na(abx2$ab)]
|
||||
),
|
||||
minlength = 3,
|
||||
method = "left.kept",
|
||||
strict = TRUE
|
||||
))
|
||||
|
||||
n_distinct(abx2$ab)
|
||||
@ -197,24 +198,26 @@ get_CID <- function(ab) {
|
||||
p$tick()
|
||||
|
||||
CID[i] <- tryCatch(
|
||||
data.table::fread(paste0(
|
||||
"https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/name/",
|
||||
URLencode(ab[i], reserved = TRUE),
|
||||
"/cids/TXT?name_type=complete"
|
||||
),
|
||||
showProgress = FALSE
|
||||
data.table::fread(
|
||||
paste0(
|
||||
"https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/name/",
|
||||
URLencode(ab[i], reserved = TRUE),
|
||||
"/cids/TXT?name_type=complete"
|
||||
),
|
||||
showProgress = FALSE
|
||||
)[[1]][1],
|
||||
error = function(e) NA_integer_
|
||||
)
|
||||
if (is.na(CID[i])) {
|
||||
# try with removing the text in brackets
|
||||
CID[i] <- tryCatch(
|
||||
data.table::fread(paste0(
|
||||
"https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/name/",
|
||||
URLencode(trimws(gsub("[(].*[)]", "", ab[i])), reserved = TRUE),
|
||||
"/cids/TXT?name_type=complete"
|
||||
),
|
||||
showProgress = FALSE
|
||||
data.table::fread(
|
||||
paste0(
|
||||
"https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/name/",
|
||||
URLencode(trimws(gsub("[(].*[)]", "", ab[i])), reserved = TRUE),
|
||||
"/cids/TXT?name_type=complete"
|
||||
),
|
||||
showProgress = FALSE
|
||||
)[[1]][1],
|
||||
error = function(e) NA_integer_
|
||||
)
|
||||
@ -223,12 +226,13 @@ get_CID <- function(ab) {
|
||||
# try match on word and take the lowest CID value (sorted)
|
||||
ab[i] <- gsub("[^a-z0-9]+", " ", ab[i], ignore.case = TRUE)
|
||||
CID[i] <- tryCatch(
|
||||
data.table::fread(paste0(
|
||||
"https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/name/",
|
||||
URLencode(ab[i], reserved = TRUE),
|
||||
"/cids/TXT?name_type=word"
|
||||
),
|
||||
showProgress = FALSE
|
||||
data.table::fread(
|
||||
paste0(
|
||||
"https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/name/",
|
||||
URLencode(ab[i], reserved = TRUE),
|
||||
"/cids/TXT?name_type=word"
|
||||
),
|
||||
showProgress = FALSE
|
||||
)[[1]][1],
|
||||
error = function(e) NA_integer_
|
||||
)
|
||||
@ -260,13 +264,14 @@ get_synonyms <- function(CID, clean = TRUE) {
|
||||
}
|
||||
|
||||
synonyms_txt <- tryCatch(
|
||||
data.table::fread(paste0(
|
||||
"https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/fastidentity/cid/",
|
||||
CID[i],
|
||||
"/synonyms/TXT"
|
||||
),
|
||||
sep = "\n",
|
||||
showProgress = FALSE
|
||||
data.table::fread(
|
||||
paste0(
|
||||
"https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/fastidentity/cid/",
|
||||
CID[i],
|
||||
"/synonyms/TXT"
|
||||
),
|
||||
sep = "\n",
|
||||
showProgress = FALSE
|
||||
)[[1]],
|
||||
error = function(e) NA_character_
|
||||
)
|
||||
|
@ -106,31 +106,32 @@ antivirals <- antivirals %>%
|
||||
oral_units,
|
||||
iv_ddd,
|
||||
iv_units
|
||||
) %>%
|
||||
) %>%
|
||||
AMR:::dataset_UTF8_to_ASCII()
|
||||
|
||||
av_codes <- tibble(name = antivirals$name %>%
|
||||
strsplit("(, | and )") %>%
|
||||
unlist() %>%
|
||||
unique() %>%
|
||||
sort()) %>%
|
||||
mutate(av_1st = toupper(abbreviate(name, minlength = 3, use.classes = FALSE))) %>%
|
||||
strsplit("(, | and )") %>%
|
||||
unlist() %>%
|
||||
unique() %>%
|
||||
sort()) %>%
|
||||
mutate(av_1st = toupper(abbreviate(name, minlength = 3, use.classes = FALSE))) %>%
|
||||
filter(!name %in% c("acid", "dipivoxil", "disoproxil", "marboxil", "alafenamide"))
|
||||
|
||||
replace_with_av_code <- function(name) {
|
||||
unname(av_codes$av_1st[match(name, av_codes$name)])
|
||||
}
|
||||
|
||||
names_codes <- antivirals %>%
|
||||
names_codes <- antivirals %>%
|
||||
separate(name,
|
||||
into = paste0("name", c(1:7)),
|
||||
sep = "(, | and )",
|
||||
remove = FALSE,
|
||||
fill = "right") %>%
|
||||
into = paste0("name", c(1:7)),
|
||||
sep = "(, | and )",
|
||||
remove = FALSE,
|
||||
fill = "right"
|
||||
) %>%
|
||||
# remove empty columns
|
||||
select(!where(function(x) all(is.na(x)))) %>%
|
||||
mutate_at(vars(matches("name[1-9]")), replace_with_av_code) %>%
|
||||
unite(av, matches("name[1-9]"), sep = "+", na.rm = TRUE) %>%
|
||||
select(!where(function(x) all(is.na(x)))) %>%
|
||||
mutate_at(vars(matches("name[1-9]")), replace_with_av_code) %>%
|
||||
unite(av, matches("name[1-9]"), sep = "+", na.rm = TRUE) %>%
|
||||
mutate(name = gsub("(, | and )", "/", name))
|
||||
substr(names_codes$name, 1, 1) <- toupper(substr(names_codes$name, 1, 1))
|
||||
|
||||
@ -143,8 +144,9 @@ antivirals <- antivirals %>% AMR:::dataset_UTF8_to_ASCII()
|
||||
|
||||
# add loinc, see 'data-raw/loinc.R'
|
||||
loinc_df <- read.csv("data-raw/Loinc.csv",
|
||||
row.names = NULL,
|
||||
stringsAsFactors = FALSE)
|
||||
row.names = NULL,
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
|
||||
loinc_df <- loinc_df %>% filter(CLASS == "DRUG/TOX")
|
||||
av_names <- antivirals %>%
|
||||
|
@ -173,7 +173,7 @@ dosage_new <- bind_rows(
|
||||
as.data.frame(stringsAsFactors = FALSE)
|
||||
rownames(dosage_new) <- NULL
|
||||
|
||||
dosage <- bind_rows(dosage_new, AMR::dosage) %>%
|
||||
dosage <- bind_rows(dosage_new, AMR::dosage) %>%
|
||||
dataset_UTF8_to_ASCII()
|
||||
|
||||
usethis::use_data(dosage, internal = FALSE, overwrite = TRUE, version = 2)
|
||||
|
@ -37,10 +37,10 @@
|
||||
# CSV file (~12,5 MB) as "taxonomy.csv". Their API unfortunately does
|
||||
# not include the full taxonomy and is currently (2022) pretty worthless.
|
||||
# 3. For data about human pathogens, we use Bartlett et al. (2022),
|
||||
# https://doi.org/10.1099/mic.0.001269. Their latest supplementary material
|
||||
# https://doi.org/10.1099/mic.0.001269. Their latest supplementary material
|
||||
# can be found here: https://github.com/padpadpadpad/bartlett_et_al_2022_human_pathogens.
|
||||
#. Download their latest xlsx file in the `data` folder and save it to our
|
||||
#. `data-raw` folder.
|
||||
# . Download their latest xlsx file in the `data` folder and save it to our
|
||||
# . `data-raw` folder.
|
||||
# 4. Set this folder_location to the path where these two files are:
|
||||
folder_location <- "~/Downloads/backbone/"
|
||||
file_gbif <- paste0(folder_location, "Taxon.tsv")
|
||||
@ -65,7 +65,7 @@ devtools::load_all(".") # load AMR package
|
||||
|
||||
get_author_year <- function(ref) {
|
||||
# Only keep first author, e.g. transform 'Smith, Jones, 2011' to 'Smith et al., 2011'
|
||||
|
||||
|
||||
authors2 <- iconv(ref, from = "UTF-8", to = "ASCII//TRANSLIT")
|
||||
authors2 <- gsub(" ?\\(Approved Lists [0-9]+\\) ?", " () ", authors2)
|
||||
authors2 <- gsub(" [)(]+ $", "", authors2)
|
||||
@ -73,21 +73,21 @@ get_author_year <- function(ref) {
|
||||
authors2 <- trimws(gsub("^[(](.*)[)]$", "\\1", authors2))
|
||||
# only take part after brackets if there's a name
|
||||
authors2 <- ifelse(grepl(".*[)] [a-zA-Z]+.*", authors2),
|
||||
gsub(".*[)] (.*)", "\\1", authors2),
|
||||
authors2
|
||||
gsub(".*[)] (.*)", "\\1", authors2),
|
||||
authors2
|
||||
)
|
||||
# replace parentheses with emend. to get the latest authors
|
||||
authors2 <- gsub("(", " emend. ", authors2, fixed = TRUE)
|
||||
authors2 <- gsub(")", "", authors2, fixed = TRUE)
|
||||
authors2 <- gsub(" +", " ", authors2)
|
||||
authors2 <- trimws(authors2)
|
||||
|
||||
|
||||
# get year from last 4 digits
|
||||
lastyear <- as.integer(gsub(".*([0-9]{4})$", "\\1", authors2))
|
||||
# can never be later than now
|
||||
lastyear <- ifelse(lastyear > as.integer(format(Sys.Date(), "%Y")),
|
||||
NA,
|
||||
lastyear
|
||||
NA,
|
||||
lastyear
|
||||
)
|
||||
# get authors without last year
|
||||
authors <- gsub("(.*)[0-9]{4}$", "\\1", authors2)
|
||||
@ -119,8 +119,8 @@ get_author_year <- function(ref) {
|
||||
authors[nchar(authors) <= 3] <- ""
|
||||
# combine author and year if year is available
|
||||
ref <- ifelse(!is.na(lastyear),
|
||||
paste0(authors, ", ", lastyear),
|
||||
authors
|
||||
paste0(authors, ", ", lastyear),
|
||||
authors
|
||||
)
|
||||
# fix beginning and ending
|
||||
ref <- gsub(", $", "", ref)
|
||||
@ -128,7 +128,7 @@ get_author_year <- function(ref) {
|
||||
ref <- gsub("^(emend|et al.,?)", "", ref)
|
||||
ref <- trimws(ref)
|
||||
ref <- gsub("'", "", ref)
|
||||
|
||||
|
||||
# a lot start with a lowercase character - fix that
|
||||
ref[!grepl("^d[A-Z]", ref)] <- gsub("^([a-z])", "\\U\\1", ref[!grepl("^d[A-Z]", ref)], perl = TRUE)
|
||||
# specific one for the French that are named dOrbigny
|
||||
@ -222,9 +222,9 @@ include_fungal_orders <- c(
|
||||
# get latest taxonomic names of these fungal orders
|
||||
include_fungal_orders_ids <- taxonomy_gbif.bak %>%
|
||||
filter(order %in% include_fungal_orders)
|
||||
include_fungal_orders <- taxonomy_gbif.bak %>%
|
||||
filter(taxonID %in% c(include_fungal_orders_ids$taxonID, include_fungal_orders_ids$acceptedNameUsageID)) %>%
|
||||
distinct(order) %>%
|
||||
include_fungal_orders <- taxonomy_gbif.bak %>%
|
||||
filter(taxonID %in% c(include_fungal_orders_ids$taxonID, include_fungal_orders_ids$acceptedNameUsageID)) %>%
|
||||
distinct(order) %>%
|
||||
pull(order)
|
||||
|
||||
# check some columns to validate below filters
|
||||
@ -361,7 +361,7 @@ for (page in LETTERS) {
|
||||
names <- names[ranks != "species"]
|
||||
ranks <- ranks[ranks != "species"]
|
||||
ranks[ranks == "domain"] <- "kingdom"
|
||||
|
||||
|
||||
df <- names %>%
|
||||
tibble() %>%
|
||||
t() %>%
|
||||
@ -369,7 +369,7 @@ for (page in LETTERS) {
|
||||
setNames(ranks) %>%
|
||||
# no candidates please
|
||||
filter(genus %unlike% "^(Candidatus|\\[)")
|
||||
|
||||
|
||||
taxonomy_lpsn_missing <- taxonomy_lpsn_missing %>%
|
||||
bind_rows(df)
|
||||
}
|
||||
@ -491,14 +491,14 @@ saveRDS(taxonomy_lpsn, "data-raw/taxonomy_lpsn.rds", version = 2)
|
||||
taxonomy_gbif <- taxonomy_gbif %>%
|
||||
# clean NAs and add fullname
|
||||
mutate(across(kingdom:subspecies, function(x) ifelse(is.na(x), "", x)),
|
||||
fullname = trimws(case_when(
|
||||
rank == "family" ~ family,
|
||||
rank == "order" ~ order,
|
||||
rank == "class" ~ class,
|
||||
rank == "phylum" ~ phylum,
|
||||
rank == "kingdom" ~ kingdom,
|
||||
TRUE ~ paste(genus, species, subspecies)
|
||||
)), .before = 1
|
||||
fullname = trimws(case_when(
|
||||
rank == "family" ~ family,
|
||||
rank == "order" ~ order,
|
||||
rank == "class" ~ class,
|
||||
rank == "phylum" ~ phylum,
|
||||
rank == "kingdom" ~ kingdom,
|
||||
TRUE ~ paste(genus, species, subspecies)
|
||||
)), .before = 1
|
||||
) %>%
|
||||
# keep only one GBIF taxon ID per full name
|
||||
arrange(fullname, gbif) %>%
|
||||
@ -507,14 +507,14 @@ taxonomy_gbif <- taxonomy_gbif %>%
|
||||
taxonomy_lpsn <- taxonomy_lpsn %>%
|
||||
# clean NAs and add fullname
|
||||
mutate(across(kingdom:subspecies, function(x) ifelse(is.na(x), "", x)),
|
||||
fullname = trimws(case_when(
|
||||
rank == "family" ~ family,
|
||||
rank == "order" ~ order,
|
||||
rank == "class" ~ class,
|
||||
rank == "phylum" ~ phylum,
|
||||
rank == "kingdom" ~ kingdom,
|
||||
TRUE ~ paste(genus, species, subspecies)
|
||||
)), .before = 1
|
||||
fullname = trimws(case_when(
|
||||
rank == "family" ~ family,
|
||||
rank == "order" ~ order,
|
||||
rank == "class" ~ class,
|
||||
rank == "phylum" ~ phylum,
|
||||
rank == "kingdom" ~ kingdom,
|
||||
TRUE ~ paste(genus, species, subspecies)
|
||||
)), .before = 1
|
||||
) %>%
|
||||
# keep only one LPSN record ID per full name
|
||||
arrange(fullname, lpsn) %>%
|
||||
@ -536,23 +536,25 @@ taxonomy_lpsn$lpsn_parent[taxonomy_lpsn$rank == "subspecies"] <- taxonomy_lpsn$l
|
||||
taxonomy <- taxonomy_lpsn %>%
|
||||
# join GBIF identifiers to them
|
||||
left_join(taxonomy_gbif %>% select(kingdom, fullname, starts_with("gbif")),
|
||||
by = c("kingdom", "fullname")
|
||||
by = c("kingdom", "fullname")
|
||||
)
|
||||
|
||||
# for everything else, add the GBIF data
|
||||
taxonomy <- taxonomy %>%
|
||||
bind_rows(taxonomy_gbif %>%
|
||||
filter(!paste(kingdom, fullname) %in% paste(taxonomy$kingdom, taxonomy$fullname))) %>%
|
||||
filter(!paste(kingdom, fullname) %in% paste(taxonomy$kingdom, taxonomy$fullname))) %>%
|
||||
arrange(fullname) %>%
|
||||
filter(fullname != "")
|
||||
|
||||
# get missing entries from existing microorganisms data set
|
||||
taxonomy <- taxonomy %>%
|
||||
bind_rows(AMR::microorganisms %>%
|
||||
select(all_of(colnames(taxonomy))) %>%
|
||||
filter(!paste(kingdom, fullname) %in% paste(taxonomy$kingdom, taxonomy$fullname),
|
||||
# these will be added later:
|
||||
source != "manually added")) %>%
|
||||
select(all_of(colnames(taxonomy))) %>%
|
||||
filter(
|
||||
!paste(kingdom, fullname) %in% paste(taxonomy$kingdom, taxonomy$fullname),
|
||||
# these will be added later:
|
||||
source != "manually added"
|
||||
)) %>%
|
||||
arrange(fullname) %>%
|
||||
filter(fullname != "")
|
||||
|
||||
@ -602,9 +604,10 @@ taxonomy <- taxonomy %>%
|
||||
source = "manually added"
|
||||
) %>%
|
||||
filter(!paste(kingdom, rank) %in% paste(taxonomy$kingdom, taxonomy$rank)) %>%
|
||||
left_join(current_gbif %>%
|
||||
select(kingdom, rank = taxonRank, ref = scientificNameAuthorship, gbif = taxonID, gbif_parent = parentNameUsageID),
|
||||
by = c("kingdom", "rank")
|
||||
left_join(
|
||||
current_gbif %>%
|
||||
select(kingdom, rank = taxonRank, ref = scientificNameAuthorship, gbif = taxonID, gbif_parent = parentNameUsageID),
|
||||
by = c("kingdom", "rank")
|
||||
) %>%
|
||||
mutate(source = ifelse(!is.na(gbif), "GBIF", source))
|
||||
)
|
||||
@ -625,17 +628,18 @@ for (i in 2:6) {
|
||||
source = "manually added"
|
||||
) %>%
|
||||
filter(!paste(kingdom, .[[ncol(.) - 4]], rank) %in% paste(taxonomy$kingdom, taxonomy[[i + 1]], taxonomy$rank)) %>%
|
||||
# get GBIF identifier where available
|
||||
left_join(current_gbif %>%
|
||||
select(kingdom, all_of(i_name), rank = taxonRank, ref = scientificNameAuthorship, gbif = taxonID, gbif_parent = parentNameUsageID),
|
||||
by = c("kingdom", "rank", i_name)
|
||||
) %>%
|
||||
mutate(source = ifelse(!is.na(gbif), "GBIF", source))
|
||||
# get GBIF identifier where available
|
||||
left_join(
|
||||
current_gbif %>%
|
||||
select(kingdom, all_of(i_name), rank = taxonRank, ref = scientificNameAuthorship, gbif = taxonID, gbif_parent = parentNameUsageID),
|
||||
by = c("kingdom", "rank", i_name)
|
||||
) %>%
|
||||
mutate(source = ifelse(!is.na(gbif), "GBIF", source))
|
||||
message("n = ", nrow(to_add))
|
||||
if (is.null(taxonomy_all_missing)) {
|
||||
taxonomy_all_missing <- to_add
|
||||
} else {
|
||||
taxonomy_all_missing <- taxonomy_all_missing %>%
|
||||
taxonomy_all_missing <- taxonomy_all_missing %>%
|
||||
bind_rows(to_add)
|
||||
}
|
||||
}
|
||||
@ -645,20 +649,24 @@ taxonomy <- taxonomy %>%
|
||||
bind_rows(taxonomy_all_missing)
|
||||
|
||||
# fix for duplicate fullnames within a kingdom (such as Nitrospira which is the name of the genus AND its class)
|
||||
taxonomy <- taxonomy %>%
|
||||
mutate(rank_index = case_when(rank == "subspecies" ~ 1,
|
||||
rank == "species" ~ 2,
|
||||
rank == "genus" ~ 3,
|
||||
rank == "family" ~ 4,
|
||||
rank == "order" ~ 5,
|
||||
rank == "class" ~ 6,
|
||||
TRUE ~ 7),
|
||||
fullname_rank = paste0(fullname, " {", rank, "}")) %>%
|
||||
arrange(kingdom, fullname, rank_index) %>%
|
||||
group_by(kingdom, fullname) %>%
|
||||
mutate(fullname = if_else(row_number() > 1, fullname_rank, fullname)) %>%
|
||||
ungroup() %>%
|
||||
select(-fullname_rank, -rank_index) %>%
|
||||
taxonomy <- taxonomy %>%
|
||||
mutate(
|
||||
rank_index = case_when(
|
||||
rank == "subspecies" ~ 1,
|
||||
rank == "species" ~ 2,
|
||||
rank == "genus" ~ 3,
|
||||
rank == "family" ~ 4,
|
||||
rank == "order" ~ 5,
|
||||
rank == "class" ~ 6,
|
||||
TRUE ~ 7
|
||||
),
|
||||
fullname_rank = paste0(fullname, " {", rank, "}")
|
||||
) %>%
|
||||
arrange(kingdom, fullname, rank_index) %>%
|
||||
group_by(kingdom, fullname) %>%
|
||||
mutate(fullname = if_else(row_number() > 1, fullname_rank, fullname)) %>%
|
||||
ungroup() %>%
|
||||
select(-fullname_rank, -rank_index) %>%
|
||||
arrange(fullname)
|
||||
|
||||
# now also add missing species (requires combination with genus)
|
||||
@ -676,12 +684,13 @@ taxonomy <- taxonomy %>%
|
||||
) %>%
|
||||
filter(!paste(kingdom, genus, species, rank) %in% paste(taxonomy$kingdom, taxonomy$genus, taxonomy$species, taxonomy$rank)) %>%
|
||||
# get GBIF identifier where available
|
||||
left_join(current_gbif %>%
|
||||
select(kingdom, genus, species = specificEpithet, rank = taxonRank, ref = scientificNameAuthorship, gbif = taxonID, gbif_parent = parentNameUsageID),
|
||||
by = c("kingdom", "rank", "genus", "species")
|
||||
left_join(
|
||||
current_gbif %>%
|
||||
select(kingdom, genus, species = specificEpithet, rank = taxonRank, ref = scientificNameAuthorship, gbif = taxonID, gbif_parent = parentNameUsageID),
|
||||
by = c("kingdom", "rank", "genus", "species")
|
||||
) %>%
|
||||
mutate(source = ifelse(!is.na(gbif), "GBIF", source))
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
# remove NAs from taxonomy again, and keep unique full names
|
||||
@ -702,7 +711,7 @@ manually_added <- AMR::microorganisms %>%
|
||||
filter(source == "manually added", !paste(kingdom, fullname) %in% paste(taxonomy$kingdom, taxonomy$fullname)) %>%
|
||||
select(fullname:subspecies, ref, source, rank)
|
||||
|
||||
manually_added <- manually_added %>%
|
||||
manually_added <- manually_added %>%
|
||||
bind_rows(salmonellae)
|
||||
|
||||
# get latest taxonomy for those entries
|
||||
@ -805,76 +814,83 @@ taxonomy <- taxonomy %>%
|
||||
pathogens <- read_excel(file_bartlett, sheet = "Tab 6 Full List")
|
||||
|
||||
# get all established, both old and current taxonomic names
|
||||
established <- pathogens %>%
|
||||
filter(status == "established") %>%
|
||||
established <- pathogens %>%
|
||||
filter(status == "established") %>%
|
||||
mutate(fullname = paste(genus, species)) %>%
|
||||
pull(fullname) %>%
|
||||
c(unlist(mo_current(.)),
|
||||
unlist(mo_synonyms(., keep_synonyms = FALSE))) %>%
|
||||
strsplit(" ", fixed = TRUE) %>%
|
||||
sapply(function(x) ifelse(length(x) == 1, x, paste(x[1], x[2]))) %>%
|
||||
sort() %>%
|
||||
pull(fullname) %>%
|
||||
c(
|
||||
unlist(mo_current(.)),
|
||||
unlist(mo_synonyms(., keep_synonyms = FALSE))
|
||||
) %>%
|
||||
strsplit(" ", fixed = TRUE) %>%
|
||||
sapply(function(x) ifelse(length(x) == 1, x, paste(x[1], x[2]))) %>%
|
||||
sort() %>%
|
||||
unique()
|
||||
|
||||
# get all putative, both old and current taxonomic names
|
||||
putative <- pathogens %>%
|
||||
filter(status == "putative") %>%
|
||||
putative <- pathogens %>%
|
||||
filter(status == "putative") %>%
|
||||
mutate(fullname = paste(genus, species)) %>%
|
||||
pull(fullname) %>%
|
||||
c(unlist(mo_current(.)),
|
||||
unlist(mo_synonyms(., keep_synonyms = FALSE))) %>%
|
||||
strsplit(" ", fixed = TRUE) %>%
|
||||
sapply(function(x) ifelse(length(x) == 1, x, paste(x[1], x[2]))) %>%
|
||||
sort() %>%
|
||||
pull(fullname) %>%
|
||||
c(
|
||||
unlist(mo_current(.)),
|
||||
unlist(mo_synonyms(., keep_synonyms = FALSE))
|
||||
) %>%
|
||||
strsplit(" ", fixed = TRUE) %>%
|
||||
sapply(function(x) ifelse(length(x) == 1, x, paste(x[1], x[2]))) %>%
|
||||
sort() %>%
|
||||
unique()
|
||||
|
||||
established <- established[established %unlike% "unknown"]
|
||||
putative <- putative[putative %unlike% "unknown"]
|
||||
|
||||
established_genera <- established %>%
|
||||
strsplit(" ", fixed = TRUE) %>%
|
||||
sapply(function(x) x[1]) %>%
|
||||
sort() %>%
|
||||
established_genera <- established %>%
|
||||
strsplit(" ", fixed = TRUE) %>%
|
||||
sapply(function(x) x[1]) %>%
|
||||
sort() %>%
|
||||
unique()
|
||||
|
||||
putative_genera <- putative %>%
|
||||
strsplit(" ", fixed = TRUE) %>%
|
||||
sapply(function(x) x[1]) %>%
|
||||
sort() %>%
|
||||
putative_genera <- putative %>%
|
||||
strsplit(" ", fixed = TRUE) %>%
|
||||
sapply(function(x) x[1]) %>%
|
||||
sort() %>%
|
||||
unique()
|
||||
|
||||
nonbacterial_genera <- AMR:::MO_PREVALENT_GENERA %>%
|
||||
c(unlist(mo_current(.)),
|
||||
unlist(mo_synonyms(., keep_synonyms = FALSE))) %>%
|
||||
strsplit(" ", fixed = TRUE) %>%
|
||||
sapply(function(x) x[1]) %>%
|
||||
sort() %>%
|
||||
nonbacterial_genera <- AMR:::MO_PREVALENT_GENERA %>%
|
||||
c(
|
||||
unlist(mo_current(.)),
|
||||
unlist(mo_synonyms(., keep_synonyms = FALSE))
|
||||
) %>%
|
||||
strsplit(" ", fixed = TRUE) %>%
|
||||
sapply(function(x) x[1]) %>%
|
||||
sort() %>%
|
||||
unique()
|
||||
nonbacterial_genera <- nonbacterial_genera[nonbacterial_genera %unlike% "unknown"]
|
||||
|
||||
# update prevalence based on taxonomy (following the recent and thorough work of Bartlett et al., 2022)
|
||||
# see https://doi.org/10.1099/mic.0.001269
|
||||
taxonomy <- taxonomy %>%
|
||||
taxonomy <- taxonomy %>%
|
||||
mutate(prevalence = case_when(
|
||||
# 'established' means 'have infected at least three persons in three or more references'
|
||||
paste(genus, species) %in% established & rank %in% c("species", "subspecies") ~ 1.0,
|
||||
# other genera in the 'established' group
|
||||
genus %in% established_genera & rank == "genus" ~ 1.0,
|
||||
|
||||
|
||||
# 'putative' means 'fewer than three known cases'
|
||||
paste(genus, species) %in% putative & rank %in% c("species", "subspecies") ~ 1.25,
|
||||
# other genera in the 'putative' group
|
||||
genus %in% putative_genera & rank == "genus" ~ 1.25,
|
||||
|
||||
|
||||
# species and subspecies in 'established' and 'putative' groups
|
||||
genus %in% c(established_genera, putative_genera) & rank %in% c("species", "subspecies") ~ 1.5,
|
||||
# other species from a genus in either group
|
||||
genus %in% nonbacterial_genera & rank %in% c("genus", "species", "subspecies") ~ 1.5,
|
||||
# we keep track of prevalent genera too of non-bacterial species
|
||||
genus %in% AMR:::MO_PREVALENT_GENERA & kingdom != "Bacteria" & rank %in% c("genus", "species", "subspecies") ~ 1.5,
|
||||
|
||||
|
||||
# all others
|
||||
TRUE ~ 2.0))
|
||||
TRUE ~ 2.0
|
||||
))
|
||||
|
||||
table(taxonomy$prevalence, useNA = "always")
|
||||
# (a lot will be removed further below)
|
||||
@ -909,13 +925,14 @@ mo_kingdom <- taxonomy %>%
|
||||
mo_phylum <- taxonomy %>%
|
||||
filter(rank == "phylum") %>%
|
||||
distinct(kingdom, phylum) %>%
|
||||
left_join(AMR::microorganisms %>%
|
||||
filter(rank == "phylum") %>%
|
||||
transmute(kingdom,
|
||||
phylum = fullname,
|
||||
mo_old = gsub("[A-Z]{1,2}_", "", as.character(mo))
|
||||
),
|
||||
by = c("kingdom", "phylum")
|
||||
left_join(
|
||||
AMR::microorganisms %>%
|
||||
filter(rank == "phylum") %>%
|
||||
transmute(kingdom,
|
||||
phylum = fullname,
|
||||
mo_old = gsub("[A-Z]{1,2}_", "", as.character(mo))
|
||||
),
|
||||
by = c("kingdom", "phylum")
|
||||
) %>%
|
||||
group_by(kingdom) %>%
|
||||
mutate(
|
||||
@ -935,13 +952,14 @@ mo_phylum <- mo_phylum %>%
|
||||
mo_class <- taxonomy %>%
|
||||
filter(rank == "class") %>%
|
||||
distinct(kingdom, class) %>%
|
||||
left_join(AMR::microorganisms %>%
|
||||
filter(rank == "class") %>%
|
||||
transmute(kingdom,
|
||||
class = fullname,
|
||||
mo_old = gsub("[A-Z]{1,2}_", "", as.character(mo))
|
||||
),
|
||||
by = c("kingdom", "class")
|
||||
left_join(
|
||||
AMR::microorganisms %>%
|
||||
filter(rank == "class") %>%
|
||||
transmute(kingdom,
|
||||
class = fullname,
|
||||
mo_old = gsub("[A-Z]{1,2}_", "", as.character(mo))
|
||||
),
|
||||
by = c("kingdom", "class")
|
||||
) %>%
|
||||
group_by(kingdom) %>%
|
||||
mutate(
|
||||
@ -961,13 +979,14 @@ mo_class <- mo_class %>%
|
||||
mo_order <- taxonomy %>%
|
||||
filter(rank == "order") %>%
|
||||
distinct(kingdom, order) %>%
|
||||
left_join(AMR::microorganisms %>%
|
||||
filter(rank == "order") %>%
|
||||
transmute(kingdom,
|
||||
order = fullname,
|
||||
mo_old = gsub("[A-Z]{1,2}_", "", as.character(mo))
|
||||
),
|
||||
by = c("kingdom", "order")
|
||||
left_join(
|
||||
AMR::microorganisms %>%
|
||||
filter(rank == "order") %>%
|
||||
transmute(kingdom,
|
||||
order = fullname,
|
||||
mo_old = gsub("[A-Z]{1,2}_", "", as.character(mo))
|
||||
),
|
||||
by = c("kingdom", "order")
|
||||
) %>%
|
||||
group_by(kingdom) %>%
|
||||
mutate(
|
||||
@ -987,13 +1006,14 @@ mo_order <- mo_order %>%
|
||||
mo_family <- taxonomy %>%
|
||||
filter(rank == "family") %>%
|
||||
distinct(kingdom, family) %>%
|
||||
left_join(AMR::microorganisms %>%
|
||||
filter(rank == "family") %>%
|
||||
transmute(kingdom,
|
||||
family = fullname,
|
||||
mo_old = gsub("[A-Z]{1,2}_", "", as.character(mo))
|
||||
),
|
||||
by = c("kingdom", "family")
|
||||
left_join(
|
||||
AMR::microorganisms %>%
|
||||
filter(rank == "family") %>%
|
||||
transmute(kingdom,
|
||||
family = fullname,
|
||||
mo_old = gsub("[A-Z]{1,2}_", "", as.character(mo))
|
||||
),
|
||||
by = c("kingdom", "family")
|
||||
) %>%
|
||||
group_by(kingdom) %>%
|
||||
mutate(
|
||||
@ -1014,11 +1034,12 @@ mo_genus <- taxonomy %>%
|
||||
filter(rank == "genus") %>%
|
||||
distinct(kingdom, genus) %>%
|
||||
# get available old MO codes
|
||||
left_join(AMR::microorganisms %>%
|
||||
filter(rank == "genus") %>%
|
||||
transmute(mo_genus_old = gsub("^[A-Z]+_", "", as.character(mo)), kingdom, genus) %>%
|
||||
distinct(kingdom, genus, .keep_all = TRUE),
|
||||
by = c("kingdom", "genus")
|
||||
left_join(
|
||||
AMR::microorganisms %>%
|
||||
filter(rank == "genus") %>%
|
||||
transmute(mo_genus_old = gsub("^[A-Z]+_", "", as.character(mo)), kingdom, genus) %>%
|
||||
distinct(kingdom, genus, .keep_all = TRUE),
|
||||
by = c("kingdom", "genus")
|
||||
) %>%
|
||||
distinct(kingdom, genus, .keep_all = TRUE) %>%
|
||||
# since kingdom is part of the code, genus abbreviations may be duplicated between kingdoms
|
||||
@ -1060,12 +1081,13 @@ mo_genus <- mo_genus %>%
|
||||
mo_species <- taxonomy %>%
|
||||
filter(rank == "species") %>%
|
||||
distinct(kingdom, genus, species) %>%
|
||||
left_join(AMR::microorganisms %>%
|
||||
filter(rank == "species") %>%
|
||||
transmute(mo_species_old = gsub("^[A-Z]+_[A-Z]+_", "", as.character(mo)), kingdom, genus, species) %>%
|
||||
filter(mo_species_old %unlike% "-") %>%
|
||||
distinct(kingdom, genus, species, .keep_all = TRUE),
|
||||
by = c("kingdom", "genus", "species")
|
||||
left_join(
|
||||
AMR::microorganisms %>%
|
||||
filter(rank == "species") %>%
|
||||
transmute(mo_species_old = gsub("^[A-Z]+_[A-Z]+_", "", as.character(mo)), kingdom, genus, species) %>%
|
||||
filter(mo_species_old %unlike% "-") %>%
|
||||
distinct(kingdom, genus, species, .keep_all = TRUE),
|
||||
by = c("kingdom", "genus", "species")
|
||||
) %>%
|
||||
distinct(kingdom, genus, species, .keep_all = TRUE) %>%
|
||||
group_by(kingdom, genus) %>%
|
||||
@ -1108,12 +1130,13 @@ mo_species <- mo_species %>%
|
||||
mo_subspecies <- taxonomy %>%
|
||||
filter(rank == "subspecies") %>%
|
||||
distinct(kingdom, genus, species, subspecies) %>%
|
||||
left_join(AMR::microorganisms %>%
|
||||
filter(rank %in% c("subspecies", "subsp.", "infraspecies")) %>%
|
||||
transmute(mo_subspecies_old = gsub("^[A-Z]+_[A-Z]+_[A-Z]+_", "", as.character(mo)), kingdom, genus, species, subspecies) %>%
|
||||
filter(mo_subspecies_old %unlike% "-") %>%
|
||||
distinct(kingdom, genus, species, subspecies, .keep_all = TRUE),
|
||||
by = c("kingdom", "genus", "species", "subspecies")
|
||||
left_join(
|
||||
AMR::microorganisms %>%
|
||||
filter(rank %in% c("subspecies", "subsp.", "infraspecies")) %>%
|
||||
transmute(mo_subspecies_old = gsub("^[A-Z]+_[A-Z]+_[A-Z]+_", "", as.character(mo)), kingdom, genus, species, subspecies) %>%
|
||||
filter(mo_subspecies_old %unlike% "-") %>%
|
||||
distinct(kingdom, genus, species, subspecies, .keep_all = TRUE),
|
||||
by = c("kingdom", "genus", "species", "subspecies")
|
||||
) %>%
|
||||
distinct(kingdom, genus, species, subspecies, .keep_all = TRUE) %>%
|
||||
group_by(kingdom, genus, species) %>%
|
||||
@ -1187,20 +1210,26 @@ taxonomy <- taxonomy %>%
|
||||
arrange(fullname)
|
||||
|
||||
# now check these - e.g. Nitrospira is the name of a genus AND its class
|
||||
taxonomy %>% filter(fullname %in% .[duplicated(fullname), "fullname", drop = TRUE]) %>% View()
|
||||
taxonomy %>%
|
||||
filter(fullname %in% .[duplicated(fullname), "fullname", drop = TRUE]) %>%
|
||||
View()
|
||||
taxonomy <- taxonomy %>%
|
||||
mutate(rank_index = case_when(kingdom == "Bacteria" ~ 1,
|
||||
kingdom == "Fungi" ~ 2,
|
||||
kingdom == "Protozoa" ~ 3,
|
||||
kingdom == "Archaea" ~ 4,
|
||||
TRUE ~ 5)) %>%
|
||||
arrange(fullname, rank_index) %>%
|
||||
distinct(fullname, .keep_all = TRUE) %>%
|
||||
select(-rank_index) %>%
|
||||
mutate(rank_index = case_when(
|
||||
kingdom == "Bacteria" ~ 1,
|
||||
kingdom == "Fungi" ~ 2,
|
||||
kingdom == "Protozoa" ~ 3,
|
||||
kingdom == "Archaea" ~ 4,
|
||||
TRUE ~ 5
|
||||
)) %>%
|
||||
arrange(fullname, rank_index) %>%
|
||||
distinct(fullname, .keep_all = TRUE) %>%
|
||||
select(-rank_index) %>%
|
||||
filter(mo != "")
|
||||
|
||||
# this must not exist:
|
||||
taxonomy %>% filter(mo %like% "__") %>% View()
|
||||
taxonomy %>%
|
||||
filter(mo %like% "__") %>%
|
||||
View()
|
||||
taxonomy <- taxonomy %>% filter(mo %unlike% "__")
|
||||
|
||||
|
||||
@ -1214,14 +1243,20 @@ taxonomy <- taxonomy %>% distinct(mo, .keep_all = TRUE)
|
||||
taxonomy %>% filter(fullname %in% .[duplicated(fullname), "fullname", drop = TRUE])
|
||||
|
||||
# are all GBIFs available?
|
||||
taxonomy %>% filter(!gbif_parent %in% gbif) %>% count(rank)
|
||||
taxonomy %>%
|
||||
filter(!gbif_parent %in% gbif) %>%
|
||||
count(rank)
|
||||
# try to find the right gbif IDs
|
||||
taxonomy$gbif_parent[which(!taxonomy$gbif_parent %in% taxonomy$gbif & taxonomy$rank == "species")] <- taxonomy$gbif[match(taxonomy$genus[which(!taxonomy$gbif_parent %in% taxonomy$gbif & taxonomy$rank == "species")], taxonomy$genus)]
|
||||
taxonomy$gbif_parent[which(!taxonomy$gbif_parent %in% taxonomy$gbif & taxonomy$rank == "class")] <- taxonomy$gbif[match(taxonomy$phylum[which(!taxonomy$gbif_parent %in% taxonomy$gbif & taxonomy$rank == "class")], taxonomy$phylum)]
|
||||
taxonomy %>% filter(!gbif_parent %in% gbif) %>% count(rank)
|
||||
taxonomy %>%
|
||||
filter(!gbif_parent %in% gbif) %>%
|
||||
count(rank)
|
||||
|
||||
# are all LPSNs available?
|
||||
taxonomy %>% filter(!lpsn_parent %in% lpsn) %>% count(rank)
|
||||
taxonomy %>%
|
||||
filter(!lpsn_parent %in% lpsn) %>%
|
||||
count(rank)
|
||||
# make GBIF refer to newest renaming according to LPSN
|
||||
taxonomy$gbif_renamed_to[which(!is.na(taxonomy$gbif_renamed_to) & !is.na(taxonomy$lpsn_renamed_to))] <- taxonomy$gbif[match(taxonomy$lpsn_renamed_to[which(!is.na(taxonomy$gbif_renamed_to) & !is.na(taxonomy$lpsn_renamed_to))], taxonomy$lpsn)]
|
||||
|
||||
@ -1251,21 +1286,33 @@ taxonomy <- taxonomy %>%
|
||||
|
||||
# no ghost families, orders classes, phyla
|
||||
taxonomy <- taxonomy %>%
|
||||
group_by(kingdom, family) %>% filter(n() > 1 | fullname %like% "unknown" | rank == "kingdom") %>%
|
||||
group_by(kingdom, order) %>% filter(n() > 1 | fullname %like% "unknown" | rank == "kingdom") %>%
|
||||
group_by(kingdom, class) %>% filter(n() > 1 | fullname %like% "unknown" | rank == "kingdom") %>%
|
||||
group_by(kingdom, phylum) %>% filter(n() > 1 | fullname %like% "unknown" | rank == "kingdom") %>%
|
||||
group_by(kingdom, family) %>%
|
||||
filter(n() > 1 | fullname %like% "unknown" | rank == "kingdom") %>%
|
||||
group_by(kingdom, order) %>%
|
||||
filter(n() > 1 | fullname %like% "unknown" | rank == "kingdom") %>%
|
||||
group_by(kingdom, class) %>%
|
||||
filter(n() > 1 | fullname %like% "unknown" | rank == "kingdom") %>%
|
||||
group_by(kingdom, phylum) %>%
|
||||
filter(n() > 1 | fullname %like% "unknown" | rank == "kingdom") %>%
|
||||
ungroup()
|
||||
|
||||
|
||||
message("\nCongratulations! The new taxonomic table will contain ", format(nrow(taxonomy), big.mark = ","), " rows.\n",
|
||||
"This was ", format(nrow(AMR::microorganisms), big.mark = ","), " rows.\n")
|
||||
message(
|
||||
"\nCongratulations! The new taxonomic table will contain ", format(nrow(taxonomy), big.mark = ","), " rows.\n",
|
||||
"This was ", format(nrow(AMR::microorganisms), big.mark = ","), " rows.\n"
|
||||
)
|
||||
|
||||
# these are the new ones:
|
||||
taxonomy %>% filter(!paste(kingdom, fullname) %in% paste(AMR::microorganisms$kingdom, AMR::microorganisms$fullname)) %>% View()
|
||||
taxonomy %>%
|
||||
filter(!paste(kingdom, fullname) %in% paste(AMR::microorganisms$kingdom, AMR::microorganisms$fullname)) %>%
|
||||
View()
|
||||
# these were removed:
|
||||
AMR::microorganisms %>% filter(!paste(kingdom, fullname) %in% paste(taxonomy$kingdom, taxonomy$fullname)) %>% View()
|
||||
AMR::microorganisms %>% filter(!fullname %in% taxonomy$fullname) %>% View()
|
||||
AMR::microorganisms %>%
|
||||
filter(!paste(kingdom, fullname) %in% paste(taxonomy$kingdom, taxonomy$fullname)) %>%
|
||||
View()
|
||||
AMR::microorganisms %>%
|
||||
filter(!fullname %in% taxonomy$fullname) %>%
|
||||
View()
|
||||
|
||||
|
||||
# Add SNOMED CT -----------------------------------------------------------
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -58,8 +58,9 @@ mo_name("Enterobacter asburiae/cloacae")
|
||||
# now add a custom entry - it will be considered by as.mo() and
|
||||
# all mo_*() functions
|
||||
add_custom_microorganisms(
|
||||
data.frame(genus = "Enterobacter",
|
||||
species = "asburiae/cloacae"
|
||||
data.frame(
|
||||
genus = "Enterobacter",
|
||||
species = "asburiae/cloacae"
|
||||
)
|
||||
)
|
||||
|
||||
@ -81,8 +82,10 @@ mo_info("Enterobacter asburiae/cloacae")
|
||||
|
||||
# the function tries to be forgiving:
|
||||
add_custom_microorganisms(
|
||||
data.frame(GENUS = "BACTEROIDES / PARABACTEROIDES SLASHLINE",
|
||||
SPECIES = "SPECIES")
|
||||
data.frame(
|
||||
GENUS = "BACTEROIDES / PARABACTEROIDES SLASHLINE",
|
||||
SPECIES = "SPECIES"
|
||||
)
|
||||
)
|
||||
mo_name("BACTEROIDES / PARABACTEROIDES")
|
||||
mo_rank("BACTEROIDES / PARABACTEROIDES")
|
||||
@ -93,9 +96,11 @@ mo_family("Bacteroides/Parabacteroides")
|
||||
|
||||
# for groups and complexes, set them as species or subspecies:
|
||||
add_custom_microorganisms(
|
||||
data.frame(genus = "Citrobacter",
|
||||
species = c("freundii", "braakii complex"),
|
||||
subspecies = c("complex", ""))
|
||||
data.frame(
|
||||
genus = "Citrobacter",
|
||||
species = c("freundii", "braakii complex"),
|
||||
subspecies = c("complex", "")
|
||||
)
|
||||
)
|
||||
mo_name(c("C. freundii complex", "C. braakii complex"))
|
||||
mo_species(c("C. freundii complex", "C. braakii complex"))
|
||||
|
@ -214,20 +214,17 @@ example_isolates[, ab_selector(oral_ddd > 1 & oral_units == "g")]
|
||||
# dplyr -------------------------------------------------------------------
|
||||
\donttest{
|
||||
if (require("dplyr")) {
|
||||
|
||||
# get AMR for all aminoglycosides e.g., per ward:
|
||||
example_isolates \%>\%
|
||||
group_by(ward) \%>\%
|
||||
summarise(across(aminoglycosides(), resistance))
|
||||
}
|
||||
if (require("dplyr")) {
|
||||
|
||||
# You can combine selectors with '&' to be more specific:
|
||||
example_isolates \%>\%
|
||||
select(penicillins() & administrable_per_os())
|
||||
}
|
||||
if (require("dplyr")) {
|
||||
|
||||
# get AMR for only drugs that matter - no intrinsic resistance:
|
||||
example_isolates \%>\%
|
||||
filter(mo_genus() \%in\% c("Escherichia", "Klebsiella")) \%>\%
|
||||
@ -235,7 +232,6 @@ if (require("dplyr")) {
|
||||
summarise(across(not_intrinsic_resistant(), resistance))
|
||||
}
|
||||
if (require("dplyr")) {
|
||||
|
||||
# get susceptibility for antibiotics whose name contains "trim":
|
||||
example_isolates \%>\%
|
||||
filter(first_isolate()) \%>\%
|
||||
@ -243,19 +239,16 @@ if (require("dplyr")) {
|
||||
summarise(across(ab_selector(name \%like\% "trim"), susceptibility))
|
||||
}
|
||||
if (require("dplyr")) {
|
||||
|
||||
# this will select columns 'IPM' (imipenem) and 'MEM' (meropenem):
|
||||
example_isolates \%>\%
|
||||
select(carbapenems())
|
||||
}
|
||||
if (require("dplyr")) {
|
||||
|
||||
# this will select columns 'mo', 'AMK', 'GEN', 'KAN' and 'TOB':
|
||||
example_isolates \%>\%
|
||||
select(mo, aminoglycosides())
|
||||
}
|
||||
if (require("dplyr")) {
|
||||
|
||||
# any() and all() work in dplyr's filter() too:
|
||||
example_isolates \%>\%
|
||||
filter(
|
||||
@ -264,25 +257,21 @@ if (require("dplyr")) {
|
||||
)
|
||||
}
|
||||
if (require("dplyr")) {
|
||||
|
||||
# also works with c():
|
||||
example_isolates \%>\%
|
||||
filter(any(c(carbapenems(), aminoglycosides()) == "R"))
|
||||
}
|
||||
if (require("dplyr")) {
|
||||
|
||||
# not setting any/all will automatically apply all():
|
||||
example_isolates \%>\%
|
||||
filter(aminoglycosides() == "R")
|
||||
}
|
||||
if (require("dplyr")) {
|
||||
|
||||
# this will select columns 'mo' and all antimycobacterial drugs ('RIF'):
|
||||
example_isolates \%>\%
|
||||
select(mo, ab_class("mycobact"))
|
||||
}
|
||||
if (require("dplyr")) {
|
||||
|
||||
# get bug/drug combinations for only glycopeptides in Gram-positives:
|
||||
example_isolates \%>\%
|
||||
filter(mo_is_gram_positive()) \%>\%
|
||||
@ -298,7 +287,6 @@ if (require("dplyr")) {
|
||||
select(penicillins()) # only the 'J01CA01' column will be selected
|
||||
}
|
||||
if (require("dplyr")) {
|
||||
|
||||
# with recent versions of dplyr this is all equal:
|
||||
x <- example_isolates[carbapenems() == "R", ]
|
||||
y <- example_isolates \%>\% filter(carbapenems() == "R")
|
||||
|
@ -91,7 +91,6 @@ ab_name("eryt")
|
||||
|
||||
\donttest{
|
||||
if (require("dplyr")) {
|
||||
|
||||
# you can quickly rename 'sir' columns using set_ab_names() with dplyr:
|
||||
example_isolates \%>\%
|
||||
set_ab_names(where(is.sir), property = "atc")
|
||||
|
@ -125,7 +125,7 @@ your_data \%>\% mutate(across(where(is.disk), as.sir))
|
||||
\item For \strong{interpreting a complete data set}, with automatic determination of MIC values, disk diffusion diameters, microorganism names or codes, and antimicrobial test results. This is done very simply by running \code{as.sir(your_data)}.
|
||||
}
|
||||
|
||||
For points 2, 3 and 4: Use \code{\link[=sir_interpretation_history]{sir_interpretation_history()}} to retrieve a \link{data.frame} (or \link[tibble:tibble]{tibble} if the \code{tibble} package is installed) with all results of the last \code{\link[=as.sir]{as.sir()}} call.
|
||||
\strong{For points 2, 3 and 4: Use \code{\link[=sir_interpretation_history]{sir_interpretation_history()}}} to retrieve a \link{data.frame} (or \link[tibble:tibble]{tibble} if the \code{tibble} package is installed) with all results of the last \code{\link[=as.sir]{as.sir()}} call.
|
||||
}
|
||||
|
||||
\subsection{Supported Guidelines}{
|
||||
|
@ -179,13 +179,11 @@ if (require("dplyr")) {
|
||||
filter(first_isolate())
|
||||
}
|
||||
if (require("dplyr")) {
|
||||
|
||||
# short-hand version:
|
||||
example_isolates \%>\%
|
||||
filter_first_isolate(info = FALSE)
|
||||
}
|
||||
if (require("dplyr")) {
|
||||
|
||||
# flag the first isolates per group:
|
||||
example_isolates \%>\%
|
||||
group_by(ward) \%>\%
|
||||
|
@ -44,11 +44,12 @@ is_new_episode(df$date, episode_days = 60) # TRUE/FALSE
|
||||
df[which(get_episode(df$date, 60) == 3), ]
|
||||
|
||||
# the functions also work for less than a day, e.g. to include one per hour:
|
||||
get_episode(c(
|
||||
Sys.time(),
|
||||
Sys.time() + 60 * 60
|
||||
),
|
||||
episode_days = 1 / 24
|
||||
get_episode(
|
||||
c(
|
||||
Sys.time(),
|
||||
Sys.time() + 60 * 60
|
||||
),
|
||||
episode_days = 1 / 24
|
||||
)
|
||||
|
||||
\donttest{
|
||||
@ -85,7 +86,6 @@ if (require("dplyr")) {
|
||||
)
|
||||
}
|
||||
if (require("dplyr")) {
|
||||
|
||||
# grouping on patients and microorganisms leads to the same
|
||||
# results as first_isolate() when using 'episode-based':
|
||||
x <- df \%>\%
|
||||
@ -102,7 +102,6 @@ if (require("dplyr")) {
|
||||
identical(x, y)
|
||||
}
|
||||
if (require("dplyr")) {
|
||||
|
||||
# but is_new_episode() has a lot more flexibility than first_isolate(),
|
||||
# since you can now group on anything that seems relevant:
|
||||
df \%>\%
|
||||
|
@ -138,13 +138,11 @@ At default, the names of antibiotics will be shown on the plots using \code{\lin
|
||||
\examples{
|
||||
\donttest{
|
||||
if (require("ggplot2") && require("dplyr")) {
|
||||
|
||||
# get antimicrobial results for drugs against a UTI:
|
||||
ggplot(example_isolates \%>\% select(AMX, NIT, FOS, TMP, CIP)) +
|
||||
geom_sir()
|
||||
}
|
||||
if (require("ggplot2") && require("dplyr")) {
|
||||
|
||||
# prettify the plot using some additional functions:
|
||||
df <- example_isolates \%>\% select(AMX, NIT, FOS, TMP, CIP)
|
||||
ggplot(df) +
|
||||
@ -155,21 +153,18 @@ if (require("ggplot2") && require("dplyr")) {
|
||||
theme_sir()
|
||||
}
|
||||
if (require("ggplot2") && require("dplyr")) {
|
||||
|
||||
# or better yet, simplify this using the wrapper function - a single command:
|
||||
example_isolates \%>\%
|
||||
select(AMX, NIT, FOS, TMP, CIP) \%>\%
|
||||
ggplot_sir()
|
||||
}
|
||||
if (require("ggplot2") && require("dplyr")) {
|
||||
|
||||
# get only proportions and no counts:
|
||||
example_isolates \%>\%
|
||||
select(AMX, NIT, FOS, TMP, CIP) \%>\%
|
||||
ggplot_sir(datalabels = FALSE)
|
||||
}
|
||||
if (require("ggplot2") && require("dplyr")) {
|
||||
|
||||
# add other ggplot2 arguments as you like:
|
||||
example_isolates \%>\%
|
||||
select(AMX, NIT, FOS, TMP, CIP) \%>\%
|
||||
@ -182,14 +177,12 @@ if (require("ggplot2") && require("dplyr")) {
|
||||
)
|
||||
}
|
||||
if (require("ggplot2") && require("dplyr")) {
|
||||
|
||||
# you can alter the colours with colour names:
|
||||
example_isolates \%>\%
|
||||
select(AMX) \%>\%
|
||||
ggplot_sir(colours = c(SI = "yellow"))
|
||||
}
|
||||
if (require("ggplot2") && require("dplyr")) {
|
||||
|
||||
# but you can also use the built-in colour-blind friendly colours for
|
||||
# your plots, where "S" is green, "I" is yellow and "R" is red:
|
||||
data.frame(
|
||||
@ -202,7 +195,6 @@ if (require("ggplot2") && require("dplyr")) {
|
||||
scale_sir_colours(Value4 = "S", Value5 = "I", Value6 = "R")
|
||||
}
|
||||
if (require("ggplot2") && require("dplyr")) {
|
||||
|
||||
# resistance of ciprofloxacine per age group
|
||||
example_isolates \%>\%
|
||||
mutate(first_isolate = first_isolate()) \%>\%
|
||||
@ -216,14 +208,12 @@ if (require("ggplot2") && require("dplyr")) {
|
||||
ggplot_sir(x = "age_group")
|
||||
}
|
||||
if (require("ggplot2") && require("dplyr")) {
|
||||
|
||||
# a shorter version which also adjusts data label colours:
|
||||
example_isolates \%>\%
|
||||
select(AMX, NIT, FOS, TMP, CIP) \%>\%
|
||||
ggplot_sir(colours = FALSE)
|
||||
}
|
||||
if (require("ggplot2") && require("dplyr")) {
|
||||
|
||||
# it also supports groups (don't forget to use the group var on `x` or `facet`):
|
||||
example_isolates \%>\%
|
||||
filter(mo_is_gram_negative(), ward != "Outpatient") \%>\%
|
||||
|
@ -405,7 +405,6 @@ mo_species("EHEC")
|
||||
mo_fullname("K. pneu rh")
|
||||
mo_shortname("K. pneu rh")
|
||||
|
||||
|
||||
\donttest{
|
||||
# Becker classification, see ?as.mo ----------------------------------------
|
||||
|
||||
|
@ -204,7 +204,6 @@ if (require("dplyr")) {
|
||||
)
|
||||
}
|
||||
if (require("dplyr")) {
|
||||
|
||||
# scoped dplyr verbs with antibiotic selectors
|
||||
# (you could also use across() of course)
|
||||
example_isolates \%>\%
|
||||
|
@ -34,7 +34,7 @@
|
||||
|
||||
# test only on GitHub Actions and at using RStudio jobs - not on CRAN as tests are lengthy
|
||||
if (tryCatch(isTRUE(AMR:::import_fn("isJob", "rstudioapi")()), error = function(e) FALSE) ||
|
||||
identical(Sys.getenv("R_RUN_TINYTEST"), "true")) {
|
||||
identical(Sys.getenv("R_RUN_TINYTEST"), "true")) {
|
||||
# env var 'R_LIBS_USER' got overwritten during 'R CMD check' in GitHub Actions, so:
|
||||
.libPaths(c(Sys.getenv("R_LIBS_USER_GH_ACTIONS"), .libPaths()))
|
||||
if (AMR:::pkg_is_available("tinytest", also_load = TRUE)) {
|
||||
|
@ -48,15 +48,16 @@ For this tutorial, we will create fake demonstration data to work with.
|
||||
You can skip to [Cleaning the data](#cleaning-the-data) if you already have your own data ready. If you start your analysis, try to make the structure of your data generally look like this:
|
||||
|
||||
```{r example table, echo = FALSE, results = 'asis'}
|
||||
knitr::kable(data.frame(
|
||||
date = Sys.Date(),
|
||||
patient_id = c("abcd", "abcd", "efgh"),
|
||||
mo = "Escherichia coli",
|
||||
AMX = c("S", "S", "R"),
|
||||
CIP = c("S", "R", "S"),
|
||||
stringsAsFactors = FALSE
|
||||
),
|
||||
align = "c"
|
||||
knitr::kable(
|
||||
data.frame(
|
||||
date = Sys.Date(),
|
||||
patient_id = c("abcd", "abcd", "efgh"),
|
||||
mo = "Escherichia coli",
|
||||
AMX = c("S", "S", "R"),
|
||||
CIP = c("S", "R", "S"),
|
||||
stringsAsFactors = FALSE
|
||||
),
|
||||
align = "c"
|
||||
)
|
||||
```
|
||||
|
||||
@ -129,14 +130,15 @@ sample_size <- 20000
|
||||
data <- data.frame(
|
||||
date = sample(dates, size = sample_size, replace = TRUE),
|
||||
patient_id = sample(patients, size = sample_size, replace = TRUE),
|
||||
hospital = sample(c(
|
||||
"Hospital A",
|
||||
"Hospital B",
|
||||
"Hospital C",
|
||||
"Hospital D"
|
||||
),
|
||||
size = sample_size, replace = TRUE,
|
||||
prob = c(0.30, 0.35, 0.15, 0.20)
|
||||
hospital = sample(
|
||||
c(
|
||||
"Hospital A",
|
||||
"Hospital B",
|
||||
"Hospital C",
|
||||
"Hospital D"
|
||||
),
|
||||
size = sample_size, replace = TRUE,
|
||||
prob = c(0.30, 0.35, 0.15, 0.20)
|
||||
),
|
||||
bacteria = sample(bacteria,
|
||||
size = sample_size, replace = TRUE,
|
||||
@ -293,10 +295,11 @@ data_1st %>%
|
||||
```
|
||||
|
||||
```{r bug_drg 2b, echo = FALSE, results = 'asis'}
|
||||
knitr::kable(data_1st %>%
|
||||
filter(any(aminoglycosides() == "R")) %>%
|
||||
head(),
|
||||
align = "c"
|
||||
knitr::kable(
|
||||
data_1st %>%
|
||||
filter(any(aminoglycosides() == "R")) %>%
|
||||
head(),
|
||||
align = "c"
|
||||
)
|
||||
```
|
||||
|
||||
@ -309,10 +312,11 @@ data_1st %>%
|
||||
```
|
||||
|
||||
```{r bug_drg 1b, echo = FALSE, results = 'asis'}
|
||||
knitr::kable(data_1st %>%
|
||||
bug_drug_combinations() %>%
|
||||
head(),
|
||||
align = "c"
|
||||
knitr::kable(
|
||||
data_1st %>%
|
||||
bug_drug_combinations() %>%
|
||||
head(),
|
||||
align = "c"
|
||||
)
|
||||
```
|
||||
|
||||
@ -325,10 +329,11 @@ data_1st %>%
|
||||
|
||||
|
||||
```{r bug_drg 3b, echo = FALSE, results = 'asis'}
|
||||
knitr::kable(data_1st %>%
|
||||
select(bacteria, aminoglycosides()) %>%
|
||||
bug_drug_combinations(),
|
||||
align = "c"
|
||||
knitr::kable(
|
||||
data_1st %>%
|
||||
select(bacteria, aminoglycosides()) %>%
|
||||
bug_drug_combinations(),
|
||||
align = "c"
|
||||
)
|
||||
```
|
||||
|
||||
|
@ -88,11 +88,12 @@ data %>%
|
||||
|
||||
```{r, echo = FALSE}
|
||||
# on very old and some new releases of R, this may lead to an error
|
||||
tryCatch(data %>%
|
||||
group_by(Country) %>%
|
||||
select(Country, AMP_ND2, AMC_ED20, CAZ_ED10, CIP_ED5) %>%
|
||||
ggplot_sir(translate_ab = "ab", facet = "Country", datalabels = FALSE) %>%
|
||||
print(),
|
||||
error = function(e) base::invisible()
|
||||
tryCatch(
|
||||
data %>%
|
||||
group_by(Country) %>%
|
||||
select(Country, AMP_ND2, AMC_ED20, CAZ_ED10, CIP_ED5) %>%
|
||||
ggplot_sir(translate_ab = "ab", facet = "Country", datalabels = FALSE) %>%
|
||||
print(),
|
||||
error = function(e) base::invisible()
|
||||
)
|
||||
```
|
||||
|
Loading…
Reference in New Issue
Block a user