P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-08-27 22:42:14 +02:00
Code Releases Activity

new antibiotics

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2019-05-10 16:44:59 +02:00
parent 73f1ee1159
commit 68cc7ef0d0
147 changed files with 6228 additions and 4187 deletions
Download Patch File Download Diff File Expand all files Collapse all files

242
R/ab.R Executable file
View File

@@ -0,0 +1,242 @@
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Analysis #
# #
# SOURCE #
# https://gitlab.com/msberends/AMR #
# #
# LICENCE #
# (c) 2019 Berends MS (m.s.berends@umcg.nl), Luz CF (c.f.luz@umcg.nl) #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
# GNU General Public License version 2.0 (GNU GPL-2), as published by #
# the Free Software Foundation. #
# #
# This R package was created for academic research and was publicly #
# released in the hope that it will be useful, but it comes WITHOUT #
# ANY WARRANTY OR LIABILITY. #
# Visit our website for more info: https://msberends.gitlab.io/AMR. #
# ==================================================================== #
#' Transform to antibiotic ID
#'
#' Use this function to determine the antibiotic code of one or more antibiotics. The data set \code{\link{antibiotics}} will be searched for abbreviations, official names and synonyms (brand names).
#' @param x character vector to determine to antibiotic ID
#' @rdname as.ab
#' @keywords atc
#' @inheritSection WHOCC WHOCC
#' @export
#' @importFrom dplyr %>% filter slice pull
#' @details Use the \code{\link{ab_property}} functions to get properties based on the returned ATC code, see Examples.
#'
#' In the ATC classification system, the active substances are classified in a hierarchy with five different levels. The system has fourteen main anatomical/pharmacological groups or 1st levels. Each ATC main group is divided into 2nd levels which could be either pharmacological or therapeutic groups. The 3rd and 4th levels are chemical, pharmacological or therapeutic subgroups and the 5th level is the chemical substance. The 2nd, 3rd and 4th levels are often used to identify pharmacological subgroups when that is considered more appropriate than therapeutic or chemical subgroups.
#' Source: \url{https://www.whocc.no/atc/structure_and_principles/}
#' @section Source:
#' World Health Organization (WHO) Collaborating Centre for Drug Statistics Methodology: \url{https://www.whocc.no/atc_ddd_index/}
#'
#' WHONET 2019 software: \url{http://www.whonet.org/software.html}
#'
#' European Commission Public Health PHARMACEUTICALS - COMMUNITY REGISTER: \url{http://ec.europa.eu/health/documents/community-register/html/atc.htm}
#' @return Character (vector) with class \code{"act"}. Unknown values will return \code{NA}.
#' @seealso \code{\link{antibiotics}} for the dataframe that is being used to determine ATCs.
#' @inheritSection AMR Read more on our website!
#' @examples
#' # These examples all return "ERY", the ID of Erythromycin:
#' as.ab("J01FA01")
#' as.ab("J 01 FA 01")
#' as.ab("Erythromycin")
#' as.ab("eryt")
#' as.ab(" eryt 123")
#' as.ab("ERYT")
#' as.ab("ERY")
#' as.ab("erytromicine") # spelled wrong
#' as.ab("Erythrocin") # trade name
#' as.ab("Romycin") # trade name
#'
#' # Use ab_* functions to get a specific properties (see ?ab_property);
#' # they use as.ab() internally:
#' ab_name("J01FA01") # "Erythromycin"
#' ab_name("eryt") # "Erythromycin"
as.ab <- function(x) {
if (is.ab(x)) {
return(x)
}
x_bak <- x
# remove suffices
x_bak_clean <- gsub("_(mic|rsi)$", "", x)
# remove disk concentrations, like LVX_NM -> LVX
x_bak_clean <- gsub("_[A-Z]{2}[0-9_]{0,3}$", "", x_bak_clean)
# clean rest of it
x_bak_clean <- gsub("[^a-zA-Z0-9/-]", "", x_bak_clean)
# keep only a-z when it's not an ATC code or only numbers
x_bak_clean[!x_bak_clean %like% "^([A-Z][0-9]{2}[A-Z]{2}[0-9]{2}|[0-9]+)$"] <- gsub("[^a-zA-Z]+",
"",
x_bak_clean[!x_bak_clean %like% "^([A-Z][0-9]{2}[A-Z]{2}[0-9]{2}|[0-9]+)$"])
x <- unique(x_bak_clean)
x_new <- rep(NA_character_, length(x))
x_unknown <- character(0)
for (i in 1:length(x)) {
if (is.na(x[i]) | is.null(x[i])) {
next
}
if (identical(x[i], "")) {
x_unknown <- c(x_unknown, x_bak[x[i] == x_bak_clean][1])
next
}
# exact AB code
found <- AMR::antibiotics[which(AMR::antibiotics$ab == toupper(x[i])),]$ab
if (length(found) > 0) {
x_new[i] <- found[1L]
next
}
# exact ATC code
found <- AMR::antibiotics[which(AMR::antibiotics$atc == toupper(x[i])),]$ab
if (length(found) > 0) {
x_new[i] <- found[1L]
next
}
# exact CID code
found <- AMR::antibiotics[which(AMR::antibiotics$cid == x[i]),]$ab
if (length(found) > 0) {
x_new[i] <- found[1L]
next
}
# exact name
found <- AMR::antibiotics[which(toupper(AMR::antibiotics$name) == toupper(x[i])),]$ab
if (length(found) > 0) {
x_new[i] <- found[1L]
next
}
# exact synonym
synonym_found <- unlist(lapply(AMR::antibiotics$synonyms,
function(s) if (toupper(x[i]) %in% toupper(s)) {
TRUE
} else {
FALSE
}))
found <- AMR::antibiotics$ab[synonym_found == TRUE]
if (length(found) > 0) {
x_new[i] <- found[1L]
next
}
# exact abbreviation
abbr_found <- unlist(lapply(AMR::antibiotics$abbreviations,
function(a) if (toupper(x[i]) %in% toupper(a)) {
TRUE
} else {
FALSE
}))
found <- AMR::antibiotics$ab[abbr_found == TRUE]
if (length(found) > 0) {
x_new[i] <- found[1L]
next
}
# first >=4 characters of name
if (nchar(x[i]) >= 4) {
found <- AMR::antibiotics[which(toupper(AMR::antibiotics$name) %like% paste0("^", x[i])),]$ab
if (length(found) > 0) {
x_new[i] <- found[1L]
next
}
}
# allow characters that resemble others, but only continue when having more than 3 characters
if (nchar(x[i]) <= 3) {
x_unknown <- c(x_unknown, x_bak[x[i] == x_bak_clean][1])
next
}
x_spelling <- x[i]
x_spelling <- gsub("[iy]+", "[iy]+", x_spelling, ignore.case = TRUE)
x_spelling <- gsub("[sz]+", "[sz]+", x_spelling, ignore.case = TRUE)
x_spelling <- gsub("(c|k|q|qu)+", "(c|k|q|qu)+", x_spelling, ignore.case = TRUE)
x_spelling <- gsub("(ph|f|v)+", "(ph|f|v)+", x_spelling, ignore.case = TRUE)
x_spelling <- gsub("(th|t)+", "(th|t)+", x_spelling, ignore.case = TRUE)
x_spelling <- gsub("a+", "a+", x_spelling, ignore.case = TRUE)
x_spelling <- gsub("e+", "e+", x_spelling, ignore.case = TRUE)
x_spelling <- gsub("o+", "o+", x_spelling, ignore.case = TRUE)
# allow any ending of -in/-ine and -im/-ime
x_spelling <- gsub("(\\[iy\\]\\+(n|m)|\\[iy\\]\\+(n|m)e\\+)$", "[iy]+(n|m)e*", x_spelling, ignore.case = TRUE)
# allow any ending of -ol/-ole
x_spelling <- gsub("(o\\+l|o\\+le\\+)$", "o+le*", x_spelling, ignore.case = TRUE)
# try if name starts with it
found <- AMR::antibiotics[which(AMR::antibiotics$name %like% paste0("^", x_spelling)),]$ab
if (length(found) > 0) {
x_new[i] <- found[1L]
next
}
# and try if any synonym starts with it
synonym_found <- unlist(lapply(AMR::antibiotics$synonyms,
function(s) if (any(s %like% paste0("^", x_spelling))) {
TRUE
} else {
FALSE
}))
found <- AMR::antibiotics$ab[synonym_found == TRUE]
if (length(found) > 0) {
x_new[i] <- found[1L]
next
}
# not found
x_unknown <- c(x_unknown, x_bak[x[i] == x_bak_clean][1])
}
if (length(x_unknown) > 0) {
warning("These values could not be coerced to a valid antibiotic ID: ",
paste('"', sort(unique(x_unknown)), '"', sep = "", collapse = ', '),
".",
call. = FALSE)
}
x_result <- data.frame(x = x_bak_clean, stringsAsFactors = FALSE) %>%
left_join(data.frame(x = x, x_new = x_new, stringsAsFactors = FALSE), by = "x") %>%
pull(x_new)
structure(.Data = x_result,
class = "ab")
}
#' @rdname as.atc
#' @export
is.ab <- function(x) {
identical(class(x), "ab")
}
#' @exportMethod print.ab
#' @export
#' @noRd
print.ab <- function(x, ...) {
cat("Class 'ab'\n")
print.default(as.character(x), quote = FALSE)
}
#' @exportMethod as.data.frame.ab
#' @export
#' @noRd
as.data.frame.ab <- function (x, ...) {
# same as as.data.frame.character but with removed stringsAsFactors
nm <- paste(deparse(substitute(x), width.cutoff = 500L),
collapse = " ")
if (!"nm" %in% names(list(...))) {
as.data.frame.vector(x, ..., nm = nm)
} else {
as.data.frame.vector(x, ...)
}
}
#' @exportMethod pull.ab
#' @export
#' @importFrom dplyr pull
#' @noRd
pull.ab <- function(.data, ...) {
pull(as.data.frame(.data), ...)
}

185
R/ab_property.R Normal file
View File

@@ -0,0 +1,185 @@
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Analysis #
# #
# SOURCE #
# https://gitlab.com/msberends/AMR #
# #
# LICENCE #
# (c) 2019 Berends MS (m.s.berends@umcg.nl), Luz CF (c.f.luz@umcg.nl) #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
# GNU General Public License version 2.0 (GNU GPL-2), as published by #
# the Free Software Foundation. #
# #
# This R package was created for academic research and was publicly #
# released in the hope that it will be useful, but it comes WITHOUT #
# ANY WARRANTY OR LIABILITY. #
# Visit our website for more info: https://msberends.gitlab.io/AMR. #
# ==================================================================== #
#' Property of an antibiotic
#'
#' Use these functions to return a specific property of an antibiotic from the \code{\link{antibiotics}} data set. All input values will be evaluated internally with \code{\link{as.ab}}.
#' @param x any (vector of) text that can be coerced to a valid microorganism code with \code{\link{as.ab}}
#' @param tolower logical to indicate whether the first character of every output should be transformed to a lower case character. This will lead to e.g. "polymyxin B" and not "polymyxin b".
#' @param property one of the column names of one of the \code{\link{antibiotics}} data set
#' @param language language of the returned text, defaults to system language (see \code{\link{get_locale}}) and can also be set with \code{\link{getOption}("AMR_locale")}. Use \code{language = NULL} or \code{language = ""} to prevent translation.
#' @param administration way of administration, either \code{"oral"} or \code{"iv"}
#' @param units a logical to indicate whether the units instead of the DDDs itself must be returned, see Examples
#' @param ... other parameters passed on to \code{\link{as.ab}}
#' @details All output will be \link{translate}d where possible.
#' @inheritSection as.ab Source
#' @rdname ab_property
#' @name ab_property
#' @return \itemize{
#' \item{An \code{integer} in case of \code{ab_cid}}
#' \item{A named \code{list} in case of multiple \code{ab_synonyms}}
#' \item{A \code{double} in case of \code{ab_ddd}}
#' \item{A \code{character} in all other cases}
#' }
#' @export
#' @seealso \code{\link{antibiotics}}
#' @inheritSection AMR Read more on our website!
#' @examples
#' # all properties:
#' ab_name("AMX") # "Amoxicillin"
#' ab_atc("AMX") # J01CA04 (ATC code from the WHO)
#' ab_cid("AMX") # 33613 (Compound ID from PubChem)
#'
#' ab_synonyms("AMX") # a list with brand names of amoxicillin
#' ab_tradenames("AMX") # same
#'
#' ab_group("AMX") # "Beta-lactams/penicillins"
#' ab_atc_group1("AMX") # "Beta-lactam antibacterials, penicillins"
#' ab_atc_group2("AMX") # "Penicillins with extended spectrum"
#'
#' 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_ddd("AMX", "oral") # 1
#' ab_ddd("AMX", "oral", units = TRUE) # "g"
#' ab_ddd("AMX", "iv") # 1
#' ab_ddd("AMX", "iv", units = TRUE) # "g"
#'
#' # all ab_* functions use as.ab() internally:
#' ab_name("Fluclox") # "Flucloxacillin"
#' ab_name("fluklox") # "Flucloxacillin"
#' ab_name("floxapen") # "Flucloxacillin"
#' ab_name(21319) # "Flucloxacillin" (using CID)
#' ab_name("J01CF05") # "Flucloxacillin" (using ATC)
ab_name <- function(x, language = get_locale(), tolower = FALSE, ...) {
x <- ab_validate(x = x, property = "name", ...)
res <- t(x, language = language)
if (tolower == TRUE) {
# use perl to only transform the first character
# as we want "polymyxin B", not "polymyxin b"
res <- gsub("^([A-Z])", "\\L\\1", res, perl = TRUE)
}
res
}
#' @rdname ab_property
#' @export
ab_atc <- function(x, ...) {
ab_validate(x = x, property = "atc", ...)
}
#' @rdname ab_property
#' @export
ab_cid <- function(x, ...) {
ab_validate(x = x, property = "cid", ...)
}
#' @rdname ab_property
#' @export
ab_synonyms <- function(x, ...) {
syns <- ab_validate(x = x, property = "synonyms", ...)
names(syns) <- x
if (length(syns) == 1) {
unname(unlist(syns))
} else {
syns
}
}
#' @rdname ab_property
#' @export
ab_tradenames <- function(x, ...) {
ab_synonyms(x, ...)
}
#' @rdname ab_property
#' @export
ab_group <- function(x, ...) {
ab_validate(x = x, property = "group", ...)
}
#' @rdname ab_property
#' @export
ab_atc_group1 <- function(x, ...) {
ab_validate(x = x, property = "atc_group1", ...)
}
#' @rdname ab_property
#' @export
ab_atc_group2 <- function(x, ...) {
ab_validate(x = x, property = "atc_group2", ...)
}
#' @rdname ab_property
#' @export
ab_ddd <- function(x, administration = "oral", units = FALSE, ...) {
if (!administration %in% c("oral", "iv")) {
stop("`administration` must be 'oral' or 'iv'", call. = FALSE)
}
ddd_prop <- administration
if (units == TRUE) {
ddd_prop <- paste0(ddd_prop, "_units")
} else {
ddd_prop <- paste0(ddd_prop, "_ddd")
}
ab_validate(x = x, property = ddd_prop, ...)
}
#' @rdname ab_property
#' @export
ab_property <- function(x, property = 'name', language = get_locale(), ...) {
if (length(property) != 1L) {
stop("'property' must be of length 1.")
}
if (!property %in% colnames(AMR::antibiotics)) {
stop("invalid property: '", property, "' - use a column name of the `antibiotics` data set")
}
t(ab_validate(x = x, property = property, ...), language = language)
}
ab_validate <- function(x, property, ...) {
if (!"AMR" %in% base::.packages()) {
library("AMR")
# check onLoad() in R/zzz.R: data tables are created there.
}
# try to catch an error when inputting an invalid parameter
# so the 'call.' can be set to FALSE
tryCatch(x[1L] %in% AMR::antibiotics[1, property],
error = function(e) stop(e$message, call. = FALSE))
if (!all(x %in% AMR::antibiotics[, property])) {
x <- data.frame(ab = as.ab(x), stringsAsFactors = FALSE) %>%
left_join(antibiotics %>% select(c("ab", property)), by = "ab") %>%
pull(property)
}
if (property %in% c("ab", "atc")) {
return(structure(x, class = property))
} else if (property == "cid") {
return(as.integer(x))
} else if (property %like% "ddd") {
return(as.double(x))
} else {
return(x)
}
}

162
R/abname.R
View File

@@ -1,162 +0,0 @@
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Analysis #
# #
# SOURCE #
# https://gitlab.com/msberends/AMR #
# #
# LICENCE #
# (c) 2019 Berends MS (m.s.berends@umcg.nl), Luz CF (c.f.luz@umcg.nl) #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
# GNU General Public License version 2.0 (GNU GPL-2), as published by #
# the Free Software Foundation. #
# #
# This R package was created for academic research and was publicly #
# released in the hope that it will be useful, but it comes WITHOUT #
# ANY WARRANTY OR LIABILITY. #
# Visit our website for more info: https://msberends.gitlab.io/AMR. #
# ==================================================================== #
#' Name of an antibiotic
#'
#' Convert antibiotic codes to a (trivial) antibiotic name or ATC code, or vice versa. This uses the data from \code{\link{antibiotics}}.
#' @param abcode a code or name, like \code{"AMOX"}, \code{"AMCL"} or \code{"J01CA04"}
#' @param from,to type to transform from and to. See \code{\link{antibiotics}} for its column names. WIth \code{from = "guess"} the from will be guessed from \code{"atc"}, \code{"certe"} and \code{"umcg"}. When using \code{to = "atc"}, the ATC code will be searched using \code{\link{as.atc}}.
#' @param textbetween text to put between multiple returned texts
#' @param tolower return output as lower case with function \code{\link{tolower}}.
#' @details \strong{The \code{\link{ab_property}} functions are faster and more concise}, but do not support concatenated strings, like \code{abname("AMCL+GENT"}.
#' @keywords ab antibiotics
#' @source \code{\link{antibiotics}}
#' @inheritSection WHOCC WHOCC
#' @export
#' @importFrom dplyr %>% pull
#' @inheritSection AMR Read more on our website!
#' @examples
#' abname("AMCL")
#' # "Amoxicillin and beta-lactamase inhibitor"
#'
#' # It is quite flexible at default (having `from = "guess"`)
#' abname(c("amox", "J01CA04", "Trimox", "dispermox", "Amoxil"))
#' # "Amoxicillin" "Amoxicillin" "Amoxicillin" "Amoxicillin" "Amoxicillin"
#'
#' # Multiple antibiotics can be combined with "+".
#' # The second antibiotic will be set to lower case when `tolower` was not set:
#' abname("AMCL+GENT", textbetween = "/")
#' # "amoxicillin and enzyme inhibitor/gentamicin"
#'
#' abname(c("AMCL", "GENT"))
#' # "Amoxicillin and beta-lactamase inhibitor" "Gentamicin"
#'
#' abname("AMCL", to = "trivial_nl")
#' # "Amoxicilline/clavulaanzuur"
#'
#' abname("AMCL", to = "atc")
#' # "J01CR02"
#'
#' # specific codes for University Medical Center Groningen (UMCG):
#' abname("J01CR02", from = "atc", to = "umcg")
#' # "AMCL"
#'
#' # specific codes for Certe:
#' abname("J01CR02", from = "atc", to = "certe")
#' # "amcl"
abname <- function(abcode,
from = c("guess", "atc", "certe", "umcg"),
to = 'official',
textbetween = ' + ',
tolower = FALSE) {
if (length(to) != 1L) {
stop('`to` must be of length 1', call. = FALSE)
}
if (to == "atc") {
return(as.character(as.atc(abcode)))
}
abx <- AMR::antibiotics
from <- from[1]
colnames(abx) <- colnames(abx) %>% tolower()
from <- from %>% tolower()
to <- to %>% tolower()
if (!(from %in% colnames(abx) | from == "guess") |
!to %in% colnames(abx)) {
stop(paste0('Invalid `from` or `to`. Choose one of ',
colnames(abx) %>% paste(collapse = ", "), '.'), call. = FALSE)
}
abcode <- as.character(abcode)
abcode.bak <- abcode
for (i in 1:length(abcode)) {
if (abcode[i] %like% "[+]") {
# support for multiple ab's with +
parts <- trimws(strsplit(abcode[i], split = "+", fixed = TRUE)[[1]])
ab1 <- abname(parts[1], from = from, to = to)
ab2 <- abname(parts[2], from = from, to = to)
if (missing(tolower)) {
ab2 <- tolower(ab2)
}
abcode[i] <- paste0(ab1, textbetween, ab2)
next
}
if (from %in% c("atc", "guess")) {
if (abcode[i] %in% abx$atc) {
abcode[i] <- abx[which(abx$atc == abcode[i]),] %>% pull(to) %>% .[1]
next
}
}
if (from %in% c("certe", "guess")) {
if (abcode[i] %in% abx$certe) {
abcode[i] <- abx[which(abx$certe == abcode[i]),] %>% pull(to) %>% .[1]
next
}
}
if (from %in% c("umcg", "guess")) {
if (abcode[i] %in% abx$umcg) {
abcode[i] <- abx[which(abx$umcg == abcode[i]),] %>% pull(to) %>% .[1]
next
}
}
if (from %in% c("trade_name", "guess")) {
if (abcode[i] %in% abx$trade_name) {
abcode[i] <- abx[which(abx$trade_name == abcode[i]),] %>% pull(to) %>% .[1]
next
}
if (sum(abx$trade_name %like% abcode[i]) > 0) {
abcode[i] <- abx[which(abx$trade_name %like% abcode[i]),] %>% pull(to) %>% .[1]
next
}
}
if (from != "guess") {
# when not found, try any `from`
abcode[i] <- abx[which(abx[,from] == abcode[i]),] %>% pull(to) %>% .[1]
}
if (is.na(abcode[i]) | length(abcode[i] == 0)) {
# try as.atc
try(suppressWarnings(
abcode[i] <- as.atc(abcode[i])
), silent = TRUE)
if (is.na(abcode[i])) {
# still not found
abcode[i] <- abcode.bak[i]
warning('Code "', abcode.bak[i], '" not found in antibiotics list.', call. = FALSE)
} else {
# fill in the found ATC code
abcode[i] <- abname(abcode[i], from = "atc", to = to)
}
}
}
if (tolower == TRUE) {
abcode <- abcode %>% tolower()
}
abcode
}

2
R/age.R
View File

@@ -112,7 +112,7 @@ age <- function(x, reference = Sys.Date()) {
#' mo == as.mo("E. coli")) %>%
#' group_by(age_group = age_groups(age)) %>%
#' select(age_group,
#' cipr) %>%
#' CIP) %>%
#' ggplot_rsi(x = "age_group")
age_groups <- function(x, split_at = c(12, 25, 55, 75)) {
if (is.character(split_at)) {

112
R/atc.R
View File

@@ -44,118 +44,8 @@
#' as.atc(" eryt 123")
#' as.atc("ERYT")
#' as.atc("ERY")
#' as.atc("Erythrocin") # Trade name
#' as.atc("Eryzole") # Trade name
#' as.atc("Pediamycin") # Trade name
#'
#' # Use ab_* functions to get a specific property based on an ATC code
#' Cipro <- as.atc("cipro") # returns `J01MA02`
#' atc_official(Cipro) # returns "Ciprofloxacin"
#' atc_umcg(Cipro) # returns "CIPR", the code used in the UMCG
as.atc <- function(x) {
x.new <- rep(NA_character_, length(x))
x <- trimws(x, which = "both")
# keep only a-z when it's not an ATC code
x[!x %like% "[A-Z][0-9]{2}[A-Z]{2}[0-9]{2}"] <- gsub("[^a-zA-Z]+", "", x[!x %like% "[A-Z][0-9]{2}[A-Z]{2}[0-9]{2}"])
x.bak <- x
x <- unique(x)
failures <- character(0)
for (i in 1:length(x)) {
if (is.na(x[i]) | is.null(x[i]) | identical(x[i], "")) {
x.new[i] <- x[i]
next
}
fail <- TRUE
# first try atc
found <- AMR::antibiotics[which(AMR::antibiotics$atc == x[i]),]$atc
if (length(found) > 0) {
fail <- FALSE
x.new[is.na(x.new) & x.bak == x[i]] <- found[1L]
}
# try ATC in ATC code form, even if it does not exist in the antibiotics data set YET
if (length(found) == 0 & x[i] %like% '[A-Z][0-9][0-9][A-Z][A-Z][0-9][0-9]') {
warning("ATC code ", x[i], " is not yet in the `antibiotics` data set.")
fail <- FALSE
x.new[is.na(x.new) & x.bak == x[i]] <- x[i]
}
# try abbreviation of EARS-Net/WHONET
found <- AMR::antibiotics[which(tolower(AMR::antibiotics$ears_net) == tolower(x[i])),]$atc
if (length(found) > 0) {
fail <- FALSE
x.new[is.na(x.new) & x.bak == x[i]] <- found[1L]
}
# try abbreviation of certe and glims
found <- AMR::antibiotics[which(tolower(AMR::antibiotics$certe) == tolower(x[i])),]$atc
if (length(found) > 0) {
fail <- FALSE
x.new[is.na(x.new) & x.bak == x[i]] <- found[1L]
}
found <- AMR::antibiotics[which(tolower(AMR::antibiotics$umcg) == tolower(x[i])),]$atc
if (length(found) > 0) {
fail <- FALSE
x.new[is.na(x.new) & x.bak == x[i]] <- found[1L]
}
# try exact official name
found <- AMR::antibiotics[which(tolower(AMR::antibiotics$official) == tolower(x[i])),]$atc
if (length(found) > 0) {
fail <- FALSE
x.new[is.na(x.new) & x.bak == x[i]] <- found[1L]
}
# try exact official Dutch
found <- AMR::antibiotics[which(tolower(AMR::antibiotics$official_nl) == tolower(x[i])),]$atc
if (length(found) > 0) {
fail <- FALSE
x.new[is.na(x.new) & x.bak == x[i]] <- found[1L]
}
# try trade name
found <- AMR::antibiotics[which(paste0("(", AMR::antibiotics$trade_name, ")") %like% x[i]),]$atc
if (length(found) > 0) {
fail <- FALSE
x.new[is.na(x.new) & x.bak == x[i]] <- found[1L]
}
# try abbreviation
found <- AMR::antibiotics[which(paste0("(", AMR::antibiotics$abbr, ")") %like% x[i]),]$atc
if (length(found) > 0) {
fail <- FALSE
x.new[is.na(x.new) & x.bak == x[i]] <- found[1L]
}
# nothing helped, try first chars of official name, but only if nchar > 4 (cipro, nitro, fosfo)
if (nchar(x[i]) > 4) {
found <- AMR::antibiotics[which(AMR::antibiotics$official %like% paste0("^", substr(x[i], 1, 5))),]$atc
if (length(found) > 0) {
fail <- FALSE
x.new[is.na(x.new) & x.bak == x[i]] <- found[1L]
}
}
# not found
if (fail == TRUE) {
failures <- c(failures, x[i])
}
}
failures <- failures[!failures %in% c(NA, NULL, NaN)]
if (length(failures) > 0) {
warning("These values could not be coerced to a valid atc: ",
paste('"', unique(failures), '"', sep = "", collapse = ', '),
".",
call. = FALSE)
}
class(x.new) <- "atc"
x.new
ab_atc(x)
}
#' @rdname as.atc

107
R/atc_property.R
View File

@@ -1,107 +0,0 @@
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Analysis #
# #
# SOURCE #
# https://gitlab.com/msberends/AMR #
# #
# LICENCE #
# (c) 2019 Berends MS (m.s.berends@umcg.nl), Luz CF (c.f.luz@umcg.nl) #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
# GNU General Public License version 2.0 (GNU GPL-2), as published by #
# the Free Software Foundation. #
# #
# This R package was created for academic research and was publicly #
# released in the hope that it will be useful, but it comes WITHOUT #
# ANY WARRANTY OR LIABILITY. #
# Visit our website for more info: https://msberends.gitlab.io/AMR. #
# ==================================================================== #
#' Property of an antibiotic
#'
#' Use these functions to return a specific property of an antibiotic from the \code{\link{antibiotics}} data set, based on their ATC code. Get such a code with \code{\link{as.atc}}.
#' @param x a (vector of a) valid \code{\link{atc}} code or any text that can be coerced to a valid atc with \code{\link{as.atc}}
#' @param property one of the column names of one of the \code{\link{antibiotics}} data set, like \code{"atc"} and \code{"official"}
#' @param language language of the returned text, defaults to English (\code{"en"}) and can be set with \code{\link{getOption}("AMR_locale")}. Either one of \code{"en"} (English) or \code{"nl"} (Dutch).
#' @rdname atc_property
#' @return A vector of values. In case of \code{atc_tradenames}, if \code{x} is of length one, a vector will be returned. Otherwise a \code{\link{list}}, with \code{x} as names.
#' @export
#' @importFrom dplyr %>% left_join pull
#' @seealso \code{\link{antibiotics}}
#' @inheritSection AMR Read more on our website!
#' @examples
#' as.atc("amcl") # J01CR02
#' atc_name("amcl") # Amoxicillin and beta-lactamase inhibitor
#' atc_name("amcl", "nl") # Amoxicilline met enzymremmer
#' atc_trivial_nl("amcl") # Amoxicilline/clavulaanzuur
#' atc_certe("amcl") # amcl
#' atc_umcg("amcl") # AMCL
atc_property <- function(x, property = 'official') {
property <- property[1]
if (!property %in% colnames(AMR::antibiotics)) {
stop("invalid property: ", property, " - use a column name of the `antibiotics` data set")
}
if (!is.atc(x)) {
x <- as.atc(x) # this will give a warning if x cannot be coerced
}
suppressWarnings(
data.frame(atc = x, stringsAsFactors = FALSE) %>%
left_join(AMR::antibiotics, by = "atc") %>%
pull(property)
)
}
#' @rdname atc_property
#' @export
atc_official <- function(x, language = NULL) {
if (is.null(language)) {
language <- getOption("AMR_locale", default = "en")[1L]
} else {
language <- tolower(language[1])
}
if (language %in% c("en", "")) {
atc_property(x, "official")
} else if (language == "nl") {
atc_property(x, "official_nl")
} else {
stop("Unsupported language: '", language, "' - use one of: 'en', 'nl'", call. = FALSE)
}
}
#' @rdname atc_property
#' @export
atc_name <- atc_official
#' @rdname atc_property
#' @export
atc_trivial_nl <- function(x) {
atc_property(x, "trivial_nl")
}
#' @rdname atc_property
#' @export
atc_certe <- function(x) {
atc_property(x, "certe")
}
#' @rdname atc_property
#' @export
atc_umcg <- function(x) {
atc_property(x, "umcg")
}
#' @rdname atc_property
#' @export
atc_tradenames <- function(x) {
res <- atc_property(x, "trade_name")
res <- strsplit(res, "|", fixed = TRUE)
if (length(x) == 1) {
res <- unlist(res)
} else {
names(res) <- x
}
res
}

55
R/count.R
View File

@@ -44,55 +44,55 @@
#' ?septic_patients
#'
#' # Count resistant isolates
#' count_R(septic_patients$amox)
#' count_IR(septic_patients$amox)
#' count_R(septic_patients$AMX)
#' count_IR(septic_patients$AMX)
#'
#' # Or susceptible isolates
#' count_S(septic_patients$amox)
#' count_SI(septic_patients$amox)
#' count_S(septic_patients$AMX)
#' count_SI(septic_patients$AMX)
#'
#' # Count all available isolates
#' count_all(septic_patients$amox)
#' n_rsi(septic_patients$amox)
#' count_all(septic_patients$AMX)
#' n_rsi(septic_patients$AMX)
#'
#' # Since n_rsi counts available isolates, you can
#' # calculate back to count e.g. non-susceptible isolates.
#' # This results in the same:
#' count_IR(septic_patients$amox)
#' portion_IR(septic_patients$amox) * n_rsi(septic_patients$amox)
#' count_IR(septic_patients$AMX)
#' portion_IR(septic_patients$AMX) * n_rsi(septic_patients$AMX)
#'
#' library(dplyr)
#' septic_patients %>%
#' group_by(hospital_id) %>%
#' summarise(R = count_R(cipr),
#' I = count_I(cipr),
#' S = count_S(cipr),
#' n1 = count_all(cipr), # the actual total; sum of all three
#' n2 = n_rsi(cipr), # same - analogous to n_distinct
#' 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!
#'
#' # Count co-resistance between amoxicillin/clav acid and gentamicin,
#' # so we can see that combination therapy does a lot more than mono therapy.
#' # Please mind that `portion_S` calculates percentages right away instead.
#' count_S(septic_patients$amcl) # S = 1342 (71.4%)
#' count_all(septic_patients$amcl) # n = 1879
#' count_S(septic_patients$AMC) # S = 1342 (71.4%)
#' count_all(septic_patients$AMC) # n = 1879
#'
#' count_S(septic_patients$gent) # S = 1372 (74.0%)
#' count_all(septic_patients$gent) # n = 1855
#' count_S(septic_patients$GEN) # S = 1372 (74.0%)
#' count_all(septic_patients$GEN) # n = 1855
#'
#' with(septic_patients,
#' count_S(amcl, gent)) # S = 1660 (92.3%)
#' count_S(AMC, GEN)) # S = 1660 (92.3%)
#' with(septic_patients, # n = 1798
#' n_rsi(amcl, gent))
#' n_rsi(AMC, GEN))
#'
#' # Get portions S/I/R immediately of all rsi columns
#' septic_patients %>%
#' select(amox, cipr) %>%
#' select(AMX, CIP) %>%
#' count_df(translate = FALSE)
#'
#' # It also supports grouping variables
#' septic_patients %>%
#' select(hospital_id, amox, cipr) %>%
#' select(hospital_id, AMX, CIP) %>%
#' group_by(hospital_id) %>%
#' count_df(translate = FALSE)
#'
@@ -172,7 +172,8 @@ n_rsi <- function(...) {
#' @importFrom dplyr %>% select_if bind_rows summarise_if mutate group_vars select everything
#' @export
count_df <- function(data,
translate_ab = getOption("get_antibiotic_names", "official"),
translate_ab = "name",
language = get_locale(),
combine_IR = FALSE) {
if (!"data.frame" %in% class(data)) {
@@ -183,10 +184,9 @@ count_df <- function(data,
stop("No columns with class 'rsi' found. See ?as.rsi.")
}
if (as.character(translate_ab) == "TRUE") {
translate_ab <- "official"
if (as.character(translate_ab) %in% c("TRUE", "official")) {
translate_ab <- "name"
}
options(get_antibiotic_names = translate_ab)
resS <- summarise_if(.tbl = data,
.predicate = is.rsi,
@@ -227,10 +227,7 @@ count_df <- function(data,
}
if (!translate_ab == FALSE) {
if (!tolower(translate_ab) %in% tolower(colnames(AMR::antibiotics))) {
stop("Parameter `translate_ab` does not occur in the `antibiotics` data set.", call. = FALSE)
}
res <- res %>% mutate(Antibiotic = abname(Antibiotic, from = "guess", to = translate_ab))
res <- res %>% mutate(Antibiotic = ab_property(Antibiotic, property = translate_ab, language = language))
}
res

148
R/data.R
View File

@@ -19,115 +19,36 @@
# Visit our website for more info: https://msberends.gitlab.io/AMR. #
# ==================================================================== #
#' Data set with ~500 antibiotics
#' Data set with ~450 antibiotics
#'
#' A data set containing all antibiotics with a J0 code and some other antimicrobial agents, with their DDDs. Except for trade names and abbreviations, all properties were downloaded from the WHO, see Source.
#' @format A \code{\link{data.frame}} with 488 observations and 17 variables:
#' A data set containing all antibiotics. Use \code{\link{as.ab}} or one of the \code{\link{ab_property}} functions to retrieve values from this data set. Three identifiers are included in this data set: an antibiotic ID (\code{ab}, primarily used in this package) as defined by WHONET/EARS-Net, an ATC code (\code{atc}) as defined by the WHO, and a Compound ID (\code{cid}) as found in PubChem. Other properties in this data set are derived from one or more of these codes.
#' @format A \code{\link{data.frame}} with 455 observations and 13 variables:
#' \describe{
#' \item{\code{atc}}{ATC code (Anatomical Therapeutic Chemical), like \code{J01CR02}}
#' \item{\code{ears_net}}{EARS-Net code (European Antimicrobial Resistance Surveillance Network), like \code{AMC}}
#' \item{\code{certe}}{Certe code, like \code{amcl}}
#' \item{\code{umcg}}{UMCG code, like \code{AMCL}}
#' \item{\code{abbr}}{Abbreviation as used by many countries, used internally by \code{\link{as.atc}}}
#' \item{\code{official}}{Official name by the WHO, like \code{"Amoxicillin and beta-lactamase inhibitor"}}
#' \item{\code{official_nl}}{Official name in the Netherlands, like \code{"Amoxicilline met enzymremmer"}}
#' \item{\code{trivial_nl}}{Trivial name in Dutch, like \code{"Amoxicilline/clavulaanzuur"}}
#' \item{\code{trade_name}}{Trade name as used by many countries (a total of 294), used internally by \code{\link{as.atc}}}
#' \item{\code{ab}}{Antibiotic ID as used in this package (like \code{AMC}), using the official EARS-Net (European Antimicrobial Resistance Surveillance Network) codes where available}
#' \item{\code{atc}}{ATC code (Anatomical Therapeutic Chemical) as defined by the WHOCC, like \code{J01CR02}}
#' \item{\code{cid}}{Compound ID as found in PubChem}
#' \item{\code{name}}{Official name as used by WHONET/EARS-Net or the WHO}
#' \item{\code{group}}{A short and concise group name, based on WHONET and WHOCC definitions}
#' \item{\code{atc_group1}}{Official pharmacological subgroup (3rd level ATC code) as defined by the WHOCC, like \code{"Macrolides, lincosamides and streptogramins"}}
#' \item{\code{atc_group2}}{Official chemical subgroup (4th level ATC code) as defined by the WHOCC, like \code{"Macrolides"}}
#' \item{\code{abbr}}{List of abbreviations as used in many countries, also for antibiotic susceptibility testing (AST)}
#' \item{\code{synonyms}}{Synonyms (often trade names) of a drug, as found in PubChem based on their compound ID}
#' \item{\code{oral_ddd}}{Defined Daily Dose (DDD), oral treatment}
#' \item{\code{oral_units}}{Units of \code{ddd_units}}
#' \item{\code{iv_ddd}}{Defined Daily Dose (DDD), parenteral treatment}
#' \item{\code{iv_units}}{Units of \code{iv_ddd}}
#' \item{\code{atc_group1}}{ATC group, like \code{"Macrolides, lincosamides and streptogramins"}}
#' \item{\code{atc_group2}}{Subgroup of \code{atc_group1}, like \code{"Macrolides"}}
#' \item{\code{useful_gramnegative}}{\code{FALSE} if not useful according to EUCAST, \code{NA} otherwise (see Source)}
#' \item{\code{useful_grampositive}}{\code{FALSE} if not useful according to EUCAST, \code{NA} otherwise (see Source)}
#' }
#' @source World Health Organization (WHO) Collaborating Centre for Drug Statistics Methodology: \url{https://www.whocc.no/atc_ddd_index/}
#' @details Properties that are based on an ATC code are only available when an ATC is available. These properties are: \code{atc_group1}, \code{atc_group2}, \code{oral_ddd}, \code{oral_units}, \code{iv_ddd} and \code{iv_units}
#'
#' Table antibiotic coding EARSS (from WHONET 5.3): \url{http://www.madsonline.dk/Tutorials/landskoder_antibiotika_WM.pdf}
#' Synonyms (i.e. trade names) are derived from the Compound ID (\code{cid}) and consequently only available where a CID is available.
#' @source World Health Organization (WHO) Collaborating Centre for Drug Statistics Methodology (WHOCC): \url{https://www.whocc.no/atc_ddd_index/}
#'
#' EUCAST Expert Rules, Intrinsic Resistance and Exceptional Phenotypes Tables. Version 3.1, 2016: \url{http://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/Expert_rules_intrinsic_exceptional_V3.1.pdf}
#' WHONET 2019 software: \url{http://www.whonet.org/software.html}
#'
#' European Commission Public Health PHARMACEUTICALS - COMMUNITY REGISTER: \url{http://ec.europa.eu/health/documents/community-register/html/atc.htm}
#' @inheritSection WHOCC WHOCC
#' @inheritSection AMR Read more on our website!
#' @seealso \code{\link{microorganisms}}
# use this later to further fill AMR::antibiotics
# drug <- "Ciprofloxacin"
# url <- xml2::read_html(paste0("https://www.ncbi.nlm.nih.gov/pccompound?term=", drug)) %>%
# html_nodes(".rslt") %>%
# .[[1]] %>%
# html_nodes(".title a") %>%
# html_attr("href") %>%
# gsub("/compound/", "/rest/pug_view/data/compound/", ., fixed = TRUE) %>%
# paste0("/XML/?response_type=display")
# synonyms <- url %>%
# read_xml() %>%
# xml_contents() %>% .[[6]] %>%
# xml_contents() %>% .[[8]] %>%
# xml_contents() %>% .[[3]] %>%
# xml_contents() %>% .[[3]] %>%
# xml_contents() %>%
# paste() %>%
# .[. %like% "StringValueList"] %>%
# gsub("[</]+StringValueList[>]", "", .)
# last two columns created with:
# antibiotics %>%
# mutate(useful_gramnegative =
# if_else(
# atc_group1 %like% '(fusidic|glycopeptide|macrolide|lincosamide|daptomycin|linezolid)' |
# atc_group2 %like% '(fusidic|glycopeptide|macrolide|lincosamide|daptomycin|linezolid)' |
# official %like% '(fusidic|glycopeptide|macrolide|lincosamide|daptomycin|linezolid)',
# FALSE,
# NA
# ),
# useful_grampositive =
# if_else(
# atc_group1 %like% '(aztreonam|temocillin|polymyxin|colistin|nalidixic)' |
# atc_group2 %like% '(aztreonam|temocillin|polymyxin|colistin|nalidixic)' |
# official %like% '(aztreonam|temocillin|polymyxin|colistin|nalidixic)',
# FALSE,
# NA
# )
# )
#
# ADD NEW TRADE NAMES FROM OTHER DATAFRAME
# antibiotics_add_to_property <- function(ab_df, atc, property, value) {
# if (length(atc) > 1L) {
# stop("only one atc at a time")
# }
# if (!property %in% c("abbr", "trade_name")) {
# stop("only possible for abbr and trade_name")
# }
#
# value <- gsub(ab_df[which(ab_df$atc == atc),] %>% pull("official"), "", value, fixed = TRUE)
# value <- gsub("||", "|", value, fixed = TRUE)
# value <- gsub("[äáàâ]", "a", value)
# value <- gsub("[ëéèê]", "e", value)
# value <- gsub("[ïíìî]", "i", value)
# value <- gsub("[öóòô]", "o", value)
# value <- gsub("[üúùû]", "u", value)
# if (!atc %in% ab_df$atc) {
# message("SKIPPING - UNKNOWN ATC: ", atc)
# }
# if (is.na(value)) {
# message("SKIPPING - VALUE MISSES: ", atc)
# }
# if (atc %in% ab_df$atc & !is.na(value)) {
# current <- ab_df[which(ab_df$atc == atc),] %>% pull(property)
# if (!is.na(current)) {
# value <- paste(current, value, sep = "|")
# }
# value <- strsplit(value, "|", fixed = TRUE) %>% unlist() %>% unique() %>% paste(collapse = "|")
# value <- gsub("||", "|", value, fixed = TRUE)
# # print(value)
# ab_df[which(ab_df$atc == atc), property] <- value
# message("Added ", value, " to ", ab_official(atc), " (", atc, ", ", ab_certe(atc), ")")
# }
# ab_df
# }
#
"antibiotics"
#' Data set with ~65,000 microorganisms
@@ -262,6 +183,24 @@ catalogue_of_life <- list(
#' @inheritSection AMR Read more on our website!
"WHONET"
#' Data set for RSI interpretation
#'
#' Data set to interpret MIC and disk diffusion to RSI values. Included guidelines are CLSI (2011-2019) and EUCAST (2011-2019). Use \code{\link{as.rsi}} to transform MICs or disks measurements to RSI values.
#' @format A \code{\link{data.frame}} with 11,559 observations and 9 variables:
#' \describe{
#' \item{\code{guideline}}{Name of the guideline}
#' \item{\code{mo}}{Microbial ID, see \code{\link{as.mo}}}
#' \item{\code{ab}}{Antibiotic ID, see \code{\link{as.ab}}}
#' \item{\code{ref_tbl}}{Info about where the guideline rule can be found}
#' \item{\code{S_mic}}{Lowest MIC value that leads to "S"}
#' \item{\code{R_mic}}{Highest MIC value that leads to "R"}
#' \item{\code{dose_disk}}{Dose of the used disk diffusion method}
#' \item{\code{S_disk}}{Lowest number of millimeters that leads to "S"}
#' \item{\code{R_disk}}{Highest number of millimeters that leads to "R"}
#' }
#' @inheritSection AMR Read more on our website!
"rsi_translation"
# transforms data set to data.frame with only ASCII values, to comply with CRAN policies
dataset_UTF8_to_ASCII <- function(df) {
trans <- function(vect) {
@@ -270,14 +209,21 @@ dataset_UTF8_to_ASCII <- function(df) {
df <- as.data.frame(df, stringsAsFactors = FALSE)
for (i in 1:NCOL(df)) {
col <- df[, i]
if (is.factor(col)) {
levels(col) <- trans(levels(col))
} else if (is.character(col)) {
col <- trans(col)
if (is.list(col)) {
for (j in 1:length(col)) {
col[[j]] <- trans(col[[j]])
}
df[, i] <- list(col)
} else {
col
if (is.factor(col)) {
levels(col) <- trans(levels(col))
} else if (is.character(col)) {
col <- trans(col)
} else {
col
}
df[, i] <- col
}
df[, i] <- col
}
df
}

70
R/deprecated.R
View File

@@ -49,71 +49,49 @@ ratio <- function(x, ratio) {
#' @rdname AMR-deprecated
#' @export
ab_property <- function(...) {
.Deprecated(new = "atc_property", package = "AMR")
atc_property(...)
abname <- function(...) {
.Deprecated("ab_name", package = "AMR")
ab_name(...)
}
#' @rdname AMR-deprecated
#' @export
ab_atc <- function(...) {
.Deprecated(new = "as.atc", package = "AMR")
as.atc(...)
atc_property <- function(...) {
.Deprecated("ab_property", package = "AMR")
ab_property(...)
}
#' @rdname AMR-deprecated
#' @export
atc_official <- function(...) {
.Deprecated("ab_name", package = "AMR")
ab_name(...)
}
#' @rdname AMR-deprecated
#' @export
ab_official <- function(...) {
.Deprecated(new = "atc_official", package = "AMR")
atc_official(...)
.Deprecated("ab_name", package = "AMR")
ab_name(...)
}
#' @rdname AMR-deprecated
#' @export
ab_name <- function(...) {
.Deprecated(new = "atc_name", package = "AMR")
atc_name(...)
atc_name <- function(...) {
.Deprecated("ab_name", package = "AMR")
ab_name(...)
}
#' @rdname AMR-deprecated
#' @export
ab_trivial_nl <- function(...) {
.Deprecated(new = "atc_trivial_nl", package = "AMR")
atc_trivial_nl(...)
atc_trivial_nl <- function(...) {
.Deprecated("ab_name", package = "AMR")
ab_name(..., language = "nl")
}
#' @rdname AMR-deprecated
#' @export
ab_certe <- function(...) {
.Deprecated(new = "atc_certe", package = "AMR")
atc_certe(...)
atc_tradenames <- function(...) {
.Deprecated("ab_tradenames", package = "AMR")
ab_tradenames(...)
}
#' @rdname AMR-deprecated
#' @export
ab_umcg <- function(...) {
.Deprecated(new = "atc_umcg", package = "AMR")
atc_umcg(...)
}
#' @rdname AMR-deprecated
#' @export
ab_tradenames <- function(...) {
.Deprecated(new = "atc_tradenames", package = "AMR")
atc_tradenames(...)
}
#' @rdname AMR-deprecated
#' @export
atc_ddd <- function(...) {
.Deprecated(new = "atc_online_ddd", package = "AMR")
atc_online_ddd(...)
}
#' @rdname AMR-deprecated
#' @export
atc_groups <- function(...) {
.Deprecated(new = "atc_online_groups", package = "AMR")
atc_online_groups(...)
}

92
R/disk.R Normal file
View File

@@ -0,0 +1,92 @@
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Analysis #
# #
# SOURCE #
# https://gitlab.com/msberends/AMR #
# #
# LICENCE #
# (c) 2019 Berends MS (m.s.berends@umcg.nl), Luz CF (c.f.luz@umcg.nl) #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
# GNU General Public License version 2.0 (GNU GPL-2), as published by #
# the Free Software Foundation. #
# #
# This R package was created for academic research and was publicly #
# released in the hope that it will be useful, but it comes WITHOUT #
# ANY WARRANTY OR LIABILITY. #
# Visit our website for more info: https://msberends.gitlab.io/AMR. #
# ==================================================================== #
#' Class 'disk'
#'
#' This transforms a vector to a new class \code{disk}, which is a growth zone size (around an antibiotic disk) in millimeters between 6 and 99.
#' @rdname as.disk
#' @param x vector
#' @param na.rm a logical indicating whether missing values should be removed
#' @details Interpret disk values as RSI values with \code{\link{as.rsi}}. It supports guidelines from EUCAST and CLSI.
#' @return Ordered integer factor with new class \code{disk}
#' @keywords disk
#' @export
#' @seealso \code{\link{as.rsi}}
#' @inheritSection AMR Read more on our website!
#' @examples
#' # interpret disk values
#' as.rsi(x = 12,
#' mo = as.mo("S. pneumoniae"),
#' ab = "AMX",
#' guideline = "EUCAST")
#' as.rsi(x = 12,
#' mo = as.mo("S. pneumoniae"),
#' ab = "AMX",
#' guideline = "CLSI")
as.disk <- function(x, na.rm = FALSE) {
if (is.disk(x)) {
x
} else {
x <- x %>% unlist()
if (na.rm == TRUE) {
x <- x[!is.na(x)]
}
x.bak <- x
na_before <- length(x[is.na(x)])
# force it to be integer
x <- suppressWarnings(as.integer(x))
# disks can never be less than 9 mm (size of a disk) or more than 50 mm
x[x < 6 | x > 99] <- NA_integer_
na_after <- length(x[is.na(x)])
if (na_before != na_after) {
list_missing <- x.bak[is.na(x) & !is.na(x.bak)] %>%
unique() %>%
sort()
list_missing <- paste0('"', list_missing , '"', collapse = ", ")
warning(na_after - na_before, ' results truncated (',
round(((na_after - na_before) / length(x)) * 100),
'%) that were invalid disk zones: ',
list_missing, call. = FALSE)
}
class(x) <- c('disk', 'integer')
x
}
}
#' @rdname as.disk
#' @export
#' @importFrom dplyr %>%
is.disk <- function(x) {
class(x) %>% identical(c('disk', 'integer'))
}
#' @exportMethod print.disk
#' @export
#' @noRd
print.disk <- function(x, ...) {
cat("Class 'disk'\n")
print(as.integer(x), quote = FALSE)
}

556
R/eucast_rules.R
View File

@@ -27,94 +27,95 @@ EUCAST_VERSION_EXPERT_RULES <- "3.1, 2016"
#' EUCAST rules
#'
#' Apply susceptibility rules as defined by the European Committee on Antimicrobial Susceptibility Testing (EUCAST, \url{http://eucast.org}), see \emph{Source}. This includes (1) expert rules, (2) intrinsic resistance and (3) inferred resistance as defined in their breakpoint tables.
#' @param x data with antibiotic columns, like e.g. \code{amox} and \code{amcl}
#' @param x data with antibiotic columns, like e.g. \code{AMX} and \code{AMC}
#' @param info print progress
#' @param rules a character vector that specifies which rules should be applied - one or more of \code{c("breakpoints", "expert", "other", "all")}
#' @param verbose a logical to indicate whether extensive info should be returned as a \code{data.frame} with info about which rows and columns are effected. It runs all EUCAST rules, but will not be applied to an output - only an informative \code{data.frame} with changes will be returned as output.
#' @param amcl,amik,amox,ampi,azit,azlo,aztr,cefa,cfep,cfot,cfox,cfra,cfta,cftr,cfur,chlo,cipr,clar,clin,clox,coli,czol,dapt,doxy,erta,eryt,fosf,fusi,gent,imip,kana,levo,linc,line,mero,mezl,mino,moxi,nali,neom,neti,nitr,norf,novo,oflo,oxac,peni,pipe,pita,poly,pris,qida,rifa,roxi,siso,teic,tetr,tica,tige,tobr,trim,trsu,vanc column name of an antibiotic, see Antibiotics
#' @param ... parameters that are passed on to \code{eucast_rules}
#' @param ... column name of an antibiotic, see section Antibiotics
#' @inheritParams first_isolate
#' @details
#' \strong{NOTE:} This function does not translate MIC values to RSI values. It only applies (1) inferred susceptibility and resistance based on results of other antibiotics and (2) intrinsic resistance based on taxonomic properties of a microorganism.
#' \strong{Note:} This function does not translate MIC values to RSI values. Use \code{\link{as.rsi}} for that. \cr
#' \strong{Note:} When ampicillin (AMP, J01CA01) is not available but amoxicillin (AMX, J01CA04) is, the latter will be used for all rules where there is a dependency on ampicillin. These drugs are interchangeable when it comes to expression of antimicrobial resistance.
#'
#' The file used for applying all EUCAST rules can be retrieved with \code{\link{eucast_rules_file}()}. It returns an easily readable data set containing all rules. The original TSV file (tab separated file) that is being read by this function can be found when running this command: \cr
#' The file used for applying all EUCAST rules can be retrieved with \code{\link{eucast_rules_file}()}. It returns an easily readable data set containing all rules. The original TSV file (tab separated file) that is being read by \code{eucast_rules()} can be found by running this command: \cr
#' \code{AMR::EUCAST_RULES_FILE_LOCATION} (without brackets).
#'
#' In the source code it is located under \href{https://gitlab.com/msberends/AMR/blob/master/inst/eucast/eucast_rules.tsv}{\code{./inst/eucast/eucast_rules.tsv}}.
#' In the source code the file containing all rules is located \href{https://gitlab.com/msberends/AMR/blob/master/inst/eucast/eucast_rules.tsv}{here}.
#'
#' \strong{Note:} When ampicillin (J01CA01) is not available but amoxicillin (J01CA04) is, the latter will be used for all rules where there is a dependency on ampicillin. These drugs are interchangeable when it comes to expression of antimicrobial resistance.
#' @section Antibiotics:
#' To define antibiotics column names, leave as it is to determine it automatically with \code{\link{guess_ab_col}} or input a text (case-insensitive) or use \code{NULL} to skip a column (e.g. \code{tica = NULL}). Non-existing columns will anyway be skipped with a warning.
#' To define antibiotics column names, leave as it is to determine it automatically with \code{\link{guess_ab_col}} or input a text (case-insensitive), or use \code{NULL} to skip a column (e.g. \code{TIC = NULL} to skip ticarcillin). Manually defined but non-existing columns will be skipped with a warning.
#'
#' Abbrevations of the column containing antibiotics in the form: \strong{abbreviation}: generic name (\emph{ATC code})
#' Available abbrevations of the column containing antibiotics in the form '\strong{antimicrobial ID}: name (\emph{ATC code})':
#'
#' \strong{amcl}: amoxicillin+clavulanic acid (\href{https://www.whocc.no/atc_ddd_index/?code=J01CR02}{J01CR02}),
#' \strong{amik}: amikacin (\href{https://www.whocc.no/atc_ddd_index/?code=J01GB06}{J01GB06}),
#' \strong{amox}: amoxicillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01CA04}{J01CA04}),
#' \strong{ampi}: ampicillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01CA01}{J01CA01}),
#' \strong{azit}: azithromycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01FA10}{J01FA10}),
#' \strong{azlo}: azlocillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01CA09}{J01CA09}),
#' \strong{aztr}: aztreonam (\href{https://www.whocc.no/atc_ddd_index/?code=J01DF01}{J01DF01}),
#' \strong{cefa}: cefaloridine (\href{https://www.whocc.no/atc_ddd_index/?code=J01DB02}{J01DB02}),
#' \strong{cfep}: cefepime (\href{https://www.whocc.no/atc_ddd_index/?code=J01DE01}{J01DE01}),
#' \strong{cfot}: cefotaxime (\href{https://www.whocc.no/atc_ddd_index/?code=J01DD01}{J01DD01}),
#' \strong{cfox}: cefoxitin (\href{https://www.whocc.no/atc_ddd_index/?code=J01DC01}{J01DC01}),
#' \strong{cfra}: cefradine (\href{https://www.whocc.no/atc_ddd_index/?code=J01DB09}{J01DB09}),
#' \strong{cfta}: ceftazidime (\href{https://www.whocc.no/atc_ddd_index/?code=J01DD02}{J01DD02}),
#' \strong{cftr}: ceftriaxone (\href{https://www.whocc.no/atc_ddd_index/?code=J01DD04}{J01DD04}),
#' \strong{cfur}: cefuroxime (\href{https://www.whocc.no/atc_ddd_index/?code=J01DC02}{J01DC02}),
#' \strong{chlo}: chloramphenicol (\href{https://www.whocc.no/atc_ddd_index/?code=J01BA01}{J01BA01}),
#' \strong{cipr}: ciprofloxacin (\href{https://www.whocc.no/atc_ddd_index/?code=J01MA02}{J01MA02}),
#' \strong{clar}: clarithromycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01FA09}{J01FA09}),
#' \strong{clin}: clindamycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01FF01}{J01FF01}),
#' \strong{clox}: flucloxacillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01CF05}{J01CF05}),
#' \strong{coli}: colistin (\href{https://www.whocc.no/atc_ddd_index/?code=J01XB01}{J01XB01}),
#' \strong{czol}: cefazolin (\href{https://www.whocc.no/atc_ddd_index/?code=J01DB04}{J01DB04}),
#' \strong{dapt}: daptomycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01XX09}{J01XX09}),
#' \strong{doxy}: doxycycline (\href{https://www.whocc.no/atc_ddd_index/?code=J01AA02}{J01AA02}),
#' \strong{erta}: ertapenem (\href{https://www.whocc.no/atc_ddd_index/?code=J01DH03}{J01DH03}),
#' \strong{eryt}: erythromycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01FA01}{J01FA01}),
#' \strong{fosf}: fosfomycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01XX01}{J01XX01}),
#' \strong{fusi}: fusidic acid (\href{https://www.whocc.no/atc_ddd_index/?code=J01XC01}{J01XC01}),
#' \strong{gent}: gentamicin (\href{https://www.whocc.no/atc_ddd_index/?code=J01GB03}{J01GB03}),
#' \strong{imip}: imipenem (\href{https://www.whocc.no/atc_ddd_index/?code=J01DH51}{J01DH51}),
#' \strong{kana}: kanamycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01GB04}{J01GB04}),
#' \strong{levo}: levofloxacin (\href{https://www.whocc.no/atc_ddd_index/?code=J01MA12}{J01MA12}),
#' \strong{linc}: lincomycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01FF02}{J01FF02}),
#' \strong{line}: linezolid (\href{https://www.whocc.no/atc_ddd_index/?code=J01XX08}{J01XX08}),
#' \strong{mero}: meropenem (\href{https://www.whocc.no/atc_ddd_index/?code=J01DH02}{J01DH02}),
#' \strong{mezl}: mezlocillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01CA10}{J01CA10}),
#' \strong{mino}: minocycline (\href{https://www.whocc.no/atc_ddd_index/?code=J01AA08}{J01AA08}),
#' \strong{moxi}: moxifloxacin (\href{https://www.whocc.no/atc_ddd_index/?code=J01MA14}{J01MA14}),
#' \strong{nali}: nalidixic acid (\href{https://www.whocc.no/atc_ddd_index/?code=J01MB02}{J01MB02}),
#' \strong{neom}: neomycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01GB05}{J01GB05}),
#' \strong{neti}: netilmicin (\href{https://www.whocc.no/atc_ddd_index/?code=J01GB07}{J01GB07}),
#' \strong{nitr}: nitrofurantoin (\href{https://www.whocc.no/atc_ddd_index/?code=J01XE01}{J01XE01}),
#' \strong{norf}: norfloxacin (\href{https://www.whocc.no/atc_ddd_index/?code=J01MA06}{J01MA06}),
#' \strong{novo}: novobiocin (an ATCvet code: \href{https://www.whocc.no/atc_ddd_index/?code=QJ01XX95}{QJ01XX95}),
#' \strong{oflo}: ofloxacin (\href{https://www.whocc.no/atc_ddd_index/?code=J01MA01}{J01MA01}),
#' \strong{peni}: (benzyl)penicillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01CE01}{J01CE01}),
#' \strong{pipe}: piperacillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01CA12}{J01CA12}),
#' \strong{pita}: piperacillin+tazobactam (\href{https://www.whocc.no/atc_ddd_index/?code=J01CR05}{J01CR05}),
#' \strong{poly}: polymyxin B (\href{https://www.whocc.no/atc_ddd_index/?code=J01XB02}{J01XB02}),
#' \strong{pris}: pristinamycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01FG01}{J01FG01}),
#' \strong{qida}: quinupristin/dalfopristin (\href{https://www.whocc.no/atc_ddd_index/?code=J01FG02}{J01FG02}),
#' \strong{rifa}: rifampicin (\href{https://www.whocc.no/atc_ddd_index/?code=J04AB02}{J04AB02}),
#' \strong{roxi}: roxithromycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01FA06}{J01FA06}),
#' \strong{siso}: sisomicin (\href{https://www.whocc.no/atc_ddd_index/?code=J01GB08}{J01GB08}),
#' \strong{teic}: teicoplanin (\href{https://www.whocc.no/atc_ddd_index/?code=J01XA02}{J01XA02}),
#' \strong{tetr}: tetracycline (\href{https://www.whocc.no/atc_ddd_index/?code=J01AA07}{J01AA07}),
#' \strong{tica}: ticarcillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01CA13}{J01CA13}),
#' \strong{tige}: tigecycline (\href{https://www.whocc.no/atc_ddd_index/?code=J01AA12}{J01AA12}),
#' \strong{tobr}: tobramycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01GB01}{J01GB01}),
#' \strong{trim}: trimethoprim (\href{https://www.whocc.no/atc_ddd_index/?code=J01EA01}{J01EA01}),
#' \strong{trsu}: sulfamethoxazole and trimethoprim (\href{https://www.whocc.no/atc_ddd_index/?code=J01EE01}{J01EE01}),
#' \strong{vanc}: vancomycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01XA01}{J01XA01}).
#' \strong{AMC}: amoxicillin/clavulanic acid (\href{https://www.whocc.no/atc_ddd_index/?code=J01CR02}{J01CR02}),
#' \strong{AMK}: amikacin (\href{https://www.whocc.no/atc_ddd_index/?code=J01GB06}{J01GB06}),
#' \strong{AMX}: amoxicillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01CA04}{J01CA04}),
#' \strong{AMP}: ampicillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01CA01}{J01CA01}),
#' \strong{AZM}: azithromycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01FA10}{J01FA10}),
#' \strong{AZL}: azlocillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01CA09}{J01CA09}),
#' \strong{ATM}: aztreonam (\href{https://www.whocc.no/atc_ddd_index/?code=J01DF01}{J01DF01}),
#' \strong{RID}: cefaloridine (\href{https://www.whocc.no/atc_ddd_index/?code=J01DB02}{J01DB02}),
#' \strong{FEP}: cefepime (\href{https://www.whocc.no/atc_ddd_index/?code=J01DE01}{J01DE01}),
#' \strong{CTX}: cefotaxime (\href{https://www.whocc.no/atc_ddd_index/?code=J01DD01}{J01DD01}),
#' \strong{FOX}: cefoxitin (\href{https://www.whocc.no/atc_ddd_index/?code=J01DC01}{J01DC01}),
#' \strong{CED}: cefradine (\href{https://www.whocc.no/atc_ddd_index/?code=J01DB09}{J01DB09}),
#' \strong{CAZ}: ceftazidime (\href{https://www.whocc.no/atc_ddd_index/?code=J01DD02}{J01DD02}),
#' \strong{CRO}: ceftriaxone (\href{https://www.whocc.no/atc_ddd_index/?code=J01DD04}{J01DD04}),
#' \strong{CXM}: cefuroxime (\href{https://www.whocc.no/atc_ddd_index/?code=J01DC02}{J01DC02}),
#' \strong{CHL}: chloramphenicol (\href{https://www.whocc.no/atc_ddd_index/?code=J01BA01}{J01BA01}),
#' \strong{CIP}: ciprofloxacin (\href{https://www.whocc.no/atc_ddd_index/?code=J01MA02}{J01MA02}),
#' \strong{CLR}: clarithromycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01FA09}{J01FA09}),
#' \strong{CLI}: clindamycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01FF01}{J01FF01}),
#' \strong{FLC}: flucloxacillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01CF05}{J01CF05}),
#' \strong{COL}: colistin (\href{https://www.whocc.no/atc_ddd_index/?code=J01XB01}{J01XB01}),
#' \strong{CZO}: cefazolin (\href{https://www.whocc.no/atc_ddd_index/?code=J01DB04}{J01DB04}),
#' \strong{DAP}: daptomycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01XX09}{J01XX09}),
#' \strong{DOX}: doxycycline (\href{https://www.whocc.no/atc_ddd_index/?code=J01AA02}{J01AA02}),
#' \strong{ETP}: ertapenem (\href{https://www.whocc.no/atc_ddd_index/?code=J01DH03}{J01DH03}),
#' \strong{ERY}: erythromycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01FA01}{J01FA01}),
#' \strong{FOS}: fosfomycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01XX01}{J01XX01}),
#' \strong{FUS}: fusidic acid (\href{https://www.whocc.no/atc_ddd_index/?code=J01XC01}{J01XC01}),
#' \strong{GEN}: gentamicin (\href{https://www.whocc.no/atc_ddd_index/?code=J01GB03}{J01GB03}),
#' \strong{IPM}: imipenem (\href{https://www.whocc.no/atc_ddd_index/?code=J01DH51}{J01DH51}),
#' \strong{KAN}: kanamycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01GB04}{J01GB04}),
#' \strong{LVX}: levofloxacin (\href{https://www.whocc.no/atc_ddd_index/?code=J01MA12}{J01MA12}),
#' \strong{LIN}: lincomycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01FF02}{J01FF02}),
#' \strong{LNZ}: linezolid (\href{https://www.whocc.no/atc_ddd_index/?code=J01XX08}{J01XX08}),
#' \strong{MEM}: meropenem (\href{https://www.whocc.no/atc_ddd_index/?code=J01DH02}{J01DH02}),
#' \strong{MEZ}: mezlocillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01CA10}{J01CA10}),
#' \strong{MNO}: minocycline (\href{https://www.whocc.no/atc_ddd_index/?code=J01AA08}{J01AA08}),
#' \strong{MFX}: moxifloxacin (\href{https://www.whocc.no/atc_ddd_index/?code=J01MA14}{J01MA14}),
#' \strong{MTR}: metronidazole (\href{https://www.whocc.no/atc_ddd_index/?code=J01MA14}{J01XD01}),
#' \strong{NAL}: nalidixic acid (\href{https://www.whocc.no/atc_ddd_index/?code=J01MB02}{J01MB02}),
#' \strong{NEO}: neomycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01GB05}{J01GB05}),
#' \strong{NET}: netilmicin (\href{https://www.whocc.no/atc_ddd_index/?code=J01GB07}{J01GB07}),
#' \strong{NIT}: nitrofurantoin (\href{https://www.whocc.no/atc_ddd_index/?code=J01XE01}{J01XE01}),
#' \strong{NOR}: norfloxacin (\href{https://www.whocc.no/atc_ddd_index/?code=J01MA06}{J01MA06}),
#' \strong{NOV}: novobiocin (an ATCvet code: \href{https://www.whocc.no/atc_ddd_index/?code=QJ01XX95}{QJ01XX95}),
#' \strong{OFX}: ofloxacin (\href{https://www.whocc.no/atc_ddd_index/?code=J01MA01}{J01MA01}),
#' \strong{OXA}: oxacillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01MA01}{J01CF04}),
#' \strong{PEN}: penicillin G (\href{https://www.whocc.no/atc_ddd_index/?code=J01CE01}{J01CE01}),
#' \strong{PIP}: piperacillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01CA12}{J01CA12}),
#' \strong{TZP}: piperacillin/tazobactam (\href{https://www.whocc.no/atc_ddd_index/?code=J01CR05}{J01CR05}),
#' \strong{PLB}: polymyxin B (\href{https://www.whocc.no/atc_ddd_index/?code=J01XB02}{J01XB02}),
#' \strong{PRI}: pristinamycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01FG01}{J01FG01}),
#' \strong{QDA}: quinupristin/dalfopristin (\href{https://www.whocc.no/atc_ddd_index/?code=J01FG02}{J01FG02}),
#' \strong{RIF}: rifampicin (\href{https://www.whocc.no/atc_ddd_index/?code=J04AB02}{J04AB02}),
#' \strong{RXT}: roxithromycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01FA06}{J01FA06}),
#' \strong{SIS}: sisomicin (\href{https://www.whocc.no/atc_ddd_index/?code=J01GB08}{J01GB08}),
#' \strong{TEC}: teicoplanin (\href{https://www.whocc.no/atc_ddd_index/?code=J01XA02}{J01XA02}),
#' \strong{TCY}: tetracycline (\href{https://www.whocc.no/atc_ddd_index/?code=J01AA07}{J01AA07}),
#' \strong{TIC}: ticarcillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01CA13}{J01CA13}),
#' \strong{TGC}: tigecycline (\href{https://www.whocc.no/atc_ddd_index/?code=J01AA12}{J01AA12}),
#' \strong{TOB}: tobramycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01GB01}{J01GB01}),
#' \strong{TMP}: trimethoprim (\href{https://www.whocc.no/atc_ddd_index/?code=J01EA01}{J01EA01}),
#' \strong{SXT}: trimethoprim/sulfamethoxazole (\href{https://www.whocc.no/atc_ddd_index/?code=J01EE01}{J01EE01}),
#' \strong{VAN}: vancomycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01XA01}{J01XA01}).
#' @keywords interpretive eucast reading resistance
#' @rdname eucast_rules
#' @export
#' @importFrom dplyr %>% select pull mutate_at vars group_by summarise n
#' @importFrom crayon bold bgGreen bgYellow bgRed black green blue italic strip_style
#' @importFrom crayon bold bgGreen bgYellow bgRed black green blue italic strip_style white
#' @return The input of \code{tbl_}, possibly with edited values of antibiotics. Or, if \code{verbose = TRUE}, a \code{data.frame} with all original and new values of the affected bug-drug combinations.
#' @source
#' \itemize{
@@ -133,7 +134,7 @@ EUCAST_VERSION_EXPERT_RULES <- "3.1, 2016"
#' }
#' }
#'
#' For editing the reference file (which is available with \code{\link{eucast_rules_file}}), these values can all be used for target antibiotics: aminoglycosides, tetracyclines, polymyxins, macrolides, glycopeptides, streptogramins, cephalosporins, cephalosporins_without_cfta, carbapenems, aminopenicillins, ureidopenicillins, fluoroquinolones, all_betalactams, and all separate four letter codes like amcl. They can be separated by comma: \code{"amcl, fluoroquinolones"}. The mo_property can be any column name from the \code{\link{microorganisms}} data set, or \code{genus_species} or \code{gramstain}. This file contains references to the 'Burkholderia cepacia complex'. The species in this group can be found in: LiPuma JJ, 2015 (PMID 16217180).
#' For editing the reference file (which is available with \code{\link{eucast_rules_file}}), these values can all be used for target antibiotics: aminoglycosides, tetracyclines, polymyxins, macrolides, glycopeptides, streptogramins, cephalosporins, cephalosporins_without_cfta, carbapenems, aminopenicillins, ureidopenicillins, fluoroquinolones, all_betalactams, and all separate four letter codes like AMC. They can be separated by comma: \code{"AMC, fluoroquinolones"}. The mo_property can be any column name from the \code{\link{microorganisms}} data set, or \code{genus_species} or \code{gramstain}. This file contains references to the 'Burkholderia cepacia complex'. The species in this group can be found in: LiPuma JJ, 2015 (PMID 16217180).
#' @inheritSection AMR Read more on our website!
#' @examples
#' a <- eucast_rules(septic_patients)
@@ -143,17 +144,17 @@ EUCAST_VERSION_EXPERT_RULES <- "3.1, 2016"
#' "Escherichia coli",
#' "Klebsiella pneumoniae",
#' "Pseudomonas aeruginosa"),
#' vanc = "-", # Vancomycin
#' amox = "-", # Amoxicillin
#' coli = "-", # Colistin
#' cfta = "-", # Ceftazidime
#' cfur = "-", # Cefuroxime
#' peni = "S", # Benzylpenicillin
#' cfox = "S", # Cefoxitin
#' VAN = "-", # Vancomycin
#' AMX = "-", # Amoxicillin
#' COL = "-", # Colistin
#' CAZ = "-", # Ceftazidime
#' CXM = "-", # Cefuroxime
#' PEN = "S", # Penicillin G
#' FOX = "S", # Cefoxitin
#' stringsAsFactors = FALSE)
#'
#' a
#' # mo vanc amox coli cfta cfur peni cfox
#' # mo VAN AMX COL CAZ CXM PEN FOX
#' # 1 Staphylococcus aureus - - - - - S S
#' # 2 Enterococcus faecalis - - - - - S S
#' # 3 Escherichia coli - - - - - S S
@@ -165,7 +166,7 @@ EUCAST_VERSION_EXPERT_RULES <- "3.1, 2016"
#' b <- eucast_rules(a)
#'
#' b
#' # mo vanc amox coli cfta cfur peni cfox
#' # mo VAN AMX COL CAZ CXM PEN FOX
#' # 1 Staphylococcus aureus - S R R S S S
#' # 2 Enterococcus faecalis - - R R R S R
#' # 3 Escherichia coli R - - - - R S
@@ -181,81 +182,12 @@ eucast_rules <- function(x,
info = TRUE,
rules = c("breakpoints", "expert", "other", "all"),
verbose = FALSE,
amcl = guess_ab_col(),
amik = guess_ab_col(),
amox = guess_ab_col(),
ampi = guess_ab_col(),
azit = guess_ab_col(),
azlo = guess_ab_col(),
aztr = guess_ab_col(),
cefa = guess_ab_col(),
cfep = guess_ab_col(),
cfot = guess_ab_col(),
cfox = guess_ab_col(),
cfra = guess_ab_col(),
cfta = guess_ab_col(),
cftr = guess_ab_col(),
cfur = guess_ab_col(),
chlo = guess_ab_col(),
cipr = guess_ab_col(),
clar = guess_ab_col(),
clin = guess_ab_col(),
clox = guess_ab_col(),
coli = guess_ab_col(),
czol = guess_ab_col(),
dapt = guess_ab_col(),
doxy = guess_ab_col(),
erta = guess_ab_col(),
eryt = guess_ab_col(),
fosf = guess_ab_col(),
fusi = guess_ab_col(),
gent = guess_ab_col(),
imip = guess_ab_col(),
kana = guess_ab_col(),
levo = guess_ab_col(),
linc = guess_ab_col(),
line = guess_ab_col(),
mero = guess_ab_col(),
mezl = guess_ab_col(),
mino = guess_ab_col(),
moxi = guess_ab_col(),
nali = guess_ab_col(),
neom = guess_ab_col(),
neti = guess_ab_col(),
nitr = guess_ab_col(),
norf = guess_ab_col(),
novo = guess_ab_col(),
oflo = guess_ab_col(),
oxac = guess_ab_col(),
peni = guess_ab_col(),
pipe = guess_ab_col(),
pita = guess_ab_col(),
poly = guess_ab_col(),
pris = guess_ab_col(),
qida = guess_ab_col(),
rifa = guess_ab_col(),
roxi = guess_ab_col(),
siso = guess_ab_col(),
teic = guess_ab_col(),
tetr = guess_ab_col(),
tica = guess_ab_col(),
tige = guess_ab_col(),
tobr = guess_ab_col(),
trim = guess_ab_col(),
trsu = guess_ab_col(),
vanc = guess_ab_col(),
...) {
# support old `tbl` parameter
if ("tbl" %in% names(list(...))) {
x <- list(...)$tbl
}
tbl_ <- x
if (!is.data.frame(tbl_)) {
stop("`tbl_` must be a data frame.", call. = FALSE)
stop("`x` must be a data frame.", call. = FALSE)
}
# try to find columns based on type
@@ -277,7 +209,7 @@ eucast_rules <- function(x,
warned <- FALSE
txt_error <- function() { cat("", bgRed(black(" ERROR ")), "\n") }
txt_error <- function() { cat("", bgRed(white(" ERROR ")), "\n") }
txt_warning <- function() { if (warned == FALSE) { cat("", bgYellow(black(" WARNING ")), "\n") }; warned <<- TRUE }
txt_ok <- function(no_of_changes) {
if (warned == FALSE) {
@@ -294,145 +226,137 @@ eucast_rules <- function(x,
}
}
# check columns
if (identical(amcl, as.name("guess_ab_col"))) { amcl <- guess_ab_col(tbl_, "amcl", verbose = verbose) }
if (identical(amik, as.name("guess_ab_col"))) { amik <- guess_ab_col(tbl_, "amik", verbose = verbose) }
if (identical(amox, as.name("guess_ab_col"))) { amox <- guess_ab_col(tbl_, "amox", verbose = verbose) }
if (identical(ampi, as.name("guess_ab_col"))) { ampi <- guess_ab_col(tbl_, "ampi", verbose = verbose) }
if (identical(azit, as.name("guess_ab_col"))) { azit <- guess_ab_col(tbl_, "azit", verbose = verbose) }
if (identical(azlo, as.name("guess_ab_col"))) { azlo <- guess_ab_col(tbl_, "azlo", verbose = verbose) }
if (identical(aztr, as.name("guess_ab_col"))) { aztr <- guess_ab_col(tbl_, "aztr", verbose = verbose) }
if (identical(cefa, as.name("guess_ab_col"))) { cefa <- guess_ab_col(tbl_, "cefa", verbose = verbose) }
if (identical(cfep, as.name("guess_ab_col"))) { cfep <- guess_ab_col(tbl_, "cfep", verbose = verbose) }
if (identical(cfot, as.name("guess_ab_col"))) { cfot <- guess_ab_col(tbl_, "cfot", verbose = verbose) }
if (identical(cfox, as.name("guess_ab_col"))) { cfox <- guess_ab_col(tbl_, "cfox", verbose = verbose) }
if (identical(cfra, as.name("guess_ab_col"))) { cfra <- guess_ab_col(tbl_, "cfra", verbose = verbose) }
if (identical(cfta, as.name("guess_ab_col"))) { cfta <- guess_ab_col(tbl_, "cfta", verbose = verbose) }
if (identical(cftr, as.name("guess_ab_col"))) { cftr <- guess_ab_col(tbl_, "cftr", verbose = verbose) }
if (identical(cfur, as.name("guess_ab_col"))) { cfur <- guess_ab_col(tbl_, "cfur", verbose = verbose) }
if (identical(chlo, as.name("guess_ab_col"))) { chlo <- guess_ab_col(tbl_, "chlo", verbose = verbose) }
if (identical(cipr, as.name("guess_ab_col"))) { cipr <- guess_ab_col(tbl_, "cipr", verbose = verbose) }
if (identical(clar, as.name("guess_ab_col"))) { clar <- guess_ab_col(tbl_, "clar", verbose = verbose) }
if (identical(clin, as.name("guess_ab_col"))) { clin <- guess_ab_col(tbl_, "clin", verbose = verbose) }
if (identical(clox, as.name("guess_ab_col"))) { clox <- guess_ab_col(tbl_, "clox", verbose = verbose) }
if (identical(coli, as.name("guess_ab_col"))) { coli <- guess_ab_col(tbl_, "coli", verbose = verbose) }
if (identical(czol, as.name("guess_ab_col"))) { czol <- guess_ab_col(tbl_, "czol", verbose = verbose) }
if (identical(dapt, as.name("guess_ab_col"))) { dapt <- guess_ab_col(tbl_, "dapt", verbose = verbose) }
if (identical(doxy, as.name("guess_ab_col"))) { doxy <- guess_ab_col(tbl_, "doxy", verbose = verbose) }
if (identical(erta, as.name("guess_ab_col"))) { erta <- guess_ab_col(tbl_, "erta", verbose = verbose) }
if (identical(eryt, as.name("guess_ab_col"))) { eryt <- guess_ab_col(tbl_, "eryt", verbose = verbose) }
if (identical(fosf, as.name("guess_ab_col"))) { fosf <- guess_ab_col(tbl_, "fosf", verbose = verbose) }
if (identical(fusi, as.name("guess_ab_col"))) { fusi <- guess_ab_col(tbl_, "fusi", verbose = verbose) }
if (identical(gent, as.name("guess_ab_col"))) { gent <- guess_ab_col(tbl_, "gent", verbose = verbose) }
if (identical(imip, as.name("guess_ab_col"))) { imip <- guess_ab_col(tbl_, "imip", verbose = verbose) }
if (identical(kana, as.name("guess_ab_col"))) { kana <- guess_ab_col(tbl_, "kana", verbose = verbose) }
if (identical(levo, as.name("guess_ab_col"))) { levo <- guess_ab_col(tbl_, "levo", verbose = verbose) }
if (identical(linc, as.name("guess_ab_col"))) { linc <- guess_ab_col(tbl_, "linc", verbose = verbose) }
if (identical(line, as.name("guess_ab_col"))) { line <- guess_ab_col(tbl_, "line", verbose = verbose) }
if (identical(mero, as.name("guess_ab_col"))) { mero <- guess_ab_col(tbl_, "mero", verbose = verbose) }
if (identical(mezl, as.name("guess_ab_col"))) { mezl <- guess_ab_col(tbl_, "mezl", verbose = verbose) }
if (identical(mino, as.name("guess_ab_col"))) { mino <- guess_ab_col(tbl_, "mino", verbose = verbose) }
if (identical(moxi, as.name("guess_ab_col"))) { moxi <- guess_ab_col(tbl_, "moxi", verbose = verbose) }
if (identical(nali, as.name("guess_ab_col"))) { nali <- guess_ab_col(tbl_, "nali", verbose = verbose) }
if (identical(neom, as.name("guess_ab_col"))) { neom <- guess_ab_col(tbl_, "neom", verbose = verbose) }
if (identical(neti, as.name("guess_ab_col"))) { neti <- guess_ab_col(tbl_, "neti", verbose = verbose) }
if (identical(nitr, as.name("guess_ab_col"))) { nitr <- guess_ab_col(tbl_, "nitr", verbose = verbose) }
if (identical(norf, as.name("guess_ab_col"))) { norf <- guess_ab_col(tbl_, "norf", verbose = verbose) }
if (identical(novo, as.name("guess_ab_col"))) { novo <- guess_ab_col(tbl_, "novo", verbose = verbose) }
if (identical(oflo, as.name("guess_ab_col"))) { oflo <- guess_ab_col(tbl_, "oflo", verbose = verbose) }
if (identical(oxac, as.name("guess_ab_col"))) { oxac <- guess_ab_col(tbl_, "oxac", verbose = verbose) }
if (identical(peni, as.name("guess_ab_col"))) { peni <- guess_ab_col(tbl_, "peni", verbose = verbose) }
if (identical(pipe, as.name("guess_ab_col"))) { pipe <- guess_ab_col(tbl_, "pipe", verbose = verbose) }
if (identical(pita, as.name("guess_ab_col"))) { pita <- guess_ab_col(tbl_, "pita", verbose = verbose) }
if (identical(poly, as.name("guess_ab_col"))) { poly <- guess_ab_col(tbl_, "poly", verbose = verbose) }
if (identical(pris, as.name("guess_ab_col"))) { pris <- guess_ab_col(tbl_, "pris", verbose = verbose) }
if (identical(qida, as.name("guess_ab_col"))) { qida <- guess_ab_col(tbl_, "qida", verbose = verbose) }
if (identical(rifa, as.name("guess_ab_col"))) { rifa <- guess_ab_col(tbl_, "rifa", verbose = verbose) }
if (identical(roxi, as.name("guess_ab_col"))) { roxi <- guess_ab_col(tbl_, "roxi", verbose = verbose) }
if (identical(siso, as.name("guess_ab_col"))) { siso <- guess_ab_col(tbl_, "siso", verbose = verbose) }
if (identical(teic, as.name("guess_ab_col"))) { teic <- guess_ab_col(tbl_, "teic", verbose = verbose) }
if (identical(tetr, as.name("guess_ab_col"))) { tetr <- guess_ab_col(tbl_, "tetr", verbose = verbose) }
if (identical(tica, as.name("guess_ab_col"))) { tica <- guess_ab_col(tbl_, "tica", verbose = verbose) }
if (identical(tige, as.name("guess_ab_col"))) { tige <- guess_ab_col(tbl_, "tige", verbose = verbose) }
if (identical(tobr, as.name("guess_ab_col"))) { tobr <- guess_ab_col(tbl_, "tobr", verbose = verbose) }
if (identical(trim, as.name("guess_ab_col"))) { trim <- guess_ab_col(tbl_, "trim", verbose = verbose) }
if (identical(trsu, as.name("guess_ab_col"))) { trsu <- guess_ab_col(tbl_, "trsu", verbose = verbose) }
if (identical(vanc, as.name("guess_ab_col"))) { vanc <- guess_ab_col(tbl_, "vanc", verbose = verbose) }
col.list <- c(amcl, amik, amox, ampi, azit, azlo, aztr, cefa, cfra, cfep, cfot,
cfox, cfta, cftr, cfur, chlo, cipr, clar, clin, clox, coli,
czol, dapt, doxy, erta, eryt, fosf, fusi, gent, imip, kana,
levo, linc, line, mero, mezl, mino, moxi, nali, neom, neti, nitr,
novo, norf, oflo, oxac, peni, pipe, pita, poly, pris, qida, rifa,
roxi, siso, teic, tetr, tica, tige, tobr, trim, trsu, vanc)
if (length(col.list) < 63) {
warning('Some columns do not exist -- THIS MAY STRONGLY INFLUENCE THE OUTCOME.',
immediate. = TRUE,
call. = FALSE)
}
col.list <- check_available_columns(tbl = tbl_, col.list = col.list, info = info)
amcl <- col.list[amcl]
amik <- col.list[amik]
amox <- col.list[amox]
ampi <- col.list[ampi]
azit <- col.list[azit]
azlo <- col.list[azlo]
aztr <- col.list[aztr]
cefa <- col.list[cefa]
cfep <- col.list[cfep]
cfot <- col.list[cfot]
cfox <- col.list[cfox]
cfra <- col.list[cfra]
cfta <- col.list[cfta]
cftr <- col.list[cftr]
cfur <- col.list[cfur]
chlo <- col.list[chlo]
cipr <- col.list[cipr]
clar <- col.list[clar]
clin <- col.list[clin]
clox <- col.list[clox]
coli <- col.list[coli]
czol <- col.list[czol]
dapt <- col.list[dapt]
doxy <- col.list[doxy]
erta <- col.list[erta]
eryt <- col.list[eryt]
fosf <- col.list[fosf]
fusi <- col.list[fusi]
gent <- col.list[gent]
imip <- col.list[imip]
kana <- col.list[kana]
levo <- col.list[levo]
linc <- col.list[linc]
line <- col.list[line]
mero <- col.list[mero]
mezl <- col.list[mezl]
mino <- col.list[mino]
moxi <- col.list[moxi]
nali <- col.list[nali]
neom <- col.list[neom]
neti <- col.list[neti]
nitr <- col.list[nitr]
norf <- col.list[norf]
novo <- col.list[novo]
oflo <- col.list[oflo]
oxac <- col.list[oxac]
peni <- col.list[peni]
pipe <- col.list[pipe]
pita <- col.list[pita]
poly <- col.list[poly]
pris <- col.list[pris]
qida <- col.list[qida]
rifa <- col.list[rifa]
roxi <- col.list[roxi]
siso <- col.list[siso]
teic <- col.list[teic]
tetr <- col.list[tetr]
tica <- col.list[tica]
tige <- col.list[tige]
tobr <- col.list[tobr]
trim <- col.list[trim]
trsu <- col.list[trsu]
vanc <- col.list[vanc]
cols_ab <- get_column_abx(tbl = x,
soft_dependencies = c("AMC",
"AMK",
"AMX",
"AMP",
"AZM",
"AZL",
"ATM",
"RID",
"FEP",
"CTX",
"FOX",
"CED",
"CAZ",
"CRO",
"CXM",
"CHL",
"CIP",
"CLR",
"CLI",
"FLC",
"COL",
"CZO",
"DAP",
"DOX",
"ETP",
"ERY",
"FOS",
"FUS",
"GEN",
"IPM",
"KAN",
"LVX",
"LIN",
"LNZ",
"MEM",
"MEZ",
"MNO",
"MFX",
"NAL",
"NEO",
"NET",
"NIT",
"NOR",
"NOV",
"OFX",
"OXA",
"PEN",
"PIP",
"TZP",
"PLB",
"PRI",
"QDA",
"RIF",
"RXT",
"SIS",
"TEC",
"TCY",
"TIC",
"TGC",
"TOB",
"TMP",
"SXT",
"VAN"),
hard_dependencies = NULL,
verbose = verbose,
...)
AMC <- cols_ab['AMC']
AMK <- cols_ab['AMK']
AMP <- cols_ab['AMP']
AMX <- cols_ab['AMX']
ATM <- cols_ab['ATM']
AZL <- cols_ab['AZL']
AZM <- cols_ab['AZM']
CAZ <- cols_ab['CAZ']
CED <- cols_ab['CED']
CHL <- cols_ab['CHL']
CIP <- cols_ab['CIP']
CLI <- cols_ab['CLI']
CLR <- cols_ab['CLR']
COL <- cols_ab['COL']
CRO <- cols_ab['CRO']
CTX <- cols_ab['CTX']
CXM <- cols_ab['CXM']
CZO <- cols_ab['CZO']
DAP <- cols_ab['DAP']
DOX <- cols_ab['DOX']
ERY <- cols_ab['ERY']
ETP <- cols_ab['ETP']
FEP <- cols_ab['FEP']
FLC <- cols_ab['FLC']
FOS <- cols_ab['FOS']
FOX <- cols_ab['FOX']
FUS <- cols_ab['FUS']
GEN <- cols_ab['GEN']
IPM <- cols_ab['IPM']
KAN <- cols_ab['KAN']
LIN <- cols_ab['LIN']
LNZ <- cols_ab['LNZ']
LVX <- cols_ab['LVX']
MEM <- cols_ab['MEM']
MEZ <- cols_ab['MEZ']
MFX <- cols_ab['MFX']
MNO <- cols_ab['MNO']
NAL <- cols_ab['NAL']
NEO <- cols_ab['NEO']
NET <- cols_ab['NET']
NIT <- cols_ab['NIT']
NOR <- cols_ab['NOR']
NOV <- cols_ab['NOV']
OFX <- cols_ab['OFX']
OXA <- cols_ab['OXA']
PEN <- cols_ab['PEN']
PIP <- cols_ab['PIP']
PLB <- cols_ab['PLB']
PRI <- cols_ab['PRI']
QDA <- cols_ab['QDA']
RID <- cols_ab['RID']
RIF <- cols_ab['RIF']
RXT <- cols_ab['RXT']
SIS <- cols_ab['SIS']
SXT <- cols_ab['SXT']
TCY <- cols_ab['TCY']
TEC <- cols_ab['TEC']
TGC <- cols_ab['TGC']
TIC <- cols_ab['TIC']
TMP <- cols_ab['TMP']
TOB <- cols_ab['TOB']
TZP <- cols_ab['TZP']
VAN <- cols_ab['VAN']
ab_missing <- function(ab) {
all(ab %in% c(NULL, NA))
@@ -521,41 +445,41 @@ eucast_rules <- function(x,
}
# since ampicillin ^= amoxicillin, get the first from the latter (not in original EUCAST table)
if (!ab_missing(ampi) & !ab_missing(amox)) {
if (!ab_missing(AMP) & !ab_missing(AMX)) {
if (verbose == TRUE) {
cat("\n VERBOSE: transforming",
length(which(tbl_[, amox] == "S" & !tbl_[, ampi] %in% c("S", "I", "R"))),
length(which(tbl_[, AMX] == "S" & !tbl_[, AMP] %in% c("S", "I", "R"))),
"empty ampicillin fields to 'S' based on amoxicillin. ")
cat("\n VERBOSE: transforming",
length(which(tbl_[, amox] == "I" & !tbl_[, ampi] %in% c("S", "I", "R"))),
length(which(tbl_[, AMX] == "I" & !tbl_[, AMP] %in% c("S", "I", "R"))),
"empty ampicillin fields to 'I' based on amoxicillin. ")
cat("\n VERBOSE: transforming",
length(which(tbl_[, amox] == "R" & !tbl_[, ampi] %in% c("S", "I", "R"))),
length(which(tbl_[, AMX] == "R" & !tbl_[, AMP] %in% c("S", "I", "R"))),
"empty ampicillin fields to 'R' based on amoxicillin. \n")
}
tbl_[which(tbl_[, amox] == "S" & !tbl_[, ampi] %in% c("S", "I", "R")), ampi] <- "S"
tbl_[which(tbl_[, amox] == "I" & !tbl_[, ampi] %in% c("S", "I", "R")), ampi] <- "I"
tbl_[which(tbl_[, amox] == "R" & !tbl_[, ampi] %in% c("S", "I", "R")), ampi] <- "R"
} else if (ab_missing(ampi) & !ab_missing(amox)) {
tbl_[which(tbl_[, AMX] == "S" & !tbl_[, AMP] %in% c("S", "I", "R")), AMP] <- "S"
tbl_[which(tbl_[, AMX] == "I" & !tbl_[, AMP] %in% c("S", "I", "R")), AMP] <- "I"
tbl_[which(tbl_[, AMX] == "R" & !tbl_[, AMP] %in% c("S", "I", "R")), AMP] <- "R"
} else if (ab_missing(AMP) & !ab_missing(AMX)) {
# ampicillin column is missing, but amoxicillin is available
message(blue(paste0("NOTE: Using column `", bold(amox), "` as input for ampicillin (J01CA01) since many EUCAST rules depend on it.")))
ampi <- amox
message(blue(paste0("NOTE: Using column `", bold(AMX), "` as input for ampicillin (J01CA01) since many EUCAST rules depend on it.")))
AMP <- AMX
}
# antibiotic classes
aminoglycosides <- c(tobr, gent, kana, neom, neti, siso)
tetracyclines <- c(doxy, mino, tetr) # since EUCAST v3.1 tige(cycline) is set apart
polymyxins <- c(poly, coli)
macrolides <- c(eryt, azit, roxi, clar) # since EUCAST v3.1 clinda is set apart
glycopeptides <- c(vanc, teic)
streptogramins <- c(qida, pris) # should officially also be quinupristin/dalfopristin
cephalosporins <- c(cfep, cfot, cfox, cfra, cfta, cftr, cfur, czol)
cephalosporins_without_cfta <- cephalosporins[cephalosporins != ifelse(is.null(cfta), "", cfta)]
carbapenems <- c(erta, imip, mero)
aminopenicillins <- c(ampi, amox)
ureidopenicillins <- c(pipe, pita, azlo, mezl)
fluoroquinolones <- c(oflo, cipr, norf, levo, moxi)
all_betalactams <- c(aminopenicillins, ureidopenicillins, cephalosporins, carbapenems, amcl, oxac, clox, peni)
aminoglycosides <- c(TOB, GEN, KAN, NEO, NET, SIS)
tetracyclines <- c(DOX, MNO, TCY) # since EUCAST v3.1 tigecycline (TGC) is set apart
polymyxins <- c(PLB, COL)
macrolides <- c(ERY, AZM, RXT, CLR) # since EUCAST v3.1 clinda is set apart
glycopeptides <- c(VAN, TEC)
streptogramins <- c(QDA, PRI) # should officially also be quinupristin/dalfopristin
aminopenicillins <- c(AMP, AMX)
cephalosporins <- c(FEP, CTX, FOX, CED, CAZ, CRO, CXM, CZO)
cephalosporins_without_CAZ <- cephalosporins[cephalosporins != ifelse(is.null(CAZ), "", CAZ)]
carbapenems <- c(ETP, IPM, MEM)
ureidopenicillins <- c(PIP, TZP, AZL, MEZ)
all_betalactams <- c(aminopenicillins, cephalosporins, carbapenems, ureidopenicillins, AMC, OXA, FLC, PEN)
fluoroquinolones <- c(OFX, CIP, NOR, LVX, MFX)
# Help function to get available antibiotic column names ------------------
get_antibiotic_columns <- function(x, df) {
@@ -578,7 +502,7 @@ eucast_rules <- function(x,
rule_group_current <- eucast_rules_df[i, "reference.rule_group"]
rule_group_next <- eucast_rules_df[min(nrow(eucast_rules_df), i + 1), "reference.rule_group"]
if (is.na(eucast_rules_df[i, 4])) {
rule_text <- paste(eucast_rules_df[i, 6], "=", eucast_rules_df[i, 7])
rule_text <- paste("always:", eucast_rules_df[i, 6], "=", eucast_rules_df[i, 7])
} else {
rule_text <- paste("if", eucast_rules_df[i, 4], "=", eucast_rules_df[i, 5],
"then", eucast_rules_df[i, 6], "=", eucast_rules_df[i, 7])

9
R/filter_ab_class.R
View File

@@ -39,9 +39,9 @@
#' # filter on isolates that have any result for any aminoglycoside
#' septic_patients %>% filter_aminoglycosides()
#'
#' # this is essentially the same as:
#' # this is essentially the same as (but without determination of column names):
#' septic_patients %>%
#' filter_at(.vars = vars(c("gent", "tobr", "amik", "kana")),
#' filter_at(.vars = vars(c("GEN", "TOB", "AMK", "KAN")),
#' .vars_predicate = any_vars(. %in% c("S", "I", "R")))
#'
#'
@@ -264,7 +264,8 @@ filter_tetracyclines <- function(tbl,
ab_class_vars <- function(ab_class) {
ab_vars <- AMR::antibiotics %>%
filter_at(vars(c("atc_group1", "atc_group2")), any_vars(. %like% ab_class)) %>%
select(atc:trade_name) %>%
select(ab:name, abbreviations, synonyms) %>%
unlist() %>%
as.matrix() %>%
as.character() %>%
paste(collapse = "|") %>%
@@ -289,7 +290,7 @@ ab_class_atcgroups <- function(ab_class) {
"tetracycline"),
paste0(ab_class, "s"),
AMR::antibiotics %>%
filter(atc %in% ab_class_vars(ab_class)) %>%
filter(ab %in% ab_class_vars(ab_class)) %>%
pull("atc_group2") %>%
unique() %>%
tolower() %>%

10
R/first_isolate.R
View File

@@ -98,14 +98,14 @@
#' # Now let's see if first isolates matter:
#' A <- septic_patients %>%
#' group_by(hospital_id) %>%
#' summarise(count = n_rsi(gent), # gentamicin availability
#' resistance = portion_IR(gent)) # gentamicin resistance
#' summarise(count = n_rsi(GEN), # gentamicin availability
#' resistance = portion_IR(GEN)) # gentamicin resistance
#'
#' B <- septic_patients %>%
#' filter_first_weighted_isolate() %>% # the 1st isolate filter
#' filter_first_weighted_isolate() %>% # the 1st isolate filter
#' group_by(hospital_id) %>%
#' summarise(count = n_rsi(gent), # gentamicin availability
#' resistance = portion_IR(gent)) # gentamicin resistance
#' summarise(count = n_rsi(GEN), # gentamicin availability
#' resistance = portion_IR(GEN)) # gentamicin resistance
#'
#' # Have a look at A and B.
#' # B is more reliable because every isolate is only counted once.

17
R/freq.R
View File

@@ -181,8 +181,8 @@
#'
#'
#' # check differences between frequency tables
#' diff(freq(septic_patients$trim),
#' freq(septic_patients$trsu))
#' diff(freq(septic_patients$TMP),
#' freq(septic_patients$SXT))
frequency_tbl <- function(x,
...,
sort.count = TRUE,
@@ -419,8 +419,8 @@ frequency_tbl <- function(x,
}
if (any(class(x) == "rsi")) {
header_list$count_S <- max(0, sum(x == "S", na.rm = TRUE), na.rm = TRUE)
header_list$count_IR <- max(0, sum(x %in% c("I", "R"), na.rm = TRUE), na.rm = TRUE)
header_list$count_SI <- max(0, sum(x %in% c("S", "I"), na.rm = TRUE), na.rm = TRUE)
header_list$count_R <- max(0, sum(x == "R", na.rm = TRUE), na.rm = TRUE)
}
formatdates <- "%e %B %Y" # = d mmmm yyyy
@@ -565,14 +565,15 @@ format_header <- function(x, markdown = FALSE, decimal.mark = ".", big.mark = ",
# FORMATTING
# rsi
if (has_length == TRUE & any(x_class == "rsi")) {
ab <- tryCatch(atc_name(attributes(x)$opt$vars), error = function(e) NA)
ab <- tryCatch(as.ab(attributes(x)$opt$vars), error = function(e) NA)
if (!is.na(ab)) {
header$drug <- ab[1L]
header$drug <- paste0(ab_name(ab[1L]), " (", ab[1L], ", ", ab_atc(ab[1L]), ")")
header$group <- ab_group(ab[1L])
}
header$`%IR` <- percent(header$count_IR / (header$count_S + header$count_IR),
header$`%SI` <- percent(header$count_SI / (header$count_SI + header$count_R),
force_zero = TRUE, round = digits, decimal.mark = decimal.mark)
}
header <- header[!names(header) %in% c("count_S", "count_IR")]
header <- header[!names(header) %in% c("count_SI", "count_R")]
# dates
if (!is.null(header$date_format)) {
if (header$date_format == "%H:%M:%S") {

51
R/get_locale.R
View File

@@ -19,20 +19,53 @@
# Visit our website for more info: https://msberends.gitlab.io/AMR. #
# ==================================================================== #
#' Get language for AMR
#' Translate strings from AMR package
#'
#' Determines the system language to be used for language-dependent output of AMR functions, like \code{\link{mo_gramstain}} and \code{\link{mo_type}}.
#' @details The system language can be overwritten with \code{\link{getOption}("AMR_locale")}.
#' @section Supported languages:
#' Supported languages are \code{"en"} (English), \code{"de"} (German), \code{"nl"} (Dutch), \code{"es"} (Spanish), \code{"it"} (Italian), \code{"fr"} (French), and \code{"pt"} (Portuguese).
#' For language-dependent output of AMR functions, like \code{\link{mo_fullname}} and \code{\link{mo_type}}.
#' @details Strings will be translated to foreign languages if they are defined in a local translation file. This file comes with this package and can be found when running:
#'
#' \code{system.file("translations.tsv", package = "AMR")}
#'
#' This file will be read by all functions where a translated output can be desired, like all \code{\link{mo_property}} functions (\code{\link{mo_fullname}}, \code{\link{mo_type}}, etc.). Please suggest your own translations \href{https://gitlab.com/msberends/AMR/issues/new?issue[title]=Translation suggestion}{by creating a new issue on our repository}.
#'
#' The system language will be used at default, if supported, using \code{\link{get_locale}}. The system language can be overwritten with \code{\link{getOption}("AMR_locale")}.
#' @inheritSection AMR Read more on our website!
#' @rdname translate
#' @name translate
#' @export
#' @examples
#' # The 'language' parameter of below functions
#' # will be set automatically to your system language
#' # with get_locale()
#'
#' # English
#' mo_fullname("CoNS", language = "en")
#' #> "Coagulase-negative Staphylococcus (CoNS)"
#'
#' # German
#' mo_fullname("CoNS", language = "de")
#' #> "Koagulase-negative Staphylococcus (KNS)"
#'
#' # Dutch
#' mo_fullname("CoNS", language = "nl")
#' #> "Coagulase-negatieve Staphylococcus (CNS)"
#'
#' # Spanish
#' mo_fullname("CoNS", language = "es")
#' #> "Staphylococcus coagulasa negativo (SCN)"
#'
#' # Italian
#' mo_fullname("CoNS", language = "it")
#' #> "Staphylococcus negativo coagulasi (CoNS)"
#'
#' # Portuguese
#' mo_fullname("CoNS", language = "pt")
#' #> "Staphylococcus coagulase negativo (CoNS)"
get_locale <- function() {
if (!is.null(getOption("AMR_locale"))) {
if (getOption("AMR_locale") %in% c("en", "de", "nl", "es", "it", "fr", "pt")) {
return(getOption("AMR_locale"))
}
if (getOption("AMR_locale", "en") != "en") {
return(getOption("AMR_locale"))
}
lang <- Sys.getlocale("LC_COLLATE")
# grepl with case = FALSE is faster than like
if (grepl("^(English|en_|EN_)", lang, ignore.case = FALSE)) {

31
R/ggplot_rsi.R
View File

@@ -29,14 +29,15 @@
#' @param breaks numeric vector of positions
#' @param limits numeric vector of length two providing limits of the scale, use \code{NA} to refer to the existing minimum or maximum
#' @param facet variable to split plots by, either \code{"Interpretation"} (default) or \code{"Antibiotic"} or a grouping variable
#' @param translate_ab a column name of the \code{\link{antibiotics}} data set to translate the antibiotic abbreviations into, using \code{\link{abname}}. Default behaviour is to translate to official names according to the WHO. Use \code{translate_ab = FALSE} to disable translation.
#' @param translate_ab a column name of the \code{\link{antibiotics}} data set to translate the antibiotic abbreviations into, using \code{\link{ab_name}}. Default behaviour is to translate to official names according to the WHO. Use \code{translate_ab = FALSE} to disable translation.
#' @param language the language used for translation of antibiotic names
#' @param fun function to transform \code{data}, either \code{\link{count_df}} (default) or \code{\link{portion_df}}
#' @param nrow (when using \code{facet}) number of rows
#' @param datalabels show datalabels using \code{labels_rsi_count}, will at default only be shown when \code{fun = count_df}
#' @param datalabels.size size of the datalabels
#' @param datalabels.colour colour of the datalabels
#' @param ... other parameters passed on to \code{geom_rsi}
#' @details At default, the names of antibiotics will be shown on the plots using \code{\link{abname}}. This can be set with the option \code{get_antibiotic_names} (a logical value), so change it e.g. to \code{FALSE} with \code{options(get_antibiotic_names = FALSE)}.
#' @details At default, the names of antibiotics will be shown on the plots using \code{\link{ab_name}}. This can be set with the option \code{get_antibiotic_names} (a logical value), so change it e.g. to \code{FALSE} with \code{options(get_antibiotic_names = FALSE)}.
#'
#' \strong{The functions}\cr
#' \code{geom_rsi} will take any variable from the data that has an \code{rsi} class (created with \code{\link{as.rsi}}) using \code{fun} (\code{\link{count_df}} at default, can also be \code{\link{portion_df}}) and will plot bars with the percentage R, I and S. The default behaviour is to have the bars stacked and to have the different antibiotics on the x axis.
@@ -61,11 +62,11 @@
#' library(ggplot2)
#'
#' # get antimicrobial results for drugs against a UTI:
#' ggplot(septic_patients %>% select(amox, nitr, fosf, trim, cipr)) +
#' ggplot(septic_patients %>% select(AMX, NIT, FOS, TMP, CIP)) +
#' geom_rsi()
#'
#' # prettify the plot using some additional functions:
#' df <- septic_patients[, c("amox", "nitr", "fosf", "trim", "cipr")]
#' df <- septic_patients[, c("AMX", "NIT", "FOS", "TMP", "CIP")]
#' ggplot(df) +
#' geom_rsi() +
#' scale_y_percent() +
@@ -75,17 +76,17 @@
#'
#' # or better yet, simplify this using the wrapper function - a single command:
#' septic_patients %>%
#' select(amox, nitr, fosf, trim, cipr) %>%
#' select(AMX, NIT, FOS, TMP, CIP) %>%
#' ggplot_rsi()
#'
#' # get only portions and no counts:
#' septic_patients %>%
#' select(amox, nitr, fosf, trim, cipr) %>%
#' select(AMX, NIT, FOS, TMP, CIP) %>%
#' ggplot_rsi(fun = portion_df)
#'
#' # add other ggplot2 parameters as you like:
#' septic_patients %>%
#' select(amox, nitr, fosf, trim, cipr) %>%
#' select(AMX, NIT, FOS, TMP, CIP) %>%
#' ggplot_rsi(width = 0.5,
#' colour = "black",
#' size = 1,
@@ -100,19 +101,19 @@
#' # `age_group` is also a function of this package:
#' group_by(age_group = age_groups(age)) %>%
#' select(age_group,
#' cipr) %>%
#' CIP) %>%
#' ggplot_rsi(x = "age_group")
#' \donttest{
#'
#' # for colourblind mode, use divergent colours from the viridis package:
#' septic_patients %>%
#' select(amox, nitr, fosf, trim, cipr) %>%
#' select(AMX, NIT, FOS, TMP, CIP) %>%
#' ggplot_rsi() + scale_fill_viridis_d()
#'
#'
#' # it also supports groups (don't forget to use the group var on `x` or `facet`):
#' septic_patients %>%
#' select(hospital_id, amox, nitr, fosf, trim, cipr) %>%
#' select(hospital_id, AMX, NIT, FOS, TMP, CIP) %>%
#' group_by(hospital_id) %>%
#' ggplot_rsi(x = hospital_id,
#' facet = Antibiotic,
@@ -136,7 +137,7 @@
#' # get short MO names (like "E. coli")
#' mutate(mo = mo_shortname(mo, Becker = TRUE)) %>%
#' # select this short name and some antiseptic drugs
#' select(mo, cfur, gent, cipr) %>%
#' select(mo, CXM, GEN, CIP) %>%
#' # group by MO
#' group_by(mo) %>%
#' # plot the thing, putting MOs on the facet
@@ -156,7 +157,8 @@ ggplot_rsi <- function(data,
facet = NULL,
breaks = seq(0, 1, 0.1),
limits = NULL,
translate_ab = "official",
translate_ab = "name",
language = get_locale(),
fun = count_df,
nrow = NULL,
datalabels = TRUE,
@@ -229,7 +231,8 @@ ggplot_rsi <- function(data,
geom_rsi <- function(position = NULL,
x = c("Antibiotic", "Interpretation"),
fill = "Interpretation",
translate_ab = "official",
translate_ab = "name",
language = get_locale(),
fun = count_df,
...) {
@@ -267,8 +270,6 @@ geom_rsi <- function(position = NULL,
x <- "Interpretation"
}
options(get_antibiotic_names = translate_ab)
ggplot2::layer(geom = "bar", stat = "identity", position = position,
mapping = ggplot2::aes_string(x = x, y = y, fill = fill),
data = fun, params = list(...))

10
R/globals.R
View File

@@ -21,13 +21,14 @@
globalVariables(c(".",
"..property",
"ab",
"abbreviations",
"antibiotic",
"Antibiotic",
"antibiotics",
"atc",
"authors",
"Becker",
"certe",
"CNS_CPS",
"cnt",
"col_id",
@@ -56,8 +57,10 @@ globalVariables(c(".",
"kingdom",
"labs",
"Lancefield",
"lang",
"Last name",
"lbl",
"lookup",
"median",
"mic",
"microorganisms",
@@ -70,6 +73,7 @@ globalVariables(c(".",
"mo",
"mo.old",
"more_than_episode_ago",
"MPM",
"n",
"name",
"new",
@@ -92,6 +96,7 @@ globalVariables(c(".",
"ref",
"reference.rule",
"reference.rule_group",
"rsi",
"rule_group",
"rule_name",
"S",
@@ -103,12 +108,13 @@ globalVariables(c(".",
"species",
"species_id",
"subspecies",
"synonyms",
"trade_name",
"trans",
"transmute",
"tsn",
"tsn_new",
"txt",
"umcg",
"value",
"Value",
"x",

96
R/guess_ab_col.R
View File

@@ -35,7 +35,7 @@
#'
#' guess_ab_col(df, "amoxicillin")
#' # [1] "amox"
#' guess_ab_col(df, "J01AA07") # ATC code of Tetracycline
#' guess_ab_col(df, "J01AA07") # ATC code of tetracycline
#' # [1] "tetr"
#'
#' guess_ab_col(df, "J01AA07", verbose = TRUE)
@@ -49,7 +49,7 @@
#' # [1] "AMP_ND10"
#' guess_ab_col(df, "J01CR02")
#' # [1] "AMC_ED20"
#' guess_ab_col(df, as.atc("augmentin"))
#' guess_ab_col(df, as.ab("augmentin"))
#' # [1] "AMC_ED20"
guess_ab_col <- function(tbl = NULL, col = NULL, verbose = FALSE) {
if (is.null(tbl) & is.null(col)) {
@@ -60,77 +60,21 @@ guess_ab_col <- function(tbl = NULL, col = NULL, verbose = FALSE) {
warning("argument 'col' has length > 1 and only the first element will be used")
col <- col[1]
}
col <- as.character(col)
if (!is.data.frame(tbl)) {
stop("`tbl` must be a data.frame")
}
tbl_names <- colnames(tbl)
tbl_names_stripped <- colnames(tbl) %>%
strsplit("_") %>%
lapply(function(x) {x[1]}) %>%
unlist()
if (col %in% tbl_names) {
if (verbose == TRUE) {
message(blue(paste0("NOTE: Using column `", bold(col), "` as input for `", col, "`.")))
}
return(col)
}
ab_result <- antibiotics %>%
select(atc:trade_name) %>%
filter_all(any_vars(tolower(.) == tolower(col))) %>%
filter_all(any_vars(. %in% tbl_names))
if (nrow(ab_result) == 0 & nchar(col) >= 5) {
# use like when col >= 5 characters
ab_result <- antibiotics %>%
select(atc:trade_name) %>%
filter_all(any_vars(tolower(.) %like% tolower(col))) %>%
filter_all(any_vars(. %in% tbl_names))
}
# WHONET
if (nrow(ab_result) == 0) {
# use like for any case
ab_result <- antibiotics %>%
select(atc:trade_name) %>%
filter_all(any_vars(tolower(.) == tolower(col))) %>%
filter_all(any_vars(. %in% tbl_names_stripped))
}
found_based_on_official_name <- FALSE
if (nrow(ab_result) == 0) {
# check if first part of official name resembles the columns that's been looking for
name <- suppressWarnings(atc_name(col))
if (!is.null(name)) {
ab_result <-
antibiotics %>%
filter(official == name) %>%
pull(official)
ab_result <- tbl_names[tbl_names %like% paste0("^", substr(ab_result, 1, 5))]
found_based_on_official_name <- TRUE
}
}
if (NROW(ab_result) > 1 & found_based_on_official_name == FALSE) {
# looking more and more for reliable hit
ab_result_1 <- ab_result %>% filter(tolower(atc) == tolower(col))
if (nrow(ab_result_1) == 0) {
ab_result_1 <- ab_result %>% filter(tolower(certe) == tolower(col))
}
if (nrow(ab_result_1) == 0) {
ab_result_1 <- ab_result %>% filter(tolower(umcg) == tolower(col))
}
if (nrow(ab_result_1) == 0) {
ab_result_1 <- ab_result %>% filter(tolower(official) == tolower(col))
}
if (nrow(ab_result_1) == 0) {
ab_result_1 <- ab_result %>% filter(tolower(official) == tolower(col))
}
if (nrow(ab_result_1) == 0) {
ab_result_1 <- ab_result[1, ]
}
ab_result <- ab_result_1
if (col %in% colnames(tbl)) {
ab_result <- col
} else {
# sort colnames on length - longest first
cols <- colnames(tbl[, tbl %>% colnames() %>% nchar() %>% order() %>% rev()])
df_trans <- data.frame(cols = cols,
abs = suppressWarnings(as.ab(cols)),
stringsAsFactors = FALSE)
ab_result <- df_trans[which(df_trans$abs == as.ab(col)), "cols"]
ab_result <- ab_result[!is.na(ab_result)][1L]
}
if (length(ab_result) == 0) {
@@ -139,19 +83,9 @@ guess_ab_col <- function(tbl = NULL, col = NULL, verbose = FALSE) {
}
return(NULL)
} else {
result <- tbl_names[tbl_names %in% ab_result]
if (length(result) == 0) {
result <- tbl_names[tbl_names_stripped %in% ab_result]
}
if (length(result) == 0 | length(result) > 1) {
if (verbose == TRUE) {
message('No column found as input for `', col, '`.')
}
return(NULL)
}
if (verbose == TRUE) {
message(blue(paste0("NOTE: Using column `", bold(result), "` as input for `", col, "`.")))
message(blue(paste0("NOTE: Using column `", bold(ab_result), "` as input for `", col, "`.")))
}
return(result)
return(ab_result)
}
}

73
R/key_antibiotics.R
View File

@@ -78,24 +78,24 @@
#' # FALSE, because I is not ignored and so the 4th value differs
key_antibiotics <- function(tbl,
col_mo = NULL,
universal_1 = guess_ab_col(tbl, "amox"),
universal_2 = guess_ab_col(tbl, "amcl"),
universal_3 = guess_ab_col(tbl, "cfur"),
universal_4 = guess_ab_col(tbl, "pita"),
universal_5 = guess_ab_col(tbl, "cipr"),
universal_6 = guess_ab_col(tbl, "trsu"),
GramPos_1 = guess_ab_col(tbl, "vanc"),
GramPos_2 = guess_ab_col(tbl, "teic"),
GramPos_3 = guess_ab_col(tbl, "tetr"),
GramPos_4 = guess_ab_col(tbl, "eryt"),
GramPos_5 = guess_ab_col(tbl, "oxac"),
GramPos_6 = guess_ab_col(tbl, "rifa"),
GramNeg_1 = guess_ab_col(tbl, "gent"),
GramNeg_2 = guess_ab_col(tbl, "tobr"),
GramNeg_3 = guess_ab_col(tbl, "coli"),
GramNeg_4 = guess_ab_col(tbl, "cfot"),
GramNeg_5 = guess_ab_col(tbl, "cfta"),
GramNeg_6 = guess_ab_col(tbl, "mero"),
universal_1 = guess_ab_col(tbl, "AMX"),
universal_2 = guess_ab_col(tbl, "AMC"),
universal_3 = guess_ab_col(tbl, "CXM"),
universal_4 = guess_ab_col(tbl, "TZP"),
universal_5 = guess_ab_col(tbl, "CIP"),
universal_6 = guess_ab_col(tbl, "SXT"),
GramPos_1 = guess_ab_col(tbl, "VAN"),
GramPos_2 = guess_ab_col(tbl, "TEC"),
GramPos_3 = guess_ab_col(tbl, "TCY"),
GramPos_4 = guess_ab_col(tbl, "ERY"),
GramPos_5 = guess_ab_col(tbl, "OXA"),
GramPos_6 = guess_ab_col(tbl, "RIF"),
GramNeg_1 = guess_ab_col(tbl, "GEN"),
GramNeg_2 = guess_ab_col(tbl, "TOB"),
GramNeg_3 = guess_ab_col(tbl, "COL"),
GramNeg_4 = guess_ab_col(tbl, "CTX"),
GramNeg_5 = guess_ab_col(tbl, "CAZ"),
GramNeg_6 = guess_ab_col(tbl, "MEM"),
warnings = TRUE,
...) {
@@ -112,6 +112,35 @@ key_antibiotics <- function(tbl,
col.list <- c(universal_1, universal_2, universal_3, universal_4, universal_5, universal_6,
GramPos_1, GramPos_2, GramPos_3, GramPos_4, GramPos_5, GramPos_6,
GramNeg_1, GramNeg_2, GramNeg_3, GramNeg_4, GramNeg_5, GramNeg_6)
check_available_columns <- function(tbl, col.list, info = TRUE) {
# check columns
col.list <- col.list[!is.na(col.list) & !is.null(col.list)]
names(col.list) <- col.list
col.list.bak <- col.list
# are they available as upper case or lower case then?
for (i in 1:length(col.list)) {
if (is.null(col.list[i]) | isTRUE(is.na(col.list[i]))) {
col.list[i] <- NA
} else if (toupper(col.list[i]) %in% colnames(tbl)) {
col.list[i] <- toupper(col.list[i])
} else if (tolower(col.list[i]) %in% colnames(tbl)) {
col.list[i] <- tolower(col.list[i])
} else if (!col.list[i] %in% colnames(tbl)) {
col.list[i] <- NA
}
}
if (!all(col.list %in% colnames(tbl))) {
if (info == TRUE) {
warning('Some columns do not exist and will be ignored: ',
col.list.bak[!(col.list %in% colnames(tbl))] %>% toString(),
'.\nTHIS MAY STRONGLY INFLUENCE THE OUTCOME.',
immediate. = TRUE,
call. = FALSE)
}
}
col.list
}
col.list <- check_available_columns(tbl = tbl, col.list = col.list, info = warnings)
universal_1 <- col.list[universal_1]
universal_2 <- col.list[universal_2]
@@ -139,11 +168,19 @@ key_antibiotics <- function(tbl,
GramPos_1, GramPos_2, GramPos_3,
GramPos_4, GramPos_5, GramPos_6)
gram_positive <- gram_positive[!is.null(gram_positive)]
gram_positive <- gram_positive[!is.na(gram_positive)]
if (length(gram_positive) < 12) {
warning("only using ", length(gram_positive), " different antibiotics as key antibiotics for Gram positives. See ?key_antibiotics.", call. = FALSE)
}
gram_negative = c(universal,
GramNeg_1, GramNeg_2, GramNeg_3,
GramNeg_4, GramNeg_5, GramNeg_6)
gram_negative <- gram_negative[!is.null(gram_negative)]
gram_negative <- gram_negative[!is.na(gram_negative)]
if (length(gram_negative) < 12) {
warning("only using ", length(gram_negative), " different antibiotics as key antibiotics for Gram negatives. See ?key_antibiotics.", call. = FALSE)
}
# join to microorganisms data set
tbl <- tbl %>%

463
R/mdro.R
View File

@@ -22,13 +22,11 @@
#' Determine multidrug-resistant organisms (MDRO)
#'
#' Determine which isolates are multidrug-resistant organisms (MDRO) according to country-specific guidelines.
#' @param tbl table with antibiotic columns, like e.g. \code{amox} and \code{amcl}
#' @param x table with antibiotic columns, like e.g. \code{AMX} and \code{AMC}
#' @param country country code to determine guidelines. EUCAST rules will be used when left empty, see Details. Should be or a code from the \href{https://en.wikipedia.org/wiki/ISO_3166-1_alpha-2#Officially_assigned_code_elements}{list of ISO 3166-1 alpha-2 country codes}. Case-insensitive. Currently supported are \code{de} (Germany) and \code{nl} (the Netherlands).
#' @param info print progress
#' @inheritParams eucast_rules
#' @param metr column name of an antibiotic, see Antibiotics
#' @param verbose print additional info: missing antibiotic columns per parameter
#' @param ... parameters that are passed on to methods
#' @inheritSection eucast_rules Antibiotics
#' @details When \code{country} will be left blank, guidelines will be taken from EUCAST Expert Rules Version 3.1 "Intrinsic Resistance and Exceptional Phenotypes Tables" (\href{http://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/Expert_rules_intrinsic_exceptional_V3.1.pdf}{link}).
#' @return Ordered factor with levels \code{Negative < Positive, unconfirmed < Positive}.
@@ -43,86 +41,28 @@
#' septic_patients %>%
#' mutate(EUCAST = mdro(.),
#' BRMO = brmo(.))
mdro <- function(tbl,
mdro <- function(x,
country = NULL,
col_mo = NULL,
info = TRUE,
amcl = guess_ab_col(),
amik = guess_ab_col(),
amox = guess_ab_col(),
ampi = guess_ab_col(),
azit = guess_ab_col(),
aztr = guess_ab_col(),
cefa = guess_ab_col(),
cfra = guess_ab_col(),
cfep = guess_ab_col(),
cfot = guess_ab_col(),
cfox = guess_ab_col(),
cfta = guess_ab_col(),
cftr = guess_ab_col(),
cfur = guess_ab_col(),
chlo = guess_ab_col(),
cipr = guess_ab_col(),
clar = guess_ab_col(),
clin = guess_ab_col(),
clox = guess_ab_col(),
coli = guess_ab_col(),
czol = guess_ab_col(),
dapt = guess_ab_col(),
doxy = guess_ab_col(),
erta = guess_ab_col(),
eryt = guess_ab_col(),
fosf = guess_ab_col(),
fusi = guess_ab_col(),
gent = guess_ab_col(),
imip = guess_ab_col(),
kana = guess_ab_col(),
levo = guess_ab_col(),
linc = guess_ab_col(),
line = guess_ab_col(),
mero = guess_ab_col(),
metr = guess_ab_col(),
mino = guess_ab_col(),
moxi = guess_ab_col(),
nali = guess_ab_col(),
neom = guess_ab_col(),
neti = guess_ab_col(),
nitr = guess_ab_col(),
novo = guess_ab_col(),
norf = guess_ab_col(),
oflo = guess_ab_col(),
peni = guess_ab_col(),
pipe = guess_ab_col(),
pita = guess_ab_col(),
poly = guess_ab_col(),
qida = guess_ab_col(),
rifa = guess_ab_col(),
roxi = guess_ab_col(),
siso = guess_ab_col(),
teic = guess_ab_col(),
tetr = guess_ab_col(),
tica = guess_ab_col(),
tige = guess_ab_col(),
tobr = guess_ab_col(),
trim = guess_ab_col(),
trsu = guess_ab_col(),
vanc = guess_ab_col(),
verbose = FALSE) {
verbose = FALSE,
...) {
if (!is.data.frame(tbl)) {
stop("`tbl` must be a data frame.", call. = FALSE)
tbl_ <- x
if (!is.data.frame(tbl_)) {
stop("`x` must be a data frame.", call. = FALSE)
}
# try to find columns based on type
# -- mo
if (is.null(col_mo)) {
col_mo <- search_type_in_df(tbl = tbl, type = "mo")
col_mo <- search_type_in_df(tbl = tbl_, type = "mo")
}
if (is.null(col_mo)) {
stop("`col_mo` must be set.", call. = FALSE)
}
# strip whitespaces
if (length(country) > 1) {
stop('`country` must be a length one character string.', call. = FALSE)
}
@@ -169,169 +109,105 @@ mdro <- function(tbl,
"\n", sep = "")
}
# check columns
if (identical(amcl, as.name("guess_ab_col"))) { amcl <- guess_ab_col(tbl, "amcl", verbose = verbose) }
if (identical(amik, as.name("guess_ab_col"))) { amik <- guess_ab_col(tbl, "amik", verbose = verbose) }
if (identical(amox, as.name("guess_ab_col"))) { amox <- guess_ab_col(tbl, "amox", verbose = verbose) }
if (identical(ampi, as.name("guess_ab_col"))) { ampi <- guess_ab_col(tbl, "ampi", verbose = verbose) }
if (identical(azit, as.name("guess_ab_col"))) { azit <- guess_ab_col(tbl, "azit", verbose = verbose) }
if (identical(aztr, as.name("guess_ab_col"))) { aztr <- guess_ab_col(tbl, "aztr", verbose = verbose) }
if (identical(cefa, as.name("guess_ab_col"))) { cefa <- guess_ab_col(tbl, "cefa", verbose = verbose) }
if (identical(cfra, as.name("guess_ab_col"))) { cfra <- guess_ab_col(tbl, "cfra", verbose = verbose) }
if (identical(cfep, as.name("guess_ab_col"))) { cfep <- guess_ab_col(tbl, "cfep", verbose = verbose) }
if (identical(cfot, as.name("guess_ab_col"))) { cfot <- guess_ab_col(tbl, "cfot", verbose = verbose) }
if (identical(cfox, as.name("guess_ab_col"))) { cfox <- guess_ab_col(tbl, "cfox", verbose = verbose) }
if (identical(cfta, as.name("guess_ab_col"))) { cfta <- guess_ab_col(tbl, "cfta", verbose = verbose) }
if (identical(cftr, as.name("guess_ab_col"))) { cftr <- guess_ab_col(tbl, "cftr", verbose = verbose) }
if (identical(cfur, as.name("guess_ab_col"))) { cfur <- guess_ab_col(tbl, "cfur", verbose = verbose) }
if (identical(chlo, as.name("guess_ab_col"))) { chlo <- guess_ab_col(tbl, "chlo", verbose = verbose) }
if (identical(cipr, as.name("guess_ab_col"))) { cipr <- guess_ab_col(tbl, "cipr", verbose = verbose) }
if (identical(clar, as.name("guess_ab_col"))) { clar <- guess_ab_col(tbl, "clar", verbose = verbose) }
if (identical(clin, as.name("guess_ab_col"))) { clin <- guess_ab_col(tbl, "clin", verbose = verbose) }
if (identical(clox, as.name("guess_ab_col"))) { clox <- guess_ab_col(tbl, "clox", verbose = verbose) }
if (identical(coli, as.name("guess_ab_col"))) { coli <- guess_ab_col(tbl, "coli", verbose = verbose) }
if (identical(czol, as.name("guess_ab_col"))) { czol <- guess_ab_col(tbl, "czol", verbose = verbose) }
if (identical(dapt, as.name("guess_ab_col"))) { dapt <- guess_ab_col(tbl, "dapt", verbose = verbose) }
if (identical(doxy, as.name("guess_ab_col"))) { doxy <- guess_ab_col(tbl, "doxy", verbose = verbose) }
if (identical(erta, as.name("guess_ab_col"))) { erta <- guess_ab_col(tbl, "erta", verbose = verbose) }
if (identical(eryt, as.name("guess_ab_col"))) { eryt <- guess_ab_col(tbl, "eryt", verbose = verbose) }
if (identical(fosf, as.name("guess_ab_col"))) { fosf <- guess_ab_col(tbl, "fosf", verbose = verbose) }
if (identical(fusi, as.name("guess_ab_col"))) { fusi <- guess_ab_col(tbl, "fusi", verbose = verbose) }
if (identical(gent, as.name("guess_ab_col"))) { gent <- guess_ab_col(tbl, "gent", verbose = verbose) }
if (identical(imip, as.name("guess_ab_col"))) { imip <- guess_ab_col(tbl, "imip", verbose = verbose) }
if (identical(kana, as.name("guess_ab_col"))) { kana <- guess_ab_col(tbl, "kana", verbose = verbose) }
if (identical(levo, as.name("guess_ab_col"))) { levo <- guess_ab_col(tbl, "levo", verbose = verbose) }
if (identical(linc, as.name("guess_ab_col"))) { linc <- guess_ab_col(tbl, "linc", verbose = verbose) }
if (identical(line, as.name("guess_ab_col"))) { line <- guess_ab_col(tbl, "line", verbose = verbose) }
if (identical(mero, as.name("guess_ab_col"))) { mero <- guess_ab_col(tbl, "mero", verbose = verbose) }
if (identical(metr, as.name("guess_ab_col"))) { metr <- guess_ab_col(tbl, "metr", verbose = verbose) }
if (identical(mino, as.name("guess_ab_col"))) { mino <- guess_ab_col(tbl, "mino", verbose = verbose) }
if (identical(moxi, as.name("guess_ab_col"))) { moxi <- guess_ab_col(tbl, "moxi", verbose = verbose) }
if (identical(nali, as.name("guess_ab_col"))) { nali <- guess_ab_col(tbl, "nali", verbose = verbose) }
if (identical(neom, as.name("guess_ab_col"))) { neom <- guess_ab_col(tbl, "neom", verbose = verbose) }
if (identical(neti, as.name("guess_ab_col"))) { neti <- guess_ab_col(tbl, "neti", verbose = verbose) }
if (identical(nitr, as.name("guess_ab_col"))) { nitr <- guess_ab_col(tbl, "nitr", verbose = verbose) }
if (identical(novo, as.name("guess_ab_col"))) { novo <- guess_ab_col(tbl, "novo", verbose = verbose) }
if (identical(norf, as.name("guess_ab_col"))) { norf <- guess_ab_col(tbl, "norf", verbose = verbose) }
if (identical(oflo, as.name("guess_ab_col"))) { oflo <- guess_ab_col(tbl, "oflo", verbose = verbose) }
if (identical(peni, as.name("guess_ab_col"))) { peni <- guess_ab_col(tbl, "peni", verbose = verbose) }
if (identical(pipe, as.name("guess_ab_col"))) { pipe <- guess_ab_col(tbl, "pipe", verbose = verbose) }
if (identical(pita, as.name("guess_ab_col"))) { pita <- guess_ab_col(tbl, "pita", verbose = verbose) }
if (identical(poly, as.name("guess_ab_col"))) { poly <- guess_ab_col(tbl, "poly", verbose = verbose) }
if (identical(qida, as.name("guess_ab_col"))) { qida <- guess_ab_col(tbl, "qida", verbose = verbose) }
if (identical(rifa, as.name("guess_ab_col"))) { rifa <- guess_ab_col(tbl, "rifa", verbose = verbose) }
if (identical(roxi, as.name("guess_ab_col"))) { roxi <- guess_ab_col(tbl, "roxi", verbose = verbose) }
if (identical(siso, as.name("guess_ab_col"))) { siso <- guess_ab_col(tbl, "siso", verbose = verbose) }
if (identical(teic, as.name("guess_ab_col"))) { teic <- guess_ab_col(tbl, "teic", verbose = verbose) }
if (identical(tetr, as.name("guess_ab_col"))) { tetr <- guess_ab_col(tbl, "tetr", verbose = verbose) }
if (identical(tica, as.name("guess_ab_col"))) { tica <- guess_ab_col(tbl, "tica", verbose = verbose) }
if (identical(tige, as.name("guess_ab_col"))) { tige <- guess_ab_col(tbl, "tige", verbose = verbose) }
if (identical(tobr, as.name("guess_ab_col"))) { tobr <- guess_ab_col(tbl, "tobr", verbose = verbose) }
if (identical(trim, as.name("guess_ab_col"))) { trim <- guess_ab_col(tbl, "trim", verbose = verbose) }
if (identical(trsu, as.name("guess_ab_col"))) { trsu <- guess_ab_col(tbl, "trsu", verbose = verbose) }
if (identical(vanc, as.name("guess_ab_col"))) { vanc <- guess_ab_col(tbl, "vanc", verbose = verbose) }
col.list <- c(amcl, amik, amox, ampi, azit, aztr, cefa, cfra, cfep, cfot,
cfox, cfta, cftr, cfur, chlo, cipr, clar, clin, clox, coli,
czol, dapt, doxy, erta, eryt, fosf, fusi, gent, imip, kana,
levo, linc, line, mero, metr, mino, moxi, nali, neom, neti,
nitr, novo, norf, oflo, peni, pipe, pita, poly, qida, rifa,
roxi, siso, teic, tetr, tica, tige, tobr, trim, trsu, vanc)
if (length(col.list) < 60) {
warning('Some columns do not exist -- THIS MAY STRONGLY INFLUENCE THE OUTCOME.',
immediate. = TRUE,
call. = FALSE)
}
col.list <- check_available_columns(tbl = tbl, col.list = col.list, info = info)
amcl <- col.list[amcl]
amik <- col.list[amik]
amox <- col.list[amox]
ampi <- col.list[ampi]
azit <- col.list[azit]
aztr <- col.list[aztr]
cefa <- col.list[cefa]
cfra <- col.list[cfra]
cfep <- col.list[cfep]
cfot <- col.list[cfot]
cfox <- col.list[cfox]
cfta <- col.list[cfta]
cftr <- col.list[cftr]
cfur <- col.list[cfur]
chlo <- col.list[chlo]
cipr <- col.list[cipr]
clar <- col.list[clar]
clin <- col.list[clin]
clox <- col.list[clox]
coli <- col.list[coli]
czol <- col.list[czol]
dapt <- col.list[dapt]
doxy <- col.list[doxy]
erta <- col.list[erta]
eryt <- col.list[eryt]
fosf <- col.list[fosf]
fusi <- col.list[fusi]
gent <- col.list[gent]
imip <- col.list[imip]
kana <- col.list[kana]
levo <- col.list[levo]
linc <- col.list[linc]
line <- col.list[line]
mero <- col.list[mero]
metr <- col.list[metr]
mino <- col.list[mino]
moxi <- col.list[moxi]
nali <- col.list[nali]
neom <- col.list[neom]
neti <- col.list[neti]
nitr <- col.list[nitr]
novo <- col.list[novo]
norf <- col.list[norf]
oflo <- col.list[oflo]
peni <- col.list[peni]
pipe <- col.list[pipe]
pita <- col.list[pita]
poly <- col.list[poly]
qida <- col.list[qida]
rifa <- col.list[rifa]
roxi <- col.list[roxi]
siso <- col.list[siso]
teic <- col.list[teic]
tetr <- col.list[tetr]
tica <- col.list[tica]
tige <- col.list[tige]
tobr <- col.list[tobr]
trim <- col.list[trim]
trsu <- col.list[trsu]
vanc <- col.list[vanc]
cols_ab <- get_column_abx(tbl = x,
...)
AMC <- cols_ab['AMC']
AMK <- cols_ab['AMK']
AMP <- cols_ab['AMP']
AMX <- cols_ab['AMX']
ATM <- cols_ab['ATM']
AZL <- cols_ab['AZL']
AZM <- cols_ab['AZM']
CAZ <- cols_ab['CAZ']
CED <- cols_ab['CED']
CHL <- cols_ab['CHL']
CIP <- cols_ab['CIP']
CLI <- cols_ab['CLI']
CLR <- cols_ab['CLR']
COL <- cols_ab['COL']
CRO <- cols_ab['CRO']
CTX <- cols_ab['CTX']
CXM <- cols_ab['CXM']
CZO <- cols_ab['CZO']
DAP <- cols_ab['DAP']
DOX <- cols_ab['DOX']
ERY <- cols_ab['ERY']
ETP <- cols_ab['ETP']
FEP <- cols_ab['FEP']
FLC <- cols_ab['FLC']
FOS <- cols_ab['FOS']
FOX <- cols_ab['FOX']
FUS <- cols_ab['FUS']
GEN <- cols_ab['GEN']
IPM <- cols_ab['IPM']
KAN <- cols_ab['KAN']
LIN <- cols_ab['LIN']
LNZ <- cols_ab['LNZ']
LVX <- cols_ab['LVX']
MEM <- cols_ab['MEM']
MEZ <- cols_ab['MEZ']
MTR <- cols_ab['MTR']
MFX <- cols_ab['MFX']
MNO <- cols_ab['MNO']
NAL <- cols_ab['NAL']
NEO <- cols_ab['NEO']
NET <- cols_ab['NET']
NIT <- cols_ab['NIT']
NOR <- cols_ab['NOR']
NOV <- cols_ab['NOV']
OFX <- cols_ab['OFX']
PEN <- cols_ab['PEN']
PIP <- cols_ab['PIP']
PLB <- cols_ab['PLB']
PRI <- cols_ab['PRI']
QDA <- cols_ab['QDA']
RID <- cols_ab['RID']
RIF <- cols_ab['RIF']
RXT <- cols_ab['RXT']
SIS <- cols_ab['SIS']
SXT <- cols_ab['SXT']
TCY <- cols_ab['TCY']
TEC <- cols_ab['TEC']
TGC <- cols_ab['TGC']
TIC <- cols_ab['TIC']
TMP <- cols_ab['TMP']
TOB <- cols_ab['TOB']
TZP <- cols_ab['TZP']
VAN <- cols_ab['VAN']
ab_missing <- function(ab) {
isTRUE(ab %in% c(NULL, NA)) | length(ab) == 0
}
# antibiotic classes
aminoglycosides <- c(tobr, gent) # can also be kana but that one is often intrinsic R
cephalosporins <- c(cfep, cfot, cfox, cfra, cfta, cftr, cfur, czol)
cephalosporins_3rd <- c(cfot, cftr, cfta)
carbapenems <- c(erta, imip, mero)
fluoroquinolones <- c(oflo, cipr, levo, moxi)
aminoglycosides <- c(TOB, GEN)
cephalosporins <- c(FEP, CTX, FOX, CED, CAZ, CRO, CXM, CZO)
cephalosporins_3rd <- c(CTX, CRO, CAZ)
carbapenems <- c(ETP, IPM, MEM)
fluoroquinolones <- c(OFX, CIP, LVX, MFX)
# helper function for editing the table
trans_tbl <- function(to, rows, cols, any_all) {
cols <- cols[!ab_missing(cols)]
cols <- cols[!is.na(cols)]
if (length(rows) > 0 & length(cols) > 0) {
if (any_all == "any") {
col_filter <- which(tbl[, cols] == 'R')
col_filter <- which(tbl_[, cols] == 'R')
} else if (any_all == "all") {
col_filter <- tbl %>%
col_filter <- tbl_ %>%
mutate(index = 1:nrow(.)) %>%
filter_at(vars(cols), all_vars(. == "R")) %>%
pull((index))
}
rows <- rows[rows %in% col_filter]
tbl[rows, 'MDRO'] <<- to
tbl_[rows, 'MDRO'] <<- to
}
}
tbl <- tbl %>%
tbl_ <- tbl_ %>%
mutate_at(vars(col_mo), as.mo) %>%
# join to microorganisms data set
left_join_microorganisms(by = col_mo) %>%
@@ -342,64 +218,64 @@ mdro <- function(tbl,
# EUCAST ------------------------------------------------------------------
# Table 5
trans_tbl(3,
which(tbl$family == 'Enterobacteriaceae'
| tbl$fullname %like% '^Pseudomonas aeruginosa'
| tbl$genus == 'Acinetobacter'),
coli,
which(tbl_$family == 'Enterobacteriaceae'
| tbl_$fullname %like% '^Pseudomonas aeruginosa'
| tbl_$genus == 'Acinetobacter'),
COL,
"all")
trans_tbl(3,
which(tbl$fullname %like% '^Salmonella Typhi'),
which(tbl_$fullname %like% '^Salmonella Typhi'),
c(carbapenems, fluoroquinolones),
"any")
trans_tbl(3,
which(tbl$fullname %like% '^Haemophilus influenzae'),
which(tbl_$fullname %like% '^Haemophilus influenzae'),
c(cephalosporins_3rd, carbapenems, fluoroquinolones),
"any")
trans_tbl(3,
which(tbl$fullname %like% '^Moraxella catarrhalis'),
which(tbl_$fullname %like% '^Moraxella catarrhalis'),
c(cephalosporins_3rd, fluoroquinolones),
"any")
trans_tbl(3,
which(tbl$fullname %like% '^Neisseria meningitidis'),
which(tbl_$fullname %like% '^Neisseria meningitidis'),
c(cephalosporins_3rd, fluoroquinolones),
"any")
trans_tbl(3,
which(tbl$fullname %like% '^Neisseria gonorrhoeae'),
azit,
which(tbl_$fullname %like% '^Neisseria gonorrhoeae'),
AZM,
"any")
# Table 6
trans_tbl(3,
which(tbl$fullname %like% '^Staphylococcus (aureus|epidermidis|coagulase negatief|hominis|haemolyticus|intermedius|pseudointermedius)'),
c(vanc, teic, dapt, line, qida, tige),
which(tbl_$fullname %like% '^Staphylococcus (aureus|epidermidis|coagulase negatief|hominis|haemolyticus|intermedius|pseudointermedius)'),
c(VAN, TEC, DAP, LNZ, QDA, TGC),
"any")
trans_tbl(3,
which(tbl$genus == 'Corynebacterium'),
c(vanc, teic, dapt, line, qida, tige),
which(tbl_$genus == 'Corynebacterium'),
c(VAN, TEC, DAP, LNZ, QDA, TGC),
"any")
trans_tbl(3,
which(tbl$fullname %like% '^Streptococcus pneumoniae'),
c(carbapenems, vanc, teic, dapt, line, qida, tige, rifa),
which(tbl_$fullname %like% '^Streptococcus pneumoniae'),
c(carbapenems, VAN, TEC, DAP, LNZ, QDA, TGC, RIF),
"any")
trans_tbl(3, # Sr. groups A/B/C/G
which(tbl$fullname %like% '^Streptococcus (pyogenes|agalactiae|equisimilis|equi|zooepidemicus|dysgalactiae|anginosus)'),
c(peni, cephalosporins, vanc, teic, dapt, line, qida, tige),
which(tbl_$fullname %like% '^Streptococcus (pyogenes|agalactiae|equisimilis|equi|zooepidemicus|dysgalactiae|anginosus)'),
c(PEN, cephalosporins, VAN, TEC, DAP, LNZ, QDA, TGC),
"any")
trans_tbl(3,
which(tbl$genus == 'Enterococcus'),
c(dapt, line, tige, teic),
which(tbl_$genus == 'Enterococcus'),
c(DAP, LNZ, TGC, TEC),
"any")
trans_tbl(3,
which(tbl$fullname %like% '^Enterococcus faecalis'),
c(ampi, amox),
which(tbl_$fullname %like% '^Enterococcus faecalis'),
c(AMP, AMX),
"any")
# Table 7
trans_tbl(3,
which(tbl$genus == 'Bacteroides'),
metr,
which(tbl_$genus == 'Bacteroides'),
MTR,
"any")
trans_tbl(3,
which(tbl$fullname %like% '^Clostridium difficile'),
c(metr, vanc),
which(tbl_$fullname %like% '^Clostridium difficile'),
c( MTR, VAN),
"any")
}
@@ -416,68 +292,68 @@ mdro <- function(tbl,
# Table 1
trans_tbl(3,
which(tbl$family == 'Enterobacteriaceae'),
which(tbl_$family == 'Enterobacteriaceae'),
c(aminoglycosides, fluoroquinolones),
"all")
trans_tbl(2,
which(tbl$family == 'Enterobacteriaceae'),
which(tbl_$family == 'Enterobacteriaceae'),
c(carbapenems),
"any")
# Table 2
trans_tbl(2,
which(tbl$genus == 'Acinetobacter'),
which(tbl_$genus == 'Acinetobacter'),
c(carbapenems),
"any")
trans_tbl(3,
which(tbl$genus == 'Acinetobacter'),
which(tbl_$genus == 'Acinetobacter'),
c(aminoglycosides, fluoroquinolones),
"all")
trans_tbl(3,
which(tbl$fullname %like% '^Stenotrophomonas maltophilia'),
trsu,
which(tbl_$fullname %like% '^Stenotrophomonas maltophilia'),
SXT,
"all")
if (!ab_missing(mero) & !ab_missing(imip)
& !ab_missing(gent) & !ab_missing(tobr)
& !ab_missing(cipr)
& !ab_missing(cfta)
& !ab_missing(pita) ) {
tbl <- tbl %>% mutate(
if (!ab_missing(MEM) & !ab_missing(IPM)
& !ab_missing(GEN) & !ab_missing(TOB)
& !ab_missing(CIP)
& !ab_missing(CAZ)
& !ab_missing(TZP) ) {
tbl_ <- tbl_ %>% mutate(
psae = 0,
psae = ifelse(mero == "R" | imip == "R", psae + 1, psae),
psae = ifelse(gent == "R" & tobr == "R", psae + 1, psae),
psae = ifelse(cipr == "R", psae + 1, psae),
psae = ifelse(cfta == "R", psae + 1, psae),
psae = ifelse(pita == "R", psae + 1, psae),
psae = ifelse(MEM == "R" | IPM == "R", psae + 1, psae),
psae = ifelse(GEN == "R" & TOB == "R", psae + 1, psae),
psae = ifelse(CIP == "R", psae + 1, psae),
psae = ifelse(CAZ == "R", psae + 1, psae),
psae = ifelse(TZP == "R", psae + 1, psae),
psae = ifelse(is.na(psae), 0, psae)
)
} else {
tbl$psae <- 0
tbl_$psae <- 0
}
tbl[which(
tbl$fullname %like% 'Pseudomonas aeruginosa'
& tbl$psae >= 3
tbl_[which(
tbl_$fullname %like% 'Pseudomonas aeruginosa'
& tbl_$psae >= 3
), 'MDRO'] <- 3
# Table 3
trans_tbl(3,
which(tbl$fullname %like% 'Streptococcus pneumoniae'),
peni,
which(tbl_$fullname %like% 'Streptococcus pneumoniae'),
PEN,
"all")
trans_tbl(3,
which(tbl$fullname %like% 'Streptococcus pneumoniae'),
vanc,
which(tbl_$fullname %like% 'Streptococcus pneumoniae'),
VAN,
"all")
trans_tbl(3,
which(tbl$fullname %like% 'Enterococcus faecium'),
c(peni, vanc),
which(tbl_$fullname %like% 'Enterococcus faecium'),
c(PEN, VAN),
"all")
}
factor(x = tbl$MDRO,
factor(x = tbl_$MDRO,
levels = 1:3,
labels = c('Negative', 'Positive, unconfirmed', 'Positive'),
ordered = TRUE)
@@ -491,12 +367,61 @@ brmo <- function(..., country = "nl") {
#' @rdname mdro
#' @export
mrgn <- function(tbl, country = "de", ...) {
mdro(tbl = tbl, country = "de", ...)
mrgn <- function(x, country = "de", ...) {
mdro(x = x, country = "de", ...)
}
#' @rdname mdro
#' @export
eucast_exceptional_phenotypes <- function(tbl, country = "EUCAST", ...) {
mdro(tbl = tbl, country = "EUCAST", ...)
eucast_exceptional_phenotypes <- function(x, country = "EUCAST", ...) {
mdro(x = x, country = "EUCAST", ...)
}
is_ESBL <- function(x, col_mo = NULL, ...) {
col_mo <- get_column_mo(tbl = x, col_mo = col_mo)
cols_ab <- get_column_abx(tbl = x,
soft_dependencies = c("AMX", "AMP"),
hard_dependencies = c("CAZ"),
...)
if (!any(c("AMX", "AMP") %in% names(cols_ab))) {
# both ampicillin and amoxicillin are missing
generate_warning_abs_missing(c("AMX", "AMP"), any = TRUE)
return(rep(NA, nrow(x)))
}
ESBLs <- rep(NA, nrow(x))
# first make all eligible cases FALSE
ESBLs[which(mo_family(x[, col_mo]) == "Enterobacteriaceae"
& x[, get_ab_col(cols_ab, "AMX")] %in% c("R", "I", "S")
& x[, get_ab_col(cols_ab, "AMX")] %in% c("R", "I", "S")
& x[, get_ab_col(cols_ab, "AMX")] %in% c("R", "I", "S")
)] <- FALSE
# now make the positives cases TRUE
ESBLs[which(!is.na(ESBLs)
& x[, get_ab_col(cols_ab, "AMX")] == "R"
& x[, get_ab_col(cols_ab, "CAZ")] == "R")] <- TRUE
ESBLs
}
is_3MRGN <- function(x, ...) {
}
is_4MRGN <- function(x, ...) {
}
get_column_mo <- function(tbl, col_mo = NULL) {
# throws a blue note about which column will be used if guessed
if (is.null(col_mo)) {
col_mo <- search_type_in_df(tbl = tbl, type = "mo")
}
if (is.null(col_mo)) {
stop("`col_mo` must be set.", call. = FALSE)
}
col_mo
}

24
R/mic.R
View File

@@ -25,6 +25,7 @@
#' @rdname as.mic
#' @param x vector
#' @param na.rm a logical indicating whether missing values should be removed
#' @details Interpret MIC values as RSI values with \code{\link{as.rsi}}. It supports guidelines from EUCAST and CLSI.
#' @return Ordered factor with new class \code{mic}
#' @keywords mic
#' @export
@@ -38,6 +39,16 @@
#' # this can also coerce combined MIC/RSI values:
#' as.mic("<=0.002; S") # will return <=0.002
#'
#' # interpret MIC values
#' as.rsi(x = as.mic(2),
#' mo = as.mo("S. pneumoniae"),
#' ab = "AMX",
#' guideline = "EUCAST")
#' as.rsi(x = as.mic(4),
#' mo = as.mo("S. pneumoniae"),
#' ab = "AMX",
#' guideline = "EUCAST")
#'
#' plot(mic_data)
#' barplot(mic_data)
#' freq(mic_data)
@@ -71,11 +82,12 @@ as.mic <- function(x, na.rm = FALSE) {
# force to be character
x <- as.character(x)
# previously unempty values now empty - should return a warning later on
## previously unempty values now empty - should return a warning later on
x[x.bak != "" & x == ""] <- "invalid"
# these are alllowed MIC values and will become factor levels
lvls <- c("<0.002", "<=0.002", "0.002", ">=0.002", ">0.002",
# these are allowed MIC values and will become factor levels
lvls <- c("<0.001", "<=0.001", "0.001", ">=0.001", ">0.001",
"<0.002", "<=0.002", "0.002", ">=0.002", ">0.002",
"<0.003", "<=0.003", "0.003", ">=0.003", ">0.003",
"<0.004", "<=0.004", "0.004", ">=0.004", ">0.004",
"<0.006", "<=0.006", "0.006", ">=0.006", ">0.006",
@@ -134,11 +146,15 @@ as.mic <- function(x, na.rm = FALSE) {
"<80", "<=80", "80", ">=80", ">80",
"<96", "<=96", "96", ">=96", ">96",
"<128", "<=128", "128", ">=128", ">128",
"129",
"<160", "<=160", "160", ">=160", ">160",
"<256", "<=256", "256", ">=256", ">256",
"257",
"<320", "<=320", "320", ">=320", ">320",
"<512", "<=512", "512", ">=512", ">512",
"<1024", "<=1024", "1024", ">=1024", ">1024")
"513",
"<1024", "<=1024", "1024", ">=1024", ">1024",
"1025")
na_before <- x[is.na(x) | x == ''] %>% length()
x[!x %in% lvls] <- NA

322
R/misc.R
View File

@@ -30,7 +30,8 @@ addin_insert_like <- function() {
}
# No export, no Rd
# works exactly like round(), but rounds `round(44.55, 1)` as 44.6 instead of 44.5 and adds decimal zeroes until `digits` is reached
# works exactly like round(), but rounds `round(44.55, 1)` as 44.6 instead of 44.5
# and adds decimal zeroes until `digits` is reached when force_zero = TRUE
round2 <- function(x, digits = 0, force_zero = TRUE) {
# https://stackoverflow.com/a/12688836/4575331
val <- (trunc((abs(x) * 10 ^ digits) + 0.5) / 10 ^ digits) * sign(x)
@@ -41,62 +42,6 @@ round2 <- function(x, digits = 0, force_zero = TRUE) {
val
}
# No export, no Rd
percent <- function(x, round = 1, force_zero = FALSE, decimal.mark = getOption("OutDec"), ...) {
decimal.mark.options <- getOption("OutDec")
options(OutDec = ".")
val <- round2(x, round + 2, force_zero = FALSE) # round up 0.5
val <- round(x = val * 100, digits = round) # remove floating point error
if (force_zero == TRUE) {
if (any(val == as.integer(val) & !is.na(val))) {
# add zeroes to all integers
val[val == as.integer(as.character(val))] <- paste0(val[val == as.integer(val)], ".", strrep(0, round))
}
# add extra zeroes if needed
val_decimals <- nchar(gsub(".*[.](.*)", "\\1", as.character(val)))
val[val_decimals < round] <- paste0(val[val_decimals < round], strrep(0, max(0, round - val_decimals)))
}
pct <- base::paste0(val, "%")
pct[pct %in% c("NA%", "NaN%")] <- NA_character_
if (decimal.mark != ".") {
pct <- gsub(".", decimal.mark, pct, fixed = TRUE)
}
options(OutDec = decimal.mark.options)
pct
}
check_available_columns <- function(tbl, col.list, info = TRUE) {
# check columns
col.list <- col.list[!is.na(col.list) & !is.null(col.list)]
names(col.list) <- col.list
col.list.bak <- col.list
# are they available as upper case or lower case then?
for (i in 1:length(col.list)) {
if (is.null(col.list[i]) | isTRUE(is.na(col.list[i]))) {
col.list[i] <- NA
} else if (toupper(col.list[i]) %in% colnames(tbl)) {
col.list[i] <- toupper(col.list[i])
} else if (tolower(col.list[i]) %in% colnames(tbl)) {
col.list[i] <- tolower(col.list[i])
} else if (!col.list[i] %in% colnames(tbl)) {
col.list[i] <- NA
}
}
if (!all(col.list %in% colnames(tbl))) {
if (info == TRUE) {
warning('Some columns do not exist and will be ignored: ',
col.list.bak[!(col.list %in% colnames(tbl))] %>% toString(),
'.\nTHIS MAY STRONGLY INFLUENCE THE OUTCOME.',
immediate. = TRUE,
call. = FALSE)
}
}
col.list
}
# Coefficient of variation (CV)
cv <- function(x, na.rm = TRUE) {
stats::sd(x, na.rm = na.rm) / base::abs(base::mean(x, na.rm = na.rm))
@@ -126,6 +71,20 @@ size_humanreadable <- function(bytes, decimals = 1) {
out
}
percent_scales <- scales::percent
# No export, no Rd
# based on scales::percent
percent <- function(x, round = 1, force_zero = FALSE, decimal.mark = getOption("OutDec"), ...) {
x <- percent_scales(x = as.double(x),
accuracy = 1 / 10 ^ round,
decimal.mark = decimal.mark,
...)
if (force_zero == FALSE) {
x <- gsub("([.]%|%%)", "%", paste0(gsub("0+%$", "", x), "%"))
}
x
}
#' @importFrom crayon blue bold red
#' @importFrom dplyr %>% pull
search_type_in_df <- function(tbl, type) {
@@ -195,8 +154,257 @@ search_type_in_df <- function(tbl, type) {
found
}
get_ab_col <- function(columns, ab) {
columns[names(columns) == ab]
}
get_column_abx <- function(tbl,
soft_dependencies = NULL,
hard_dependencies = NULL,
verbose = FALSE,
AMC = guess_ab_col(),
AMK = guess_ab_col(),
AMX = guess_ab_col(),
AMP = guess_ab_col(),
AZM = guess_ab_col(),
AZL = guess_ab_col(),
ATM = guess_ab_col(),
RID = guess_ab_col(),
FEP = guess_ab_col(),
CTX = guess_ab_col(),
FOX = guess_ab_col(),
CED = guess_ab_col(),
CAZ = guess_ab_col(),
CRO = guess_ab_col(),
CXM = guess_ab_col(),
CHL = guess_ab_col(),
CIP = guess_ab_col(),
CLR = guess_ab_col(),
CLI = guess_ab_col(),
FLC = guess_ab_col(),
COL = guess_ab_col(),
CZO = guess_ab_col(),
DAP = guess_ab_col(),
DOX = guess_ab_col(),
ETP = guess_ab_col(),
ERY = guess_ab_col(),
FOS = guess_ab_col(),
FUS = guess_ab_col(),
GEN = guess_ab_col(),
IPM = guess_ab_col(),
KAN = guess_ab_col(),
LVX = guess_ab_col(),
LIN = guess_ab_col(),
LNZ = guess_ab_col(),
MEM = guess_ab_col(),
MTR = guess_ab_col(),
MEZ = guess_ab_col(),
MNO = guess_ab_col(),
MFX = guess_ab_col(),
NAL = guess_ab_col(),
NEO = guess_ab_col(),
NET = guess_ab_col(),
NIT = guess_ab_col(),
NOR = guess_ab_col(),
NOV = guess_ab_col(),
OFX = guess_ab_col(),
OXA = guess_ab_col(),
PEN = guess_ab_col(),
PIP = guess_ab_col(),
TZP = guess_ab_col(),
PLB = guess_ab_col(),
PRI = guess_ab_col(),
QDA = guess_ab_col(),
RIF = guess_ab_col(),
RXT = guess_ab_col(),
SIS = guess_ab_col(),
TEC = guess_ab_col(),
TCY = guess_ab_col(),
TIC = guess_ab_col(),
TGC = guess_ab_col(),
TOB = guess_ab_col(),
TMP = guess_ab_col(),
SXT = guess_ab_col(),
VAN = guess_ab_col()) {
# check columns
if (identical(AMC, as.name("guess_ab_col"))) AMC <- guess_ab_col(tbl, "AMC", verbose = verbose)
if (identical(AMK, as.name("guess_ab_col"))) AMK <- guess_ab_col(tbl, "AMK", verbose = verbose)
if (identical(AMX, as.name("guess_ab_col"))) AMX <- guess_ab_col(tbl, "AMX", verbose = verbose)
if (identical(AMP, as.name("guess_ab_col"))) AMP <- guess_ab_col(tbl, "AMP", verbose = verbose)
if (identical(AZM, as.name("guess_ab_col"))) AZM <- guess_ab_col(tbl, "AZM", verbose = verbose)
if (identical(AZL, as.name("guess_ab_col"))) AZL <- guess_ab_col(tbl, "AZL", verbose = verbose)
if (identical(ATM, as.name("guess_ab_col"))) ATM <- guess_ab_col(tbl, "ATM", verbose = verbose)
if (identical(RID, as.name("guess_ab_col"))) RID <- guess_ab_col(tbl, "RID", verbose = verbose)
if (identical(FEP, as.name("guess_ab_col"))) FEP <- guess_ab_col(tbl, "FEP", verbose = verbose)
if (identical(CTX, as.name("guess_ab_col"))) CTX <- guess_ab_col(tbl, "CTX", verbose = verbose)
if (identical(FOX, as.name("guess_ab_col"))) FOX <- guess_ab_col(tbl, "FOX", verbose = verbose)
if (identical(CED, as.name("guess_ab_col"))) CED <- guess_ab_col(tbl, "CED", verbose = verbose)
if (identical(CAZ, as.name("guess_ab_col"))) CAZ <- guess_ab_col(tbl, "CAZ", verbose = verbose)
if (identical(CRO, as.name("guess_ab_col"))) CRO <- guess_ab_col(tbl, "CRO", verbose = verbose)
if (identical(CXM, as.name("guess_ab_col"))) CXM <- guess_ab_col(tbl, "CXM", verbose = verbose)
if (identical(CHL, as.name("guess_ab_col"))) CHL <- guess_ab_col(tbl, "CHL", verbose = verbose)
if (identical(CIP, as.name("guess_ab_col"))) CIP <- guess_ab_col(tbl, "CIP", verbose = verbose)
if (identical(CLR, as.name("guess_ab_col"))) CLR <- guess_ab_col(tbl, "CLR", verbose = verbose)
if (identical(CLI, as.name("guess_ab_col"))) CLI <- guess_ab_col(tbl, "CLI", verbose = verbose)
if (identical(FLC, as.name("guess_ab_col"))) FLC <- guess_ab_col(tbl, "FLC", verbose = verbose)
if (identical(COL, as.name("guess_ab_col"))) COL <- guess_ab_col(tbl, "COL", verbose = verbose)
if (identical(CZO, as.name("guess_ab_col"))) CZO <- guess_ab_col(tbl, "CZO", verbose = verbose)
if (identical(DAP, as.name("guess_ab_col"))) DAP <- guess_ab_col(tbl, "DAP", verbose = verbose)
if (identical(DOX, as.name("guess_ab_col"))) DOX <- guess_ab_col(tbl, "DOX", verbose = verbose)
if (identical(ETP, as.name("guess_ab_col"))) ETP <- guess_ab_col(tbl, "ETP", verbose = verbose)
if (identical(ERY, as.name("guess_ab_col"))) ERY <- guess_ab_col(tbl, "ERY", verbose = verbose)
if (identical(FOS, as.name("guess_ab_col"))) FOS <- guess_ab_col(tbl, "FOS", verbose = verbose)
if (identical(FUS, as.name("guess_ab_col"))) FUS <- guess_ab_col(tbl, "FUS", verbose = verbose)
if (identical(GEN, as.name("guess_ab_col"))) GEN <- guess_ab_col(tbl, "GEN", verbose = verbose)
if (identical(IPM, as.name("guess_ab_col"))) IPM <- guess_ab_col(tbl, "IPM", verbose = verbose)
if (identical(KAN, as.name("guess_ab_col"))) KAN <- guess_ab_col(tbl, "KAN", verbose = verbose)
if (identical(LVX, as.name("guess_ab_col"))) LVX <- guess_ab_col(tbl, "LVX", verbose = verbose)
if (identical(LIN, as.name("guess_ab_col"))) LIN <- guess_ab_col(tbl, "LIN", verbose = verbose)
if (identical(LNZ, as.name("guess_ab_col"))) LNZ <- guess_ab_col(tbl, "LNZ", verbose = verbose)
if (identical(MEM, as.name("guess_ab_col"))) MEM <- guess_ab_col(tbl, "MEM", verbose = verbose)
if (identical(MTR, as.name("guess_ab_col"))) MTR <- guess_ab_col(tbl, "MTR", verbose = verbose)
if (identical(MEZ, as.name("guess_ab_col"))) MEZ <- guess_ab_col(tbl, "MEZ", verbose = verbose)
if (identical(MNO, as.name("guess_ab_col"))) MNO <- guess_ab_col(tbl, "MNO", verbose = verbose)
if (identical(MFX, as.name("guess_ab_col"))) MFX <- guess_ab_col(tbl, "MFX", verbose = verbose)
if (identical(NAL, as.name("guess_ab_col"))) NAL <- guess_ab_col(tbl, "NAL", verbose = verbose)
if (identical(NEO, as.name("guess_ab_col"))) NEO <- guess_ab_col(tbl, "NEO", verbose = verbose)
if (identical(NET, as.name("guess_ab_col"))) NET <- guess_ab_col(tbl, "NET", verbose = verbose)
if (identical(NIT, as.name("guess_ab_col"))) NIT <- guess_ab_col(tbl, "NIT", verbose = verbose)
if (identical(NOR, as.name("guess_ab_col"))) NOR <- guess_ab_col(tbl, "NOR", verbose = verbose)
if (identical(NOV, as.name("guess_ab_col"))) NOV <- guess_ab_col(tbl, "NOV", verbose = verbose)
if (identical(OFX, as.name("guess_ab_col"))) OFX <- guess_ab_col(tbl, "OFX", verbose = verbose)
if (identical(OXA, as.name("guess_ab_col"))) OXA <- guess_ab_col(tbl, "OXA", verbose = verbose)
if (identical(PEN, as.name("guess_ab_col"))) PEN <- guess_ab_col(tbl, "PEN", verbose = verbose)
if (identical(PIP, as.name("guess_ab_col"))) PIP <- guess_ab_col(tbl, "PIP", verbose = verbose)
if (identical(TZP, as.name("guess_ab_col"))) TZP <- guess_ab_col(tbl, "TZP", verbose = verbose)
if (identical(PLB, as.name("guess_ab_col"))) PLB <- guess_ab_col(tbl, "PLB", verbose = verbose)
if (identical(PRI, as.name("guess_ab_col"))) PRI <- guess_ab_col(tbl, "PRI", verbose = verbose)
if (identical(QDA, as.name("guess_ab_col"))) QDA <- guess_ab_col(tbl, "QDA", verbose = verbose)
if (identical(RIF, as.name("guess_ab_col"))) RIF <- guess_ab_col(tbl, "RIF", verbose = verbose)
if (identical(RXT, as.name("guess_ab_col"))) RXT <- guess_ab_col(tbl, "RXT", verbose = verbose)
if (identical(SIS, as.name("guess_ab_col"))) SIS <- guess_ab_col(tbl, "SIS", verbose = verbose)
if (identical(TEC, as.name("guess_ab_col"))) TEC <- guess_ab_col(tbl, "TEC", verbose = verbose)
if (identical(TCY, as.name("guess_ab_col"))) TCY <- guess_ab_col(tbl, "TCY", verbose = verbose)
if (identical(TIC, as.name("guess_ab_col"))) TIC <- guess_ab_col(tbl, "TIC", verbose = verbose)
if (identical(TGC, as.name("guess_ab_col"))) TGC <- guess_ab_col(tbl, "TGC", verbose = verbose)
if (identical(TOB, as.name("guess_ab_col"))) TOB <- guess_ab_col(tbl, "TOB", verbose = verbose)
if (identical(TMP, as.name("guess_ab_col"))) TMP <- guess_ab_col(tbl, "TMP", verbose = verbose)
if (identical(SXT, as.name("guess_ab_col"))) SXT <- guess_ab_col(tbl, "SXT", verbose = verbose)
if (identical(VAN, as.name("guess_ab_col"))) VAN <- guess_ab_col(tbl, "VAN", verbose = verbose)
columns_available <- c(AMC = AMC, AMK = AMK, AMX = AMX, AMP = AMP, AZM = AZM,
AZL = AZL, ATM = ATM, RID = RID, FEP = FEP, CTX = CTX,
FOX = FOX, CED = CED, CAZ = CAZ, CRO = CRO, CXM = CXM,
CHL = CHL, CIP = CIP, CLR = CLR, CLI = CLI, FLC = FLC,
COL = COL, CZO = CZO, DAP = DAP, DOX = DOX, ETP = ETP,
ERY = ERY, FOS = FOS, FUS = FUS, GEN = GEN, IPM = IPM,
KAN = KAN, LVX = LVX, LIN = LIN, LNZ = LNZ, MEM = MEM,
MTR = MTR, MEZ = MEZ, MNO = MNO, MFX = MFX, NAL = NAL,
NEO = NEO, NET = NET, NIT = NIT, NOR = NOR, NOV = NOV,
OFX = OFX, OXA = OXA, PEN = PEN, PIP = PIP, TZP = TZP,
PLB = PLB, PRI = PRI, QDA = QDA, RIF = RIF, RXT = RXT,
SIS = SIS, TEC = TEC, TCY = TCY, TIC = TIC, TGC = TGC,
TOB = TOB, TMP = TMP, SXT = SXT, VAN = VAN)
if (!is.null(hard_dependencies)) {
if (!all(hard_dependencies %in% names(columns_available))) {
# missing a hard dependency will return NA and consequently the data will not be analysed
missing <- hard_dependencies[!hard_dependencies %in% names(columns_available)]
generate_warning_abs_missing(missing, any = FALSE)
return(NA)
}
}
if (!is.null(soft_dependencies)) {
if (!all(soft_dependencies %in% names(columns_available))) {
# missing a soft dependency may lower the reliability
missing <- soft_dependencies[!soft_dependencies %in% names(columns_available)]
missing <- paste0("`", missing, "` (", ab_name(missing, tolower = TRUE), ")")
warning('Reliability might be improved if these antimicrobial results would be available too: ', paste(missing, collapse = ", "),
immediate. = TRUE,
call. = FALSE)
}
}
#deps <- c(soft_dependencies, hard_dependencies)
#if (length(deps) > 0) {
# columns_available[names(columns_available) %in% deps]
#} else {
columns_available
#}
}
generate_warning_abs_missing <- function(missing, any = FALSE) {
missing <- paste0("`", missing, "` (", ab_name(missing, tolower = TRUE), ")")
if (any == TRUE) {
any_txt <- c(" any of", "is")
} else {
any_txt <- c("", "are")
}
warning(paste0("Introducing NAs since", any_txt[1], " these antimicrobials ", any_txt[2], " required: ",
paste(missing, collapse = ", ")),
immediate. = TRUE,
call. = FALSE)
}
stopifnot_installed_package <- function(package) {
if (!package %in% base::rownames(utils::installed.packages())) {
stop("this function requires the ", package, " package.", call. = FALSE)
}
}
# translate strings based on inst/translations.tsv
#' @importFrom dplyr %>% filter
t <- function(from, language = get_locale()) {
# if (getOption("AMR_locale", "en") != language) {
# language <- getOption("AMR_locale", "en")
# }
if (is.null(language)) {
return(from)
}
if (language %in% c("en", "")) {
return(from)
}
df_trans <- utils::read.table(file = system.file("translations.tsv", package = "AMR"),
sep = "\t",
stringsAsFactors = FALSE,
header = TRUE,
blank.lines.skip = TRUE,
fill = TRUE,
strip.white = TRUE,
encoding = "UTF-8",
fileEncoding = "UTF-8",
na.strings = c(NA, "", NULL))
if (!language %in% df_trans$lang) {
stop("Unsupported language: '", language, "' - use one of: ",
paste0("'", sort(unique(df_trans$lang)), "'", collapse = ", "),
call. = FALSE)
}
df_trans <- df_trans %>% filter(lang == language)
# default case sensitive if value if 'ignore.case' is missing:
df_trans$ignore.case[is.na(df_trans$ignore.case)] <- FALSE
# default not using regular expressions (fixed = TRUE) if 'fixed' is missing:
df_trans$fixed[is.na(df_trans$fixed)] <- TRUE
# check if text to look for is in one of the patterns
pattern_total <- tryCatch(paste0("(", paste(df_trans$pattern, collapse = "|"), ")"),
error = "")
if (NROW(df_trans) == 0 | !any(from %like% pattern_total)) {
return(from)
}
for (i in 1:nrow(df_trans)) {
from <- gsub(x = from,
pattern = df_trans$pattern[i],
replacement = df_trans$replacement[i],
fixed = df_trans$fixed[i],
ignore.case = df_trans$ignore.case[i])
}
# force UTF-8 for diacritics
base::enc2utf8(from)
}

16
R/mo.R
View File

@@ -126,7 +126,7 @@
#' @section Source:
#' [1] Becker K \emph{et al.} \strong{Coagulase-Negative Staphylococci}. 2014. Clin Microbiol Rev. 27(4): 870–926. \url{https://dx.doi.org/10.1128/CMR.00109-13}
#'
#' [2] Becker K \emph{et al.} \strong{Implications of identifying the recently defined members of the S. aureus complex, S. argenteus and S. schweitzeri: A position paper of members of the ESCMID Study Group for staphylococci and Staphylococcal Diseases (ESGS).}. 2019. Clin Microbiol Infect. 2019 Mar 11. \url{https://doi.org/10.1016/j.cmi.2019.02.028}
#' [2] Becker K \emph{et al.} \strong{Implications of identifying the recently defined members of the \emph{S. aureus} complex, \emph{S. argenteus} and \emph{S. schweitzeri}: A position paper of members of the ESCMID Study Group for staphylococci and Staphylococcal Diseases (ESGS).} 2019. Clin Microbiol Infect. \url{https://doi.org/10.1016/j.cmi.2019.02.028}
#'
#' [3] Lancefield RC \strong{A serological differentiation of human and other groups of hemolytic streptococci}. 1933. J Exp Med. 57(4): 571–95. \url{https://dx.doi.org/10.1084/jem.57.4.571}
#'
@@ -195,6 +195,8 @@ as.mo <- function(x, Becker = FALSE, Lancefield = FALSE, allow_uncertain = TRUE,
# check onLoad() in R/zzz.R: data tables are created there.
}
x[x == ""] <- NA_character_
uncertainty_level <- translate_allow_uncertain(allow_uncertain)
mo_hist <- get_mo_history(x, uncertainty_level, force = isTRUE(list(...)$force_mo_history))
@@ -261,7 +263,8 @@ as.mo <- function(x, Becker = FALSE, Lancefield = FALSE, allow_uncertain = TRUE,
y <- mo_validate(x = x, property = "mo",
Becker = Becker, Lancefield = Lancefield,
allow_uncertain = uncertainty_level, reference_df = reference_df,
force_mo_history = isTRUE(list(...)$force_mo_history))
force_mo_history = isTRUE(list(...)$force_mo_history),
...)
}
@@ -296,6 +299,8 @@ exec_as.mo <- function(x,
# check onLoad() in R/zzz.R: data tables are created there.
}
x[x == ""] <- NA_character_
if (initial_search == TRUE) {
options(mo_failures = NULL)
options(mo_uncertainties = NULL)
@@ -548,7 +553,9 @@ exec_as.mo <- function(x,
next
}
if (nchar(gsub("[^a-zA-Z]", "", x_trimmed[i])) < 3) {
# check for very small input, but ignore the O antigens of E. coli
if (nchar(gsub("[^a-zA-Z]", "", x_trimmed[i])) < 3
& !x_backup_without_spp[i] %like% "O?(26|103|104|104|111|121|145|157)") {
# check if search term was like "A. species", then return first genus found with ^A
if (x_backup[i] %like% "[a-z]+ species" | x_backup[i] %like% "[a-z] spp[.]?") {
# get mo code of first hit
@@ -609,7 +616,8 @@ exec_as.mo <- function(x,
}
next
}
if (toupper(x_backup_without_spp[i]) %in% c("EHEC", "EPEC", "EIEC", "STEC", "ATEC")) {
if (toupper(x_backup_without_spp[i]) %in% c("EHEC", "EPEC", "EIEC", "STEC", "ATEC")
| x_backup_without_spp[i] %like% "O?(26|103|104|104|111|121|145|157)") {
x[i] <- microorganismsDT[mo == 'B_ESCHR_COL', ..property][[1]][1L]
if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history)

6
R/mo_history.R
View File

@@ -22,7 +22,7 @@
# print successful as.mo coercions to AMR environment
#' @importFrom dplyr %>% distinct filter
set_mo_history <- function(x, mo, uncertainty_level, force = FALSE) {
# disable function
# disable function for now
return(base::invisible())
# if (base::interactive() | force == TRUE) {
@@ -58,7 +58,7 @@ set_mo_history <- function(x, mo, uncertainty_level, force = FALSE) {
}
get_mo_history <- function(x, uncertainty_level, force = FALSE) {
# disable function
# disable function for now
return(NA)
# history <- read_mo_history(uncertainty_level = uncertainty_level, force = force)
@@ -73,7 +73,7 @@ get_mo_history <- function(x, uncertainty_level, force = FALSE) {
#' @importFrom dplyr %>% filter distinct
read_mo_history <- function(uncertainty_level = 2, force = FALSE, unfiltered = FALSE) {
# disable function
# disable function for now
return(NULL)
# if ((!base::interactive() & force == FALSE)) {

246
R/mo_property.R
View File

@@ -36,8 +36,9 @@
#'
#' The Gram stain - \code{mo_gramstain()} - will be determined on the taxonomic kingdom and phylum. According to Cavalier-Smith (2002) who defined subkingdoms Negibacteria and Posibacteria, only these phyla are Posibacteria: Actinobacteria, Chloroflexi, Firmicutes and Tenericutes. These bacteria are considered Gram positive - all other bacteria are considered Gram negative. Species outside the kingdom of Bacteria will return a value \code{NA}.
#'
#' All output will be \link{translate}d where possible.
#'
#' The function \code{mo_url()} will return the direct URL to the online database entry, which also shows the scientific reference of the concerned species.
#' @inheritSection get_locale Supported languages
#' @inheritSection catalogue_of_life Catalogue of Life
#' @inheritSection as.mo Source
#' @rdname mo_property
@@ -70,7 +71,7 @@
#' mo_gramstain("E. coli") # "Gram negative"
#' mo_type("E. coli") # "Bacteria" (equal to kingdom)
#' mo_rank("E. coli") # "species"
#' mo_url("E. coli") # get the direct url to the Catalogue of Life
#' mo_url("E. coli") # get the direct url to the online database entry
#'
#' ## scientific reference
#' mo_ref("E. coli") # "Castellani et al., 1919"
@@ -128,11 +129,11 @@
#' language = "nl") # "Streptococcus groep A"
#'
#'
#' # get a list with the complete taxonomy (kingdom to subspecies)
#' # get a list with the complete taxonomy (from kingdom to subspecies)
#' mo_taxonomy("E. coli")
mo_fullname <- function(x, language = get_locale(), ...) {
x <- mo_validate(x = x, property = "fullname", ...)
mo_translate(x, language = language)
t(x, language = language)
}
#' @rdname mo_property
@@ -199,49 +200,49 @@ mo_shortname <- function(x, language = get_locale(), ...) {
}
}
mo_translate(result, language = language)
t(result, language = language)
}
#' @rdname mo_property
#' @export
mo_subspecies <- function(x, language = get_locale(), ...) {
mo_translate(mo_validate(x = x, property = "subspecies", ...), language = language)
t(mo_validate(x = x, property = "subspecies", ...), language = language)
}
#' @rdname mo_property
#' @export
mo_species <- function(x, language = get_locale(), ...) {
mo_translate(mo_validate(x = x, property = "species", ...), language = language)
t(mo_validate(x = x, property = "species", ...), language = language)
}
#' @rdname mo_property
#' @export
mo_genus <- function(x, language = get_locale(), ...) {
mo_translate(mo_validate(x = x, property = "genus", ...), language = language)
t(mo_validate(x = x, property = "genus", ...), language = language)
}
#' @rdname mo_property
#' @export
mo_family <- function(x, language = get_locale(), ...) {
mo_translate(mo_validate(x = x, property = "family", ...), language = language)
t(mo_validate(x = x, property = "family", ...), language = language)
}
#' @rdname mo_property
#' @export
mo_order <- function(x, language = get_locale(), ...) {
mo_translate(mo_validate(x = x, property = "order", ...), language = language)
t(mo_validate(x = x, property = "order", ...), language = language)
}
#' @rdname mo_property
#' @export
mo_class <- function(x, language = get_locale(), ...) {
mo_translate(mo_validate(x = x, property = "class", ...), language = language)
t(mo_validate(x = x, property = "class", ...), language = language)
}
#' @rdname mo_property
#' @export
mo_phylum <- function(x, language = get_locale(), ...) {
mo_translate(mo_validate(x = x, property = "phylum", ...), language = language)
t(mo_validate(x = x, property = "phylum", ...), language = language)
}
#' @rdname mo_property
@@ -250,10 +251,10 @@ mo_kingdom <- function(x, language = get_locale(), ...) {
if (all(x %in% AMR::microorganisms$kingdom)) {
return(x)
}
x <- as.mo(x, language = "en", ...)
x <- as.mo(x, ...)
kngdm <- mo_validate(x = x, property = "kingdom", ...)
if (language != "en") {
kngdm[x == "UNKNOWN"] <- mo_translate(kngdm[x == "UNKNOWN"], language = language)
kngdm[x == "UNKNOWN"] <- t(kngdm[x == "UNKNOWN"], language = language)
}
kngdm
}
@@ -261,13 +262,13 @@ mo_kingdom <- function(x, language = get_locale(), ...) {
#' @rdname mo_property
#' @export
mo_type <- function(x, language = get_locale(), ...) {
mo_translate(mo_validate(x = x, property = "kingdom", ...), language = language)
t(mo_validate(x = x, property = "kingdom", ...), language = language)
}
#' @rdname mo_property
#' @export
mo_gramstain <- function(x, language = get_locale(), ...) {
x.mo <- as.mo(x, language = "en", ...)
x.mo <- as.mo(x, ...)
x.phylum <- mo_phylum(x.mo, language = "en")
x[x.phylum %in% c("Actinobacteria",
"Chloroflexi",
@@ -278,7 +279,7 @@ mo_gramstain <- function(x, language = get_locale(), ...) {
x[x.mo == "B_GRAMP"] <- "Gram positive"
x[x.mo == "B_GRAMN"] <- "Gram negative"
mo_translate(x, language = language)
t(x, language = language)
}
#' @rdname mo_property
@@ -363,214 +364,7 @@ mo_property <- function(x, property = 'fullname', language = get_locale(), ...)
stop("invalid property: '", property, "' - use a column name of the `microorganisms` data set")
}
mo_translate(mo_validate(x = x, property = property, ...), language = language)
}
#' @importFrom dplyr %>% case_when
mo_translate <- function(x, language) {
if (is.null(language)) {
return(x)
}
if (language %in% c("en", "")) {
return(x)
}
supported <- c("en", "de", "nl", "es", "pt", "it", "fr")
if (!language %in% supported) {
stop("Unsupported language: '", language, "' - use one of: ", paste0("'", sort(supported), "'", collapse = ", "), call. = FALSE)
}
x_tobetranslated <- grepl(x = x,
pattern = "(Coagulase-negative Staphylococcus|Coagulase-positive Staphylococcus|Beta-haemolytic Streptococcus|unknown Gram negatives|unknown Gram positives|unknown name|unknown kingdom|unknown phylum|unknown class|unknown order|unknown family|unknown genus|unknown species|unknown subspecies|unknown rank|CoNS|CoPS|Gram negative|Gram positive|Bacteria|Fungi|Protozoa|biogroup|biotype|vegetative|group|Group)")
if (sum(x_tobetranslated, na.rm = TRUE) == 0) {
return(x)
}
# only translate the ones that need translation
x[x_tobetranslated] <- case_when(
# German
language == "de" ~ x[x_tobetranslated] %>%
gsub("Coagulase-negative Staphylococcus","Koagulase-negative Staphylococcus", ., fixed = TRUE) %>%
gsub("Coagulase-positive Staphylococcus","Koagulase-positive Staphylococcus", ., fixed = TRUE) %>%
gsub("Beta-haemolytic Streptococcus", "Beta-h\u00e4molytischer Streptococcus", ., fixed = TRUE) %>%
gsub("unknown Gram negatives", "unbekannte Gramnegativen", ., fixed = TRUE) %>%
gsub("unknown Gram positives", "unbekannte Grampositiven", ., fixed = TRUE) %>%
gsub("unknown name", "unbekannte Name", ., fixed = TRUE) %>%
gsub("unknown kingdom", "unbekanntes Reich", ., fixed = TRUE) %>%
gsub("unknown phylum", "unbekannter Stamm", ., fixed = TRUE) %>%
gsub("unknown class", "unbekannte Klasse", ., fixed = TRUE) %>%
gsub("unknown order", "unbekannte Ordnung", ., fixed = TRUE) %>%
gsub("unknown family", "unbekannte Familie", ., fixed = TRUE) %>%
gsub("unknown genus", "unbekannte Gattung", ., fixed = TRUE) %>%
gsub("unknown species", "unbekannte Art", ., fixed = TRUE) %>%
gsub("unknown subspecies", "unbekannte Unterart", ., fixed = TRUE) %>%
gsub("unknown rank", "unbekannter Rang", ., fixed = TRUE) %>%
gsub("(CoNS)", "(KNS)", ., fixed = TRUE) %>%
gsub("(CoPS)", "(KPS)", ., fixed = TRUE) %>%
gsub("Gram negative", "Gramnegativ", ., fixed = TRUE) %>%
gsub("Gram positive", "Grampositiv", ., fixed = TRUE) %>%
gsub("Bacteria", "Bakterien", ., fixed = TRUE) %>%
gsub("Fungi", "Hefen/Pilze", ., fixed = TRUE) %>%
gsub("Protozoa", "Protozoen", ., fixed = TRUE) %>%
gsub("biogroup", "Biogruppe", ., fixed = TRUE) %>%
gsub("biotype", "Biotyp", ., fixed = TRUE) %>%
gsub("vegetative", "vegetativ", ., fixed = TRUE) %>%
gsub("([([ ]*?)group", "\\1Gruppe", .) %>%
gsub("([([ ]*?)Group", "\\1Gruppe", .) %>%
iconv(to = "UTF-8"),
# Dutch
language == "nl" ~ x[x_tobetranslated] %>%
gsub("Coagulase-negative Staphylococcus","Coagulase-negatieve Staphylococcus", ., fixed = TRUE) %>%
gsub("Coagulase-positive Staphylococcus","Coagulase-positieve Staphylococcus", ., fixed = TRUE) %>%
gsub("Beta-haemolytic Streptococcus", "Beta-hemolytische Streptococcus", ., fixed = TRUE) %>%
gsub("unknown Gram negatives", "onbekende Gram-negatieven", ., fixed = TRUE) %>%
gsub("unknown Gram positives", "onbekende Gram-positieven", ., fixed = TRUE) %>%
gsub("unknown name", "onbekende naam", ., fixed = TRUE) %>%
gsub("unknown kingdom", "onbekend koninkrijk", ., fixed = TRUE) %>%
gsub("unknown phylum", "onbekende fylum", ., fixed = TRUE) %>%
gsub("unknown class", "onbekende klasse", ., fixed = TRUE) %>%
gsub("unknown order", "onbekende orde", ., fixed = TRUE) %>%
gsub("unknown family", "onbekende familie", ., fixed = TRUE) %>%
gsub("unknown genus", "onbekend geslacht", ., fixed = TRUE) %>%
gsub("unknown species", "onbekende soort", ., fixed = TRUE) %>%
gsub("unknown subspecies", "onbekende ondersoort", ., fixed = TRUE) %>%
gsub("unknown rank", "onbekende rang", ., fixed = TRUE) %>%
gsub("(CoNS)", "(CNS)", ., fixed = TRUE) %>%
gsub("(CoPS)", "(CPS)", ., fixed = TRUE) %>%
gsub("Gram negative", "Gram-negatief", ., fixed = TRUE) %>%
gsub("Gram positive", "Gram-positief", ., fixed = TRUE) %>%
gsub("Bacteria", "Bacteri\u00ebn", ., fixed = TRUE) %>%
gsub("Fungi", "Schimmels/gisten", ., fixed = TRUE) %>%
gsub("Protozoa", "protozo\u00ebn", ., fixed = TRUE) %>%
gsub("biogroup", "biogroep", ., fixed = TRUE) %>%
# gsub("biotype", "biotype", ., fixed = TRUE) %>%
gsub("vegetative", "vegetatief", ., fixed = TRUE) %>%
gsub("([([ ]*?)group", "\\1groep", .) %>%
gsub("([([ ]*?)Group", "\\1Groep", .) %>%
iconv(to = "UTF-8"),
# Spanish
language == "es" ~ x[x_tobetranslated] %>%
# not 'negativa'
# https://www.sciencedirect.com/science/article/pii/S0123939215000739
gsub("Coagulase-negative Staphylococcus","Staphylococcus coagulasa negativo", ., fixed = TRUE) %>%
gsub("Coagulase-positive Staphylococcus","Staphylococcus coagulasa positivo", ., fixed = TRUE) %>%
gsub("Beta-haemolytic Streptococcus", "Streptococcus Beta-hemol\u00edtico", ., fixed = TRUE) %>%
gsub("unknown Gram negatives", "Gram negativos desconocidos", ., fixed = TRUE) %>%
gsub("unknown Gram positives", "Gram positivos desconocidos", ., fixed = TRUE) %>%
gsub("unknown name", "nombre desconocido", ., fixed = TRUE) %>%
gsub("unknown kingdom", "reino desconocido", ., fixed = TRUE) %>%
gsub("unknown phylum", "filo desconocido", ., fixed = TRUE) %>%
gsub("unknown class", "clase desconocida", ., fixed = TRUE) %>%
gsub("unknown order", "orden desconocido", ., fixed = TRUE) %>%
gsub("unknown family", "familia desconocida", ., fixed = TRUE) %>%
gsub("unknown genus", "g\u00e9nero desconocido", ., fixed = TRUE) %>%
gsub("unknown species", "especie desconocida", ., fixed = TRUE) %>%
gsub("unknown subspecies", "subespecie desconocida", ., fixed = TRUE) %>%
gsub("unknown rank", "rango desconocido", ., fixed = TRUE) %>%
gsub("(CoNS)", "(SCN)", ., fixed = TRUE) %>%
gsub("(CoPS)", "(SCP)", ., fixed = TRUE) %>%
gsub("Gram negative", "Gram negativo", ., fixed = TRUE) %>%
gsub("Gram positive", "Gram positivo", ., fixed = TRUE) %>%
gsub("Bacteria", "Bacterias", ., fixed = TRUE) %>%
gsub("Fungi", "Hongos", ., fixed = TRUE) %>%
gsub("Protozoa", "Protozoarios", ., fixed = TRUE) %>%
gsub("biogroup", "biogrupo", ., fixed = TRUE) %>%
gsub("biotype", "biotipo", ., fixed = TRUE) %>%
gsub("vegetative", "vegetativo", ., fixed = TRUE) %>%
gsub("([([ ]*?)group", "\\1grupo", .) %>%
gsub("([([ ]*?)Group", "\\1Grupo", .) %>%
iconv(to = "UTF-8"),
# Italian
language == "it" ~ x[x_tobetranslated] %>%
gsub("Coagulase-negative Staphylococcus","Staphylococcus negativo coagulasi", ., fixed = TRUE) %>%
gsub("Coagulase-positive Staphylococcus","Staphylococcus positivo coagulasi", ., fixed = TRUE) %>%
gsub("Beta-haemolytic Streptococcus", "Streptococcus Beta-emolitico", ., fixed = TRUE) %>%
gsub("unknown Gram negatives", "Gram negativi sconosciuti", ., fixed = TRUE) %>%
gsub("unknown Gram positives", "Gram positivi sconosciuti", ., fixed = TRUE) %>%
gsub("unknown name", "nome sconosciuto", ., fixed = TRUE) %>%
gsub("unknown kingdom", "regno sconosciuto", ., fixed = TRUE) %>%
gsub("unknown phylum", "phylum sconosciuto", ., fixed = TRUE) %>%
gsub("unknown class", "classe sconosciuta", ., fixed = TRUE) %>%
gsub("unknown order", "ordine sconosciuto", ., fixed = TRUE) %>%
gsub("unknown family", "famiglia sconosciuta", ., fixed = TRUE) %>%
gsub("unknown genus", "genere sconosciuto", ., fixed = TRUE) %>%
gsub("unknown species", "specie sconosciute", ., fixed = TRUE) %>%
gsub("unknown subspecies", "sottospecie sconosciute", ., fixed = TRUE) %>%
gsub("unknown rank", "grado sconosciuto", ., fixed = TRUE) %>%
gsub("Gram negative", "Gram negativo", ., fixed = TRUE) %>%
gsub("Gram positive", "Gram positivo", ., fixed = TRUE) %>%
gsub("Bacteria", "Batteri", ., fixed = TRUE) %>%
gsub("Fungi", "Fungo", ., fixed = TRUE) %>%
gsub("Protozoa", "Protozoi", ., fixed = TRUE) %>%
gsub("biogroup", "biogruppo", ., fixed = TRUE) %>%
gsub("biotype", "biotipo", ., fixed = TRUE) %>%
gsub("vegetative", "vegetativo", ., fixed = TRUE) %>%
gsub("([([ ]*?)group", "\\1gruppo", .) %>%
gsub("([([ ]*?)Group", "\\1Gruppo", .),
# French
language == "fr" ~ x[x_tobetranslated] %>%
gsub("Coagulase-negative Staphylococcus","Staphylococcus \u00e0 coagulase n\u00e9gative", ., fixed = TRUE) %>%
gsub("Coagulase-positive Staphylococcus","Staphylococcus \u00e0 coagulase positif", ., fixed = TRUE) %>%
gsub("Beta-haemolytic Streptococcus", "Streptococcus B\u00eata-h\u00e9molytique", ., fixed = TRUE) %>%
gsub("unknown Gram negatives", "Gram n\u00e9gatifs inconnus", ., fixed = TRUE) %>%
gsub("unknown Gram positives", "Gram positifs inconnus", ., fixed = TRUE) %>%
gsub("unknown name", "nom inconnu", ., fixed = TRUE) %>%
gsub("unknown kingdom", "r\u00e8gme inconnu", ., fixed = TRUE) %>%
gsub("unknown phylum", "embranchement inconnu", ., fixed = TRUE) %>%
gsub("unknown class", "classe inconnue", ., fixed = TRUE) %>%
gsub("unknown order", "ordre inconnu", ., fixed = TRUE) %>%
gsub("unknown family", "famille inconnue", ., fixed = TRUE) %>%
gsub("unknown genus", "genre inconnu", ., fixed = TRUE) %>%
gsub("unknown species", "esp\u00e8ce inconnue", ., fixed = TRUE) %>%
gsub("unknown subspecies", "sous-esp\u00e8ce inconnue", ., fixed = TRUE) %>%
gsub("unknown rank", "rang inconnu", ., fixed = TRUE) %>%
gsub("Gram negative", "Gram n\u00e9gatif", ., fixed = TRUE) %>%
gsub("Gram positive", "Gram positif", ., fixed = TRUE) %>%
gsub("Bacteria", "Bact\u00e9ries", ., fixed = TRUE) %>%
gsub("Fungi", "Champignons", ., fixed = TRUE) %>%
gsub("Protozoa", "Protozoaires", ., fixed = TRUE) %>%
gsub("biogroup", "biogroupe", ., fixed = TRUE) %>%
# gsub("biotype", "biotype", ., fixed = TRUE) %>%
gsub("vegetative", "v\u00e9g\u00e9tatif", ., fixed = TRUE) %>%
gsub("([([ ]*?)group", "\\1groupe", .) %>%
gsub("([([ ]*?)Group", "\\1Groupe", .) %>%
iconv(to = "UTF-8"),
# Portuguese
language == "pt" ~ x[x_tobetranslated] %>%
gsub("Coagulase-negative Staphylococcus","Staphylococcus coagulase negativo", ., fixed = TRUE) %>%
gsub("Coagulase-positive Staphylococcus","Staphylococcus coagulase positivo", ., fixed = TRUE) %>%
gsub("Beta-haemolytic Streptococcus", "Streptococcus Beta-hemol\u00edtico", ., fixed = TRUE) %>%
gsub("unknown Gram negatives", "Gram negativos desconhecidos", ., fixed = TRUE) %>%
gsub("unknown Gram positives", "Gram positivos desconhecidos", ., fixed = TRUE) %>%
gsub("unknown name", "nome desconhecido", ., fixed = TRUE) %>%
gsub("unknown kingdom", "reino desconhecido", ., fixed = TRUE) %>%
gsub("unknown phylum", "filo desconhecido", ., fixed = TRUE) %>%
gsub("unknown class", "classe desconhecida", ., fixed = TRUE) %>%
gsub("unknown order", "ordem desconhecido", ., fixed = TRUE) %>%
gsub("unknown family", "fam\u00edlia desconhecida", ., fixed = TRUE) %>%
gsub("unknown genus", "g\u00eanero desconhecido", ., fixed = TRUE) %>%
gsub("unknown species", "esp\u00e9cies desconhecida", ., fixed = TRUE) %>%
gsub("unknown subspecies", "subesp\u00e9cies desconhecida", ., fixed = TRUE) %>%
gsub("unknown rank", "classifica\u00e7\u00e3o desconhecido", ., fixed = TRUE) %>%
gsub("Gram negative", "Gram negativo", ., fixed = TRUE) %>%
gsub("Gram positive", "Gram positivo", ., fixed = TRUE) %>%
gsub("Bacteria", "Bact\u00e9rias", ., fixed = TRUE) %>%
gsub("Fungi", "Fungos", ., fixed = TRUE) %>%
gsub("Protozoa", "Protozo\u00e1rios", ., fixed = TRUE) %>%
gsub("biogroup", "biogrupo", ., fixed = TRUE) %>%
gsub("biotype", "bi\u00f3tipo", ., fixed = TRUE) %>%
gsub("vegetative", "vegetativo", ., fixed = TRUE) %>%
gsub("([([ ]*?)group", "\\1grupo", .) %>%
gsub("([([ ]*?)Group", "\\1Grupo", .) %>%
iconv(to = "UTF-8"))
x
t(mo_validate(x = x, property = property, ...), language = language)
}
mo_validate <- function(x, property, ...) {
@@ -591,7 +385,7 @@ mo_validate <- function(x, property, ...) {
}
# try to catch an error when inputting an invalid parameter
# so the call can be set to FALSE
# so the 'call.' can be set to FALSE
tryCatch(x[1L] %in% AMR::microorganisms[1, property],
error = function(e) stop(e$message, call. = FALSE))

124
R/portion.R
View File

@@ -29,15 +29,14 @@
#' @param as_percent a logical to indicate whether the output must be returned as a hundred fold with \% sign (a character). A value of \code{0.123456} will then be returned as \code{"12.3\%"}.
#' @param also_single_tested a logical to indicate whether (in combination therapies) also observations should be included where not all antibiotics were tested, but at least one of the tested antibiotics contains a target interpretation (e.g. S in case of \code{portion_S} and R in case of \code{portion_R}). \strong{This would lead to selection bias in almost all cases.}
#' @param data a \code{data.frame} containing columns with class \code{rsi} (see \code{\link{as.rsi}})
#' @param translate_ab a column name of the \code{\link{antibiotics}} data set to translate the antibiotic abbreviations to, using \code{\link{abname}}. This can be set with \code{\link{getOption}("get_antibiotic_names")}.
#' @param translate_ab a column name of the \code{\link{antibiotics}} data set to translate the antibiotic abbreviations to, using \code{\link{ab_property}}
#' @inheritParams ab_property
#' @param combine_IR a logical to indicate whether all values of I and R must be merged into one, so the output only consists of S vs. IR (susceptible vs. non-susceptible)
#' @details \strong{Remember that you should filter your table to let it contain only first isolates!} Use \code{\link{first_isolate}} to determine them in your data set.
#'
#' These functions are not meant to count isolates, but to calculate the portion of resistance/susceptibility. Use the \code{\link[AMR]{count}} functions to count isolates. \emph{Low counts can infuence the outcome - these \code{portion} functions may camouflage this, since they only return the portion albeit being dependent on the \code{minimum} parameter.}
#'
#' \code{portion_df} takes any variable from \code{data} that has an \code{"rsi"} class (created with \code{\link{as.rsi}}) and calculates the portions R, I and S. The resulting \emph{tidy data} (see Source) \code{data.frame} will have three rows (S/I/R) and a column for each variable with class \code{"rsi"}.
#'
#' The old \code{\link{rsi}} function is still available for backwards compatibility but is deprecated.
#' \if{html}{
# (created with https://www.latex4technics.com/)
#' \cr\cr
@@ -69,64 +68,64 @@
#' ?septic_patients
#'
#' # Calculate resistance
#' portion_R(septic_patients$amox)
#' portion_IR(septic_patients$amox)
#' portion_R(septic_patients$AMX)
#' portion_IR(septic_patients$AMX)
#'
#' # Or susceptibility
#' portion_S(septic_patients$amox)
#' portion_SI(septic_patients$amox)
#' portion_S(septic_patients$AMX)
#' portion_SI(septic_patients$AMX)
#'
#' # Do the above with pipes:
#' library(dplyr)
#' septic_patients %>% portion_R(amox)
#' septic_patients %>% portion_IR(amox)
#' septic_patients %>% portion_S(amox)
#' septic_patients %>% portion_SI(amox)
#' septic_patients %>% portion_R(AMX)
#' septic_patients %>% portion_IR(AMX)
#' septic_patients %>% portion_S(AMX)
#' septic_patients %>% portion_SI(AMX)
#'
#' septic_patients %>%
#' group_by(hospital_id) %>%
#' summarise(p = portion_S(cipr),
#' n = n_rsi(cipr)) # n_rsi works like n_distinct in dplyr
#' summarise(p = portion_S(CIP),
#' n = n_rsi(CIP)) # n_rsi works like n_distinct in dplyr
#'
#' septic_patients %>%
#' group_by(hospital_id) %>%
#' summarise(R = portion_R(cipr, as_percent = TRUE),
#' I = portion_I(cipr, as_percent = TRUE),
#' S = portion_S(cipr, as_percent = TRUE),
#' n1 = count_all(cipr), # the actual total; sum of all three
#' n2 = n_rsi(cipr), # same - analogous to n_distinct
#' summarise(R = portion_R(CIP, as_percent = TRUE),
#' I = portion_I(CIP, as_percent = TRUE),
#' S = portion_S(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!
#'
#' # Calculate co-resistance between amoxicillin/clav acid and gentamicin,
#' # so we can see that combination therapy does a lot more than mono therapy:
#' septic_patients %>% portion_S(amcl) # S = 71.4%
#' septic_patients %>% count_all(amcl) # n = 1879
#' septic_patients %>% portion_S(AMC) # S = 71.4%
#' septic_patients %>% count_all(AMC) # n = 1879
#'
#' septic_patients %>% portion_S(gent) # S = 74.0%
#' septic_patients %>% count_all(gent) # n = 1855
#' septic_patients %>% portion_S(GEN) # S = 74.0%
#' septic_patients %>% count_all(GEN) # n = 1855
#'
#' septic_patients %>% portion_S(amcl, gent) # S = 92.3%
#' septic_patients %>% count_all(amcl, gent) # n = 1798
#' septic_patients %>% portion_S(AMC, GEN) # S = 92.3%
#' septic_patients %>% count_all(AMC, GEN) # n = 1798
#'
#'
#' septic_patients %>%
#' group_by(hospital_id) %>%
#' summarise(cipro_p = portion_S(cipr, as_percent = TRUE),
#' cipro_n = count_all(cipr),
#' genta_p = portion_S(gent, as_percent = TRUE),
#' genta_n = count_all(gent),
#' combination_p = portion_S(cipr, gent, as_percent = TRUE),
#' combination_n = count_all(cipr, gent))
#' summarise(cipro_p = portion_S(CIP, as_percent = TRUE),
#' cipro_n = count_all(CIP),
#' genta_p = portion_S(GEN, as_percent = TRUE),
#' genta_n = count_all(GEN),
#' combination_p = portion_S(CIP, GEN, as_percent = TRUE),
#' combination_n = count_all(CIP, GEN))
#'
#' # Get portions S/I/R immediately of all rsi columns
#' septic_patients %>%
#' select(amox, cipr) %>%
#' select(AMX, CIP) %>%
#' portion_df(translate = FALSE)
#'
#' # It also supports grouping variables
#' septic_patients %>%
#' select(hospital_id, amox, cipr) %>%
#' select(hospital_id, AMX, CIP) %>%
#' group_by(hospital_id) %>%
#' portion_df(translate = FALSE)
#'
@@ -137,8 +136,8 @@
#' my_table %>%
#' filter(first_isolate == TRUE,
#' genus == "Helicobacter") %>%
#' summarise(p = portion_S(amox, metr), # amoxicillin with metronidazole
#' n = count_all(amox, metr))
#' summarise(p = portion_S(AMX, MTR), # amoxicillin with metronidazole
#' n = count_all(AMX, MTR))
#' }
portion_R <- function(...,
minimum = 30,
@@ -217,7 +216,8 @@ portion_S <- function(...,
#' @importFrom dplyr %>% select_if bind_rows summarise_if mutate group_vars select everything
#' @export
portion_df <- function(data,
translate_ab = getOption("get_antibiotic_names", "official"),
translate_ab = "name",
language = get_locale(),
minimum = 30,
as_percent = FALSE,
combine_IR = FALSE) {
@@ -230,10 +230,9 @@ portion_df <- function(data,
stop("No columns with class 'rsi' found. See ?as.rsi.")
}
if (as.character(translate_ab) == "TRUE") {
translate_ab <- "official"
if (as.character(translate_ab) %in% c("TRUE", "official")) {
translate_ab <- "name"
}
options(get_antibiotic_names = translate_ab)
resS <- summarise_if(.tbl = data,
.predicate = is.rsi,
@@ -282,55 +281,8 @@ portion_df <- function(data,
}
if (!translate_ab == FALSE) {
if (!tolower(translate_ab) %in% tolower(colnames(AMR::antibiotics))) {
stop("Parameter `translate_ab` does not occur in the `antibiotics` data set.", call. = FALSE)
}
res <- res %>% mutate(Antibiotic = abname(Antibiotic, from = "guess", to = translate_ab))
res <- res %>% mutate(Antibiotic = ab_property(Antibiotic, property = translate_ab, language = language))
}
res
}
#' Calculate resistance of isolates
#'
#' This function is deprecated. Use the \code{\link{portion}} functions instead.
#' @inheritParams portion
#' @param ab1,ab2 vector (or column) with antibiotic interpretations. It will be transformed internally with \code{\link{as.rsi}} if needed.
#' @param interpretation antimicrobial interpretation to check for
#' @param ... deprecated parameters to support usage on older versions
#' @importFrom dplyr tibble case_when
#' @export
rsi <- function(ab1,
ab2 = NULL,
interpretation = "IR",
minimum = 30,
as_percent = FALSE,
...) {
.Deprecated(new = paste0("portion_", interpretation))
if (all(is.null(ab2))) {
df <- tibble(ab1 = ab1)
} else {
df <- tibble(ab1 = ab1,
ab2 = ab2)
}
if (!interpretation %in% c("S", "SI", "IS", "I", "RI", "IR", "R")) {
stop("invalid interpretation")
}
result <- case_when(
interpretation == "S" ~ portion_S(df, minimum = minimum, as_percent = FALSE),
interpretation %in% c("SI", "IS") ~ portion_SI(df, minimum = minimum, as_percent = FALSE),
interpretation == "I" ~ portion_I(df, minimum = minimum, as_percent = FALSE),
interpretation %in% c("RI", "IR") ~ portion_IR(df, minimum = minimum, as_percent = FALSE),
interpretation == "R" ~ portion_R(df, minimum = minimum, as_percent = FALSE))
if (as_percent == TRUE) {
percent(result, force_zero = TRUE)
} else {
result
}
}

6
R/resistance_predict.R
View File

@@ -60,7 +60,7 @@
#' @importFrom dplyr %>% pull mutate mutate_at n group_by_at summarise filter filter_at all_vars n_distinct arrange case_when n_groups transmute
#' @inheritSection AMR Read more on our website!
#' @examples
#' x <- resistance_predict(septic_patients, col_ab = "amox", year_min = 2010)
#' x <- resistance_predict(septic_patients, col_ab = "AMX", year_min = 2010)
#' plot(x)
#' ggplot_rsi_predict(x)
#'
@@ -69,7 +69,7 @@
#' x <- septic_patients %>%
#' filter_first_isolate() %>%
#' filter(mo_genus(mo) == "Staphylococcus") %>%
#' resistance_predict("peni")
#' resistance_predict("PEN")
#' plot(x)
#'
#'
@@ -83,7 +83,7 @@
#'
#' data <- septic_patients %>%
#' filter(mo == as.mo("E. coli")) %>%
#' resistance_predict(col_ab = "amox",
#' resistance_predict(col_ab = "AMX",
#' col_date = "date",
#' info = FALSE,
#' minimum = 15)

213
R/rsi.R
View File

@@ -21,14 +21,20 @@
#' Class 'rsi'
#'
#' This transforms a vector to a new class \code{rsi}, which is an ordered factor with levels \code{S < I < R}. Invalid antimicrobial interpretations will be translated as \code{NA} with a warning.
#' Interpret MIC values according to EUCAST or CLSI, or clean up existing RSI values. This transforms the input to a new class \code{rsi}, which is an ordered factor with levels \code{S < I < R}. Invalid antimicrobial interpretations will be translated as \code{NA} with a warning.
#' @rdname as.rsi
#' @param x vector
#' @param x vector of values (for class \code{mic}: an MIC value in mg/L, for class \code{disk}: a disk diffusion radius in millimeters)
#' @param mo a microorganism code, generated with \code{\link{as.mo}}
#' @param ab an antibiotic code, generated with \code{\link{as.ab}}
#' @inheritParams first_isolate
#' @param guideline defaults to the latest included EUCAST guideline, run \code{unique(AMR::rsi_translation$guideline)} for all options
#' @param threshold maximum fraction of \code{x} that is allowed to fail transformation, see Examples
#' @details
#' \strong{NOTE:} This function does not translate MIC values to RSI values. If more than 50\% of the input resembles MIC values, it will warn about this.\cr You can use \code{\link{eucast_rules}} to (1) apply inferred susceptibility and resistance based on results of other antibiotics and (2) apply intrinsic resistance based on taxonomic properties of a microorganism.
#' @param ... parameters passed on to methods
#' @details Run \code{unique(AMR::rsi_translation$guideline)} for a list of all supported guidelines.
#'
#' The function \code{is.rsi.eligible} returns \code{TRUE} when a columns contains only valid antimicrobial interpretations (S and/or I and/or R), and \code{FALSE} otherwise.
#' After using \code{as.rsi}, you can use \code{\link{eucast_rules}} to (1) apply inferred susceptibility and resistance based on results of other antibiotics and (2) apply intrinsic resistance based on taxonomic properties of a microorganism.
#'
#' The function \code{is.rsi.eligible} returns \code{TRUE} when a columns contains at most 5\% invalid antimicrobial interpretations (not S and/or I and/or R), and \code{FALSE} otherwise. The threshold of 5\% can be set with the \code{threshold} parameter.
#' @return Ordered factor with new class \code{rsi}
#' @keywords rsi
#' @export
@@ -43,6 +49,16 @@
#' # this can also coerce combined MIC/RSI values:
#' as.rsi("<= 0.002; S") # will return S
#'
#' # interpret MIC values
#' as.rsi(x = as.mic(2),
#' mo = as.mo("S. pneumoniae"),
#' ab = "AMX",
#' guideline = "EUCAST")
#' as.rsi(x = as.mic(4),
#' mo = as.mo("S. pneumoniae"),
#' ab = "AMX",
#' guideline = "EUCAST")
#'
#' plot(rsi_data) # for percentages
#' barplot(rsi_data) # for frequencies
#' freq(rsi_data) # frequency table with informative header
@@ -50,7 +66,7 @@
#' # using dplyr's mutate
#' library(dplyr)
#' septic_patients %>%
#' mutate_at(vars(peni:rifa), as.rsi)
#' mutate_at(vars(PEN:RIF), as.rsi)
#'
#'
#' # fastest way to transform all columns with already valid AB results to class `rsi`:
@@ -60,16 +76,21 @@
#'
#' # default threshold of `is.rsi.eligible` is 5%.
#' is.rsi.eligible(WHONET$`First name`) # fails, >80% is invalid
#' is.rsi.eligible(WHONET$`First name`, threshold = 0.9) # succeeds
as.rsi <- function(x) {
#' is.rsi.eligible(WHONET$`First name`, threshold = 0.99) # succeeds
as.rsi <- function(x, ...) {
UseMethod("as.rsi")
}
#' @export
as.rsi.default <- function(x, ...) {
if (is.rsi(x)) {
x
} else if (identical(levels(x), c("S", "I", "R"))) {
structure(x, class = c('rsi', 'ordered', 'factor'))
} else {
if (input_resembles_mic(x) > 0.5) {
warning("`as.rsi` is intended to clean antimicrobial interpretations - not to interpret MIC values.", call. = FALSE)
}
# if (input_resembles_mic(x) > 0.5) {
# warning("`as.rsi` is intended to clean antimicrobial interpretations - not to interpret MIC values.", call. = FALSE)
# }
x <- x %>% unlist()
x.bak <- x
@@ -106,9 +127,8 @@ as.rsi <- function(x) {
list_missing, call. = FALSE)
}
x <- factor(x, levels = c("S", "I", "R"), ordered = TRUE)
class(x) <- c('rsi', 'ordered', 'factor')
x
structure(.Data = factor(x, levels = c("S", "I", "R"), ordered = TRUE),
class = c('rsi', 'ordered', 'factor'))
}
}
@@ -125,6 +145,160 @@ input_resembles_mic <- function(x) {
}
}
#' @rdname as.rsi
#' @importFrom dplyr case_when
#' @export
as.rsi.mic <- function(x, mo, ab, guideline = "EUCAST", ...) {
exec_as.rsi(method = "mic",
x = x,
mo = mo,
ab = ab,
guideline = guideline)
}
#' @rdname as.rsi
#' @export
as.rsi.disk <- function(x, mo, ab, guideline = "EUCAST", ...) {
exec_as.rsi(method = "disk",
x = x,
mo = mo,
ab = ab,
guideline = guideline)
}
exec_as.rsi <- function(method, x, mo, ab, guideline) {
if (method == "mic") {
x <- as.mic(x) # when as.rsi.mic is called directly
} else if (method == "disk") {
x <- as.disk(x) # when as.rsi.disk is called directly
}
mo <- as.mo(mo)
ab <- as.ab(ab)
mo_genus <- as.mo(mo_genus(mo))
mo_family <- as.mo(mo_family(mo))
mo_order <- as.mo(mo_order(mo))
mo_becker <- as.mo(mo, Becker = TRUE)
mo_lancefield <- as.mo(mo, Lancefield = TRUE)
guideline <- toupper(guideline)
if (guideline %in% c("CLSI", "EUCAST")) {
guideline <- AMR::rsi_translation %>%
filter(guideline %like% guideline) %>%
pull(guideline) %>%
sort() %>%
rev() %>%
.[1]
}
if (!guideline %in% AMR::rsi_translation$guideline) {
stop(paste0("invalid guideline: '", guideline,
"'.\nValid guidelines are: ", paste0("'", rev(sort(unique(AMR::rsi_translation$guideline))), "'", collapse = ", ")),
call. = FALSE)
}
new_rsi <- rep(NA_character_, length(x))
trans <- AMR::rsi_translation %>%
filter(guideline == guideline) %>%
mutate(lookup = paste(mo, 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)
for (i in 1:length(x)) {
get_record <- trans %>%
filter(lookup %in% c(lookup_mo[i],
lookup_genus[i],
lookup_family[i],
lookup_order[i],
lookup_becker[i],
lookup_lancefield[i])) %>%
# be as specific as possible (i.e. prefer species over genus):
arrange(desc(nchar(mo))) %>%
.[1L,]
if (NROW(get_record) > 0) {
if (method == "mic") {
new_rsi[i] <- case_when(is.na(get_record$S_mic) | is.na(get_record$R_mic) ~ NA_character_,
x[i] <= get_record$S_mic ~ "S",
x[i] >= get_record$R_mic ~ "R",
TRUE ~ "I")
} else if (method == "disk") {
new_rsi[i] <- case_when(is.na(get_record$S_disk) | is.na(get_record$R_disk) ~ NA_character_,
x[i] <= get_record$S_disk ~ "S",
x[i] >= get_record$R_disk ~ "R",
TRUE ~ "I")
}
}
}
structure(.Data = factor(new_rsi, levels = c("S", "I", "R"), ordered = TRUE),
class = c('rsi', 'ordered', 'factor'))
}
#' @rdname as.rsi
#' @importFrom crayon red blue
#' @export
as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", ...) {
tbl_ <- x
ab_cols <- colnames(tbl_)[sapply(tbl_, function(x) is.mic(x) | is.disk(x))]
if (length(ab_cols) == 0) {
stop("No columns with MIC values or disk zones found in this data set. Use as.mic or as.disk to transform antibiotic columns.", call. = FALSE)
}
# try to find columns based on type
# -- mo
if (is.null(col_mo)) {
col_mo <- search_type_in_df(tbl = tbl_, type = "mo")
}
if (is.null(col_mo)) {
stop("`col_mo` must be set.", call. = FALSE)
}
# transform all MICs
ab_cols <- colnames(tbl_)[sapply(tbl_, is.mic)]
if (length(ab_cols) > 0) {
for (i in 1:length(ab_cols)) {
if (is.na(suppressWarnings(as.ab(ab_cols[i])))) {
message(red(paste0("Unknown drug: `", bold(ab_cols[i]), "`. Rename this column to a drug name or code, and check the output with as.ab().")))
next
}
message(blue(paste0("Interpreting column `", bold(ab_cols[i]), "` (", ab_name(ab_cols[i], tolower = TRUE), ")...")), appendLF = FALSE)
tbl_[, ab_cols[i]] <- exec_as.rsi(method = "mic",
x = tbl_ %>% pull(ab_cols[i]),
mo = tbl_ %>% pull(col_mo),
ab = as.ab(ab_cols[i]),
guideline = guideline)
message(blue(" OK."))
}
}
# transform all disks
ab_cols <- colnames(tbl_)[sapply(tbl_, is.disk)]
if (length(ab_cols) > 0) {
for (i in 1:length(ab_cols)) {
if (is.na(suppressWarnings(as.ab(ab_cols[i])))) {
message(red(paste0("Unknown drug: `", bold(ab_cols[i]), "`. Rename this column to a drug name or code, and check the output with as.ab().")))
next
}
message(blue(paste0("Interpreting column `", bold(ab_cols[i]), "` (", ab_name(ab_cols[i], tolower = TRUE), ")...")), appendLF = FALSE)
tbl_[, ab_cols[i]] <- exec_as.rsi(method = "disk",
x = tbl_ %>% pull(ab_cols[i]),
mo = tbl_ %>% pull(col_mo),
ab = as.ab(ab_cols[i]),
guideline = guideline)
message(blue(" OK."))
}
}
tbl_
}
#' @rdname as.rsi
#' @export
is.rsi <- function(x) {
@@ -211,6 +385,15 @@ plot.rsi <- function(x, ...) {
filter(!is.na(x)) %>%
mutate(s = round((n / sum(n)) * 100, 1))
)
if (!"S" %in% data$x) {
data <- rbind(data, data.frame(x = "S", n = 0, s = 0))
}
if (!"I" %in% data$x) {
data <- rbind(data, data.frame(x = "I", n = 0, s = 0))
}
if (!"R" %in% data$x) {
data <- rbind(data, data.frame(x = "R", n = 0, s = 0))
}
data$x <- factor(data$x, levels = c('S', 'I', 'R'), ordered = TRUE)
@@ -239,7 +422,7 @@ plot.rsi <- function(x, ...) {
#' @exportMethod barplot.rsi
#' @export
#' @importFrom dplyr %>% group_by summarise filter mutate if_else n_distinct
#' @importFrom dplyr %>% group_by summarise
#' @importFrom graphics barplot axis
#' @noRd
barplot.rsi <- function(height, ...) {

5
R/rsi_calc.R
View File

@@ -73,6 +73,11 @@ rsi_calc <- function(...,
}
}
if (is.null(x)) {
warning("argument is NULL (check if columns exist): returning NA", call. = FALSE)
return(NA)
}
print_warning <- FALSE
type_trans <- as.integer(as.rsi(type))

1
R/zzz.R
View File

@@ -84,6 +84,7 @@ make <- function() {
"Treponema",
"Trichophyton",
"Ureaplasma")
| rank %in% c("kingdom", "phylum", "class", "order", "family")
~ 2,
TRUE ~ 3
))