P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2024-12-25 20:46:11 +01:00
Code Releases Activity

sort sir history

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends 2023-01-23 15:01:21 +01:00
parent af139a3c82
commit 19fd0ef121
57 changed files with 2864 additions and 2739 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
DESCRIPTION
View File

@ -1,6 +1,6 @@
Package: AMR Package: AMR
Version: 1.8.2.9096 Version: 1.8.2.9098
Date: 2023-01-21 Date: 2023-01-23
Title: Antimicrobial Resistance Data Analysis Title: Antimicrobial Resistance Data Analysis
Description: Functions to simplify and standardise antimicrobial resistance (AMR) Description: Functions to simplify and standardise antimicrobial resistance (AMR)
data analysis and to work with microbial and antimicrobial properties by data analysis and to work with microbial and antimicrobial properties by

2
NEWS.md
View File

@ -1,4 +1,4 @@
# AMR 1.8.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!)* *(this beta version will eventually become v2.0! We're happy to reach a new major milestone soon!)*

171
R/aa_helper_functions.R
View File

@ -49,12 +49,13 @@ pm_left_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
merged <- cbind( merged <- cbind(
x, x,
y[match( y[
x[, by[1], drop = TRUE], match(
y[, by[2], drop = TRUE] x[, by[1], drop = TRUE],
), y[, by[2], drop = TRUE]
colnames(y)[!colnames(y) %in% colnames(x) & !colnames(y) == by[2]], ),
drop = FALSE 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) { replace_pos <- function(old, with) {
modifyRange(document_range( modifyRange(
document_position(current_row, current_col - nchar(old)), document_range(
document_position(current_row, current_col) document_position(current_row, current_col - nchar(old)),
), document_position(current_row, current_col)
text = with, ),
id = context$id text = with,
id = context$id
) )
} }
@ -253,11 +255,12 @@ search_type_in_df <- function(x, type, info = TRUE) {
# WHONET support # WHONET support
found <- sort(colnames(x)[colnames_formatted %like_case% "^(specimen date|specimen_date|spec_date)"]) found <- sort(colnames(x)[colnames_formatted %like_case% "^(specimen date|specimen_date|spec_date)"])
if (!inherits(pm_pull(x, found), c("Date", "POSIXct"))) { if (!inherits(pm_pull(x, found), c("Date", "POSIXct"))) {
stop(font_red(paste0( stop(
"Found column '", font_bold(found), "' to be used as input for `col_", type, font_red(paste0(
"`, but this column contains no valid dates. Transform its values to valid dates first." "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 )),
call. = FALSE
) )
} }
} else if (any(vapply(FUN.VALUE = logical(1), x, function(x) inherits(x, c("Date", "POSIXct"))))) { } 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) { is_valid_regex <- function(x) {
regex_at_all <- tryCatch(vapply( regex_at_all <- tryCatch(
FUN.VALUE = logical(1), vapply(
X = strsplit(x, "", fixed = TRUE), FUN.VALUE = logical(1),
FUN = function(y) { X = strsplit(x, "", fixed = TRUE),
any(y %in% c( FUN = function(y) {
"$", "(", ")", "*", "+", "-", any(
".", "?", "[", "]", "^", "{", y %in% c(
"|", "}", "\\" "$", "(", ")", "*", "+", "-",
), ".", "?", "[", "]", "^", "{",
na.rm = TRUE "|", "}", "\\"
) ),
}, na.rm = TRUE
USE.NAMES = FALSE )
), },
error = function(e) rep(TRUE, length(x)) USE.NAMES = FALSE
),
error = function(e) rep(TRUE, length(x))
) )
regex_valid <- vapply( regex_valid <- vapply(
FUN.VALUE = logical(1), FUN.VALUE = logical(1),
@ -410,16 +415,17 @@ word_wrap <- function(...,
if (msg %like% "\n") { if (msg %like% "\n") {
# run word_wraps() over every line here, bind them and return again # run word_wraps() over every line here, bind them and return again
return(paste0(vapply( return(paste0(
FUN.VALUE = character(1), vapply(
trimws(unlist(strsplit(msg, "\n", fixed = TRUE)), which = "right"), FUN.VALUE = character(1),
word_wrap, trimws(unlist(strsplit(msg, "\n", fixed = TRUE)), which = "right"),
add_fn = add_fn, word_wrap,
as_note = FALSE, add_fn = add_fn,
width = width, as_note = FALSE,
extra_indent = extra_indent width = width,
), extra_indent = extra_indent
collapse = "\n" ),
collapse = "\n"
)) ))
} }
@ -429,11 +435,12 @@ word_wrap <- function(...,
# we need to correct for already applied style, that adds text like "\033[31m\" # we need to correct for already applied style, that adds text like "\033[31m\"
msg_stripped <- font_stripstyle(msg) msg_stripped <- font_stripstyle(msg)
# where are the spaces now? # where are the spaces now?
msg_stripped_wrapped <- paste0(strwrap(msg_stripped, msg_stripped_wrapped <- paste0(
simplify = TRUE, strwrap(msg_stripped,
width = width simplify = TRUE,
), width = width
collapse = "\n" ),
collapse = "\n"
) )
msg_stripped_wrapped <- paste0(unlist(strsplit(msg_stripped_wrapped, "(\n|\\*\\|\\*)")), msg_stripped_wrapped <- paste0(unlist(strsplit(msg_stripped_wrapped, "(\n|\\*\\|\\*)")),
collapse = "\n" collapse = "\n"
@ -487,11 +494,12 @@ message_ <- function(...,
appendLF = TRUE, appendLF = TRUE,
add_fn = list(font_blue), add_fn = list(font_blue),
as_note = TRUE) { as_note = TRUE) {
message(word_wrap(..., message(
add_fn = add_fn, word_wrap(...,
as_note = as_note add_fn = add_fn,
), as_note = as_note
appendLF = appendLF ),
appendLF = appendLF
) )
} }
@ -499,12 +507,13 @@ warning_ <- function(...,
add_fn = list(), add_fn = list(),
immediate = FALSE, immediate = FALSE,
call = FALSE) { call = FALSE) {
warning(word_wrap(..., warning(
add_fn = add_fn, word_wrap(...,
as_note = FALSE add_fn = add_fn,
), as_note = FALSE
immediate. = immediate, ),
call. = call immediate. = immediate,
call. = call
) )
} }
@ -836,17 +845,18 @@ meet_criteria <- function(object,
) )
} }
if (!is.null(contains_column_class)) { if (!is.null(contains_column_class)) {
stop_ifnot(any(vapply( stop_ifnot(
FUN.VALUE = logical(1), any(vapply(
object, FUN.VALUE = logical(1),
function(col, columns_class = contains_column_class) { object,
inherits(col, columns_class) function(col, columns_class = contains_column_class) {
} inherits(col, columns_class)
), na.rm = TRUE), }
"the data provided in argument `", obj_name, ), na.rm = TRUE),
"` must contain at least one column of class <", contains_column_class, ">. ", "the data provided in argument `", obj_name,
"See ?as.", contains_column_class, ".", "` must contain at least one column of class <", contains_column_class, ">. ",
call = call_depth "See ?as.", contains_column_class, ".",
call = call_depth
) )
} }
return(invisible()) return(invisible())
@ -1314,7 +1324,6 @@ round2 <- function(x, digits = 1, force_zero = TRUE) {
# percentage from our other package: 'cleaner' # percentage from our other package: 'cleaner'
percentage <- function(x, digits = NULL, ...) { percentage <- function(x, digits = NULL, ...) {
# getdecimalplaces() function # getdecimalplaces() function
getdecimalplaces <- function(x, minimum = 0, maximum = 3) { getdecimalplaces <- function(x, minimum = 0, maximum = 3) {
if (maximum < minimum) { if (maximum < minimum) {
@ -1330,12 +1339,13 @@ percentage <- function(x, digits = NULL, ...) {
), ".", fixed = TRUE), ), ".", fixed = TRUE),
function(y) ifelse(length(y) == 2, nchar(y[2]), 0) function(y) ifelse(length(y) == 2, nchar(y[2]), 0)
)), na.rm = TRUE) )), na.rm = TRUE)
max(min(max_places, max(
maximum, min(max_places,
maximum,
na.rm = TRUE
),
minimum,
na.rm = TRUE na.rm = TRUE
),
minimum,
na.rm = TRUE
) )
} }
@ -1366,11 +1376,12 @@ percentage <- function(x, digits = NULL, ...) {
# max one digit if undefined # max one digit if undefined
digits <- getdecimalplaces(x, minimum = 0, maximum = 1) digits <- getdecimalplaces(x, minimum = 0, maximum = 1)
} }
format_percentage(structure( format_percentage(
.Data = as.double(x), structure(
class = c("percentage", "numeric") .Data = as.double(x),
), class = c("percentage", "numeric")
digits = digits, ... ),
digits = digits, ...
) )
} }

69
R/ab.R
View File

@ -87,7 +87,6 @@
#' #'
#' \donttest{ #' \donttest{
#' if (require("dplyr")) { #' if (require("dplyr")) {
#'
#' # you can quickly rename 'sir' columns using set_ab_names() with dplyr: #' # you can quickly rename 'sir' columns using set_ab_names() with dplyr:
#' example_isolates %>% #' example_isolates %>%
#' set_ab_names(where(is.sir), property = "atc") #' 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 # transform back from other languages and try again
x_translated <- paste(lapply( x_translated <- paste(
strsplit(x[i], "[^A-Z0-9]"), lapply(
function(y) { strsplit(x[i], "[^A-Z0-9]"),
for (i in seq_len(length(y))) { function(y) {
for (lang in LANGUAGES_SUPPORTED[LANGUAGES_SUPPORTED != "en"]) { for (i in seq_len(length(y))) {
y[i] <- ifelse(tolower(y[i]) %in% tolower(TRANSLATIONS[, lang, drop = TRUE]), for (lang in LANGUAGES_SUPPORTED[LANGUAGES_SUPPORTED != "en"]) {
TRANSLATIONS[which(tolower(TRANSLATIONS[, lang, drop = TRUE]) == tolower(y[i]) & y[i] <- ifelse(tolower(y[i]) %in% tolower(TRANSLATIONS[, lang, drop = TRUE]),
!isFALSE(TRANSLATIONS$fixed)), "pattern"], TRANSLATIONS[which(tolower(TRANSLATIONS[, lang, drop = TRUE]) == tolower(y[i]) &
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)) x_translated_guess <- suppressWarnings(as.ab(x_translated, initial_search = FALSE))
if (!is.na(x_translated_guess)) { 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" # now also try to coerce brandname combinations like "Amoxy/clavulanic acid"
x_translated <- paste(lapply( x_translated <- paste(
strsplit(x_translated, "[^A-Z0-9 ]"), lapply(
function(y) { strsplit(x_translated, "[^A-Z0-9 ]"),
for (i in seq_len(length(y))) { function(y) {
y_name <- suppressWarnings(ab_name(y[i], language = NULL, initial_search = FALSE)) for (i in seq_len(length(y))) {
y[i] <- ifelse(!is.na(y_name), y_name <- suppressWarnings(ab_name(y[i], language = NULL, initial_search = FALSE))
y_name, y[i] <- ifelse(!is.na(y_name),
y[i] 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)) x_translated_guess <- suppressWarnings(as.ab(x_translated, initial_search = FALSE))
if (!is.na(x_translated_guess)) { 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 <- x_unknown[!x_unknown %in% x_unknown_ATCs]
x_unknown <- c(x_unknown, x_unknown <- c(
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,
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) { if (length(x_unknown) > 0 && fast_mode == FALSE) {
warning_( warning_(
"in `as.ab()`: these values could not be coerced to a valid antimicrobial ID: ", "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 { } else {
translate_ab <- tolower(translate_ab) translate_ab <- tolower(translate_ab)
stop_ifnot(translate_ab %in% colnames(AMR::antibiotics), 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", "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.", "or TRUE (equals 'name') or FALSE to not translate at all.",
call = FALSE call = FALSE
) )
translate_ab translate_ab
} }

92
R/ab_selectors.R
View File

@ -95,20 +95,17 @@
#' # dplyr ------------------------------------------------------------------- #' # dplyr -------------------------------------------------------------------
#' \donttest{ #' \donttest{
#' if (require("dplyr")) { #' if (require("dplyr")) {
#'
#' # get AMR for all aminoglycosides e.g., per ward: #' # get AMR for all aminoglycosides e.g., per ward:
#' example_isolates %>% #' example_isolates %>%
#' group_by(ward) %>% #' group_by(ward) %>%
#' summarise(across(aminoglycosides(), resistance)) #' summarise(across(aminoglycosides(), resistance))
#' } #' }
#' if (require("dplyr")) { #' if (require("dplyr")) {
#'
#' # You can combine selectors with '&' to be more specific: #' # You can combine selectors with '&' to be more specific:
#' example_isolates %>% #' example_isolates %>%
#' select(penicillins() & administrable_per_os()) #' select(penicillins() & administrable_per_os())
#' } #' }
#' if (require("dplyr")) { #' if (require("dplyr")) {
#'
#' # get AMR for only drugs that matter - no intrinsic resistance: #' # get AMR for only drugs that matter - no intrinsic resistance:
#' example_isolates %>% #' example_isolates %>%
#' filter(mo_genus() %in% c("Escherichia", "Klebsiella")) %>% #' filter(mo_genus() %in% c("Escherichia", "Klebsiella")) %>%
@ -116,7 +113,6 @@
#' summarise(across(not_intrinsic_resistant(), resistance)) #' summarise(across(not_intrinsic_resistant(), resistance))
#' } #' }
#' if (require("dplyr")) { #' if (require("dplyr")) {
#'
#' # get susceptibility for antibiotics whose name contains "trim": #' # get susceptibility for antibiotics whose name contains "trim":
#' example_isolates %>% #' example_isolates %>%
#' filter(first_isolate()) %>% #' filter(first_isolate()) %>%
@ -124,19 +120,16 @@
#' summarise(across(ab_selector(name %like% "trim"), susceptibility)) #' summarise(across(ab_selector(name %like% "trim"), susceptibility))
#' } #' }
#' if (require("dplyr")) { #' if (require("dplyr")) {
#'
#' # this will select columns 'IPM' (imipenem) and 'MEM' (meropenem): #' # this will select columns 'IPM' (imipenem) and 'MEM' (meropenem):
#' example_isolates %>% #' example_isolates %>%
#' select(carbapenems()) #' select(carbapenems())
#' } #' }
#' if (require("dplyr")) { #' if (require("dplyr")) {
#'
#' # this will select columns 'mo', 'AMK', 'GEN', 'KAN' and 'TOB': #' # this will select columns 'mo', 'AMK', 'GEN', 'KAN' and 'TOB':
#' example_isolates %>% #' example_isolates %>%
#' select(mo, aminoglycosides()) #' select(mo, aminoglycosides())
#' } #' }
#' if (require("dplyr")) { #' if (require("dplyr")) {
#'
#' # any() and all() work in dplyr's filter() too: #' # any() and all() work in dplyr's filter() too:
#' example_isolates %>% #' example_isolates %>%
#' filter( #' filter(
@ -145,25 +138,21 @@
#' ) #' )
#' } #' }
#' if (require("dplyr")) { #' if (require("dplyr")) {
#'
#' # also works with c(): #' # also works with c():
#' example_isolates %>% #' example_isolates %>%
#' filter(any(c(carbapenems(), aminoglycosides()) == "R")) #' filter(any(c(carbapenems(), aminoglycosides()) == "R"))
#' } #' }
#' if (require("dplyr")) { #' if (require("dplyr")) {
#'
#' # not setting any/all will automatically apply all(): #' # not setting any/all will automatically apply all():
#' example_isolates %>% #' example_isolates %>%
#' filter(aminoglycosides() == "R") #' filter(aminoglycosides() == "R")
#' } #' }
#' if (require("dplyr")) { #' if (require("dplyr")) {
#'
#' # this will select columns 'mo' and all antimycobacterial drugs ('RIF'): #' # this will select columns 'mo' and all antimycobacterial drugs ('RIF'):
#' example_isolates %>% #' example_isolates %>%
#' select(mo, ab_class("mycobact")) #' select(mo, ab_class("mycobact"))
#' } #' }
#' if (require("dplyr")) { #' if (require("dplyr")) {
#'
#' # get bug/drug combinations for only glycopeptides in Gram-positives: #' # get bug/drug combinations for only glycopeptides in Gram-positives:
#' example_isolates %>% #' example_isolates %>%
#' filter(mo_is_gram_positive()) %>% #' filter(mo_is_gram_positive()) %>%
@ -179,7 +168,6 @@
#' select(penicillins()) # only the 'J01CA01' column will be selected #' select(penicillins()) # only the 'J01CA01' column will be selected
#' } #' }
#' if (require("dplyr")) { #' if (require("dplyr")) {
#'
#' # with recent versions of dplyr this is all equal: #' # with recent versions of dplyr this is all equal:
#' x <- example_isolates[carbapenems() == "R", ] #' x <- example_isolates[carbapenems() == "R", ]
#' y <- example_isolates %>% filter(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", ab_group = "administrable_per_os",
examples = paste0( examples = paste0(
" (such as ", " (such as ",
vector_or(ab_name(sample(agents_all, vector_or(
size = min(5, length(agents_all)), ab_name(
replace = FALSE sample(agents_all,
), size = min(5, length(agents_all)),
tolower = TRUE, replace = FALSE
language = NULL ),
), tolower = TRUE,
quotes = FALSE 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" sort = FALSE, fn = "not_intrinsic_resistant"
) )
# intrinsic vars # intrinsic vars
vars_df_R <- tryCatch(sapply( vars_df_R <- tryCatch(
eucast_rules(vars_df, sapply(
col_mo = col_mo, eucast_rules(vars_df,
version_expertrules = version_expertrules, col_mo = col_mo,
rules = "expert", version_expertrules = version_expertrules,
info = FALSE rules = "expert",
info = FALSE
),
function(col) {
tryCatch(!any(is.na(col)) && all(col == "R"),
error = function(e) FALSE
)
}
), ),
function(col) { error = function(e) stop_("in not_intrinsic_resistant(): ", e$message, call = FALSE)
tryCatch(!any(is.na(col)) && all(col == "R"),
error = function(e) 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)])] 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)) { if (message_not_thrown_before(function_name, "ab_class", "untreatable", entire_session = TRUE)) {
warning_( warning_(
"in `", function_name, "()`: some drugs were ignored since they cannot be used for treating patients: ", "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], vector_and(
language = NULL, ab_name(names(ab_in_data)[names(ab_in_data) %in% untreatable],
tolower = TRUE language = NULL,
), tolower = TRUE
quotes = FALSE, ),
sort = TRUE quotes = FALSE,
sort = TRUE
), ". They can be included using `", function_name, "(only_treatable = FALSE)`. ", ), ". They can be included using `", function_name, "(only_treatable = FALSE)`. ",
"This warning will be shown once per session." "This warning will be shown once per session."
) )
@ -593,11 +585,12 @@ ab_select_exec <- function(function_name,
} }
ab_group <- function_name ab_group <- function_name
} }
examples <- paste0(" (such as ", vector_or(ab_name(sample(abx, size = min(2, length(abx)), replace = FALSE), examples <- paste0(" (such as ", vector_or(
tolower = TRUE, ab_name(sample(abx, size = min(2, length(abx)), replace = FALSE),
language = NULL tolower = TRUE,
), language = NULL
quotes = FALSE ),
quotes = FALSE
), ")") ), ")")
} else { } else {
# this for the 'manual' ab_class() function # this for the 'manual' ab_class() function
@ -821,11 +814,12 @@ find_ab_names <- function(ab_group, n = 3) {
if (length(drugs) == 0) { if (length(drugs) == 0) {
return("??") return("??")
} }
vector_or(ab_name(sample(drugs, size = min(n, length(drugs)), replace = FALSE), vector_or(
tolower = TRUE, ab_name(sample(drugs, size = min(n, length(drugs)), replace = FALSE),
language = NULL tolower = TRUE,
), language = NULL
quotes = FALSE ),
quotes = FALSE
) )
} }

11
R/age.R
View File

@ -83,11 +83,12 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
# add decimals # add decimals
if (exact == TRUE) { if (exact == TRUE) {
# get dates of `x` when `x` would have the year of `reference` # get dates of `x` when `x` would have the year of `reference`
x_in_reference_year <- as.POSIXlt(paste0( x_in_reference_year <- as.POSIXlt(
format(as.Date(reference), "%Y"), paste0(
format(as.Date(x), "-%m-%d") format(as.Date(reference), "%Y"),
), format(as.Date(x), "-%m-%d")
format = "%Y-%m-%d" ),
format = "%Y-%m-%d"
) )
# get differences in days # get differences in days
n_days_x_rest <- as.double(difftime(as.Date(reference), n_days_x_rest <- as.double(difftime(as.Date(reference),

68
R/av.R
View File

@ -308,22 +308,23 @@ as.av <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
} }
# transform back from other languages and try again # transform back from other languages and try again
x_translated <- paste(lapply( x_translated <- paste(
strsplit(x[i], "[^A-Z0-9]"), lapply(
function(y) { strsplit(x[i], "[^A-Z0-9]"),
for (i in seq_len(length(y))) { function(y) {
for (lang in LANGUAGES_SUPPORTED[LANGUAGES_SUPPORTED != "en"]) { for (i in seq_len(length(y))) {
y[i] <- ifelse(tolower(y[i]) %in% tolower(TRANSLATIONS[, lang, drop = TRUE]), for (lang in LANGUAGES_SUPPORTED[LANGUAGES_SUPPORTED != "en"]) {
TRANSLATIONS[which(tolower(TRANSLATIONS[, lang, drop = TRUE]) == tolower(y[i]) & y[i] <- ifelse(tolower(y[i]) %in% tolower(TRANSLATIONS[, lang, drop = TRUE]),
!isFALSE(TRANSLATIONS$fixed)), "pattern"], TRANSLATIONS[which(tolower(TRANSLATIONS[, lang, drop = TRUE]) == tolower(y[i]) &
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)) x_translated_guess <- suppressWarnings(as.av(x_translated, initial_search = FALSE))
if (!is.na(x_translated_guess)) { 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" # now also try to coerce brandname combinations like "Amoxy/clavulanic acid"
x_translated <- paste(lapply( x_translated <- paste(
strsplit(x_translated, "[^A-Z0-9 ]"), lapply(
function(y) { strsplit(x_translated, "[^A-Z0-9 ]"),
for (i in seq_len(length(y))) { function(y) {
y_name <- suppressWarnings(av_name(y[i], language = NULL, initial_search = FALSE)) for (i in seq_len(length(y))) {
y[i] <- ifelse(!is.na(y_name), y_name <- suppressWarnings(av_name(y[i], language = NULL, initial_search = FALSE))
y_name, y[i] <- ifelse(!is.na(y_name),
y[i] 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)) x_translated_guess <- suppressWarnings(as.av(x_translated, initial_search = FALSE))
if (!is.na(x_translated_guess)) { 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 <- x_unknown[!x_unknown %in% x_unknown_ATCs]
x_unknown <- c(x_unknown, x_unknown <- c(
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,
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) { if (length(x_unknown) > 0 && fast_mode == FALSE) {
warning_( warning_(
"in `as.av()`: these values could not be coerced to a valid antiviral drug ID: ", "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 { } else {
translate_av <- tolower(translate_av) translate_av <- tolower(translate_av)
stop_ifnot(translate_av %in% colnames(AMR::antivirals), 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", "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.", "or TRUE (equals 'name') or FALSE to not translate at all.",
call = FALSE call = FALSE
) )
translate_av translate_av
} }

2
R/av_from_text.R
View File

@ -88,7 +88,7 @@ av_from_text <- function(text,
translate_av <- get_translate_av(translate_av) translate_av <- get_translate_av(translate_av)
if (isTRUE(thorough_search) || 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)] 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) { result <- lapply(text_split_all, function(text_split) {
progress$tick() progress$tick()

2
R/av_property.R
View File

@ -264,7 +264,7 @@ av_validate <- function(x, property, ...) {
# try to catch an error when inputting an invalid argument # try to catch an error when inputting an invalid argument
# so the 'call.' can be set to FALSE # so the 'call.' can be set to FALSE
tryCatch(x[1L] %in% AMR_env$AV_lookup[1, property, drop = TRUE], 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])) { if (!all(x %in% AMR_env$AV_lookup[, property, drop = TRUE])) {

11
R/custom_eucast_rules.R
View File

@ -240,11 +240,12 @@ print.custom_eucast_rules <- function(x, ...) {
" (", rule$result_group, ")" " (", rule$result_group, ")"
) )
agents <- sort(agents) agents <- sort(agents)
rule_if <- word_wrap(paste0( rule_if <- word_wrap(
i, ". ", font_bold("If "), font_blue(rule$query), font_bold(" then "), paste0(
"set to {result}:" i, ". ", font_bold("If "), font_blue(rule$query), font_bold(" then "),
), "set to {result}:"
extra_indent = 5 ),
extra_indent = 5
) )
rule_if <- gsub("{result}", val, rule_if, fixed = TRUE) rule_if <- gsub("{result}", val, rule_if, fixed = TRUE)
rule_then <- paste0(" ", word_wrap(paste0(agents, collapse = ", "), extra_indent = 5)) rule_then <- paste0(" ", word_wrap(paste0(agents, collapse = ", "), extra_indent = 5))

65
R/custom_microorganisms.R
View File

@ -77,8 +77,9 @@
#' # now add a custom entry - it will be considered by as.mo() and #' # now add a custom entry - it will be considered by as.mo() and
#' # all mo_*() functions #' # all mo_*() functions
#' add_custom_microorganisms( #' add_custom_microorganisms(
#' data.frame(genus = "Enterobacter", #' data.frame(
#' species = "asburiae/cloacae" #' genus = "Enterobacter",
#' species = "asburiae/cloacae"
#' ) #' )
#' ) #' )
#' #'
@ -100,8 +101,10 @@
#' #'
#' # the function tries to be forgiving: #' # the function tries to be forgiving:
#' add_custom_microorganisms( #' add_custom_microorganisms(
#' data.frame(GENUS = "BACTEROIDES / PARABACTEROIDES SLASHLINE", #' data.frame(
#' SPECIES = "SPECIES") #' GENUS = "BACTEROIDES / PARABACTEROIDES SLASHLINE",
#' SPECIES = "SPECIES"
#' )
#' ) #' )
#' mo_name("BACTEROIDES / PARABACTEROIDES") #' mo_name("BACTEROIDES / PARABACTEROIDES")
#' mo_rank("BACTEROIDES / PARABACTEROIDES") #' mo_rank("BACTEROIDES / PARABACTEROIDES")
@ -112,9 +115,11 @@
#' #'
#' # for groups and complexes, set them as species or subspecies: #' # for groups and complexes, set them as species or subspecies:
#' add_custom_microorganisms( #' add_custom_microorganisms(
#' data.frame(genus = "Citrobacter", #' data.frame(
#' species = c("freundii", "braakii complex"), #' genus = "Citrobacter",
#' subspecies = c("complex", "")) #' species = c("freundii", "braakii complex"),
#' subspecies = c("complex", "")
#' )
#' ) #' )
#' mo_name(c("C. freundii complex", "C. braakii complex")) #' mo_name(c("C. freundii complex", "C. braakii complex"))
#' mo_species(c("C. freundii complex", "C. braakii complex")) #' mo_species(c("C. freundii complex", "C. braakii complex"))
@ -163,19 +168,27 @@ add_custom_microorganisms <- function(x) {
x[, col] <- col_ x[, col] <- col_
} }
# if subspecies is a group or complex, add it to the species and empty the subspecies # 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$species[which(x$subspecies %in% c("group", "Group", "complex"))] <- paste(
x$subspecies[which(x$subspecies %in% c("group", "Group", "complex"))]) 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"))] <- "" x$subspecies[which(x$subspecies %in% c("group", "Group", "complex"))] <- ""
if ("rank" %in% colnames(x)) { if ("rank" %in% colnames(x)) {
stop_ifnot(all(x$rank %in% AMR_env$MO_lookup$rank), stop_ifnot(
"the 'rank' column can only contain these values: ", vector_or(AMR_env$MO_lookup$rank)) 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 { } else {
x$rank <- ifelse(x$subspecies != "", "subspecies", x$rank <- ifelse(x$subspecies != "", "subspecies",
ifelse(x$species != "", "species", ifelse(x$species != "", "species",
ifelse(x$genus != "", "genus", ifelse(x$genus != "", "genus",
stop("in add_custom_microorganisms(): only microorganisms up to the genus level can be added", stop("in add_custom_microorganisms(): only microorganisms up to the genus level can be added",
call. = FALSE)))) call. = FALSE
)
)
)
)
} }
x$source <- "Added by user" x$source <- "Added by user"
if (!"fullname" %in% colnames(x)) { if (!"fullname" %in% colnames(x)) {
@ -230,13 +243,21 @@ add_custom_microorganisms <- function(x) {
x$mo <- trimws2(as.character(x$mo)) x$mo <- trimws2(as.character(x$mo))
x$mo[x$mo == ""] <- NA_character_ x$mo[x$mo == ""] <- NA_character_
current <- sum(AMR_env$MO_lookup$source == "Added by user", na.rm = TRUE) current <- sum(AMR_env$MO_lookup$source == "Added by user", na.rm = TRUE)
x$mo[is.na(x$mo)] <- paste0("CUSTOM", x$mo[is.na(x$mo)] <- paste0(
seq.int(from = current + 1, to = current + nrow(x), by = 1), "CUSTOM",
"_", seq.int(from = current + 1, to = current + nrow(x), by = 1),
toupper(unname(abbreviate(gsub(" +", " _ ", "_",
gsub("[^A-Za-z0-9-]", " ", toupper(unname(abbreviate(
trimws2(paste(x$genus, x$species, x$subspecies)))), gsub(
minlength = 10)))) " +", " _ ",
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") 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 ---- # add to package ----

14
R/disk.R
View File

@ -120,13 +120,13 @@ as.disk <- function(x, na.rm = FALSE) {
vector_and(quotes = TRUE) vector_and(quotes = TRUE)
cur_col <- get_current_column() cur_col <- get_current_column()
warning_("in `as.disk()`: ", na_after - na_before, " result", warning_("in `as.disk()`: ", na_after - na_before, " result",
ifelse(na_after - na_before > 1, "s", ""), ifelse(na_after - na_before > 1, "s", ""),
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")), ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
" truncated (", " truncated (",
round(((na_after - na_before) / length(x)) * 100), round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid disk zones: ", "%) that were invalid disk zones: ",
list_missing, list_missing,
call = FALSE call = FALSE
) )
} }
} }

13
R/episode.R
View File

@ -57,11 +57,12 @@
#' df[which(get_episode(df$date, 60) == 3), ] #' df[which(get_episode(df$date, 60) == 3), ]
#' #'
#' # the functions also work for less than a day, e.g. to include one per hour: #' # the functions also work for less than a day, e.g. to include one per hour:
#' get_episode(c( #' get_episode(
#' Sys.time(), #' c(
#' Sys.time() + 60 * 60 #' Sys.time(),
#' ), #' Sys.time() + 60 * 60
#' episode_days = 1 / 24 #' ),
#' episode_days = 1 / 24
#' ) #' )
#' #'
#' \donttest{ #' \donttest{
@ -98,7 +99,6 @@
#' ) #' )
#' } #' }
#' if (require("dplyr")) { #' if (require("dplyr")) {
#'
#' # grouping on patients and microorganisms leads to the same #' # grouping on patients and microorganisms leads to the same
#' # results as first_isolate() when using 'episode-based': #' # results as first_isolate() when using 'episode-based':
#' x <- df %>% #' x <- df %>%
@ -115,7 +115,6 @@
#' identical(x, y) #' identical(x, y)
#' } #' }
#' if (require("dplyr")) { #' if (require("dplyr")) {
#'
#' # but is_new_episode() has a lot more flexibility than first_isolate(), #' # but is_new_episode() has a lot more flexibility than first_isolate(),
#' # since you can now group on anything that seems relevant: #' # since you can now group on anything that seems relevant:
#' df %>% #' df %>%

88
R/eucast_rules.R
View File

@ -702,11 +702,12 @@ eucast_rules <- function(x,
# Print rule ------------------------------------------------------------- # Print rule -------------------------------------------------------------
if (rule_current != rule_previous) { if (rule_current != rule_previous) {
# is new rule within group, print its name # is new rule within group, print its name
cat(italicise_taxonomy(word_wrap(rule_current, cat(italicise_taxonomy(
width = getOption("width") - 30, word_wrap(rule_current,
extra_indent = 6 width = getOption("width") - 30,
), extra_indent = 6
type = "ansi" ),
type = "ansi"
)) ))
warned <- FALSE 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% "coagulase" && any(x$genus == "Staphylococcus", na.rm = TRUE)) {
if (mo_value %like% "negative") { if (mo_value %like% "negative") {
eucast_rules_df[i, "this_value"] <- paste0( eucast_rules_df[i, "this_value"] <- paste0(
"^(", paste0(all_staph[which(all_staph$CNS_CPS %like% "negative"), "^(", paste0(
"fullname", all_staph[which(all_staph$CNS_CPS %like% "negative"),
drop = TRUE "fullname",
], drop = TRUE
collapse = "|" ],
collapse = "|"
), ),
")$" ")$"
) )
} else { } else {
eucast_rules_df[i, "this_value"] <- paste0( eucast_rules_df[i, "this_value"] <- paste0(
"^(", paste0(all_staph[which(all_staph$CNS_CPS %like% "positive"), "^(", paste0(
"fullname", all_staph[which(all_staph$CNS_CPS %like% "positive"),
drop = TRUE "fullname",
], drop = TRUE
collapse = "|" ],
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 # 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)) { if (mo_value %like% "group [ABCG]" && any(x$genus == "Streptococcus", na.rm = TRUE)) {
eucast_rules_df[i, "this_value"] <- paste0( eucast_rules_df[i, "this_value"] <- paste0(
"^(", paste0(all_strep[which(all_strep$Lancefield %like% "group [ABCG]"), "^(", paste0(
"fullname", all_strep[which(all_strep$Lancefield %like% "group [ABCG]"),
drop = TRUE "fullname",
], drop = TRUE
collapse = "|" ],
collapse = "|"
), ),
")$" ")$"
) )
@ -789,15 +793,17 @@ eucast_rules <- function(x,
if (length(source_antibiotics) == 0) { if (length(source_antibiotics) == 0) {
rows <- integer(0) rows <- integer(0)
} else if (length(source_antibiotics) == 1) { } else if (length(source_antibiotics) == 1) {
rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like% mo_value & rows <- tryCatch(
as.sir_no_warning(x[, source_antibiotics[1L]]) == source_value[1L]), which(x[, if_mo_property, drop = TRUE] %like% mo_value &
error = function(e) integer(0) as.sir_no_warning(x[, source_antibiotics[1L]]) == source_value[1L]),
error = function(e) integer(0)
) )
} else if (length(source_antibiotics) == 2) { } else if (length(source_antibiotics) == 2) {
rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like% mo_value & rows <- tryCatch(
as.sir_no_warning(x[, source_antibiotics[1L]]) == source_value[1L] & which(x[, if_mo_property, drop = TRUE] %like% mo_value &
as.sir_no_warning(x[, source_antibiotics[2L]]) == source_value[2L]), as.sir_no_warning(x[, source_antibiotics[1L]]) == source_value[1L] &
error = function(e) integer(0) as.sir_no_warning(x[, source_antibiotics[2L]]) == source_value[2L]),
error = function(e) integer(0)
) )
# nolint start # nolint start
# } else if (length(source_antibiotics) == 3) { # } else if (length(source_antibiotics) == 3) {
@ -872,11 +878,12 @@ eucast_rules <- function(x,
) )
if (isTRUE(info)) { if (isTRUE(info)) {
# print rule # print rule
cat(italicise_taxonomy(word_wrap(format_custom_query_rule(rule$query, colours = FALSE), cat(italicise_taxonomy(
width = getOption("width") - 30, word_wrap(format_custom_query_rule(rule$query, colours = FALSE),
extra_indent = 6 width = getOption("width") - 30,
), extra_indent = 6
type = "ansi" ),
type = "ansi"
)) ))
warned <- FALSE warned <- FALSE
} }
@ -1117,14 +1124,15 @@ edit_sir <- function(x,
}, },
error = function(e) { error = function(e) {
txt_error() txt_error()
stop(paste0( stop(
"In row(s) ", paste(rows[seq_len(min(length(rows), 10))], collapse = ","), paste0(
ifelse(length(rows) > 10, "...", ""), "In row(s) ", paste(rows[seq_len(min(length(rows), 10))], collapse = ","),
" while writing value '", to, ifelse(length(rows) > 10, "...", ""),
"' to column(s) `", paste(cols, collapse = "`, `"), " while writing value '", to,
"`:\n", e$message "' to column(s) `", paste(cols, collapse = "`, `"),
), "`:\n", e$message
call. = FALSE ),
call. = FALSE
) )
} }
) )

76
R/first_isolate.R
View File

@ -144,13 +144,11 @@
#' filter(first_isolate()) #' filter(first_isolate())
#' } #' }
#' if (require("dplyr")) { #' if (require("dplyr")) {
#'
#' # short-hand version: #' # short-hand version:
#' example_isolates %>% #' example_isolates %>%
#' filter_first_isolate(info = FALSE) #' filter_first_isolate(info = FALSE)
#' } #' }
#' if (require("dplyr")) { #' if (require("dplyr")) {
#'
#' # flag the first isolates per group: #' # flag the first isolates per group:
#' example_isolates %>% #' example_isolates %>%
#' group_by(ward) %>% #' group_by(ward) %>%
@ -244,18 +242,19 @@ first_isolate <- function(x = NULL,
method <- "episode-based" method <- "episode-based"
} }
if (isTRUE(info) && message_not_thrown_before("first_isolate", "method")) { if (isTRUE(info) && message_not_thrown_before("first_isolate", "method")) {
message_(paste0( message_(
"Determining first isolates ", paste0(
ifelse(method %in% c("episode-based", "phenotype-based"), "Determining first isolates ",
ifelse(is.infinite(episode_days), ifelse(method %in% c("episode-based", "phenotype-based"),
"without a specified episode length", ifelse(is.infinite(episode_days),
paste("using an episode length of", episode_days, "days") "without a specified episode length",
), paste("using an episode length of", episode_days, "days")
"" ),
) ""
), )
as_note = FALSE, ),
add_fn = font_black 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$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$episode_group <- paste(x$newvar_patient_id, x$newvar_genus_species)
x$more_than_episode_ago <- unlist(lapply(split( x$more_than_episode_ago <- unlist(
x$newvar_date, lapply(
x$episode_group split(
), x$newvar_date,
exec_episode, # this will skip meet_criteria() in is_new_episode(), saving time x$episode_group
type = "logical", ),
episode_days = episode_days exec_episode, # this will skip meet_criteria() in is_new_episode(), saving time
), type = "logical",
use.names = FALSE episode_days = episode_days
),
use.names = FALSE
) )
if (!is.null(col_keyantimicrobials)) { if (!is.null(col_keyantimicrobials)) {
@ -606,21 +607,22 @@ first_isolate <- function(x = NULL,
} }
# mark up number of found # mark up number of found
n_found <- format(n_found, big.mark = big.mark, decimal.mark = decimal.mark) n_found <- format(n_found, big.mark = big.mark, decimal.mark = decimal.mark)
message_(paste0( message_(
"=> Found ", paste0(
font_bold(paste0( "=> Found ",
n_found, font_bold(paste0(
ifelse(method == "isolate-based", "", paste0(" '", method, "'")), n_found,
" first isolates" ifelse(method == "isolate-based", "", paste0(" '", method, "'")),
)), " first isolates"
" (", )),
ifelse(p_found_total != p_found_scope, " (",
paste0(p_found_scope, " within scope and "), 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
) )
} }

15
R/ggplot_pca.R
View File

@ -414,13 +414,14 @@ pca_calculations <- function(pca_model,
sigma <- var(cbind(x$xvar, x$yvar)) sigma <- var(cbind(x$xvar, x$yvar))
mu <- c(mean(x$xvar), mean(x$yvar)) mu <- c(mean(x$xvar), mean(x$yvar))
ed <- sqrt(qchisq(ellipse_prob, df = 2)) ed <- sqrt(qchisq(ellipse_prob, df = 2))
data.frame(sweep(circle %*% chol(sigma) * ed, data.frame(
MARGIN = 2, sweep(circle %*% chol(sigma) * ed,
STATS = mu, MARGIN = 2,
FUN = "+" STATS = mu,
), FUN = "+"
groups = x$groups[1], ),
stringsAsFactors = FALSE groups = x$groups[1],
stringsAsFactors = FALSE
) )
}) })
ell <- do.call(rbind, df.groups) ell <- do.call(rbind, df.groups)

10
R/ggplot_sir.R
View File

@ -71,13 +71,11 @@
#' @examples #' @examples
#' \donttest{ #' \donttest{
#' if (require("ggplot2") && require("dplyr")) { #' if (require("ggplot2") && require("dplyr")) {
#'
#' # get antimicrobial results for drugs against a UTI: #' # get antimicrobial results for drugs against a UTI:
#' ggplot(example_isolates %>% select(AMX, NIT, FOS, TMP, CIP)) + #' ggplot(example_isolates %>% select(AMX, NIT, FOS, TMP, CIP)) +
#' geom_sir() #' geom_sir()
#' } #' }
#' if (require("ggplot2") && require("dplyr")) { #' if (require("ggplot2") && require("dplyr")) {
#'
#' # prettify the plot using some additional functions: #' # prettify the plot using some additional functions:
#' df <- example_isolates %>% select(AMX, NIT, FOS, TMP, CIP) #' df <- example_isolates %>% select(AMX, NIT, FOS, TMP, CIP)
#' ggplot(df) + #' ggplot(df) +
@ -88,21 +86,18 @@
#' theme_sir() #' theme_sir()
#' } #' }
#' if (require("ggplot2") && require("dplyr")) { #' if (require("ggplot2") && require("dplyr")) {
#'
#' # or better yet, simplify this using the wrapper function - a single command: #' # or better yet, simplify this using the wrapper function - a single command:
#' example_isolates %>% #' example_isolates %>%
#' select(AMX, NIT, FOS, TMP, CIP) %>% #' select(AMX, NIT, FOS, TMP, CIP) %>%
#' ggplot_sir() #' ggplot_sir()
#' } #' }
#' if (require("ggplot2") && require("dplyr")) { #' if (require("ggplot2") && require("dplyr")) {
#'
#' # get only proportions and no counts: #' # get only proportions and no counts:
#' example_isolates %>% #' example_isolates %>%
#' select(AMX, NIT, FOS, TMP, CIP) %>% #' select(AMX, NIT, FOS, TMP, CIP) %>%
#' ggplot_sir(datalabels = FALSE) #' ggplot_sir(datalabels = FALSE)
#' } #' }
#' if (require("ggplot2") && require("dplyr")) { #' if (require("ggplot2") && require("dplyr")) {
#'
#' # add other ggplot2 arguments as you like: #' # add other ggplot2 arguments as you like:
#' example_isolates %>% #' example_isolates %>%
#' select(AMX, NIT, FOS, TMP, CIP) %>% #' select(AMX, NIT, FOS, TMP, CIP) %>%
@ -115,14 +110,12 @@
#' ) #' )
#' } #' }
#' if (require("ggplot2") && require("dplyr")) { #' if (require("ggplot2") && require("dplyr")) {
#'
#' # you can alter the colours with colour names: #' # you can alter the colours with colour names:
#' example_isolates %>% #' example_isolates %>%
#' select(AMX) %>% #' select(AMX) %>%
#' ggplot_sir(colours = c(SI = "yellow")) #' ggplot_sir(colours = c(SI = "yellow"))
#' } #' }
#' if (require("ggplot2") && require("dplyr")) { #' if (require("ggplot2") && require("dplyr")) {
#'
#' # but you can also use the built-in colour-blind friendly colours for #' # 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: #' # your plots, where "S" is green, "I" is yellow and "R" is red:
#' data.frame( #' data.frame(
@ -135,7 +128,6 @@
#' scale_sir_colours(Value4 = "S", Value5 = "I", Value6 = "R") #' scale_sir_colours(Value4 = "S", Value5 = "I", Value6 = "R")
#' } #' }
#' if (require("ggplot2") && require("dplyr")) { #' if (require("ggplot2") && require("dplyr")) {
#'
#' # resistance of ciprofloxacine per age group #' # resistance of ciprofloxacine per age group
#' example_isolates %>% #' example_isolates %>%
#' mutate(first_isolate = first_isolate()) %>% #' mutate(first_isolate = first_isolate()) %>%
@ -149,14 +141,12 @@
#' ggplot_sir(x = "age_group") #' ggplot_sir(x = "age_group")
#' } #' }
#' if (require("ggplot2") && require("dplyr")) { #' if (require("ggplot2") && require("dplyr")) {
#'
#' # a shorter version which also adjusts data label colours: #' # a shorter version which also adjusts data label colours:
#' example_isolates %>% #' example_isolates %>%
#' select(AMX, NIT, FOS, TMP, CIP) %>% #' select(AMX, NIT, FOS, TMP, CIP) %>%
#' ggplot_sir(colours = FALSE) #' ggplot_sir(colours = FALSE)
#' } #' }
#' if (require("ggplot2") && require("dplyr")) { #' if (require("ggplot2") && require("dplyr")) {
#'
#' # it also supports groups (don't forget to use the group var on `x` or `facet`): #' # it also supports groups (don't forget to use the group var on `x` or `facet`):
#' example_isolates %>% #' example_isolates %>%
#' filter(mo_is_gram_negative(), ward != "Outpatient") %>% #' filter(mo_is_gram_negative(), ward != "Outpatient") %>%

39
R/guess_ab_col.R
View File

@ -274,14 +274,15 @@ get_column_abx <- function(x,
} }
if (names(out[i]) %in% names(duplicates)) { if (names(out[i]) %in% names(duplicates)) {
already_set_as <- out[unname(out) == unname(out[i])][1L] already_set_as <- out[unname(out) == unname(out[i])][1L]
warning_(paste0( warning_(
"Column '", font_bold(out[i]), "' will not be used for ", paste0(
names(out)[i], " (", ab_name(names(out)[i], tolower = TRUE, language = NULL), ")", "Column '", font_bold(out[i]), "' will not be used for ",
", as it is already set for ", names(out)[i], " (", ab_name(names(out)[i], tolower = TRUE, language = NULL), ")",
names(already_set_as), " (", ab_name(names(already_set_as), 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 add_fn = font_red,
immediate = verbose
) )
} }
} }
@ -307,11 +308,12 @@ get_column_abx <- function(x,
if (isTRUE(info) && !all(soft_dependencies %in% names(out))) { if (isTRUE(info) && !all(soft_dependencies %in% names(out))) {
# missing a soft dependency may lower the reliability # missing a soft dependency may lower the reliability
missing <- soft_dependencies[!soft_dependencies %in% names(out)] missing <- soft_dependencies[!soft_dependencies %in% names(out)]
missing_msg <- vector_and(paste0( missing_msg <- vector_and(
ab_name(missing, tolower = TRUE, language = NULL), paste0(
" (", font_bold(missing, collapse = NULL), ")" ab_name(missing, tolower = TRUE, language = NULL),
), " (", font_bold(missing, collapse = NULL), ")"
quotes = FALSE ),
quotes = FALSE
) )
message_( message_(
"Reliability would be improved if these antimicrobial results would be available too: ", "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 { } else {
any_txt <- c("", "are") any_txt <- c("", "are")
} }
warning_(paste0( warning_(
"Introducing NAs since", any_txt[1], " these antimicrobials ", any_txt[2], " required: ", paste0(
vector_and(missing, quotes = FALSE) "Introducing NAs since", any_txt[1], " these antimicrobials ", any_txt[2], " required: ",
), vector_and(missing, quotes = FALSE)
immediate = TRUE ),
immediate = TRUE
) )
} }

59
R/italicise_taxonomy.R
View File

@ -73,41 +73,44 @@ italicise_taxonomy <- function(string, type = c("markdown", "ansi")) {
search_strings <- gsub("[^a-zA-Z-]", "", s_split) search_strings <- gsub("[^a-zA-Z-]", "", s_split)
ind_species <- search_strings != "" & ind_species <- search_strings != "" &
search_strings %in% AMR_env$MO_lookup[which(AMR_env$MO_lookup$rank %in% c( search_strings %in% AMR_env$MO_lookup[
"family", which(AMR_env$MO_lookup$rank %in% c(
"genus", "family",
"genus",
"species",
"subspecies",
"infraspecies",
"subsp."
)),
"species", "species",
"subspecies", drop = TRUE
"infraspecies",
"subsp."
)),
"species",
drop = TRUE
] ]
ind_fullname <- search_strings != "" & ind_fullname <- search_strings != "" &
search_strings %in% c( search_strings %in% c(
AMR_env$MO_lookup[which(AMR_env$MO_lookup$rank %in% c( AMR_env$MO_lookup[
"family", which(AMR_env$MO_lookup$rank %in% c(
"genus", "family",
"species", "genus",
"subspecies", "species",
"infraspecies", "subspecies",
"subsp." "infraspecies",
)), "subsp."
"fullname", )),
drop = TRUE "fullname",
drop = TRUE
], ],
AMR_env$MO_lookup[which(AMR_env$MO_lookup$rank %in% c( AMR_env$MO_lookup[
"family", which(AMR_env$MO_lookup$rank %in% c(
"genus", "family",
"species", "genus",
"species",
"subspecies",
"infraspecies",
"subsp."
)),
"subspecies", "subspecies",
"infraspecies", drop = TRUE
"subsp."
)),
"subspecies",
drop = TRUE
] ]
) )

312
R/mdro.R
View File

@ -260,8 +260,8 @@ mdro <- function(x = NULL,
txt <- paste0( txt <- paste0(
"Determining MDROs based on custom rules", "Determining MDROs based on custom rules",
ifelse(isTRUE(attributes(guideline)$as_factor), 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 = " < ")),
"" ""
), ),
"." "."
) )
@ -615,15 +615,15 @@ 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(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", 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("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", word_wrap(paste0(font_bold("Author(s): "), guideline$author), extra_indent = 11, as_note = FALSE), "\n",
ifelse(!is.na(guideline$version), ifelse(!is.na(guideline$version),
paste0(word_wrap(paste0(font_bold("Version: "), guideline$version), extra_indent = 11, as_note = FALSE), "\n"), paste0(word_wrap(paste0(font_bold("Version: "), guideline$version), extra_indent = 11, as_note = FALSE), "\n"),
"" ""
), ),
paste0(font_bold("Source: "), guideline$source_url), paste0(font_bold("Source: "), guideline$source_url),
"\n\n", "\n\n",
sep = "" sep = ""
) )
} }
@ -655,11 +655,12 @@ mdro <- function(x = NULL,
cols <- cols[!ab_missing(cols)] cols <- cols[!ab_missing(cols)]
cols <- cols[!is.na(cols)] cols <- cols[!is.na(cols)]
if (length(rows) > 0 && length(cols) > 0) { if (length(rows) > 0 && length(cols) > 0) {
x[, cols] <- as.data.frame(lapply( x[, cols] <- as.data.frame(
x[, cols, drop = FALSE], lapply(
function(col) as.sir(col) x[, cols, drop = FALSE],
), function(col) as.sir(col)
stringsAsFactors = FALSE ),
stringsAsFactors = FALSE
) )
x[rows, "columns_nonsusceptible"] <<- vapply( x[rows, "columns_nonsusceptible"] <<- vapply(
FUN.VALUE = character(1), FUN.VALUE = character(1),
@ -670,11 +671,12 @@ mdro <- function(x = NULL,
x[row, group_vct, drop = FALSE], x[row, group_vct, drop = FALSE],
function(y) y %in% search_result function(y) y %in% search_result
) )
paste(sort(c( paste(
unlist(strsplit(x[row, "columns_nonsusceptible", drop = TRUE], ", ", fixed = TRUE)), sort(c(
names(cols_nonsus)[cols_nonsus] unlist(strsplit(x[row, "columns_nonsusceptible", drop = TRUE], ", ", fixed = TRUE)),
)), names(cols_nonsus)[cols_nonsus]
collapse = ", " )),
collapse = ", "
) )
} }
) )
@ -685,7 +687,7 @@ mdro <- function(x = NULL,
search_function <- all search_function <- all
} }
x_transposed <- as.list(as.data.frame(t(x[, cols, drop = FALSE]), x_transposed <- as.list(as.data.frame(t(x[, cols, drop = FALSE]),
stringsAsFactors = FALSE stringsAsFactors = FALSE
)) ))
rows_affected <- vapply( rows_affected <- vapply(
FUN.VALUE = logical(1), FUN.VALUE = logical(1),
@ -715,11 +717,12 @@ mdro <- function(x = NULL,
# keep only unique ones: # keep only unique ones:
lst_vector <- lst_vector[!duplicated(paste(lst_vector, names(lst_vector)))] lst_vector <- lst_vector[!duplicated(paste(lst_vector, names(lst_vector)))]
x[, lst_vector] <- as.data.frame(lapply( x[, lst_vector] <- as.data.frame(
x[, lst_vector, drop = FALSE], lapply(
function(col) as.sir(col) x[, lst_vector, drop = FALSE],
), function(col) as.sir(col)
stringsAsFactors = FALSE ),
stringsAsFactors = FALSE
) )
x[rows, "classes_in_guideline"] <<- length(lst) x[rows, "classes_in_guideline"] <<- length(lst)
x[rows, "classes_available"] <<- vapply( x[rows, "classes_available"] <<- vapply(
@ -748,20 +751,21 @@ mdro <- function(x = NULL,
FUN.VALUE = double(1), FUN.VALUE = double(1),
rows, rows,
function(row, group_tbl = lst) { function(row, group_tbl = lst) {
sum(vapply( sum(
FUN.VALUE = logical(1), vapply(
group_tbl, FUN.VALUE = logical(1),
function(group) { group_tbl,
any(unlist(x[row, group[!is.na(group)], drop = TRUE]) %in% search_result, na.rm = TRUE) function(group) {
} any(unlist(x[row, group[!is.na(group)], drop = TRUE]) %in% search_result, na.rm = TRUE)
), }
na.rm = TRUE ),
na.rm = TRUE
) )
} }
) )
# for PDR; all drugs are R (or I if combine_SI = FALSE) # 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]), 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)) 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 x[which(row_filter), "classes_affected"] <<- 999
@ -814,76 +818,76 @@ mdro <- function(x = NULL,
x[which(x$genus == "Enterococcus" & x$species == "faecium"), ab_NA(IPM)] <- NA 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 == "Enterococcus" & x$species == "faecalis"), ab_NA(QDA)] <- NA
x[which((x$genus == "Providencia" & x$species == "rettgeri") | 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 == "Escherichia" & x$species == "hermannii"), ab_NA(c(TCC, TZP))] <- NA
x[which((x$genus == "Citrobacter" & x$species == "freundii") | x[which((x$genus == "Citrobacter" & x$species == "freundii") |
(x$genus == "Enterobacter" & x$species == "aerogenes") | (x$genus == "Enterobacter" & x$species == "aerogenes") |
(x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017) (x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017)
| (x$genus == "Enterobacter" & x$species == "cloacae") | | (x$genus == "Enterobacter" & x$species == "cloacae") |
(x$genus == "Hafnia" & x$species == "alvei") | (x$genus == "Hafnia" & x$species == "alvei") |
(x$genus == "Morganella" & x$species == "morganii") | (x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Proteus" & x$species == "penneri") | (x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") | (x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(CZO)] <- NA (x$genus == "Serratia" & x$species == "marcescens")), ab_NA(CZO)] <- NA
x[which((x$genus == "Morganella" & x$species == "morganii") | x[which((x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Proteus" & x$species == "penneri") | (x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") | (x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(CXM)] <- NA (x$genus == "Serratia" & x$species == "marcescens")), ab_NA(CXM)] <- NA
x[which((x$genus == "Morganella" & x$species == "morganii") | x[which((x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Proteus" & x$species == "mirabilis") | (x$genus == "Proteus" & x$species == "mirabilis") |
(x$genus == "Proteus" & x$species == "penneri") | (x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") | (x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Providencia" & x$species == "rettgeri") | (x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Providencia" & x$species == "stuartii")), ab_NA(TGC)] <- NA (x$genus == "Providencia" & x$species == "stuartii")), ab_NA(TGC)] <- NA
x[which((x$genus == "Citrobacter" & x$species == "koseri") | x[which((x$genus == "Citrobacter" & x$species == "koseri") |
(x$genus == "Citrobacter" & x$species == "freundii") | (x$genus == "Citrobacter" & x$species == "freundii") |
(x$genus == "Enterobacter" & x$species == "aerogenes") | (x$genus == "Enterobacter" & x$species == "aerogenes") |
(x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017) (x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017)
| (x$genus == "Enterobacter" & x$species == "cloacae") | | (x$genus == "Enterobacter" & x$species == "cloacae") |
(x$genus == "Escherichia" & x$species == "hermannii") | (x$genus == "Escherichia" & x$species == "hermannii") |
(x$genus == "Hafnia" & x$species == "alvei") | (x$genus == "Hafnia" & x$species == "alvei") |
(x$genus == "Klebsiella") | (x$genus == "Klebsiella") |
(x$genus == "Morganella" & x$species == "morganii") | (x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Proteus" & x$species == "penneri") | (x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") | (x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Providencia" & x$species == "rettgeri") | (x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Providencia" & x$species == "stuartii") | (x$genus == "Providencia" & x$species == "stuartii") |
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(AMP)] <- NA (x$genus == "Serratia" & x$species == "marcescens")), ab_NA(AMP)] <- NA
x[which((x$genus == "Citrobacter" & x$species == "freundii") | x[which((x$genus == "Citrobacter" & x$species == "freundii") |
(x$genus == "Enterobacter" & x$species == "aerogenes") | (x$genus == "Enterobacter" & x$species == "aerogenes") |
(x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017) (x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017)
| (x$genus == "Enterobacter" & x$species == "cloacae") | | (x$genus == "Enterobacter" & x$species == "cloacae") |
(x$genus == "Hafnia" & x$species == "alvei") | (x$genus == "Hafnia" & x$species == "alvei") |
(x$genus == "Morganella" & x$species == "morganii") | (x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Providencia" & x$species == "rettgeri") | (x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Providencia" & x$species == "stuartii") | (x$genus == "Providencia" & x$species == "stuartii") |
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(AMC)] <- NA (x$genus == "Serratia" & x$species == "marcescens")), ab_NA(AMC)] <- NA
x[which((x$genus == "Citrobacter" & x$species == "freundii") | x[which((x$genus == "Citrobacter" & x$species == "freundii") |
(x$genus == "Citrobacter" & x$species == "koseri") | (x$genus == "Citrobacter" & x$species == "koseri") |
(x$genus == "Enterobacter" & x$species == "aerogenes") | (x$genus == "Enterobacter" & x$species == "aerogenes") |
(x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017) (x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017)
| (x$genus == "Enterobacter" & x$species == "cloacae") | | (x$genus == "Enterobacter" & x$species == "cloacae") |
(x$genus == "Hafnia" & x$species == "alvei") | (x$genus == "Hafnia" & x$species == "alvei") |
(x$genus == "Providencia" & x$species == "rettgeri") | (x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(SAM)] <- NA (x$genus == "Serratia" & x$species == "marcescens")), ab_NA(SAM)] <- NA
x[which((x$genus == "Morganella" & x$species == "morganii") | x[which((x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Proteus" & x$species == "mirabilis") | (x$genus == "Proteus" & x$species == "mirabilis") |
(x$genus == "Proteus" & x$species == "penneri") | (x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") | (x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Providencia" & x$species == "rettgeri") | (x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Providencia" & x$species == "stuartii") | (x$genus == "Providencia" & x$species == "stuartii") |
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(COL)] <- NA (x$genus == "Serratia" & x$species == "marcescens")), ab_NA(COL)] <- NA
x[which((x$genus == "Morganella" & x$species == "morganii") | x[which((x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Proteus" & x$species == "mirabilis") | (x$genus == "Proteus" & x$species == "mirabilis") |
(x$genus == "Proteus" & x$species == "penneri") | (x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") | (x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Providencia" & x$species == "rettgeri") | (x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Providencia" & x$species == "stuartii")), ab_NA(TCY)] <- NA (x$genus == "Providencia" & x$species == "stuartii")), ab_NA(TCY)] <- NA
x[which((x$genus == "Morganella" & x$species == "morganii") | x[which((x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Proteus" & x$species == "penneri") | (x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") | (x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Providencia" & x$species == "rettgeri") | (x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Providencia" & x$species == "stuartii")), ab_NA(c(DOX, MNO))] <- NA (x$genus == "Providencia" & x$species == "stuartii")), ab_NA(c(DOX, MNO))] <- NA
x$classes_in_guideline <- NA_integer_ x$classes_in_guideline <- NA_integer_
x$classes_available <- NA_integer_ x$classes_available <- NA_integer_
@ -1042,8 +1046,8 @@ mdro <- function(x = NULL,
trans_tbl( trans_tbl(
3, 3,
which(x$order == "Enterobacterales" | which(x$order == "Enterobacterales" |
(x$genus == "Pseudomonas" & x$species == "aeruginosa") | (x$genus == "Pseudomonas" & x$species == "aeruginosa") |
x$genus == "Acinetobacter"), x$genus == "Acinetobacter"),
COL, COL,
"all" "all"
) )
@ -1135,10 +1139,10 @@ mdro <- function(x = NULL,
trans_tbl( trans_tbl(
3, 3,
which((x$order == "Enterobacterales" & which((x$order == "Enterobacterales" &
!x$family == "Morganellaceae" & !x$family == "Morganellaceae" &
!(x$genus == "Serratia" & x$species == "marcescens")) | !(x$genus == "Serratia" & x$species == "marcescens")) |
(x$genus == "Pseudomonas" & x$species == "aeruginosa") | (x$genus == "Pseudomonas" & x$species == "aeruginosa") |
x$genus == "Acinetobacter"), x$genus == "Acinetobacter"),
COL, COL,
"all" "all"
) )
@ -1237,10 +1241,10 @@ mdro <- function(x = NULL,
trans_tbl( trans_tbl(
3, 3,
which((x$order == "Enterobacterales" & which((x$order == "Enterobacterales" &
!x$family == "Morganellaceae" & !x$family == "Morganellaceae" &
!(x$genus == "Serratia" & x$species == "marcescens")) | !(x$genus == "Serratia" & x$species == "marcescens")) |
(x$genus == "Pseudomonas" & x$species == "aeruginosa") | (x$genus == "Pseudomonas" & x$species == "aeruginosa") |
x$genus == "Acinetobacter"), x$genus == "Acinetobacter"),
COL, COL,
"all" "all"
) )
@ -1339,11 +1343,11 @@ mdro <- function(x = NULL,
trans_tbl( trans_tbl(
2, # 3MRGN 2, # 3MRGN
which((x$order == "Enterobacterales" | # following in fact the old Enterobacteriaceae classification which((x$order == "Enterobacterales" | # following in fact the old Enterobacteriaceae classification
(x$genus == "Acinetobacter" & x$species == "baumannii")) & (x$genus == "Acinetobacter" & x$species == "baumannii")) &
try_ab(x[, PIP, 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[, 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[, IPM, drop = TRUE] != "R") | try_ab(x[, MEM, drop = TRUE] != "R")) &
try_ab(x[, CIP, drop = TRUE] == "R")), try_ab(x[, CIP, drop = TRUE] == "R")),
c(PIP, CTX, CAZ, IPM, MEM, CIP), c(PIP, CTX, CAZ, IPM, MEM, CIP),
"any" "any"
) )
@ -1351,11 +1355,11 @@ mdro <- function(x = NULL,
trans_tbl( trans_tbl(
3, # 4MRGN, overwrites 3MRGN if applicable 3, # 4MRGN, overwrites 3MRGN if applicable
which((x$order == "Enterobacterales" | # following in fact the old Enterobacteriaceae classification which((x$order == "Enterobacterales" | # following in fact the old Enterobacteriaceae classification
(x$genus == "Acinetobacter" & x$species == "baumannii")) & (x$genus == "Acinetobacter" & x$species == "baumannii")) &
try_ab(x[, PIP, 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[, 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[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R")) &
try_ab(x[, CIP, drop = TRUE] == "R")), try_ab(x[, CIP, drop = TRUE] == "R")),
c(PIP, CTX, CAZ, IPM, MEM, CIP), c(PIP, CTX, CAZ, IPM, MEM, CIP),
"any" "any"
) )
@ -1363,8 +1367,8 @@ mdro <- function(x = NULL,
trans_tbl( trans_tbl(
3, # 4MRGN, overwrites 3MRGN if applicable 3, # 4MRGN, overwrites 3MRGN if applicable
which((x$order == "Enterobacterales" | # following in fact the old Enterobacteriaceae classification which((x$order == "Enterobacterales" | # following in fact the old Enterobacteriaceae classification
(x$genus == "Acinetobacter" & x$species == "baumannii")) & (x$genus == "Acinetobacter" & x$species == "baumannii")) &
(try_ab(x[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R"))), (try_ab(x[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R"))),
c(IPM, MEM), c(IPM, MEM),
"any" "any"
) )
@ -1372,12 +1376,12 @@ mdro <- function(x = NULL,
trans_tbl( trans_tbl(
2, # 3MRGN, if only 1 group is S 2, # 3MRGN, if only 1 group is S
which(x$genus == "Pseudomonas" & x$species == "aeruginosa" & which(x$genus == "Pseudomonas" & x$species == "aeruginosa" &
try_ab(x[, PIP, drop = TRUE] == "S") + try_ab(x[, PIP, drop = TRUE] == "S") +
try_ab(x[, CTX, drop = TRUE] == "S") + try_ab(x[, CTX, drop = TRUE] == "S") +
try_ab(x[, CAZ, drop = TRUE] == "S") + try_ab(x[, CAZ, drop = TRUE] == "S") +
try_ab(x[, IPM, drop = TRUE] == "S") + try_ab(x[, IPM, drop = TRUE] == "S") +
try_ab(x[, MEM, drop = TRUE] == "S") + try_ab(x[, MEM, drop = TRUE] == "S") +
try_ab(x[, CIP, drop = TRUE] == "S") == 1), try_ab(x[, CIP, drop = TRUE] == "S") == 1),
c(PIP, CTX, CAZ, IPM, MEM, CIP), c(PIP, CTX, CAZ, IPM, MEM, CIP),
"any" "any"
) )
@ -1385,10 +1389,10 @@ mdro <- function(x = NULL,
trans_tbl( trans_tbl(
3, # 4MRGN otherwise 3, # 4MRGN otherwise
which((x$genus == "Pseudomonas" & x$species == "aeruginosa") & which((x$genus == "Pseudomonas" & x$species == "aeruginosa") &
try_ab(x[, PIP, 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[, 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[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R")) &
try_ab(x[, CIP, drop = TRUE] == "R")), try_ab(x[, CIP, drop = TRUE] == "R")),
c(PIP, CTX, CAZ, IPM, MEM, CIP), c(PIP, CTX, CAZ, IPM, MEM, CIP),
"any" "any"
) )
@ -1454,10 +1458,10 @@ mdro <- function(x = NULL,
) )
if (!ab_missing(MEM) && !ab_missing(IPM) && if (!ab_missing(MEM) && !ab_missing(IPM) &&
!ab_missing(GEN) && !ab_missing(TOB) && !ab_missing(GEN) && !ab_missing(TOB) &&
!ab_missing(CIP) && !ab_missing(CIP) &&
!ab_missing(CAZ) && !ab_missing(CAZ) &&
!ab_missing(TZP)) { !ab_missing(TZP)) {
x$psae <- 0 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[, 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"] 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"]
@ -1551,13 +1555,13 @@ mdro <- function(x = NULL,
x$second <- drug_is_R(CAP) | drug_is_R(KAN) | drug_is_R(AMK) x$second <- drug_is_R(CAP) | drug_is_R(KAN) | drug_is_R(AMK)
x$xdr <- x$mdr & x$xdr & x$second x$xdr <- x$mdr & x$xdr & x$second
x$MDRO <- ifelse(x$xdr, 5, x$MDRO <- ifelse(x$xdr, 5,
ifelse(x$mdr, 4, ifelse(x$mdr, 4,
ifelse(x$poly, 3, ifelse(x$poly, 3,
ifelse(x$mono, 2, ifelse(x$mono, 2,
1 1
) )
) )
) )
) )
# keep all real TB, make other species NA # keep all real TB, make other species NA
x$MDRO <- ifelse(x$fullname == "Mycobacterium tuberculosis", x$MDRO, NA_real_) x$MDRO <- ifelse(x$fullname == "Mycobacterium tuberculosis", x$MDRO, NA_real_)
@ -1595,7 +1599,7 @@ mdro <- function(x = NULL,
# Fill in blanks ---- # Fill in blanks ----
# for rows that have no results # for rows that have no results
x_transposed <- as.list(as.data.frame(t(x[, cols_ab, drop = FALSE]), x_transposed <- as.list(as.data.frame(t(x[, cols_ab, drop = FALSE]),
stringsAsFactors = FALSE stringsAsFactors = FALSE
)) ))
rows_empty <- which(vapply( rows_empty <- which(vapply(
FUN.VALUE = logical(1), FUN.VALUE = logical(1),
@ -1680,7 +1684,7 @@ custom_mdro_guideline <- function(..., as_factor = TRUE) {
meet_criteria(as_factor, allow_class = "logical", has_length = 1) meet_criteria(as_factor, allow_class = "logical", has_length = 1)
dots <- tryCatch(list(...), dots <- tryCatch(list(...),
error = function(e) "error" error = function(e) "error"
) )
stop_if( stop_if(
identical(dots, "error"), identical(dots, "error"),
@ -1739,8 +1743,8 @@ c.custom_mdro_guideline <- function(x, ..., as_factor = NULL) {
} }
for (g in list(...)) { for (g in list(...)) {
stop_ifnot(inherits(g, "custom_mdro_guideline"), stop_ifnot(inherits(g, "custom_mdro_guideline"),
"for combining custom MDRO guidelines, all rules must be created with `custom_mdro_guideline()`", "for combining custom MDRO guidelines, all rules must be created with `custom_mdro_guideline()`",
call = FALSE call = FALSE
) )
vals <- attributes(x)$values vals <- attributes(x)$values
if (!all(attributes(g)$values %in% vals)) { if (!all(attributes(g)$values %in% vals)) {
@ -1790,24 +1794,24 @@ run_custom_mdro_guideline <- function(df, guideline, info) {
reasons <- character(length = NROW(df)) reasons <- character(length = NROW(df))
for (i in seq_len(n_dots)) { for (i in seq_len(n_dots)) {
qry <- tryCatch(eval(parse(text = guideline[[i]]$query), envir = df, enclos = parent.frame()), qry <- tryCatch(eval(parse(text = guideline[[i]]$query), envir = df, enclos = parent.frame()),
error = function(e) { error = function(e) {
AMR_env$err_msg <- e$message AMR_env$err_msg <- e$message
return("error") return("error")
} }
) )
if (identical(qry, "error")) { if (identical(qry, "error")) {
warning_("in `custom_mdro_guideline()`: rule ", i, warning_("in `custom_mdro_guideline()`: rule ", i,
" (`", as.character(guideline[[i]]$query), "`) was ignored because of this error message: ", " (`", as.character(guideline[[i]]$query), "`) was ignored because of this error message: ",
AMR_env$err_msg, AMR_env$err_msg,
call = FALSE, call = FALSE,
add_fn = font_red add_fn = font_red
) )
next next
} }
stop_ifnot(is.logical(qry), "in custom_mdro_guideline(): rule ", i, " (`", guideline[[i]]$query, stop_ifnot(is.logical(qry), "in custom_mdro_guideline(): rule ", i, " (`", guideline[[i]]$query,
"`) must return `TRUE` or `FALSE`, not ", "`) must return `TRUE` or `FALSE`, not ",
format_class(class(qry), plural = FALSE), format_class(class(qry), plural = FALSE),
call = FALSE call = FALSE
) )
new_mdros <- which(qry == TRUE & out == "") new_mdros <- which(qry == TRUE & out == "")

14
R/mic.R
View File

@ -230,13 +230,13 @@ as.mic <- function(x, na.rm = FALSE) {
vector_and(quotes = TRUE) vector_and(quotes = TRUE)
cur_col <- get_current_column() cur_col <- get_current_column()
warning_("in `as.mic()`: ", na_after - na_before, " result", warning_("in `as.mic()`: ", na_after - na_before, " result",
ifelse(na_after - na_before > 1, "s", ""), ifelse(na_after - na_before > 1, "s", ""),
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")), ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
" truncated (", " truncated (",
round(((na_after - na_before) / length(x)) * 100), round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid MICs: ", "%) that were invalid MICs: ",
list_missing, list_missing,
call = FALSE call = FALSE
) )
} }

74
R/mo.R
View File

@ -365,18 +365,19 @@ as.mo <- function(x,
plural <- c("s", "these uncertainties") plural <- c("s", "these uncertainties")
} }
if (length(AMR_env$mo_uncertainties$original_input) <= 3) { if (length(AMR_env$mo_uncertainties$original_input) <= 3) {
examples <- vector_and(paste0( examples <- vector_and(
'"', AMR_env$mo_uncertainties$original_input, paste0(
'" (assumed ', italicise(AMR_env$mo_uncertainties$fullname), ")" '"', AMR_env$mo_uncertainties$original_input,
), '" (assumed ', italicise(AMR_env$mo_uncertainties$fullname), ")"
quotes = FALSE ),
quotes = FALSE
) )
} else { } else {
examples <- paste0(nr2char(length(AMR_env$mo_uncertainties$original_input)), " microorganism", plural[1]) examples <- paste0(nr2char(length(AMR_env$mo_uncertainties$original_input)), " microorganism", plural[1])
} }
msg <- c(msg, paste0( msg <- c(msg, paste0(
"Microorganism translation was uncertain for ", examples, "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) { for (m in msg) {
@ -577,10 +578,11 @@ pillar_shaft.mo <- function(x, ...) {
if (!all(x %in% all_mos) || if (!all(x %in% all_mos) ||
(!is.null(df) && !all(unlist(df[, which(mo_cols), drop = FALSE]) %in% all_mos))) { (!is.null(df) && !all(unlist(df[, which(mo_cols), drop = FALSE]) %in% all_mos))) {
# markup old mo codes # 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
),
collapse = NULL
) )
# throw a warning with the affected column name(s) # throw a warning with the affected column name(s)
if (!is.null(mo_cols)) { if (!is.null(mo_cols)) {
@ -835,21 +837,23 @@ print.mo_uncertainties <- function(x, ...) {
candidates_formatted <- candidates_formatted[order(1 - scores)] candidates_formatted <- candidates_formatted[order(1 - scores)]
scores_formatted <- scores_formatted[order(1 - scores)] scores_formatted <- scores_formatted[order(1 - scores)]
candidates <- word_wrap(paste0( candidates <- word_wrap(
"Also matched: ", paste0(
vector_and(paste0( "Also matched: ",
candidates_formatted, vector_and(
font_blue(paste0(" (", scores_formatted, ")"), collapse = NULL) 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 extra_indent = nchar("Also matched: "),
), width = 0.9 * getOption("width", 100)
ifelse(n_candidates == 25,
font_grey(" [showing first 25]"),
""
)
),
extra_indent = nchar("Also matched: "),
width = 0.9 * getOption("width", 100)
) )
} else { } else {
candidates <- "" candidates <- ""
@ -957,14 +961,14 @@ convert_colloquial_input <- function(x) {
# Salmonella in different languages, like "Salmonella grupo B" # Salmonella in different languages, like "Salmonella grupo B"
out[x %like_case% "salmonella.* [bcd]$"] <- gsub(".*salmonella.* ([bcd])$", out[x %like_case% "salmonella.* [bcd]$"] <- gsub(".*salmonella.* ([bcd])$",
"B_SLMNL_GRP\\U\\1", "B_SLMNL_GRP\\U\\1",
x[x %like_case% "salmonella.* [bcd]$"], x[x %like_case% "salmonella.* [bcd]$"],
perl = TRUE perl = TRUE
) )
out[x %like_case% "group [bcd] salmonella"] <- gsub(".*group ([bcd]) salmonella*", out[x %like_case% "group [bcd] salmonella"] <- gsub(".*group ([bcd]) salmonella*",
"B_SLMNL_GRP\\U\\1", "B_SLMNL_GRP\\U\\1",
x[x %like_case% "group [bcd] salmonella"], x[x %like_case% "group [bcd] salmonella"],
perl = TRUE perl = TRUE
) )
# CoNS/CoPS in different languages (support for German, Dutch, Spanish, Portuguese) # CoNS/CoPS in different languages (support for German, Dutch, Spanish, Portuguese)
@ -999,10 +1003,14 @@ convert_colloquial_input <- function(x) {
italicise <- function(x) { italicise <- function(x) {
out <- font_italic(x, collapse = NULL) out <- font_italic(x, collapse = NULL)
out[x %like_case% "Salmonella [A-Z]"] <- paste(font_italic("Salmonella"), out[x %like_case% "Salmonella [A-Z]"] <- paste(
gsub("Salmonella ", "", x[x %like_case% "Salmonella [A-Z]"])) font_italic("Salmonella"),
out[x %like_case% "Streptococcus [A-Z]"] <- paste(font_italic("Streptococcus"), gsub("Salmonella ", "", x[x %like_case% "Salmonella [A-Z]"])
gsub("Streptococcus ", "", x[x %like_case% "Streptococcus [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()) { if (has_colour()) {
out <- gsub("(Group|group|Complex|complex)(\033\\[23m)?", "\033[23m\\1", out, perl = TRUE) out <- gsub("(Group|group|Complex|complex)(\033\\[23m)?", "\033[23m\\1", out, perl = TRUE)
} }

29
R/mo_property.R
View File

@ -133,7 +133,6 @@
#' mo_fullname("K. pneu rh") #' mo_fullname("K. pneu rh")
#' mo_shortname("K. pneu rh") #' mo_shortname("K. pneu rh")
#' #'
#'
#' \donttest{ #' \donttest{
#' # Becker classification, see ?as.mo ---------------------------------------- #' # Becker classification, see ?as.mo ----------------------------------------
#' #'
@ -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)] 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)] rank <- AMR_env$MO_lookup$rank[match(x.mo, AMR_env$MO_lookup$mo)]
out <- factor(ifelse(prev == 1 & kngd == "Bacteria" & rank != "genus", out <- factor(
"Pathogenic", ifelse(prev == 1 & kngd == "Bacteria" & rank != "genus",
ifelse(prev < 2 & kngd == "Fungi", "Pathogenic",
"Potentially pathogenic", ifelse(prev < 2 & kngd == "Fungi",
ifelse(prev == 2 & kngd == "Bacteria", "Potentially pathogenic",
"Non-pathogenic", ifelse(prev == 2 & kngd == "Bacteria",
ifelse(kngd == "Bacteria", "Non-pathogenic",
"Potentially pathogenic", ifelse(kngd == "Bacteria",
"Unknown")))), "Potentially pathogenic",
levels = c("Pathogenic", "Potentially pathogenic", "Non-pathogenic", "Unknown"), "Unknown"
ordered = TRUE) )
)
)
),
levels = c("Pathogenic", "Potentially pathogenic", "Non-pathogenic", "Unknown"),
ordered = TRUE
)
load_mo_uncertainties(metadata) load_mo_uncertainties(metadata)
out out

1
R/proportion.R
View File

@ -140,7 +140,6 @@
#' ) #' )
#' } #' }
#' if (require("dplyr")) { #' if (require("dplyr")) {
#'
#' # scoped dplyr verbs with antibiotic selectors #' # scoped dplyr verbs with antibiotic selectors
#' # (you could also use across() of course) #' # (you could also use across() of course)
#' example_isolates %>% #' example_isolates %>%

2
R/resistance_predict.R
View File

@ -274,7 +274,7 @@ resistance_predict <- function(x,
df_prediction$value <- ifelse(df_prediction$value > 1, 1, pmax(df_prediction$value, 0)) df_prediction$value <- ifelse(df_prediction$value > 1, 1, pmax(df_prediction$value, 0))
df_prediction <- df_prediction[order(df_prediction$year), , drop = FALSE] 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, structure(out,
class = c("resistance_predict", class(out)), class = c("resistance_predict", class(out)),
I_as_S = I_as_S, I_as_S = I_as_S,

50
R/sir.R
View File

@ -64,7 +64,7 @@
#' ``` #' ```
#' 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)`. #' 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 #' ### Supported Guidelines
#' #'
@ -806,19 +806,23 @@ as_sir_method <- function(method_short,
for (i in seq_len(length(messages))) { for (i in seq_len(length(messages))) {
messages[i] <- word_wrap(extra_indent = 5, messages[i]) messages[i] <- word_wrap(extra_indent = 5, messages[i])
} }
message(font_green(font_bold(" Note:\n")), message(
paste0(" ", font_black(AMR_env$bullet_icon)," ", font_black(messages, collapse = NULL) , collapse = "\n")) font_green(font_bold(" Note:\n")),
paste0(" ", font_black(AMR_env$bullet_icon), " ", font_black(messages, collapse = NULL), collapse = "\n")
)
} }
method <- method_short method <- method_short
metadata_mo <- get_mo_uncertainties() metadata_mo <- get_mo_uncertainties()
df <- data.frame(values = x, df <- data.frame(
mo = mo, values = x,
result = NA_sir_, mo = mo,
uti = uti, result = NA_sir_,
stringsAsFactors = FALSE) uti = uti,
stringsAsFactors = FALSE
)
if (method == "mic") { if (method == "mic") {
# when as.sir.mic is called directly # when as.sir.mic is called directly
df$values <- as.mic(df$values) df$values <- as.mic(df$values)
@ -849,9 +853,11 @@ as_sir_method <- function(method_short,
msgs <- character(0) msgs <- character(0)
if (nrow(breakpoints) == 0) { if (nrow(breakpoints) == 0) {
# apparently no breakpoints found # apparently no breakpoints found
msg_note(paste0("No ", method_coerced, " breakpoints available for ", msg_note(paste0(
suppressMessages(suppressWarnings(ab_name(ab_coerced, language = NULL, tolower = TRUE))), "No ", method_coerced, " breakpoints available for ",
" (", ab_coerced, ")")) suppressMessages(suppressWarnings(ab_name(ab_coerced, language = NULL, tolower = TRUE))),
" (", ab_coerced, ")"
))
load_mo_uncertainties(metadata_mo) load_mo_uncertainties(metadata_mo)
return(rep(NA_sir_, nrow(df))) return(rep(NA_sir_, nrow(df)))
} }
@ -863,7 +869,6 @@ as_sir_method <- function(method_short,
# run the rules # run the rules
for (mo_unique in unique(df$mo)) { for (mo_unique in unique(df$mo)) {
rows <- which(df$mo == mo_unique) rows <- which(df$mo == mo_unique)
values <- df[rows, "values", drop = TRUE] values <- df[rows, "values", drop = TRUE]
uti <- df[rows, "uti", drop = TRUE] uti <- df[rows, "uti", drop = TRUE]
@ -890,16 +895,20 @@ as_sir_method <- function(method_short,
if (!mo_rank(mo_unique) %in% c("kingdom", "phylum", "class", "order")) { if (!mo_rank(mo_unique) %in% c("kingdom", "phylum", "class", "order")) {
mo_formatted <- font_italic(mo_formatted) mo_formatted <- font_italic(mo_formatted)
} }
ab_formatted <- paste0(suppressMessages(suppressWarnings(ab_name(ab_coerced, language = NULL, tolower = TRUE))), ab_formatted <- paste0(
" (", ab_coerced, ")") suppressMessages(suppressWarnings(ab_name(ab_coerced, language = NULL, tolower = TRUE))),
" (", ab_coerced, ")"
)
# gather all available breakpoints for current MO and sort on taxonomic rank # gather all available breakpoints for current MO and sort on taxonomic rank
# (this will prefer species breakpoints over order breakpoints) # (this will prefer species breakpoints over order breakpoints)
breakpoints_current <- breakpoints %pm>% breakpoints_current <- breakpoints %pm>%
subset(mo %in% c(mo_current_genus, mo_current_family, subset(mo %in% c(
mo_current_order, mo_current_class, mo_current_genus, mo_current_family,
mo_current_becker, mo_current_lancefield, mo_current_order, mo_current_class,
mo_current_other)) mo_current_becker, mo_current_lancefield,
mo_current_other
))
if (any(df[rows, "uti", drop = TRUE], na.rm = TRUE)) { if (any(df[rows, "uti", drop = TRUE], na.rm = TRUE)) {
breakpoints_current <- breakpoints_current %pm>% breakpoints_current <- breakpoints_current %pm>%
@ -937,7 +946,6 @@ as_sir_method <- function(method_short,
if (isTRUE(add_intrinsic_resistance) && guideline_coerced %like% "EUCAST" && paste(mo_unique, ab_coerced) %in% AMR_env$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, "")) msgs <- c(msgs, paste0("Intrinsic resistance applied for ", ab_formatted, " in ", mo_formatted, ""))
new_sir <- rep(as.sir("R"), length(rows)) new_sir <- rep(as.sir("R"), length(rows))
} else { } else {
# then run the rules # then run the rules
breakpoints_current <- breakpoints_current[1L, , drop = FALSE] breakpoints_current <- breakpoints_current[1L, , drop = FALSE]
@ -953,7 +961,6 @@ as_sir_method <- function(method_short,
# and NA otherwise # and NA otherwise
TRUE ~ NA_sir_ TRUE ~ NA_sir_
) )
} else if (method == "disk") { } else if (method == "disk") {
new_sir <- quick_case_when( new_sir <- quick_case_when(
is.na(values) ~ NA_sir_, is.na(values) ~ NA_sir_,
@ -1027,6 +1034,9 @@ sir_interpretation_history <- function(clean = FALSE) {
AMR_env$sir_interpretation_history <- out.bak 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)) { if (pkg_is_available("tibble", also_load = FALSE)) {
import_fn("as_tibble", "tibble")(out) import_fn("as_tibble", "tibble")(out)
} else { } else {

BIN
R/sysdata.rda
View File

Binary file not shown.

27
R/translate.R
View File

@ -141,10 +141,11 @@ reset_AMR_locale <- function() {
#' @export #' @export
translate_AMR <- function(x, language = get_AMR_locale()) { translate_AMR <- function(x, language = get_AMR_locale()) {
translate_into_language(x, translate_into_language(x,
language = language, language = language,
only_unknown = FALSE, only_unknown = FALSE,
only_affect_ab_names = FALSE, only_affect_ab_names = FALSE,
only_affect_mo_names = FALSE) only_affect_mo_names = FALSE
)
} }
@ -170,14 +171,15 @@ find_language <- function(language, fallback = TRUE) {
language <- Map(LANGUAGES_SUPPORTED_NAMES, language <- Map(LANGUAGES_SUPPORTED_NAMES,
LANGUAGES_SUPPORTED, LANGUAGES_SUPPORTED,
f = function(l, n, check = language) { f = function(l, n, check = language) {
grepl(paste0( grepl(
"^(", l[1], "|", l[2], "|", paste0(
n, "(_|$)|", toupper(n), "(_|$))" "^(", l[1], "|", l[2], "|",
), n, "(_|$)|", toupper(n), "(_|$))"
check, ),
ignore.case = TRUE, check,
perl = TRUE, ignore.case = TRUE,
useBytes = FALSE perl = TRUE,
useBytes = FALSE
) )
}, },
USE.NAMES = TRUE USE.NAMES = TRUE
@ -196,7 +198,6 @@ translate_into_language <- function(from,
only_unknown = FALSE, only_unknown = FALSE,
only_affect_ab_names = FALSE, only_affect_ab_names = FALSE,
only_affect_mo_names = FALSE) { only_affect_mo_names = FALSE) {
# get ISO-639-1 of language # get ISO-639-1 of language
lang <- validate_language(language) lang <- validate_language(language)
if (lang == "en") { if (lang == "en") {

23
R/zz_deprecated.R
View File

@ -35,7 +35,8 @@
#' @rdname AMR-deprecated #' @rdname AMR-deprecated
#' @export #' @export
NA_rsi_ <- set_clean_class(factor(NA_character_, levels = c("S", "I", "R"), ordered = TRUE), 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 #' @rdname AMR-deprecated
#' @export #' @export
as.rsi <- function(x, ...) { as.rsi <- function(x, ...) {
@ -197,14 +198,18 @@ deprecation_warning <- function(old = NULL, new = NULL, extra_msg = NULL) {
env <- paste0("deprecated_", old) env <- paste0("deprecated_", old)
if (!env %in% names(AMR_env)) { if (!env %in% names(AMR_env)) {
AMR_env[[paste0("deprecated_", old)]] <- 1 AMR_env[[paste0("deprecated_", old)]] <- 1
warning_(ifelse(is.null(new), warning_(
paste0("The `", old, "()` function is no longer in use"), ifelse(is.null(new),
paste0("The `", old, "()` function has been replaced with `", new, "()`")), paste0("The `", old, "()` function is no longer in use"),
", see `?AMR-deprecated`.", paste0("The `", old, "()` function has been replaced with `", new, "()`")
ifelse(!is.null(extra_msg), ),
paste0(" ", extra_msg), ", see `?AMR-deprecated`.",
""), ifelse(!is.null(extra_msg),
"\nThis warning will be shown once per session.") paste0(" ", extra_msg),
""
),
"\nThis warning will be shown once per session."
)
} }
} }
} }

22
R/zzz.R
View File

@ -192,18 +192,24 @@ if (utf8_supported && !is_latex) {
if (!is.null(getOption("AMR_custom_ab")) && file.exists(getOption("AMR_custom_ab", default = ""))) { 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) packageStartupMessage("Adding custom antimicrobials from '", getOption("AMR_custom_ab"), "'...", appendLF = FALSE)
x <- readRDS2(getOption("AMR_custom_ab")) x <- readRDS2(getOption("AMR_custom_ab"))
tryCatch({ tryCatch(
suppressWarnings(suppressMessages(add_custom_antimicrobials(x))) {
packageStartupMessage("OK.") suppressWarnings(suppressMessages(add_custom_antimicrobials(x)))
}, error = function(e) packageStartupMessage("Failed: ", e$message)) packageStartupMessage("OK.")
},
error = function(e) packageStartupMessage("Failed: ", e$message)
)
} }
# if custom mo option is available, load it # if custom mo option is available, load it
if (!is.null(getOption("AMR_custom_mo")) && file.exists(getOption("AMR_custom_mo", default = ""))) { 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) packageStartupMessage("Adding custom microorganisms from '", getOption("AMR_custom_mo"), "'...", appendLF = FALSE)
x <- readRDS2(getOption("AMR_custom_mo")) x <- readRDS2(getOption("AMR_custom_mo"))
tryCatch({ tryCatch(
suppressWarnings(suppressMessages(add_custom_microorganisms(x))) {
packageStartupMessage("OK.") suppressWarnings(suppressMessages(add_custom_microorganisms(x)))
}, error = function(e) packageStartupMessage("Failed: ", e$message)) packageStartupMessage("OK.")
},
error = function(e) packageStartupMessage("Failed: ", e$message)
)
} }
} }

97
data-raw/_pre_commit_hook.R
View File

@ -101,46 +101,48 @@ create_species_cons_cops <- function(type = c("CoNS", "CoPS")) {
MO_staph <- AMR::microorganisms MO_staph <- AMR::microorganisms
MO_staph <- MO_staph[which(MO_staph$genus == "Staphylococcus"), , drop = FALSE] MO_staph <- MO_staph[which(MO_staph$genus == "Staphylococcus"), , drop = FALSE]
if (type == "CoNS") { if (type == "CoNS") {
MO_staph[which(MO_staph$species %in% c( MO_staph[
"coagulase-negative", "argensis", "arlettae", which(MO_staph$species %in% c(
"auricularis", "borealis", "caeli", "capitis", "caprae", "coagulase-negative", "argensis", "arlettae",
"carnosus", "casei", "caseolyticus", "chromogenes", "cohnii", "condimenti", "auricularis", "borealis", "caeli", "capitis", "caprae",
"croceilyticus", "carnosus", "casei", "caseolyticus", "chromogenes", "cohnii", "condimenti",
"debuckii", "devriesei", "edaphicus", "epidermidis", "croceilyticus",
"equorum", "felis", "fleurettii", "gallinarum", "debuckii", "devriesei", "edaphicus", "epidermidis",
"haemolyticus", "hominis", "jettensis", "kloosii", "equorum", "felis", "fleurettii", "gallinarum",
"lentus", "lugdunensis", "massiliensis", "microti", "haemolyticus", "hominis", "jettensis", "kloosii",
"muscae", "nepalensis", "pasteuri", "petrasii", "lentus", "lugdunensis", "massiliensis", "microti",
"pettenkoferi", "piscifermentans", "pragensis", "pseudoxylosus", "muscae", "nepalensis", "pasteuri", "petrasii",
"pulvereri", "rostri", "saccharolyticus", "saprophyticus", "pettenkoferi", "piscifermentans", "pragensis", "pseudoxylosus",
"sciuri", "simulans", "stepanovicii", "succinus", "pulvereri", "rostri", "saccharolyticus", "saprophyticus",
"ureilyticus", "sciuri", "simulans", "stepanovicii", "succinus",
"vitulinus", "vitulus", "warneri", "xylosus", "ureilyticus",
"caledonicus", "canis", "vitulinus", "vitulus", "warneri", "xylosus",
"durrellii", "lloydii", "caledonicus", "canis",
"ratti", "taiwanensis", "veratri", "urealyticus" "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", ""))), # old, now renamed to S. schleiferi (but still as synonym in our data of course):
"mo", (MO_staph$species == "schleiferi" & MO_staph$subspecies %in% c("schleiferi", ""))),
drop = TRUE "mo",
drop = TRUE
] ]
} else if (type == "CoPS") { } else if (type == "CoPS") {
MO_staph[which(MO_staph$species %in% c( MO_staph[
"coagulase-positive", "coagulans", which(MO_staph$species %in% c(
"agnetis", "argenteus", "coagulase-positive", "coagulans",
"cornubiensis", "agnetis", "argenteus",
"delphini", "lutrae", "cornubiensis",
"hyicus", "intermedius", "delphini", "lutrae",
"pseudintermedius", "pseudointermedius", "hyicus", "intermedius",
"schweitzeri", "simiae", "pseudintermedius", "pseudointermedius",
"roterodami", "schweitzeri", "simiae",
"singaporensis" "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")), # old, now renamed to S. coagulans (but still as synonym in our data of course):
"mo", (MO_staph$species == "schleiferi" & MO_staph$subspecies == "coagulans")),
drop = TRUE "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_loinc <- lapply(new_df$loinc, generalise_antibiotic_name)
new_df$generalised_all <- unname(lapply( new_df$generalised_all <- unname(lapply(
as.list(as.data.frame(t(new_df[, as.list(as.data.frame(
c( t(new_df[,
colnames(new_df)[colnames(new_df) %in% c("ab", "av", "atc", "cid", "name")], c(
colnames(new_df)[colnames(new_df) %like% "generalised"] colnames(new_df)[colnames(new_df) %in% c("ab", "av", "atc", "cid", "name")],
), colnames(new_df)[colnames(new_df) %like% "generalised"]
drop = FALSE ),
]), drop = FALSE
stringsAsFactors = FALSE ]),
stringsAsFactors = FALSE
)), )),
function(x) { function(x) {
x <- generalise_antibiotic_name(unname(unlist(x))) x <- generalise_antibiotic_name(unname(unlist(x)))
@ -472,7 +475,7 @@ suppressMessages(devtools::document(quiet = TRUE))
if (!"styler" %in% rownames(utils::installed.packages())) { if (!"styler" %in% rownames(utils::installed.packages())) {
message("Package 'styler' not installed!") message("Package 'styler' not installed!")
} else if (interactive()) { } else if (interactive()) {
# # only when sourcing this file ourselves # only when sourcing this file ourselves
# usethis::ui_info("Styling package") # usethis::ui_info("Styling package")
# styler::style_pkg( # styler::style_pkg(
# style = styler::tidyverse_style, # style = styler::tidyverse_style,

1
data-raw/create_survey_page.R
View File

@ -1,4 +1,3 @@
license_text <- readLines("docs/LICENSE-text.html") license_text <- readLines("docs/LICENSE-text.html")
license_text <- paste(license_text, collapse = "|||") license_text <- paste(license_text, collapse = "|||")
license_text <- gsub("licen(s|c)e", "Survey", license_text, ignore.case = TRUE) license_text <- gsub("licen(s|c)e", "Survey", license_text, ignore.case = TRUE)

49
data-raw/read_EUCAST.R
View File

@ -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 # in the info header in the Excel file, EUCAST mentions which genera are targeted
if (sheet %like% "anaerob.*Gram.*posi") { if (sheet %like% "anaerob.*Gram.*posi") {
sheet <- paste0(c( sheet <- paste0(
"Actinomyces", "Bifidobacterium", "Clostridioides", c(
"Clostridium", "Cutibacterium", "Eggerthella", "Actinomyces", "Bifidobacterium", "Clostridioides",
"Eubacterium", "Lactobacillus", "Propionibacterium", "Clostridium", "Cutibacterium", "Eggerthella",
"Staphylococcus saccharolyticus" "Eubacterium", "Lactobacillus", "Propionibacterium",
), "Staphylococcus saccharolyticus"
collapse = "_" ),
collapse = "_"
) )
} else if (sheet %like% "anaerob.*Gram.*nega") { } else if (sheet %like% "anaerob.*Gram.*nega") {
sheet <- paste0(c( sheet <- paste0(
"Bacteroides", c(
"Bilophila", "Bacteroides",
"Fusobacterium", "Bilophila",
"Mobiluncus", "Fusobacterium",
"Parabacteroides", "Mobiluncus",
"Porphyromonas", "Parabacteroides",
"Prevotella" "Porphyromonas",
), "Prevotella"
collapse = "_" ),
collapse = "_"
) )
} else if (sheet == "Streptococcus A,B,C,G") { } else if (sheet == "Streptococcus A,B,C,G") {
sheet <- paste0(microorganisms %>% sheet <- paste0(
filter(genus == "Streptococcus") %>% microorganisms %>%
mutate(lancefield = mo_name(mo, Lancefield = TRUE)) %>% filter(genus == "Streptococcus") %>%
filter(lancefield %like% "^Streptococcus group") %>% mutate(lancefield = mo_name(mo, Lancefield = TRUE)) %>%
pull(fullname), filter(lancefield %like% "^Streptococcus group") %>%
collapse = "_" pull(fullname),
collapse = "_"
) )
} else if (sheet %like% "PK.*PD") { } else if (sheet %like% "PK.*PD") {
sheet <- "UNKNOWN" sheet <- "UNKNOWN"

71
data-raw/reproduction_of_antibiotics.R
View File

@ -142,14 +142,15 @@ abx2 <- bind_rows(abx_atc1, abx_atc2)
rm(abx_atc1) rm(abx_atc1)
rm(abx_atc2) rm(abx_atc2)
abx2$ab[is.na(abx2$ab)] <- toupper(abbreviate(gsub( abx2$ab[is.na(abx2$ab)] <- toupper(abbreviate(
"[/0-9-]", gsub(
" ", "[/0-9-]",
abx2$name[is.na(abx2$ab)] " ",
), abx2$name[is.na(abx2$ab)]
minlength = 3, ),
method = "left.kept", minlength = 3,
strict = TRUE method = "left.kept",
strict = TRUE
)) ))
n_distinct(abx2$ab) n_distinct(abx2$ab)
@ -197,24 +198,26 @@ get_CID <- function(ab) {
p$tick() p$tick()
CID[i] <- tryCatch( CID[i] <- tryCatch(
data.table::fread(paste0( data.table::fread(
"https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/name/", paste0(
URLencode(ab[i], reserved = TRUE), "https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/name/",
"/cids/TXT?name_type=complete" URLencode(ab[i], reserved = TRUE),
), "/cids/TXT?name_type=complete"
showProgress = FALSE ),
showProgress = FALSE
)[[1]][1], )[[1]][1],
error = function(e) NA_integer_ error = function(e) NA_integer_
) )
if (is.na(CID[i])) { if (is.na(CID[i])) {
# try with removing the text in brackets # try with removing the text in brackets
CID[i] <- tryCatch( CID[i] <- tryCatch(
data.table::fread(paste0( data.table::fread(
"https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/name/", paste0(
URLencode(trimws(gsub("[(].*[)]", "", ab[i])), reserved = TRUE), "https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/name/",
"/cids/TXT?name_type=complete" URLencode(trimws(gsub("[(].*[)]", "", ab[i])), reserved = TRUE),
), "/cids/TXT?name_type=complete"
showProgress = FALSE ),
showProgress = FALSE
)[[1]][1], )[[1]][1],
error = function(e) NA_integer_ error = function(e) NA_integer_
) )
@ -223,12 +226,13 @@ get_CID <- function(ab) {
# try match on word and take the lowest CID value (sorted) # try match on word and take the lowest CID value (sorted)
ab[i] <- gsub("[^a-z0-9]+", " ", ab[i], ignore.case = TRUE) ab[i] <- gsub("[^a-z0-9]+", " ", ab[i], ignore.case = TRUE)
CID[i] <- tryCatch( CID[i] <- tryCatch(
data.table::fread(paste0( data.table::fread(
"https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/name/", paste0(
URLencode(ab[i], reserved = TRUE), "https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/name/",
"/cids/TXT?name_type=word" URLencode(ab[i], reserved = TRUE),
), "/cids/TXT?name_type=word"
showProgress = FALSE ),
showProgress = FALSE
)[[1]][1], )[[1]][1],
error = function(e) NA_integer_ error = function(e) NA_integer_
) )
@ -260,13 +264,14 @@ get_synonyms <- function(CID, clean = TRUE) {
} }
synonyms_txt <- tryCatch( synonyms_txt <- tryCatch(
data.table::fread(paste0( data.table::fread(
"https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/fastidentity/cid/", paste0(
CID[i], "https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/fastidentity/cid/",
"/synonyms/TXT" CID[i],
), "/synonyms/TXT"
sep = "\n", ),
showProgress = FALSE sep = "\n",
showProgress = FALSE
)[[1]], )[[1]],
error = function(e) NA_character_ error = function(e) NA_character_
) )

22
data-raw/reproduction_of_antivirals.R
View File

@ -110,10 +110,10 @@ antivirals <- antivirals %>%
AMR:::dataset_UTF8_to_ASCII() AMR:::dataset_UTF8_to_ASCII()
av_codes <- tibble(name = antivirals$name %>% av_codes <- tibble(name = antivirals$name %>%
strsplit("(, | and )") %>% strsplit("(, | and )") %>%
unlist() %>% unlist() %>%
unique() %>% unique() %>%
sort()) %>% sort()) %>%
mutate(av_1st = toupper(abbreviate(name, minlength = 3, use.classes = FALSE))) %>% mutate(av_1st = toupper(abbreviate(name, minlength = 3, use.classes = FALSE))) %>%
filter(!name %in% c("acid", "dipivoxil", "disoproxil", "marboxil", "alafenamide")) filter(!name %in% c("acid", "dipivoxil", "disoproxil", "marboxil", "alafenamide"))
@ -123,10 +123,11 @@ replace_with_av_code <- function(name) {
names_codes <- antivirals %>% names_codes <- antivirals %>%
separate(name, separate(name,
into = paste0("name", c(1:7)), into = paste0("name", c(1:7)),
sep = "(, | and )", sep = "(, | and )",
remove = FALSE, remove = FALSE,
fill = "right") %>% fill = "right"
) %>%
# remove empty columns # remove empty columns
select(!where(function(x) all(is.na(x)))) %>% select(!where(function(x) all(is.na(x)))) %>%
mutate_at(vars(matches("name[1-9]")), replace_with_av_code) %>% mutate_at(vars(matches("name[1-9]")), replace_with_av_code) %>%
@ -143,8 +144,9 @@ antivirals <- antivirals %>% AMR:::dataset_UTF8_to_ASCII()
# add loinc, see 'data-raw/loinc.R' # add loinc, see 'data-raw/loinc.R'
loinc_df <- read.csv("data-raw/Loinc.csv", loinc_df <- read.csv("data-raw/Loinc.csv",
row.names = NULL, row.names = NULL,
stringsAsFactors = FALSE) stringsAsFactors = FALSE
)
loinc_df <- loinc_df %>% filter(CLASS == "DRUG/TOX") loinc_df <- loinc_df %>% filter(CLASS == "DRUG/TOX")
av_names <- antivirals %>% av_names <- antivirals %>%

291
data-raw/reproduction_of_microorganisms.R
View File

@ -39,8 +39,8 @@
# 3. For data about human pathogens, we use Bartlett et al. (2022), # 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. # 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 # . Download their latest xlsx file in the `data` folder and save it to our
#. `data-raw` folder. # . `data-raw` folder.
# 4. Set this folder_location to the path where these two files are: # 4. Set this folder_location to the path where these two files are:
folder_location <- "~/Downloads/backbone/" folder_location <- "~/Downloads/backbone/"
file_gbif <- paste0(folder_location, "Taxon.tsv") file_gbif <- paste0(folder_location, "Taxon.tsv")
@ -73,8 +73,8 @@ get_author_year <- function(ref) {
authors2 <- trimws(gsub("^[(](.*)[)]$", "\\1", authors2)) authors2 <- trimws(gsub("^[(](.*)[)]$", "\\1", authors2))
# only take part after brackets if there's a name # only take part after brackets if there's a name
authors2 <- ifelse(grepl(".*[)] [a-zA-Z]+.*", authors2), authors2 <- ifelse(grepl(".*[)] [a-zA-Z]+.*", authors2),
gsub(".*[)] (.*)", "\\1", authors2), gsub(".*[)] (.*)", "\\1", authors2),
authors2 authors2
) )
# replace parentheses with emend. to get the latest authors # replace parentheses with emend. to get the latest authors
authors2 <- gsub("(", " emend. ", authors2, fixed = TRUE) authors2 <- gsub("(", " emend. ", authors2, fixed = TRUE)
@ -86,8 +86,8 @@ get_author_year <- function(ref) {
lastyear <- as.integer(gsub(".*([0-9]{4})$", "\\1", authors2)) lastyear <- as.integer(gsub(".*([0-9]{4})$", "\\1", authors2))
# can never be later than now # can never be later than now
lastyear <- ifelse(lastyear > as.integer(format(Sys.Date(), "%Y")), lastyear <- ifelse(lastyear > as.integer(format(Sys.Date(), "%Y")),
NA, NA,
lastyear lastyear
) )
# get authors without last year # get authors without last year
authors <- gsub("(.*)[0-9]{4}$", "\\1", authors2) authors <- gsub("(.*)[0-9]{4}$", "\\1", authors2)
@ -119,8 +119,8 @@ get_author_year <- function(ref) {
authors[nchar(authors) <= 3] <- "" authors[nchar(authors) <= 3] <- ""
# combine author and year if year is available # combine author and year if year is available
ref <- ifelse(!is.na(lastyear), ref <- ifelse(!is.na(lastyear),
paste0(authors, ", ", lastyear), paste0(authors, ", ", lastyear),
authors authors
) )
# fix beginning and ending # fix beginning and ending
ref <- gsub(", $", "", ref) ref <- gsub(", $", "", ref)
@ -491,14 +491,14 @@ saveRDS(taxonomy_lpsn, "data-raw/taxonomy_lpsn.rds", version = 2)
taxonomy_gbif <- taxonomy_gbif %>% taxonomy_gbif <- taxonomy_gbif %>%
# clean NAs and add fullname # clean NAs and add fullname
mutate(across(kingdom:subspecies, function(x) ifelse(is.na(x), "", x)), mutate(across(kingdom:subspecies, function(x) ifelse(is.na(x), "", x)),
fullname = trimws(case_when( fullname = trimws(case_when(
rank == "family" ~ family, rank == "family" ~ family,
rank == "order" ~ order, rank == "order" ~ order,
rank == "class" ~ class, rank == "class" ~ class,
rank == "phylum" ~ phylum, rank == "phylum" ~ phylum,
rank == "kingdom" ~ kingdom, rank == "kingdom" ~ kingdom,
TRUE ~ paste(genus, species, subspecies) TRUE ~ paste(genus, species, subspecies)
)), .before = 1 )), .before = 1
) %>% ) %>%
# keep only one GBIF taxon ID per full name # keep only one GBIF taxon ID per full name
arrange(fullname, gbif) %>% arrange(fullname, gbif) %>%
@ -507,14 +507,14 @@ taxonomy_gbif <- taxonomy_gbif %>%
taxonomy_lpsn <- taxonomy_lpsn %>% taxonomy_lpsn <- taxonomy_lpsn %>%
# clean NAs and add fullname # clean NAs and add fullname
mutate(across(kingdom:subspecies, function(x) ifelse(is.na(x), "", x)), mutate(across(kingdom:subspecies, function(x) ifelse(is.na(x), "", x)),
fullname = trimws(case_when( fullname = trimws(case_when(
rank == "family" ~ family, rank == "family" ~ family,
rank == "order" ~ order, rank == "order" ~ order,
rank == "class" ~ class, rank == "class" ~ class,
rank == "phylum" ~ phylum, rank == "phylum" ~ phylum,
rank == "kingdom" ~ kingdom, rank == "kingdom" ~ kingdom,
TRUE ~ paste(genus, species, subspecies) TRUE ~ paste(genus, species, subspecies)
)), .before = 1 )), .before = 1
) %>% ) %>%
# keep only one LPSN record ID per full name # keep only one LPSN record ID per full name
arrange(fullname, lpsn) %>% arrange(fullname, lpsn) %>%
@ -536,23 +536,25 @@ taxonomy_lpsn$lpsn_parent[taxonomy_lpsn$rank == "subspecies"] <- taxonomy_lpsn$l
taxonomy <- taxonomy_lpsn %>% taxonomy <- taxonomy_lpsn %>%
# join GBIF identifiers to them # join GBIF identifiers to them
left_join(taxonomy_gbif %>% select(kingdom, fullname, starts_with("gbif")), 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 # for everything else, add the GBIF data
taxonomy <- taxonomy %>% taxonomy <- taxonomy %>%
bind_rows(taxonomy_gbif %>% 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) %>% arrange(fullname) %>%
filter(fullname != "") filter(fullname != "")
# get missing entries from existing microorganisms data set # get missing entries from existing microorganisms data set
taxonomy <- taxonomy %>% taxonomy <- taxonomy %>%
bind_rows(AMR::microorganisms %>% bind_rows(AMR::microorganisms %>%
select(all_of(colnames(taxonomy))) %>% select(all_of(colnames(taxonomy))) %>%
filter(!paste(kingdom, fullname) %in% paste(taxonomy$kingdom, taxonomy$fullname), filter(
# these will be added later: !paste(kingdom, fullname) %in% paste(taxonomy$kingdom, taxonomy$fullname),
source != "manually added")) %>% # these will be added later:
source != "manually added"
)) %>%
arrange(fullname) %>% arrange(fullname) %>%
filter(fullname != "") filter(fullname != "")
@ -602,9 +604,10 @@ taxonomy <- taxonomy %>%
source = "manually added" source = "manually added"
) %>% ) %>%
filter(!paste(kingdom, rank) %in% paste(taxonomy$kingdom, taxonomy$rank)) %>% filter(!paste(kingdom, rank) %in% paste(taxonomy$kingdom, taxonomy$rank)) %>%
left_join(current_gbif %>% left_join(
select(kingdom, rank = taxonRank, ref = scientificNameAuthorship, gbif = taxonID, gbif_parent = parentNameUsageID), current_gbif %>%
by = c("kingdom", "rank") select(kingdom, rank = taxonRank, ref = scientificNameAuthorship, gbif = taxonID, gbif_parent = parentNameUsageID),
by = c("kingdom", "rank")
) %>% ) %>%
mutate(source = ifelse(!is.na(gbif), "GBIF", source)) mutate(source = ifelse(!is.na(gbif), "GBIF", source))
) )
@ -625,12 +628,13 @@ for (i in 2:6) {
source = "manually added" source = "manually added"
) %>% ) %>%
filter(!paste(kingdom, .[[ncol(.) - 4]], rank) %in% paste(taxonomy$kingdom, taxonomy[[i + 1]], taxonomy$rank)) %>% filter(!paste(kingdom, .[[ncol(.) - 4]], rank) %in% paste(taxonomy$kingdom, taxonomy[[i + 1]], taxonomy$rank)) %>%
# get GBIF identifier where available # get GBIF identifier where available
left_join(current_gbif %>% left_join(
select(kingdom, all_of(i_name), rank = taxonRank, ref = scientificNameAuthorship, gbif = taxonID, gbif_parent = parentNameUsageID), current_gbif %>%
by = c("kingdom", "rank", i_name) 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)) ) %>%
mutate(source = ifelse(!is.na(gbif), "GBIF", source))
message("n = ", nrow(to_add)) message("n = ", nrow(to_add))
if (is.null(taxonomy_all_missing)) { if (is.null(taxonomy_all_missing)) {
taxonomy_all_missing <- to_add taxonomy_all_missing <- to_add
@ -646,14 +650,18 @@ taxonomy <- taxonomy %>%
# fix for duplicate fullnames within a kingdom (such as Nitrospira which is the name of the genus AND its class) # fix for duplicate fullnames within a kingdom (such as Nitrospira which is the name of the genus AND its class)
taxonomy <- taxonomy %>% taxonomy <- taxonomy %>%
mutate(rank_index = case_when(rank == "subspecies" ~ 1, mutate(
rank == "species" ~ 2, rank_index = case_when(
rank == "genus" ~ 3, rank == "subspecies" ~ 1,
rank == "family" ~ 4, rank == "species" ~ 2,
rank == "order" ~ 5, rank == "genus" ~ 3,
rank == "class" ~ 6, rank == "family" ~ 4,
TRUE ~ 7), rank == "order" ~ 5,
fullname_rank = paste0(fullname, " {", rank, "}")) %>% rank == "class" ~ 6,
TRUE ~ 7
),
fullname_rank = paste0(fullname, " {", rank, "}")
) %>%
arrange(kingdom, fullname, rank_index) %>% arrange(kingdom, fullname, rank_index) %>%
group_by(kingdom, fullname) %>% group_by(kingdom, fullname) %>%
mutate(fullname = if_else(row_number() > 1, fullname_rank, fullname)) %>% mutate(fullname = if_else(row_number() > 1, fullname_rank, fullname)) %>%
@ -676,12 +684,13 @@ taxonomy <- taxonomy %>%
) %>% ) %>%
filter(!paste(kingdom, genus, species, rank) %in% paste(taxonomy$kingdom, taxonomy$genus, taxonomy$species, taxonomy$rank)) %>% filter(!paste(kingdom, genus, species, rank) %in% paste(taxonomy$kingdom, taxonomy$genus, taxonomy$species, taxonomy$rank)) %>%
# get GBIF identifier where available # get GBIF identifier where available
left_join(current_gbif %>% left_join(
select(kingdom, genus, species = specificEpithet, rank = taxonRank, ref = scientificNameAuthorship, gbif = taxonID, gbif_parent = parentNameUsageID), current_gbif %>%
by = c("kingdom", "rank", "genus", "species") 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)) mutate(source = ifelse(!is.na(gbif), "GBIF", source))
) )
# remove NAs from taxonomy again, and keep unique full names # remove NAs from taxonomy again, and keep unique full names
@ -809,8 +818,10 @@ established <- pathogens %>%
filter(status == "established") %>% filter(status == "established") %>%
mutate(fullname = paste(genus, species)) %>% mutate(fullname = paste(genus, species)) %>%
pull(fullname) %>% pull(fullname) %>%
c(unlist(mo_current(.)), c(
unlist(mo_synonyms(., keep_synonyms = FALSE))) %>% unlist(mo_current(.)),
unlist(mo_synonyms(., keep_synonyms = FALSE))
) %>%
strsplit(" ", fixed = TRUE) %>% strsplit(" ", fixed = TRUE) %>%
sapply(function(x) ifelse(length(x) == 1, x, paste(x[1], x[2]))) %>% sapply(function(x) ifelse(length(x) == 1, x, paste(x[1], x[2]))) %>%
sort() %>% sort() %>%
@ -821,8 +832,10 @@ putative <- pathogens %>%
filter(status == "putative") %>% filter(status == "putative") %>%
mutate(fullname = paste(genus, species)) %>% mutate(fullname = paste(genus, species)) %>%
pull(fullname) %>% pull(fullname) %>%
c(unlist(mo_current(.)), c(
unlist(mo_synonyms(., keep_synonyms = FALSE))) %>% unlist(mo_current(.)),
unlist(mo_synonyms(., keep_synonyms = FALSE))
) %>%
strsplit(" ", fixed = TRUE) %>% strsplit(" ", fixed = TRUE) %>%
sapply(function(x) ifelse(length(x) == 1, x, paste(x[1], x[2]))) %>% sapply(function(x) ifelse(length(x) == 1, x, paste(x[1], x[2]))) %>%
sort() %>% sort() %>%
@ -844,8 +857,10 @@ putative_genera <- putative %>%
unique() unique()
nonbacterial_genera <- AMR:::MO_PREVALENT_GENERA %>% nonbacterial_genera <- AMR:::MO_PREVALENT_GENERA %>%
c(unlist(mo_current(.)), c(
unlist(mo_synonyms(., keep_synonyms = FALSE))) %>% unlist(mo_current(.)),
unlist(mo_synonyms(., keep_synonyms = FALSE))
) %>%
strsplit(" ", fixed = TRUE) %>% strsplit(" ", fixed = TRUE) %>%
sapply(function(x) x[1]) %>% sapply(function(x) x[1]) %>%
sort() %>% sort() %>%
@ -874,7 +889,8 @@ taxonomy <- taxonomy %>%
genus %in% AMR:::MO_PREVALENT_GENERA & kingdom != "Bacteria" & rank %in% c("genus", "species", "subspecies") ~ 1.5, genus %in% AMR:::MO_PREVALENT_GENERA & kingdom != "Bacteria" & rank %in% c("genus", "species", "subspecies") ~ 1.5,
# all others # all others
TRUE ~ 2.0)) TRUE ~ 2.0
))
table(taxonomy$prevalence, useNA = "always") table(taxonomy$prevalence, useNA = "always")
# (a lot will be removed further below) # (a lot will be removed further below)
@ -909,13 +925,14 @@ mo_kingdom <- taxonomy %>%
mo_phylum <- taxonomy %>% mo_phylum <- taxonomy %>%
filter(rank == "phylum") %>% filter(rank == "phylum") %>%
distinct(kingdom, phylum) %>% distinct(kingdom, phylum) %>%
left_join(AMR::microorganisms %>% left_join(
filter(rank == "phylum") %>% AMR::microorganisms %>%
transmute(kingdom, filter(rank == "phylum") %>%
phylum = fullname, transmute(kingdom,
mo_old = gsub("[A-Z]{1,2}_", "", as.character(mo)) phylum = fullname,
), mo_old = gsub("[A-Z]{1,2}_", "", as.character(mo))
by = c("kingdom", "phylum") ),
by = c("kingdom", "phylum")
) %>% ) %>%
group_by(kingdom) %>% group_by(kingdom) %>%
mutate( mutate(
@ -935,13 +952,14 @@ mo_phylum <- mo_phylum %>%
mo_class <- taxonomy %>% mo_class <- taxonomy %>%
filter(rank == "class") %>% filter(rank == "class") %>%
distinct(kingdom, class) %>% distinct(kingdom, class) %>%
left_join(AMR::microorganisms %>% left_join(
filter(rank == "class") %>% AMR::microorganisms %>%
transmute(kingdom, filter(rank == "class") %>%
class = fullname, transmute(kingdom,
mo_old = gsub("[A-Z]{1,2}_", "", as.character(mo)) class = fullname,
), mo_old = gsub("[A-Z]{1,2}_", "", as.character(mo))
by = c("kingdom", "class") ),
by = c("kingdom", "class")
) %>% ) %>%
group_by(kingdom) %>% group_by(kingdom) %>%
mutate( mutate(
@ -961,13 +979,14 @@ mo_class <- mo_class %>%
mo_order <- taxonomy %>% mo_order <- taxonomy %>%
filter(rank == "order") %>% filter(rank == "order") %>%
distinct(kingdom, order) %>% distinct(kingdom, order) %>%
left_join(AMR::microorganisms %>% left_join(
filter(rank == "order") %>% AMR::microorganisms %>%
transmute(kingdom, filter(rank == "order") %>%
order = fullname, transmute(kingdom,
mo_old = gsub("[A-Z]{1,2}_", "", as.character(mo)) order = fullname,
), mo_old = gsub("[A-Z]{1,2}_", "", as.character(mo))
by = c("kingdom", "order") ),
by = c("kingdom", "order")
) %>% ) %>%
group_by(kingdom) %>% group_by(kingdom) %>%
mutate( mutate(
@ -987,13 +1006,14 @@ mo_order <- mo_order %>%
mo_family <- taxonomy %>% mo_family <- taxonomy %>%
filter(rank == "family") %>% filter(rank == "family") %>%
distinct(kingdom, family) %>% distinct(kingdom, family) %>%
left_join(AMR::microorganisms %>% left_join(
filter(rank == "family") %>% AMR::microorganisms %>%
transmute(kingdom, filter(rank == "family") %>%
family = fullname, transmute(kingdom,
mo_old = gsub("[A-Z]{1,2}_", "", as.character(mo)) family = fullname,
), mo_old = gsub("[A-Z]{1,2}_", "", as.character(mo))
by = c("kingdom", "family") ),
by = c("kingdom", "family")
) %>% ) %>%
group_by(kingdom) %>% group_by(kingdom) %>%
mutate( mutate(
@ -1014,11 +1034,12 @@ mo_genus <- taxonomy %>%
filter(rank == "genus") %>% filter(rank == "genus") %>%
distinct(kingdom, genus) %>% distinct(kingdom, genus) %>%
# get available old MO codes # get available old MO codes
left_join(AMR::microorganisms %>% left_join(
filter(rank == "genus") %>% AMR::microorganisms %>%
transmute(mo_genus_old = gsub("^[A-Z]+_", "", as.character(mo)), kingdom, genus) %>% filter(rank == "genus") %>%
distinct(kingdom, genus, .keep_all = TRUE), transmute(mo_genus_old = gsub("^[A-Z]+_", "", as.character(mo)), kingdom, genus) %>%
by = c("kingdom", "genus") distinct(kingdom, genus, .keep_all = TRUE),
by = c("kingdom", "genus")
) %>% ) %>%
distinct(kingdom, genus, .keep_all = TRUE) %>% distinct(kingdom, genus, .keep_all = TRUE) %>%
# since kingdom is part of the code, genus abbreviations may be duplicated between kingdoms # 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 %>% mo_species <- taxonomy %>%
filter(rank == "species") %>% filter(rank == "species") %>%
distinct(kingdom, genus, species) %>% distinct(kingdom, genus, species) %>%
left_join(AMR::microorganisms %>% left_join(
filter(rank == "species") %>% AMR::microorganisms %>%
transmute(mo_species_old = gsub("^[A-Z]+_[A-Z]+_", "", as.character(mo)), kingdom, genus, species) %>% filter(rank == "species") %>%
filter(mo_species_old %unlike% "-") %>% transmute(mo_species_old = gsub("^[A-Z]+_[A-Z]+_", "", as.character(mo)), kingdom, genus, species) %>%
distinct(kingdom, genus, species, .keep_all = TRUE), filter(mo_species_old %unlike% "-") %>%
by = c("kingdom", "genus", "species") distinct(kingdom, genus, species, .keep_all = TRUE),
by = c("kingdom", "genus", "species")
) %>% ) %>%
distinct(kingdom, genus, species, .keep_all = TRUE) %>% distinct(kingdom, genus, species, .keep_all = TRUE) %>%
group_by(kingdom, genus) %>% group_by(kingdom, genus) %>%
@ -1108,12 +1130,13 @@ mo_species <- mo_species %>%
mo_subspecies <- taxonomy %>% mo_subspecies <- taxonomy %>%
filter(rank == "subspecies") %>% filter(rank == "subspecies") %>%
distinct(kingdom, genus, species, subspecies) %>% distinct(kingdom, genus, species, subspecies) %>%
left_join(AMR::microorganisms %>% left_join(
filter(rank %in% c("subspecies", "subsp.", "infraspecies")) %>% AMR::microorganisms %>%
transmute(mo_subspecies_old = gsub("^[A-Z]+_[A-Z]+_[A-Z]+_", "", as.character(mo)), kingdom, genus, species, subspecies) %>% filter(rank %in% c("subspecies", "subsp.", "infraspecies")) %>%
filter(mo_subspecies_old %unlike% "-") %>% transmute(mo_subspecies_old = gsub("^[A-Z]+_[A-Z]+_[A-Z]+_", "", as.character(mo)), kingdom, genus, species, subspecies) %>%
distinct(kingdom, genus, species, subspecies, .keep_all = TRUE), filter(mo_subspecies_old %unlike% "-") %>%
by = c("kingdom", "genus", "species", "subspecies") distinct(kingdom, genus, species, subspecies, .keep_all = TRUE),
by = c("kingdom", "genus", "species", "subspecies")
) %>% ) %>%
distinct(kingdom, genus, species, subspecies, .keep_all = TRUE) %>% distinct(kingdom, genus, species, subspecies, .keep_all = TRUE) %>%
group_by(kingdom, genus, species) %>% group_by(kingdom, genus, species) %>%
@ -1187,20 +1210,26 @@ taxonomy <- taxonomy %>%
arrange(fullname) arrange(fullname)
# now check these - e.g. Nitrospira is the name of a genus AND its class # 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 %>% taxonomy <- taxonomy %>%
mutate(rank_index = case_when(kingdom == "Bacteria" ~ 1, mutate(rank_index = case_when(
kingdom == "Fungi" ~ 2, kingdom == "Bacteria" ~ 1,
kingdom == "Protozoa" ~ 3, kingdom == "Fungi" ~ 2,
kingdom == "Archaea" ~ 4, kingdom == "Protozoa" ~ 3,
TRUE ~ 5)) %>% kingdom == "Archaea" ~ 4,
TRUE ~ 5
)) %>%
arrange(fullname, rank_index) %>% arrange(fullname, rank_index) %>%
distinct(fullname, .keep_all = TRUE) %>% distinct(fullname, .keep_all = TRUE) %>%
select(-rank_index) %>% select(-rank_index) %>%
filter(mo != "") filter(mo != "")
# this must not exist: # this must not exist:
taxonomy %>% filter(mo %like% "__") %>% View() taxonomy %>%
filter(mo %like% "__") %>%
View()
taxonomy <- taxonomy %>% filter(mo %unlike% "__") 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]) taxonomy %>% filter(fullname %in% .[duplicated(fullname), "fullname", drop = TRUE])
# are all GBIFs available? # 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 # 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 == "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$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? # 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 # 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)] 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 # no ghost families, orders classes, phyla
taxonomy <- taxonomy %>% taxonomy <- taxonomy %>%
group_by(kingdom, family) %>% filter(n() > 1 | fullname %like% "unknown" | rank == "kingdom") %>% group_by(kingdom, family) %>%
group_by(kingdom, order) %>% filter(n() > 1 | fullname %like% "unknown" | rank == "kingdom") %>% filter(n() > 1 | fullname %like% "unknown" | rank == "kingdom") %>%
group_by(kingdom, class) %>% filter(n() > 1 | fullname %like% "unknown" | rank == "kingdom") %>% group_by(kingdom, order) %>%
group_by(kingdom, phylum) %>% filter(n() > 1 | fullname %like% "unknown" | rank == "kingdom") %>% 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() ungroup()
message("\nCongratulations! The new taxonomic table will contain ", format(nrow(taxonomy), big.mark = ","), " rows.\n", message(
"This was ", format(nrow(AMR::microorganisms), big.mark = ","), " rows.\n") "\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: # 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: # these were removed:
AMR::microorganisms %>% filter(!paste(kingdom, fullname) %in% paste(taxonomy$kingdom, taxonomy$fullname)) %>% View() AMR::microorganisms %>%
AMR::microorganisms %>% filter(!fullname %in% taxonomy$fullname) %>% View() filter(!paste(kingdom, fullname) %in% paste(taxonomy$kingdom, taxonomy$fullname)) %>%
View()
AMR::microorganisms %>%
filter(!fullname %in% taxonomy$fullname) %>%
View()
# Add SNOMED CT ----------------------------------------------------------- # Add SNOMED CT -----------------------------------------------------------

3050
data-raw/salmonellae.R
View File

File diff suppressed because it is too large Load Diff

19
man/add_custom_microorganisms.Rd
View File

@ -58,8 +58,9 @@ mo_name("Enterobacter asburiae/cloacae")
# now add a custom entry - it will be considered by as.mo() and # now add a custom entry - it will be considered by as.mo() and
# all mo_*() functions # all mo_*() functions
add_custom_microorganisms( add_custom_microorganisms(
data.frame(genus = "Enterobacter", data.frame(
species = "asburiae/cloacae" genus = "Enterobacter",
species = "asburiae/cloacae"
) )
) )
@ -81,8 +82,10 @@ mo_info("Enterobacter asburiae/cloacae")
# the function tries to be forgiving: # the function tries to be forgiving:
add_custom_microorganisms( add_custom_microorganisms(
data.frame(GENUS = "BACTEROIDES / PARABACTEROIDES SLASHLINE", data.frame(
SPECIES = "SPECIES") GENUS = "BACTEROIDES / PARABACTEROIDES SLASHLINE",
SPECIES = "SPECIES"
)
) )
mo_name("BACTEROIDES / PARABACTEROIDES") mo_name("BACTEROIDES / PARABACTEROIDES")
mo_rank("BACTEROIDES / PARABACTEROIDES") mo_rank("BACTEROIDES / PARABACTEROIDES")
@ -93,9 +96,11 @@ mo_family("Bacteroides/Parabacteroides")
# for groups and complexes, set them as species or subspecies: # for groups and complexes, set them as species or subspecies:
add_custom_microorganisms( add_custom_microorganisms(
data.frame(genus = "Citrobacter", data.frame(
species = c("freundii", "braakii complex"), genus = "Citrobacter",
subspecies = c("complex", "")) species = c("freundii", "braakii complex"),
subspecies = c("complex", "")
)
) )
mo_name(c("C. freundii complex", "C. braakii complex")) mo_name(c("C. freundii complex", "C. braakii complex"))
mo_species(c("C. freundii complex", "C. braakii complex")) mo_species(c("C. freundii complex", "C. braakii complex"))

12
man/antibiotic_class_selectors.Rd
View File

@ -214,20 +214,17 @@ example_isolates[, ab_selector(oral_ddd > 1 & oral_units == "g")]
# dplyr ------------------------------------------------------------------- # dplyr -------------------------------------------------------------------
\donttest{ \donttest{
if (require("dplyr")) { if (require("dplyr")) {
# get AMR for all aminoglycosides e.g., per ward: # get AMR for all aminoglycosides e.g., per ward:
example_isolates \%>\% example_isolates \%>\%
group_by(ward) \%>\% group_by(ward) \%>\%
summarise(across(aminoglycosides(), resistance)) summarise(across(aminoglycosides(), resistance))
} }
if (require("dplyr")) { if (require("dplyr")) {
# You can combine selectors with '&' to be more specific: # You can combine selectors with '&' to be more specific:
example_isolates \%>\% example_isolates \%>\%
select(penicillins() & administrable_per_os()) select(penicillins() & administrable_per_os())
} }
if (require("dplyr")) { if (require("dplyr")) {
# get AMR for only drugs that matter - no intrinsic resistance: # get AMR for only drugs that matter - no intrinsic resistance:
example_isolates \%>\% example_isolates \%>\%
filter(mo_genus() \%in\% c("Escherichia", "Klebsiella")) \%>\% filter(mo_genus() \%in\% c("Escherichia", "Klebsiella")) \%>\%
@ -235,7 +232,6 @@ if (require("dplyr")) {
summarise(across(not_intrinsic_resistant(), resistance)) summarise(across(not_intrinsic_resistant(), resistance))
} }
if (require("dplyr")) { if (require("dplyr")) {
# get susceptibility for antibiotics whose name contains "trim": # get susceptibility for antibiotics whose name contains "trim":
example_isolates \%>\% example_isolates \%>\%
filter(first_isolate()) \%>\% filter(first_isolate()) \%>\%
@ -243,19 +239,16 @@ if (require("dplyr")) {
summarise(across(ab_selector(name \%like\% "trim"), susceptibility)) summarise(across(ab_selector(name \%like\% "trim"), susceptibility))
} }
if (require("dplyr")) { if (require("dplyr")) {
# this will select columns 'IPM' (imipenem) and 'MEM' (meropenem): # this will select columns 'IPM' (imipenem) and 'MEM' (meropenem):
example_isolates \%>\% example_isolates \%>\%
select(carbapenems()) select(carbapenems())
} }
if (require("dplyr")) { if (require("dplyr")) {
# this will select columns 'mo', 'AMK', 'GEN', 'KAN' and 'TOB': # this will select columns 'mo', 'AMK', 'GEN', 'KAN' and 'TOB':
example_isolates \%>\% example_isolates \%>\%
select(mo, aminoglycosides()) select(mo, aminoglycosides())
} }
if (require("dplyr")) { if (require("dplyr")) {
# any() and all() work in dplyr's filter() too: # any() and all() work in dplyr's filter() too:
example_isolates \%>\% example_isolates \%>\%
filter( filter(
@ -264,25 +257,21 @@ if (require("dplyr")) {
) )
} }
if (require("dplyr")) { if (require("dplyr")) {
# also works with c(): # also works with c():
example_isolates \%>\% example_isolates \%>\%
filter(any(c(carbapenems(), aminoglycosides()) == "R")) filter(any(c(carbapenems(), aminoglycosides()) == "R"))
} }
if (require("dplyr")) { if (require("dplyr")) {
# not setting any/all will automatically apply all(): # not setting any/all will automatically apply all():
example_isolates \%>\% example_isolates \%>\%
filter(aminoglycosides() == "R") filter(aminoglycosides() == "R")
} }
if (require("dplyr")) { if (require("dplyr")) {
# this will select columns 'mo' and all antimycobacterial drugs ('RIF'): # this will select columns 'mo' and all antimycobacterial drugs ('RIF'):
example_isolates \%>\% example_isolates \%>\%
select(mo, ab_class("mycobact")) select(mo, ab_class("mycobact"))
} }
if (require("dplyr")) { if (require("dplyr")) {
# get bug/drug combinations for only glycopeptides in Gram-positives: # get bug/drug combinations for only glycopeptides in Gram-positives:
example_isolates \%>\% example_isolates \%>\%
filter(mo_is_gram_positive()) \%>\% filter(mo_is_gram_positive()) \%>\%
@ -298,7 +287,6 @@ if (require("dplyr")) {
select(penicillins()) # only the 'J01CA01' column will be selected select(penicillins()) # only the 'J01CA01' column will be selected
} }
if (require("dplyr")) { if (require("dplyr")) {
# with recent versions of dplyr this is all equal: # with recent versions of dplyr this is all equal:
x <- example_isolates[carbapenems() == "R", ] x <- example_isolates[carbapenems() == "R", ]
y <- example_isolates \%>\% filter(carbapenems() == "R") y <- example_isolates \%>\% filter(carbapenems() == "R")

1
man/as.ab.Rd
View File

@ -91,7 +91,6 @@ ab_name("eryt")
\donttest{ \donttest{
if (require("dplyr")) { if (require("dplyr")) {
# you can quickly rename 'sir' columns using set_ab_names() with dplyr: # you can quickly rename 'sir' columns using set_ab_names() with dplyr:
example_isolates \%>\% example_isolates \%>\%
set_ab_names(where(is.sir), property = "atc") set_ab_names(where(is.sir), property = "atc")

2
man/as.sir.Rd
View File

@ -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)}. \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}{ \subsection{Supported Guidelines}{

2
man/first_isolate.Rd
View File

@ -179,13 +179,11 @@ if (require("dplyr")) {
filter(first_isolate()) filter(first_isolate())
} }
if (require("dplyr")) { if (require("dplyr")) {
# short-hand version: # short-hand version:
example_isolates \%>\% example_isolates \%>\%
filter_first_isolate(info = FALSE) filter_first_isolate(info = FALSE)
} }
if (require("dplyr")) { if (require("dplyr")) {
# flag the first isolates per group: # flag the first isolates per group:
example_isolates \%>\% example_isolates \%>\%
group_by(ward) \%>\% group_by(ward) \%>\%

13
man/get_episode.Rd
View File

@ -44,11 +44,12 @@ is_new_episode(df$date, episode_days = 60) # TRUE/FALSE
df[which(get_episode(df$date, 60) == 3), ] df[which(get_episode(df$date, 60) == 3), ]
# the functions also work for less than a day, e.g. to include one per hour: # the functions also work for less than a day, e.g. to include one per hour:
get_episode(c( get_episode(
Sys.time(), c(
Sys.time() + 60 * 60 Sys.time(),
), Sys.time() + 60 * 60
episode_days = 1 / 24 ),
episode_days = 1 / 24
) )
\donttest{ \donttest{
@ -85,7 +86,6 @@ if (require("dplyr")) {
) )
} }
if (require("dplyr")) { if (require("dplyr")) {
# grouping on patients and microorganisms leads to the same # grouping on patients and microorganisms leads to the same
# results as first_isolate() when using 'episode-based': # results as first_isolate() when using 'episode-based':
x <- df \%>\% x <- df \%>\%
@ -102,7 +102,6 @@ if (require("dplyr")) {
identical(x, y) identical(x, y)
} }
if (require("dplyr")) { if (require("dplyr")) {
# but is_new_episode() has a lot more flexibility than first_isolate(), # but is_new_episode() has a lot more flexibility than first_isolate(),
# since you can now group on anything that seems relevant: # since you can now group on anything that seems relevant:
df \%>\% df \%>\%

10
man/ggplot_sir.Rd
View File

@ -138,13 +138,11 @@ At default, the names of antibiotics will be shown on the plots using \code{\lin
\examples{ \examples{
\donttest{ \donttest{
if (require("ggplot2") && require("dplyr")) { if (require("ggplot2") && require("dplyr")) {
# get antimicrobial results for drugs against a UTI: # get antimicrobial results for drugs against a UTI:
ggplot(example_isolates \%>\% select(AMX, NIT, FOS, TMP, CIP)) + ggplot(example_isolates \%>\% select(AMX, NIT, FOS, TMP, CIP)) +
geom_sir() geom_sir()
} }
if (require("ggplot2") && require("dplyr")) { if (require("ggplot2") && require("dplyr")) {
# prettify the plot using some additional functions: # prettify the plot using some additional functions:
df <- example_isolates \%>\% select(AMX, NIT, FOS, TMP, CIP) df <- example_isolates \%>\% select(AMX, NIT, FOS, TMP, CIP)
ggplot(df) + ggplot(df) +
@ -155,21 +153,18 @@ if (require("ggplot2") && require("dplyr")) {
theme_sir() theme_sir()
} }
if (require("ggplot2") && require("dplyr")) { if (require("ggplot2") && require("dplyr")) {
# or better yet, simplify this using the wrapper function - a single command: # or better yet, simplify this using the wrapper function - a single command:
example_isolates \%>\% example_isolates \%>\%
select(AMX, NIT, FOS, TMP, CIP) \%>\% select(AMX, NIT, FOS, TMP, CIP) \%>\%
ggplot_sir() ggplot_sir()
} }
if (require("ggplot2") && require("dplyr")) { if (require("ggplot2") && require("dplyr")) {
# get only proportions and no counts: # get only proportions and no counts:
example_isolates \%>\% example_isolates \%>\%
select(AMX, NIT, FOS, TMP, CIP) \%>\% select(AMX, NIT, FOS, TMP, CIP) \%>\%
ggplot_sir(datalabels = FALSE) ggplot_sir(datalabels = FALSE)
} }
if (require("ggplot2") && require("dplyr")) { if (require("ggplot2") && require("dplyr")) {
# add other ggplot2 arguments as you like: # add other ggplot2 arguments as you like:
example_isolates \%>\% example_isolates \%>\%
select(AMX, NIT, FOS, TMP, CIP) \%>\% select(AMX, NIT, FOS, TMP, CIP) \%>\%
@ -182,14 +177,12 @@ if (require("ggplot2") && require("dplyr")) {
) )
} }
if (require("ggplot2") && require("dplyr")) { if (require("ggplot2") && require("dplyr")) {
# you can alter the colours with colour names: # you can alter the colours with colour names:
example_isolates \%>\% example_isolates \%>\%
select(AMX) \%>\% select(AMX) \%>\%
ggplot_sir(colours = c(SI = "yellow")) ggplot_sir(colours = c(SI = "yellow"))
} }
if (require("ggplot2") && require("dplyr")) { if (require("ggplot2") && require("dplyr")) {
# but you can also use the built-in colour-blind friendly colours for # 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: # your plots, where "S" is green, "I" is yellow and "R" is red:
data.frame( data.frame(
@ -202,7 +195,6 @@ if (require("ggplot2") && require("dplyr")) {
scale_sir_colours(Value4 = "S", Value5 = "I", Value6 = "R") scale_sir_colours(Value4 = "S", Value5 = "I", Value6 = "R")
} }
if (require("ggplot2") && require("dplyr")) { if (require("ggplot2") && require("dplyr")) {
# resistance of ciprofloxacine per age group # resistance of ciprofloxacine per age group
example_isolates \%>\% example_isolates \%>\%
mutate(first_isolate = first_isolate()) \%>\% mutate(first_isolate = first_isolate()) \%>\%
@ -216,14 +208,12 @@ if (require("ggplot2") && require("dplyr")) {
ggplot_sir(x = "age_group") ggplot_sir(x = "age_group")
} }
if (require("ggplot2") && require("dplyr")) { if (require("ggplot2") && require("dplyr")) {
# a shorter version which also adjusts data label colours: # a shorter version which also adjusts data label colours:
example_isolates \%>\% example_isolates \%>\%
select(AMX, NIT, FOS, TMP, CIP) \%>\% select(AMX, NIT, FOS, TMP, CIP) \%>\%
ggplot_sir(colours = FALSE) ggplot_sir(colours = FALSE)
} }
if (require("ggplot2") && require("dplyr")) { if (require("ggplot2") && require("dplyr")) {
# it also supports groups (don't forget to use the group var on `x` or `facet`): # it also supports groups (don't forget to use the group var on `x` or `facet`):
example_isolates \%>\% example_isolates \%>\%
filter(mo_is_gram_negative(), ward != "Outpatient") \%>\% filter(mo_is_gram_negative(), ward != "Outpatient") \%>\%

1
man/mo_property.Rd
View File

@ -405,7 +405,6 @@ mo_species("EHEC")
mo_fullname("K. pneu rh") mo_fullname("K. pneu rh")
mo_shortname("K. pneu rh") mo_shortname("K. pneu rh")
\donttest{ \donttest{
# Becker classification, see ?as.mo ---------------------------------------- # Becker classification, see ?as.mo ----------------------------------------

1
man/proportion.Rd
View File

@ -204,7 +204,6 @@ if (require("dplyr")) {
) )
} }
if (require("dplyr")) { if (require("dplyr")) {
# scoped dplyr verbs with antibiotic selectors # scoped dplyr verbs with antibiotic selectors
# (you could also use across() of course) # (you could also use across() of course)
example_isolates \%>\% example_isolates \%>\%

2
tests/tinytest.R
View File

@ -34,7 +34,7 @@
# test only on GitHub Actions and at using RStudio jobs - not on CRAN as tests are lengthy # 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) || 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: # 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())) .libPaths(c(Sys.getenv("R_LIBS_USER_GH_ACTIONS"), .libPaths()))
if (AMR:::pkg_is_available("tinytest", also_load = TRUE)) { if (AMR:::pkg_is_available("tinytest", also_load = TRUE)) {

63
vignettes/AMR.Rmd
View File

@ -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: 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'} ```{r example table, echo = FALSE, results = 'asis'}
knitr::kable(data.frame( knitr::kable(
date = Sys.Date(), data.frame(
patient_id = c("abcd", "abcd", "efgh"), date = Sys.Date(),
mo = "Escherichia coli", patient_id = c("abcd", "abcd", "efgh"),
AMX = c("S", "S", "R"), mo = "Escherichia coli",
CIP = c("S", "R", "S"), AMX = c("S", "S", "R"),
stringsAsFactors = FALSE CIP = c("S", "R", "S"),
), stringsAsFactors = FALSE
align = "c" ),
align = "c"
) )
``` ```
@ -129,14 +130,15 @@ sample_size <- 20000
data <- data.frame( data <- data.frame(
date = sample(dates, size = sample_size, replace = TRUE), date = sample(dates, size = sample_size, replace = TRUE),
patient_id = sample(patients, size = sample_size, replace = TRUE), patient_id = sample(patients, size = sample_size, replace = TRUE),
hospital = sample(c( hospital = sample(
"Hospital A", c(
"Hospital B", "Hospital A",
"Hospital C", "Hospital B",
"Hospital D" "Hospital C",
), "Hospital D"
size = sample_size, replace = TRUE, ),
prob = c(0.30, 0.35, 0.15, 0.20) size = sample_size, replace = TRUE,
prob = c(0.30, 0.35, 0.15, 0.20)
), ),
bacteria = sample(bacteria, bacteria = sample(bacteria,
size = sample_size, replace = TRUE, size = sample_size, replace = TRUE,
@ -293,10 +295,11 @@ data_1st %>%
``` ```
```{r bug_drg 2b, echo = FALSE, results = 'asis'} ```{r bug_drg 2b, echo = FALSE, results = 'asis'}
knitr::kable(data_1st %>% knitr::kable(
filter(any(aminoglycosides() == "R")) %>% data_1st %>%
head(), filter(any(aminoglycosides() == "R")) %>%
align = "c" head(),
align = "c"
) )
``` ```
@ -309,10 +312,11 @@ data_1st %>%
``` ```
```{r bug_drg 1b, echo = FALSE, results = 'asis'} ```{r bug_drg 1b, echo = FALSE, results = 'asis'}
knitr::kable(data_1st %>% knitr::kable(
bug_drug_combinations() %>% data_1st %>%
head(), bug_drug_combinations() %>%
align = "c" head(),
align = "c"
) )
``` ```
@ -325,10 +329,11 @@ data_1st %>%
```{r bug_drg 3b, echo = FALSE, results = 'asis'} ```{r bug_drg 3b, echo = FALSE, results = 'asis'}
knitr::kable(data_1st %>% knitr::kable(
select(bacteria, aminoglycosides()) %>% data_1st %>%
bug_drug_combinations(), select(bacteria, aminoglycosides()) %>%
align = "c" bug_drug_combinations(),
align = "c"
) )
``` ```

13
vignettes/WHONET.Rmd
View File

@ -88,11 +88,12 @@ data %>%
```{r, echo = FALSE} ```{r, echo = FALSE}
# on very old and some new releases of R, this may lead to an error # on very old and some new releases of R, this may lead to an error
tryCatch(data %>% tryCatch(
group_by(Country) %>% data %>%
select(Country, AMP_ND2, AMC_ED20, CAZ_ED10, CIP_ED5) %>% group_by(Country) %>%
ggplot_sir(translate_ab = "ab", facet = "Country", datalabels = FALSE) %>% select(Country, AMP_ND2, AMC_ED20, CAZ_ED10, CIP_ED5) %>%
print(), ggplot_sir(translate_ab = "ab", facet = "Country", datalabels = FALSE) %>%
error = function(e) base::invisible() print(),
error = function(e) base::invisible()
) )
``` ```