P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2026-08-20 05:19:32 +02:00
Code Releases Activity

styled, unit test fix

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2022-08-28 10:31:50 +02:00
parent 4cb1db4554
commit 4d050aef7c
147 changed files with 10897 additions and 8169 deletions
Download Patch File Download Diff File Expand all files Collapse all files

11
.github/prehooks/pre-commit vendored
View File

@@ -5,13 +5,16 @@ echo "Running pre-commit hook..."
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
echo ">> Updating R documentation..."
if command -v Rscript > /dev/null; then
if [ "$(Rscript -e 'cat(all(c('"'pkgload'"', '"'devtools'"', '"'dplyr'"') %in% rownames(installed.packages())))')" = "TRUE" ]; then
Rscript -e "source('data-raw/pre-commit-hook.R')"
if [ "$(Rscript -e 'cat(all(c('"'pkgload'"', '"'devtools'"', '"'dplyr'"', '"'styler'"') %in% rownames(installed.packages())))')" = "TRUE" ]; then
Rscript -e "source('data-raw/_pre_commit_hook.R')"
currentpkg=`Rscript -e "cat(pkgload::pkg_name())"`
echo ">> Adding all files in folders 'data-raw', 'inst', 'man', and 'R' to this git commit"
git add data-raw/*
git add inst/*
git add man/*
git add R/sysdata.rda
git add R/*
else
echo ">> R package 'pkgload', 'devtools', or 'dplyr' not installed!"
echo ">> R package 'pkgload', 'devtools', 'dplyr', or 'styler' not installed!"
currentpkg="your"
fi
else

4
DESCRIPTION
View File

@@ -1,6 +1,6 @@
Package: AMR
Version: 1.8.1.9032
Date: 2022-08-27
Version: 1.8.1.9033
Date: 2022-08-28
Title: Antimicrobial Resistance Data Analysis
Description: Functions to simplify and standardise antimicrobial resistance (AMR)
data analysis and to work with microbial and antimicrobial properties by

3
NEWS.md
View File

@@ -1,4 +1,4 @@
# AMR 1.8.1.9032
# AMR 1.8.1.9033
### New
* EUCAST 2022 and CLSI 2022 guidelines have been added for `as.rsi()`. EUCAST 2022 is now the new default guideline for all MIC and disks diffusion interpretations.
@@ -25,6 +25,7 @@
* New website to make use of the new Bootstrap 5 and pkgdown v2.0. The website now contains results for all examples and will be automatically regenerated with every change to our repository, using GitHub Actions
* Added Peter Dutey-Magni and Anton Mymrikov as contributors, to thank them for their valuable input
* Set up Git Large File Storage (Git LFS) for the large SAS and SPSS file formats
* All R and Rmd files in this project are now styled using the `styler` package
# `AMR` 1.8.1

48
R/aa_globals.R
View File

@@ -24,34 +24,50 @@
# ==================================================================== #
# add new version numbers here, and add the rules themselves to "data-raw/eucast_rules.tsv" and rsi_translation
# (sourcing "data-raw/pre-commit-hook.R" will process the TSV file)
EUCAST_VERSION_BREAKPOINTS <- list("11.0" = list(version_txt = "v11.0",
# (sourcing "data-raw/_pre_commit_hook.R" will process the TSV file)
EUCAST_VERSION_BREAKPOINTS <- list(
"11.0" = list(
version_txt = "v11.0",
year = 2021,
title = "'EUCAST Clinical Breakpoint Tables'",
url = "https://www.eucast.org/clinical_breakpoints/"),
"10.0" = list(version_txt = "v10.0",
url = "https://www.eucast.org/clinical_breakpoints/"
),
"10.0" = list(
version_txt = "v10.0",
year = 2020,
title = "'EUCAST Clinical Breakpoint Tables'",
url = "https://www.eucast.org/ast_of_bacteria/previous_versions_of_documents/"))
EUCAST_VERSION_EXPERT_RULES <- list("3.1" = list(version_txt = "v3.1",
url = "https://www.eucast.org/ast_of_bacteria/previous_versions_of_documents/"
)
)
EUCAST_VERSION_EXPERT_RULES <- list(
"3.1" = list(
version_txt = "v3.1",
year = 2016,
title = "'EUCAST Expert Rules, Intrinsic Resistance and Exceptional Phenotypes'",
url = "https://www.eucast.org/expert_rules_and_expected_phenotypes/"),
"3.2" = list(version_txt = "v3.2",
url = "https://www.eucast.org/expert_rules_and_expected_phenotypes/"
),
"3.2" = list(
version_txt = "v3.2",
year = 2020,
title = "'EUCAST Expert Rules' and 'EUCAST Intrinsic Resistance and Unusual Phenotypes'",
url = "https://www.eucast.org/expert_rules_and_expected_phenotypes/"),
"3.3" = list(version_txt = "v3.3",
url = "https://www.eucast.org/expert_rules_and_expected_phenotypes/"
),
"3.3" = list(
version_txt = "v3.3",
year = 2021,
title = "'EUCAST Expert Rules' and 'EUCAST Intrinsic Resistance and Unusual Phenotypes'",
url = "https://www.eucast.org/expert_rules_and_expected_phenotypes/"))
url = "https://www.eucast.org/expert_rules_and_expected_phenotypes/"
)
)
SNOMED_VERSION <- list(title = "Public Health Information Network Vocabulary Access and Distribution System (PHIN VADS)",
SNOMED_VERSION <- list(
title = "Public Health Information Network Vocabulary Access and Distribution System (PHIN VADS)",
current_source = "US Edition of SNOMED CT from 1 September 2020",
current_version = 12,
current_oid = "2.16.840.1.114222.4.11.1009",
value_set_name = "Microorganism",
url = "https://phinvads.cdc.gov/vads/ViewValueSet.action?oid=2.16.840.1.114222.4.11.1009")
url = "https://phinvads.cdc.gov/vads/ViewValueSet.action?oid=2.16.840.1.114222.4.11.1009"
)
CATALOGUE_OF_LIFE <- list(
year = 2019,
@@ -61,7 +77,8 @@ CATALOGUE_OF_LIFE <- list(
yearmonth_LPSN = "5 October 2021"
)
globalVariables(c(".rowid",
globalVariables(c(
".rowid",
"ab",
"ab_txt",
"affect_ab_name",
@@ -130,4 +147,5 @@ globalVariables(c(".rowid",
"xvar",
"y",
"year",
"yvar"))
"yvar"
))

412
R/aa_helper_functions.R
View File

@@ -43,11 +43,16 @@ pm_left_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
colnames(x)[int_x] <- paste0(colnames(x)[int_x], suffix[1L])
colnames(y)[int_y] <- paste0(colnames(y)[int_y], suffix[2L])
merged <- cbind(x,
y[match(x[, by[1], drop = TRUE],
y[, by[2], drop = TRUE]),
merged <- cbind(
x,
y[match(
x[, by[1], drop = TRUE],
y[, by[2], drop = TRUE]
),
colnames(y)[!colnames(y) %in% colnames(x) & !colnames(y) == by[2]],
drop = FALSE])
drop = FALSE
]
)
rownames(merged) <- NULL
merged
@@ -73,24 +78,30 @@ where <- function(fn) {
}
# copied and slightly rewritten from poorman under same license (2021-10-15)
quick_case_when <- function (...) {
quick_case_when <- function(...) {
fs <- list(...)
lapply(fs, function(x) if (class(x) != "formula")
stop("`case_when()` requires formula inputs."))
lapply(fs, function(x) {
if (class(x) != "formula") {
stop("`case_when()` requires formula inputs.")
}
})
n <- length(fs)
if (n == 0L)
if (n == 0L) {
stop("No cases provided.")
}
validate_case_when_length <- function (query, value, fs) {
validate_case_when_length <- function(query, value, fs) {
lhs_lengths <- lengths(query)
rhs_lengths <- lengths(value)
all_lengths <- unique(c(lhs_lengths, rhs_lengths))
if (length(all_lengths) <= 1L)
if (length(all_lengths) <= 1L) {
return(all_lengths[[1L]])
}
non_atomic_lengths <- all_lengths[all_lengths != 1L]
len <- non_atomic_lengths[[1L]]
if (length(non_atomic_lengths) == 1L)
if (length(non_atomic_lengths) == 1L) {
return(len)
}
inconsistent_lengths <- non_atomic_lengths[-1L]
lhs_problems <- lhs_lengths %in% inconsistent_lengths
rhs_problems <- rhs_lengths %in% inconsistent_lengths
@@ -99,18 +110,19 @@ quick_case_when <- function (...) {
stop("The following formulas must be length ", len, " or 1, not ",
paste(inconsistent_lengths, collapse = ", "), ".\n ",
paste(fs[problems], collapse = "\n "),
call. = FALSE)
call. = FALSE
)
}
}
replace_with <- function (x, i, val, arg_name) {
if (is.null(val))
replace_with <- function(x, i, val, arg_name) {
if (is.null(val)) {
return(x)
}
i[is.na(i)] <- FALSE
if (length(val) == 1L) {
x[i] <- val
}
else {
} else {
x[i] <- val[i]
}
x
@@ -122,15 +134,18 @@ quick_case_when <- function (...) {
for (i in seq_len(n)) {
query[[i]] <- eval(fs[[i]][[2]], envir = default_env)
value[[i]] <- eval(fs[[i]][[3]], envir = default_env)
if (!is.logical(query[[i]]))
if (!is.logical(query[[i]])) {
stop(fs[[i]][[2]], " does not return a `logical` vector.")
}
}
m <- validate_case_when_length(query, value, fs)
out <- value[[1]][rep(NA_integer_, m)]
replaced <- rep(FALSE, m)
for (i in seq_len(n)) {
out <- replace_with(out, query[[i]] & !replaced, value[[i]],
NULL)
out <- replace_with(
out, query[[i]] & !replaced, value[[i]],
NULL
)
replaced <- replaced | (query[[i]] & !is.na(query[[i]]))
}
out
@@ -162,17 +177,22 @@ addin_insert_like <- function() {
pos_preceded_by <- function(txt) {
if (tryCatch(substr(current_row_txt, current_col - nchar(trimws(txt, which = "right")), current_col) == trimws(txt, which = "right"),
error = function(e) FALSE)) {
error = function(e) FALSE
)) {
return(TRUE)
}
tryCatch(substr(current_row_txt, current_col - nchar(txt), current_col) %like% paste0("^", txt),
error = function(e) FALSE)
error = function(e) FALSE
)
}
replace_pos <- function(old, with) {
modifyRange(document_range(document_position(current_row, current_col - nchar(old)),
document_position(current_row, current_col)),
modifyRange(document_range(
document_position(current_row, current_col - nchar(old)),
document_position(current_row, current_col)
),
text = with,
id = context$id)
id = context$id
)
}
if (pos_preceded_by(" %like% ")) {
@@ -202,33 +222,46 @@ check_dataset_integrity <- function() {
plural <- c(" is", "s", "")
}
if (message_not_thrown_before("check_dataset_integrity", overwritten)) {
warning_("The following data set", plural[1],
warning_(
"The following data set", plural[1],
" overwritten by your global environment and prevent", plural[2],
" the AMR package from working correctly: ",
vector_and(overwritten, quotes = "'"),
".\nPlease rename your object", plural[3], ".")
".\nPlease rename your object", plural[3], "."
)
}
}
# check if other packages did not overwrite our data sets
valid_microorganisms <- TRUE
valid_antibiotics <- TRUE
tryCatch({
valid_microorganisms <- all(c("mo", "fullname", "kingdom", "phylum",
tryCatch(
{
valid_microorganisms <- all(c(
"mo", "fullname", "kingdom", "phylum",
"class", "order", "family", "genus",
"species", "subspecies", "rank",
"species_id", "source", "ref", "prevalence") %in% colnames(microorganisms),
na.rm = TRUE)
valid_antibiotics <- all(c("ab", "atc", "cid", "name", "group",
"species_id", "source", "ref", "prevalence"
) %in% colnames(microorganisms),
na.rm = TRUE
)
valid_antibiotics <- all(c(
"ab", "atc", "cid", "name", "group",
"atc_group1", "atc_group2", "abbreviations",
"synonyms", "oral_ddd", "oral_units",
"iv_ddd", "iv_units", "loinc") %in% colnames(antibiotics),
na.rm = TRUE)
}, error = function(e) {
"iv_ddd", "iv_units", "loinc"
) %in% colnames(antibiotics),
na.rm = TRUE
)
},
error = function(e) {
# package not yet loaded
require("AMR")
})
stop_if(!valid_microorganisms | !valid_antibiotics,
"the data set `microorganisms` or `antibiotics` was overwritten in your environment because another package with the same object name(s) was loaded _after_ the AMR package, preventing the AMR package from working correctly. Please load the AMR package last.")
}
)
stop_if(
!valid_microorganisms | !valid_antibiotics,
"the data set `microorganisms` or `antibiotics` was overwritten in your environment because another package with the same object name(s) was loaded _after_ the AMR package, preventing the AMR package from working correctly. Please load the AMR package last."
)
invisible(TRUE)
}
@@ -258,7 +291,6 @@ search_type_in_df <- function(x, type, info = TRUE) {
} else if (any(colnames_formatted %like_case% "species")) {
found <- sort(colnames(x)[colnames_formatted %like_case% "species"])
}
}
# -- key antibiotics
if (type %in% c("keyantibiotics", "keyantimicrobials")) {
@@ -272,11 +304,13 @@ search_type_in_df <- function(x, type, info = TRUE) {
# WHONET support
found <- sort(colnames(x)[colnames_formatted %like_case% "^(specimen date|specimen_date|spec_date)"])
if (!any(class(pm_pull(x, found)) %in% c("Date", "POSIXct"))) {
stop(font_red(paste0("Found column '", font_bold(found), "' to be used as input for `col_", type,
"`, but this column contains no valid dates. Transform its values to valid dates first.")),
call. = FALSE)
stop(font_red(paste0(
"Found column '", font_bold(found), "' to be used as input for `col_", type,
"`, but this column contains no valid dates. Transform its values to valid dates first."
)),
call. = FALSE
)
}
} else if (any(vapply(FUN.VALUE = logical(1), x, function(x) inherits(x, c("Date", "POSIXct"))))) {
# take first <Date> column
found <- colnames(x)[vapply(FUN.VALUE = logical(1), x, function(x) inherits(x, c("Date", "POSIXct")))]
@@ -314,7 +348,8 @@ search_type_in_df <- function(x, type, info = TRUE) {
if (!is.logical(x[, found, drop = TRUE])) {
message_("Column '", font_bold(found), "' found as input for `col_", type,
"`, but this column does not contain 'logical' values (TRUE/FALSE) and was ignored.",
add_fn = font_red)
add_fn = font_red
)
found <- NULL
}
}
@@ -335,26 +370,39 @@ search_type_in_df <- function(x, type, info = TRUE) {
}
is_valid_regex <- function(x) {
regex_at_all <- tryCatch(vapply(FUN.VALUE = logical(1),
regex_at_all <- tryCatch(vapply(
FUN.VALUE = logical(1),
X = strsplit(x, ""),
FUN = function(y) any(y %in% c("$", "(", ")", "*", "+", "-",
FUN = function(y) {
any(y %in% c(
"$", "(", ")", "*", "+", "-",
".", "?", "[", "]", "^", "{",
"|", "}", "\\"),
na.rm = TRUE),
USE.NAMES = FALSE),
error = function(e) rep(TRUE, length(x)))
regex_valid <- vapply(FUN.VALUE = logical(1),
"|", "}", "\\"
),
na.rm = TRUE
)
},
USE.NAMES = FALSE
),
error = function(e) rep(TRUE, length(x))
)
regex_valid <- vapply(
FUN.VALUE = logical(1),
X = x,
FUN = function(y) !"try-error" %in% class(try(grepl(y, "", perl = TRUE),
silent = TRUE)),
USE.NAMES = FALSE)
FUN = function(y) {
!"try-error" %in% class(try(grepl(y, "", perl = TRUE),
silent = TRUE
))
},
USE.NAMES = FALSE
)
regex_at_all & regex_valid
}
stop_ifnot_installed <- function(package) {
# no "utils::installed.packages()" since it requires non-staged install since R 3.6.0
# https://developer.r-project.org/Blog/public/2019/02/14/staged-install/index.html
vapply(FUN.VALUE = character(1), package, function(pkg)
vapply(FUN.VALUE = character(1), package, function(pkg) {
tryCatch(get(".packageName", envir = asNamespace(pkg)),
error = function(e) {
if (pkg == "rstudioapi") {
@@ -362,9 +410,12 @@ stop_ifnot_installed <- function(package) {
} else if (pkg != "base") {
stop("This requires the '", pkg, "' package.",
"\nTry to install it with: install.packages(\"", pkg, "\")",
call. = FALSE)
call. = FALSE
)
}
}))
}
)
})
return(invisible())
}
@@ -391,11 +442,13 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) {
if (isTRUE(error_on_fail)) {
stop_("function ", name, "() is not an exported object from package '", pkg,
"'. Please create an issue at https://github.com/msberends/AMR/issues. Many thanks!",
call = FALSE)
call = FALSE
)
} else {
return(NULL)
}
})
}
)
}
# this alternative wrapper to the message(), warning() and stop() functions:
@@ -416,14 +469,17 @@ word_wrap <- function(...,
if (msg %like% "\n") {
# run word_wraps() over every line here, bind them and return again
return(paste0(vapply(FUN.VALUE = character(1),
return(paste0(vapply(
FUN.VALUE = character(1),
trimws(unlist(strsplit(msg, "\n")), which = "right"),
word_wrap,
add_fn = add_fn,
as_note = FALSE,
width = width,
extra_indent = extra_indent),
collapse = "\n"))
extra_indent = extra_indent
),
collapse = "\n"
))
}
# correct for operators (will add the space later on)
@@ -434,10 +490,13 @@ word_wrap <- function(...,
# where are the spaces now?
msg_stripped_wrapped <- paste0(strwrap(msg_stripped,
simplify = TRUE,
width = width),
collapse = "\n")
width = width
),
collapse = "\n"
)
msg_stripped_wrapped <- paste0(unlist(strsplit(msg_stripped_wrapped, "(\n|\\*\\|\\*)")),
collapse = "\n")
collapse = "\n"
)
msg_stripped_spaces <- which(unlist(strsplit(msg_stripped, "")) == " ")
msg_stripped_wrapped_spaces <- which(unlist(strsplit(msg_stripped_wrapped, "")) != "\n")
# so these are the indices of spaces that need to be replaced
@@ -485,8 +544,10 @@ message_ <- function(...,
as_note = TRUE) {
message(word_wrap(...,
add_fn = add_fn,
as_note = as_note),
appendLF = appendLF)
as_note = as_note
),
appendLF = appendLF
)
}
warning_ <- function(...,
@@ -495,9 +556,11 @@ warning_ <- function(...,
call = FALSE) {
warning(word_wrap(...,
add_fn = add_fn,
as_note = FALSE),
as_note = FALSE
),
immediate. = immediate,
call. = call)
call. = call
)
}
# this alternative to the stop() function:
@@ -554,7 +617,8 @@ stop_ifnot <- function(expr, ..., call = TRUE) {
}
ifelse(!is.na(x),
x,
ifelse(!is.na(y), y, NA))
ifelse(!is.na(y), y, NA)
)
}
return_after_integrity_check <- function(value, type, check_vector) {
@@ -596,7 +660,7 @@ create_eucast_ab_documentation <- function() {
ab <- character()
for (val in x) {
if (paste0("AB_", val) %in% ls(envir = asNamespace("AMR"))) {
# antibiotic group names, as defined in data-raw/pre-commit-hook.R, such as `CARBAPENEMS`
# antibiotic group names, as defined in data-raw/_pre_commit_hook.R, such as `CARBAPENEMS`
val <- eval(parse(text = paste0("AB_", val)), envir = asNamespace("AMR"))
} else if (val %in% AB_lookup$ab) {
# separate drugs, such as `AMX`
@@ -646,13 +710,17 @@ vector_or <- function(v, quotes = TRUE, reverse = FALSE, sort = TRUE, initial_ca
v <- c("R", "S", "I")
}
# all commas except for last item, so will become '"val1", "val2", "val3" or "val4"'
paste0(paste0(quotes, v[seq_len(length(v) - 1)], quotes, collapse = ", "),
last_sep, paste0(quotes, v[length(v)], quotes))
paste0(
paste0(quotes, v[seq_len(length(v) - 1)], quotes, collapse = ", "),
last_sep, paste0(quotes, v[length(v)], quotes)
)
}
vector_and <- function(v, quotes = TRUE, reverse = FALSE, sort = TRUE, initial_captital = FALSE) {
vector_or(v = v, quotes = quotes, reverse = reverse, sort = sort,
initial_captital = initial_captital, last_sep = " and ")
vector_or(
v = v, quotes = quotes, reverse = reverse, sort = sort,
initial_captital = initial_captital, last_sep = " and "
)
}
format_class <- function(class, plural = FALSE) {
@@ -664,9 +732,11 @@ format_class <- function(class, plural = FALSE) {
}
class[class == "character"] <- "text string"
class[class %in% c("Date", "POSIXt")] <- "date"
class[class != class.bak] <- paste0(ifelse(plural, "", "a "),
class[class != class.bak] <- paste0(
ifelse(plural, "", "a "),
class[class != class.bak],
ifelse(plural, "s", ""))
ifelse(plural, "s", "")
)
# exceptions
class[class == "logical"] <- ifelse(plural, "a vector of `TRUE`/`FALSE`", "`TRUE` or `FALSE`")
class[class == "data.frame"] <- "a data set"
@@ -707,7 +777,8 @@ meet_criteria <- function(object,
# if object is missing, or another error:
tryCatch(invisible(object),
error = function(e) pkg_env$meet_criteria_error_txt <- e$message)
error = function(e) pkg_env$meet_criteria_error_txt <- e$message
)
if (!is.null(pkg_env$meet_criteria_error_txt)) {
error_txt <- pkg_env$meet_criteria_error_txt
pkg_env$meet_criteria_error_txt <- NULL
@@ -728,14 +799,16 @@ meet_criteria <- function(object,
stop_ifnot(inherits(object, allow_class), "argument `", obj_name,
"` must be ", format_class(allow_class, plural = isTRUE(has_length > 1)),
", i.e. not be ", format_class(class(object), plural = isTRUE(has_length > 1)),
call = call_depth)
call = call_depth
)
# check data.frames for data
if (inherits(object, "data.frame")) {
stop_if(any(dim(object) == 0),
"the data provided in argument `", obj_name,
"` must contain rows and columns (current dimensions: ",
paste(dim(object), collapse = "x"), ")",
call = call_depth)
call = call_depth
)
}
}
if (!is.null(has_length)) {
@@ -743,13 +816,15 @@ meet_criteria <- function(object,
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
"be of length ", vector_or(has_length, quotes = FALSE),
", not ", length(object),
call = call_depth)
call = call_depth
)
}
if (!is.null(looks_like)) {
stop_ifnot(object %like% looks_like, "argument `", obj_name,
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
"resemble the regular expression \"", looks_like, "\"",
call = call_depth)
call = call_depth
)
}
if (!is.null(is_in)) {
if (ignore.case == TRUE) {
@@ -759,46 +834,57 @@ meet_criteria <- function(object,
stop_ifnot(all(object %in% is_in, na.rm = TRUE), "argument `", obj_name, "` ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"must be either ",
"must only contain values "),
"must only contain values "
),
vector_or(is_in, quotes = !isTRUE(any(c("double", "numeric", "integer") %in% allow_class))),
ifelse(allow_NA == TRUE, ", or NA", ""),
call = call_depth)
call = call_depth
)
}
if (isTRUE(is_positive)) {
stop_if(is.numeric(object) && !all(object > 0, na.rm = TRUE), "argument `", obj_name,
"` must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"be a number higher than zero",
"all be numbers higher than zero"),
call = call_depth)
"all be numbers higher than zero"
),
call = call_depth
)
}
if (isTRUE(is_positive_or_zero)) {
stop_if(is.numeric(object) && !all(object >= 0, na.rm = TRUE), "argument `", obj_name,
"` must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"be zero or a positive number",
"all be zero or numbers higher than zero"),
call = call_depth)
"all be zero or numbers higher than zero"
),
call = call_depth
)
}
if (isTRUE(is_finite)) {
stop_if(is.numeric(object) && !all(is.finite(object[!is.na(object)]), na.rm = TRUE), "argument `", obj_name,
"` must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"be a finite number",
"all be finite numbers"),
"all be finite numbers"
),
" (i.e. not be infinite)",
call = call_depth)
call = call_depth
)
}
if (!is.null(contains_column_class)) {
stop_ifnot(any(vapply(FUN.VALUE = logical(1),
stop_ifnot(any(vapply(
FUN.VALUE = logical(1),
object,
function(col, columns_class = contains_column_class) {
inherits(col, columns_class)
}), na.rm = TRUE),
}
), na.rm = TRUE),
"the data provided in argument `", obj_name,
"` must contain at least one column of class <", contains_column_class, ">. ",
"See ?as.", contains_column_class, ".",
call = call_depth)
call = call_depth
)
}
return(invisible())
}
@@ -827,11 +913,9 @@ get_current_data <- function(arg_name, call) {
# an element `.data` will be in the environment when using `dplyr::select()`
# (but not when using `dplyr::filter()`, `dplyr::mutate()` or `dplyr::summarise()`)
return(env$`.data`)
} else if (valid_df(env$xx)) {
# an element `xx` will be in the environment for rows + cols, e.g. `example_isolates[c(1:3), carbapenems()]`
return(env$xx)
} else if (valid_df(env$x)) {
# an element `x` will be in the environment for only cols, e.g. `example_isolates[, carbapenems()]`
return(env$x)
@@ -843,17 +927,20 @@ get_current_data <- function(arg_name, call) {
if (is.na(arg_name)) {
if (isTRUE(is.numeric(call))) {
fn <- as.character(sys.call(call + 1)[1])
examples <- paste0(", e.g.:\n",
examples <- paste0(
", e.g.:\n",
" your_data %>% select(", fn, "())\n",
" your_data %>% select(column_a, column_b, ", fn, "())\n",
" your_data[, ", fn, "()]\n",
' your_data[, c("column_a", "column_b", ', fn, "())]")
' your_data[, c("column_a", "column_b", ', fn, "())]"
)
} else {
examples <- ""
}
stop_("this function must be used inside a `dplyr` verb or `data.frame` call",
examples,
call = call)
call = call
)
} else {
# mimic a base R error that the argument is missing
stop_("argument `", arg_name, "` is missing with no default", call = call)
@@ -917,13 +1004,17 @@ unique_call_id <- function(entire_session = FALSE, match_fn = NULL) {
for (i in seq_len(length(calls))) {
call_clean <- gsub("[^a-zA-Z0-9_().-]", "", as.character(calls[[i]]), perl = TRUE)
if (any(call_clean %like% paste0(match_fn, "\\("), na.rm = TRUE)) {
return(c(envir = gsub("<environment: (.*)>", "\\1", utils::capture.output(sys.frames()[[1]]), perl = TRUE),
call = paste0(deparse(calls[[i]]), collapse = "")))
return(c(
envir = gsub("<environment: (.*)>", "\\1", utils::capture.output(sys.frames()[[1]]), perl = TRUE),
call = paste0(deparse(calls[[i]]), collapse = "")
))
}
}
}
c(envir = paste0(sample(c(c(0:9), letters[1:6]), size = 32, replace = TRUE), collapse = ""),
call = paste0(sample(c(c(0:9), letters[1:6]), size = 32, replace = TRUE), collapse = ""))
c(
envir = paste0(sample(c(c(0:9), letters[1:6]), size = 32, replace = TRUE), collapse = ""),
call = paste0(sample(c(c(0:9), letters[1:6]), size = 32, replace = TRUE), collapse = "")
)
}
#' @noRd
@@ -935,14 +1026,20 @@ message_not_thrown_before <- function(fn, ..., entire_session = FALSE) {
# e.g. this would show a msg 4 times: example_isolates %>% group_by(ward) %>% filter(mo_is_gram_negative())
salt <- gsub("[^a-zA-Z0-9|_-]", "?", paste(c(...), sep = "|", collapse = "|"), perl = TRUE)
not_thrown_before <- is.null(pkg_env[[paste0("thrown_msg.", fn, ".", salt)]]) ||
!identical(pkg_env[[paste0("thrown_msg.", fn, ".", salt)]],
unique_call_id(entire_session = entire_session,
match_fn = fn))
!identical(
pkg_env[[paste0("thrown_msg.", fn, ".", salt)]],
unique_call_id(
entire_session = entire_session,
match_fn = fn
)
)
if (isTRUE(not_thrown_before)) {
# message was not thrown before - remember this so on the next run it will return FALSE:
assign(x = paste0("thrown_msg.", fn, ".", salt),
assign(
x = paste0("thrown_msg.", fn, ".", salt),
value = unique_call_id(entire_session = entire_session, match_fn = fn),
envir = pkg_env)
envir = pkg_env
)
}
not_thrown_before
}
@@ -965,8 +1062,12 @@ has_colour <- function() {
if ((cols <- Sys.getenv("RSTUDIO_CONSOLE_COLOR", "")) != "" && !is.na(as.double(cols))) {
return(TRUE)
}
tryCatch(get("isAvailable", envir = asNamespace("rstudioapi"))(), error = function(e) return(FALSE)) &&
tryCatch(get("hasFun", envir = asNamespace("rstudioapi"))("getConsoleHasColor"), error = function(e) return(FALSE))
tryCatch(get("isAvailable", envir = asNamespace("rstudioapi"))(), error = function(e) {
return(FALSE)
}) &&
tryCatch(get("hasFun", envir = asNamespace("rstudioapi"))("getConsoleHasColor"), error = function(e) {
return(FALSE)
})
}
if (rstudio_with_ansi_support() && sink.number() == 0) {
return(TRUE)
@@ -989,10 +1090,12 @@ has_colour <- function() {
if (Sys.getenv("TERM") == "dumb") {
return(FALSE)
}
grepl(pattern = "^screen|^xterm|^vt100|color|ansi|cygwin|linux",
grepl(
pattern = "^screen|^xterm|^vt100|color|ansi|cygwin|linux",
x = Sys.getenv("TERM"),
ignore.case = TRUE,
perl = TRUE)
perl = TRUE
)
}
# set colours if console has_colour()
@@ -1051,15 +1154,15 @@ font_green_bg <- function(..., collapse = " ") {
try_colour(..., before = "\033[42m", after = "\033[49m", collapse = collapse)
}
font_rsi_R_bg <- function(..., collapse = " ") {
#ED553B
# ED553B
try_colour(..., before = "\033[48;5;203m", after = "\033[49m", collapse = collapse)
}
font_rsi_S_bg <- function(..., collapse = " ") {
#3CAEA3
# 3CAEA3
try_colour(..., before = "\033[48;5;79m", after = "\033[49m", collapse = collapse)
}
font_rsi_I_bg <- function(..., collapse = " ") {
#F6D55C
# F6D55C
try_colour(..., before = "\033[48;5;222m", after = "\033[49m", collapse = collapse)
}
font_red_bg <- function(..., collapse = " ") {
@@ -1101,8 +1204,10 @@ progress_ticker <- function(n = 1, n_min = 0, print = TRUE, ...) {
if (!is.null(progress_bar)) {
# so we use progress::progress_bar
# a close() method was also added, see below this function
pb <- progress_bar$new(format = "[:bar] :percent (:current/:total)",
total = n)
pb <- progress_bar$new(
format = "[:bar] :percent (:current/:total)",
total = n
)
} else {
pb <- utils::txtProgressBar(max = n, style = 3)
pb$tick <- function() {
@@ -1180,16 +1285,14 @@ s3_register <- function(generic, class, method = NULL) {
top <- topenv(caller)
if (isNamespace(top)) {
asNamespace(environmentName(top))
}
else {
} else {
caller
}
}
get_method <- function(method, env) {
if (is.null(method)) {
get(paste0(generic, ".", class), envir = get_method_env())
}
else {
} else {
method
}
}
@@ -1215,19 +1318,30 @@ s3_register <- function(generic, class, method = NULL) {
round2 <- function(x, digits = 1, force_zero = TRUE) {
x <- as.double(x)
# https://stackoverflow.com/a/12688836/4575331
val <- (trunc((abs(x) * 10 ^ digits) + 0.5) / 10 ^ digits) * sign(x)
val <- (trunc((abs(x) * 10^digits) + 0.5) / 10^digits) * sign(x)
if (digits > 0 & force_zero == TRUE) {
values_trans <- val[val != as.integer(val) & !is.na(val)]
val[val != as.integer(val) & !is.na(val)] <- paste0(values_trans,
strrep("0",
max(0,
val[val != as.integer(val) & !is.na(val)] <- paste0(
values_trans,
strrep(
"0",
max(
0,
digits - nchar(
format(
as.double(
gsub(".*[.](.*)$",
gsub(
".*[.](.*)$",
"\\1",
values_trans)),
scientific = FALSE)))))
values_trans
)
),
scientific = FALSE
)
)
)
)
)
}
as.double(val)
}
@@ -1244,12 +1358,20 @@ percentage <- function(x, digits = NULL, ...) {
if (minimum > maximum) {
minimum <- maximum
}
max_places <- max(unlist(lapply(strsplit(sub("0+$", "",
as.character(x * 100)), ".", fixed = TRUE),
function(y) ifelse(length(y) == 2, nchar(y[2]), 0))), na.rm = TRUE)
max_places <- max(unlist(lapply(
strsplit(sub(
"0+$", "",
as.character(x * 100)
), ".", fixed = TRUE),
function(y) ifelse(length(y) == 2, nchar(y[2]), 0)
)), na.rm = TRUE)
max(min(max_places,
maximum, na.rm = TRUE),
minimum, na.rm = TRUE)
maximum,
na.rm = TRUE
),
minimum,
na.rm = TRUE
)
}
# format_percentage() function
@@ -1266,7 +1388,8 @@ percentage <- function(x, digits = NULL, ...) {
scientific = FALSE,
digits = max(1, digits),
nsmall = digits,
...)
...
)
x_formatted <- paste0(x_formatted, "%")
x_formatted[!grepl(pattern = "^[0-9.,e-]+$", x = x)] <- NA_character_
x_formatted
@@ -1278,9 +1401,12 @@ percentage <- function(x, digits = NULL, ...) {
# max one digit if undefined
digits <- getdecimalplaces(x, minimum = 0, maximum = 1)
}
format_percentage(structure(.Data = as.double(x),
class = c("percentage", "numeric")),
digits = digits, ...)
format_percentage(structure(
.Data = as.double(x),
class = c("percentage", "numeric")
),
digits = digits, ...
)
}
time_start_tracking <- function() {
@@ -1296,13 +1422,16 @@ time_track <- function(name = NULL) {
# see here for the full list: https://github.com/r-lib/backports
strrep <- function(x, times) {
x <- as.character(x)
if (length(x) == 0L)
if (length(x) == 0L) {
return(x)
}
unlist(.mapply(function(x, times) {
if (is.na(x) || is.na(times))
if (is.na(x) || is.na(times)) {
return(NA_character_)
if (times <= 0L)
}
if (times <= 0L) {
return("")
}
paste0(replicate(times, x), collapse = "")
}, list(x = x, times = times), MoreArgs = list()), use.names = FALSE)
}
@@ -1312,7 +1441,8 @@ trimws <- function(x, which = c("both", "left", "right"), whitespace = "[ \t\r\n
switch(which,
left = mysub(paste0("^", whitespace, "+"), x),
right = mysub(paste0(whitespace, "+$"), x),
both = mysub(paste0(whitespace, "+$"), mysub(paste0("^", whitespace, "+"), x)))
both = mysub(paste0(whitespace, "+$"), mysub(paste0("^", whitespace, "+"), x))
)
}
isFALSE <- function(x) {
is.logical(x) && length(x) == 1L && !is.na(x) && !x
@@ -1346,7 +1476,7 @@ if (getRversion() < "3.1") {
sinpi <- function(...) 1
tanpi <- function(...) 1
}
dir.exists <- function (paths) {
x = base::file.info(paths)$isdir
dir.exists <- function(paths) {
x <- base::file.info(paths)$isdir
!is.na(x) & x
}

73
R/aa_helper_pm_functions.R
View File

@@ -206,7 +206,9 @@ pm_distinct <- function(.data, ...) {
}
pm_distinct.default <- function(.data, ..., .keep_all = FALSE) {
if (ncol(.data) == 0L) return(.data[1, ])
if (ncol(.data) == 0L) {
return(.data[1, ])
}
cols <- pm_deparse_dots(...)
col_names <- names(cols)
col_len <- length(cols)
@@ -336,7 +338,9 @@ pm_print.grouped_data <- function(x, ..., digits = NULL, quote = FALSE, right =
}
pm_group_data <- function(.data) {
if (!pm_has_groups(.data)) return(data.frame(.rows = I(list(seq_len(nrow(.data))))))
if (!pm_has_groups(.data)) {
return(data.frame(.rows = I(list(seq_len(nrow(.data))))))
}
pm_groups <- pm_get_groups(.data)
pm_group_data_worker(.data, pm_groups)
}
@@ -360,7 +364,9 @@ pm_group_rows <- function(.data) {
}
pm_group_indices <- function(.data) {
if (!pm_has_groups(.data)) return(rep(1L, nrow(.data)))
if (!pm_has_groups(.data)) {
return(rep(1L, nrow(.data)))
}
pm_groups <- pm_get_groups(.data)
res <- unique(.data[, pm_groups, drop = FALSE])
res <- res[do.call(order, lapply(pm_groups, function(x) res[, x])), , drop = FALSE]
@@ -417,7 +423,9 @@ pm_group_keys <- function(.data) {
pm_context$setup(.data)
res <- pm_context$.data[, pm_context$get_colnames() %in% pm_groups, drop = FALSE]
res <- res[!duplicated(res), , drop = FALSE]
if (nrow(res) == 0L) return(res)
if (nrow(res) == 0L) {
return(res)
}
class(res) <- "data.frame"
res <- res[do.call(order, lapply(pm_groups, function(x) res[, x])), , drop = FALSE]
rownames(res) <- NULL
@@ -509,7 +517,9 @@ pm_join_message <- function(by) {
pm_lag <- function(x, pm_n = 1L, default = NA) {
if (inherits(x, "ts")) stop("`x` must be a vector, not a `ts` object, do you want `stats::pm_lag()`?")
if (length(pm_n) != 1L || !is.numeric(pm_n) || pm_n < 0L) stop("`pm_n` must be a nonnegative integer scalar")
if (pm_n == 0L) return(x)
if (pm_n == 0L) {
return(x)
}
tryCatch(
storage.mode(default) <- typeof(x),
warning = function(w) {
@@ -525,7 +535,9 @@ pm_lag <- function(x, pm_n = 1L, default = NA) {
pm_lead <- function(x, pm_n = 1L, default = NA) {
if (length(pm_n) != 1L || !is.numeric(pm_n) || pm_n < 0L) stop("pm_n must be a nonnegative integer scalar")
if (pm_n == 0L) return(x)
if (pm_n == 0L) {
return(x)
}
tryCatch(
storage.mode(default) <- typeof(x),
warning = function(w) {
@@ -565,7 +577,9 @@ pm_mutate.grouped_data <- function(.data, ...) {
}
pm_n_distinct <- function(..., na.rm = FALSE) {
res <- c(...)
if (is.list(res)) return(nrow(unique(as.data.frame(res, stringsAsFactors = FALSE))))
if (is.list(res)) {
return(nrow(unique(as.data.frame(res, stringsAsFactors = FALSE))))
}
if (isTRUE(na.rm)) res <- res[!is.na(res)]
length(unique(res))
}
@@ -593,7 +607,7 @@ pm_pull <- function(.data, var = -1) {
} else if (var_deparse %in% col_names) {
var <- var_deparse
}
.data[, var]
.data[, var, drop = TRUE]
}
pm_set_names <- function(object = nm, nm) {
names(object) <- nm
@@ -669,15 +683,16 @@ pm_rename_with <- function(.data, .fn, .cols = pm_everything(), ...) {
.data
}
pm_replace_with <- function(x, i, val, arg_name) {
if (is.null(val)) return(x)
if (is.null(val)) {
return(x)
}
pm_check_length(val, x, arg_name)
pm_check_type(val, x, arg_name)
pm_check_class(val, x, arg_name)
i[is.na(i)] <- FALSE
if (length(val) == 1L) {
x[i] <- val
}
else {
} else {
x[i] <- val[i]
}
x
@@ -686,7 +701,9 @@ pm_replace_with <- function(x, i, val, arg_name) {
pm_check_length <- function(x, y, arg_name) {
length_x <- length(x)
length_y <- length(y)
if (all(length_x %in% c(1L, length_y))) return()
if (all(length_x %in% c(1L, length_y))) {
return()
}
if (length_y == 1) {
stop(arg_name, " must be length 1, not ", paste(length_x, sep = ", "))
} else {
@@ -697,15 +714,21 @@ pm_check_length <- function(x, y, arg_name) {
pm_check_type <- function(x, y, arg_name) {
x_type <- typeof(x)
y_type <- typeof(y)
if (identical(x_type, y_type)) return()
if (identical(x_type, y_type)) {
return()
}
stop(arg_name, " must be `", y_type, "`, not `", x_type, "`")
}
pm_check_class <- function(x, y, arg_name) {
if (!is.object(x)) return()
if (!is.object(x)) {
return()
}
exp_classes <- class(y)
out_classes <- class(x)
if (identical(out_classes, exp_classes)) return()
if (identical(out_classes, exp_classes)) {
return()
}
stop(arg_name, " must have class `", exp_classes, "`, not class `", out_classes, "`")
}
pm_rownames_to_column <- function(.data, var = "rowname") {
@@ -827,8 +850,7 @@ pm_select_positions <- function(.data, ..., .group_pos = FALSE) {
pm_eval_expr <- function(x) {
type <- typeof(x)
switch(
type,
switch(type,
"integer" = x,
"double" = as.integer(x),
"character" = pm_select_char(x),
@@ -864,8 +886,7 @@ pm_select_symbol <- function(expr) {
pm_eval_call <- function(x) {
type <- as.character(x[[1]])
switch(
type,
switch(type,
`:` = pm_select_seq(x),
`!` = pm_select_negate(x),
`-` = pm_select_minus(x),
@@ -1029,7 +1050,7 @@ pm_is_wholenumber <- function(x) {
x %% 1L == 0L
}
pm_seq2 <- function (from, to) {
pm_seq2 <- function(from, to) {
if (length(from) != 1) stop("`from` must be length one")
if (length(to) != 1) stop("`to` must be length one")
if (from > to) integer() else seq.int(from, to)
@@ -1041,19 +1062,25 @@ pm_is_function <- function(x, frame) {
warning = function(w) FALSE,
error = function(e) FALSE
)
if (isTRUE(res)) return(res)
if (isTRUE(res)) {
return(res)
}
res <- tryCatch(
is.function(eval(x)),
warning = function(w) FALSE,
error = function(e) FALSE
)
if (isTRUE(res)) return(res)
if (isTRUE(res)) {
return(res)
}
res <- tryCatch(
is.function(eval(as.symbol(deparse(substitute(x))))),
warning = function(w) FALSE,
error = function(e) FALSE
)
if (isTRUE(res)) return(res)
if (isTRUE(res)) {
return(res)
}
FALSE
}

99
R/ab.R
View File

@@ -84,7 +84,6 @@
#' # you can quickly rename <rsi> columns using dplyr >= 1.0.0:
#' example_isolates %>%
#' rename_with(as.ab, where(is.rsi))
#'
#' }
#' }
as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
@@ -100,7 +99,8 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
if (all(x %in% c(AB_lookup$ab, NA))) {
# all valid AB codes, but not yet right class
return(set_clean_class(x,
new_class = c("ab", "character")))
new_class = c("ab", "character")
))
}
initial_search <- is.null(list(...)$initial_search)
@@ -133,8 +133,10 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
abnames <- abnames[!abnames %in% c("clavulanic acid", "avibactam")]
}
if (length(abnames) > 1) {
message_("More than one result was found for item ", index, ": ",
vector_and(abnames, quotes = FALSE))
message_(
"More than one result was found for item ", index, ": ",
vector_and(abnames, quotes = FALSE)
)
}
}
found[1L]
@@ -147,12 +149,18 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
known_codes_atc <- vapply(FUN.VALUE = logical(1), x, function(x_) x_ %in% unlist(AB_lookup$atc), USE.NAMES = FALSE)
known_codes_cid <- x %in% AB_lookup$cid
x_new[known_codes_ab] <- AB_lookup$ab[match(x[known_codes_ab], AB_lookup$ab)]
x_new[known_codes_atc] <- AB_lookup$ab[vapply(FUN.VALUE = integer(1),
x_new[known_codes_atc] <- AB_lookup$ab[vapply(
FUN.VALUE = integer(1),
x[known_codes_atc],
function(x_) which(vapply(FUN.VALUE = logical(1),
function(x_) {
which(vapply(
FUN.VALUE = logical(1),
AB_lookup$atc,
function(atc) x_ %in% atc))[1L],
USE.NAMES = FALSE)]
function(atc) x_ %in% atc
))[1L]
},
USE.NAMES = FALSE
)]
x_new[known_codes_cid] <- AB_lookup$ab[match(x[known_codes_cid], AB_lookup$cid)]
already_known <- known_names | known_codes_ab | known_codes_atc | known_codes_cid
@@ -162,7 +170,6 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
}
for (i in which(!already_known)) {
if (initial_search == TRUE) {
progress$tick()
}
@@ -179,7 +186,8 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
if (fast_mode == FALSE && flag_multiple_results == TRUE && x[i] %like% "[ ]") {
from_text <- tryCatch(suppressWarnings(ab_from_text(x[i], initial_search = FALSE, translate_ab = FALSE)[[1]]),
error = function(e) character(0))
error = function(e) character(0)
)
} else {
from_text <- character(0)
}
@@ -191,8 +199,10 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
}
# exact LOINC code
loinc_found <- unlist(lapply(AB_lookup$generalised_loinc,
function(s) x[i] %in% s))
loinc_found <- unlist(lapply(
AB_lookup$generalised_loinc,
function(s) x[i] %in% s
))
found <- antibiotics$ab[loinc_found == TRUE]
if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
@@ -200,8 +210,10 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
}
# exact synonym
synonym_found <- unlist(lapply(AB_lookup$generalised_synonyms,
function(s) x[i] %in% s))
synonym_found <- unlist(lapply(
AB_lookup$generalised_synonyms,
function(s) x[i] %in% s
))
found <- antibiotics$ab[synonym_found == TRUE]
if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
@@ -209,9 +221,11 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
}
# exact abbreviation
abbr_found <- unlist(lapply(AB_lookup$generalised_abbreviations,
abbr_found <- unlist(lapply(
AB_lookup$generalised_abbreviations,
# require at least 2 characters for abbreviations
function(s) x[i] %in% s & nchar(x[i]) >= 2))
function(s) x[i] %in% s & nchar(x[i]) >= 2
))
found <- antibiotics$ab[abbr_found == TRUE]
if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
@@ -235,7 +249,6 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
}
x_spelling <- x[i]
if (already_regex == FALSE) {
x_spelling <- gsub("[IY]+", "[IY]+", x_spelling, perl = TRUE)
x_spelling <- gsub("(C|K|Q|QU|S|Z|X|KS)+", "(C|K|Q|QU|S|Z|X|KS)+", x_spelling, perl = TRUE)
x_spelling <- gsub("(PH|F|V)+", "(PH|F|V)+", x_spelling, perl = TRUE)
@@ -273,8 +286,10 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
}
# and try if any synonym starts with it
synonym_found <- unlist(lapply(AB_lookup$generalised_synonyms,
function(s) any(s %like% paste0("^", x_spelling))))
synonym_found <- unlist(lapply(
AB_lookup$generalised_synonyms,
function(s) any(s %like% paste0("^", x_spelling))
))
found <- antibiotics$ab[synonym_found == TRUE]
if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
@@ -305,19 +320,23 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
}
# transform back from other languages and try again
x_translated <- paste(lapply(strsplit(x[i], "[^A-Z0-9]"),
x_translated <- paste(lapply(
strsplit(x[i], "[^A-Z0-9]"),
function(y) {
for (i in seq_len(length(y))) {
for (lang in LANGUAGES_SUPPORTED[LANGUAGES_SUPPORTED != "en"]) {
y[i] <- ifelse(tolower(y[i]) %in% tolower(TRANSLATIONS[, lang, drop = TRUE]),
TRANSLATIONS[which(tolower(TRANSLATIONS[, lang, drop = TRUE]) == tolower(y[i]) &
!isFALSE(TRANSLATIONS$fixed)), "pattern"],
y[i])
y[i]
)
}
}
generalise_antibiotic_name(y)
})[[1]],
collapse = "/")
}
)[[1]],
collapse = "/"
)
x_translated_guess <- suppressWarnings(as.ab(x_translated, initial_search = FALSE))
if (!is.na(x_translated_guess)) {
x_new[i] <- x_translated_guess
@@ -325,17 +344,21 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
}
# now also try to coerce brandname combinations like "Amoxy/clavulanic acid"
x_translated <- paste(lapply(strsplit(x_translated, "[^A-Z0-9 ]"),
x_translated <- paste(lapply(
strsplit(x_translated, "[^A-Z0-9 ]"),
function(y) {
for (i in seq_len(length(y))) {
y_name <- suppressWarnings(ab_name(y[i], language = NULL, initial_search = FALSE))
y[i] <- ifelse(!is.na(y_name),
y_name,
y[i])
y[i]
)
}
generalise_antibiotic_name(y)
})[[1]],
collapse = "/")
}
)[[1]],
collapse = "/"
)
x_translated_guess <- suppressWarnings(as.ab(x_translated, initial_search = FALSE))
if (!is.na(x_translated_guess)) {
x_new[i] <- x_translated_guess
@@ -364,7 +387,8 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
found <- from_text[1L]
} else {
found <- tryCatch(suppressWarnings(ab_from_text(x[i], initial_search = FALSE, translate_ab = FALSE)[[1]][1L]),
error = function(e) NA_character_)
error = function(e) NA_character_
)
}
if (!is.na(found)) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
@@ -428,7 +452,8 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
substr(x[i], j + 1, j + 1),
substr(x[i], j, j),
# ending part:
substr(x[i], j + 2, nchar(x[i])))
substr(x[i], j + 2, nchar(x[i]))
)
found <- suppressWarnings(as.ab(x_switched, initial_search = FALSE))
if (!is.na(found)) {
break
@@ -438,7 +463,6 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
x_new[i] <- found[1L]
next
}
} # end of initial_search = TRUE
# not found
@@ -453,13 +477,17 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
x_unknown_ATCs <- x_unknown[x_unknown %like% "[A-Z][0-9][0-9][A-Z][A-Z][0-9][0-9]"]
x_unknown <- x_unknown[!x_unknown %in% x_unknown_ATCs]
if (length(x_unknown_ATCs) > 0 & fast_mode == FALSE) {
warning_("in `as.ab()`: these ATC codes are not (yet) in the antibiotics data set: ",
vector_and(x_unknown_ATCs), ".")
warning_(
"in `as.ab()`: these ATC codes are not (yet) in the antibiotics data set: ",
vector_and(x_unknown_ATCs), "."
)
}
if (length(x_unknown) > 0 & fast_mode == FALSE) {
warning_("in `as.ab()`: these values could not be coerced to a valid antimicrobial ID: ",
vector_and(x_unknown), ".")
warning_(
"in `as.ab()`: these values could not be coerced to a valid antimicrobial ID: ",
vector_and(x_unknown), "."
)
}
x_result <- x_new[match(x_bak_clean, x)]
@@ -468,7 +496,8 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
}
set_clean_class(x_result,
new_class = c("ab", "character"))
new_class = c("ab", "character")
)
}
#' @rdname as.ab

44
R/ab_from_text.R
View File

@@ -68,22 +68,28 @@
#' ab_group(abx[[1]])
#'
#' if (require("dplyr")) {
#' tibble(clinical_text = c("given 400mg cipro and 500 mg amox",
#' "started on doxy iv today")) %>%
#' mutate(abx_codes = ab_from_text(clinical_text),
#' tibble(clinical_text = c(
#' "given 400mg cipro and 500 mg amox",
#' "started on doxy iv today"
#' )) %>%
#' mutate(
#' abx_codes = ab_from_text(clinical_text),
#' abx_doses = ab_from_text(clinical_text, type = "doses"),
#' abx_admin = ab_from_text(clinical_text, type = "admin"),
#' abx_coll = ab_from_text(clinical_text, collapse = "|"),
#' abx_coll_names = ab_from_text(clinical_text,
#' collapse = "|",
#' translate_ab = "name"),
#' translate_ab = "name"
#' ),
#' abx_coll_doses = ab_from_text(clinical_text,
#' type = "doses",
#' collapse = "|"),
#' collapse = "|"
#' ),
#' abx_coll_admin = ab_from_text(clinical_text,
#' type = "admin",
#' collapse = "|"))
#'
#' collapse = "|"
#' )
#' )
#' }
#' }
ab_from_text <- function(text,
@@ -112,7 +118,6 @@ ab_from_text <- function(text,
on.exit(close(progress))
if (type %like% "(drug|ab|anti)") {
translate_ab <- get_translate_ab(translate_ab)
if (isTRUE(thorough_search) |
@@ -124,7 +129,6 @@ ab_from_text <- function(text,
out <- as.ab(text_split, ...)
)
})
} else {
# no thorough search
abbr <- unlist(antibiotics$abbreviations)
@@ -136,19 +140,24 @@ ab_from_text <- function(text,
synonyms_part1 <- synonyms[seq_len(0.5 * length(synonyms))]
synonyms_part2 <- synonyms[!synonyms %in% synonyms_part1]
to_regex <- function(x) {
paste0("^(",
paste0(
"^(",
paste0(unique(gsub("[^a-z0-9]+", "", sort(tolower(x)))), collapse = "|"),
").*")
").*"
)
}
result <- lapply(text_split_all, function(text_split) {
progress$tick()
suppressWarnings(
out <- as.ab(unique(c(text_split[text_split %like_case% to_regex(abbr)],
out <- as.ab(
unique(c(
text_split[text_split %like_case% to_regex(abbr)],
text_split[text_split %like_case% to_regex(names_atc)],
text_split[text_split %like_case% to_regex(synonyms_part1)],
text_split[text_split %like_case% to_regex(synonyms_part2)])
),
...)
text_split[text_split %like_case% to_regex(synonyms_part2)]
)),
...
)
)
})
}
@@ -165,9 +174,7 @@ ab_from_text <- function(text,
}
out
}
})
} else if (type %like% "dos") {
text_split_all <- strsplit(text, " ")
result <- lapply(text_split_all, function(text_split) {
@@ -185,7 +192,6 @@ ab_from_text <- function(text,
NA_real_
}
})
} else if (type %like% "adm") {
result <- lapply(text_split_all, function(text_split) {
text_split <- text_split[text_split %like% "(^iv$|intraven|^po$|per os|oral|implant|inhal|instill|nasal|paren|rectal|sublingual|buccal|trans.*dermal|vaginal)"]
@@ -197,7 +203,6 @@ ab_from_text <- function(text,
NA_character_
}
})
} else {
stop_("`type` must be either 'drug', 'dose' or 'administration'")
}
@@ -214,5 +219,4 @@ ab_from_text <- function(text,
}
result
}

75
R/ab_property.R
View File

@@ -67,8 +67,10 @@
#'
#' # smart lowercase tranformation
#' ab_name(x = c("AMC", "PLB")) # "Amoxicillin/clavulanic acid" "Polymyxin B"
#' ab_name(x = c("AMC", "PLB"),
#' tolower = TRUE) # "amoxicillin/clavulanic acid" "polymyxin B"
#' ab_name(
#' x = c("AMC", "PLB"),
#' tolower = TRUE
#' ) # "amoxicillin/clavulanic acid" "polymyxin B"
#'
#' # defined daily doses (DDD)
#' ab_ddd("AMX", "oral") # 1.5
@@ -104,12 +106,12 @@
#'
#' # this does the same:
#' example_isolates %>%
#' rename_with(set_ab_names)%>%
#' rename_with(set_ab_names) %>%
#' head()
#'
#' # set_ab_names() works with any AB property:
#' example_isolates %>%
#' set_ab_names(property = "atc")%>%
#' set_ab_names(property = "atc") %>%
#' head()
#'
#' example_isolates %>%
@@ -180,7 +182,8 @@ ab_atc <- function(x, only_first = FALSE, ...) {
atcs <- ab_validate(x = x, property = "atc", ...)
if (only_first == TRUE) {
atcs <- vapply(FUN.VALUE = character(1),
atcs <- vapply(
FUN.VALUE = character(1),
# get only the first ATC code
atcs,
function(x) {
@@ -190,7 +193,8 @@ ab_atc <- function(x, only_first = FALSE, ...) {
} else {
as.character(x[1L])
}
})
}
)
} else if (length(atcs) == 1) {
atcs <- unname(unlist(atcs))
} else {
@@ -241,8 +245,10 @@ ab_ddd <- function(x, administration = "oral", ...) {
units <- list(...)$units
if (!is.null(units) && isTRUE(units)) {
if (message_not_thrown_before("ab_ddd", entire_session = TRUE)) {
warning_("in `ab_ddd()`: using `ab_ddd(..., units = TRUE)` is deprecated, use `ab_ddd_units()` to retrieve units instead.",
"This warning will be shown once per session.")
warning_(
"in `ab_ddd()`: using `ab_ddd(..., units = TRUE)` is deprecated, use `ab_ddd_units()` to retrieve units instead.",
"This warning will be shown once per session."
)
}
ddd_prop <- paste0(ddd_prop, "_units")
} else {
@@ -251,9 +257,11 @@ ab_ddd <- function(x, administration = "oral", ...) {
out <- ab_validate(x = x, property = ddd_prop)
if (any(ab_name(x, language = NULL) %like% "/" & is.na(out))) {
warning_("in `ab_ddd()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
warning_(
"in `ab_ddd()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
"Please refer to the WHOCC website:\n",
"www.whocc.no/ddd/list_of_ddds_combined_products/")
"www.whocc.no/ddd/list_of_ddds_combined_products/"
)
}
out
}
@@ -266,9 +274,11 @@ ab_ddd_units <- function(x, administration = "oral", ...) {
x <- as.ab(x, ...)
if (any(ab_name(x, language = NULL) %like% "/")) {
warning_("in `ab_ddd_units()`: DDDs of combined products are available for different dose combinations and not (yet) part of the AMR package.",
warning_(
"in `ab_ddd_units()`: DDDs of combined products are available for different dose combinations and not (yet) part of the AMR package.",
"Please refer to the WHOCC website:\n",
"www.whocc.no/ddd/list_of_ddds_combined_products/")
"www.whocc.no/ddd/list_of_ddds_combined_products/"
)
}
ddd_prop <- paste0(administration, "_units")
@@ -282,7 +292,8 @@ ab_info <- function(x, language = get_AMR_locale(), ...) {
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
x <- as.ab(x, ...)
list(ab = as.character(x),
list(
ab = as.character(x),
cid = ab_cid(x),
name = ab_name(x, language = language),
group = ab_group(x, language = language),
@@ -291,10 +302,17 @@ ab_info <- function(x, language = get_AMR_locale(), ...) {
atc_group2 = ab_atc_group2(x, language = language),
tradenames = ab_tradenames(x),
loinc = ab_loinc(x),
ddd = list(oral = list(amount = ab_ddd(x, administration = "oral"),
units = ab_ddd_units(x, administration = "oral")),
iv = list(amount = ab_ddd(x, administration = "iv"),
units = ab_ddd_units(x, administration = "iv"))))
ddd = list(
oral = list(
amount = ab_ddd(x, administration = "oral"),
units = ab_ddd_units(x, administration = "oral")
),
iv = list(
amount = ab_ddd(x, administration = "iv"),
units = ab_ddd_units(x, administration = "iv")
)
)
)
}
@@ -370,7 +388,8 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale
vars_ab <- as.ab(data, fast_mode = TRUE)
vars <- data[!is.na(vars_ab)]
}
x <- vapply(FUN.VALUE = character(1),
x <- vapply(
FUN.VALUE = character(1),
ab_property(vars, property = property, language = language),
function(x) {
if (property == "atc") {
@@ -384,10 +403,13 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale
as.character(x[1L])
}
},
USE.NAMES = FALSE)
USE.NAMES = FALSE
)
if (any(x %in% c("", NA))) {
warning_("in `set_ab_names()`: no ", property, " found for column(s): ",
vector_and(vars[x %in% c("", NA)], sort = FALSE))
warning_(
"in `set_ab_names()`: no ", property, " found for column(s): ",
vector_and(vars[x %in% c("", NA)], sort = FALSE)
)
x[x %in% c("", NA)] <- vars[x %in% c("", NA)]
}
@@ -399,7 +421,8 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale
# very hacky way of adding the index to each duplicate
# so "Amoxicillin", "Amoxicillin", "Amoxicillin"
# will be "Amoxicillin", "Amoxicillin_2", "Amoxicillin_3"
invisible(lapply(unique(x),
invisible(lapply(
unique(x),
function(u) {
dups <- which(x == u)
if (length(dups) > 1) {
@@ -407,7 +430,8 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale
dup_add_int <- dups[2:length(dups)]
x[dup_add_int] <<- paste0(x[dup_add_int], "_", c(2:length(dups)))
}
}))
}
))
}
if (is.data.frame(data)) {
colnames(data)[colnames(data) %in% vars] <- x
@@ -419,18 +443,17 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale
}
ab_validate <- function(x, property, ...) {
check_dataset_integrity()
if (tryCatch(all(x[!is.na(x)] %in% AB_lookup$ab), error = function(e) FALSE)) {
# special case for ab_* functions where class is already <ab>
x <- AB_lookup[match(x, AB_lookup$ab), property, drop = TRUE]
} else {
# try to catch an error when inputting an invalid argument
# so the 'call.' can be set to FALSE
tryCatch(x[1L] %in% antibiotics[1, property, drop = TRUE],
error = function(e) stop(e$message, call. = FALSE))
error = function(e) stop(e$message, call. = FALSE)
)
if (!all(x %in% AB_lookup[, property, drop = TRUE])) {
x <- as.ab(x, ...)

210
R/ab_selectors.R
View File

@@ -96,14 +96,12 @@
#' example_isolates %>%
#' group_by(ward) %>%
#' summarise(across(aminoglycosides(), resistance))
#'
#' }
#' if (require("dplyr")) {
#'
#' # You can combine selectors with '&' to be more specific:
#' example_isolates %>%
#' select(penicillins() & administrable_per_os())
#'
#' }
#' if (require("dplyr")) {
#'
@@ -112,7 +110,6 @@
#' filter(mo_genus() %in% c("Escherichia", "Klebsiella")) %>%
#' group_by(ward) %>%
#' summarise(across(not_intrinsic_resistant(), resistance))
#'
#' }
#' if (require("dplyr")) {
#'
@@ -121,50 +118,45 @@
#' filter(first_isolate()) %>%
#' group_by(ward) %>%
#' summarise(across(ab_selector(name %like% "trim"), susceptibility))
#'
#' }
#' if (require("dplyr")) {
#'
#' # this will select columns 'IPM' (imipenem) and 'MEM' (meropenem):
#' example_isolates %>%
#' select(carbapenems())
#'
#' }
#' if (require("dplyr")) {
#'
#' # this will select columns 'mo', 'AMK', 'GEN', 'KAN' and 'TOB':
#' example_isolates %>%
#' select(mo, aminoglycosides())
#'
#' }
#' if (require("dplyr")) {
#'
#' # any() and all() work in dplyr's filter() too:
#' example_isolates %>%
#' filter(any(aminoglycosides() == "R"),
#' all(cephalosporins_2nd() == "R"))
#'
#' filter(
#' any(aminoglycosides() == "R"),
#' all(cephalosporins_2nd() == "R")
#' )
#' }
#' if (require("dplyr")) {
#'
#' # also works with c():
#' example_isolates %>%
#' filter(any(c(carbapenems(), aminoglycosides()) == "R"))
#'
#' }
#' if (require("dplyr")) {
#'
#' # not setting any/all will automatically apply all():
#' example_isolates %>%
#' filter(aminoglycosides() == "R")
#'
#' }
#' if (require("dplyr")) {
#'
#' # this will select columns 'mo' and all antimycobacterial drugs ('RIF'):
#' example_isolates %>%
#' select(mo, ab_class("mycobact"))
#'
#' }
#' if (require("dplyr")) {
#'
@@ -174,21 +166,20 @@
#' select(mo, glycopeptides()) %>%
#' bug_drug_combinations() %>%
#' format()
#'
#' }
#' if (require("dplyr")) {
#'
#' data.frame(some_column = "some_value",
#' J01CA01 = "S") %>% # ATC code of ampicillin
#' data.frame(
#' some_column = "some_value",
#' J01CA01 = "S"
#' ) %>% # ATC code of ampicillin
#' select(penicillins()) # only the 'J01CA01' column will be selected
#'
#' }
#' if (require("dplyr")) {
#'
#' # with recent versions of dplyr this is all equal:
#' x <- example_isolates[carbapenems() == "R", ]
#' y <- example_isolates %>% filter(carbapenems() == "R")
#' z <- example_isolates %>% filter(if_all(carbapenems(), ~.x == "R"))
#' z <- example_isolates %>% filter(if_all(carbapenems(), ~ .x == "R"))
#' identical(x, y) && identical(y, z)
#' }
#' }
@@ -216,19 +207,25 @@ ab_selector <- function(filter,
# but it only takes a couple of milliseconds
vars_df <- get_current_data(arg_name = NA, call = -2)
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
ab_in_data <- get_column_abx(vars_df, info = FALSE, only_rsi_columns = only_rsi_columns,
sort = FALSE, fn = "ab_selector")
ab_in_data <- get_column_abx(vars_df,
info = FALSE, only_rsi_columns = only_rsi_columns,
sort = FALSE, fn = "ab_selector"
)
call <- substitute(filter)
agents <- tryCatch(AMR::antibiotics[which(eval(call, envir = AMR::antibiotics)), "ab", drop = TRUE],
error = function(e) stop_(e$message, call = -5))
error = function(e) stop_(e$message, call = -5)
)
agents <- ab_in_data[ab_in_data %in% agents]
message_agent_names(function_name = "ab_selector",
message_agent_names(
function_name = "ab_selector",
agents = agents,
ab_group = NULL,
examples = "",
call = call)
call = call
)
structure(unname(agents),
class = c("ab_selector", "character"))
class = c("ab_selector", "character")
)
}
#' @rdname antibiotic_class_selectors
@@ -419,24 +416,34 @@ administrable_per_os <- function(only_rsi_columns = FALSE, ...) {
# but it only takes a couple of milliseconds
vars_df <- get_current_data(arg_name = NA, call = -2)
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
ab_in_data <- get_column_abx(vars_df, info = FALSE, only_rsi_columns = only_rsi_columns,
sort = FALSE, fn = "administrable_per_os")
ab_in_data <- get_column_abx(vars_df,
info = FALSE, only_rsi_columns = only_rsi_columns,
sort = FALSE, fn = "administrable_per_os"
)
agents_all <- antibiotics[which(!is.na(antibiotics$oral_ddd)), "ab", drop = TRUE]
agents <- antibiotics[which(antibiotics$ab %in% ab_in_data & !is.na(antibiotics$oral_ddd)), "ab", drop = TRUE]
agents <- ab_in_data[ab_in_data %in% agents]
message_agent_names(function_name = "administrable_per_os",
message_agent_names(
function_name = "administrable_per_os",
agents = agents,
ab_group = "administrable_per_os",
examples = paste0(" (such as ",
examples = paste0(
" (such as ",
vector_or(ab_name(sample(agents_all,
size = min(5, length(agents_all)),
replace = FALSE),
replace = FALSE
),
tolower = TRUE,
language = NULL),
quotes = FALSE),
")"))
language = NULL
),
quotes = FALSE
),
")"
)
)
structure(unname(agents),
class = c("ab_selector", "character"))
class = c("ab_selector", "character")
)
}
#' @rdname antibiotic_class_selectors
@@ -447,17 +454,22 @@ administrable_iv <- function(only_rsi_columns = FALSE, ...) {
# but it only takes a couple of milliseconds
vars_df <- get_current_data(arg_name = NA, call = -2)
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
ab_in_data <- get_column_abx(vars_df, info = FALSE, only_rsi_columns = only_rsi_columns,
sort = FALSE, fn = "administrable_iv")
ab_in_data <- get_column_abx(vars_df,
info = FALSE, only_rsi_columns = only_rsi_columns,
sort = FALSE, fn = "administrable_iv"
)
agents_all <- antibiotics[which(!is.na(antibiotics$iv_ddd)), "ab", drop = TRUE]
agents <- antibiotics[which(antibiotics$ab %in% ab_in_data & !is.na(antibiotics$iv_ddd)), "ab", drop = TRUE]
agents <- ab_in_data[ab_in_data %in% agents]
message_agent_names(function_name = "administrable_iv",
message_agent_names(
function_name = "administrable_iv",
agents = agents,
ab_group = "administrable_iv",
examples = "")
examples = ""
)
structure(unname(agents),
class = c("ab_selector", "character"))
class = c("ab_selector", "character")
)
}
#' @rdname antibiotic_class_selectors
@@ -470,17 +482,26 @@ not_intrinsic_resistant <- function(only_rsi_columns = FALSE, col_mo = NULL, ver
# but it only takes a couple of milliseconds
vars_df <- get_current_data(arg_name = NA, call = -2)
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
ab_in_data <- get_column_abx(vars_df, info = FALSE, only_rsi_columns = only_rsi_columns,
sort = FALSE, fn = "not_intrinsic_resistant")
ab_in_data <- get_column_abx(vars_df,
info = FALSE, only_rsi_columns = only_rsi_columns,
sort = FALSE, fn = "not_intrinsic_resistant"
)
# intrinsic vars
vars_df_R <- tryCatch(sapply(eucast_rules(vars_df,
vars_df_R <- tryCatch(sapply(
eucast_rules(vars_df,
col_mo = col_mo,
version_expertrules = version_expertrules,
rules = "expert",
info = FALSE),
function(col) tryCatch(!any(is.na(col)) && all(col == "R"),
error = function(e) FALSE)),
error = function(e) stop_("in not_intrinsic_resistant(): ", e$message, call = FALSE))
info = FALSE
),
function(col) {
tryCatch(!any(is.na(col)) && all(col == "R"),
error = function(e) FALSE
)
}
),
error = function(e) stop_("in not_intrinsic_resistant(): ", e$message, call = FALSE)
)
agents <- ab_in_data[ab_in_data %in% names(vars_df_R[which(vars_df_R)])]
if (length(agents) > 0 &&
@@ -489,16 +510,19 @@ not_intrinsic_resistant <- function(only_rsi_columns = FALSE, col_mo = NULL, ver
agents_names <- ab_name(names(agents), tolower = TRUE, language = NULL)
need_name <- generalise_antibiotic_name(agents) != generalise_antibiotic_name(agents_names)
agents_formatted[need_name] <- paste0(agents_formatted[need_name], " (", agents_names[need_name], ")")
message_("For `not_intrinsic_resistant()` removing ",
message_(
"For `not_intrinsic_resistant()` removing ",
ifelse(length(agents) == 1, "column ", "columns "),
vector_and(agents_formatted, quotes = FALSE, sort = FALSE))
vector_and(agents_formatted, quotes = FALSE, sort = FALSE)
)
}
vars_df_R <- names(vars_df_R)[which(!vars_df_R)]
# find columns that are abx, but also intrinsic R
out <- unname(intersect(ab_in_data, vars_df_R))
structure(out,
class = c("ab_selector", "character"))
class = c("ab_selector", "character")
)
}
ab_select_exec <- function(function_name,
@@ -509,20 +533,26 @@ ab_select_exec <- function(function_name,
# but it only takes a couple of milliseconds
vars_df <- get_current_data(arg_name = NA, call = -3)
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
ab_in_data <- get_column_abx(vars_df, info = FALSE, only_rsi_columns = only_rsi_columns,
sort = FALSE, fn = function_name)
ab_in_data <- get_column_abx(vars_df,
info = FALSE, only_rsi_columns = only_rsi_columns,
sort = FALSE, fn = function_name
)
# untreatable drugs
if (only_treatable == TRUE) {
untreatable <- antibiotics[which(antibiotics$name %like% "-high|EDTA|polysorbate|macromethod|screening|/nacubactam"), "ab", drop = TRUE]
if (any(untreatable %in% names(ab_in_data))) {
if (message_not_thrown_before(function_name, "ab_class", "untreatable", entire_session = TRUE)) {
warning_("in `", function_name, "()`: some agents were ignored since they cannot be used for treating patients: ",
warning_(
"in `", function_name, "()`: some agents were ignored since they cannot be used for treating patients: ",
vector_and(ab_name(names(ab_in_data)[names(ab_in_data) %in% untreatable],
language = NULL,
tolower = TRUE),
tolower = TRUE
),
quotes = FALSE,
sort = TRUE), ". They can be included using `", function_name, "(only_treatable = FALSE)`. ",
"This warning will be shown once per session.")
sort = TRUE
), ". They can be included using `", function_name, "(only_treatable = FALSE)`. ",
"This warning will be shown once per session."
)
}
ab_in_data <- ab_in_data[!names(ab_in_data) %in% untreatable]
}
@@ -534,20 +564,24 @@ ab_select_exec <- function(function_name,
}
if (is.null(ab_class_args)) {
# their upper case equivalent are vectors with class <ab>, created in data-raw/pre-commit-hook.R
# their upper case equivalent are vectors with class <ab>, created in data-raw/_pre_commit_hook.R
# carbapenems() gets its codes from AMR:::AB_CARBAPENEMS
abx <- get(paste0("AB_", toupper(function_name)), envir = asNamespace("AMR"))
ab_group <- function_name
examples <- paste0(" (such as ", vector_or(ab_name(sample(abx, size = min(2, length(abx)), replace = FALSE),
tolower = TRUE,
language = NULL),
quotes = FALSE), ")")
language = NULL
),
quotes = FALSE
), ")")
} else {
# this for the 'manual' ab_class() function
abx <- subset(AB_lookup,
abx <- subset(
AB_lookup,
group %like% ab_class_args |
atc_group1 %like% ab_class_args |
atc_group2 %like% ab_class_args)$ab
atc_group2 %like% ab_class_args
)$ab
ab_group <- find_ab_group(ab_class_args)
function_name <- "ab_class"
examples <- paste0(" (such as ", find_ab_names(ab_class_args, 2), ")")
@@ -556,14 +590,17 @@ ab_select_exec <- function(function_name,
# get the columns with a group names in the chosen ab class
agents <- ab_in_data[names(ab_in_data) %in% abx]
message_agent_names(function_name = function_name,
message_agent_names(
function_name = function_name,
agents = agents,
ab_group = ab_group,
examples = examples,
ab_class_args = ab_class_args)
ab_class_args = ab_class_args
)
structure(unname(agents),
class = c("ab_selector", "character"))
class = c("ab_selector", "character")
)
}
#' @method c ab_selector
@@ -571,7 +608,8 @@ ab_select_exec <- function(function_name,
#' @noRd
c.ab_selector <- function(...) {
structure(unlist(lapply(list(...), as.character)),
class = c("ab_selector", "character"))
class = c("ab_selector", "character")
)
}
all_any_ab_selector <- function(type, ..., na.rm = TRUE) {
@@ -591,10 +629,12 @@ all_any_ab_selector <- function(type, ..., na.rm = TRUE) {
}
x_transposed <- as.list(as.data.frame(t(df[, cols_ab, drop = FALSE]), stringsAsFactors = FALSE))
vapply(FUN.VALUE = logical(1),
vapply(
FUN.VALUE = logical(1),
X = x_transposed,
FUN = function(y) scope_fn(y %in% result, na.rm = na.rm),
USE.NAMES = FALSE)
USE.NAMES = FALSE
)
}
#' @method all ab_selector
@@ -654,12 +694,15 @@ any.ab_selector_any_all <- function(..., na.rm = FALSE) {
} else {
type <- "all"
if (length(e1) > 1) {
message_("Assuming a filter on ", type, " ", length(e1), " ", gsub("[\\(\\)]", "", fn_name),
". Wrap around `all()` or `any()` to prevent this note.")
message_(
"Assuming a filter on ", type, " ", length(e1), " ", gsub("[\\(\\)]", "", fn_name),
". Wrap around `all()` or `any()` to prevent this note."
)
}
}
structure(all_any_ab_selector(type = type, e1, e2),
class = c("ab_selector_any_all", "logical"))
class = c("ab_selector_any_all", "logical")
)
}
#' @method != ab_selector
@@ -676,15 +719,18 @@ any.ab_selector_any_all <- function(..., na.rm = FALSE) {
} else {
type <- "all"
if (length(e1) > 1) {
message_("Assuming a filter on ", type, " ", length(e1), " ", gsub("[\\(\\)]", "", fn_name),
". Wrap around `all()` or `any()` to prevent this note.")
message_(
"Assuming a filter on ", type, " ", length(e1), " ", gsub("[\\(\\)]", "", fn_name),
". Wrap around `all()` or `any()` to prevent this note."
)
}
}
# this is `!=`, so turn around the values
rsi <- c("R", "S", "I")
e2 <- rsi[rsi != e2]
structure(all_any_ab_selector(type = type, e1, e2),
class = c("ab_selector_any_all", "logical"))
class = c("ab_selector_any_all", "logical")
)
}
#' @method & ab_selector
@@ -694,7 +740,8 @@ any.ab_selector_any_all <- function(..., na.rm = FALSE) {
# this is only required for base R, since tidyselect has already implemented this
# e.g., for: example_isolates[, penicillins() & administrable_per_os()]
structure(intersect(unclass(e1), unclass(e2)),
class = c("ab_selector", "character"))
class = c("ab_selector", "character")
)
}
#' @method | ab_selector
#' @export
@@ -703,7 +750,8 @@ any.ab_selector_any_all <- function(..., na.rm = FALSE) {
# this is only required for base R, since tidyselect has already implemented this
# e.g., for: example_isolates[, penicillins() | administrable_per_os()]
structure(union(unclass(e1), unclass(e2)),
class = c("ab_selector", "character"))
class = c("ab_selector", "character")
)
}
is_any <- function(el1) {
@@ -750,8 +798,10 @@ find_ab_names <- function(ab_group, n = 3) {
}
vector_or(ab_name(sample(drugs, size = min(n, length(drugs)), replace = FALSE),
tolower = TRUE,
language = NULL),
quotes = FALSE)
language = NULL
),
quotes = FALSE
)
}
message_agent_names <- function(function_name, agents, ab_group = NULL, examples = "", ab_class_args = NULL, call = NULL) {
@@ -771,15 +821,19 @@ message_agent_names <- function(function_name, agents, ab_group = NULL, examples
agents_names <- ab_name(names(agents), tolower = TRUE, language = NULL)
need_name <- generalise_antibiotic_name(agents) != generalise_antibiotic_name(agents_names)
agents_formatted[need_name] <- paste0(agents_formatted[need_name], " (", agents_names[need_name], ")")
message_("For `", function_name, "(",
message_(
"For `", function_name, "(",
ifelse(function_name == "ab_class",
paste0("\"", ab_class_args, "\""),
ifelse(!is.null(call),
paste0(deparse(call), collapse = " "),
"")),
""
)
),
")` using ",
ifelse(length(agents) == 1, "column ", "columns "),
vector_and(agents_formatted, quotes = FALSE, sort = FALSE))
vector_and(agents_formatted, quotes = FALSE, sort = FALSE)
)
}
}
}

24
R/age.R
View File

@@ -73,21 +73,27 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
years_gap <- reference$year - x$year
ages <- ifelse(reference$mon < x$mon | (reference$mon == x$mon & reference$mday < x$mday),
as.integer(years_gap - 1),
as.integer(years_gap))
as.integer(years_gap)
)
# add decimals
if (exact == TRUE) {
# get dates of `x` when `x` would have the year of `reference`
x_in_reference_year <- as.POSIXlt(paste0(format(as.Date(reference), "%Y"),
format(as.Date(x), "-%m-%d")),
format = "%Y-%m-%d")
x_in_reference_year <- as.POSIXlt(paste0(
format(as.Date(reference), "%Y"),
format(as.Date(x), "-%m-%d")
),
format = "%Y-%m-%d"
)
# get differences in days
n_days_x_rest <- as.double(difftime(as.Date(reference),
as.Date(x_in_reference_year),
units = "days"))
units = "days"
))
# get numbers of days the years of `reference` has for a reliable denominator
n_days_reference_year <- as.POSIXlt(paste0(format(as.Date(reference), "%Y"), "-12-31"),
format = "%Y-%m-%d")$yday + 1
format = "%Y-%m-%d"
)$yday + 1
# add decimal parts of year
mod <- n_days_x_rest / n_days_reference_year
# negative mods are cases where `x_in_reference_year` > `reference` - so 'add' a year
@@ -163,10 +169,12 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
#' filter(mo == as.mo("Escherichia coli")) %>%
#' group_by(age_group = age_groups(age)) %>%
#' select(age_group, CIP) %>%
#' ggplot_rsi(x = "age_group",
#' ggplot_rsi(
#' x = "age_group",
#' minimum = 0,
#' x.title = "Age Group",
#' title = "Ciprofloxacin resistance per age group")
#' title = "Ciprofloxacin resistance per age group"
#' )
#' }
#' }
age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {

11
R/atc_online.R
View File

@@ -103,7 +103,8 @@ atc_online_property <- function(atc_code,
if (!has_internet()) {
message_("There appears to be no internet connection, returning NA.",
add_fn = font_red,
as_note = FALSE)
as_note = FALSE
)
return(rep(NA, length(atc_code)))
}
@@ -124,7 +125,6 @@ atc_online_property <- function(atc_code,
on.exit(close(progress))
for (i in seq_len(length(atc_code))) {
progress$tick()
if (atc_code[i] %like% "^Q") {
@@ -141,7 +141,8 @@ atc_online_property <- function(atc_code,
html_node("#content") %pm>%
html_children() %pm>%
html_node("a"),
error = function(e) NULL)
error = function(e) NULL
)
if (is.null(out)) {
message_("Connection to ", atc_url, " failed.")
return(rep(NA, length(atc_code)))
@@ -156,14 +157,14 @@ atc_online_property <- function(atc_code,
# last one is antibiotics, skip it
texts <- texts[seq_len(length(texts)) - 1]
returnvalue <- c(list(texts), returnvalue)
} else {
out <- tryCatch(
read_html(atc_url) %pm>%
html_nodes("table") %pm>%
html_table(header = TRUE) %pm>%
as.data.frame(stringsAsFactors = FALSE),
error = function(e) NULL)
error = function(e) NULL
)
if (is.null(out)) {
message_("Connection to ", atc_url, " failed.")
return(rep(NA, length(atc_code)))

6
R/availability.R
View File

@@ -82,12 +82,14 @@ availability <- function(tbl, width = NULL) {
x_chars <- strrep("#", round(x, digits = 2) / (1 / width))
x_chars_empty <- strrep("-", width - nchar(x_chars))
df <- data.frame(count = n,
df <- data.frame(
count = n,
available = percentage(x),
visual_availabilty = paste0("|", x_chars, x_chars_empty, "|"),
resistant = R_print,
visual_resistance = vis_resistance,
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
if (length(R[is.na(R)]) == ncol(tbl)) {
df[, 1:3, drop = FALSE]
} else {

77
R/bug_drug_combinations.R
View File

@@ -48,12 +48,17 @@
#'
#' # Use FUN to change to transformation of microorganism codes
#' bug_drug_combinations(example_isolates,
#' FUN = mo_gramstain)
#' FUN = mo_gramstain
#' )
#'
#' bug_drug_combinations(example_isolates,
#' FUN = function(x) ifelse(x == as.mo("Escherichia coli"),
#' FUN = function(x) {
#' ifelse(x == as.mo("Escherichia coli"),
#' "E. coli",
#' "Others"))
#' "Others"
#' )
#' }
#' )
#' }
bug_drug_combinations <- function(x,
col_mo = NULL,
@@ -89,13 +94,15 @@ bug_drug_combinations <- function(x,
}
run_it <- function(x) {
out <- data.frame(mo = character(0),
out <- data.frame(
mo = character(0),
ab = character(0),
S = integer(0),
I = integer(0),
R = integer(0),
total = integer(0),
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
if (data_has_groups) {
group_values <- unique(x[, which(colnames(x) %in% groups), drop = FALSE])
rownames(group_values) <- NULL
@@ -111,18 +118,21 @@ bug_drug_combinations <- function(x,
data.frame(S = m["S", ], I = m["I", ], R = m["R", ], stringsAsFactors = FALSE)
})
merged <- do.call(rbind, pivot)
out_group <- data.frame(mo = rep(unique_mo[i], NROW(merged)),
out_group <- data.frame(
mo = rep(unique_mo[i], NROW(merged)),
ab = rownames(merged),
S = merged$S,
I = merged$I,
R = merged$R,
total = merged$S + merged$I + merged$R,
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
if (data_has_groups) {
if (nrow(group_values) < nrow(out_group)) {
# repeat group_values for the number of rows in out_group
repeated <- rep(seq_len(nrow(group_values)),
each = nrow(out_group) / nrow(group_values))
each = nrow(out_group) / nrow(group_values)
)
group_values <- group_values[repeated, , drop = FALSE]
}
out_group <- cbind(group_values, out_group)
@@ -183,15 +193,19 @@ format.bug_drug_combinations <- function(x,
warning_("in `format()`: formatting the output of `bug_drug_combinations()` does not support grouped variables, they were ignored")
x <- as.data.frame(x, stringsAsFactors = FALSE)
idx <- split(seq_len(nrow(x)), paste0(x$mo, "%%", x$ab))
x <- data.frame(mo = gsub("(.*)%%(.*)", "\\1", names(idx)),
x <- data.frame(
mo = gsub("(.*)%%(.*)", "\\1", names(idx)),
ab = gsub("(.*)%%(.*)", "\\2", names(idx)),
S = sapply(idx, function(i) sum(x$S[i], na.rm = TRUE)),
I = sapply(idx, function(i) sum(x$I[i], na.rm = TRUE)),
R = sapply(idx, function(i) sum(x$R[i], na.rm = TRUE)),
total = sapply(idx, function(i) sum(x$S[i], na.rm = TRUE) +
total = sapply(idx, function(i) {
sum(x$S[i], na.rm = TRUE) +
sum(x$I[i], na.rm = TRUE) +
sum(x$R[i], na.rm = TRUE)),
stringsAsFactors = FALSE)
sum(x$R[i], na.rm = TRUE)
}),
stringsAsFactors = FALSE
)
}
x <- as.data.frame(x, stringsAsFactors = FALSE)
@@ -225,7 +239,8 @@ format.bug_drug_combinations <- function(x,
remove_NAs <- function(.data) {
cols <- colnames(.data)
.data <- as.data.frame(lapply(.data, function(x) ifelse(is.na(x), "", x)),
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
colnames(.data) <- cols
.data
}
@@ -239,17 +254,23 @@ format.bug_drug_combinations <- function(x,
}
y <- x %pm>%
create_var(ab = as.ab(x$ab),
ab_txt = give_ab_name(ab = x$ab, format = translate_ab, language = language)) %pm>%
create_var(
ab = as.ab(x$ab),
ab_txt = give_ab_name(ab = x$ab, format = translate_ab, language = language)
) %pm>%
pm_group_by(ab, ab_txt, mo) %pm>%
pm_summarise(isolates = sum(isolates, na.rm = TRUE),
total = sum(total, na.rm = TRUE)) %pm>%
pm_summarise(
isolates = sum(isolates, na.rm = TRUE),
total = sum(total, na.rm = TRUE)
) %pm>%
pm_ungroup()
y <- y %pm>%
create_var(txt = paste0(percentage(y$isolates / y$total, decimal.mark = decimal.mark, big.mark = big.mark),
create_var(txt = paste0(
percentage(y$isolates / y$total, decimal.mark = decimal.mark, big.mark = big.mark),
" (", trimws(format(y$isolates, big.mark = big.mark)), "/",
trimws(format(y$total, big.mark = big.mark)), ")")) %pm>%
trimws(format(y$total, big.mark = big.mark)), ")"
)) %pm>%
pm_select(ab, ab_txt, mo, txt) %pm>%
pm_arrange(mo)
@@ -285,8 +306,10 @@ format.bug_drug_combinations <- function(x,
colnames(y)[1] <- translate_into_language(colnames(y)[1], language, only_unknown = FALSE)
} else {
y <- y %pm>%
pm_rename("Group" = ab_group,
"Drug" = ab_txt)
pm_rename(
"Group" = ab_group,
"Drug" = ab_txt
)
}
if (!is.null(language)) {
@@ -305,10 +328,14 @@ format.bug_drug_combinations <- function(x,
#' @export
print.bug_drug_combinations <- function(x, ...) {
x_class <- class(x)
print(set_clean_class(x,
new_class = x_class[!x_class %in% c("bug_drug_combinations", "grouped")]),
...)
print(
set_clean_class(x,
new_class = x_class[!x_class %in% c("bug_drug_combinations", "grouped")]
),
...
)
message_("Use 'format()' on this result to get a publishable/printable format.",
ifelse(inherits(x, "grouped"), " Note: The grouping variable(s) will be ignored.", ""),
as_note = FALSE)
as_note = FALSE
)
}

35
R/catalogue_of_life.R
View File

@@ -94,41 +94,52 @@ NULL
#' @inheritSection catalogue_of_life Catalogue of Life
#' @export
catalogue_of_life_version <- function() {
check_dataset_integrity()
# see the `CATALOGUE_OF_LIFE` list in R/globals.R
lst <- list(CoL =
list(version = gsub("{year}", CATALOGUE_OF_LIFE$year, CATALOGUE_OF_LIFE$version, fixed = TRUE),
lst <- list(
CoL =
list(
version = gsub("{year}", CATALOGUE_OF_LIFE$year, CATALOGUE_OF_LIFE$version, fixed = TRUE),
url = gsub("{year}", CATALOGUE_OF_LIFE$year, CATALOGUE_OF_LIFE$url_CoL, fixed = TRUE),
n = nrow(pm_filter(microorganisms, source == "CoL"))),
n = nrow(pm_filter(microorganisms, source == "CoL"))
),
LPSN =
list(version = "List of Prokaryotic names with Standing in Nomenclature",
list(
version = "List of Prokaryotic names with Standing in Nomenclature",
url = CATALOGUE_OF_LIFE$url_LPSN,
yearmonth = CATALOGUE_OF_LIFE$yearmonth_LPSN,
n = nrow(pm_filter(microorganisms, source == "LPSN"))),
n = nrow(pm_filter(microorganisms, source == "LPSN"))
),
total_included =
list(
n_total_species = nrow(microorganisms),
n_total_synonyms = nrow(microorganisms.old)))
n_total_synonyms = nrow(microorganisms.old)
)
)
set_clean_class(lst,
new_class = c("catalogue_of_life_version", "list"))
new_class = c("catalogue_of_life_version", "list")
)
}
#' @method print catalogue_of_life_version
#' @export
#' @noRd
print.catalogue_of_life_version <- function(x, ...) {
cat(paste0(font_bold("Included in this AMR package (v", utils::packageDescription("AMR")$Version, ") are:\n\n", collapse = ""),
cat(paste0(
font_bold("Included in this AMR package (v", utils::packageDescription("AMR")$Version, ") are:\n\n", collapse = ""),
font_underline(x$CoL$version), "\n",
" Available at: ", font_blue(x$CoL$url), "\n",
" Number of included microbial species: ", format(x$CoL$n, big.mark = ","), "\n",
font_underline(paste0(x$LPSN$version, " (",
x$LPSN$yearmonth, ")")), "\n",
font_underline(paste0(
x$LPSN$version, " (",
x$LPSN$yearmonth, ")"
)), "\n",
" Available at: ", font_blue(x$LPSN$url), "\n",
" Number of included bacterial species: ", format(x$LPSN$n, big.mark = ","), "\n\n",
"=> Total number of species included: ", format(x$total_included$n_total_species, big.mark = ","), "\n",
"=> Total number of synonyms included: ", format(x$total_included$n_total_synonyms, big.mark = ","), "\n\n",
"See for more info ", font_grey_bg("`?microorganisms`"), " and ", font_grey_bg("`?catalogue_of_life`"), ".\n"))
"See for more info ", font_grey_bg("`?microorganisms`"), " and ", font_grey_bg("`?catalogue_of_life`"), ".\n"
))
}

63
R/count.R
View File

@@ -76,12 +76,14 @@
#' if (require("dplyr")) {
#' example_isolates %>%
#' group_by(ward) %>%
#' summarise(R = count_R(CIP),
#' summarise(
#' R = count_R(CIP),
#' I = count_I(CIP),
#' S = count_S(CIP),
#' n1 = count_all(CIP), # the actual total; sum of all three
#' n2 = n_rsi(CIP), # same - analogous to n_distinct
#' total = n()) # NOT the number of tested isolates!
#' total = n()
#' ) # NOT the number of tested isolates!
#'
#' # Number of available isolates for a whole antibiotic class
#' # (i.e., in this data set columns GEN, TOB, AMK, KAN)
@@ -118,8 +120,10 @@ count_resistant <- function(..., only_all_tested = FALSE) {
rsi_calc(...,
ab_result = "R",
only_all_tested = only_all_tested,
only_count = TRUE),
error = function(e) stop_(e$message, call = -5))
only_count = TRUE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname count
@@ -129,8 +133,10 @@ count_susceptible <- function(..., only_all_tested = FALSE) {
rsi_calc(...,
ab_result = c("S", "I"),
only_all_tested = only_all_tested,
only_count = TRUE),
error = function(e) stop_(e$message, call = -5))
only_count = TRUE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname count
@@ -140,8 +146,10 @@ count_R <- function(..., only_all_tested = FALSE) {
rsi_calc(...,
ab_result = "R",
only_all_tested = only_all_tested,
only_count = TRUE),
error = function(e) stop_(e$message, call = -5))
only_count = TRUE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname count
@@ -154,8 +162,10 @@ count_IR <- function(..., only_all_tested = FALSE) {
rsi_calc(...,
ab_result = c("I", "R"),
only_all_tested = only_all_tested,
only_count = TRUE),
error = function(e) stop_(e$message, call = -5))
only_count = TRUE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname count
@@ -165,8 +175,10 @@ count_I <- function(..., only_all_tested = FALSE) {
rsi_calc(...,
ab_result = "I",
only_all_tested = only_all_tested,
only_count = TRUE),
error = function(e) stop_(e$message, call = -5))
only_count = TRUE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname count
@@ -176,8 +188,10 @@ count_SI <- function(..., only_all_tested = FALSE) {
rsi_calc(...,
ab_result = c("S", "I"),
only_all_tested = only_all_tested,
only_count = TRUE),
error = function(e) stop_(e$message, call = -5))
only_count = TRUE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname count
@@ -190,8 +204,10 @@ count_S <- function(..., only_all_tested = FALSE) {
rsi_calc(...,
ab_result = "S",
only_all_tested = only_all_tested,
only_count = TRUE),
error = function(e) stop_(e$message, call = -5))
only_count = TRUE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname count
@@ -201,8 +217,10 @@ count_all <- function(..., only_all_tested = FALSE) {
rsi_calc(...,
ab_result = c("S", "I", "R"),
only_all_tested = only_all_tested,
only_count = TRUE),
error = function(e) stop_(e$message, call = -5))
only_count = TRUE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname count
@@ -217,12 +235,15 @@ count_df <- function(data,
combine_SI = TRUE,
combine_IR = FALSE) {
tryCatch(
rsi_calc_df(type = "count",
rsi_calc_df(
type = "count",
data = data,
translate_ab = translate_ab,
language = language,
combine_SI = combine_SI,
combine_IR = combine_IR,
combine_SI_missing = missing(combine_SI)),
error = function(e) stop_(e$message, call = -5))
combine_SI_missing = missing(combine_SI)
),
error = function(e) stop_(e$message, call = -5)
)
}

73
R/custom_eucast_rules.R
View File

@@ -77,8 +77,10 @@
#' @returns A [list] containing the custom rules
#' @export
#' @examples
#' x <- custom_eucast_rules(AMC == "R" & genus == "Klebsiella" ~ aminopenicillins == "R",
#' AMC == "I" & genus == "Klebsiella" ~ aminopenicillins == "I")
#' x <- custom_eucast_rules(
#' AMC == "R" & genus == "Klebsiella" ~ aminopenicillins == "R",
#' AMC == "I" & genus == "Klebsiella" ~ aminopenicillins == "I"
#' )
#' x
#'
#' # run the custom rule set (verbose = TRUE will return a logbook instead of the data set):
@@ -86,24 +88,31 @@
#' rules = "custom",
#' custom_rules = x,
#' info = FALSE,
#' verbose = TRUE)
#' verbose = TRUE
#' )
#'
#' # combine rule sets
#' x2 <- c(x,
#' custom_eucast_rules(TZP == "R" ~ carbapenems == "R"))
#' x2 <- c(
#' x,
#' custom_eucast_rules(TZP == "R" ~ carbapenems == "R")
#' )
#' x2
custom_eucast_rules <- function(...) {
dots <- tryCatch(list(...),
error = function(e) "error")
stop_if(identical(dots, "error"),
"rules must be a valid formula inputs (e.g., using '~'), see `?custom_eucast_rules`")
error = function(e) "error"
)
stop_if(
identical(dots, "error"),
"rules must be a valid formula inputs (e.g., using '~'), see `?custom_eucast_rules`"
)
n_dots <- length(dots)
stop_if(n_dots == 0, "no custom rules were set. Please read the documentation using `?custom_eucast_rules`.")
out <- vector("list", n_dots)
for (i in seq_len(n_dots)) {
stop_ifnot(inherits(dots[[i]], "formula"),
"rule ", i, " must be a valid formula input (e.g., using '~'), see `?custom_eucast_rules`")
stop_ifnot(
inherits(dots[[i]], "formula"),
"rule ", i, " must be a valid formula input (e.g., using '~'), see `?custom_eucast_rules`"
)
# Query
qry <- dots[[i]][[2]]
@@ -122,8 +131,10 @@ custom_eucast_rules <- function(...) {
# Resulting rule
result <- dots[[i]][[3]]
stop_ifnot(deparse(result) %like% "==",
"the result of rule ", i, " (the part after the `~`) must contain `==`, such as in `... ~ ampicillin == \"R\"`, see `?custom_eucast_rules`")
stop_ifnot(
deparse(result) %like% "==",
"the result of rule ", i, " (the part after the `~`) must contain `==`, such as in `... ~ ampicillin == \"R\"`, see `?custom_eucast_rules`"
)
result_group <- as.character(result)[[2]]
if (paste0("AB_", toupper(result_group), "S") %in% DEFINED_AB_GROUPS) {
# support for e.g. 'aminopenicillin' if user meant 'aminopenicillins'
@@ -135,18 +146,24 @@ custom_eucast_rules <- function(...) {
result_group <- tryCatch(
suppressWarnings(as.ab(result_group,
fast_mode = TRUE,
flag_multiple_results = FALSE)),
error = function(e) NA_character_)
flag_multiple_results = FALSE
)),
error = function(e) NA_character_
)
}
stop_if(any(is.na(result_group)),
stop_if(
any(is.na(result_group)),
"this result of rule ", i, " could not be translated to a single antimicrobial agent/group: \"",
as.character(result)[[2]], "\".\n\nThe input can be a name or code of an antimicrobial agent, or be one of: ",
vector_or(tolower(gsub("AB_", "", DEFINED_AB_GROUPS)), quotes = FALSE), ".")
vector_or(tolower(gsub("AB_", "", DEFINED_AB_GROUPS)), quotes = FALSE), "."
)
result_value <- as.character(result)[[3]]
result_value[result_value == "NA"] <- NA
stop_ifnot(result_value %in% c("R", "S", "I", NA),
"the resulting value of rule ", i, " must be either \"R\", \"S\", \"I\" or NA")
stop_ifnot(
result_value %in% c("R", "S", "I", NA),
"the resulting value of rule ", i, " must be either \"R\", \"S\", \"I\" or NA"
)
result_value <- as.rsi(result_value)
out[[i]]$result_group <- result_group
@@ -196,13 +213,19 @@ print.custom_eucast_rules <- function(x, ...) {
} else {
val <- font_rsi_I_bg(font_black(" I "))
}
agents <- paste0(font_blue(ab_name(rule$result_group, language = NULL, tolower = TRUE),
collapse = NULL),
" (", rule$result_group, ")")
agents <- paste0(
font_blue(ab_name(rule$result_group, language = NULL, tolower = TRUE),
collapse = NULL
),
" (", rule$result_group, ")"
)
agents <- sort(agents)
rule_if <- word_wrap(paste0(i, ". ", font_bold("If "), font_blue(rule$query), font_bold(" then "),
"set to {result}:"),
extra_indent = 5)
rule_if <- word_wrap(paste0(
i, ". ", font_bold("If "), font_blue(rule$query), font_bold(" then "),
"set to {result}:"
),
extra_indent = 5
)
rule_if <- gsub("{result}", val, rule_if, fixed = TRUE)
rule_then <- paste0(" ", word_wrap(paste0(agents, collapse = ", "), extra_indent = 5))
cat("\n ", rule_if, "\n", rule_then, "\n", sep = "")

46
R/disk.R
View File

@@ -36,11 +36,13 @@
#' @seealso [as.rsi()]
#' @examples
#' # transform existing disk zones to the `disk` class (using base R)
#' df <- data.frame(microorganism = "Escherichia coli",
#' df <- data.frame(
#' microorganism = "Escherichia coli",
#' AMP = 20,
#' CIP = 14,
#' GEN = 18,
#' TOB = 16)
#' TOB = 16
#' )
#' df[, 2:5] <- lapply(df[, 2:5], as.disk)
#' str(df)
#'
@@ -52,10 +54,12 @@
#' }
#'
#' # interpret disk values, see ?as.rsi
#' as.rsi(x = as.disk(18),
#' as.rsi(
#' x = as.disk(18),
#' mo = "Strep pneu", # `mo` will be coerced with as.mo()
#' ab = "ampicillin", # and `ab` with as.ab()
#' guideline = "EUCAST")
#' guideline = "EUCAST"
#' )
#'
#' # interpret whole data set, pretend to be all from urinary tract infections:
#' as.rsi(df, uti = TRUE)
@@ -84,9 +88,12 @@ as.disk <- function(x, na.rm = FALSE) {
gsub(".", "",
reverse(sub(".", "}}tod{{",
reverse(x),
fixed = TRUE)),
fixed = TRUE),
fixed = TRUE)
fixed = TRUE
)),
fixed = TRUE
),
fixed = TRUE
)
x_clean <- gsub(remove, "", x, ignore.case = TRUE, fixed = fixed)
# remove everything that is not a number or dot
as.double(gsub("[^0-9.]+", "", x_clean))
@@ -104,14 +111,17 @@ as.disk <- function(x, na.rm = FALSE) {
unique() %pm>%
sort() %pm>%
vector_and(quotes = TRUE)
warning_("in `as.disk()`: ", na_after - na_before, " results truncated (",
warning_(
"in `as.disk()`: ", na_after - na_before, " results truncated (",
round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid disk zones: ",
list_missing)
list_missing
)
}
}
set_clean_class(as.integer(x),
new_class = c("disk", "integer"))
new_class = c("disk", "integer")
)
}
all_valid_disks <- function(x) {
@@ -119,7 +129,8 @@ all_valid_disks <- function(x) {
return(FALSE)
}
x_disk <- tryCatch(suppressWarnings(as.disk(x[!is.na(x)])),
error = function(e) NA)
error = function(e) NA
)
!any(is.na(x_disk)) && !all(is.na(x))
}
@@ -127,7 +138,8 @@ all_valid_disks <- function(x) {
#' @details `NA_disk_` is a missing value of the new `<disk>` class.
#' @export
NA_disk_ <- set_clean_class(as.integer(NA_real_),
new_class = c("disk", "integer"))
new_class = c("disk", "integer")
)
#' @rdname as.disk
#' @export
@@ -218,10 +230,10 @@ rep.disk <- function(x, ...) {
get_skimmers.disk <- function(column) {
skimr::sfl(
skim_type = "disk",
min = ~min(as.double(.), na.rm = TRUE),
max = ~max(as.double(.), na.rm = TRUE),
median = ~stats::median(as.double(.), na.rm = TRUE),
n_unique = ~length(unique(stats::na.omit(.))),
hist = ~skimr::inline_hist(stats::na.omit(as.double(.)))
min = ~ min(as.double(.), na.rm = TRUE),
max = ~ max(as.double(.), na.rm = TRUE),
median = ~ stats::median(as.double(.), na.rm = TRUE),
n_unique = ~ length(unique(stats::na.omit(.))),
hist = ~ skimr::inline_hist(stats::na.omit(as.double(.)))
)
}

48
R/episode.R
View File

@@ -53,50 +53,55 @@
#' df[which(get_episode(df$date, 60) == 3), ]
#'
#' # the functions also work for less than a day, e.g. to include one per hour:
#' get_episode(c(Sys.time(),
#' Sys.time() + 60 * 60),
#' episode_days = 1/24)
#' get_episode(c(
#' Sys.time(),
#' Sys.time() + 60 * 60
#' ),
#' episode_days = 1 / 24
#' )
#'
#' \donttest{
#' if (require("dplyr")) {
#' # is_new_episode() can also be used in dplyr verbs to determine patient
#' # episodes based on any (combination of) grouping variables:
#' df %>%
#' mutate(condition = sample(x = c("A", "B", "C"),
#' mutate(condition = sample(
#' x = c("A", "B", "C"),
#' size = 200,
#' replace = TRUE)) %>%
#' replace = TRUE
#' )) %>%
#' group_by(condition) %>%
#' mutate(new_episode = is_new_episode(date, 365)) %>%
#' select(patient, date, condition, new_episode)
#'
#' }
#' if (require("dplyr")) {
#'
#' df %>%
#' group_by(ward, patient) %>%
#' transmute(date,
#' patient,
#' new_index = get_episode(date, 60),
#' new_logical = is_new_episode(date, 60))
#'
#' new_logical = is_new_episode(date, 60)
#' )
#' }
#' if (require("dplyr")) {
#'
#' df %>%
#' group_by(ward) %>%
#' summarise(n_patients = n_distinct(patient),
#' summarise(
#' n_patients = n_distinct(patient),
#' n_episodes_365 = sum(is_new_episode(date, episode_days = 365)),
#' n_episodes_60 = sum(is_new_episode(date, episode_days = 60)),
#' n_episodes_30 = sum(is_new_episode(date, episode_days = 30)))
#'
#' n_episodes_30 = sum(is_new_episode(date, episode_days = 30))
#' )
#' }
#' if (require("dplyr")) {
#'
#' # grouping on patients and microorganisms leads to the same
#' # results as first_isolate() when using 'episode-based':
#' x <- df %>%
#' filter_first_isolate(include_unknown = TRUE,
#' method = "episode-based")
#' filter_first_isolate(
#' include_unknown = TRUE,
#' method = "episode-based"
#' )
#'
#' y <- df %>%
#' group_by(patient, mo) %>%
@@ -104,7 +109,6 @@
#' ungroup()
#'
#' identical(x, y)
#'
#' }
#' if (require("dplyr")) {
#'
@@ -120,10 +124,12 @@ get_episode <- function(x, episode_days, ...) {
meet_criteria(x, allow_class = c("Date", "POSIXt"), allow_NA = TRUE)
meet_criteria(episode_days, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = FALSE)
exec_episode(x = x,
exec_episode(
x = x,
type = "sequential",
episode_days = episode_days,
... = ...)
... = ...
)
}
#' @rdname get_episode
@@ -132,10 +138,12 @@ is_new_episode <- function(x, episode_days, ...) {
meet_criteria(x, allow_class = c("Date", "POSIXt"), allow_NA = TRUE)
meet_criteria(episode_days, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = FALSE)
exec_episode(x = x,
exec_episode(
x = x,
type = "logical",
episode_days = episode_days,
... = ...)
... = ...
)
}
exec_episode <- function(x, type, episode_days, ...) {

411
R/eucast_rules.R
View File

@@ -35,11 +35,15 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
for (i in seq_len(length(version))) {
v <- version[i]
if (markdown == TRUE) {
txt <- c(txt, paste0("[", lst[[v]]$title, " ", lst[[v]]$version_txt, "](", lst[[v]]$url, ")",
" (", lst[[v]]$year, ")"))
txt <- c(txt, paste0(
"[", lst[[v]]$title, " ", lst[[v]]$version_txt, "](", lst[[v]]$url, ")",
" (", lst[[v]]$year, ")"
))
} else {
txt <- c(txt, paste0(lst[[version]]$title, " ", lst[[v]]$version_txt,
" (", lst[[v]]$year, ")"))
txt <- c(txt, paste0(
lst[[version]]$title, " ", lst[[v]]$version_txt,
" (", lst[[v]]$year, ")"
))
}
}
@@ -117,11 +121,14 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
#' @examples
#' \donttest{
#' a <- data.frame(mo = c("Staphylococcus aureus",
#' a <- data.frame(
#' mo = c(
#' "Staphylococcus aureus",
#' "Enterococcus faecalis",
#' "Escherichia coli",
#' "Klebsiella pneumoniae",
#' "Pseudomonas aeruginosa"),
#' "Pseudomonas aeruginosa"
#' ),
#' VAN = "-", # Vancomycin
#' AMX = "-", # Amoxicillin
#' COL = "-", # Colistin
@@ -129,7 +136,8 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
#' CXM = "-", # Cefuroxime
#' PEN = "S", # Benzylpenicillin
#' FOX = "S", # Cefoxitin
#' stringsAsFactors = FALSE)
#' stringsAsFactors = FALSE
#' )
#'
#' head(a)
#'
@@ -175,7 +183,8 @@ eucast_rules <- function(x,
if ("custom" %in% rules & is.null(custom_rules)) {
warning_("in `eucast_rules()`: no custom rules were set with the `custom_rules` argument",
immediate = TRUE)
immediate = TRUE
)
rules <- rules[rules != "custom"]
if (length(rules) == 0) {
if (info == TRUE) {
@@ -201,9 +210,11 @@ eucast_rules <- function(x,
}
if (interactive() & verbose == TRUE & info == TRUE) {
txt <- paste0("WARNING: In Verbose mode, the eucast_rules() function does not apply rules to the data, but instead returns a data set in logbook form with extensive info about which rows and columns would be effected and in which way.",
txt <- paste0(
"WARNING: In Verbose mode, the eucast_rules() function does not apply rules to the data, but instead returns a data set in logbook form with extensive info about which rows and columns would be effected and in which way.",
"\n\nThis may overwrite your existing data if you use e.g.:",
"\ndata <- eucast_rules(data, verbose = TRUE)\n\nDo you want to continue?")
"\ndata <- eucast_rules(data, verbose = TRUE)\n\nDo you want to continue?"
)
showQuestion <- import_fn("showQuestion", "rstudioapi", error_on_fail = FALSE)
if (!is.null(showQuestion)) {
q_continue <- showQuestion("Using verbose = TRUE with eucast_rules()", txt)
@@ -277,8 +288,10 @@ eucast_rules <- function(x,
}
}
cols_ab <- get_column_abx(x = x,
soft_dependencies = c("AMC",
cols_ab <- get_column_abx(
x = x,
soft_dependencies = c(
"AMC",
"AMP",
"AMX",
"CIP",
@@ -292,13 +305,15 @@ eucast_rules <- function(x,
"PIP",
"TCY",
"TIC",
"TOB"),
"TOB"
),
hard_dependencies = NULL,
verbose = verbose,
info = info,
only_rsi_columns = only_rsi_columns,
fn = "eucast_rules",
...)
...
)
if (!"AMP" %in% names(cols_ab) & "AMX" %in% names(cols_ab)) {
# ampicillin column is missing, but amoxicillin is available
@@ -348,13 +363,17 @@ eucast_rules <- function(x,
} else {
if (length(ab_names) == 2) {
# like PEN,FOX S,R
paste0(ab_names[1], " is '", ab_results[1], "' and ",
ab_names[2], " is '", ab_results[2], "'")
paste0(
ab_names[1], " is '", ab_results[1], "' and ",
ab_names[2], " is '", ab_results[2], "'"
)
} else {
# like PEN,FOX,GEN S,R,R (although dependency on > 2 ABx does not exist at the moment)
paste0(ab_names[1], " is '", ab_results[1], "' and ",
paste0(
ab_names[1], " is '", ab_results[1], "' and ",
ab_names[2], " is '", ab_results[2], "' and ",
ab_names[3], " is '", ab_results[3], "'")
ab_names[3], " is '", ab_results[3], "'"
)
}
}
}
@@ -367,7 +386,8 @@ eucast_rules <- function(x,
# Preparing the data ------------------------------------------------------
verbose_info <- data.frame(rowid = character(0),
verbose_info <- data.frame(
rowid = character(0),
col = character(0),
mo_fullname = character(0),
old = as.rsi(character(0)),
@@ -376,20 +396,24 @@ eucast_rules <- function(x,
rule_group = character(0),
rule_name = character(0),
rule_source = character(0),
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
old_cols <- colnames(x)
old_attributes <- attributes(x)
x <- as.data.frame(x, stringsAsFactors = FALSE) # no tibbles, data.tables, etc.
rownames(x) <- NULL # will later be restored with old_attributes
# create unique row IDs - combination of the MO and all ABx columns (so they will only run once per unique combination)
x$`.rowid` <- vapply(FUN.VALUE = character(1),
x$`.rowid` <- vapply(
FUN.VALUE = character(1),
as.list(as.data.frame(t(x[, c(col_mo, cols_ab), drop = FALSE]),
stringsAsFactors = FALSE)),
stringsAsFactors = FALSE
)),
function(x) {
x[is.na(x)] <- "."
paste0(x, collapse = "")
})
}
)
# save original table, with the new .rowid column
x.bak <- x
@@ -428,9 +452,14 @@ eucast_rules <- function(x,
if (info == TRUE) {
cat("\n")
cat(word_wrap(
font_bold(paste0("Rules by this AMR package (",
font_red(paste0("v", utils::packageDescription("AMR")$Version, ", ",
format(as.Date(utils::packageDescription("AMR")$Date), format = "%Y"))), "), see ?eucast_rules\n"))))
font_bold(paste0(
"Rules by this AMR package (",
font_red(paste0(
"v", utils::packageDescription("AMR")$Version, ", ",
format(as.Date(utils::packageDescription("AMR")$Date), format = "%Y")
)), "), see ?eucast_rules\n"
))
))
}
ab_enzyme <- subset(antibiotics, name %like% "/")[, c("ab", "name"), drop = FALSE]
colnames(ab_enzyme) <- c("enzyme_ab", "enzyme_name")
@@ -455,24 +484,31 @@ eucast_rules <- function(x,
col_enzyme <- unname(cols_ab[ab_enzyme$enzyme_ab[i]])
# Set base to R where base + enzyme inhibitor is R ----
rule_current <- paste0(ab_enzyme$base_name[i], " ('", font_bold(col_base), "') = R if ",
tolower(ab_enzyme$enzyme_name[i]), " ('", font_bold(col_enzyme), "') = R")
rule_current <- paste0(
ab_enzyme$base_name[i], " ('", font_bold(col_base), "') = R if ",
tolower(ab_enzyme$enzyme_name[i]), " ('", font_bold(col_enzyme), "') = R"
)
if (info == TRUE) {
cat(word_wrap(rule_current,
width = getOption("width") - 30,
extra_indent = 6))
extra_indent = 6
))
}
run_changes <- edit_rsi(x = x,
run_changes <- edit_rsi(
x = x,
to = "R",
rule = c(rule_current, "Other rules", "",
paste0("Non-EUCAST: AMR package v", utils::packageDescription("AMR")$Version)),
rule = c(
rule_current, "Other rules", "",
paste0("Non-EUCAST: AMR package v", utils::packageDescription("AMR")$Version)
),
rows = which(as.rsi_no_warning(x[, col_enzyme, drop = TRUE]) == "R"),
cols = col_base,
last_verbose_info = verbose_info,
original_data = x.bak,
warned = warned,
info = info,
verbose = verbose)
verbose = verbose
)
n_added <- n_added + run_changes$added
n_changed <- n_changed + run_changes$changed
verbose_info <- run_changes$verbose_info
@@ -488,25 +524,32 @@ eucast_rules <- function(x,
}
# Set base + enzyme inhibitor to S where base is S ----
rule_current <- paste0(ab_enzyme$enzyme_name[i], " ('", font_bold(col_enzyme), "') = S if ",
tolower(ab_enzyme$base_name[i]), " ('", font_bold(col_base), "') = S")
rule_current <- paste0(
ab_enzyme$enzyme_name[i], " ('", font_bold(col_enzyme), "') = S if ",
tolower(ab_enzyme$base_name[i]), " ('", font_bold(col_base), "') = S"
)
if (info == TRUE) {
cat(word_wrap(rule_current,
width = getOption("width") - 30,
extra_indent = 6))
extra_indent = 6
))
}
run_changes <- edit_rsi(x = x,
run_changes <- edit_rsi(
x = x,
to = "S",
rule = c(rule_current, "Other rules", "",
paste0("Non-EUCAST: AMR package v", utils::packageDescription("AMR")$Version)),
rule = c(
rule_current, "Other rules", "",
paste0("Non-EUCAST: AMR package v", utils::packageDescription("AMR")$Version)
),
rows = which(as.rsi_no_warning(x[, col_base, drop = TRUE]) == "S"),
cols = col_enzyme,
last_verbose_info = verbose_info,
original_data = x.bak,
warned = warned,
info = info,
verbose = verbose)
verbose = verbose
)
n_added <- n_added + run_changes$added
n_changed <- n_changed + run_changes$changed
verbose_info <- run_changes$verbose_info
@@ -522,7 +565,6 @@ eucast_rules <- function(x,
}
}
}
} else {
if (info == TRUE) {
cat("\n")
@@ -543,27 +585,33 @@ eucast_rules <- function(x,
# this allows: eucast_rules(x, eucast_rules_df = AMR:::EUCAST_RULES_DF %>% filter(is.na(have_these_values)))
eucast_rules_df <- list(...)$eucast_rules_df
} else {
# otherwise internal data file, created in data-raw/pre-commit-hook.R
# otherwise internal data file, created in data-raw/_pre_commit_hook.R
eucast_rules_df <- EUCAST_RULES_DF
}
# filter on user-set guideline versions ----
if (any(c("all", "breakpoints") %in% rules)) {
eucast_rules_df <- subset(eucast_rules_df,
eucast_rules_df <- subset(
eucast_rules_df,
reference.rule_group %unlike% "breakpoint" |
(reference.rule_group %like% "breakpoint" & reference.version == version_breakpoints))
(reference.rule_group %like% "breakpoint" & reference.version == version_breakpoints)
)
}
if (any(c("all", "expert") %in% rules)) {
eucast_rules_df <- subset(eucast_rules_df,
eucast_rules_df <- subset(
eucast_rules_df,
reference.rule_group %unlike% "expert" |
(reference.rule_group %like% "expert" & reference.version == version_expertrules))
(reference.rule_group %like% "expert" & reference.version == version_expertrules)
)
}
# filter out AmpC de-repressed cephalosporin-resistant mutants ----
# no need to filter on version number here - the rules contain these version number, so are inherently filtered
# cefotaxime, ceftriaxone, ceftazidime
if (is.null(ampc_cephalosporin_resistance) || isFALSE(ampc_cephalosporin_resistance)) {
eucast_rules_df <- subset(eucast_rules_df,
reference.rule %unlike% "ampc")
eucast_rules_df <- subset(
eucast_rules_df,
reference.rule %unlike% "ampc"
)
} else {
if (isTRUE(ampc_cephalosporin_resistance)) {
ampc_cephalosporin_resistance <- "R"
@@ -573,7 +621,6 @@ eucast_rules <- function(x,
# Go over all rules and apply them ----
for (i in seq_len(nrow(eucast_rules_df))) {
rule_previous <- eucast_rules_df[max(1, i - 1), "reference.rule", drop = TRUE]
rule_current <- eucast_rules_df[i, "reference.rule", drop = TRUE]
rule_next <- eucast_rules_df[min(nrow(eucast_rules_df), i + 1), "reference.rule", drop = TRUE]
@@ -593,10 +640,14 @@ eucast_rules <- function(x,
if (is.na(eucast_rules_df[i, "and_these_antibiotics", drop = TRUE])) {
rule_text <- paste0("always report as '", eucast_rules_df[i, "to_value", drop = TRUE], "': ", get_antibiotic_names(eucast_rules_df[i, "then_change_these_antibiotics", drop = TRUE]))
} else {
rule_text <- paste0("report as '", eucast_rules_df[i, "to_value", drop = TRUE], "' when ",
format_antibiotic_names(ab_names = get_antibiotic_names(eucast_rules_df[i, "and_these_antibiotics", drop = TRUE]),
ab_results = eucast_rules_df[i, "have_these_values", drop = TRUE]), ": ",
get_antibiotic_names(eucast_rules_df[i, "then_change_these_antibiotics", drop = TRUE]))
rule_text <- paste0(
"report as '", eucast_rules_df[i, "to_value", drop = TRUE], "' when ",
format_antibiotic_names(
ab_names = get_antibiotic_names(eucast_rules_df[i, "and_these_antibiotics", drop = TRUE]),
ab_results = eucast_rules_df[i, "have_these_values", drop = TRUE]
), ": ",
get_antibiotic_names(eucast_rules_df[i, "then_change_these_antibiotics", drop = TRUE])
)
}
}
if (i == 1) {
@@ -611,9 +662,12 @@ eucast_rules <- function(x,
# Print EUCAST intro ------------------------------------------------------
if (rule_group_current %unlike% "other" & eucast_notification_shown == FALSE) {
cat(
paste0("\n", font_grey(strrep("-", 0.95 * options()$width)), "\n",
paste0(
"\n", font_grey(strrep("-", 0.95 * options()$width)), "\n",
word_wrap("Rules by the ", font_bold("European Committee on Antimicrobial Susceptibility Testing (EUCAST)")), "\n",
font_blue("https://eucast.org/"), "\n"))
font_blue("https://eucast.org/"), "\n"
)
)
eucast_notification_shown <- TRUE
}
@@ -623,25 +677,36 @@ eucast_rules <- function(x,
cat(font_bold(
ifelse(
rule_group_current %like% "breakpoint",
paste0("\n",
paste0(
"\n",
word_wrap(
breakpoints_info$title, " (",
font_red(paste0(breakpoints_info$version_txt, ", ", breakpoints_info$year)), ")\n")),
font_red(paste0(breakpoints_info$version_txt, ", ", breakpoints_info$year)), ")\n"
)
),
ifelse(
rule_group_current %like% "expert",
paste0("\n",
paste0(
"\n",
word_wrap(
expertrules_info$title, " (",
font_red(paste0(expertrules_info$version_txt, ", ", expertrules_info$year)), ")\n")),
""))), "\n")
font_red(paste0(expertrules_info$version_txt, ", ", expertrules_info$year)), ")\n"
)
),
""
)
)
), "\n")
}
# Print rule -------------------------------------------------------------
if (rule_current != rule_previous) {
# is new rule within group, print its name
cat(italicise_taxonomy(word_wrap(rule_current,
width = getOption("width") - 30,
extra_indent = 6),
type = "ansi"))
extra_indent = 6
),
type = "ansi"
))
warned <- FALSE
}
}
@@ -654,27 +719,39 @@ eucast_rules <- function(x,
# be sure to comprise all coagulase-negative/-positive staphylococci when they are mentioned
if (mo_value %like% "coagulase" && any(x$genus == "Staphylococcus", na.rm = TRUE)) {
if (mo_value %like% "negative") {
eucast_rules_df[i, "this_value"] <- paste0("^(", paste0(all_staph[which(all_staph$CNS_CPS %like% "negative"),
eucast_rules_df[i, "this_value"] <- paste0(
"^(", paste0(all_staph[which(all_staph$CNS_CPS %like% "negative"),
"fullname",
drop = TRUE],
collapse = "|"),
")$")
drop = TRUE
],
collapse = "|"
),
")$"
)
} else {
eucast_rules_df[i, "this_value"] <- paste0("^(", paste0(all_staph[which(all_staph$CNS_CPS %like% "positive"),
eucast_rules_df[i, "this_value"] <- paste0(
"^(", paste0(all_staph[which(all_staph$CNS_CPS %like% "positive"),
"fullname",
drop = TRUE],
collapse = "|"),
")$")
drop = TRUE
],
collapse = "|"
),
")$"
)
}
like_is_one_of <- "like"
}
# be sure to comprise all beta-haemolytic Streptococci (Lancefield groups A, B, C and G) when they are mentioned
if (mo_value %like% "group [ABCG]" && any(x$genus == "Streptococcus", na.rm = TRUE)) {
eucast_rules_df[i, "this_value"] <- paste0("^(", paste0(all_strep[which(all_strep$Lancefield %like% "group [ABCG]"),
eucast_rules_df[i, "this_value"] <- paste0(
"^(", paste0(all_strep[which(all_strep$Lancefield %like% "group [ABCG]"),
"fullname",
drop = TRUE],
collapse = "|"),
")$")
drop = TRUE
],
collapse = "|"
),
")$"
)
like_is_one_of <- "like"
}
@@ -683,10 +760,13 @@ eucast_rules <- function(x,
mo_value <- paste0("^", mo_value, "$")
} else if (like_is_one_of == "one_of") {
# so 'Clostridium, Actinomyces, ...' will turn into '^(Clostridium|Actinomyces|...)$'
mo_value <- paste0("^(",
mo_value <- paste0(
"^(",
paste(trimws(unlist(strsplit(mo_value, ",", fixed = TRUE))),
collapse = "|"),
")$")
collapse = "|"
),
")$"
)
} else if (like_is_one_of != "like") {
stop("invalid value for column 'like.is.one_of'", call. = FALSE)
}
@@ -698,7 +778,8 @@ eucast_rules <- function(x,
if (is.na(source_antibiotics)) {
rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like% mo_value),
error = function(e) integer(0))
error = function(e) integer(0)
)
} else {
source_antibiotics <- get_ab_from_namespace(source_antibiotics, cols_ab)
if (length(source_value) == 1 & length(source_antibiotics) > 1) {
@@ -707,14 +788,16 @@ eucast_rules <- function(x,
if (length(source_antibiotics) == 0) {
rows <- integer(0)
} else if (length(source_antibiotics) == 1) {
rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like% mo_value
& as.rsi_no_warning(x[, source_antibiotics[1L]]) == source_value[1L]),
error = function(e) integer(0))
rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like% mo_value &
as.rsi_no_warning(x[, source_antibiotics[1L]]) == source_value[1L]),
error = function(e) integer(0)
)
} else if (length(source_antibiotics) == 2) {
rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like% mo_value
& as.rsi_no_warning(x[, source_antibiotics[1L]]) == source_value[1L]
& as.rsi_no_warning(x[, source_antibiotics[2L]]) == source_value[2L]),
error = function(e) integer(0))
rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like% mo_value &
as.rsi_no_warning(x[, source_antibiotics[1L]]) == source_value[1L] &
as.rsi_no_warning(x[, source_antibiotics[2L]]) == source_value[2L]),
error = function(e) integer(0)
)
# nolint start
# } else if (length(source_antibiotics) == 3) {
# rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like% mo_value
@@ -732,19 +815,24 @@ eucast_rules <- function(x,
# Apply rule on data ------------------------------------------------------
# this will return the unique number of changes
run_changes <- edit_rsi(x = x,
run_changes <- edit_rsi(
x = x,
to = target_value,
rule = c(rule_text, rule_group_current, rule_current,
rule = c(
rule_text, rule_group_current, rule_current,
ifelse(rule_group_current %like% "breakpoint",
paste0(breakpoints_info$title, " ", breakpoints_info$version_txt, ", ", breakpoints_info$year),
paste0(expertrules_info$title, " ", expertrules_info$version_txt, ", ", expertrules_info$year))),
paste0(expertrules_info$title, " ", expertrules_info$version_txt, ", ", expertrules_info$year)
)
),
rows = rows,
cols = cols,
last_verbose_info = verbose_info,
original_data = x.bak,
warned = warned,
info = info,
verbose = verbose)
verbose = verbose
)
n_added <- n_added + run_changes$added
n_changed <- n_changed + run_changes$changed
verbose_info <- run_changes$verbose_info
@@ -770,35 +858,47 @@ eucast_rules <- function(x,
rule <- custom_rules[[i]]
rows <- which(eval(parse(text = rule$query), envir = x))
cols <- as.character(rule$result_group)
cols <- c(cols[cols %in% colnames(x)], # direct column names
unname(cols_ab[names(cols_ab) %in% cols])) # based on previous cols_ab finding
cols <- c(
cols[cols %in% colnames(x)], # direct column names
unname(cols_ab[names(cols_ab) %in% cols])
) # based on previous cols_ab finding
cols <- unique(cols)
target_value <- as.character(rule$result_value)
rule_text <- paste0("report as '", target_value, "' when ",
rule_text <- paste0(
"report as '", target_value, "' when ",
format_custom_query_rule(rule$query, colours = FALSE), ": ",
get_antibiotic_names(cols))
get_antibiotic_names(cols)
)
if (info == TRUE) {
# print rule
cat(italicise_taxonomy(word_wrap(format_custom_query_rule(rule$query, colours = FALSE),
width = getOption("width") - 30,
extra_indent = 6),
type = "ansi"))
extra_indent = 6
),
type = "ansi"
))
warned <- FALSE
}
run_changes <- edit_rsi(x = x,
run_changes <- edit_rsi(
x = x,
to = target_value,
rule = c(rule_text,
rule = c(
rule_text,
"Custom EUCAST rules",
paste0("Custom EUCAST rule ", i),
paste0("Object '", deparse(substitute(custom_rules)),
"' consisting of ", length(custom_rules), " custom rules")),
paste0(
"Object '", deparse(substitute(custom_rules)),
"' consisting of ", length(custom_rules), " custom rules"
)
),
rows = rows,
cols = cols,
last_verbose_info = verbose_info,
original_data = x.bak,
warned = warned,
info = info,
verbose = verbose)
verbose = verbose
)
n_added <- n_added + run_changes$added
n_changed <- n_changed + run_changes$changed
verbose_info <- run_changes$verbose_info
@@ -821,7 +921,8 @@ eucast_rules <- function(x,
pm_mutate(row = pm_row_number()) %pm>%
pm_select(`.rowid`, row) %pm>%
pm_right_join(verbose_info,
by = c(".rowid" = "rowid")) %pm>%
by = c(".rowid" = "rowid")
) %pm>%
pm_select(-`.rowid`) %pm>%
pm_select(row, pm_everything()) %pm>%
pm_filter(!is.na(new) | is.na(new) & !is.na(old)) %pm>%
@@ -830,7 +931,6 @@ eucast_rules <- function(x,
}
if (info == TRUE) {
if (verbose == TRUE) {
wouldve <- "would have "
} else {
@@ -838,12 +938,16 @@ eucast_rules <- function(x,
}
cat(paste0("\n", font_grey(strrep("-", 0.95 * options()$width)), "\n"))
cat(word_wrap(paste0("The rules ", paste0(wouldve, "affected "),
font_bold(formatnr(pm_n_distinct(verbose_info$row)),
cat(word_wrap(paste0(
"The rules ", paste0(wouldve, "affected "),
font_bold(
formatnr(pm_n_distinct(verbose_info$row)),
"out of", formatnr(nrow(x.bak)),
"rows"),
"rows"
),
", making a total of ",
font_bold(formatnr(nrow(verbose_info)), "edits\n"))))
font_bold(formatnr(nrow(verbose_info)), "edits\n")
)))
total_n_added <- verbose_info %pm>% pm_filter(is.na(old)) %pm>% nrow()
total_n_changed <- verbose_info %pm>% pm_filter(!is.na(old)) %pm>% nrow()
@@ -854,18 +958,24 @@ eucast_rules <- function(x,
} else {
colour <- font_green # is function
}
cat(colour(paste0("=> ", wouldve, "added ",
cat(colour(paste0(
"=> ", wouldve, "added ",
font_bold(formatnr(verbose_info %pm>%
pm_filter(is.na(old)) %pm>%
nrow()), "test results"),
"\n")))
"\n"
)))
if (total_n_added > 0) {
added_summary <- verbose_info %pm>%
pm_filter(is.na(old)) %pm>%
pm_count(new, name = "n")
cat(paste(" -",
paste0(formatnr(added_summary$n), " test result", ifelse(added_summary$n > 1, "s", ""),
" added as ", paste0('"', added_summary$new, '"')), collapse = "\n"))
paste0(
formatnr(added_summary$n), " test result", ifelse(added_summary$n > 1, "s", ""),
" added as ", paste0('"', added_summary$new, '"')
),
collapse = "\n"
))
}
# print changed values
@@ -877,19 +987,25 @@ eucast_rules <- function(x,
if (total_n_added + total_n_changed > 0) {
cat("\n")
}
cat(colour(paste0("=> ", wouldve, "changed ",
cat(colour(paste0(
"=> ", wouldve, "changed ",
font_bold(formatnr(verbose_info %pm>%
pm_filter(!is.na(old)) %pm>%
nrow()), "test results"),
"\n")))
"\n"
)))
if (total_n_changed > 0) {
changed_summary <- verbose_info %pm>%
pm_filter(!is.na(old)) %pm>%
pm_mutate(new = ifelse(is.na(new), "NA", new)) %pm>%
pm_count(old, new, name = "n")
cat(paste(" -",
paste0(formatnr(changed_summary$n), " test result", ifelse(changed_summary$n > 1, "s", ""), " changed from ",
paste0('"', changed_summary$old, '"'), " to ", paste0('"', changed_summary$new, '"')), collapse = "\n"))
paste0(
formatnr(changed_summary$n), " test result", ifelse(changed_summary$n > 1, "s", ""), " changed from ",
paste0('"', changed_summary$old, '"'), " to ", paste0('"', changed_summary$new, '"')
),
collapse = "\n"
))
cat("\n")
}
@@ -907,12 +1023,15 @@ eucast_rules <- function(x,
# take order from original data set
warn_lacking_rsi_class <- warn_lacking_rsi_class[order(colnames(x.bak))]
warn_lacking_rsi_class <- warn_lacking_rsi_class[!is.na(warn_lacking_rsi_class)]
warning_("in `eucast_rules()`: not all columns with antimicrobial results are of class <rsi>. Transform them on beforehand, with e.g.:\n",
warning_(
"in `eucast_rules()`: not all columns with antimicrobial results are of class <rsi>. Transform them on beforehand, with e.g.:\n",
" - ", x_deparsed, " %>% as.rsi(", ifelse(length(warn_lacking_rsi_class) == 1,
warn_lacking_rsi_class,
paste0(warn_lacking_rsi_class[1], ":", warn_lacking_rsi_class[length(warn_lacking_rsi_class)])), ")\n",
paste0(warn_lacking_rsi_class[1], ":", warn_lacking_rsi_class[length(warn_lacking_rsi_class)])
), ")\n",
" - ", x_deparsed, " %>% mutate_if(is.rsi.eligible, as.rsi)\n",
" - ", x_deparsed, " %>% mutate(across(where(is.rsi.eligible), as.rsi))")
" - ", x_deparsed, " %>% mutate(across(where(is.rsi.eligible), as.rsi))"
)
}
# Return data set ---------------------------------------------------------
@@ -945,11 +1064,13 @@ edit_rsi <- function(x,
cols <- unique(cols[!is.na(cols) & !is.null(cols)])
# for Verbose Mode, keep track of all changes and return them
track_changes <- list(added = 0,
track_changes <- list(
added = 0,
changed = 0,
output = x,
verbose_info = last_verbose_info,
rsi_warn = character(0))
rsi_warn = character(0)
)
txt_error <- function() {
if (info == TRUE) cat("", font_red_bg(font_white(" ERROR ")), "\n\n")
@@ -972,15 +1093,19 @@ edit_rsi <- function(x,
warning = function(w) {
if (w$message %like% "invalid factor level") {
xyz <- vapply(FUN.VALUE = logical(1), cols, function(col) {
new_edits[, col] <<- factor(x = as.character(pm_pull(new_edits, col)),
levels = unique(c(to, levels(pm_pull(new_edits, col)))))
new_edits[, col] <<- factor(
x = as.character(pm_pull(new_edits, col)),
levels = unique(c(to, levels(pm_pull(new_edits, col))))
)
TRUE
})
suppressWarnings(new_edits[rows, cols] <<- to)
warning_("in `eucast_rules()`: value \"", to, "\" added to the factor levels of column",
warning_(
"in `eucast_rules()`: value \"", to, "\" added to the factor levels of column",
ifelse(length(cols) == 1, "", "s"),
" ", vector_and(cols, quotes = "`", sort = FALSE),
" because this value was not an existing factor level.")
" because this value was not an existing factor level."
)
txt_warning()
warned <- FALSE
} else {
@@ -990,12 +1115,15 @@ edit_rsi <- function(x,
},
error = function(e) {
txt_error()
stop(paste0("In row(s) ", paste(rows[1:min(length(rows), 10)], collapse = ","),
stop(paste0(
"In row(s) ", paste(rows[1:min(length(rows), 10)], collapse = ","),
ifelse(length(rows) > 10, "...", ""),
" while writing value '", to,
"' to column(s) `", paste(cols, collapse = "`, `"),
"`:\n", e$message),
call. = FALSE)
"`:\n", e$message
),
call. = FALSE
)
}
)
@@ -1005,7 +1133,8 @@ edit_rsi <- function(x,
as.integer(rownames(original_data[which(original_data$.rowid %in% rowids), , drop = FALSE]))
}
for (i in seq_len(length(cols))) {
verbose_new <- data.frame(rowid = new_edits[rows, ".rowid", drop = TRUE],
verbose_new <- data.frame(
rowid = new_edits[rows, ".rowid", drop = TRUE],
col = cols[i],
mo_fullname = new_edits[rows, "fullname", drop = TRUE],
old = x[rows, cols[i], drop = TRUE],
@@ -1014,14 +1143,18 @@ edit_rsi <- function(x,
rule_group = font_stripstyle(rule[2]),
rule_name = font_stripstyle(rule[3]),
rule_source = font_stripstyle(rule[4]),
stringsAsFactors = FALSE)
colnames(verbose_new) <- c("rowid", "col", "mo_fullname", "old", "new",
"rule", "rule_group", "rule_name", "rule_source")
stringsAsFactors = FALSE
)
colnames(verbose_new) <- c(
"rowid", "col", "mo_fullname", "old", "new",
"rule", "rule_group", "rule_name", "rule_source"
)
verbose_new <- verbose_new %pm>% pm_filter(old != new | is.na(old) | is.na(new) & !is.na(old))
# save changes to data set 'verbose_info'
track_changes$verbose_info <- rbind(track_changes$verbose_info,
verbose_new,
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
# count adds and changes
track_changes$added <- track_changes$added + verbose_new %pm>%
pm_filter(is.na(old)) %pm>%
@@ -1048,23 +1181,29 @@ eucast_dosage <- function(ab, administration = "iv", version_breakpoints = 11.0)
# show used version_breakpoints number once per session (pkg_env will reload every session)
if (message_not_thrown_before("eucast_dosage", "v", gsub("[^0-9]", "", version_breakpoints), entire_session = TRUE)) {
message_("Dosages for antimicrobial drugs, as meant for ",
message_(
"Dosages for antimicrobial drugs, as meant for ",
format_eucast_version_nr(version_breakpoints, markdown = FALSE), ". ",
font_red("This note will be shown once per session."))
font_red("This note will be shown once per session.")
)
}
ab <- as.ab(ab)
lst <- vector("list", length = length(ab))
for (i in seq_len(length(ab))) {
df <- AMR::dosage[which(AMR::dosage$ab == ab[i] & AMR::dosage$administration == administration), , drop = FALSE]
lst[[i]] <- list(ab = "",
lst[[i]] <- list(
ab = "",
name = "",
standard_dosage = ifelse("standard_dosage" %in% df$type,
df[which(df$type == "standard_dosage"), "original_txt", drop = TRUE],
NA_character_),
NA_character_
),
high_dosage = ifelse("high_dosage" %in% df$type,
df[which(df$type == "high_dosage"), "original_txt", drop = TRUE],
NA_character_))
NA_character_
)
)
}
out <- do.call("rbind", lapply(lst, as.data.frame, stringsAsFactors = FALSE))
rownames(out) <- NULL

150
R/first_isolate.R
View File

@@ -138,14 +138,12 @@
#' # filter on first isolates using dplyr:
#' example_isolates %>%
#' filter(first_isolate())
#'
#' }
#' if (require("dplyr")) {
#'
#' # short-hand version:
#' example_isolates %>%
#' filter_first_isolate(info = FALSE)
#'
#' }
#' if (require("dplyr")) {
#'
@@ -176,7 +174,6 @@ first_isolate <- function(x = NULL,
include_unknown = FALSE,
include_untested_rsi = TRUE,
...) {
dots <- unlist(list(...))
if (length(dots) != 0) {
# backwards compatibility with old arguments
@@ -244,23 +241,30 @@ first_isolate <- function(x = NULL,
# remove data.table, grouping from tibbles, etc.
x <- as.data.frame(x, stringsAsFactors = FALSE)
any_col_contains_rsi <- any(vapply(FUN.VALUE = logical(1),
any_col_contains_rsi <- any(vapply(
FUN.VALUE = logical(1),
X = x,
# check only first 10,000 rows
FUN = function(x) any(as.character(x[1:10000]) %in% c("R", "S", "I"), na.rm = TRUE),
USE.NAMES = FALSE))
USE.NAMES = FALSE
))
if (method == "phenotype-based" & !any_col_contains_rsi) {
method <- "episode-based"
}
if (info == TRUE & message_not_thrown_before("first_isolate", "method")) {
message_(paste0("Determining first isolates ",
message_(paste0(
"Determining first isolates ",
ifelse(method %in% c("episode-based", "phenotype-based"),
ifelse(is.infinite(episode_days),
"without a specified episode length",
paste("using an episode length of", episode_days, "days")),
"")),
paste("using an episode length of", episode_days, "days")
),
""
)
),
as_note = FALSE,
add_fn = font_black)
add_fn = font_black
)
}
# try to find columns based on type
@@ -329,7 +333,9 @@ first_isolate <- function(x = NULL,
check_columns_existance <- function(column, tblname = x) {
if (!is.null(column)) {
stop_ifnot(column %in% colnames(tblname),
"Column '", column, "' not found.", call = FALSE)
"Column '", column, "' not found.",
call = FALSE
)
}
}
@@ -358,7 +364,8 @@ first_isolate <- function(x = NULL,
if (!is.null(testcodes_exclude) & info == TRUE & message_not_thrown_before("first_isolate", "excludingtestcodes")) {
message_("Excluding test codes: ", vector_and(testcodes_exclude, quotes = TRUE),
add_fn = font_black,
as_note = FALSE)
as_note = FALSE
)
}
if (is.null(col_specimen)) {
@@ -371,7 +378,8 @@ first_isolate <- function(x = NULL,
if (info == TRUE & message_not_thrown_before("first_isolate", "excludingspecimen")) {
message_("Excluding other than specimen group '", specimen_group, "'",
add_fn = font_black,
as_note = FALSE)
as_note = FALSE
)
}
}
if (!is.null(col_keyantimicrobials)) {
@@ -384,18 +392,22 @@ first_isolate <- function(x = NULL,
# arrange data to the right sorting
if (is.null(specimen_group)) {
x <- x[order(x$newvar_patient_id,
x <- x[order(
x$newvar_patient_id,
x$newvar_genus_species,
x$newvar_date), ]
x$newvar_date
), ]
rownames(x) <- NULL
row.start <- 1
row.end <- nrow(x)
} else {
# filtering on specimen and only analyse these rows to save time
x <- x[order(pm_pull(x, col_specimen),
x <- x[order(
pm_pull(x, col_specimen),
x$newvar_patient_id,
x$newvar_genus_species,
x$newvar_date), ]
x$newvar_date
), ]
rownames(x) <- NULL
suppressWarnings(
row.start <- which(x %pm>% pm_pull(col_specimen) == specimen_group) %pm>% min(na.rm = TRUE)
@@ -410,7 +422,8 @@ first_isolate <- function(x = NULL,
if (info == TRUE) {
message_("=> Found ", font_bold("no isolates"),
add_fn = font_black,
as_note = FALSE)
as_note = FALSE
)
}
return(rep(FALSE, nrow(x)))
}
@@ -418,7 +431,8 @@ first_isolate <- function(x = NULL,
if (info == TRUE) {
message_("=> Found ", font_bold("1 first isolate"), ", as the data only contained 1 row",
add_fn = font_black,
as_note = FALSE)
as_note = FALSE
)
}
return(TRUE)
}
@@ -427,7 +441,8 @@ first_isolate <- function(x = NULL,
message_("=> Found ", font_bold(paste(length(c(row.start:row.end)), "first isolates")),
", as all isolates were different microbial species",
add_fn = font_black,
as_note = FALSE)
as_note = FALSE
)
}
return(rep(TRUE, length(c(row.start:row.end))))
}
@@ -446,13 +461,15 @@ first_isolate <- function(x = NULL,
ifelse(ignore_I == FALSE, "not ", ""),
"ignoring I",
add_fn = font_black,
as_note = FALSE)
as_note = FALSE
)
}
if (type == "points") {
message_("Basing inclusion on all antimicrobial results, using a points threshold of ",
points_threshold,
add_fn = font_black,
as_note = FALSE)
as_note = FALSE
)
}
}
}
@@ -460,37 +477,48 @@ first_isolate <- function(x = NULL,
x$other_pat_or_mo <- ifelse(x$newvar_patient_id == pm_lag(x$newvar_patient_id) &
x$newvar_genus_species == pm_lag(x$newvar_genus_species),
FALSE,
TRUE)
TRUE
)
x$episode_group <- paste(x$newvar_patient_id, x$newvar_genus_species)
x$more_than_episode_ago <- unlist(lapply(split(x$newvar_date,
x$episode_group),
x$more_than_episode_ago <- unlist(lapply(split(
x$newvar_date,
x$episode_group
),
exec_episode, # this will skip meet_criteria() in is_new_episode(), saving time
type = "logical",
episode_days = episode_days),
use.names = FALSE)
episode_days = episode_days
),
use.names = FALSE
)
if (!is.null(col_keyantimicrobials)) {
# with key antibiotics
x$other_key_ab <- !antimicrobials_equal(y = x$newvar_key_ab,
x$other_key_ab <- !antimicrobials_equal(
y = x$newvar_key_ab,
z = pm_lag(x$newvar_key_ab),
type = type,
ignore_I = ignore_I,
points_threshold = points_threshold)
x$newvar_first_isolate <- pm_if_else(x$newvar_row_index_sorted >= row.start &
points_threshold = points_threshold
)
x$newvar_first_isolate <- pm_if_else(
x$newvar_row_index_sorted >= row.start &
x$newvar_row_index_sorted <= row.end &
x$newvar_genus_species != "" &
(x$other_pat_or_mo | x$more_than_episode_ago | x$other_key_ab),
TRUE,
FALSE)
FALSE
)
} else {
# no key antibiotics
x$newvar_first_isolate <- pm_if_else(x$newvar_row_index_sorted >= row.start &
x$newvar_first_isolate <- pm_if_else(
x$newvar_row_index_sorted >= row.start &
x$newvar_row_index_sorted <= row.end &
x$newvar_genus_species != "" &
(x$other_pat_or_mo | x$more_than_episode_ago),
TRUE,
FALSE)
FALSE
)
}
# first one as TRUE
@@ -503,12 +531,14 @@ first_isolate <- function(x = NULL,
if (icu_exclude == TRUE) {
message_("Excluding ", format(sum(!col_icu, na.rm = TRUE), big.mark = ","), " isolates from ICU.",
add_fn = font_black,
as_note = FALSE)
as_note = FALSE
)
x[which(col_icu), "newvar_first_isolate"] <- FALSE
} else {
message_("Including isolates from ICU.",
add_fn = font_black,
as_note = FALSE)
as_note = FALSE
)
}
}
@@ -533,33 +563,42 @@ first_isolate <- function(x = NULL,
})
message_("\nGroup: ", paste0(names(group), " = ", group, collapse = ", "), "\n",
as_note = FALSE,
add_fn = font_red)
add_fn = font_red
)
}
}
}
# handle empty microorganisms
if (any(x$newvar_mo == "UNKNOWN", na.rm = TRUE) & info == TRUE) {
message_(ifelse(include_unknown == TRUE, "Included ", "Excluded "),
message_(
ifelse(include_unknown == TRUE, "Included ", "Excluded "),
format(sum(x$newvar_mo == "UNKNOWN", na.rm = TRUE),
decimal.mark = decimal.mark, big.mark = big.mark),
" isolates with a microbial ID 'UNKNOWN' (in column '", font_bold(col_mo), "')")
decimal.mark = decimal.mark, big.mark = big.mark
),
" isolates with a microbial ID 'UNKNOWN' (in column '", font_bold(col_mo), "')"
)
}
x[which(x$newvar_mo == "UNKNOWN"), "newvar_first_isolate"] <- include_unknown
# exclude all NAs
if (any(is.na(x$newvar_mo)) & info == TRUE) {
message_("Excluded ", format(sum(is.na(x$newvar_mo), na.rm = TRUE),
decimal.mark = decimal.mark, big.mark = big.mark),
" isolates with a microbial ID 'NA' (in column '", font_bold(col_mo), "')")
message_(
"Excluded ", format(sum(is.na(x$newvar_mo), na.rm = TRUE),
decimal.mark = decimal.mark, big.mark = big.mark
),
" isolates with a microbial ID 'NA' (in column '", font_bold(col_mo), "')"
)
}
x[which(is.na(x$newvar_mo)), "newvar_first_isolate"] <- FALSE
# handle isolates without antibiogram
if (include_untested_rsi == FALSE && any(is.rsi(x))) {
rsi_all_NA <- which(unname(vapply(FUN.VALUE = logical(1),
rsi_all_NA <- which(unname(vapply(
FUN.VALUE = logical(1),
as.data.frame(t(x[, is.rsi(x), drop = FALSE])),
function(rsi_values) all(is.na(rsi_values)))))
function(rsi_values) all(is.na(rsi_values))
)))
x[rsi_all_NA, "newvar_first_isolate"] <- FALSE
}
@@ -579,20 +618,25 @@ first_isolate <- function(x = NULL,
}
# mark up number of found
n_found <- format(n_found, big.mark = big.mark, decimal.mark = decimal.mark)
message_(paste0("=> Found ",
font_bold(paste0(n_found,
message_(paste0(
"=> Found ",
font_bold(paste0(
n_found,
ifelse(method == "isolate-based", "", paste0(" '", method, "'")),
" first isolates")),
" first isolates"
)),
" (",
ifelse(p_found_total != p_found_scope,
paste0(p_found_scope, " within scope and "),
""),
p_found_total, " of total where a microbial ID was available)"),
add_fn = font_black, as_note = FALSE)
""
),
p_found_total, " of total where a microbial ID was available)"
),
add_fn = font_black, as_note = FALSE
)
}
x$newvar_first_isolate
}
#' @rdname first_isolate
@@ -617,13 +661,15 @@ filter_first_isolate <- function(x = NULL,
method <- coerce_method(method)
meet_criteria(method, allow_class = "character", has_length = 1, is_in = c("phenotype-based", "episode-based", "patient-based", "isolate-based"))
subset(x, first_isolate(x = x,
subset(x, first_isolate(
x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
episode_days = episode_days,
method = method,
...))
...
))
}
coerce_method <- function(method) {

76
R/g.test.R
View File

@@ -111,74 +111,92 @@ g.test <- function(x,
p = rep(1 / length(x), length(x)),
rescale.p = FALSE) {
DNAME <- deparse(substitute(x))
if (is.data.frame(x))
if (is.data.frame(x)) {
x <- as.matrix(x)
}
if (is.matrix(x)) {
if (min(dim(x)) == 1L)
if (min(dim(x)) == 1L) {
x <- as.vector(x)
}
}
if (!is.matrix(x) && !is.null(y)) {
if (length(x) != length(y))
if (length(x) != length(y)) {
stop("'x' and 'y' must have the same length")
}
DNAME2 <- deparse(substitute(y))
xname <- if (length(DNAME) > 1L || nchar(DNAME, "w") >
30)
30) {
""
else DNAME
} else {
DNAME
}
yname <- if (length(DNAME2) > 1L || nchar(DNAME2, "w") >
30)
30) {
""
else DNAME2
} else {
DNAME2
}
OK <- complete.cases(x, y)
x <- factor(x[OK])
y <- factor(y[OK])
if ((nlevels(x) < 2L) || (nlevels(y) < 2L))
if ((nlevels(x) < 2L) || (nlevels(y) < 2L)) {
stop("'x' and 'y' must have at least 2 levels")
}
x <- table(x, y)
names(dimnames(x)) <- c(xname, yname)
DNAME <- paste(paste(DNAME, collapse = "\n"), "and",
paste(DNAME2, collapse = "\n"))
DNAME <- paste(
paste(DNAME, collapse = "\n"), "and",
paste(DNAME2, collapse = "\n")
)
}
if (any(x < 0) || any(is.na((x)))) # this last one was anyNA, but only introduced in R 3.1.0
if (any(x < 0) || any(is.na((x)))) { # this last one was anyNA, but only introduced in R 3.1.0
stop("all entries of 'x' must be nonnegative and finite")
if ((n <- sum(x)) == 0)
}
if ((n <- sum(x)) == 0) {
stop("at least one entry of 'x' must be positive")
}
if (is.matrix(x)) {
METHOD <- "G-test of independence"
nr <- as.integer(nrow(x))
nc <- as.integer(ncol(x))
if (is.na(nr) || is.na(nc) || is.na(nr * nc))
if (is.na(nr) || is.na(nc) || is.na(nr * nc)) {
stop("invalid nrow(x) or ncol(x)", domain = NA)
}
# add fisher.test suggestion
if (nr == 2 && nc == 2)
if (nr == 2 && nc == 2) {
warning("`fisher.test()` is always more reliable for 2x2 tables and although much slower, often only takes seconds.")
}
sr <- rowSums(x)
sc <- colSums(x)
E <- outer(sr, sc, "*") / n
v <- function(r, c, n) c * r * (n - r) * (n - c) / n ^ 3
v <- function(r, c, n) c * r * (n - r) * (n - c) / n^3
V <- outer(sr, sc, v, n)
dimnames(E) <- dimnames(x)
STATISTIC <- 2 * sum(x * log(x / E)) # sum((abs(x - E) - YATES)^2/E) for chisq.test
PARAMETER <- (nr - 1L) * (nc - 1L)
PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE)
}
else {
if (length(dim(x)) > 2L)
} else {
if (length(dim(x)) > 2L) {
stop("invalid 'x'")
if (length(x) == 1L)
}
if (length(x) == 1L) {
stop("'x' must at least have 2 elements")
if (length(x) != length(p))
}
if (length(x) != length(p)) {
stop("'x' and 'p' must have the same number of elements")
if (any(p < 0))
}
if (any(p < 0)) {
stop("probabilities must be non-negative.")
}
if (abs(sum(p) - 1) > sqrt(.Machine$double.eps)) {
if (rescale.p)
if (rescale.p) {
p <- p / sum(p)
else stop("probabilities must sum to 1.")
} else {
stop("probabilities must sum to 1.")
}
}
METHOD <- "G-test of goodness-of-fit (likelihood ratio test)"
E <- n * p
@@ -188,15 +206,17 @@ g.test <- function(x,
PARAMETER <- length(x) - 1
PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE)
}
names(STATISTIC) <- "X-squared"
names(PARAMETER) <- "df"
if (any(E < 5) && is.finite(PARAMETER))
if (any(E < 5) && is.finite(PARAMETER)) {
warning("G-statistic approximation may be incorrect due to E < 5")
}
structure(list(statistic = STATISTIC, argument = PARAMETER,
structure(list(
statistic = STATISTIC, argument = PARAMETER,
p.value = PVAL, method = METHOD, data.name = DNAME,
observed = x, expected = E, residuals = (x - E) / sqrt(E),
stdres = (x - E) / sqrt(V)), class = "htest")
stdres = (x - E) / sqrt(V)
), class = "htest")
}

142
R/ggplot_pca.R
View File

@@ -67,8 +67,10 @@
#' if (require("dplyr")) {
#' # calculate the resistance per group first
#' resistance_data <- example_isolates %>%
#' group_by(order = mo_order(mo), # group on anything, like order
#' genus = mo_genus(mo)) %>% # and genus as we do here;
#' group_by(
#' order = mo_order(mo), # group on anything, like order
#' genus = mo_genus(mo)
#' ) %>% # and genus as we do here;
#' filter(n() >= 30) %>% # filter on only 30 results per group
#' summarise_if(is.rsi, resistance) # then get resistance of all drugs
#'
@@ -112,7 +114,6 @@ ggplot_pca <- function(x,
arrows_alpha = 0.75,
base_textsize = 10,
...) {
stop_ifnot_installed("ggplot2")
meet_criteria(x, allow_class = c("prcomp", "princomp", "PCA", "lda"))
meet_criteria(choices, allow_class = c("numeric", "integer"), has_length = 2, is_positive = TRUE, is_finite = TRUE)
@@ -136,7 +137,8 @@ ggplot_pca <- function(x,
meet_criteria(arrows_alpha, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(base_textsize, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
calculations <- pca_calculations(pca_model = x,
calculations <- pca_calculations(
pca_model = x,
groups = groups,
groups_missing = missing(groups),
labels = labels,
@@ -145,7 +147,8 @@ ggplot_pca <- function(x,
scale = scale,
pc.biplot = pc.biplot,
ellipse_prob = ellipse_prob,
labels_text_placement = labels_text_placement)
labels_text_placement = labels_text_placement
)
choices <- calculations$choices
df.u <- calculations$df.u
df.v <- calculations$df.v
@@ -160,10 +163,14 @@ ggplot_pca <- function(x,
} else {
u.axis.labs <- paste0("PC", choices)
}
u.axis.labs <- paste0(u.axis.labs,
paste0("\n(explained var: ",
percentage(x$sdev[choices] ^ 2 / sum(x$sdev ^ 2)),
")"))
u.axis.labs <- paste0(
u.axis.labs,
paste0(
"\n(explained var: ",
percentage(x$sdev[choices]^2 / sum(x$sdev^2)),
")"
)
)
# Score Labels
if (!is.null(labels)) {
@@ -176,87 +183,113 @@ ggplot_pca <- function(x,
}
# Base plot
g <- ggplot2::ggplot(data = df.u,
ggplot2::aes(x = xvar, y = yvar)) +
g <- ggplot2::ggplot(
data = df.u,
ggplot2::aes(x = xvar, y = yvar)
) +
ggplot2::xlab(u.axis.labs[1]) +
ggplot2::ylab(u.axis.labs[2]) +
ggplot2::expand_limits(x = c(-1.15, 1.15),
y = c(-1.15, 1.15))
ggplot2::expand_limits(
x = c(-1.15, 1.15),
y = c(-1.15, 1.15)
)
# Draw either labels or points
if (!is.null(df.u$labels)) {
if (!is.null(df.u$groups)) {
g <- g + ggplot2::geom_point(ggplot2::aes(colour = groups),
alpha = points_alpha,
size = points_size) +
size = points_size
) +
ggplot2::geom_text(ggplot2::aes(label = labels, colour = groups),
nudge_y = -0.05,
size = labels_textsize) +
size = labels_textsize
) +
ggplot2::labs(colour = group_name)
} else {
g <- g + ggplot2::geom_point(alpha = points_alpha,
size = points_size) +
g <- g + ggplot2::geom_point(
alpha = points_alpha,
size = points_size
) +
ggplot2::geom_text(ggplot2::aes(label = labels),
nudge_y = -0.05,
size = labels_textsize)
size = labels_textsize
)
}
} else {
if (!is.null(df.u$groups)) {
g <- g + ggplot2::geom_point(ggplot2::aes(colour = groups),
alpha = points_alpha,
size = points_size) +
size = points_size
) +
ggplot2::labs(colour = group_name)
} else {
g <- g + ggplot2::geom_point(alpha = points_alpha,
size = points_size)
g <- g + ggplot2::geom_point(
alpha = points_alpha,
size = points_size
)
}
}
# Overlay a concentration ellipse if there are groups
if (!is.null(df.u$groups) & !is.null(ell) & isTRUE(ellipse)) {
g <- g + ggplot2::geom_path(data = ell,
g <- g + ggplot2::geom_path(
data = ell,
ggplot2::aes(colour = groups, group = groups),
size = ellipse_size,
alpha = points_alpha)
alpha = points_alpha
)
}
# Label the variable axes
if (arrows == TRUE) {
g <- g + ggplot2::geom_segment(data = df.v,
g <- g + ggplot2::geom_segment(
data = df.v,
ggplot2::aes(x = 0, y = 0, xend = xvar, yend = yvar),
arrow = ggplot2::arrow(length = ggplot2::unit(0.5, "picas"),
arrow = ggplot2::arrow(
length = ggplot2::unit(0.5, "picas"),
angle = 20,
ends = "last",
type = "open"),
type = "open"
),
colour = arrows_colour,
size = arrows_size,
alpha = arrows_alpha)
alpha = arrows_alpha
)
if (arrows_textangled == TRUE) {
g <- g + ggplot2::geom_text(data = df.v,
g <- g + ggplot2::geom_text(
data = df.v,
ggplot2::aes(label = varname, x = xvar, y = yvar, angle = angle, hjust = hjust),
colour = arrows_colour,
size = arrows_textsize,
alpha = arrows_alpha)
alpha = arrows_alpha
)
} else {
g <- g + ggplot2::geom_text(data = df.v,
g <- g + ggplot2::geom_text(
data = df.v,
ggplot2::aes(label = varname, x = xvar, y = yvar, hjust = hjust),
colour = arrows_colour,
size = arrows_textsize,
alpha = arrows_alpha)
alpha = arrows_alpha
)
}
}
# Add caption label about total explained variance
g <- g + ggplot2::labs(caption = paste0("Total explained variance: ",
percentage(sum(x$sdev[choices] ^ 2 / sum(x$sdev ^ 2)))))
g <- g + ggplot2::labs(caption = paste0(
"Total explained variance: ",
percentage(sum(x$sdev[choices]^2 / sum(x$sdev^2)))
))
# mark-up nicely
g <- g + ggplot2::theme_minimal(base_size = base_textsize) +
ggplot2::theme(panel.grid.major = ggplot2::element_line(colour = "grey85"),
ggplot2::theme(
panel.grid.major = ggplot2::element_line(colour = "grey85"),
panel.grid.minor = ggplot2::element_blank(),
# centre title and subtitle
plot.title = ggplot2::element_text(hjust = 0.5),
plot.subtitle = ggplot2::element_text(hjust = 0.5))
plot.subtitle = ggplot2::element_text(hjust = 0.5)
)
g
}
@@ -272,17 +305,19 @@ pca_calculations <- function(pca_model,
pc.biplot = TRUE,
ellipse_prob = 0.68,
labels_text_placement = 1.5) {
non_numeric_cols <- attributes(pca_model)$non_numeric_cols
if (groups_missing) {
groups <- tryCatch(non_numeric_cols[[1]],
error = function(e) NULL)
error = function(e) NULL
)
group_name <- tryCatch(colnames(non_numeric_cols[1]),
error = function(e) NULL)
error = function(e) NULL
)
}
if (labels_missing) {
labels <- tryCatch(non_numeric_cols[[2]],
error = function(e) NULL)
error = function(e) NULL
)
}
if (!is.null(groups) & is.null(labels)) {
# turn them around
@@ -319,13 +354,15 @@ pca_calculations <- function(pca_model,
# Scores
choices <- pmin(choices, ncol(u))
obs.scale <- 1 - as.integer(scale)
df.u <- as.data.frame(sweep(u[, choices], 2, d[choices] ^ obs.scale, FUN = "*"),
stringsAsFactors = FALSE)
df.u <- as.data.frame(sweep(u[, choices], 2, d[choices]^obs.scale, FUN = "*"),
stringsAsFactors = FALSE
)
# Directions
v <- sweep(v, 2, d ^ as.integer(scale), FUN = "*")
v <- sweep(v, 2, d^as.integer(scale), FUN = "*")
df.v <- as.data.frame(v[, choices],
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
names(df.u) <- c("xvar", "yvar")
names(df.v) <- names(df.u)
@@ -337,10 +374,10 @@ pca_calculations <- function(pca_model,
# Scale the radius of the correlation circle so that it corresponds to
# a data ellipse for the standardized PC scores
circle_prob <- 0.69
r <- sqrt(qchisq(circle_prob, df = 2)) * prod(colMeans(df.u ^ 2)) ^ (0.25)
r <- sqrt(qchisq(circle_prob, df = 2)) * prod(colMeans(df.u^2))^(0.25)
# Scale directions
v.scale <- rowSums(v ^ 2)
v.scale <- rowSums(v^2)
df.v <- r * df.v / sqrt(max(v.scale))
# Grouping variable
@@ -361,10 +398,12 @@ pca_calculations <- function(pca_model,
df.groups <- lapply(unique(df.u$groups), function(g, df = df.u) {
x <- df[which(df$groups == g), , drop = FALSE]
if (nrow(x) <= 2) {
return(data.frame(X1 = numeric(0),
return(data.frame(
X1 = numeric(0),
X2 = numeric(0),
groups = character(0),
stringsAsFactors = FALSE))
stringsAsFactors = FALSE
))
}
sigma <- var(cbind(x$xvar, x$yvar))
mu <- c(mean(x$xvar), mean(x$yvar))
@@ -372,9 +411,11 @@ pca_calculations <- function(pca_model,
data.frame(sweep(circle %*% chol(sigma) * ed,
MARGIN = 2,
STATS = mu,
FUN = "+"),
FUN = "+"
),
groups = x$groups[1],
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
})
ell <- do.call(rbind, df.groups)
if (NROW(ell) == 0) {
@@ -386,7 +427,8 @@ pca_calculations <- function(pca_model,
ell <- NULL
}
list(choices = choices,
list(
choices = choices,
df.u = df.u,
df.v = df.v,
ell = ell,

128
R/ggplot_rsi.R
View File

@@ -71,7 +71,6 @@
#' # get antimicrobial results for drugs against a UTI:
#' ggplot(example_isolates %>% select(AMX, NIT, FOS, TMP, CIP)) +
#' geom_rsi()
#'
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
@@ -83,7 +82,6 @@
#' scale_rsi_colours() +
#' labels_rsi_count() +
#' theme_rsi()
#'
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
@@ -91,7 +89,6 @@
#' example_isolates %>%
#' select(AMX, NIT, FOS, TMP, CIP) %>%
#' ggplot_rsi()
#'
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
@@ -99,19 +96,19 @@
#' example_isolates %>%
#' select(AMX, NIT, FOS, TMP, CIP) %>%
#' ggplot_rsi(datalabels = FALSE)
#'
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
#' # add other ggplot2 arguments as you like:
#' example_isolates %>%
#' select(AMX, NIT, FOS, TMP, CIP) %>%
#' ggplot_rsi(width = 0.5,
#' ggplot_rsi(
#' width = 0.5,
#' colour = "black",
#' size = 1,
#' linetype = 2,
#' alpha = 0.25)
#'
#' alpha = 0.25
#' )
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
@@ -119,32 +116,33 @@
#' example_isolates %>%
#' select(AMX) %>%
#' ggplot_rsi(colours = c(SI = "yellow"))
#'
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
#' # but you can also use the built-in colour-blind friendly colours for
#' # your plots, where "S" is green, "I" is yellow and "R" is red:
#' data.frame(x = c("Value1", "Value2", "Value3"),
#' data.frame(
#' x = c("Value1", "Value2", "Value3"),
#' y = c(1, 2, 3),
#' z = c("Value4", "Value5", "Value6")) %>%
#' z = c("Value4", "Value5", "Value6")
#' ) %>%
#' ggplot() +
#' geom_col(aes(x = x, y = y, fill = z)) +
#' scale_rsi_colours(Value4 = "S", Value5 = "I", Value6 = "R")
#'
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
#' # resistance of ciprofloxacine per age group
#' example_isolates %>%
#' mutate(first_isolate = first_isolate()) %>%
#' filter(first_isolate == TRUE,
#' mo == as.mo("Escherichia coli")) %>%
#' filter(
#' first_isolate == TRUE,
#' mo == as.mo("Escherichia coli")
#' ) %>%
#' # age_groups() is also a function in this AMR package:
#' group_by(age_group = age_groups(age)) %>%
#' select(age_group, CIP) %>%
#' ggplot_rsi(x = "age_group")
#'
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
@@ -152,7 +150,6 @@
#' example_isolates %>%
#' select(AMX, NIT, FOS, TMP, CIP) %>%
#' ggplot_rsi(colours = FALSE)
#'
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
@@ -162,12 +159,14 @@
#' # select only UTI-specific drugs
#' select(ward, AMX, NIT, FOS, TMP, CIP) %>%
#' group_by(ward) %>%
#' ggplot_rsi(x = "ward",
#' ggplot_rsi(
#' x = "ward",
#' facet = "antibiotic",
#' nrow = 1,
#' title = "AMR of Anti-UTI Drugs Per Ward",
#' x.title = "Ward",
#' datalabels = FALSE)
#' datalabels = FALSE
#' )
#' }
#' }
ggplot_rsi <- function(data,
@@ -184,11 +183,13 @@ ggplot_rsi <- function(data,
minimum = 30,
language = get_AMR_locale(),
nrow = NULL,
colours = c(S = "#3CAEA3",
colours = c(
S = "#3CAEA3",
SI = "#3CAEA3",
I = "#F6D55C",
IR = "#ED553B",
R = "#ED553B"),
R = "#ED553B"
),
datalabels = TRUE,
datalabels.size = 2.5,
datalabels.colour = "grey15",
@@ -198,7 +199,6 @@ ggplot_rsi <- function(data,
x.title = "Antimicrobial",
y.title = "Proportion",
...) {
stop_ifnot_installed("ggplot2")
meet_criteria(data, allow_class = "data.frame", contains_column_class = "rsi")
meet_criteria(position, allow_class = "character", has_length = 1, is_in = c("fill", "stack", "dodge"), allow_NULL = TRUE)
@@ -247,9 +247,11 @@ ggplot_rsi <- function(data,
}
p <- ggplot2::ggplot(data = data) +
geom_rsi(position = position, x = x, fill = fill, translate_ab = translate_ab,
geom_rsi(
position = position, x = x, fill = fill, translate_ab = translate_ab,
minimum = minimum, language = language,
combine_SI = combine_SI, combine_IR = combine_IR, ...) +
combine_SI = combine_SI, combine_IR = combine_IR, ...
) +
theme_rsi()
if (fill == "interpretation") {
@@ -262,7 +264,8 @@ ggplot_rsi <- function(data,
}
if (datalabels == TRUE) {
p <- p + labels_rsi_count(position = position,
p <- p + labels_rsi_count(
position = position,
x = x,
translate_ab = translate_ab,
minimum = minimum,
@@ -270,18 +273,21 @@ ggplot_rsi <- function(data,
combine_SI = combine_SI,
combine_IR = combine_IR,
datalabels.size = datalabels.size,
datalabels.colour = datalabels.colour)
datalabels.colour = datalabels.colour
)
}
if (!is.null(facet)) {
p <- p + facet_rsi(facet = facet, nrow = nrow)
}
p <- p + ggplot2::labs(title = title,
p <- p + ggplot2::labs(
title = title,
subtitle = subtitle,
caption = caption,
x = x.title,
y = y.title)
y = y.title
)
p
}
@@ -335,12 +341,14 @@ geom_rsi <- function(position = NULL,
ggplot2::geom_col(
data = function(x) {
rsi_df(data = x,
rsi_df(
data = x,
translate_ab = translate_ab,
language = language,
minimum = minimum,
combine_SI = combine_SI,
combine_IR = combine_IR)
combine_IR = combine_IR
)
},
mapping = ggplot2::aes_string(x = x, y = y, fill = fill),
position = position,
@@ -384,9 +392,11 @@ scale_y_percent <- function(breaks = seq(0, 1, 0.1), limits = NULL) {
if (all(breaks[breaks != 0] > 1)) {
breaks <- breaks / 100
}
ggplot2::scale_y_continuous(breaks = breaks,
ggplot2::scale_y_continuous(
breaks = breaks,
labels = percentage(breaks),
limits = limits)
limits = limits
)
}
#' @rdname ggplot_rsi
@@ -397,11 +407,13 @@ scale_rsi_colours <- function(...,
meet_criteria(aesthetics, allow_class = "character", is_in = c("alpha", "colour", "color", "fill", "linetype", "shape", "size"))
# behaviour until AMR pkg v1.5.0 and also when coming from ggplot_rsi()
if ("colours" %in% names(list(...))) {
original_cols <- c(S = "#3CAEA3",
original_cols <- c(
S = "#3CAEA3",
SI = "#3CAEA3",
I = "#F6D55C",
IR = "#ED553B",
R = "#ED553B")
R = "#ED553B"
)
colours <- replace(original_cols, names(list(...)$colours), list(...)$colours)
# limits = force is needed in ggplot2 3.3.4 and 3.3.5, see here;
# https://github.com/tidyverse/ggplot2/issues/4511#issuecomment-866185530
@@ -411,18 +423,32 @@ scale_rsi_colours <- function(...,
return(invisible())
}
names_susceptible <- c("S", "SI", "IS", "S+I", "I+S", "susceptible", "Susceptible",
names_susceptible <- c(
"S", "SI", "IS", "S+I", "I+S", "susceptible", "Susceptible",
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Susceptible"),
"replacement", drop = TRUE]))
names_incr_exposure <- c("I", "intermediate", "increased exposure", "incr. exposure",
"replacement",
drop = TRUE
])
)
names_incr_exposure <- c(
"I", "intermediate", "increased exposure", "incr. exposure",
"Increased exposure", "Incr. exposure", "Susceptible, incr. exp.",
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Intermediate"),
"replacement", drop = TRUE]),
"replacement",
drop = TRUE
]),
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Susceptible, incr. exp."),
"replacement", drop = TRUE]))
names_resistant <- c("R", "IR", "RI", "R+I", "I+R", "resistant", "Resistant",
"replacement",
drop = TRUE
])
)
names_resistant <- c(
"R", "IR", "RI", "R+I", "I+R", "resistant", "Resistant",
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Resistant"),
"replacement", drop = TRUE]))
"replacement",
drop = TRUE
])
)
susceptible <- rep("#3CAEA3", length(names_susceptible))
names(susceptible) <- names_susceptible
@@ -431,7 +457,7 @@ scale_rsi_colours <- function(...,
resistant <- rep("#ED553B", length(names_resistant))
names(resistant) <- names_resistant
original_cols = c(susceptible, incr_exposure, resistant)
original_cols <- c(susceptible, incr_exposure, resistant)
dots <- c(...)
# replace S, I, R as colours: scale_rsi_colours(mydatavalue = "S")
dots[dots == "S"] <- "#3CAEA3"
@@ -448,12 +474,14 @@ scale_rsi_colours <- function(...,
theme_rsi <- function() {
stop_ifnot_installed("ggplot2")
ggplot2::theme_minimal(base_size = 10) +
ggplot2::theme(panel.grid.major.x = ggplot2::element_blank(),
ggplot2::theme(
panel.grid.major.x = ggplot2::element_blank(),
panel.grid.minor = ggplot2::element_blank(),
panel.grid.major.y = ggplot2::element_line(colour = "grey75"),
# center title and subtitle
plot.title = ggplot2::element_text(hjust = 0.5),
plot.subtitle = ggplot2::element_text(hjust = 0.5))
plot.subtitle = ggplot2::element_text(hjust = 0.5)
)
}
#' @rdname ggplot_rsi
@@ -485,26 +513,32 @@ labels_rsi_count <- function(position = NULL,
position <- ggplot2::position_fill(vjust = 0.5, reverse = TRUE)
}
x_name <- x
ggplot2::geom_text(mapping = ggplot2::aes_string(label = "lbl",
ggplot2::geom_text(
mapping = ggplot2::aes_string(
label = "lbl",
x = x,
y = "value"),
y = "value"
),
position = position,
inherit.aes = FALSE,
size = datalabels.size,
colour = datalabels.colour,
lineheight = 0.75,
data = function(x) {
transformed <- rsi_df(data = x,
transformed <- rsi_df(
data = x,
translate_ab = translate_ab,
combine_SI = combine_SI,
combine_IR = combine_IR,
minimum = minimum,
language = language)
language = language
)
transformed$gr <- transformed[, x_name, drop = TRUE]
transformed %pm>%
pm_group_by(gr) %pm>%
pm_mutate(lbl = paste0("n=", isolates)) %pm>%
pm_ungroup() %pm>%
pm_select(-gr)
})
}
)
}

105
R/guess_ab_col.R
View File

@@ -34,8 +34,10 @@
#' @return A column name of `x`, or `NULL` when no result is found.
#' @export
#' @examples
#' df <- data.frame(amox = "S",
#' tetr = "R")
#' df <- data.frame(
#' amox = "S",
#' tetr = "R"
#' )
#'
#' guess_ab_col(df, "amoxicillin")
#' # [1] "amox"
@@ -47,8 +49,10 @@
#' # [1] "tetr"
#'
#' # WHONET codes
#' df <- data.frame(AMP_ND10 = "R",
#' AMC_ED20 = "S")
#' df <- data.frame(
#' AMP_ND10 = "R",
#' AMC_ED20 = "S"
#' )
#' guess_ab_col(df, "ampicillin")
#' # [1] "AMP_ND10"
#' guess_ab_col(df, "J01CR02")
@@ -57,8 +61,10 @@
#' # [1] "AMC_ED20"
#'
#' # Longer names take precendence:
#' df <- data.frame(AMP_ED2 = "S",
#' AMP_ED20 = "S")
#' df <- data.frame(
#' AMP_ED2 = "S",
#' AMP_ED20 = "S"
#' )
#' guess_ab_col(df, "ampicillin")
#' # [1] "AMP_ED20"
guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE, only_rsi_columns = FALSE) {
@@ -73,8 +79,10 @@ guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE, only_r
meet_criteria(search_string, allow_class = "character", has_length = 1, allow_NULL = FALSE)
}
all_found <- get_column_abx(x, info = verbose, only_rsi_columns = only_rsi_columns,
verbose = verbose, fn = "guess_ab_col")
all_found <- get_column_abx(x,
info = verbose, only_rsi_columns = only_rsi_columns,
verbose = verbose, fn = "guess_ab_col"
)
search_string.ab <- suppressWarnings(as.ab(search_string))
ab_result <- unname(all_found[names(all_found) == search_string.ab])
@@ -83,13 +91,16 @@ guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE, only_r
message_("No column found as input for ", search_string,
" (", ab_name(search_string, language = NULL, tolower = TRUE), ").",
add_fn = font_black,
as_note = FALSE)
as_note = FALSE
)
}
return(NULL)
} else {
if (verbose == TRUE) {
message_("Using column '", font_bold(ab_result), "' as input for ", search_string,
" (", ab_name(search_string, language = NULL, tolower = TRUE), ").")
message_(
"Using column '", font_bold(ab_result), "' as input for ", search_string,
" (", ab_name(search_string, language = NULL, tolower = TRUE), ")."
)
}
return(ab_result)
}
@@ -106,9 +117,13 @@ get_column_abx <- function(x,
reuse_previous_result = TRUE,
fn = NULL) {
# check if retrieved before, then get it from package environment
if (isTRUE(reuse_previous_result) && identical(unique_call_id(entire_session = FALSE,
match_fn = fn),
pkg_env$get_column_abx.call)) {
if (isTRUE(reuse_previous_result) && identical(
unique_call_id(
entire_session = FALSE,
match_fn = fn
),
pkg_env$get_column_abx.call
)) {
# so within the same call, within the same environment, we got here again.
# but we could've come from another function within the same call, so now only check the columns that changed
@@ -157,7 +172,8 @@ get_column_abx <- function(x,
if (info == TRUE) {
message_(" (using only ", font_bold("the first 10,000 rows"), ")...",
appendLF = FALSE,
as_note = FALSE)
as_note = FALSE
)
}
x <- x[1:10000, , drop = FALSE]
} else if (info == TRUE) {
@@ -169,7 +185,8 @@ get_column_abx <- function(x,
# and that they have no more than 50% invalid values
vectr_antibiotics <- unlist(AB_lookup$generalised_all)
vectr_antibiotics <- vectr_antibiotics[!is.na(vectr_antibiotics) & nchar(vectr_antibiotics) >= 3]
x_columns <- vapply(FUN.VALUE = character(1),
x_columns <- vapply(
FUN.VALUE = character(1),
colnames(x),
function(col, df = x) {
if (generalise_antibiotic_name(col) %in% vectr_antibiotics ||
@@ -180,13 +197,16 @@ get_column_abx <- function(x,
} else {
return(NA_character_)
}
}, USE.NAMES = FALSE)
}, USE.NAMES = FALSE
)
x_columns <- x_columns[!is.na(x_columns)]
x <- x[, x_columns, drop = FALSE] # without drop = FALSE, x will become a vector when x_columns is length 1
df_trans <- data.frame(colnames = colnames(x),
df_trans <- data.frame(
colnames = colnames(x),
abcode = suppressWarnings(as.ab(colnames(x), info = FALSE)),
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
df_trans <- df_trans[!is.na(df_trans$abcode), , drop = FALSE]
out <- as.character(df_trans$colnames)
names(out) <- df_trans$abcode
@@ -205,7 +225,8 @@ get_column_abx <- function(x,
}
warning_("Invalid antibiotic reference(s): ", vector_and(names(dots)[is.na(newnames)], quotes = FALSE),
call = FALSE,
immediate = TRUE)
immediate = TRUE
)
all_okay <- FALSE
}
unexisting_cols <- which(!vapply(FUN.VALUE = logical(1), dots, function(col) all(col %in% x_columns)))
@@ -214,7 +235,8 @@ get_column_abx <- function(x,
message_(" ERROR", add_fn = list(font_red, font_bold), as_note = FALSE)
}
stop_("Column(s) not found: ", vector_and(unlist(dots[[unexisting_cols]]), quotes = FALSE),
call = FALSE)
call = FALSE
)
all_okay <- FALSE
}
# turn all NULLs to NAs
@@ -255,17 +277,22 @@ get_column_abx <- function(x,
}
for (i in seq_len(length(out))) {
if (verbose == TRUE & !names(out[i]) %in% names(duplicates)) {
message_("Using column '", font_bold(out[i]), "' as input for ", names(out)[i],
" (", ab_name(names(out)[i], tolower = TRUE, language = NULL), ").")
message_(
"Using column '", font_bold(out[i]), "' as input for ", names(out)[i],
" (", ab_name(names(out)[i], tolower = TRUE, language = NULL), ")."
)
}
if (names(out[i]) %in% names(duplicates)) {
already_set_as <- out[unname(out) == unname(out[i])][1L]
warning_(paste0("Column '", font_bold(out[i]), "' will not be used for ",
warning_(paste0(
"Column '", font_bold(out[i]), "' will not be used for ",
names(out)[i], " (", ab_name(names(out)[i], tolower = TRUE, language = NULL), ")",
", as it is already set for ",
names(already_set_as), " (", ab_name(names(already_set_as), tolower = TRUE, language = NULL), ")"),
names(already_set_as), " (", ab_name(names(already_set_as), tolower = TRUE, language = NULL), ")"
),
add_fn = font_red,
immediate = verbose)
immediate = verbose
)
}
}
}
@@ -290,11 +317,16 @@ get_column_abx <- function(x,
if (info == TRUE & !all(soft_dependencies %in% names(out))) {
# missing a soft dependency may lower the reliability
missing <- soft_dependencies[!soft_dependencies %in% names(out)]
missing_msg <- vector_and(paste0(ab_name(missing, tolower = TRUE, language = NULL),
" (", font_bold(missing, collapse = NULL), ")"),
quotes = FALSE)
message_("Reliability would be improved if these antimicrobial results would be available too: ",
missing_msg)
missing_msg <- vector_and(paste0(
ab_name(missing, tolower = TRUE, language = NULL),
" (", font_bold(missing, collapse = NULL), ")"
),
quotes = FALSE
)
message_(
"Reliability would be improved if these antimicrobial results would be available too: ",
missing_msg
)
}
}
@@ -311,7 +343,7 @@ get_ab_from_namespace <- function(x, cols_ab) {
x_new <- character()
for (val in x) {
if (paste0("AB_", val) %in% ls(envir = asNamespace("AMR"))) {
# antibiotic group names, as defined in data-raw/pre-commit-hook.R, such as `AB_CARBAPENEMS`
# antibiotic group names, as defined in data-raw/_pre_commit_hook.R, such as `AB_CARBAPENEMS`
val <- eval(parse(text = paste0("AB_", val)), envir = asNamespace("AMR"))
} else if (val %in% AB_lookup$ab) {
# separate drugs, such as `AMX`
@@ -333,7 +365,10 @@ generate_warning_abs_missing <- function(missing, any = FALSE) {
} else {
any_txt <- c("", "are")
}
warning_(paste0("Introducing NAs since", any_txt[1], " these antimicrobials ", any_txt[2], " required: ",
vector_and(missing, quotes = FALSE)),
immediate = TRUE)
warning_(paste0(
"Introducing NAs since", any_txt[1], " these antimicrobials ", any_txt[2], " required: ",
vector_and(missing, quotes = FALSE)
),
immediate = TRUE
)
}

35
R/italicise_taxonomy.R
View File

@@ -58,7 +58,8 @@ italicise_taxonomy <- function(string, type = c("markdown", "ansi")) {
after <- "\033[23m"
}
vapply(FUN.VALUE = character(1),
vapply(
FUN.VALUE = character(1),
string,
function(s) {
s_split <- unlist(strsplit(s, " "))
@@ -66,32 +67,43 @@ italicise_taxonomy <- function(string, type = c("markdown", "ansi")) {
search_strings <- gsub("[^a-zA-Z-]", "", s_split)
ind_species <- search_strings != "" &
search_strings %in% MO_lookup[which(MO_lookup$rank %in% c("family",
search_strings %in% MO_lookup[which(MO_lookup$rank %in% c(
"family",
"genus",
"species",
"subspecies",
"infraspecies",
"subsp.")),
"subsp."
)),
"species",
drop = TRUE]
drop = TRUE
]
ind_fullname <- search_strings != "" &
search_strings %in% c(MO_lookup[which(MO_lookup$rank %in% c("family",
search_strings %in% c(
MO_lookup[which(MO_lookup$rank %in% c(
"family",
"genus",
"species",
"subspecies",
"infraspecies",
"subsp.")),
"subsp."
)),
"fullname",
drop = TRUE],
MO_lookup[which(MO_lookup$rank %in% c("family",
drop = TRUE
],
MO_lookup[which(MO_lookup$rank %in% c(
"family",
"genus",
"species",
"subspecies",
"infraspecies",
"subsp.")),
"subsp."
)),
"subspecies",
drop = TRUE])
drop = TRUE
]
)
# also support E. coli, add "E." to indices
has_previous_genera_abbr <- s_split[which(ind_species) - 1] %like_case% "^[A-Z][.]?$"
@@ -107,7 +119,8 @@ italicise_taxonomy <- function(string, type = c("markdown", "ansi")) {
s_paste
},
USE.NAMES = FALSE)
USE.NAMES = FALSE
)
}
#' @rdname italicise_taxonomy

16
R/join_microorganisms.R
View File

@@ -42,12 +42,18 @@
#' left_join_microorganisms(as.mo("K. pneumoniae"))
#' left_join_microorganisms("B_KLBSL_PNMN")
#'
#' df <- data.frame(date = seq(from = as.Date("2018-01-01"),
#' df <- data.frame(
#' date = seq(
#' from = as.Date("2018-01-01"),
#' to = as.Date("2018-01-07"),
#' by = 1),
#' bacteria = as.mo(c("S. aureus", "MRSA", "MSSA", "STAAUR",
#' "E. coli", "E. coli", "E. coli")),
#' stringsAsFactors = FALSE)
#' by = 1
#' ),
#' bacteria = as.mo(c(
#' "S. aureus", "MRSA", "MSSA", "STAAUR",
#' "E. coli", "E. coli", "E. coli"
#' )),
#' stringsAsFactors = FALSE
#' )
#' colnames(df)
#'
#' df_joined <- left_join_microorganisms(df, "bacteria")

93
R/key_antimicrobials.R
View File

@@ -115,14 +115,22 @@
#' }
key_antimicrobials <- function(x = NULL,
col_mo = NULL,
universal = c("ampicillin", "amoxicillin/clavulanic acid", "cefuroxime",
"piperacillin/tazobactam", "ciprofloxacin", "trimethoprim/sulfamethoxazole"),
gram_negative = c("gentamicin", "tobramycin", "colistin",
"cefotaxime", "ceftazidime", "meropenem"),
gram_positive = c("vancomycin", "teicoplanin", "tetracycline",
"erythromycin", "oxacillin", "rifampin"),
antifungal = c("anidulafungin", "caspofungin", "fluconazole",
"miconazole", "nystatin", "voriconazole"),
universal = c(
"ampicillin", "amoxicillin/clavulanic acid", "cefuroxime",
"piperacillin/tazobactam", "ciprofloxacin", "trimethoprim/sulfamethoxazole"
),
gram_negative = c(
"gentamicin", "tobramycin", "colistin",
"cefotaxime", "ceftazidime", "meropenem"
),
gram_positive = c(
"vancomycin", "teicoplanin", "tetracycline",
"erythromycin", "oxacillin", "rifampin"
),
antifungal = c(
"anidulafungin", "caspofungin", "fluconazole",
"miconazole", "nystatin", "voriconazole"
),
only_rsi_columns = FALSE,
...) {
if (is_null_or_grouped_tbl(x)) {
@@ -170,11 +178,14 @@ key_antimicrobials <- function(x = NULL,
if (values_new_length < values_old_length &
any(filter, na.rm = TRUE) &
message_not_thrown_before("key_antimicrobials", name)) {
warning_("in `key_antimicrobials()`: ",
warning_(
"in `key_antimicrobials()`: ",
ifelse(values_new_length == 0,
"No columns available ",
paste0("Only using ", values_new_length, " out of ", values_old_length, " defined columns ")),
"as key antimicrobials for ", name, "s. See ?key_antimicrobials.")
paste0("Only using ", values_new_length, " out of ", values_old_length, " defined columns ")
),
"as key antimicrobials for ", name, "s. See ?key_antimicrobials."
)
}
generate_antimcrobials_string(x[which(filter), c(universal, values), drop = FALSE])
@@ -189,30 +200,38 @@ key_antimicrobials <- function(x = NULL,
key_ab <- rep(NA_character_, nrow(x))
key_ab[which(gramstain == "Gram-negative")] <- AMR_string(x = x,
key_ab[which(gramstain == "Gram-negative")] <- AMR_string(
x = x,
values = gram_negative,
name = "Gram-negative",
filter = gramstain == "Gram-negative",
cols = cols)
cols = cols
)
key_ab[which(gramstain == "Gram-positive")] <- AMR_string(x = x,
key_ab[which(gramstain == "Gram-positive")] <- AMR_string(
x = x,
values = gram_positive,
name = "Gram-positive",
filter = gramstain == "Gram-positive",
cols = cols)
cols = cols
)
key_ab[which(kingdom == "Fungi")] <- AMR_string(x = x,
key_ab[which(kingdom == "Fungi")] <- AMR_string(
x = x,
values = antifungal,
name = "antifungal",
filter = kingdom == "Fungi",
cols = cols)
cols = cols
)
# back-up - only use `universal`
key_ab[which(is.na(key_ab))] <- AMR_string(x = x,
key_ab[which(is.na(key_ab))] <- AMR_string(
x = x,
values = character(0),
name = "",
filter = is.na(key_ab),
cols = cols)
cols = cols
)
if (length(unique(key_ab)) == 1) {
warning_("in `key_antimicrobials()`: no distinct key antibiotics determined.")
@@ -236,10 +255,12 @@ all_antimicrobials <- function(x = NULL,
# force regular data.frame, not a tibble or data.table
x <- as.data.frame(x, stringsAsFactors = FALSE)
cols <- get_column_abx(x, only_rsi_columns = only_rsi_columns, info = FALSE,
sort = FALSE, fn = "all_antimicrobials")
cols <- get_column_abx(x,
only_rsi_columns = only_rsi_columns, info = FALSE,
sort = FALSE, fn = "all_antimicrobials"
)
generate_antimcrobials_string(x[ , cols, drop = FALSE])
generate_antimcrobials_string(x[, cols, drop = FALSE])
}
generate_antimcrobials_string <- function(df) {
@@ -249,16 +270,22 @@ generate_antimcrobials_string <- function(df) {
if (NROW(df) == 0) {
return(character(0))
}
tryCatch({
do.call(paste0,
lapply(as.list(df),
tryCatch(
{
do.call(
paste0,
lapply(
as.list(df),
function(x) {
x <- toupper(as.character(x))
x[!x %in% c("R", "S", "I")] <- "."
paste(x)
}))
}
)
)
},
error = function(e) rep(strrep(".", NCOL(df)), NROW(df)))
error = function(e) rep(strrep(".", NCOL(df)), NROW(df))
)
}
#' @rdname key_antimicrobials
@@ -320,14 +347,18 @@ antimicrobials_equal <- function(y,
all(a == b, na.rm = TRUE)
}
}
out <- unlist(mapply(FUN = determine_equality,
out <- unlist(mapply(
FUN = determine_equality,
y,
z,
MoreArgs = list(type = type,
MoreArgs = list(
type = type,
points_threshold = points_threshold,
ignore_I = ignore_I),
ignore_I = ignore_I
),
SIMPLIFY = FALSE,
USE.NAMES = FALSE))
USE.NAMES = FALSE
))
out[is.na(y) | is.na(z)] <- NA
out
}

14
R/like.R
View File

@@ -52,7 +52,7 @@
#'
#' # also supports multiple patterns
#' a <- c("Test case", "Something different", "Yet another thing")
#' b <- c( "case", "diff", "yet")
#' b <- c("case", "diff", "yet")
#' a %like% b
#' a %unlike% b
#'
@@ -96,18 +96,22 @@ like <- function(x, pattern, ignore.case = TRUE) {
if (length(x) == 1) {
x <- rep(x, length(pattern))
} else if (length(pattern) != length(x)) {
stop_("arguments `x` and `pattern` must be of same length, or either one must be 1 ",
"(`x` has length ", length(x), " and `pattern` has length ", length(pattern), ")")
stop_(
"arguments `x` and `pattern` must be of same length, or either one must be 1 ",
"(`x` has length ", length(x), " and `pattern` has length ", length(pattern), ")"
)
}
unlist(
mapply(FUN = grepl,
mapply(
FUN = grepl,
x = x,
pattern = pattern,
fixed = fixed,
perl = !fixed,
MoreArgs = list(ignore.case = FALSE),
SIMPLIFY = FALSE,
USE.NAMES = FALSE)
USE.NAMES = FALSE
)
)
}
}

975
R/mdro.R
View File

File diff suppressed because it is too large Load Diff

93
R/mic.R
View File

@@ -25,20 +25,42 @@
# these are allowed MIC values and will become [factor] levels
ops <- c("<", "<=", "", ">=", ">")
valid_mic_levels <- c(c(t(vapply(FUN.VALUE = character(9), ops,
function(x) paste0(x, "0.00", 1:9)))),
unique(c(t(vapply(FUN.VALUE = character(104), ops,
function(x) paste0(x, sort(as.double(paste0("0.0",
sort(c(1:99, 125, 128, 256, 512, 625)))))))))),
unique(c(t(vapply(FUN.VALUE = character(103), ops,
function(x) paste0(x, sort(as.double(paste0("0.",
c(1:99, 125, 128, 256, 512))))))))),
c(t(vapply(FUN.VALUE = character(10), ops,
function(x) paste0(x, sort(c(1:9, 1.5)))))),
c(t(vapply(FUN.VALUE = character(45), ops,
function(x) paste0(x, c(10:98)[9:98 %% 2 == TRUE])))),
c(t(vapply(FUN.VALUE = character(17), ops,
function(x) paste0(x, sort(c(2 ^ c(7:11), 192, 80 * c(2:12))))))))
valid_mic_levels <- c(
c(t(vapply(
FUN.VALUE = character(9), ops,
function(x) paste0(x, "0.00", 1:9)
))),
unique(c(t(vapply(
FUN.VALUE = character(104), ops,
function(x) {
paste0(x, sort(as.double(paste0(
"0.0",
sort(c(1:99, 125, 128, 256, 512, 625))
))))
}
)))),
unique(c(t(vapply(
FUN.VALUE = character(103), ops,
function(x) {
paste0(x, sort(as.double(paste0(
"0.",
c(1:99, 125, 128, 256, 512)
))))
}
)))),
c(t(vapply(
FUN.VALUE = character(10), ops,
function(x) paste0(x, sort(c(1:9, 1.5)))
))),
c(t(vapply(
FUN.VALUE = character(45), ops,
function(x) paste0(x, c(10:98)[9:98 %% 2 == TRUE])
))),
c(t(vapply(
FUN.VALUE = character(17), ops,
function(x) paste0(x, sort(c(2^c(7:11), 192, 80 * c(2:12))))
)))
)
#' Transform Input to Minimum Inhibitory Concentrations (MIC)
#'
@@ -108,14 +130,18 @@ valid_mic_levels <- c(c(t(vapply(FUN.VALUE = character(9), ops,
#' all(mic_data < 512)
#'
#' # interpret MIC values
#' as.rsi(x = as.mic(2),
#' as.rsi(
#' x = as.mic(2),
#' mo = as.mo("Streptococcus pneumoniae"),
#' ab = "AMX",
#' guideline = "EUCAST")
#' as.rsi(x = as.mic(c(0.01, 2, 4, 8)),
#' guideline = "EUCAST"
#' )
#' as.rsi(
#' x = as.mic(c(0.01, 2, 4, 8)),
#' mo = as.mo("Streptococcus pneumoniae"),
#' ab = "AMX",
#' guideline = "EUCAST")
#' guideline = "EUCAST"
#' )
#'
#' # plot MIC values, see ?plot
#' plot(mic_data)
@@ -193,11 +219,14 @@ as.mic <- function(x, na.rm = FALSE) {
warning_("in `as.mic()`: ", na_after - na_before, " results truncated (",
round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid MICs: ",
list_missing, call = FALSE)
list_missing,
call = FALSE
)
}
set_clean_class(factor(x, levels = valid_mic_levels, ordered = TRUE),
new_class = c("mic", "ordered", "factor"))
new_class = c("mic", "ordered", "factor")
)
}
}
@@ -206,7 +235,8 @@ all_valid_mics <- function(x) {
return(FALSE)
}
x_mic <- tryCatch(suppressWarnings(as.mic(x[!is.na(x)])),
error = function(e) NA)
error = function(e) NA
)
!any(is.na(x_mic)) && !all(is.na(x))
}
@@ -215,7 +245,8 @@ all_valid_mics <- function(x) {
#' @format NULL
#' @export
NA_mic_ <- set_clean_class(factor(NA, levels = valid_mic_levels, ordered = TRUE),
new_class = c("mic", "ordered", "factor"))
new_class = c("mic", "ordered", "factor")
)
#' @rdname as.mic
#' @export
@@ -272,7 +303,9 @@ type_sum.mic <- function(x, ...) {
print.mic <- function(x, ...) {
cat("Class <mic>",
ifelse(length(levels(x)) < length(valid_mic_levels), font_red(" with dropped levels"), ""),
"\n", sep = "")
"\n",
sep = ""
)
print(as.character(x), quote = FALSE)
att <- attributes(x)
if ("na.action" %in% names(att)) {
@@ -378,12 +411,12 @@ hist.mic <- function(x, ...) {
get_skimmers.mic <- function(column) {
skimr::sfl(
skim_type = "mic",
p0 = ~stats::quantile(., probs = 0, na.rm = TRUE, names = FALSE),
p25 = ~stats::quantile(., probs = 0.25, na.rm = TRUE, names = FALSE),
p50 = ~stats::quantile(., probs = 0.5, na.rm = TRUE, names = FALSE),
p75 = ~stats::quantile(., probs = 0.75, na.rm = TRUE, names = FALSE),
p100 = ~stats::quantile(., probs = 1, na.rm = TRUE, names = FALSE),
hist = ~skimr::inline_hist(log2(stats::na.omit(.)), 5)
p0 = ~ stats::quantile(., probs = 0, na.rm = TRUE, names = FALSE),
p25 = ~ stats::quantile(., probs = 0.25, na.rm = TRUE, names = FALSE),
p50 = ~ stats::quantile(., probs = 0.5, na.rm = TRUE, names = FALSE),
p75 = ~ stats::quantile(., probs = 0.75, na.rm = TRUE, names = FALSE),
p100 = ~ stats::quantile(., probs = 1, na.rm = TRUE, names = FALSE),
hist = ~ skimr::inline_hist(log2(stats::na.omit(.)), 5)
)
}
@@ -679,7 +712,7 @@ is_lower <- function(el) {
#' @export
#' @noRd
`^.mic` <- function(e1, e2) {
as.double(e1) ^ as.double(e2)
as.double(e1)^as.double(e2)
}
#' @method %% mic

682
R/mo.R
View File

File diff suppressed because it is too large Load Diff

16
R/mo_matching_score.R
View File

@@ -56,8 +56,10 @@
#' as.mo("E. coli")
#' mo_uncertainties()
#'
#' mo_matching_score(x = "E. coli",
#' n = c("Escherichia coli", "Entamoeba coli"))
#' mo_matching_score(
#' x = "E. coli",
#' n = c("Escherichia coli", "Entamoeba coli")
#' )
mo_matching_score <- function(x, n) {
meet_criteria(x, allow_class = c("character", "data.frame", "list"))
meet_criteria(n, allow_class = "character")
@@ -67,10 +69,14 @@ mo_matching_score <- function(x, n) {
x <- gsub("[^a-zA-Z0-9 \\(\\)]+", "", x)
# remove abbreviations known to the field
x <- gsub(paste0("(^|[^a-z0-9]+)(",
x <- gsub(paste0(
"(^|[^a-z0-9]+)(",
paste0(pkg_env$mo_field_abbreviations, collapse = "|"),
")([^a-z0-9]+|$)"),
"", x, perl = TRUE, ignore.case = TRUE)
")([^a-z0-9]+|$)"
),
"", x,
perl = TRUE, ignore.case = TRUE
)
# only keep one space
x <- gsub(" +", " ", x)

54
R/mo_property.R
View File

@@ -140,10 +140,12 @@
#'
#' mo_fullname("S. pyogenes",
#' Lancefield = TRUE,
#' language = "de")
#' language = "de"
#' )
#' mo_fullname("S. pyogenes",
#' Lancefield = TRUE,
#' language = "nl")
#' language = "nl"
#' )
#'
#'
#' # other --------------------------------------------------------------------
@@ -178,7 +180,8 @@ mo_name <- function(x, language = get_AMR_locale(), ...) {
translate_into_language(mo_validate(x = x, property = "fullname", language = language, ...),
language = language,
only_unknown = FALSE,
only_affect_mo_names = TRUE)
only_affect_mo_names = TRUE
)
}
#' @rdname mo_property
@@ -367,10 +370,12 @@ mo_gramstain <- function(x, language = get_AMR_locale(), ...) {
x[mo_kingdom(x.mo) == "Bacteria"] <- "Gram-negative"
# overwrite these 4 phyla with Gram-positives
# Source: https://itis.gov/servlet/SingleRpt/SingleRpt?search_topic=TSN&search_value=956097 (Cavalier-Smith, 2002)
x[(mo_phylum(x.mo) %in% c("Actinobacteria",
x[(mo_phylum(x.mo) %in% c(
"Actinobacteria",
"Chloroflexi",
"Firmicutes",
"Tenericutes") &
"Tenericutes"
) &
# but class Negativicutes (of phylum Firmicutes) are Gram-negative!
mo_class(x.mo) != "Negativicutes")
# and of course our own ID for Gram-positives
@@ -467,9 +472,11 @@ mo_is_intrinsic_resistant <- function(x, ab, language = get_AMR_locale(), ...) {
# show used version number once per session (pkg_env will reload every session)
if (message_not_thrown_before("mo_is_intrinsic_resistant", "version.mo", entire_session = TRUE)) {
message_("Determining intrinsic resistance based on ",
message_(
"Determining intrinsic resistance based on ",
format_eucast_version_nr(3.3, markdown = FALSE), ". ",
font_red("This note will be shown once per session."))
font_red("This note will be shown once per session.")
)
}
# runs against internal vector: INTRINSIC_R (see zzz.R)
@@ -573,14 +580,16 @@ mo_taxonomy <- function(x, language = get_AMR_locale(), ...) {
x <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
out <- list(kingdom = mo_kingdom(x, language = language),
out <- list(
kingdom = mo_kingdom(x, language = language),
phylum = mo_phylum(x, language = language),
class = mo_class(x, language = language),
order = mo_order(x, language = language),
family = mo_family(x, language = language),
genus = mo_genus(x, language = language),
species = mo_species(x, language = language),
subspecies = mo_subspecies(x, language = language))
subspecies = mo_subspecies(x, language = language)
)
load_mo_failures_uncertainties_renamed(metadata)
out
@@ -632,13 +641,18 @@ mo_info <- function(x, language = get_AMR_locale(), ...) {
x <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
info <- lapply(x, function(y)
c(mo_taxonomy(y, language = language),
list(synonyms = mo_synonyms(y),
info <- lapply(x, function(y) {
c(
mo_taxonomy(y, language = language),
list(
synonyms = mo_synonyms(y),
gramstain = mo_gramstain(y, language = language),
url = unname(mo_url(y, open = FALSE)),
ref = mo_ref(y),
snomed = unlist(mo_snomed(y)))))
snomed = unlist(mo_snomed(y))
)
)
})
if (length(info) > 1) {
names(info) <- mo_name(x)
result <- info
@@ -667,7 +681,8 @@ mo_url <- function(x, open = FALSE, language = get_AMR_locale(), ...) {
df <- microorganisms[match(x.mo, microorganisms$mo), c("mo", "fullname", "source", "kingdom", "rank"), drop = FALSE]
df$url <- ifelse(df$source == "LPSN",
paste0(CATALOGUE_OF_LIFE$url_LPSN, "/species/", gsub(" ", "-", tolower(df$fullname), fixed = TRUE)),
paste0(CATALOGUE_OF_LIFE$url_CoL, "/data/search?type=EXACT&q=", gsub(" ", "%20", df$fullname, fixed = TRUE)))
paste0(CATALOGUE_OF_LIFE$url_CoL, "/data/search?type=EXACT&q=", gsub(" ", "%20", df$fullname, fixed = TRUE))
)
genera <- which(df$kingdom == "Bacteria" & df$rank == "genus")
df$url[genera] <- gsub("/species/", "/genus/", df$url[genera], fixed = TRUE)
@@ -719,12 +734,12 @@ mo_validate <- function(x, property, language, ...) {
if (tryCatch(all(x[!is.na(x)] %in% MO_lookup$mo) & !has_Becker_or_Lancefield, error = function(e) FALSE)) {
# special case for mo_* functions where class is already <mo>
x <- MO_lookup[match(x, MO_lookup$mo), property, drop = TRUE]
} else {
# try to catch an error when inputting an invalid argument
# so the 'call.' can be set to FALSE
tryCatch(x[1L] %in% MO_lookup[1, property, drop = TRUE],
error = function(e) stop(e$message, call. = FALSE))
error = function(e) stop(e$message, call. = FALSE)
)
if (!all(x[!is.na(x)] %in% MO_lookup[, property, drop = TRUE]) | has_Becker_or_Lancefield) {
x <- exec_as.mo(x, property = property, language = language, ...)
@@ -747,9 +762,12 @@ find_mo_col <- function(fn) {
# which is useful when functions are used within dplyr verbs
df <- get_current_data(arg_name = "x", call = -3) # will return an error if not found
mo <- NULL
try({
try(
{
mo <- suppressMessages(search_type_in_df(df, "mo"))
}, silent = TRUE)
},
silent = TRUE
)
if (!is.null(df) && !is.null(mo) && is.data.frame(df)) {
if (message_not_thrown_before(fn = fn)) {
message_("Using column '", font_bold(mo), "' as input for `", fn, "()`")

35
R/mo_source.R
View File

@@ -135,7 +135,8 @@ set_mo_source <- function(path, destination = getOption("AMR_mo_source", "~/mo_s
unlink(mo_source_destination)
message_("Removed mo_source file '", font_bold(mo_source_destination), "'",
add_fn = font_red,
as_note = FALSE)
as_note = FALSE
)
}
return(invisible())
}
@@ -145,34 +146,33 @@ set_mo_source <- function(path, destination = getOption("AMR_mo_source", "~/mo_s
df <- NULL
if (path %like% "[.]rds$") {
df <- readRDS(path)
} else if (path %like% "[.]xlsx?$") {
# is Excel file (old or new)
stop_ifnot_installed("readxl")
df <- readxl::read_excel(path)
} else if (path %like% "[.]tsv$") {
df <- utils::read.table(file = path, header = TRUE, sep = "\t", stringsAsFactors = FALSE)
} else if (path %like% "[.]csv$") {
df <- utils::read.table(file = path, header = TRUE, sep = ",", stringsAsFactors = FALSE)
} else {
# try comma first
try(
df <- utils::read.table(file = path, header = TRUE, sep = ",", stringsAsFactors = FALSE),
silent = TRUE)
silent = TRUE
)
if (!check_validity_mo_source(df, stop_on_error = FALSE)) {
# try tab
try(
df <- utils::read.table(file = path, header = TRUE, sep = "\t", stringsAsFactors = FALSE),
silent = TRUE)
silent = TRUE
)
}
if (!check_validity_mo_source(df, stop_on_error = FALSE)) {
# try pipe
try(
df <- utils::read.table(file = path, header = TRUE, sep = "|", stringsAsFactors = FALSE),
silent = TRUE)
silent = TRUE
)
}
}
@@ -200,11 +200,15 @@ set_mo_source <- function(path, destination = getOption("AMR_mo_source", "~/mo_s
} else {
action <- "Created"
# only ask when file is created, not when it is updated
txt <- paste0(word_wrap(paste0("This will write create the new file '",
txt <- paste0(
word_wrap(paste0(
"This will write create the new file '",
mo_source_destination,
"', for which your permission is needed.")),
"', for which your permission is needed."
)),
"\n\n",
word_wrap("Do you agree that this file will be created?"))
word_wrap("Do you agree that this file will be created?")
)
showQuestion <- import_fn("showQuestion", "rstudioapi", error_on_fail = FALSE)
if (!is.null(showQuestion)) {
q_continue <- showQuestion("Create new file in home directory", txt)
@@ -220,11 +224,13 @@ set_mo_source <- function(path, destination = getOption("AMR_mo_source", "~/mo_s
attr(df, "mo_source_timestamp") <- file.mtime(path)
saveRDS(df, mo_source_destination)
pkg_env$mo_source <- df
message_(action, " mo_source file '", font_bold(mo_source_destination),
message_(
action, " mo_source file '", font_bold(mo_source_destination),
"' (", formatted_filesize(mo_source_destination),
") from '", font_bold(path),
"' (", formatted_filesize(path),
'), columns "', colnames(df)[1], '" and "', colnames(df)[2], '"')
'), columns "', colnames(df)[1], '" and "', colnames(df)[2], '"'
)
}
#' @rdname mo_source
@@ -291,7 +297,8 @@ check_validity_mo_source <- function(x, refer_to_name = "`reference_df`", stop_o
stop_("Value", plural, " ", vector_and(invalid[, 1, drop = TRUE], quotes = TRUE),
" found in ", tolower(refer_to_name),
", but with invalid microorganism code", plural, " ", vector_and(invalid$mo, quotes = TRUE),
call = FALSE)
call = FALSE
)
} else {
return(FALSE)
}

18
R/pca.R
View File

@@ -43,8 +43,10 @@
#' if (require("dplyr")) {
#' # calculate the resistance per group first
#' resistance_data <- example_isolates %>%
#' group_by(order = mo_order(mo), # group on anything, like order
#' genus = mo_genus(mo)) %>% # and genus as we do here;
#' group_by(
#' order = mo_order(mo), # group on anything, like order
#' genus = mo_genus(mo)
#' ) %>% # and genus as we do here;
#' filter(n() >= 30) %>% # filter on only 30 results per group
#' summarise_if(is.rsi, resistance) # then get resistance of all drugs
#'
@@ -92,7 +94,8 @@ pca <- function(x,
new_list <- list(0)
for (i in seq_len(length(dots) - 1)) {
new_list[[i]] <- tryCatch(eval(dots[[i + 1]], envir = x),
error = function(e) stop(e$message, call. = FALSE))
error = function(e) stop(e$message, call. = FALSE)
)
if (length(new_list[[i]]) == 1) {
if (is.character(new_list[[i]]) & new_list[[i]] %in% colnames(x)) {
# this is to support quoted variables: df %pm>% pca("mycol1", "mycol2")
@@ -111,7 +114,8 @@ pca <- function(x,
# set column names
tryCatch(colnames(x) <- as.character(dots)[2:length(dots)],
error = function(e) warning("column names could not be set"))
error = function(e) warning("column names could not be set")
)
# keep only numeric columns
x <- x[, vapply(FUN.VALUE = logical(1), x, function(y) is.numeric(y)), drop = FALSE]
@@ -124,8 +128,10 @@ pca <- function(x,
pca_data <- x[, which(vapply(FUN.VALUE = logical(1), x, function(x) is.numeric(x))), drop = FALSE]
message_("Columns selected for PCA: ", vector_and(font_bold(colnames(pca_data), collapse = NULL), quotes = TRUE),
". Total observations available: ", nrow(pca_data), ".")
message_(
"Columns selected for PCA: ", vector_and(font_bold(colnames(pca_data), collapse = NULL), quotes = TRUE),
". Total observations available: ", nrow(pca_data), "."
)
if (getRversion() < "3.4.0") {
# stats::prcomp prior to 3.4.0 does not have the 'rank.' argument

144
R/plot.R
View File

@@ -111,21 +111,24 @@ plot.mic <- function(x,
x <- plot_prepare_table(x, expand = expand)
cols_sub <- plot_colours_subtitle_guideline(x = x,
cols_sub <- plot_colours_subtitle_guideline(
x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
fn = as.mic,
language = language,
...)
...
)
barplot(x,
col = cols_sub$cols,
main = main,
ylim = c(0, max(x) * ifelse(any(colours_RSI %in% cols_sub$cols), 1.1, 1)),
ylab = ylab,
xlab = xlab,
axes = FALSE)
axes = FALSE
)
axis(2, seq(0, max(x)))
if (!is.null(cols_sub$sub)) {
mtext(side = 3, line = 0.5, adj = 0.5, cex = 0.75, cols_sub$sub)
@@ -155,7 +158,8 @@ plot.mic <- function(x,
cex = 0.75,
box.lwd = 0,
box.col = "#FFFFFF55",
bg = "#FFFFFF55")
bg = "#FFFFFF55"
)
}
}
@@ -193,7 +197,8 @@ barplot.mic <- function(height,
main <- gsub(" +", " ", paste0(main, collapse = " "))
plot(x = height,
plot(
x = height,
main = main,
ylab = ylab,
xlab = xlab,
@@ -201,7 +206,8 @@ barplot.mic <- function(height,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
...)
...
)
}
#' @method autoplot mic
@@ -245,14 +251,16 @@ autoplot.mic <- function(object,
}
x <- plot_prepare_table(object, expand = expand)
cols_sub <- plot_colours_subtitle_guideline(x = x,
cols_sub <- plot_colours_subtitle_guideline(
x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
fn = as.mic,
language = language,
...)
...
)
df <- as.data.frame(x, stringsAsFactors = TRUE)
colnames(df) <- c("mic", "count")
df$cols <- cols_sub$cols
@@ -261,22 +269,28 @@ autoplot.mic <- function(object,
df$cols[df$cols == colours_RSI[3]] <- plot_name_of_I(cols_sub$guideline)
df$cols <- factor(translate_into_language(df$cols, language = language),
levels = translate_into_language(c("Susceptible", plot_name_of_I(cols_sub$guideline), "Resistant"),
language = language),
ordered = TRUE)
language = language
),
ordered = TRUE
)
p <- ggplot2::ggplot(df)
if (any(colours_RSI %in% cols_sub$cols)) {
vals <- c("Resistant" = colours_RSI[1],
vals <- c(
"Resistant" = colours_RSI[1],
"Susceptible" = colours_RSI[2],
"Susceptible, incr. exp." = colours_RSI[3],
"Intermediate" = colours_RSI[3])
"Intermediate" = colours_RSI[3]
)
names(vals) <- translate_into_language(names(vals), language = language)
p <- p +
ggplot2::geom_col(ggplot2::aes(x = mic, y = count, fill = cols)) +
# limits = force is needed because of a ggplot2 >= 3.3.4 bug (#4511)
ggplot2::scale_fill_manual(values = vals,
ggplot2::scale_fill_manual(
values = vals,
name = NULL,
limits = force)
limits = force
)
} else {
p <- p +
ggplot2::geom_col(ggplot2::aes(x = mic, y = count))
@@ -290,8 +304,10 @@ autoplot.mic <- function(object,
#' @rdname plot
# will be exported using s3_register() in R/zzz.R
fortify.mic <- function(object, ...) {
stats::setNames(as.data.frame(plot_prepare_table(object, expand = FALSE)),
c("x", "y"))
stats::setNames(
as.data.frame(plot_prepare_table(object, expand = FALSE)),
c("x", "y")
)
}
#' @method plot disk
@@ -334,14 +350,16 @@ plot.disk <- function(x,
x <- plot_prepare_table(x, expand = expand)
cols_sub <- plot_colours_subtitle_guideline(x = x,
cols_sub <- plot_colours_subtitle_guideline(
x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
fn = as.disk,
language = language,
...)
...
)
barplot(x,
col = cols_sub$cols,
@@ -349,7 +367,8 @@ plot.disk <- function(x,
ylim = c(0, max(x) * ifelse(any(colours_RSI %in% cols_sub$cols), 1.1, 1)),
ylab = ylab,
xlab = xlab,
axes = FALSE)
axes = FALSE
)
axis(2, seq(0, max(x)))
if (!is.null(cols_sub$sub)) {
mtext(side = 3, line = 0.5, adj = 0.5, cex = 0.75, cols_sub$sub)
@@ -378,7 +397,8 @@ plot.disk <- function(x,
cex = 0.75,
box.lwd = 0,
box.col = "#FFFFFF55",
bg = "#FFFFFF55")
bg = "#FFFFFF55"
)
}
}
@@ -416,7 +436,8 @@ barplot.disk <- function(height,
main <- gsub(" +", " ", paste0(main, collapse = " "))
plot(x = height,
plot(
x = height,
main = main,
ylab = ylab,
xlab = xlab,
@@ -424,7 +445,8 @@ barplot.disk <- function(height,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
...)
...
)
}
#' @method autoplot disk
@@ -468,14 +490,16 @@ autoplot.disk <- function(object,
}
x <- plot_prepare_table(object, expand = expand)
cols_sub <- plot_colours_subtitle_guideline(x = x,
cols_sub <- plot_colours_subtitle_guideline(
x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
fn = as.disk,
language = language,
...)
...
)
df <- as.data.frame(x, stringsAsFactors = TRUE)
colnames(df) <- c("disk", "count")
df$cols <- cols_sub$cols
@@ -485,22 +509,28 @@ autoplot.disk <- function(object,
df$cols[df$cols == colours_RSI[3]] <- plot_name_of_I(cols_sub$guideline)
df$cols <- factor(translate_into_language(df$cols, language = language),
levels = translate_into_language(c("Susceptible", plot_name_of_I(cols_sub$guideline), "Resistant"),
language = language),
ordered = TRUE)
language = language
),
ordered = TRUE
)
p <- ggplot2::ggplot(df)
if (any(colours_RSI %in% cols_sub$cols)) {
vals <- c("Resistant" = colours_RSI[1],
vals <- c(
"Resistant" = colours_RSI[1],
"Susceptible" = colours_RSI[2],
"Susceptible, incr. exp." = colours_RSI[3],
"Intermediate" = colours_RSI[3])
"Intermediate" = colours_RSI[3]
)
names(vals) <- translate_into_language(names(vals), language = language)
p <- p +
ggplot2::geom_col(ggplot2::aes(x = disk, y = count, fill = cols)) +
# limits = force is needed because of a ggplot2 >= 3.3.4 bug (#4511)
ggplot2::scale_fill_manual(values = vals,
ggplot2::scale_fill_manual(
values = vals,
name = NULL,
limits = force)
limits = force
)
} else {
p <- p +
ggplot2::geom_col(ggplot2::aes(x = disk, y = count))
@@ -514,8 +544,10 @@ autoplot.disk <- function(object,
#' @rdname plot
# will be exported using s3_register() in R/zzz.R
fortify.disk <- function(object, ...) {
stats::setNames(as.data.frame(plot_prepare_table(object, expand = FALSE)),
c("x", "y"))
stats::setNames(
as.data.frame(plot_prepare_table(object, expand = FALSE)),
c("x", "y")
)
}
#' @method plot rsi
@@ -546,37 +578,44 @@ plot.rsi <- function(x,
if (!"S" %in% data$x) {
data <- rbind(data, data.frame(x = "S", n = 0, s = 0, stringsAsFactors = FALSE),
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
}
if (!"I" %in% data$x) {
data <- rbind(data, data.frame(x = "I", n = 0, s = 0, stringsAsFactors = FALSE),
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
}
if (!"R" %in% data$x) {
data <- rbind(data, data.frame(x = "R", n = 0, s = 0, stringsAsFactors = FALSE),
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
}
data$x <- factor(data$x, levels = c("S", "I", "R"), ordered = TRUE)
ymax <- pm_if_else(max(data$s) > 95, 105, 100)
plot(x = data$x,
plot(
x = data$x,
y = data$s,
lwd = 2,
ylim = c(0, ymax),
ylab = ylab,
xlab = xlab,
main = main,
axes = FALSE)
axes = FALSE
)
# x axis
axis(side = 1, at = 1:pm_n_distinct(data$x), labels = levels(data$x), lwd = 0)
# y axis, 0-100%
axis(side = 2, at = seq(0, 100, 5))
text(x = data$x,
text(
x = data$x,
y = data$s + 4,
labels = paste0(data$s, "% (n = ", data$n, ")"))
labels = paste0(data$s, "% (n = ", data$n, ")")
)
}
@@ -621,7 +660,8 @@ barplot.rsi <- function(height,
xlab = xlab,
main = main,
ylab = ylab,
axes = FALSE)
axes = FALSE
)
axis(2, seq(0, max(x)))
}
@@ -665,10 +705,14 @@ autoplot.rsi <- function(object,
ggplot2::ggplot(df) +
ggplot2::geom_col(ggplot2::aes(x = rsi, y = count, fill = rsi)) +
# limits = force is needed because of a ggplot2 >= 3.3.4 bug (#4511)
ggplot2::scale_fill_manual(values = c("R" = colours_RSI[1],
ggplot2::scale_fill_manual(
values = c(
"R" = colours_RSI[1],
"S" = colours_RSI[2],
"I" = colours_RSI[3]),
limits = force) +
"I" = colours_RSI[3]
),
limits = force
) +
ggplot2::labs(title = title, x = xlab, y = ylab) +
ggplot2::theme(legend.position = "none")
}
@@ -677,8 +721,10 @@ autoplot.rsi <- function(object,
#' @rdname plot
# will be exported using s3_register() in R/zzz.R
fortify.rsi <- function(object, ...) {
stats::setNames(as.data.frame(table(object)),
c("x", "y"))
stats::setNames(
as.data.frame(table(object)),
c("x", "y")
)
}
plot_prepare_table <- function(x, expand) {
@@ -743,8 +789,10 @@ plot_colours_subtitle_guideline <- function(x, mo, ab, guideline, colours_RSI, f
moname <- mo_name(mo, language = language)
abname <- ab_name(ab, language = language)
if (all(cols == "#BEBEBE")) {
message_("No ", guideline, " interpretations found for ",
ab_name(ab, language = NULL, tolower = TRUE), " in ", moname)
message_(
"No ", guideline, " interpretations found for ",
ab_name(ab, language = NULL, tolower = TRUE), " in ", moname
)
guideline_txt <- ""
} else {
guideline_txt <- guideline
@@ -753,7 +801,7 @@ plot_colours_subtitle_guideline <- function(x, mo, ab, guideline, colours_RSI, f
}
guideline_txt <- paste0("(", guideline_txt, ")")
}
sub <- bquote(.(abname)~"-"~italic(.(moname))~.(guideline_txt))
sub <- bquote(.(abname) ~ "-" ~ italic(.(moname)) ~ .(guideline_txt))
} else {
cols <- "#BEBEBE"
sub <- NULL

81
R/proportion.R
View File

@@ -107,16 +107,20 @@
#' if (require("dplyr")) {
#' example_isolates %>%
#' group_by(ward) %>%
#' summarise(r = resistance(CIP),
#' n = n_rsi(CIP)) # n_rsi works like n_distinct in dplyr, see ?n_rsi
#' summarise(
#' r = resistance(CIP),
#' n = n_rsi(CIP)
#' ) # n_rsi works like n_distinct in dplyr, see ?n_rsi
#'
#' example_isolates %>%
#' group_by(ward) %>%
#' summarise(R = resistance(CIP, as_percent = TRUE),
#' summarise(
#' R = resistance(CIP, as_percent = TRUE),
#' SI = susceptibility(CIP, as_percent = TRUE),
#' n1 = count_all(CIP), # the actual total; sum of all three
#' n2 = n_rsi(CIP), # same - analogous to n_distinct
#' total = n()) # NOT the number of tested isolates!
#' total = n()
#' ) # NOT the number of tested isolates!
#'
#' # Calculate co-resistance between amoxicillin/clav acid and gentamicin,
#' # so we can see that combination therapy does a lot more than mono therapy:
@@ -132,24 +136,30 @@
#'
#' # See Details on how `only_all_tested` works. Example:
#' example_isolates %>%
#' summarise(numerator = count_susceptible(AMC, GEN),
#' summarise(
#' numerator = count_susceptible(AMC, GEN),
#' denominator = count_all(AMC, GEN),
#' proportion = susceptibility(AMC, GEN))
#' proportion = susceptibility(AMC, GEN)
#' )
#'
#' example_isolates %>%
#' summarise(numerator = count_susceptible(AMC, GEN, only_all_tested = TRUE),
#' summarise(
#' numerator = count_susceptible(AMC, GEN, only_all_tested = TRUE),
#' denominator = count_all(AMC, GEN, only_all_tested = TRUE),
#' proportion = susceptibility(AMC, GEN, only_all_tested = TRUE))
#' proportion = susceptibility(AMC, GEN, only_all_tested = TRUE)
#' )
#'
#'
#' example_isolates %>%
#' group_by(ward) %>%
#' summarise(cipro_p = susceptibility(CIP, as_percent = TRUE),
#' summarise(
#' cipro_p = susceptibility(CIP, as_percent = TRUE),
#' cipro_n = count_all(CIP),
#' genta_p = susceptibility(GEN, as_percent = TRUE),
#' genta_n = count_all(GEN),
#' combination_p = susceptibility(CIP, GEN, as_percent = TRUE),
#' combination_n = count_all(CIP, GEN))
#' combination_n = count_all(CIP, GEN)
#' )
#'
#' # Get proportions S/I/R immediately of all rsi columns
#' example_isolates %>%
@@ -174,8 +184,10 @@ resistance <- function(...,
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE),
error = function(e) stop_(e$message, call = -5))
only_count = FALSE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname proportion
@@ -190,8 +202,10 @@ susceptibility <- function(...,
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE),
error = function(e) stop_(e$message, call = -5))
only_count = FALSE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname proportion
@@ -206,8 +220,10 @@ proportion_R <- function(...,
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE),
error = function(e) stop_(e$message, call = -5))
only_count = FALSE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname proportion
@@ -222,8 +238,10 @@ proportion_IR <- function(...,
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE),
error = function(e) stop_(e$message, call = -5))
only_count = FALSE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname proportion
@@ -238,8 +256,10 @@ proportion_I <- function(...,
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE),
error = function(e) stop_(e$message, call = -5))
only_count = FALSE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname proportion
@@ -254,8 +274,10 @@ proportion_SI <- function(...,
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE),
error = function(e) stop_(e$message, call = -5))
only_count = FALSE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname proportion
@@ -270,8 +292,10 @@ proportion_S <- function(...,
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE),
error = function(e) stop_(e$message, call = -5))
only_count = FALSE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname proportion
@@ -284,7 +308,8 @@ proportion_df <- function(data,
combine_SI = TRUE,
combine_IR = FALSE) {
tryCatch(
rsi_calc_df(type = "proportion",
rsi_calc_df(
type = "proportion",
data = data,
translate_ab = translate_ab,
language = language,
@@ -292,6 +317,8 @@ proportion_df <- function(data,
as_percent = as_percent,
combine_SI = combine_SI,
combine_IR = combine_IR,
combine_SI_missing = missing(combine_SI)),
error = function(e) stop_(e$message, call = -5))
combine_SI_missing = missing(combine_SI)
),
error = function(e) stop_(e$message, call = -5)
)
}

24
R/random.R
View File

@@ -96,10 +96,12 @@ random_exec <- function(type, size, mo = NULL, ab = NULL) {
if (!is.null(mo)) {
mo_coerced <- as.mo(mo)
mo_include <- c(mo_coerced,
mo_include <- c(
mo_coerced,
as.mo(mo_genus(mo_coerced)),
as.mo(mo_family(mo_coerced)),
as.mo(mo_order(mo_coerced)))
as.mo(mo_order(mo_coerced))
)
df_new <- df %pm>%
subset(mo %in% mo_include)
if (nrow(df_new) > 0) {
@@ -125,10 +127,14 @@ random_exec <- function(type, size, mo = NULL, ab = NULL) {
mic_range <- c(0.001, 0.002, 0.005, 0.010, 0.025, 0.0625, 0.125, 0.250, 0.5, 1, 2, 4, 8, 16, 32, 64, 128, 256)
# get highest/lowest +/- random 1 to 3 higher factors of two
max_range <- mic_range[min(length(mic_range),
which(mic_range == max(df$breakpoint_R)) + sample(c(1:3), 1))]
min_range <- mic_range[max(1,
which(mic_range == min(df$breakpoint_S)) - sample(c(1:3), 1))]
max_range <- mic_range[min(
length(mic_range),
which(mic_range == max(df$breakpoint_R)) + sample(c(1:3), 1)
)]
min_range <- mic_range[max(
1,
which(mic_range == min(df$breakpoint_S)) - sample(c(1:3), 1)
)]
mic_range_new <- mic_range[mic_range <= max_range & mic_range >= min_range]
if (length(mic_range_new) == 0) {
@@ -144,9 +150,11 @@ random_exec <- function(type, size, mo = NULL, ab = NULL) {
}
return(out)
} else if (type == "DISK") {
set_range <- seq(from = as.integer(min(df$breakpoint_R) / 1.25),
set_range <- seq(
from = as.integer(min(df$breakpoint_R) / 1.25),
to = as.integer(max(df$breakpoint_S) * 1.25),
by = 1)
by = 1
)
out <- sample(set_range, size = size, replace = TRUE)
out[out < 6] <- sample(c(6:10), length(out[out < 6]), replace = TRUE)
out[out > 50] <- sample(c(40:50), length(out[out > 50]), replace = TRUE)

87
R/resistance_predict.R
View File

@@ -67,7 +67,8 @@
#' x <- resistance_predict(example_isolates,
#' col_ab = "AMX",
#' year_min = 2010,
#' model = "binomial")
#' model = "binomial"
#' )
#' plot(x)
#' \donttest{
#' if (require("ggplot2")) {
@@ -89,14 +90,15 @@
#'
#' # create nice plots with ggplot2 yourself
#' if (require("dplyr") && require("ggplot2")) {
#'
#' data <- example_isolates %>%
#' filter(mo == as.mo("E. coli")) %>%
#' resistance_predict(col_ab = "AMX",
#' resistance_predict(
#' col_ab = "AMX",
#' col_date = "date",
#' model = "binomial",
#' info = FALSE,
#' minimum = 15)
#' minimum = 15
#' )
#' head(data)
#' autoplot(data)
#' }
@@ -147,8 +149,10 @@ resistance_predict <- function(x,
col_date <- search_type_in_df(x = x, type = "date")
stop_if(is.null(col_date), "`col_date` must be set")
}
stop_ifnot(col_date %in% colnames(x),
"column '", col_date, "' not found")
stop_ifnot(
col_date %in% colnames(x),
"column '", col_date, "' not found"
)
year <- function(x) {
# don't depend on lubridate or so, would be overkill for only this function
@@ -174,7 +178,8 @@ resistance_predict <- function(x,
df <- subset(df, !is.na(df[, col_ab, drop = TRUE]))
df$year <- year(df[, col_date, drop = TRUE])
df <- as.data.frame(rbind(table(df[, c("year", col_ab), drop = FALSE])),
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
df$year <- as.integer(rownames(df))
rownames(df) <- NULL
@@ -209,7 +214,6 @@ resistance_predict <- function(x,
predictmodel <- predict(model_lm, newdata = years, type = "response", se.fit = TRUE)
prediction <- predictmodel$fit
se <- predictmodel$se.fit
} else if (model %in% c("loglin", "poisson")) {
model <- "poisson"
model_lm <- with(df, glm(R ~ year, family = poisson))
@@ -222,7 +226,6 @@ resistance_predict <- function(x,
predictmodel <- predict(model_lm, newdata = years, type = "response", se.fit = TRUE)
prediction <- predictmodel$fit
se <- predictmodel$se.fit
} else if (model %in% c("lin", "linear")) {
model <- "linear"
model_lm <- with(df, lm((R / (R + S)) ~ year))
@@ -235,23 +238,23 @@ resistance_predict <- function(x,
predictmodel <- predict(model_lm, newdata = years, se.fit = TRUE)
prediction <- predictmodel$fit
se <- predictmodel$se.fit
} else {
stop("no valid model selected. See ?resistance_predict.")
}
# prepare the output dataframe
df_prediction <- data.frame(year = unlist(years),
df_prediction <- data.frame(
year = unlist(years),
value = prediction,
se_min = prediction - se,
se_max = prediction + se,
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
if (model == "poisson") {
df_prediction$value <- as.integer(format(df_prediction$value, scientific = FALSE))
df_prediction$se_min <- as.integer(df_prediction$se_min)
df_prediction$se_max <- as.integer(df_prediction$se_max)
} else {
# se_max not above 1
df_prediction$se_max <- ifelse(df_prediction$se_max > 1, 1, df_prediction$se_max)
@@ -259,10 +262,12 @@ resistance_predict <- function(x,
# se_min not below 0
df_prediction$se_min <- ifelse(df_prediction$se_min < 0, 0, df_prediction$se_min)
df_observations <- data.frame(year = df$year,
df_observations <- data.frame(
year = df$year,
observations = df$R + df$S,
observed = df$R / (df$R + df$S),
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
df_prediction <- df_prediction %pm>%
pm_left_join(df_observations, by = "year")
df_prediction$estimated <- df_prediction$value
@@ -305,7 +310,8 @@ plot.resistance_predict <- function(x, main = paste("Resistance Prediction of",
ylab <- "%IR"
}
plot(x = x$year,
plot(
x = x$year,
y = x$value,
ylim = c(0, 1),
yaxt = "n", # no y labels
@@ -313,25 +319,32 @@ plot.resistance_predict <- function(x, main = paste("Resistance Prediction of",
ylab = paste0("Percentage (", ylab, ")"),
xlab = "Year",
main = main,
sub = paste0("(n = ", sum(x$observations, na.rm = TRUE),
", model: ", attributes(x)$model_title, ")"),
cex.sub = 0.75)
sub = paste0(
"(n = ", sum(x$observations, na.rm = TRUE),
", model: ", attributes(x)$model_title, ")"
),
cex.sub = 0.75
)
axis(side = 2, at = seq(0, 1, 0.1), labels = paste0(0:10 * 10, "%"))
# hack for error bars: https://stackoverflow.com/a/22037078/4575331
arrows(x0 = x$year,
arrows(
x0 = x$year,
y0 = x$se_min,
x1 = x$year,
y1 = x$se_max,
length = 0.05, angle = 90, code = 3, lwd = 1.5)
length = 0.05, angle = 90, code = 3, lwd = 1.5
)
# overlay grey points for prediction
points(x = subset(x, is.na(observations))$year,
points(
x = subset(x, is.na(observations))$year,
y = subset(x, is.na(observations))$value,
pch = 19,
col = "grey40")
col = "grey40"
)
}
#' @rdname resistance_predict
@@ -353,16 +366,24 @@ ggplot_rsi_predict <- function(x,
ylab <- "%IR"
}
p <- ggplot2::ggplot(as.data.frame(x, stringsAsFactors = FALSE),
ggplot2::aes(x = year, y = value)) +
ggplot2::geom_point(data = subset(x, !is.na(observations)),
size = 2) +
p <- ggplot2::ggplot(
as.data.frame(x, stringsAsFactors = FALSE),
ggplot2::aes(x = year, y = value)
) +
ggplot2::geom_point(
data = subset(x, !is.na(observations)),
size = 2
) +
scale_y_percent(limits = c(0, 1)) +
ggplot2::labs(title = main,
ggplot2::labs(
title = main,
y = paste0("Percentage (", ylab, ")"),
x = "Year",
caption = paste0("(n = ", sum(x$observations, na.rm = TRUE),
", model: ", attributes(x)$model_title, ")"))
caption = paste0(
"(n = ", sum(x$observations, na.rm = TRUE),
", model: ", attributes(x)$model_title, ")"
)
)
if (ribbon == TRUE) {
p <- p + ggplot2::geom_ribbon(ggplot2::aes(ymin = se_min, ymax = se_max), alpha = 0.25)
@@ -371,9 +392,11 @@ ggplot_rsi_predict <- function(x,
}
p <- p +
# overlay grey points for prediction
ggplot2::geom_point(data = subset(x, is.na(observations)),
ggplot2::geom_point(
data = subset(x, is.na(observations)),
size = 2,
colour = "grey40")
colour = "grey40"
)
p
}

261
R/rsi.R
View File

@@ -104,25 +104,31 @@
#' # For INTERPRETING disk diffusion and MIC values -----------------------
#'
#' # a whole data set, even with combined MIC values and disk zones
#' df <- data.frame(microorganism = "Escherichia coli",
#' df <- data.frame(
#' microorganism = "Escherichia coli",
#' AMP = as.mic(8),
#' CIP = as.mic(0.256),
#' GEN = as.disk(18),
#' TOB = as.disk(16),
#' NIT = as.mic(32),
#' ERY = "R")
#' ERY = "R"
#' )
#' as.rsi(df)
#'
#' # for single values
#' as.rsi(x = as.mic(2),
#' as.rsi(
#' x = as.mic(2),
#' mo = as.mo("S. pneumoniae"),
#' ab = "AMP",
#' guideline = "EUCAST")
#' guideline = "EUCAST"
#' )
#'
#' as.rsi(x = as.disk(18),
#' as.rsi(
#' x = as.disk(18),
#' mo = "Strep pneu", # `mo` will be coerced with as.mo()
#' ab = "ampicillin", # and `ab` with as.ab()
#' guideline = "EUCAST")
#' guideline = "EUCAST"
#' )
#'
#' \donttest{
#' # the dplyr way
@@ -137,14 +143,18 @@
#' mutate_at(vars(AMP:TOB), as.rsi, mo = .$microorganism)
#'
#' # to include information about urinary tract infections (UTI)
#' data.frame(mo = "E. coli",
#' data.frame(
#' mo = "E. coli",
#' NIT = c("<= 2", 32),
#' from_the_bladder = c(TRUE, FALSE)) %>%
#' from_the_bladder = c(TRUE, FALSE)
#' ) %>%
#' as.rsi(uti = "from_the_bladder")
#'
#' data.frame(mo = "E. coli",
#' data.frame(
#' mo = "E. coli",
#' NIT = c("<= 2", 32),
#' specimen = c("urine", "blood")) %>%
#' specimen = c("urine", "blood")
#' ) %>%
#' as.rsi() # automatically determines urine isolates
#'
#' df %>%
@@ -155,7 +165,6 @@
#'
#' as.rsi(c("S", "I", "R", "A", "B", "C"))
#' as.rsi("<= 0.002; S") # will return "S"
#' rsi_data <- as.rsi(c(rep("S", 474), rep("I", 36), rep("R", 370)))
#' is.rsi(rsi_data)
#' plot(rsi_data) # for percentages
@@ -186,7 +195,8 @@ as.rsi <- function(x, ...) {
#' @details `NA_rsi_` is a missing value of the new `<rsi>` class, analogous to e.g. base \R's [`NA_character_`][base::NA].
#' @export
NA_rsi_ <- set_clean_class(factor(NA, levels = c("S", "I", "R"), ordered = TRUE),
new_class = c("rsi", "ordered", "factor"))
new_class = c("rsi", "ordered", "factor")
)
#' @rdname as.rsi
#' @export
@@ -209,7 +219,8 @@ is.rsi.eligible <- function(x, threshold = 0.05) {
}
stop_if(NCOL(x) > 1, "`x` must be a one-dimensional vector.")
if (any(c("numeric",
if (any(c(
"numeric",
"integer",
"mo",
"ab",
@@ -218,7 +229,8 @@ is.rsi.eligible <- function(x, threshold = 0.05) {
"raw",
"hms",
"mic",
"disk")
"disk"
)
%in% class(x))) {
# no transformation needed
return(FALSE)
@@ -235,8 +247,10 @@ is.rsi.eligible <- function(x, threshold = 0.05) {
ab <- suppressWarnings(as.ab(cur_col, fast_mode = TRUE, info = FALSE))
if (!is.na(ab)) {
# this is a valid antibiotic code
message_("Column '", font_bold(cur_col), "' is as.rsi()-eligible (despite only having empty values), since it seems to be ",
ab_name(ab, language = NULL, tolower = TRUE), " (", ab, ")")
message_(
"Column '", font_bold(cur_col), "' is as.rsi()-eligible (despite only having empty values), since it seems to be ",
ab_name(ab, language = NULL, tolower = TRUE), " (", ab, ")"
)
return(TRUE)
}
}
@@ -272,9 +286,7 @@ as.rsi.default <- function(x, ...) {
x[x.bak == 2] <- "I"
x[x.bak == 3] <- "R"
}
} else if (!all(is.na(x)) && !identical(levels(x), c("R", "S", "I")) && !all(x %in% c("R", "S", "I", NA))) {
if (all(x %unlike% "(R|S|I)", na.rm = TRUE)) {
# check if they are actually MICs or disks
if (all_valid_mics(x)) {
@@ -291,12 +303,18 @@ as.rsi.default <- function(x, ...) {
na_before <- length(x[is.na(x)])
# correct for translations
trans_R <- unlist(TRANSLATIONS[which(TRANSLATIONS$pattern == "Resistant"),
LANGUAGES_SUPPORTED[LANGUAGES_SUPPORTED %in% colnames(TRANSLATIONS)]])
trans_S <- unlist(TRANSLATIONS[which(TRANSLATIONS$pattern == "Susceptible"),
LANGUAGES_SUPPORTED[LANGUAGES_SUPPORTED %in% colnames(TRANSLATIONS)]])
trans_I <- unlist(TRANSLATIONS[which(TRANSLATIONS$pattern %in% c("Incr. exposure", "Susceptible, incr. exp.", "Intermediate")),
LANGUAGES_SUPPORTED[LANGUAGES_SUPPORTED %in% colnames(TRANSLATIONS)]])
trans_R <- unlist(TRANSLATIONS[
which(TRANSLATIONS$pattern == "Resistant"),
LANGUAGES_SUPPORTED[LANGUAGES_SUPPORTED %in% colnames(TRANSLATIONS)]
])
trans_S <- unlist(TRANSLATIONS[
which(TRANSLATIONS$pattern == "Susceptible"),
LANGUAGES_SUPPORTED[LANGUAGES_SUPPORTED %in% colnames(TRANSLATIONS)]
])
trans_I <- unlist(TRANSLATIONS[
which(TRANSLATIONS$pattern %in% c("Incr. exposure", "Susceptible, incr. exp.", "Intermediate")),
LANGUAGES_SUPPORTED[LANGUAGES_SUPPORTED %in% colnames(TRANSLATIONS)]
])
x <- gsub(paste0(unique(trans_R[!is.na(trans_R)]), collapse = "|"), "R", x, ignore.case = TRUE)
x <- gsub(paste0(unique(trans_S[!is.na(trans_S)]), collapse = "|"), "S", x, ignore.case = TRUE)
x <- gsub(paste0(unique(trans_I[!is.na(trans_I)]), collapse = "|"), "I", x, ignore.case = TRUE)
@@ -330,7 +348,9 @@ as.rsi.default <- function(x, ...) {
warning_("in `as.rsi()`: ", na_after - na_before, " results truncated (",
round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid antimicrobial interpretations: ",
list_missing, call = FALSE)
list_missing,
call = FALSE
)
}
if (any(toupper(x.bak[!is.na(x.bak)]) == "U") && message_not_thrown_before("as.rsi", "U")) {
warning_("in `as.rsi()`: 'U' was interpreted as 'S', following some laboratory systems")
@@ -345,7 +365,8 @@ as.rsi.default <- function(x, ...) {
}
set_clean_class(factor(x, levels = c("S", "I", "R"), ordered = TRUE),
new_class = c("rsi", "ordered", "factor"))
new_class = c("rsi", "ordered", "factor")
)
}
#' @rdname as.rsi
@@ -359,7 +380,8 @@ as.rsi.mic <- function(x,
add_intrinsic_resistance = FALSE,
reference_data = AMR::rsi_translation,
...) {
as_rsi_method(method_short = "mic",
as_rsi_method(
method_short = "mic",
method_long = "MIC values",
x = x,
mo = mo,
@@ -369,7 +391,8 @@ as.rsi.mic <- function(x,
conserve_capped_values = conserve_capped_values,
add_intrinsic_resistance = add_intrinsic_resistance,
reference_data = reference_data,
...)
...
)
}
#' @rdname as.rsi
@@ -382,7 +405,8 @@ as.rsi.disk <- function(x,
add_intrinsic_resistance = FALSE,
reference_data = AMR::rsi_translation,
...) {
as_rsi_method(method_short = "disk",
as_rsi_method(
method_short = "disk",
method_long = "disk diffusion zones",
x = x,
mo = mo,
@@ -392,7 +416,8 @@ as.rsi.disk <- function(x,
conserve_capped_values = FALSE,
add_intrinsic_resistance = add_intrinsic_resistance,
reference_data = reference_data,
...)
...
)
}
#' @rdname as.rsi
@@ -442,8 +467,10 @@ as.rsi.data.frame <- function(x,
}
} else {
# column found, transform to logical
stop_if(length(col_uti) != 1 | !col_uti %in% colnames(x),
"argument `uti` must be a [logical] vector, of must be a single column name of `x`")
stop_if(
length(col_uti) != 1 | !col_uti %in% colnames(x),
"argument `uti` must be a [logical] vector, of must be a single column name of `x`"
)
uti <- as.logical(x[, col_uti, drop = TRUE])
}
} else {
@@ -457,11 +484,13 @@ as.rsi.data.frame <- function(x,
} else {
plural <- c("", "s", "a ")
}
message_("Assuming value", plural[1], " ",
message_(
"Assuming value", plural[1], " ",
vector_and(values, quotes = TRUE),
" in column '", font_bold(col_specimen),
"' reflect", plural[2], " ", plural[3], "urinary tract infection", plural[1],
".\n Use `as.rsi(uti = FALSE)` to prevent this.")
".\n Use `as.rsi(uti = FALSE)` to prevent this."
)
} else {
# no data about UTI's found
uti <- FALSE
@@ -501,8 +530,10 @@ as.rsi.data.frame <- function(x,
}
})]
stop_if(length(ab_cols) == 0,
"no columns with MIC values, disk zones or antibiotic column names found in this data set. Use as.mic() or as.disk() to transform antimicrobial columns.")
stop_if(
length(ab_cols) == 0,
"no columns with MIC values, disk zones or antibiotic column names found in this data set. Use as.mic() or as.disk() to transform antimicrobial columns."
)
# set type per column
types <- character(length(ab_cols))
types[vapply(FUN.VALUE = logical(1), x.bak[, ab_cols, drop = FALSE], is.disk)] <- "disk"
@@ -522,7 +553,8 @@ as.rsi.data.frame <- function(x,
for (i in seq_len(length(ab_cols))) {
if (types[i] == "mic") {
x[, ab_cols[i]] <- as.rsi(x = x %pm>%
x[, ab_cols[i]] <- as.rsi(
x = x %pm>%
pm_pull(ab_cols[i]) %pm>%
as.character() %pm>%
as.mic(),
@@ -533,9 +565,11 @@ as.rsi.data.frame <- function(x,
conserve_capped_values = conserve_capped_values,
add_intrinsic_resistance = add_intrinsic_resistance,
reference_data = reference_data,
is_data.frame = TRUE)
is_data.frame = TRUE
)
} else if (types[i] == "disk") {
x[, ab_cols[i]] <- as.rsi(x = x %pm>%
x[, ab_cols[i]] <- as.rsi(
x = x %pm>%
pm_pull(ab_cols[i]) %pm>%
as.character() %pm>%
as.disk(),
@@ -545,7 +579,8 @@ as.rsi.data.frame <- function(x,
uti = uti,
add_intrinsic_resistance = add_intrinsic_resistance,
reference_data = reference_data,
is_data.frame = TRUE)
is_data.frame = TRUE
)
} else if (types[i] == "rsi") {
show_message <- FALSE
ab <- ab_cols[i]
@@ -557,7 +592,8 @@ as.rsi.data.frame <- function(x,
ifelse(ab_coerced != toupper(ab), paste0(ab_coerced, ", "), ""),
ab_name(ab_coerced, tolower = TRUE), ")... ",
appendLF = FALSE,
as_note = FALSE)
as_note = FALSE
)
} else if (!is.rsi(x.bak[, ab_cols[i], drop = TRUE])) {
show_message <- TRUE
# only print message if class not already set
@@ -565,7 +601,8 @@ as.rsi.data.frame <- function(x,
ifelse(ab_coerced != toupper(ab), paste0(ab_coerced, ", "), ""),
ab_name(ab_coerced, tolower = TRUE), ")... ",
appendLF = FALSE,
as_note = FALSE)
as_note = FALSE
)
}
x[, ab_cols[i]] <- as.rsi.default(x = as.character(x[, ab_cols[i], drop = TRUE]))
if (show_message == TRUE) {
@@ -592,7 +629,9 @@ get_guideline <- function(guideline, reference_data) {
stop_ifnot(guideline_param %in% reference_data$guideline,
"invalid guideline: '", guideline,
"'.\nValid guidelines are: ", vector_and(reference_data$guideline, quotes = TRUE, reverse = TRUE), call = FALSE)
"'.\nValid guidelines are: ", vector_and(reference_data$guideline, quotes = TRUE, reverse = TRUE),
call = FALSE
)
guideline_param
}
@@ -623,34 +662,43 @@ as_rsi_method <- function(method_short,
if (!is.null(cur_column_dplyr) && tryCatch(is.data.frame(get_current_data("ab", call = 0)), error = function(e) FALSE)) {
# try to get current column, which will only be available when in across()
ab <- tryCatch(cur_column_dplyr(),
error = function(e) ab)
error = function(e) ab
)
}
# for auto-determining mo
mo_var_found <- ""
if (is.null(mo)) {
tryCatch({
tryCatch(
{
df <- get_current_data(arg_name = "mo", call = -3) # will return an error if not found
mo <- NULL
try({
try(
{
mo <- suppressMessages(search_type_in_df(df, "mo"))
}, silent = TRUE)
},
silent = TRUE
)
if (!is.null(df) && !is.null(mo) && is.data.frame(df)) {
mo_var_found <- paste0(" based on column '", font_bold(mo), "'")
mo <- df[, mo, drop = TRUE]
}
}, error = function(e) {
},
error = function(e) {
mo <- NULL
})
}
)
}
if (is.null(mo)) {
stop_("No information was supplied about the microorganisms (missing argument `mo` and no column of class <mo> found). See ?as.rsi.\n\n",
"To transform certain columns with e.g. mutate(), use `data %>% mutate(across(..., as.rsi, mo = x))`, where x is your column with microorganisms.\n",
"To tranform all ", method_long, " in a data set, use `data %>% as.rsi()` or `data %>% mutate(across(where(is.", method_short, "), as.rsi))`.", call = FALSE)
"To tranform all ", method_long, " in a data set, use `data %>% as.rsi()` or `data %>% mutate(across(where(is.", method_short, "), as.rsi))`.",
call = FALSE
)
}
if (length(ab) == 1 && ab %like% paste0("as.", method_short)) {
stop_('No unambiguous name was supplied about the antibiotic (argument `ab`). See ?as.rsi.', call = FALSE)
stop_("No unambiguous name was supplied about the antibiotic (argument `ab`). See ?as.rsi.", call = FALSE)
}
ab_coerced <- suppressWarnings(as.ab(ab))
@@ -660,7 +708,8 @@ as_rsi_method <- function(method_short,
message_("Returning NAs for unknown drug: '", font_bold(ab),
"'. Rename this column to a drug name or code, and check the output with `as.ab()`.",
add_fn = font_red,
as_note = FALSE)
as_note = FALSE
)
return(as.rsi(rep(NA, length(x))))
}
if (length(mo_coerced) == 1) {
@@ -680,11 +729,14 @@ as_rsi_method <- function(method_short,
mo_var_found,
" according to ", ifelse(identical(reference_data, AMR::rsi_translation),
font_bold(guideline_coerced),
"manually defined 'reference_data'"),
"manually defined 'reference_data'"
),
"... ",
appendLF = FALSE,
as_note = FALSE)
result <- exec_as.rsi(method = method_short,
as_note = FALSE
)
result <- exec_as.rsi(
method = method_short,
x = x,
mo = mo_coerced,
ab = ab_coerced,
@@ -692,7 +744,8 @@ as_rsi_method <- function(method_short,
uti = uti,
conserve_capped_values = conserve_capped_values,
add_intrinsic_resistance = add_intrinsic_resistance,
reference_data = reference_data) # exec_as.rsi will return message 'OK'
reference_data = reference_data
) # exec_as.rsi will return message 'OK'
result
}
@@ -739,13 +792,19 @@ exec_as.rsi <- function(method,
guideline_coerced <- get_guideline(guideline, reference_data)
if (guideline_coerced != guideline) {
if (message_not_thrown_before("as.rsi", "msg1")) {
if (message_not_thrown_before("as.rsi", "guideline")) {
message_("Using guideline ", font_bold(guideline_coerced), " as input for `guideline`.")
}
}
new_rsi <- rep(NA_character_, length(x))
ab_param <- ab
if (ab_param == "AMX") {
ab_param <- "AMP"
if (message_not_thrown_before("as.rsi", "AMP_for_AMX")) {
message_("(using ampicillin rules)", appendLF = FALSE, as_note = FALSE)
}
}
if (identical(reference_data, AMR::rsi_translation)) {
trans <- reference_data %pm>%
subset(guideline == guideline_coerced & method == method_param & ab == ab_param)
@@ -755,23 +814,23 @@ exec_as.rsi <- function(method,
}
trans$lookup <- paste(trans$mo, trans$ab)
lookup_mo <- paste(mo, ab)
lookup_genus <- paste(mo_genus, ab)
lookup_family <- paste(mo_family, ab)
lookup_order <- paste(mo_order, ab)
lookup_becker <- paste(mo_becker, ab)
lookup_lancefield <- paste(mo_lancefield, ab)
lookup_other <- paste(mo_other, ab)
lookup_mo <- paste(mo, ab_param)
lookup_genus <- paste(mo_genus, ab_param)
lookup_family <- paste(mo_family, ab_param)
lookup_order <- paste(mo_order, ab_param)
lookup_becker <- paste(mo_becker, ab_param)
lookup_lancefield <- paste(mo_lancefield, ab_param)
lookup_other <- paste(mo_other, ab_param)
any_is_intrinsic_resistant <- FALSE
for (i in seq_len(length(x))) {
is_intrinsic_r <- paste(mo[i], ab) %in% INTRINSIC_R
is_intrinsic_r <- paste(mo[i], ab_param) %in% INTRINSIC_R
any_is_intrinsic_resistant <- any_is_intrinsic_resistant | is_intrinsic_r
if (isTRUE(add_intrinsic_resistance) & is_intrinsic_r) {
if (guideline_coerced %unlike% "EUCAST") {
if (message_not_thrown_before("as.rsi", "msg2")) {
if (message_not_thrown_before("as.rsi", "intrinsic")) {
warning_("in `as.rsi()`: using 'add_intrinsic_resistance' is only useful when using EUCAST guidelines, since the rules for intrinsic resistance are based on EUCAST.")
}
} else {
@@ -782,16 +841,18 @@ exec_as.rsi <- function(method,
get_record <- trans %pm>%
# no subsetting to UTI here
subset(lookup %in% c(lookup_mo[i],
subset(lookup %in% c(
lookup_mo[i],
lookup_genus[i],
lookup_family[i],
lookup_order[i],
lookup_becker[i],
lookup_lancefield[i],
lookup_other[i]))
lookup_other[i]
))
if (any(get_record$uti == TRUE, na.rm = TRUE) && !any(uti == TRUE, na.rm = TRUE) && message_not_thrown_before("as.rsi", "msg3", ab)) {
warning_("in `as.rsi()`: interpretation of ", font_bold(ab_name(ab, tolower = TRUE)), " is only available for (uncomplicated) urinary tract infections (UTI) for some microorganisms. Use argument `uti` to set which isolates are from urine. See ?as.rsi.")
if (any(get_record$uti == TRUE, na.rm = TRUE) && !any(uti == TRUE, na.rm = TRUE) && message_not_thrown_before("as.rsi", "uti", ab_param)) {
warning_("in `as.rsi()`: interpretation of ", font_bold(ab_name(ab_param, tolower = TRUE)), " is only available for (uncomplicated) urinary tract infections (UTI) for some microorganisms. Use argument `uti` to set which isolates are from urine. See ?as.rsi.")
rise_warning <- TRUE
}
@@ -812,7 +873,8 @@ exec_as.rsi <- function(method,
if (is.na(x[i]) | (is.na(get_record$breakpoint_S) & is.na(get_record$breakpoint_R))) {
new_rsi[i] <- NA_character_
} else if (method == "mic") {
new_rsi[i] <- quick_case_when(isTRUE(conserve_capped_values) & isTRUE(x[i] %like% "^<[0-9]") ~ "S",
new_rsi[i] <- quick_case_when(
isTRUE(conserve_capped_values) & isTRUE(x[i] %like% "^<[0-9]") ~ "S",
isTRUE(conserve_capped_values) & isTRUE(x[i] %like% "^>[0-9]") ~ "R",
# these basically call `<=.mic()` and `>=.mic()`:
isTRUE(x[i] <= get_record$breakpoint_S) ~ "S",
@@ -821,31 +883,37 @@ exec_as.rsi <- function(method,
# return "I" when not match the bottom or top
!is.na(get_record$breakpoint_S) & !is.na(get_record$breakpoint_R) ~ "I",
# and NA otherwise
TRUE ~ NA_character_)
TRUE ~ NA_character_
)
} else if (method == "disk") {
new_rsi[i] <- quick_case_when(isTRUE(as.double(x[i]) >= as.double(get_record$breakpoint_S)) ~ "S",
new_rsi[i] <- quick_case_when(
isTRUE(as.double(x[i]) >= as.double(get_record$breakpoint_S)) ~ "S",
guideline_coerced %like% "EUCAST" & isTRUE(as.double(x[i]) < as.double(get_record$breakpoint_R)) ~ "R",
guideline_coerced %like% "CLSI" & isTRUE(as.double(x[i]) <= as.double(get_record$breakpoint_R)) ~ "R",
# return "I" when not match the bottom or top
!is.na(get_record$breakpoint_S) & !is.na(get_record$breakpoint_R) ~ "I",
# and NA otherwise
TRUE ~ NA_character_)
TRUE ~ NA_character_
)
}
}
}
if (any_is_intrinsic_resistant & guideline_coerced %like% "EUCAST" & !isTRUE(add_intrinsic_resistance)) {
# found some intrinsic resistance, but was not applied
if (message_not_thrown_before("as.rsi", "msg4")) {
if (message_not_thrown_before("as.rsi", "unapplied_instrinsic")) {
warning_("in `as.rsi()`: found intrinsic resistance in some bug/drug combinations, although it was not applied.\nUse `as.rsi(..., add_intrinsic_resistance = TRUE)` to apply it.")
}
rise_warning <- TRUE
}
new_rsi <- x_bak %pm>%
pm_left_join(data.frame(x_mo = paste0(x, mo), new_rsi,
stringsAsFactors = FALSE),
by = "x_mo") %pm>%
pm_left_join(data.frame(
x_mo = paste0(x, mo), new_rsi,
stringsAsFactors = FALSE
),
by = "x_mo"
) %pm>%
pm_pull(new_rsi)
if (isTRUE(rise_warning)) {
@@ -857,7 +925,8 @@ exec_as.rsi <- function(method,
load_mo_failures_uncertainties_renamed(metadata_mo)
set_clean_class(factor(new_rsi, levels = c("S", "I", "R"), ordered = TRUE),
new_class = c("rsi", "ordered", "factor"))
new_class = c("rsi", "ordered", "factor")
)
}
# will be exported using s3_register() in R/zzz.R
@@ -885,12 +954,14 @@ freq.rsi <- function(x, ...) {
x_name <- gsub(".*[$]", "", x_name)
if (x_name %in% c("x", ".")) {
# try again going through system calls
x_name <- stats::na.omit(vapply(FUN.VALUE = character(1),
x_name <- stats::na.omit(vapply(
FUN.VALUE = character(1),
sys.calls(),
function(call) {
call_txt <- as.character(call)
ifelse(call_txt[1] %like% "freq$", call_txt[length(call_txt)], character(0))
}))[1L]
}
))[1L]
}
ab <- suppressMessages(suppressWarnings(as.ab(x_name)))
digits <- list(...)$digits
@@ -898,17 +969,25 @@ freq.rsi <- function(x, ...) {
digits <- 2
}
if (!is.na(ab)) {
cleaner::freq.default(x = x, ...,
cleaner::freq.default(
x = x, ...,
.add_header = list(
Drug = paste0(ab_name(ab, language = NULL), " (", ab, ", ", paste(ab_atc(ab), collapse = "/"), ")"),
`Drug group` = ab_group(ab, language = NULL),
`%SI` = trimws(percentage(susceptibility(x, minimum = 0, as_percent = FALSE),
digits = digits))))
digits = digits
))
)
)
} else {
cleaner::freq.default(x = x, ...,
cleaner::freq.default(
x = x, ...,
.add_header = list(
`%SI` = trimws(percentage(susceptibility(x, minimum = 0, as_percent = FALSE),
digits = digits))))
digits = digits
))
)
)
}
}
@@ -923,9 +1002,11 @@ get_skimmers.rsi <- function(column) {
if (any(calls_txt %like% "skim_variable", na.rm = TRUE)) {
ind <- which(calls_txt %like% "skim_variable")[1L]
vars <- tryCatch(eval(parse(text = ".data$skim_variable$rsi"), envir = frms[[ind]]),
error = function(e) NULL)
error = function(e) NULL
)
tryCatch(ab_name(as.character(calls[[length(calls)]][[2]]), language = NULL),
error = function(e) NA_character_)
error = function(e) NA_character_
)
} else {
NA_character_
}
@@ -937,9 +1018,9 @@ get_skimmers.rsi <- function(column) {
count_R = count_R,
count_S = count_susceptible,
count_I = count_I,
prop_R = ~proportion_R(., minimum = 0),
prop_S = ~susceptibility(., minimum = 0),
prop_I = ~proportion_I(., minimum = 0)
prop_R = ~ proportion_R(., minimum = 0),
prop_S = ~ susceptibility(., minimum = 0),
prop_I = ~ proportion_I(., minimum = 0)
)
}

48
R/rsi_calc.R
View File

@@ -44,7 +44,9 @@ rsi_calc <- function(...,
data_vars <- dots2vars(...)
dots_df <- switch(1, ...)
dots_df <- switch(1,
...
)
if (is.data.frame(dots_df)) {
# make sure to remove all other classes like tibbles, data.tables, etc
dots_df <- as.data.frame(dots_df, stringsAsFactors = FALSE)
@@ -55,7 +57,9 @@ rsi_calc <- function(...,
stop_if("also_single_tested" %in% names(dots),
"`also_single_tested` was replaced by `only_all_tested`.\n",
"Please read Details in the help page (`?proportion`) as this may have a considerable impact on your analysis.", call = -2)
"Please read Details in the help page (`?proportion`) as this may have a considerable impact on your analysis.",
call = -2
)
ndots <- length(dots)
if (is.data.frame(dots_df)) {
@@ -75,8 +79,10 @@ rsi_calc <- function(...,
} else {
# get dots that are in column names already, and the ones that will be once evaluated using dots_df or global env
# this is to support susceptibility(example_isolates, AMC, any_of(some_vector_with_AB_names))
dots <- c(dots[dots %in% colnames(dots_df)],
eval(parse(text = dots[!dots %in% colnames(dots_df)]), envir = dots_df, enclos = globalenv()))
dots <- c(
dots[dots %in% colnames(dots_df)],
eval(parse(text = dots[!dots %in% colnames(dots_df)]), envir = dots_df, enclos = globalenv())
)
dots_not_exist <- dots[!dots %in% colnames(dots_df)]
stop_if(length(dots_not_exist) > 0, "column(s) not found: ", vector_and(dots_not_exist, quotes = TRUE), call = -2)
x <- dots_df[, dots, drop = FALSE]
@@ -125,9 +131,11 @@ rsi_calc <- function(...,
x_transposed <- as.list(as.data.frame(t(x), stringsAsFactors = FALSE))
if (only_all_tested == TRUE) {
# no NAs in any column
y <- apply(X = as.data.frame(lapply(x, as.integer), stringsAsFactors = FALSE),
y <- apply(
X = as.data.frame(lapply(x, as.integer), stringsAsFactors = FALSE),
MARGIN = 1,
FUN = min)
FUN = min
)
numerator <- sum(as.integer(y) %in% as.integer(ab_result), na.rm = TRUE)
denominator <- sum(vapply(FUN.VALUE = logical(1), x_transposed, function(y) !(any(is.na(y)))))
} else {
@@ -151,7 +159,8 @@ rsi_calc <- function(...,
warning_("Increase speed by transforming to class <rsi> on beforehand:\n",
" your_data %>% mutate_if(is.rsi.eligible, as.rsi)\n",
" your_data %>% mutate(across(where(is.rsi.eligible), as.rsi))",
call = FALSE)
call = FALSE
)
}
}
@@ -185,7 +194,9 @@ rsi_calc <- function(...,
ifelse(denominator == 0, "no", paste("only", denominator)),
" results available",
data_vars,
" (`minimum` = ", minimum, ").", call = FALSE)
" (`minimum` = ", minimum, ").",
call = FALSE
)
fraction <- NA_real_
} else {
fraction <- numerator / denominator
@@ -252,11 +263,13 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
}
sum_it <- function(.data) {
out <- data.frame(antibiotic = character(0),
out <- data.frame(
antibiotic = character(0),
interpretation = character(0),
value = double(0),
isolates = integer(0),
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
if (data_has_groups) {
group_values <- unique(.data[, which(colnames(.data) %in% groups), drop = FALSE])
rownames(group_values) <- NULL
@@ -280,18 +293,22 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
} else {
col_results$value <- rep(NA_real_, NROW(col_results))
}
out_new <- data.frame(antibiotic = ifelse(isFALSE(translate_ab),
out_new <- data.frame(
antibiotic = ifelse(isFALSE(translate_ab),
colnames(.data)[i],
ab_property(colnames(.data)[i], property = translate_ab, language = language)),
ab_property(colnames(.data)[i], property = translate_ab, language = language)
),
interpretation = col_results$interpretation,
value = col_results$value,
isolates = col_results$isolates,
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
if (data_has_groups) {
if (nrow(group_values) < nrow(out_new)) {
# repeat group_values for the number of rows in out_new
repeated <- rep(seq_len(nrow(group_values)),
each = nrow(out_new) / nrow(group_values))
each = nrow(out_new) / nrow(group_values)
)
group_values <- group_values[repeated, , drop = FALSE]
}
out_new <- cbind(group_values, out_new)
@@ -360,7 +377,8 @@ get_translate_ab <- function(translate_ab) {
stop_ifnot(translate_ab %in% colnames(AMR::antibiotics),
"invalid value for 'translate_ab', this must be a column name of the antibiotics data set\n",
"or TRUE (equals 'name') or FALSE to not translate at all.",
call = FALSE)
call = FALSE
)
translate_ab
}
}

7
R/rsi_df.R
View File

@@ -32,7 +32,8 @@ rsi_df <- function(data,
as_percent = FALSE,
combine_SI = TRUE,
combine_IR = FALSE) {
rsi_calc_df(type = "both",
rsi_calc_df(
type = "both",
data = data,
translate_ab = translate_ab,
language = language,
@@ -40,6 +41,6 @@ rsi_df <- function(data,
as_percent = as_percent,
combine_SI = combine_SI,
combine_IR = combine_IR,
combine_SI_missing = missing(combine_SI))
combine_SI_missing = missing(combine_SI)
)
}

2
R/skewness.R
View File

@@ -50,7 +50,7 @@ skewness.default <- function(x, na.rm = FALSE) {
x <- x[!is.na(x)]
}
n <- length(x)
(sum((x - mean(x))^3) / n) / (sum((x - mean(x)) ^ 2) / n) ^ (3 / 2)
(sum((x - mean(x))^3) / n) / (sum((x - mean(x))^2) / n)^(3 / 2)
}
#' @method skewness matrix

41
R/translate.R
View File

@@ -84,9 +84,11 @@ get_AMR_locale <- function() {
lang <- find_language(lang)
if (lang != "en" && interactive() && message_not_thrown_before("get_AMR_locale", entire_session = TRUE)) {
message_("Assuming the ", LANGUAGES_SUPPORTED_NAMES[[lang]]$exonym, " language (",
message_(
"Assuming the ", LANGUAGES_SUPPORTED_NAMES[[lang]]$exonym, " language (",
LANGUAGES_SUPPORTED_NAMES[[lang]]$endonym, ") for the AMR package. Change this with `set_AMR_locale()`. ",
"This note will be shown once per session.")
"This note will be shown once per session."
)
}
lang
}
@@ -120,23 +122,30 @@ validate_language <- function(language, extra_txt = character(0)) {
stop_ifnot(length(lang) > 0 && lang %in% LANGUAGES_SUPPORTED,
"unsupported language for AMR package", extra_txt, ": \"", language, "\". Use one of these language names or ISO-639-1 codes: ",
paste0('"', vapply(FUN.VALUE = character(1), LANGUAGES_SUPPORTED_NAMES, function(x) x[[1]]),
'" ("' , LANGUAGES_SUPPORTED, '")', collapse = ", "),
call = FALSE)
'" ("', LANGUAGES_SUPPORTED, '")',
collapse = ", "
),
call = FALSE
)
lang
}
find_language <- function(language, fallback = TRUE) {
language <- Map(function(l, n, check = language) {
grepl(paste0("^(", l[1], "|", l[2], "|",
n, "(_|$)|", toupper(n), "(_|$))"),
grepl(paste0(
"^(", l[1], "|", l[2], "|",
n, "(_|$)|", toupper(n), "(_|$))"
),
check,
ignore.case = FALSE,
perl = TRUE,
useBytes = FALSE)
useBytes = FALSE
)
},
LANGUAGES_SUPPORTED_NAMES,
LANGUAGES_SUPPORTED,
USE.NAMES = TRUE)
USE.NAMES = TRUE
)
language <- names(which(language == TRUE))
if (isTRUE(fallback) && length(language) == 0) {
# other language -> set to English
@@ -151,7 +160,6 @@ translate_into_language <- function(from,
only_unknown = FALSE,
only_affect_ab_names = FALSE,
only_affect_mo_names = FALSE) {
if (is.null(language)) {
return(from)
}
@@ -194,19 +202,26 @@ translate_into_language <- function(from,
error = function(e) {
warning_("Translation not possible. Please open an issue on GitHub (https://github.com/msberends/AMR/issues).")
return(FALSE)
})
}
)
if (NROW(df_trans) == 0 | !any_form_in_patterns) {
return(from)
}
lapply(seq_len(nrow(df_trans)),
function(i) from_unique_translated <<- gsub(pattern = df_trans$pattern[i],
lapply(
seq_len(nrow(df_trans)),
function(i) {
from_unique_translated <<- gsub(
pattern = df_trans$pattern[i],
replacement = df_trans[i, lang, drop = TRUE],
x = from_unique_translated,
ignore.case = !df_trans$case_sensitive[i] & df_trans$regular_expr[i],
fixed = !df_trans$regular_expr[i],
perl = df_trans$regular_expr[i]))
perl = df_trans$regular_expr[i]
)
}
)
# force UTF-8 for diacritics
from_unique_translated <- enc2utf8(from_unique_translated)

18
R/zzz.R
View File

@@ -26,16 +26,19 @@
# set up package environment, used by numerous AMR functions
pkg_env <- new.env(hash = FALSE)
pkg_env$mo_failed <- character(0)
pkg_env$mo_field_abbreviations <- c("AIEC", "ATEC", "BORSA", "CRSM", "DAEC", "EAEC",
pkg_env$mo_field_abbreviations <- c(
"AIEC", "ATEC", "BORSA", "CRSM", "DAEC", "EAEC",
"EHEC", "EIEC", "EPEC", "ETEC", "GISA", "MRPA",
"MRSA", "MRSE", "MSSA", "MSSE", "NMEC", "PISP",
"PRSP", "STEC", "UPEC", "VISA", "VISP", "VRE",
"VRSA", "VRSP")
"VRSA", "VRSP"
)
# determine info icon for messages
utf8_supported <- isTRUE(base::l10n_info()$`UTF-8`)
is_latex <- tryCatch(import_fn("is_latex_output", "knitr", error_on_fail = FALSE)(),
error = function(e) FALSE)
error = function(e) FALSE
)
if (utf8_supported && !is_latex) {
# \u2139 is a symbol officially named 'information source'
pkg_env$info_icon <- "\u2139"
@@ -95,11 +98,14 @@ if (utf8_supported && !is_latex) {
s3_register("vctrs::vec_cast", "integer.disk")
# if mo source exists, fire it up (see mo_source())
try({
try(
{
if (file.exists(getOption("AMR_mo_source", "~/mo_source.rds"))) {
invisible(get_mo_source())
}
}, silent = TRUE)
},
silent = TRUE
)
# be sure to print tibbles as tibbles
if (pkg_is_available("tibble", also_load = FALSE)) {
@@ -137,7 +143,7 @@ create_MO_lookup <- function() {
MO_lookup$fullname_lower <- MO_FULLNAME_LOWER
} else {
MO_lookup$fullname_lower <- ""
warning("MO table updated - Run: source(\"data-raw/pre-commit-hook.R\")", call. = FALSE)
warning("MO table updated - Run: source(\"data-raw/_pre_commit_hook.R\")", call. = FALSE)
}
# add a column with only "e coli" like combinations

25
data-raw/_install_deps.R
View File

@@ -28,10 +28,14 @@ install.packages("data-raw/tinytest_1.3.1.tar.gz", dependencies = c("Depends", "
install.packages(getwd(), repos = NULL, type = "source")
# install.packages("data-raw/AMR_latest.tar.gz", dependencies = FALSE)
pkg_suggests <- gsub("[^a-zA-Z0-9]+", "",
pkg_suggests <- gsub(
"[^a-zA-Z0-9]+", "",
unlist(strsplit(unlist(packageDescription("AMR",
fields = c("Suggests", "Enhances", "LinkingTo"))),
split = ", ?")))
fields = c("Suggests", "Enhances", "LinkingTo")
)),
split = ", ?"
))
)
pkg_suggests <- unname(pkg_suggests[!is.na(pkg_suggests)])
cat("################################################\n")
cat("Packages listed in Suggests/Enhances:", paste(pkg_suggests, collapse = ", "), "\n")
@@ -52,19 +56,23 @@ for (i in seq_len(length(to_install))) {
type = "source",
repos = "https://cran.rstudio.com/",
dependencies = c("Depends", "Imports", "LinkingTo"),
quiet = FALSE),
quiet = FALSE
),
# message = function(m) invisible(),
warning = function(w) message(w$message),
error = function(e) message(e$message))
error = function(e) message(e$message)
)
if (.Platform$OS.type != "unix" && !to_install[i] %in% rownames(utils::installed.packages())) {
tryCatch(install.packages(to_install[i],
type = "binary",
repos = "https://cran.rstudio.com/",
dependencies = c("Depends", "Imports", "LinkingTo"),
quiet = FALSE),
quiet = FALSE
),
# message = function(m) invisible(),
warning = function(w) message(w$message),
error = function(e) message(e$message))
error = function(e) message(e$message)
)
}
}
@@ -78,6 +86,7 @@ for (i in seq_len(length(to_update))) {
tryCatch(update.packages(to_update[i], repos = "https://cran.rstudio.com/", ask = FALSE),
# message = function(m) invisible(),
warning = function(w) message(w$message),
error = function(e) message(e$message))
error = function(e) message(e$message)
)
cat("Updated to '", to_update[i], "' v", as.character(packageVersion(to_update[i])), "\n", sep = "")
}

25
data-raw/_language_update.R
View File

@@ -30,7 +30,8 @@ if (!file.exists("DESCRIPTION") || !"Package: AMR" %in% readLines("DESCRIPTION")
stop("Be sure to run this script in the root location of the AMR package folder.\n",
"Working directory expected to contain the DESCRIPTION file of the AMR package.\n",
"Current working directory: ", getwd(),
call. = FALSE)
call. = FALSE
)
}
# save old global env to restore later
@@ -41,7 +42,8 @@ load("R/sysdata.rda", envir = lang_env)
# replace language objects with updates
message("Reading translation file...")
lang_env$TRANSLATIONS <- utils::read.delim(file = "data-raw/translations.tsv",
lang_env$TRANSLATIONS <- utils::read.delim(
file = "data-raw/translations.tsv",
sep = "\t",
stringsAsFactors = FALSE,
header = TRUE,
@@ -52,23 +54,30 @@ lang_env$TRANSLATIONS <- utils::read.delim(file = "data-raw/translations.tsv",
fileEncoding = "UTF-8",
na.strings = c(NA, "", NULL),
allowEscapes = TRUE, # else "\\1" will be imported as "\\\\1"
quote = "")
quote = ""
)
lang_env$LANGUAGES_SUPPORTED_NAMES <- c(list(en = list(exonym = "English", endonym = "English")),
lapply(lang_env$TRANSLATIONS[, which(nchar(colnames(lang_env$TRANSLATIONS)) == 2), drop = FALSE],
function(x) list(exonym = x[1], endonym = x[2])))
lang_env$LANGUAGES_SUPPORTED_NAMES <- c(
list(en = list(exonym = "English", endonym = "English")),
lapply(
lang_env$TRANSLATIONS[, which(nchar(colnames(lang_env$TRANSLATIONS)) == 2), drop = FALSE],
function(x) list(exonym = x[1], endonym = x[2])
)
)
lang_env$LANGUAGES_SUPPORTED <- names(lang_env$LANGUAGES_SUPPORTED_NAMES)
# save env to internal package data
# usethis::use_data() does not allow to save a list :(
message("Saving to internal data...")
save(list = names(lang_env),
save(
list = names(lang_env),
file = "R/sysdata.rda",
ascii = FALSE,
version = 2,
compress = "xz",
envir = lang_env)
envir = lang_env
)
rm(lang_env)

222
data-raw/pre-commit-hook.R → data-raw/_pre_commit_hook.R
View File

@@ -24,7 +24,7 @@
# ==================================================================== #
# Run this file to update the package using:
# source("data-raw/pre-commit-hook.R")
# source("data-raw/_pre_commit_hook.R")
library(dplyr, warn.conflicts = FALSE)
devtools::load_all(quiet = TRUE)
@@ -36,26 +36,34 @@ old_globalenv <- ls(envir = globalenv())
# Save internal data to R/sysdata.rda -------------------------------------
# See 'data-raw/eucast_rules.tsv' for the EUCAST reference file
EUCAST_RULES_DF <- utils::read.delim(file = "data-raw/eucast_rules.tsv",
EUCAST_RULES_DF <- utils::read.delim(
file = "data-raw/eucast_rules.tsv",
skip = 10,
sep = "\t",
stringsAsFactors = FALSE,
header = TRUE,
strip.white = TRUE,
na = c(NA, "", NULL)) %>%
na = c(NA, "", NULL)
) %>%
# take the order of the reference.rule_group column in the original data file
mutate(reference.rule_group = factor(reference.rule_group,
mutate(
reference.rule_group = factor(reference.rule_group,
levels = unique(reference.rule_group),
ordered = TRUE),
sorting_rule = ifelse(grepl("^Table", reference.rule, ignore.case = TRUE), 1, 2)) %>%
arrange(reference.rule_group,
ordered = TRUE
),
sorting_rule = ifelse(grepl("^Table", reference.rule, ignore.case = TRUE), 1, 2)
) %>%
arrange(
reference.rule_group,
reference.version,
sorting_rule,
reference.rule) %>%
reference.rule
) %>%
mutate(reference.rule_group = as.character(reference.rule_group)) %>%
select(-sorting_rule)
TRANSLATIONS <- utils::read.delim(file = "data-raw/translations.tsv",
TRANSLATIONS <- utils::read.delim(
file = "data-raw/translations.tsv",
sep = "\t",
stringsAsFactors = FALSE,
header = TRUE,
@@ -66,11 +74,16 @@ TRANSLATIONS <- utils::read.delim(file = "data-raw/translations.tsv",
fileEncoding = "UTF-8",
na.strings = c(NA, "", NULL),
allowEscapes = TRUE, # else "\\1" will be imported as "\\\\1"
quote = "")
quote = ""
)
LANGUAGES_SUPPORTED_NAMES <- c(list(en = list(exonym = "English", endonym = "English")),
lapply(TRANSLATIONS[, which(nchar(colnames(TRANSLATIONS)) == 2), drop = FALSE],
function(x) list(exonym = x[1], endonym = x[2])))
LANGUAGES_SUPPORTED_NAMES <- c(
list(en = list(exonym = "English", endonym = "English")),
lapply(
TRANSLATIONS[, which(nchar(colnames(TRANSLATIONS)) == 2), drop = FALSE],
function(x) list(exonym = x[1], endonym = x[2])
)
)
LANGUAGES_SUPPORTED <- names(LANGUAGES_SUPPORTED_NAMES)
@@ -84,7 +97,8 @@ create_species_cons_cops <- function(type = c("CoNS", "CoPS")) {
MO_staph <- AMR::microorganisms
MO_staph <- MO_staph[which(MO_staph$genus == "Staphylococcus"), , drop = FALSE]
if (type == "CoNS") {
MO_staph[which(MO_staph$species %in% c("coagulase-negative", "argensis", "arlettae",
MO_staph[which(MO_staph$species %in% c(
"coagulase-negative", "argensis", "arlettae",
"auricularis", "borealis", "caeli", "capitis", "caprae",
"carnosus", "casei", "chromogenes", "cohnii", "condimenti",
"croceilyticus",
@@ -99,28 +113,37 @@ create_species_cons_cops <- function(type = c("CoNS", "CoPS")) {
"ureilyticus",
"vitulinus", "vitulus", "warneri", "xylosus",
"caledonicus", "canis",
"durrellii", "lloydii")
| (MO_staph$species == "schleiferi" & MO_staph$subspecies %in% c("schleiferi", ""))),
"mo", drop = TRUE]
"durrellii", "lloydii"
) |
(MO_staph$species == "schleiferi" & MO_staph$subspecies %in% c("schleiferi", ""))),
"mo",
drop = TRUE
]
} else if (type == "CoPS") {
MO_staph[which(MO_staph$species %in% c("coagulase-positive", "coagulans",
MO_staph[which(MO_staph$species %in% c(
"coagulase-positive", "coagulans",
"agnetis", "argenteus",
"cornubiensis",
"delphini", "lutrae",
"hyicus", "intermedius",
"pseudintermedius", "pseudointermedius",
"schweitzeri", "simiae",
"roterodami")
| (MO_staph$species == "schleiferi" & MO_staph$subspecies == "coagulans")),
"mo", drop = TRUE]
"roterodami"
) |
(MO_staph$species == "schleiferi" & MO_staph$subspecies == "coagulans")),
"mo",
drop = TRUE
]
}
}
create_MO_fullname_lower <- function() {
MO_lookup <- AMR::microorganisms
# use this paste instead of `fullname` to work with Viridans Group Streptococci, etc.
MO_lookup$fullname_lower <- tolower(trimws(paste(MO_lookup$genus,
MO_lookup$fullname_lower <- tolower(trimws(paste(
MO_lookup$genus,
MO_lookup$species,
MO_lookup$subspecies)))
MO_lookup$subspecies
)))
ind <- MO_lookup$genus == "" | grepl("^[(]unknown ", MO_lookup$fullname, perl = TRUE)
MO_lookup[ind, "fullname_lower"] <- tolower(MO_lookup[ind, "fullname", drop = TRUE])
MO_lookup$fullname_lower <- trimws(gsub("[^.a-z0-9/ \\-]+", "", MO_lookup$fullname_lower, perl = TRUE))
@@ -130,7 +153,8 @@ MO_CONS <- create_species_cons_cops("CoNS")
MO_COPS <- create_species_cons_cops("CoPS")
MO_STREP_ABCG <- as.mo(MO_lookup[which(MO_lookup$genus == "Streptococcus"), "mo", drop = TRUE], Lancefield = TRUE) %in% c("B_STRPT_GRPA", "B_STRPT_GRPB", "B_STRPT_GRPC", "B_STRPT_GRPG")
MO_FULLNAME_LOWER <- create_MO_fullname_lower()
MO_PREVALENT_GENERA <- c("Absidia", "Acholeplasma", "Acremonium", "Actinotignum", "Aedes", "Alistipes", "Alloprevotella",
MO_PREVALENT_GENERA <- c(
"Absidia", "Acholeplasma", "Acremonium", "Actinotignum", "Aedes", "Alistipes", "Alloprevotella",
"Alternaria", "Anaerosalibacter", "Ancylostoma", "Angiostrongylus", "Anisakis", "Anopheles",
"Apophysomyces", "Arachnia", "Aspergillus", "Aureobasidium", "Bacteroides", "Basidiobolus",
"Beauveria", "Bergeyella", "Blastocystis", "Blastomyces", "Borrelia", "Brachyspira", "Branhamella",
@@ -152,37 +176,80 @@ MO_PREVALENT_GENERA <- c("Absidia", "Acholeplasma", "Acremonium", "Actinotignum"
"Syngamus", "Taenia", "Tannerella", "Tenacibaculum", "Terrimonas", "Toxocara", "Treponema", "Trichinella",
"Trichobilharzia", "Trichoderma", "Trichomonas", "Trichophyton", "Trichosporon", "Trichostrongylus",
"Trichuris", "Tritirachium", "Trombicula", "Tunga", "Ureaplasma", "Victivallis", "Wautersiella",
"Weeksella", "Wuchereria")
"Weeksella", "Wuchereria"
)
# antibiotic groups
# (these will also be used for eucast_rules() and understanding data-raw/eucast_rules.tsv)
globalenv_before_ab <- c(ls(envir = globalenv()), "globalenv_before_ab")
AB_AMINOGLYCOSIDES <- antibiotics %>% filter(group %like% "aminoglycoside") %>% pull(ab)
AB_AMINOGLYCOSIDES <- antibiotics %>%
filter(group %like% "aminoglycoside") %>%
pull(ab)
AB_AMINOPENICILLINS <- as.ab(c("AMP", "AMX"))
AB_ANTIFUNGALS <- AB_lookup %>% filter(group %like% "antifungal") %>% pull(ab)
AB_ANTIMYCOBACTERIALS <- AB_lookup %>% filter(group %like% "antimycobacterial") %>% pull(ab)
AB_CARBAPENEMS <- antibiotics %>% filter(group %like% "carbapenem") %>% pull(ab)
AB_CEPHALOSPORINS <- antibiotics %>% filter(group %like% "cephalosporin") %>% pull(ab)
AB_CEPHALOSPORINS_1ST <- antibiotics %>% filter(group %like% "cephalosporin.*1") %>% pull(ab)
AB_CEPHALOSPORINS_2ND <- antibiotics %>% filter(group %like% "cephalosporin.*2") %>% pull(ab)
AB_CEPHALOSPORINS_3RD <- antibiotics %>% filter(group %like% "cephalosporin.*3") %>% pull(ab)
AB_CEPHALOSPORINS_4TH <- antibiotics %>% filter(group %like% "cephalosporin.*4") %>% pull(ab)
AB_CEPHALOSPORINS_5TH <- antibiotics %>% filter(group %like% "cephalosporin.*5") %>% pull(ab)
AB_ANTIFUNGALS <- AB_lookup %>%
filter(group %like% "antifungal") %>%
pull(ab)
AB_ANTIMYCOBACTERIALS <- AB_lookup %>%
filter(group %like% "antimycobacterial") %>%
pull(ab)
AB_CARBAPENEMS <- antibiotics %>%
filter(group %like% "carbapenem") %>%
pull(ab)
AB_CEPHALOSPORINS <- antibiotics %>%
filter(group %like% "cephalosporin") %>%
pull(ab)
AB_CEPHALOSPORINS_1ST <- antibiotics %>%
filter(group %like% "cephalosporin.*1") %>%
pull(ab)
AB_CEPHALOSPORINS_2ND <- antibiotics %>%
filter(group %like% "cephalosporin.*2") %>%
pull(ab)
AB_CEPHALOSPORINS_3RD <- antibiotics %>%
filter(group %like% "cephalosporin.*3") %>%
pull(ab)
AB_CEPHALOSPORINS_4TH <- antibiotics %>%
filter(group %like% "cephalosporin.*4") %>%
pull(ab)
AB_CEPHALOSPORINS_5TH <- antibiotics %>%
filter(group %like% "cephalosporin.*5") %>%
pull(ab)
AB_CEPHALOSPORINS_EXCEPT_CAZ <- AB_CEPHALOSPORINS[AB_CEPHALOSPORINS != "CAZ"]
AB_FLUOROQUINOLONES <- antibiotics %>% filter(atc_group2 %like% "fluoroquinolone" | (group %like% "quinolone" & is.na(atc_group2))) %>% pull(ab)
AB_GLYCOPEPTIDES <- antibiotics %>% filter(group %like% "glycopeptide") %>% pull(ab)
AB_FLUOROQUINOLONES <- antibiotics %>%
filter(atc_group2 %like% "fluoroquinolone" | (group %like% "quinolone" & is.na(atc_group2))) %>%
pull(ab)
AB_GLYCOPEPTIDES <- antibiotics %>%
filter(group %like% "glycopeptide") %>%
pull(ab)
AB_LIPOGLYCOPEPTIDES <- as.ab(c("DAL", "ORI", "TLV")) # dalba/orita/tela
AB_GLYCOPEPTIDES_EXCEPT_LIPO <- AB_GLYCOPEPTIDES[!AB_GLYCOPEPTIDES %in% AB_LIPOGLYCOPEPTIDES]
AB_LINCOSAMIDES <- antibiotics %>% filter(atc_group2 %like% "lincosamide" | (group %like% "lincosamide" & is.na(atc_group2))) %>% pull(ab)
AB_MACROLIDES <- antibiotics %>% filter(atc_group2 %like% "macrolide" | (group %like% "macrolide" & is.na(atc_group2))) %>% pull(ab)
AB_OXAZOLIDINONES <- antibiotics %>% filter(group %like% "oxazolidinone") %>% pull(ab)
AB_PENICILLINS <- antibiotics %>% filter(group %like% "penicillin") %>% pull(ab)
AB_POLYMYXINS <- antibiotics %>% filter(group %like% "polymyxin") %>% pull(ab)
AB_QUINOLONES <- antibiotics %>% filter(group %like% "quinolone") %>% pull(ab)
AB_STREPTOGRAMINS <- antibiotics %>% filter(atc_group2 %like% "streptogramin") %>% pull(ab)
AB_TETRACYCLINES <- antibiotics %>% filter(group %like% "tetracycline") %>% pull(ab)
AB_LINCOSAMIDES <- antibiotics %>%
filter(atc_group2 %like% "lincosamide" | (group %like% "lincosamide" & is.na(atc_group2))) %>%
pull(ab)
AB_MACROLIDES <- antibiotics %>%
filter(atc_group2 %like% "macrolide" | (group %like% "macrolide" & is.na(atc_group2))) %>%
pull(ab)
AB_OXAZOLIDINONES <- antibiotics %>%
filter(group %like% "oxazolidinone") %>%
pull(ab)
AB_PENICILLINS <- antibiotics %>%
filter(group %like% "penicillin") %>%
pull(ab)
AB_POLYMYXINS <- antibiotics %>%
filter(group %like% "polymyxin") %>%
pull(ab)
AB_QUINOLONES <- antibiotics %>%
filter(group %like% "quinolone") %>%
pull(ab)
AB_STREPTOGRAMINS <- antibiotics %>%
filter(atc_group2 %like% "streptogramin") %>%
pull(ab)
AB_TETRACYCLINES <- antibiotics %>%
filter(group %like% "tetracycline") %>%
pull(ab)
AB_TETRACYCLINES_EXCEPT_TGC <- AB_TETRACYCLINES[AB_TETRACYCLINES != "TGC"]
AB_TRIMETHOPRIMS <- antibiotics %>% filter(group %like% "trimethoprim") %>% pull(ab)
AB_TRIMETHOPRIMS <- antibiotics %>%
filter(group %like% "trimethoprim") %>%
pull(ab)
AB_UREIDOPENICILLINS <- as.ab(c("PIP", "TZP", "AZL", "MEZ"))
AB_BETALACTAMS <- c(AB_PENICILLINS, AB_CEPHALOSPORINS, AB_CARBAPENEMS)
# this will be used for documentation:
@@ -194,15 +261,21 @@ create_AB_lookup <- function() {
AB_lookup$generalised_synonyms <- lapply(AB_lookup$synonyms, generalise_antibiotic_name)
AB_lookup$generalised_abbreviations <- lapply(AB_lookup$abbreviations, generalise_antibiotic_name)
AB_lookup$generalised_loinc <- lapply(AB_lookup$loinc, generalise_antibiotic_name)
AB_lookup$generalised_all <- unname(lapply(as.list(as.data.frame(t(AB_lookup[,
c("ab", "atc", "cid", "name",
colnames(AB_lookup)[colnames(AB_lookup) %like% "generalised"]),
drop = FALSE]),
stringsAsFactors = FALSE)),
AB_lookup$generalised_all <- unname(lapply(
as.list(as.data.frame(t(AB_lookup[,
c(
"ab", "atc", "cid", "name",
colnames(AB_lookup)[colnames(AB_lookup) %like% "generalised"]
),
drop = FALSE
]),
stringsAsFactors = FALSE
)),
function(x) {
x <- generalise_antibiotic_name(unname(unlist(x)))
x[x != ""]
}))
}
))
AB_lookup[, colnames(AB_lookup)[colnames(AB_lookup) %like% "^generalised"]]
}
AB_LOOKUP <- create_AB_lookup()
@@ -251,7 +324,8 @@ suppressMessages(usethis::use_data(EUCAST_RULES_DF,
internal = TRUE,
overwrite = TRUE,
version = 2,
compress = "xz"))
compress = "xz"
))
# Export data sets to the repository in different formats -----------------
@@ -273,12 +347,15 @@ write_md5 <- function(object) {
close(conn)
}
changed_md5 <- function(object) {
tryCatch({
tryCatch(
{
conn <- file(paste0("data-raw/", deparse(substitute(object)), ".md5"))
compared <- md5(object) != readLines(con = conn)
close(conn)
compared
}, error = function(e) TRUE)
},
error = function(e) TRUE
)
}
# give official names to ABs and MOs
@@ -306,7 +383,7 @@ if (changed_md5(microorganisms)) {
max_50_snomed <- sapply(microorganisms$snomed, function(x) paste(x[seq_len(min(50, length(x), na.rm = TRUE))], collapse = " "))
mo <- microorganisms
mo$snomed <- max_50_snomed
mo <- dplyr::mutate_if(mo, ~!is.numeric(.), as.character)
mo <- dplyr::mutate_if(mo, ~ !is.numeric(.), as.character)
try(haven::write_sas(mo, "data-raw/microorganisms.sas"), silent = TRUE)
try(haven::write_sav(mo, "data-raw/microorganisms.sav"), silent = TRUE)
try(haven::write_dta(mo, "data-raw/microorganisms.dta"), silent = TRUE)
@@ -328,7 +405,7 @@ if (changed_md5(microorganisms.old)) {
try(arrow::write_parquet(microorganisms.old, "data-raw/microorganisms.old.parquet"), silent = TRUE)
}
ab <- dplyr::mutate_if(antibiotics, ~!is.numeric(.), as.character)
ab <- dplyr::mutate_if(antibiotics, ~ !is.numeric(.), as.character)
if (changed_md5(ab)) {
usethis::ui_info(paste0("Saving {usethis::ui_value('antibiotics')} to {usethis::ui_value('data-raw/')}"))
write_md5(ab)
@@ -342,7 +419,7 @@ if (changed_md5(ab)) {
try(arrow::write_parquet(antibiotics, "data-raw/antibiotics.parquet"), silent = TRUE)
}
av <- dplyr::mutate_if(antivirals, ~!is.numeric(.), as.character)
av <- dplyr::mutate_if(antivirals, ~ !is.numeric(.), as.character)
if (changed_md5(av)) {
usethis::ui_info(paste0("Saving {usethis::ui_value('antivirals')} to {usethis::ui_value('data-raw/')}"))
write_md5(av)
@@ -357,9 +434,11 @@ if (changed_md5(av)) {
}
# give official names to ABs and MOs
intrinsicR <- data.frame(microorganism = mo_name(intrinsic_resistant$mo, language = NULL),
intrinsicR <- data.frame(
microorganism = mo_name(intrinsic_resistant$mo, language = NULL),
antibiotic = ab_name(intrinsic_resistant$ab, language = NULL),
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
if (changed_md5(intrinsicR)) {
usethis::ui_info(paste0("Saving {usethis::ui_value('intrinsic_resistant')} to {usethis::ui_value('data-raw/')}"))
write_md5(intrinsicR)
@@ -394,4 +473,25 @@ rm(list = current_globalenv[!current_globalenv %in% old_globalenv])
rm(current_globalenv)
devtools::load_all(quiet = TRUE)
devtools::document()
# Document pkg ------------------------------------------------------------
usethis::ui_info("Documenting package")
suppressMessages(devtools::document(quiet = TRUE))
# Style pkg ---------------------------------------------------------------
usethis::ui_info("Styling package")
invisible(capture.output(styler::style_pkg(
style = styler::tidyverse_style,
filetype = c("R", "Rmd")
)))
invisible(capture.output(styler::style_dir(
path = "inst", # unit tests
style = styler::tidyverse_style,
filetype = c("R", "Rmd")
)))
# Finished ----------------------------------------------------------------
usethis::ui_info("All done")

8
data-raw/loinc.R
View File

@@ -31,7 +31,8 @@
# 3. Read Loinc.csv that's in this zip file
loinc_df <- read.csv("data-raw/Loinc.csv",
row.names = NULL,
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
# 4. Clean and add
library(dplyr)
@@ -39,7 +40,10 @@ library(cleaner)
library(AMR)
loinc_df %>% freq(CLASS) # to find the drugs
loinc_df <- loinc_df %>% filter(CLASS == "DRUG/TOX")
ab_names <- antibiotics %>% pull(name) %>% paste0(collapse = "|") %>% paste0("(", ., ")")
ab_names <- antibiotics %>%
pull(name) %>%
paste0(collapse = "|") %>%
paste0("(", ., ")")
antibiotics$loinc <- as.list(rep(NA_character_, nrow(antibiotics)))
for (i in seq_len(nrow(antibiotics))) {

121
data-raw/read_EUCAST.R
View File

@@ -32,7 +32,6 @@ library(AMR)
# USE THIS FUNCTION TO READ THE EUCAST EXCEL FILE THAT CONTAINS THE BREAKPOINT TABLES
read_EUCAST <- function(sheet, file, guideline_name) {
message("\nGetting sheet: ", sheet)
sheet.bak <- sheet
@@ -45,14 +44,16 @@ read_EUCAST <- function(sheet, file, guideline_name) {
}
}
raw_data <- read.xlsx(xlsxFile = file,
raw_data <- read.xlsx(
xlsxFile = file,
sheet = sheet,
colNames = FALSE,
skipEmptyRows = FALSE,
skipEmptyCols = FALSE,
fillMergedCells = TRUE,
na.strings = c("", "-", "NA", "IE", "IP"))
probable_rows <- suppressWarnings(raw_data %>% mutate_all(as.double) %>% summarise_all(~sum(!is.na(.))) %>% unlist() %>% max())
na.strings = c("", "-", "NA", "IE", "IP")
)
probable_rows <- suppressWarnings(raw_data %>% mutate_all(as.double) %>% summarise_all(~ sum(!is.na(.))) %>% unlist() %>% max())
if (probable_rows == 0) {
message("NO ROWS FOUND")
message("------------------------")
@@ -61,27 +62,34 @@ read_EUCAST <- function(sheet, file, guideline_name) {
# in the info header in the Excel file, EUCAST mentions which genera are targeted
if (sheet %like% "anaerob.*Gram.*posi") {
sheet <- paste0(c("Actinomyces", "Bifidobacterium", "Clostridioides",
sheet <- paste0(c(
"Actinomyces", "Bifidobacterium", "Clostridioides",
"Clostridium", "Cutibacterium", "Eggerthella",
"Eubacterium", "Lactobacillus", "Propionibacterium",
"Staphylococcus saccharolyticus"),
collapse = "_")
"Staphylococcus saccharolyticus"
),
collapse = "_"
)
} else if (sheet %like% "anaerob.*Gram.*nega") {
sheet <- paste0(c("Bacteroides",
sheet <- paste0(c(
"Bacteroides",
"Bilophila",
"Fusobacterium",
"Mobiluncus",
"Parabacteroides",
"Porphyromonas",
"Prevotella"),
collapse = "_")
"Prevotella"
),
collapse = "_"
)
} else if (sheet == "Streptococcus A,B,C,G") {
sheet <- paste0(microorganisms %>%
filter(genus == "Streptococcus") %>%
mutate(lancefield = mo_name(mo, Lancefield = TRUE)) %>%
filter(lancefield %like% "^Streptococcus group") %>%
pull(fullname),
collapse = "_")
collapse = "_"
)
} else if (sheet %like% "PK.*PD") {
sheet <- "UNKNOWN"
}
@@ -105,7 +113,8 @@ read_EUCAST <- function(sheet, file, guideline_name) {
x
}
MICs_with_trailing_superscript <- c(seq(from = 0.0011, to = 0.0019, by = 0.0001),
MICs_with_trailing_superscript <- c(
seq(from = 0.0011, to = 0.0019, by = 0.0001),
seq(from = 0.031, to = 0.039, by = 0.001),
seq(from = 0.061, to = 0.069, by = 0.001),
seq(from = 0.1251, to = 0.1259, by = 0.0001),
@@ -116,7 +125,8 @@ read_EUCAST <- function(sheet, file, guideline_name) {
seq(from = 21, to = 29, by = 1),
seq(from = 321, to = 329, by = 1),
seq(from = 41, to = 49, by = 1),
seq(from = 81, to = 89, by = 1))
seq(from = 81, to = 89, by = 1)
)
has_superscript <- function(x) {
# because due to floating point error, 0.1252 is not in:
# seq(from = 0.1251, to = 0.1259, by = 0.0001)
@@ -128,27 +138,36 @@ read_EUCAST <- function(sheet, file, guideline_name) {
cleaned <- raw_data %>%
as_tibble() %>%
set_columns_names(LETTERS) %>%
transmute(drug = A,
transmute(
drug = A,
MIC_S = B,
MIC_R = C,
disk_dose = ifelse(has_zone_diameters, E, NA_character_),
disk_S = ifelse(has_zone_diameters, `F`, NA_character_),
disk_R = ifelse(has_zone_diameters, G, NA_character_)) %>%
filter(!is.na(drug),
disk_R = ifelse(has_zone_diameters, G, NA_character_)
) %>%
filter(
!is.na(drug),
!(is.na(MIC_S) & is.na(MIC_R) & is.na(disk_S) & is.na(disk_R)),
MIC_S %unlike% "(MIC|S ≤|note)",
MIC_S %unlike% "^[-]",
drug != MIC_S,) %>%
mutate(administration = case_when(drug %like% "[( ]oral" ~ "oral",
drug != MIC_S,
) %>%
mutate(
administration = case_when(
drug %like% "[( ]oral" ~ "oral",
drug %like% "[( ]iv" ~ "iv",
TRUE ~ NA_character_),
TRUE ~ NA_character_
),
uti = ifelse(drug %like% "(UTI|urinary|urine)", TRUE, FALSE),
systemic = ifelse(drug %like% "(systemic|septic)", TRUE, FALSE),
mo = ifelse(drug %like% "([.]|spp)", get_mo(drug), mo_sheet)) %>%
mo = ifelse(drug %like% "([.]|spp)", get_mo(drug), mo_sheet)
) %>%
# clean disk doses
mutate(disk_dose = clean_character(disk_dose, remove = "[^0-9.-]")) %>%
# clean MIC and disk values
mutate(MIC_S = gsub(".,.", "", MIC_S), # remove superscript notes with comma, like 0.5^2,3
mutate(
MIC_S = gsub(".,.", "", MIC_S), # remove superscript notes with comma, like 0.5^2,3
MIC_R = gsub(".,.", "", MIC_R),
disk_S = gsub(".,.", "", disk_S),
disk_R = gsub(".,.", "", disk_R),
@@ -159,18 +178,22 @@ read_EUCAST <- function(sheet, file, guideline_name) {
# invalid MIC values have a superscript text, delete those
MIC_S = ifelse(has_superscript(MIC_S),
substr(MIC_S, 1, nchar(MIC_S) - 1),
MIC_S),
MIC_S
),
MIC_R = ifelse(has_superscript(MIC_R),
substr(MIC_R, 1, nchar(MIC_R) - 1),
MIC_R),
MIC_R
),
# and some are just awful
MIC_S = ifelse(MIC_S == 43.4, 4, MIC_S),
MIC_R = ifelse(MIC_R == 43.4, 4, MIC_R),
) %>%
# clean drug names
mutate(drug = gsub(" ?[(, ].*$", "", drug),
mutate(
drug = gsub(" ?[(, ].*$", "", drug),
drug = gsub("[1-9]+$", "", drug),
ab = as.ab(drug)) %>%
ab = as.ab(drug)
) %>%
select(ab, mo, everything(), -drug) %>%
as.data.frame(stringsAsFactors = FALSE)
@@ -181,7 +204,7 @@ read_EUCAST <- function(sheet, file, guideline_name) {
mo_vect <- unlist(strsplit(mo, "|", fixed = TRUE))
cleaned[i, "mo"] <- mo_vect[1]
for (j in seq_len(length(mo_vect))) {
cleaned <- bind_rows(cleaned, cleaned[i , , drop = FALSE])
cleaned <- bind_rows(cleaned, cleaned[i, , drop = FALSE])
cleaned[nrow(cleaned), "mo"] <- mo_vect[j]
}
}
@@ -192,24 +215,31 @@ read_EUCAST <- function(sheet, file, guideline_name) {
arrange(ab, mo) %>%
mutate_at(c("MIC_S", "MIC_R", "disk_S", "disk_R"), as.double) %>%
pivot_longer(c("MIC_S", "MIC_R", "disk_S", "disk_R"), "type") %>%
mutate(method = ifelse(type %like% "MIC", "MIC", "DISK"),
type = gsub("^.*_", "breakpoint_", type)) %>%
mutate(
method = ifelse(type %like% "MIC", "MIC", "DISK"),
type = gsub("^.*_", "breakpoint_", type)
) %>%
pivot_wider(names_from = type, values_from = value) %>%
mutate(guideline = guideline_name,
mutate(
guideline = guideline_name,
disk_dose = ifelse(method == "DISK", disk_dose, NA_character_),
mo = ifelse(mo == "", mo_sheet, mo)) %>%
mo = ifelse(mo == "", mo_sheet, mo)
) %>%
filter(!(is.na(breakpoint_S) & is.na(breakpoint_R))) %>%
# comply with rsi_translation for now
transmute(guideline,
method,
site = case_when(uti ~ "UTI",
site = case_when(
uti ~ "UTI",
systemic ~ "Systemic",
TRUE ~ administration),
TRUE ~ administration
),
mo, ab,
ref_tbl = sheet.bak,
disk_dose = ifelse(!is.na(disk_dose), paste0(disk_dose, "ug"), NA_character_),
breakpoint_S,
breakpoint_R) %>%
breakpoint_R
) %>%
as.data.frame(stringsAsFactors = FALSE)
if (!is.null(uncertainties)) {
@@ -231,24 +261,33 @@ guideline_name <- "EUCAST 2021"
sheets_to_analyse <- sheets[!sheets %in% c("Content", "Changes", "Notes", "Guidance", "Dosages", "Technical uncertainty", "Topical agents")]
# takes the longest time:
new_EUCAST <- read_EUCAST(sheet = sheets_to_analyse[1],
new_EUCAST <- read_EUCAST(
sheet = sheets_to_analyse[1],
file = file,
guideline_name = guideline_name)
guideline_name = guideline_name
)
for (i in 2:length(sheets_to_analyse)) {
tryCatch(
new_EUCAST <<- bind_rows(new_EUCAST,
read_EUCAST(sheet = sheets_to_analyse[i],
new_EUCAST <<- bind_rows(
new_EUCAST,
read_EUCAST(
sheet = sheets_to_analyse[i],
file = file,
guideline_name = guideline_name))
, error = function(e) message(e$message))
guideline_name = guideline_name
)
),
error = function(e) message(e$message)
)
}
# 2021-07-12 fix for Morganellaceae (check other lines too next time)
morg <- rsi_translation %>%
as_tibble() %>%
filter(ab == "IPM",
filter(
ab == "IPM",
guideline == "EUCAST 2021",
mo == as.mo("Enterobacterales")) %>%
mo == as.mo("Enterobacterales")
) %>%
mutate(mo = as.mo("Morganellaceae"))
morg[which(morg$method == "MIC"), "breakpoint_S"] <- 0.001
morg[which(morg$method == "MIC"), "breakpoint_R"] <- 4

181
data-raw/reproduction_of_antibiotics.R
View File

@@ -33,16 +33,20 @@ library(dplyr)
library(readxl)
DRGLST <- read_excel("DRGLST.xlsx")
abx <- DRGLST %>%
select(ab = WHON5_CODE,
name = ANTIBIOTIC) %>%
select(
ab = WHON5_CODE,
name = ANTIBIOTIC
) %>%
# remove the ones without WHONET code
filter(!is.na(ab)) %>%
distinct(name, .keep_all = TRUE) %>%
# add the ones without WHONET code
bind_rows(
DRGLST %>%
select(ab = WHON5_CODE,
name = ANTIBIOTIC) %>%
select(
ab = WHON5_CODE,
name = ANTIBIOTIC
) %>%
filter(is.na(ab)) %>%
distinct(name, .keep_all = TRUE)
# add new ab code later
@@ -51,16 +55,21 @@ abx <- DRGLST %>%
# add old ATC codes
ab_old <- AMR::antibiotics %>%
mutate(official = gsub("( and |, )", "/", official),
mutate(
official = gsub("( and |, )", "/", official),
abbr = tolower(paste(ifelse(is.na(abbr), "", abbr),
ifelse(is.na(certe), "", certe),
ifelse(is.na(umcg), "", umcg),
sep = "|")))
sep = "|"
))
)
for (i in 1:nrow(ab_old)) {
abbr <- ab_old[i, "abbr"]
abbr <- strsplit(abbr, "|", fixed = TRUE) %>% unlist() %>% unique()
abbr <- strsplit(abbr, "|", fixed = TRUE) %>%
unlist() %>%
unique()
abbr <- abbr[abbr != ""]
#print(abbr)
# print(abbr)
if (length(abbr) == 0) {
ab_old[i, "abbr"] <- NA_character_
} else {
@@ -101,21 +110,25 @@ abx_atc1 <- abx %>%
mutate(official = gsub("ine$", "in", official)) %>%
transmute(official = tolower(official), atc), by = c(name_lower = "official")) %>%
rename(atc6 = atc) %>%
mutate(atc = case_when(!is.na(atc1) ~ atc1,
mutate(atc = case_when(
!is.na(atc1) ~ atc1,
!is.na(atc2) ~ atc2,
!is.na(atc3) ~ atc3,
!is.na(atc4) ~ atc4,
!is.na(atc4) ~ atc5,
TRUE ~ atc6)) %>%
TRUE ~ atc6
)) %>%
distinct(ab, name, .keep_all = TRUE) %>%
select(ab, atc, name)
abx_atc2 <- ab_old %>%
filter(!atc %in% abx_atc1$atc,
filter(
!atc %in% abx_atc1$atc,
is.na(ears_net),
!is.na(atc_group1),
atc_group1 %unlike% ("virus|vaccin|viral|immun"),
official %unlike% "(combinations| with )") %>%
official %unlike% "(combinations| with )"
) %>%
mutate(ab = NA_character_) %>%
as.data.frame(stringsAsFactors = FALSE) %>%
select(ab, atc, name = official)
@@ -125,12 +138,15 @@ abx2 <- bind_rows(abx_atc1, abx_atc2)
rm(abx_atc1)
rm(abx_atc2)
abx2$ab[is.na(abx2$ab)] <- toupper(abbreviate(gsub("[/0-9-]",
abx2$ab[is.na(abx2$ab)] <- toupper(abbreviate(gsub(
"[/0-9-]",
" ",
abx2$name[is.na(abx2$ab)]),
minlength = 3,
method = "left.kept",
strict = TRUE))
abx2$name[is.na(abx2$ab)]
),
minlength = 3,
method = "left.kept",
strict = TRUE
))
n_distinct(abx2$ab)
@@ -150,7 +166,9 @@ for (i in 2:nrow(abx2)) {
abx2[i, "ab"] <- paste0(abx2[i, "ab", drop = TRUE], abx2[i, "seqnr", drop = TRUE])
}
}
abx2 <- abx2 %>% select(-seqnr) %>% arrange(name)
abx2 <- abx2 %>%
select(-seqnr) %>%
arrange(name)
# everything unique??
nrow(abx2) == n_distinct(abx2$ab)
@@ -158,8 +176,10 @@ nrow(abx2) == n_distinct(abx2$ab)
# get ATC properties
abx2 <- abx2 %>%
left_join(ab_old %>%
select(atc, abbr, atc_group1, atc_group2,
oral_ddd, oral_units, iv_ddd, iv_units))
select(
atc, abbr, atc_group1, atc_group2,
oral_ddd, oral_units, iv_ddd, iv_units
))
abx2$abbr <- lapply(as.list(abx2$abbr), function(x) unlist(strsplit(x, "|", fixed = TRUE)))
@@ -171,29 +191,41 @@ get_CID <- function(ab) {
p$tick()$print()
CID[i] <- tryCatch(
data.table::fread(paste0("https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/name/",
data.table::fread(paste0(
"https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/name/",
URLencode(ab[i], reserved = TRUE),
"/cids/TXT?name_type=complete"),
showProgress = FALSE)[[1]][1],
error = function(e) NA_integer_)
"/cids/TXT?name_type=complete"
),
showProgress = FALSE
)[[1]][1],
error = function(e) NA_integer_
)
if (is.na(CID[i])) {
# try with removing the text in brackets
CID[i] <- tryCatch(
data.table::fread(paste0("https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/name/",
data.table::fread(paste0(
"https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/name/",
URLencode(trimws(gsub("[(].*[)]", "", ab[i])), reserved = TRUE),
"/cids/TXT?name_type=complete"),
showProgress = FALSE)[[1]][1],
error = function(e) NA_integer_)
"/cids/TXT?name_type=complete"
),
showProgress = FALSE
)[[1]][1],
error = function(e) NA_integer_
)
}
if (is.na(CID[i])) {
# try match on word and take the lowest CID value (sorted)
ab[i] <- gsub("[^a-z0-9]+", " ", ab[i], ignore.case = TRUE)
CID[i] <- tryCatch(
data.table::fread(paste0("https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/name/",
data.table::fread(paste0(
"https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/name/",
URLencode(ab[i], reserved = TRUE),
"/cids/TXT?name_type=word"),
showProgress = FALSE)[[1]][1],
error = function(e) NA_integer_)
"/cids/TXT?name_type=word"
),
showProgress = FALSE
)[[1]][1],
error = function(e) NA_integer_
)
}
Sys.sleep(0.1)
}
@@ -203,15 +235,15 @@ get_CID <- function(ab) {
# get CIDs (2-3 min)
CIDs <- get_CID(abx2$name)
# These could not be found:
abx2[is.na(CIDs),] %>% View()
abx2[is.na(CIDs), ] %>% View()
# returns list with synonyms (brand names), with CIDs as names
get_synonyms <- function(CID, clean = TRUE) {
synonyms <- rep(NA_character_, length(CID))
#p <- progress_ticker(n = length(CID), min_time = 0)
# p <- progress_ticker(n = length(CID), min_time = 0)
for (i in 1:length(CID)) {
#p$tick()$print()
# p$tick()$print()
synonyms_txt <- ""
@@ -220,26 +252,36 @@ get_synonyms <- function(CID, clean = TRUE) {
}
synonyms_txt <- tryCatch(
data.table::fread(paste0("https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/fastidentity/cid/",
data.table::fread(paste0(
"https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/fastidentity/cid/",
CID[i],
"/synonyms/TXT"),
"/synonyms/TXT"
),
sep = "\n",
showProgress = FALSE)[[1]],
error = function(e) NA_character_)
showProgress = FALSE
)[[1]],
error = function(e) NA_character_
)
Sys.sleep(0.1)
if (clean == TRUE) {
# remove text between brackets
synonyms_txt <- trimws(gsub("[(].*[)]", "",
gsub("[[].*[]]", "",
gsub("[(].*[]]", "",
gsub("[[].*[)]", "", synonyms_txt)))))
synonyms_txt <- trimws(gsub(
"[(].*[)]", "",
gsub(
"[[].*[]]", "",
gsub(
"[(].*[]]", "",
gsub("[[].*[)]", "", synonyms_txt)
)
)
))
synonyms_txt <- gsub("Co-", "Co", synonyms_txt, fixed = TRUE)
# only length 6 to 20 and no txt with reading marks or numbers and must start with capital letter (= brand)
synonyms_txt <- synonyms_txt[nchar(synonyms_txt) %in% c(6:20)
& !grepl("[-&{},_0-9/]", synonyms_txt)
& grepl("^[A-Z]", synonyms_txt, ignore.case = FALSE)]
synonyms_txt <- synonyms_txt[nchar(synonyms_txt) %in% c(6:20) &
!grepl("[-&{},_0-9/]", synonyms_txt) &
grepl("^[A-Z]", synonyms_txt, ignore.case = FALSE)]
synonyms_txt <- unlist(strsplit(synonyms_txt, ";", fixed = TRUE))
}
synonyms_txt <- unique(trimws(synonyms_txt[tolower(synonyms_txt) %in% unique(tolower(synonyms_txt))]))
@@ -251,13 +293,16 @@ get_synonyms <- function(CID, clean = TRUE) {
# get brand names from PubChem (2-3 min)
synonyms <- get_synonyms(CIDs)
synonyms <- lapply(synonyms,
synonyms <- lapply(
synonyms,
function(x) {
if (length(x) == 0 | all(is.na(x))) {
""
} else {
x
}})
}
}
)
# add them to data set
antibiotics <- abx2 %>%
@@ -296,7 +341,8 @@ antibiotics <- abx2 %>%
abbreviations = unname(abbr),
synonyms = unname(synonyms),
oral_ddd, oral_units,
iv_ddd, iv_units) %>%
iv_ddd, iv_units
) %>%
as.data.frame(stringsAsFactors = FALSE)
# some exceptions
@@ -329,13 +375,15 @@ antibiotics[which(antibiotics$ab == as.ab("cefepime")), "abbreviations"][[1]] <-
antibiotics[which(antibiotics$ab == as.ab("cefoxitin")), "abbreviations"][[1]] <- list(c(antibiotics[which(antibiotics$ab == as.ab("cefoxitin")), "abbreviations"][[1]], "cfxt"))
# Add cefoxitin screening
class(antibiotics$ab) <- "character"
antibiotics <- rbind(antibiotics,data.frame(ab = "FOX1", atc = NA, cid = NA,
antibiotics <- rbind(antibiotics, data.frame(
ab = "FOX1", atc = NA, cid = NA,
name = "Cefoxitin screening",
group = "Cephalosporins (2nd gen.)", atc_group1 = NA, atc_group2 = NA,
abbreviations = "cfsc", synonyms = NA,
oral_ddd = NA, oral_units = NA, iv_ddd = NA, iv_units = NA,
loinc = NA,
stringsAsFactors = FALSE))
stringsAsFactors = FALSE
))
# More GLIMS codes
antibiotics[which(antibiotics$ab == "AMB"), "abbreviations"][[1]] <- list(c(antibiotics[which(antibiotics$ab == "AMB"), "abbreviations"][[1]], "amf"))
antibiotics[which(antibiotics$ab == "CAZ"), "abbreviations"][[1]] <- list(c(antibiotics[which(antibiotics$ab == "CAZ"), "abbreviations"][[1]], "cftz"))
@@ -524,23 +572,29 @@ antibiotics <- antibiotics %>%
mutate(ab = as.character(ab)) %>%
rbind(antibiotics %>%
filter(ab == "GEH") %>%
mutate(ab = "AMH",
mutate(
ab = "AMH",
name = "Amphotericin B-high",
abbreviations = list(c("amhl", "amfo b high", "ampho b high", "amphotericin high")))) %>%
abbreviations = list(c("amhl", "amfo b high", "ampho b high", "amphotericin high"))
)) %>%
rbind(antibiotics %>%
filter(ab == "GEH") %>%
mutate(ab = "TOH",
mutate(
ab = "TOH",
name = "Tobramycin-high",
abbreviations = list(c("tohl", "tobra high", "tobramycin high")))) %>%
abbreviations = list(c("tohl", "tobra high", "tobramycin high"))
)) %>%
rbind(antibiotics %>%
filter(ab == "BUT") %>%
mutate(ab = "CIX",
mutate(
ab = "CIX",
atc = "D01AE14",
name = "Ciclopirox",
group = "Antifungals/antimycotics",
atc_group1 = "Antifungals for topical use",
atc_group2 = "Other antifungals for topical use",
abbreviations = list(c("cipx"))))
abbreviations = list(c("cipx"))
))
antibiotics[which(antibiotics$ab == "SSS"), "name"] <- "Sulfonamide"
# ESBL E-test codes:
antibiotics[which(antibiotics$ab == "CCV"), "abbreviations"][[1]] <- list(c("xtzl"))
@@ -650,7 +704,8 @@ antibiotics <- antibiotics %>%
name == "Ceftolozane/enzyme inhibitor" ~ "Cephalosporins (5th gen.)",
name == "Ceftolozane/tazobactam" ~ "Cephalosporins (5th gen.)",
name == "Cefuroxime axetil" ~ "Cephalosporins (2nd gen.)",
TRUE ~ group))
TRUE ~ group
))
antibiotics[which(antibiotics$ab %in% c("CYC", "LNZ", "THA", "TZD")), "group"] <- "Oxazolidinones"
# add pretomanid
@@ -659,12 +714,14 @@ antibiotics <- antibiotics %>%
bind_rows(antibiotics %>%
mutate(ab = as.character(ab)) %>%
filter(ab == "SMF") %>%
mutate(ab = "PMD",
mutate(
ab = "PMD",
atc = "J04AK08",
cid = 456199,
name = "Pretomanid",
abbreviations = list(""),
oral_ddd = NA_real_))
oral_ddd = NA_real_
))
@@ -675,7 +732,6 @@ antibiotics <- antibiotics %>%
updated_atc <- as.list(antibiotics$atc)
get_atcs <- function(ab_name, url = "https://www.whocc.no/atc_ddd_index/") {
ab_name <- gsub("/", " and ", tolower(ab_name), fixed = TRUE)
# we will do a search on their website, which means:
@@ -704,7 +760,8 @@ get_atcs <- function(ab_name, url = "https://www.whocc.no/atc_ddd_index/") {
for (i in seq_len(nrow(antibiotics))) {
message(percentage(i / nrow(antibiotics), digits = 1),
" - Downloading ", antibiotics$name[i],
appendLF = FALSE)
appendLF = FALSE
)
atcs <- get_atcs(antibiotics$name[i])
if (length(atcs) > 0) {
updated_atc[[i]] <- atcs

23
data-raw/reproduction_of_antivirals.R
View File

@@ -28,7 +28,9 @@
get_atc_table <- function(atc_group) {
# give as input J0XXX, like atc_group = "J05AB"
downloaded <- read_html(paste0("https://www.whocc.no/atc_ddd_index/?code=", atc_group, "&showdescription=no"))
table_title <- downloaded %>% html_nodes(paste0('a[href="./?code=', atc_group, '"]')) %>% html_text()
table_title <- downloaded %>%
html_nodes(paste0('a[href="./?code=', atc_group, '"]')) %>%
html_text()
table_content <- downloaded %>%
html_nodes("table") %>%
html_table(header = TRUE) %>%
@@ -48,7 +50,8 @@ get_atc_table <- function(atc_group) {
}
table_content %>% select(atc, name, atc_group,
oral_ddd = ddd_O, oral_units = unit_O,
iv_ddd = ddd_P, iv_units = unit_P)
iv_ddd = ddd_P, iv_units = unit_P
)
}
# these are the relevant groups for input: https://www.whocc.no/atc_ddd_index/?code=J05A (J05 only contains J05A)
@@ -62,21 +65,26 @@ for (i in 2:length(atc_groups)) {
}
# arrange on name, untibble it
antivirals <- antivirals %>% arrange(name) %>% as.data.frame(stringsAsFactors = FALSE)
antivirals <- antivirals %>%
arrange(name) %>%
as.data.frame(stringsAsFactors = FALSE)
# add PubChem Compound ID (cid) and their trade names - functions are in file to create `antibiotics` data set
CIDs <- get_CID(antivirals$name)
# these could not be found:
antivirals[is.na(CIDs),] %>% View()
antivirals[is.na(CIDs), ] %>% View()
# get brand names from PubChem
synonyms <- get_synonyms(CIDs)
synonyms <- lapply(synonyms,
synonyms <- lapply(
synonyms,
function(x) {
if (length(x) == 0 | all(is.na(x))) {
""
} else {
x
}})
}
}
)
antivirals <- antivirals %>%
transmute(atc,
@@ -87,7 +95,8 @@ antivirals <- antivirals %>%
oral_ddd,
oral_units,
iv_ddd,
iv_units)
iv_units
)
# save it
usethis::use_data(antivirals, overwrite = TRUE)

39
data-raw/reproduction_of_dosage.R
View File

@@ -39,26 +39,34 @@ dosage_source <- read_excel("data-raw/Dosages_v_11.0_Breakpoint_Tables.xlsx", sk
# keep only one drug in the table
arrange(desc(drug)) %>%
mutate(drug = gsub("(.*) ([(]|iv|oral).*", "\\1", drug)) %>%
#distinct(drug, .keep_all = TRUE) %>%
# distinct(drug, .keep_all = TRUE) %>%
arrange(drug) %>%
mutate(ab = as.ab(drug),
ab_name = ab_name(ab, language = NULL))
mutate(
ab = as.ab(drug),
ab_name = ab_name(ab, language = NULL)
)
dosage_source <- bind_rows(
# oral
dosage_source %>%
filter(standard_dosage %like% " oral") %>%
mutate(standard_dosage = gsub("oral.*", "oral", standard_dosage),
mutate(
standard_dosage = gsub("oral.*", "oral", standard_dosage),
high_dosage = if_else(high_dosage %like% "oral",
gsub("oral.*", "oral", high_dosage),
NA_character_)),
NA_character_
)
),
# iv
dosage_source %>%
filter(standard_dosage %like% " iv") %>%
mutate(standard_dosage = gsub(".* or ", "", standard_dosage),
mutate(
standard_dosage = gsub(".* or ", "", standard_dosage),
high_dosage = if_else(high_dosage %like% "( or | iv)",
gsub(".* or ", "", high_dosage),
NA_character_)),
NA_character_
)
),
# im
dosage_source %>%
filter(standard_dosage %like% " im")
@@ -79,11 +87,12 @@ get_dosage_lst <- function(col_data) {
# remove drug names
gsub(" [a-z]{5,99}( |$)", " ", .) %>%
gsub(" [a-z]{5,99}( |$)", " ", .) %>%
gsub(" (acid|dose)", "", .)# %>%
gsub(" (acid|dose)", "", .) # %>%
# keep lowest value only (25-30 mg -> 25 mg)
# gsub("[-].*? ", " ", .)
dosage_lst <- lapply(strsplit(standard, " x "),
dosage_lst <- lapply(
strsplit(standard, " x "),
function(x) {
dose <- x[1]
if (dose %like% "under") {
@@ -98,7 +107,8 @@ get_dosage_lst <- function(col_data) {
notes = "",
original_txt = ""
)
})
}
)
for (i in seq_len(length(col_data))) {
dosage_lst[[i]]$original_txt <- gsub("\n", " ", col_data[i])
if (col_data[i] %like% " (or|with|loading|depending|over) ") {
@@ -147,10 +157,13 @@ dosage <- bind_rows(
notes = sapply(uti, function(x) x$notes),
original_txt = sapply(uti, function(x) x$original_txt),
stringsAsFactors = FALSE
)) %>%
mutate(eucast_version = breakpoints_version,
)
) %>%
mutate(
eucast_version = breakpoints_version,
dose_times = as.integer(dose_times),
administration = gsub("([a-z]+) .*", "\\1", administration)) %>%
administration = gsub("([a-z]+) .*", "\\1", administration)
) %>%
arrange(name, administration, type) %>%
filter(!is.na(dose), dose != ".") %>%
as.data.frame(stringsAsFactors = FALSE)

126
data-raw/reproduction_of_example_isolates_unclean.R
View File

@@ -25,65 +25,109 @@
patients <- unlist(lapply(LETTERS, paste0, 1:10))
patients_table <- data.frame(patient_id = patients,
gender = c(rep("M", 135),
rep("F", 125)))
patients_table <- data.frame(
patient_id = patients,
gender = c(
rep("M", 135),
rep("F", 125)
)
)
dates <- seq(as.Date("2011-01-01"), as.Date("2020-01-01"), by = "day")
bacteria_a <- c("E. coli", "S. aureus",
"S. pneumoniae", "K. pneumoniae")
bacteria_a <- c(
"E. coli", "S. aureus",
"S. pneumoniae", "K. pneumoniae"
)
bacteria_b <- c("esccol", "staaur", "strpne", "klepne")
bacteria_c <- c("Escherichia coli", "Staphylococcus aureus",
"Streptococcus pneumoniae", "Klebsiella pneumoniae")
bacteria_c <- c(
"Escherichia coli", "Staphylococcus aureus",
"Streptococcus pneumoniae", "Klebsiella pneumoniae"
)
ab_interpretations <- c("S", "I", "R")
ab_interpretations_messy = c("R", "< 0.5 S", "I")
ab_interpretations_messy <- c("R", "< 0.5 S", "I")
sample_size <- 1000
data_a <- data.frame(date = sample(dates, size = sample_size, replace = TRUE),
data_a <- data.frame(
date = sample(dates, size = sample_size, replace = TRUE),
hospital = "A",
bacteria = sample(bacteria_a, size = sample_size, replace = TRUE,
prob = c(0.50, 0.25, 0.15, 0.10)),
AMX = sample(ab_interpretations, size = sample_size, replace = TRUE,
prob = c(0.60, 0.05, 0.35)),
AMC = sample(ab_interpretations, size = sample_size, replace = TRUE,
prob = c(0.75, 0.10, 0.15)),
CIP = sample(ab_interpretations, size = sample_size, replace = TRUE,
prob = c(0.80, 0.00, 0.20)),
GEN = sample(ab_interpretations, size = sample_size, replace = TRUE,
prob = c(0.92, 0.00, 0.08)))
bacteria = sample(bacteria_a,
size = sample_size, replace = TRUE,
prob = c(0.50, 0.25, 0.15, 0.10)
),
AMX = sample(ab_interpretations,
size = sample_size, replace = TRUE,
prob = c(0.60, 0.05, 0.35)
),
AMC = sample(ab_interpretations,
size = sample_size, replace = TRUE,
prob = c(0.75, 0.10, 0.15)
),
CIP = sample(ab_interpretations,
size = sample_size, replace = TRUE,
prob = c(0.80, 0.00, 0.20)
),
GEN = sample(ab_interpretations,
size = sample_size, replace = TRUE,
prob = c(0.92, 0.00, 0.08)
)
)
data_b <- data.frame(date = sample(dates, size = sample_size, replace = TRUE),
data_b <- data.frame(
date = sample(dates, size = sample_size, replace = TRUE),
hospital = "B",
bacteria = sample(bacteria_b, size = sample_size, replace = TRUE,
prob = c(0.50, 0.25, 0.15, 0.10)),
AMX = sample(ab_interpretations_messy, size = sample_size, replace = TRUE,
prob = c(0.60, 0.05, 0.35)),
AMC = sample(ab_interpretations_messy, size = sample_size, replace = TRUE,
prob = c(0.75, 0.10, 0.15)),
CIP = sample(ab_interpretations_messy, size = sample_size, replace = TRUE,
prob = c(0.80, 0.00, 0.20)),
GEN = sample(ab_interpretations_messy, size = sample_size, replace = TRUE,
prob = c(0.92, 0.00, 0.08)))
bacteria = sample(bacteria_b,
size = sample_size, replace = TRUE,
prob = c(0.50, 0.25, 0.15, 0.10)
),
AMX = sample(ab_interpretations_messy,
size = sample_size, replace = TRUE,
prob = c(0.60, 0.05, 0.35)
),
AMC = sample(ab_interpretations_messy,
size = sample_size, replace = TRUE,
prob = c(0.75, 0.10, 0.15)
),
CIP = sample(ab_interpretations_messy,
size = sample_size, replace = TRUE,
prob = c(0.80, 0.00, 0.20)
),
GEN = sample(ab_interpretations_messy,
size = sample_size, replace = TRUE,
prob = c(0.92, 0.00, 0.08)
)
)
data_c <- data.frame(date = sample(dates, size = sample_size, replace = TRUE),
data_c <- data.frame(
date = sample(dates, size = sample_size, replace = TRUE),
hospital = "C",
bacteria = sample(bacteria_c, size = sample_size, replace = TRUE,
prob = c(0.50, 0.25, 0.15, 0.10)),
AMX = sample(ab_interpretations, size = sample_size, replace = TRUE,
prob = c(0.60, 0.05, 0.35)),
AMC = sample(ab_interpretations, size = sample_size, replace = TRUE,
prob = c(0.75, 0.10, 0.15)),
CIP = sample(ab_interpretations, size = sample_size, replace = TRUE,
prob = c(0.80, 0.00, 0.20)),
GEN = sample(ab_interpretations, size = sample_size, replace = TRUE,
prob = c(0.92, 0.00, 0.08)))
bacteria = sample(bacteria_c,
size = sample_size, replace = TRUE,
prob = c(0.50, 0.25, 0.15, 0.10)
),
AMX = sample(ab_interpretations,
size = sample_size, replace = TRUE,
prob = c(0.60, 0.05, 0.35)
),
AMC = sample(ab_interpretations,
size = sample_size, replace = TRUE,
prob = c(0.75, 0.10, 0.15)
),
CIP = sample(ab_interpretations,
size = sample_size, replace = TRUE,
prob = c(0.80, 0.00, 0.20)
),
GEN = sample(ab_interpretations,
size = sample_size, replace = TRUE,
prob = c(0.92, 0.00, 0.08)
)
)
example_isolates_unclean <- data_a %>%

9
data-raw/reproduction_of_intrinsic_resistant.R
View File

@@ -32,9 +32,12 @@ for (i in seq_len(nrow(antibiotics))) {
}
int_resis <- eucast_rules(int_resis,
eucast_rules_df = subset(AMR:::EUCAST_RULES_DF,
is.na(have_these_values) & reference.version == 3.3),
info = FALSE)
eucast_rules_df = subset(
AMR:::EUCAST_RULES_DF,
is.na(have_these_values) & reference.version == 3.3
),
info = FALSE
)
int_resis2 <- int_resis[, sapply(int_resis, function(x) any(!is.rsi(x) | x == "R")), drop = FALSE] %>%
tidyr::pivot_longer(-mo) %>%

485
data-raw/reproduction_of_microorganisms.R
View File

@@ -66,8 +66,10 @@ dsmz_first <- GET_df("https://bacdive.dsmz.de/api/pnu/species?page=1&format=json
data_dsmz <- dsmz_first$results
# this next process will take appr. `dsmz_first$count / 100 * 5 / 60` minutes
for (i in 2:round((dsmz_first$count / 100) + 0.5)) {
data_dsmz <<- rbind(data_dsmz,
GET_df(paste0("https://bacdive.dsmz.de/api/pnu/species/?page=", i, "&format=json"))$results)
data_dsmz <<- rbind(
data_dsmz,
GET_df(paste0("https://bacdive.dsmz.de/api/pnu/species/?page=", i, "&format=json"))$results
)
cat(i, "-", AMR:::percentage(i / round((dsmz_first$count / 100) + 0.5)), "\n")
}
rm(dsmz_first)
@@ -91,19 +93,25 @@ data_col_old <- data_col %>%
# filter: has new accepted name
filter(!is.na(acceptedNameUsageID)) %>%
as_tibble() %>%
transmute(fullname = trimws(stringr::str_replace(scientificName,
transmute(
fullname = trimws(stringr::str_replace(scientificName,
pattern = stringr::fixed(scientificNameAuthorship),
replacement = "")),
fullname_new = trimws(paste(ifelse(is.na(genus), "", genus),
replacement = ""
)),
fullname_new = trimws(paste(
ifelse(is.na(genus), "", genus),
ifelse(is.na(specificEpithet), "", specificEpithet),
ifelse(is.na(infraspecificEpithet), "", infraspecificEpithet))),
ifelse(is.na(infraspecificEpithet), "", infraspecificEpithet)
)),
ref = scientificNameAuthorship,
prevalence = NA_integer_)
prevalence = NA_integer_
)
data_col <- data_col %>%
# filter: has no new accepted name
filter(is.na(acceptedNameUsageID)) %>%
as_tibble() %>%
transmute(fullname = "",
transmute(
fullname = "",
kingdom,
phylum,
class,
@@ -115,7 +123,8 @@ data_col <- data_col %>%
rank = taxonRank,
ref = scientificNameAuthorship,
species_id = referenceID,
source = "CoL")
source = "CoL"
)
# clean data_dsmz
data_dsmz.bak <- data_dsmz
@@ -123,18 +132,23 @@ data_dsmz_old <- data_dsmz %>%
# filter: correct name is not NULL
filter(!sapply(correct_name, is.null)) %>%
as_tibble() %>%
transmute(fullname = trimws(paste(ifelse(is.na(genus), "", genus),
transmute(
fullname = trimws(paste(
ifelse(is.na(genus), "", genus),
ifelse(is.na(species_epithet), "", species_epithet),
ifelse(is.na(subspecies_epithet), "", subspecies_epithet))),
ifelse(is.na(subspecies_epithet), "", subspecies_epithet)
)),
fullname_new = sapply(correct_name, function(x) x[2L]),
ref = authors,
prevalence = NA_integer_)
prevalence = NA_integer_
)
data_dsmz <- data_dsmz %>%
# filter: correct name is NULL
filter(sapply(correct_name, is.null)) %>%
as_tibble() %>%
transmute(fullname = "",
transmute(
fullname = "",
kingdom = regio,
phylum,
class = classis,
@@ -146,7 +160,8 @@ data_dsmz <- data_dsmz %>%
rank = ifelse(species == "", "genus", "species"),
ref = authors,
species_id = as.character(pnu_no),
source = "DSMZ")
source = "DSMZ"
)
# DSMZ only contains genus/(sub)species, try to find taxonomic properties based on genus and data_col
ref_taxonomy <- data_col %>%
@@ -175,8 +190,8 @@ MOs <- data_total %>%
!kingdom %in% c("Animalia", "Plantae", "Viruses")
# and not all fungi: Aspergillus, Candida, Trichphyton and Pneumocystis are the most important,
# so only keep these orders from the fungi:
& !(kingdom == "Fungi"
& !order %in% c("Eurotiales", "Microascales", "Mucorales", "Saccharomycetales", "Schizosaccharomycetales", "Tremellales", "Onygenales", "Pneumocystales"))
& !(kingdom == "Fungi" &
!order %in% c("Eurotiales", "Microascales", "Mucorales", "Saccharomycetales", "Schizosaccharomycetales", "Tremellales", "Onygenales", "Pneumocystales"))
)
# or the genus has to be one of the genera we found in our hospitals last decades (Northern Netherlands, 2002-2018)
| genus %in% MO_PREVALENT_GENERA
@@ -187,12 +202,12 @@ MOs <- data_total %>%
# include all ranks other than species for the included species
MOs <- MOs %>% bind_rows(data_total %>%
filter((kingdom %in% MOs$kingdom & rank == "kingdom")
| (phylum %in% MOs$phylum & rank == "phylum")
| (class %in% MOs$class & rank == "class")
| (order %in% MOs$order & rank == "order")
| (family %in% MOs$family & rank == "family")
| (genus %in% MOs$genus & rank == "genus")))
filter((kingdom %in% MOs$kingdom & rank == "kingdom") |
(phylum %in% MOs$phylum & rank == "phylum") |
(class %in% MOs$class & rank == "class") |
(order %in% MOs$order & rank == "order") |
(family %in% MOs$family & rank == "family") |
(genus %in% MOs$genus & rank == "genus")))
get_author_year <- function(ref) {
# Only keep first author, e.g. transform 'Smith, Jones, 2011' to 'Smith et al., 2011'
@@ -203,13 +218,15 @@ get_author_year <- function(ref) {
# only take part after brackets if there's a name
authors2 <- ifelse(grepl(".*[)] [a-zA-Z]+.*", authors2),
gsub(".*[)] (.*)", "\\1", authors2),
authors2)
authors2
)
# get year from last 4 digits
lastyear = as.integer(gsub(".*([0-9]{4})$", "\\1", authors2))
lastyear <- as.integer(gsub(".*([0-9]{4})$", "\\1", authors2))
# 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,
lastyear)
lastyear
)
# get authors without last year
authors <- gsub("(.*)[0-9]{4}$", "\\1", authors2)
# remove nonsense characters from names
@@ -228,7 +245,8 @@ get_author_year <- function(ref) {
# combine author and year if year is available
ref <- ifelse(!is.na(lastyear),
paste0(authors, ", ", lastyear),
authors)
authors
)
# fix beginning and ending
ref <- gsub(", $", "", ref)
ref <- gsub("^, ", "", ref)
@@ -250,32 +268,40 @@ MOs <- MOs %>%
lapply(iconv, from = "UTF-8", to = "ASCII//TRANSLIT") %>%
as_tibble(stringsAsFactors = FALSE) %>%
# remove invalid characters
mutate_all(~gsub("[\"'`]+", "", .))
mutate_all(~ gsub("[\"'`]+", "", .))
# set new fullnames
MOs <- MOs %>%
mutate(fullname = trimws(case_when(rank == "family" ~ family,
mutate(
fullname = trimws(case_when(
rank == "family" ~ family,
rank == "order" ~ order,
rank == "class" ~ class,
rank == "phylum" ~ phylum,
rank == "kingdom" ~ kingdom,
TRUE ~ paste(genus, species, subspecies))),
fullname = gsub(" (var|f|subsp)[.]", "", fullname)) %>%
TRUE ~ paste(genus, species, subspecies)
)),
fullname = gsub(" (var|f|subsp)[.]", "", fullname)
) %>%
# remove text if it contains 'Not assigned', etc.
mutate_all(function(x) ifelse(x %like% "(not assigned|homonym|mistake)", NA, x)) %>%
# clean taxonomy
mutate(kingdom = ifelse(is.na(kingdom) | trimws(kingdom) == "", "(unknown kingdom)", trimws(kingdom)),
mutate(
kingdom = ifelse(is.na(kingdom) | trimws(kingdom) == "", "(unknown kingdom)", trimws(kingdom)),
phylum = ifelse(is.na(phylum) | trimws(phylum) == "", "(unknown phylum)", trimws(phylum)),
class = ifelse(is.na(class) | trimws(class) == "", "(unknown class)", trimws(class)),
order = ifelse(is.na(order) | trimws(order) == "", "(unknown order)", trimws(order)),
family = ifelse(is.na(family) | trimws(family) == "", "(unknown family)", trimws(family)))
family = ifelse(is.na(family) | trimws(family) == "", "(unknown family)", trimws(family))
)
# Split old taxonomic names
MOs.old <- data_col_old %>%
filter(!gsub(" (var|f|subsp)[.]", "", fullname_new) %in% data_dsmz_old$fullname) %>%
bind_rows(data_dsmz_old) %>%
mutate(fullname_new = gsub(" (var|f|subsp)[.]", "", fullname_new),
fullname = gsub(" (var|f|subsp)[.]", "", fullname)) %>%
mutate(
fullname_new = gsub(" (var|f|subsp)[.]", "", fullname_new),
fullname = gsub(" (var|f|subsp)[.]", "", fullname)
) %>%
# for cases like Chlamydia pneumoniae -> Chlamydophila pneumoniae -> Chlamydia pneumoniae:
filter(!fullname %in% fullname_new &
fullname_new %in% MOs$fullname &
@@ -301,7 +327,8 @@ MOs <- MOs %>%
rank,
ref,
species_id = gsub("[^a-zA-Z0-9].*", "", species_id),
source) %>%
source
) %>%
# prefer known taxonomy over unknown taxonomy, then DSMZ over CoL (= desc)
arrange(desc(kingdom, genus, species, source)) %>%
distinct(kingdom, fullname, .keep_all = TRUE)
@@ -324,29 +351,35 @@ MOs <- MOs %>%
arrange(genus, species) %>%
distinct(genus, .keep_all = TRUE) %>%
filter(rank == "species") %>%
mutate(fullname = genus,
mutate(
fullname = genus,
species = "",
rank = "genus",
species_id = "",
ref = NA_character_)) %>%
ref = NA_character_
)) %>%
bind_rows(MOs %>%
arrange(family, genus) %>%
distinct(family, .keep_all = TRUE) %>%
filter(rank == "genus") %>%
mutate(fullname = family,
mutate(
fullname = family,
genus = "",
rank = "family",
species_id = "",
ref = NA_character_)) %>%
ref = NA_character_
)) %>%
bind_rows(MOs %>%
arrange(order, family) %>%
distinct(family, .keep_all = TRUE) %>%
filter(rank == "family") %>%
mutate(fullname = order,
mutate(
fullname = order,
family = "",
rank = "order",
species_id = "",
ref = NA_character_))
ref = NA_character_
))
# remove the empty ones
MOs <- MOs %>%
@@ -356,7 +389,10 @@ MOs <- MOs %>%
# what characters are in the fullnames?
table(sort(unlist(strsplit(x = paste(MOs$fullname, collapse = ""), split = ""))))
MOs %>% filter(fullname %unlike% "^[a-z ]+$") %>% arrange(fullname) %>% View()
MOs %>%
filter(fullname %unlike% "^[a-z ]+$") %>%
arrange(fullname) %>%
View()
table(MOs$kingdom, MOs$rank)
table(AMR::microorganisms$kingdom, AMR::microorganisms$rank)
@@ -364,16 +400,18 @@ table(AMR::microorganisms$kingdom, AMR::microorganisms$rank)
# set prevalence per species
MOs <- MOs %>%
mutate(prevalence = case_when(
class == "Gammaproteobacteria"
| genus %in% c("Enterococcus", "Staphylococcus", "Streptococcus")
class == "Gammaproteobacteria" |
genus %in% c("Enterococcus", "Staphylococcus", "Streptococcus")
~ 1,
kingdom %in% c("Archaea", "Bacteria", "Chromista", "Fungi")
& (phylum %in% c("Proteobacteria",
kingdom %in% c("Archaea", "Bacteria", "Chromista", "Fungi") &
(phylum %in% c(
"Proteobacteria",
"Firmicutes",
"Actinobacteria",
"Sarcomastigophora")
| genus %in% MO_PREVALENT_GENERA
| rank %in% c("kingdom", "phylum", "class", "order", "family"))
"Sarcomastigophora"
) |
genus %in% MO_PREVALENT_GENERA |
rank %in% c("kingdom", "phylum", "class", "order", "family"))
~ 2,
TRUE ~ 3
))
@@ -384,30 +422,42 @@ MOs <- MOs %>%
arrange(prevalence, genus, species, subspecies) %>%
group_by(kingdom) %>%
mutate(abbr_other = case_when(
rank == "family" ~ paste0("[FAM]_",
rank == "family" ~ paste0(
"[FAM]_",
abbreviate(family,
minlength = 8,
use.classes = TRUE,
method = "both.sides",
strict = FALSE)),
rank == "order" ~ paste0("[ORD]_",
strict = FALSE
)
),
rank == "order" ~ paste0(
"[ORD]_",
abbreviate(order,
minlength = 8,
use.classes = TRUE,
method = "both.sides",
strict = FALSE)),
rank == "class" ~ paste0("[CLS]_",
strict = FALSE
)
),
rank == "class" ~ paste0(
"[CLS]_",
abbreviate(class,
minlength = 8,
use.classes = TRUE,
method = "both.sides",
strict = FALSE)),
rank == "phylum" ~ paste0("[PHL]_",
strict = FALSE
)
),
rank == "phylum" ~ paste0(
"[PHL]_",
abbreviate(phylum,
minlength = 8,
use.classes = TRUE,
method = "both.sides",
strict = FALSE)),
strict = FALSE
)
),
rank == "kingdom" ~ paste0("[KNG]_", kingdom),
TRUE ~ NA_character_
)) %>%
@@ -416,7 +466,8 @@ MOs <- MOs %>%
mutate(abbr_genus = abbreviate(gsub("^ae", "\u00E6\u00E6", genus, ignore.case = TRUE), # keep a starting Latin ae
minlength = 5,
use.classes = TRUE,
method = "both.sides")) %>%
method = "both.sides"
)) %>%
ungroup() %>%
group_by(genus) %>%
# species abbreviations may be the same between genera
@@ -424,34 +475,48 @@ MOs <- MOs %>%
mutate(abbr_species = abbreviate(gsub("^ae", "\u00E6\u00E6", species),
minlength = 4,
use.classes = TRUE,
method = "both.sides")) %>%
method = "both.sides"
)) %>%
ungroup() %>%
group_by(genus, species) %>%
mutate(abbr_subspecies = abbreviate(gsub("^ae", "\u00E6\u00E6", subspecies),
minlength = 4,
use.classes = TRUE,
method = "both.sides")) %>%
method = "both.sides"
)) %>%
ungroup() %>%
# remove trailing underscores
mutate(mo = gsub("_+$", "",
mutate(
mo = gsub(
"_+$", "",
toupper(paste(ifelse(kingdom %in% c("Animalia", "Plantae"),
substr(kingdom, 1, 2),
substr(kingdom, 1, 1)),
substr(kingdom, 1, 1)
),
ifelse(is.na(abbr_other),
paste(abbr_genus,
abbr_species,
abbr_subspecies,
sep = "_"),
abbr_other),
sep = "_"))),
mo = gsub("(\u00C6|\u00E6)+", "AE", mo)) %>%
mutate(mo = ifelse(duplicated(.$mo),
sep = "_"
),
abbr_other
),
sep = "_"
))
),
mo = gsub("(\u00C6|\u00E6)+", "AE", mo)
) %>%
mutate(
mo = ifelse(duplicated(.$mo),
# these one or two must be unique too
paste0(mo, "1"),
mo),
mo
),
fullname = ifelse(fullname == "",
trimws(paste(genus, species, subspecies)),
fullname)) %>%
fullname
)
) %>%
# put `mo` in front, followed by the rest
select(mo, everything(), -abbr_other, -abbr_genus, -abbr_species, -abbr_subspecies)
@@ -459,7 +524,8 @@ MOs <- MOs %>%
MOs <- MOs %>%
bind_rows(
# Unknowns
data.frame(mo = "UNKNOWN",
data.frame(
mo = "UNKNOWN",
fullname = "(unknown name)",
kingdom = "(unknown kingdom)",
phylum = "(unknown phylum)",
@@ -474,8 +540,10 @@ MOs <- MOs %>%
species_id = "",
source = "manually added",
prevalence = 1,
stringsAsFactors = FALSE),
data.frame(mo = "B_GRAMN",
stringsAsFactors = FALSE
),
data.frame(
mo = "B_GRAMN",
fullname = "(unknown Gram-negatives)",
kingdom = "Bacteria",
phylum = "(unknown phylum)",
@@ -490,8 +558,10 @@ MOs <- MOs %>%
species_id = "",
source = "manually added",
prevalence = 1,
stringsAsFactors = FALSE),
data.frame(mo = "B_GRAMP",
stringsAsFactors = FALSE
),
data.frame(
mo = "B_GRAMP",
fullname = "(unknown Gram-positives)",
kingdom = "Bacteria",
phylum = "(unknown phylum)",
@@ -506,8 +576,10 @@ MOs <- MOs %>%
species_id = "",
source = "manually added",
prevalence = 1,
stringsAsFactors = FALSE),
data.frame(mo = "F_YEAST",
stringsAsFactors = FALSE
),
data.frame(
mo = "F_YEAST",
fullname = "(unknown yeast)",
kingdom = "Fungi",
phylum = "(unknown phylum)",
@@ -522,8 +594,10 @@ MOs <- MOs %>%
species_id = "",
source = "manually added",
prevalence = 2,
stringsAsFactors = FALSE),
data.frame(mo = "F_FUNGUS",
stringsAsFactors = FALSE
),
data.frame(
mo = "F_FUNGUS",
fullname = "(unknown fungus)",
kingdom = "Fungi",
phylum = "(unknown phylum)",
@@ -538,157 +612,200 @@ MOs <- MOs %>%
species_id = "",
source = "manually added",
prevalence = 2,
stringsAsFactors = FALSE),
stringsAsFactors = FALSE
),
# CoNS
MOs %>%
filter(genus == "Staphylococcus", species == "epidermidis") %>% .[1,] %>%
mutate(mo = gsub("(.*)_(.*)_.*", "\\1_\\2_CONS", mo),
filter(genus == "Staphylococcus", species == "epidermidis") %>%
.[1, ] %>%
mutate(
mo = gsub("(.*)_(.*)_.*", "\\1_\\2_CONS", mo),
species = "coagulase-negative",
fullname = "Coagulase-negative Staphylococcus (CoNS)",
ref = NA_character_,
species_id = "",
source = "manually added"),
source = "manually added"
),
# CoPS
MOs %>%
filter(genus == "Staphylococcus", species == "epidermidis") %>% .[1,] %>%
mutate(mo = gsub("(.*)_(.*)_.*", "\\1_\\2_COPS", mo),
filter(genus == "Staphylococcus", species == "epidermidis") %>%
.[1, ] %>%
mutate(
mo = gsub("(.*)_(.*)_.*", "\\1_\\2_COPS", mo),
species = "coagulase-positive",
fullname = "Coagulase-positive Staphylococcus (CoPS)",
ref = NA_character_,
species_id = "",
source = "manually added"),
source = "manually added"
),
# Streptococci groups A, B, C, F, H, K
MOs %>%
filter(genus == "Streptococcus", species == "pyogenes") %>% .[1,] %>%
filter(genus == "Streptococcus", species == "pyogenes") %>%
.[1, ] %>%
# we can keep all other details, since S. pyogenes is the only member of group A
mutate(mo = gsub("(.*)_(.*)_.*", "\\1_\\2_GRPA", mo),
species = "group A" ,
mutate(
mo = gsub("(.*)_(.*)_.*", "\\1_\\2_GRPA", mo),
species = "group A",
fullname = "Streptococcus group A",
source = "manually added"),
source = "manually added"
),
MOs %>%
filter(genus == "Streptococcus", species == "agalactiae") %>% .[1,] %>%
filter(genus == "Streptococcus", species == "agalactiae") %>% .[1, ] %>%
# we can keep all other details, since S. agalactiae is the only member of group B
mutate(mo = gsub("(.*)_(.*)_.*", "\\1_\\2_GRPB", mo),
species = "group B" ,
mutate(
mo = gsub("(.*)_(.*)_.*", "\\1_\\2_GRPB", mo),
species = "group B",
fullname = "Streptococcus group B",
source = "manually added"),
source = "manually added"
),
MOs %>%
filter(genus == "Streptococcus", species == "dysgalactiae") %>% .[1,] %>%
mutate(mo = gsub("(.*)_(.*)_.*", "\\1_\\2_GRPC", mo),
species = "group C" ,
filter(genus == "Streptococcus", species == "dysgalactiae") %>% .[1, ] %>%
mutate(
mo = gsub("(.*)_(.*)_.*", "\\1_\\2_GRPC", mo),
species = "group C",
fullname = "Streptococcus group C",
ref = NA_character_,
species_id = "",
source = "manually added"),
source = "manually added"
),
MOs %>%
filter(genus == "Streptococcus", species == "agalactiae") %>% .[1,] %>%
mutate(mo = gsub("(.*)_(.*)_.*", "\\1_\\2_GRPD", mo),
species = "group D" ,
filter(genus == "Streptococcus", species == "agalactiae") %>% .[1, ] %>%
mutate(
mo = gsub("(.*)_(.*)_.*", "\\1_\\2_GRPD", mo),
species = "group D",
fullname = "Streptococcus group D",
ref = NA_character_,
species_id = "",
source = "manually added"),
source = "manually added"
),
MOs %>%
filter(genus == "Streptococcus", species == "agalactiae") %>% .[1,] %>%
mutate(mo = gsub("(.*)_(.*)_.*", "\\1_\\2_GRPF", mo),
species = "group F" ,
filter(genus == "Streptococcus", species == "agalactiae") %>% .[1, ] %>%
mutate(
mo = gsub("(.*)_(.*)_.*", "\\1_\\2_GRPF", mo),
species = "group F",
fullname = "Streptococcus group F",
ref = NA_character_,
species_id = "",
source = "manually added"),
source = "manually added"
),
MOs %>%
filter(genus == "Streptococcus", species == "agalactiae") %>% .[1,] %>%
mutate(mo = gsub("(.*)_(.*)_.*", "\\1_\\2_GRPG", mo),
species = "group G" ,
filter(genus == "Streptococcus", species == "agalactiae") %>% .[1, ] %>%
mutate(
mo = gsub("(.*)_(.*)_.*", "\\1_\\2_GRPG", mo),
species = "group G",
fullname = "Streptococcus group G",
ref = NA_character_,
species_id = "",
source = "manually added"),
source = "manually added"
),
MOs %>%
filter(genus == "Streptococcus", species == "agalactiae") %>% .[1,] %>%
mutate(mo = gsub("(.*)_(.*)_.*", "\\1_\\2_GRPH", mo),
species = "group H" ,
filter(genus == "Streptococcus", species == "agalactiae") %>% .[1, ] %>%
mutate(
mo = gsub("(.*)_(.*)_.*", "\\1_\\2_GRPH", mo),
species = "group H",
fullname = "Streptococcus group H",
ref = NA_character_,
species_id = "",
source = "manually added"),
source = "manually added"
),
MOs %>%
filter(genus == "Streptococcus", species == "agalactiae") %>% .[1,] %>%
mutate(mo = gsub("(.*)_(.*)_.*", "\\1_\\2_GRPK", mo),
species = "group K" ,
filter(genus == "Streptococcus", species == "agalactiae") %>% .[1, ] %>%
mutate(
mo = gsub("(.*)_(.*)_.*", "\\1_\\2_GRPK", mo),
species = "group K",
fullname = "Streptococcus group K",
ref = NA_character_,
species_id = "",
source = "manually added"),
source = "manually added"
),
# Beta haemolytic Streptococci
MOs %>%
filter(genus == "Streptococcus", species == "agalactiae") %>% .[1,] %>%
mutate(mo = gsub("(.*)_(.*)_.*", "\\1_\\2_HAEM", mo),
species = "beta-haemolytic" ,
filter(genus == "Streptococcus", species == "agalactiae") %>%
.[1, ] %>%
mutate(
mo = gsub("(.*)_(.*)_.*", "\\1_\\2_HAEM", mo),
species = "beta-haemolytic",
fullname = "Beta-haemolytic Streptococcus",
ref = NA_character_,
species_id = "",
source = "manually added"),
source = "manually added"
),
# Viridans Streptococci
MOs %>%
filter(genus == "Streptococcus", species == "agalactiae") %>% .[1,] %>%
mutate(mo = gsub("(.*)_(.*)_.*", "\\1_\\2_VIRI", mo),
species = "viridans" ,
filter(genus == "Streptococcus", species == "agalactiae") %>%
.[1, ] %>%
mutate(
mo = gsub("(.*)_(.*)_.*", "\\1_\\2_VIRI", mo),
species = "viridans",
fullname = "Viridans Group Streptococcus (VGS)",
ref = NA_character_,
species_id = "",
source = "manually added"),
source = "manually added"
),
# Milleri Streptococci
MOs %>%
filter(genus == "Streptococcus", species == "agalactiae") %>% .[1,] %>%
mutate(mo = gsub("(.*)_(.*)_.*", "\\1_\\2_MILL", mo),
species = "milleri" ,
filter(genus == "Streptococcus", species == "agalactiae") %>%
.[1, ] %>%
mutate(
mo = gsub("(.*)_(.*)_.*", "\\1_\\2_MILL", mo),
species = "milleri",
fullname = "Milleri Group Streptococcus (MGS)",
ref = NA_character_,
species_id = "",
source = "manually added"),
source = "manually added"
),
# Candida krusei
MOs %>%
filter(genus == "Candida", species == "glabrata") %>% .[1,] %>%
mutate(mo = gsub("(.*)_(.*)_.*", "\\1_\\2_KRUS", mo),
species = "krusei" ,
filter(genus == "Candida", species == "glabrata") %>%
.[1, ] %>%
mutate(
mo = gsub("(.*)_(.*)_.*", "\\1_\\2_KRUS", mo),
species = "krusei",
fullname = "Candida krusei",
ref = NA_character_,
species_id = "",
source = "manually added"),
source = "manually added"
),
# Blastocystis hominis does not exist (it means 'got a Blastocystis from humans', PMID 15634993)
# but let's be nice to the clinical people in microbiology
MOs %>%
filter(fullname == "Blastocystis") %>%
mutate(mo = paste0(mo, "_HMNS"),
mutate(
mo = paste0(mo, "_HMNS"),
fullname = paste(fullname, "hominis"),
species = "hominis",
source = "manually added",
ref = NA_character_,
species_id = ""),
species_id = ""
),
# Trichomonas vaginalis is missing, same order as Dientamoeba
MOs %>%
filter(fullname == "Dientamoeba") %>%
mutate(mo = gsub("(.*?)_.*", "\\1_THMNS", mo),
mutate(
mo = gsub("(.*?)_.*", "\\1_THMNS", mo),
fullname = "Trichomonas",
family = "Trichomonadidae",
genus = "Trichomonas",
source = "manually added",
ref = "Donne, 1836",
species_id = ""),
species_id = ""
),
MOs %>%
filter(fullname == "Dientamoeba fragilis") %>%
mutate(mo = gsub("(.*?)_.*", "\\1_THMNS_VAG", mo),
mutate(
mo = gsub("(.*?)_.*", "\\1_THMNS_VAG", mo),
fullname = "Trichomonas vaginalis",
family = "Trichomonadidae",
genus = "Trichomonas",
species = "vaginalis",
source = "manually added",
ref = "Donne, 1836",
species_id = ""),
species_id = ""
),
MOs %>% # add family as such too
filter(fullname == "Monocercomonadidae") %>%
mutate(mo = gsub("(.*)_(.*)_.*", "\\1_\\2_TRCHMNDD", mo),
mutate(
mo = gsub("(.*)_(.*)_.*", "\\1_\\2_TRCHMNDD", mo),
fullname = "Trichomonadidae",
family = "Trichomonadidae",
rank = "family",
@@ -696,12 +813,14 @@ MOs <- MOs %>%
species = "",
source = "manually added",
ref = "",
species_id = ""),
species_id = ""
),
)
# Incorporate new microbial order for Gammaproteobacteria - Adeolu et al. (2016), PMID 27620848
MOs[which(MOs$family == "Enterobacteriaceae"), "family"] <- ""
MOs[which(MOs$genus %in% c("Escherichia",
MOs[which(MOs$genus %in% c(
"Escherichia",
"Atlantibacter",
"Biostraticola",
"Buttiauxella",
@@ -729,46 +848,61 @@ MOs[which(MOs$genus %in% c("Escherichia",
"Shimwellia",
"Siccibacter",
"Trabulsiella",
"Yokenella")), "family"] <- "Enterobacteriaceae"
MOs[which(MOs$genus %in% c("Erwinia",
"Yokenella"
)), "family"] <- "Enterobacteriaceae"
MOs[which(MOs$genus %in% c(
"Erwinia",
"Buchnera",
"Pantoea",
"Phaseolibacter",
"Tatumella",
"Wigglesworthia")), "family"] <- "Erwiniaceae"
MOs[which(MOs$genus %in% c("Pectobacterium",
"Wigglesworthia"
)), "family"] <- "Erwiniaceae"
MOs[which(MOs$genus %in% c(
"Pectobacterium",
"Brenneria",
"Dickeya",
"Lonsdalea",
"Sodalis")), "family"] <- "Pectobacteriaceae"
MOs[which(MOs$genus %in% c("Yersinia",
"Sodalis"
)), "family"] <- "Pectobacteriaceae"
MOs[which(MOs$genus %in% c(
"Yersinia",
"Chania",
"Ewingella",
"Rahnella",
"Rouxiella",
"Samsonia",
"Serratia")), "family"] <- "Yersiniaceae"
MOs[which(MOs$genus %in% c("Hafnia",
"Serratia"
)), "family"] <- "Yersiniaceae"
MOs[which(MOs$genus %in% c(
"Hafnia",
"Edwardsiella",
"Obesumbacterium")), "family"] <- "Hafniaceae"
MOs[which(MOs$genus %in% c("Morganella",
"Obesumbacterium"
)), "family"] <- "Hafniaceae"
MOs[which(MOs$genus %in% c(
"Morganella",
"Arsenophonus",
"Cosenzaea",
"Moellerella",
"Photorhabdus",
"Proteus",
"Providencia",
"Xenorhabdus")), "family"] <- "Morganellaceae"
MOs[which(MOs$genus %in% c("Budvicia",
"Xenorhabdus"
)), "family"] <- "Morganellaceae"
MOs[which(MOs$genus %in% c(
"Budvicia",
"Leminorella",
"Pragia")), "family"] <- "Budviciaceae"
MOs[which(MOs$family %in% c("Enterobacteriaceae",
"Pragia"
)), "family"] <- "Budviciaceae"
MOs[which(MOs$family %in% c(
"Enterobacteriaceae",
"Erwiniaceae",
"Pectobacteriaceae",
"Yersiniaceae",
"Hafniaceae",
"Morganellaceae",
"Budviciaceae")), "order"] <- "Enterobacterales"
"Budviciaceae"
)), "order"] <- "Enterobacterales"
new_families <- MOs %>%
filter(order == "Enterobacterales") %>%
pull(family) %>%
@@ -776,12 +910,16 @@ new_families <- MOs %>%
MOs <- MOs %>%
filter(!(rank == "family" & fullname %in% new_families)) %>%
bind_rows(tibble(mo = paste0("B_[FAM]_",
bind_rows(tibble(
mo = paste0(
"B_[FAM]_",
toupper(abbreviate(new_families,
minlength = 8,
use.classes = TRUE,
method = "both.sides",
strict = FALSE))),
strict = FALSE
))
),
fullname = new_families,
kingdom = "Bacteria",
phylum = "Proteobacteria",
@@ -795,7 +933,8 @@ MOs <- MOs %>%
ref = "Adeolu et al., 2016",
species_id = NA_character_,
source = "manually added",
prevalence = 1))
prevalence = 1
))
MOs[which(MOs$order == "Enterobacteriales"), "order"] <- "Enterobacterales"
MOs[which(MOs$fullname == "Enterobacteriales"), "fullname"] <- "Enterobacterales"
@@ -823,11 +962,19 @@ MOs <- MOs %>%
)
# here we welcome the new ones:
MOs %>% arrange(fullname) %>% filter(!fullname %in% AMR::microorganisms$fullname) %>% View()
MOs.old %>% arrange(fullname) %>% filter(!fullname %in% AMR::microorganisms.old$fullname) %>% View()
MOs %>%
arrange(fullname) %>%
filter(!fullname %in% AMR::microorganisms$fullname) %>%
View()
MOs.old %>%
arrange(fullname) %>%
filter(!fullname %in% AMR::microorganisms.old$fullname) %>%
View()
# and the ones we lost:
# AMR::microorganisms %>% filter(!fullname %in% MOs$fullname) %>% View() # based on fullname
AMR::microorganisms %>% filter(!fullname %in% c(MOs$fullname, MOs.old$fullname)) %>% View() # excluding renamed ones
AMR::microorganisms %>%
filter(!fullname %in% c(MOs$fullname, MOs.old$fullname)) %>%
View() # excluding renamed ones
# AMR::microorganisms %>% filter(!mo %in% MOs$mo) %>% View() # based on mo
# AMR::microorganisms %>% filter(!mo %in% MOs$mo & !fullname %in% MOs$fullname) %>% View()
# and these IDs have changed:
@@ -901,7 +1048,7 @@ usethis::use_data(rsi_translation, overwrite = TRUE, version = 2)
usethis::use_data(microorganisms.codes, overwrite = TRUE, version = 2)
# saveRDS(microorganisms.translation, file = "data-raw/microorganisms.translation.rds", version = 2)
# to save microorganisms.translation internally to the package
# source("data-raw/pre-commit-hook.R")
# source("data-raw/_pre_commit_hook.R")
# load new data sets again
devtools::load_all(".")
@@ -927,10 +1074,12 @@ testthat::test_file("tests/testthat/test-mo_property.R")
microorganisms <- microorganisms %>%
bind_rows(microorganisms %>%
filter(mo == "B_MYCBC_AFRC") %>%
mutate(mo = "B_MYCBC_TBRC", snomed = list(c("113861009", "113858008")),
ref = "Lehmann et al., 2018",species_id = "778540",
mutate(
mo = "B_MYCBC_TBRC", snomed = list(c("113861009", "113858008")),
ref = "Lehmann et al., 2018", species_id = "778540",
source = "DSMZ", species = "tuberculosis",
fullname = "Mycobacterium tuberculosis")) %>%
fullname = "Mycobacterium tuberculosis"
)) %>%
arrange(fullname)
class(microorganisms$mo) <- c("mo", "character")
microorganisms.old <- microorganisms.old %>% filter(fullname != "Mycobacterium tuberculosis")

154
data-raw/reproduction_of_microorganisms_update.R
View File

@@ -48,13 +48,15 @@ get_author_year <- function(ref) {
# only take part after brackets if there's a name
authors2 <- ifelse(grepl(".*[)] [a-zA-Z]+.*", authors2),
gsub(".*[)] (.*)", "\\1", authors2),
authors2)
authors2
)
# get year from last 4 digits
lastyear = as.integer(gsub(".*([0-9]{4})$", "\\1", authors2))
lastyear <- as.integer(gsub(".*([0-9]{4})$", "\\1", authors2))
# 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,
lastyear)
lastyear
)
# get authors without last year
authors <- gsub("(.*)[0-9]{4}$", "\\1", authors2)
# remove nonsense characters from names
@@ -73,7 +75,8 @@ get_author_year <- function(ref) {
# combine author and year if year is available
ref <- ifelse(!is.na(lastyear),
paste0(authors, ", ", lastyear),
authors)
authors
)
# fix beginning and ending
ref <- gsub(", $", "", ref)
ref <- gsub("^, ", "", ref)
@@ -94,7 +97,7 @@ df_remove_nonASCII <- function(df) {
df %>%
mutate_if(is.character, iconv, from = "UTF-8", to = "ASCII//TRANSLIT") %>%
# also remove invalid characters
mutate_if(is.character, ~gsub("[\"'`]+", "", .)) %>%
mutate_if(is.character, ~ gsub("[\"'`]+", "", .)) %>%
AMR:::dataset_UTF8_to_ASCII()
}
@@ -102,9 +105,11 @@ abbreviate_mo <- function(x, minlength = 5, prefix = "", ...) {
# keep a starting Latin ae
suppressWarnings(
gsub("^ae", "\u00E6\u00E6", x, ignore.case = TRUE) %>%
abbreviate(minlength = minlength,
abbreviate(
minlength = minlength,
use.classes = TRUE,
method = "both.sides", ...) %>%
method = "both.sides", ...
) %>%
paste0(prefix, .) %>%
toupper() %>%
gsub("(\u00C6|\u00E6)+", "AE", .)
@@ -120,13 +125,16 @@ taxonomy <- read_csv(file_location)
new_synonyms <- taxonomy %>%
left_join(taxonomy,
by = c("record_lnk" = "record_no"),
suffix = c("", ".new")) %>%
suffix = c("", ".new")
) %>%
filter(!is.na(record_lnk)) %>%
mutate_all(~ifelse(is.na(.), "", .)) %>%
transmute(fullname = trimws(paste(genus_name, sp_epithet, subsp_epithet)),
mutate_all(~ ifelse(is.na(.), "", .)) %>%
transmute(
fullname = trimws(paste(genus_name, sp_epithet, subsp_epithet)),
fullname_new = trimws(paste(genus_name.new, sp_epithet.new, subsp_epithet.new)),
ref = get_author_year(authors),
prevalence = 0) %>%
prevalence = 0
) %>%
distinct(fullname, .keep_all = TRUE) %>%
filter(fullname != fullname_new) %>%
# this part joins this table to itself to correct for entries that had >1 renames,
@@ -134,9 +142,12 @@ new_synonyms <- taxonomy %>%
# Bacteroides tectum -> Bacteroides tectus -> Bacteroides pyogenes
left_join(., .,
by = c("fullname_new" = "fullname"),
suffix = c("", ".2")) %>%
mutate(fullname_new = ifelse(!is.na(fullname_new.2), fullname_new.2, fullname_new),
ref = ifelse(!is.na(ref.2), ref.2, ref)) %>%
suffix = c("", ".2")
) %>%
mutate(
fullname_new = ifelse(!is.na(fullname_new.2), fullname_new.2, fullname_new),
ref = ifelse(!is.na(ref.2), ref.2, ref)
) %>%
select(-ends_with(".2"))
mo_became_synonym <- microorganisms %>%
@@ -144,8 +155,9 @@ mo_became_synonym <- microorganisms %>%
updated_microorganisms <- taxonomy %>%
filter(is.na(record_lnk)) %>%
mutate_all(~ifelse(is.na(.), "", .)) %>%
transmute(mo = "",
mutate_all(~ ifelse(is.na(.), "", .)) %>%
transmute(
mo = "",
fullname = trimws(paste(genus_name, sp_epithet, subsp_epithet)),
kingdom = "Bacteria",
phylum = "",
@@ -155,14 +167,17 @@ updated_microorganisms <- taxonomy %>%
genus = trimws(genus_name),
species = trimws(replace_na(sp_epithet, "")),
subspecies = trimws(replace_na(subsp_epithet, "")),
rank = case_when(subspecies == "" & species == "" ~ "genus",
rank = case_when(
subspecies == "" & species == "" ~ "genus",
subspecies == "" ~ "species",
TRUE ~ "subsp."),
TRUE ~ "subsp."
),
ref = get_author_year(authors),
species_id = as.character(record_no),
source = "LPSN",
prevalence = 0,
snomed = NA)
snomed = NA
)
new_microorganisms <- updated_microorganisms %>%
filter(!fullname %in% microorganisms$fullname)
@@ -171,7 +186,8 @@ genera_with_mo_code <- updated_microorganisms %>%
filter(genus %in% (microorganisms %>% filter(kingdom == "Bacteria", rank == "genus") %>% pull(genus))) %>%
distinct(genus) %>%
left_join(microorganisms %>% filter(kingdom == "Bacteria", rank == "genus") %>% select(mo, genus),
by = "genus")
by = "genus"
)
genera_without_mo_code <- updated_microorganisms %>%
filter(!genus %in% genera_with_mo_code$genus) %>%
@@ -184,8 +200,10 @@ genera_without_mo_code_abbr[genera_without_mo_code_abbr %in% microorganisms$mo]
# all unique??
sum(genera_without_mo_code_abbr %in% microorganisms$mo) == 0
genus_abb <- tibble(genus = genera_without_mo_code,
abbr = genera_without_mo_code_abbr) %>%
genus_abb <- tibble(
genus = genera_without_mo_code,
abbr = genera_without_mo_code_abbr
) %>%
bind_rows(microorganisms %>%
filter(kingdom == "Bacteria", rank == "genus", !genus %in% genera_without_mo_code) %>%
transmute(genus, abbr = as.character(mo))) %>%
@@ -195,11 +213,13 @@ genus_abb <- tibble(genus = genera_without_mo_code,
# Update taxonomy ---------------------------------------------------------
# fill in the taxonomy of new genera
updated_taxonomy <- tibble(phylum = character(0),
updated_taxonomy <- tibble(
phylum = character(0),
class = character(0),
order = character(0),
family = character(0),
genus = character(0))
genus = character(0)
)
for (page in LETTERS) {
message("Downloading page ", page, "... ", appendLF = FALSE)
url <- paste0("https://lpsn.dsmz.de/genus?page=", page)
@@ -223,11 +243,13 @@ for (page in LETTERS) {
txt[txt == "NA"] <- ""
txt <- gsub("[^A-Za-z]+", "", txt)
updated_taxonomy <- updated_taxonomy %>%
bind_rows(tibble(phylum = txt[2],
bind_rows(tibble(
phylum = txt[2],
class = txt[3],
order = txt[4],
family = txt[5],
genus = txt[6]))
genus = txt[6]
))
}
message(length(x), " entries (total ", nrow(updated_taxonomy), ")")
}
@@ -241,8 +263,10 @@ new_microorganisms <- new_microorganisms %>%
group_by(genus, species) %>%
mutate(subspecies_abb = abbreviate_mo(subspecies, 4)) %>%
ungroup() %>%
mutate(mo = paste(abbr, species_abb, subspecies_abb, sep = "_"),
mo = gsub("_+$", "", mo)) %>%
mutate(
mo = paste(abbr, species_abb, subspecies_abb, sep = "_"),
mo = gsub("_+$", "", mo)
) %>%
select(-matches("abb"))
# add taxonomy new microorganisms
@@ -261,23 +285,27 @@ MOs <- MOs %>%
filter(!fullname %in% new_synonyms$fullname) %>%
# update the taxonomy
left_join(updated_taxonomy, by = "genus", suffix = c("", ".new")) %>%
mutate(phylum = ifelse(!is.na(phylum.new), phylum.new, phylum),
mutate(
phylum = ifelse(!is.na(phylum.new), phylum.new, phylum),
class = ifelse(!is.na(class.new), class.new, class),
order = ifelse(!is.na(order.new), order.new, order),
family = ifelse(!is.na(family.new), family.new, family)) %>%
family = ifelse(!is.na(family.new), family.new, family)
) %>%
select(-ends_with(".new")) %>%
# update prevalence based on taxonomy (Berends et al., 2021)
mutate(prevalence = case_when(
class == "Gammaproteobacteria"
| genus %in% c("Enterococcus", "Staphylococcus", "Streptococcus")
class == "Gammaproteobacteria" |
genus %in% c("Enterococcus", "Staphylococcus", "Streptococcus")
~ 1,
kingdom %in% c("Archaea", "Bacteria", "Chromista", "Fungi")
& (phylum %in% c("Proteobacteria",
kingdom %in% c("Archaea", "Bacteria", "Chromista", "Fungi") &
(phylum %in% c(
"Proteobacteria",
"Firmicutes",
"Actinobacteria",
"Sarcomastigophora")
| genus %in% MO_PREVALENT_GENERA
| rank %in% c("kingdom", "phylum", "class", "order", "family"))
"Sarcomastigophora"
) |
genus %in% MO_PREVALENT_GENERA |
rank %in% c("kingdom", "phylum", "class", "order", "family"))
~ 2,
TRUE ~ 3
))
@@ -289,14 +317,16 @@ MOs <- MOs %>%
arrange(genus, species) %>%
distinct(genus, .keep_all = TRUE) %>%
filter(rank == "species", source != "manually added") %>%
mutate(mo = gsub("^([A-Z]_[A-Z]+)_.*", "\\1", mo),
mutate(
mo = gsub("^([A-Z]_[A-Z]+)_.*", "\\1", mo),
fullname = genus,
species = "",
subspecies = "",
rank = "genus",
species_id = "",
snomed = NA,
ref = NA_character_),
ref = NA_character_
),
MOs %>%
group_by(family) %>%
filter(!any(rank == "family") & n() > 1) %>%
@@ -304,12 +334,16 @@ MOs <- MOs %>%
arrange(family) %>%
distinct(family, .keep_all = TRUE) %>%
filter(!family %in% c("", NA), source != "manually added") %>%
mutate(mo = paste0(substr(kingdom, 1, 1), "_[FAM]_",
mutate(
mo = paste0(
substr(kingdom, 1, 1), "_[FAM]_",
abbreviate(family,
minlength = 8,
use.classes = TRUE,
method = "both.sides",
strict = FALSE)),
strict = FALSE
)
),
mo = toupper(mo),
fullname = family,
genus = "",
@@ -318,7 +352,8 @@ MOs <- MOs %>%
rank = "family",
species_id = "",
snomed = NA,
ref = NA_character_),
ref = NA_character_
),
MOs %>%
group_by(order) %>%
filter(!any(rank == "order") & n() > 1) %>%
@@ -326,12 +361,16 @@ MOs <- MOs %>%
arrange(order) %>%
distinct(order, .keep_all = TRUE) %>%
filter(!order %in% c("", NA), source != "manually added") %>%
mutate(mo = paste0(substr(kingdom, 1, 1), "_[ORD]_",
mutate(
mo = paste0(
substr(kingdom, 1, 1), "_[ORD]_",
abbreviate(order,
minlength = 8,
use.classes = TRUE,
method = "both.sides",
strict = FALSE)),
strict = FALSE
)
),
mo = toupper(mo),
fullname = order,
family = "",
@@ -341,7 +380,8 @@ MOs <- MOs %>%
rank = "order",
species_id = "",
snomed = NA,
ref = NA_character_)
ref = NA_character_
)
) %>%
arrange(fullname)
@@ -352,8 +392,12 @@ MOs <- MOs %>%
# Add LPSN record IDs -----------------------------------------------------
records_ids <- taxonomy %>%
mutate(across(1:3, function(x) { x[is.na(x)] <- ""; x}),
fullname = trimws(paste(genus_name, sp_epithet, subsp_epithet))) %>%
mutate(across(1:3, function(x) {
x[is.na(x)] <- ""
x
}),
fullname = trimws(paste(genus_name, sp_epithet, subsp_epithet))
) %>%
transmute(fullname, species_id = as.numeric(record_no)) %>%
arrange(fullname, species_id) %>%
distinct(fullname, .keep_all = TRUE)
@@ -362,9 +406,11 @@ MOs <- MOs %>%
select(-species_id) %>%
left_join(records_ids, by = "fullname") %>%
relocate(species_id, .after = ref) %>%
mutate(source = case_when(!is.na(species_id) ~ "LPSN",
mutate(source = case_when(
!is.na(species_id) ~ "LPSN",
source %unlike% "manual" ~ "CoL",
TRUE ~ source))
TRUE ~ source
))
# Merge synonyms ----------------------------------------------------------
@@ -398,12 +444,14 @@ microorganisms.old <- MOs.old
microorganisms <- microorganisms %>%
bind_rows(microorganisms %>%
filter(fullname == "Branhamella catarrhalis") %>%
mutate(mo = "B_MRXLL_CTRR",
mutate(
mo = "B_MRXLL_CTRR",
fullname = "Moraxella catarrhalis",
genus = "Moraxella",
ref = "Henriksen et al., 1968",
species_id = "a374f6f0868e05f9c0f5077b60ee0a6c",
snomed = as.list(24226003))) %>%
snomed = as.list(24226003)
)) %>%
arrange(fullname) %>%
df_remove_nonASCII()
microorganisms.old <- microorganisms.old %>%
@@ -444,7 +492,7 @@ rm(intrinsic_resistant)
# load new data sets again
devtools::load_all(".")
source("data-raw/pre-commit-hook.R")
source("data-raw/_pre_commit_hook.R")
devtools::load_all(".")

12
data-raw/reproduction_of_poorman.R
View File

@@ -25,20 +25,22 @@ sapply(files, function(file) {
contents <<- c(contents, readLines(file))
invisible()
})
contents <- c(intro,
contents <- c(
intro,
copyright,
"",
contents)
contents
)
# remove lines starting with "#'" and NULL and write to file
contents <- contents[!grepl("^(#'|NULL|\"_PACKAGE)", contents)]
# now make it independent on UseMethod, since we will not export these functions
contents <- gsub('UseMethod[(]"(.*?)"[)]',
'if ("grouped_data" %in% class(.data)) {||| \\1.grouped_data(.data, ...)||| } else {||| \\1.default(.data, ...)||| }',
paste(contents, collapse = "|||"),
perl = TRUE) %>%
perl = TRUE
) %>%
# add commit to intro part
gsub("{commit}", commit, ., fixed = TRUE) %>%
# add date to intro part
@@ -70,6 +72,8 @@ contents <- gsub("context", "pm_context", contents, fixed = TRUE)
contents <- gsub("(pm_)+", "pm_", contents)
# special case for pm_distinct(), we need '.keep_all' to work
contents <- gsub("pm_distinct <- function(.data, ..., .keep_all = FALSE)", "pm_distinct <- function(.data, ...)", contents, fixed = TRUE)
# pm_pull does not correct for tibbles, misses the drop argument
contents[contents == ".data[, var]"] <- ".data[, var, drop = TRUE]"
# who needs US spelling?
contents <- contents[!grepl("summarize", contents)]

52
data-raw/reproduction_of_rsi_translation.R
View File

@@ -41,18 +41,22 @@ ORGLIST <- read_tsv("data-raw/WHONET/Codes/ORGLIST.txt", na = c("", "NA", "-"),
rsi_generic <- DRGLST %>%
filter(CLSI == "X" | EUCST == "X") %>%
select(ab = ANTIBIOTIC, disk_dose = POTENCY, matches("^(CLSI|EUCST)[0-9]")) %>%
mutate(ab = as.ab(ab),
across(matches("(CLSI|EUCST)"), as.double)) %>%
mutate(
ab = as.ab(ab),
across(matches("(CLSI|EUCST)"), as.double)
) %>%
pivot_longer(-c(ab, disk_dose), names_to = "method") %>%
separate(method, into = c("guideline", "method"), sep = "_") %>%
mutate(method = ifelse(method %like% "D",
gsub("D", "DISK_", method, fixed = TRUE),
gsub("M", "MIC_", method, fixed = TRUE))) %>%
gsub("M", "MIC_", method, fixed = TRUE)
)) %>%
separate(method, into = c("method", "rsi"), sep = "_") %>%
# I is in the middle, so we only need R and S (saves data)
filter(rsi %in% c("R", "S")) %>%
pivot_wider(names_from = rsi, values_from = value) %>%
transmute(guideline = gsub("([0-9]+)$", " 20\\1", gsub("EUCST", "EUCAST", guideline)),
transmute(
guideline = gsub("([0-9]+)$", " 20\\1", gsub("EUCST", "EUCAST", guideline)),
method,
site = NA_character_,
mo = as.mo("UNKNOWN"),
@@ -61,31 +65,38 @@ rsi_generic <- DRGLST %>%
disk_dose,
breakpoint_S = S,
breakpoint_R = R,
uti = FALSE) %>%
uti = FALSE
) %>%
filter(!(is.na(breakpoint_S) & is.na(breakpoint_R)), !is.na(mo), !is.na(ab))
rsi_generic
# create data set for AB-specific and MO-specific rules
rsi_specific <- DRGLST1 %>%
# only support guidelines for humans (for now)
filter(HOST == "Human" & SITE_INF %unlike% "canine|feline",
filter(
HOST == "Human" & SITE_INF %unlike% "canine|feline",
# only CLSI and EUCAST
GUIDELINES %like% "(CLSI|EUCST)") %>%
GUIDELINES %like% "(CLSI|EUCST)"
) %>%
# get microorganism names from another WHONET table
mutate(ORG_CODE = tolower(ORG_CODE)) %>%
left_join(ORGLIST %>%
transmute(ORG_CODE = tolower(ORG),
SCT_TEXT = case_when(is.na(SCT_TEXT) & is.na(ORGANISM) ~ ORG_CODE,
transmute(
ORG_CODE = tolower(ORG),
SCT_TEXT = case_when(
is.na(SCT_TEXT) & is.na(ORGANISM) ~ ORG_CODE,
is.na(SCT_TEXT) ~ ORGANISM,
TRUE ~ SCT_TEXT)) %>%
TRUE ~ SCT_TEXT
)
) %>%
# WHO for 'Generic'
bind_rows(tibble(ORG_CODE = "gen", SCT_TEXT = "Unknown")) %>%
# WHO for 'Enterobacterales'
bind_rows(tibble(ORG_CODE = "ebc", SCT_TEXT = "Enterobacterales"))
) %>%
bind_rows(tibble(ORG_CODE = "ebc", SCT_TEXT = "Enterobacterales"))) %>%
# still some manual cleaning required
filter(!SCT_TEXT %in% c("Anaerobic Actinomycetes")) %>%
transmute(guideline = gsub("([0-9]+)$", " 20\\1", gsub("EUCST", "EUCAST", GUIDELINES)),
transmute(
guideline = gsub("([0-9]+)$", " 20\\1", gsub("EUCST", "EUCAST", GUIDELINES)),
method = toupper(TESTMETHOD),
site = SITE_INF,
mo = as.mo(SCT_TEXT),
@@ -94,20 +105,25 @@ rsi_specific <- DRGLST1 %>%
disk_dose = POTENCY,
breakpoint_S = as.double(ifelse(method == "DISK", DISK_S, MIC_S)),
breakpoint_R = as.double(ifelse(method == "DISK", DISK_R, MIC_R)),
uti = site %like% "(UTI|urinary|urine)") %>%
uti = site %like% "(UTI|urinary|urine)"
) %>%
filter(!(is.na(breakpoint_S) & is.na(breakpoint_R)), !is.na(mo), !is.na(ab))
rsi_specific
rsi_translation <- rsi_generic %>%
bind_rows(rsi_specific) %>%
# add the taxonomic rank index, used for sorting (so subspecies match first, order matches last)
mutate(rank_index = case_when(mo_rank(mo) %like% "(infra|sub)" ~ 1,
mutate(
rank_index = case_when(
mo_rank(mo) %like% "(infra|sub)" ~ 1,
mo_rank(mo) == "species" ~ 2,
mo_rank(mo) == "genus" ~ 3,
mo_rank(mo) == "family" ~ 4,
mo_rank(mo) == "order" ~ 5,
TRUE ~ 6),
.after = mo) %>%
TRUE ~ 6
),
.after = mo
) %>%
arrange(desc(guideline), ab, mo, method) %>%
distinct(guideline, ab, mo, method, site, .keep_all = TRUE) %>%
as.data.frame(stringsAsFactors = FALSE)
@@ -139,7 +155,7 @@ eucast_mics <- which(rsi_translation$guideline %like% "EUCAST" &
!is.na(rsi_translation$breakpoint_R))
old_R <- rsi_translation[eucast_mics, "breakpoint_R", drop = TRUE]
old_S <- rsi_translation[eucast_mics, "breakpoint_S", drop = TRUE]
new_R <- 2 ^ (log2(old_R) - 1)
new_R <- 2^(log2(old_R) - 1)
new_R[new_R < old_S | is.na(as.mic(new_R))] <- old_S[new_R < old_S | is.na(as.mic(new_R))]
rsi_translation[eucast_mics, "breakpoint_R"] <- new_R
eucast_disks <- which(rsi_translation$guideline %like% "EUCAST" &

11
data-raw/snomed.R
View File

@@ -42,12 +42,16 @@ vctr <- tolower(vctr[vctr %like% "^[a-z]+$"])
# remove all parts of the name that are no valid values in genera, species or subspecies
# this takes ~20 seconds
snomed <- snomed %>%
mutate(fullname = vapply(FUN.VALUE = character(1),
mutate(
fullname = vapply(
FUN.VALUE = character(1),
# split on space and/or comma
strsplit(tolower(mo), "[ ,]"),
function(x) trimws(paste0(x[x %in% vctr], collapse = " "))),
function(x) trimws(paste0(x[x %in% vctr], collapse = " "))
),
# remove " group"
fullname = gsub(" group", "", fullname, fixed = TRUE))
fullname = gsub(" group", "", fullname, fixed = TRUE)
)
snomed_keep <- snomed %>%
filter(fullname %in% tolower(c(microorganisms$fullname, microorganisms.old$fullname))) %>%
@@ -71,4 +75,3 @@ microorganisms <- microorganisms %>%
# don't forget to update the version number in SNOMED_VERSION in ./R/globals.R!
# usethis::use_data(microorganisms, overwrite = TRUE, version = 2, compress = "xz")

27
data-raw/toxoplasma.R
View File

@@ -1,6 +1,8 @@
microorganisms <- microorganisms |> bind_rows(
microorganisms <- microorganisms |>
bind_rows(
# Toxoplasma
data.frame(mo = "P_TXPL_GOND", # species
data.frame(
mo = "P_TXPL_GOND", # species
fullname = "Toxoplasma gondii",
kingdom = "(unknown kingdom)",
phylum = "Apicomplexa",
@@ -15,8 +17,10 @@ microorganisms <- microorganisms |> bind_rows(
species_id = NA_real_,
source = "manually added",
prevalence = 2,
stringsAsFactors = FALSE),
data.frame(mo = "P_TXPL", # genus
stringsAsFactors = FALSE
),
data.frame(
mo = "P_TXPL", # genus
fullname = "Toxoplasma",
kingdom = "(unknown kingdom)",
phylum = "Apicomplexa",
@@ -31,8 +35,10 @@ microorganisms <- microorganisms |> bind_rows(
species_id = NA_real_,
source = "manually added",
prevalence = 2,
stringsAsFactors = FALSE),
data.frame(mo = "[FAM]_SRCCYSTD", # family
stringsAsFactors = FALSE
),
data.frame(
mo = "[FAM]_SRCCYSTD", # family
fullname = "Sarcocystidae",
kingdom = "(unknown kingdom)",
phylum = "Apicomplexa",
@@ -47,8 +53,10 @@ microorganisms <- microorganisms |> bind_rows(
species_id = NA_real_,
source = "manually added",
prevalence = 2,
stringsAsFactors = FALSE),
data.frame(mo = "[ORD]_EUCCCDRD", # order
stringsAsFactors = FALSE
),
data.frame(
mo = "[ORD]_EUCCCDRD", # order
fullname = "Eucoccidiorida",
kingdom = "(unknown kingdom)",
phylum = "Apicomplexa",
@@ -63,6 +71,7 @@ microorganisms <- microorganisms |> bind_rows(
species_id = NA_real_,
source = "manually added",
prevalence = 2,
stringsAsFactors = FALSE),
stringsAsFactors = FALSE
),
) |>
arrange(fullname)

1
inst/tinytest/test-_deprecated.R
View File

@@ -22,4 +22,3 @@
# Visit our website for the full manual and a complete tutorial about #
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #

34
inst/tinytest/test-ab.R
View File

@@ -23,7 +23,9 @@
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
expect_equal(as.character(as.ab(c("J01FA01",
expect_equal(
as.character(as.ab(c(
"J01FA01",
"J 01 FA 01",
"Erythromycin",
"eryt",
@@ -32,8 +34,10 @@ expect_equal(as.character(as.ab(c("J01FA01",
"ERY",
"erytromicine",
"Erythrocin",
"Romycin"))),
rep("ERY", 10))
"Romycin"
))),
rep("ERY", 10)
)
expect_identical(class(as.ab("amox")), c("ab", "character"))
expect_identical(class(antibiotics$ab), c("ab", "character"))
@@ -47,17 +51,25 @@ expect_warning(as.ab(""))
expect_stdout(print(as.ab("amox")))
expect_equal(as.character(as.ab("Phloxapen")),
"FLC")
expect_equal(
as.character(as.ab("Phloxapen")),
"FLC"
)
expect_equal(suppressWarnings(as.character(as.ab(c("Bacteria", "Bacterial")))),
c(NA, "TMP"))
expect_equal(
suppressWarnings(as.character(as.ab(c("Bacteria", "Bacterial")))),
c(NA, "TMP")
)
expect_equal(as.character(as.ab("Amoxy + clavulaanzuur")),
"AMC")
expect_equal(
as.character(as.ab("Amoxy + clavulaanzuur")),
"AMC"
)
expect_equal(as.character(as.ab(c("mreopenem", "co-maoxiclav"))),
c("MEM", "AMC"))
expect_equal(
as.character(as.ab(c("mreopenem", "co-maoxiclav"))),
c("MEM", "AMC")
)
expect_message(as.ab("cipro mero"))

42
inst/tinytest/test-ab_from_text.R
View File

@@ -23,18 +23,32 @@
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
expect_identical(ab_from_text("28/03/2020 regular amoxicilliin 500mg po tds")[[1]],
as.ab("Amoxicillin"))
expect_identical(ab_from_text("28/03/2020 regular amoxicilliin 500mg po tds", thorough_search = TRUE)[[1]],
as.ab("Amoxicillin"))
expect_identical(ab_from_text("28/03/2020 regular amoxicilliin 500mg po tds", thorough_search = FALSE)[[1]],
as.ab("Amoxicillin"))
expect_identical(ab_from_text("28/03/2020 regular amoxicilliin 500mg po tds", translate_ab = TRUE)[[1]],
"Amoxicillin")
expect_identical(ab_from_text("administered amoxi/clav and cipro", collapse = ", ")[[1]],
"AMC, CIP")
expect_identical(
ab_from_text("28/03/2020 regular amoxicilliin 500mg po tds")[[1]],
as.ab("Amoxicillin")
)
expect_identical(
ab_from_text("28/03/2020 regular amoxicilliin 500mg po tds", thorough_search = TRUE)[[1]],
as.ab("Amoxicillin")
)
expect_identical(
ab_from_text("28/03/2020 regular amoxicilliin 500mg po tds", thorough_search = FALSE)[[1]],
as.ab("Amoxicillin")
)
expect_identical(
ab_from_text("28/03/2020 regular amoxicilliin 500mg po tds", translate_ab = TRUE)[[1]],
"Amoxicillin"
)
expect_identical(
ab_from_text("administered amoxi/clav and cipro", collapse = ", ")[[1]],
"AMC, CIP"
)
expect_identical(ab_from_text("28/03/2020 regular amoxicilliin 500mg po tds", type = "dose")[[1]],
500)
expect_identical(ab_from_text("28/03/2020 regular amoxicilliin 500mg po tds", type = "admin")[[1]],
"oral")
expect_identical(
ab_from_text("28/03/2020 regular amoxicilliin 500mg po tds", type = "dose")[[1]],
500
)
expect_identical(
ab_from_text("28/03/2020 regular amoxicilliin 500mg po tds", type = "admin")[[1]],
"oral"
)

42
inst/tinytest/test-ab_property.R
View File

@@ -47,8 +47,10 @@ expect_identical(ab_ddd("AMX", "iv"), 3)
expect_identical(ab_ddd_units("AMX", "iv"), "g")
expect_identical(ab_name(x = c("AMC", "PLB"), language = NULL), c("Amoxicillin/clavulanic acid", "Polymyxin B"))
expect_identical(ab_name(x = c("AMC", "PLB"), tolower = TRUE, language = NULL),
c("amoxicillin/clavulanic acid", "polymyxin B"))
expect_identical(
ab_name(x = c("AMC", "PLB"), tolower = TRUE, language = NULL),
c("amoxicillin/clavulanic acid", "polymyxin B")
)
expect_inherits(ab_info("AMX"), "list")
@@ -57,24 +59,36 @@ expect_error(ab_name("amox", language = "INVALID"))
expect_stdout(print(ab_name("amox", language = NULL)))
expect_equal(ab_name("21066-6", language = NULL), "Ampicillin")
expect_equal(ab_loinc("ampicillin"),
c("21066-6", "3355-5", "33562-0", "33919-2", "43883-8", "43884-6", "87604-5"))
expect_equal(
ab_loinc("ampicillin"),
c("21066-6", "3355-5", "33562-0", "33919-2", "43883-8", "43884-6", "87604-5")
)
expect_true(ab_url("AMX") %like% "whocc.no")
expect_warning(ab_url("ASP"))
expect_identical(colnames(set_ab_names(example_isolates[, 20:25])),
c("cefoxitin", "cefotaxime", "ceftazidime", "ceftriaxone", "gentamicin", "tobramycin"))
expect_identical(colnames(set_ab_names(example_isolates[, 20:25], language = "nl", snake_case = FALSE)),
c("Cefoxitine", "Cefotaxim", "Ceftazidim", "Ceftriaxon", "Gentamicine", "Tobramycine"))
expect_identical(colnames(set_ab_names(example_isolates[, 20:25], property = "atc")),
c("J01DC01", "J01DD01", "J01DD02", "J01DD04", "J01GB03", "J01GB01"))
expect_identical(
colnames(set_ab_names(example_isolates[, 20:25])),
c("cefoxitin", "cefotaxime", "ceftazidime", "ceftriaxone", "gentamicin", "tobramycin")
)
expect_identical(
colnames(set_ab_names(example_isolates[, 20:25], language = "nl", snake_case = FALSE)),
c("Cefoxitine", "Cefotaxim", "Ceftazidim", "Ceftriaxon", "Gentamicine", "Tobramycine")
)
expect_identical(
colnames(set_ab_names(example_isolates[, 20:25], property = "atc")),
c("J01DC01", "J01DD01", "J01DD02", "J01DD04", "J01GB03", "J01GB01")
)
if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0")) {
expect_identical(example_isolates %>% set_ab_names(),
example_isolates %>% rename_with(set_ab_names))
expect_true(all(c("SXT", "nitrofurantoin", "fosfomycin", "linezolid", "ciprofloxacin",
"moxifloxacin", "vancomycin", "TEC") %in%
expect_identical(
example_isolates %>% set_ab_names(),
example_isolates %>% rename_with(set_ab_names)
)
expect_true(all(c(
"SXT", "nitrofurantoin", "fosfomycin", "linezolid", "ciprofloxacin",
"moxifloxacin", "vancomycin", "TEC"
) %in%
(example_isolates %>%
set_ab_names(NIT:VAN) %>%
colnames())))

12
inst/tinytest/test-ab_selectors.R
View File

@@ -76,16 +76,20 @@ expect_equal(nrow(example_isolates[all(c(carbapenems(), aminoglycosides()) == "R
expect_equal(nrow(example_isolates[any(carbapenems() == "R"), penicillins()]), 55, tolerance = 0.5)
expect_equal(ncol(example_isolates[any(carbapenems() == "R"), penicillins()]), 7, tolerance = 0.5)
x <- data.frame(x = 0,
x <- data.frame(
x = 0,
mo = 0,
gen = "S",
genta = "S",
J01GB03 = "S",
tobra = "S",
Tobracin = "S")
Tobracin = "S"
)
# should have the first hits
expect_identical(colnames(x[, aminoglycosides()]),
c("gen", "tobra"))
expect_identical(
colnames(x[, aminoglycosides()]),
c("gen", "tobra")
)
if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0")) {
expect_equal(example_isolates %>% select(administrable_per_os() & penicillins()) %>% ncol(), 5, tolerance = 0.5)

87
inst/tinytest/test-age.R
View File

@@ -23,46 +23,75 @@
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
expect_equal(age(x = c("1980-01-01", "1985-01-01", "1990-01-01"),
reference = "2019-01-01"),
c(39, 34, 29))
expect_equal(
age(
x = c("1980-01-01", "1985-01-01", "1990-01-01"),
reference = "2019-01-01"
),
c(39, 34, 29)
)
expect_equal(age(x = c("2019-01-01", "2019-04-01", "2019-07-01"),
expect_equal(age(
x = c("2019-01-01", "2019-04-01", "2019-07-01"),
reference = "2019-09-01",
exact = TRUE),
c(0.6656393, 0.4191781, 0.1698630),
tolerance = 0.001)
exact = TRUE
),
c(0.6656393, 0.4191781, 0.1698630),
tolerance = 0.001
)
expect_error(age(x = c("1980-01-01", "1985-01-01", "1990-01-01"),
reference = c("2019-01-01", "2019-01-01")))
expect_error(age(
x = c("1980-01-01", "1985-01-01", "1990-01-01"),
reference = c("2019-01-01", "2019-01-01")
))
expect_warning(age(x = c("1980-01-01", "1985-01-01", "1990-01-01"),
reference = "1975-01-01"))
expect_warning(age(
x = c("1980-01-01", "1985-01-01", "1990-01-01"),
reference = "1975-01-01"
))
expect_warning(age(x = c("1800-01-01", "1805-01-01", "1810-01-01"),
reference = "2019-01-01"))
expect_warning(age(
x = c("1800-01-01", "1805-01-01", "1810-01-01"),
reference = "2019-01-01"
))
expect_equal(length(age(x = c("2019-01-01", NA), na.rm = TRUE)),
1)
expect_equal(
length(age(x = c("2019-01-01", NA), na.rm = TRUE)),
1
)
ages <- c(3, 8, 16, 54, 31, 76, 101, 43, 21)
expect_equal(length(unique(age_groups(ages, 50))),
2)
expect_equal(length(unique(age_groups(ages, c(50, 60)))),
3)
expect_identical(class(age_groups(ages, "child")),
c("ordered", "factor"))
expect_equal(
length(unique(age_groups(ages, 50))),
2
)
expect_equal(
length(unique(age_groups(ages, c(50, 60)))),
3
)
expect_identical(
class(age_groups(ages, "child")),
c("ordered", "factor")
)
expect_identical(class(age_groups(ages, "elderly")),
c("ordered", "factor"))
expect_identical(
class(age_groups(ages, "elderly")),
c("ordered", "factor")
)
expect_identical(class(age_groups(ages, "tens")),
c("ordered", "factor"))
expect_identical(
class(age_groups(ages, "tens")),
c("ordered", "factor")
)
expect_identical(class(age_groups(ages, "fives")),
c("ordered", "factor"))
expect_identical(
class(age_groups(ages, "fives")),
c("ordered", "factor")
)
expect_equal(length(age_groups(c(10, 20, 30, NA), na.rm = TRUE)),
3)
expect_equal(
length(age_groups(c(10, 20, 30, NA), na.rm = TRUE)),
3
)

1
inst/tinytest/test-atc_online.R
View File

@@ -31,5 +31,4 @@ if (AMR:::pkg_is_available("curl", also_load = FALSE) &&
expect_equal(atc_online_ddd(ab_atc("AMX"), administration = "O"), 1.5)
expect_equal(atc_online_ddd(ab_atc("AMX"), administration = "P"), 3)
expect_equal(atc_online_ddd_units("AMX", administration = "P"), "g")
}

54
inst/tinytest/test-count.R
View File

@@ -31,16 +31,22 @@ expect_equal(count_all(example_isolates$AMX), n_rsi(example_isolates$AMX))
expect_equal(count_R(example_isolates$AMX), 804)
expect_equal(count_I(example_isolates$AMX), 3)
expect_equal(suppressWarnings(count_S(example_isolates$AMX)), 543)
expect_equal(count_R(example_isolates$AMX) + count_I(example_isolates$AMX),
suppressWarnings(count_IR(example_isolates$AMX)))
expect_equal(suppressWarnings(count_S(example_isolates$AMX)) + count_I(example_isolates$AMX),
count_SI(example_isolates$AMX))
expect_equal(
count_R(example_isolates$AMX) + count_I(example_isolates$AMX),
suppressWarnings(count_IR(example_isolates$AMX))
)
expect_equal(
suppressWarnings(count_S(example_isolates$AMX)) + count_I(example_isolates$AMX),
count_SI(example_isolates$AMX)
)
# warning for speed loss
expect_warning(count_resistant(as.character(example_isolates$AMC)))
expect_warning(count_resistant(example_isolates$AMC,
as.character(example_isolates$GEN)))
expect_warning(count_resistant(
example_isolates$AMC,
as.character(example_isolates$GEN)
))
# check for errors
expect_error(count_resistant("test", minimum = "test"))
@@ -57,35 +63,47 @@ if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0")) {
expect_equal(example_isolates %>% count_susceptible(AMC, GEN, only_all_tested = FALSE), 1764)
expect_equal(example_isolates %>% count_all(AMC, GEN, only_all_tested = TRUE), 1798)
expect_equal(example_isolates %>% count_all(AMC, GEN, only_all_tested = FALSE), 1936)
expect_identical(example_isolates %>% count_all(AMC, GEN, only_all_tested = TRUE),
expect_identical(
example_isolates %>% count_all(AMC, GEN, only_all_tested = TRUE),
example_isolates %>% count_susceptible(AMC, GEN, only_all_tested = TRUE) +
example_isolates %>% count_resistant(AMC, GEN, only_all_tested = TRUE))
example_isolates %>% count_resistant(AMC, GEN, only_all_tested = TRUE)
)
# count of cases
expect_equal(example_isolates %>%
expect_equal(
example_isolates %>%
group_by(ward) %>%
summarise(cipro = count_susceptible(CIP),
summarise(
cipro = count_susceptible(CIP),
genta = count_susceptible(GEN),
combination = count_susceptible(CIP, GEN)) %>%
combination = count_susceptible(CIP, GEN)
) %>%
pull(combination),
c(253, 465, 192, 558))
c(253, 465, 192, 558)
)
# count_df
expect_equal(
example_isolates %>% select(AMX) %>% count_df() %>% pull(value),
c(example_isolates$AMX %>% count_susceptible(),
example_isolates$AMX %>% count_resistant())
c(
example_isolates$AMX %>% count_susceptible(),
example_isolates$AMX %>% count_resistant()
)
)
expect_equal(
example_isolates %>% select(AMX) %>% count_df(combine_IR = TRUE) %>% pull(value),
c(suppressWarnings(example_isolates$AMX %>% count_S()),
suppressWarnings(example_isolates$AMX %>% count_IR()))
c(
suppressWarnings(example_isolates$AMX %>% count_S()),
suppressWarnings(example_isolates$AMX %>% count_IR())
)
)
expect_equal(
example_isolates %>% select(AMX) %>% count_df(combine_SI = FALSE) %>% pull(value),
c(suppressWarnings(example_isolates$AMX %>% count_S()),
c(
suppressWarnings(example_isolates$AMX %>% count_S()),
example_isolates$AMX %>% count_I(),
example_isolates$AMX %>% count_R())
example_isolates$AMX %>% count_R()
)
)
# grouping in rsi_calc_df() (= backbone of rsi_df())

32
inst/tinytest/test-data.R
View File

@@ -64,30 +64,42 @@ for (i in seq_len(length(datasets))) {
df <- AMR:::MO_lookup
expect_true(nrow(df[which(df$prevalence == 1), , drop = FALSE]) < nrow(df[which(df$prevalence == 2), , drop = FALSE]))
expect_true(nrow(df[which(df$prevalence == 2), , drop = FALSE]) < nrow(df[which(df$prevalence == 3), , drop = FALSE]))
expect_true(all(c("mo", "fullname",
expect_true(all(c(
"mo", "fullname",
"kingdom", "phylum", "class", "order", "family", "genus", "species", "subspecies",
"rank", "ref", "species_id", "source", "prevalence", "snomed",
"kingdom_index", "fullname_lower", "g_species") %in% colnames(df)))
"kingdom_index", "fullname_lower", "g_species"
) %in% colnames(df)))
expect_true(all(c("fullname", "fullname_new", "ref", "prevalence",
"fullname_lower", "g_species") %in% colnames(AMR:::MO.old_lookup)))
expect_true(all(c(
"fullname", "fullname_new", "ref", "prevalence",
"fullname_lower", "g_species"
) %in% colnames(AMR:::MO.old_lookup)))
expect_inherits(AMR:::MO_CONS, "mo")
expect_identical(class(catalogue_of_life_version()),
c("catalogue_of_life_version", "list"))
expect_identical(
class(catalogue_of_life_version()),
c("catalogue_of_life_version", "list")
)
expect_stdout(print(catalogue_of_life_version()))
uncategorised <- subset(microorganisms,
uncategorised <- subset(
microorganisms,
genus == "Staphylococcus" &
!species %in% c("", "aureus") &
!mo %in% c(AMR:::MO_CONS, AMR:::MO_COPS))
!mo %in% c(AMR:::MO_CONS, AMR:::MO_COPS)
)
expect_true(NROW(uncategorised) == 0,
info = ifelse(NROW(uncategorised) == 0,
"All staphylococcal species categorised as CoNS/CoPS.",
paste0("Staphylococcal species not categorised as CoNS/CoPS: S. ",
uncategorised$species, " (", uncategorised$mo, ")")))
paste0(
"Staphylococcal species not categorised as CoNS/CoPS: S. ",
uncategorised$species, " (", uncategorised$mo, ")"
)
)
)
# THIS WILL CHECK NON-ASCII STRINGS IN ALL FILES:

27
inst/tinytest/test-episode.R
View File

@@ -31,18 +31,27 @@ test_df <- rbind(
data.frame(
date = as.Date(c("2015-01-01", "2016-02-01", "2016-12-31", "2017-01-01", "2017-02-03")),
patient_id = "B"
))
)
)
expect_equal(get_episode(test_df$date, 365),
c(1, 1, 2, 2, 2, 3, 3, 4, 1, 2, 2, 2, 3))
expect_equal(get_episode(test_df$date[which(test_df$patient_id == "A")], 365),
c(1, 1, 2, 2, 2, 2, 3, 4))
expect_equal(get_episode(test_df$date[which(test_df$patient_id == "B")], 365),
c(1, 2, 2, 2, 3))
expect_equal(
get_episode(test_df$date, 365),
c(1, 1, 2, 2, 2, 3, 3, 4, 1, 2, 2, 2, 3)
)
expect_equal(
get_episode(test_df$date[which(test_df$patient_id == "A")], 365),
c(1, 1, 2, 2, 2, 2, 3, 4)
)
expect_equal(
get_episode(test_df$date[which(test_df$patient_id == "B")], 365),
c(1, 2, 2, 2, 3)
)
if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0")) {
expect_identical(test_df %>% group_by(patient_id) %>% mutate(f = is_new_episode(date, 365)) %>% pull(f),
c(TRUE, FALSE, TRUE, FALSE, FALSE, FALSE, TRUE, TRUE, TRUE, TRUE, FALSE, FALSE, TRUE))
expect_identical(
test_df %>% group_by(patient_id) %>% mutate(f = is_new_episode(date, 365)) %>% pull(f),
c(TRUE, FALSE, TRUE, FALSE, FALSE, FALSE, TRUE, TRUE, TRUE, TRUE, FALSE, FALSE, TRUE)
)
suppressMessages(
x <- example_isolates %>%

149
inst/tinytest/test-eucast_rules.R
View File

@@ -24,13 +24,17 @@
# ==================================================================== #
# thoroughly check input table
expect_equal(colnames(AMR:::EUCAST_RULES_DF),
c("if_mo_property", "like.is.one_of", "this_value",
expect_equal(
colnames(AMR:::EUCAST_RULES_DF),
c(
"if_mo_property", "like.is.one_of", "this_value",
"and_these_antibiotics", "have_these_values",
"then_change_these_antibiotics", "to_value",
"reference.rule", "reference.rule_group",
"reference.version",
"note"))
"note"
)
)
MOs_mentioned <- unique(AMR:::EUCAST_RULES_DF$this_value)
MOs_mentioned <- sort(AMR:::trimws(unlist(strsplit(MOs_mentioned[!AMR:::is_valid_regex(MOs_mentioned)], ",", fixed = TRUE))))
MOs_test <- suppressWarnings(suppressMessages(mo_name(MOs_mentioned)))
@@ -43,71 +47,103 @@ expect_error(eucast_rules(data.frame(mo = "test"), rules = "invalid rules set"))
expect_warning(eucast_rules(data.frame(mo = "Escherichia coli", vancomycin = "S", stringsAsFactors = TRUE)))
expect_identical(colnames(example_isolates),
colnames(suppressWarnings(eucast_rules(example_isolates, info = FALSE))))
expect_identical(
colnames(example_isolates),
colnames(suppressWarnings(eucast_rules(example_isolates, info = FALSE)))
)
expect_stdout(suppressMessages(eucast_rules(example_isolates, info = TRUE)))
a <- data.frame(mo = c("Klebsiella pneumoniae",
a <- data.frame(
mo = c(
"Klebsiella pneumoniae",
"Pseudomonas aeruginosa",
"Enterobacter cloacae"),
"Enterobacter cloacae"
),
amox = "-", # Amoxicillin
stringsAsFactors = FALSE)
b <- data.frame(mo = c("Klebsiella pneumoniae",
stringsAsFactors = FALSE
)
b <- data.frame(
mo = c(
"Klebsiella pneumoniae",
"Pseudomonas aeruginosa",
"Enterobacter cloacae"),
"Enterobacter cloacae"
),
amox = "R", # Amoxicillin
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
expect_identical(suppressWarnings(eucast_rules(a, "mo", info = FALSE)), b)
expect_stdout(suppressMessages(suppressWarnings(eucast_rules(a, "mo", info = TRUE))))
a <- data.frame(mo = c("Staphylococcus aureus",
"Streptococcus group A"),
a <- data.frame(
mo = c(
"Staphylococcus aureus",
"Streptococcus group A"
),
COL = "-", # Colistin
stringsAsFactors = FALSE)
b <- data.frame(mo = c("Staphylococcus aureus",
"Streptococcus group A"),
stringsAsFactors = FALSE
)
b <- data.frame(
mo = c(
"Staphylococcus aureus",
"Streptococcus group A"
),
COL = "R", # Colistin
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
expect_equal(suppressWarnings(eucast_rules(a, "mo", info = FALSE)), b)
# piperacillin must be R in Enterobacteriaceae when tica is R
if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0")) {
expect_equal(suppressWarnings(
expect_equal(
suppressWarnings(
example_isolates %>%
filter(mo_family(mo) == "Enterobacteriaceae") %>%
mutate(TIC = as.rsi("R"),
PIP = as.rsi("S")) %>%
mutate(
TIC = as.rsi("R"),
PIP = as.rsi("S")
) %>%
eucast_rules(col_mo = "mo", version_expertrules = 3.1, info = FALSE) %>%
pull(PIP) %>%
unique() %>%
as.character()),
"R")
as.character()
),
"R"
)
}
# azithromycin and clarythromycin must be equal to Erythromycin
a <- suppressWarnings(as.rsi(eucast_rules(data.frame(mo = example_isolates$mo,
a <- suppressWarnings(as.rsi(eucast_rules(data.frame(
mo = example_isolates$mo,
ERY = example_isolates$ERY,
AZM = as.rsi("R"),
CLR = factor("R"),
stringsAsFactors = FALSE),
version_expertrules = 3.1,
only_rsi_columns = FALSE)$CLR))
stringsAsFactors = FALSE
),
version_expertrules = 3.1,
only_rsi_columns = FALSE
)$CLR))
b <- example_isolates$ERY
expect_identical(a[!is.na(b)],
b[!is.na(b)])
expect_identical(
a[!is.na(b)],
b[!is.na(b)]
)
# amox is inferred by benzylpenicillin in Kingella kingae
expect_equal(
suppressWarnings(
as.list(eucast_rules(
data.frame(mo = as.mo("Kingella kingae"),
data.frame(
mo = as.mo("Kingella kingae"),
PEN = "S",
AMX = "-",
stringsAsFactors = FALSE)
, info = FALSE))$AMX
stringsAsFactors = FALSE
),
"S")
info = FALSE
))$AMX
),
"S"
)
# also test norf
if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0")) {
@@ -120,25 +156,37 @@ expect_stdout(suppressWarnings(eucast_rules(example_isolates, verbose = TRUE, ru
# AmpC de-repressed cephalo mutants
expect_identical(
eucast_rules(data.frame(mo = c("Escherichia coli", "Enterobacter cloacae"),
cefotax = as.rsi(c("S", "S"))),
eucast_rules(data.frame(
mo = c("Escherichia coli", "Enterobacter cloacae"),
cefotax = as.rsi(c("S", "S"))
),
ampc_cephalosporin_resistance = TRUE,
info = FALSE)$cefotax,
as.rsi(c("S", "R")))
info = FALSE
)$cefotax,
as.rsi(c("S", "R"))
)
expect_identical(
eucast_rules(data.frame(mo = c("Escherichia coli", "Enterobacter cloacae"),
cefotax = as.rsi(c("S", "S"))),
eucast_rules(data.frame(
mo = c("Escherichia coli", "Enterobacter cloacae"),
cefotax = as.rsi(c("S", "S"))
),
ampc_cephalosporin_resistance = NA,
info = FALSE)$cefotax,
as.rsi(c("S", NA)))
info = FALSE
)$cefotax,
as.rsi(c("S", NA))
)
expect_identical(
eucast_rules(data.frame(mo = c("Escherichia coli", "Enterobacter cloacae"),
cefotax = as.rsi(c("S", "S"))),
eucast_rules(data.frame(
mo = c("Escherichia coli", "Enterobacter cloacae"),
cefotax = as.rsi(c("S", "S"))
),
ampc_cephalosporin_resistance = NULL,
info = FALSE)$cefotax,
as.rsi(c("S", "S")))
info = FALSE
)$cefotax,
as.rsi(c("S", "S"))
)
# EUCAST dosage -----------------------------------------------------------
expect_equal(nrow(eucast_dosage(c("tobra", "genta", "cipro"))), 3)
@@ -146,9 +194,11 @@ expect_inherits(eucast_dosage(c("tobra", "genta", "cipro")), "data.frame")
x <- custom_eucast_rules(AMC == "R" & genus == "Klebsiella" ~ aminopenicillins == "R",
x <- custom_eucast_rules(
AMC == "R" & genus == "Klebsiella" ~ aminopenicillins == "R",
AMC == "I" & genus == "Klebsiella" ~ aminopenicillins == "I",
AMX == "S" ~ AMC == "S")
AMX == "S" ~ AMC == "S"
)
expect_stdout(print(x))
expect_stdout(print(c(x, x)))
expect_stdout(print(as.list(x, x)))
@@ -158,5 +208,8 @@ expect_equal(nrow(eucast_rules(example_isolates,
rules = "custom",
custom_rules = x,
info = FALSE,
verbose = TRUE)),
8, tolerance = 0.5)
verbose = TRUE
)),
8,
tolerance = 0.5
)

155
inst/tinytest/test-first_isolate.R
View File

@@ -24,26 +24,42 @@
# ==================================================================== #
# all four methods
expect_equal(sum(first_isolate(x = example_isolates, method = "isolate-based", info = TRUE), na.rm = TRUE),
1984)
expect_equal(sum(first_isolate(x = example_isolates, method = "patient-based", info = TRUE), na.rm = TRUE),
1265)
expect_equal(sum(first_isolate(x = example_isolates, method = "episode-based", info = TRUE), na.rm = TRUE),
1300)
expect_equal(sum(first_isolate(x = example_isolates, method = "phenotype-based", info = TRUE), na.rm = TRUE),
1379)
expect_equal(
sum(first_isolate(x = example_isolates, method = "isolate-based", info = TRUE), na.rm = TRUE),
1984
)
expect_equal(
sum(first_isolate(x = example_isolates, method = "patient-based", info = TRUE), na.rm = TRUE),
1265
)
expect_equal(
sum(first_isolate(x = example_isolates, method = "episode-based", info = TRUE), na.rm = TRUE),
1300
)
expect_equal(
sum(first_isolate(x = example_isolates, method = "phenotype-based", info = TRUE), na.rm = TRUE),
1379
)
# Phenotype-based, using key antimicrobials
expect_equal(sum(first_isolate(x = example_isolates,
expect_equal(
sum(first_isolate(
x = example_isolates,
method = "phenotype-based",
type = "keyantimicrobials",
antifungal = NULL, info = TRUE), na.rm = TRUE),
1395)
expect_equal(sum(first_isolate(x = example_isolates,
antifungal = NULL, info = TRUE
), na.rm = TRUE),
1395
)
expect_equal(
sum(first_isolate(
x = example_isolates,
method = "phenotype-based",
type = "keyantimicrobials",
antifungal = NULL, info = TRUE, ignore_I = FALSE), na.rm = TRUE),
1418)
antifungal = NULL, info = TRUE, ignore_I = FALSE
), na.rm = TRUE),
1418
)
# first non-ICU isolates
@@ -55,9 +71,12 @@ expect_equal(
col_patient_id = "patient",
col_icu = example_isolates$ward == "ICU",
info = TRUE,
icu_exclude = TRUE),
na.rm = TRUE),
941)
icu_exclude = TRUE
),
na.rm = TRUE
),
941
)
# set 1500 random observations to be of specimen type 'Urine'
random_rows <- sample(x = 1:2000, size = 1500, replace = FALSE)
@@ -65,16 +84,20 @@ x <- example_isolates
x$specimen <- "Other"
x[random_rows, "specimen"] <- "Urine"
expect_true(
sum(first_isolate(x = x,
sum(first_isolate(
x = x,
col_date = "date",
col_patient_id = "patient",
col_mo = "mo",
col_specimen = "specimen",
filter_specimen = "Urine",
info = TRUE), na.rm = TRUE) < 1501)
info = TRUE
), na.rm = TRUE) < 1501
)
# same, but now exclude ICU
expect_true(
sum(first_isolate(x = x,
sum(first_isolate(
x = x,
col_date = "date",
col_patient_id = "patient",
col_mo = "mo",
@@ -82,7 +105,9 @@ expect_true(
filter_specimen = "Urine",
col_icu = x$ward == "ICU",
icu_exclude = TRUE,
info = TRUE), na.rm = TRUE) < 1501)
info = TRUE
), na.rm = TRUE) < 1501
)
# "No isolates found"
test_iso <- example_isolates
@@ -93,7 +118,8 @@ expect_message(first_isolate(test_iso,
col_mo = "mo",
col_specimen = "specimen",
filter_specimen = "something_unexisting",
info = TRUE))
info = TRUE
))
# printing of exclusion message
expect_message(first_isolate(example_isolates,
@@ -102,41 +128,54 @@ expect_message(first_isolate(example_isolates,
col_patient_id = "patient",
col_testcode = "gender",
testcodes_exclude = "M",
info = TRUE))
info = TRUE
))
# errors
expect_error(first_isolate("date", "patient", col_mo = "mo"))
expect_error(first_isolate(example_isolates,
col_date = "non-existing col",
col_mo = "mo"))
col_mo = "mo"
))
if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0")) {
# if mo is not an mo class, result should be the same
expect_identical(example_isolates %>%
mutate(mo = as.character(mo)) %>%
first_isolate(col_date = "date",
col_mo = "mo",
col_patient_id = "patient",
info = FALSE),
expect_identical(
example_isolates %>%
first_isolate(col_date = "date",
mutate(mo = as.character(mo)) %>%
first_isolate(
col_date = "date",
col_mo = "mo",
col_patient_id = "patient",
info = FALSE))
info = FALSE
),
example_isolates %>%
first_isolate(
col_date = "date",
col_mo = "mo",
col_patient_id = "patient",
info = FALSE
)
)
# support for WHONET
expect_message(example_isolates %>%
select(-patient_id) %>%
mutate(`First name` = "test",
mutate(
`First name` = "test",
`Last name` = "test",
Sex = "Female") %>%
Sex = "Female"
) %>%
first_isolate(info = TRUE))
# groups
x <- example_isolates %>% group_by(ward) %>% mutate(first = first_isolate())
y <- example_isolates %>% group_by(ward) %>% mutate(first = first_isolate(.))
x <- example_isolates %>%
group_by(ward) %>%
mutate(first = first_isolate())
y <- example_isolates %>%
group_by(ward) %>%
mutate(first = first_isolate(.))
expect_identical(x, y)
}
# missing dates should be no problem
@@ -144,33 +183,47 @@ df <- example_isolates
df[1:100, "date"] <- NA
expect_equal(
sum(
first_isolate(x = df,
first_isolate(
x = df,
col_date = "date",
col_patient_id = "patient",
col_mo = "mo",
info = TRUE),
na.rm = TRUE),
1382)
info = TRUE
),
na.rm = TRUE
),
1382
)
# unknown MOs
test_unknown <- example_isolates
test_unknown$mo <- ifelse(test_unknown$mo == "B_ESCHR_COLI", "UNKNOWN", test_unknown$mo)
expect_equal(sum(first_isolate(test_unknown, include_unknown = FALSE)),
1108)
expect_equal(sum(first_isolate(test_unknown, include_unknown = TRUE)),
1591)
expect_equal(
sum(first_isolate(test_unknown, include_unknown = FALSE)),
1108
)
expect_equal(
sum(first_isolate(test_unknown, include_unknown = TRUE)),
1591
)
test_unknown$mo <- ifelse(test_unknown$mo == "UNKNOWN", NA, test_unknown$mo)
expect_equal(sum(first_isolate(test_unknown)),
1108)
expect_equal(
sum(first_isolate(test_unknown)),
1108
)
# empty rsi results
expect_equal(sum(first_isolate(example_isolates, include_untested_rsi = FALSE)),
1366)
expect_equal(
sum(first_isolate(example_isolates, include_untested_rsi = FALSE)),
1366
)
# shortcuts
expect_identical(filter_first_isolate(example_isolates),
subset(example_isolates, first_isolate(example_isolates)))
expect_identical(
filter_first_isolate(example_isolates),
subset(example_isolates, first_isolate(example_isolates))
)
# notice that all mo's are distinct, so all are TRUE

18
inst/tinytest/test-g.test.R
View File

@@ -29,13 +29,15 @@
x <- c(772, 1611, 737)
expect_equal(g.test(x, p = c(0.25, 0.50, 0.25))$p.value,
0.12574,
tolerance = 0.0001)
tolerance = 0.0001
)
# example 2: red crossbills
x <- c(1752, 1895)
expect_equal(g.test(x)$p.value,
0.017873,
tolerance = 0.0001)
tolerance = 0.0001
)
expect_error(g.test(0))
expect_error(g.test(c(0, 1), 0))
@@ -46,18 +48,22 @@ expect_warning(g.test(c(1, 2, 3, 4), p = c(0.25, 0.25, 0.25, 0.24), rescale.p =
# INDEPENDENCE
x <- as.data.frame(
matrix(data = round(runif(4) * 100000, 0),
matrix(
data = round(runif(4) * 100000, 0),
ncol = 2,
byrow = TRUE)
byrow = TRUE
)
)
# fisher.test() is always better for 2x2 tables:
expect_warning(g.test(x))
expect_true(suppressWarnings(g.test(x)$p.value) < 1)
expect_warning(g.test(x = c(772, 1611, 737),
expect_warning(g.test(
x = c(772, 1611, 737),
y = c(780, 1560, 780),
rescale.p = TRUE))
rescale.p = TRUE
))
expect_error(g.test(matrix(data = c(-1, -2, -3, -4), ncol = 2, byrow = TRUE)))
expect_error(g.test(matrix(data = c(0, 0, 0, 0), ncol = 2, byrow = TRUE)))

42
inst/tinytest/test-ggplot_rsi.R
View File

@@ -24,7 +24,6 @@
# ==================================================================== #
if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0") & AMR:::pkg_is_available("ggplot2")) {
pdf(NULL) # prevent Rplots.pdf being created
# data should be equal
@@ -84,29 +83,44 @@ if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0") & AMR:::pkg_is_availa
)
# support for scale_type ab and mo
expect_inherits((data.frame(mo = as.mo(c("e. coli", "s aureus")),
n = c(40, 100)) %>%
expect_inherits(
(data.frame(
mo = as.mo(c("e. coli", "s aureus")),
n = c(40, 100)
) %>%
ggplot(aes(x = mo, y = n)) +
geom_col())$data,
"data.frame")
expect_inherits((data.frame(ab = as.ab(c("amx", "amc")),
n = c(40, 100)) %>%
"data.frame"
)
expect_inherits(
(data.frame(
ab = as.ab(c("amx", "amc")),
n = c(40, 100)
) %>%
ggplot(aes(x = ab, y = n)) +
geom_col())$data,
"data.frame")
"data.frame"
)
expect_inherits((data.frame(ab = as.ab(c("amx", "amc")),
n = c(40, 100)) %>%
expect_inherits(
(data.frame(
ab = as.ab(c("amx", "amc")),
n = c(40, 100)
) %>%
ggplot(aes(x = ab, y = n)) +
geom_col())$data,
"data.frame")
"data.frame"
)
# support for manual colours
expect_inherits((ggplot(data.frame(x = c("Value1", "Value2", "Value3"),
expect_inherits(
(ggplot(data.frame(
x = c("Value1", "Value2", "Value3"),
y = c(1, 2, 3),
z = c("Value4", "Value5", "Value6"))) +
z = c("Value4", "Value5", "Value6")
)) +
geom_col(aes(x = x, y = y, fill = z)) +
scale_rsi_colours(Value4 = "S", Value5 = "I", Value6 = "R"))$data,
"data.frame")
"data.frame"
)
}

48
inst/tinytest/test-guess_ab_col.R
View File

@@ -23,20 +23,36 @@
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
expect_equal(guess_ab_col(example_isolates, "amox"),
"AMX")
expect_equal(guess_ab_col(example_isolates, "amoxicillin"),
"AMX")
expect_equal(guess_ab_col(example_isolates, "J01AA07"),
"TCY")
expect_equal(guess_ab_col(example_isolates, "tetracycline"),
"TCY")
expect_equal(guess_ab_col(example_isolates, "TETR"),
"TCY")
expect_equal(
guess_ab_col(example_isolates, "amox"),
"AMX"
)
expect_equal(
guess_ab_col(example_isolates, "amoxicillin"),
"AMX"
)
expect_equal(
guess_ab_col(example_isolates, "J01AA07"),
"TCY"
)
expect_equal(
guess_ab_col(example_isolates, "tetracycline"),
"TCY"
)
expect_equal(
guess_ab_col(example_isolates, "TETR"),
"TCY"
)
df <- data.frame(AMP_ND10 = "R",
AMC_ED20 = "S")
expect_equal(guess_ab_col(df, "ampicillin"),
"AMP_ND10")
expect_equal(guess_ab_col(df, "J01CR02"),
"AMC_ED20")
df <- data.frame(
AMP_ND10 = "R",
AMC_ED20 = "S"
)
expect_equal(
guess_ab_col(df, "ampicillin"),
"AMP_ND10"
)
expect_equal(
guess_ab_col(df, "J01CR02"),
"AMC_ED20"
)

18
inst/tinytest/test-italicise_taxonomy.R
View File

@@ -23,11 +23,17 @@
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
expect_identical(italicise_taxonomy("test for E. coli"),
"test for *E. coli*")
expect_identical(italicise_taxonomy("test for E. coli"),
italicize_taxonomy("test for E. coli"))
expect_identical(
italicise_taxonomy("test for E. coli"),
"test for *E. coli*"
)
expect_identical(
italicise_taxonomy("test for E. coli"),
italicize_taxonomy("test for E. coli")
)
if (AMR:::has_colour()) {
expect_identical(italicise_taxonomy("test for E. coli", type = "ansi"),
"test for \033[3mE. coli\033[23m")
expect_identical(
italicise_taxonomy("test for E. coli", type = "ansi"),
"test for \033[3mE. coli\033[23m"
)
}

15
inst/tinytest/test-kurtosis.R
View File

@@ -25,18 +25,23 @@
expect_equal(kurtosis(example_isolates$age),
5.227999,
tolerance = 0.00001)
tolerance = 0.00001
)
expect_equal(unname(kurtosis(data.frame(example_isolates$age))),
5.227999,
tolerance = 0.00001)
tolerance = 0.00001
)
expect_equal(unname(kurtosis(data.frame(example_isolates$age), excess = TRUE)),
2.227999,
tolerance = 0.00001)
tolerance = 0.00001
)
expect_equal(kurtosis(matrix(example_isolates$age)),
5.227999,
tolerance = 0.00001)
tolerance = 0.00001
)
expect_equal(kurtosis(matrix(example_isolates$age), excess = TRUE),
2.227999,
tolerance = 0.00001)
tolerance = 0.00001
)

18
inst/tinytest/test-like.R
View File

@@ -32,9 +32,15 @@ expect_true(factor("test") %like% "t")
expect_true("test" %like% factor("t"))
expect_true(as.factor("test") %like% "TEST")
expect_identical(factor(c("Test case", "Something different", "Yet another thing")) %like% c("case", "diff", "yet"),
c(TRUE, TRUE, TRUE))
expect_identical("test" %like% c("t", "e", "s", "t"),
c(TRUE, TRUE, TRUE, TRUE))
expect_identical(factor("test") %like% factor(c("t", "e", "s", "t")),
c(TRUE, TRUE, TRUE, TRUE))
expect_identical(
factor(c("Test case", "Something different", "Yet another thing")) %like% c("case", "diff", "yet"),
c(TRUE, TRUE, TRUE)
)
expect_identical(
"test" %like% c("t", "e", "s", "t"),
c(TRUE, TRUE, TRUE, TRUE)
)
expect_identical(
factor("test") %like% factor(c("t", "e", "s", "t")),
c(TRUE, TRUE, TRUE, TRUE)
)

122
inst/tinytest/test-mdro.R
View File

@@ -41,78 +41,109 @@ expect_stdout(outcome <- mdro(example_isolates, "nl", info = TRUE))
expect_identical(class(outcome), c("ordered", "factor"))
# example_isolates should have these finding using Dutch guidelines
expect_equal(as.double(table(outcome)),
c(1954, 24, 6)) # 1954 neg, 24 unconfirmed, 6 pos, rest is NA
expect_equal(
as.double(table(outcome)),
c(1954, 24, 6)
) # 1954 neg, 24 unconfirmed, 6 pos, rest is NA
expect_equal(brmo(example_isolates, info = FALSE),
mdro(example_isolates, guideline = "BRMO", info = FALSE))
expect_equal(
brmo(example_isolates, info = FALSE),
mdro(example_isolates, guideline = "BRMO", info = FALSE)
)
# test Dutch P. aeruginosa MDRO
expect_equal(
as.character(mdro(data.frame(mo = as.mo("P. aeruginosa"),
as.character(mdro(data.frame(
mo = as.mo("P. aeruginosa"),
cfta = "S",
cipr = "S",
mero = "S",
imip = "S",
gent = "S",
tobr = "S",
pita = "S"),
pita = "S"
),
guideline = "BRMO",
col_mo = "mo",
info = FALSE)),
"Negative")
info = FALSE
)),
"Negative"
)
expect_equal(
as.character(mdro(data.frame(mo = as.mo("P. aeruginosa"),
as.character(mdro(data.frame(
mo = as.mo("P. aeruginosa"),
cefta = "R",
cipr = "R",
mero = "R",
imip = "R",
gent = "R",
tobr = "R",
pita = "R"),
pita = "R"
),
guideline = "BRMO",
col_mo = "mo",
info = FALSE)),
"Positive")
info = FALSE
)),
"Positive"
)
# German 3MRGN and 4MRGN
expect_equal(as.character(mrgn(
data.frame(mo = c("E. coli", "E. coli", "K. pneumoniae", "E. coli",
expect_equal(
as.character(mrgn(
data.frame(
mo = c(
"E. coli", "E. coli", "K. pneumoniae", "E. coli",
"A. baumannii", "A. baumannii", "A. baumannii",
"P. aeruginosa", "P. aeruginosa", "P. aeruginosa"),
PIP = c("S", "R", "R", "S",
"P. aeruginosa", "P. aeruginosa", "P. aeruginosa"
),
PIP = c(
"S", "R", "R", "S",
"S", "R", "R",
"S", "R", "R"),
CTX = c("S", "R", "R", "S",
"S", "R", "R"
),
CTX = c(
"S", "R", "R", "S",
"R", "R", "R",
"R", "R", "R"),
IPM = c("S", "R", "S", "R",
"R", "R", "R"
),
IPM = c(
"S", "R", "S", "R",
"R", "R", "S",
"S", "R", "R"),
CIP = c("S", "R", "R", "S",
"S", "R", "R"
),
CIP = c(
"S", "R", "R", "S",
"R", "R", "R",
"R", "S", "R"),
stringsAsFactors = FALSE))),
c("Negative", "4MRGN", "3MRGN", "4MRGN", "4MRGN", "4MRGN", "3MRGN", "Negative", "3MRGN", "4MRGN"))
"R", "S", "R"
),
stringsAsFactors = FALSE
)
)),
c("Negative", "4MRGN", "3MRGN", "4MRGN", "4MRGN", "4MRGN", "3MRGN", "Negative", "3MRGN", "4MRGN")
)
# MDR TB
expect_equal(
# select only rifampicine, mo will be determined automatically (as M. tuberculosis),
# number of mono-resistant strains should be equal to number of rifampicine-resistant strains
as.double(table(mdr_tb(example_isolates[, "RIF", drop = FALSE])))[2],
count_R(example_isolates$RIF))
count_R(example_isolates$RIF)
)
x <- data.frame(rifampicin = random_rsi(5000, prob_RSI = c(0.4, 0.1, 0.5)),
x <- data.frame(
rifampicin = random_rsi(5000, prob_RSI = c(0.4, 0.1, 0.5)),
inh = random_rsi(5000, prob_RSI = c(0.4, 0.1, 0.5)),
gatifloxacin = random_rsi(5000, prob_RSI = c(0.4, 0.1, 0.5)),
eth = random_rsi(5000, prob_RSI = c(0.4, 0.1, 0.5)),
pza = random_rsi(5000, prob_RSI = c(0.4, 0.1, 0.5)),
MFX = random_rsi(5000, prob_RSI = c(0.4, 0.1, 0.5)),
KAN = random_rsi(5000, prob_RSI = c(0.4, 0.1, 0.5)))
KAN = random_rsi(5000, prob_RSI = c(0.4, 0.1, 0.5))
)
expect_true(length(unique(mdr_tb(x))) > 2)
# check the guideline by Magiorakos et al. (2012), the default guideline
stau <- data.frame(mo = c("S. aureus", "S. aureus", "S. aureus", "S. aureus"),
stau <- data.frame(
mo = c("S. aureus", "S. aureus", "S. aureus", "S. aureus"),
GEN = c("R", "R", "S", "R"),
RIF = c("S", "R", "S", "R"),
CPT = c("S", "R", "R", "R"),
@@ -135,11 +166,13 @@ stau <- data.frame(mo = c("S. aureus", "S. aureus", "S. aureus", "S. aureus"),
TCY = c("S", "S", "R", "R"),
DOX = c("S", "S", "R", "R"),
MNO = c("S", "S", "R", "R"),
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
expect_equal(as.integer(mdro(stau)), c(1:4))
expect_inherits(mdro(stau, verbose = TRUE), "data.frame")
ente <- data.frame(mo = c("Enterococcus", "Enterococcus", "Enterococcus", "Enterococcus"),
ente <- data.frame(
mo = c("Enterococcus", "Enterococcus", "Enterococcus", "Enterococcus"),
GEH = c("R", "R", "S", "R"),
STH = c("S", "R", "S", "R"),
IPM = c("S", "R", "R", "R"),
@@ -157,11 +190,13 @@ ente <- data.frame(mo = c("Enterococcus", "Enterococcus", "Enterococcus", "Enter
QDA = c("S", "S", "R", "R"),
DOX = c("S", "S", "R", "R"),
MNO = c("S", "S", "R", "R"),
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
expect_equal(as.integer(mdro(ente)), c(1:4))
expect_inherits(mdro(ente, verbose = TRUE), "data.frame")
entero <- data.frame(mo = c("E. coli", "E. coli", "E. coli", "E. coli"),
entero <- data.frame(
mo = c("E. coli", "E. coli", "E. coli", "E. coli"),
GEN = c("R", "R", "S", "R"), TOB = c("S", "R", "S", "R"),
AMK = c("S", "R", "R", "R"), NET = c("S", "R", "R", "R"),
CPT = c("S", "R", "R", "R"), TCC = c("S", "R", "R", "R"),
@@ -178,11 +213,13 @@ entero <- data.frame(mo = c("E. coli", "E. coli", "E. coli", "E. coli"),
FOS = c("S", "S", "R", "R"), COL = c("S", "S", "R", "R"),
TCY = c("S", "S", "R", "R"), DOX = c("S", "S", "R", "R"),
MNO = c("S", "S", "R", "R"),
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
expect_equal(as.integer(mdro(entero)), c(1:4))
expect_inherits(mdro(entero, verbose = TRUE), "data.frame")
pseud <- data.frame(mo = c("P. aeruginosa", "P. aeruginosa", "P. aeruginosa", "P. aeruginosa"),
pseud <- data.frame(
mo = c("P. aeruginosa", "P. aeruginosa", "P. aeruginosa", "P. aeruginosa"),
GEN = c("R", "R", "S", "R"), TOB = c("S", "S", "S", "R"),
AMK = c("S", "S", "R", "R"), NET = c("S", "S", "R", "R"),
IPM = c("S", "R", "R", "R"), MEM = c("S", "S", "R", "R"),
@@ -192,11 +229,13 @@ pseud <- data.frame(mo = c("P. aeruginosa", "P. aeruginosa", "P. aeruginosa", "P
TZP = c("S", "S", "R", "R"), ATM = c("S", "S", "R", "R"),
FOS = c("S", "S", "R", "R"), COL = c("S", "S", "R", "R"),
PLB = c("S", "S", "R", "R"),
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
expect_equal(as.integer(mdro(pseud)), c(1:4))
expect_inherits(mdro(pseud, verbose = TRUE), "data.frame")
acin <- data.frame(mo = c("A. baumannii", "A. baumannii", "A. baumannii", "A. baumannii"),
acin <- data.frame(
mo = c("A. baumannii", "A. baumannii", "A. baumannii", "A. baumannii"),
GEN = c("R", "R", "S", "R"), TOB = c("S", "R", "S", "R"),
AMK = c("S", "R", "R", "R"), NET = c("S", "R", "R", "R"),
IPM = c("S", "S", "R", "R"), MEM = c("S", "R", "R", "R"),
@@ -208,14 +247,16 @@ acin <- data.frame(mo = c("A. baumannii", "A. baumannii", "A. baumannii", "A. ba
SAM = c("S", "S", "R", "R"), COL = c("S", "S", "R", "R"),
PLB = c("S", "S", "R", "R"), TCY = c("S", "S", "R", "R"),
DOX = c("S", "S", "R", "R"), MNO = c("S", "S", "R", "R"),
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
expect_equal(as.integer(mdro(acin)), c(1:4))
expect_inherits(mdro(acin, verbose = TRUE), "data.frame")
# custom rules
custom <- custom_mdro_guideline("CIP == 'R' & age > 60" ~ "Elderly Type A",
"ERY == 'R' & age > 60" ~ "Elderly Type B",
as_factor = TRUE)
as_factor = TRUE
)
expect_stdout(print(custom))
expect_stdout(print(c(custom, custom)))
expect_stdout(print(as.list(custom, custom)))
@@ -231,7 +272,8 @@ expect_error(custom_mdro_guideline("test" ~ A))
expect_warning(mdro(example_isolates,
# since `test` gives an error, it will be ignored with a warning
guideline = custom_mdro_guideline(test ~ "A"),
info = FALSE))
info = FALSE
))
# print groups
if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0")) {

9
inst/tinytest/test-mic.R
View File

@@ -33,9 +33,12 @@ expect_true(is.mic(as.mic(8)))
expect_equal(as.double(as.mic(">=32")), 32)
expect_equal(as.numeric(as.mic(">=32")), 32)
expect_equal(as.integer(as.mic(">=32")), # should be factor level, not the MIC
expect_equal(
as.integer(as.mic(">=32")), # should be factor level, not the MIC
as.integer(factor(as.character(">=32"),
levels = levels(as.mic(">=32")))))
levels = levels(as.mic(">=32"))
))
)
expect_equal(suppressWarnings(as.logical(as.mic("INVALID VALUE"))), NA)
# all levels should be valid MICs
@@ -131,7 +134,7 @@ suppressWarnings(expect_identical(el1 + el2, el1_double + el2_double))
suppressWarnings(expect_identical(el1 - el2, el1_double - el2_double))
suppressWarnings(expect_identical(el1 * el2, el1_double * el2_double))
suppressWarnings(expect_identical(el1 / el2, el1_double / el2_double))
suppressWarnings(expect_identical(el1 ^ el2, el1_double ^ el2_double))
suppressWarnings(expect_identical(el1^el2, el1_double^el2_double))
suppressWarnings(expect_identical(el1 %% el2, el1_double %% el2_double))
suppressWarnings(expect_identical(el1 %/% el2, el1_double %/% el2_double))
suppressWarnings(expect_identical(el1 & el2, el1_double & el2_double))

145
inst/tinytest/test-mo.R
View File

@@ -28,7 +28,8 @@ expect_identical(as.character(MOs$mo), as.character(as.mo(MOs$mo)))
expect_identical(
as.character(as.mo(c("E. coli", "H. influenzae"))),
c("B_ESCHR_COLI", "B_HMPHL_INFL"))
c("B_ESCHR_COLI", "B_HMPHL_INFL")
)
expect_equal(as.character(as.mo("Escherichia coli")), "B_ESCHR_COLI")
expect_equal(as.character(as.mo("Escherichia coli")), "B_ESCHR_COLI")
@@ -79,7 +80,8 @@ expect_equal(as.character(as.mo(c("Gram negative", "Gram positive"))), c("B_GRAM
# prevalent MO
expect_identical(
suppressWarnings(as.character(
as.mo(c("stau",
as.mo(c(
"stau",
"STAU",
"staaur",
"S. aureus",
@@ -88,20 +90,29 @@ expect_identical(
"Staphylococcus aureus",
"MRSA",
"VISA",
"meth.-resis. S. aureus (MRSA)")))),
rep("B_STPHY_AURS", 10))
"meth.-resis. S. aureus (MRSA)"
))
)),
rep("B_STPHY_AURS", 10)
)
expect_identical(
as.character(
as.mo(c("EHEC", "EPEC", "EIEC", "STEC", "ATEC", "UPEC"))),
rep("B_ESCHR_COLI", 6))
as.mo(c("EHEC", "EPEC", "EIEC", "STEC", "ATEC", "UPEC"))
),
rep("B_ESCHR_COLI", 6)
)
# unprevalent MO
expect_identical(
as.character(
as.mo(c("parnod",
as.mo(c(
"parnod",
"P. nodosa",
"P nodosa",
"Paraburkholderia nodosa"))),
rep("B_PRBRK_NODS", 4))
"Paraburkholderia nodosa"
))
),
rep("B_PRBRK_NODS", 4)
)
# empty values
expect_identical(as.character(as.mo(c("", " ", NA, NaN))), rep(NA_character_, 4))
@@ -109,8 +120,10 @@ expect_identical(as.character(as.mo(" ")), NA_character_)
# too few characters
expect_warning(as.mo("ab"))
expect_equal(suppressWarnings(as.character(as.mo(c("Qq species", "", "CRSM", "K. pneu rhino", "esco")))),
c("UNKNOWN", NA_character_, "B_STNTR_MLTP", "B_KLBSL_PNMN_RHNS", "B_ESCHR_COLI"))
expect_equal(
suppressWarnings(as.character(as.mo(c("Qq species", "", "CRSM", "K. pneu rhino", "esco")))),
c("UNKNOWN", NA_character_, "B_STNTR_MLTP", "B_KLBSL_PNMN_RHNS", "B_ESCHR_COLI")
)
# check for Becker classification
expect_identical(as.character(as.mo("S. epidermidis", Becker = FALSE)), "B_STPHY_EPDR")
@@ -153,8 +166,11 @@ if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0")) {
select(genus) %>%
as.mo() %>%
as.character(),
c("B_ESCHR", "B_ESCHR", "B_STPHY", "B_STPHY", "B_STPHY",
"B_STPHY", "B_STPHY", "B_STPHY", "B_STPHY", "B_STPHY"))
c(
"B_ESCHR", "B_ESCHR", "B_STPHY", "B_STPHY", "B_STPHY",
"B_STPHY", "B_STPHY", "B_STPHY", "B_STPHY", "B_STPHY"
)
)
# select with two columns
expect_identical(
@@ -165,14 +181,17 @@ if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0")) {
slice(1:10) %>%
left_join_microorganisms() %>%
select(genus, species) %>%
as.mo())
as.mo()
)
# too many columns
expect_error(example_isolates %>% select(1:3) %>% as.mo())
# test pull
expect_equal(nrow(example_isolates %>% mutate(mo = as.mo(mo))),
2000)
expect_equal(
nrow(example_isolates %>% mutate(mo = as.mo(mo))),
2000
)
expect_true(example_isolates %>% pull(mo) %>% is.mo())
}
@@ -183,12 +202,16 @@ expect_warning(as.mo(c("INVALID", "Yeah, unknown")))
expect_stdout(print(as.mo(c("B_ESCHR_COLI", NA))))
# test data.frame
expect_equal(nrow(data.frame(test = as.mo("B_ESCHR_COLI"))),
1)
expect_equal(
nrow(data.frame(test = as.mo("B_ESCHR_COLI"))),
1
)
# check empty values
expect_equal(as.character(suppressWarnings(as.mo(""))),
NA_character_)
expect_equal(
as.character(suppressWarnings(as.mo(""))),
NA_character_
)
# check less prevalent MOs
expect_equal(as.character(as.mo("Gomphosphaeria aponina delicatula")), "B_GMPHS_APNN_DLCT")
@@ -215,38 +238,56 @@ expect_equal(suppressMessages(as.character(as.mo("unexisting staphy", allow_unce
expect_equal(suppressMessages(as.character(as.mo(c("s aure THISISATEST", "Staphylococcus aureus unexisting"), allow_uncertain = 3))), c("B_STPHY_AURS_AURS", "B_STPHY_AURS_AURS"))
# predefined reference_df
expect_equal(as.character(as.mo("TestingOwnID",
reference_df = data.frame(mycol = "TestingOwnID", mo = "B_ESCHR_COLI"))),
"B_ESCHR_COLI")
expect_equal(as.character(as.mo(c("TestingOwnID", "E. coli"),
reference_df = data.frame(mycol = "TestingOwnID", mo = "B_ESCHR_COLI"))),
c("B_ESCHR_COLI", "B_ESCHR_COLI"))
expect_equal(
as.character(as.mo("TestingOwnID",
reference_df = data.frame(mycol = "TestingOwnID", mo = "B_ESCHR_COLI")
)),
"B_ESCHR_COLI"
)
expect_equal(
as.character(as.mo(c("TestingOwnID", "E. coli"),
reference_df = data.frame(mycol = "TestingOwnID", mo = "B_ESCHR_COLI")
)),
c("B_ESCHR_COLI", "B_ESCHR_COLI")
)
expect_warning(as.mo("TestingOwnID", reference_df = NULL))
expect_error(as.mo("E. coli", reference_df = data.frame(mycol = "TestingOwnID")))
# combination of existing mo and other code
expect_identical(as.character(as.mo(c("B_ESCHR_COL", "ESCCOL"))),
c("B_ESCHR_COLI", "B_ESCHR_COLI"))
expect_identical(
as.character(as.mo(c("B_ESCHR_COL", "ESCCOL"))),
c("B_ESCHR_COLI", "B_ESCHR_COLI")
)
# from different sources
expect_equal(as.character(as.mo(
c("PRTMIR", "bclcer", "B_ESCHR_COLI"))),
c("B_PROTS_MRBL", "B_BCLLS_CERS", "B_ESCHR_COLI"))
expect_equal(
as.character(as.mo(
c("PRTMIR", "bclcer", "B_ESCHR_COLI")
)),
c("B_PROTS_MRBL", "B_BCLLS_CERS", "B_ESCHR_COLI")
)
# hard to find
expect_equal(as.character(suppressMessages(as.mo(
c("Microbacterium paraoxidans",
expect_equal(
as.character(suppressMessages(as.mo(
c(
"Microbacterium paraoxidans",
"Streptococcus suis (bovis gr)",
"Raoultella (here some text) terrigena")))),
c("B_MCRBC_PRXY", "B_STRPT_SUIS", "B_RLTLL_TRRG"))
"Raoultella (here some text) terrigena"
)
))),
c("B_MCRBC_PRXY", "B_STRPT_SUIS", "B_RLTLL_TRRG")
)
expect_stdout(print(mo_uncertainties()))
x <- as.mo("S. aur")
# many hits
expect_stdout(print(mo_uncertainties()))
# Salmonella (City) are all actually Salmonella enterica spp (City)
expect_equal(suppressMessages(as.mo(c("Salmonella Goettingen", "Salmonella Typhimurium", "Salmonella Group A"))),
as.mo(c("Salmonella enterica", "Salmonella enterica", "Salmonella")))
expect_equal(
suppressMessages(as.mo(c("Salmonella Goettingen", "Salmonella Typhimurium", "Salmonella Group A"))),
as.mo(c("Salmonella enterica", "Salmonella enterica", "Salmonella"))
)
# no viruses
expect_equal(as.character(as.mo("Virus")), NA_character_)
@@ -255,13 +296,17 @@ expect_equal(as.character(as.mo("Virus")), NA_character_)
expect_equal(length(summary(example_isolates$mo)), 6)
# WHONET codes and NA/NaN
expect_equal(as.character(as.mo(c("xxx", "na", "nan"), debug = TRUE)),
rep(NA_character_, 3))
expect_equal(
as.character(as.mo(c("xxx", "na", "nan"), debug = TRUE)),
rep(NA_character_, 3)
)
expect_equal(as.character(as.mo("con")), "UNKNOWN")
expect_equal(as.character(as.mo("xxx")), NA_character_)
expect_equal(as.character(as.mo(c("xxx", "con", "eco"))), c(NA_character_, "UNKNOWN", "B_ESCHR_COLI"))
expect_equal(as.character(as.mo(c("other", "none", "unknown"))),
rep("UNKNOWN", 3))
expect_equal(
as.character(as.mo(c("other", "none", "unknown"))),
rep("UNKNOWN", 3)
)
expect_null(mo_failures())
@@ -271,11 +316,15 @@ expect_error(translate_allow_uncertain(5))
expect_stdout(print(suppressMessages(suppressWarnings(as.mo("kshgcjkhsdgkshjdfsfvsdfv", debug = TRUE, allow_uncertain = 3)))))
# ..coccus
expect_equal(as.character(as.mo(c("meningococ", "gonococ", "pneumococ"))),
c("B_NESSR_MNNG", "B_NESSR_GNRR", "B_STRPT_PNMN"))
expect_equal(
as.character(as.mo(c("meningococ", "gonococ", "pneumococ"))),
c("B_NESSR_MNNG", "B_NESSR_GNRR", "B_STRPT_PNMN")
)
# yeasts and fungi
expect_equal(suppressWarnings(as.character(as.mo(c("yeasts", "fungi")))),
c("F_YEAST", "F_FUNGUS"))
expect_equal(
suppressWarnings(as.character(as.mo(c("yeasts", "fungi")))),
c("F_YEAST", "F_FUNGUS")
)
if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0")) {
# print tibble
@@ -292,8 +341,10 @@ expect_warning(x[[1]] <- "invalid code")
expect_warning(c(x[1], "test"))
# ignoring patterns
expect_equal(as.character(as.mo(c("E. coli", "E. coli ignorethis"), ignore_pattern = "this")),
c("B_ESCHR_COLI", NA))
expect_equal(
as.character(as.mo(c("E. coli", "E. coli ignorethis"), ignore_pattern = "this")),
c("B_ESCHR_COLI", NA)
)
# frequency tables
if (AMR:::pkg_is_available("cleaner")) {

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

@@ -45,15 +45,19 @@ expect_equal(mo_subspecies("Escherichia coli"), "")
expect_equal(mo_type("Escherichia coli", language = "en"), "Bacteria")
expect_equal(mo_gramstain("Escherichia coli", language = "en"), "Gram-negative")
expect_inherits(mo_taxonomy("Escherichia coli"), "list")
expect_equal(names(mo_taxonomy("Escherichia coli")), c("kingdom", "phylum", "class", "order",
"family", "genus", "species", "subspecies"))
expect_equal(names(mo_taxonomy("Escherichia coli")), c(
"kingdom", "phylum", "class", "order",
"family", "genus", "species", "subspecies"
))
expect_equal(mo_synonyms("Escherichia coli"), NULL)
expect_true(length(mo_synonyms("Candida albicans")) > 1)
expect_inherits(mo_synonyms(c("Candida albicans", "Escherichia coli")), "list")
expect_equal(names(mo_info("Escherichia coli")), c("kingdom", "phylum", "class", "order",
expect_equal(names(mo_info("Escherichia coli")), c(
"kingdom", "phylum", "class", "order",
"family", "genus", "species", "subspecies",
"synonyms", "gramstain", "url", "ref",
"snomed"))
"snomed"
))
expect_inherits(mo_info(c("Escherichia coli", "Staphylococcus aureus")), "list")
expect_equal(mo_ref("Escherichia coli"), "Castellani et al., 1919")
@@ -86,14 +90,22 @@ expect_identical(mo_name(dutch, language = NULL), microorganisms$fullname) # gig
# manual property function
expect_error(mo_property("Escherichia coli", property = c("tsn", "fullname")))
expect_error(mo_property("Escherichia coli", property = "UNKNOWN"))
expect_identical(mo_property("Escherichia coli", property = "fullname"),
mo_fullname("Escherichia coli"))
expect_identical(mo_property("Escherichia coli", property = "genus"),
mo_genus("Escherichia coli"))
expect_identical(mo_property("Escherichia coli", property = "species"),
mo_species("Escherichia coli"))
expect_identical(mo_property("Escherichia coli", property = "species_id"),
mo_lpsn("Escherichia coli"))
expect_identical(
mo_property("Escherichia coli", property = "fullname"),
mo_fullname("Escherichia coli")
)
expect_identical(
mo_property("Escherichia coli", property = "genus"),
mo_genus("Escherichia coli")
)
expect_identical(
mo_property("Escherichia coli", property = "species"),
mo_species("Escherichia coli")
)
expect_identical(
mo_property("Escherichia coli", property = "species_id"),
mo_lpsn("Escherichia coli")
)
expect_identical(suppressWarnings(mo_ref("Chlamydia psittaci")), "Page, 1968")
expect_identical(mo_ref("Chlamydophila psittaci"), "Everett et al., 1999")
@@ -102,30 +114,48 @@ expect_true(112283007 %in% mo_snomed("Escherichia coli"))
# old codes must throw a warning in mo_* family
expect_warning(mo_name(c("B_ESCHR_COL", "B_STPHY_AUR")))
# outcome of mo_fullname must always return the fullname from the data set
x <- data.frame(mo = microorganisms$mo,
x <- data.frame(
mo = microorganisms$mo,
# fullname from the original data:
f1 = microorganisms$fullname,
# newly created fullname based on MO code:
f2 = mo_fullname(microorganisms$mo, language = "en"),
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
expect_equal(nrow(subset(x, f1 != f2)), 0)
# is gram pos/neg (also return FALSE for all non-bacteria)
expect_equal(mo_is_gram_negative(c("Escherichia coli", "Staphylococcus aureus", "Candida albicans")),
c(TRUE, FALSE, FALSE))
expect_equal(mo_is_gram_positive(c("Escherichia coli", "Staphylococcus aureus", "Candida albicans")),
c(FALSE, TRUE, FALSE))
expect_equal(
mo_is_gram_negative(c("Escherichia coli", "Staphylococcus aureus", "Candida albicans")),
c(TRUE, FALSE, FALSE)
)
expect_equal(
mo_is_gram_positive(c("Escherichia coli", "Staphylococcus aureus", "Candida albicans")),
c(FALSE, TRUE, FALSE)
)
# is intrinsic resistant
expect_equal(mo_is_intrinsic_resistant(c("Escherichia coli", "Staphylococcus aureus", "Candida albicans"),
"vanco"),
c(TRUE, FALSE, FALSE))
expect_equal(
mo_is_intrinsic_resistant(
c("Escherichia coli", "Staphylococcus aureus", "Candida albicans"),
"vanco"
),
c(TRUE, FALSE, FALSE)
)
# with reference data
expect_equal(mo_name("test", reference_df = data.frame(col1 = "test", mo = "B_ESCHR_COLI")),
"Escherichia coli")
expect_equal(
mo_name("test", reference_df = data.frame(col1 = "test", mo = "B_ESCHR_COLI")),
"Escherichia coli"
)
if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0")) {
expect_equal(example_isolates %>% filter(mo_is_gram_negative()) %>% nrow(),
730, tolerance = 0.5)
730,
tolerance = 0.5
)
expect_equal(example_isolates %>% filter(mo_is_gram_positive()) %>% nrow(),
1238, tolerance = 0.5)
1238,
tolerance = 0.5
)
expect_equal(example_isolates %>% filter(mo_is_intrinsic_resistant(ab = "Vancomycin")) %>% nrow(),
710, tolerance = 0.5)
710,
tolerance = 0.5
)
}

30
inst/tinytest/test-pca.R
View File

@@ -23,20 +23,26 @@
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
resistance_data <- structure(list(order = c("Bacillales", "Enterobacterales", "Enterobacterales"),
resistance_data <- structure(list(
order = c("Bacillales", "Enterobacterales", "Enterobacterales"),
genus = c("Staphylococcus", "Escherichia", "Klebsiella"),
AMC = c(0.00425, 0.13062, 0.10344),
CXM = c(0.00425, 0.05376, 0.10344),
CTX = c(0.00000, 0.02396, 0.05172),
TOB = c(0.02325, 0.02597, 0.10344),
TMP = c(0.08387, 0.39141, 0.18367)),
class = c("grouped_df", "tbl_df", "tbl", "data.frame"),
row.names = c(NA, -3L),
groups = structure(list(order = c("Bacillales", "Enterobacterales"),
.rows = list(1L, 2:3)),
row.names = c(NA, -2L),
class = c("tbl_df", "tbl", "data.frame"),
.drop = TRUE))
TMP = c(0.08387, 0.39141, 0.18367)
),
class = c("grouped_df", "tbl_df", "tbl", "data.frame"),
row.names = c(NA, -3L),
groups = structure(list(
order = c("Bacillales", "Enterobacterales"),
.rows = list(1L, 2:3)
),
row.names = c(NA, -2L),
class = c("tbl_df", "tbl", "data.frame"),
.drop = TRUE
)
)
pca_model <- pca(resistance_data)
expect_inherits(pca_model, "pca")
@@ -49,8 +55,10 @@ if (AMR:::pkg_is_available("ggplot2")) {
if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0")) {
resistance_data <- example_isolates %>%
group_by(order = mo_order(mo),
genus = mo_genus(mo)) %>%
group_by(
order = mo_order(mo),
genus = mo_genus(mo)
) %>%
summarise_if(is.rsi, resistance, minimum = 0)
pca_result <- resistance_data %>%
pca(AMC, CXM, CTX, CAZ, GEN, TOB, TMP, "SXT")

109
inst/tinytest/test-proportion.R
View File

@@ -28,77 +28,108 @@ expect_equal(proportion_SI(example_isolates$AMX), susceptibility(example_isolate
# AMX resistance in `example_isolates`
expect_equal(proportion_R(example_isolates$AMX), 0.5955556, tolerance = 0.0001)
expect_equal(proportion_I(example_isolates$AMX), 0.002222222, tolerance = 0.0001)
expect_equal(1 - proportion_R(example_isolates$AMX) - proportion_I(example_isolates$AMX),
proportion_S(example_isolates$AMX))
expect_equal(proportion_R(example_isolates$AMX) + proportion_I(example_isolates$AMX),
proportion_IR(example_isolates$AMX))
expect_equal(proportion_S(example_isolates$AMX) + proportion_I(example_isolates$AMX),
proportion_SI(example_isolates$AMX))
expect_equal(
1 - proportion_R(example_isolates$AMX) - proportion_I(example_isolates$AMX),
proportion_S(example_isolates$AMX)
)
expect_equal(
proportion_R(example_isolates$AMX) + proportion_I(example_isolates$AMX),
proportion_IR(example_isolates$AMX)
)
expect_equal(
proportion_S(example_isolates$AMX) + proportion_I(example_isolates$AMX),
proportion_SI(example_isolates$AMX)
)
if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0")) {
expect_equal(example_isolates %>% proportion_SI(AMC),
0.7626397,
tolerance = 0.0001)
tolerance = 0.0001
)
expect_equal(example_isolates %>% proportion_SI(AMC, GEN),
0.9408,
tolerance = 0.0001)
tolerance = 0.0001
)
expect_equal(example_isolates %>% proportion_SI(AMC, GEN, only_all_tested = TRUE),
0.9382647,
tolerance = 0.0001)
tolerance = 0.0001
)
# percentages
expect_equal(example_isolates %>%
expect_equal(
example_isolates %>%
group_by(ward) %>%
summarise(R = proportion_R(CIP, as_percent = TRUE),
summarise(
R = proportion_R(CIP, as_percent = TRUE),
I = proportion_I(CIP, as_percent = TRUE),
S = proportion_S(CIP, as_percent = TRUE),
n = n_rsi(CIP),
total = n()) %>%
total = n()
) %>%
pull(n) %>%
sum(),
1409)
1409
)
# count of cases
expect_equal(example_isolates %>%
expect_equal(
example_isolates %>%
group_by(ward) %>%
summarise(cipro_p = proportion_SI(CIP, as_percent = TRUE),
summarise(
cipro_p = proportion_SI(CIP, as_percent = TRUE),
cipro_n = n_rsi(CIP),
genta_p = proportion_SI(GEN, as_percent = TRUE),
genta_n = n_rsi(GEN),
combination_p = proportion_SI(CIP, GEN, as_percent = TRUE),
combination_n = n_rsi(CIP, GEN)) %>%
combination_n = n_rsi(CIP, GEN)
) %>%
pull(combination_n),
c(305, 617, 241, 711))
c(305, 617, 241, 711)
)
# proportion_df
expect_equal(
example_isolates %>% select(AMX) %>% proportion_df() %>% pull(value),
c(example_isolates$AMX %>% proportion_SI(),
example_isolates$AMX %>% proportion_R())
c(
example_isolates$AMX %>% proportion_SI(),
example_isolates$AMX %>% proportion_R()
)
)
expect_equal(
example_isolates %>% select(AMX) %>% proportion_df(combine_IR = TRUE) %>% pull(value),
c(example_isolates$AMX %>% proportion_S(),
example_isolates$AMX %>% proportion_IR())
c(
example_isolates$AMX %>% proportion_S(),
example_isolates$AMX %>% proportion_IR()
)
)
expect_equal(
example_isolates %>% select(AMX) %>% proportion_df(combine_SI = FALSE) %>% pull(value),
c(example_isolates$AMX %>% proportion_S(),
c(
example_isolates$AMX %>% proportion_S(),
example_isolates$AMX %>% proportion_I(),
example_isolates$AMX %>% proportion_R())
example_isolates$AMX %>% proportion_R()
)
)
}
expect_warning(proportion_R(as.character(example_isolates$AMC)))
expect_warning(proportion_S(as.character(example_isolates$AMC)))
expect_warning(proportion_S(as.character(example_isolates$AMC,
example_isolates$GEN)))
expect_warning(proportion_S(as.character(
example_isolates$AMC,
example_isolates$GEN
)))
expect_warning(n_rsi(as.character(example_isolates$AMC,
example_isolates$GEN)))
expect_equal(suppressWarnings(n_rsi(as.character(example_isolates$AMC,
example_isolates$GEN))),
1879)
expect_warning(n_rsi(as.character(
example_isolates$AMC,
example_isolates$GEN
)))
expect_equal(
suppressWarnings(n_rsi(as.character(
example_isolates$AMC,
example_isolates$GEN
))),
1879
)
# check for errors
expect_error(proportion_IR("test", minimum = "test"))
@@ -110,12 +141,18 @@ expect_error(proportion_S("test", as_percent = "test"))
expect_error(proportion_S("test", also_single_tested = TRUE))
# check too low amount of isolates
expect_identical(suppressWarnings(proportion_R(example_isolates$AMX, minimum = nrow(example_isolates) + 1)),
NA_real_)
expect_identical(suppressWarnings(proportion_I(example_isolates$AMX, minimum = nrow(example_isolates) + 1)),
NA_real_)
expect_identical(suppressWarnings(proportion_S(example_isolates$AMX, minimum = nrow(example_isolates) + 1)),
NA_real_)
expect_identical(
suppressWarnings(proportion_R(example_isolates$AMX, minimum = nrow(example_isolates) + 1)),
NA_real_
)
expect_identical(
suppressWarnings(proportion_I(example_isolates$AMX, minimum = nrow(example_isolates) + 1)),
NA_real_
)
expect_identical(
suppressWarnings(proportion_S(example_isolates$AMX, minimum = nrow(example_isolates) + 1)),
NA_real_
)
# warning for speed loss
expect_warning(proportion_R(as.character(example_isolates$GEN)))

63
inst/tinytest/test-resistance_predict.R
View File

@@ -26,11 +26,13 @@
if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0")) {
expect_stdout(AMX_R <- example_isolates %>%
filter(mo == "B_ESCHR_COLI") %>%
rsi_predict(col_ab = "AMX",
rsi_predict(
col_ab = "AMX",
col_date = "date",
model = "binomial",
minimum = 10,
info = TRUE) %>%
info = TRUE
) %>%
pull("value"))
# AMX resistance will increase according to data set `example_isolates`
expect_true(AMX_R[3] < AMX_R[20])
@@ -40,7 +42,8 @@ expect_stdout(x <- suppressMessages(resistance_predict(example_isolates,
col_ab = "AMX",
year_min = 2010,
model = "binomial",
info = TRUE)))
info = TRUE
)))
pdf(NULL) # prevent Rplots.pdf being created
expect_silent(plot(x))
if (AMR:::pkg_is_available("ggplot2")) {
@@ -48,48 +51,66 @@ if (AMR:::pkg_is_available("ggplot2")) {
expect_silent(autoplot(x))
expect_error(ggplot_rsi_predict(example_isolates))
}
expect_stdout(rsi_predict(x = subset(example_isolates, mo == "B_ESCHR_COLI"),
expect_stdout(rsi_predict(
x = subset(example_isolates, mo == "B_ESCHR_COLI"),
model = "binomial",
col_ab = "AMX",
col_date = "date",
info = TRUE))
expect_stdout(rsi_predict(x = subset(example_isolates, mo == "B_ESCHR_COLI"),
info = TRUE
))
expect_stdout(rsi_predict(
x = subset(example_isolates, mo == "B_ESCHR_COLI"),
model = "loglin",
col_ab = "AMX",
col_date = "date",
info = TRUE))
expect_stdout(rsi_predict(x = subset(example_isolates, mo == "B_ESCHR_COLI"),
info = TRUE
))
expect_stdout(rsi_predict(
x = subset(example_isolates, mo == "B_ESCHR_COLI"),
model = "lin",
col_ab = "AMX",
col_date = "date",
info = TRUE))
info = TRUE
))
expect_error(rsi_predict(x = subset(example_isolates, mo == "B_ESCHR_COLI"),
expect_error(rsi_predict(
x = subset(example_isolates, mo == "B_ESCHR_COLI"),
model = "INVALID MODEL",
col_ab = "AMX",
col_date = "date",
info = TRUE))
expect_error(rsi_predict(x = subset(example_isolates, mo == "B_ESCHR_COLI"),
info = TRUE
))
expect_error(rsi_predict(
x = subset(example_isolates, mo == "B_ESCHR_COLI"),
model = "binomial",
col_ab = "NOT EXISTING COLUMN",
col_date = "date",
info = TRUE))
expect_error(rsi_predict(x = subset(example_isolates, mo == "B_ESCHR_COLI"),
info = TRUE
))
expect_error(rsi_predict(
x = subset(example_isolates, mo == "B_ESCHR_COLI"),
model = "binomial",
col_ab = "AMX",
col_date = "NOT EXISTING COLUMN",
info = TRUE))
expect_error(rsi_predict(x = subset(example_isolates, mo == "B_ESCHR_COLI"),
info = TRUE
))
expect_error(rsi_predict(
x = subset(example_isolates, mo == "B_ESCHR_COLI"),
col_ab = "AMX",
col_date = "NOT EXISTING COLUMN",
info = TRUE))
expect_error(rsi_predict(x = subset(example_isolates, mo == "B_ESCHR_COLI"),
info = TRUE
))
expect_error(rsi_predict(
x = subset(example_isolates, mo == "B_ESCHR_COLI"),
col_ab = "AMX",
col_date = "date",
info = TRUE))
info = TRUE
))
# almost all E. coli are MEM S in the Netherlands :)
expect_error(resistance_predict(x = subset(example_isolates, mo == "B_ESCHR_COLI"),
expect_error(resistance_predict(
x = subset(example_isolates, mo == "B_ESCHR_COLI"),
model = "binomial",
col_ab = "MEM",
col_date = "date",
info = TRUE))
info = TRUE
))

163
inst/tinytest/test-rsi.R
View File

@@ -24,8 +24,10 @@
# ==================================================================== #
# we must only have EUCAST and CLSI, because otherwise the rules in as.rsi() will fail
expect_identical(unique(gsub("[^A-Z]", "", AMR::rsi_translation$guideline)),
c("EUCAST", "CLSI"))
expect_identical(
unique(gsub("[^A-Z]", "", AMR::rsi_translation$guideline)),
c("EUCAST", "CLSI")
)
expect_true(as.rsi("S") < as.rsi("I"))
expect_true(as.rsi("I") < as.rsi("R"))
@@ -45,63 +47,91 @@ expect_stdout(print(as.rsi(c("S", "I", "R"))))
expect_equal(as.character(as.rsi(c(1:3))), c("S", "I", "R"))
expect_equal(as.character(as.rsi(c(1:3))), c("S", "I", "R"))
expect_equal(suppressWarnings(as.logical(as.rsi("INVALID VALUE"))), NA)
expect_equal(summary(as.rsi(c("S", "R"))),
structure(c("Class" = "rsi",
expect_equal(
summary(as.rsi(c("S", "R"))),
structure(c(
"Class" = "rsi",
"%R" = "50.0% (n=1)",
"%SI" = "50.0% (n=1)",
"- %S" = "50.0% (n=1)",
"- %I" = " 0.0% (n=0)"), class = c("summaryDefault", "table")))
expect_identical(as.logical(lapply(example_isolates, is.rsi.eligible)),
as.logical(lapply(example_isolates, is.rsi)))
"- %I" = " 0.0% (n=0)"
), class = c("summaryDefault", "table"))
)
expect_identical(
as.logical(lapply(example_isolates, is.rsi.eligible)),
as.logical(lapply(example_isolates, is.rsi))
)
expect_error(as.rsi.mic(as.mic(16)))
expect_error(as.rsi.disk(as.disk(16)))
expect_error(get_guideline("this one does not exist"))
if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0")) {
# 40 rsi columns
expect_equal(example_isolates %>%
expect_equal(
example_isolates %>%
mutate_at(vars(PEN:RIF), as.character) %>%
lapply(is.rsi.eligible) %>%
as.logical() %>%
sum(),
40)
40
)
expect_equal(sum(is.rsi(example_isolates)), 40)
expect_stdout(print(tibble(ab = as.rsi("S"))))
}
if (AMR:::pkg_is_available("skimr", min_version = "2.0.0")) {
expect_inherits(skim(example_isolates),
"data.frame")
expect_inherits(
skim(example_isolates),
"data.frame"
)
if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0")) {
expect_inherits(example_isolates %>%
mutate(m = as.mic(2),
d = as.disk(20)) %>%
expect_inherits(
example_isolates %>%
mutate(
m = as.mic(2),
d = as.disk(20)
) %>%
skim(),
"data.frame")
"data.frame"
)
}
}
expect_equal(as.rsi(c("", "-", NA, "NULL")), c(NA_rsi_, NA_rsi_, NA_rsi_, NA_rsi_))
# S. pneumoniae/ampicillin in EUCAST 2020: 0.5-2 ug/ml (R is only > 2)
expect_equal(as.character(
as.rsi(x = as.mic(c(0.125, 0.5, 1, 2, 4)),
expect_equal(
as.character(
as.rsi(
x = as.mic(c(0.125, 0.5, 1, 2, 4)),
mo = "B_STRPT_PNMN",
ab = "AMP",
guideline = "EUCAST 2020")),
c("S", "S", "I", "I", "R"))
guideline = "EUCAST 2020"
)
),
c("S", "S", "I", "I", "R")
)
# S. pneumoniae/amoxicillin in CLSI 2019: 2-8 ug/ml (R is 8 and > 8)
expect_equal(as.character(
as.rsi(x = as.mic(c(1, 2, 4, 8, 16)),
expect_equal(
as.character(
as.rsi(
x = as.mic(c(1, 2, 4, 8, 16)),
mo = "B_STRPT_PNMN",
ab = "AMX",
guideline = "CLSI 2019")),
c("S", "S", "I", "R", "R"))
guideline = "CLSI 2019"
)
),
c("S", "S", "I", "R", "R")
)
# cutoffs at MIC = 8
expect_equal(as.rsi(as.mic(2), "E. coli", "ampicillin", guideline = "EUCAST 2020"),
as.rsi("S"))
expect_equal(as.rsi(as.mic(32), "E. coli", "ampicillin", guideline = "EUCAST 2020"),
as.rsi("R"))
expect_equal(
as.rsi(as.mic(2), "E. coli", "ampicillin", guideline = "EUCAST 2020"),
as.rsi("S")
)
expect_equal(
as.rsi(as.mic(32), "E. coli", "ampicillin", guideline = "EUCAST 2020"),
as.rsi("R")
)
if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0")) {
expect_true(suppressWarnings(example_isolates %>%
mutate(amox_mic = as.mic(2)) %>%
@@ -111,24 +141,39 @@ if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0")) {
is.rsi()))
}
expect_equal(as.character(
as.rsi(x = as.disk(22),
expect_equal(
as.character(
as.rsi(
x = as.disk(22),
mo = "B_STRPT_PNMN",
ab = "ERY",
guideline = "CLSI")),
"S")
expect_equal(as.character(
as.rsi(x = as.disk(18),
guideline = "CLSI"
)
),
"S"
)
expect_equal(
as.character(
as.rsi(
x = as.disk(18),
mo = "B_STRPT_PNMN",
ab = "ERY",
guideline = "CLSI")),
"I")
expect_equal(as.character(
as.rsi(x = as.disk(10),
guideline = "CLSI"
)
),
"I"
)
expect_equal(
as.character(
as.rsi(
x = as.disk(10),
mo = "B_STRPT_PNMN",
ab = "ERY",
guideline = "CLSI")),
"R")
guideline = "CLSI"
)
),
"R"
)
if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0")) {
expect_true(example_isolates %>%
mutate(amox_disk = as.disk(15)) %>%
@@ -143,23 +188,37 @@ if (AMR:::pkg_is_available("cleaner")) {
}
df <- data.frame(microorganism = "Escherichia coli",
df <- data.frame(
microorganism = "Escherichia coli",
AMP = as.mic(8),
CIP = as.mic(0.256),
GEN = as.disk(18),
TOB = as.disk(16),
ERY = "R", # note about assigning <rsi> class
CLR = "V") # note about cleaning
expect_inherits(suppressWarnings(as.rsi(df)),
"data.frame")
expect_inherits(suppressWarnings(as.rsi(data.frame(mo = "Escherichia coli",
amoxi = c("R", "S", "I", "invalid")))$amoxi),
"rsi")
expect_warning(as.rsi(data.frame(mo = "E. coli",
NIT = c("<= 2", 32))))
expect_message(as.rsi(data.frame(mo = "E. coli",
CLR = "V"
) # note about cleaning
expect_inherits(
suppressWarnings(as.rsi(df)),
"data.frame"
)
expect_inherits(
suppressWarnings(as.rsi(data.frame(
mo = "Escherichia coli",
amoxi = c("R", "S", "I", "invalid")
))$amoxi),
"rsi"
)
expect_warning(as.rsi(data.frame(
mo = "E. coli",
NIT = c("<= 2", 32)
)))
expect_message(as.rsi(data.frame(
mo = "E. coli",
NIT = c("<= 2", 32),
uti = TRUE)))
expect_message(as.rsi(data.frame(mo = "E. coli",
uti = TRUE
)))
expect_message(as.rsi(data.frame(
mo = "E. coli",
NIT = c("<= 2", 32),
specimen = c("urine", "blood"))))
specimen = c("urine", "blood")
)))

9
inst/tinytest/test-skewness.R
View File

@@ -25,10 +25,13 @@
expect_equal(skewness(example_isolates$age),
-1.212888,
tolerance = 0.00001)
tolerance = 0.00001
)
expect_equal(unname(skewness(data.frame(example_isolates$age))),
-1.212888,
tolerance = 0.00001)
tolerance = 0.00001
)
expect_equal(skewness(matrix(example_isolates$age)),
-1.212888,
tolerance = 0.00001)
tolerance = 0.00001
)

13
inst/tinytest/test-zzz.R
View File

@@ -46,7 +46,8 @@ import_functions <- c(
"read_html" = "xml2",
"right_join" = "dplyr",
"semi_join" = "dplyr",
"showQuestion" = "rstudioapi")
"showQuestion" = "rstudioapi"
)
# functions that are called directly
call_functions <- c(
@@ -86,7 +87,8 @@ if (AMR:::pkg_is_available("skimr", also_load = FALSE, min_version = "2.0.0")) {
call_functions <- c(call_functions,
# skimr
"inline_hist" = "skimr",
"sfl" = "skimr")
"sfl" = "skimr"
)
}
extended_functions <- c(
@@ -106,11 +108,14 @@ for (i in seq_len(length(import_functions))) {
# function should exist in foreign pkg namespace
if (AMR:::pkg_is_available(pkg,
also_load = FALSE,
min_version = if (pkg == "dplyr") "1.0.0" else NULL)) {
min_version = if (pkg == "dplyr") "1.0.0" else NULL
)) {
tst <- !is.null(AMR:::import_fn(name = fn, pkg = pkg, error_on_fail = FALSE))
expect_true(tst,
info = ifelse(tst,
"All external function references exist.",
paste0("Function ", pkg, "::", fn, "() does not exist anymore")))
paste0("Function ", pkg, "::", fn, "() does not exist anymore")
)
)
}
}

20
man/ab_from_text.Rd
View File

@@ -73,22 +73,28 @@ abx <- ab_from_text("500 mg amoxi po and 400mg cipro iv")
ab_group(abx[[1]])
if (require("dplyr")) {
tibble(clinical_text = c("given 400mg cipro and 500 mg amox",
"started on doxy iv today")) \%>\%
mutate(abx_codes = ab_from_text(clinical_text),
tibble(clinical_text = c(
"given 400mg cipro and 500 mg amox",
"started on doxy iv today"
)) \%>\%
mutate(
abx_codes = ab_from_text(clinical_text),
abx_doses = ab_from_text(clinical_text, type = "doses"),
abx_admin = ab_from_text(clinical_text, type = "admin"),
abx_coll = ab_from_text(clinical_text, collapse = "|"),
abx_coll_names = ab_from_text(clinical_text,
collapse = "|",
translate_ab = "name"),
translate_ab = "name"
),
abx_coll_doses = ab_from_text(clinical_text,
type = "doses",
collapse = "|"),
collapse = "|"
),
abx_coll_admin = ab_from_text(clinical_text,
type = "admin",
collapse = "|"))
collapse = "|"
)
)
}
}
}

10
man/ab_property.Rd
View File

@@ -121,8 +121,10 @@ ab_url("AMX") # link to the official WHO page
# smart lowercase tranformation
ab_name(x = c("AMC", "PLB")) # "Amoxicillin/clavulanic acid" "Polymyxin B"
ab_name(x = c("AMC", "PLB"),
tolower = TRUE) # "amoxicillin/clavulanic acid" "polymyxin B"
ab_name(
x = c("AMC", "PLB"),
tolower = TRUE
) # "amoxicillin/clavulanic acid" "polymyxin B"
# defined daily doses (DDD)
ab_ddd("AMX", "oral") # 1.5
@@ -158,12 +160,12 @@ if (require("dplyr")) {
# this does the same:
example_isolates \%>\%
rename_with(set_ab_names)\%>\%
rename_with(set_ab_names) \%>\%
head()
# set_ab_names() works with any AB property:
example_isolates \%>\%
set_ab_names(property = "atc")\%>\%
set_ab_names(property = "atc") \%>\%
head()
example_isolates \%>\%

6
man/age_groups.Rd
View File

@@ -62,10 +62,12 @@ if (require("dplyr")) {
filter(mo == as.mo("Escherichia coli")) \%>\%
group_by(age_group = age_groups(age)) \%>\%
select(age_group, CIP) \%>\%
ggplot_rsi(x = "age_group",
ggplot_rsi(
x = "age_group",
minimum = 0,
x.title = "Age Group",
title = "Ciprofloxacin resistance per age group")
title = "Ciprofloxacin resistance per age group"
)
}
}
}

27
man/antibiotic_class_selectors.Rd
View File

@@ -219,14 +219,12 @@ if (require("dplyr")) {
example_isolates \%>\%
group_by(ward) \%>\%
summarise(across(aminoglycosides(), resistance))
}
if (require("dplyr")) {
# You can combine selectors with '&' to be more specific:
example_isolates \%>\%
select(penicillins() & administrable_per_os())
}
if (require("dplyr")) {
@@ -235,7 +233,6 @@ if (require("dplyr")) {
filter(mo_genus() \%in\% c("Escherichia", "Klebsiella")) \%>\%
group_by(ward) \%>\%
summarise(across(not_intrinsic_resistant(), resistance))
}
if (require("dplyr")) {
@@ -244,50 +241,45 @@ if (require("dplyr")) {
filter(first_isolate()) \%>\%
group_by(ward) \%>\%
summarise(across(ab_selector(name \%like\% "trim"), susceptibility))
}
if (require("dplyr")) {
# this will select columns 'IPM' (imipenem) and 'MEM' (meropenem):
example_isolates \%>\%
select(carbapenems())
}
if (require("dplyr")) {
# this will select columns 'mo', 'AMK', 'GEN', 'KAN' and 'TOB':
example_isolates \%>\%
select(mo, aminoglycosides())
}
if (require("dplyr")) {
# any() and all() work in dplyr's filter() too:
example_isolates \%>\%
filter(any(aminoglycosides() == "R"),
all(cephalosporins_2nd() == "R"))
filter(
any(aminoglycosides() == "R"),
all(cephalosporins_2nd() == "R")
)
}
if (require("dplyr")) {
# also works with c():
example_isolates \%>\%
filter(any(c(carbapenems(), aminoglycosides()) == "R"))
}
if (require("dplyr")) {
# not setting any/all will automatically apply all():
example_isolates \%>\%
filter(aminoglycosides() == "R")
}
if (require("dplyr")) {
# this will select columns 'mo' and all antimycobacterial drugs ('RIF'):
example_isolates \%>\%
select(mo, ab_class("mycobact"))
}
if (require("dplyr")) {
@@ -297,21 +289,20 @@ if (require("dplyr")) {
select(mo, glycopeptides()) \%>\%
bug_drug_combinations() \%>\%
format()
}
if (require("dplyr")) {
data.frame(some_column = "some_value",
J01CA01 = "S") \%>\% # ATC code of ampicillin
data.frame(
some_column = "some_value",
J01CA01 = "S"
) \%>\% # ATC code of ampicillin
select(penicillins()) # only the 'J01CA01' column will be selected
}
if (require("dplyr")) {
# with recent versions of dplyr this is all equal:
x <- example_isolates[carbapenems() == "R", ]
y <- example_isolates \%>\% filter(carbapenems() == "R")
z <- example_isolates \%>\% filter(if_all(carbapenems(), ~.x == "R"))
z <- example_isolates \%>\% filter(if_all(carbapenems(), ~ .x == "R"))
identical(x, y) && identical(y, z)
}
}

1
man/as.ab.Rd
View File

@@ -93,7 +93,6 @@ if (require("dplyr")) {
# you can quickly rename <rsi> columns using dplyr >= 1.0.0:
example_isolates \%>\%
rename_with(as.ab, where(is.rsi))
}
}
}

12
man/as.disk.Rd
View File

@@ -35,11 +35,13 @@ Interpret disk values as RSI values with \code{\link[=as.rsi]{as.rsi()}}. It sup
}
\examples{
# transform existing disk zones to the `disk` class (using base R)
df <- data.frame(microorganism = "Escherichia coli",
df <- data.frame(
microorganism = "Escherichia coli",
AMP = 20,
CIP = 14,
GEN = 18,
TOB = 16)
TOB = 16
)
df[, 2:5] <- lapply(df[, 2:5], as.disk)
str(df)
@@ -51,10 +53,12 @@ if (require("dplyr")) {
}
# interpret disk values, see ?as.rsi
as.rsi(x = as.disk(18),
as.rsi(
x = as.disk(18),
mo = "Strep pneu", # `mo` will be coerced with as.mo()
ab = "ampicillin", # and `ab` with as.ab()
guideline = "EUCAST")
guideline = "EUCAST"
)
# interpret whole data set, pretend to be all from urinary tract infections:
as.rsi(df, uti = TRUE)

12
man/as.mic.Rd
View File

@@ -91,14 +91,18 @@ quantile(mic_data)
all(mic_data < 512)
# interpret MIC values
as.rsi(x = as.mic(2),
as.rsi(
x = as.mic(2),
mo = as.mo("Streptococcus pneumoniae"),
ab = "AMX",
guideline = "EUCAST")
as.rsi(x = as.mic(c(0.01, 2, 4, 8)),
guideline = "EUCAST"
)
as.rsi(
x = as.mic(c(0.01, 2, 4, 8)),
mo = as.mo("Streptococcus pneumoniae"),
ab = "AMX",
guideline = "EUCAST")
guideline = "EUCAST"
)
# plot MIC values, see ?plot
plot(mic_data)

30
man/as.rsi.Rd
View File

@@ -166,25 +166,31 @@ summary(example_isolates) # see all R/SI results at a glance
# For INTERPRETING disk diffusion and MIC values -----------------------
# a whole data set, even with combined MIC values and disk zones
df <- data.frame(microorganism = "Escherichia coli",
df <- data.frame(
microorganism = "Escherichia coli",
AMP = as.mic(8),
CIP = as.mic(0.256),
GEN = as.disk(18),
TOB = as.disk(16),
NIT = as.mic(32),
ERY = "R")
ERY = "R"
)
as.rsi(df)
# for single values
as.rsi(x = as.mic(2),
as.rsi(
x = as.mic(2),
mo = as.mo("S. pneumoniae"),
ab = "AMP",
guideline = "EUCAST")
guideline = "EUCAST"
)
as.rsi(x = as.disk(18),
as.rsi(
x = as.disk(18),
mo = "Strep pneu", # `mo` will be coerced with as.mo()
ab = "ampicillin", # and `ab` with as.ab()
guideline = "EUCAST")
guideline = "EUCAST"
)
\donttest{
# the dplyr way
@@ -199,14 +205,18 @@ if (require("dplyr")) {
mutate_at(vars(AMP:TOB), as.rsi, mo = .$microorganism)
# to include information about urinary tract infections (UTI)
data.frame(mo = "E. coli",
data.frame(
mo = "E. coli",
NIT = c("<= 2", 32),
from_the_bladder = c(TRUE, FALSE)) \%>\%
from_the_bladder = c(TRUE, FALSE)
) \%>\%
as.rsi(uti = "from_the_bladder")
data.frame(mo = "E. coli",
data.frame(
mo = "E. coli",
NIT = c("<= 2", 32),
specimen = c("urine", "blood")) \%>\%
specimen = c("urine", "blood")
) \%>\%
as.rsi() # automatically determines urine isolates
df \%>\%

11
man/bug_drug_combinations.Rd
View File

@@ -71,11 +71,16 @@ format(x, translate_ab = "name (atc)")
# Use FUN to change to transformation of microorganism codes
bug_drug_combinations(example_isolates,
FUN = mo_gramstain)
FUN = mo_gramstain
)
bug_drug_combinations(example_isolates,
FUN = function(x) ifelse(x == as.mo("Escherichia coli"),
FUN = function(x) {
ifelse(x == as.mo("Escherichia coli"),
"E. coli",
"Others"))
"Others"
)
}
)
}
}

6
man/count.Rd
View File

@@ -156,12 +156,14 @@ susceptibility(example_isolates$AMX) * n_rsi(example_isolates$AMX)
if (require("dplyr")) {
example_isolates \%>\%
group_by(ward) \%>\%
summarise(R = count_R(CIP),
summarise(
R = count_R(CIP),
I = count_I(CIP),
S = count_S(CIP),
n1 = count_all(CIP), # the actual total; sum of all three
n2 = n_rsi(CIP), # same - analogous to n_distinct
total = n()) # NOT the number of tested isolates!
total = n()
) # NOT the number of tested isolates!
# Number of available isolates for a whole antibiotic class
# (i.e., in this data set columns GEN, TOB, AMK, KAN)

Some files were not shown because too many files have changed in this diff Show More