Browse Source

added mdr_tb()

pull/67/head
parent
commit
60983a1640
  1. 4
      DESCRIPTION
  2. 1
      NAMESPACE
  3. 10
      NEWS.md
  4. 2
      R/data.R
  5. 66
      R/eucast_rules.R
  6. 18
      R/first_isolate.R
  7. 7
      R/freq.R
  8. 84
      R/key_antibiotics.R
  9. 290
      R/mdro.R
  10. 44
      R/misc.R
  11. 2
      R/portion.R
  12. 2
      R/resistance_predict.R
  13. 30
      R/rsi.R
  14. 3
      _pkgdown.yml
  15. BIN
      data/antibiotics.rda
  16. 9
      docs/LICENSE-text.html
  17. 422
      docs/articles/AMR.html
  18. BIN
      docs/articles/AMR_files/figure-html/plot 1-1.png
  19. BIN
      docs/articles/AMR_files/figure-html/plot 3-1.png
  20. BIN
      docs/articles/AMR_files/figure-html/plot 4-1.png
  21. BIN
      docs/articles/AMR_files/figure-html/plot 5-1.png
  22. 11
      docs/articles/EUCAST.html
  23. 11
      docs/articles/G_test.html
  24. 323
      docs/articles/MDR.html
  25. 11
      docs/articles/SPSS.html
  26. 11
      docs/articles/WHONET.html
  27. 11
      docs/articles/ab_property.html
  28. 81
      docs/articles/benchmarks.html
  29. BIN
      docs/articles/benchmarks_files/figure-html/unnamed-chunk-5-1.png
  30. 79
      docs/articles/freq.html
  31. 10
      docs/articles/index.html
  32. 11
      docs/articles/mo_property.html
  33. 11
      docs/articles/resistance_predict.html
  34. 9
      docs/authors.html
  35. 33
      docs/index.html
  36. 27
      docs/news/index.html
  37. 1
      docs/pkgdown.yml
  38. 11
      docs/reference/antibiotics.html
  39. 15
      docs/reference/as.rsi.html
  40. 17
      docs/reference/count.html
  41. 11
      docs/reference/eucast_rules.html
  42. 11
      docs/reference/ggplot_rsi.html
  43. 11
      docs/reference/index.html
  44. 48
      docs/reference/key_antibiotics.html
  45. 33
      docs/reference/mdro.html
  46. 17
      docs/reference/portion.html
  47. 3
      docs/sitemap.xml
  48. 24
      index.md
  49. 2
      man/antibiotics.Rd
  50. 6
      man/as.rsi.Rd
  51. 8
      man/count.Rd
  52. 2
      man/eucast_rules.Rd
  53. 2
      man/ggplot_rsi.Rd
  54. 33
      man/key_antibiotics.Rd
  55. 27
      man/mdro.Rd
  56. 8
      man/portion.Rd
  57. 11
      reproduction_of_antibiotics.R
  58. 34
      tests/testthat/test-mdro.R
  59. 79
      vignettes/MDR.Rmd
  60. 8
      vignettes/freq.Rmd

4
DESCRIPTION

@ -1,6 +1,6 @@ @@ -1,6 +1,6 @@
Package: AMR
Version: 0.6.1.9034
Date: 2019-05-20
Version: 0.6.1.9035
Date: 2019-05-23
Title: Antimicrobial Resistance Analysis
Authors@R: c(
person(

1
NAMESPACE

@ -132,6 +132,7 @@ export(kurtosis) @@ -132,6 +132,7 @@ export(kurtosis)
export(labels_rsi_count)
export(left_join_microorganisms)
export(like)
export(mdr_tb)
export(mdro)
export(mo_authors)
export(mo_class)

10
NEWS.md

@ -1,9 +1,10 @@ @@ -1,9 +1,10 @@
# AMR 0.6.1.9001
# AMR 0.6.1.90xx
**Note: latest development version**
#### New
* Support for translation of disk diffusion and MIC values to RSI values (i.e. antimicrobial interpretations). Supported guidelines are EUCAST (2011 to 2019) and CLSI (2011 to 2019). Use `as.rsi()` on an MIC value (created with `as.mic()`), a disk diffusion value (created with the new `as.disk()`) or on a complete date set containing columns with MIC or disk diffusion values.
* Function `mo_name()` as alias of `mo_fullname()`
* Added guidelines of the WHO to determine mutli-drug resistance (MDR) for TB (`mdr_tb()`) and added a new vignette about MDR
#### Changed
* Completely reworked the `antibiotics` data set:
@ -11,7 +12,7 @@ @@ -11,7 +12,7 @@
* Column `ab` contains a human readable EARS-Net code, used by ECDC and WHO/WHONET - this is the primary identifier used in this package
* Column `atc` contains the ATC code, used by WHO/WHOCC
* Column `cid` contains the CID code (Compound ID), used by PubChem
* Based on the Compound ID, more than a thousand official brand names have been added from many different countries
* Based on the Compound ID, almost 5,000 official brand names have been added from many different countries
* All references to antibiotics in our package now use EARS-Net codes, like `AMX` for amoxicillin
* Functions `atc_certe`, `ab_umcg` and `atc_trivial_nl` have been removed
* All `atc_*` functions are superceded by `ab_*` functions
@ -24,7 +25,10 @@ @@ -24,7 +25,10 @@
* Added ~5,000 more old taxonomic names to the `microorganisms.old` data set, which leads to better results finding when using the `as.mo()` function
* This package now honours the new EUCAST insight (2019) that S and I are but classified as susceptible, where I is defined as 'increased exposure' and not 'intermediate' anymore. For functions like `portion_df()` and `count_df()` this means that their new parameter `combine_SI` is TRUE at default.
* Removed deprecated functions `guess_mo()`, `guess_atc()`, `EUCAST_rules()`, `interpretive_reading()`, `rsi()`
* Frequency tables of microbial IDs speed improvement
* Frequency tables (`freq()`):
* speed improvement for microbial IDs
* fixed level names in markdown
*
* Removed all hardcoded EUCAST rules and replaced them with a new reference file: `./inst/eucast/eucast.tsv`
* Added ceftazidim intrinsic resistance to *Streptococci*
* Changed default settings for `age_groups()`, to let groups of fives and tens end with 100+ instead of 120+

2
R/data.R

@ -22,7 +22,7 @@ @@ -22,7 +22,7 @@
#' Data set with ~450 antibiotics
#'
#' 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:
#' @format A \code{\link{data.frame}} with 454 observations and 13 variables:
#' \describe{
#' \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}}

66
R/eucast_rules.R

@ -116,7 +116,7 @@ EUCAST_VERSION_EXPERT_RULES <- "3.1, 2016" @@ -116,7 +116,7 @@ EUCAST_VERSION_EXPERT_RULES <- "3.1, 2016"
#' @export
#' @importFrom dplyr %>% select pull mutate_at vars group_by summarise n
#' @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.
#' @return The input of \code{x}, 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{
#' \item{
@ -184,16 +184,16 @@ eucast_rules <- function(x, @@ -184,16 +184,16 @@ eucast_rules <- function(x,
verbose = FALSE,
...) {
tbl_ <- x
x <- x
if (!is.data.frame(tbl_)) {
if (!is.data.frame(x)) {
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(x = x, type = "mo")
}
if (is.null(col_mo)) {
stop("`col_mo` must be set.", call. = FALSE)
@ -376,12 +376,12 @@ eucast_rules <- function(x, @@ -376,12 +376,12 @@ eucast_rules <- function(x,
edit_rsi <- function(to, rule, rows, cols) {
cols <- unique(cols[!is.na(cols) & !is.null(cols)])
if (length(rows) > 0 & length(cols) > 0) {
before_df <- tbl_original
before <- as.character(unlist(as.list(tbl_original[rows, cols])))
before_df <- x_original
before <- as.character(unlist(as.list(x_original[rows, cols])))
tryCatch(
# insert into original table
tbl_original[rows, cols] <<- to,
x_original[rows, cols] <<- to,
warning = function(w) {
if (w$message %like% 'invalid factor level') {
warning('Value "', to, '" could not be applied to column(s) `', paste(cols, collapse = '`, `'), '` because this value is not an existing factor level.', call. = FALSE)
@ -396,9 +396,9 @@ eucast_rules <- function(x, @@ -396,9 +396,9 @@ eucast_rules <- function(x,
}
)
tbl_[rows, cols] <<- tbl_original[rows, cols]
x[rows, cols] <<- x_original[rows, cols]
after <- as.character(unlist(as.list(tbl_original[rows, cols])))
after <- as.character(unlist(as.list(x_original[rows, cols])))
# before_df might not be a data.frame, but a tibble of data.table instead
old <- as.data.frame(before_df, stringsAsFactors = FALSE)[rows,]
@ -406,9 +406,9 @@ eucast_rules <- function(x, @@ -406,9 +406,9 @@ eucast_rules <- function(x,
for (i in 1:length(cols)) {
verbose_new <- data.frame(row = rows,
col = cols[i],
mo_fullname = tbl_[rows, "fullname"],
mo_fullname = x[rows, "fullname"],
old = as.character(old[, cols[i]]),
new = as.character(tbl_[rows, cols[i]]),
new = as.character(x[rows, cols[i]]),
rule = strip_style(rule[1]),
rule_group = strip_style(rule[2]),
rule_name = strip_style(rule[3]),
@ -426,11 +426,11 @@ eucast_rules <- function(x, @@ -426,11 +426,11 @@ eucast_rules <- function(x,
}
# save original table
tbl_original <- tbl_
x_original <- x
# join to microorganisms data set
suppressWarnings(
tbl_ <- tbl_ %>%
x <- x %>%
mutate_at(vars(col_mo), as.mo) %>%
left_join_microorganisms(by = col_mo, suffix = c("_oldcols", "")) %>%
mutate(gramstain = mo_gramstain(pull(., col_mo), language = "en"),
@ -448,18 +448,18 @@ eucast_rules <- function(x, @@ -448,18 +448,18 @@ eucast_rules <- function(x,
if (!ab_missing(AMP) & !ab_missing(AMX)) {
if (verbose == TRUE) {
cat("\n VERBOSE: transforming",
length(which(tbl_[, AMX] == "S" & !tbl_[, AMP] %in% c("S", "I", "R"))),
length(which(x[, AMX] == "S" & !x[, AMP] %in% c("S", "I", "R"))),
"empty ampicillin fields to 'S' based on amoxicillin. ")
cat("\n VERBOSE: transforming",
length(which(tbl_[, AMX] == "I" & !tbl_[, AMP] %in% c("S", "I", "R"))),
length(which(x[, AMX] == "I" & !x[, AMP] %in% c("S", "I", "R"))),
"empty ampicillin fields to 'I' based on amoxicillin. ")
cat("\n VERBOSE: transforming",
length(which(tbl_[, AMX] == "R" & !tbl_[, AMP] %in% c("S", "I", "R"))),
length(which(x[, AMX] == "R" & !x[, AMP] %in% c("S", "I", "R"))),
"empty ampicillin fields to 'R' based on amoxicillin. \n")
}
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"
x[which(x[, AMX] == "S" & !x[, AMP] %in% c("S", "I", "R")), AMP] <- "S"
x[which(x[, AMX] == "I" & !x[, AMP] %in% c("S", "I", "R")), AMP] <- "I"
x[which(x[, AMX] == "R" & !x[, 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(AMX), "` as input for ampicillin (J01CA01) since many EUCAST rules depend on it.")))
@ -605,36 +605,36 @@ eucast_rules <- function(x, @@ -605,36 +605,36 @@ eucast_rules <- function(x,
target_value <- eucast_rules_df[i, 7]
if (is.na(source_antibiotics)) {
rows <- tryCatch(which(tbl_[, col_mo_property] %like% mo_value),
rows <- tryCatch(which(x[, col_mo_property] %like% mo_value),
error = function(e) integer(0))
} else {
source_antibiotics <- get_antibiotic_columns(source_antibiotics, tbl_)
source_antibiotics <- get_antibiotic_columns(source_antibiotics, x)
if (length(source_value) == 1 & length(source_antibiotics) > 1) {
source_value <- rep(source_value, length(source_antibiotics))
}
if (length(source_antibiotics) == 0) {
rows <- integer(0)
} else if (length(source_antibiotics) == 1) {
rows <- tryCatch(which(tbl_[, col_mo_property] %like% mo_value
& tbl_[, source_antibiotics[1L]] == source_value[1L]),
rows <- tryCatch(which(x[, col_mo_property] %like% mo_value
& x[, source_antibiotics[1L]] == source_value[1L]),
error = function(e) integer(0))
} else if (length(source_antibiotics) == 2) {
rows <- tryCatch(which(tbl_[, col_mo_property] %like% mo_value
& tbl_[, source_antibiotics[1L]] == source_value[1L]
& tbl_[, source_antibiotics[2L]] == source_value[2L]),
rows <- tryCatch(which(x[, col_mo_property] %like% mo_value
& x[, source_antibiotics[1L]] == source_value[1L]
& x[, source_antibiotics[2L]] == source_value[2L]),
error = function(e) integer(0))
} else if (length(source_antibiotics) == 3) {
rows <- tryCatch(which(tbl_[, col_mo_property] %like% mo_value
& tbl_[, source_antibiotics[1L]] == source_value[1L]
& tbl_[, source_antibiotics[2L]] == source_value[2L]
& tbl_[, source_antibiotics[3L]] == source_value[3L]),
rows <- tryCatch(which(x[, col_mo_property] %like% mo_value
& x[, source_antibiotics[1L]] == source_value[1L]
& x[, source_antibiotics[2L]] == source_value[2L]
& x[, source_antibiotics[3L]] == source_value[3L]),
error = function(e) integer(0))
} else {
stop("only 3 antibiotics supported for source_antibiotics ", call. = FALSE)
}
}
cols <- get_antibiotic_columns(target_antibiotics, tbl_)
cols <- get_antibiotic_columns(target_antibiotics, x)
# Apply rule on data ------------------------------------------------------
# this will return the unique number of changes
@ -671,7 +671,7 @@ eucast_rules <- function(x, @@ -671,7 +671,7 @@ eucast_rules <- function(x,
cat(paste0("\n", silver(strrep("-", options()$width - 1)), "\n"))
cat(bold(paste('EUCAST rules', paste0(wouldve, 'affected'),
formatnr(n_distinct(verbose_info$row)),
'out of', formatnr(nrow(tbl_original)),
'out of', formatnr(nrow(x_original)),
'rows, making a total of', formatnr(nrow(verbose_info)), 'edits\n')))
n_added <- verbose_info %>% filter(is.na(old)) %>% nrow()
@ -742,7 +742,7 @@ eucast_rules <- function(x, @@ -742,7 +742,7 @@ eucast_rules <- function(x,
if (verbose == TRUE) {
verbose_info
} else {
tbl_original
x_original
}
}

18
R/first_isolate.R

@ -191,7 +191,7 @@ first_isolate <- function(x, @@ -191,7 +191,7 @@ first_isolate <- function(x,
# try to find columns based on type
# -- mo
if (is.null(col_mo)) {
col_mo <- search_type_in_df(tbl = x, type = "mo")
col_mo <- search_type_in_df(x = x, type = "mo")
}
if (is.null(col_mo)) {
stop("`col_mo` must be set.", call. = FALSE)
@ -199,7 +199,7 @@ first_isolate <- function(x, @@ -199,7 +199,7 @@ first_isolate <- function(x,
# -- date
if (is.null(col_date)) {
col_date <- search_type_in_df(tbl = x, type = "date")
col_date <- search_type_in_df(x = x, type = "date")
}
if (is.null(col_date)) {
stop("`col_date` must be set.", call. = FALSE)
@ -217,7 +217,7 @@ first_isolate <- function(x, @@ -217,7 +217,7 @@ first_isolate <- function(x,
col_patient_id <- "patient_id"
message(blue(paste0("NOTE: Using combined columns ", bold("`First name`, `Last name` and `Sex`"), " as input for `col_patient_id`.")))
} else {
col_patient_id <- search_type_in_df(tbl = x, type = "patient_id")
col_patient_id <- search_type_in_df(x = x, type = "patient_id")
}
}
if (is.null(col_patient_id)) {
@ -226,7 +226,7 @@ first_isolate <- function(x, @@ -226,7 +226,7 @@ first_isolate <- function(x,
# -- key antibiotics
if (is.null(col_keyantibiotics)) {
col_keyantibiotics <- search_type_in_df(tbl = x, type = "keyantibiotics")
col_keyantibiotics <- search_type_in_df(x = x, type = "keyantibiotics")
}
if (isFALSE(col_keyantibiotics)) {
col_keyantibiotics <- NULL
@ -234,7 +234,7 @@ first_isolate <- function(x, @@ -234,7 +234,7 @@ first_isolate <- function(x,
# -- specimen
if (is.null(col_specimen)) {
col_specimen <- search_type_in_df(tbl = x, type = "specimen")
col_specimen <- search_type_in_df(x = x, type = "specimen")
}
if (isFALSE(col_specimen)) {
col_specimen <- NULL
@ -547,10 +547,10 @@ filter_first_isolate <- function(x, @@ -547,10 +547,10 @@ filter_first_isolate <- function(x,
col_mo = NULL,
...) {
filter(x, first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
...))
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
...))
}
#' @rdname first_isolate

7
R/freq.R

@ -336,9 +336,10 @@ frequency_tbl <- function(x, @@ -336,9 +336,10 @@ frequency_tbl <- function(x,
cols <- unlist(strsplit(x.name, "$", fixed = TRUE))[2]
x.name <- unlist(strsplit(x.name, "$", fixed = TRUE))[1]
# try to find the object to determine dimensions
x.obj <- tryCatch(get(x.name), error = function(e) NULL)
x.name <- paste0("`", x.name , "`")
if (!is.null(x.obj)) {
if (!is.null(dim(x.obj))) {
x.name <- paste0(x.name,
" (",
x.obj %>%
@ -664,6 +665,10 @@ format_header <- function(x, markdown = FALSE, decimal.mark = ".", big.mark = ", @@ -664,6 +665,10 @@ format_header <- function(x, markdown = FALSE, decimal.mark = ".", big.mark = ",
if (nchar(levels_text) > 70) {
# levels text wider than half the console
levels_text <- paste0(substr(levels_text, 1, 70 - 3), "...")
if (nchar(gsub("[^`]", "", levels_text)) %% 2 == 1) {
# odd number of backticks, should be even
levels_text <- paste0(levels_text, "`")
}
}
header$levels <- paste0(length(header$levels), ": ", levels_text)
header <- header[names(header) != "ordered"]

84
R/key_antibiotics.R

@ -22,7 +22,7 @@ @@ -22,7 +22,7 @@
#' Key antibiotics for first \emph{weighted} isolates
#'
#' These function can be used to determine first isolates (see \code{\link{first_isolate}}). Using key antibiotics to determine first isolates is more reliable than without key antibiotics. These selected isolates will then be called first \emph{weighted} isolates.
#' @param tbl table with antibiotics coloms, like \code{amox} and \code{amcl}.
#' @param x table with antibiotics coloms, like \code{AMX} or \code{amox}
#' @param x,y characters to compare
#' @inheritParams first_isolate
#' @param universal_1,universal_2,universal_3,universal_4,universal_5,universal_6 column names of \strong{broad-spectrum} antibiotics, case-insensitive. At default, the columns containing these antibiotics will be guessed with \code{\link{guess_ab_col}}.
@ -76,33 +76,33 @@ @@ -76,33 +76,33 @@
#'
#' key_antibiotics_equal(strainA, strainB, ignore_I = FALSE)
#' # FALSE, because I is not ignored and so the 4th value differs
key_antibiotics <- function(tbl,
key_antibiotics <- function(x,
col_mo = NULL,
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"),
universal_1 = guess_ab_col(x, "AMX"),
universal_2 = guess_ab_col(x, "AMC"),
universal_3 = guess_ab_col(x, "CXM"),
universal_4 = guess_ab_col(x, "TZP"),
universal_5 = guess_ab_col(x, "CIP"),
universal_6 = guess_ab_col(x, "SXT"),
GramPos_1 = guess_ab_col(x, "VAN"),
GramPos_2 = guess_ab_col(x, "TEC"),
GramPos_3 = guess_ab_col(x, "TCY"),
GramPos_4 = guess_ab_col(x, "ERY"),
GramPos_5 = guess_ab_col(x, "OXA"),
GramPos_6 = guess_ab_col(x, "RIF"),
GramNeg_1 = guess_ab_col(x, "GEN"),
GramNeg_2 = guess_ab_col(x, "TOB"),
GramNeg_3 = guess_ab_col(x, "COL"),
GramNeg_4 = guess_ab_col(x, "CTX"),
GramNeg_5 = guess_ab_col(x, "CAZ"),
GramNeg_6 = guess_ab_col(x, "MEM"),
warnings = TRUE,
...) {
# 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(x = x, type = "mo")
}
if (is.null(col_mo)) {
stop("`col_mo` must be set.", call. = FALSE)
@ -112,7 +112,7 @@ key_antibiotics <- function(tbl, @@ -112,7 +112,7 @@ 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_available_columns <- function(x, col.list, info = TRUE) {
# check columns
col.list <- col.list[!is.na(col.list) & !is.null(col.list)]
names(col.list) <- col.list
@ -121,18 +121,18 @@ key_antibiotics <- function(tbl, @@ -121,18 +121,18 @@ key_antibiotics <- function(tbl,
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)) {
} else if (toupper(col.list[i]) %in% colnames(x)) {
col.list[i] <- toupper(col.list[i])
} else if (tolower(col.list[i]) %in% colnames(tbl)) {
} else if (tolower(col.list[i]) %in% colnames(x)) {
col.list[i] <- tolower(col.list[i])
} else if (!col.list[i] %in% colnames(tbl)) {
} else if (!col.list[i] %in% colnames(x)) {
col.list[i] <- NA
}
}
if (!all(col.list %in% colnames(tbl))) {
if (!all(col.list %in% colnames(x))) {
if (info == TRUE) {
warning('Some columns do not exist and will be ignored: ',
col.list.bak[!(col.list %in% colnames(tbl))] %>% toString(),
col.list.bak[!(col.list %in% colnames(x))] %>% toString(),
'.\nTHIS MAY STRONGLY INFLUENCE THE OUTCOME.',
immediate. = TRUE,
call. = FALSE)
@ -141,7 +141,7 @@ key_antibiotics <- function(tbl, @@ -141,7 +141,7 @@ key_antibiotics <- function(tbl,
col.list
}
col.list <- check_available_columns(tbl = tbl, col.list = col.list, info = warnings)
col.list <- check_available_columns(x = x, col.list = col.list, info = warnings)
universal_1 <- col.list[universal_1]
universal_2 <- col.list[universal_2]
universal_3 <- col.list[universal_3]
@ -183,30 +183,30 @@ key_antibiotics <- function(tbl, @@ -183,30 +183,30 @@ key_antibiotics <- function(tbl,
}
# join to microorganisms data set
tbl <- tbl %>%
x <- x %>%
mutate_at(vars(col_mo), as.mo) %>%
left_join_microorganisms(by = col_mo) %>%
mutate(key_ab = NA_character_,
gramstain = mo_gramstain(pull(., col_mo)))
# Gram +
tbl <- tbl %>% mutate(key_ab =
if_else(gramstain == "Gram positive",
apply(X = tbl[, gram_positive],
MARGIN = 1,
FUN = function(x) paste(x, collapse = "")),
key_ab))
x <- x %>% mutate(key_ab =
if_else(gramstain == "Gram positive",
apply(X = x[, gram_positive],
MARGIN = 1,
FUN = function(x) paste(x, collapse = "")),
key_ab))
# Gram -
tbl <- tbl %>% mutate(key_ab =
if_else(gramstain == "Gram negative",
apply(X = tbl[, gram_negative],
MARGIN = 1,
FUN = function(x) paste(x, collapse = "")),
key_ab))
x <- x %>% mutate(key_ab =
if_else(gramstain == "Gram negative",
apply(X = x[, gram_negative],
MARGIN = 1,
FUN = function(x) paste(x, collapse = "")),
key_ab))
# format
key_abs <- tbl %>%
key_abs <- x %>%
pull(key_ab) %>%
gsub('(NA|NULL)', '.', .) %>%
gsub('[^SIR]', '.', ., ignore.case = TRUE)

290
R/mdro.R

@ -23,12 +23,25 @@ @@ -23,12 +23,25 @@
#'
#' 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 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 country country code to determine guidelines. 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.
#' @param guideline a specific guideline to mention. For some countries this will be determined automatically, see Details. EUCAST guidelines will be used when left empty, see Details.
#' @param info print progress
#' @inheritParams eucast_rules
#' @param verbose print additional info: missing antibiotic columns per parameter
#' @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}).
#' @details When \code{country} is set, the parameter guideline will be ignored as these guidelines will be used:
#'
#' \itemize{
#' \item{\code{country = "nl"}: Rijksinstituut voor Volksgezondheid en Milieu "WIP-richtlijn BRMO (Bijzonder Resistente Micro-Organismen) [ZKH]" (\href{https://www.rivm.nl/Documenten_en_publicaties/Professioneel_Praktisch/Richtlijnen/Infectieziekten/WIP_Richtlijnen/WIP_Richtlijnen/Ziekenhuizen/WIP_richtlijn_BRMO_Bijzonder_Resistente_Micro_Organismen_ZKH}{link})}
#' }
#'
#' Please suggest your own country's specific guidelines by letting us know: \url{https://gitlab.com/msberends/AMR/issues/new}.
#'
#' Other currently supported guidelines are:
#' \itemize{
#' \item{\code{guideline = "eucast"}: 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})}
#' \item{\code{guideline = "tb"}: World Health Organization "Companion handbook to the WHO guidelines for the programmatic management of drug-resistant tuberculosis" (\href{https://www.who.int/tb/publications/pmdt_companionhandbook/en/}{link})}
#' }
#' @return Ordered factor with levels \code{Negative < Positive, unconfirmed < Positive}.
#' @rdname mdro
#' @importFrom dplyr %>%
@ -43,21 +56,41 @@ @@ -43,21 +56,41 @@
#' BRMO = brmo(.))
mdro <- function(x,
country = NULL,
guideline = NULL,
col_mo = NULL,
info = TRUE,
verbose = FALSE,
...) {
tbl_ <- x
if (!is.data.frame(tbl_)) {
if (!is.data.frame(x)) {
stop("`x` must be a data frame.", call. = FALSE)
}
if (length(guideline) > 1) {
stop("`guideline` must be a length one character string.", call. = FALSE)
}
if (!is.null(country)) {
guideline <- country
}
if (is.null(guideline)) {
guideline <- "eucast"
}
if (!tolower(guideline) %in% c("nl", "de", "eucast", "tb")) {
stop("invalid guideline: ", guideline, call. = FALSE)
}
guideline <- list(code = tolower(guideline))
# 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(x = x, type = "mo")
}
if (is.null(col_mo) & guideline$code == "tb") {
message(blue("NOTE: No column found as input for `col_mo`,",
bold("assuming all records contain",
italic("Mycobacterium tuberculosis."))))
x$mo <- AMR::as.mo("Mycobacterium tuberculosis")
col_mo <- "mo"
}
if (is.null(col_mo)) {
stop("`col_mo` must be set.", call. = FALSE)
@ -67,50 +100,59 @@ mdro <- function(x, @@ -67,50 +100,59 @@ mdro <- function(x,
stop("`country` must be a length one character string.", call. = FALSE)
}
if (is.null(country)) {
country <- "EUCAST"
}
country <- trimws(country)
if (tolower(country) != "eucast" & !country %like% "^[a-z]{2}$") {
stop("This is not a valid ISO 3166-1 alpha-2 country code: '", country, "'. Please see ?mdro.", call. = FALSE)
}
# create list and make country code case-independent
guideline <- list(country = list(code = tolower(country)))
if (guideline$country$code == "eucast") {
guideline$country$name <- "(European guidelines)"
if (guideline$code == "eucast") {
guideline$name <- "EUCAST Expert Rules, \"Intrinsic Resistance and Exceptional Phenotypes Tables\""
guideline$version <- "Version 3.1"
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$country$code == "de") {
guideline$country$name <- "Germany"
} else if (guideline$code == "de") {
guideline$name <- "Germany"
guideline$name <- ""
guideline$version <- ""
guideline$source <- ""
} else if (guideline$country$code == "nl") {
guideline$country$name <- "The Netherlands"
guideline$name <- "WIP-Richtlijn BRMO"
} else if (guideline$code == "nl") {
guideline$name <- "WIP-Richtlijn Bijzonder Resistente Micro-organismen (BRMO)"
guideline$author <- "RIVM (Rijksinstituut voor de Volksgezondheid)"
guideline$version <- "Revision as of December 2017"
guideline$source <- "https://www.rivm.nl/Documenten_en_publicaties/Professioneel_Praktisch/Richtlijnen/Infectieziekten/WIP_Richtlijnen/WIP_Richtlijnen/Ziekenhuizen/WIP_richtlijn_BRMO_Bijzonder_Resistente_Micro_Organismen_ZKH"
# add here more countries like this:
# } else if (country$code == "xx") {
# country$name <- "country name"
} else {
stop("This country code is currently unsupported: ", guideline$country$code, call. = FALSE)
stop("This guideline is currently unsupported: ", guideline$code, call. = FALSE)
}
if (info == TRUE) {
cat("Determining multidrug-resistant organisms (MDRO), according to:\n",
"Guideline: ", red(paste0(guideline$name, ", ", guideline$version, "\n")),
"Country : ", red(paste0(guideline$country$name, "\n")),
"Source : ", blue(paste0(guideline$source, "\n")),
"Guideline: ", red(guideline$name), "\n",
"Version: ", red(guideline$version), "\n",
"Author: ", red(guideline$author), "\n",
"Source: ", blue(guideline$source), "\n",
"\n", sep = "")
}
cols_ab <- get_column_abx(x = x, verbose = verbose, ...)
if (guideline$code == "tb") {
cols_ab <- get_column_abx(x = x,
soft_dependencies = c("CAP",
"ETH",
"GAT",
"INH",
"PZA",
"RIF",
"RIB",
"RFP"),
verbose = verbose, ...)
} else {
cols_ab <- get_column_abx(x = x, verbose = verbose, ...)
}
AMC <- cols_ab["AMC"]
AMK <- cols_ab["AMK"]
@ -175,7 +217,20 @@ mdro <- function(x, @@ -175,7 +217,20 @@ mdro <- function(x,
TOB <- cols_ab["TOB"]
TZP <- cols_ab["TZP"]
VAN <- cols_ab["VAN"]
# additional for TB
CAP <- cols_ab["CAP"]
ETH <- cols_ab["ETH"]
GAT <- cols_ab["GAT"]
INH <- cols_ab["INH"]
PZA <- cols_ab["PZA"]
RIF <- cols_ab["RIF"]
RIB <- cols_ab["RIB"]
RFP <- cols_ab["RFP"]
abx_tb <- c(CAP, ETH, GAT, INH, PZA, RIF, RIB, RFP)
abx_tb <- abx_tb[!is.na(abx_tb)]
if (guideline$code == "tb" & length(abx_tb) == 0) {
stop("No antimycobacterials found in data set.", call. = FALSE)
}
ab_missing <- function(ab) {
isTRUE(ab %in% c(NULL, NA)) | length(ab) == 0
@ -194,96 +249,96 @@ mdro <- function(x, @@ -194,96 +249,96 @@ mdro <- function(x,
cols <- cols[!is.na(cols)]
if (length(rows) > 0 & length(cols) > 0) {
if (any_all == "any") {
row_filter <- which(tbl_[, cols] == "R")
row_filter <- which(x[, cols] == "R")
} else if (any_all == "all") {
row_filter <- tbl_ %>%
row_filter <- x %>%
mutate(index = 1:nrow(.)) %>%
filter_at(vars(cols), all_vars(. == "R")) %>%
pull((index))
}
rows <- rows[rows %in% row_filter]
tbl_[rows, "MDRO"] <<- to
x[rows, "MDRO"] <<- to
}
}
tbl_ <- tbl_ %>%
x <- 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
mutate(MDRO = ifelse(!is.na(genus), 1, NA_integer_))
if (guideline$country$code == "eucast") {
if (guideline$code == "eucast") {
# EUCAST ------------------------------------------------------------------
# Table 5
trans_tbl(3,
which(tbl_$family == "Enterobacteriaceae"
| tbl_$fullname %like% "^Pseudomonas aeruginosa"
| tbl_$genus == "Acinetobacter"),
which(x$family == "Enterobacteriaceae"
| x$fullname %like% "^Pseudomonas aeruginosa"
| x$genus == "Acinetobacter"),
COL,
"all")
trans_tbl(3,
which(tbl_$fullname %like% "^Salmonella Typhi"),
which(x$fullname %like% "^Salmonella Typhi"),
c(carbapenems, fluoroquinolones),
"any")
trans_tbl(3,
which(tbl_$fullname %like% "^Haemophilus influenzae"),
which(x$fullname %like% "^Haemophilus influenzae"),
c(cephalosporins_3rd, carbapenems, fluoroquinolones),
"any")
trans_tbl(3,
which(tbl_$fullname %like% "^Moraxella catarrhalis"),
which(x$fullname %like% "^Moraxella catarrhalis"),
c(cephalosporins_3rd, fluoroquinolones),
"any")
trans_tbl(3,
which(tbl_$fullname %like% "^Neisseria meningitidis"),
which(x$fullname %like% "^Neisseria meningitidis"),
c(cephalosporins_3rd, fluoroquinolones),
"any")
trans_tbl(3,
which(tbl_$fullname %like% "^Neisseria gonorrhoeae"),
which(x$fullname %like% "^Neisseria gonorrhoeae"),
AZM,
"any")
# Table 6
trans_tbl(3,
which(tbl_$fullname %like% "^Staphylococcus (aureus|epidermidis|coagulase negatief|hominis|haemolyticus|intermedius|pseudointermedius)"),
which(x$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"),
which(x$genus == "Corynebacterium"),
c(VAN, TEC, DAP, LNZ, QDA, TGC),
"any")
trans_tbl(3,
which(tbl_$fullname %like% "^Streptococcus pneumoniae"),
which(x$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)"),
which(x$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"),
which(x$genus == "Enterococcus"),
c(DAP, LNZ, TGC, TEC),
"any")
trans_tbl(3,
which(tbl_$fullname %like% "^Enterococcus faecalis"),
which(x$fullname %like% "^Enterococcus faecalis"),
c(AMP, AMX),
"any")
# Table 7
trans_tbl(3,
which(tbl_$genus == "Bacteroides"),
which(x$genus == "Bacteroides"),
MTR,
"any")
trans_tbl(3,
which(tbl_$fullname %like% "^Clostridium difficile"),
which(x$fullname %like% "^Clostridium difficile"),
c(MTR, VAN),
"any")
}
if (guideline$country$code == "de") {
if (guideline$code == "de") {
# Germany -----------------------------------------------------------------
stop("We are still working on German guidelines in this beta version.", call. = FALSE)
}
if (guideline$country$code == "nl") {
if (guideline$code == "nl") {
# Netherlands -------------------------------------------------------------
aminoglycosides <- aminoglycosides[!is.na(aminoglycosides)]
fluoroquinolones <- fluoroquinolones[!is.na(fluoroquinolones)]
@ -298,32 +353,32 @@ mdro <- function(x, @@ -298,32 +353,32 @@ mdro <- function(x,
# Table 1
trans_tbl(3,
which(tbl_$family == "Enterobacteriaceae"),
which(x$family == "Enterobacteriaceae"),
c(aminoglycosides, fluoroquinolones),
"all")
trans_tbl(2,
which(tbl_$family == "Enterobacteriaceae"),
which(x$family == "Enterobacteriaceae"),
carbapenems,
"any")
trans_tbl(2,
which(tbl_$family == "Enterobacteriaceae"),
which(x$family == "Enterobacteriaceae"),
ESBLs,
"all")
# Table 2
trans_tbl(2,
which(tbl_$genus == "Acinetobacter"),
which(x$genus == "Acinetobacter"),
c(carbapenems),
"any")
trans_tbl(3,
which(tbl_$genus == "Acinetobacter"),
which(x$genus == "Acinetobacter"),
c(aminoglycosides, fluoroquinolones),
"all")
trans_tbl(3,
which(tbl_$fullname %like% "^Stenotrophomonas maltophilia"),
which(x$fullname %like% "^Stenotrophomonas maltophilia"),
SXT,
"all")
@ -332,39 +387,108 @@ mdro <- function(x, @@ -332,39 +387,108 @@ mdro <- function(x,
& !ab_missing(CIP)
& !ab_missing(CAZ)
& !ab_missing(TZP) ) {
tbl_$psae <- 0
tbl_[which(tbl_[, MEM] == "R" | tbl_[, IPM] == "R"), "psae"] <- 1 + tbl_[which(tbl_[, MEM] == "R" | tbl_[, IPM] == "R"), "psae"]
tbl_[which(tbl_[, GEN] == "R" & tbl_[, TOB] == "R"), "psae"] <- 1 + tbl_[which(tbl_[, GEN] == "R" & tbl_[, TOB] == "R"), "psae"]
tbl_[which(tbl_[, CIP] == "R"), "psae"] <- 1 + tbl_[which(tbl_[, CIP] == "R"), "psae"]
tbl_[which(tbl_[, CAZ] == "R"), "psae"] <- 1 + tbl_[which(tbl_[, CAZ] == "R"), "psae"]
tbl_[which(tbl_[, TZP] == "R"), "psae"] <- 1 + tbl_[which(tbl_[, TZP] == "R"), "psae"]
x$psae <- 0
x[which(x[, MEM] == "R" | x[, IPM] == "R"), "psae"] <- 1 + x[which(x[, MEM] == "R" | x[, IPM] == "R"), "psae"]
x[which(x[, GEN] == "R" & x[, TOB] == "R"), "psae"] <- 1 + x[which(x[, GEN] == "R" & x[, TOB] == "R"), "psae"]
x[which(x[, CIP] == "R"), "psae"] <- 1 + x[which(x[, CIP] == "R"), "psae"]
x[which(x[, CAZ] == "R"), "psae"] <- 1 + x[which(x[, CAZ] == "R"), "psae"]
x[which(x[, TZP] == "R"), "psae"] <- 1 + x[which(x[, TZP] == "R"), "psae"]
} else {
tbl_$psae <- 0
x$psae <- 0
}
tbl_[which(
tbl_$fullname %like% "Pseudomonas aeruginosa"
& tbl_$psae >= 3
x[which(
x$fullname %like% "Pseudomonas aeruginosa"
& x$psae >= 3
), "MDRO"] <- 3
# Table 3
trans_tbl(3,
which(tbl_$fullname %like% "Streptococcus pneumoniae"),
which(x$fullname %like% "Streptococcus pneumoniae"),
PEN,
"all")
trans_tbl(3,
which(tbl_$fullname %like% "Streptococcus pneumoniae"),
which(x$fullname %like% "Streptococcus pneumoniae"),
VAN,
"all")
trans_tbl(3,
which(tbl_$fullname %like% "Enterococcus faecium"),
which(x$fullname %like% "Enterococcus faecium"),
c(PEN, VAN),
"all")
}
factor(x = tbl_$MDRO,
levels = 1:3,
labels = c("Negative", "Positive, unconfirmed", "Positive"),
ordered = TRUE)
prepare_drug <- function(ab) {
# returns vector values of drug
# if `ab` is a column name, looks up the values in `x`
if (length(ab) == 1 & is.character(ab)) {
if (ab %in% colnames(x)) {
ab <- as.data.frame(x)[, ab]
}
}
ab <- as.character(as.rsi(ab))
ab[is.na(ab)] <- ""
ab
}
drug_is_R <- function(ab) {
# returns logical vector
ab <- prepare_drug(ab)
if (length(ab) == 1) {
rep(ab, NROW(x)) == "R"
} else {
ab == "R"
}
}
drug_is_not_R <- function(ab) {
# returns logical vector
ab <- prepare_drug(ab)
if (length(ab) == 1) {
rep(ab, NROW(x)) != "R"
} else {
ab != "R"
}
}
if (guideline$code == "tb") {
# Tuberculosis ------------------------------------------------------------
x <- x %>%
mutate(mono_count = 0,
mono_count = ifelse(drug_is_R(INH), mono_count + 1, mono_count),
mono_count = ifelse(drug_is_R(RIF), mono_count + 1, mono_count),
mono_count = ifelse(drug_is_R(ETH), mono_count + 1, mono_count),
mono_count = ifelse(drug_is_R(PZA), mono_count + 1, mono_count),
mono_count = ifelse(drug_is_R(RIB), mono_count + 1, mono_count),
mono_count = ifelse(drug_is_R(RFP), mono_count + 1, mono_count),
# from here on logicals
mono = mono_count > 0,
poly = ifelse(mono_count > 1 & drug_is_not_R(RIF) & drug_is_not_R(INH),
TRUE, FALSE),
mdr = ifelse(drug_is_R(RIF) & drug_is_R(INH),
TRUE, FALSE),
xdr = ifelse(drug_is_R(LVX) | drug_is_R(MFX) | drug_is_R(GAT),
TRUE, FALSE),
second = ifelse(drug_is_R(CAP) | drug_is_R(KAN) | drug_is_R(AMK),
TRUE, FALSE),
xdr = ifelse(mdr & xdr & second, TRUE, FALSE)) %>%
mutate(mdr_tb = case_when(xdr ~ 5,
mdr ~ 4,
poly ~ 3,
mono ~ 2,
TRUE ~ 1),
# keep all real TB, make other species NA
mdr_tb = ifelse(x$fullname == "Mycobacterium tuberculosis", mdr_tb, NA_real_))
}
# return results
if (guideline$code == "tb") {
factor(x = x$mdr_tb,
levels = 1:5,
labels = c("Negative", "Mono-resistance", "Poly-resistance", "Multidrug resistance", "Extensive drug resistance"),
ordered = TRUE)
} else {
factor(x = x$MDRO,
levels = 1:3,
labels = c("Negative", "Positive, unconfirmed", "Positive"),
ordered = TRUE)
}
}
#' @rdname mdro
@ -381,6 +505,12 @@ mrgn <- function(x, country = "de", ...) { @@ -381,6 +505,12 @@ mrgn <- function(x, country = "de", ...) {
#' @rdname mdro
#' @export
eucast_exceptional_phenotypes <- function(x, country = "EUCAST", ...) {
mdro(x = x, country = "EUCAST", ...)
mdr_tb <- function(x, guideline = "TB", ...) {
mdro(x = x, guideline = "TB", ...)
}
#' @rdname mdro
#' @export
eucast_exceptional_phenotypes <- function(x, guideline = "EUCAST", ...) {
mdro(x = x, guideline = "EUCAST", ...)
}

44
R/misc.R

@ -87,43 +87,43 @@ percent <- function(x, round = 1, force_zero = FALSE, decimal.mark = getOption(" @@ -87,43 +87,43 @@ percent <- function(x, round = 1, force_zero = FALSE, decimal.mark = getOption("
#' @importFrom crayon blue bold red
#' @importFrom dplyr %>% pull
search_type_in_df <- function(tbl, type) {
search_type_in_df <- function(x, type) {
# try to find columns based on type
found <- NULL
colnames(tbl) <- trimws(colnames(tbl))
colnames(x) <- trimws(colnames(x))
# -- mo
if (type == "mo") {
if ("mo" %in% lapply(tbl, class)) {
found <- colnames(tbl)[lapply(tbl, class) == "mo"][1]
} else if (any(colnames(tbl) %like% "^(mo|microorganism|organism|bacteria)")) {
found <- colnames(tbl)[colnames(tbl) %like% "^(mo|microorganism|organism|bacteria)"][1]
} else if (any(colnames(tbl) %like% "species")) {
found <- colnames(tbl)[colnames(tbl) %like% "species"][1]
if ("mo" %in% lapply(x, class)) {
found <- colnames(x)[lapply(x, class) == "mo"][1]
} else if (any(colnames(x) %like% "^(mo|microorganism|organism|bacteria)s?$")) {
found <- colnames(x)[colnames(x) %like% "^(mo|microorganism|organism|bacteria)s?$"][1]
} else if (any(colnames(x) %like% "species")) {
found <- colnames(x)[colnames(x) %like% "species"][1]
}
}
# -- key antibiotics
if (type == "keyantibiotics") {
if (any(colnames(tbl) %like% "^key.*(ab|antibiotics)")) {
found <- colnames(tbl)[colnames(tbl) %like% "^key.*(ab|antibiotics)"][1]
if (any(colnames(x) %like% "^key.*(ab|antibiotics)")) {
found <- colnames(x)[colnames(x) %like% "^key.*(ab|antibiotics)"][1]
}
}
# -- date
if (type == "date") {
if (any(colnames(tbl) %like% "^(specimen date|specimen_date|spec_date)")) {
if (any(colnames(x) %like% "^(specimen date|specimen_date|spec_date)")) {
# WHONET support
found <- colnames(tbl)[colnames(tbl) %like% "^(specimen date|specimen_date|spec_date)"][1]
if (!any(class(tbl %>% pull(found)) %in% c("Date", "POSIXct"))) {
found <- colnames(x)[colnames(x) %like% "^(specimen date|specimen_date|spec_date)"][1]
if (!any(class(x %>% pull(found)) %in% c("Date", "POSIXct"))) {
stop(red(paste0("ERROR: Found column `", bold(found), "` to be used as input for `col_", type,
"`, but this column contains no valid dates. Transform its values to valid dates first.")),
call. = FALSE)
}
} else {
for (i in 1:ncol(tbl)) {
if (any(class(tbl %>% pull(i)) %in% c("Date", "POSIXct"))) {
found <- colnames(tbl)[i]
for (i in 1:ncol(x)) {
if (any(class(x %>% pull(i)) %in% c("Date", "POSIXct"))) {
found <- colnames(x)[i]
break
}
}
@ -131,16 +131,16 @@ search_type_in_df <- function(tbl, type) { @@ -131,16 +131,16 @@ search_type_in_df <- function(tbl, type) {
}
# -- patient id
if (type == "patient_id") {
if (any(colnames(tbl) %like% "^(identification |patient|patid)")) {
found <- colnames(tbl)[colnames(tbl) %like% "^(identification |patient|patid)"][1]
if (any(colnames(x) %like% "^(identification |patient|patid)")) {
found <- colnames(x)[colnames(x) %like% "^(identification |patient|patid)"][1]
}
}
# -- specimen
if (type == "specimen") {
if (any(colnames(tbl) %like% "(specimen type|spec_type)")) {
found <- colnames(tbl)[colnames(tbl) %like% "(specimen type|spec_type)"][1]
} else if (any(colnames(tbl) %like% "^(specimen)")) {
found <- colnames(tbl)[colnames(tbl) %like% "^(specimen)"][1]
if (any(colnames(x) %like% "(specimen type|spec_type)")) {
found <- colnames(x)[colnames(x) %like% "(specimen type|spec_type)"][1]
} else if (any(colnames(x) %like% "^(specimen)")) {
found <- colnames(x)[colnames(x) %like% "^(specimen)"][1]
}
}

2
R/portion.R

@ -31,7 +31,7 @@ @@ -31,7 +31,7 @@
#' @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{ab_property}}
#' @inheritParams ab_property
#' @param combine_SI a logical to indicate whether all values of S and I must be merged into one, so the output only consists of S+I vs. R (susceptible vs. resistant). This used to be the parameter \code{combine_IR}, but this now follows the redefinition by EUCAST about the interpretion of I (increased exposure) in 2019, see below. Default is now \code{TRUE}.
#' @param combine_SI a logical to indicate whether all values of S and I must be merged into one, so the output only consists of S+I vs. R (susceptible vs. resistant). This used to be the parameter \code{combine_IR}, but this now follows the redefinition by EUCAST about the interpretion of I (increased exposure) in 2019, see section 'Interpretation of S, I and R' below. Default is \code{TRUE}.
#' @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. I+R (susceptible vs. non-susceptible). This is outdated, see parameter \code{combine_SI}.
#' @inheritSection as.rsi Interpretation of S, I and R
#' @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.

2
R/resistance_predict.R

@ -140,7 +140,7 @@ resistance_predict <- function(x, @@ -140,7 +140,7 @@ resistance_predict <- function(x,
# -- date
if (is.null(col_date)) {
col_date <- search_type_in_df(tbl = x, type = "date")
col_date <- search_type_in_df(x = x, type = "date")
}
if (is.null(col_date)) {
stop("`col_date` must be set.", call. = FALSE)

30
R/rsi.R

@ -39,9 +39,9 @@ @@ -39,9 +39,9 @@
#' In 2019, EUCAST has decided to change the definitions of susceptibility testing categories S, I and R as shown below. Results of several consultations on the new definitions are available on the EUCAST website under "Consultations".
#'
#' \itemize{
#' \item{\strong{S}}{Susceptible, standard dosing regimen: A microorganism is categorised as "Susceptible, standard dosing regimen", when there is a high likelihood of therapeutic success using a standard dosing regimen of the agent.}
#' \item{\strong{I}}{Susceptible, increased exposure: A microorganism is categorised as "Susceptible, Increased exposure" when there is a high likelihood of therapeutic success because exposure to the agent is increased by adjusting the dosing regimen or by its concentration at the site of infection.}
#' \item{\strong{R}}{Resistant: A microorganism is categorised as "Resistant" when there is a high likelihood of therapeutic failure even when there is increased exposure.}
#' \item{\strong{S} - }{Susceptible, standard dosing regimen: A microorganism is categorised as "Susceptible, standard dosing regimen", when there is a high likelihood of therapeutic success using a standard dosing regimen of the agent.}
#' \item{\strong{I} - }{Susceptible, increased exposure: A microorganism is categorised as "Susceptible, Increased exposure" when there is a high likelihood of therapeutic success because exposure to the agent is increased by adjusting the dosing regimen or by its concentration at the site of infection.}
#' \item{\strong{R} - }{Resistant: A microorganism is categorised as "Resistant" when there is a high likelihood of therapeutic failure even when there is increased exposure.}
#' }
#'
#' Exposure is a function of how the mode of administration, dose, dosing interval, infusion time, as well as distribution and excretion of the antimicrobial agent will influence the infecting organism at the site of infection.
@ -259,9 +259,9 @@ exec_as.rsi <- function(method, x, mo, ab, guideline) { @@ -259,9 +259,9 @@ exec_as.rsi <- function(method, x, mo, ab, guideline) {
#' @importFrom crayon red blue
#' @export
as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", ...) {
tbl_ <- x
x <- x
ab_cols <- colnames(tbl_)[sapply(tbl_, function(x) is.mic(x) | is.disk(x))]
ab_cols <- colnames(x)[sapply(x, function(y) is.mic(y) | is.disk(y))]
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)
}
@ -269,14 +269,14 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", ...) { @@ -269,14 +269,14 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", ...) {
# 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(x = x, 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)]
ab_cols <- colnames(x)[sapply(x, is.mic)]
if (length(ab_cols) > 0) {
for (i in 1:length(ab_cols)) {
if (is.na(suppressWarnings(as.ab(ab_cols[i])))) {
@ -284,16 +284,16 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", ...) { @@ -284,16 +284,16 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", ...) {
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),
x[, ab_cols[i]] <- exec_as.rsi(method = "mic",
x = x %>% pull(ab_cols[i]),
mo = x %>% 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)]
ab_cols <- colnames(x)[sapply(x, is.disk)]
if (length(ab_cols) > 0) {
for (i in 1:length(ab_cols)) {
if (is.na(suppressWarnings(as.ab(ab_cols[i])))) {
@ -301,16 +301,16 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", ...) { @@ -301,16 +301,16 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", ...) {
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),
x[, ab_cols[i]] <- exec_as.rsi(method = "disk",
x = x %>% pull(ab_cols[i]),
mo = x %>% pull(col_mo),
ab = as.ab(ab_cols[i]),