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

(v0.8.0.9008) new verbose mode for MDROs

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2019-11-03 22:24:42 +01:00
parent 09c4b04cd0
commit 29e448883d
42 changed files with 338 additions and 343 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
R/availability.R
View File

@ -27,7 +27,7 @@
#' @details The function returns a \code{data.frame} with columns \code{"resistant"} and \code{"visual_resistance"}. The values in that columns are calculated with \code{\link{portion_R}}.
#' @return \code{data.frame} with column names of \code{tbl} as row names
#' @inheritSection AMR Read more on our website!
# @importFrom clean percentage
#' @importFrom cleaner percentage
#' @export
#' @examples
#' availability(example_isolates)

2
R/bug_drug_combinations.R
View File

@ -33,7 +33,6 @@
#' @inheritParams base::formatC
#' @importFrom dplyr %>% rename group_by select mutate filter summarise ungroup
#' @importFrom tidyr spread
# @importFrom clean freq percentage
#' @details The function \code{format} calculates the resistance per bug-drug combination. Use \code{combine_IR = FALSE} (default) to test R vs. S+I and \code{combine_IR = TRUE} to test R+I vs. S.
#'
#' The language of the output can be overwritten with \code{options(AMR_locale)}, please see \link{translate}.
@ -95,6 +94,7 @@ bug_drug_combinations <- function(x,
#' @importFrom dplyr everything rename %>% ungroup group_by summarise mutate_all arrange everything lag
#' @importFrom tidyr spread
#' @importFrom cleaner percentage
#' @exportMethod format.bug_drug_combinations
#' @export
#' @rdname bug_drug_combinations

1
R/catalogue_of_life.R
View File

@ -90,7 +90,6 @@ NULL
#' @export
#' @examples
#' library(dplyr)
#' library(clean)
#' microorganisms %>% freq(kingdom)
#' microorganisms %>% group_by(kingdom) %>% freq(phylum, nmax = NULL)
catalogue_of_life_version <- function() {

9
R/freq.R
View File

@ -19,14 +19,13 @@
# Visit our website for more info: https://msberends.gitlab.io/AMR. #
# ==================================================================== #
#' @importFrom clean freq
#' @importFrom cleaner freq
#' @export
clean::freq
cleaner::freq
#' @exportMethod freq.mo
#' @importFrom dplyr n_distinct
#' @importFrom clean freq.default
# @importFrom clean percentage
#' @importFrom cleaner freq.default percentage
#' @export
#' @noRd
freq.mo <- function(x, ...) {
@ -53,7 +52,7 @@ freq.mo <- function(x, ...) {
}
#' @exportMethod freq.rsi
#' @importFrom clean freq.default
#' @importFrom cleaner freq.default
#' @export
#' @noRd
freq.rsi <- function(x, ...) {

4
R/ggplot_rsi.R
View File

@ -337,7 +337,7 @@ facet_rsi <- function(facet = c("interpretation", "antibiotic"), nrow = NULL) {
}
#' @rdname ggplot_rsi
# @importFrom clean percentage
#' @importFrom cleaner percentage
#' @export
scale_y_percent <- function(breaks = seq(0, 1, 0.1), limits = NULL) {
stopifnot_installed_package("ggplot2")
@ -387,7 +387,7 @@ theme_rsi <- function() {
#' @rdname ggplot_rsi
#' @importFrom dplyr mutate %>% group_by_at
# @importFrom clean percentage
#' @importFrom cleaner percentage
#' @export
labels_rsi_count <- function(position = NULL,
x = "antibiotic",

1
R/like.R
View File

@ -48,7 +48,6 @@
#'
#' # get frequencies of bacteria whose name start with 'Ent' or 'ent'
#' library(dplyr)
#' library(clean)
#' example_isolates %>%
#' left_join_microorganisms() %>%
#' filter(genus %like% '^ent') %>%

284
R/mdro.R
View File

@ -22,13 +22,16 @@
#' Determine multidrug-resistant organisms (MDRO)
#'
#' Determine which isolates are multidrug-resistant organisms (MDRO) according to (country-specific) guidelines.
#' @param x table with antibiotic columns, like e.g. \code{AMX} and \code{AMC}
#' @param guideline a specific guideline to follow. When left empty, the publication by Magiorakos \emph{et al.} (2012, Clinical Microbiology and Infection) will be followed, see Details.
#' @param info print progress
#' @inheritParams eucast_rules
#' @param verbose print additional info: missing antibiotic columns per parameter
#' @param pct_required_classes minimal required percentage of antimicrobial classes that must be available per isolate, rounded down. For example, with the default guideline, 17 antimicrobial classes must be available for \emph{S. aureus}. Setting this \code{pct_required_classes} argument to \code{0.5} (default) means that for every \emph{S. aureus} isolate at least 8 different classes must be available. Any lower number of available classes will return \code{NA} for that isolate.
#' @param verbose a logical to turn Verbose mode on and off (default is off). In Verbose mode, the function does not return the MDRO results, but instead returns a data set in logbook form with extensive info about which isolates would be MDRO-positive, or why they are not.
#' @inheritSection eucast_rules Antibiotics
#' @details Currently supported guidelines are (case-insensitive):
#' @details
#' For the \code{pct_required_classes} argument, values above 1 will be divided by 100. This is to support both fractions (\code{0.75} or \code{3/4}) and percentages (\code{75}).
#' Currently supported guidelines are (case-insensitive):
#' \itemize{
#' \item{\code{guideline = "CMI2012"}: Magiorakos AP, Srinivasan A \emph{et al.} "Multidrug-resistant, extensively drug-resistant and pandrug-resistant bacteria: an international expert proposal for interim standard definitions for acquired resistance." Clinical Microbiology and Infection (2012) (\href{https://www.clinicalmicrobiologyandinfection.com/article/S1198-743X(14)61632-3/fulltext}{link})}
#' \item{\code{guideline = "EUCAST"}: The European international guideline - 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})}
@ -38,6 +41,7 @@
#' }
#'
#' Please suggest your own (country-specific) guidelines by letting us know: \url{https://gitlab.com/msberends/AMR/issues/new}.
#'
#' @return \itemize{
#' \item{CMI 2012 paper - function \code{mdr_cmi2012()} or \code{mdro()}:\cr Ordered factor with levels \code{Negative < Multi-drug-resistant (MDR) < Extensively drug-resistant (XDR) < Pandrug-resistant (PDR)}}
#' \item{TB guideline - function \code{mdr_tb()} or \code{mdro(..., guideline = "TB")}:\cr Ordered factor with levels \code{Negative < Mono-resistant < Poly-resistant < Multi-drug-resistant < Extensively drug-resistant}}
@ -47,6 +51,7 @@
#' @rdname mdro
#' @importFrom dplyr %>% filter_all
#' @importFrom crayon blue bold italic
#' @importFrom cleaner percentage
#' @export
#' @inheritSection AMR Read more on our website!
#' @source
@ -54,13 +59,13 @@
#' @examples
#' library(dplyr)
#'
#' example_isolates %>%
#' mdro() %>%
#' example_isolates %>%
#' mdro() %>%
#' freq()
#'
#' \donttest{
#' example_isolates %>%
#' mutate(EUCAST = mdro(.),
#' mutate(EUCAST = eucast_exceptional_phenotypes(.),
#' BRMO = brmo(.),
#' MRGN = mrgn(.))
#'
@ -74,13 +79,35 @@ mdro <- function(x,
col_mo = NULL,
info = TRUE,
verbose = FALSE,
pct_required_classes = 0.5,
...) {
if (verbose == TRUE & interactive()) {
txt <- paste0("WARNING: In Verbose mode, the mdro() function does not return the MDRO results, but instead returns a data set in logbook form with extensive info about which isolates would be MDRO-positive, or why they are not.",
"\n\nThis may overwrite your existing data if you use e.g.:",
"\ndata <- mdro(data, verbose = TRUE)\n\nDo you want to continue?")
if ("rstudioapi" %in% rownames(utils::installed.packages())) {
q_continue <- rstudioapi::showQuestion("Using verbose = TRUE with mdro()", txt)
} else {
q_continue <- menu(choices = c("OK", "Cancel"), graphics = TRUE, title = txt)
}
if (q_continue %in% c(FALSE, 2)) {
message("Cancelled, returning original data")
return(x)
}
}
if (!is.data.frame(x)) {
stop("`x` must be a data frame.", call. = FALSE)
}
if (!is.numeric(pct_required_classes)) {
stop("`pct_required_classes` must be numeric.", call. = FALSE)
}
if (pct_required_classes > 1) {
# allow pct_required_classes = 75 -> pct_required_classes = 0.75
pct_required_classes <- pct_required_classes / 100
}
if (!is.null(list(...)$country)) {
warning("Using `country` is deprecated, use `guideline` instead. Please see ?mdro.", call. = FALSE)
guideline <- list(...)$country
@ -88,7 +115,7 @@ mdro <- function(x,
if (length(guideline) > 1) {
stop("`guideline` must be a length one character string.", call. = FALSE)
}
if (is.null(guideline)) {
# default to the paper by Magiorakos et al. (2012)
guideline <- "cmi2012"
@ -103,7 +130,7 @@ mdro <- function(x,
stop("invalid guideline: ", guideline, call. = FALSE)
}
guideline <- list(code = tolower(guideline))
# try to find columns based on type
# -- mo
if (is.null(col_mo)) {
@ -118,7 +145,7 @@ mdro <- function(x,
if (is.null(col_mo)) {
stop("`col_mo` must be set.", call. = FALSE)
}
if (guideline$code == "cmi2012") {
guideline$name <- "Multidrug-resistant, extensively drug-resistant and pandrug-resistant bacteria: an international expert proposal for interim standard definitions for acquired resistance."
guideline$author <- "Magiorakos AP, Srinivasan A, Carey RB, ..., Vatopoulos A, Weber JT, Monnet DL"
@ -130,13 +157,13 @@ mdro <- function(x,
guideline$author <- "EUCAST (European Committee on Antimicrobial Susceptibility Testing)"
guideline$version <- "3.1"
guideline$source <- "http://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/Expert_rules_intrinsic_exceptional_V3.1.pdf"
} else if (guideline$code == "tb") {
guideline$name <- "Companion handbook to the WHO guidelines for the programmatic management of drug-resistant tuberculosis"
guideline$author <- "WHO (World Health Organization)"
guideline$version <- "WHO/HTM/TB/2014.11"
guideline$source <- "https://www.who.int/tb/publications/pmdt_companionhandbook/en/"
# support per country:
} else if (guideline$code == "mrgn") {
guideline$name <- "Cross-border comparison of the Dutch and German guidelines on multidrug-resistant Gram-negative microorganisms"
@ -152,7 +179,7 @@ mdro <- function(x,
} else {
stop("This guideline is currently unsupported: ", guideline$code, call. = FALSE)
}
if (guideline$code == "cmi2012") {
cols_ab <- get_column_abx(x = x,
soft_dependencies = c(
@ -270,7 +297,7 @@ mdro <- function(x,
"TCY",
"DOX",
"MNO"
),
),
verbose = verbose, ...)
} else if (guideline$code == "tb") {
cols_ab <- get_column_abx(x = x,
@ -295,7 +322,7 @@ mdro <- function(x,
} else {
cols_ab <- get_column_abx(x = x, verbose = verbose, ...)
}
AMC <- cols_ab["AMC"]
AMK <- cols_ab["AMK"]
AMP <- cols_ab["AMP"]
@ -391,21 +418,23 @@ mdro <- function(x,
bold("Source: "), guideline$source, "\n",
"\n", sep = "")
}
ab_missing <- function(ab) {
isTRUE(ab %in% c(NULL, NA)) | length(ab) == 0
}
ab_NA <- function(x) {
x[!is.na(x)]
}
verbose_df <- NULL
# antibiotic classes
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)]
@ -421,41 +450,41 @@ mdro <- function(x,
}
rows <- rows[rows %in% row_filter]
x[rows, "MDRO"] <<- to
x[rows, "reason"] <<- paste0(any_all, " of these ", ifelse(any_all == "any", "is", "are"), " R: ",
paste(cols, collapse = ", "))
}
}
trans_tbl2 <- function(txt, rows, lst) {
if (info == TRUE) {
message(blue(txt, "..."), appendLF = FALSE)
}
# function specific for the CMI paper of 2012 (Magiorakos et al.)
lst_vector <- unlist(lst)[!is.na(unlist(lst))]
x$total_groups <- NA_integer_
x$affected_groups <- NA_integer_
x[rows, "total_groups"] <- length(lst)
# now the hard part - using two sapply()s for super fast results:
# [1] run through all `rows` with sapply()
# [2] within each row, run through all antibiotic groups with another sapply()
# [3] determine for each antibiotic group in that row if at least 1 drug is R of I
# [4] sum the number of TRUEs of this determination
x[rows, "affected_groups"] <- sapply(rows,
function(row, group_tbl = lst) {
sum(sapply(group_tbl,
function(group) {
any(x[row, group[!is.na(group)]] == "R") |
any(x[row, group[!is.na(group)]] == "I")
}),
na.rm = TRUE)
})
# now set MDROs:
# MDR (=2): >=3 groups affected
x[which(x$row_number %in% rows & x$affected_groups >= 3), "MDRO"] <<- 2
# XDR (=3): all but <=2 groups affected
x[which(x$row_number %in% rows & (x$total_groups - x$affected_groups) <= 2), "MDRO"] <<- 3
# PDR (=4): all agents are R
x[filter_at(x[rows, ],
vars(lst_vector),
all_vars(. %in% c("R", "I")))$row_number,
"MDRO"] <<- 4
if (length(rows) > 0) {
# function specific for the CMI paper of 2012 (Magiorakos et al.)
lst_vector <- unlist(lst)[!is.na(unlist(lst))]
x[rows, "classes_in_guideline"] <<- length(lst)
x[rows, "classes_available"] <<- sapply(rows,
function(row, group_tbl = lst) {
sum(sapply(group_tbl, function(group) !all(is.na(group))))
})
# now the hard part - using two sapply()s for super fast results:
# [1] run through all `rows` with sapply()
# [2] within each row, run through all antibiotic classes with another sapply()
# [3] determine for each antibiotic group in that row if at least 1 drug is R of I
# [4] sum the number of TRUEs of this determination
x[rows, "classes_affected"] <<- sapply(rows,
function(row, group_tbl = lst) {
sum(sapply(group_tbl,
function(group) {
any(x[row, group[!is.na(group)]] == "R") |
any(x[row, group[!is.na(group)]] == "I")
}),
na.rm = TRUE)
})
x[filter_at(x[rows,],
vars(lst_vector),
all_vars(. %in% c("R", "I")))$row_number, "classes_affected"] <<- 999
}
if (info == TRUE) {
message(blue(" OK"))
}
@ -465,9 +494,10 @@ mdro <- function(x,
mutate_at(vars(col_mo), as.mo) %>%
# join to microorganisms data set
left_join_microorganisms(by = col_mo) %>%
# add unconfirmed to where genus is available
# add unavailable to where genus is available
mutate(MDRO = ifelse(!is.na(genus), 1, NA_integer_),
row_number = seq_len(nrow(.))) %>%
row_number = seq_len(nrow(.)),
reason = paste0("not covered by ", toupper(guideline$code), " guideline")) %>%
# transform to data.frame so subsetting is possible with x[y, z] (might not be the case with tibble/data.table/...)
as.data.frame(stringsAsFactors = FALSE)
@ -475,19 +505,34 @@ mdro <- function(x,
# CMI, 2012 ---------------------------------------------------------------
# Non-susceptible = R and I
# (see header 'Approaches to Creating Definitions for MDR, XDR and PDR' in paper)
# take amoxicillin if ampicillin is unavailable
if (is.na(AMP) & !is.na(AMX)) AMP <- AMX
if (is.na(AMP) & !is.na(AMX)) {
if (verbose == TRUE) {
message(blue("NOTE: Filling ampicillin (AMP) results with amoxicillin (AMX) results"))
}
AMP <- AMX
}
# take ceftriaxone if cefotaxime is unavailable and vice versa
if (is.na(CRO) & !is.na(CTX)) CRO <- CTX
if (is.na(CTX) & !is.na(CRO)) CTX <- CRO
if (is.na(CRO) & !is.na(CTX)) {
if (verbose == TRUE) {
message(blue("NOTE: Filling ceftriaxone (CRO) results with cefotaxime (CTX) results"))
}
CRO <- CTX
}
if (is.na(CTX) & !is.na(CRO)) {
if (verbose == TRUE) {
message(blue("NOTE: Filling cefotaxime (CTX) results with ceftriaxone (CRO) results"))
}
CTX <- CRO
}
# intrinsic resistant must not be considered for the determination of MDR,
# so let's just remove them, meticulously following the paper
x[which(x$genus == "Enterococcus" & x$species == "faecium"), ab_NA(IPM)] <- NA
x[which(x$genus == "Enterococcus" & x$species == "faecalis"), ab_NA(QDA)] <- NA
x[which((x$genus == "Providencia" & x$species == "rettgeri")
| (x$genus == "Providencia" & x$species == "stuartii")), ab_NA(c(GEN, TOB, NET))] <- NA
| (x$genus == "Providencia" & x$species == "stuartii")), ab_NA(c(GEN, TOB, NET))] <- NA
x[which(x$genus == "Escherichia" & x$species == "hermannii"), ab_NA(c(TCC, TZP))] <- NA
x[which((x$genus == "Citrobacter" & x$species == "freundii")
| (x$genus == "Enterobacter" & x$species == "aerogenes")
@ -554,6 +599,10 @@ mdro <- function(x,
| (x$genus == "Providencia" & x$species == "rettgeri")
| (x$genus == "Providencia" & x$species == "stuartii")), ab_NA(c(DOX, MNO))] <- NA
x$classes_in_guideline <- NA_integer_
x$classes_available <- NA_integer_
x$classes_affected <- NA_integer_
# now add the MDR levels to the data
trans_tbl(2,
which(x$genus == "Staphylococcus" & x$species == "aureus"),
@ -592,7 +641,7 @@ mdro <- function(x,
QDA,
c(DOX, MNO)))
trans_tbl2(paste0("Table 3 - ", italic("Enterobacteriaceae"),
" (before the taxonomic reclassification by Adeolu ", italic("et al."), ", 2016)"),
" (before the taxonomic reclassification by Adeolu ", italic("et al."), ", 2016)"),
# this new order was previously 'Enterobacteriales' and contained only the family 'Enterobacteriaceae':
which(x$order == "Enterobacterales"),
list(c(GEN, TOB, AMK, NET),
@ -634,6 +683,37 @@ mdro <- function(x,
SAM,
c(COL, PLB),
c(TCY, DOX, MNO)))
# now set MDROs:
# MDR (=2): >=3 classes affected
x[which(x$classes_affected >= 3), "MDRO"] <- 2
if (verbose == TRUE) {
x[which(x$classes_affected >= 3), "reason"] <- paste0("at least 3 classes contain R or I: ", x$classes_affected[which(x$classes_affected >= 3)],
" out of ", x$classes_available[which(x$classes_affected >= 3)], " available classes")
}
# XDR (=3): all but <=2 classes affected
x[which((x$classes_in_guideline - x$classes_affected) <= 2), "MDRO"] <- 3
if (verbose == TRUE) {
x[which((x$classes_in_guideline - x$classes_affected) <= 2), "reason"] <- paste0("less than 3 classes remain susceptible (", x$classes_in_guideline[which((x$classes_in_guideline - x$classes_affected) <= 2)] - x$classes_affected[which((x$classes_in_guideline - x$classes_affected) <= 2)],
" out of ", x$classes_in_guideline[which((x$classes_in_guideline - x$classes_affected) <= 2)], " classes)")
}
# PDR (=4): all agents are R
x[which(x$classes_affected == 999 & x$classes_in_guideline == x$classes_available), "MDRO"] <- 4
if (verbose == TRUE) {
x[which(x$classes_affected == 999 & x$classes_in_guideline == x$classes_available), "reason"] <- paste("all antibiotics in all", x$classes_in_guideline[which(x$classes_affected == 999 & x$classes_in_guideline == x$classes_available)], "classes were tested R or I")
}
# not enough classes available
x[which(x$classes_available < base::floor(x$classes_in_guideline * pct_required_classes)), "MDRO"] <- -1
if (verbose == TRUE) {
x[which(x$classes_available < base::floor(x$classes_in_guideline * pct_required_classes)), "reason"] <- paste0("not enough classes available: ", x$classes_available[which(x$classes_available < base::floor(x$classes_in_guideline * pct_required_classes))],
" instead of ", (base::floor(x$classes_in_guideline * pct_required_classes))[which(x$classes_available < base::floor(x$classes_in_guideline * pct_required_classes))],
" (~", percentage(pct_required_classes), " of ", x$classes_in_guideline[which(x$classes_available < base::floor(x$classes_in_guideline * pct_required_classes))], ")")
}
# some more info on negative results
if (verbose == TRUE) {
x[which(x$MDRO == 1 & !is.na(x$classes_affected)), "reason"] <- paste0(x$classes_affected[which(x$MDRO == 1 & !is.na(x$classes_affected))], " of ", x$classes_available[which(x$MDRO == 1 & !is.na(x$classes_affected))], " available classes contain R or I (3 required for MDR)")
}
}
if (guideline$code == "eucast") {
@ -693,14 +773,14 @@ mdro <- function(x,
# Table 7
trans_tbl(3,
which(x$genus == "Bacteroides"),
MTR,
MTR,
"any")
trans_tbl(3,
which(x$fullname %like% "^Clostridium difficile"),
c(MTR, VAN),
"any")
}
if (guideline$code == "mrgn") {
# Germany -----------------------------------------------------------------
CTX_or_CAZ <- CTX %or% CAZ
@ -715,7 +795,7 @@ mdro <- function(x,
# Table 1
x[which((x$order == "Enterobacterales" | # following in fact the old Enterobacteriaceae classification
x$fullname %like% "^Acinetobacter baumannii") &
x$fullname %like% "^Acinetobacter baumannii") &
x[, PIP] == "R" &
x[, CTX_or_CAZ] == "R" &
x[, IPM_or_MEM] == "S" &
@ -749,7 +829,7 @@ mdro <- function(x,
x[, CIP] == "R"),
"MDRO"] <- 3 # 3 = 4MRGN
}
if (guideline$code == "brmo") {
# Netherlands -------------------------------------------------------------
aminoglycosides <- aminoglycosides[!is.na(aminoglycosides)]
@ -762,23 +842,23 @@ mdro <- function(x,
if (length(ESBLs) != 2) {
ESBLs <- character(0)
}
# Table 1
trans_tbl(3,
which(x$order == "Enterobacterales"), # following in fact the old Enterobacteriaceae classification
c(aminoglycosides, fluoroquinolones),
"all")
trans_tbl(2,
which(x$order == "Enterobacterales"), # following in fact the old Enterobacteriaceae classification
carbapenems,
"any")
trans_tbl(2,
which(x$order == "Enterobacterales"), # following in fact the old Enterobacteriaceae classification
ESBLs,
"all")
# Table 2
trans_tbl(2,
which(x$genus == "Acinetobacter"),
@ -788,12 +868,12 @@ mdro <- function(x,
which(x$genus == "Acinetobacter"),
c(aminoglycosides, fluoroquinolones),
"all")
trans_tbl(3,
which(x$fullname %like% "^Stenotrophomonas maltophilia"),
SXT,
"all")
if (!ab_missing(MEM) & !ab_missing(IPM)
& !ab_missing(GEN) & !ab_missing(TOB)
& !ab_missing(CIP)
@ -812,7 +892,7 @@ mdro <- function(x,
x$fullname %like% "Pseudomonas aeruginosa"
& x$psae >= 3
), "MDRO"] <- 3
# Table 3
trans_tbl(3,
which(x$fullname %like% "Streptococcus pneumoniae"),
@ -827,7 +907,7 @@ mdro <- function(x,
c(PEN, VAN),
"all")
}
prepare_drug <- function(ab) {
# returns vector values of drug
# if `ab` is a column name, looks up the values in `x`
@ -858,7 +938,7 @@ mdro <- function(x,
ab != "R"
}
}
if (guideline$code == "tb") {
# Tuberculosis ------------------------------------------------------------
x <- x %>%
@ -881,43 +961,59 @@ mdro <- function(x,
TRUE, FALSE),
xdr = ifelse(mdr & xdr & second, TRUE, FALSE)) %>%
mutate(MDRO = case_when(xdr ~ 5,
mdr ~ 4,
poly ~ 3,
mono ~ 2,
TRUE ~ 1),
mdr ~ 4,
poly ~ 3,
mono ~ 2,
TRUE ~ 1),
# keep all real TB, make other species NA
MDRO = ifelse(x$fullname == "Mycobacterium tuberculosis", MDRO, NA_real_))
}
if (info == TRUE) {
cat(bold(paste0("=> Found ", sum(x$MDRO %in% c(2:5), na.rm = TRUE), " MDROs out of ", sum(!is.na(x$MDRO)),
" possible cases (", percentage(sum(x$MDRO %in% c(2:5), na.rm = TRUE) / sum(!is.na(x$MDRO))), ")")))
" tested isolates (", percentage(sum(x$MDRO %in% c(2:5), na.rm = TRUE) / sum(!is.na(x$MDRO))), ")\n")))
}
# return results
# Results ----
if (guideline$code == "cmi2012") {
factor(x = x$MDRO,
levels = 1:4,
labels = c("Negative", "Multi-drug-resistant (MDR)",
"Extensively drug-resistant (XDR)", "Pandrug-resistant (PDR)"),
ordered = TRUE)
if (any(x$MDRO == -1)) {
warning("NA introduced for isolates where the available percentage of antimicrobial classes was below ",
percentage(pct_required_classes), " (set with `pct_required_classes`)")
# set these -1s to NA
x[which(x$MDRO == -1), "MDRO"] <- NA_integer_
}
x$MDRO <- factor(x = x$MDRO,
levels = 1:4,
labels = c("Negative", "Multi-drug-resistant (MDR)",
"Extensively drug-resistant (XDR)", "Pandrug-resistant (PDR)"),
ordered = TRUE)
} else if (guideline$code == "tb") {
factor(x = x$MDRO,
levels = 1:5,
labels = c("Negative", "Mono-resistant", "Poly-resistant",
"Multi-drug-resistant", "Extensively drug-resistant"),
ordered = TRUE)
x$MDRO <- factor(x = x$MDRO,
levels = 1:5,
labels = c("Negative", "Mono-resistant", "Poly-resistant",
"Multi-drug-resistant", "Extensively drug-resistant"),
ordered = TRUE)
} else if (guideline$code == "mrgn") {
factor(x = x$MDRO,
levels = 1:3,
labels = c("Negative", "3MRGN", "4MRGN"),
ordered = TRUE)
x$MDRO <- factor(x = x$MDRO,
levels = 1:3,
labels = c("Negative", "3MRGN", "4MRGN"),
ordered = TRUE)
} else {
factor(x = x$MDRO,
levels = 1:3,
labels = c("Negative", "Positive, unconfirmed", "Positive"),
ordered = TRUE)
x$MDRO <- factor(x = x$MDRO,
levels = 1:3,
labels = c("Negative", "Positive, unconfirmed", "Positive"),
ordered = TRUE)
}
if (verbose == TRUE) {
x[, c("row_number",
col_mo,
"MDRO",
"reason")]
} else {
x$MDRO
}
}
#' @rdname mdro

103
R/mic.R
View File

@ -51,8 +51,6 @@
#'
#' plot(mic_data)
#' barplot(mic_data)
#'
#' library(clean)
#' freq(mic_data)
as.mic <- function(x, na.rm = FALSE) {
if (is.mic(x)) {
@ -97,98 +95,15 @@ as.mic <- function(x, na.rm = FALSE) {
x[x.bak != "" & x == ""] <- "invalid"
# 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.005", "<=0.005", "0.005", ">=0.005", ">0.005",
"<0.006", "<=0.006", "0.006", ">=0.006", ">0.006",
"<0.007", "<=0.007", "0.007", ">=0.007", ">0.007",
"<0.008", "<=0.008", "0.008", ">=0.008", ">0.008",
"<0.009", "<=0.009", "0.009", ">=0.009", ">0.009",
"<0.01", "<=0.01", "0.01", ">=0.01", ">0.01",
"<0.012", "<=0.012", "0.012", ">=0.012", ">0.012",
"<0.0125", "<=0.0125", "0.0125", ">=0.0125", ">0.0125",
"<0.016", "<=0.016", "0.016", ">=0.016", ">0.016",
"<0.019", "<=0.019", "0.019", ">=0.019", ">0.019",
"<0.02", "<=0.02", "0.02", ">=0.02", ">0.02",
"<0.023", "<=0.023", "0.023", ">=0.023", ">0.023",
"<0.025", "<=0.025", "0.025", ">=0.025", ">0.025",
"<0.028", "<=0.028", "0.028", ">=0.028", ">0.028",
"<0.03", "<=0.03", "0.03", ">=0.03", ">0.03",
"<0.031", "<=0.031", "0.031", ">=0.031", ">0.031",
"<0.032", "<=0.032", "0.032", ">=0.032", ">0.032",
"<0.038", "<=0.038", "0.038", ">=0.038", ">0.038",
"<0.04", "<=0.04", "0.04", ">=0.04", ">0.04",
"<0.047", "<=0.047", "0.047", ">=0.047", ">0.047",
"<0.05", "<=0.05", "0.05", ">=0.05", ">0.05",
"<0.054", "<=0.054", "0.054", ">=0.054", ">0.054",
"<0.06", "<=0.06", "0.06", ">=0.06", ">0.06",
"<0.0625", "<=0.0625", "0.0625", ">=0.0625", ">0.0625",
"<0.063", "<=0.063", "0.063", ">=0.063", ">0.063",
"<0.064", "<=0.064", "0.064", ">=0.064", ">0.064",
"<0.075", "<=0.075", "0.075", ">=0.075", ">0.075",
"<0.08", "<=0.08", "0.08", ">=0.08", ">0.08",
"<0.09", "<=0.09", "0.09", ">=0.09", ">0.09",
"<0.094", "<=0.094", "0.094", ">=0.094", ">0.094",
"<0.095", "<=0.095", "0.095", ">=0.095", ">0.095",
"<0.1", "<=0.1", "0.1", ">=0.1", ">0.1",
"<0.12", "<=0.12", "0.12", ">=0.12", ">0.12",
"<0.125", "<=0.125", "0.125", ">=0.125", ">0.125",
"<0.128", "<=0.128", "0.128", ">=0.128", ">0.128",
"<0.15", "<=0.15", "0.15", ">=0.15", ">0.15",
"<0.16", "<=0.16", "0.16", ">=0.16", ">0.16",
"<0.17", "<=0.17", "0.17", ">=0.17", ">0.17",
"<0.18", "<=0.18", "0.18", ">=0.18", ">0.18",
"<0.19", "<=0.19", "0.19", ">=0.19", ">0.19",
"<0.2", "<=0.2", "0.2", ">=0.2", ">0.2",
"<0.23", "<=0.23", "0.23", ">=0.23", ">0.23",
"<0.25", "<=0.25", "0.25", ">=0.25", ">0.25",
"<0.256", "<=0.256", "0.256", ">=0.256", ">0.256",
"<0.28", "<=0.28", "0.28", ">=0.28", ">0.28",
"<0.3", "<=0.3", "0.3", ">=0.3", ">0.3",
"<0.32", "<=0.32", "0.32", ">=0.32", ">0.32",
"<0.35", "<=0.35", "0.35", ">=0.35", ">0.35",
"<0.36", "<=0.36", "0.36", ">=0.36", ">0.36",
"<0.38", "<=0.38", "0.38", ">=0.38", ">0.38",
"<0.47", "<=0.47", "0.47", ">=0.47", ">0.47",
"<0.5", "<=0.5", "0.5", ">=0.5", ">0.5",
"<0.512", "<=0.512", "0.512", ">=0.512", ">0.512",
"<0.64", "<=0.64", "0.64", ">=0.64", ">0.64",
"<0.73", "<=0.73", "0.73", ">=0.73", ">0.73",
"<0.75", "<=0.75", "0.75", ">=0.75", ">0.75",
"<0.8", "<=0.8", "0.8", ">=0.8", ">0.8",
"<0.94", "<=0.94", "0.94", ">=0.94", ">0.94",
"<1", "<=1", "1", ">=1", ">1",
"<1.5", "<=1.5", "1.5", ">=1.5", ">1.5",
"<2", "<=2", "2", ">=2", ">2",
"<3", "<=3", "3", ">=3", ">3",
"<4", "<=4", "4", ">=4", ">4",
"<5", "<=5", "5", ">=5", ">5",
"<6", "<=6", "6", ">=6", ">6",
"<7", "<=7", "7", ">=7", ">7",
"<8", "<=8", "8", ">=8", ">8",
"<10", "<=10", "10", ">=10", ">10",
"<12", "<=12", "12", ">=12", ">12",
"<16", "<=16", "16", ">=16", ">16",
"<20", "<=20", "20", ">=20", ">20",
"<24", "<=24", "24", ">=24", ">24",
"<32", "<=32", "32", ">=32", ">32",
"<40", "<=40", "40", ">=40", ">40",
"<48", "<=48", "48", ">=48", ">48",
"<64", "<=64", "64", ">=64", ">64",
"<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",
"513",
"<1024", "<=1024", "1024", ">=1024", ">1024",
"1025")
ops <- c("<", "<=", "", ">=", ">")
lvls <- c(c(t(sapply(ops, function(x) paste0(x, "0.00", 1:9)))),
unique(c(t(sapply(ops, function(x) paste0(x, sort(as.double(paste0("0.0",
sort(c(1:99, 125, 128, 256, 512, 625)))))))))),
unique(c(t(sapply(ops, function(x) paste0(x, sort(as.double(paste0("0.",
c(1:99, 125, 128, 256, 512))))))))),
c(t(sapply(ops, function(x) paste0(x, sort(c(1:9, 1.5)))))),
c(t(sapply(ops, function(x) paste0(x, c(10:98)[9:98 %% 2 == TRUE])))),
c(t(sapply(ops, function(x) paste0(x, sort(c(2 ^ c(7:10), 80 * c(2:12))))))))
na_before <- x[is.na(x) | x == ""] %>% length()
x[!x %in% lvls] <- NA

42
R/misc.R
View File

@ -127,45 +127,3 @@ class_integrity_check <- function(value, type, check_vector) {
}
value
}
# Percentages -------------------------------------------------------------
# Can all be removed when clean 1.2.0 is on CRAN
getdecimalplaces <- function(x, minimum = 0, maximum = 3) {
if (maximum < minimum) {
maximum <- minimum
}
if (minimum > maximum) {
minimum <- maximum
}
max_places <- max(unlist(lapply(strsplit(sub("0+$", "",
as.character(x * 100)), ".", fixed = TRUE),
function(y) ifelse(length(y) == 2, nchar(y[2]), 0))), na.rm = TRUE)
max(min(max_places,
maximum, na.rm = TRUE),
minimum, na.rm = 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)
if (digits > 0 & force_zero == TRUE) {
val[val != as.integer(val) & !is.na(val)] <- paste0(val[val != as.integer(val) & !is.na(val)],
strrep("0", max(0, digits - nchar(gsub(".*[.](.*)$", "\\1", val[val != as.integer(val) & !is.na(val)])))))
}
val
}
percentage <- function(x, digits = NULL, ...) {
if (is.null(digits)) {
digits <- getdecimalplaces(x, minimum = 0, maximum = 1)
}
# round right: percentage(0.4455) should return "44.6%", not "44.5%"
x <- as.numeric(round2(x, digits = digits + 2))
x_formatted <- format(as.double(x) * 100, scientific = FALSE, digits = digits, nsmall = digits, ...)
x_formatted[!is.na(x)] <- paste0(x_formatted[!is.na(x)], "%")
x_formatted
}

4
R/mo.R
View File

@ -267,7 +267,7 @@ is.mo <- function(x) {
#' @importFrom dplyr %>% pull left_join n_distinct progress_estimated filter distinct
#' @importFrom data.table data.table as.data.table setkey
#' @importFrom crayon magenta red blue silver italic
# @importFrom clean percentage
#' @importFrom cleaner percentage
# param property a column name of AMR::microorganisms
# param initial_search logical - is FALSE when coming from uncertain tries, which uses exec_as.mo internally too
# param dyslexia_mode logical - also check for characters that resemble others
@ -1774,7 +1774,7 @@ pillar_shaft.mo <- function(x, ...) {
#' @exportMethod summary.mo
#' @importFrom dplyr n_distinct
#' @importFrom clean freq top_freq
#' @importFrom cleaner freq top_freq
#' @export
#' @noRd
summary.mo <- function(object, ...) {

2
R/rsi.R
View File

@ -73,8 +73,6 @@
#'
#' plot(rsi_data) # for percentages
#' barplot(rsi_data) # for frequencies
#'
#' library(clean)
#' freq(rsi_data) # frequency table with informative header
#'
#' # using dplyr's mutate

2
R/rsi_calc.R
View File

@ -39,7 +39,7 @@ dots2vars <- function(...) {
}
#' @importFrom dplyr %>% pull all_vars any_vars filter_all funs mutate_all
# @importFrom clean percentage
#' @importFrom cleaner percentage
rsi_calc <- function(...,
ab_result,
minimum = 0,