P281424/AMR
1
0 Fork 0
mirror of https://github.com/msberends/AMR.git synced 2026-10-01 04:13:33 +02:00
Code Releases Activity

sort sir history

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends committed 2023-01-23 15:01:21 +01:00
1 parent af139a3c82
commit 19fd0ef121
49 files changed
+2605 -2480
Download Patch File Download Diff File Expand all files Collapse all files

No files matched your search

DESCRIPTION
+2 -2
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
NEWS.md
+1 -1
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!)*
R/aa_helper_functions.R
+91 -80
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, ...
) )
} }
R/ab.R
+36 -33
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
} }
R/ab_selectors.R
+43 -49
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
) )
} }
R/age.R
+6 -5
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),
R/av.R
+36 -32
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
} }
R/av_from_text.R
+1 -1
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()
R/av_property.R
+1 -1
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])) {
R/custom_eucast_rules.R
+6 -5
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))
R/custom_microorganisms.R
+43 -22
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 ----
R/disk.R
+7 -7
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
) )
} }
} }
R/episode.R
+6 -7
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 %>%
R/eucast_rules.R
+48 -40
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
) )
} }
) )
R/first_isolate.R
+39 -37
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
) )
} }
R/ggplot_pca.R
+8 -7
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)
R/ggplot_sir.R
-10
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") %>%
R/guess_ab_col.R
+21 -18
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
) )
} }
R/italicise_taxonomy.R
+31 -28
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
] ]
) )
R/mdro.R
+158 -154
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 == "")
R/mic.R
+7 -7
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
) )
} }
R/mo.R
+41 -33
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)
} }
R/mo_property.R
+17 -12
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
R/proportion.R
-1
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 %>%
R/resistance_predict.R
+1 -1
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,
R/sir.R
+30 -20
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 {
R/sysdata.rda
BIN
View File
Binary file not shown.
R/translate.R
+14 -13
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") {
R/zz_deprecated.R
+14 -9
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."
)
} }
} }
} }
R/zzz.R
+14 -8
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)
)
} }
} }
data-raw/_pre_commit_hook.R
+50 -47
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,
data-raw/create_survey_page.R
-1
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)
data-raw/read_EUCAST.R
+26 -23
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"
data-raw/reproduction_of_antibiotics.R
+38 -33
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_
) )
data-raw/reproduction_of_antivirals.R
+12 -10
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 %>%
data-raw/reproduction_of_microorganisms.R
+169 -122
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 -----------------------------------------------------------
data-raw/salmonellae.R
+1527 -1523
View File
File diff suppressed because it is too large. Load diff
man/add_custom_microorganisms.Rd
+12 -7
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"))
man/antibiotic_class_selectors.Rd
-12
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")
man/as.ab.Rd
-1
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")
man/as.sir.Rd
+1 -1
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}{
man/first_isolate.Rd
-2
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) \%>\%
man/get_episode.Rd
+6 -7
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 \%>\%
man/ggplot_sir.Rd
-10
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") \%>\%
man/mo_property.Rd
-1
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 ----------------------------------------
man/proportion.Rd
-1
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 \%>\%
tests/tinytest.R
+1 -1
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)) {
vignettes/AMR.Rmd
+34 -29
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"
) )
``` ```
vignettes/WHONET.Rmd
+7 -6
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()
) )
``` ```