2023-02-06 11:57:22 +01:00
# ==================================================================== #
# TITLE #
# AMR: An R Package for Working with Antimicrobial Resistance Data #
# #
# SOURCE #
# https://github.com/msberends/AMR #
# #
# CITE AS #
# Berends MS, Luz CF, Friedrich AW, Sinha BNM, Albers CJ, Glasner C #
# (2022). AMR: An R Package for Working with Antimicrobial Resistance #
# Data. Journal of Statistical Software, 104(3), 1-31. #
# doi:10.18637/jss.v104.i03 #
# #
# Developed at the University of Groningen and the University Medical #
# Center Groningen in The Netherlands, in collaboration with many #
# colleagues from around the world, see our website. #
# #
# 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. #
# We created this package for both routine data analysis and academic #
# research and it was publicly released in the hope that it will be #
# useful, but it comes WITHOUT ANY WARRANTY OR LIABILITY. #
# #
# Visit our website for the full manual and a complete tutorial about #
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
#' Generate Antibiogram: Traditional, Combined, Syndromic, or Weighted-Incidence Syndromic Combination (WISCA)
#'
2023-02-13 10:21:43 +01:00
#' Generate an antibiogram, and communicate the results in plots or tables. These functions follow the logic of Klinker *et al.* and Barbieri *et al.* (see *Source*), and allow reporting in e.g. R Markdown and Quarto as well.
2023-02-06 11:57:22 +01:00
#' @param x a [data.frame] containing at least a column with microorganisms and columns with antibiotic results (class 'sir', see [as.sir()])
2023-02-22 15:40:05 +01:00
#' @param antibiotics vector of any antibiotic name or code (will be evaluated with [as.ab()], column name of `x`, or (any combinations of) [antibiotic selectors][antibiotic_class_selectors] such as [aminoglycosides()] or [carbapenems()]. For combination antibiograms, this can also be set to values separated with `"+"`, such as "TZP+TOB" or "cipro + genta", given that columns resembling such antibiotics exist in `x`. See *Examples*.
2023-02-06 11:57:22 +01:00
#' @param mo_transform a character to transform microorganism input - must be "name", "shortname", "gramstain", or one of the column names of the [microorganisms] data set: `r vector_or(colnames(microorganisms), sort = FALSE, quotes = TRUE)`. Can also be `NULL` to not transform the input.
#' @param ab_transform a character to transform antibiotic input - must be one of the column names of the [antibiotics] data set: `r vector_or(colnames(antibiotics), sort = FALSE, quotes = TRUE)`. Can also be `NULL` to not transform the input.
#' @param syndromic_group a column name of `x`, or values calculated to split rows of `x`, e.g. by using [ifelse()] or [`case_when()`][dplyr::case_when()]. See *Examples*.
2023-02-22 14:38:57 +01:00
#' @param add_total_n a [logical] to indicate whether total available numbers per pathogen should be added to the table (default is `TRUE`). This will add the lowest and highest number of available isolate per antibiotic (e.g, if for *E. coli* 200 isolates are available for ciprofloxacin and 150 for amoxicillin, the returned number will be "150-200").
2023-02-06 11:57:22 +01:00
#' @param only_all_tested (for combination antibiograms): a [logical] to indicate that isolates must be tested for all antibiotics, see *Details*
#' @param digits number of digits to use for rounding
2023-02-22 14:38:57 +01:00
#' @param col_mo column name of the names or codes of the microorganisms (see [as.mo()]) - the default is the first column of class [`mo`]. Values will be coerced using [as.mo()].
2023-02-06 11:57:22 +01:00
#' @param language language to translate text, which defaults to the system language (see [get_AMR_locale()])
#' @param minimum the minimum allowed number of available (tested) isolates. Any isolate count lower than `minimum` will return `NA` with a warning. The default number of `30` isolates is advised by the Clinical and Laboratory Standards Institute (CLSI) as best practice, see *Source*.
2023-02-22 14:38:57 +01:00
#' @param combine_SI a [logical] to indicate whether all susceptibility should be determined by results of either S or I, instead of only S (default is `TRUE`)
2023-02-06 11:57:22 +01:00
#' @param sep a separating character for antibiotic columns in combination antibiograms
2023-02-22 14:38:57 +01:00
#' @param info a [logical] to indicate info should be printed - the default is `TRUE` only in interactive mode
2023-02-06 12:38:52 +01:00
#' @param object an [antibiogram()] object
2023-02-17 09:42:51 +01:00
#' @param ... when used in [print()]: arguments passed on to [knitr::kable()] (otherwise, has no use)
2023-02-06 11:57:22 +01:00
#' @details This function returns a table with values between 0 and 100 for *susceptibility*, not resistance.
2023-02-12 17:10:48 +01:00
#'
2023-02-06 11:57:22 +01:00
#' **Remember that you should filter your data to let it contain only first isolates!** This is needed to exclude duplicates and to reduce selection bias. Use [first_isolate()] to determine them in your data set with one of the four available algorithms.
2023-02-12 17:10:48 +01:00
#'
2023-02-06 11:57:22 +01:00
#' There are four antibiogram types, as proposed by Klinker *et al.* (2021, \doi{10.1177/20499361211011373}), and they are all supported by [antibiogram()]:
2023-02-12 17:10:48 +01:00
#'
2023-02-06 11:57:22 +01:00
#' 1. **Traditional Antibiogram**
2023-02-12 17:10:48 +01:00
#'
2023-02-06 11:57:22 +01:00
#' Case example: Susceptibility of *Pseudomonas aeruginosa* to piperacillin/tazobactam (TZP)
2023-02-12 17:10:48 +01:00
#'
2023-02-06 11:57:22 +01:00
#' Code example:
2023-02-12 17:10:48 +01:00
#'
2023-02-06 11:57:22 +01:00
#' ```r
#' antibiogram(your_data,
#' antibiotics = "TZP")
#' ```
2023-02-12 17:10:48 +01:00
#'
2023-02-06 11:57:22 +01:00
#' 2. **Combination Antibiogram**
2023-02-12 17:10:48 +01:00
#'
2023-02-06 11:57:22 +01:00
#' Case example: Additional susceptibility of *Pseudomonas aeruginosa* to TZP + tobramycin versus TZP alone
2023-02-12 17:10:48 +01:00
#'
2023-02-06 11:57:22 +01:00
#' Code example:
2023-02-12 17:10:48 +01:00
#'
2023-02-06 11:57:22 +01:00
#' ```r
#' antibiogram(your_data,
#' antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"))
#' ```
2023-02-12 17:10:48 +01:00
#'
2023-02-06 11:57:22 +01:00
#' 3. **Syndromic Antibiogram**
2023-02-12 17:10:48 +01:00
#'
2023-02-06 11:57:22 +01:00
#' Case example: Susceptibility of *Pseudomonas aeruginosa* to TZP among respiratory specimens (obtained among ICU patients only)
2023-02-12 17:10:48 +01:00
#'
2023-02-06 11:57:22 +01:00
#' Code example:
2023-02-12 17:10:48 +01:00
#'
2023-02-06 11:57:22 +01:00
#' ```r
#' antibiogram(your_data,
#' antibiotics = penicillins(),
#' syndromic_group = "ward")
#' ```
2023-02-12 17:10:48 +01:00
#'
2023-02-06 11:57:22 +01:00
#' 4. **Weighted-Incidence Syndromic Combination Antibiogram (WISCA)**
2023-02-12 17:10:48 +01:00
#'
2023-02-06 11:57:22 +01:00
#' Case example: Susceptibility of *Pseudomonas aeruginosa* to TZP among respiratory specimens (obtained among ICU patients only) for male patients age >=65 years with heart failure
2023-02-12 17:10:48 +01:00
#'
2023-02-06 11:57:22 +01:00
#' Code example:
2023-02-12 17:10:48 +01:00
#'
2023-02-06 11:57:22 +01:00
#' ```r
2023-02-13 10:21:43 +01:00
#' library(dplyr)
#' your_data %>%
#' filter(ward == "ICU" & specimen_type == "Respiratory") %>%
#' antibiogram(antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
#' syndromic_group = ifelse(.$age >= 65 &
#' .$gender == "Male" &
#' .$condition == "Heart Disease",
#' "Study Group", "Control Group"))
2023-02-06 11:57:22 +01:00
#' ```
2023-02-12 17:10:48 +01:00
#'
2023-02-15 17:16:40 +01:00
#' All types of antibiograms can be generated with the functions as described on this page, and can be plotted (using [ggplot2::autoplot()] or base \R [plot()]/[barplot()]) or printed into R Markdown / Quarto formats for reports using `print()`. Use functions from specific 'table reporting' packages to transform the output of [antibiogram()] to your needs, e.g. `flextable::as_flextable()` or `gt::gt()`.
2023-02-12 17:10:48 +01:00
#'
2023-02-22 14:38:57 +01:00
#' Note that for combination antibiograms, it is important to realise that susceptibility can be calculated in two ways, which can be set with the `only_all_tested` argument (default is `FALSE`). See this example for two antibiotics, Drug A and Drug B, about how [antibiogram()] works to calculate the %SI:
2023-02-12 17:10:48 +01:00
#'
2023-02-06 11:57:22 +01:00
#' ```
#' --------------------------------------------------------------------
#' only_all_tested = FALSE only_all_tested = TRUE
#' ----------------------- -----------------------
#' Drug A Drug B include as include as include as include as
#' numerator denominator numerator denominator
#' -------- -------- ---------- ----------- ---------- -----------
#' S or I S or I X X X X
#' R S or I X X X X
#' <NA> S or I X X - -
#' S or I R X X X X
#' R R - X - X
#' <NA> R - - - -
#' S or I <NA> X X - -
#' R <NA> - - - -
#' <NA> <NA> - - - -
#' --------------------------------------------------------------------
#' ```
2023-02-12 17:10:48 +01:00
#' @source
2023-02-06 11:57:22 +01:00
#' * Klinker KP *et al.* (2021). **Antimicrobial stewardship and antibiograms: importance of moving beyond traditional antibiograms**. *Therapeutic Advances in Infectious Disease*, May 5;8:20499361211011373; \doi{10.1177/20499361211011373}
#' * Barbieri E *et al.* (2021). **Development of a Weighted-Incidence Syndromic Combination Antibiogram (WISCA) to guide the choice of the empiric antibiotic treatment for urinary tract infection in paediatric patients: a Bayesian approach** *Antimicrobial Resistance & Infection Control* May 1;10(1):74; \doi{10.1186/s13756-021-00939-2}
#' * **M39 Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data, 5th Edition**, 2022, *Clinical and Laboratory Standards Institute (CLSI)*. <https://clsi.org/standards/products/microbiology/documents/m39/>.
#' @rdname antibiogram
#' @name antibiogram
#' @export
2023-02-12 17:10:48 +01:00
#' @examples
2023-02-06 11:57:22 +01:00
#' # example_isolates is a data set available in the AMR package.
#' # run ?example_isolates for more info.
#' example_isolates
2023-02-12 17:10:48 +01:00
#'
2023-02-13 16:56:25 +01:00
#' \donttest{
2023-02-06 11:57:22 +01:00
#' # Traditional antibiogram ----------------------------------------------
2023-02-12 17:10:48 +01:00
#'
2023-02-06 11:57:22 +01:00
#' antibiogram(example_isolates,
2023-02-12 17:10:48 +01:00
#' antibiotics = c(aminoglycosides(), carbapenems())
#' )
#'
2023-02-06 11:57:22 +01:00
#' antibiogram(example_isolates,
2023-02-12 17:10:48 +01:00
#' antibiotics = aminoglycosides(),
#' ab_transform = "atc",
#' mo_transform = "gramstain"
#' )
#'
2023-02-06 11:57:22 +01:00
#' antibiogram(example_isolates,
2023-02-12 17:10:48 +01:00
#' antibiotics = carbapenems(),
#' ab_transform = "name",
#' mo_transform = "name"
#' )
#'
#'
2023-02-06 11:57:22 +01:00
#' # Combined antibiogram -------------------------------------------------
2023-02-12 17:10:48 +01:00
#'
2023-02-06 11:57:22 +01:00
#' # combined antibiotics yield higher empiric coverage
#' antibiogram(example_isolates,
2023-02-12 17:10:48 +01:00
#' antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
#' mo_transform = "gramstain"
#' )
#'
2023-02-22 15:40:05 +01:00
#' # names of antibiotics do not need to resemble columns exactly:
2023-02-06 11:57:22 +01:00
#' antibiogram(example_isolates,
2023-02-22 15:40:05 +01:00
#' antibiotics = c("Cipro", "cipro + genta"),
2023-02-12 17:10:48 +01:00
#' mo_transform = "gramstain",
#' ab_transform = "name",
#' sep = " & "
#' )
#'
#'
2023-02-06 11:57:22 +01:00
#' # Syndromic antibiogram ------------------------------------------------
2023-02-12 17:10:48 +01:00
#'
2023-02-06 11:57:22 +01:00
#' # the data set could contain a filter for e.g. respiratory specimens
#' antibiogram(example_isolates,
2023-02-12 17:10:48 +01:00
#' antibiotics = c(aminoglycosides(), carbapenems()),
#' syndromic_group = "ward"
#' )
#'
2023-02-10 16:18:00 +01:00
#' # now define a data set with only E. coli
#' ex1 <- example_isolates[which(mo_genus() == "Escherichia"), ]
2023-02-12 17:10:48 +01:00
#'
2023-02-06 11:57:22 +01:00
#' # with a custom language, though this will be determined automatically
#' # (i.e., this table will be in Spanish on Spanish systems)
#' antibiogram(ex1,
2023-02-22 16:26:13 +01:00
#' antibiotics = aminoglycosides(),
#' ab_transform = "name",
#' syndromic_group = ifelse(ex1$ward == "ICU",
#' "UCI", "No UCI"),
#' language = "es"
2023-02-12 17:10:48 +01:00
#' )
#'
#'
2023-02-06 11:57:22 +01:00
#' # Weighted-incidence syndromic combination antibiogram (WISCA) ---------
2023-02-12 17:10:48 +01:00
#'
2023-02-13 10:21:43 +01:00
#' # the data set could contain a filter for e.g. respiratory specimens/ICU
2023-02-06 11:57:22 +01:00
#' antibiogram(example_isolates,
2023-02-22 16:26:13 +01:00
#' antibiotics = c("AMC", "AMC+CIP", "TZP", "TZP+TOB"),
#' mo_transform = "gramstain",
#' minimum = 10, # this should be >=30, but now just as example
#' syndromic_group = ifelse(example_isolates$age >= 65 &
#' example_isolates$gender == "M",
#' "WISCA Group 1", "WISCA Group 2"
#' )
2023-02-12 17:10:48 +01:00
#' )
#'
2023-02-17 09:42:51 +01:00
#' # Print the output for R Markdown / Quarto -----------------------------
#'
#' ureido <- antibiogram(example_isolates,
#' antibiotics = ureidopenicillins(),
#' ab_transform = "name")
#'
#' # in an Rmd file, you would just need print(ureido), but to be explicit:
#' print(ureido, as_kable = TRUE, format = "markdown", italicise = TRUE)
#'
#'
2023-02-06 11:57:22 +01:00
#' # Generate plots with ggplot2 or base R --------------------------------
2023-02-12 17:10:48 +01:00
#'
2023-02-06 11:57:22 +01:00
#' ab1 <- antibiogram(example_isolates,
2023-02-12 17:10:48 +01:00
#' antibiotics = c("AMC", "CIP", "TZP", "TZP+TOB"),
#' mo_transform = "gramstain"
#' )
2023-02-06 11:57:22 +01:00
#' ab2 <- antibiogram(example_isolates,
2023-02-12 17:10:48 +01:00
#' antibiotics = c("AMC", "CIP", "TZP", "TZP+TOB"),
#' mo_transform = "gramstain",
#' syndromic_group = "ward"
#' )
#'
2023-02-06 11:57:22 +01:00
#' if (requireNamespace("ggplot2")) {
#' ggplot2::autoplot(ab1)
#' }
#' if (requireNamespace("ggplot2")) {
#' ggplot2::autoplot(ab2)
#' }
2023-02-17 09:42:51 +01:00
#'
#' plot(ab1)
#' plot(ab2)
#'
2023-02-13 16:56:25 +01:00
#' }
2023-02-06 11:57:22 +01:00
antibiogram <- function ( x ,
antibiotics = where ( is.sir ) ,
mo_transform = " shortname" ,
ab_transform = NULL ,
syndromic_group = NULL ,
add_total_n = TRUE ,
only_all_tested = FALSE ,
digits = 0 ,
col_mo = NULL ,
language = get_AMR_locale ( ) ,
minimum = 30 ,
combine_SI = TRUE ,
2023-02-17 11:39:00 +01:00
sep = " + " ,
info = interactive ( ) ) {
2023-02-22 14:38:57 +01:00
meet_criteria ( x , allow_class = " data.frame" , contains_column_class = c ( " sir" , " rsi" ) )
2023-02-06 11:57:22 +01:00
meet_criteria ( mo_transform , allow_class = " character" , has_length = 1 , is_in = c ( " name" , " shortname" , " gramstain" , colnames ( AMR :: microorganisms ) ) , allow_NULL = TRUE )
meet_criteria ( ab_transform , allow_class = " character" , has_length = 1 , is_in = colnames ( AMR :: antibiotics ) , allow_NULL = TRUE )
meet_criteria ( syndromic_group , allow_class = " character" , allow_NULL = TRUE , allow_NA = TRUE )
meet_criteria ( add_total_n , allow_class = " logical" , has_length = 1 )
meet_criteria ( only_all_tested , allow_class = " logical" , has_length = 1 )
meet_criteria ( digits , allow_class = c ( " numeric" , " integer" ) , has_length = 1 , is_finite = TRUE )
meet_criteria ( col_mo , allow_class = " character" , has_length = 1 , allow_NULL = TRUE , is_in = colnames ( x ) )
language <- validate_language ( language )
meet_criteria ( minimum , allow_class = c ( " numeric" , " integer" ) , has_length = 1 , is_positive_or_zero = TRUE , is_finite = TRUE )
meet_criteria ( combine_SI , allow_class = " logical" , has_length = 1 )
meet_criteria ( sep , allow_class = " character" , has_length = 1 )
2023-02-17 11:39:00 +01:00
meet_criteria ( info , allow_class = " logical" , has_length = 1 )
2023-02-06 11:57:22 +01:00
# try to find columns based on type
if ( is.null ( col_mo ) ) {
col_mo <- search_type_in_df ( x = x , type = " mo" , info = interactive ( ) )
stop_if ( is.null ( col_mo ) , " `col_mo` must be set" )
}
# transform MOs
x $ `.mo` <- x [ , col_mo , drop = TRUE ]
if ( is.null ( mo_transform ) ) {
# leave as is
} else if ( mo_transform == " gramstain" ) {
x $ `.mo` <- mo_gramstain ( x $ `.mo` , language = language )
} else if ( mo_transform == " shortname" ) {
x $ `.mo` <- mo_shortname ( x $ `.mo` , language = language )
} else if ( mo_transform == " name" ) {
x $ `.mo` <- mo_name ( x $ `.mo` , language = language )
} else {
x $ `.mo` <- mo_property ( x $ `.mo` , language = language )
}
x $ `.mo` [is.na ( x $ `.mo` ) ] <- " (??)"
# get syndromic groups
if ( ! is.null ( syndromic_group ) ) {
if ( length ( syndromic_group ) == 1 && syndromic_group %in% colnames ( x ) ) {
x $ `.syndromic_group` <- x [ , syndromic_group , drop = TRUE ]
} else if ( ! is.null ( syndromic_group ) ) {
x $ `.syndromic_group` <- syndromic_group
}
x $ `.syndromic_group` [is.na ( x $ `.syndromic_group` ) | x $ `.syndromic_group` == " " ] <- paste0 ( " (" , translate_AMR ( " unknown" , language = language ) , " )" )
has_syndromic_group <- TRUE
} else {
has_syndromic_group <- FALSE
}
2023-02-12 17:10:48 +01:00
2023-02-06 11:57:22 +01:00
# get antibiotics
if ( tryCatch ( is.character ( antibiotics ) , error = function ( e ) FALSE ) ) {
2023-02-22 14:38:57 +01:00
antibiotics.bak <- antibiotics
# split antibiotics on separator and make it a list
2023-02-06 11:57:22 +01:00
antibiotics <- strsplit ( gsub ( " " , " " , antibiotics ) , " +" , fixed = TRUE )
2023-02-22 14:38:57 +01:00
# get available antibiotics in data set
df_ab <- get_column_abx ( x , verbose = FALSE , info = FALSE )
# get antibiotics from user
user_ab <- suppressMessages ( suppressWarnings ( lapply ( antibiotics , as.ab , flag_multiple_results = FALSE , info = FALSE ) ) )
2023-02-22 16:00:52 +01:00
non_existing <- character ( 0 )
user_ab <- lapply ( user_ab , function ( x ) {
out <- unname ( df_ab [match ( x , names ( df_ab ) ) ] )
non_existing <<- c ( non_existing , x [is.na ( out ) & ! is.na ( x ) ] )
# remove non-existing columns
out [ ! is.na ( out ) ]
} )
user_ab <- user_ab [unlist ( lapply ( user_ab , length ) ) > 0 ]
2023-02-22 15:40:05 +01:00
2023-02-22 16:00:52 +01:00
if ( length ( non_existing ) > 0 ) {
warning_ ( " The following antibiotics were not available and ignored: " , vector_and ( ab_name ( non_existing , language = NULL , tolower = TRUE ) , quotes = FALSE ) )
}
2023-02-06 11:57:22 +01:00
# make list unique
2023-02-22 15:40:05 +01:00
antibiotics <- unique ( user_ab )
2023-02-06 11:57:22 +01:00
# go through list to set AMR in combinations
for ( i in seq_len ( length ( antibiotics ) ) ) {
abx <- antibiotics [ [i ] ]
for ( ab in abx ) {
# make sure they are SIR columns
x [ , ab ] <- as.sir ( x [ , ab , drop = TRUE ] )
}
new_colname <- paste0 ( trimws ( abx ) , collapse = sep )
if ( length ( abx ) == 1 ) {
next
} else {
# determine whether this new column should contain S, I, R, or NA
if ( isTRUE ( combine_SI ) ) {
S_values <- c ( " S" , " I" )
2023-02-12 17:10:48 +01:00
} else {
2023-02-06 11:57:22 +01:00
S_values <- " S"
}
other_values <- setdiff ( c ( " S" , " I" , " R" ) , S_values )
x_transposed <- as.list ( as.data.frame ( t ( x [ , abx , drop = FALSE ] ) , stringsAsFactors = FALSE ) )
if ( isTRUE ( only_all_tested ) ) {
x [new_colname ] <- as.sir ( vapply ( FUN.VALUE = character ( 1 ) , x_transposed , function ( x ) ifelse ( anyNA ( x ) , NA_character_ , ifelse ( any ( x %in% S_values ) , " S" , " R" ) ) , USE.NAMES = FALSE ) )
} else {
2023-02-12 17:10:48 +01:00
x [new_colname ] <- as.sir ( vapply (
FUN.VALUE = character ( 1 ) , x_transposed , function ( x ) ifelse ( any ( x %in% S_values , na.rm = TRUE ) , " S" , ifelse ( anyNA ( x ) , NA_character_ , " R" ) ) ,
USE.NAMES = FALSE
) )
2023-02-06 11:57:22 +01:00
}
}
antibiotics [ [i ] ] <- new_colname
}
antibiotics <- unlist ( antibiotics )
} else {
2023-02-10 16:18:00 +01:00
antibiotics <- colnames ( suppressWarnings ( x [ , antibiotics , drop = FALSE ] ) )
2023-02-06 11:57:22 +01:00
}
2023-02-12 17:10:48 +01:00
2023-02-06 11:57:22 +01:00
if ( isTRUE ( has_syndromic_group ) ) {
2023-02-12 17:10:48 +01:00
out <- x %pm>%
pm_select ( .syndromic_group , .mo , antibiotics ) %pm>%
2023-02-10 16:18:00 +01:00
pm_group_by ( .syndromic_group )
2023-02-06 11:57:22 +01:00
} else {
2023-02-12 17:10:48 +01:00
out <- x %pm>%
2023-02-10 16:18:00 +01:00
pm_select ( .mo , antibiotics )
2023-02-06 11:57:22 +01:00
}
2023-02-12 17:10:48 +01:00
2023-02-06 11:57:22 +01:00
# get numbers of S, I, R (per group)
2023-02-12 17:10:48 +01:00
out <- out %pm>%
bug_drug_combinations (
col_mo = " .mo" ,
FUN = function ( x ) x
)
2023-02-06 11:57:22 +01:00
counts <- out
2023-02-13 10:21:43 +01:00
if ( isTRUE ( combine_SI ) ) {
out $ numerator <- out $ S + out $ I
} else {
out $ numerator <- out $ S
}
if ( any ( out $ total < minimum , na.rm = TRUE ) ) {
2023-02-17 11:39:00 +01:00
if ( isTRUE ( info ) ) {
message_ ( " NOTE: " , sum ( out $ total < minimum , na.rm = TRUE ) , " combinations had less than `minimum = " , minimum , " ` results and were ignored" , add_fn = font_red )
}
2023-02-13 10:21:43 +01:00
out <- out %pm>%
subset ( total >= minimum )
}
2023-02-17 11:39:00 +01:00
2023-02-06 11:57:22 +01:00
# regroup for summarising
if ( isTRUE ( has_syndromic_group ) ) {
colnames ( out ) [1 ] <- " syndromic_group"
2023-02-12 17:10:48 +01:00
out <- out %pm>%
2023-02-10 16:18:00 +01:00
pm_group_by ( syndromic_group , mo , ab )
} else {
2023-02-12 17:10:48 +01:00
out <- out %pm>%
2023-02-10 16:18:00 +01:00
pm_group_by ( mo , ab )
}
out <- out %pm>%
pm_summarise ( SI = numerator / total )
2023-02-12 17:10:48 +01:00
2023-02-06 11:57:22 +01:00
# transform names of antibiotics
ab_naming_function <- function ( x , t , l , s ) {
x <- strsplit ( x , s , fixed = TRUE )
out <- character ( length = length ( x ) )
for ( i in seq_len ( length ( x ) ) ) {
a <- x [ [i ] ]
if ( is.null ( t ) ) {
# leave as is
} else if ( t == " atc" ) {
a <- ab_atc ( a , only_first = TRUE , language = l )
} else {
a <- ab_property ( a , property = t , language = l )
}
if ( length ( a ) > 1 ) {
a <- paste0 ( trimws ( a ) , collapse = sep )
}
out [i ] <- a
}
out
}
out $ ab <- ab_naming_function ( out $ ab , t = ab_transform , l = language , s = sep )
2023-02-12 17:10:48 +01:00
2023-02-06 11:57:22 +01:00
# transform long to wide
long_to_wide <- function ( object , digs ) {
2023-02-10 16:18:00 +01:00
object $ SI <- round ( object $ SI * 100 , digits = digs )
object <- object %pm>%
2023-02-06 11:57:22 +01:00
# an unclassed data.frame is required for stats::reshape()
2023-02-12 17:10:48 +01:00
as.data.frame ( stringsAsFactors = FALSE ) %pm>%
2023-02-06 11:57:22 +01:00
stats :: reshape ( direction = " wide" , idvar = " mo" , timevar = " ab" , v.names = " SI" )
colnames ( object ) <- gsub ( " ^SI?[.]" , " " , colnames ( object ) )
return ( object )
}
2023-02-12 17:10:48 +01:00
2023-02-10 16:18:00 +01:00
# ungroup for long -> wide transformation
attr ( out , " pm_groups" ) <- NULL
attr ( out , " groups" ) <- NULL
class ( out ) <- class ( out ) [ ! class ( out ) %in% c ( " grouped_df" , " grouped_data" ) ]
long <- out
2023-02-12 17:10:48 +01:00
2023-02-06 11:57:22 +01:00
if ( isTRUE ( has_syndromic_group ) ) {
grps <- unique ( out $ syndromic_group )
for ( i in seq_len ( length ( grps ) ) ) {
grp <- grps [i ]
if ( i == 1 ) {
new_df <- long_to_wide ( out [which ( out $ syndromic_group == grp ) , , drop = FALSE ] , digs = digits )
} else {
2023-02-12 17:10:48 +01:00
new_df <- rbind2 (
new_df ,
long_to_wide ( out [which ( out $ syndromic_group == grp ) , , drop = FALSE ] , digs = digits )
)
2023-02-06 11:57:22 +01:00
}
}
# sort rows
2023-02-10 16:18:00 +01:00
new_df <- new_df %pm>% pm_arrange ( mo , syndromic_group )
2023-02-06 11:57:22 +01:00
# sort columns
new_df <- new_df [ , c ( " syndromic_group" , " mo" , sort ( colnames ( new_df ) [ ! colnames ( new_df ) %in% c ( " syndromic_group" , " mo" ) ] ) ) , drop = FALSE ]
colnames ( new_df ) [1 : 2 ] <- translate_AMR ( c ( " Syndromic Group" , " Pathogen" ) , language = language )
} else {
new_df <- long_to_wide ( out , digs = digits )
# sort rows
2023-02-10 16:18:00 +01:00
new_df <- new_df %pm>% pm_arrange ( mo )
2023-02-06 11:57:22 +01:00
# sort columns
new_df <- new_df [ , c ( " mo" , sort ( colnames ( new_df ) [colnames ( new_df ) != " mo" ] ) ) , drop = FALSE ]
colnames ( new_df ) [1 ] <- translate_AMR ( " Pathogen" , language = language )
}
2023-02-12 17:10:48 +01:00
2023-02-06 11:57:22 +01:00
# add total N if indicated
if ( isTRUE ( add_total_n ) ) {
if ( isTRUE ( has_syndromic_group ) ) {
2023-02-10 16:18:00 +01:00
n_per_mo <- counts %pm>%
pm_group_by ( mo , .syndromic_group ) %pm>%
pm_summarise ( paste0 ( min ( total , na.rm = TRUE ) , " -" , max ( total , na.rm = TRUE ) ) )
2023-02-06 11:57:22 +01:00
colnames ( n_per_mo ) <- c ( " mo" , " syn" , " count" )
count_group <- n_per_mo $ count [match ( paste ( new_df [ [2 ] ] , new_df [ [1 ] ] ) , paste ( n_per_mo $ mo , n_per_mo $ syn ) ) ]
edit_col <- 2
} else {
2023-02-10 16:18:00 +01:00
n_per_mo <- counts %pm>%
pm_group_by ( mo ) %pm>%
pm_summarise ( paste0 ( min ( total , na.rm = TRUE ) , " -" , max ( total , na.rm = TRUE ) ) )
2023-02-06 11:57:22 +01:00
colnames ( n_per_mo ) <- c ( " mo" , " count" )
count_group <- n_per_mo $ count [match ( new_df [ [1 ] ] , n_per_mo $ mo ) ]
edit_col <- 1
}
2023-02-22 16:26:13 +01:00
if ( NCOL ( new_df ) == edit_col + 1 ) {
# only 1 antibiotic
new_df [ [edit_col ] ] <- paste0 ( new_df [ [edit_col ] ] , " (" , unlist ( lapply ( strsplit ( count_group , " -" ) , function ( x ) x [1 ] ) ) , " )" )
colnames ( new_df ) [edit_col ] <- paste ( colnames ( new_df ) [edit_col ] , " (N)" )
} else {
# more than 1 antibiotic
new_df [ [edit_col ] ] <- paste0 ( new_df [ [edit_col ] ] , " (" , count_group , " )" )
colnames ( new_df ) [edit_col ] <- paste ( colnames ( new_df ) [edit_col ] , " (N min-max)" )
}
2023-02-06 11:57:22 +01:00
}
2023-02-12 17:10:48 +01:00
2023-02-18 11:57:17 +01:00
out <- as_original_data_class ( new_df , class ( x ) , extra_class = " antibiogram" )
rownames ( out ) <- NULL
structure ( out ,
2023-02-12 17:10:48 +01:00
long = long ,
combine_SI = combine_SI
)
2023-02-06 11:57:22 +01:00
}
#' @export
#' @rdname antibiogram
plot.antibiogram <- function ( x , ... ) {
df <- attributes ( x ) $ long
if ( " syndromic_group" %in% colnames ( df ) ) {
# barplot in base R does not support facets - paste columns together
df $ mo <- paste ( df $ mo , " -" , df $ syndromic_group )
df $ syndromic_group <- NULL
df <- df [order ( df $ mo ) , , drop = FALSE ]
}
2023-02-12 17:10:48 +01:00
mo_levels <- unique ( df $ mo )
2023-02-06 12:38:52 +01:00
mfrow_old <- graphics :: par ( ) $ mfrow
2023-02-06 11:57:22 +01:00
sqrt_levels <- sqrt ( length ( mo_levels ) )
2023-02-06 12:38:52 +01:00
graphics :: par ( mfrow = c ( ceiling ( sqrt_levels ) , floor ( sqrt_levels ) ) )
2023-02-06 11:57:22 +01:00
for ( i in seq_along ( mo_levels ) ) {
mo <- mo_levels [i ]
df_sub <- df [df $ mo == mo , , drop = FALSE ]
2023-02-12 17:10:48 +01:00
barplot (
height = df_sub $ SI * 100 ,
xlab = NULL ,
ylab = ifelse ( isTRUE ( attributes ( x ) $ combine_SI ) , " %SI" , " %S" ) ,
names.arg = df_sub $ ab ,
col = " #aaaaaa" ,
beside = TRUE ,
main = mo ,
legend = NULL
)
2023-02-06 11:57:22 +01:00
}
2023-02-06 12:38:52 +01:00
graphics :: par ( mfrow = mfrow_old )
2023-02-06 11:57:22 +01:00
}
#' @export
#' @noRd
2023-02-06 12:38:52 +01:00
barplot.antibiogram <- function ( height , ... ) {
plot ( height , ... )
}
2023-02-06 11:57:22 +01:00
#' @method autoplot antibiogram
#' @rdname antibiogram
# will be exported using s3_register() in R/zzz.R
autoplot.antibiogram <- function ( object , ... ) {
df <- attributes ( object ) $ long
ggplot2 :: ggplot ( df ) +
2023-02-12 17:10:48 +01:00
ggplot2 :: geom_col (
ggplot2 :: aes (
x = ab ,
y = SI * 100 ,
fill = if ( " syndromic_group" %in% colnames ( df ) ) {
syndromic_group
} else {
NULL
}
) ,
position = ggplot2 :: position_dodge2 ( preserve = " single" )
) +
2023-02-06 11:57:22 +01:00
ggplot2 :: facet_wrap ( " mo" ) +
2023-02-12 17:10:48 +01:00
ggplot2 :: labs (
y = ifelse ( isTRUE ( attributes ( object ) $ combine_SI ) , " %SI" , " %S" ) ,
x = NULL ,
fill = if ( " syndromic_group" %in% colnames ( df ) ) {
colnames ( object ) [1 ]
} else {
NULL
}
)
2023-02-06 11:57:22 +01:00
}
#' @export
#' @param as_kable a [logical] to indicate whether the printing should be done using [knitr::kable()] (which is the default in non-interactive sessions)
2023-02-22 14:38:57 +01:00
#' @param italicise (only when `as_kable = TRUE`) a [logical] to indicate whether the microorganism names in the output table should be made italic, using [italicise_taxonomy()]. This only works when the output format is markdown, such as in HTML output.
#' @param na (only when `as_kable = TRUE`) character to use for showing `NA` values
2023-02-06 11:57:22 +01:00
#' @details Printing the antibiogram in non-interactive sessions will be done by [knitr::kable()], with support for [all their implemented formats][knitr::kable()], such as "markdown". The knitr format will be automatically determined if printed inside a knitr document (LaTeX, HTML, etc.).
#' @rdname antibiogram
2023-02-22 14:38:57 +01:00
print.antibiogram <- function ( x , as_kable = ! interactive ( ) , italicise = TRUE , na = getOption ( " knitr.kable.NA" , default = " " ) , ... ) {
2023-02-06 11:57:22 +01:00
meet_criteria ( as_kable , allow_class = " logical" , has_length = 1 )
2023-02-17 09:42:51 +01:00
meet_criteria ( italicise , allow_class = " logical" , has_length = 1 )
2023-02-22 14:38:57 +01:00
meet_criteria ( na , allow_class = " character" , has_length = 1 , allow_NA = TRUE )
2023-02-17 09:42:51 +01:00
if ( isTRUE ( as_kable ) &&
2023-02-18 14:56:06 +01:00
pkg_is_available ( " knitr" ) &&
2023-02-13 16:56:25 +01:00
# be sure not to run kable in pkgdown for our website generation
2023-02-17 09:42:51 +01:00
! ( missing ( as_kable ) && identical ( Sys.getenv ( " IN_PKGDOWN" ) , " true" ) ) ) {
2023-02-22 14:38:57 +01:00
old_option <- getOption ( " knitr.kable.NA" )
options ( knitr.kable.NA = na )
on.exit ( options ( knitr.kable.NA = old_option ) )
2023-02-17 09:42:51 +01:00
out <- knitr :: kable ( x , ... )
format <- attributes ( out ) $ format
if ( ! is.null ( format ) && format %in% c ( " markdown" , " pipe" ) ) {
# try to italicise the output
rows_with_txt <- which ( out %like% " [a-z]" )
rows_without_txt <- setdiff ( seq_len ( length ( out ) ) , rows_with_txt )
out [rows_with_txt ] <- gsub ( " ^[|]" , " | " , out [rows_with_txt ] )
# put hyphen directly after second character
out [rows_without_txt ] <- gsub ( " ^[|](.)" , " |\\1-" , out [rows_without_txt ] )
out_ita <- italicise_taxonomy ( as.character ( out ) , type = " markdown" )
if ( length ( unique ( nchar ( out_ita ) ) ) != 1 ) {
# so there has been alterations done by italicise_taxonomy()
to_fill <- which ( nchar ( out_ita ) < max ( nchar ( out_ita ) ) )
out_ita [intersect ( to_fill , rows_with_txt ) ] <- gsub ( " (^[|].*?)([|])(.*)" , " \\1 \\2\\3" , out_ita [intersect ( to_fill , rows_with_txt ) ] , perl = TRUE )
out_ita [intersect ( to_fill , rows_without_txt ) ] <- gsub ( " (^[|].*?)([|])(.*)" , " \\1--\\2\\3" , out_ita [intersect ( to_fill , rows_without_txt ) ] , perl = TRUE )
}
attributes ( out_ita ) <- attributes ( out )
out <- out_ita
}
out
2023-02-06 11:57:22 +01:00
} else {
2023-02-10 16:18:00 +01:00
# remove 'antibiogram' class and print with default method
2023-02-06 11:57:22 +01:00
class ( x ) <- class ( x ) [class ( x ) != " antibiogram" ]
print ( x , ... )
}
}