Browse Source

(v1.5.0.9016) only_rsi_columns update, documentation

main
parent
commit
4a84894f79
  1. 4
      DESCRIPTION
  2. 2
      NAMESPACE
  3. 34
      NEWS.md
  4. 18
      R/aa_helper_functions.R
  5. 50
      R/ab_class_selectors.R
  6. 2
      R/ab_property.R
  7. 18
      R/eucast_rules.R
  8. 74
      R/filter_ab_class.R
  9. 56
      R/first_isolate.R
  10. 4
      R/guess_ab_col.R
  11. 16
      R/key_antibiotics.R
  12. 174
      R/mdro.R
  13. 9
      R/mo_property.R
  14. 3
      R/rsi.R
  15. BIN
      data-raw/AMR_1.5.0.9016.tar.gz
  16. BIN
      data/example_isolates.rda
  17. 2
      docs/404.html
  18. 2
      docs/LICENSE-text.html
  19. 2
      docs/articles/index.html
  20. 2
      docs/authors.html
  21. 10
      docs/index.html
  22. 2
      docs/pkgdown.yml
  23. 2
      docs/reference/AMR-deprecated.html
  24. 2
      docs/reference/AMR.html
  25. 2
      docs/reference/WHOCC.html
  26. 2
      docs/reference/WHONET.html
  27. 2
      docs/reference/ab_from_text.html
  28. 4
      docs/reference/ab_property.html
  29. 2
      docs/reference/age.html
  30. 2
      docs/reference/age_groups.html
  31. 34
      docs/reference/antibiotic_class_selectors.html
  32. 2
      docs/reference/antibiotics.html
  33. 2
      docs/reference/as.ab.html
  34. 2
      docs/reference/as.disk.html
  35. 2
      docs/reference/as.mic.html
  36. 2
      docs/reference/as.mo.html
  37. 2
      docs/reference/as.rsi.html
  38. 2
      docs/reference/atc_online.html
  39. 2
      docs/reference/availability.html
  40. 2
      docs/reference/bug_drug_combinations.html
  41. 2
      docs/reference/catalogue_of_life.html
  42. 2
      docs/reference/catalogue_of_life_version.html
  43. 2
      docs/reference/count.html
  44. 2
      docs/reference/dosage.html
  45. 6
      docs/reference/eucast_rules.html
  46. 2
      docs/reference/example_isolates.html
  47. 2
      docs/reference/example_isolates_unclean.html
  48. 118
      docs/reference/filter_ab_class.html
  49. 18
      docs/reference/first_isolate.html
  50. 2
      docs/reference/g.test.html
  51. 2
      docs/reference/get_episode.html
  52. 2
      docs/reference/ggplot_rsi.html
  53. 6
      docs/reference/guess_ab_col.html
  54. 6
      docs/reference/index.html
  55. 2
      docs/reference/intrinsic_resistant.html
  56. 2
      docs/reference/isolate_identifier.html
  57. 2
      docs/reference/join.html
  58. 6
      docs/reference/key_antibiotics.html
  59. 2
      docs/reference/kurtosis.html
  60. 2
      docs/reference/like.html
  61. 23
      docs/reference/mdro.html
  62. 2
      docs/reference/microorganisms.codes.html
  63. 2
      docs/reference/microorganisms.html
  64. 2
      docs/reference/microorganisms.old.html
  65. 2
      docs/reference/mo_matching_score.html
  66. 8
      docs/reference/mo_property.html
  67. 2
      docs/reference/mo_source.html
  68. 2
      docs/reference/pca.html
  69. 2
      docs/reference/plot.html
  70. 2
      docs/reference/proportion.html
  71. 2
      docs/reference/random.html
  72. 4
      docs/reference/resistance_predict.html
  73. 2
      docs/reference/rsi_translation.html
  74. 2
      docs/reference/skewness.html
  75. 2
      docs/reference/translate.html
  76. 2
      docs/survey.html
  77. 8
      index.md
  78. 2
      man/ab_property.Rd
  79. 33
      man/antibiotic_class_selectors.Rd
  80. 4
      man/eucast_rules.Rd
  81. 117
      man/filter_ab_class.Rd
  82. 16
      man/first_isolate.Rd
  83. 4
      man/guess_ab_col.Rd
  84. 4
      man/key_antibiotics.Rd
  85. 21
      man/mdro.Rd
  86. 6
      man/mo_property.Rd
  87. 2
      man/resistance_predict.Rd
  88. 9
      tests/testthat/test-_misc.R

4
DESCRIPTION

@ -1,6 +1,6 @@ @@ -1,6 +1,6 @@
Package: AMR
Version: 1.5.0.9015
Date: 2021-02-04
Version: 1.5.0.9016
Date: 2021-02-08
Title: Antimicrobial Resistance Data Analysis
Authors@R: c(
person(role = c("aut", "cre"),

2
NAMESPACE

@ -143,6 +143,7 @@ export(filter_first_weighted_isolate) @@ -143,6 +143,7 @@ export(filter_first_weighted_isolate)
export(filter_fluoroquinolones)
export(filter_glycopeptides)
export(filter_macrolides)
export(filter_oxazolidinones)
export(filter_penicillins)
export(filter_tetracyclines)
export(first_isolate)
@ -211,6 +212,7 @@ export(mo_url) @@ -211,6 +212,7 @@ export(mo_url)
export(mo_year)
export(mrgn)
export(n_rsi)
export(oxazolidinones)
export(p_symbol)
export(pca)
export(penicillins)

34
NEWS.md

@ -1,30 +1,26 @@ @@ -1,30 +1,26 @@
# AMR 1.5.0.9015
## <small>Last updated: 4 February 2021</small>
# AMR 1.5.0.9016
## <small>Last updated: 8 February 2021</small>
### Breaking
* Functions that are applied to a data set containing antibiotic columns gained the argument `only_rsi_columns`, which defaults to `TRUE` if any of the columns are of class `<rsi>` (i.e., transformed with `as.rsi()`). This increases reliability of automatic determination of antibiotic columns (so only columns that are defined to be `<rsi>` will be affected).
This change might invalidate existing code. But since the new argument always returns `FALSE` when no `<rsi>` column can be found in the data, this chance is low.
Affected functions are:
### New
* Support for EUCAST Clinical Breakpoints v11.0 (2021), effective in the `eucast_rules()` function and in `as.rsi()` to interpret MIC and disk diffusion values. This is now the default guideline in this package.
* Added function `eucast_dosage()` to get a `data.frame` with advised dosages of a certain bug-drug combination, which is based on the new `dosage` data set
* Added data set `dosage` to fuel the new `eucast_dosage()` function and to make this data available in a structured way
* Existing data set `example_isolates` now reflects the latest EUCAST rules
* Added argument `only_rsi_columns` for some functions, which defaults to `FALSE`, to indicate if the functions must only be applied to columns that are of class `<rsi>` (i.e., transformed with `as.rsi()`). This increases speed since automatic determination of antibiotic columns is not needed anymore. Affected functions are:
* All antibiotic selector functions (`ab_class()` and its wrappers, such as `aminoglocysides()`, `carbapenems()`, `penicillins()`)
* All antibiotic filter functions (`filter_ab_class()` and its wrappers, such as `filter_aminoglocysides()`, `filter_carbapenems()`, `filter_penicillins()`)
* `eucast_rules()`
* `mdro()` (including wrappers such as `brmo()`, `mrgn` and `eucast_exceptional_phenotypes()`)
* `guess_ab_col()`
You can quickly transform all your eligible columns using either:
* Functions `oxazolidinones()` (an antibiotic selector function) and `filter_oxazolidinones()` (an antibiotic filter function) to select/filter on e.g. linezolid and tedizolid
```r
library(dplyr)
your_date %>% mutate_if(is.rsi.eligible, as.rsi) # old dplyr
your_date %>% mutate(across((is.rsi.eligible), as.rsi)) # new dplyr
```
### New
* Support for EUCAST Clinical Breakpoints v11.0 (2021), effective in the `eucast_rules()` function and in `as.rsi()` to interpret MIC and disk diffusion values. This is now the default guideline in this package.
* Data set `dosage` to fuel the new `eucast_dosage()` function and to make this data available in a structured way
* Function `eucast_dosage()` to get a `data.frame` with advised dosages of a certain bug-drug combination, which is based on the new `dosage` data set
x <- example_isolates %>% select(date, hospital_id, oxazolidinones())
#> Selecting oxazolidinones: column 'LNZ' (linezolid)
x <- example_isolates %>% filter_oxazolidinones()
#> Filtering on oxazolidinones: value in column `LNZ` (linezolid) is either "R", "S" or "I"
```
* Support for custom MDRO guidelines, using the new `custom_mdro_guideline()` function, please see `mdro()` for additional info
* Function `isolate_identifier()`, which will paste a microorganism code with all antimicrobial results of a data set into one string for each row. This is useful to compare isolates, e.g. between institutions or regions, when there is no genotyping available.
* Function `mo_is_yeast()`, which determines whether a microorganism is a member of the taxonomic class Saccharomycetes or the taxonomic order Saccharomycetales:

18
R/aa_helper_functions.R

@ -675,7 +675,18 @@ get_current_data <- function(arg_name, call) { @@ -675,7 +675,18 @@ get_current_data <- function(arg_name, call) {
# nothing worked, so:
if (is.na(arg_name)) {
stop_("this function must be used inside valid dplyr selection verbs or inside a data.frame call",
if (isTRUE(is.numeric(call))) {
fn <- as.character(sys.call(call + 1)[1])
examples <- paste0(", e.g.:\n",
" your_data %>% select(", fn, "())\n",
" your_data %>% select(column_a, column_b, ", fn, "())\n",
" your_data[, ", fn, "()]\n",
' your_data[, c("column_a", "column_b", ', fn, "())]")
} else {
examples <- ""
}
stop_("this function must be used inside valid dplyr selection verbs or inside a data.frame call",
examples,
call = call)
} else {
stop_("argument `", arg_name, "` is missing with no default", call = call)
@ -721,6 +732,11 @@ get_current_column <- function() { @@ -721,6 +732,11 @@ get_current_column <- function() {
}
}
is_null_or_grouped_tbl <- function(x) {
# attribute "grouped_df" might change at one point, so only set in one place; here.
is.null(x) || inherits(x, "grouped_tbl")
}
unique_call_id <- function(entire_session = FALSE) {
if (entire_session == TRUE) {
c(envir = "session",

50
R/ab_class_selectors.R

@ -27,7 +27,7 @@ @@ -27,7 +27,7 @@
#'
#' These functions help to select the columns of antibiotics that are of a specific antibiotic class, without the need to define the columns or antibiotic abbreviations. \strong{\Sexpr{ifelse(as.double(R.Version()$major) + (as.double(R.Version()$minor) / 10) < 3.2, paste0("NOTE: THESE FUNCTIONS DO NOT WORK ON YOUR CURRENT R VERSION. These functions require R version 3.2 or later - you have ", R.version.string, "."), "")}}
#' @inheritSection lifecycle Stable Lifecycle
#' @param only_rsi_columns a logical to indicate whether only columns of class [`<rsi>`]([rsi]) must be selected. If set to `NULL` (default), it will be `TRUE` if any column of the data was [transformed to class `<rsi>`]([rsi]) on beforehand, and `FALSE` otherwise.
#' @param only_rsi_columns a logical to indicate whether only columns of class [`<rsi>`]([rsi]) must be selected (defaults to `FALSE`)
#' @inheritParams filter_ab_class
#' @details \strong{\Sexpr{ifelse(as.double(R.Version()$major) + (as.double(R.Version()$minor) / 10) < 3.2, paste0("NOTE: THESE FUNCTIONS DO NOT WORK ON YOUR CURRENT R VERSION. These functions require R version 3.2 or later - you have ", R.version.string, "."), "")}}
#'
@ -81,85 +81,91 @@ @@ -81,85 +81,91 @@
#' example_isolates %>% filter(across(carbapenems(), ~. == "R"))
#' }
ab_class <- function(ab_class,
only_rsi_columns = NULL) {
only_rsi_columns = FALSE) {
ab_selector(ab_class, function_name = "ab_class", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
aminoglycosides <- function(only_rsi_columns = NULL) {
aminoglycosides <- function(only_rsi_columns = FALSE) {
ab_selector("aminoglycoside", function_name = "aminoglycosides", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
carbapenems <- function(only_rsi_columns = NULL) {
carbapenems <- function(only_rsi_columns = FALSE) {
ab_selector("carbapenem", function_name = "carbapenems", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
cephalosporins <- function(only_rsi_columns = NULL) {
cephalosporins <- function(only_rsi_columns = FALSE) {
ab_selector("cephalosporin", function_name = "cephalosporins", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
cephalosporins_1st <- function(only_rsi_columns = NULL) {
cephalosporins_1st <- function(only_rsi_columns = FALSE) {
ab_selector("cephalosporins.*1", function_name = "cephalosporins_1st", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
cephalosporins_2nd <- function(only_rsi_columns = NULL) {
cephalosporins_2nd <- function(only_rsi_columns = FALSE) {
ab_selector("cephalosporins.*2", function_name = "cephalosporins_2nd", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
cephalosporins_3rd <- function(only_rsi_columns = NULL) {
cephalosporins_3rd <- function(only_rsi_columns = FALSE) {
ab_selector("cephalosporins.*3", function_name = "cephalosporins_3rd", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
cephalosporins_4th <- function(only_rsi_columns = NULL) {
cephalosporins_4th <- function(only_rsi_columns = FALSE) {
ab_selector("cephalosporins.*4", function_name = "cephalosporins_4th", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
cephalosporins_5th <- function(only_rsi_columns = NULL) {
cephalosporins_5th <- function(only_rsi_columns = FALSE) {
ab_selector("cephalosporins.*5", function_name = "cephalosporins_5th", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
fluoroquinolones <- function(only_rsi_columns = NULL) {
fluoroquinolones <- function(only_rsi_columns = FALSE) {
ab_selector("fluoroquinolone", function_name = "fluoroquinolones", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
glycopeptides <- function(only_rsi_columns = NULL) {
glycopeptides <- function(only_rsi_columns = FALSE) {
ab_selector("glycopeptide", function_name = "glycopeptides", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
macrolides <- function(only_rsi_columns = NULL) {
macrolides <- function(only_rsi_columns = FALSE) {
ab_selector("macrolide", function_name = "macrolides", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
penicillins <- function(only_rsi_columns = NULL) {
oxazolidinones <- function(only_rsi_columns = FALSE) {
ab_selector("oxazolidinone", function_name = "oxazolidinones", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
penicillins <- function(only_rsi_columns = FALSE) {
ab_selector("penicillin", function_name = "penicillins", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
tetracyclines <- function(only_rsi_columns = NULL) {
tetracyclines <- function(only_rsi_columns = FALSE) {
ab_selector("tetracycline", function_name = "tetracyclines", only_rsi_columns = only_rsi_columns)
}
@ -168,7 +174,7 @@ ab_selector <- function(ab_class, @@ -168,7 +174,7 @@ ab_selector <- function(ab_class,
only_rsi_columns) {
meet_criteria(ab_class, allow_class = "character", has_length = 1, .call_depth = 1)
meet_criteria(function_name, allow_class = "character", has_length = 1, .call_depth = 1)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1, allow_NULL = TRUE, .call_depth = 1)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1, .call_depth = 1)
if (as.double(R.Version()$major) + (as.double(R.Version()$minor) / 10) < 3.2) {
warning_("antibiotic class selectors such as ", function_name,
@ -178,9 +184,7 @@ ab_selector <- function(ab_class, @@ -178,9 +184,7 @@ ab_selector <- function(ab_class,
}
vars_df <- get_current_data(arg_name = NA, call = -3)
if (is.null(only_rsi_columns)) {
only_rsi_columns <- any(is.rsi(vars_df))
}
# improve speed here so it will only run once when e.g. in one select call
if (!identical(pkg_env$ab_selector, unique_call_id())) {
ab_in_data <- get_column_abx(vars_df, info = FALSE, only_rsi_columns = only_rsi_columns)
@ -212,14 +216,16 @@ ab_selector <- function(ab_class, @@ -212,14 +216,16 @@ ab_selector <- function(ab_class,
if (length(agents) == 0) {
message_("No antimicrobial agents of class ", ab_group, " found", examples, ".")
} else {
agents_formatted <- paste0("column '", font_bold(agents, collapse = NULL), "'")
agents_formatted <- paste0("'", font_bold(agents, collapse = NULL), "'")
agents_names <- ab_name(names(agents), tolower = TRUE, language = NULL)
need_name <- tolower(gsub("[^a-zA-Z]", "", agents)) != tolower(gsub("[^a-zA-Z]", "", agents_names))
agents_formatted[need_name] <- paste0(agents_formatted[need_name],
" (", agents_names[need_name], ")")
message_("Selecting ", ab_group, ": ", vector_and(agents_formatted, quotes = FALSE),
message_("Selecting ", ab_group, ": ",
ifelse(length(agents) == 1, "column ", "columns "),
vector_and(agents_formatted, quotes = FALSE),
as_note = FALSE,
extra_indent = 4)
extra_indent = 6)
}
remember_thrown_message(function_name)
}

2
R/ab_property.R

@ -35,7 +35,7 @@ @@ -35,7 +35,7 @@
#' @param units a logical to indicate whether the units instead of the DDDs itself must be returned, see *Examples*
#' @param open browse the URL using [utils::browseURL()]
#' @param ... other arguments passed on to [as.ab()]
#' @details All output will be [translate]d where possible.
#' @details All output [will be translated][translate] where possible.
#'
#' The function [ab_url()] will return the direct URL to the official WHO website. A warning will be returned if the required ATC code is not available.
#' @inheritSection as.ab Source

18
R/eucast_rules.R

@ -78,7 +78,7 @@ format_eucast_version_nr <- function(version, markdown = TRUE) { @@ -78,7 +78,7 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
#' @param ... column name of an antibiotic, see section *Antibiotics* below
#' @param ab any (vector of) text that can be coerced to a valid antibiotic code with [as.ab()]
#' @param administration route of administration, either `r vector_or(dosage$administration)`
#' @param only_rsi_columns a logical to indicate whether only antibiotic columns must be detected that were [transformed to class `<rsi>`]([rsi]) on beforehand. Defaults to `TRUE` if any column of `x` is of class `<rsi>`.
#' @param only_rsi_columns a logical to indicate whether only antibiotic columns must be detected that were [transformed to class `<rsi>`]([rsi]) on beforehand (defaults to `FALSE`)
#' @inheritParams first_isolate
#' @details
#' **Note:** This function does not translate MIC values to RSI values. Use [as.rsi()] for that. \cr
@ -167,7 +167,7 @@ eucast_rules <- function(x, @@ -167,7 +167,7 @@ eucast_rules <- function(x,
version_breakpoints = 11.0,
version_expertrules = 3.2,
ampc_cephalosporin_resistance = NA,
only_rsi_columns = any(is.rsi(x)),
only_rsi_columns = FALSE,
...) {
meet_criteria(x, allow_class = "data.frame")
meet_criteria(col_mo, allow_class = "character", has_length = 1, is_in = colnames(x), allow_NULL = TRUE)
@ -282,17 +282,7 @@ eucast_rules <- function(x, @@ -282,17 +282,7 @@ eucast_rules <- function(x,
info = info,
only_rsi_columns = only_rsi_columns,
...)
if (only_rsi_columns == TRUE && !paste0(sys.calls()[1], collapse = "") %like% "only_rsi_columns") {
cols_rsi_eligible <- colnames(x[, is.rsi.eligible(x), drop = FALSE])
if (length(cols_rsi_eligible) > 0) {
message_("These columns might be eligible for EUCAST rules, but are ignored since `only_rsi_columns` is `TRUE`: ",
vector_and(cols_rsi_eligible, quotes = TRUE, sort = FALSE),
as_note = TRUE, add_fn = font_red)
}
}
AMC <- cols_ab["AMC"]
AMK <- cols_ab["AMK"]
AMP <- cols_ab["AMP"]
@ -850,7 +840,7 @@ eucast_rules <- function(x, @@ -850,7 +840,7 @@ eucast_rules <- function(x,
# is new rule within group, print its name
cat(markup_italics_where_needed(word_wrap(rule_current,
width = getOption("width") - 30,
extra_indent = 4)))
extra_indent = 6)))
warned <- FALSE
}
}

74
R/filter_ab_class.R

@ -31,7 +31,7 @@ @@ -31,7 +31,7 @@
#' @param ab_class an antimicrobial class, like `"carbapenems"`. The columns `group`, `atc_group1` and `atc_group2` of the [antibiotics] data set will be searched (case-insensitive) for this value.
#' @param result an antibiotic result: S, I or R (or a combination of more of them)
#' @param scope the scope to check which variables to check, can be `"any"` (default) or `"all"`
#' @param only_rsi_columns a logical to indicate whether only columns must be included that were [transformed to class `<rsi>`]([rsi]) on beforehand. Defaults to `TRUE` if any column of `x` is of class `<rsi>`.
#' @param only_rsi_columns a logical to indicate whether only columns must be included that were [transformed to class `<rsi>`]([rsi]) on beforehand (defaults to `FALSE`)
#' @param ... arguments passed on to [filter_ab_class()]
#' @details All columns of `x` will be searched for known antibiotic names, abbreviations, brand names and codes (ATC, EARS-Net, WHO, etc.). This means that a filter function like e.g. [filter_aminoglycosides()] will include column names like 'gen', 'genta', 'J01GB03', 'tobra', 'Tobracin', etc.
#' @rdname filter_ab_class
@ -82,7 +82,7 @@ filter_ab_class <- function(x, @@ -82,7 +82,7 @@ filter_ab_class <- function(x,
ab_class,
result = NULL,
scope = "any",
only_rsi_columns = any(is.rsi(x)),
only_rsi_columns = FALSE,
...) {
.call_depth <- list(...)$`.call_depth`
if (is.null(.call_depth)) {
@ -92,6 +92,7 @@ filter_ab_class <- function(x, @@ -92,6 +92,7 @@ filter_ab_class <- function(x,
meet_criteria(ab_class, allow_class = "character", has_length = 1, .call_depth = .call_depth)
meet_criteria(result, allow_class = "character", has_length = c(1, 2, 3), allow_NULL = TRUE, .call_depth = .call_depth)
meet_criteria(scope, allow_class = "character", has_length = 1, is_in = c("all", "any"), .call_depth = .call_depth)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1, .call_depth = .call_depth)
check_dataset_integrity()
@ -110,7 +111,7 @@ filter_ab_class <- function(x, @@ -110,7 +111,7 @@ filter_ab_class <- function(x,
stop_ifnot(all(scope %in% c("any", "all")), "`scope` must be one of: 'any', 'all'")
# get all columns in data with names that resemble antibiotics
ab_in_data <- get_column_abx(x, info = FALSE)
ab_in_data <- get_column_abx(x, info = FALSE, only_rsi_columns = only_rsi_columns)
if (length(ab_in_data) == 0) {
message_("No columns with class <rsi> found (see ?as.rsi), data left unchanged.")
return(x.bak)
@ -132,17 +133,14 @@ filter_ab_class <- function(x, @@ -132,17 +133,14 @@ filter_ab_class <- function(x,
# get the columns with a group names in the chosen ab class
agents <- ab_in_data[names(ab_in_data) %in% ab_reference$ab]
if (length(agents) == 0) {
message_("no antimicrobial agents of class ", ab_group,
message_("No antimicrobial agents of class ", ab_group,
" found (such as ", find_ab_names(ab_class, 2),
"), data left unchanged.")
")",
ifelse(only_rsi_columns == TRUE, " with class <rsi>,", ","),
" data left unchanged.")
return(x.bak)
}
if (length(result) == 1) {
operator <- " is "
} else {
operator <- " is one of "
}
if (scope == "any") {
scope_txt <- " or "
scope_fn <- any
@ -154,9 +152,14 @@ filter_ab_class <- function(x, @@ -154,9 +152,14 @@ filter_ab_class <- function(x,
}
}
if (length(agents) > 1) {
scope <- paste(scope, "of columns ")
operator <- " are"
scope <- paste("values in", scope, "of columns ")
} else {
scope <- "column "
operator <- " is"
scope <- "value in column "
}
if (length(result) > 1) {
operator <- paste(operator, "either")
}
# sort columns on official name
@ -166,7 +169,9 @@ filter_ab_class <- function(x, @@ -166,7 +169,9 @@ filter_ab_class <- function(x,
paste(paste0("`", font_bold(agents, collapse = NULL),
"` (", ab_name(names(agents), tolower = TRUE, language = NULL), ")"),
collapse = scope_txt),
operator, toString(result), as_note = FALSE)
operator, " ", vector_or(result, quotes = TRUE),
as_note = FALSE,
extra_indent = 6)
x_transposed <- as.list(as.data.frame(t(x[, agents, drop = FALSE]), stringsAsFactors = FALSE))
filtered <- vapply(FUN.VALUE = logical(1), x_transposed, function(y) scope_fn(y %in% result, na.rm = TRUE))
x <- x[which(filtered), , drop = FALSE]
@ -179,11 +184,13 @@ filter_ab_class <- function(x, @@ -179,11 +184,13 @@ filter_ab_class <- function(x,
filter_aminoglycosides <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "aminoglycoside",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
...)
}
@ -193,11 +200,13 @@ filter_aminoglycosides <- function(x, @@ -193,11 +200,13 @@ filter_aminoglycosides <- function(x,
filter_carbapenems <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "carbapenem",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
...)
}
@ -207,11 +216,13 @@ filter_carbapenems <- function(x, @@ -207,11 +216,13 @@ filter_carbapenems <- function(x,
filter_cephalosporins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "cephalosporin",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
...)
}
@ -221,11 +232,13 @@ filter_cephalosporins <- function(x, @@ -221,11 +232,13 @@ filter_cephalosporins <- function(x,
filter_1st_cephalosporins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "cephalosporins (1st gen.)",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
...)
}
@ -235,11 +248,13 @@ filter_1st_cephalosporins <- function(x, @@ -235,11 +248,13 @@ filter_1st_cephalosporins <- function(x,
filter_2nd_cephalosporins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "cephalosporins (2nd gen.)",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
...)
}
@ -249,11 +264,13 @@ filter_2nd_cephalosporins <- function(x, @@ -249,11 +264,13 @@ filter_2nd_cephalosporins <- function(x,
filter_3rd_cephalosporins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "cephalosporins (3rd gen.)",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
...)
}
@ -263,11 +280,13 @@ filter_3rd_cephalosporins <- function(x, @@ -263,11 +280,13 @@ filter_3rd_cephalosporins <- function(x,
filter_4th_cephalosporins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "cephalosporins (4th gen.)",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
...)
}
@ -277,11 +296,13 @@ filter_4th_cephalosporins <- function(x, @@ -277,11 +296,13 @@ filter_4th_cephalosporins <- function(x,
filter_5th_cephalosporins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "cephalosporins (5th gen.)",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
...)
}
@ -291,11 +312,13 @@ filter_5th_cephalosporins <- function(x, @@ -291,11 +312,13 @@ filter_5th_cephalosporins <- function(x,
filter_fluoroquinolones <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "fluoroquinolone",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
...)
}
@ -305,11 +328,13 @@ filter_fluoroquinolones <- function(x, @@ -305,11 +328,13 @@ filter_fluoroquinolones <- function(x,
filter_glycopeptides <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "glycopeptide",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
...)
}
@ -319,11 +344,29 @@ filter_glycopeptides <- function(x, @@ -319,11 +344,29 @@ filter_glycopeptides <- function(x,
filter_macrolides <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "macrolide",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
...)
}
#' @rdname filter_ab_class
#' @export
filter_oxazolidinones <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "oxazolidinone",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
...)
}
@ -333,11 +376,13 @@ filter_macrolides <- function(x, @@ -333,11 +376,13 @@ filter_macrolides <- function(x,
filter_penicillins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "penicillin",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
...)
}
@ -347,11 +392,13 @@ filter_penicillins <- function(x, @@ -347,11 +392,13 @@ filter_penicillins <- function(x,
filter_tetracyclines <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "tetracycline",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
...)
}
@ -364,6 +411,7 @@ find_ab_group <- function(ab_class) { @@ -364,6 +411,7 @@ find_ab_group <- function(ab_class) {
"fluoroquinolone",
"glycopeptide",
"macrolide",
"oxazolidinone",
"tetracycline"),
paste0(ab_class, "s"),
antibiotics %pm>%

56
R/first_isolate.R

@ -27,7 +27,7 @@ @@ -27,7 +27,7 @@
#'
#' Determine first (weighted) isolates of all microorganisms of every patient per episode and (if needed) per specimen type. To determine patient episodes not necessarily based on microorganisms, use [is_new_episode()] that also supports grouping with the `dplyr` package.
#' @inheritSection lifecycle Stable Lifecycle
#' @param x a [data.frame] containing isolates. Can be left blank for automatic determination.
#' @param x a [data.frame] containing isolates. Can be left blank for automatic determination, see *Examples*.
#' @param col_date column name of the result date (or date that is was received on the lab), defaults to the first column with a date class
#' @param col_patient_id column name of the unique IDs of the patients, defaults to the first column that starts with 'patient' or 'patid' (case insensitive)
#' @param col_mo column name of the IDs of the microorganisms (see [as.mo()]), defaults to the first column of class [`mo`]. Values will be coerced using [as.mo()].
@ -86,7 +86,7 @@ @@ -86,7 +86,7 @@
#'
#' 2. Using `type = "points"` and argument `points_threshold`
#'
#' A difference from I to S|R (or vice versa) means 0.5 points, a difference from S to R (or vice versa) means 1 point. When the sum of points exceeds `points_threshold`, which default to `2`, an isolate will be (re)selected as a first weighted isolate.
#' A difference from I to S|R (or vice versa) means 0.5 points, a difference from S to R (or vice versa) means 1 point. When the sum of points exceeds `points_threshold`, which defaults to `2`, an isolate will be (re)selected as a first weighted isolate.
#' @rdname first_isolate
#' @seealso [key_antibiotics()]
#' @export
@ -99,10 +99,12 @@ @@ -99,10 +99,12 @@
#' # `example_isolates` is a data set available in the AMR package.
#' # See ?example_isolates.
#'
#' # basic filtering on first isolates
#' example_isolates[first_isolate(), ]
#' example_isolates[first_isolate(example_isolates), ]
#'
#' \donttest{
#' # faster way, only works in R 3.2 and later:
#' example_isolates[first_isolate(), ]
#'
#' # get all first Gram-negatives
#' example_isolates[which(first_isolate() & mo_is_gram_negative()), ]
#'
@ -140,7 +142,7 @@ @@ -140,7 +142,7 @@
#' # when you (erroneously) would have used all isolates for analysis.
#' }
#' }
first_isolate <- function(x,
first_isolate <- function(x = NULL,
col_date = NULL,
col_patient_id = NULL,
col_mo = NULL,
@ -158,10 +160,7 @@ first_isolate <- function(x, @@ -158,10 +160,7 @@ first_isolate <- function(x,
info = interactive(),
include_unknown = FALSE,
...) {
if (missing(x)) {
x <- get_current_data(arg_name = "x", call = -2)
}
meet_criteria(x, allow_class = "data.frame") # also checks dimensions to be >0
meet_criteria(x, allow_class = "data.frame", allow_NULL = TRUE) # also checks dimensions to be >0
meet_criteria(col_date, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
meet_criteria(col_patient_id, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
meet_criteria(col_mo, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
@ -185,6 +184,14 @@ first_isolate <- function(x, @@ -185,6 +184,14 @@ first_isolate <- function(x,
meet_criteria(info, allow_class = "logical", has_length = 1)
meet_criteria(include_unknown, allow_class = "logical", has_length = 1)
if (is_null_or_grouped_tbl(x)) {
# when `x` is left blank, auto determine it (get_current_data() also contains dplyr::cur_data_all())
# is also fix for using a grouped df as input (a dot as first argument)
x <- get_current_data(arg_name = "x", call = -2)
}
# remove data.table, grouping from tibbles, etc.
x <- as.data.frame(x, stringsAsFactors = FALSE)
dots <- unlist(list(...))
if (length(dots) != 0) {
# backwards compatibility with old arguments
@ -197,18 +204,7 @@ first_isolate <- function(x, @@ -197,18 +204,7 @@ first_isolate <- function(x,
}
}
# fix for using a grouped df as input (a dot as first argument)
# such as example_isolates %>% group_by(hospital_id) %>% mutate(first_isolate = first_isolate(.))
if (inherits(x, "grouped_df")) {
# get_current_data() contains dplyr::cur_data_all()
x <- tryCatch(get_current_data(arg_name = "x", 0),
error = function(e) x)
}
# remove data.table, grouping from tibbles, etc.
x <- as.data.frame(x, stringsAsFactors = FALSE)
# try to find columns based on type
# try to find columns based on type
# -- mo
if (is.null(col_mo)) {
col_mo <- search_type_in_df(x = x, type = "mo")
@ -510,15 +506,20 @@ first_isolate <- function(x, @@ -510,15 +506,20 @@ first_isolate <- function(x,
#' @rdname first_isolate
#' @export
filter_first_isolate <- function(x,
filter_first_isolate <- function(x = NULL,
col_date = NULL,
col_patient_id = NULL,
col_mo = NULL,
...) {
meet_criteria(x, allow_class = "data.frame")
meet_criteria(x, allow_class = "data.frame", allow_NULL = TRUE)
meet_criteria(col_date, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
meet_criteria(col_patient_id, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
meet_criteria(col_mo, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
if (is_null_or_grouped_tbl(x)) {
# when `x` is left blank, auto determine it (get_current_data() also contains dplyr::cur_data_all())
# is also fix for using a grouped df as input (a dot as first argument)
x <- get_current_data(arg_name = "x", call = -2)
}
subset(x, first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
@ -528,17 +529,22 @@ filter_first_isolate <- function(x, @@ -528,17 +529,22 @@ filter_first_isolate <- function(x,
#' @rdname first_isolate
#' @export
filter_first_weighted_isolate <- function(x,
filter_first_weighted_isolate <- function(x = NULL,
col_date = NULL,
col_patient_id = NULL,
col_mo = NULL,
col_keyantibiotics = NULL,
...) {
meet_criteria(x, allow_class = "data.frame")
meet_criteria(x, allow_class = "data.frame", allow_NULL = TRUE)
meet_criteria(col_date, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
meet_criteria(col_patient_id, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
meet_criteria(col_mo, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
meet_criteria(col_keyantibiotics, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
if (is_null_or_grouped_tbl(x)) {
# when `x` is left blank, auto determine it (get_current_data() also contains dplyr::cur_data_all())
# is also fix for using a grouped df as input (a dot as first argument)
x <- get_current_data(arg_name = "x", call = -2)
}
y <- x
if (is.null(col_keyantibiotics)) {
# first try to look for it

4
R/guess_ab_col.R

@ -30,7 +30,7 @@ @@ -30,7 +30,7 @@
#' @param x a [data.frame]
#' @param search_string a text to search `x` for, will be checked with [as.ab()] if this value is not a column in `x`
#' @param verbose a logical to indicate whether additional info should be printed
#' @param only_rsi_columns a logical to indicate whether only antibiotic columns must be detected that were [transformed to class `<rsi>`]([rsi]) on beforehand. Defaults to `TRUE` if any column of `x` is of class `<rsi>`.
#' @param only_rsi_columns a logical to indicate whether only antibiotic columns must be detected that were [transformed to class `<rsi>`]([rsi]) on beforehand (defaults to `FALSE`)
#' @details You can look for an antibiotic (trade) name or abbreviation and it will search `x` and the [antibiotics] data set for any column containing a name or code of that antibiotic. **Longer columns names take precedence over shorter column names.**
#' @return A column name of `x`, or `NULL` when no result is found.
#' @export
@ -63,7 +63,7 @@ @@ -63,7 +63,7 @@
#' AMP_ED20 = "S")
#' guess_ab_col(df, "ampicillin")
#' # [1] "AMP_ED20"
guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE, only_rsi_columns = any(is.rsi(x))) {
guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE, only_rsi_columns = FALSE) {
meet_criteria(x, allow_class = "data.frame", allow_NULL = TRUE)
meet_criteria(search_string, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(verbose, allow_class = "logical", has_length = 1)

16
R/key_antibiotics.R

@ -108,7 +108,7 @@ @@ -108,7 +108,7 @@
#' sum(my_patients$first_weighted, na.rm = TRUE)
#' }
#' }
key_antibiotics <- function(x,
key_antibiotics <- function(x = NULL,
col_mo = NULL,
universal_1 = guess_ab_col(x, "amoxicillin"),
universal_2 = guess_ab_col(x, "amoxicillin/clavulanic acid"),
@ -130,10 +130,7 @@ key_antibiotics <- function(x, @@ -130,10 +130,7 @@ key_antibiotics <- function(x,
GramNeg_6 = guess_ab_col(x, "meropenem"),
warnings = TRUE,
...) {
if (missing(x)) {
x <- get_current_data(arg_name = "x", call = -2)
}
meet_criteria(x, allow_class = "data.frame")
meet_criteria(x, allow_class = "data.frame", allow_NULL = TRUE)
meet_criteria(col_mo, allow_class = "character", has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(universal_1, allow_class = "character", has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(universal_2, allow_class = "character", has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
@ -155,6 +152,14 @@ key_antibiotics <- function(x, @@ -155,6 +152,14 @@ key_antibiotics <- function(x,
meet_criteria(GramNeg_6, allow_class = "character", has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(warnings, allow_class = "logical", has_length = 1)
if (is_null_or_grouped_tbl(x)) {
# when `x` is left blank, auto determine it (get_current_data() also contains dplyr::cur_data_all())
# is also fix for using a grouped df as input (a dot as first argument)
x <- get_current_data(arg_name = "x", call = -2)
}
# force regular data.frame, not a tibble or data.table
x <- as.data.frame(x, stringsAsFactors = FALSE)
dots <- unlist(list(...))
if (length(dots) != 0) {
# backwards compatibility with old arguments
@ -249,7 +254,6 @@ key_antibiotics <- function(x, @@ -249,7 +254,6 @@ key_antibiotics <- function(x,
remember_thrown_message("key_antibiotics.gramneg")
}
x <- as.data.frame(x, stringsAsFactors = FALSE)
x[, col_mo] <- as.mo(x[, col_mo, drop = TRUE])
x$gramstain <- mo_gramstain(x[, col_mo, drop = TRUE], language = NULL)
x$key_ab <- NA_character_

174
R/mdro.R

@ -146,19 +146,16 @@ @@ -146,19 +146,16 @@
#' MRGN = mrgn())
#' }
#' }
mdro <- function(x,
mdro <- function(x = NULL,
guideline = "CMI2012",
col_mo = NULL,
info = interactive(),
pct_required_classes = 0.5,
combine_SI = TRUE,
verbose = FALSE,
only_rsi_columns = any(is.rsi(x)),
only_rsi_columns = FALSE,
...) {
if (missing(x)) {
x <- get_current_data(arg_name = "x", call = -2)
}
meet_criteria(x, allow_class = "data.frame")
meet_criteria(x, allow_class = "data.frame", allow_NULL = TRUE)
meet_criteria(guideline, allow_class = c("list", "character"), allow_NULL = TRUE)
if (!is.list(guideline)) {
meet_criteria(guideline, allow_class = "character", has_length = 1, allow_NULL = TRUE)
@ -168,9 +165,18 @@ mdro <- function(x, @@ -168,9 +165,18 @@ mdro <- function(x,
meet_criteria(pct_required_classes, allow_class = "numeric", has_length = 1)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
meet_criteria(verbose, allow_class = "logical", has_length = 1)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
check_dataset_integrity()
info.bak <- info
if (message_not_thrown_before("mdro")) {
remember_thrown_message("mdro")
} else {
# don't thrown info's more than once per call
info <- FALSE
}
if (interactive() & verbose == TRUE & info == TRUE) {
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.:",
@ -187,10 +193,37 @@ mdro <- function(x, @@ -187,10 +193,37 @@ mdro <- function(x,
}
}
group_msg <- ""
if (info.bak == TRUE) {
# print group name if used in dplyr::group_by()
cur_group <- import_fn("cur_group", "dplyr", error_on_fail = FALSE)
if (!is.null(cur_group)) {
group_df <- tryCatch(cur_group(), error = function(e) data.frame())
if (NCOL(group_df) > 0) {
# transform factors to characters
group <- vapply(FUN.VALUE = character(1), group_df, function(x) {
if (is.numeric(x)) {
format(x)
} else if (is.logical(x)) {
as.character(x)
} else {
paste0('"', x, '"')
}
})
group_msg <- paste0("\nGroup: ", paste0(names(group), " = ", group, collapse = ", "), "\n")
}
}
}
if (is_null_or_grouped_tbl(x)) {
# when `x` is left blank, auto determine it (get_current_data() also contains dplyr::cur_data_all())
# is also fix for using a grouped df as input (a dot as first argument)
x <- get_current_data(arg_name = "x", call = -2)
}
# force regular data.frame, not a tibble or data.table
x <- as.data.frame(x, stringsAsFactors = FALSE)
stop_ifnot(is.numeric(pct_required_classes), "`pct_required_classes` must be numeric")
if (pct_required_classes > 1) {
# allow pct_required_classes = 75 -> pct_required_classes = 0.75
pct_required_classes <- pct_required_classes / 100
@ -215,7 +248,8 @@ mdro <- function(x, @@ -215,7 +248,8 @@ mdro <- function(x,
cat(txt, "\n", sep = "")
}
x <- run_custom_mdro_guideline(x, guideline)
if (info == TRUE) {
if (info.bak == TRUE) {
cat(group_msg)
if (sum(!is.na(x$MDRO)) == 0) {
cat(word_wrap(font_bold(paste0("=> Found 0 MDROs since no isolates are covered by the custom guideline"))))
} else {
@ -496,16 +530,7 @@ mdro <- function(x, @@ -496,16 +530,7 @@ mdro <- function(x,
only_rsi_columns = only_rsi_columns,
...)
}
if (only_rsi_columns == TRUE) {
cols_rsi_eligible <- colnames(x[, is.rsi.eligible(x), drop = FALSE])
if (length(cols_rsi_eligible) > 0) {
message_("These columns might be eligible for determining ", guideline$type, ", but are ignored since `only_rsi_columns` is `TRUE`: ",
vector_and(cols_rsi_eligible, quotes = TRUE, sort = FALSE),
as_note = TRUE, add_fn = font_red)
}
}
# nolint start
AMC <- cols_ab["AMC"]
AMK <- cols_ab["AMK"]
@ -1341,7 +1366,8 @@ mdro <- function(x, @@ -1341,7 +1366,8 @@ mdro <- function(x,
x$reason <- "PDR/MDR/XDR criteria were met"
}
if (info == TRUE) {
if (info.bak == TRUE) {
cat(group_msg)
if (sum(!is.na(x$MDRO)) == 0) {
cat(font_bold(paste0("=> Found 0 MDROs since no isolates are covered by the guideline")))
} else {
@ -1362,8 +1388,11 @@ mdro <- function(x, @@ -1362,8 +1388,11 @@ mdro <- function(x,
# Results ----
if (guideline$code == "cmi2012") {
if (any(x$MDRO == -1, na.rm = TRUE)) {
warning_("NA introduced for isolates where the available percentage of antimicrobial classes was below ",
percentage(pct_required_classes), " (set with `pct_required_classes`)", call = FALSE)
if (message_not_thrown_before("mdro.availability")) {
warning_("NA introduced for isolates where the available percentage of antimicrobial classes was below ",
percentage(pct_required_classes), " (set with `pct_required_classes`)", call = FALSE)
remember_thrown_message("mdro.availability")
}
# set these -1s to NA
x[which(x$MDRO == -1), "MDRO"] <- NA_integer_
}
@ -1423,12 +1452,12 @@ custom_mdro_guideline <- function(..., as_factor = TRUE) { @@ -1423,12 +1452,12 @@ custom_mdro_guideline <- function(..., as_factor = TRUE) {
qry <- as.expression(qry)
}
qry <- as.character(qry)
# these will prevent vectorisaton, so replace them:
# these will prevent vectorisation, so replace them:
qry <- gsub("&&", "&", qry, fixed = TRUE)
qry <- gsub("||", "|", qry, fixed = TRUE)
# support filter()-like writing: custom_mdro_guideline('CIP == "R", AMX == "S"' ~ "result 1")
qry <- gsub(" *, *", " & ", qry)
# format nicely
# format nicely, setting spaces around operators
qry <- gsub(" *([&|+-/*^><==]+) *", " \\1 ", qry)
qry <- gsub("'", "\"", qry, fixed = TRUE)
out[[i]]$query <- as.expression(qry)
@ -1454,21 +1483,23 @@ print.custom_mdro_guideline <- function(x, ...) { @@ -1454,21 +1483,23 @@ print.custom_mdro_guideline <- function(x, ...) {
cat("A set of custom MDRO rules:\n")
for (i in seq_len(length(x))) {
rule <- x[[i]]
rule$query <- gsub(" & ", " and ", rule$query, fixed = TRUE)
rule$query <- gsub(" | ", " or ", rule$query, fixed = TRUE)
rule$query <- gsub(" + ", " plus ", rule$query, fixed = TRUE)
rule$query <- gsub(" - ", " minus ", rule$query, fixed = TRUE)
rule$query <- gsub(" / ", " divided by ", rule$query, fixed = TRUE)
rule$query <- gsub(" * ", " times ", rule$query, fixed = TRUE)
rule$query <- gsub(" == ", " is ", rule$query, fixed = TRUE)
rule$query <- gsub(" > ", " is higher than ", rule$query, fixed = TRUE)
rule$query <- gsub(" < ", " is lower than ", rule$query, fixed = TRUE)
rule$query <- gsub(" >= ", " is higher than or equal to ", rule$query, fixed = TRUE)
rule$query <- gsub(" <= ", " is lower than or equal to ", rule$query, fixed = TRUE)
rule$query <- gsub(" ^ ", " to the power of ", rule$query, fixed = TRUE)
cat(" ", i, ". ", font_blue(as.character(rule$query)), " -> ", font_red(rule$value), "\n", sep = "")
rule$query <- gsub(" & ", font_black(font_italic(" and ")), rule$query, fixed = TRUE)
rule$query <- gsub(" | ", font_black(" or "), rule$query, fixed = TRUE)
rule$query <- gsub(" + ", font_black(" plus "), rule$query, fixed = TRUE)
rule$query <- gsub(" - ", font_black(" minus "), rule$query, fixed = TRUE)
rule$query <- gsub(" / ", font_black(" divided by "), rule$query, fixed = TRUE)
rule$query <- gsub(" * ", font_black(" times "), rule$query, fixed = TRUE)
rule$query <- gsub(" == ", font_black(" is "), rule$query, fixed = TRUE)
rule$query <- gsub(" > ", font_black(" is higher than "), rule$query, fixed = TRUE)
rule$query <- gsub(" < ", font_black(" is lower than "), rule$query, fixed = TRUE)
rule$query <- gsub(" >= ", font_black(" is higher than or equal to "), rule$query, fixed = TRUE)
rule$query <- gsub(" <= ", font_black(" is lower than or equal to "), rule$query, fixed = TRUE)
rule$query <- gsub(" ^ ", font_black(" to the power of "), rule$query, fixed = TRUE)
# replace the black colour 'stops' with blue colour 'starts'
rule$query <- gsub("\033[39m", "\033[34m", as.character(rule$query), fixed = TRUE)
cat(" ", i, ". ", font_blue(rule$query), font_bold(" -> "), font_red(rule$value), "\n", sep = "")
}
cat(" ", i + 1, ". Otherwise -> ", font_red(paste0("Negative")), "\n", sep = "")
cat(" ", i + 1, ". Otherwise", font_bold(" -> "), font_red(paste0("Negative")), "\n", sep = "")
cat("\nUnmatched rows will return ", font_red("NA"), ".\n", sep = "")
if (isTRUE(attributes(x)$as_factor)) {
cat("Results will be of class <factor>, with ordered levels: ", paste0(attributes(x)$values, collapse = " < "), "\n", sep = "")
@ -1489,7 +1520,9 @@ run_custom_mdro_guideline <- function(df, guideline) { @@ -1489,7 +1520,9 @@ run_custom_mdro_guideline <- function(df, guideline) {
return("error")
})
if (identical(qry, "error")) {
warning_("in custom_mdro_guideline(): rule ", i, " (`", guideline[[i]]$query, "`) was ignored because of this error message: ", pkg_env$err_msg,
warning_("in custom_mdro_guideline(): rule ", i,
" (`", guideline[[i]]$query, "`) was ignored because of this error message: ",
pkg_env$err_msg,
call = FALSE,
add_fn = font_red)
next
@ -1524,55 +1557,50 @@ run_custom_mdro_guideline <- function(df, guideline) { @@ -1524,55 +1557,50 @@ run_custom_mdro_guideline <- function(df, guideline) {
#' @rdname mdro
#' @export
brmo <- function(x, guideline = "BRMO", only_rsi_columns = any(is.rsi(x)), ...) {
if (missing(x)) {
x <- get_current_data(arg_name = "x", call = -2)
}
meet_criteria(x, allow_class = "data.frame")
meet_criteria(guideline, allow_class = "character", has_length = 1)
mdro(x, guideline = "BRMO", only_rsi_columns = only_rsi_columns, ...)
brmo <- function(x = NULL, only_rsi_columns = FALSE, ...) {
meet_criteria(x, allow_class = "data.frame", allow_NULL = TRUE)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
stop_if("guideline" %in% names(list(...)),
"argument `guideline` must not be set since this is a guideline-specific function")
mdro(x = x, only_rsi_columns = only_rsi_columns, guideline = "BRMO", ...)
}
#' @rdname mdro
#' @export
mrgn <- function(x, guideline = "MRGN", only_rsi_columns = any(is.rsi(x)), ...) {
if (missing(x)) {
x <- get_current_data(arg_name = "x", call = -2)
}
meet_criteria(x, allow_class = "data.frame")
meet_criteria(guideline, allow_class = "character", has_length = 1)
mdro(x = x, guideline = "MRGN", only_rsi_columns = only_rsi_columns, ...)
mrgn <- function(x = NULL, only_rsi_columns = FALSE, ...) {
meet_criteria(x, allow_class = "data.frame", allow_NULL = TRUE)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
stop_if("guideline" %in% names(list(...)),
"argument `guideline` must not be set since this is a guideline-specific function")
mdro(x = x, only_rsi_columns = only_rsi_columns, guideline = "MRGN", ...)
}
#' @rdname mdro
#' @export
mdr_tb <- function(x, guideline = "TB", only_rsi_columns = any(is.rsi(x)), ...) {
if (missing(x)) {
x <- get_current_data(arg_name = "x", call = -2)
}
meet_criteria(x, allow_class = "data.frame")
meet_criteria(guideline, allow_class = "character", has_length = 1)
mdro(x = x, guideline = "TB", only_rsi_columns = only_rsi_columns, ...)
mdr_tb <- function(x = NULL, only_rsi_columns = FALSE, ...) {
meet_criteria(x, allow_class = "data.frame", allow_NULL = TRUE)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
stop_if("guideline" %in% names(list(...)),
"argument `guideline` must not be set since this is a guideline-specific function")
mdro(x = x, only_rsi_columns = only_rsi_columns, guideline = "TB", ...)
}
#' @rdname mdro
#' @export
mdr_cmi2012 <- function(x, guideline = "CMI2012", only_rsi_columns = any(is.rsi(x)), ...) {
if (missing(x)) {
x <- get_current_data(arg_name = "x", call = -2)
}
meet_criteria(x, allow_class = "data.frame")
meet_criteria(guideline, allow_class = "character", has_length = 1)
mdro(x = x, guideline = "CMI2012", only_rsi_columns = only_rsi_columns, ...)
mdr_cmi2012 <- function(x = NULL, only_rsi_columns = FALSE, ...) {
meet_criteria(x, allow_class = "data.frame", allow_NULL = TRUE)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
stop_if("guideline" %in% names(list(...)),
"argument `guideline` must not be set since this is a guideline-specific function")
mdro(x = x, only_rsi_columns = only_rsi_columns, guideline = "CMI2012", ...)
}
#' @rdname mdro
#' @export
eucast_exceptional_phenotypes <- function(x, guideline = "EUCAST", only_rsi_columns = any(is.rsi(x)), ...) {
if (missing(x)) {
x <- get_current_data(arg_name = "x", call = -2)
}
meet_criteria(x, allow_class = "data.frame")
meet_criteria(guideline, allow_class = "character", has_length = 1)
mdro(x = x, guideline = "EUCAST", only_rsi_columns = only_rsi_columns, ...)
eucast_exceptional_phenotypes <- function(x = NULL, only_rsi_columns = FALSE, ...) {
meet_criteria(x, allow_class = "data.frame", allow_NULL = TRUE)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
stop_if("guideline" %in% names(list(...)),
"argument `guideline` must not be set since this is a guideline-specific function")
mdro(x = x, only_rsi_columns = only_rsi_columns, guideline = "EUCAST", ...)
}

9
R/mo_property.R

@ -44,11 +44,11 @@ @@ -44,11 +44,11 @@
#'
#' The Gram stain - [mo_gramstain()] - will be determined based on the taxonomic kingdom and phylum. According to Cavalier-Smith (2002, [PMID 11837318](https://pubmed.ncbi.nlm.nih.gov/11837318)), who defined subkingdoms Negibacteria and Posibacteria, only these phyla are Posibacteria: Actinobacteria, Chloroflexi, Firmicutes and Tenericutes. These bacteria are considered Gram-positive - all other bacteria are considered Gram-negative. Species outside the kingdom of Bacteria will return a value `NA`. Functions [mo_is_gram_negative()] and [mo_is_gram_positive()] always return `TRUE` or `FALSE` (except when the input is `NA` or the MO code is `UNKNOWN`), thus always return `FALSE` for species outside the taxonomic kingdom of Bacteria.
#'
#' Determination of yeasts - [mo_is_yeast()] - will be based on the taxonomic phylum, class and order. Budding yeasts are true fungi of the phylum Ascomycetes, class Saccharomycetes (also called Hemiascomycetes). The true yeasts are separated into one main order Saccharomycetales. For all microorganisms that are in one of those two groups, the function will return `TRUE`. It returns `FALSE` for all other taxonomic entries.
#' Determination of yeasts - [mo_is_yeast()] - will be based on the taxonomic kingdom and class. *Budding yeasts* are fungi of the phylum Ascomycetes, class Saccharomycetes (also called Hemiascomycetes). *True yeasts* are aggregated into the underlying order Saccharomycetales. Thus, for all microorganisms that are fungi and member of the taxonomic class Saccharomycetes, the function will return `TRUE`. It returns `FALSE` otherwise (except when the input is `NA` or the MO code is `UNKNOWN`).
#'
#' Intrinsic resistance - [mo_is_intrinsic_resistant()] - will be determined based on the [intrinsic_resistant] data set, which is based on `r format_eucast_version_nr(3.2)`. The [mo_is_intrinsic_resistant()] can be vectorised over arguments `x` (input for microorganisms) and over `ab` (input for antibiotics).
#' Intrinsic resistance - [mo_is_intrinsic_resistant()] - will be determined based on the [intrinsic_resistant] data set, which is based on `r format_eucast_version_nr(3.2)`. The [mo_is_intrinsic_resistant()] functions can be vectorised over arguments `x` (input for microorganisms) and over `ab` (input for antibiotics).
#'
#' All output will be [translate]d where possible.
#' All output [will be translated][translate] where possible.
#'
#' The function [mo_url()] will return the direct URL to the online database entry, which also shows the scientific reference of the concerned species.
#' @inheritSection mo_matching_score Matching Score for Microorganisms
@ -438,8 +438,7 @@ mo_is_yeast <- function(x, language = get_locale(), ...) { @@ -438,8 +438,7 @@ mo_is_yeast <- function(x, language = get_locale(), ...) {
load_mo_failures_uncertainties_renamed(metadata)
out <- rep(FALSE, length(x))
out[x.kingdom == "Fungi" &
((x.phylum == "Ascomycetes" & x.class == "Saccharomycetes") | x.order == "Saccharomycetales")] <- TRUE
out[x.kingdom == "Fungi" & x.class == "Saccharomycetes"] <- TRUE
out[x.mo %in% c(NA_character_, "UNKNOWN")] <- NA
out
}

3
R/rsi.R

@ -204,6 +204,7 @@ is.rsi.eligible <- function(x, threshold = 0.05) { @@ -204,6 +204,7 @@ is.rsi.eligible <- function(x, threshold = 0.05) {
meet_criteria(threshold, allow_class = "numeric", has_length = 1)
if (inherits(x, "data.frame")) {