mirror of
https://github.com/msberends/AMR.git
synced 2026-08-05 20:56:58 +02:00
(v2.1.1.9163) cleanup
This commit is contained in:
8
.github/workflows/lintr.yaml
vendored
8
.github/workflows/lintr.yaml
vendored
@@ -56,9 +56,15 @@ jobs:
|
|||||||
extra-packages: |
|
extra-packages: |
|
||||||
any::lintr
|
any::lintr
|
||||||
any::cyclocomp
|
any::cyclocomp
|
||||||
|
any::roxygen2
|
||||||
|
any::devtools
|
||||||
|
any::usethis
|
||||||
|
|
||||||
- name: Lint
|
- name: Lint
|
||||||
run: |
|
run: |
|
||||||
|
# no not check these folders
|
||||||
|
rm -rf data-raw
|
||||||
|
rm -rf tests
|
||||||
# old: lintr::lint_package(linters = lintr::with_defaults(line_length_linter = NULL, trailing_whitespace_linter = NULL, object_name_linter = NULL, cyclocomp_linter = NULL, object_length_linter = lintr::object_length_linter(length = 50L)), exclusions = list("R/aa_helper_pm_functions.R"))
|
# old: lintr::lint_package(linters = lintr::with_defaults(line_length_linter = NULL, trailing_whitespace_linter = NULL, object_name_linter = NULL, cyclocomp_linter = NULL, object_length_linter = lintr::object_length_linter(length = 50L)), exclusions = list("R/aa_helper_pm_functions.R"))
|
||||||
# now get ALL linters, not just default ones
|
# now get ALL linters, not just default ones
|
||||||
linters <- getNamespaceExports(asNamespace("lintr"))
|
linters <- getNamespaceExports(asNamespace("lintr"))
|
||||||
@@ -67,7 +73,7 @@ jobs:
|
|||||||
linters <- linters[!grepl("^(closed_curly|open_curly|paren_brace|semicolon_terminator|consecutive_stopifnot|no_tab|single_quotes|unnecessary_nested_if|unneeded_concatenation)_linter$", linters)]
|
linters <- linters[!grepl("^(closed_curly|open_curly|paren_brace|semicolon_terminator|consecutive_stopifnot|no_tab|single_quotes|unnecessary_nested_if|unneeded_concatenation)_linter$", linters)]
|
||||||
linters <- linters[linters != "linter"]
|
linters <- linters[linters != "linter"]
|
||||||
# and the ones we find unnnecessary
|
# and the ones we find unnnecessary
|
||||||
linters <- linters[!grepl("^(extraction_operator|implicit_integer|line_length|object_name|nonportable_path|is)_linter$", linters)]
|
linters <- linters[!grepl("^(extraction_operator|implicit_integer|line_length|object_length|object_name|object_usage|nonportable_path|is)_linter$", linters)]
|
||||||
# put the functions in a list
|
# put the functions in a list
|
||||||
linters_list <- lapply(linters, function(l) eval(parse(text = paste0("lintr::", l, "()")), envir = asNamespace("lintr")))
|
linters_list <- lapply(linters, function(l) eval(parse(text = paste0("lintr::", l, "()")), envir = asNamespace("lintr")))
|
||||||
names(linters_list) <- linters
|
names(linters_list) <- linters
|
||||||
|
|||||||
@@ -1,6 +1,6 @@
|
|||||||
Package: AMR
|
Package: AMR
|
||||||
Version: 2.1.1.9160
|
Version: 2.1.1.9163
|
||||||
Date: 2025-02-26
|
Date: 2025-02-27
|
||||||
Title: Antimicrobial Resistance Data Analysis
|
Title: Antimicrobial Resistance Data Analysis
|
||||||
Description: Functions to simplify and standardise antimicrobial resistance (AMR)
|
Description: Functions to simplify and standardise antimicrobial resistance (AMR)
|
||||||
data analysis and to work with microbial and antimicrobial properties by
|
data analysis and to work with microbial and antimicrobial properties by
|
||||||
|
|||||||
6
NEWS.md
6
NEWS.md
@@ -1,4 +1,4 @@
|
|||||||
# AMR 2.1.1.9160
|
# AMR 2.1.1.9163
|
||||||
|
|
||||||
*(this beta version will eventually become v3.0. We're happy to reach a new major milestone soon, which will be all about the new One Health support! Install this beta using [the instructions here](https://msberends.github.io/AMR/#latest-development-version).)*
|
*(this beta version will eventually become v3.0. We're happy to reach a new major milestone soon, which will be all about the new One Health support! Install this beta using [the instructions here](https://msberends.github.io/AMR/#latest-development-version).)*
|
||||||
|
|
||||||
@@ -62,6 +62,7 @@ This package now supports not only tools for AMR data analysis in clinical setti
|
|||||||
* Added Amorolfine (`AMO`, D01AE16), which is now also part of the `antifungals()` selector
|
* Added Amorolfine (`AMO`, D01AE16), which is now also part of the `antifungals()` selector
|
||||||
* Added Efflux (`EFF`), to allow mapping to AMRFinderPlus
|
* Added Efflux (`EFF`), to allow mapping to AMRFinderPlus
|
||||||
* Added Tigemonam (`TNM`), a monobactam
|
* Added Tigemonam (`TNM`), a monobactam
|
||||||
|
* Added over 1,500 trade names
|
||||||
* MICs
|
* MICs
|
||||||
* Added as valid levels: 4096, 6 powers of 0.0625, and 5 powers of 192 (192, 384, 576, 768, 960)
|
* Added as valid levels: 4096, 6 powers of 0.0625, and 5 powers of 192 (192, 384, 576, 768, 960)
|
||||||
* Fixed a bug in `as.mic()` that failed translation of scientifically formatted numbers
|
* Fixed a bug in `as.mic()` that failed translation of scientifically formatted numbers
|
||||||
@@ -76,12 +77,11 @@ This package now supports not only tools for AMR data analysis in clinical setti
|
|||||||
* `mo_info()` now contains an extra element `rank` and `group_members` (with the contents of the new `mo_group_members()` function)
|
* `mo_info()` now contains an extra element `rank` and `group_members` (with the contents of the new `mo_group_members()` function)
|
||||||
* Updated all ATC codes from WHOCC
|
* Updated all ATC codes from WHOCC
|
||||||
* Updated all antibiotic DDDs from WHOCC
|
* Updated all antibiotic DDDs from WHOCC
|
||||||
* Added over 1,500 trade names for antibiotics
|
|
||||||
* Fix for using a manual value for `mo_transform` in `antibiogram()`
|
* Fix for using a manual value for `mo_transform` in `antibiogram()`
|
||||||
* Fixed a bug for when `antibiogram()` returns an empty data set
|
* Fixed a bug for when `antibiogram()` returns an empty data set
|
||||||
* Fix for mapping 'high level' antibiotics in `as.ab()` (amphotericin B-high, gentamicin-high, kanamycin-high, streptomycin-high, tobramycin-high)
|
* Fix for mapping 'high level' antibiotics in `as.ab()` (amphotericin B-high, gentamicin-high, kanamycin-high, streptomycin-high, tobramycin-high)
|
||||||
* Improved overall algorithm of `as.ab()` for better performance and accuracy, including the new function `as_reset_session()` to remove earlier coercions.
|
* Improved overall algorithm of `as.ab()` for better performance and accuracy, including the new function `as_reset_session()` to remove earlier coercions.
|
||||||
* Improved overall algorithm of `as.mo()` for better performance and accuracy. Specifically:
|
* Improved overall algorithm of `as.mo()` for better performance and accuracy, specifically:
|
||||||
* More weight is given to genus and species combinations in cases where the subspecies is miswritten, so that the result will be the correct genus and species
|
* More weight is given to genus and species combinations in cases where the subspecies is miswritten, so that the result will be the correct genus and species
|
||||||
* Genera from the World Health Organization's (WHO) Priority Pathogen List now have the highest prevalence
|
* Genera from the World Health Organization's (WHO) Priority Pathogen List now have the highest prevalence
|
||||||
* Fixed a bug for `sir_confidence_interval()` when there are no isolates available
|
* Fixed a bug for `sir_confidence_interval()` when there are no isolates available
|
||||||
|
|||||||
@@ -1,6 +1,6 @@
|
|||||||
Metadata-Version: 2.2
|
Metadata-Version: 2.2
|
||||||
Name: AMR
|
Name: AMR
|
||||||
Version: 2.1.1.9160
|
Version: 2.1.1.9163
|
||||||
Summary: A Python wrapper for the AMR R package
|
Summary: A Python wrapper for the AMR R package
|
||||||
Home-page: https://github.com/msberends/AMR
|
Home-page: https://github.com/msberends/AMR
|
||||||
Author: Matthijs Berends
|
Author: Matthijs Berends
|
||||||
|
|||||||
@@ -28,8 +28,6 @@ from .functions import age_groups
|
|||||||
from .functions import antibiogram
|
from .functions import antibiogram
|
||||||
from .functions import wisca
|
from .functions import wisca
|
||||||
from .functions import retrieve_wisca_parameters
|
from .functions import retrieve_wisca_parameters
|
||||||
from .functions import amr_class
|
|
||||||
from .functions import amr_selector
|
|
||||||
from .functions import aminoglycosides
|
from .functions import aminoglycosides
|
||||||
from .functions import aminopenicillins
|
from .functions import aminopenicillins
|
||||||
from .functions import antifungals
|
from .functions import antifungals
|
||||||
@@ -61,6 +59,8 @@ from .functions import streptogramins
|
|||||||
from .functions import tetracyclines
|
from .functions import tetracyclines
|
||||||
from .functions import trimethoprims
|
from .functions import trimethoprims
|
||||||
from .functions import ureidopenicillins
|
from .functions import ureidopenicillins
|
||||||
|
from .functions import amr_class
|
||||||
|
from .functions import amr_selector
|
||||||
from .functions import administrable_per_os
|
from .functions import administrable_per_os
|
||||||
from .functions import administrable_iv
|
from .functions import administrable_iv
|
||||||
from .functions import not_intrinsic_resistant
|
from .functions import not_intrinsic_resistant
|
||||||
|
|||||||
@@ -114,12 +114,6 @@ def wisca(x, *args, **kwargs):
|
|||||||
def retrieve_wisca_parameters(wisca_model, *args, **kwargs):
|
def retrieve_wisca_parameters(wisca_model, *args, **kwargs):
|
||||||
"""See our website of the R package for the manual: https://msberends.github.io/AMR/index.html"""
|
"""See our website of the R package for the manual: https://msberends.github.io/AMR/index.html"""
|
||||||
return convert_to_python(amr_r.retrieve_wisca_parameters(wisca_model, *args, **kwargs))
|
return convert_to_python(amr_r.retrieve_wisca_parameters(wisca_model, *args, **kwargs))
|
||||||
def amr_class(amr_class, *args, **kwargs):
|
|
||||||
"""See our website of the R package for the manual: https://msberends.github.io/AMR/index.html"""
|
|
||||||
return convert_to_python(amr_r.amr_class(amr_class, *args, **kwargs))
|
|
||||||
def amr_selector(filter, *args, **kwargs):
|
|
||||||
"""See our website of the R package for the manual: https://msberends.github.io/AMR/index.html"""
|
|
||||||
return convert_to_python(amr_r.amr_selector(filter, *args, **kwargs))
|
|
||||||
def aminoglycosides(only_sir_columns = False, *args, **kwargs):
|
def aminoglycosides(only_sir_columns = False, *args, **kwargs):
|
||||||
"""See our website of the R package for the manual: https://msberends.github.io/AMR/index.html"""
|
"""See our website of the R package for the manual: https://msberends.github.io/AMR/index.html"""
|
||||||
return convert_to_python(amr_r.aminoglycosides(only_sir_columns = False, *args, **kwargs))
|
return convert_to_python(amr_r.aminoglycosides(only_sir_columns = False, *args, **kwargs))
|
||||||
@@ -213,6 +207,12 @@ def trimethoprims(only_sir_columns = False, *args, **kwargs):
|
|||||||
def ureidopenicillins(only_sir_columns = False, *args, **kwargs):
|
def ureidopenicillins(only_sir_columns = False, *args, **kwargs):
|
||||||
"""See our website of the R package for the manual: https://msberends.github.io/AMR/index.html"""
|
"""See our website of the R package for the manual: https://msberends.github.io/AMR/index.html"""
|
||||||
return convert_to_python(amr_r.ureidopenicillins(only_sir_columns = False, *args, **kwargs))
|
return convert_to_python(amr_r.ureidopenicillins(only_sir_columns = False, *args, **kwargs))
|
||||||
|
def amr_class(amr_class, *args, **kwargs):
|
||||||
|
"""See our website of the R package for the manual: https://msberends.github.io/AMR/index.html"""
|
||||||
|
return convert_to_python(amr_r.amr_class(amr_class, *args, **kwargs))
|
||||||
|
def amr_selector(filter, *args, **kwargs):
|
||||||
|
"""See our website of the R package for the manual: https://msberends.github.io/AMR/index.html"""
|
||||||
|
return convert_to_python(amr_r.amr_selector(filter, *args, **kwargs))
|
||||||
def administrable_per_os(only_sir_columns = False, *args, **kwargs):
|
def administrable_per_os(only_sir_columns = False, *args, **kwargs):
|
||||||
"""See our website of the R package for the manual: https://msberends.github.io/AMR/index.html"""
|
"""See our website of the R package for the manual: https://msberends.github.io/AMR/index.html"""
|
||||||
return convert_to_python(amr_r.administrable_per_os(only_sir_columns = False, *args, **kwargs))
|
return convert_to_python(amr_r.administrable_per_os(only_sir_columns = False, *args, **kwargs))
|
||||||
|
|||||||
Binary file not shown.
BIN
PythonPackage/AMR/dist/amr-2.1.1.9160.tar.gz
vendored
BIN
PythonPackage/AMR/dist/amr-2.1.1.9160.tar.gz
vendored
Binary file not shown.
BIN
PythonPackage/AMR/dist/amr-2.1.1.9163-py3-none-any.whl
vendored
Normal file
BIN
PythonPackage/AMR/dist/amr-2.1.1.9163-py3-none-any.whl
vendored
Normal file
Binary file not shown.
BIN
PythonPackage/AMR/dist/amr-2.1.1.9163.tar.gz
vendored
Normal file
BIN
PythonPackage/AMR/dist/amr-2.1.1.9163.tar.gz
vendored
Normal file
Binary file not shown.
@@ -2,7 +2,7 @@ from setuptools import setup, find_packages
|
|||||||
|
|
||||||
setup(
|
setup(
|
||||||
name='AMR',
|
name='AMR',
|
||||||
version='2.1.1.9160',
|
version='2.1.1.9163',
|
||||||
packages=find_packages(),
|
packages=find_packages(),
|
||||||
install_requires=[
|
install_requires=[
|
||||||
'rpy2',
|
'rpy2',
|
||||||
|
|||||||
@@ -511,26 +511,36 @@ word_wrap <- function(...,
|
|||||||
|
|
||||||
# format backticks
|
# format backticks
|
||||||
if (pkg_is_available("cli") &&
|
if (pkg_is_available("cli") &&
|
||||||
tryCatch(isTRUE(getExportedValue("ansi_has_hyperlink_support", ns = asNamespace("cli"))()), error = function(e) FALSE) &&
|
tryCatch(isTRUE(getExportedValue("ansi_has_hyperlink_support", ns = asNamespace("cli"))()), error = function(e) FALSE) &&
|
||||||
tryCatch(getExportedValue("isAvailable", ns = asNamespace("rstudioapi"))(), error = function(e) return(FALSE)) &&
|
tryCatch(getExportedValue("isAvailable", ns = asNamespace("rstudioapi"))(), error = function(e) {
|
||||||
tryCatch(getExportedValue("versionInfo", ns = asNamespace("rstudioapi"))()$version > "2023.6.0.0", error = function(e) return(FALSE))) {
|
return(FALSE)
|
||||||
|
}) &&
|
||||||
|
tryCatch(getExportedValue("versionInfo", ns = asNamespace("rstudioapi"))()$version > "2023.6.0.0", error = function(e) {
|
||||||
|
return(FALSE)
|
||||||
|
})) {
|
||||||
# we are in a recent version of RStudio, so do something nice: add links to our help pages in the console.
|
# we are in a recent version of RStudio, so do something nice: add links to our help pages in the console.
|
||||||
parts <- strsplit(msg, "`", fixed = TRUE)[[1]]
|
parts <- strsplit(msg, "`", fixed = TRUE)[[1]]
|
||||||
cmds <- parts %in% paste0(ls(envir = asNamespace("AMR")), "()")
|
cmds <- parts %in% paste0(ls(envir = asNamespace("AMR")), "()")
|
||||||
# functions with a dot are not allowed: https://github.com/rstudio/rstudio/issues/11273#issuecomment-1156193252
|
# functions with a dot are not allowed: https://github.com/rstudio/rstudio/issues/11273#issuecomment-1156193252
|
||||||
# lead them to the help page of our package
|
# lead them to the help page of our package
|
||||||
parts[cmds & parts %like% "[.]"] <- font_url(url = paste0("ide:help:AMR::", gsub("()", "", parts[cmds & parts %like% "[.]"], fixed = TRUE)),
|
parts[cmds & parts %like% "[.]"] <- font_url(
|
||||||
txt = parts[cmds & parts %like% "[.]"])
|
url = paste0("ide:help:AMR::", gsub("()", "", parts[cmds & parts %like% "[.]"], fixed = TRUE)),
|
||||||
|
txt = parts[cmds & parts %like% "[.]"]
|
||||||
|
)
|
||||||
# otherwise, give a 'click to run' popup
|
# otherwise, give a 'click to run' popup
|
||||||
parts[cmds & parts %unlike% "[.]"] <- font_url(url = paste0("ide:run:AMR::", parts[cmds & parts %unlike% "[.]"]),
|
parts[cmds & parts %unlike% "[.]"] <- font_url(
|
||||||
txt = parts[cmds & parts %unlike% "[.]"])
|
url = paste0("ide:run:AMR::", parts[cmds & parts %unlike% "[.]"]),
|
||||||
|
txt = parts[cmds & parts %unlike% "[.]"]
|
||||||
|
)
|
||||||
# text starting with `?` must also lead to the help page
|
# text starting with `?` must also lead to the help page
|
||||||
parts[parts %like% "^[?]"] <- font_url(url = paste0("ide:help:AMR::", gsub("()", "", gsub("^[?]", "", parts[parts %like% "^[?]"]), fixed = TRUE)),
|
parts[parts %like% "^[?]"] <- font_url(
|
||||||
txt = parts[parts %like% "^[?]"])
|
url = paste0("ide:help:AMR::", gsub("()", "", gsub("^[?]", "", parts[parts %like% "^[?]"]), fixed = TRUE)),
|
||||||
|
txt = parts[parts %like% "^[?]"]
|
||||||
|
)
|
||||||
msg <- paste0(parts, collapse = "`")
|
msg <- paste0(parts, collapse = "`")
|
||||||
}
|
}
|
||||||
msg <- gsub("`(.+?)`", font_grey_bg("\\1"), msg)
|
msg <- gsub("`(.+?)`", font_grey_bg("\\1"), msg)
|
||||||
|
|
||||||
# clean introduced whitespace in between fullstops
|
# clean introduced whitespace in between fullstops
|
||||||
msg <- gsub("[.] +[.]", "..", msg)
|
msg <- gsub("[.] +[.]", "..", msg)
|
||||||
# remove extra space that was introduced (e.g. "Smith et al. , 2022")
|
# remove extra space that was introduced (e.g. "Smith et al. , 2022")
|
||||||
@@ -850,7 +860,7 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
|
|||||||
stop_if(allow_NA == FALSE, "argument `", obj_name, "` must not be NA", call = call_depth)
|
stop_if(allow_NA == FALSE, "argument `", obj_name, "` must not be NA", call = call_depth)
|
||||||
return(invisible())
|
return(invisible())
|
||||||
}
|
}
|
||||||
|
|
||||||
if (identical(class(object), "list") && !"list" %in% allow_class) {
|
if (identical(class(object), "list") && !"list" %in% allow_class) {
|
||||||
# coming from Python, possibly - turn lists (not data.frame) to the underlying data type
|
# coming from Python, possibly - turn lists (not data.frame) to the underlying data type
|
||||||
object <- unlist(object)
|
object <- unlist(object)
|
||||||
@@ -965,9 +975,11 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
|
|||||||
ascertain_sir_classes <- function(x, obj_name) {
|
ascertain_sir_classes <- function(x, obj_name) {
|
||||||
sirs <- vapply(FUN.VALUE = logical(1), x, is.sir)
|
sirs <- vapply(FUN.VALUE = logical(1), x, is.sir)
|
||||||
if (!any(sirs, na.rm = TRUE)) {
|
if (!any(sirs, na.rm = TRUE)) {
|
||||||
warning_("the data provided in argument `", obj_name,
|
warning_(
|
||||||
"` should contain at least one column of class 'sir'. Eligible SIR column were now guessed. ",
|
"the data provided in argument `", obj_name,
|
||||||
"See `?as.sir`.")
|
"` should contain at least one column of class 'sir'. Eligible SIR column were now guessed. ",
|
||||||
|
"See `?as.sir`."
|
||||||
|
)
|
||||||
sirs_eligible <- is_sir_eligible(x)
|
sirs_eligible <- is_sir_eligible(x)
|
||||||
for (col in colnames(x)[sirs_eligible]) {
|
for (col in colnames(x)[sirs_eligible]) {
|
||||||
x[[col]] <- as.sir(x[[col]])
|
x[[col]] <- as.sir(x[[col]])
|
||||||
@@ -1322,8 +1334,10 @@ progress_ticker <- function(n = 1, n_min = 0, print = TRUE, clear = TRUE, title
|
|||||||
# a close()-method was also added, see below for that
|
# a close()-method was also added, see below for that
|
||||||
pb <- progress_bar$new(
|
pb <- progress_bar$new(
|
||||||
show_after = 0,
|
show_after = 0,
|
||||||
format = paste0(title,
|
format = paste0(
|
||||||
ifelse(only_bar_percent == TRUE, "[:bar] :percent", "[:bar] :percent (:current/:total,:eta)")),
|
title,
|
||||||
|
ifelse(only_bar_percent == TRUE, "[:bar] :percent", "[:bar] :percent (:current/:total,:eta)")
|
||||||
|
),
|
||||||
clear = clear,
|
clear = clear,
|
||||||
total = n
|
total = n
|
||||||
)
|
)
|
||||||
@@ -1530,7 +1544,7 @@ add_MO_lookup_to_AMR_env <- function() {
|
|||||||
MO_lookup$fullname_lower[which(MO_lookup$subspecies %like_case% "^[A-Z]")] <- gsub(" enterica ", " ", MO_lookup$fullname_lower[which(MO_lookup$subspecies %like_case% "^[A-Z]")], fixed = TRUE)
|
MO_lookup$fullname_lower[which(MO_lookup$subspecies %like_case% "^[A-Z]")] <- gsub(" enterica ", " ", MO_lookup$fullname_lower[which(MO_lookup$subspecies %like_case% "^[A-Z]")], fixed = TRUE)
|
||||||
|
|
||||||
MO_lookup$genus_lower <- tolower(MO_lookup$genus)
|
MO_lookup$genus_lower <- tolower(MO_lookup$genus)
|
||||||
|
|
||||||
MO_lookup$full_first <- substr(MO_lookup$fullname_lower, 1, 1)
|
MO_lookup$full_first <- substr(MO_lookup$fullname_lower, 1, 1)
|
||||||
MO_lookup$species_first <- tolower(substr(MO_lookup$species, 1, 1)) # tolower for groups (Streptococcus, Salmonella)
|
MO_lookup$species_first <- tolower(substr(MO_lookup$species, 1, 1)) # tolower for groups (Streptococcus, Salmonella)
|
||||||
MO_lookup$subspecies_first <- tolower(substr(MO_lookup$subspecies, 1, 1)) # tolower for Salmonella serovars
|
MO_lookup$subspecies_first <- tolower(substr(MO_lookup$subspecies, 1, 1)) # tolower for Salmonella serovars
|
||||||
|
|||||||
@@ -44,7 +44,7 @@
|
|||||||
#' * `AMR_keep_synonyms` \cr A [logical] to use in [as.mo()] and all [`mo_*`][mo_property()] functions, to indicate if old, previously valid taxonomic names must be preserved and not be corrected to currently accepted names. The default is `FALSE`.
|
#' * `AMR_keep_synonyms` \cr A [logical] to use in [as.mo()] and all [`mo_*`][mo_property()] functions, to indicate if old, previously valid taxonomic names must be preserved and not be corrected to currently accepted names. The default is `FALSE`.
|
||||||
#' * `AMR_locale` \cr A [character] to set the language for the `AMR` package, can be one of these supported language names or ISO-639-1 codes: `r vector_or(paste0(sapply(LANGUAGES_SUPPORTED_NAMES, function(x) x[[1]]), " (" , LANGUAGES_SUPPORTED, ")"), quotes = FALSE, sort = FALSE)`. The default is the current system language (if supported, English otherwise).
|
#' * `AMR_locale` \cr A [character] to set the language for the `AMR` package, can be one of these supported language names or ISO-639-1 codes: `r vector_or(paste0(sapply(LANGUAGES_SUPPORTED_NAMES, function(x) x[[1]]), " (" , LANGUAGES_SUPPORTED, ")"), quotes = FALSE, sort = FALSE)`. The default is the current system language (if supported, English otherwise).
|
||||||
#' * `AMR_mo_source` \cr A file location for a manual code list to be used in [as.mo()] and all [`mo_*`][mo_property()] functions. This is explained in [set_mo_source()].
|
#' * `AMR_mo_source` \cr A file location for a manual code list to be used in [as.mo()] and all [`mo_*`][mo_property()] functions. This is explained in [set_mo_source()].
|
||||||
#'
|
#'
|
||||||
#' @section Saving Settings Between Sessions:
|
#' @section Saving Settings Between Sessions:
|
||||||
#' Settings in \R are not saved globally and are thus lost when \R is exited. You can save your options to your own `.Rprofile` file, which is a user-specific file. You can edit it using:
|
#' Settings in \R are not saved globally and are thus lost when \R is exited. You can save your options to your own `.Rprofile` file, which is a user-specific file. You can edit it using:
|
||||||
#'
|
#'
|
||||||
|
|||||||
174
R/ab.R
174
R/ab.R
@@ -97,21 +97,21 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
|||||||
meet_criteria(flag_multiple_results, allow_class = "logical", has_length = 1)
|
meet_criteria(flag_multiple_results, allow_class = "logical", has_length = 1)
|
||||||
language <- validate_language(language)
|
language <- validate_language(language)
|
||||||
meet_criteria(info, allow_class = "logical", has_length = 1)
|
meet_criteria(info, allow_class = "logical", has_length = 1)
|
||||||
|
|
||||||
if (is.ab(x) || all(x %in% c(AMR_env$AB_lookup$ab, NA))) {
|
if (is.ab(x) || all(x %in% c(AMR_env$AB_lookup$ab, NA))) {
|
||||||
# all valid AB codes, but not yet right class or might have additional attributes as AMR selector
|
# all valid AB codes, but not yet right class or might have additional attributes as AMR selector
|
||||||
attributes(x) <- NULL
|
attributes(x) <- NULL
|
||||||
return(set_clean_class(x,
|
return(set_clean_class(x,
|
||||||
new_class = c("ab", "character")
|
new_class = c("ab", "character")
|
||||||
))
|
))
|
||||||
}
|
}
|
||||||
|
|
||||||
already_regex <- isTRUE(list(...)$already_regex)
|
already_regex <- isTRUE(list(...)$already_regex)
|
||||||
fast_mode <- isTRUE(list(...)$fast_mode)
|
fast_mode <- isTRUE(list(...)$fast_mode)
|
||||||
|
|
||||||
x_bak <- x
|
x_bak <- x
|
||||||
x <- toupper(x)
|
x <- toupper(x)
|
||||||
|
|
||||||
# remove diacritics
|
# remove diacritics
|
||||||
x <- iconv(x, from = "UTF-8", to = "ASCII//TRANSLIT")
|
x <- iconv(x, from = "UTF-8", to = "ASCII//TRANSLIT")
|
||||||
x <- gsub('"', "", x, fixed = TRUE)
|
x <- gsub('"', "", x, fixed = TRUE)
|
||||||
@@ -122,13 +122,13 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
|||||||
if (already_regex == FALSE) {
|
if (already_regex == FALSE) {
|
||||||
x_bak_clean <- generalise_antibiotic_name(x_bak_clean)
|
x_bak_clean <- generalise_antibiotic_name(x_bak_clean)
|
||||||
}
|
}
|
||||||
|
|
||||||
x <- unique(x_bak_clean) # this means that every x is in fact generalise_antibiotic_name(x)
|
x <- unique(x_bak_clean) # this means that every x is in fact generalise_antibiotic_name(x)
|
||||||
x_new <- rep(NA_character_, length(x))
|
x_new <- rep(NA_character_, length(x))
|
||||||
x_uncertain <- character(0)
|
x_uncertain <- character(0)
|
||||||
x_unknown <- character(0)
|
x_unknown <- character(0)
|
||||||
x_unknown_ATCs <- character(0)
|
x_unknown_ATCs <- character(0)
|
||||||
|
|
||||||
note_if_more_than_one_found <- function(found, index, from_text) {
|
note_if_more_than_one_found <- function(found, index, from_text) {
|
||||||
if (isTRUE(length(from_text) > 1)) {
|
if (isTRUE(length(from_text) > 1)) {
|
||||||
abnames <- ab_name(from_text, tolower = TRUE)
|
abnames <- ab_name(from_text, tolower = TRUE)
|
||||||
@@ -149,7 +149,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
|||||||
}
|
}
|
||||||
found[1L]
|
found[1L]
|
||||||
}
|
}
|
||||||
|
|
||||||
# Fill in names, AB codes, CID codes and ATC codes directly (`x` is already clean and uppercase)
|
# Fill in names, AB codes, CID codes and ATC codes directly (`x` is already clean and uppercase)
|
||||||
known_names <- x %in% AMR_env$AB_lookup$generalised_name
|
known_names <- x %in% AMR_env$AB_lookup$generalised_name
|
||||||
x_new[known_names] <- AMR_env$AB_lookup$ab[match(x[known_names], AMR_env$AB_lookup$generalised_name)]
|
x_new[known_names] <- AMR_env$AB_lookup$ab[match(x[known_names], AMR_env$AB_lookup$generalised_name)]
|
||||||
@@ -179,27 +179,27 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
|||||||
" for ", vector_and(prev), ". Run `ab_reset_session()` to reset this. This note will be shown once per session for this input."
|
" for ", vector_and(prev), ". Run `ab_reset_session()` to reset this. This note will be shown once per session for this input."
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
already_known <- known_names | known_codes_ab | known_codes_atc | known_codes_cid | previously_coerced
|
already_known <- known_names | known_codes_ab | known_codes_atc | known_codes_cid | previously_coerced
|
||||||
|
|
||||||
# fix for NAs
|
# fix for NAs
|
||||||
x_new[is.na(x)] <- NA
|
x_new[is.na(x)] <- NA
|
||||||
already_known[is.na(x)] <- FALSE
|
already_known[is.na(x)] <- FALSE
|
||||||
|
|
||||||
if (sum(already_known) < length(x)) {
|
if (sum(already_known) < length(x)) {
|
||||||
progress <- progress_ticker(n = sum(!already_known), n_min = 25, print = info) # start if n >= 25
|
progress <- progress_ticker(n = sum(!already_known), n_min = 25, print = info) # start if n >= 25
|
||||||
on.exit(close(progress))
|
on.exit(close(progress))
|
||||||
}
|
}
|
||||||
|
|
||||||
for (i in which(!already_known)) {
|
for (i in which(!already_known)) {
|
||||||
progress$tick()
|
progress$tick()
|
||||||
|
|
||||||
if (is.na(x[i]) || is.null(x[i])) {
|
if (is.na(x[i]) || is.null(x[i])) {
|
||||||
next
|
next
|
||||||
}
|
}
|
||||||
if (identical(x[i], "") ||
|
if (identical(x[i], "") ||
|
||||||
# prevent "bacteria" from coercing to TMP, since Bacterial is a brand name of it:
|
# prevent "bacteria" from coercing to TMP, since Bacterial is a brand name of it:
|
||||||
identical(tolower(x[i]), "bacteria")) {
|
identical(tolower(x[i]), "bacteria")) {
|
||||||
x_unknown <- c(x_unknown, x_bak[x[i] == x_bak_clean][1])
|
x_unknown <- c(x_unknown, x_bak[x[i] == x_bak_clean][1])
|
||||||
next
|
next
|
||||||
}
|
}
|
||||||
@@ -210,21 +210,21 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
|||||||
x_new[i] <- NA_character_
|
x_new[i] <- NA_character_
|
||||||
next
|
next
|
||||||
}
|
}
|
||||||
|
|
||||||
if (fast_mode == FALSE && flag_multiple_results == TRUE && x[i] %like% "[ ]") {
|
if (fast_mode == FALSE && flag_multiple_results == TRUE && x[i] %like% "[ ]") {
|
||||||
from_text <- tryCatch(suppressWarnings(ab_from_text(x[i], translate_ab = FALSE)[[1]]),
|
from_text <- tryCatch(suppressWarnings(ab_from_text(x[i], translate_ab = FALSE)[[1]]),
|
||||||
error = function(e) character(0)
|
error = function(e) character(0)
|
||||||
)
|
)
|
||||||
} else {
|
} else {
|
||||||
from_text <- character(0)
|
from_text <- character(0)
|
||||||
}
|
}
|
||||||
|
|
||||||
# old code for phenoxymethylpenicillin (Peni V)
|
# old code for phenoxymethylpenicillin (Peni V)
|
||||||
if (x[i] == "PNV") {
|
if (x[i] == "PNV") {
|
||||||
x_new[i] <- "PHN"
|
x_new[i] <- "PHN"
|
||||||
next
|
next
|
||||||
}
|
}
|
||||||
|
|
||||||
# exact LOINC code
|
# exact LOINC code
|
||||||
loinc_found <- unlist(lapply(
|
loinc_found <- unlist(lapply(
|
||||||
AMR_env$AB_lookup$generalised_loinc,
|
AMR_env$AB_lookup$generalised_loinc,
|
||||||
@@ -235,7 +235,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
|||||||
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
||||||
next
|
next
|
||||||
}
|
}
|
||||||
|
|
||||||
# exact synonym
|
# exact synonym
|
||||||
synonym_found <- unlist(lapply(
|
synonym_found <- unlist(lapply(
|
||||||
AMR_env$AB_lookup$generalised_synonyms,
|
AMR_env$AB_lookup$generalised_synonyms,
|
||||||
@@ -246,7 +246,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
|||||||
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
||||||
next
|
next
|
||||||
}
|
}
|
||||||
|
|
||||||
# exact abbreviation
|
# exact abbreviation
|
||||||
abbr_found <- unlist(lapply(
|
abbr_found <- unlist(lapply(
|
||||||
AMR_env$AB_lookup$generalised_abbreviations,
|
AMR_env$AB_lookup$generalised_abbreviations,
|
||||||
@@ -258,7 +258,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
|||||||
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
||||||
next
|
next
|
||||||
}
|
}
|
||||||
|
|
||||||
# length of input is quite long, and Levenshtein distance is only max 2
|
# length of input is quite long, and Levenshtein distance is only max 2
|
||||||
if (nchar(x[i]) >= 10) {
|
if (nchar(x[i]) >= 10) {
|
||||||
levenshtein <- as.double(utils::adist(x[i], AMR_env$AB_lookup$generalised_name))
|
levenshtein <- as.double(utils::adist(x[i], AMR_env$AB_lookup$generalised_name))
|
||||||
@@ -268,7 +268,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
|||||||
next
|
next
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
# allow characters that resemble others, but only continue when having more than 3 characters
|
# allow characters that resemble others, but only continue when having more than 3 characters
|
||||||
if (nchar(x[i]) <= 3) {
|
if (nchar(x[i]) <= 3) {
|
||||||
x_unknown <- c(x_unknown, x_bak[x[i] == x_bak_clean][1])
|
x_unknown <- c(x_unknown, x_bak[x[i] == x_bak_clean][1])
|
||||||
@@ -298,22 +298,22 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
|||||||
x_spelling <- gsub("(O|0)", "(O|0)+", x_spelling, perl = TRUE)
|
x_spelling <- gsub("(O|0)", "(O|0)+", x_spelling, perl = TRUE)
|
||||||
x_spelling <- gsub("++", "+", x_spelling, fixed = TRUE)
|
x_spelling <- gsub("++", "+", x_spelling, fixed = TRUE)
|
||||||
}
|
}
|
||||||
|
|
||||||
# try if name starts with it
|
# try if name starts with it
|
||||||
found <- AMR_env$AB_lookup[which(AMR_env$AB_lookup$generalised_name %like% paste0("^", x_spelling)), "ab", drop = TRUE]
|
found <- AMR_env$AB_lookup[which(AMR_env$AB_lookup$generalised_name %like% paste0("^", x_spelling)), "ab", drop = TRUE]
|
||||||
if (length(found) > 0) {
|
if (length(found) > 0) {
|
||||||
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
||||||
next
|
next
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
# try if name ends with it
|
# try if name ends with it
|
||||||
found <- AMR_env$AB_lookup[which(AMR_env$AB_lookup$generalised_name %like% paste0(x_spelling, "$")), "ab", drop = TRUE]
|
found <- AMR_env$AB_lookup[which(AMR_env$AB_lookup$generalised_name %like% paste0(x_spelling, "$")), "ab", drop = TRUE]
|
||||||
if (nchar(x[i]) >= 4 && length(found) > 0) {
|
if (nchar(x[i]) >= 4 && length(found) > 0) {
|
||||||
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
||||||
next
|
next
|
||||||
}
|
}
|
||||||
|
|
||||||
# and try if any synonym starts with it
|
# and try if any synonym starts with it
|
||||||
synonym_found <- unlist(lapply(
|
synonym_found <- unlist(lapply(
|
||||||
AMR_env$AB_lookup$generalised_synonyms,
|
AMR_env$AB_lookup$generalised_synonyms,
|
||||||
@@ -324,38 +324,46 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
|||||||
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
||||||
next
|
next
|
||||||
}
|
}
|
||||||
|
|
||||||
# More uncertain results ----
|
# More uncertain results ----
|
||||||
if (fast_mode == FALSE) {
|
if (fast_mode == FALSE) {
|
||||||
|
|
||||||
ab_df <- AMR_env$AB_lookup
|
ab_df <- AMR_env$AB_lookup
|
||||||
ab_df$length_name <- nchar(ab_df$generalised_name)
|
ab_df$length_name <- nchar(ab_df$generalised_name)
|
||||||
# now retrieve Levensthein distance for name, synonyms, and translated names
|
# now retrieve Levensthein distance for name, synonyms, and translated names
|
||||||
ab_df$lev_name <- as.double(utils::adist(x[i], ab_df$generalised_name,
|
ab_df$lev_name <- as.double(utils::adist(x[i], ab_df$generalised_name,
|
||||||
ignore.case = FALSE,
|
ignore.case = FALSE,
|
||||||
fixed = TRUE,
|
fixed = TRUE,
|
||||||
costs = c(insertions = 1, deletions = 1, substitutions = 2),
|
costs = c(insertions = 1, deletions = 1, substitutions = 2),
|
||||||
counts = FALSE))
|
counts = FALSE
|
||||||
ab_df$lev_syn <- vapply(FUN.VALUE = double(1),
|
))
|
||||||
ab_df$generalised_synonyms,
|
ab_df$lev_syn <- vapply(
|
||||||
function(y) ifelse(length(y[nchar(y) >= 5]) == 0,
|
FUN.VALUE = double(1),
|
||||||
999,
|
ab_df$generalised_synonyms,
|
||||||
min(as.double(utils::adist(x[i], y[nchar(y) >= 5], ignore.case = FALSE,
|
function(y) {
|
||||||
fixed = TRUE,
|
ifelse(length(y[nchar(y) >= 5]) == 0,
|
||||||
costs = c(insertions = 1, deletions = 1, substitutions = 2),
|
999,
|
||||||
counts = FALSE)), na.rm = TRUE)),
|
min(as.double(utils::adist(x[i], y[nchar(y) >= 5],
|
||||||
USE.NAMES = FALSE)
|
ignore.case = FALSE,
|
||||||
|
fixed = TRUE,
|
||||||
|
costs = c(insertions = 1, deletions = 1, substitutions = 2),
|
||||||
|
counts = FALSE
|
||||||
|
)), na.rm = TRUE)
|
||||||
|
)
|
||||||
|
},
|
||||||
|
USE.NAMES = FALSE
|
||||||
|
)
|
||||||
if (!is.null(language) && language != "en") {
|
if (!is.null(language) && language != "en") {
|
||||||
ab_df$trans <- generalise_antibiotic_name(translate_AMR(ab_df$name, language = language))
|
ab_df$trans <- generalise_antibiotic_name(translate_AMR(ab_df$name, language = language))
|
||||||
ab_df$lev_trans <- as.double(utils::adist(x[i], ab_df$trans,
|
ab_df$lev_trans <- as.double(utils::adist(x[i], ab_df$trans,
|
||||||
ignore.case = FALSE,
|
ignore.case = FALSE,
|
||||||
fixed = TRUE,
|
fixed = TRUE,
|
||||||
costs = c(insertions = 1, deletions = 1, substitutions = 2),
|
costs = c(insertions = 1, deletions = 1, substitutions = 2),
|
||||||
counts = FALSE))
|
counts = FALSE
|
||||||
|
))
|
||||||
} else {
|
} else {
|
||||||
ab_df$lev_trans <- ab_df$lev_name
|
ab_df$lev_trans <- ab_df$lev_name
|
||||||
}
|
}
|
||||||
|
|
||||||
if (any(ab_df$lev_name < 5, na.rm = TRUE)) {
|
if (any(ab_df$lev_name < 5, na.rm = TRUE)) {
|
||||||
x_new[i] <- ab_df$ab[order(ab_df$lev_name)][1]
|
x_new[i] <- ab_df$ab[order(ab_df$lev_name)][1]
|
||||||
x_uncertain <- c(x_uncertain, x_bak[x[i] == x_bak_clean][1])
|
x_uncertain <- c(x_uncertain, x_bak[x[i] == x_bak_clean][1])
|
||||||
@@ -379,15 +387,15 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
|||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
# nothing found
|
# nothing found
|
||||||
x_unknown <- c(x_unknown, x_bak[x[i] == x_bak_clean][1])
|
x_unknown <- c(x_unknown, x_bak[x[i] == x_bak_clean][1])
|
||||||
}
|
}
|
||||||
|
|
||||||
if (sum(already_known) < length(x)) {
|
if (sum(already_known) < length(x)) {
|
||||||
close(progress)
|
close(progress)
|
||||||
}
|
}
|
||||||
|
|
||||||
# save to package env to save time for next time
|
# save to package env to save time for next time
|
||||||
AMR_env$ab_previously_coerced <- AMR_env$ab_previously_coerced[which(!AMR_env$ab_previously_coerced$x %in% x), , drop = FALSE]
|
AMR_env$ab_previously_coerced <- AMR_env$ab_previously_coerced[which(!AMR_env$ab_previously_coerced$x %in% x), , drop = FALSE]
|
||||||
AMR_env$ab_previously_coerced <- unique(rbind_AMR(
|
AMR_env$ab_previously_coerced <- unique(rbind_AMR(
|
||||||
@@ -399,7 +407,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
|||||||
stringsAsFactors = FALSE
|
stringsAsFactors = FALSE
|
||||||
)
|
)
|
||||||
))
|
))
|
||||||
|
|
||||||
# take failed ATC codes apart from rest
|
# take failed ATC codes apart from rest
|
||||||
if (length(x_unknown_ATCs) > 0 && fast_mode == FALSE) {
|
if (length(x_unknown_ATCs) > 0 && fast_mode == FALSE) {
|
||||||
warning_(
|
warning_(
|
||||||
@@ -407,7 +415,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
|||||||
vector_and(x_unknown_ATCs), "."
|
vector_and(x_unknown_ATCs), "."
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
# Throw note about uncertainties
|
# Throw note about uncertainties
|
||||||
x_unknown <- x_unknown[!x_unknown %in% x_unknown_ATCs]
|
x_unknown <- x_unknown[!x_unknown %in% x_unknown_ATCs]
|
||||||
x_unknown <- c(
|
x_unknown <- c(
|
||||||
@@ -421,7 +429,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
|||||||
vector_and(x_unknown), "."
|
vector_and(x_unknown), "."
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
# Throw note about uncertainties
|
# Throw note about uncertainties
|
||||||
if (isTRUE(info) && length(x_uncertain) > 0 && fast_mode == FALSE) {
|
if (isTRUE(info) && length(x_uncertain) > 0 && fast_mode == FALSE) {
|
||||||
x_uncertain <- unique(x_uncertain)
|
x_uncertain <- unique(x_uncertain)
|
||||||
@@ -429,25 +437,29 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
|||||||
if (length(x_uncertain) <= 3) {
|
if (length(x_uncertain) <= 3) {
|
||||||
examples <- vector_and(
|
examples <- vector_and(
|
||||||
paste0(
|
paste0(
|
||||||
'"', x_uncertain, '" (assumed ',
|
'"', x_uncertain, '" (assumed ',
|
||||||
ab_name(AMR_env$ab_previously_coerced$ab[which(AMR_env$ab_previously_coerced$x_bak %in% x_uncertain)], language = NULL, tolower = TRUE),
|
ab_name(AMR_env$ab_previously_coerced$ab[which(AMR_env$ab_previously_coerced$x_bak %in% x_uncertain)], language = NULL, tolower = TRUE),
|
||||||
", ", AMR_env$ab_previously_coerced$ab[which(AMR_env$ab_previously_coerced$x_bak %in% x_uncertain)], ")"),
|
", ", AMR_env$ab_previously_coerced$ab[which(AMR_env$ab_previously_coerced$x_bak %in% x_uncertain)], ")"
|
||||||
quotes = FALSE)
|
),
|
||||||
|
quotes = FALSE
|
||||||
|
)
|
||||||
} else {
|
} else {
|
||||||
examples <- paste0(nr2char(length(x_uncertain)), " antimicrobials")
|
examples <- paste0(nr2char(length(x_uncertain)), " antimicrobials")
|
||||||
}
|
}
|
||||||
message_("Antimicrobial translation was uncertain for ", examples,
|
message_(
|
||||||
". If required, use `add_custom_antimicrobials()` to add custom entries.")
|
"Antimicrobial translation was uncertain for ", examples,
|
||||||
|
". If required, use `add_custom_antimicrobials()` to add custom entries."
|
||||||
|
)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
x_result <- x_new[match(x_bak_clean, x)]
|
x_result <- x_new[match(x_bak_clean, x)]
|
||||||
if (length(x_result) == 0) {
|
if (length(x_result) == 0) {
|
||||||
x_result <- NA_character_
|
x_result <- NA_character_
|
||||||
}
|
}
|
||||||
|
|
||||||
set_clean_class(x_result,
|
set_clean_class(x_result,
|
||||||
new_class = c("ab", "character")
|
new_class = c("ab", "character")
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -473,13 +485,15 @@ ab_reset_session <- function() {
|
|||||||
pillar_shaft.ab <- function(x, ...) {
|
pillar_shaft.ab <- function(x, ...) {
|
||||||
out <- trimws(format(x))
|
out <- trimws(format(x))
|
||||||
out[is.na(x)] <- font_na(NA)
|
out[is.na(x)] <- font_na(NA)
|
||||||
|
|
||||||
# add the names to the drugs as mouse-over!
|
# add the names to the drugs as mouse-over!
|
||||||
if (tryCatch(isTRUE(getExportedValue("ansi_has_hyperlink_support", ns = asNamespace("cli"))()), error = function(e) FALSE)) {
|
if (tryCatch(isTRUE(getExportedValue("ansi_has_hyperlink_support", ns = asNamespace("cli"))()), error = function(e) FALSE)) {
|
||||||
out[!is.na(x)] <- font_url(url = paste0(x[!is.na(x)], ": ", ab_name(x[!is.na(x)])),
|
out[!is.na(x)] <- font_url(
|
||||||
txt = out[!is.na(x)])
|
url = paste0(x[!is.na(x)], ": ", ab_name(x[!is.na(x)])),
|
||||||
|
txt = out[!is.na(x)]
|
||||||
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
create_pillar_column(out, align = "left", min_width = 4)
|
create_pillar_column(out, align = "left", min_width = 4)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -494,12 +508,14 @@ type_sum.ab <- function(x, ...) {
|
|||||||
print.ab <- function(x, ...) {
|
print.ab <- function(x, ...) {
|
||||||
if (!is.null(attributes(x)$amr_selector)) {
|
if (!is.null(attributes(x)$amr_selector)) {
|
||||||
function_name <- attributes(x)$amr_selector
|
function_name <- attributes(x)$amr_selector
|
||||||
message_("This 'ab' vector was retrieved using `" , function_name, "()`, which should normally be used inside a `dplyr` verb or `data.frame` call, e.g.:\n",
|
message_(
|
||||||
" ", AMR_env$bullet_icon, " your_data %>% select(", function_name, "())\n",
|
"This 'ab' vector was retrieved using `", function_name, "()`, which should normally be used inside a `dplyr` verb or `data.frame` call, e.g.:\n",
|
||||||
" ", AMR_env$bullet_icon, " your_data %>% select(column_a, column_b, ", function_name, "())\n",
|
" ", AMR_env$bullet_icon, " your_data %>% select(", function_name, "())\n",
|
||||||
" ", AMR_env$bullet_icon, " your_data %>% filter(any(", function_name, "() == \"R\"))\n",
|
" ", AMR_env$bullet_icon, " your_data %>% select(column_a, column_b, ", function_name, "())\n",
|
||||||
" ", AMR_env$bullet_icon, " your_data[, ", function_name, "()]\n",
|
" ", AMR_env$bullet_icon, " your_data %>% filter(any(", function_name, "() == \"R\"))\n",
|
||||||
" ", AMR_env$bullet_icon, " your_data[, c(\"column_a\", \"column_b\", ", function_name, "())]")
|
" ", AMR_env$bullet_icon, " your_data[, ", function_name, "()]\n",
|
||||||
|
" ", AMR_env$bullet_icon, " your_data[, c(\"column_a\", \"column_b\", ", function_name, "())]"
|
||||||
|
)
|
||||||
}
|
}
|
||||||
cat("Class 'ab'\n")
|
cat("Class 'ab'\n")
|
||||||
print(as.character(x), quote = FALSE)
|
print(as.character(x), quote = FALSE)
|
||||||
@@ -614,9 +630,9 @@ get_translate_ab <- function(translate_ab) {
|
|||||||
} else {
|
} else {
|
||||||
translate_ab <- tolower(translate_ab)
|
translate_ab <- tolower(translate_ab)
|
||||||
stop_ifnot(translate_ab %in% colnames(AMR::antibiotics),
|
stop_ifnot(translate_ab %in% colnames(AMR::antibiotics),
|
||||||
"invalid value for 'translate_ab', this must be a column name of the antibiotics data set\n",
|
"invalid value for 'translate_ab', this must be a column name of the antibiotics data set\n",
|
||||||
"or TRUE (equals 'name') or FALSE to not translate at all.",
|
"or TRUE (equals 'name') or FALSE to not translate at all.",
|
||||||
call = FALSE
|
call = FALSE
|
||||||
)
|
)
|
||||||
translate_ab
|
translate_ab
|
||||||
}
|
}
|
||||||
@@ -633,11 +649,11 @@ create_AB_AV_lookup <- function(df) {
|
|||||||
new_df$generalised_all <- unname(lapply(
|
new_df$generalised_all <- unname(lapply(
|
||||||
as.list(as.data.frame(
|
as.list(as.data.frame(
|
||||||
t(new_df[,
|
t(new_df[,
|
||||||
c(
|
c(
|
||||||
colnames(new_df)[colnames(new_df) %in% c("ab", "av", "atc", "cid", "name")],
|
colnames(new_df)[colnames(new_df) %in% c("ab", "av", "atc", "cid", "name")],
|
||||||
colnames(new_df)[colnames(new_df) %like% "generalised"]
|
colnames(new_df)[colnames(new_df) %like% "generalised"]
|
||||||
),
|
),
|
||||||
drop = FALSE
|
drop = FALSE
|
||||||
]),
|
]),
|
||||||
stringsAsFactors = FALSE
|
stringsAsFactors = FALSE
|
||||||
)),
|
)),
|
||||||
|
|||||||
@@ -32,7 +32,7 @@
|
|||||||
#' @description These functions allow for filtering rows and selecting columns based on antimicrobial test results that are of a specific antimicrobial class or group, without the need to define the columns or antimicrobial abbreviations.
|
#' @description These functions allow for filtering rows and selecting columns based on antimicrobial test results that are of a specific antimicrobial class or group, without the need to define the columns or antimicrobial abbreviations.
|
||||||
#'
|
#'
|
||||||
#' In short, if you have a column name that resembles an antimicrobial drug, it will be picked up by any of these functions that matches its pharmaceutical class: "cefazolin", "kefzol", "CZO" and "J01DB04" will all be picked up using:
|
#' In short, if you have a column name that resembles an antimicrobial drug, it will be picked up by any of these functions that matches its pharmaceutical class: "cefazolin", "kefzol", "CZO" and "J01DB04" will all be picked up using:
|
||||||
#'
|
#'
|
||||||
#' ```r
|
#' ```r
|
||||||
#' library(dplyr)
|
#' library(dplyr)
|
||||||
#' my_data_with_all_these_columns %>%
|
#' my_data_with_all_these_columns %>%
|
||||||
@@ -46,7 +46,7 @@
|
|||||||
#' @param ... ignored, only in place to allow future extensions
|
#' @param ... ignored, only in place to allow future extensions
|
||||||
#' @details
|
#' @details
|
||||||
#' These functions can be used in data set calls for selecting columns and filtering rows. They work with base \R, the Tidyverse, and `data.table`. They are heavily inspired by the [Tidyverse selection helpers][tidyselect::language] such as [`everything()`][tidyselect::everything()], but are not limited to `dplyr` verbs. Nonetheless, they are very convenient to use with `dplyr` functions such as [`select()`][dplyr::select()], [`filter()`][dplyr::filter()] and [`summarise()`][dplyr::summarise()], see *Examples*.
|
#' These functions can be used in data set calls for selecting columns and filtering rows. They work with base \R, the Tidyverse, and `data.table`. They are heavily inspired by the [Tidyverse selection helpers][tidyselect::language] such as [`everything()`][tidyselect::everything()], but are not limited to `dplyr` verbs. Nonetheless, they are very convenient to use with `dplyr` functions such as [`select()`][dplyr::select()], [`filter()`][dplyr::filter()] and [`summarise()`][dplyr::summarise()], see *Examples*.
|
||||||
#'
|
#'
|
||||||
#' All selectors can also be used in `tidymodels` packages such as `recipe` and `parsnip`. See for more info [our tutorial](https://msberends.github.io/AMR/articles/AMR_with_tidymodels.html) on using antimicrobial selectors for predictive modelling.
|
#' All selectors can also be used in `tidymodels` packages such as `recipe` and `parsnip`. See for more info [our tutorial](https://msberends.github.io/AMR/articles/AMR_with_tidymodels.html) on using antimicrobial selectors for predictive modelling.
|
||||||
#'
|
#'
|
||||||
#' All columns in the data in which these functions are called will be searched for known antimicrobial names, abbreviations, brand names, and codes (ATC, EARS-Net, WHO, etc.) according to the [antibiotics] data set. This means that a selector such as [aminoglycosides()] will pick up column names like 'gen', 'genta', 'J01GB03', 'tobra', 'Tobracin', etc.
|
#' All columns in the data in which these functions are called will be searched for known antimicrobial names, abbreviations, brand names, and codes (ATC, EARS-Net, WHO, etc.) according to the [antibiotics] data set. This means that a selector such as [aminoglycosides()] will pick up column names like 'gen', 'genta', 'J01GB03', 'tobra', 'Tobracin', etc.
|
||||||
@@ -72,88 +72,88 @@
|
|||||||
#'
|
#'
|
||||||
#' # Though they are primarily intended to use for selections and filters.
|
#' # Though they are primarily intended to use for selections and filters.
|
||||||
#' # Examples sections below are split into 'dplyr', 'base R', and 'data.table':
|
#' # Examples sections below are split into 'dplyr', 'base R', and 'data.table':
|
||||||
#'
|
#'
|
||||||
#' \donttest{
|
#' \donttest{
|
||||||
#' \dontrun{
|
#' \dontrun{
|
||||||
#' # dplyr -------------------------------------------------------------------
|
#' # dplyr -------------------------------------------------------------------
|
||||||
#'
|
#'
|
||||||
#' library(dplyr, warn.conflicts = FALSE)
|
#' library(dplyr, warn.conflicts = FALSE)
|
||||||
#'
|
#'
|
||||||
#' example_isolates %>% select(carbapenems())
|
#' example_isolates %>% select(carbapenems())
|
||||||
#'
|
#'
|
||||||
#' # select columns 'mo', 'AMK', 'GEN', 'KAN' and 'TOB'
|
#' # select columns 'mo', 'AMK', 'GEN', 'KAN' and 'TOB'
|
||||||
#' example_isolates %>% select(mo, aminoglycosides())
|
#' example_isolates %>% select(mo, aminoglycosides())
|
||||||
#'
|
#'
|
||||||
#' # you can combine selectors like you are used with tidyverse
|
#' # you can combine selectors like you are used with tidyverse
|
||||||
#' # e.g., for betalactams, but not the ones with an enzyme inhibitor:
|
#' # e.g., for betalactams, but not the ones with an enzyme inhibitor:
|
||||||
#' example_isolates %>% select(betalactams(), -betalactams_with_inhibitor())
|
#' example_isolates %>% select(betalactams(), -betalactams_with_inhibitor())
|
||||||
#'
|
#'
|
||||||
#' # select only antimicrobials with DDDs for oral treatment
|
#' # select only antimicrobials with DDDs for oral treatment
|
||||||
#' example_isolates %>% select(administrable_per_os())
|
#' example_isolates %>% select(administrable_per_os())
|
||||||
#'
|
#'
|
||||||
#' # get AMR for all aminoglycosides e.g., per ward:
|
#' # get AMR for all aminoglycosides e.g., per ward:
|
||||||
#' example_isolates %>%
|
#' example_isolates %>%
|
||||||
#' group_by(ward) %>%
|
#' group_by(ward) %>%
|
||||||
#' summarise(across(aminoglycosides(),
|
#' summarise(across(aminoglycosides(),
|
||||||
#' resistance))
|
#' resistance))
|
||||||
#'
|
#'
|
||||||
#' # You can combine selectors with '&' to be more specific:
|
#' # You can combine selectors with '&' to be more specific:
|
||||||
#' example_isolates %>%
|
#' example_isolates %>%
|
||||||
#' select(penicillins() & administrable_per_os())
|
#' select(penicillins() & administrable_per_os())
|
||||||
#'
|
#'
|
||||||
#' # get AMR for only drugs that matter - no intrinsic resistance:
|
#' # get AMR for only drugs that matter - no intrinsic resistance:
|
||||||
#' example_isolates %>%
|
#' example_isolates %>%
|
||||||
#' filter(mo_genus() %in% c("Escherichia", "Klebsiella")) %>%
|
#' filter(mo_genus() %in% c("Escherichia", "Klebsiella")) %>%
|
||||||
#' group_by(ward) %>%
|
#' group_by(ward) %>%
|
||||||
#' summarise_at(not_intrinsic_resistant(),
|
#' summarise_at(not_intrinsic_resistant(),
|
||||||
#' resistance)
|
#' resistance)
|
||||||
#'
|
#'
|
||||||
#' # get susceptibility for antimicrobials whose name contains "trim":
|
#' # get susceptibility for antimicrobials whose name contains "trim":
|
||||||
#' example_isolates %>%
|
#' example_isolates %>%
|
||||||
#' filter(first_isolate()) %>%
|
#' filter(first_isolate()) %>%
|
||||||
#' group_by(ward) %>%
|
#' group_by(ward) %>%
|
||||||
#' summarise(across(amr_selector(name %like% "trim"), susceptibility))
|
#' summarise(across(amr_selector(name %like% "trim"), susceptibility))
|
||||||
#'
|
#'
|
||||||
#' # this will select columns 'IPM' (imipenem) and 'MEM' (meropenem):
|
#' # this will select columns 'IPM' (imipenem) and 'MEM' (meropenem):
|
||||||
#' example_isolates %>%
|
#' example_isolates %>%
|
||||||
#' select(carbapenems())
|
#' select(carbapenems())
|
||||||
#'
|
#'
|
||||||
#' # this will select columns 'mo', 'AMK', 'GEN', 'KAN' and 'TOB':
|
#' # this will select columns 'mo', 'AMK', 'GEN', 'KAN' and 'TOB':
|
||||||
#' example_isolates %>%
|
#' example_isolates %>%
|
||||||
#' select(mo, aminoglycosides())
|
#' select(mo, aminoglycosides())
|
||||||
#'
|
#'
|
||||||
#' # any() and all() work in dplyr's filter() too:
|
#' # any() and all() work in dplyr's filter() too:
|
||||||
#' example_isolates %>%
|
#' example_isolates %>%
|
||||||
#' filter(
|
#' filter(
|
||||||
#' any(aminoglycosides() == "R"),
|
#' any(aminoglycosides() == "R"),
|
||||||
#' all(cephalosporins_2nd() == "R")
|
#' all(cephalosporins_2nd() == "R")
|
||||||
#' )
|
#' )
|
||||||
#'
|
#'
|
||||||
#' # also works with c():
|
#' # also works with c():
|
||||||
#' example_isolates %>%
|
#' example_isolates %>%
|
||||||
#' filter(any(c(carbapenems(), aminoglycosides()) == "R"))
|
#' filter(any(c(carbapenems(), aminoglycosides()) == "R"))
|
||||||
#'
|
#'
|
||||||
#' # not setting any/all will automatically apply all():
|
#' # not setting any/all will automatically apply all():
|
||||||
#' example_isolates %>%
|
#' example_isolates %>%
|
||||||
#' filter(aminoglycosides() == "R")
|
#' filter(aminoglycosides() == "R")
|
||||||
#'
|
#'
|
||||||
#' # this will select columns 'mo' and all antimycobacterial drugs ('RIF'):
|
#' # this will select columns 'mo' and all antimycobacterial drugs ('RIF'):
|
||||||
#' example_isolates %>%
|
#' example_isolates %>%
|
||||||
#' select(mo, amr_class("mycobact"))
|
#' select(mo, amr_class("mycobact"))
|
||||||
#'
|
#'
|
||||||
#' # get bug/drug combinations for only glycopeptides in Gram-positives:
|
#' # get bug/drug combinations for only glycopeptides in Gram-positives:
|
||||||
#' example_isolates %>%
|
#' example_isolates %>%
|
||||||
#' filter(mo_is_gram_positive()) %>%
|
#' filter(mo_is_gram_positive()) %>%
|
||||||
#' select(mo, glycopeptides()) %>%
|
#' select(mo, glycopeptides()) %>%
|
||||||
#' bug_drug_combinations() %>%
|
#' bug_drug_combinations() %>%
|
||||||
#' format()
|
#' format()
|
||||||
#'
|
#'
|
||||||
#' data.frame(
|
#' data.frame(
|
||||||
#' some_column = "some_value",
|
#' some_column = "some_value",
|
||||||
#' J01CA01 = "S"
|
#' J01CA01 = "S"
|
||||||
#' ) %>% # ATC code of ampicillin
|
#' ) %>% # ATC code of ampicillin
|
||||||
#' select(penicillins()) # only the 'J01CA01' column will be selected
|
#' select(penicillins()) # only the 'J01CA01' column will be selected
|
||||||
#'
|
#'
|
||||||
#' # with recent versions of dplyr, this is all equal:
|
#' # with recent versions of dplyr, this is all equal:
|
||||||
#' x <- example_isolates[carbapenems() == "R", ]
|
#' x <- example_isolates[carbapenems() == "R", ]
|
||||||
#' y <- example_isolates %>% filter(carbapenems() == "R")
|
#' y <- example_isolates %>% filter(carbapenems() == "R")
|
||||||
@@ -231,57 +231,6 @@
|
|||||||
#' dt[any(carbapenems() == "S"), penicillins(), with = FALSE]
|
#' dt[any(carbapenems() == "S"), penicillins(), with = FALSE]
|
||||||
#' }
|
#' }
|
||||||
#' }
|
#' }
|
||||||
amr_class <- function(amr_class,
|
|
||||||
only_sir_columns = FALSE,
|
|
||||||
only_treatable = TRUE,
|
|
||||||
return_all = TRUE,
|
|
||||||
...) {
|
|
||||||
meet_criteria(amr_class, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
|
||||||
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
|
|
||||||
meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
|
|
||||||
meet_criteria(return_all, allow_class = "logical", has_length = 1)
|
|
||||||
amr_select_exec(NULL, only_sir_columns = only_sir_columns, amr_class_args = amr_class, only_treatable = only_treatable, return_all = return_all)
|
|
||||||
}
|
|
||||||
|
|
||||||
#' @rdname antimicrobial_selectors
|
|
||||||
#' @details The [amr_selector()] function can be used to internally filter the [antibiotics] data set on any results, see *Examples*. It allows for filtering on a (part of) a certain name, and/or a group name or even a minimum of DDDs for oral treatment. This function yields the highest flexibility, but is also the least user-friendly, since it requires a hard-coded filter to set.
|
|
||||||
#' @export
|
|
||||||
amr_selector <- function(filter,
|
|
||||||
only_sir_columns = FALSE,
|
|
||||||
only_treatable = TRUE,
|
|
||||||
return_all = TRUE,
|
|
||||||
...) {
|
|
||||||
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
|
|
||||||
meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
|
|
||||||
meet_criteria(return_all, allow_class = "logical", has_length = 1)
|
|
||||||
|
|
||||||
# get_current_data() has to run each time, for cases where e.g., filter() and select() are used in same call
|
|
||||||
# but it only takes a couple of milliseconds
|
|
||||||
vars_df <- get_current_data(arg_name = NA, call = -2)
|
|
||||||
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
|
|
||||||
ab_in_data <- get_column_abx(vars_df,
|
|
||||||
info = FALSE, only_sir_columns = only_sir_columns,
|
|
||||||
sort = FALSE, fn = "amr_selector", return_all = return_all
|
|
||||||
)
|
|
||||||
call <- substitute(filter)
|
|
||||||
agents <- tryCatch(AMR_env$AB_lookup[which(eval(call, envir = AMR_env$AB_lookup)), "ab", drop = TRUE],
|
|
||||||
error = function(e) stop_(e$message, call = -5)
|
|
||||||
)
|
|
||||||
agents <- ab_in_data[ab_in_data %in% agents]
|
|
||||||
message_agent_names(
|
|
||||||
function_name = "amr_selector",
|
|
||||||
agents = agents,
|
|
||||||
ab_group = NULL,
|
|
||||||
examples = "",
|
|
||||||
call = call
|
|
||||||
)
|
|
||||||
structure(unname(agents),
|
|
||||||
class = c("amr_selector", "character")
|
|
||||||
)
|
|
||||||
}
|
|
||||||
|
|
||||||
#' @rdname antimicrobial_selectors
|
|
||||||
#' @export
|
|
||||||
aminoglycosides <- function(only_sir_columns = FALSE, only_treatable = TRUE, return_all = TRUE, ...) {
|
aminoglycosides <- function(only_sir_columns = FALSE, only_treatable = TRUE, return_all = TRUE, ...) {
|
||||||
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
|
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
|
||||||
meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
|
meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
|
||||||
@@ -536,6 +485,57 @@ ureidopenicillins <- function(only_sir_columns = FALSE, return_all = TRUE, ...)
|
|||||||
#' @rdname antimicrobial_selectors
|
#' @rdname antimicrobial_selectors
|
||||||
#' @details The [administrable_per_os()] and [administrable_iv()] functions also rely on the [antibiotics] data set - antimicrobials will be matched where a DDD (defined daily dose) for resp. oral and IV treatment is available in the [antibiotics] data set.
|
#' @details The [administrable_per_os()] and [administrable_iv()] functions also rely on the [antibiotics] data set - antimicrobials will be matched where a DDD (defined daily dose) for resp. oral and IV treatment is available in the [antibiotics] data set.
|
||||||
#' @export
|
#' @export
|
||||||
|
amr_class <- function(amr_class,
|
||||||
|
only_sir_columns = FALSE,
|
||||||
|
only_treatable = TRUE,
|
||||||
|
return_all = TRUE,
|
||||||
|
...) {
|
||||||
|
meet_criteria(amr_class, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||||
|
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
|
||||||
|
meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
|
||||||
|
meet_criteria(return_all, allow_class = "logical", has_length = 1)
|
||||||
|
amr_select_exec(NULL, only_sir_columns = only_sir_columns, amr_class_args = amr_class, only_treatable = only_treatable, return_all = return_all)
|
||||||
|
}
|
||||||
|
|
||||||
|
#' @rdname antimicrobial_selectors
|
||||||
|
#' @details The [amr_selector()] function can be used to internally filter the [antibiotics] data set on any results, see *Examples*. It allows for filtering on a (part of) a certain name, and/or a group name or even a minimum of DDDs for oral treatment. This function yields the highest flexibility, but is also the least user-friendly, since it requires a hard-coded filter to set.
|
||||||
|
#' @export
|
||||||
|
amr_selector <- function(filter,
|
||||||
|
only_sir_columns = FALSE,
|
||||||
|
only_treatable = TRUE,
|
||||||
|
return_all = TRUE,
|
||||||
|
...) {
|
||||||
|
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
|
||||||
|
meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
|
||||||
|
meet_criteria(return_all, allow_class = "logical", has_length = 1)
|
||||||
|
|
||||||
|
# get_current_data() has to run each time, for cases where e.g., filter() and select() are used in same call
|
||||||
|
# but it only takes a couple of milliseconds
|
||||||
|
vars_df <- get_current_data(arg_name = NA, call = -2)
|
||||||
|
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
|
||||||
|
ab_in_data <- get_column_abx(vars_df,
|
||||||
|
info = FALSE, only_sir_columns = only_sir_columns,
|
||||||
|
sort = FALSE, fn = "amr_selector", return_all = return_all
|
||||||
|
)
|
||||||
|
call <- substitute(filter)
|
||||||
|
agents <- tryCatch(AMR_env$AB_lookup[which(eval(call, envir = AMR_env$AB_lookup)), "ab", drop = TRUE],
|
||||||
|
error = function(e) stop_(e$message, call = -5)
|
||||||
|
)
|
||||||
|
agents <- ab_in_data[ab_in_data %in% agents]
|
||||||
|
message_agent_names(
|
||||||
|
function_name = "amr_selector",
|
||||||
|
agents = agents,
|
||||||
|
ab_group = NULL,
|
||||||
|
examples = "",
|
||||||
|
call = call
|
||||||
|
)
|
||||||
|
structure(unname(agents),
|
||||||
|
class = c("amr_selector", "character")
|
||||||
|
)
|
||||||
|
}
|
||||||
|
|
||||||
|
#' @rdname antimicrobial_selectors
|
||||||
|
#' @export
|
||||||
administrable_per_os <- function(only_sir_columns = FALSE, return_all = TRUE, ...) {
|
administrable_per_os <- function(only_sir_columns = FALSE, return_all = TRUE, ...) {
|
||||||
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
|
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
|
||||||
meet_criteria(return_all, allow_class = "logical", has_length = 1)
|
meet_criteria(return_all, allow_class = "logical", has_length = 1)
|
||||||
@@ -544,8 +544,8 @@ administrable_per_os <- function(only_sir_columns = FALSE, return_all = TRUE, ..
|
|||||||
vars_df <- get_current_data(arg_name = NA, call = -2)
|
vars_df <- get_current_data(arg_name = NA, call = -2)
|
||||||
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
|
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
|
||||||
ab_in_data <- get_column_abx(vars_df,
|
ab_in_data <- get_column_abx(vars_df,
|
||||||
info = FALSE, only_sir_columns = only_sir_columns,
|
info = FALSE, only_sir_columns = only_sir_columns,
|
||||||
sort = FALSE, fn = "administrable_per_os", return_all = return_all
|
sort = FALSE, fn = "administrable_per_os", return_all = return_all
|
||||||
)
|
)
|
||||||
agents_all <- AMR_env$AB_lookup[which(!is.na(AMR_env$AB_lookup$oral_ddd)), "ab", drop = TRUE]
|
agents_all <- AMR_env$AB_lookup[which(!is.na(AMR_env$AB_lookup$oral_ddd)), "ab", drop = TRUE]
|
||||||
agents <- AMR_env$AB_lookup[which(AMR_env$AB_lookup$ab %in% ab_in_data & !is.na(AMR_env$AB_lookup$oral_ddd)), "ab", drop = TRUE]
|
agents <- AMR_env$AB_lookup[which(AMR_env$AB_lookup$ab %in% ab_in_data & !is.na(AMR_env$AB_lookup$oral_ddd)), "ab", drop = TRUE]
|
||||||
@@ -559,8 +559,8 @@ administrable_per_os <- function(only_sir_columns = FALSE, return_all = TRUE, ..
|
|||||||
vector_or(
|
vector_or(
|
||||||
ab_name(
|
ab_name(
|
||||||
sample(agents_all,
|
sample(agents_all,
|
||||||
size = min(5, length(agents_all)),
|
size = min(5, length(agents_all)),
|
||||||
replace = FALSE
|
replace = FALSE
|
||||||
),
|
),
|
||||||
tolower = TRUE,
|
tolower = TRUE,
|
||||||
language = NULL
|
language = NULL
|
||||||
@@ -571,7 +571,7 @@ administrable_per_os <- function(only_sir_columns = FALSE, return_all = TRUE, ..
|
|||||||
)
|
)
|
||||||
)
|
)
|
||||||
structure(unname(agents),
|
structure(unname(agents),
|
||||||
class = c("amr_selector", "character")
|
class = c("amr_selector", "character")
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -585,8 +585,8 @@ administrable_iv <- function(only_sir_columns = FALSE, return_all = TRUE, ...) {
|
|||||||
vars_df <- get_current_data(arg_name = NA, call = -2)
|
vars_df <- get_current_data(arg_name = NA, call = -2)
|
||||||
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
|
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
|
||||||
ab_in_data <- get_column_abx(vars_df,
|
ab_in_data <- get_column_abx(vars_df,
|
||||||
info = FALSE, only_sir_columns = only_sir_columns,
|
info = FALSE, only_sir_columns = only_sir_columns,
|
||||||
sort = FALSE, fn = "administrable_iv", return_all = return_all
|
sort = FALSE, fn = "administrable_iv", return_all = return_all
|
||||||
)
|
)
|
||||||
agents_all <- AMR_env$AB_lookup[which(!is.na(AMR_env$AB_lookup$iv_ddd)), "ab", drop = TRUE]
|
agents_all <- AMR_env$AB_lookup[which(!is.na(AMR_env$AB_lookup$iv_ddd)), "ab", drop = TRUE]
|
||||||
agents <- AMR_env$AB_lookup[which(AMR_env$AB_lookup$ab %in% ab_in_data & !is.na(AMR_env$AB_lookup$iv_ddd)), "ab", drop = TRUE]
|
agents <- AMR_env$AB_lookup[which(AMR_env$AB_lookup$ab %in% ab_in_data & !is.na(AMR_env$AB_lookup$iv_ddd)), "ab", drop = TRUE]
|
||||||
@@ -598,7 +598,7 @@ administrable_iv <- function(only_sir_columns = FALSE, return_all = TRUE, ...) {
|
|||||||
examples = ""
|
examples = ""
|
||||||
)
|
)
|
||||||
structure(unname(agents),
|
structure(unname(agents),
|
||||||
class = c("amr_selector", "character")
|
class = c("amr_selector", "character")
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -613,30 +613,30 @@ not_intrinsic_resistant <- function(only_sir_columns = FALSE, col_mo = NULL, ver
|
|||||||
vars_df <- get_current_data(arg_name = NA, call = -2)
|
vars_df <- get_current_data(arg_name = NA, call = -2)
|
||||||
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
|
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
|
||||||
ab_in_data <- get_column_abx(vars_df,
|
ab_in_data <- get_column_abx(vars_df,
|
||||||
info = FALSE, only_sir_columns = only_sir_columns,
|
info = FALSE, only_sir_columns = only_sir_columns,
|
||||||
sort = FALSE, fn = "not_intrinsic_resistant", return_all = TRUE
|
sort = FALSE, fn = "not_intrinsic_resistant", return_all = TRUE
|
||||||
)
|
)
|
||||||
# intrinsic vars
|
# intrinsic vars
|
||||||
vars_df_R <- tryCatch(
|
vars_df_R <- tryCatch(
|
||||||
sapply(
|
sapply(
|
||||||
eucast_rules(vars_df,
|
eucast_rules(vars_df,
|
||||||
col_mo = col_mo,
|
col_mo = col_mo,
|
||||||
version_expertrules = version_expertrules,
|
version_expertrules = version_expertrules,
|
||||||
rules = "expert",
|
rules = "expert",
|
||||||
info = FALSE
|
info = FALSE
|
||||||
),
|
),
|
||||||
function(col) {
|
function(col) {
|
||||||
tryCatch(!any(is.na(col)) && all(col == "R"),
|
tryCatch(!any(is.na(col)) && all(col == "R"),
|
||||||
error = function(e) FALSE
|
error = function(e) FALSE
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
),
|
),
|
||||||
error = function(e) stop_("in not_intrinsic_resistant(): ", e$message, call = FALSE)
|
error = function(e) stop_("in not_intrinsic_resistant(): ", e$message, call = FALSE)
|
||||||
)
|
)
|
||||||
|
|
||||||
agents <- ab_in_data[ab_in_data %in% names(vars_df_R[which(vars_df_R)])]
|
agents <- ab_in_data[ab_in_data %in% names(vars_df_R[which(vars_df_R)])]
|
||||||
if (length(agents) > 0 &&
|
if (length(agents) > 0 &&
|
||||||
message_not_thrown_before("not_intrinsic_resistant", sort(agents))) {
|
message_not_thrown_before("not_intrinsic_resistant", sort(agents))) {
|
||||||
agents_formatted <- paste0("'", font_bold(agents, collapse = NULL), "'")
|
agents_formatted <- paste0("'", font_bold(agents, collapse = NULL), "'")
|
||||||
agents_names <- ab_name(names(agents), tolower = TRUE, language = NULL)
|
agents_names <- ab_name(names(agents), tolower = TRUE, language = NULL)
|
||||||
need_name <- generalise_antibiotic_name(agents) != generalise_antibiotic_name(agents_names)
|
need_name <- generalise_antibiotic_name(agents) != generalise_antibiotic_name(agents_names)
|
||||||
@@ -647,12 +647,12 @@ not_intrinsic_resistant <- function(only_sir_columns = FALSE, col_mo = NULL, ver
|
|||||||
vector_and(agents_formatted, quotes = FALSE, sort = FALSE)
|
vector_and(agents_formatted, quotes = FALSE, sort = FALSE)
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
vars_df_R <- names(vars_df_R)[which(!vars_df_R)]
|
vars_df_R <- names(vars_df_R)[which(!vars_df_R)]
|
||||||
# find columns that are abx, but also intrinsic R
|
# find columns that are abx, but also intrinsic R
|
||||||
out <- unname(intersect(ab_in_data, vars_df_R))
|
out <- unname(intersect(ab_in_data, vars_df_R))
|
||||||
structure(out,
|
structure(out,
|
||||||
class = c("amr_selector", "character")
|
class = c("amr_selector", "character")
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -667,13 +667,14 @@ amr_select_exec <- function(function_name,
|
|||||||
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
|
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
|
||||||
if (!is.null(vars_df)) {
|
if (!is.null(vars_df)) {
|
||||||
ab_in_data <- get_column_abx(vars_df,
|
ab_in_data <- get_column_abx(vars_df,
|
||||||
info = FALSE,
|
info = FALSE,
|
||||||
only_sir_columns = only_sir_columns,
|
only_sir_columns = only_sir_columns,
|
||||||
sort = FALSE,
|
sort = FALSE,
|
||||||
fn = function_name,
|
fn = function_name,
|
||||||
return_all = return_all)
|
return_all = return_all
|
||||||
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
# untreatable drugs
|
# untreatable drugs
|
||||||
if (!is.null(vars_df) && only_treatable == TRUE) {
|
if (!is.null(vars_df) && only_treatable == TRUE) {
|
||||||
untreatable <- AMR_env$AB_lookup[which(AMR_env$AB_lookup$name %like% "(-high|EDTA|polysorbate|macromethod|screening|nacubactam)"), "ab", drop = TRUE]
|
untreatable <- AMR_env$AB_lookup[which(AMR_env$AB_lookup$name %like% "(-high|EDTA|polysorbate|macromethod|screening|nacubactam)"), "ab", drop = TRUE]
|
||||||
@@ -683,8 +684,8 @@ amr_select_exec <- function(function_name,
|
|||||||
"in `", function_name, "()`: some drugs were ignored since they cannot be used for treating patients: ",
|
"in `", function_name, "()`: some drugs were ignored since they cannot be used for treating patients: ",
|
||||||
vector_and(
|
vector_and(
|
||||||
ab_name(names(ab_in_data)[names(ab_in_data) %in% untreatable],
|
ab_name(names(ab_in_data)[names(ab_in_data) %in% untreatable],
|
||||||
language = NULL,
|
language = NULL,
|
||||||
tolower = TRUE
|
tolower = TRUE
|
||||||
),
|
),
|
||||||
quotes = FALSE,
|
quotes = FALSE,
|
||||||
sort = TRUE
|
sort = TRUE
|
||||||
@@ -694,12 +695,12 @@ amr_select_exec <- function(function_name,
|
|||||||
ab_in_data <- ab_in_data[!names(ab_in_data) %in% untreatable]
|
ab_in_data <- ab_in_data[!names(ab_in_data) %in% untreatable]
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
if (!is.null(vars_df) && length(ab_in_data) == 0) {
|
if (!is.null(vars_df) && length(ab_in_data) == 0) {
|
||||||
message_("No antimicrobial drugs found in the data.")
|
message_("No antimicrobial drugs found in the data.")
|
||||||
return(NULL)
|
return(NULL)
|
||||||
}
|
}
|
||||||
|
|
||||||
if (is.null(amr_class_args) || isTRUE(function_name %in% c("antifungals", "antimycobacterials"))) {
|
if (is.null(amr_class_args) || isTRUE(function_name %in% c("antifungals", "antimycobacterials"))) {
|
||||||
ab_group <- NULL
|
ab_group <- NULL
|
||||||
if (isTRUE(function_name == "antifungals")) {
|
if (isTRUE(function_name == "antifungals")) {
|
||||||
@@ -727,8 +728,8 @@ amr_select_exec <- function(function_name,
|
|||||||
}
|
}
|
||||||
examples <- paste0(" (such as ", vector_or(
|
examples <- paste0(" (such as ", vector_or(
|
||||||
ab_name(sample(abx, size = min(2, length(abx)), replace = FALSE),
|
ab_name(sample(abx, size = min(2, length(abx)), replace = FALSE),
|
||||||
tolower = TRUE,
|
tolower = TRUE,
|
||||||
language = NULL
|
language = NULL
|
||||||
),
|
),
|
||||||
quotes = FALSE
|
quotes = FALSE
|
||||||
), ")")
|
), ")")
|
||||||
@@ -744,16 +745,16 @@ amr_select_exec <- function(function_name,
|
|||||||
function_name <- "amr_class"
|
function_name <- "amr_class"
|
||||||
examples <- paste0(" (such as ", find_ab_names(amr_class_args, 2), ")")
|
examples <- paste0(" (such as ", find_ab_names(amr_class_args, 2), ")")
|
||||||
}
|
}
|
||||||
|
|
||||||
if (is.null(vars_df)) {
|
if (is.null(vars_df)) {
|
||||||
# no data found, no antimicrobials, so no input. Happens if users run e.g. `aminoglycosides()` as a separate command.
|
# no data found, no antimicrobials, so no input. Happens if users run e.g. `aminoglycosides()` as a separate command.
|
||||||
# print.ab will cover the additional printing text
|
# print.ab will cover the additional printing text
|
||||||
return(structure(sort(abx), amr_selector = function_name))
|
return(structure(sort(abx), amr_selector = function_name))
|
||||||
}
|
}
|
||||||
|
|
||||||
# get the columns with a group names in the chosen ab class
|
# get the columns with a group names in the chosen ab class
|
||||||
agents <- ab_in_data[names(ab_in_data) %in% abx]
|
agents <- ab_in_data[names(ab_in_data) %in% abx]
|
||||||
|
|
||||||
message_agent_names(
|
message_agent_names(
|
||||||
function_name = function_name,
|
function_name = function_name,
|
||||||
agents = agents,
|
agents = agents,
|
||||||
@@ -761,9 +762,9 @@ amr_select_exec <- function(function_name,
|
|||||||
examples = examples,
|
examples = examples,
|
||||||
amr_class_args = amr_class_args
|
amr_class_args = amr_class_args
|
||||||
)
|
)
|
||||||
|
|
||||||
structure(unname(agents),
|
structure(unname(agents),
|
||||||
class = c("amr_selector", "character")
|
class = c("amr_selector", "character")
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -772,7 +773,8 @@ amr_select_exec <- function(function_name,
|
|||||||
#' @noRd
|
#' @noRd
|
||||||
print.amr_selector <- function(x, ...) {
|
print.amr_selector <- function(x, ...) {
|
||||||
warning_("It should never be needed to print an antimicrobial selector class. Are you using data.table? Then add the argument `with = FALSE`, see our examples at `?amr_selector`.",
|
warning_("It should never be needed to print an antimicrobial selector class. Are you using data.table? Then add the argument `with = FALSE`, see our examples at `?amr_selector`.",
|
||||||
immediate = TRUE)
|
immediate = TRUE
|
||||||
|
)
|
||||||
cat("Class 'amr_selector'\n")
|
cat("Class 'amr_selector'\n")
|
||||||
print(as.character(x), quote = FALSE)
|
print(as.character(x), quote = FALSE)
|
||||||
}
|
}
|
||||||
@@ -782,7 +784,7 @@ print.amr_selector <- function(x, ...) {
|
|||||||
#' @noRd
|
#' @noRd
|
||||||
c.amr_selector <- function(...) {
|
c.amr_selector <- function(...) {
|
||||||
structure(unlist(lapply(list(...), as.character)),
|
structure(unlist(lapply(list(...), as.character)),
|
||||||
class = c("amr_selector", "character")
|
class = c("amr_selector", "character")
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -795,13 +797,13 @@ all_any_amr_selector <- function(type, ..., na.rm = TRUE) {
|
|||||||
}
|
}
|
||||||
cols_ab <- cols_ab[!cols_ab %in% result]
|
cols_ab <- cols_ab[!cols_ab %in% result]
|
||||||
df <- get_current_data(arg_name = NA, call = -3)
|
df <- get_current_data(arg_name = NA, call = -3)
|
||||||
|
|
||||||
if (type == "all") {
|
if (type == "all") {
|
||||||
scope_fn <- all
|
scope_fn <- all
|
||||||
} else {
|
} else {
|
||||||
scope_fn <- any
|
scope_fn <- any
|
||||||
}
|
}
|
||||||
|
|
||||||
x_transposed <- as.list(as.data.frame(t(df[, cols_ab, drop = FALSE]), stringsAsFactors = FALSE))
|
x_transposed <- as.list(as.data.frame(t(df[, cols_ab, drop = FALSE]), stringsAsFactors = FALSE))
|
||||||
vapply(
|
vapply(
|
||||||
FUN.VALUE = logical(1),
|
FUN.VALUE = logical(1),
|
||||||
@@ -875,7 +877,7 @@ any.amr_selector_any_all <- function(..., na.rm = FALSE) {
|
|||||||
}
|
}
|
||||||
}
|
}
|
||||||
structure(all_any_amr_selector(type = type, e1, e2),
|
structure(all_any_amr_selector(type = type, e1, e2),
|
||||||
class = c("amr_selector_any_all", "logical")
|
class = c("amr_selector_any_all", "logical")
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -903,7 +905,7 @@ any.amr_selector_any_all <- function(..., na.rm = FALSE) {
|
|||||||
sir <- c("S", "SDD", "I", "R", "NI")
|
sir <- c("S", "SDD", "I", "R", "NI")
|
||||||
e2 <- sir[sir != e2]
|
e2 <- sir[sir != e2]
|
||||||
structure(all_any_amr_selector(type = type, e1, e2),
|
structure(all_any_amr_selector(type = type, e1, e2),
|
||||||
class = c("amr_selector_any_all", "logical")
|
class = c("amr_selector_any_all", "logical")
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -914,7 +916,7 @@ any.amr_selector_any_all <- function(..., na.rm = FALSE) {
|
|||||||
# this is only required for base R, since tidyselect has already implemented this
|
# this is only required for base R, since tidyselect has already implemented this
|
||||||
# e.g., for: example_isolates[, penicillins() & administrable_per_os()]
|
# e.g., for: example_isolates[, penicillins() & administrable_per_os()]
|
||||||
structure(intersect(unclass(e1), unclass(e2)),
|
structure(intersect(unclass(e1), unclass(e2)),
|
||||||
class = c("amr_selector", "character")
|
class = c("amr_selector", "character")
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
#' @method | amr_selector
|
#' @method | amr_selector
|
||||||
@@ -924,7 +926,7 @@ any.amr_selector_any_all <- function(..., na.rm = FALSE) {
|
|||||||
# this is only required for base R, since tidyselect has already implemented this
|
# this is only required for base R, since tidyselect has already implemented this
|
||||||
# e.g., for: example_isolates[, penicillins() | administrable_per_os()]
|
# e.g., for: example_isolates[, penicillins() | administrable_per_os()]
|
||||||
structure(union(unclass(e1), unclass(e2)),
|
structure(union(unclass(e1), unclass(e2)),
|
||||||
class = c("amr_selector", "character")
|
class = c("amr_selector", "character")
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -943,8 +945,8 @@ find_ab_group <- function(amr_class_args) {
|
|||||||
amr_class_args <- gsub("[^a-zA-Z0-9]", ".*", amr_class_args)
|
amr_class_args <- gsub("[^a-zA-Z0-9]", ".*", amr_class_args)
|
||||||
AMR_env$AB_lookup %pm>%
|
AMR_env$AB_lookup %pm>%
|
||||||
subset(group %like% amr_class_args |
|
subset(group %like% amr_class_args |
|
||||||
atc_group1 %like% amr_class_args |
|
atc_group1 %like% amr_class_args |
|
||||||
atc_group2 %like% amr_class_args) %pm>%
|
atc_group2 %like% amr_class_args) %pm>%
|
||||||
pm_pull(group) %pm>%
|
pm_pull(group) %pm>%
|
||||||
unique() %pm>%
|
unique() %pm>%
|
||||||
tolower() %pm>%
|
tolower() %pm>%
|
||||||
@@ -954,26 +956,26 @@ find_ab_group <- function(amr_class_args) {
|
|||||||
|
|
||||||
find_ab_names <- function(ab_group, n = 3) {
|
find_ab_names <- function(ab_group, n = 3) {
|
||||||
ab_group <- gsub("[^a-zA-Z|0-9]", ".*", ab_group)
|
ab_group <- gsub("[^a-zA-Z|0-9]", ".*", ab_group)
|
||||||
|
|
||||||
# try popular first, they have DDDs
|
# try popular first, they have DDDs
|
||||||
drugs <- AMR_env$AB_lookup[which((!is.na(AMR_env$AB_lookup$iv_ddd) | !is.na(AMR_env$AB_lookup$oral_ddd)) &
|
drugs <- AMR_env$AB_lookup[which((!is.na(AMR_env$AB_lookup$iv_ddd) | !is.na(AMR_env$AB_lookup$oral_ddd)) &
|
||||||
AMR_env$AB_lookup$name %unlike% " " &
|
AMR_env$AB_lookup$name %unlike% " " &
|
||||||
AMR_env$AB_lookup$group %like% ab_group &
|
AMR_env$AB_lookup$group %like% ab_group &
|
||||||
AMR_env$AB_lookup$ab %unlike% "[0-9]$"), ]$name
|
AMR_env$AB_lookup$ab %unlike% "[0-9]$"), ]$name
|
||||||
if (length(drugs) < n) {
|
if (length(drugs) < n) {
|
||||||
# now try it all
|
# now try it all
|
||||||
drugs <- AMR_env$AB_lookup[which((AMR_env$AB_lookup$group %like% ab_group |
|
drugs <- AMR_env$AB_lookup[which((AMR_env$AB_lookup$group %like% ab_group |
|
||||||
AMR_env$AB_lookup$atc_group1 %like% ab_group |
|
AMR_env$AB_lookup$atc_group1 %like% ab_group |
|
||||||
AMR_env$AB_lookup$atc_group2 %like% ab_group) &
|
AMR_env$AB_lookup$atc_group2 %like% ab_group) &
|
||||||
AMR_env$AB_lookup$ab %unlike% "[0-9]$"), ]$name
|
AMR_env$AB_lookup$ab %unlike% "[0-9]$"), ]$name
|
||||||
}
|
}
|
||||||
if (length(drugs) == 0) {
|
if (length(drugs) == 0) {
|
||||||
return("??")
|
return("??")
|
||||||
}
|
}
|
||||||
vector_or(
|
vector_or(
|
||||||
ab_name(sample(drugs, size = min(n, length(drugs)), replace = FALSE),
|
ab_name(sample(drugs, size = min(n, length(drugs)), replace = FALSE),
|
||||||
tolower = TRUE,
|
tolower = TRUE,
|
||||||
language = NULL
|
language = NULL
|
||||||
),
|
),
|
||||||
quotes = FALSE
|
quotes = FALSE
|
||||||
)
|
)
|
||||||
@@ -999,11 +1001,11 @@ message_agent_names <- function(function_name, agents, ab_group = NULL, examples
|
|||||||
message_(
|
message_(
|
||||||
"For `", function_name, "(",
|
"For `", function_name, "(",
|
||||||
ifelse(function_name == "amr_class",
|
ifelse(function_name == "amr_class",
|
||||||
paste0("\"", amr_class_args, "\""),
|
paste0("\"", amr_class_args, "\""),
|
||||||
ifelse(!is.null(call),
|
ifelse(!is.null(call),
|
||||||
paste0(deparse(call), collapse = " "),
|
paste0(deparse(call), collapse = " "),
|
||||||
""
|
""
|
||||||
)
|
)
|
||||||
),
|
),
|
||||||
")` using ",
|
")` using ",
|
||||||
ifelse(length(agents) == 1, "column ", "columns "),
|
ifelse(length(agents) == 1, "column ", "columns "),
|
||||||
|
|||||||
454
R/antibiogram.R
454
R/antibiogram.R
@@ -31,7 +31,7 @@
|
|||||||
#'
|
#'
|
||||||
#' @description
|
#' @description
|
||||||
#' Create detailed antibiograms with options for traditional, combination, syndromic, and Bayesian WISCA methods.
|
#' Create detailed antibiograms with options for traditional, combination, syndromic, and Bayesian WISCA methods.
|
||||||
#'
|
#'
|
||||||
#' Adhering to previously described approaches (see *Source*) and especially the Bayesian WISCA model (Weighted-Incidence Syndromic Combination Antibiogram) by Bielicki *et al.*, these functions provide flexible output formats including plots and tables, ideal for integration with R Markdown and Quarto reports.
|
#' Adhering to previously described approaches (see *Source*) and especially the Bayesian WISCA model (Weighted-Incidence Syndromic Combination Antibiogram) by Bielicki *et al.*, these functions provide flexible output formats including plots and tables, ideal for integration with R Markdown and Quarto reports.
|
||||||
#' @param x a [data.frame] containing at least a column with microorganisms and columns with antimicrobial results (class 'sir', see [as.sir()])
|
#' @param x a [data.frame] containing at least a column with microorganisms and columns with antimicrobial results (class 'sir', see [as.sir()])
|
||||||
#' @param antibiotics vector of any antimicrobial name or code (will be evaluated with [as.ab()], column name of `x`, or (any combinations of) [antimicrobial selectors][antimicrobial_selectors] such as [aminoglycosides()] or [carbapenems()]. For combination antibiograms, this can also be set to values separated with `"+"`, such as `"TZP+TOB"` or `"cipro + genta"`, given that columns resembling such antimicrobials exist in `x`. See *Examples*.
|
#' @param antibiotics vector of any antimicrobial name or code (will be evaluated with [as.ab()], column name of `x`, or (any combinations of) [antimicrobial selectors][antimicrobial_selectors] such as [aminoglycosides()] or [carbapenems()]. For combination antibiograms, this can also be set to values separated with `"+"`, such as `"TZP+TOB"` or `"cipro + genta"`, given that columns resembling such antimicrobials exist in `x`. See *Examples*.
|
||||||
@@ -55,17 +55,17 @@
|
|||||||
#' @param object an [antibiogram()] object
|
#' @param object an [antibiogram()] object
|
||||||
#' @param ... when used in [R Markdown or Quarto][knitr::kable()]: arguments passed on to [knitr::kable()] (otherwise, has no use)
|
#' @param ... when used in [R Markdown or Quarto][knitr::kable()]: arguments passed on to [knitr::kable()] (otherwise, has no use)
|
||||||
#' @details These functions return a table with values between 0 and 100 for *susceptibility*, not resistance.
|
#' @details These functions return a table with values between 0 and 100 for *susceptibility*, not resistance.
|
||||||
#'
|
#'
|
||||||
#' **Remember that you should filter your data to let it contain only first isolates!** This is needed to exclude duplicates and to reduce selection bias. Use [first_isolate()] to determine them with one of the four available algorithms: isolate-based, patient-based, episode-based, or phenotype-based.
|
#' **Remember that you should filter your data to let it contain only first isolates!** This is needed to exclude duplicates and to reduce selection bias. Use [first_isolate()] to determine them with one of the four available algorithms: isolate-based, patient-based, episode-based, or phenotype-based.
|
||||||
#'
|
#'
|
||||||
#' For estimating antimicrobial coverage, especially when creating a WISCA, the outcome might become more reliable by only including the top *n* species encountered in the data. You can filter on this top *n* using [top_n_microorganisms()]. For example, use `top_n_microorganisms(your_data, n = 10)` as a pre-processing step to only include the top 10 species in the data.
|
#' For estimating antimicrobial coverage, especially when creating a WISCA, the outcome might become more reliable by only including the top *n* species encountered in the data. You can filter on this top *n* using [top_n_microorganisms()]. For example, use `top_n_microorganisms(your_data, n = 10)` as a pre-processing step to only include the top 10 species in the data.
|
||||||
#'
|
#'
|
||||||
#' The numeric values of an antibiogram are stored in a long format as the [attribute][attributes()] `long_numeric`. You can retrieve them using `attributes(x)$long_numeric`, where `x` is the outcome of [antibiogram()] or [wisca()]. This is ideal for e.g. advanced plotting.
|
#' The numeric values of an antibiogram are stored in a long format as the [attribute][attributes()] `long_numeric`. You can retrieve them using `attributes(x)$long_numeric`, where `x` is the outcome of [antibiogram()] or [wisca()]. This is ideal for e.g. advanced plotting.
|
||||||
#'
|
#'
|
||||||
#' ### Formatting Type
|
#' ### Formatting Type
|
||||||
#'
|
#'
|
||||||
#' The formatting of the 'cells' of the table can be set with the argument `formatting_type`. In these examples, `5` is the antimicrobial coverage (`4-6` indicates the confidence level), `15` the number of susceptible isolates, and `300` the number of tested (i.e., available) isolates:
|
#' The formatting of the 'cells' of the table can be set with the argument `formatting_type`. In these examples, `5` is the antimicrobial coverage (`4-6` indicates the confidence level), `15` the number of susceptible isolates, and `300` the number of tested (i.e., available) isolates:
|
||||||
#'
|
#'
|
||||||
#' 1. 5
|
#' 1. 5
|
||||||
#' 2. 15
|
#' 2. 15
|
||||||
#' 3. 300
|
#' 3. 300
|
||||||
@@ -88,15 +88,15 @@
|
|||||||
#' 20. 5% (4-6%,15/300)
|
#' 20. 5% (4-6%,15/300)
|
||||||
#' 21. 5 (4-6,N=15/300)
|
#' 21. 5 (4-6,N=15/300)
|
||||||
#' 22. 5% (4-6%,N=15/300)
|
#' 22. 5% (4-6%,N=15/300)
|
||||||
#'
|
#'
|
||||||
#' The default is `14`, which can be set globally with the package option [`AMR_antibiogram_formatting_type`][AMR-options], e.g. `options(AMR_antibiogram_formatting_type = 5)`. Do note that for WISCA, the total numbers of tested and susceptible isolates are less useful to report, since these are included in the Bayesian model and apparent from the susceptibility and its confidence level.
|
#' The default is `14`, which can be set globally with the package option [`AMR_antibiogram_formatting_type`][AMR-options], e.g. `options(AMR_antibiogram_formatting_type = 5)`. Do note that for WISCA, the total numbers of tested and susceptible isolates are less useful to report, since these are included in the Bayesian model and apparent from the susceptibility and its confidence level.
|
||||||
#'
|
#'
|
||||||
#' Set `digits` (defaults to `0`) to alter the rounding of the susceptibility percentages.
|
#' Set `digits` (defaults to `0`) to alter the rounding of the susceptibility percentages.
|
||||||
#'
|
#'
|
||||||
#' ### Antibiogram Types
|
#' ### Antibiogram Types
|
||||||
#'
|
#'
|
||||||
#' There are various antibiogram types, as summarised by Klinker *et al.* (2021, \doi{10.1177/20499361211011373}), and they are all supported by [antibiogram()].
|
#' There are various antibiogram types, as summarised by Klinker *et al.* (2021, \doi{10.1177/20499361211011373}), and they are all supported by [antibiogram()].
|
||||||
#'
|
#'
|
||||||
#' For clinical coverage estimations, **use WISCA whenever possible**, since it provides more precise coverage estimates by accounting for pathogen incidence and antimicrobial susceptibility, as has been shown by Bielicki *et al.* (2020, \doi{10.1001.jamanetworkopen.2019.21124}). See the section *Explaining WISCA* on this page. Do note that WISCA is pathogen-agnostic, meaning that the outcome is not stratied by pathogen, but rather by syndrome.
|
#' For clinical coverage estimations, **use WISCA whenever possible**, since it provides more precise coverage estimates by accounting for pathogen incidence and antimicrobial susceptibility, as has been shown by Bielicki *et al.* (2020, \doi{10.1001.jamanetworkopen.2019.21124}). See the section *Explaining WISCA* on this page. Do note that WISCA is pathogen-agnostic, meaning that the outcome is not stratied by pathogen, but rather by syndrome.
|
||||||
#'
|
#'
|
||||||
#' 1. **Traditional Antibiogram**
|
#' 1. **Traditional Antibiogram**
|
||||||
@@ -134,7 +134,7 @@
|
|||||||
#' ```
|
#' ```
|
||||||
#'
|
#'
|
||||||
#' 4. **Weighted-Incidence Syndromic Combination Antibiogram (WISCA)**
|
#' 4. **Weighted-Incidence Syndromic Combination Antibiogram (WISCA)**
|
||||||
#'
|
#'
|
||||||
#' WISCA can be applied to any antibiogram, see the section *Explaining WISCA* on this page for more information.
|
#' WISCA can be applied to any antibiogram, see the section *Explaining WISCA* on this page for more information.
|
||||||
#'
|
#'
|
||||||
#' Code example:
|
#' Code example:
|
||||||
@@ -143,18 +143,18 @@
|
|||||||
#' antibiogram(your_data,
|
#' antibiogram(your_data,
|
||||||
#' antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
|
#' antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
|
||||||
#' wisca = TRUE)
|
#' wisca = TRUE)
|
||||||
#'
|
#'
|
||||||
#' # this is equal to:
|
#' # this is equal to:
|
||||||
#' wisca(your_data,
|
#' wisca(your_data,
|
||||||
#' antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"))
|
#' antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"))
|
||||||
#' ```
|
#' ```
|
||||||
#'
|
#'
|
||||||
#' WISCA uses a sophisticated Bayesian decision model to combine both local and pooled antimicrobial resistance data. This approach not only evaluates local patterns but can also draw on multi-centre datasets to improve regimen accuracy, even in low-incidence infections like paediatric bloodstream infections (BSIs).
|
#' WISCA uses a sophisticated Bayesian decision model to combine both local and pooled antimicrobial resistance data. This approach not only evaluates local patterns but can also draw on multi-centre datasets to improve regimen accuracy, even in low-incidence infections like paediatric bloodstream infections (BSIs).
|
||||||
#'
|
#'
|
||||||
#' ### Grouped tibbles
|
#' ### Grouped tibbles
|
||||||
#'
|
#'
|
||||||
#' For any type of antibiogram, grouped [tibbles][tibble::tibble] can also be used to calculate susceptibilities over various groups.
|
#' For any type of antibiogram, grouped [tibbles][tibble::tibble] can also be used to calculate susceptibilities over various groups.
|
||||||
#'
|
#'
|
||||||
#' Code example:
|
#' Code example:
|
||||||
#'
|
#'
|
||||||
#' ```r
|
#' ```r
|
||||||
@@ -163,60 +163,60 @@
|
|||||||
#' group_by(has_sepsis, is_neonate, sex) %>%
|
#' group_by(has_sepsis, is_neonate, sex) %>%
|
||||||
#' wisca(antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"))
|
#' wisca(antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"))
|
||||||
#' ```
|
#' ```
|
||||||
#'
|
#'
|
||||||
#' ### Stepped Approach for Clinical Insight
|
#' ### Stepped Approach for Clinical Insight
|
||||||
#'
|
#'
|
||||||
#' In clinical practice, antimicrobial coverage decisions evolve as more microbiological data becomes available. This theoretical stepped approach ensures empirical coverage can continuously assessed to improve patient outcomes:
|
#' In clinical practice, antimicrobial coverage decisions evolve as more microbiological data becomes available. This theoretical stepped approach ensures empirical coverage can continuously assessed to improve patient outcomes:
|
||||||
#'
|
#'
|
||||||
#' 1. **Initial Empirical Therapy (Admission / Pre-Culture Data)**
|
#' 1. **Initial Empirical Therapy (Admission / Pre-Culture Data)**
|
||||||
#'
|
#'
|
||||||
#' At admission, no pathogen information is available.
|
#' At admission, no pathogen information is available.
|
||||||
#'
|
#'
|
||||||
#' - Action: broad-spectrum coverage is based on local resistance patterns and syndromic antibiograms. Using the pathogen-agnostic yet incidence-weighted WISCA is preferred.
|
#' - Action: broad-spectrum coverage is based on local resistance patterns and syndromic antibiograms. Using the pathogen-agnostic yet incidence-weighted WISCA is preferred.
|
||||||
#' - Code example:
|
#' - Code example:
|
||||||
#'
|
#'
|
||||||
#' ```r
|
#' ```r
|
||||||
#' antibiogram(your_data,
|
#' antibiogram(your_data,
|
||||||
#' antibiotics = selected_regimens,
|
#' antibiotics = selected_regimens,
|
||||||
#' mo_transform = NA) # all pathogens set to `NA`
|
#' mo_transform = NA) # all pathogens set to `NA`
|
||||||
#'
|
#'
|
||||||
#' # preferred: use WISCA
|
#' # preferred: use WISCA
|
||||||
#' wisca(your_data,
|
#' wisca(your_data,
|
||||||
#' antibiotics = selected_regimens)
|
#' antibiotics = selected_regimens)
|
||||||
#' ```
|
#' ```
|
||||||
#'
|
#'
|
||||||
#' 2. **Refinement with Gram Stain Results**
|
#' 2. **Refinement with Gram Stain Results**
|
||||||
#'
|
#'
|
||||||
#' When a blood culture becomes positive, the Gram stain provides an initial and crucial first stratification (Gram-positive vs. Gram-negative).
|
#' When a blood culture becomes positive, the Gram stain provides an initial and crucial first stratification (Gram-positive vs. Gram-negative).
|
||||||
#'
|
#'
|
||||||
#' - Action: narrow coverage based on Gram stain-specific resistance patterns.
|
#' - Action: narrow coverage based on Gram stain-specific resistance patterns.
|
||||||
#' - Code example:
|
#' - Code example:
|
||||||
#'
|
#'
|
||||||
#' ```r
|
#' ```r
|
||||||
#' antibiogram(your_data,
|
#' antibiogram(your_data,
|
||||||
#' antibiotics = selected_regimens,
|
#' antibiotics = selected_regimens,
|
||||||
#' mo_transform = "gramstain") # all pathogens set to Gram-pos/Gram-neg
|
#' mo_transform = "gramstain") # all pathogens set to Gram-pos/Gram-neg
|
||||||
#' ```
|
#' ```
|
||||||
#'
|
#'
|
||||||
#' 3. **Definitive Therapy Based on Species Identification**
|
#' 3. **Definitive Therapy Based on Species Identification**
|
||||||
#'
|
#'
|
||||||
#' After cultivation of the pathogen, full pathogen identification allows precise targeting of therapy.
|
#' After cultivation of the pathogen, full pathogen identification allows precise targeting of therapy.
|
||||||
#'
|
#'
|
||||||
#' - Action: adjust treatment to pathogen-specific antibiograms, minimizing resistance risks.
|
#' - Action: adjust treatment to pathogen-specific antibiograms, minimizing resistance risks.
|
||||||
#' - Code example:
|
#' - Code example:
|
||||||
#'
|
#'
|
||||||
#' ```r
|
#' ```r
|
||||||
#' antibiogram(your_data,
|
#' antibiogram(your_data,
|
||||||
#' antibiotics = selected_regimens,
|
#' antibiotics = selected_regimens,
|
||||||
#' mo_transform = "shortname") # all pathogens set to 'G. species', e.g., E. coli
|
#' mo_transform = "shortname") # all pathogens set to 'G. species', e.g., E. coli
|
||||||
#' ```
|
#' ```
|
||||||
#'
|
#'
|
||||||
#' By structuring antibiograms around this stepped approach, clinicians can make data-driven adjustments at each stage, ensuring optimal empirical and targeted therapy while reducing unnecessary broad-spectrum antimicrobial use.
|
#' By structuring antibiograms around this stepped approach, clinicians can make data-driven adjustments at each stage, ensuring optimal empirical and targeted therapy while reducing unnecessary broad-spectrum antimicrobial use.
|
||||||
#'
|
#'
|
||||||
#' ### Inclusion in Combination Antibiograms
|
#' ### Inclusion in Combination Antibiograms
|
||||||
#'
|
#'
|
||||||
#' Note that for combination antibiograms, it is important to realise that susceptibility can be calculated in two ways, which can be set with the `only_all_tested` argument (default is `FALSE`). See this example for two antimicrobials, Drug A and Drug B, about how [antibiogram()] works to calculate the %SI:
|
#' Note that for combination antibiograms, it is important to realise that susceptibility can be calculated in two ways, which can be set with the `only_all_tested` argument (default is `FALSE`). See this example for two antimicrobials, Drug A and Drug B, about how [antibiogram()] works to calculate the %SI:
|
||||||
#'
|
#'
|
||||||
#' ```
|
#' ```
|
||||||
#' --------------------------------------------------------------------
|
#' --------------------------------------------------------------------
|
||||||
#' only_all_tested = FALSE only_all_tested = TRUE
|
#' only_all_tested = FALSE only_all_tested = TRUE
|
||||||
@@ -235,20 +235,20 @@
|
|||||||
#' <NA> <NA> - - - -
|
#' <NA> <NA> - - - -
|
||||||
#' --------------------------------------------------------------------
|
#' --------------------------------------------------------------------
|
||||||
#' ```
|
#' ```
|
||||||
#'
|
#'
|
||||||
#' ### Plotting
|
#' ### Plotting
|
||||||
#'
|
#'
|
||||||
#' All types of antibiograms as listed above can be plotted (using [ggplot2::autoplot()] or base \R's [plot()] and [barplot()]). As mentioned above, the numeric values of an antibiogram are stored in a long format as the [attribute][attributes()] `long_numeric`. You can retrieve them using `attributes(x)$long_numeric`, where `x` is the outcome of [antibiogram()] or [wisca()].
|
#' All types of antibiograms as listed above can be plotted (using [ggplot2::autoplot()] or base \R's [plot()] and [barplot()]). As mentioned above, the numeric values of an antibiogram are stored in a long format as the [attribute][attributes()] `long_numeric`. You can retrieve them using `attributes(x)$long_numeric`, where `x` is the outcome of [antibiogram()] or [wisca()].
|
||||||
#'
|
#'
|
||||||
#' The outcome of [antibiogram()] can also be used directly in R Markdown / Quarto (i.e., `knitr`) for reports. In this case, [knitr::kable()] will be applied automatically and microorganism names will even be printed in italics at default (see argument `italicise`).
|
#' The outcome of [antibiogram()] can also be used directly in R Markdown / Quarto (i.e., `knitr`) for reports. In this case, [knitr::kable()] will be applied automatically and microorganism names will even be printed in italics at default (see argument `italicise`).
|
||||||
#'
|
#'
|
||||||
#' You can also use functions from specific 'table reporting' packages to transform the output of [antibiogram()] to your needs, e.g. with `flextable::as_flextable()` or `gt::gt()`.
|
#' You can also use functions from specific 'table reporting' packages to transform the output of [antibiogram()] to your needs, e.g. with `flextable::as_flextable()` or `gt::gt()`.
|
||||||
#'
|
#'
|
||||||
#' @section Explaining WISCA:
|
#' @section Explaining WISCA:
|
||||||
#'
|
|
||||||
#' WISCA, as outlined by Bielicki *et al.* (\doi{10.1093/jac/dkv397}), stands for Weighted-Incidence Syndromic Combination Antibiogram, which estimates the probability of adequate empirical antimicrobial regimen coverage for specific infection syndromes. This method leverages a Bayesian decision model with random effects for pathogen incidence and susceptibility, enabling robust estimates in the presence of sparse data.
|
|
||||||
#'
|
#'
|
||||||
#' The Bayesian model assumes conjugate priors for parameter estimation. For example, the coverage probability \eqn{\theta} for a given antimicrobial regimen is modelled using a Beta distribution as a prior:
|
#' WISCA, as outlined by Bielicki *et al.* (\doi{10.1093/jac/dkv397}), stands for Weighted-Incidence Syndromic Combination Antibiogram, which estimates the probability of adequate empirical antimicrobial regimen coverage for specific infection syndromes. This method leverages a Bayesian decision model with random effects for pathogen incidence and susceptibility, enabling robust estimates in the presence of sparse data.
|
||||||
|
#'
|
||||||
|
#' The Bayesian model assumes conjugate priors for parameter estimation. For example, the coverage probability \eqn{\theta} for a given antimicrobial regimen is modelled using a Beta distribution as a prior:
|
||||||
#'
|
#'
|
||||||
#' \deqn{\theta \sim \text{Beta}(\alpha_0, \beta_0)}
|
#' \deqn{\theta \sim \text{Beta}(\alpha_0, \beta_0)}
|
||||||
#'
|
#'
|
||||||
@@ -260,7 +260,7 @@
|
|||||||
#'
|
#'
|
||||||
#' \deqn{\theta | y \sim \text{Beta}(\alpha_0 + y, \beta_0 + n - y)}
|
#' \deqn{\theta | y \sim \text{Beta}(\alpha_0 + y, \beta_0 + n - y)}
|
||||||
#'
|
#'
|
||||||
#' Pathogen incidence, representing the proportion of infections caused by different pathogens, is modelled using a Dirichlet distribution, which is the natural conjugate prior for multinomial outcomes. The Dirichlet distribution is parameterised by a vector of concentration parameters \eqn{\alpha}, where each \eqn{\alpha_i} corresponds to a specific pathogen. The prior is typically chosen to be uniform (\eqn{\alpha_i = 1}), reflecting an assumption of equal prior probability across pathogens.
|
#' Pathogen incidence, representing the proportion of infections caused by different pathogens, is modelled using a Dirichlet distribution, which is the natural conjugate prior for multinomial outcomes. The Dirichlet distribution is parameterised by a vector of concentration parameters \eqn{\alpha}, where each \eqn{\alpha_i} corresponds to a specific pathogen. The prior is typically chosen to be uniform (\eqn{\alpha_i = 1}), reflecting an assumption of equal prior probability across pathogens.
|
||||||
#'
|
#'
|
||||||
#' The posterior distribution of pathogen incidence is then given by:
|
#' The posterior distribution of pathogen incidence is then given by:
|
||||||
#'
|
#'
|
||||||
@@ -280,7 +280,7 @@
|
|||||||
#' \deqn{\text{OR}_{\text{covariate}} = \frac{\exp(\beta_{\text{covariate}})}{\exp(\beta_0)}}
|
#' \deqn{\text{OR}_{\text{covariate}} = \frac{\exp(\beta_{\text{covariate}})}{\exp(\beta_0)}}
|
||||||
#'
|
#'
|
||||||
#' By combining empirical data with prior knowledge, WISCA overcomes the limitations of traditional combination antibiograms, offering disease-specific, patient-stratified estimates with robust uncertainty quantification. This tool is invaluable for antimicrobial stewardship programs and empirical treatment guideline refinement.
|
#' By combining empirical data with prior knowledge, WISCA overcomes the limitations of traditional combination antibiograms, offering disease-specific, patient-stratified estimates with robust uncertainty quantification. This tool is invaluable for antimicrobial stewardship programs and empirical treatment guideline refinement.
|
||||||
#'
|
#'
|
||||||
#' **Note:** WISCA never gives an output on the pathogen/species level, as all incidences and susceptibilities are already weighted for all species.
|
#' **Note:** WISCA never gives an output on the pathogen/species level, as all incidences and susceptibilities are already weighted for all species.
|
||||||
#' @source
|
#' @source
|
||||||
#' * Bielicki JA *et al.* (2016). **Selecting appropriate empirical antibiotic regimens for paediatric bloodstream infections: application of a Bayesian decision model to local and pooled antimicrobial resistance surveillance data** *Journal of Antimicrobial Chemotherapy* 71(3); \doi{10.1093/jac/dkv397}
|
#' * Bielicki JA *et al.* (2016). **Selecting appropriate empirical antibiotic regimens for paediatric bloodstream infections: application of a Bayesian decision model to local and pooled antimicrobial resistance surveillance data** *Journal of Antimicrobial Chemotherapy* 71(3); \doi{10.1093/jac/dkv397}
|
||||||
@@ -307,12 +307,14 @@
|
|||||||
#' antibiogram(example_isolates,
|
#' antibiogram(example_isolates,
|
||||||
#' antibiotics = aminoglycosides(),
|
#' antibiotics = aminoglycosides(),
|
||||||
#' ab_transform = "atc",
|
#' ab_transform = "atc",
|
||||||
#' mo_transform = "gramstain")
|
#' mo_transform = "gramstain"
|
||||||
|
#' )
|
||||||
#'
|
#'
|
||||||
#' antibiogram(example_isolates,
|
#' antibiogram(example_isolates,
|
||||||
#' antibiotics = carbapenems(),
|
#' antibiotics = carbapenems(),
|
||||||
#' ab_transform = "name",
|
#' ab_transform = "name",
|
||||||
#' mo_transform = "name")
|
#' mo_transform = "name"
|
||||||
|
#' )
|
||||||
#'
|
#'
|
||||||
#'
|
#'
|
||||||
#' # Combined antibiogram -------------------------------------------------
|
#' # Combined antibiogram -------------------------------------------------
|
||||||
@@ -320,14 +322,16 @@
|
|||||||
#' # combined antibiotics yield higher empiric coverage
|
#' # combined antibiotics yield higher empiric coverage
|
||||||
#' antibiogram(example_isolates,
|
#' antibiogram(example_isolates,
|
||||||
#' antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
|
#' antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
|
||||||
#' mo_transform = "gramstain")
|
#' mo_transform = "gramstain"
|
||||||
|
#' )
|
||||||
#'
|
#'
|
||||||
#' # names of antibiotics do not need to resemble columns exactly:
|
#' # names of antibiotics do not need to resemble columns exactly:
|
||||||
#' antibiogram(example_isolates,
|
#' antibiogram(example_isolates,
|
||||||
#' antibiotics = c("Cipro", "cipro + genta"),
|
#' antibiotics = c("Cipro", "cipro + genta"),
|
||||||
#' mo_transform = "gramstain",
|
#' mo_transform = "gramstain",
|
||||||
#' ab_transform = "name",
|
#' ab_transform = "name",
|
||||||
#' sep = " & ")
|
#' sep = " & "
|
||||||
|
#' )
|
||||||
#'
|
#'
|
||||||
#'
|
#'
|
||||||
#' # Syndromic antibiogram ------------------------------------------------
|
#' # Syndromic antibiogram ------------------------------------------------
|
||||||
@@ -335,7 +339,8 @@
|
|||||||
#' # the data set could contain a filter for e.g. respiratory specimens
|
#' # the data set could contain a filter for e.g. respiratory specimens
|
||||||
#' antibiogram(example_isolates,
|
#' antibiogram(example_isolates,
|
||||||
#' antibiotics = c(aminoglycosides(), carbapenems()),
|
#' antibiotics = c(aminoglycosides(), carbapenems()),
|
||||||
#' syndromic_group = "ward")
|
#' syndromic_group = "ward"
|
||||||
|
#' )
|
||||||
#'
|
#'
|
||||||
#' # now define a data set with only E. coli
|
#' # now define a data set with only E. coli
|
||||||
#' ex1 <- example_isolates[which(mo_genus() == "Escherichia"), ]
|
#' ex1 <- example_isolates[which(mo_genus() == "Escherichia"), ]
|
||||||
@@ -348,16 +353,18 @@
|
|||||||
#' syndromic_group = ifelse(ex1$ward == "ICU",
|
#' syndromic_group = ifelse(ex1$ward == "ICU",
|
||||||
#' "UCI", "No UCI"
|
#' "UCI", "No UCI"
|
||||||
#' ),
|
#' ),
|
||||||
#' language = "es")
|
#' language = "es"
|
||||||
#'
|
#' )
|
||||||
#'
|
#'
|
||||||
|
#'
|
||||||
#' # WISCA antibiogram ----------------------------------------------------
|
#' # WISCA antibiogram ----------------------------------------------------
|
||||||
#'
|
#'
|
||||||
#' # WISCA are not stratified by species, but rather on syndromes
|
#' # WISCA are not stratified by species, but rather on syndromes
|
||||||
#' antibiogram(example_isolates,
|
#' antibiogram(example_isolates,
|
||||||
#' antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
|
#' antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
|
||||||
#' syndromic_group = "ward",
|
#' syndromic_group = "ward",
|
||||||
#' wisca = TRUE)
|
#' wisca = TRUE
|
||||||
|
#' )
|
||||||
#'
|
#'
|
||||||
#'
|
#'
|
||||||
#' # Print the output for R Markdown / Quarto -----------------------------
|
#' # Print the output for R Markdown / Quarto -----------------------------
|
||||||
@@ -365,7 +372,8 @@
|
|||||||
#' ureido <- antibiogram(example_isolates,
|
#' ureido <- antibiogram(example_isolates,
|
||||||
#' antibiotics = ureidopenicillins(),
|
#' antibiotics = ureidopenicillins(),
|
||||||
#' syndromic_group = "ward",
|
#' syndromic_group = "ward",
|
||||||
#' wisca = TRUE)
|
#' wisca = TRUE
|
||||||
|
#' )
|
||||||
#'
|
#'
|
||||||
#' # in an Rmd file, you would just need to return `ureido` in a chunk,
|
#' # in an Rmd file, you would just need to return `ureido` in a chunk,
|
||||||
#' # but to be explicit here:
|
#' # but to be explicit here:
|
||||||
@@ -378,11 +386,13 @@
|
|||||||
#'
|
#'
|
||||||
#' ab1 <- antibiogram(example_isolates,
|
#' ab1 <- antibiogram(example_isolates,
|
||||||
#' antibiotics = c("AMC", "CIP", "TZP", "TZP+TOB"),
|
#' antibiotics = c("AMC", "CIP", "TZP", "TZP+TOB"),
|
||||||
#' mo_transform = "gramstain")
|
#' mo_transform = "gramstain"
|
||||||
|
#' )
|
||||||
#' ab2 <- antibiogram(example_isolates,
|
#' ab2 <- antibiogram(example_isolates,
|
||||||
#' antibiotics = c("AMC", "CIP", "TZP", "TZP+TOB"),
|
#' antibiotics = c("AMC", "CIP", "TZP", "TZP+TOB"),
|
||||||
#' mo_transform = "gramstain",
|
#' mo_transform = "gramstain",
|
||||||
#' syndromic_group = "ward")
|
#' syndromic_group = "ward"
|
||||||
|
#' )
|
||||||
#'
|
#'
|
||||||
#' if (requireNamespace("ggplot2")) {
|
#' if (requireNamespace("ggplot2")) {
|
||||||
#' ggplot2::autoplot(ab1)
|
#' ggplot2::autoplot(ab1)
|
||||||
@@ -466,7 +476,7 @@ antibiogram.default <- function(x,
|
|||||||
meet_criteria(conf_interval, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE, is_positive = TRUE)
|
meet_criteria(conf_interval, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE, is_positive = TRUE)
|
||||||
meet_criteria(interval_side, allow_class = "character", has_length = 1, is_in = c("two-tailed", "left", "right"))
|
meet_criteria(interval_side, allow_class = "character", has_length = 1, is_in = c("two-tailed", "left", "right"))
|
||||||
meet_criteria(info, allow_class = "logical", has_length = 1)
|
meet_criteria(info, allow_class = "logical", has_length = 1)
|
||||||
|
|
||||||
# try to find columns based on type
|
# try to find columns based on type
|
||||||
if (is.null(col_mo)) {
|
if (is.null(col_mo)) {
|
||||||
col_mo <- search_type_in_df(x = x, type = "mo", info = info)
|
col_mo <- search_type_in_df(x = x, type = "mo", info = info)
|
||||||
@@ -490,7 +500,7 @@ antibiogram.default <- function(x,
|
|||||||
x$`.mo` <- mo_property(x$`.mo`, property = mo_transform, language = language)
|
x$`.mo` <- mo_property(x$`.mo`, property = mo_transform, language = language)
|
||||||
}
|
}
|
||||||
x$`.mo`[is.na(x$`.mo`)] <- "(??)"
|
x$`.mo`[is.na(x$`.mo`)] <- "(??)"
|
||||||
|
|
||||||
# get syndromic groups
|
# get syndromic groups
|
||||||
if (!is.null(syndromic_group)) {
|
if (!is.null(syndromic_group)) {
|
||||||
if (length(syndromic_group) == 1 && syndromic_group %in% colnames(x)) {
|
if (length(syndromic_group) == 1 && syndromic_group %in% colnames(x)) {
|
||||||
@@ -503,7 +513,7 @@ antibiogram.default <- function(x,
|
|||||||
} else {
|
} else {
|
||||||
has_syndromic_group <- FALSE
|
has_syndromic_group <- FALSE
|
||||||
}
|
}
|
||||||
|
|
||||||
# get antibiotics
|
# get antibiotics
|
||||||
ab_trycatch <- tryCatch(colnames(suppressWarnings(x[, antibiotics, drop = FALSE])), error = function(e) NULL)
|
ab_trycatch <- tryCatch(colnames(suppressWarnings(x[, antibiotics, drop = FALSE])), error = function(e) NULL)
|
||||||
if (is.null(ab_trycatch)) {
|
if (is.null(ab_trycatch)) {
|
||||||
@@ -523,11 +533,11 @@ antibiogram.default <- function(x,
|
|||||||
out[!is.na(out)]
|
out[!is.na(out)]
|
||||||
})
|
})
|
||||||
user_ab <- user_ab[unlist(lapply(user_ab, length)) > 0]
|
user_ab <- user_ab[unlist(lapply(user_ab, length)) > 0]
|
||||||
|
|
||||||
if (length(non_existing) > 0) {
|
if (length(non_existing) > 0) {
|
||||||
warning_("The following antibiotics were not available and ignored: ", vector_and(ab_name(non_existing, language = NULL, tolower = TRUE), quotes = FALSE))
|
warning_("The following antibiotics were not available and ignored: ", vector_and(ab_name(non_existing, language = NULL, tolower = TRUE), quotes = FALSE))
|
||||||
}
|
}
|
||||||
|
|
||||||
# make list unique
|
# make list unique
|
||||||
antibiotics <- unique(user_ab)
|
antibiotics <- unique(user_ab)
|
||||||
# go through list to set AMR in combinations
|
# go through list to set AMR in combinations
|
||||||
@@ -564,7 +574,7 @@ antibiogram.default <- function(x,
|
|||||||
} else {
|
} else {
|
||||||
antibiotics <- ab_trycatch
|
antibiotics <- ab_trycatch
|
||||||
}
|
}
|
||||||
|
|
||||||
if (isTRUE(has_syndromic_group)) {
|
if (isTRUE(has_syndromic_group)) {
|
||||||
out <- x %pm>%
|
out <- x %pm>%
|
||||||
pm_select(.syndromic_group, .mo, antibiotics) %pm>%
|
pm_select(.syndromic_group, .mo, antibiotics) %pm>%
|
||||||
@@ -573,8 +583,8 @@ antibiogram.default <- function(x,
|
|||||||
out <- x %pm>%
|
out <- x %pm>%
|
||||||
pm_select(.mo, antibiotics)
|
pm_select(.mo, antibiotics)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
# get numbers of S, I, R (per group)
|
# get numbers of S, I, R (per group)
|
||||||
out <- out %pm>%
|
out <- out %pm>%
|
||||||
bug_drug_combinations(
|
bug_drug_combinations(
|
||||||
@@ -584,9 +594,9 @@ antibiogram.default <- function(x,
|
|||||||
)
|
)
|
||||||
colnames(out)[colnames(out) == "total"] <- "n_tested"
|
colnames(out)[colnames(out) == "total"] <- "n_tested"
|
||||||
colnames(out)[colnames(out) == "total_rows"] <- "n_total"
|
colnames(out)[colnames(out) == "total_rows"] <- "n_total"
|
||||||
|
|
||||||
counts <- out
|
counts <- out
|
||||||
|
|
||||||
if (isTRUE(combine_SI)) {
|
if (isTRUE(combine_SI)) {
|
||||||
out$n_susceptible <- out$S + out$I + out$SDD
|
out$n_susceptible <- out$S + out$I + out$SDD
|
||||||
} else {
|
} else {
|
||||||
@@ -610,13 +620,13 @@ antibiogram.default <- function(x,
|
|||||||
warning_("Number of tested isolates per regimen should exceed ", minimum, " for each species. Coverage estimates might be inaccurate.", call = FALSE)
|
warning_("Number of tested isolates per regimen should exceed ", minimum, " for each species. Coverage estimates might be inaccurate.", call = FALSE)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
if (NROW(out) == 0) {
|
if (NROW(out) == 0) {
|
||||||
return(as_original_data_class(data.frame(), class(x), extra_class = "antibiogram"))
|
return(as_original_data_class(data.frame(), class(x), extra_class = "antibiogram"))
|
||||||
}
|
}
|
||||||
|
|
||||||
out$p_susceptible <- out$n_susceptible / out$n_tested
|
out$p_susceptible <- out$n_susceptible / out$n_tested
|
||||||
|
|
||||||
# add confidence levels
|
# add confidence levels
|
||||||
out$lower_ci <- NA_real_
|
out$lower_ci <- NA_real_
|
||||||
out$upper_ci <- NA_real_
|
out$upper_ci <- NA_real_
|
||||||
@@ -627,7 +637,7 @@ antibiogram.default <- function(x,
|
|||||||
out$upper_ci[r] <- ci[2]
|
out$upper_ci[r] <- ci[2]
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
# regroup for summarising
|
# regroup for summarising
|
||||||
if (isTRUE(has_syndromic_group)) {
|
if (isTRUE(has_syndromic_group)) {
|
||||||
colnames(out)[1] <- "syndromic_group"
|
colnames(out)[1] <- "syndromic_group"
|
||||||
@@ -637,20 +647,22 @@ antibiogram.default <- function(x,
|
|||||||
out <- out %pm>%
|
out <- out %pm>%
|
||||||
pm_group_by(mo, ab)
|
pm_group_by(mo, ab)
|
||||||
}
|
}
|
||||||
|
|
||||||
long_numeric <- out %pm>%
|
long_numeric <- out %pm>%
|
||||||
pm_summarise(coverage = p_susceptible,
|
pm_summarise(
|
||||||
lower_ci = lower_ci,
|
coverage = p_susceptible,
|
||||||
upper_ci = upper_ci,
|
lower_ci = lower_ci,
|
||||||
n_total = n_total,
|
upper_ci = upper_ci,
|
||||||
n_tested = n_tested,
|
n_total = n_total,
|
||||||
n_susceptible = n_susceptible)
|
n_tested = n_tested,
|
||||||
|
n_susceptible = n_susceptible
|
||||||
|
)
|
||||||
|
|
||||||
wisca_parameters <- data.frame()
|
wisca_parameters <- data.frame()
|
||||||
|
|
||||||
if (wisca == TRUE) {
|
if (wisca == TRUE) {
|
||||||
# WISCA ----
|
# WISCA ----
|
||||||
|
|
||||||
if (isTRUE(has_syndromic_group)) {
|
if (isTRUE(has_syndromic_group)) {
|
||||||
colnames(out)[1] <- "syndromic_group"
|
colnames(out)[1] <- "syndromic_group"
|
||||||
out_wisca <- out %pm>%
|
out_wisca <- out %pm>%
|
||||||
@@ -660,14 +672,16 @@ antibiogram.default <- function(x,
|
|||||||
pm_group_by(ab)
|
pm_group_by(ab)
|
||||||
}
|
}
|
||||||
out_wisca <- out_wisca %pm>%
|
out_wisca <- out_wisca %pm>%
|
||||||
pm_summarise(coverage = NA_real_,
|
pm_summarise(
|
||||||
lower_ci = NA_real_,
|
coverage = NA_real_,
|
||||||
upper_ci = NA_real_,
|
lower_ci = NA_real_,
|
||||||
n_total = sum(n_total, na.rm = TRUE),
|
upper_ci = NA_real_,
|
||||||
n_tested = sum(n_tested, na.rm = TRUE),
|
n_total = sum(n_total, na.rm = TRUE),
|
||||||
n_susceptible = sum(n_susceptible, na.rm = TRUE))
|
n_tested = sum(n_tested, na.rm = TRUE),
|
||||||
|
n_susceptible = sum(n_susceptible, na.rm = TRUE)
|
||||||
|
)
|
||||||
out_wisca$p_susceptible <- out_wisca$n_susceptible / out_wisca$n_tested
|
out_wisca$p_susceptible <- out_wisca$n_susceptible / out_wisca$n_tested
|
||||||
|
|
||||||
if (isTRUE(has_syndromic_group)) {
|
if (isTRUE(has_syndromic_group)) {
|
||||||
out$group <- paste(out$syndromic_group, out$ab)
|
out$group <- paste(out$syndromic_group, out$ab)
|
||||||
out_wisca$group <- paste(out_wisca$syndromic_group, out_wisca$ab)
|
out_wisca$group <- paste(out_wisca$syndromic_group, out_wisca$ab)
|
||||||
@@ -675,30 +689,32 @@ antibiogram.default <- function(x,
|
|||||||
out$group <- out$ab
|
out$group <- out$ab
|
||||||
out_wisca$group <- out_wisca$ab
|
out_wisca$group <- out_wisca$ab
|
||||||
}
|
}
|
||||||
|
|
||||||
# create the WISCA parameters, including our priors/posteriors
|
# create the WISCA parameters, including our priors/posteriors
|
||||||
out$gamma_posterior <- NA_real_
|
out$gamma_posterior <- NA_real_
|
||||||
out$beta_posterior1 <- NA_real_
|
out$beta_posterior1 <- NA_real_
|
||||||
out$beta_posterior2 <- NA_real_
|
out$beta_posterior2 <- NA_real_
|
||||||
|
|
||||||
for (i in seq_len(NROW(out))) {
|
for (i in seq_len(NROW(out))) {
|
||||||
if (out$n_tested[i] == 0) {
|
if (out$n_tested[i] == 0) {
|
||||||
next
|
next
|
||||||
}
|
}
|
||||||
|
|
||||||
out_current <- out[i, , drop = FALSE]
|
out_current <- out[i, , drop = FALSE]
|
||||||
priors <- calculate_priors(out_current, combine_SI = combine_SI)
|
priors <- calculate_priors(out_current, combine_SI = combine_SI)
|
||||||
out$gamma_posterior[i] = priors$gamma_posterior
|
out$gamma_posterior[i] <- priors$gamma_posterior
|
||||||
out$beta_posterior1[i] = priors$beta_posterior_1
|
out$beta_posterior1[i] <- priors$beta_posterior_1
|
||||||
out$beta_posterior2[i] = priors$beta_posterior_2
|
out$beta_posterior2[i] <- priors$beta_posterior_2
|
||||||
}
|
}
|
||||||
|
|
||||||
wisca_parameters <- out
|
wisca_parameters <- out
|
||||||
|
|
||||||
progress <- progress_ticker(n = length(unique(wisca_parameters$group)) * simulations,
|
progress <- progress_ticker(
|
||||||
n_min = 25,
|
n = length(unique(wisca_parameters$group)) * simulations,
|
||||||
print = info,
|
n_min = 25,
|
||||||
title = paste("Calculating WISCA for", length(unique(wisca_parameters$group)), "regimens"))
|
print = info,
|
||||||
|
title = paste("Calculating WISCA for", length(unique(wisca_parameters$group)), "regimens")
|
||||||
|
)
|
||||||
on.exit(close(progress))
|
on.exit(close(progress))
|
||||||
|
|
||||||
# run WISCA
|
# run WISCA
|
||||||
@@ -707,11 +723,11 @@ antibiogram.default <- function(x,
|
|||||||
if (sum(params_current$n_tested, na.rm = TRUE) == 0) {
|
if (sum(params_current$n_tested, na.rm = TRUE) == 0) {
|
||||||
next
|
next
|
||||||
}
|
}
|
||||||
|
|
||||||
# Monte Carlo simulation
|
# Monte Carlo simulation
|
||||||
coverage_simulations <- replicate(simulations, {
|
coverage_simulations <- replicate(simulations, {
|
||||||
progress$tick()
|
progress$tick()
|
||||||
|
|
||||||
# simulate pathogen incidence
|
# simulate pathogen incidence
|
||||||
# = Dirichlet (Gamma) parameters
|
# = Dirichlet (Gamma) parameters
|
||||||
random_incidence <- stats::runif(1, min = 0, max = 1)
|
random_incidence <- stats::runif(1, min = 0, max = 1)
|
||||||
@@ -722,7 +738,7 @@ antibiogram.default <- function(x,
|
|||||||
)
|
)
|
||||||
# normalise
|
# normalise
|
||||||
simulated_incidence <- simulated_incidence / sum(simulated_incidence, na.rm = TRUE)
|
simulated_incidence <- simulated_incidence / sum(simulated_incidence, na.rm = TRUE)
|
||||||
|
|
||||||
# simulate susceptibility
|
# simulate susceptibility
|
||||||
# = Beta parameters
|
# = Beta parameters
|
||||||
random_susceptibity <- stats::runif(1, min = 0, max = 1)
|
random_susceptibity <- stats::runif(1, min = 0, max = 1)
|
||||||
@@ -733,7 +749,7 @@ antibiogram.default <- function(x,
|
|||||||
)
|
)
|
||||||
sum(simulated_incidence * simulated_susceptibility, na.rm = TRUE)
|
sum(simulated_incidence * simulated_susceptibility, na.rm = TRUE)
|
||||||
})
|
})
|
||||||
|
|
||||||
# calculate coverage statistics
|
# calculate coverage statistics
|
||||||
coverage_mean <- mean(coverage_simulations)
|
coverage_mean <- mean(coverage_simulations)
|
||||||
if (interval_side == "two-tailed") {
|
if (interval_side == "two-tailed") {
|
||||||
@@ -744,24 +760,24 @@ antibiogram.default <- function(x,
|
|||||||
probs <- c(1 - conf_interval, 1)
|
probs <- c(1 - conf_interval, 1)
|
||||||
}
|
}
|
||||||
coverage_ci <- unname(stats::quantile(coverage_simulations, probs = probs))
|
coverage_ci <- unname(stats::quantile(coverage_simulations, probs = probs))
|
||||||
|
|
||||||
out_wisca$coverage[which(out_wisca$group == group)] <- coverage_mean
|
out_wisca$coverage[which(out_wisca$group == group)] <- coverage_mean
|
||||||
out_wisca$lower_ci[which(out_wisca$group == group)] <- coverage_ci[1]
|
out_wisca$lower_ci[which(out_wisca$group == group)] <- coverage_ci[1]
|
||||||
out_wisca$upper_ci[which(out_wisca$group == group)] <- coverage_ci[2]
|
out_wisca$upper_ci[which(out_wisca$group == group)] <- coverage_ci[2]
|
||||||
}
|
}
|
||||||
# remove progress bar from console
|
# remove progress bar from console
|
||||||
close(progress)
|
close(progress)
|
||||||
|
|
||||||
# prepare for definitive output
|
# prepare for definitive output
|
||||||
out <- out_wisca
|
out <- out_wisca
|
||||||
wisca_parameters <- wisca_parameters[, colnames(wisca_parameters)[!colnames(wisca_parameters) %in% c(levels(NA_sir_), "lower_ci", "upper_ci", "group")], drop = FALSE]
|
wisca_parameters <- wisca_parameters[, colnames(wisca_parameters)[!colnames(wisca_parameters) %in% c(levels(NA_sir_), "lower_ci", "upper_ci", "group")], drop = FALSE]
|
||||||
}
|
}
|
||||||
|
|
||||||
out$digits <- digits # since pm_sumarise() cannot work with an object outside the current frame
|
out$digits <- digits # since pm_sumarise() cannot work with an object outside the current frame
|
||||||
if (isFALSE(wisca)) {
|
if (isFALSE(wisca)) {
|
||||||
out$coverage <- out$p_susceptible
|
out$coverage <- out$p_susceptible
|
||||||
}
|
}
|
||||||
|
|
||||||
# formatting type:
|
# formatting type:
|
||||||
# 1. 5
|
# 1. 5
|
||||||
# 2. 15
|
# 2. 15
|
||||||
@@ -807,7 +823,7 @@ antibiogram.default <- function(x,
|
|||||||
if (formatting_type == 20) out <- out %pm>% pm_summarise(out_value = paste0(round(coverage * 100, digits = digits), "% (", round(lower_ci * 100, digits = digits), "-", round(upper_ci * 100, digits = digits), "%,", n_susceptible, "/", n_tested, ")"))
|
if (formatting_type == 20) out <- out %pm>% pm_summarise(out_value = paste0(round(coverage * 100, digits = digits), "% (", round(lower_ci * 100, digits = digits), "-", round(upper_ci * 100, digits = digits), "%,", n_susceptible, "/", n_tested, ")"))
|
||||||
if (formatting_type == 21) out <- out %pm>% pm_summarise(out_value = paste0(round(coverage * 100, digits = digits), " (", round(lower_ci * 100, digits = digits), "-", round(upper_ci * 100, digits = digits), ",N=", n_susceptible, "/", n_tested, ")"))
|
if (formatting_type == 21) out <- out %pm>% pm_summarise(out_value = paste0(round(coverage * 100, digits = digits), " (", round(lower_ci * 100, digits = digits), "-", round(upper_ci * 100, digits = digits), ",N=", n_susceptible, "/", n_tested, ")"))
|
||||||
if (formatting_type == 22) out <- out %pm>% pm_summarise(out_value = paste0(round(coverage * 100, digits = digits), "% (", round(lower_ci * 100, digits = digits), "-", round(upper_ci * 100, digits = digits), "%,N=", n_susceptible, "/", n_tested, ")"))
|
if (formatting_type == 22) out <- out %pm>% pm_summarise(out_value = paste0(round(coverage * 100, digits = digits), "% (", round(lower_ci * 100, digits = digits), "-", round(upper_ci * 100, digits = digits), "%,N=", n_susceptible, "/", n_tested, ")"))
|
||||||
|
|
||||||
# transform names of antibiotics
|
# transform names of antibiotics
|
||||||
ab_naming_function <- function(x, t, l, s) {
|
ab_naming_function <- function(x, t, l, s) {
|
||||||
x <- strsplit(x, s, fixed = TRUE)
|
x <- strsplit(x, s, fixed = TRUE)
|
||||||
@@ -832,12 +848,12 @@ antibiogram.default <- function(x,
|
|||||||
}
|
}
|
||||||
out$ab <- ab_naming_function(out$ab, t = ab_transform, l = language, s = sep)
|
out$ab <- ab_naming_function(out$ab, t = ab_transform, l = language, s = sep)
|
||||||
long_numeric$ab <- ab_naming_function(long_numeric$ab, t = ab_transform, l = language, s = sep)
|
long_numeric$ab <- ab_naming_function(long_numeric$ab, t = ab_transform, l = language, s = sep)
|
||||||
|
|
||||||
# transform long to wide
|
# transform long to wide
|
||||||
long_to_wide <- function(object) {
|
long_to_wide <- function(object) {
|
||||||
if (wisca == TRUE) {
|
if (wisca == TRUE) {
|
||||||
# column `mo` has already been removed, but we create here a surrogate to make the stats::reshape() work since it needs an identifier
|
# column `mo` has already been removed, but we create here a surrogate to make the stats::reshape() work since it needs an identifier
|
||||||
object$mo <- 1 #seq_len(NROW(object))
|
object$mo <- 1 # seq_len(NROW(object))
|
||||||
}
|
}
|
||||||
object <- object %pm>%
|
object <- object %pm>%
|
||||||
# an unclassed data.frame is required for stats::reshape()
|
# an unclassed data.frame is required for stats::reshape()
|
||||||
@@ -849,12 +865,12 @@ antibiogram.default <- function(x,
|
|||||||
}
|
}
|
||||||
return(object)
|
return(object)
|
||||||
}
|
}
|
||||||
|
|
||||||
# ungroup for long -> wide transformation
|
# ungroup for long -> wide transformation
|
||||||
attr(out, "pm_groups") <- NULL
|
attr(out, "pm_groups") <- NULL
|
||||||
attr(out, "groups") <- NULL
|
attr(out, "groups") <- NULL
|
||||||
class(out) <- class(out)[!class(out) %in% c("grouped_df", "grouped_data")]
|
class(out) <- class(out)[!class(out) %in% c("grouped_df", "grouped_data")]
|
||||||
|
|
||||||
if (isTRUE(has_syndromic_group)) {
|
if (isTRUE(has_syndromic_group)) {
|
||||||
grps <- unique(out$syndromic_group)
|
grps <- unique(out$syndromic_group)
|
||||||
for (i in seq_len(length(grps))) {
|
for (i in seq_len(length(grps))) {
|
||||||
@@ -894,7 +910,7 @@ antibiogram.default <- function(x,
|
|||||||
colnames(new_df)[1] <- translate_AMR("Pathogen", language = language)
|
colnames(new_df)[1] <- translate_AMR("Pathogen", language = language)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
# add n_tested N if indicated
|
# add n_tested N if indicated
|
||||||
if (isTRUE(add_total_n) && isFALSE(wisca)) {
|
if (isTRUE(add_total_n) && isFALSE(wisca)) {
|
||||||
if (isTRUE(has_syndromic_group)) {
|
if (isTRUE(has_syndromic_group)) {
|
||||||
@@ -922,15 +938,16 @@ antibiogram.default <- function(x,
|
|||||||
colnames(new_df)[edit_col] <- paste(colnames(new_df)[edit_col], "(N min-max)")
|
colnames(new_df)[edit_col] <- paste(colnames(new_df)[edit_col], "(N min-max)")
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
out <- structure(as_original_data_class(new_df, class(x), extra_class = "antibiogram"),
|
out <- structure(as_original_data_class(new_df, class(x), extra_class = "antibiogram"),
|
||||||
has_syndromic_group = has_syndromic_group,
|
has_syndromic_group = has_syndromic_group,
|
||||||
combine_SI = combine_SI,
|
combine_SI = combine_SI,
|
||||||
wisca = wisca,
|
wisca = wisca,
|
||||||
conf_interval = conf_interval,
|
conf_interval = conf_interval,
|
||||||
formatting_type = formatting_type,
|
formatting_type = formatting_type,
|
||||||
wisca_parameters = as_original_data_class(wisca_parameters, class(x)),
|
wisca_parameters = as_original_data_class(wisca_parameters, class(x)),
|
||||||
long_numeric = as_original_data_class(long_numeric, class(x)))
|
long_numeric = as_original_data_class(long_numeric, class(x))
|
||||||
|
)
|
||||||
rownames(out) <- NULL
|
rownames(out) <- NULL
|
||||||
out
|
out
|
||||||
}
|
}
|
||||||
@@ -960,16 +977,18 @@ antibiogram.grouped_df <- function(x,
|
|||||||
stop_ifnot(is.null(syndromic_group), "`syndromic_group` must not be set if creating an antibiogram using a grouped tibble. The groups will become the variables over which the antimicrobials are calculated, making `syndromic_groups` redundant.", call = FALSE)
|
stop_ifnot(is.null(syndromic_group), "`syndromic_group` must not be set if creating an antibiogram using a grouped tibble. The groups will become the variables over which the antimicrobials are calculated, making `syndromic_groups` redundant.", call = FALSE)
|
||||||
groups <- attributes(x)$groups
|
groups <- attributes(x)$groups
|
||||||
n_groups <- NROW(groups)
|
n_groups <- NROW(groups)
|
||||||
progress <- progress_ticker(n = n_groups,
|
progress <- progress_ticker(
|
||||||
n_min = 5,
|
n = n_groups,
|
||||||
print = info,
|
n_min = 5,
|
||||||
title = paste("Calculating AMR for", n_groups, "groups"))
|
print = info,
|
||||||
|
title = paste("Calculating AMR for", n_groups, "groups")
|
||||||
|
)
|
||||||
on.exit(close(progress))
|
on.exit(close(progress))
|
||||||
|
|
||||||
out <- NULL
|
out <- NULL
|
||||||
wisca_parameters <- NULL
|
wisca_parameters <- NULL
|
||||||
long_numeric <- NULL
|
long_numeric <- NULL
|
||||||
|
|
||||||
for (i in seq_len(n_groups)) {
|
for (i in seq_len(n_groups)) {
|
||||||
progress$tick()
|
progress$tick()
|
||||||
rows <- unlist(groups[i, ]$.rows)
|
rows <- unlist(groups[i, ]$.rows)
|
||||||
@@ -977,53 +996,54 @@ antibiogram.grouped_df <- function(x,
|
|||||||
next
|
next
|
||||||
}
|
}
|
||||||
new_out <- antibiogram(as.data.frame(x)[rows, , drop = FALSE],
|
new_out <- antibiogram(as.data.frame(x)[rows, , drop = FALSE],
|
||||||
antibiotics = antibiotics,
|
antibiotics = antibiotics,
|
||||||
mo_transform = NULL,
|
mo_transform = NULL,
|
||||||
ab_transform = ab_transform,
|
ab_transform = ab_transform,
|
||||||
syndromic_group = NULL,
|
syndromic_group = NULL,
|
||||||
add_total_n = add_total_n,
|
add_total_n = add_total_n,
|
||||||
only_all_tested = only_all_tested,
|
only_all_tested = only_all_tested,
|
||||||
digits = digits,
|
digits = digits,
|
||||||
formatting_type = formatting_type,
|
formatting_type = formatting_type,
|
||||||
col_mo = col_mo,
|
col_mo = col_mo,
|
||||||
language = language,
|
language = language,
|
||||||
minimum = minimum,
|
minimum = minimum,
|
||||||
combine_SI = combine_SI,
|
combine_SI = combine_SI,
|
||||||
sep = sep,
|
sep = sep,
|
||||||
wisca = wisca,
|
wisca = wisca,
|
||||||
simulations = simulations,
|
simulations = simulations,
|
||||||
conf_interval = conf_interval,
|
conf_interval = conf_interval,
|
||||||
interval_side = interval_side,
|
interval_side = interval_side,
|
||||||
info = FALSE)
|
info = FALSE
|
||||||
|
)
|
||||||
new_wisca_parameters <- attributes(new_out)$wisca_parameters
|
new_wisca_parameters <- attributes(new_out)$wisca_parameters
|
||||||
new_long_numeric <- attributes(new_out)$long_numeric
|
new_long_numeric <- attributes(new_out)$long_numeric
|
||||||
|
|
||||||
if (NROW(new_out) == 0) {
|
if (NROW(new_out) == 0) {
|
||||||
next
|
next
|
||||||
}
|
}
|
||||||
|
|
||||||
# remove first column 'Pathogen' (in whatever language), except WISCA since that never has Pathogen column
|
# remove first column 'Pathogen' (in whatever language), except WISCA since that never has Pathogen column
|
||||||
if (isFALSE(wisca)) {
|
if (isFALSE(wisca)) {
|
||||||
new_out <- new_out[, -1, drop = FALSE]
|
new_out <- new_out[, -1, drop = FALSE]
|
||||||
new_long_numeric <- new_long_numeric[, -1, drop = FALSE]
|
new_long_numeric <- new_long_numeric[, -1, drop = FALSE]
|
||||||
}
|
}
|
||||||
|
|
||||||
# add group names to data set
|
# add group names to data set
|
||||||
for (col in rev(seq_len(NCOL(groups) - 1))) {
|
for (col in rev(seq_len(NCOL(groups) - 1))) {
|
||||||
col_name <- colnames(groups)[col]
|
col_name <- colnames(groups)[col]
|
||||||
col_value <- groups[i, col, drop = TRUE]
|
col_value <- groups[i, col, drop = TRUE]
|
||||||
new_out[, col_name] <- col_value
|
new_out[, col_name] <- col_value
|
||||||
new_out <- new_out[, c(col_name, setdiff(names(new_out), col_name))] # set place to 1st col
|
new_out <- new_out[, c(col_name, setdiff(names(new_out), col_name))] # set place to 1st col
|
||||||
|
|
||||||
if (isTRUE(wisca)) {
|
if (isTRUE(wisca)) {
|
||||||
new_wisca_parameters[, col_name] <- col_value
|
new_wisca_parameters[, col_name] <- col_value
|
||||||
new_wisca_parameters <- new_wisca_parameters[, c(col_name, setdiff(names(new_wisca_parameters), col_name))] # set place to 1st col
|
new_wisca_parameters <- new_wisca_parameters[, c(col_name, setdiff(names(new_wisca_parameters), col_name))] # set place to 1st col
|
||||||
}
|
}
|
||||||
|
|
||||||
new_long_numeric[, col_name] <- col_value
|
new_long_numeric[, col_name] <- col_value
|
||||||
new_long_numeric <- new_long_numeric[, c(col_name, setdiff(names(new_long_numeric), col_name))] # set place to 1st col
|
new_long_numeric <- new_long_numeric[, c(col_name, setdiff(names(new_long_numeric), col_name))] # set place to 1st col
|
||||||
}
|
}
|
||||||
|
|
||||||
if (i == 1) {
|
if (i == 1) {
|
||||||
# the first go
|
# the first go
|
||||||
out <- new_out
|
out <- new_out
|
||||||
@@ -1035,17 +1055,18 @@ antibiogram.grouped_df <- function(x,
|
|||||||
long_numeric <- rbind_AMR(long_numeric, new_long_numeric)
|
long_numeric <- rbind_AMR(long_numeric, new_long_numeric)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
close(progress)
|
close(progress)
|
||||||
|
|
||||||
out <- structure(as_original_data_class(out, class(x), extra_class = "antibiogram"),
|
out <- structure(as_original_data_class(out, class(x), extra_class = "antibiogram"),
|
||||||
has_syndromic_group = FALSE,
|
has_syndromic_group = FALSE,
|
||||||
combine_SI = isTRUE(combine_SI),
|
combine_SI = isTRUE(combine_SI),
|
||||||
wisca = isTRUE(wisca),
|
wisca = isTRUE(wisca),
|
||||||
conf_interval = conf_interval,
|
conf_interval = conf_interval,
|
||||||
formatting_type = formatting_type,
|
formatting_type = formatting_type,
|
||||||
wisca_parameters = as_original_data_class(wisca_parameters, class(x)),
|
wisca_parameters = as_original_data_class(wisca_parameters, class(x)),
|
||||||
long_numeric = as_original_data_class(long_numeric, class(x)))
|
long_numeric = as_original_data_class(long_numeric, class(x))
|
||||||
|
)
|
||||||
rownames(out) <- NULL
|
rownames(out) <- NULL
|
||||||
out
|
out
|
||||||
}
|
}
|
||||||
@@ -1069,25 +1090,27 @@ wisca <- function(x,
|
|||||||
conf_interval = 0.95,
|
conf_interval = 0.95,
|
||||||
interval_side = "two-tailed",
|
interval_side = "two-tailed",
|
||||||
info = interactive()) {
|
info = interactive()) {
|
||||||
antibiogram(x = x,
|
antibiogram(
|
||||||
antibiotics = antibiotics,
|
x = x,
|
||||||
ab_transform = ab_transform,
|
antibiotics = antibiotics,
|
||||||
mo_transform = NULL,
|
ab_transform = ab_transform,
|
||||||
syndromic_group = syndromic_group,
|
mo_transform = NULL,
|
||||||
add_total_n = add_total_n,
|
syndromic_group = syndromic_group,
|
||||||
only_all_tested = only_all_tested,
|
add_total_n = add_total_n,
|
||||||
digits = digits,
|
only_all_tested = only_all_tested,
|
||||||
formatting_type = formatting_type,
|
digits = digits,
|
||||||
col_mo = col_mo,
|
formatting_type = formatting_type,
|
||||||
language = language,
|
col_mo = col_mo,
|
||||||
minimum = minimum,
|
language = language,
|
||||||
combine_SI = combine_SI,
|
minimum = minimum,
|
||||||
sep = sep,
|
combine_SI = combine_SI,
|
||||||
wisca = TRUE,
|
sep = sep,
|
||||||
simulations = simulations,
|
wisca = TRUE,
|
||||||
conf_interval = conf_interval,
|
simulations = simulations,
|
||||||
interval_side = interval_side,
|
conf_interval = conf_interval,
|
||||||
info = info)
|
interval_side = interval_side,
|
||||||
|
info = info
|
||||||
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
#' @export
|
#' @export
|
||||||
@@ -1100,16 +1123,16 @@ retrieve_wisca_parameters <- function(wisca_model, ...) {
|
|||||||
|
|
||||||
calculate_priors <- function(data, combine_SI = TRUE) {
|
calculate_priors <- function(data, combine_SI = TRUE) {
|
||||||
# Pathogen incidence (Dirichlet distribution)
|
# Pathogen incidence (Dirichlet distribution)
|
||||||
gamma_prior <- rep(1, length(unique(data$mo))) # Dirichlet prior
|
gamma_prior <- rep(1, length(unique(data$mo))) # Dirichlet prior
|
||||||
gamma_posterior <- gamma_prior + data$n_total # Posterior parameters
|
gamma_posterior <- gamma_prior + data$n_total # Posterior parameters
|
||||||
|
|
||||||
# Regimen susceptibility (Beta distribution)
|
# Regimen susceptibility (Beta distribution)
|
||||||
beta_prior <- rep(1, length(unique(data$mo))) # Beta prior
|
beta_prior <- rep(1, length(unique(data$mo))) # Beta prior
|
||||||
r <- data$n_susceptible # Number of pathogens tested susceptible
|
r <- data$n_susceptible # Number of pathogens tested susceptible
|
||||||
n <- data$n_tested # n_tested tested
|
n <- data$n_tested # n_tested tested
|
||||||
beta_posterior_1 <- beta_prior + r # Posterior alpha
|
beta_posterior_1 <- beta_prior + r # Posterior alpha
|
||||||
beta_posterior_2 <- beta_prior + (n - r) # Posterior beta
|
beta_posterior_2 <- beta_prior + (n - r) # Posterior beta
|
||||||
|
|
||||||
# Return parameters as a list
|
# Return parameters as a list
|
||||||
list(
|
list(
|
||||||
gamma_posterior = gamma_posterior,
|
gamma_posterior = gamma_posterior,
|
||||||
@@ -1137,9 +1160,11 @@ tbl_format_footer.antibiogram <- function(x, ...) {
|
|||||||
if (NROW(x) == 0) {
|
if (NROW(x) == 0) {
|
||||||
return(footer)
|
return(footer)
|
||||||
}
|
}
|
||||||
c(footer, font_subtle(paste0("# Use `plot()` or `ggplot2::autoplot()` to create a plot of this antibiogram,\n",
|
c(footer, font_subtle(paste0(
|
||||||
"# or use it directly in R Markdown or ",
|
"# Use `plot()` or `ggplot2::autoplot()` to create a plot of this antibiogram,\n",
|
||||||
font_url("https://quarto.org", "Quarto"), ", see ", word_wrap("?antibiogram"))))
|
"# or use it directly in R Markdown or ",
|
||||||
|
font_url("https://quarto.org", "Quarto"), ", see ", word_wrap("?antibiogram")
|
||||||
|
)))
|
||||||
}
|
}
|
||||||
|
|
||||||
#' @export
|
#' @export
|
||||||
@@ -1148,7 +1173,8 @@ plot.antibiogram <- function(x, ...) {
|
|||||||
df <- attributes(x)$long_numeric
|
df <- attributes(x)$long_numeric
|
||||||
if (!"mo" %in% colnames(df)) {
|
if (!"mo" %in% colnames(df)) {
|
||||||
stop_("Plotting antibiograms using `plot()` is only possible if they were not created using dplyr groups. See `?antibiogram` for how to retrieve numeric values in a long format for advanced plotting.",
|
stop_("Plotting antibiograms using `plot()` is only possible if they were not created using dplyr groups. See `?antibiogram` for how to retrieve numeric values in a long format for advanced plotting.",
|
||||||
call = FALSE)
|
call = FALSE
|
||||||
|
)
|
||||||
}
|
}
|
||||||
if ("syndromic_group" %in% colnames(df)) {
|
if ("syndromic_group" %in% colnames(df)) {
|
||||||
# barplot in base R does not support facets - paste columns together
|
# barplot in base R does not support facets - paste columns together
|
||||||
@@ -1160,11 +1186,11 @@ plot.antibiogram <- function(x, ...) {
|
|||||||
mfrow_old <- graphics::par()$mfrow
|
mfrow_old <- graphics::par()$mfrow
|
||||||
sqrt_levels <- sqrt(length(mo_levels))
|
sqrt_levels <- sqrt(length(mo_levels))
|
||||||
graphics::par(mfrow = c(ceiling(sqrt_levels), floor(sqrt_levels)))
|
graphics::par(mfrow = c(ceiling(sqrt_levels), floor(sqrt_levels)))
|
||||||
|
|
||||||
for (i in seq_along(mo_levels)) {
|
for (i in seq_along(mo_levels)) {
|
||||||
mo <- mo_levels[i]
|
mo <- mo_levels[i]
|
||||||
df_sub <- df[df$mo == mo, , drop = FALSE]
|
df_sub <- df[df$mo == mo, , drop = FALSE]
|
||||||
|
|
||||||
bp <- barplot(
|
bp <- barplot(
|
||||||
height = df_sub$coverage * 100,
|
height = df_sub$coverage * 100,
|
||||||
xlab = NULL,
|
xlab = NULL,
|
||||||
@@ -1175,18 +1201,18 @@ plot.antibiogram <- function(x, ...) {
|
|||||||
main = mo,
|
main = mo,
|
||||||
legend = NULL
|
legend = NULL
|
||||||
)
|
)
|
||||||
|
|
||||||
if (isTRUE(attributes(x)$wisca)) {
|
if (isTRUE(attributes(x)$wisca)) {
|
||||||
lower_ci <- df_sub$lower_ci * 100
|
lower_ci <- df_sub$lower_ci * 100
|
||||||
upper_ci <- df_sub$upper_ci * 100
|
upper_ci <- df_sub$upper_ci * 100
|
||||||
arrows(
|
arrows(
|
||||||
x0 = bp, y0 = lower_ci, # Start of error bar (lower bound)
|
x0 = bp, y0 = lower_ci, # Start of error bar (lower bound)
|
||||||
x1 = bp, y1 = upper_ci, # End of error bar (upper bound)
|
x1 = bp, y1 = upper_ci, # End of error bar (upper bound)
|
||||||
angle = 90, code = 3, length = 0.05, col = "black"
|
angle = 90, code = 3, length = 0.05, col = "black"
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
graphics::par(mfrow = mfrow_old)
|
graphics::par(mfrow = mfrow_old)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -1203,18 +1229,20 @@ autoplot.antibiogram <- function(object, ...) {
|
|||||||
df <- attributes(object)$long_numeric
|
df <- attributes(object)$long_numeric
|
||||||
if (!"mo" %in% colnames(df)) {
|
if (!"mo" %in% colnames(df)) {
|
||||||
stop_("Plotting antibiograms using `autoplot()` is only possible if they were not created using dplyr groups. See `?antibiogram` for how to retrieve numeric values in a long format for advanced plotting.",
|
stop_("Plotting antibiograms using `autoplot()` is only possible if they were not created using dplyr groups. See `?antibiogram` for how to retrieve numeric values in a long format for advanced plotting.",
|
||||||
call = FALSE)
|
call = FALSE
|
||||||
|
)
|
||||||
}
|
}
|
||||||
out <- ggplot2::ggplot(df,
|
out <- ggplot2::ggplot(df,
|
||||||
mapping = ggplot2::aes(
|
mapping = ggplot2::aes(
|
||||||
x = ab,
|
x = ab,
|
||||||
y = coverage * 100,
|
y = coverage * 100,
|
||||||
fill = if ("syndromic_group" %in% colnames(df)) {
|
fill = if ("syndromic_group" %in% colnames(df)) {
|
||||||
syndromic_group
|
syndromic_group
|
||||||
} else {
|
} else {
|
||||||
NULL
|
NULL
|
||||||
}
|
}
|
||||||
)) +
|
)
|
||||||
|
) +
|
||||||
ggplot2::geom_col(position = ggplot2::position_dodge2(preserve = "single")) +
|
ggplot2::geom_col(position = ggplot2::position_dodge2(preserve = "single")) +
|
||||||
ggplot2::facet_wrap("mo") +
|
ggplot2::facet_wrap("mo") +
|
||||||
ggplot2::labs(
|
ggplot2::labs(
|
||||||
@@ -1227,10 +1255,12 @@ autoplot.antibiogram <- function(object, ...) {
|
|||||||
}
|
}
|
||||||
)
|
)
|
||||||
if (isTRUE(attributes(object)$wisca)) {
|
if (isTRUE(attributes(object)$wisca)) {
|
||||||
out <- out +
|
out <- out +
|
||||||
ggplot2::geom_errorbar(mapping = ggplot2::aes(ymin = lower_ci * 100, ymax = upper_ci * 100),
|
ggplot2::geom_errorbar(
|
||||||
position = ggplot2::position_dodge2(preserve = "single"),
|
mapping = ggplot2::aes(ymin = lower_ci * 100, ymax = upper_ci * 100),
|
||||||
width = 0.5)
|
position = ggplot2::position_dodge2(preserve = "single"),
|
||||||
|
width = 0.5
|
||||||
|
)
|
||||||
}
|
}
|
||||||
out
|
out
|
||||||
}
|
}
|
||||||
@@ -1244,9 +1274,9 @@ knit_print.antibiogram <- function(x, italicise = TRUE, na = getOption("knitr.ka
|
|||||||
stop_ifnot_installed("knitr")
|
stop_ifnot_installed("knitr")
|
||||||
meet_criteria(italicise, allow_class = "logical", has_length = 1)
|
meet_criteria(italicise, allow_class = "logical", has_length = 1)
|
||||||
meet_criteria(na, allow_class = "character", has_length = 1, allow_NA = TRUE)
|
meet_criteria(na, allow_class = "character", has_length = 1, allow_NA = TRUE)
|
||||||
|
|
||||||
add_MO_lookup_to_AMR_env()
|
add_MO_lookup_to_AMR_env()
|
||||||
|
|
||||||
cols_with_mo_names <- vapply(FUN.VALUE = logical(1), x, function(x) any(x %in% AMR_env$MO_lookup$fullname, na.rm = TRUE))
|
cols_with_mo_names <- vapply(FUN.VALUE = logical(1), x, function(x) any(x %in% AMR_env$MO_lookup$fullname, na.rm = TRUE))
|
||||||
if (any(cols_with_mo_names)) {
|
if (any(cols_with_mo_names)) {
|
||||||
for (i in which(cols_with_mo_names)) {
|
for (i in which(cols_with_mo_names)) {
|
||||||
@@ -1254,11 +1284,11 @@ knit_print.antibiogram <- function(x, italicise = TRUE, na = getOption("knitr.ka
|
|||||||
x[[i]] <- italicise_taxonomy(x[[i]], type = "markdown")
|
x[[i]] <- italicise_taxonomy(x[[i]], type = "markdown")
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
old_option <- getOption("knitr.kable.NA")
|
old_option <- getOption("knitr.kable.NA")
|
||||||
options(knitr.kable.NA = na)
|
options(knitr.kable.NA = na)
|
||||||
on.exit(options(knitr.kable.NA = old_option))
|
on.exit(options(knitr.kable.NA = old_option))
|
||||||
|
|
||||||
out <- paste(c("", "", knitr::kable(x, ..., output = FALSE)), collapse = "\n")
|
out <- paste(c("", "", knitr::kable(x, ..., output = FALSE)), collapse = "\n")
|
||||||
knitr::asis_output(out)
|
knitr::asis_output(out)
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -128,7 +128,7 @@ atc_online_property <- function(atc_code,
|
|||||||
|
|
||||||
for (i in seq_len(length(atc_code))) {
|
for (i in seq_len(length(atc_code))) {
|
||||||
progress$tick()
|
progress$tick()
|
||||||
|
|
||||||
if (is.na(atc_code[i])) {
|
if (is.na(atc_code[i])) {
|
||||||
next
|
next
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -127,13 +127,15 @@ bug_drug_combinations <- function(x,
|
|||||||
# turn and merge everything
|
# turn and merge everything
|
||||||
pivot <- lapply(x_mo_filter, function(x) {
|
pivot <- lapply(x_mo_filter, function(x) {
|
||||||
m <- as.matrix(table(as.sir(x), useNA = "always"))
|
m <- as.matrix(table(as.sir(x), useNA = "always"))
|
||||||
data.frame(S = m["S", ],
|
data.frame(
|
||||||
SDD = m["SDD", ],
|
S = m["S", ],
|
||||||
I = m["I", ],
|
SDD = m["SDD", ],
|
||||||
R = m["R", ],
|
I = m["I", ],
|
||||||
NI = m["NI", ],
|
R = m["R", ],
|
||||||
na = m[which(is.na(rownames(m))), ],
|
NI = m["NI", ],
|
||||||
stringsAsFactors = FALSE)
|
na = m[which(is.na(rownames(m))), ],
|
||||||
|
stringsAsFactors = FALSE
|
||||||
|
)
|
||||||
})
|
})
|
||||||
merged <- do.call(rbind_AMR, pivot)
|
merged <- do.call(rbind_AMR, pivot)
|
||||||
out_group <- data.frame(
|
out_group <- data.frame(
|
||||||
@@ -172,20 +174,20 @@ bug_drug_combinations <- function(x,
|
|||||||
}
|
}
|
||||||
res
|
res
|
||||||
}
|
}
|
||||||
|
|
||||||
if (data_has_groups) {
|
if (data_has_groups) {
|
||||||
out <- apply_group(x, "run_it", groups)
|
out <- apply_group(x, "run_it", groups)
|
||||||
} else {
|
} else {
|
||||||
out <- run_it(x)
|
out <- run_it(x)
|
||||||
}
|
}
|
||||||
|
|
||||||
if (include_n_rows == FALSE) {
|
if (include_n_rows == FALSE) {
|
||||||
out <- out[, colnames(out)[colnames(out) != "total_rows"], drop = FALSE]
|
out <- out[, colnames(out)[colnames(out) != "total_rows"], drop = FALSE]
|
||||||
}
|
}
|
||||||
|
|
||||||
out <- as_original_data_class(out, class(x.bak)) # will remove tibble groups
|
out <- as_original_data_class(out, class(x.bak)) # will remove tibble groups
|
||||||
out <- out %pm>% pm_arrange(mo, ab)
|
out <- out %pm>% pm_arrange(mo, ab)
|
||||||
class(out) <- c("bug_drug_combinations", if(data_has_groups) "grouped" else NULL, class(out))
|
class(out) <- c("bug_drug_combinations", if (data_has_groups) "grouped" else NULL, class(out))
|
||||||
rownames(out) <- NULL
|
rownames(out) <- NULL
|
||||||
out
|
out
|
||||||
}
|
}
|
||||||
|
|||||||
24
R/count.R
24
R/count.R
@@ -167,9 +167,9 @@ count_SI <- function(..., only_all_tested = FALSE) {
|
|||||||
}
|
}
|
||||||
tryCatch(
|
tryCatch(
|
||||||
sir_calc(...,
|
sir_calc(...,
|
||||||
ab_result = c("S", "SDD", "I"),
|
ab_result = c("S", "SDD", "I"),
|
||||||
only_all_tested = only_all_tested,
|
only_all_tested = only_all_tested,
|
||||||
only_count = TRUE
|
only_count = TRUE
|
||||||
),
|
),
|
||||||
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
|
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
|
||||||
)
|
)
|
||||||
@@ -183,9 +183,9 @@ count_I <- function(..., only_all_tested = FALSE) {
|
|||||||
}
|
}
|
||||||
tryCatch(
|
tryCatch(
|
||||||
sir_calc(...,
|
sir_calc(...,
|
||||||
ab_result = c("I", "SDD"),
|
ab_result = c("I", "SDD"),
|
||||||
only_all_tested = only_all_tested,
|
only_all_tested = only_all_tested,
|
||||||
only_count = TRUE
|
only_count = TRUE
|
||||||
),
|
),
|
||||||
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
|
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
|
||||||
)
|
)
|
||||||
@@ -199,9 +199,9 @@ count_IR <- function(..., only_all_tested = FALSE) {
|
|||||||
}
|
}
|
||||||
tryCatch(
|
tryCatch(
|
||||||
sir_calc(...,
|
sir_calc(...,
|
||||||
ab_result = c("I", "SDD", "R"),
|
ab_result = c("I", "SDD", "R"),
|
||||||
only_all_tested = only_all_tested,
|
only_all_tested = only_all_tested,
|
||||||
only_count = TRUE
|
only_count = TRUE
|
||||||
),
|
),
|
||||||
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
|
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
|
||||||
)
|
)
|
||||||
@@ -212,9 +212,9 @@ count_IR <- function(..., only_all_tested = FALSE) {
|
|||||||
count_R <- function(..., only_all_tested = FALSE) {
|
count_R <- function(..., only_all_tested = FALSE) {
|
||||||
tryCatch(
|
tryCatch(
|
||||||
sir_calc(...,
|
sir_calc(...,
|
||||||
ab_result = "R",
|
ab_result = "R",
|
||||||
only_all_tested = only_all_tested,
|
only_all_tested = only_all_tested,
|
||||||
only_count = TRUE
|
only_count = TRUE
|
||||||
),
|
),
|
||||||
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
|
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
|
||||||
)
|
)
|
||||||
|
|||||||
@@ -90,16 +90,16 @@
|
|||||||
#' ```
|
#' ```
|
||||||
#'
|
#'
|
||||||
#' ### Usage of multiple antibiotics and antibiotic group names
|
#' ### Usage of multiple antibiotics and antibiotic group names
|
||||||
#'
|
#'
|
||||||
#' You can define antibiotic groups instead of single antibiotics for the rule consequence, which is the part *after* the tilde (~). In the examples above, the antibiotic group `aminopenicillins` includes both ampicillin and amoxicillin.
|
#' You can define antibiotic groups instead of single antibiotics for the rule consequence, which is the part *after* the tilde (~). In the examples above, the antibiotic group `aminopenicillins` includes both ampicillin and amoxicillin.
|
||||||
#'
|
#'
|
||||||
#' Rules can also be applied to multiple antibiotics and antibiotic groups simultaneously. Use the `c()` function to combine multiple antibiotics. For instance, the following example sets all aminopenicillins and ureidopenicillins to "R" if column TZP (piperacillin/tazobactam) is "R":
|
#' Rules can also be applied to multiple antibiotics and antibiotic groups simultaneously. Use the `c()` function to combine multiple antibiotics. For instance, the following example sets all aminopenicillins and ureidopenicillins to "R" if column TZP (piperacillin/tazobactam) is "R":
|
||||||
#'
|
#'
|
||||||
#' ```r
|
#' ```r
|
||||||
#' x <- custom_eucast_rules(TZP == "R" ~ c(aminopenicillins, ureidopenicillins) == "R")
|
#' x <- custom_eucast_rules(TZP == "R" ~ c(aminopenicillins, ureidopenicillins) == "R")
|
||||||
#' x
|
#' x
|
||||||
#' #> A set of custom EUCAST rules:
|
#' #> A set of custom EUCAST rules:
|
||||||
#' #>
|
#' #>
|
||||||
#' #> 1. If TZP is "R" then set to "R":
|
#' #> 1. If TZP is "R" then set to "R":
|
||||||
#' #> amoxicillin (AMX), ampicillin (AMP), azlocillin (AZL), mezlocillin (MEZ), piperacillin (PIP), piperacillin/tazobactam (TZP)
|
#' #> amoxicillin (AMX), ampicillin (AMP), azlocillin (AZL), mezlocillin (MEZ), piperacillin (PIP), piperacillin/tazobactam (TZP)
|
||||||
#' ```
|
#' ```
|
||||||
@@ -169,7 +169,7 @@ custom_eucast_rules <- function(...) {
|
|||||||
"the result of rule ", i, " (the part after the `~`) must contain `==`, such as in `... ~ ampicillin == \"R\"`, see `?custom_eucast_rules`"
|
"the result of rule ", i, " (the part after the `~`) must contain `==`, such as in `... ~ ampicillin == \"R\"`, see `?custom_eucast_rules`"
|
||||||
)
|
)
|
||||||
result_group <- as.character(result)[[2]]
|
result_group <- as.character(result)[[2]]
|
||||||
result_group<- as.character(str2lang(result_group))
|
result_group <- as.character(str2lang(result_group))
|
||||||
result_group <- result_group[result_group != "c"]
|
result_group <- result_group[result_group != "c"]
|
||||||
result_group_agents <- character(0)
|
result_group_agents <- character(0)
|
||||||
for (j in seq_len(length(result_group))) {
|
for (j in seq_len(length(result_group))) {
|
||||||
@@ -178,13 +178,15 @@ custom_eucast_rules <- function(...) {
|
|||||||
result_group[j] <- paste0(result_group[j], "s")
|
result_group[j] <- paste0(result_group[j], "s")
|
||||||
}
|
}
|
||||||
if (paste0("AB_", toupper(result_group[j])) %in% DEFINED_AB_GROUPS) {
|
if (paste0("AB_", toupper(result_group[j])) %in% DEFINED_AB_GROUPS) {
|
||||||
result_group_agents <- c(result_group_agents,
|
result_group_agents <- c(
|
||||||
eval(parse(text = paste0("AB_", toupper(result_group[j]))), envir = asNamespace("AMR")))
|
result_group_agents,
|
||||||
|
eval(parse(text = paste0("AB_", toupper(result_group[j]))), envir = asNamespace("AMR"))
|
||||||
|
)
|
||||||
} else {
|
} else {
|
||||||
out_group <- tryCatch(
|
out_group <- tryCatch(
|
||||||
suppressWarnings(as.ab(result_group[j],
|
suppressWarnings(as.ab(result_group[j],
|
||||||
fast_mode = TRUE,
|
fast_mode = TRUE,
|
||||||
flag_multiple_results = FALSE
|
flag_multiple_results = FALSE
|
||||||
)),
|
)),
|
||||||
error = function(e) NA_character_
|
error = function(e) NA_character_
|
||||||
)
|
)
|
||||||
@@ -194,7 +196,7 @@ custom_eucast_rules <- function(...) {
|
|||||||
}
|
}
|
||||||
}
|
}
|
||||||
result_group_agents <- result_group_agents[!is.na(result_group_agents)]
|
result_group_agents <- result_group_agents[!is.na(result_group_agents)]
|
||||||
|
|
||||||
stop_if(
|
stop_if(
|
||||||
length(result_group_agents) == 0,
|
length(result_group_agents) == 0,
|
||||||
"this result of rule ", i, " could not be translated to a single antimicrobial drug/group: \"",
|
"this result of rule ", i, " could not be translated to a single antimicrobial drug/group: \"",
|
||||||
|
|||||||
@@ -250,12 +250,15 @@ add_custom_microorganisms <- function(x) {
|
|||||||
"_",
|
"_",
|
||||||
trimws(
|
trimws(
|
||||||
paste(abbreviate_mo(x$genus, 5),
|
paste(abbreviate_mo(x$genus, 5),
|
||||||
abbreviate_mo(x$species, 4, hyphen_as_space = TRUE),
|
abbreviate_mo(x$species, 4, hyphen_as_space = TRUE),
|
||||||
abbreviate_mo(x$subspecies, 4, hyphen_as_space = TRUE),
|
abbreviate_mo(x$subspecies, 4, hyphen_as_space = TRUE),
|
||||||
sep = "_"),
|
sep = "_"
|
||||||
whitespace = "_"))
|
),
|
||||||
|
whitespace = "_"
|
||||||
|
)
|
||||||
|
)
|
||||||
stop_if(anyDuplicated(c(as.character(AMR_env$MO_lookup$mo), x$mo)), "MO codes must be unique and not match existing MO codes of the AMR package")
|
stop_if(anyDuplicated(c(as.character(AMR_env$MO_lookup$mo), x$mo)), "MO codes must be unique and not match existing MO codes of the AMR package")
|
||||||
|
|
||||||
# add to package ----
|
# add to package ----
|
||||||
AMR_env$custom_mo_codes <- c(AMR_env$custom_mo_codes, x$mo)
|
AMR_env$custom_mo_codes <- c(AMR_env$custom_mo_codes, x$mo)
|
||||||
class(AMR_env$MO_lookup$mo) <- "character"
|
class(AMR_env$MO_lookup$mo) <- "character"
|
||||||
@@ -309,19 +312,25 @@ abbreviate_mo <- function(x, minlength = 5, prefix = "", hyphen_as_space = FALSE
|
|||||||
}
|
}
|
||||||
# keep a starting Latin ae
|
# keep a starting Latin ae
|
||||||
suppressWarnings(
|
suppressWarnings(
|
||||||
gsub("(\u00C6|\u00E6)+",
|
gsub(
|
||||||
"AE",
|
"(\u00C6|\u00E6)+",
|
||||||
toupper(
|
"AE",
|
||||||
paste0(prefix,
|
toupper(
|
||||||
abbreviate(
|
paste0(
|
||||||
gsub("^ae",
|
prefix,
|
||||||
"\u00E6\u00E6",
|
abbreviate(
|
||||||
x,
|
gsub("^ae",
|
||||||
ignore.case = TRUE),
|
"\u00E6\u00E6",
|
||||||
minlength = minlength,
|
x,
|
||||||
use.classes = TRUE,
|
ignore.case = TRUE
|
||||||
method = "both.sides",
|
),
|
||||||
...
|
minlength = minlength,
|
||||||
))))
|
use.classes = TRUE,
|
||||||
|
method = "both.sides",
|
||||||
|
...
|
||||||
|
)
|
||||||
|
)
|
||||||
|
)
|
||||||
|
)
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|||||||
30
R/data.R
30
R/data.R
@@ -86,7 +86,7 @@
|
|||||||
#'
|
#'
|
||||||
#' @description
|
#' @description
|
||||||
#' A data set containing the full microbial taxonomy (**last updated: `r documentation_date(max(TAXONOMY_VERSION$GBIF$accessed_date, TAXONOMY_VERSION$LPSN$accessed_date, TAXONOMY_VERSION$MycoBank$accessed_date))`**) of `r nr2char(length(unique(microorganisms$kingdom[!microorganisms$kingdom %like% "unknown"])))` kingdoms. This data set is the backbone of this `AMR` package. MO codes can be looked up using [as.mo()] and microorganism properties can be looked up using any of the [`mo_*`][mo_property()] functions.
|
#' A data set containing the full microbial taxonomy (**last updated: `r documentation_date(max(TAXONOMY_VERSION$GBIF$accessed_date, TAXONOMY_VERSION$LPSN$accessed_date, TAXONOMY_VERSION$MycoBank$accessed_date))`**) of `r nr2char(length(unique(microorganisms$kingdom[!microorganisms$kingdom %like% "unknown"])))` kingdoms. This data set is the backbone of this `AMR` package. MO codes can be looked up using [as.mo()] and microorganism properties can be looked up using any of the [`mo_*`][mo_property()] functions.
|
||||||
#'
|
#'
|
||||||
#' This data set is carefully crafted, yet made 100% reproducible from public and authoritative taxonomic sources (using [this script](https://github.com/msberends/AMR/blob/main/data-raw/reproduction_of_microorganisms.R)), namely: *`r TAXONOMY_VERSION$LPSN$name`* for bacteria, *`r TAXONOMY_VERSION$MycoBank$name`* for fungi, and *`r TAXONOMY_VERSION$GBIF$name`* for all others taxons.
|
#' This data set is carefully crafted, yet made 100% reproducible from public and authoritative taxonomic sources (using [this script](https://github.com/msberends/AMR/blob/main/data-raw/reproduction_of_microorganisms.R)), namely: *`r TAXONOMY_VERSION$LPSN$name`* for bacteria, *`r TAXONOMY_VERSION$MycoBank$name`* for fungi, and *`r TAXONOMY_VERSION$GBIF$name`* for all others taxons.
|
||||||
#' @format A [tibble][tibble::tibble] with `r format(nrow(microorganisms), big.mark = " ")` observations and `r ncol(microorganisms)` variables:
|
#' @format A [tibble][tibble::tibble] with `r format(nrow(microorganisms), big.mark = " ")` observations and `r ncol(microorganisms)` variables:
|
||||||
#' - `mo`\cr ID of microorganism as used by this package. ***This is a unique identifier.***
|
#' - `mo`\cr ID of microorganism as used by this package. ***This is a unique identifier.***
|
||||||
@@ -141,7 +141,7 @@
|
|||||||
#' Taxonomic entries were imported in this order of importance:
|
#' Taxonomic entries were imported in this order of importance:
|
||||||
#' 1. `r TAXONOMY_VERSION$LPSN$name`:\cr\cr
|
#' 1. `r TAXONOMY_VERSION$LPSN$name`:\cr\cr
|
||||||
#' `r TAXONOMY_VERSION$LPSN$citation` Accessed from <`r TAXONOMY_VERSION$LPSN$url`> on `r documentation_date(TAXONOMY_VERSION$LPSN$accessed_date)`.
|
#' `r TAXONOMY_VERSION$LPSN$citation` Accessed from <`r TAXONOMY_VERSION$LPSN$url`> on `r documentation_date(TAXONOMY_VERSION$LPSN$accessed_date)`.
|
||||||
#'
|
#'
|
||||||
#' 2. `r TAXONOMY_VERSION$MycoBank$name`:\cr\cr
|
#' 2. `r TAXONOMY_VERSION$MycoBank$name`:\cr\cr
|
||||||
#' `r TAXONOMY_VERSION$MycoBank$citation` Accessed from <`r TAXONOMY_VERSION$MycoBank$url`> on `r documentation_date(TAXONOMY_VERSION$MycoBank$accessed_date)`.
|
#' `r TAXONOMY_VERSION$MycoBank$citation` Accessed from <`r TAXONOMY_VERSION$MycoBank$url`> on `r documentation_date(TAXONOMY_VERSION$MycoBank$accessed_date)`.
|
||||||
#'
|
#'
|
||||||
@@ -149,10 +149,10 @@
|
|||||||
#' `r TAXONOMY_VERSION$GBIF$citation` Accessed from <`r TAXONOMY_VERSION$GBIF$url`> on `r documentation_date(TAXONOMY_VERSION$GBIF$accessed_date)`.
|
#' `r TAXONOMY_VERSION$GBIF$citation` Accessed from <`r TAXONOMY_VERSION$GBIF$url`> on `r documentation_date(TAXONOMY_VERSION$GBIF$accessed_date)`.
|
||||||
#'
|
#'
|
||||||
#' Furthermore, these sources were used for additional details:
|
#' Furthermore, these sources were used for additional details:
|
||||||
#'
|
#'
|
||||||
#' * `r TAXONOMY_VERSION$BacDive$name`:\cr\cr
|
#' * `r TAXONOMY_VERSION$BacDive$name`:\cr\cr
|
||||||
#' `r TAXONOMY_VERSION$BacDive$citation` Accessed from <`r TAXONOMY_VERSION$BacDive$url`> on `r documentation_date(TAXONOMY_VERSION$BacDive$accessed_date)`.
|
#' `r TAXONOMY_VERSION$BacDive$citation` Accessed from <`r TAXONOMY_VERSION$BacDive$url`> on `r documentation_date(TAXONOMY_VERSION$BacDive$accessed_date)`.
|
||||||
#'
|
#'
|
||||||
#' * `r TAXONOMY_VERSION$SNOMED$name`:\cr\cr
|
#' * `r TAXONOMY_VERSION$SNOMED$name`:\cr\cr
|
||||||
#' `r TAXONOMY_VERSION$SNOMED$citation` Accessed from <`r TAXONOMY_VERSION$SNOMED$url`> on `r documentation_date(TAXONOMY_VERSION$SNOMED$accessed_date)`.
|
#' `r TAXONOMY_VERSION$SNOMED$citation` Accessed from <`r TAXONOMY_VERSION$SNOMED$url`> on `r documentation_date(TAXONOMY_VERSION$SNOMED$accessed_date)`.
|
||||||
#'
|
#'
|
||||||
@@ -175,13 +175,13 @@
|
|||||||
#' @seealso [as.mo()] [microorganisms]
|
#' @seealso [as.mo()] [microorganisms]
|
||||||
#' @examples
|
#' @examples
|
||||||
#' microorganisms.codes
|
#' microorganisms.codes
|
||||||
#'
|
#'
|
||||||
#' # 'ECO' or 'eco' is the WHONET code for E. coli:
|
#' # 'ECO' or 'eco' is the WHONET code for E. coli:
|
||||||
#' microorganisms.codes[microorganisms.codes$code == "ECO", ]
|
#' microorganisms.codes[microorganisms.codes$code == "ECO", ]
|
||||||
#'
|
#'
|
||||||
#' # and therefore, 'eco' will be understood as E. coli in this package:
|
#' # and therefore, 'eco' will be understood as E. coli in this package:
|
||||||
#' mo_info("eco")
|
#' mo_info("eco")
|
||||||
#'
|
#'
|
||||||
#' # works for all AMR functions:
|
#' # works for all AMR functions:
|
||||||
#' mo_is_intrinsic_resistant("eco", ab = "vancomycin")
|
#' mo_is_intrinsic_resistant("eco", ab = "vancomycin")
|
||||||
"microorganisms.codes"
|
"microorganisms.codes"
|
||||||
@@ -199,7 +199,7 @@
|
|||||||
#' @seealso [as.mo()] [microorganisms]
|
#' @seealso [as.mo()] [microorganisms]
|
||||||
#' @examples
|
#' @examples
|
||||||
#' microorganisms.groups
|
#' microorganisms.groups
|
||||||
#'
|
#'
|
||||||
#' # these are all species in the Bacteroides fragilis group, as per WHONET:
|
#' # these are all species in the Bacteroides fragilis group, as per WHONET:
|
||||||
#' microorganisms.groups[microorganisms.groups$mo_group == "B_BCTRD_FRGL-C", ]
|
#' microorganisms.groups[microorganisms.groups$mo_group == "B_BCTRD_FRGL-C", ]
|
||||||
"microorganisms.groups"
|
"microorganisms.groups"
|
||||||
@@ -275,12 +275,12 @@
|
|||||||
#' Data Set with Clinical Breakpoints for SIR Interpretation
|
#' Data Set with Clinical Breakpoints for SIR Interpretation
|
||||||
#'
|
#'
|
||||||
#' @description Data set containing clinical breakpoints to interpret MIC and disk diffusion to SIR values, according to international guidelines. This dataset contain breakpoints for humans, `r length(unique(clinical_breakpoints$host[!clinical_breakpoints$host %in% clinical_breakpoints$type]))` different animal groups, and ECOFFs.
|
#' @description Data set containing clinical breakpoints to interpret MIC and disk diffusion to SIR values, according to international guidelines. This dataset contain breakpoints for humans, `r length(unique(clinical_breakpoints$host[!clinical_breakpoints$host %in% clinical_breakpoints$type]))` different animal groups, and ECOFFs.
|
||||||
#'
|
#'
|
||||||
#' These breakpoints are currently implemented:
|
#' These breakpoints are currently implemented:
|
||||||
#' - For **clinical microbiology**: EUCAST `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "human")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "human")$guideline)))` and CLSI `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "human")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "human")$guideline)))`;
|
#' - For **clinical microbiology**: EUCAST `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "human")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "human")$guideline)))` and CLSI `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "human")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "human")$guideline)))`;
|
||||||
#' - For **veterinary microbiology**: EUCAST `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "animal")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "animal")$guideline)))` and CLSI `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "animal")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "animal")$guideline)))`;
|
#' - For **veterinary microbiology**: EUCAST `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "animal")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "animal")$guideline)))` and CLSI `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "animal")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "animal")$guideline)))`;
|
||||||
#' - For **ECOFFs** (Epidemiological Cut-off Values): EUCAST `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "ECOFF")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "ECOFF")$guideline)))` and CLSI `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "ECOFF")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "ECOFF")$guideline)))`.
|
#' - For **ECOFFs** (Epidemiological Cut-off Values): EUCAST `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "ECOFF")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "ECOFF")$guideline)))` and CLSI `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "ECOFF")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "ECOFF")$guideline)))`.
|
||||||
#'
|
#'
|
||||||
#' Use [as.sir()] to transform MICs or disks measurements to SIR values.
|
#' Use [as.sir()] to transform MICs or disks measurements to SIR values.
|
||||||
#' @format A [tibble][tibble::tibble] with `r format(nrow(clinical_breakpoints), big.mark = " ")` observations and `r ncol(clinical_breakpoints)` variables:
|
#' @format A [tibble][tibble::tibble] with `r format(nrow(clinical_breakpoints), big.mark = " ")` observations and `r ncol(clinical_breakpoints)` variables:
|
||||||
#' - `guideline`\cr Name of the guideline
|
#' - `guideline`\cr Name of the guideline
|
||||||
@@ -300,18 +300,18 @@
|
|||||||
#' @details
|
#' @details
|
||||||
#' ### Different types of breakpoints
|
#' ### Different types of breakpoints
|
||||||
#' Supported types of breakpoints are `r vector_and(clinical_breakpoints$type, quote = FALSE)`. ECOFF (Epidemiological cut-off) values are used in antimicrobial susceptibility testing to differentiate between wild-type and non-wild-type strains of bacteria or fungi.
|
#' Supported types of breakpoints are `r vector_and(clinical_breakpoints$type, quote = FALSE)`. ECOFF (Epidemiological cut-off) values are used in antimicrobial susceptibility testing to differentiate between wild-type and non-wild-type strains of bacteria or fungi.
|
||||||
#'
|
#'
|
||||||
#' The default is `"human"`, which can also be set with the package option [`AMR_breakpoint_type`][AMR-options]. Use [`as.sir(..., breakpoint_type = ...)`][as.sir()] to interpret raw data using a specific breakpoint type, e.g. `as.sir(..., breakpoint_type = "ECOFF")` to use ECOFFs.
|
#' The default is `"human"`, which can also be set with the package option [`AMR_breakpoint_type`][AMR-options]. Use [`as.sir(..., breakpoint_type = ...)`][as.sir()] to interpret raw data using a specific breakpoint type, e.g. `as.sir(..., breakpoint_type = "ECOFF")` to use ECOFFs.
|
||||||
#'
|
#'
|
||||||
#' ### Imported from WHONET
|
#' ### Imported from WHONET
|
||||||
#' Clinical breakpoints in this package were validated through and imported from [WHONET](https://whonet.org), a free desktop Windows application developed and supported by the WHO Collaborating Centre for Surveillance of Antimicrobial Resistance. More can be read on [their website](https://whonet.org). The developers of WHONET and this `AMR` package have been in contact about sharing their work. We highly appreciate their great development on the WHONET software.
|
#' Clinical breakpoints in this package were validated through and imported from [WHONET](https://whonet.org), a free desktop Windows application developed and supported by the WHO Collaborating Centre for Surveillance of Antimicrobial Resistance. More can be read on [their website](https://whonet.org). The developers of WHONET and this `AMR` package have been in contact about sharing their work. We highly appreciate their great development on the WHONET software.
|
||||||
#'
|
#'
|
||||||
#' ### Response from CLSI and EUCAST
|
#' ### Response from CLSI and EUCAST
|
||||||
#' The CEO of CLSI and the chairman of EUCAST have endorsed the work and public use of this `AMR` package (and consequently the use of their breakpoints) in June 2023, when future development of distributing clinical breakpoints was discussed in a meeting between CLSI, EUCAST, WHO, developers of WHONET software, and developers of this `AMR` package.
|
#' The CEO of CLSI and the chairman of EUCAST have endorsed the work and public use of this `AMR` package (and consequently the use of their breakpoints) in June 2023, when future development of distributing clinical breakpoints was discussed in a meeting between CLSI, EUCAST, WHO, developers of WHONET software, and developers of this `AMR` package.
|
||||||
#'
|
#'
|
||||||
#' ### Download
|
#' ### Download
|
||||||
#' Like all data sets in this package, this data set is publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, and Stata. Please visit [our website for the download links](https://msberends.github.io/AMR/articles/datasets.html). The actual files are of course available on [our GitHub repository](https://github.com/msberends/AMR/tree/main/data-raw). They allow for machine reading EUCAST and CLSI guidelines, which is almost impossible with the MS Excel and PDF files distributed by EUCAST and CLSI, though initiatives have started to overcome these burdens.
|
#' Like all data sets in this package, this data set is publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, and Stata. Please visit [our website for the download links](https://msberends.github.io/AMR/articles/datasets.html). The actual files are of course available on [our GitHub repository](https://github.com/msberends/AMR/tree/main/data-raw). They allow for machine reading EUCAST and CLSI guidelines, which is almost impossible with the MS Excel and PDF files distributed by EUCAST and CLSI, though initiatives have started to overcome these burdens.
|
||||||
#'
|
#'
|
||||||
#' **NOTE:** this `AMR` package (and the WHONET software as well) contains rather complex internal methods to apply the guidelines. For example, some breakpoints must be applied on certain species groups (which are in case of this package available through the [microorganisms.groups] data set). It is important that this is considered when using the breakpoints for own use.
|
#' **NOTE:** this `AMR` package (and the WHONET software as well) contains rather complex internal methods to apply the guidelines. For example, some breakpoints must be applied on certain species groups (which are in case of this package available through the [microorganisms.groups] data set). It is important that this is considered when using the breakpoints for own use.
|
||||||
#' @seealso [intrinsic_resistant]
|
#' @seealso [intrinsic_resistant]
|
||||||
#' @examples
|
#' @examples
|
||||||
|
|||||||
@@ -211,7 +211,7 @@ eucast_rules <- function(x,
|
|||||||
breakpoints_info <- EUCAST_VERSION_BREAKPOINTS[[which(as.double(names(EUCAST_VERSION_BREAKPOINTS)) == version_breakpoints)]]
|
breakpoints_info <- EUCAST_VERSION_BREAKPOINTS[[which(as.double(names(EUCAST_VERSION_BREAKPOINTS)) == version_breakpoints)]]
|
||||||
expertrules_info <- EUCAST_VERSION_EXPERT_RULES[[which(as.double(names(EUCAST_VERSION_EXPERT_RULES)) == version_expertrules)]]
|
expertrules_info <- EUCAST_VERSION_EXPERT_RULES[[which(as.double(names(EUCAST_VERSION_EXPERT_RULES)) == version_expertrules)]]
|
||||||
# resistantphenotypes_info <- EUCAST_VERSION_RESISTANTPHENOTYPES[[which(as.double(names(EUCAST_VERSION_RESISTANTPHENOTYPES)) == version_resistant_phenotypes)]]
|
# resistantphenotypes_info <- EUCAST_VERSION_RESISTANTPHENOTYPES[[which(as.double(names(EUCAST_VERSION_RESISTANTPHENOTYPES)) == version_resistant_phenotypes)]]
|
||||||
|
|
||||||
# support old setting (until AMR v1.3.0)
|
# support old setting (until AMR v1.3.0)
|
||||||
if (missing(rules) && !is.null(getOption("AMR.eucast_rules"))) {
|
if (missing(rules) && !is.null(getOption("AMR.eucast_rules"))) {
|
||||||
rules <- getOption("AMR.eucast_rules")
|
rules <- getOption("AMR.eucast_rules")
|
||||||
@@ -462,10 +462,12 @@ eucast_rules <- function(x,
|
|||||||
if (isTRUE(info)) {
|
if (isTRUE(info)) {
|
||||||
cat(paste0("\n", font_grey(strrep("-", 0.95 * getOption("width", 100))), "\n"))
|
cat(paste0("\n", font_grey(strrep("-", 0.95 * getOption("width", 100))), "\n"))
|
||||||
cat(word_wrap(
|
cat(word_wrap(
|
||||||
paste0("Rules by the ",
|
paste0(
|
||||||
font_bold(paste0("AMR package v", utils::packageDescription("AMR")$Version)),
|
"Rules by the ",
|
||||||
" (", format(as.Date(utils::packageDescription("AMR")$Date), format = "%Y"),
|
font_bold(paste0("AMR package v", utils::packageDescription("AMR")$Version)),
|
||||||
"), see `?eucast_rules`\n")
|
" (", format(as.Date(utils::packageDescription("AMR")$Date), format = "%Y"),
|
||||||
|
"), see `?eucast_rules`\n"
|
||||||
|
)
|
||||||
))
|
))
|
||||||
cat("\n\n")
|
cat("\n\n")
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -29,8 +29,8 @@
|
|||||||
|
|
||||||
#' Export Data Set as NCBI BioSample Antibiogram
|
#' Export Data Set as NCBI BioSample Antibiogram
|
||||||
#'
|
#'
|
||||||
#'
|
#'
|
||||||
#' @param x a data set
|
#' @param x a data set
|
||||||
#' @param filename a character string specifying the file name
|
#' @param filename a character string specifying the file name
|
||||||
#' @param type a character string specifying the type of data set, either "pathogen MIC" or "beta-lactamase MIC", see <https://www.ncbi.nlm.nih.gov/biosample/docs/>
|
#' @param type a character string specifying the type of data set, either "pathogen MIC" or "beta-lactamase MIC", see <https://www.ncbi.nlm.nih.gov/biosample/docs/>
|
||||||
#' @keywords internal
|
#' @keywords internal
|
||||||
@@ -43,11 +43,11 @@ export_ncbi_biosample <- function(x,
|
|||||||
meet_criteria(filename, allow_class = "character", has_length = 1)
|
meet_criteria(filename, allow_class = "character", has_length = 1)
|
||||||
meet_criteria(type, allow_class = "character", has_length = 1, is_in = c("pathogen MIC", "beta-lactamase MIC"))
|
meet_criteria(type, allow_class = "character", has_length = 1, is_in = c("pathogen MIC", "beta-lactamase MIC"))
|
||||||
meet_criteria(save_as_xlsx, allow_class = "logical", has_length = 1)
|
meet_criteria(save_as_xlsx, allow_class = "logical", has_length = 1)
|
||||||
|
|
||||||
out <- x %pm>%
|
out <- x %pm>%
|
||||||
pm_select(columns)
|
pm_select(columns)
|
||||||
stop_if(NROW(out) == 0, "No columns found.")
|
stop_if(NROW(out) == 0, "No columns found.")
|
||||||
|
|
||||||
if (isTRUE(save_as_xlsx)) {
|
if (isTRUE(save_as_xlsx)) {
|
||||||
export <- import_fn("write.xlsx", pkg = "openxlsx", error_on_fail = TRUE)
|
export <- import_fn("write.xlsx", pkg = "openxlsx", error_on_fail = TRUE)
|
||||||
export(out, file = filename, overwrite = TRUE, asTable = FALSE)
|
export(out, file = filename, overwrite = TRUE, asTable = FALSE)
|
||||||
|
|||||||
@@ -466,7 +466,7 @@ first_isolate <- function(x = NULL,
|
|||||||
x$other_pat_or_mo <- !(x$newvar_patient_id == pm_lag(x$newvar_patient_id) & x$newvar_genus_species == pm_lag(x$newvar_genus_species))
|
x$other_pat_or_mo <- !(x$newvar_patient_id == pm_lag(x$newvar_patient_id) & x$newvar_genus_species == pm_lag(x$newvar_genus_species))
|
||||||
|
|
||||||
x$newvar_episode_group <- paste(x$newvar_patient_id, x$newvar_genus_species)
|
x$newvar_episode_group <- paste(x$newvar_patient_id, x$newvar_genus_species)
|
||||||
|
|
||||||
x$more_than_episode_ago <- unlist(
|
x$more_than_episode_ago <- unlist(
|
||||||
lapply(
|
lapply(
|
||||||
split(
|
split(
|
||||||
@@ -479,7 +479,7 @@ first_isolate <- function(x = NULL,
|
|||||||
),
|
),
|
||||||
use.names = FALSE
|
use.names = FALSE
|
||||||
)
|
)
|
||||||
|
|
||||||
if (!is.null(col_keyantimicrobials)) {
|
if (!is.null(col_keyantimicrobials)) {
|
||||||
# using phenotypes
|
# using phenotypes
|
||||||
x$different_antibiogram <- !unlist(
|
x$different_antibiogram <- !unlist(
|
||||||
@@ -498,15 +498,15 @@ first_isolate <- function(x = NULL,
|
|||||||
} else {
|
} else {
|
||||||
x$different_antibiogram <- FALSE
|
x$different_antibiogram <- FALSE
|
||||||
}
|
}
|
||||||
|
|
||||||
x$newvar_first_isolate <- x$newvar_row_index_sorted >= row.start &
|
x$newvar_first_isolate <- x$newvar_row_index_sorted >= row.start &
|
||||||
x$newvar_row_index_sorted <= row.end &
|
x$newvar_row_index_sorted <= row.end &
|
||||||
x$newvar_genus_species != "" &
|
x$newvar_genus_species != "" &
|
||||||
(x$other_pat_or_mo | x$more_than_episode_ago | x$different_antibiogram)
|
(x$other_pat_or_mo | x$more_than_episode_ago | x$different_antibiogram)
|
||||||
|
|
||||||
decimal.mark <- getOption("OutDec")
|
decimal.mark <- getOption("OutDec")
|
||||||
big.mark <- ifelse(decimal.mark != ",", ",", " ")
|
big.mark <- ifelse(decimal.mark != ",", ",", " ")
|
||||||
|
|
||||||
# first one as TRUE
|
# first one as TRUE
|
||||||
x[row.start, "newvar_first_isolate"] <- TRUE
|
x[row.start, "newvar_first_isolate"] <- TRUE
|
||||||
# no tests that should be included, or ICU
|
# no tests that should be included, or ICU
|
||||||
@@ -517,7 +517,8 @@ first_isolate <- function(x = NULL,
|
|||||||
if (icu_exclude == TRUE) {
|
if (icu_exclude == TRUE) {
|
||||||
if (isTRUE(info)) {
|
if (isTRUE(info)) {
|
||||||
message_("Excluding ", format(sum(x$newvar_is_icu, na.rm = TRUE), decimal.mark = decimal.mark, big.mark = big.mark), " isolates from ICU.",
|
message_("Excluding ", format(sum(x$newvar_is_icu, na.rm = TRUE), decimal.mark = decimal.mark, big.mark = big.mark), " isolates from ICU.",
|
||||||
add_fn = font_red)
|
add_fn = font_red
|
||||||
|
)
|
||||||
}
|
}
|
||||||
x[which(x$newvar_is_icu), "newvar_first_isolate"] <- FALSE
|
x[which(x$newvar_is_icu), "newvar_first_isolate"] <- FALSE
|
||||||
} else if (isTRUE(info)) {
|
} else if (isTRUE(info)) {
|
||||||
@@ -673,24 +674,27 @@ duplicated_antibiogram <- function(antibiogram, points_threshold, ignore_I, type
|
|||||||
return(FALSE)
|
return(FALSE)
|
||||||
}
|
}
|
||||||
# first sort on data availability - count the dots and order that ascending so that highest availability of SIR is on top
|
# first sort on data availability - count the dots and order that ascending so that highest availability of SIR is on top
|
||||||
number_dots <- vapply(FUN.VALUE = integer(1),
|
number_dots <- vapply(
|
||||||
antibiogram,
|
FUN.VALUE = integer(1),
|
||||||
function(x) sum(strsplit(x, "", fixed = TRUE)[[1]] == "."),
|
antibiogram,
|
||||||
USE.NAMES = FALSE)
|
function(x) sum(strsplit(x, "", fixed = TRUE)[[1]] == "."),
|
||||||
|
USE.NAMES = FALSE
|
||||||
|
)
|
||||||
new_order <- order(number_dots, antibiogram)
|
new_order <- order(number_dots, antibiogram)
|
||||||
antibiogram.bak <- antibiogram
|
antibiogram.bak <- antibiogram
|
||||||
antibiogram <- antibiogram[new_order]
|
antibiogram <- antibiogram[new_order]
|
||||||
|
|
||||||
out <- rep(NA, length(antibiogram))
|
out <- rep(NA, length(antibiogram))
|
||||||
out[1] <- FALSE
|
out[1] <- FALSE
|
||||||
out[2] <- antimicrobials_equal(antibiogram[1], antibiogram[2],
|
out[2] <- antimicrobials_equal(antibiogram[1], antibiogram[2],
|
||||||
ignore_I = ignore_I, points_threshold = points_threshold,
|
ignore_I = ignore_I, points_threshold = points_threshold,
|
||||||
type = type)
|
type = type
|
||||||
|
)
|
||||||
if (length(antibiogram) == 2) {
|
if (length(antibiogram) == 2) {
|
||||||
# fast return, no further check required
|
# fast return, no further check required
|
||||||
return(out)
|
return(out)
|
||||||
}
|
}
|
||||||
|
|
||||||
# we can skip the duplicates - they are never unique antibiograms of course
|
# we can skip the duplicates - they are never unique antibiograms of course
|
||||||
duplicates <- duplicated(antibiogram)
|
duplicates <- duplicated(antibiogram)
|
||||||
out[3:length(out)][duplicates[3:length(out)] == TRUE] <- TRUE
|
out[3:length(out)][duplicates[3:length(out)] == TRUE] <- TRUE
|
||||||
@@ -698,17 +702,24 @@ duplicated_antibiogram <- function(antibiogram, points_threshold, ignore_I, type
|
|||||||
# fast return, no further check required
|
# fast return, no further check required
|
||||||
return(c(out[1:2], rep(TRUE, length(out) - 2)))
|
return(c(out[1:2], rep(TRUE, length(out) - 2)))
|
||||||
}
|
}
|
||||||
|
|
||||||
for (na in antibiogram[is.na(out)]) {
|
for (na in antibiogram[is.na(out)]) {
|
||||||
# check if this antibiogram has any change with other antibiograms
|
# check if this antibiogram has any change with other antibiograms
|
||||||
out[which(antibiogram == na)] <- all(
|
out[which(antibiogram == na)] <- all(
|
||||||
vapply(FUN.VALUE = logical(1),
|
vapply(
|
||||||
antibiogram[!is.na(out) & antibiogram != na],
|
FUN.VALUE = logical(1),
|
||||||
function(y) antimicrobials_equal(y = y, z = na,
|
antibiogram[!is.na(out) & antibiogram != na],
|
||||||
ignore_I = ignore_I, points_threshold = points_threshold,
|
function(y) {
|
||||||
type = type)))
|
antimicrobials_equal(
|
||||||
|
y = y, z = na,
|
||||||
|
ignore_I = ignore_I, points_threshold = points_threshold,
|
||||||
|
type = type
|
||||||
|
)
|
||||||
|
}
|
||||||
|
)
|
||||||
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
out <- out[order(new_order)]
|
out <- out[order(new_order)]
|
||||||
# rerun duplicated again
|
# rerun duplicated again
|
||||||
duplicates <- duplicated(antibiogram.bak)
|
duplicates <- duplicated(antibiogram.bak)
|
||||||
|
|||||||
@@ -221,11 +221,11 @@ exec_episode <- function(x, episode_days, case_free_days, ...) {
|
|||||||
|
|
||||||
# running as.double() on a POSIXct object will return its number of seconds since 1970-01-01
|
# running as.double() on a POSIXct object will return its number of seconds since 1970-01-01
|
||||||
x <- as.double(as.POSIXct(x)) # as.POSIXct() required for Date classes
|
x <- as.double(as.POSIXct(x)) # as.POSIXct() required for Date classes
|
||||||
|
|
||||||
# since x is now in seconds, get seconds from episode_days as well
|
# since x is now in seconds, get seconds from episode_days as well
|
||||||
episode_seconds <- episode_days * 60 * 60 * 24
|
episode_seconds <- episode_days * 60 * 60 * 24
|
||||||
case_free_seconds <- case_free_days * 60 * 60 * 24
|
case_free_seconds <- case_free_days * 60 * 60 * 24
|
||||||
|
|
||||||
if (length(x) == 1) { # this will also match 1 NA, which is fine
|
if (length(x) == 1) { # this will also match 1 NA, which is fine
|
||||||
return(1)
|
return(1)
|
||||||
} else if (length(x) == 2 && all(!is.na(x))) {
|
} else if (length(x) == 2 && all(!is.na(x))) {
|
||||||
|
|||||||
@@ -52,7 +52,7 @@
|
|||||||
#' @details At default, the names of antibiotics will be shown on the plots using [ab_name()]. This can be set with the `translate_ab` argument. See [count_df()].
|
#' @details At default, the names of antibiotics will be shown on the plots using [ab_name()]. This can be set with the `translate_ab` argument. See [count_df()].
|
||||||
#'
|
#'
|
||||||
#' [geom_sir()] will take any variable from the data that has an [`sir`] class (created with [as.sir()]) using [sir_df()] and will plot bars with the percentage S, I, and R. The default behaviour is to have the bars stacked and to have the different antibiotics on the x axis.
|
#' [geom_sir()] will take any variable from the data that has an [`sir`] class (created with [as.sir()]) using [sir_df()] and will plot bars with the percentage S, I, and R. The default behaviour is to have the bars stacked and to have the different antibiotics on the x axis.
|
||||||
#'
|
#'
|
||||||
#' Additional functions include:
|
#' Additional functions include:
|
||||||
#'
|
#'
|
||||||
#' * [facet_sir()] creates 2d plots (at default based on S/I/R) using [ggplot2::facet_wrap()].
|
#' * [facet_sir()] creates 2d plots (at default based on S/I/R) using [ggplot2::facet_wrap()].
|
||||||
@@ -121,8 +121,10 @@
|
|||||||
#' ) %>%
|
#' ) %>%
|
||||||
#' ggplot() +
|
#' ggplot() +
|
||||||
#' geom_col(aes(x = x, y = y, fill = z)) +
|
#' geom_col(aes(x = x, y = y, fill = z)) +
|
||||||
#' scale_sir_colours(aesthetics = "fill",
|
#' scale_sir_colours(
|
||||||
#' Value4 = "S", Value5 = "I", Value6 = "R")
|
#' aesthetics = "fill",
|
||||||
|
#' Value4 = "S", Value5 = "I", Value6 = "R"
|
||||||
|
#' )
|
||||||
#' }
|
#' }
|
||||||
#' if (require("ggplot2") && require("dplyr")) {
|
#' if (require("ggplot2") && require("dplyr")) {
|
||||||
#' # resistance of ciprofloxacine per age group
|
#' # resistance of ciprofloxacine per age group
|
||||||
@@ -212,7 +214,7 @@ ggplot_sir <- function(data,
|
|||||||
meet_criteria(caption, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
meet_criteria(caption, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||||
meet_criteria(x.title, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
meet_criteria(x.title, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||||
meet_criteria(y.title, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
meet_criteria(y.title, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||||
|
|
||||||
x_deparse <- deparse(substitute(x))
|
x_deparse <- deparse(substitute(x))
|
||||||
if (x_deparse != "x") {
|
if (x_deparse != "x") {
|
||||||
x <- x_deparse
|
x <- x_deparse
|
||||||
@@ -309,7 +311,7 @@ geom_sir <- function(position = NULL,
|
|||||||
if (identical(position, "fill")) {
|
if (identical(position, "fill")) {
|
||||||
position <- ggplot2::position_fill(vjust = 0.5, reverse = TRUE)
|
position <- ggplot2::position_fill(vjust = 0.5, reverse = TRUE)
|
||||||
}
|
}
|
||||||
|
|
||||||
x_deparse <- deparse(substitute(x))
|
x_deparse <- deparse(substitute(x))
|
||||||
if (x_deparse != "x") {
|
if (x_deparse != "x") {
|
||||||
x <- x_deparse
|
x <- x_deparse
|
||||||
@@ -323,7 +325,7 @@ geom_sir <- function(position = NULL,
|
|||||||
} else if (tolower(x) %in% tolower(c("SIR", "sir", "interpretations", "result"))) {
|
} else if (tolower(x) %in% tolower(c("SIR", "sir", "interpretations", "result"))) {
|
||||||
x <- "interpretation"
|
x <- "interpretation"
|
||||||
}
|
}
|
||||||
|
|
||||||
ggplot2::geom_col(
|
ggplot2::geom_col(
|
||||||
data = function(x) {
|
data = function(x) {
|
||||||
sir_df(
|
sir_df(
|
||||||
|
|||||||
@@ -254,14 +254,14 @@ get_column_abx <- function(x,
|
|||||||
if (sort == TRUE) {
|
if (sort == TRUE) {
|
||||||
out <- out[order(names(out), out)]
|
out <- out[order(names(out), out)]
|
||||||
}
|
}
|
||||||
|
|
||||||
if (return_all == FALSE) {
|
if (return_all == FALSE) {
|
||||||
# only keep the first hits, no duplicates
|
# only keep the first hits, no duplicates
|
||||||
duplicates <- c(out[duplicated(names(out))], out[duplicated(unname(out))])
|
duplicates <- c(out[duplicated(names(out))], out[duplicated(unname(out))])
|
||||||
if (length(duplicates) > 0) {
|
if (length(duplicates) > 0) {
|
||||||
all_okay <- FALSE
|
all_okay <- FALSE
|
||||||
}
|
}
|
||||||
|
|
||||||
if (isTRUE(info)) {
|
if (isTRUE(info)) {
|
||||||
if (all_okay == TRUE) {
|
if (all_okay == TRUE) {
|
||||||
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
|
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
|
||||||
@@ -292,7 +292,7 @@ get_column_abx <- function(x,
|
|||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
out <- out[!duplicated(names(out))]
|
out <- out[!duplicated(names(out))]
|
||||||
out <- out[!duplicated(unname(out))]
|
out <- out[!duplicated(unname(out))]
|
||||||
if (sort == TRUE) {
|
if (sort == TRUE) {
|
||||||
|
|||||||
2
R/like.R
2
R/like.R
@@ -51,7 +51,7 @@
|
|||||||
#' @examples
|
#' @examples
|
||||||
#' # data.table has a more limited version of %like%, so unload it:
|
#' # data.table has a more limited version of %like%, so unload it:
|
||||||
#' try(detach("package:data.table", unload = TRUE), silent = TRUE)
|
#' try(detach("package:data.table", unload = TRUE), silent = TRUE)
|
||||||
#'
|
#'
|
||||||
#' a <- "This is a test"
|
#' a <- "This is a test"
|
||||||
#' b <- "TEST"
|
#' b <- "TEST"
|
||||||
#' a %like% b
|
#' a %like% b
|
||||||
|
|||||||
84
R/mdro.R
84
R/mdro.R
@@ -83,9 +83,9 @@
|
|||||||
#' * `guideline = "BRMO"`
|
#' * `guideline = "BRMO"`
|
||||||
#'
|
#'
|
||||||
#' The Dutch national guideline - Samenwerkingverband Richtlijnen Infectiepreventie (SRI) (2024) "Bijzonder Resistente Micro-Organismen (BRMO)" ([link](https://www.sri-richtlijnen.nl/brmo))
|
#' The Dutch national guideline - Samenwerkingverband Richtlijnen Infectiepreventie (SRI) (2024) "Bijzonder Resistente Micro-Organismen (BRMO)" ([link](https://www.sri-richtlijnen.nl/brmo))
|
||||||
#'
|
#'
|
||||||
#' Also:
|
#' Also:
|
||||||
#'
|
#'
|
||||||
#' * `guideline = "BRMO 2017"`
|
#' * `guideline = "BRMO 2017"`
|
||||||
#'
|
#'
|
||||||
#' The former Dutch national guideline - Werkgroep Infectiepreventie (WIP), RIVM, last revision as of 2017: "Bijzonder Resistente Micro-Organismen (BRMO)"
|
#' The former Dutch national guideline - Werkgroep Infectiepreventie (WIP), RIVM, last revision as of 2017: "Bijzonder Resistente Micro-Organismen (BRMO)"
|
||||||
@@ -219,7 +219,7 @@ mdro <- function(x = NULL,
|
|||||||
if (!any(is_sir_eligible(x))) {
|
if (!any(is_sir_eligible(x))) {
|
||||||
stop_("There were no possible SIR columns found in the data set. Transform columns with `as.sir()` for valid antimicrobial interpretations.")
|
stop_("There were no possible SIR columns found in the data set. Transform columns with `as.sir()` for valid antimicrobial interpretations.")
|
||||||
}
|
}
|
||||||
|
|
||||||
# get gene values as TRUE/FALSE
|
# get gene values as TRUE/FALSE
|
||||||
if (is.character(esbl)) {
|
if (is.character(esbl)) {
|
||||||
meet_criteria(esbl, is_in = colnames(x), allow_NA = FALSE, has_length = 1)
|
meet_criteria(esbl, is_in = colnames(x), allow_NA = FALSE, has_length = 1)
|
||||||
@@ -263,7 +263,7 @@ mdro <- function(x = NULL,
|
|||||||
} else if (length(vanB) == 1) {
|
} else if (length(vanB) == 1) {
|
||||||
vanB <- rep(vanB, NROW(x))
|
vanB <- rep(vanB, NROW(x))
|
||||||
}
|
}
|
||||||
|
|
||||||
info.bak <- info
|
info.bak <- info
|
||||||
# don't throw info's more than once per call
|
# don't throw info's more than once per call
|
||||||
if (isTRUE(info)) {
|
if (isTRUE(info)) {
|
||||||
@@ -780,14 +780,14 @@ mdro <- function(x = NULL,
|
|||||||
)
|
)
|
||||||
}
|
}
|
||||||
)
|
)
|
||||||
|
|
||||||
if (any_all == "any") {
|
if (any_all == "any") {
|
||||||
search_function <- any
|
search_function <- any
|
||||||
} else if (any_all == "all") {
|
} else if (any_all == "all") {
|
||||||
search_function <- all
|
search_function <- all
|
||||||
}
|
}
|
||||||
x_transposed <- as.list(as.data.frame(t(x[, cols, drop = FALSE]),
|
x_transposed <- as.list(as.data.frame(t(x[, cols, drop = FALSE]),
|
||||||
stringsAsFactors = FALSE
|
stringsAsFactors = FALSE
|
||||||
))
|
))
|
||||||
rows_affected <- vapply(
|
rows_affected <- vapply(
|
||||||
FUN.VALUE = logical(1),
|
FUN.VALUE = logical(1),
|
||||||
@@ -799,18 +799,20 @@ mdro <- function(x = NULL,
|
|||||||
rows_not_to_change <- rows[!rows %in% c(rows_affected, rows_to_change)]
|
rows_not_to_change <- rows[!rows %in% c(rows_affected, rows_to_change)]
|
||||||
rows_not_to_change <- rows_not_to_change[is.na(x[rows_not_to_change, "reason"])]
|
rows_not_to_change <- rows_not_to_change[is.na(x[rows_not_to_change, "reason"])]
|
||||||
if (is.null(reason)) {
|
if (is.null(reason)) {
|
||||||
reason <- paste0(any_all,
|
reason <- paste0(
|
||||||
" of the required antibiotics ",
|
any_all,
|
||||||
ifelse(any_all == "any", "is", "are"),
|
" of the required antibiotics ",
|
||||||
" R",
|
ifelse(any_all == "any", "is", "are"),
|
||||||
ifelse(!isTRUE(combine_SI), " or I", ""))
|
" R",
|
||||||
|
ifelse(!isTRUE(combine_SI), " or I", "")
|
||||||
|
)
|
||||||
}
|
}
|
||||||
x[rows_to_change, "MDRO"] <<- to
|
x[rows_to_change, "MDRO"] <<- to
|
||||||
x[rows_to_change, "reason"] <<- reason
|
x[rows_to_change, "reason"] <<- reason
|
||||||
x[rows_not_to_change, "reason"] <<- "guideline criteria not met"
|
x[rows_not_to_change, "reason"] <<- "guideline criteria not met"
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
trans_tbl2 <- function(txt, rows, lst) {
|
trans_tbl2 <- function(txt, rows, lst) {
|
||||||
if (isTRUE(info)) {
|
if (isTRUE(info)) {
|
||||||
message_(txt, "...", appendLF = FALSE, as_note = FALSE)
|
message_(txt, "...", appendLF = FALSE, as_note = FALSE)
|
||||||
@@ -1519,7 +1521,7 @@ mdro <- function(x = NULL,
|
|||||||
if (length(ESBLs) != 2) {
|
if (length(ESBLs) != 2) {
|
||||||
ESBLs <- character(0)
|
ESBLs <- character(0)
|
||||||
}
|
}
|
||||||
|
|
||||||
# Enterobacterales
|
# Enterobacterales
|
||||||
if (length(ESBLs) > 0) {
|
if (length(ESBLs) > 0) {
|
||||||
trans_tbl(
|
trans_tbl(
|
||||||
@@ -1561,9 +1563,9 @@ mdro <- function(x = NULL,
|
|||||||
trans_tbl(
|
trans_tbl(
|
||||||
3,
|
3,
|
||||||
rows = which(x[[SXT]] == "R" &
|
rows = which(x[[SXT]] == "R" &
|
||||||
(x[[GEN]] == "R" | x[[TOB]] == "R" | x[[AMK]] == "R") &
|
(x[[GEN]] == "R" | x[[TOB]] == "R" | x[[AMK]] == "R") &
|
||||||
(x[[CIP]] == "R" | x[[NOR]] == "R" | x[[LVX]] == "R") &
|
(x[[CIP]] == "R" | x[[NOR]] == "R" | x[[LVX]] == "R") &
|
||||||
(x$genus %in% c("Enterobacter", "Providencia") | paste(x$genus, x$species) %in% c("Citrobacter freundii", "Klebsiella aerogenes", "Hafnia alvei", "Morganella morganii"))),
|
(x$genus %in% c("Enterobacter", "Providencia") | paste(x$genus, x$species) %in% c("Citrobacter freundii", "Klebsiella aerogenes", "Hafnia alvei", "Morganella morganii"))),
|
||||||
cols = c(SXT, aminoglycosides, fluoroquinolones),
|
cols = c(SXT, aminoglycosides, fluoroquinolones),
|
||||||
any_all = "any",
|
any_all = "any",
|
||||||
reason = "Enterobacterales group II: aminoglycoside + fluoroquinolone + cotrimoxazol"
|
reason = "Enterobacterales group II: aminoglycoside + fluoroquinolone + cotrimoxazol"
|
||||||
@@ -1571,20 +1573,20 @@ mdro <- function(x = NULL,
|
|||||||
trans_tbl(
|
trans_tbl(
|
||||||
3,
|
3,
|
||||||
rows = which(x[[SXT]] == "R" &
|
rows = which(x[[SXT]] == "R" &
|
||||||
x[[GEN]] == "R" &
|
x[[GEN]] == "R" &
|
||||||
(x[[CIP]] == "R" | x[[NOR]] == "R" | x[[LVX]] == "R") &
|
(x[[CIP]] == "R" | x[[NOR]] == "R" | x[[LVX]] == "R") &
|
||||||
paste(x$genus, x$species) == "Serratia marcescens"),
|
paste(x$genus, x$species) == "Serratia marcescens"),
|
||||||
cols = c(SXT, aminoglycosides_serratia_marcescens, fluoroquinolones),
|
cols = c(SXT, aminoglycosides_serratia_marcescens, fluoroquinolones),
|
||||||
any_all = "any",
|
any_all = "any",
|
||||||
reason = "Enterobacterales group II: aminoglycoside + fluoroquinolone + cotrimoxazol"
|
reason = "Enterobacterales group II: aminoglycoside + fluoroquinolone + cotrimoxazol"
|
||||||
)
|
)
|
||||||
|
|
||||||
# Acinetobacter baumannii-calcoaceticus complex
|
# Acinetobacter baumannii-calcoaceticus complex
|
||||||
trans_tbl(
|
trans_tbl(
|
||||||
3,
|
3,
|
||||||
rows = which((x[[GEN]] == "R" | x[[TOB]] == "R" | x[[AMK]] == "R") &
|
rows = which((x[[GEN]] == "R" | x[[TOB]] == "R" | x[[AMK]] == "R") &
|
||||||
(x[[CIP]] == "R" | x[[LVX]] == "R") &
|
(x[[CIP]] == "R" | x[[LVX]] == "R") &
|
||||||
x[[col_mo]] %in% AMR::microorganisms.groups$mo[AMR::microorganisms.groups$mo_group_name == "Acinetobacter baumannii complex"]),
|
x[[col_mo]] %in% AMR::microorganisms.groups$mo[AMR::microorganisms.groups$mo_group_name == "Acinetobacter baumannii complex"]),
|
||||||
cols = c(aminoglycosides, CIP, LVX),
|
cols = c(aminoglycosides, CIP, LVX),
|
||||||
any_all = "any",
|
any_all = "any",
|
||||||
reason = "A. baumannii-calcoaceticus complex: aminoglycoside + ciprofloxacin or levofloxacin"
|
reason = "A. baumannii-calcoaceticus complex: aminoglycoside + ciprofloxacin or levofloxacin"
|
||||||
@@ -1603,7 +1605,7 @@ mdro <- function(x = NULL,
|
|||||||
any_all = "any",
|
any_all = "any",
|
||||||
reason = "A. baumannii-calcoaceticus complex: carbapenemase"
|
reason = "A. baumannii-calcoaceticus complex: carbapenemase"
|
||||||
)
|
)
|
||||||
|
|
||||||
# Pseudomonas aeruginosa
|
# Pseudomonas aeruginosa
|
||||||
if (ab_missing(PIP) && !ab_missing(TZP)) {
|
if (ab_missing(PIP) && !ab_missing(TZP)) {
|
||||||
# take pip/tazo if just pip is not available - many labs only test for pip/tazo because of availability on a Vitek card
|
# take pip/tazo if just pip is not available - many labs only test for pip/tazo because of availability on a Vitek card
|
||||||
@@ -1645,7 +1647,7 @@ mdro <- function(x = NULL,
|
|||||||
any_all = "any",
|
any_all = "any",
|
||||||
reason = "E. faecium: vanA/vanB gene + penicillin group"
|
reason = "E. faecium: vanA/vanB gene + penicillin group"
|
||||||
)
|
)
|
||||||
|
|
||||||
# Staphylococcus aureus
|
# Staphylococcus aureus
|
||||||
trans_tbl(
|
trans_tbl(
|
||||||
2,
|
2,
|
||||||
@@ -1661,7 +1663,7 @@ mdro <- function(x = NULL,
|
|||||||
any_all = "any",
|
any_all = "any",
|
||||||
reason = "S. aureus: mecA/mecC gene"
|
reason = "S. aureus: mecA/mecC gene"
|
||||||
)
|
)
|
||||||
|
|
||||||
# Candida auris
|
# Candida auris
|
||||||
trans_tbl(
|
trans_tbl(
|
||||||
3,
|
3,
|
||||||
@@ -1671,7 +1673,7 @@ mdro <- function(x = NULL,
|
|||||||
reason = "C. auris: regardless of resistance"
|
reason = "C. auris: regardless of resistance"
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
if (guideline$code == "brmo2017") {
|
if (guideline$code == "brmo2017") {
|
||||||
# Netherlands 2017 --------------------------------------------------------
|
# Netherlands 2017 --------------------------------------------------------
|
||||||
aminoglycosides <- aminoglycosides[!is.na(aminoglycosides)]
|
aminoglycosides <- aminoglycosides[!is.na(aminoglycosides)]
|
||||||
@@ -1684,7 +1686,7 @@ mdro <- function(x = NULL,
|
|||||||
if (length(ESBLs) != 2) {
|
if (length(ESBLs) != 2) {
|
||||||
ESBLs <- character(0)
|
ESBLs <- character(0)
|
||||||
}
|
}
|
||||||
|
|
||||||
# Table 1
|
# Table 1
|
||||||
trans_tbl(
|
trans_tbl(
|
||||||
3,
|
3,
|
||||||
@@ -1692,21 +1694,21 @@ mdro <- function(x = NULL,
|
|||||||
c(aminoglycosides, fluoroquinolones),
|
c(aminoglycosides, fluoroquinolones),
|
||||||
"all"
|
"all"
|
||||||
)
|
)
|
||||||
|
|
||||||
trans_tbl(
|
trans_tbl(
|
||||||
2,
|
2,
|
||||||
which(x$order == "Enterobacterales"), # following in fact the old Enterobacteriaceae classification
|
which(x$order == "Enterobacterales"), # following in fact the old Enterobacteriaceae classification
|
||||||
carbapenems,
|
carbapenems,
|
||||||
"any"
|
"any"
|
||||||
)
|
)
|
||||||
|
|
||||||
trans_tbl(
|
trans_tbl(
|
||||||
2,
|
2,
|
||||||
which(x$order == "Enterobacterales"), # following in fact the old Enterobacteriaceae classification
|
which(x$order == "Enterobacterales"), # following in fact the old Enterobacteriaceae classification
|
||||||
ESBLs,
|
ESBLs,
|
||||||
"all"
|
"all"
|
||||||
)
|
)
|
||||||
|
|
||||||
# Table 2
|
# Table 2
|
||||||
trans_tbl(
|
trans_tbl(
|
||||||
2,
|
2,
|
||||||
@@ -1720,19 +1722,19 @@ mdro <- function(x = NULL,
|
|||||||
c(aminoglycosides, fluoroquinolones),
|
c(aminoglycosides, fluoroquinolones),
|
||||||
"all"
|
"all"
|
||||||
)
|
)
|
||||||
|
|
||||||
trans_tbl(
|
trans_tbl(
|
||||||
3,
|
3,
|
||||||
which(x$genus == "Stenotrophomonas" & x$species == "maltophilia"),
|
which(x$genus == "Stenotrophomonas" & x$species == "maltophilia"),
|
||||||
SXT,
|
SXT,
|
||||||
"all"
|
"all"
|
||||||
)
|
)
|
||||||
|
|
||||||
if (!ab_missing(MEM) && !ab_missing(IPM) &&
|
if (!ab_missing(MEM) && !ab_missing(IPM) &&
|
||||||
!ab_missing(GEN) && !ab_missing(TOB) &&
|
!ab_missing(GEN) && !ab_missing(TOB) &&
|
||||||
!ab_missing(CIP) &&
|
!ab_missing(CIP) &&
|
||||||
!ab_missing(CAZ) &&
|
!ab_missing(CAZ) &&
|
||||||
!ab_missing(TZP)) {
|
!ab_missing(TZP)) {
|
||||||
x$psae <- 0
|
x$psae <- 0
|
||||||
x[which(x[, MEM, drop = TRUE] == "R" | x[, IPM, drop = TRUE] == "R"), "psae"] <- 1 + x[which(x[, MEM, drop = TRUE] == "R" | x[, IPM, drop = TRUE] == "R"), "psae"]
|
x[which(x[, MEM, drop = TRUE] == "R" | x[, IPM, drop = TRUE] == "R"), "psae"] <- 1 + x[which(x[, MEM, drop = TRUE] == "R" | x[, IPM, drop = TRUE] == "R"), "psae"]
|
||||||
x[which(x[, GEN, drop = TRUE] == "R" & x[, TOB, drop = TRUE] == "R"), "psae"] <- 1 + x[which(x[, GEN, drop = TRUE] == "R" & x[, TOB, drop = TRUE] == "R"), "psae"]
|
x[which(x[, GEN, drop = TRUE] == "R" & x[, TOB, drop = TRUE] == "R"), "psae"] <- 1 + x[which(x[, GEN, drop = TRUE] == "R" & x[, TOB, drop = TRUE] == "R"), "psae"]
|
||||||
@@ -1749,7 +1751,7 @@ mdro <- function(x = NULL,
|
|||||||
"any"
|
"any"
|
||||||
)
|
)
|
||||||
x[which(x$genus == "Pseudomonas" & x$species == "aeruginosa" & x$psae >= 3), "reason"] <- paste0("at least 3 classes contain R", ifelse(!isTRUE(combine_SI), " or I", ""))
|
x[which(x$genus == "Pseudomonas" & x$species == "aeruginosa" & x$psae >= 3), "reason"] <- paste0("at least 3 classes contain R", ifelse(!isTRUE(combine_SI), " or I", ""))
|
||||||
|
|
||||||
# Table 3
|
# Table 3
|
||||||
trans_tbl(
|
trans_tbl(
|
||||||
3,
|
3,
|
||||||
@@ -1848,7 +1850,7 @@ mdro <- function(x = NULL,
|
|||||||
" (3 required for MDR)"
|
" (3 required for MDR)"
|
||||||
)
|
)
|
||||||
} else {
|
} else {
|
||||||
#x[which(x$MDRO == 1), "reason"] <- "too few antibiotics are R"
|
# x[which(x$MDRO == 1), "reason"] <- "too few antibiotics are R"
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -1881,7 +1883,7 @@ mdro <- function(x = NULL,
|
|||||||
} else if (isTRUE(info.bak)) {
|
} else if (isTRUE(info.bak)) {
|
||||||
cat("\n")
|
cat("\n")
|
||||||
}
|
}
|
||||||
|
|
||||||
if (isTRUE(info.bak) && !isTRUE(verbose)) {
|
if (isTRUE(info.bak) && !isTRUE(verbose)) {
|
||||||
cat("\nRerun with 'verbose = TRUE' to retrieve detailed info and reasons for every MDRO classification.\n")
|
cat("\nRerun with 'verbose = TRUE' to retrieve detailed info and reasons for every MDRO classification.\n")
|
||||||
}
|
}
|
||||||
@@ -1932,8 +1934,8 @@ mdro <- function(x = NULL,
|
|||||||
ordered = TRUE
|
ordered = TRUE
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
if (isTRUE(verbose)) {
|
if (isTRUE(verbose)) {
|
||||||
# fill in empty reasons
|
# fill in empty reasons
|
||||||
x$reason[is.na(x$reason)] <- "not covered by guideline"
|
x$reason[is.na(x$reason)] <- "not covered by guideline"
|
||||||
|
|||||||
118
R/mic.R
118
R/mic.R
@@ -39,18 +39,22 @@ VALID_MIC_LEVELS <- c(
|
|||||||
)
|
)
|
||||||
VALID_MIC_LEVELS <- trimws(gsub("[.]?0+$", "", format(unique(sort(VALID_MIC_LEVELS)), scientific = FALSE), perl = TRUE))
|
VALID_MIC_LEVELS <- trimws(gsub("[.]?0+$", "", format(unique(sort(VALID_MIC_LEVELS)), scientific = FALSE), perl = TRUE))
|
||||||
operators <- c("<", "<=", "", ">=", ">")
|
operators <- c("<", "<=", "", ">=", ">")
|
||||||
VALID_MIC_LEVELS <- c(t(vapply(FUN.VALUE = character(length(VALID_MIC_LEVELS)),
|
VALID_MIC_LEVELS <- c(t(vapply(
|
||||||
c("<", "<=", "", ">=", ">"),
|
FUN.VALUE = character(length(VALID_MIC_LEVELS)),
|
||||||
paste0,
|
c("<", "<=", "", ">=", ">"),
|
||||||
VALID_MIC_LEVELS)))
|
paste0,
|
||||||
COMMON_MIC_VALUES <- c(0.0001, 0.0002, 0.0005,
|
VALID_MIC_LEVELS
|
||||||
0.001, 0.002, 0.004, 0.008,
|
)))
|
||||||
0.016, 0.032, 0.064,
|
COMMON_MIC_VALUES <- c(
|
||||||
0.125, 0.25, 0.5,
|
0.0001, 0.0002, 0.0005,
|
||||||
1, 2, 4, 8,
|
0.001, 0.002, 0.004, 0.008,
|
||||||
16, 32, 64,
|
0.016, 0.032, 0.064,
|
||||||
128, 256, 512,
|
0.125, 0.25, 0.5,
|
||||||
1024, 2048, 4096)
|
1, 2, 4, 8,
|
||||||
|
16, 32, 64,
|
||||||
|
128, 256, 512,
|
||||||
|
1024, 2048, 4096
|
||||||
|
)
|
||||||
|
|
||||||
#' Transform Input to Minimum Inhibitory Concentrations (MIC)
|
#' Transform Input to Minimum Inhibitory Concentrations (MIC)
|
||||||
#'
|
#'
|
||||||
@@ -103,7 +107,7 @@ COMMON_MIC_VALUES <- c(0.0001, 0.0002, 0.0005,
|
|||||||
#' Using [as.double()] or [as.numeric()] on MIC values will remove the operators and return a numeric vector. Do **not** use [as.integer()] on MIC values as by the \R convention on [factor]s, it will return the index of the factor levels (which is often useless for regular users).
|
#' Using [as.double()] or [as.numeric()] on MIC values will remove the operators and return a numeric vector. Do **not** use [as.integer()] on MIC values as by the \R convention on [factor]s, it will return the index of the factor levels (which is often useless for regular users).
|
||||||
#'
|
#'
|
||||||
#' Use [droplevels()] to drop unused levels. At default, it will return a plain factor. Use `droplevels(..., as.mic = TRUE)` to maintain the `mic` class.
|
#' Use [droplevels()] to drop unused levels. At default, it will return a plain factor. Use `droplevels(..., as.mic = TRUE)` to maintain the `mic` class.
|
||||||
#'
|
#'
|
||||||
#' With [rescale_mic()], existing MIC ranges can be limited to a defined range of MIC values. This can be useful to better compare MIC distributions.
|
#' With [rescale_mic()], existing MIC ranges can be limited to a defined range of MIC values. This can be useful to better compare MIC distributions.
|
||||||
#'
|
#'
|
||||||
#' For `ggplot2`, use one of the [`scale_*_mic()`][scale_x_mic()] functions to plot MIC values. They allows custom MIC ranges and to plot intermediate log2 levels for missing MIC values.
|
#' For `ggplot2`, use one of the [`scale_*_mic()`][scale_x_mic()] functions to plot MIC values. They allows custom MIC ranges and to plot intermediate log2 levels for missing MIC values.
|
||||||
@@ -123,7 +127,7 @@ COMMON_MIC_VALUES <- c(0.0001, 0.0002, 0.0005,
|
|||||||
#' fivenum(mic_data)
|
#' fivenum(mic_data)
|
||||||
#' quantile(mic_data)
|
#' quantile(mic_data)
|
||||||
#' all(mic_data < 512)
|
#' all(mic_data < 512)
|
||||||
#'
|
#'
|
||||||
#' # rescale MICs using rescale_mic()
|
#' # rescale MICs using rescale_mic()
|
||||||
#' rescale_mic(mic_data, mic_range = c(4, 16))
|
#' rescale_mic(mic_data, mic_range = c(4, 16))
|
||||||
#'
|
#'
|
||||||
@@ -160,16 +164,17 @@ as.mic <- function(x, na.rm = FALSE, keep_operators = "all") {
|
|||||||
} else if (isFALSE(keep_operators)) {
|
} else if (isFALSE(keep_operators)) {
|
||||||
keep_operators <- "none"
|
keep_operators <- "none"
|
||||||
}
|
}
|
||||||
|
|
||||||
if (is.mic(x) && (keep_operators == "all" || !any(x %like% "[>=<]", na.rm = TRUE))) {
|
if (is.mic(x) && (keep_operators == "all" || !any(x %like% "[>=<]", na.rm = TRUE))) {
|
||||||
if (!identical(levels(x), VALID_MIC_LEVELS)) {
|
if (!identical(levels(x), VALID_MIC_LEVELS)) {
|
||||||
# might be from an older AMR version - just update MIC factor levels
|
# might be from an older AMR version - just update MIC factor levels
|
||||||
x <- set_clean_class(factor(as.character(x), levels = VALID_MIC_LEVELS, ordered = TRUE),
|
x <- set_clean_class(factor(as.character(x), levels = VALID_MIC_LEVELS, ordered = TRUE),
|
||||||
new_class = c("mic", "ordered", "factor"))
|
new_class = c("mic", "ordered", "factor")
|
||||||
|
)
|
||||||
}
|
}
|
||||||
return(x)
|
return(x)
|
||||||
}
|
}
|
||||||
|
|
||||||
x.bak <- NULL
|
x.bak <- NULL
|
||||||
if (is.numeric(x)) {
|
if (is.numeric(x)) {
|
||||||
x.bak <- format(x, scientific = FALSE)
|
x.bak <- format(x, scientific = FALSE)
|
||||||
@@ -186,7 +191,7 @@ as.mic <- function(x, na.rm = FALSE, keep_operators = "all") {
|
|||||||
if (is.null(x.bak)) {
|
if (is.null(x.bak)) {
|
||||||
x.bak <- x
|
x.bak <- x
|
||||||
}
|
}
|
||||||
|
|
||||||
# comma to period
|
# comma to period
|
||||||
x <- gsub(",", ".", x, fixed = TRUE)
|
x <- gsub(",", ".", x, fixed = TRUE)
|
||||||
# transform Unicode for >= and <=
|
# transform Unicode for >= and <=
|
||||||
@@ -229,14 +234,14 @@ as.mic <- function(x, na.rm = FALSE, keep_operators = "all") {
|
|||||||
x <- gsub("(NA)+", "", x)
|
x <- gsub("(NA)+", "", x)
|
||||||
# trim it
|
# trim it
|
||||||
x <- trimws2(x)
|
x <- trimws2(x)
|
||||||
|
|
||||||
## previously unempty values now empty - should return a warning later on
|
## previously unempty values now empty - should return a warning later on
|
||||||
x[x.bak != "" & x == ""] <- "invalid"
|
x[x.bak != "" & x == ""] <- "invalid"
|
||||||
|
|
||||||
na_before <- x[is.na(x) | x == ""] %pm>% length()
|
na_before <- x[is.na(x) | x == ""] %pm>% length()
|
||||||
x[!as.character(x) %in% VALID_MIC_LEVELS] <- NA
|
x[!as.character(x) %in% VALID_MIC_LEVELS] <- NA
|
||||||
na_after <- x[is.na(x) | x == ""] %pm>% length()
|
na_after <- x[is.na(x) | x == ""] %pm>% length()
|
||||||
|
|
||||||
if (na_before != na_after) {
|
if (na_before != na_after) {
|
||||||
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ""] %pm>%
|
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ""] %pm>%
|
||||||
unique() %pm>%
|
unique() %pm>%
|
||||||
@@ -244,16 +249,16 @@ as.mic <- function(x, na.rm = FALSE, keep_operators = "all") {
|
|||||||
vector_and(quotes = TRUE)
|
vector_and(quotes = TRUE)
|
||||||
cur_col <- get_current_column()
|
cur_col <- get_current_column()
|
||||||
warning_("in `as.mic()`: ", na_after - na_before, " result",
|
warning_("in `as.mic()`: ", na_after - na_before, " result",
|
||||||
ifelse(na_after - na_before > 1, "s", ""),
|
ifelse(na_after - na_before > 1, "s", ""),
|
||||||
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
|
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
|
||||||
" truncated (",
|
" truncated (",
|
||||||
round(((na_after - na_before) / length(x)) * 100),
|
round(((na_after - na_before) / length(x)) * 100),
|
||||||
"%) that were invalid MICs: ",
|
"%) that were invalid MICs: ",
|
||||||
list_missing,
|
list_missing,
|
||||||
call = FALSE
|
call = FALSE
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
if (keep_operators == "none" && !all(is.na(x))) {
|
if (keep_operators == "none" && !all(is.na(x))) {
|
||||||
x <- gsub("[>=<]", "", x)
|
x <- gsub("[>=<]", "", x)
|
||||||
} else if (keep_operators == "edges" && !all(is.na(x))) {
|
} else if (keep_operators == "edges" && !all(is.na(x))) {
|
||||||
@@ -263,9 +268,10 @@ as.mic <- function(x, na.rm = FALSE, keep_operators = "all") {
|
|||||||
keep <- x[dbls == max(dbls, na.rm = TRUE) | dbls == min(dbls, na.rm = TRUE)]
|
keep <- x[dbls == max(dbls, na.rm = TRUE) | dbls == min(dbls, na.rm = TRUE)]
|
||||||
x[!x %in% keep] <- gsub("[>=<]", "", x[!x %in% keep])
|
x[!x %in% keep] <- gsub("[>=<]", "", x[!x %in% keep])
|
||||||
}
|
}
|
||||||
|
|
||||||
set_clean_class(factor(x, levels = VALID_MIC_LEVELS, ordered = TRUE),
|
set_clean_class(factor(x, levels = VALID_MIC_LEVELS, ordered = TRUE),
|
||||||
new_class = c("mic", "ordered", "factor"))
|
new_class = c("mic", "ordered", "factor")
|
||||||
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
#' @rdname as.mic
|
#' @rdname as.mic
|
||||||
@@ -294,17 +300,19 @@ rescale_mic <- function(x, mic_range, keep_operators = "edges", as.mic = TRUE) {
|
|||||||
} else if (is.mic(mic_range)) {
|
} else if (is.mic(mic_range)) {
|
||||||
mic_range <- as.character(mic_range)
|
mic_range <- as.character(mic_range)
|
||||||
}
|
}
|
||||||
stop_ifnot(all(mic_range %in% c(VALID_MIC_LEVELS, NA)),
|
stop_ifnot(
|
||||||
"Values in `mic_range` must be valid MIC values. ",
|
all(mic_range %in% c(VALID_MIC_LEVELS, NA)),
|
||||||
"The allowed range is ", format(as.double(as.mic(VALID_MIC_LEVELS)[1]), scientific = FALSE), " to ", format(as.double(as.mic(VALID_MIC_LEVELS)[length(VALID_MIC_LEVELS)]), scientific = FALSE), ". ",
|
"Values in `mic_range` must be valid MIC values. ",
|
||||||
"Unvalid: ", vector_and(mic_range[!mic_range %in% c(VALID_MIC_LEVELS, NA)], quotes = FALSE), ".")
|
"The allowed range is ", format(as.double(as.mic(VALID_MIC_LEVELS)[1]), scientific = FALSE), " to ", format(as.double(as.mic(VALID_MIC_LEVELS)[length(VALID_MIC_LEVELS)]), scientific = FALSE), ". ",
|
||||||
|
"Unvalid: ", vector_and(mic_range[!mic_range %in% c(VALID_MIC_LEVELS, NA)], quotes = FALSE), "."
|
||||||
|
)
|
||||||
|
|
||||||
x <- as.mic(x)
|
x <- as.mic(x)
|
||||||
if (is.null(mic_range)) {
|
if (is.null(mic_range)) {
|
||||||
mic_range <- c(NA, NA)
|
mic_range <- c(NA, NA)
|
||||||
}
|
}
|
||||||
mic_range <- as.mic(mic_range)
|
mic_range <- as.mic(mic_range)
|
||||||
|
|
||||||
min_mic <- mic_range[1]
|
min_mic <- mic_range[1]
|
||||||
max_mic <- mic_range[2]
|
max_mic <- mic_range[2]
|
||||||
if (!is.na(min_mic)) {
|
if (!is.na(min_mic)) {
|
||||||
@@ -313,9 +321,9 @@ rescale_mic <- function(x, mic_range, keep_operators = "edges", as.mic = TRUE) {
|
|||||||
if (!is.na(max_mic)) {
|
if (!is.na(max_mic)) {
|
||||||
x[x > max_mic] <- max_mic
|
x[x > max_mic] <- max_mic
|
||||||
}
|
}
|
||||||
|
|
||||||
x <- as.mic(x, keep_operators = ifelse(keep_operators == "edges", "none", keep_operators))
|
x <- as.mic(x, keep_operators = ifelse(keep_operators == "edges", "none", keep_operators))
|
||||||
|
|
||||||
if (isTRUE(as.mic)) {
|
if (isTRUE(as.mic)) {
|
||||||
if (keep_operators == "edges" && length(x) > 1) {
|
if (keep_operators == "edges" && length(x) > 1) {
|
||||||
x[x == min(x, na.rm = TRUE)] <- paste0("<=", x[x == min(x, na.rm = TRUE)])
|
x[x == min(x, na.rm = TRUE)] <- paste0("<=", x[x == min(x, na.rm = TRUE)])
|
||||||
@@ -323,25 +331,27 @@ rescale_mic <- function(x, mic_range, keep_operators = "edges", as.mic = TRUE) {
|
|||||||
}
|
}
|
||||||
return(x)
|
return(x)
|
||||||
}
|
}
|
||||||
|
|
||||||
# create a manual factor with levels only within desired range
|
# create a manual factor with levels only within desired range
|
||||||
expanded <- plotrange_as_table(x,
|
expanded <- plotrange_as_table(x,
|
||||||
expand = TRUE,
|
expand = TRUE,
|
||||||
keep_operators = ifelse(keep_operators == "edges", "none", keep_operators),
|
keep_operators = ifelse(keep_operators == "edges", "none", keep_operators),
|
||||||
mic_range = mic_range)
|
mic_range = mic_range
|
||||||
|
)
|
||||||
if (keep_operators == "edges") {
|
if (keep_operators == "edges") {
|
||||||
names(expanded)[1] <- paste0("<=", names(expanded)[1])
|
names(expanded)[1] <- paste0("<=", names(expanded)[1])
|
||||||
names(expanded)[length(expanded)] <- paste0(">=", names(expanded)[length(expanded)])
|
names(expanded)[length(expanded)] <- paste0(">=", names(expanded)[length(expanded)])
|
||||||
}
|
}
|
||||||
# MICs contain all MIC levels, so strip this to only existing levels and their intermediate values
|
# MICs contain all MIC levels, so strip this to only existing levels and their intermediate values
|
||||||
out <- factor(names(expanded),
|
out <- factor(names(expanded),
|
||||||
levels = names(expanded),
|
levels = names(expanded),
|
||||||
ordered = TRUE)
|
ordered = TRUE
|
||||||
|
)
|
||||||
# and only keep the ones in the data
|
# and only keep the ones in the data
|
||||||
if (keep_operators == "edges") {
|
if (keep_operators == "edges") {
|
||||||
out <- out[match(x, as.double(as.mic(out, keep_operators = "all")))]
|
out <- out[match(x, as.double(as.mic(out, keep_operators = "all")))]
|
||||||
} else {
|
} else {
|
||||||
out <- out[match(x, out)]
|
out <- out[match(x, out)]
|
||||||
}
|
}
|
||||||
out
|
out
|
||||||
}
|
}
|
||||||
@@ -393,16 +403,17 @@ all_valid_mics <- function(x) {
|
|||||||
return(FALSE)
|
return(FALSE)
|
||||||
}
|
}
|
||||||
x_mic <- tryCatch(suppressWarnings(as.mic(x[!is.na(x)])),
|
x_mic <- tryCatch(suppressWarnings(as.mic(x[!is.na(x)])),
|
||||||
error = function(e) NA
|
error = function(e) NA
|
||||||
)
|
)
|
||||||
!any(is.na(x_mic)) && !all(is.na(x))
|
!any(is.na(x_mic)) && !all(is.na(x))
|
||||||
}
|
}
|
||||||
|
|
||||||
# will be exported using s3_register() in R/zzz.R
|
# will be exported using s3_register() in R/zzz.R
|
||||||
pillar_shaft.mic <- function(x, ...) {
|
pillar_shaft.mic <- function(x, ...) {
|
||||||
if(!identical(levels(x), VALID_MIC_LEVELS) && message_not_thrown_before("pillar_shaft.mic")) {
|
if (!identical(levels(x), VALID_MIC_LEVELS) && message_not_thrown_before("pillar_shaft.mic")) {
|
||||||
warning_(AMR_env$sup_1_icon, " These columns contain an outdated or altered structure - convert with `as.mic()` to update",
|
warning_(AMR_env$sup_1_icon, " These columns contain an outdated or altered structure - convert with `as.mic()` to update",
|
||||||
call = FALSE)
|
call = FALSE
|
||||||
|
)
|
||||||
}
|
}
|
||||||
crude_numbers <- as.double(x)
|
crude_numbers <- as.double(x)
|
||||||
operators <- gsub("[^<=>]+", "", as.character(x))
|
operators <- gsub("[^<=>]+", "", as.character(x))
|
||||||
@@ -416,7 +427,7 @@ pillar_shaft.mic <- function(x, ...) {
|
|||||||
|
|
||||||
# will be exported using s3_register() in R/zzz.R
|
# will be exported using s3_register() in R/zzz.R
|
||||||
type_sum.mic <- function(x, ...) {
|
type_sum.mic <- function(x, ...) {
|
||||||
if(!identical(levels(x), VALID_MIC_LEVELS)) {
|
if (!identical(levels(x), VALID_MIC_LEVELS)) {
|
||||||
paste0("mic", AMR_env$sup_1_icon)
|
paste0("mic", AMR_env$sup_1_icon)
|
||||||
} else {
|
} else {
|
||||||
"mic"
|
"mic"
|
||||||
@@ -428,7 +439,7 @@ type_sum.mic <- function(x, ...) {
|
|||||||
#' @noRd
|
#' @noRd
|
||||||
print.mic <- function(x, ...) {
|
print.mic <- function(x, ...) {
|
||||||
cat("Class 'mic'")
|
cat("Class 'mic'")
|
||||||
if(!identical(levels(x), VALID_MIC_LEVELS)) {
|
if (!identical(levels(x), VALID_MIC_LEVELS)) {
|
||||||
cat(font_red(" with an outdated or altered structure - convert with `as.mic()` to update"))
|
cat(font_red(" with an outdated or altered structure - convert with `as.mic()` to update"))
|
||||||
}
|
}
|
||||||
cat("\n")
|
cat("\n")
|
||||||
@@ -649,5 +660,6 @@ Summary.mic <- function(..., na.rm = FALSE) {
|
|||||||
# NextMethod() cannot be called from an anonymous function (`...`), so we get() the generic directly:
|
# NextMethod() cannot be called from an anonymous function (`...`), so we get() the generic directly:
|
||||||
fn <- get(.Generic, envir = .GenericCallEnv)
|
fn <- get(.Generic, envir = .GenericCallEnv)
|
||||||
fn(as.double(c(...)),
|
fn(as.double(c(...)),
|
||||||
na.rm = na.rm)
|
na.rm = na.rm
|
||||||
|
)
|
||||||
}
|
}
|
||||||
|
|||||||
365
R/mo.R
365
R/mo.R
@@ -50,7 +50,7 @@
|
|||||||
#' @aliases mo
|
#' @aliases mo
|
||||||
#' @details
|
#' @details
|
||||||
#' A microorganism (MO) code from this package (class: [`mo`]) is human-readable and typically looks like these examples:
|
#' A microorganism (MO) code from this package (class: [`mo`]) is human-readable and typically looks like these examples:
|
||||||
#'
|
#'
|
||||||
#' ```
|
#' ```
|
||||||
#' Code Full name
|
#' Code Full name
|
||||||
#' --------------- --------------------------------------
|
#' --------------- --------------------------------------
|
||||||
@@ -85,40 +85,40 @@
|
|||||||
#' - Use [mo_renamed()] to get a [data.frame] with all values that could be coerced based on old, previously accepted taxonomic names.
|
#' - Use [mo_renamed()] to get a [data.frame] with all values that could be coerced based on old, previously accepted taxonomic names.
|
||||||
#'
|
#'
|
||||||
#' ### For Mycologists
|
#' ### For Mycologists
|
||||||
#'
|
#'
|
||||||
#' The [matching score algorithm][mo_matching_score()] gives precedence to bacteria over fungi. If you are only analysing fungi, be sure to use `only_fungi = TRUE`, or better yet, add this to your code and run it once every session:
|
#' The [matching score algorithm][mo_matching_score()] gives precedence to bacteria over fungi. If you are only analysing fungi, be sure to use `only_fungi = TRUE`, or better yet, add this to your code and run it once every session:
|
||||||
#'
|
#'
|
||||||
#' ```r
|
#' ```r
|
||||||
#' options(AMR_only_fungi = TRUE)
|
#' options(AMR_only_fungi = TRUE)
|
||||||
#' ```
|
#' ```
|
||||||
#'
|
#'
|
||||||
#' This will make sure that no bacteria or other 'non-fungi' will be returned by [as.mo()], or any of the [`mo_*`][mo_property()] functions.
|
#' This will make sure that no bacteria or other 'non-fungi' will be returned by [as.mo()], or any of the [`mo_*`][mo_property()] functions.
|
||||||
#'
|
#'
|
||||||
#' ### Coagulase-negative and Coagulase-positive Staphylococci
|
#' ### Coagulase-negative and Coagulase-positive Staphylococci
|
||||||
#'
|
#'
|
||||||
#' With `Becker = TRUE`, the following staphylococci will be converted to their corresponding coagulase group:
|
#' With `Becker = TRUE`, the following staphylococci will be converted to their corresponding coagulase group:
|
||||||
#'
|
#'
|
||||||
#' * Coagulase-negative: `r vector_and(gsub("Staphylococcus", "S.", mo_name(MO_CONS[MO_CONS != "B_STPHY_CONS"], keep_synonyms = TRUE)), quotes = "*")`
|
#' * Coagulase-negative: `r vector_and(gsub("Staphylococcus", "S.", mo_name(MO_CONS[MO_CONS != "B_STPHY_CONS"], keep_synonyms = TRUE)), quotes = "*")`
|
||||||
#' * Coagulase-positive: `r vector_and(gsub("Staphylococcus", "S.", mo_name(MO_COPS[MO_COPS != "B_STPHY_COPS"], keep_synonyms = TRUE)), quotes = "*")`
|
#' * Coagulase-positive: `r vector_and(gsub("Staphylococcus", "S.", mo_name(MO_COPS[MO_COPS != "B_STPHY_COPS"], keep_synonyms = TRUE)), quotes = "*")`
|
||||||
#'
|
#'
|
||||||
#' This is based on:
|
#' This is based on:
|
||||||
#'
|
#'
|
||||||
#' * Becker K *et al.* (2014). **Coagulase-Negative Staphylococci.** *Clin Microbiol Rev.* 27(4): 870-926; \doi{10.1128/CMR.00109-13}
|
#' * Becker K *et al.* (2014). **Coagulase-Negative Staphylococci.** *Clin Microbiol Rev.* 27(4): 870-926; \doi{10.1128/CMR.00109-13}
|
||||||
#' * Becker K *et al.* (2019). **Implications of identifying the recently defined members of the *S. aureus* complex, *S. argenteus* and *S. schweitzeri*: A position paper of members of the ESCMID Study Group for staphylococci and Staphylococcal Diseases (ESGS).** *Clin Microbiol Infect*; \doi{10.1016/j.cmi.2019.02.028}
|
#' * Becker K *et al.* (2019). **Implications of identifying the recently defined members of the *S. aureus* complex, *S. argenteus* and *S. schweitzeri*: A position paper of members of the ESCMID Study Group for staphylococci and Staphylococcal Diseases (ESGS).** *Clin Microbiol Infect*; \doi{10.1016/j.cmi.2019.02.028}
|
||||||
#' * Becker K *et al.* (2020). **Emergence of coagulase-negative staphylococci.** *Expert Rev Anti Infect Ther.* 18(4):349-366; \doi{10.1080/14787210.2020.1730813}
|
#' * Becker K *et al.* (2020). **Emergence of coagulase-negative staphylococci.** *Expert Rev Anti Infect Ther.* 18(4):349-366; \doi{10.1080/14787210.2020.1730813}
|
||||||
#'
|
#'
|
||||||
#' For newly named staphylococcal species, such as *S. brunensis* (2024) and *S. shinii* (2023), we looked up the scientific reference to make sure the species are considered for the correct coagulase group.
|
#' For newly named staphylococcal species, such as *S. brunensis* (2024) and *S. shinii* (2023), we looked up the scientific reference to make sure the species are considered for the correct coagulase group.
|
||||||
#'
|
#'
|
||||||
#' ### Lancefield Groups in Streptococci
|
#' ### Lancefield Groups in Streptococci
|
||||||
#'
|
#'
|
||||||
#' With `Lancefield = TRUE`, the following streptococci will be converted to their corresponding Lancefield group:
|
#' With `Lancefield = TRUE`, the following streptococci will be converted to their corresponding Lancefield group:
|
||||||
#'
|
#'
|
||||||
#' * `r paste(apply(aggregate(mo_name ~ mo_group_name, data = microorganisms.groups[microorganisms.groups$mo_group_name %like_case% "Streptococcus Group [A-Z]$", ], FUN = function(x) vector_and(gsub("Streptococcus", "S.", x, fixed = TRUE), quotes = "*", sort = TRUE)), 1, function(row) paste(row["mo_group_name"], ": ", row["mo_name"], sep = "")), collapse = "\n* ")`
|
#' * `r paste(apply(aggregate(mo_name ~ mo_group_name, data = microorganisms.groups[microorganisms.groups$mo_group_name %like_case% "Streptococcus Group [A-Z]$", ], FUN = function(x) vector_and(gsub("Streptococcus", "S.", x, fixed = TRUE), quotes = "*", sort = TRUE)), 1, function(row) paste(row["mo_group_name"], ": ", row["mo_name"], sep = "")), collapse = "\n* ")`
|
||||||
#'
|
#'
|
||||||
#' This is based on:
|
#' This is based on:
|
||||||
#'
|
#'
|
||||||
#' * Lancefield RC (1933). **A serological differentiation of human and other groups of hemolytic streptococci.** *J Exp Med.* 57(4): 571-95; \doi{10.1084/jem.57.4.571}
|
#' * Lancefield RC (1933). **A serological differentiation of human and other groups of hemolytic streptococci.** *J Exp Med.* 57(4): 571-95; \doi{10.1084/jem.57.4.571}
|
||||||
#'
|
#'
|
||||||
#' @inheritSection mo_matching_score Matching Score for Microorganisms
|
#' @inheritSection mo_matching_score Matching Score for Microorganisms
|
||||||
#'
|
#'
|
||||||
# (source as a section here, so it can be inherited by other man pages)
|
# (source as a section here, so it can be inherited by other man pages)
|
||||||
@@ -161,7 +161,7 @@
|
|||||||
#' "Ureaplasmium urealytica",
|
#' "Ureaplasmium urealytica",
|
||||||
#' "Ureaplazma urealitycium"
|
#' "Ureaplazma urealitycium"
|
||||||
#' ))
|
#' ))
|
||||||
#'
|
#'
|
||||||
#' # input will get cleaned up with the input given in the `cleaning_regex` argument,
|
#' # input will get cleaned up with the input given in the `cleaning_regex` argument,
|
||||||
#' # which defaults to `mo_cleaning_regex()`:
|
#' # which defaults to `mo_cleaning_regex()`:
|
||||||
#' cat(mo_cleaning_regex(), "\n")
|
#' cat(mo_cleaning_regex(), "\n")
|
||||||
@@ -202,34 +202,34 @@ as.mo <- function(x,
|
|||||||
meet_criteria(only_fungi, allow_class = "logical", has_length = 1)
|
meet_criteria(only_fungi, allow_class = "logical", has_length = 1)
|
||||||
language <- validate_language(language)
|
language <- validate_language(language)
|
||||||
meet_criteria(info, allow_class = "logical", has_length = 1)
|
meet_criteria(info, allow_class = "logical", has_length = 1)
|
||||||
|
|
||||||
add_MO_lookup_to_AMR_env()
|
add_MO_lookup_to_AMR_env()
|
||||||
|
|
||||||
if (tryCatch(all(x %in% c(AMR_env$MO_lookup$mo, NA)), error = function(e) FALSE) &&
|
if (tryCatch(all(x %in% c(AMR_env$MO_lookup$mo, NA)), error = function(e) FALSE) &&
|
||||||
isFALSE(Becker) &&
|
isFALSE(Becker) &&
|
||||||
isFALSE(Lancefield) &&
|
isFALSE(Lancefield) &&
|
||||||
isTRUE(keep_synonyms)) {
|
isTRUE(keep_synonyms)) {
|
||||||
# don't look into valid MO codes, just return them
|
# don't look into valid MO codes, just return them
|
||||||
# is.mo() won't work - MO codes might change between package versions
|
# is.mo() won't work - MO codes might change between package versions
|
||||||
return(set_clean_class(x, new_class = c("mo", "character")))
|
return(set_clean_class(x, new_class = c("mo", "character")))
|
||||||
}
|
}
|
||||||
|
|
||||||
# start off with replaced language-specific non-ASCII characters with ASCII characters
|
# start off with replaced language-specific non-ASCII characters with ASCII characters
|
||||||
x <- parse_and_convert(x)
|
x <- parse_and_convert(x)
|
||||||
# replace mo codes used in older package versions
|
# replace mo codes used in older package versions
|
||||||
x <- replace_old_mo_codes(x, property = "mo")
|
x <- replace_old_mo_codes(x, property = "mo")
|
||||||
# ignore cases that match the ignore pattern
|
# ignore cases that match the ignore pattern
|
||||||
x <- replace_ignore_pattern(x, ignore_pattern)
|
x <- replace_ignore_pattern(x, ignore_pattern)
|
||||||
|
|
||||||
x_lower <- tolower(x)
|
x_lower <- tolower(x)
|
||||||
|
|
||||||
# WHONET: xxx = no growth
|
# WHONET: xxx = no growth
|
||||||
x[x_lower %in% c("", "xxx", "na", "nan")] <- NA_character_
|
x[x_lower %in% c("", "xxx", "na", "nan")] <- NA_character_
|
||||||
|
|
||||||
out <- rep(NA_character_, length(x))
|
out <- rep(NA_character_, length(x))
|
||||||
|
|
||||||
# below we use base R's match(), known for powering '%in%', and incredibly fast!
|
# below we use base R's match(), known for powering '%in%', and incredibly fast!
|
||||||
|
|
||||||
# From reference_df ----
|
# From reference_df ----
|
||||||
reference_df <- repair_reference_df(reference_df)
|
reference_df <- repair_reference_df(reference_df)
|
||||||
if (!is.null(reference_df)) {
|
if (!is.null(reference_df)) {
|
||||||
@@ -261,38 +261,38 @@ as.mo <- function(x,
|
|||||||
" for ", vector_and(x[is.na(old) & !is.na(new)]), ". Run `mo_reset_session()` to reset this. This note will be shown once per session for this input."
|
" for ", vector_and(x[is.na(old) & !is.na(new)]), ". Run `mo_reset_session()` to reset this. This note will be shown once per session for this input."
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
# For all other input ----
|
# For all other input ----
|
||||||
if (any(is.na(out) & !is.na(x))) {
|
if (any(is.na(out) & !is.na(x))) {
|
||||||
# reset uncertainties
|
# reset uncertainties
|
||||||
AMR_env$mo_uncertainties <- AMR_env$mo_uncertainties[0, ]
|
AMR_env$mo_uncertainties <- AMR_env$mo_uncertainties[0, ]
|
||||||
AMR_env$mo_failures <- NULL
|
AMR_env$mo_failures <- NULL
|
||||||
|
|
||||||
# Laboratory systems: remove (translated) entries like "no growth", "not E. coli", etc.
|
# Laboratory systems: remove (translated) entries like "no growth", "not E. coli", etc.
|
||||||
x[trimws2(x) %like% translate_into_language("no .*growth", language = language)] <- NA_character_
|
x[trimws2(x) %like% translate_into_language("no .*growth", language = language)] <- NA_character_
|
||||||
x[trimws2(x) %like% paste0("^(", translate_into_language("no|not", language = language), ") ")] <- NA_character_
|
x[trimws2(x) %like% paste0("^(", translate_into_language("no|not", language = language), ") ")] <- NA_character_
|
||||||
|
|
||||||
# groups are in our taxonomic table with a capital G
|
# groups are in our taxonomic table with a capital G
|
||||||
x <- gsub(" group( |$)", " Group\\1", x, perl = TRUE)
|
x <- gsub(" group( |$)", " Group\\1", x, perl = TRUE)
|
||||||
|
|
||||||
# run over all unique leftovers
|
# run over all unique leftovers
|
||||||
x_unique <- unique(x[is.na(out) & !is.na(x)])
|
x_unique <- unique(x[is.na(out) & !is.na(x)])
|
||||||
|
|
||||||
# set up progress bar
|
# set up progress bar
|
||||||
progress <- progress_ticker(n = length(x_unique), n_min = 10, print = info, title = "Converting microorganism input")
|
progress <- progress_ticker(n = length(x_unique), n_min = 10, print = info, title = "Converting microorganism input")
|
||||||
on.exit(close(progress))
|
on.exit(close(progress))
|
||||||
|
|
||||||
msg <- character(0)
|
msg <- character(0)
|
||||||
|
|
||||||
MO_lookup_current <- AMR_env$MO_lookup
|
MO_lookup_current <- AMR_env$MO_lookup
|
||||||
if (isTRUE(only_fungi)) {
|
if (isTRUE(only_fungi)) {
|
||||||
MO_lookup_current <- MO_lookup_current[MO_lookup_current$kingdom == "Fungi", , drop = FALSE]
|
MO_lookup_current <- MO_lookup_current[MO_lookup_current$kingdom == "Fungi", , drop = FALSE]
|
||||||
}
|
}
|
||||||
|
|
||||||
# run it
|
# run it
|
||||||
x_coerced <- vapply(FUN.VALUE = character(1), x_unique, function(x_search) {
|
x_coerced <- vapply(FUN.VALUE = character(1), x_unique, function(x_search) {
|
||||||
progress$tick()
|
progress$tick()
|
||||||
|
|
||||||
# some required cleaning steps
|
# some required cleaning steps
|
||||||
x_out <- trimws2(x_search)
|
x_out <- trimws2(x_search)
|
||||||
# this applies the `cleaning_regex` argument, which defaults to mo_cleaning_regex()
|
# this applies the `cleaning_regex` argument, which defaults to mo_cleaning_regex()
|
||||||
@@ -302,17 +302,17 @@ as.mo <- function(x,
|
|||||||
x_out <- tolower(x_out)
|
x_out <- tolower(x_out)
|
||||||
# when x_search_cleaned are only capitals (such as in codes), make them lowercase to increase matching score
|
# when x_search_cleaned are only capitals (such as in codes), make them lowercase to increase matching score
|
||||||
x_search_cleaned[x_search_cleaned == toupper(x_search_cleaned)] <- x_out[x_search_cleaned == toupper(x_search_cleaned)]
|
x_search_cleaned[x_search_cleaned == toupper(x_search_cleaned)] <- x_out[x_search_cleaned == toupper(x_search_cleaned)]
|
||||||
|
|
||||||
# first check if cleaning led to an exact result, case-insensitive
|
# first check if cleaning led to an exact result, case-insensitive
|
||||||
if (x_out %in% MO_lookup_current$fullname_lower) {
|
if (x_out %in% MO_lookup_current$fullname_lower) {
|
||||||
return(as.character(MO_lookup_current$mo[match(x_out, MO_lookup_current$fullname_lower)]))
|
return(as.character(MO_lookup_current$mo[match(x_out, MO_lookup_current$fullname_lower)]))
|
||||||
}
|
}
|
||||||
|
|
||||||
# input must not be too short
|
# input must not be too short
|
||||||
if (nchar(x_out) < 3) {
|
if (nchar(x_out) < 3) {
|
||||||
return("UNKNOWN")
|
return("UNKNOWN")
|
||||||
}
|
}
|
||||||
|
|
||||||
# take out the parts, split by space
|
# take out the parts, split by space
|
||||||
x_parts <- strsplit(gsub("-", " ", x_out, fixed = TRUE), " ", fixed = TRUE)[[1]]
|
x_parts <- strsplit(gsub("-", " ", x_out, fixed = TRUE), " ", fixed = TRUE)[[1]]
|
||||||
# do a pre-match on first character (and if it contains a space, first chars of first two terms)
|
# do a pre-match on first character (and if it contains a space, first chars of first two terms)
|
||||||
@@ -326,14 +326,14 @@ as.mo <- function(x,
|
|||||||
minimum_matching_score <- 0.05
|
minimum_matching_score <- 0.05
|
||||||
} else if (nchar(gsub("[^a-z]", "", x_parts[1], perl = TRUE)) <= 3) {
|
} else if (nchar(gsub("[^a-z]", "", x_parts[1], perl = TRUE)) <= 3) {
|
||||||
filtr <- which(MO_lookup_current$full_first == substr(x_parts[1], 1, 1) &
|
filtr <- which(MO_lookup_current$full_first == substr(x_parts[1], 1, 1) &
|
||||||
(MO_lookup_current$species_first == substr(x_parts[2], 1, 1) |
|
(MO_lookup_current$species_first == substr(x_parts[2], 1, 1) |
|
||||||
MO_lookup_current$subspecies_first == substr(x_parts[2], 1, 1) |
|
MO_lookup_current$subspecies_first == substr(x_parts[2], 1, 1) |
|
||||||
MO_lookup_current$subspecies_first == substr(x_parts[3], 1, 1)))
|
MO_lookup_current$subspecies_first == substr(x_parts[3], 1, 1)))
|
||||||
} else {
|
} else {
|
||||||
filtr <- which(MO_lookup_current$full_first == substr(x_parts[1], 1, 1) |
|
filtr <- which(MO_lookup_current$full_first == substr(x_parts[1], 1, 1) |
|
||||||
MO_lookup_current$species_first == substr(x_parts[2], 1, 1) |
|
MO_lookup_current$species_first == substr(x_parts[2], 1, 1) |
|
||||||
MO_lookup_current$subspecies_first == substr(x_parts[2], 1, 1) |
|
MO_lookup_current$subspecies_first == substr(x_parts[2], 1, 1) |
|
||||||
MO_lookup_current$subspecies_first == substr(x_parts[3], 1, 1))
|
MO_lookup_current$subspecies_first == substr(x_parts[3], 1, 1))
|
||||||
}
|
}
|
||||||
} else if (length(x_parts) > 3) {
|
} else if (length(x_parts) > 3) {
|
||||||
first_chars <- paste0("(^| )[", paste(substr(x_parts, 1, 1), collapse = ""), "]")
|
first_chars <- paste0("(^| )[", paste(substr(x_parts, 1, 1), collapse = ""), "]")
|
||||||
@@ -355,15 +355,15 @@ as.mo <- function(x,
|
|||||||
} else {
|
} else {
|
||||||
# for genus or species or subspecies
|
# for genus or species or subspecies
|
||||||
filtr <- which(MO_lookup_current$full_first == substr(x_parts, 1, 1) |
|
filtr <- which(MO_lookup_current$full_first == substr(x_parts, 1, 1) |
|
||||||
MO_lookup_current$species_first == substr(x_parts, 1, 1) |
|
MO_lookup_current$species_first == substr(x_parts, 1, 1) |
|
||||||
MO_lookup_current$subspecies_first == substr(x_parts, 1, 1))
|
MO_lookup_current$subspecies_first == substr(x_parts, 1, 1))
|
||||||
}
|
}
|
||||||
if (length(filtr) == 0) {
|
if (length(filtr) == 0) {
|
||||||
mo_to_search <- MO_lookup_current$fullname
|
mo_to_search <- MO_lookup_current$fullname
|
||||||
} else {
|
} else {
|
||||||
mo_to_search <- MO_lookup_current$fullname[filtr]
|
mo_to_search <- MO_lookup_current$fullname[filtr]
|
||||||
}
|
}
|
||||||
|
|
||||||
AMR_env$mo_to_search <- mo_to_search
|
AMR_env$mo_to_search <- mo_to_search
|
||||||
# determine the matching score on the original search value
|
# determine the matching score on the original search value
|
||||||
m <- mo_matching_score(x = x_search_cleaned, n = mo_to_search)
|
m <- mo_matching_score(x = x_search_cleaned, n = mo_to_search)
|
||||||
@@ -385,7 +385,7 @@ as.mo <- function(x,
|
|||||||
m[m < minimum_matching_score] <- NA_real_
|
m[m < minimum_matching_score] <- NA_real_
|
||||||
minimum_matching_score_current <- minimum_matching_score
|
minimum_matching_score_current <- minimum_matching_score
|
||||||
}
|
}
|
||||||
|
|
||||||
top_hits <- mo_to_search[order(m, decreasing = TRUE, na.last = NA)] # na.last = NA will remove the NAs
|
top_hits <- mo_to_search[order(m, decreasing = TRUE, na.last = NA)] # na.last = NA will remove the NAs
|
||||||
if (length(top_hits) == 0) {
|
if (length(top_hits) == 0) {
|
||||||
warning_("No hits found for \"", x_search, "\" with minimum_matching_score = ", ifelse(is.null(minimum_matching_score), paste0("NULL (=", round(min(minimum_matching_score_current, na.rm = TRUE), 3), ")"), minimum_matching_score), ". Try setting this value lower or even to 0.", call = FALSE)
|
warning_("No hits found for \"", x_search, "\" with minimum_matching_score = ", ifelse(is.null(minimum_matching_score), paste0("NULL (=", round(min(minimum_matching_score_current, na.rm = TRUE), 3), ")"), minimum_matching_score), ". Try setting this value lower or even to 0.", call = FALSE)
|
||||||
@@ -418,12 +418,12 @@ as.mo <- function(x,
|
|||||||
# the actual result:
|
# the actual result:
|
||||||
as.character(result_mo)
|
as.character(result_mo)
|
||||||
})
|
})
|
||||||
|
|
||||||
# remove progress bar from console
|
# remove progress bar from console
|
||||||
close(progress)
|
close(progress)
|
||||||
# expand from unique again
|
# expand from unique again
|
||||||
out[is.na(out)] <- x_coerced[match(x[is.na(out)], x_unique)]
|
out[is.na(out)] <- x_coerced[match(x[is.na(out)], x_unique)]
|
||||||
|
|
||||||
# Throw note about uncertainties ----
|
# Throw note about uncertainties ----
|
||||||
if (isTRUE(info) && NROW(AMR_env$mo_uncertainties) > 0) {
|
if (isTRUE(info) && NROW(AMR_env$mo_uncertainties) > 0) {
|
||||||
if (message_not_thrown_before("as.mo", "uncertainties", AMR_env$mo_uncertainties$original_input)) {
|
if (message_not_thrown_before("as.mo", "uncertainties", AMR_env$mo_uncertainties$original_input)) {
|
||||||
@@ -446,14 +446,14 @@ as.mo <- function(x,
|
|||||||
"Microorganism translation was uncertain for ", examples,
|
"Microorganism translation was uncertain for ", examples,
|
||||||
". Run `mo_uncertainties()` to review ", plural[2], ", or use `add_custom_microorganisms()` to add custom entries."
|
". Run `mo_uncertainties()` to review ", plural[2], ", or use `add_custom_microorganisms()` to add custom entries."
|
||||||
))
|
))
|
||||||
|
|
||||||
for (m in msg) {
|
for (m in msg) {
|
||||||
message_(m)
|
message_(m)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
} # end of loop over all yet unknowns
|
} # end of loop over all yet unknowns
|
||||||
|
|
||||||
# Keep or replace synonyms ----
|
# Keep or replace synonyms ----
|
||||||
out_current <- synonym_mo_to_accepted_mo(out, fill_in_accepted = FALSE)
|
out_current <- synonym_mo_to_accepted_mo(out, fill_in_accepted = FALSE)
|
||||||
AMR_env$mo_renamed <- list(old = out[!is.na(out_current)])
|
AMR_env$mo_renamed <- list(old = out[!is.na(out_current)])
|
||||||
@@ -466,14 +466,14 @@ as.mo <- function(x,
|
|||||||
# keep synonyms is TRUE, so check if any do have synonyms
|
# keep synonyms is TRUE, so check if any do have synonyms
|
||||||
warning_("Function `as.mo()` returned ", nr2char(length(unique(AMR_env$mo_renamed$old))), " old taxonomic name", ifelse(length(unique(AMR_env$mo_renamed$old)) > 1, "s", ""), ". Use `as.mo(..., keep_synonyms = FALSE)` to clean the input to currently accepted taxonomic names, or set the R option `AMR_keep_synonyms` to `FALSE`. This warning will be shown once per session.", call = FALSE)
|
warning_("Function `as.mo()` returned ", nr2char(length(unique(AMR_env$mo_renamed$old))), " old taxonomic name", ifelse(length(unique(AMR_env$mo_renamed$old)) > 1, "s", ""), ". Use `as.mo(..., keep_synonyms = FALSE)` to clean the input to currently accepted taxonomic names, or set the R option `AMR_keep_synonyms` to `FALSE`. This warning will be shown once per session.", call = FALSE)
|
||||||
}
|
}
|
||||||
|
|
||||||
# Apply Becker ----
|
# Apply Becker ----
|
||||||
if (!isTRUE(only_fungi) && (isTRUE(Becker) || Becker == "all")) {
|
if (!isTRUE(only_fungi) && (isTRUE(Becker) || Becker == "all")) {
|
||||||
# warn when species found that are not in:
|
# warn when species found that are not in:
|
||||||
# - Becker et al. 2014, PMID 25278577
|
# - Becker et al. 2014, PMID 25278577
|
||||||
# - Becker et al. 2019, PMID 30872103
|
# - Becker et al. 2019, PMID 30872103
|
||||||
# - Becker et al. 2020, PMID 32056452
|
# - Becker et al. 2020, PMID 32056452
|
||||||
|
|
||||||
# comment below code if all staphylococcal species are categorised as CoNS/CoPS
|
# comment below code if all staphylococcal species are categorised as CoNS/CoPS
|
||||||
post_Becker <- paste(
|
post_Becker <- paste(
|
||||||
"Staphylococcus",
|
"Staphylococcus",
|
||||||
@@ -482,13 +482,13 @@ as.mo <- function(x,
|
|||||||
if (any(out %in% AMR_env$MO_lookup$mo[match(post_Becker, AMR_env$MO_lookup$fullname)])) {
|
if (any(out %in% AMR_env$MO_lookup$mo[match(post_Becker, AMR_env$MO_lookup$fullname)])) {
|
||||||
if (message_not_thrown_before("as.mo", "becker")) {
|
if (message_not_thrown_before("as.mo", "becker")) {
|
||||||
warning_("in `as.mo()`: Becker ", font_italic("et al."), " (2014, 2019, 2020) does not contain these species named after their publication: ",
|
warning_("in `as.mo()`: Becker ", font_italic("et al."), " (2014, 2019, 2020) does not contain these species named after their publication: ",
|
||||||
vector_and(font_italic(gsub("Staphylococcus", "S.", post_Becker, fixed = TRUE), collapse = NULL), quotes = FALSE),
|
vector_and(font_italic(gsub("Staphylococcus", "S.", post_Becker, fixed = TRUE), collapse = NULL), quotes = FALSE),
|
||||||
". Categorisation to CoNS/CoPS was taken from the original scientific publication(s).",
|
". Categorisation to CoNS/CoPS was taken from the original scientific publication(s).",
|
||||||
immediate = TRUE, call = FALSE
|
immediate = TRUE, call = FALSE
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
# 'MO_CONS' and 'MO_COPS' are 'mo' vectors created in R/_pre_commit_checks.R
|
# 'MO_CONS' and 'MO_COPS' are 'mo' vectors created in R/_pre_commit_checks.R
|
||||||
out[out %in% MO_CONS] <- "B_STPHY_CONS"
|
out[out %in% MO_CONS] <- "B_STPHY_CONS"
|
||||||
out[out %in% MO_COPS] <- "B_STPHY_COPS"
|
out[out %in% MO_COPS] <- "B_STPHY_COPS"
|
||||||
@@ -496,11 +496,11 @@ as.mo <- function(x,
|
|||||||
out[out == "B_STPHY_AURS"] <- "B_STPHY_COPS"
|
out[out == "B_STPHY_AURS"] <- "B_STPHY_COPS"
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
# Apply Lancefield ----
|
# Apply Lancefield ----
|
||||||
if (!isTRUE(only_fungi) && (isTRUE(Lancefield) || Lancefield == "all")) {
|
if (!isTRUE(only_fungi) && (isTRUE(Lancefield) || Lancefield == "all")) {
|
||||||
# (using `%like_case%` to also match subspecies)
|
# (using `%like_case%` to also match subspecies)
|
||||||
|
|
||||||
# group A - S. pyogenes
|
# group A - S. pyogenes
|
||||||
out[out %like_case% "^B_STRPT_PYGN(_|$)"] <- "B_STRPT_GRPA"
|
out[out %like_case% "^B_STRPT_PYGN(_|$)"] <- "B_STRPT_GRPA"
|
||||||
# group B - S. agalactiae
|
# group B - S. agalactiae
|
||||||
@@ -521,17 +521,17 @@ as.mo <- function(x,
|
|||||||
out[out %like_case% "^B_STRPT_SLVR(_|$)"] <- "B_STRPT_GRPK"
|
out[out %like_case% "^B_STRPT_SLVR(_|$)"] <- "B_STRPT_GRPK"
|
||||||
# group L - only S. dysgalactiae which is also group C & G, so ignore it here
|
# group L - only S. dysgalactiae which is also group C & G, so ignore it here
|
||||||
}
|
}
|
||||||
|
|
||||||
# All unknowns ----
|
# All unknowns ----
|
||||||
out[is.na(out) & !is.na(x)] <- "UNKNOWN"
|
out[is.na(out) & !is.na(x)] <- "UNKNOWN"
|
||||||
AMR_env$mo_failures <- unique(x[out == "UNKNOWN" & !toupper(x) %in% c("UNKNOWN", "CON", "UNK") & !x %like_case% "^[(]unknown [a-z]+[)]$" & !is.na(x)])
|
AMR_env$mo_failures <- unique(x[out == "UNKNOWN" & !toupper(x) %in% c("UNKNOWN", "CON", "UNK") & !x %like_case% "^[(]unknown [a-z]+[)]$" & !is.na(x)])
|
||||||
if (length(AMR_env$mo_failures) > 0) {
|
if (length(AMR_env$mo_failures) > 0) {
|
||||||
warning_("The following input could not be coerced and was returned as \"UNKNOWN\": ", vector_and(AMR_env$mo_failures, quotes = TRUE), ".\nYou can retrieve this list with `mo_failures()`.", call = FALSE)
|
warning_("The following input could not be coerced and was returned as \"UNKNOWN\": ", vector_and(AMR_env$mo_failures, quotes = TRUE), ".\nYou can retrieve this list with `mo_failures()`.", call = FALSE)
|
||||||
}
|
}
|
||||||
|
|
||||||
# Return class ----
|
# Return class ----
|
||||||
set_clean_class(out,
|
set_clean_class(out,
|
||||||
new_class = c("mo", "character")
|
new_class = c("mo", "character")
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -554,13 +554,13 @@ mo_uncertainties <- function() {
|
|||||||
mo_renamed <- function() {
|
mo_renamed <- function() {
|
||||||
add_MO_lookup_to_AMR_env()
|
add_MO_lookup_to_AMR_env()
|
||||||
x <- AMR_env$mo_renamed
|
x <- AMR_env$mo_renamed
|
||||||
|
|
||||||
x$new <- synonym_mo_to_accepted_mo(x$old)
|
x$new <- synonym_mo_to_accepted_mo(x$old)
|
||||||
mo_old <- AMR_env$MO_lookup$fullname[match(x$old, AMR_env$MO_lookup$mo)]
|
mo_old <- AMR_env$MO_lookup$fullname[match(x$old, AMR_env$MO_lookup$mo)]
|
||||||
mo_new <- AMR_env$MO_lookup$fullname[match(x$new, AMR_env$MO_lookup$mo)]
|
mo_new <- AMR_env$MO_lookup$fullname[match(x$new, AMR_env$MO_lookup$mo)]
|
||||||
ref_old <- AMR_env$MO_lookup$ref[match(x$old, AMR_env$MO_lookup$mo)]
|
ref_old <- AMR_env$MO_lookup$ref[match(x$old, AMR_env$MO_lookup$mo)]
|
||||||
ref_new <- AMR_env$MO_lookup$ref[match(x$new, AMR_env$MO_lookup$mo)]
|
ref_new <- AMR_env$MO_lookup$ref[match(x$new, AMR_env$MO_lookup$mo)]
|
||||||
|
|
||||||
df_renamed <- data.frame(
|
df_renamed <- data.frame(
|
||||||
old = mo_old,
|
old = mo_old,
|
||||||
new = mo_new,
|
new = mo_new,
|
||||||
@@ -594,10 +594,12 @@ mo_reset_session <- function() {
|
|||||||
#' @rdname as.mo
|
#' @rdname as.mo
|
||||||
#' @export
|
#' @export
|
||||||
mo_cleaning_regex <- function() {
|
mo_cleaning_regex <- function() {
|
||||||
parts_to_remove <- c("e?spp([^a-z]+|$)", "e?ssp([^a-z]+|$)", "e?ss([^a-z]+|$)", "e?sp([^a-z]+|$)", "e?subsp", "sube?species", "e?species",
|
parts_to_remove <- c(
|
||||||
"biovar[a-z]*", "biotype", "serovar[a-z]*", "var([^a-z]+|$)", "serogr.?up[a-z]*",
|
"e?spp([^a-z]+|$)", "e?ssp([^a-z]+|$)", "e?ss([^a-z]+|$)", "e?sp([^a-z]+|$)", "e?subsp", "sube?species", "e?species",
|
||||||
"titer", "dummy", "Ig[ADEGM]", " ?[a-z-]+[-](resistant|susceptible) ?")
|
"biovar[a-z]*", "biotype", "serovar[a-z]*", "var([^a-z]+|$)", "serogr.?up[a-z]*",
|
||||||
|
"titer", "dummy", "Ig[ADEGM]", " ?[a-z-]+[-](resistant|susceptible) ?"
|
||||||
|
)
|
||||||
|
|
||||||
paste0(
|
paste0(
|
||||||
"(",
|
"(",
|
||||||
"[^A-Za-z- \\(\\)\\[\\]{}]+",
|
"[^A-Za-z- \\(\\)\\[\\]{}]+",
|
||||||
@@ -605,7 +607,8 @@ mo_cleaning_regex <- function() {
|
|||||||
"([({]|\\[).+([})]|\\])",
|
"([({]|\\[).+([})]|\\])",
|
||||||
"|(^| )(",
|
"|(^| )(",
|
||||||
paste0(parts_to_remove[order(1 - nchar(parts_to_remove))], collapse = "|"),
|
paste0(parts_to_remove[order(1 - nchar(parts_to_remove))], collapse = "|"),
|
||||||
"))")
|
"))"
|
||||||
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
# UNDOCUMENTED METHODS ----------------------------------------------------
|
# UNDOCUMENTED METHODS ----------------------------------------------------
|
||||||
@@ -618,30 +621,30 @@ pillar_shaft.mo <- function(x, ...) {
|
|||||||
out[!is.na(x)] <- gsub("^([A-Z]+_)(.*)", paste0(font_subtle("\\1"), "\\2"), out[!is.na(x)], perl = TRUE)
|
out[!is.na(x)] <- gsub("^([A-Z]+_)(.*)", paste0(font_subtle("\\1"), "\\2"), out[!is.na(x)], perl = TRUE)
|
||||||
# and grey out every _
|
# and grey out every _
|
||||||
out[!is.na(x)] <- gsub("_", font_subtle("_"), out[!is.na(x)])
|
out[!is.na(x)] <- gsub("_", font_subtle("_"), out[!is.na(x)])
|
||||||
|
|
||||||
# markup NA and UNKNOWN
|
# markup NA and UNKNOWN
|
||||||
out[is.na(x)] <- font_na(" NA")
|
out[is.na(x)] <- font_na(" NA")
|
||||||
out[x == "UNKNOWN"] <- font_na(" UNKNOWN")
|
out[x == "UNKNOWN"] <- font_na(" UNKNOWN")
|
||||||
|
|
||||||
# markup manual codes
|
# markup manual codes
|
||||||
out[x %in% AMR_env$MO_lookup$mo & !x %in% AMR::microorganisms$mo] <- font_blue(out[x %in% AMR_env$MO_lookup$mo & !x %in% AMR::microorganisms$mo], collapse = NULL)
|
out[x %in% AMR_env$MO_lookup$mo & !x %in% AMR::microorganisms$mo] <- font_blue(out[x %in% AMR_env$MO_lookup$mo & !x %in% AMR::microorganisms$mo], collapse = NULL)
|
||||||
|
|
||||||
df <- tryCatch(get_current_data(arg_name = "x", call = 0),
|
df <- tryCatch(get_current_data(arg_name = "x", call = 0),
|
||||||
error = function(e) NULL
|
error = function(e) NULL
|
||||||
)
|
)
|
||||||
if (!is.null(df)) {
|
if (!is.null(df)) {
|
||||||
mo_cols <- vapply(FUN.VALUE = logical(1), df, is.mo)
|
mo_cols <- vapply(FUN.VALUE = logical(1), df, is.mo)
|
||||||
} else {
|
} else {
|
||||||
mo_cols <- NULL
|
mo_cols <- NULL
|
||||||
}
|
}
|
||||||
|
|
||||||
all_mos <- c(AMR_env$MO_lookup$mo, NA)
|
all_mos <- c(AMR_env$MO_lookup$mo, NA)
|
||||||
if (!all(x %in% all_mos) ||
|
if (!all(x %in% all_mos) ||
|
||||||
(!is.null(df) && !all(unlist(df[, which(mo_cols), drop = FALSE]) %in% all_mos))) {
|
(!is.null(df) && !all(unlist(df[, which(mo_cols), drop = FALSE]) %in% all_mos))) {
|
||||||
# markup old mo codes
|
# markup old mo codes
|
||||||
out[!x %in% all_mos] <- font_italic(
|
out[!x %in% all_mos] <- font_italic(
|
||||||
font_na(x[!x %in% all_mos],
|
font_na(x[!x %in% all_mos],
|
||||||
collapse = NULL
|
collapse = NULL
|
||||||
),
|
),
|
||||||
collapse = NULL
|
collapse = NULL
|
||||||
)
|
)
|
||||||
@@ -657,22 +660,26 @@ pillar_shaft.mo <- function(x, ...) {
|
|||||||
call = FALSE
|
call = FALSE
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
# add the names to the bugs as mouse-over!
|
# add the names to the bugs as mouse-over!
|
||||||
if (tryCatch(isTRUE(getExportedValue("ansi_has_hyperlink_support", ns = asNamespace("cli"))()), error = function(e) FALSE)) {
|
if (tryCatch(isTRUE(getExportedValue("ansi_has_hyperlink_support", ns = asNamespace("cli"))()), error = function(e) FALSE)) {
|
||||||
out[!x %in% c("UNKNOWN", NA)] <- font_url(url = paste0(x[!x %in% c("UNKNOWN", NA)], ": ",
|
out[!x %in% c("UNKNOWN", NA)] <- font_url(
|
||||||
mo_name(x[!x %in% c("UNKNOWN", NA)], keep_synonyms = TRUE)),
|
url = paste0(
|
||||||
txt = out[!x %in% c("UNKNOWN", NA)])
|
x[!x %in% c("UNKNOWN", NA)], ": ",
|
||||||
|
mo_name(x[!x %in% c("UNKNOWN", NA)], keep_synonyms = TRUE)
|
||||||
|
),
|
||||||
|
txt = out[!x %in% c("UNKNOWN", NA)]
|
||||||
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
# make it always fit exactly
|
# make it always fit exactly
|
||||||
max_char <- max(nchar(x))
|
max_char <- max(nchar(x))
|
||||||
if (is.na(max_char)) {
|
if (is.na(max_char)) {
|
||||||
max_char <- 12
|
max_char <- 12
|
||||||
}
|
}
|
||||||
create_pillar_column(out,
|
create_pillar_column(out,
|
||||||
align = "left",
|
align = "left",
|
||||||
width = max_char + ifelse(any(x %in% c(NA, "UNKNOWN")), 2, 0)
|
width = max_char + ifelse(any(x %in% c(NA, "UNKNOWN")), 2, 0)
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -695,21 +702,21 @@ freq.mo <- function(x, ...) {
|
|||||||
.add_header = list(
|
.add_header = list(
|
||||||
`Gram-negative` = paste0(
|
`Gram-negative` = paste0(
|
||||||
format(sum(grams == "Gram-negative", na.rm = TRUE),
|
format(sum(grams == "Gram-negative", na.rm = TRUE),
|
||||||
big.mark = " ",
|
big.mark = " ",
|
||||||
decimal.mark = "."
|
decimal.mark = "."
|
||||||
),
|
),
|
||||||
" (", percentage(sum(grams == "Gram-negative", na.rm = TRUE) / length(grams),
|
" (", percentage(sum(grams == "Gram-negative", na.rm = TRUE) / length(grams),
|
||||||
digits = digits
|
digits = digits
|
||||||
),
|
),
|
||||||
")"
|
")"
|
||||||
),
|
),
|
||||||
`Gram-positive` = paste0(
|
`Gram-positive` = paste0(
|
||||||
format(sum(grams == "Gram-positive", na.rm = TRUE),
|
format(sum(grams == "Gram-positive", na.rm = TRUE),
|
||||||
big.mark = " ",
|
big.mark = " ",
|
||||||
decimal.mark = "."
|
decimal.mark = "."
|
||||||
),
|
),
|
||||||
" (", percentage(sum(grams == "Gram-positive", na.rm = TRUE) / length(grams),
|
" (", percentage(sum(grams == "Gram-positive", na.rm = TRUE) / length(grams),
|
||||||
digits = digits
|
digits = digits
|
||||||
),
|
),
|
||||||
")"
|
")"
|
||||||
),
|
),
|
||||||
@@ -871,26 +878,26 @@ print.mo_uncertainties <- function(x, n = 10, ...) {
|
|||||||
more_than_50 <- TRUE
|
more_than_50 <- TRUE
|
||||||
x <- x[1:50, , drop = FALSE]
|
x <- x[1:50, , drop = FALSE]
|
||||||
}
|
}
|
||||||
|
|
||||||
cat(word_wrap("Matching scores are based on the resemblance between the input and the full taxonomic name, and the pathogenicity in humans. See `?mo_matching_score`.\n\n", add_fn = font_blue))
|
cat(word_wrap("Matching scores are based on the resemblance between the input and the full taxonomic name, and the pathogenicity in humans. See `?mo_matching_score`.\n\n", add_fn = font_blue))
|
||||||
|
|
||||||
add_MO_lookup_to_AMR_env()
|
add_MO_lookup_to_AMR_env()
|
||||||
|
|
||||||
col_red <- function(x) font_rose_bg(x, collapse = NULL)
|
col_red <- function(x) font_rose_bg(x, collapse = NULL)
|
||||||
col_orange <- function(x) font_orange_bg(x, collapse = NULL)
|
col_orange <- function(x) font_orange_bg(x, collapse = NULL)
|
||||||
col_yellow <- function(x) font_yellow_bg(x, collapse = NULL)
|
col_yellow <- function(x) font_yellow_bg(x, collapse = NULL)
|
||||||
col_green <- function(x) font_green_bg(x, collapse = NULL)
|
col_green <- function(x) font_green_bg(x, collapse = NULL)
|
||||||
|
|
||||||
if (has_colour()) {
|
if (has_colour()) {
|
||||||
cat(word_wrap("Colour keys: ",
|
cat(word_wrap("Colour keys: ",
|
||||||
col_red(" 0.000-0.549 "),
|
col_red(" 0.000-0.549 "),
|
||||||
col_orange(" 0.550-0.649 "),
|
col_orange(" 0.550-0.649 "),
|
||||||
col_yellow(" 0.650-0.749 "),
|
col_yellow(" 0.650-0.749 "),
|
||||||
col_green(" 0.750-1.000"),
|
col_green(" 0.750-1.000"),
|
||||||
add_fn = font_blue
|
add_fn = font_blue
|
||||||
), font_green_bg(" "), "\n", sep = "")
|
), font_green_bg(" "), "\n", sep = "")
|
||||||
}
|
}
|
||||||
|
|
||||||
score_set_colour <- function(text, scores) {
|
score_set_colour <- function(text, scores) {
|
||||||
# set colours to scores
|
# set colours to scores
|
||||||
text[scores >= 0.75] <- col_green(text[scores >= 0.75])
|
text[scores >= 0.75] <- col_green(text[scores >= 0.75])
|
||||||
@@ -899,7 +906,7 @@ print.mo_uncertainties <- function(x, n = 10, ...) {
|
|||||||
text[scores < 0.55] <- col_red(text[scores < 0.55])
|
text[scores < 0.55] <- col_red(text[scores < 0.55])
|
||||||
text
|
text
|
||||||
}
|
}
|
||||||
|
|
||||||
txt <- ""
|
txt <- ""
|
||||||
any_maxed_out <- FALSE
|
any_maxed_out <- FALSE
|
||||||
for (i in seq_len(nrow(x))) {
|
for (i in seq_len(nrow(x))) {
|
||||||
@@ -911,15 +918,15 @@ print.mo_uncertainties <- function(x, n = 10, ...) {
|
|||||||
}
|
}
|
||||||
scores <- mo_matching_score(x = x[i, ]$input, n = candidates)
|
scores <- mo_matching_score(x = x[i, ]$input, n = candidates)
|
||||||
n_candidates <- length(candidates)
|
n_candidates <- length(candidates)
|
||||||
|
|
||||||
candidates_formatted <- italicise(candidates)
|
candidates_formatted <- italicise(candidates)
|
||||||
scores_formatted <- trimws(formatC(round(scores, 3), format = "f", digits = 3))
|
scores_formatted <- trimws(formatC(round(scores, 3), format = "f", digits = 3))
|
||||||
scores_formatted <- score_set_colour(scores_formatted, scores)
|
scores_formatted <- score_set_colour(scores_formatted, scores)
|
||||||
|
|
||||||
# sort on descending scores
|
# sort on descending scores
|
||||||
candidates_formatted <- candidates_formatted[order(1 - scores)]
|
candidates_formatted <- candidates_formatted[order(1 - scores)]
|
||||||
scores_formatted <- scores_formatted[order(1 - scores)]
|
scores_formatted <- scores_formatted[order(1 - scores)]
|
||||||
|
|
||||||
candidates <- word_wrap(
|
candidates <- word_wrap(
|
||||||
paste0(
|
paste0(
|
||||||
"Also matched: ",
|
"Also matched: ",
|
||||||
@@ -937,46 +944,46 @@ print.mo_uncertainties <- function(x, n = 10, ...) {
|
|||||||
} else {
|
} else {
|
||||||
candidates <- ""
|
candidates <- ""
|
||||||
}
|
}
|
||||||
|
|
||||||
score <- mo_matching_score(
|
score <- mo_matching_score(
|
||||||
x = x[i, ]$input,
|
x = x[i, ]$input,
|
||||||
n = x[i, ]$fullname
|
n = x[i, ]$fullname
|
||||||
)
|
)
|
||||||
score_formatted <- trimws(formatC(round(score, 3), format = "f", digits = 3))
|
score_formatted <- trimws(formatC(round(score, 3), format = "f", digits = 3))
|
||||||
txt <- paste(txt,
|
txt <- paste(txt,
|
||||||
paste0(
|
paste0(
|
||||||
paste0(
|
paste0(
|
||||||
"", strrep(font_grey("-"), times = getOption("width", 100)), "\n",
|
"", strrep(font_grey("-"), times = getOption("width", 100)), "\n",
|
||||||
'"', x[i, ]$original_input, '"',
|
'"', x[i, ]$original_input, '"',
|
||||||
" -> ",
|
" -> ",
|
||||||
paste0(
|
paste0(
|
||||||
font_bold(italicise(x[i, ]$fullname)),
|
font_bold(italicise(x[i, ]$fullname)),
|
||||||
" (", x[i, ]$mo, ", ", score_set_colour(score_formatted, score), ")"
|
" (", x[i, ]$mo, ", ", score_set_colour(score_formatted, score), ")"
|
||||||
)
|
)
|
||||||
),
|
),
|
||||||
collapse = "\n"
|
collapse = "\n"
|
||||||
),
|
),
|
||||||
ifelse(x[i, ]$mo %in% AMR_env$MO_lookup$mo[which(AMR_env$MO_lookup$status == "synonym")],
|
ifelse(x[i, ]$mo %in% AMR_env$MO_lookup$mo[which(AMR_env$MO_lookup$status == "synonym")],
|
||||||
paste0(
|
paste0(
|
||||||
strrep(" ", nchar(x[i, ]$original_input) + 6),
|
strrep(" ", nchar(x[i, ]$original_input) + 6),
|
||||||
ifelse(x[i, ]$keep_synonyms == FALSE,
|
ifelse(x[i, ]$keep_synonyms == FALSE,
|
||||||
# Add note if result was coerced to accepted taxonomic name
|
# Add note if result was coerced to accepted taxonomic name
|
||||||
font_red(paste0("This outdated taxonomic name was converted to ", font_italic(AMR_env$MO_lookup$fullname[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], collapse = NULL), " (", synonym_mo_to_accepted_mo(x[i, ]$mo), ")."), collapse = NULL),
|
font_red(paste0("This outdated taxonomic name was converted to ", font_italic(AMR_env$MO_lookup$fullname[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], collapse = NULL), " (", synonym_mo_to_accepted_mo(x[i, ]$mo), ")."), collapse = NULL),
|
||||||
# Or add note if result is currently another taxonomic name
|
# Or add note if result is currently another taxonomic name
|
||||||
font_red(paste0(font_bold("Note: "), "The current name is ", font_italic(AMR_env$MO_lookup$fullname[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], collapse = NULL), " (", AMR_env$MO_lookup$ref[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], ")."), collapse = NULL)
|
font_red(paste0(font_bold("Note: "), "The current name is ", font_italic(AMR_env$MO_lookup$fullname[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], collapse = NULL), " (", AMR_env$MO_lookup$ref[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], ")."), collapse = NULL)
|
||||||
)
|
)
|
||||||
),
|
),
|
||||||
""
|
""
|
||||||
),
|
),
|
||||||
candidates,
|
candidates,
|
||||||
sep = "\n"
|
sep = "\n"
|
||||||
)
|
)
|
||||||
txt <- gsub("[\n]+", "\n", txt)
|
txt <- gsub("[\n]+", "\n", txt)
|
||||||
# remove first and last break
|
# remove first and last break
|
||||||
txt <- gsub("(^[\n]|[\n]$)", "", txt)
|
txt <- gsub("(^[\n]|[\n]$)", "", txt)
|
||||||
txt <- paste0("\n", txt, "\n")
|
txt <- paste0("\n", txt, "\n")
|
||||||
}
|
}
|
||||||
|
|
||||||
cat(txt)
|
cat(txt)
|
||||||
if (isTRUE(any_maxed_out)) {
|
if (isTRUE(any_maxed_out)) {
|
||||||
cat(font_blue(word_wrap("\nOnly the first ", n, " other matches of each record are shown. Run `print(mo_uncertainties(), n = ...)` to view more entries, or save `mo_uncertainties()` to an object.")))
|
cat(font_blue(word_wrap("\nOnly the first ", n, " other matches of each record are shown. Run `print(mo_uncertainties(), n = ...)` to view more entries, or save `mo_uncertainties()` to an object.")))
|
||||||
@@ -994,19 +1001,19 @@ print.mo_renamed <- function(x, extra_txt = "", n = 25, ...) {
|
|||||||
cat(word_wrap("No renamed taxonomy to show. Only renamed taxonomy of the last call of `as.mo()` or any `mo_*()` function are stored.\n", add_fn = font_blue))
|
cat(word_wrap("No renamed taxonomy to show. Only renamed taxonomy of the last call of `as.mo()` or any `mo_*()` function are stored.\n", add_fn = font_blue))
|
||||||
return(invisible(NULL))
|
return(invisible(NULL))
|
||||||
}
|
}
|
||||||
|
|
||||||
x$ref_old[!is.na(x$ref_old)] <- paste0(" (", gsub("et al.", font_italic("et al."), x$ref_old[!is.na(x$ref_old)], fixed = TRUE), ")")
|
x$ref_old[!is.na(x$ref_old)] <- paste0(" (", gsub("et al.", font_italic("et al."), x$ref_old[!is.na(x$ref_old)], fixed = TRUE), ")")
|
||||||
x$ref_new[!is.na(x$ref_new)] <- paste0(" (", gsub("et al.", font_italic("et al."), x$ref_new[!is.na(x$ref_new)], fixed = TRUE), ")")
|
x$ref_new[!is.na(x$ref_new)] <- paste0(" (", gsub("et al.", font_italic("et al."), x$ref_new[!is.na(x$ref_new)], fixed = TRUE), ")")
|
||||||
x$ref_old[is.na(x$ref_old)] <- " (author unknown)"
|
x$ref_old[is.na(x$ref_old)] <- " (author unknown)"
|
||||||
x$ref_new[is.na(x$ref_new)] <- " (author unknown)"
|
x$ref_new[is.na(x$ref_new)] <- " (author unknown)"
|
||||||
|
|
||||||
rows <- seq_len(min(NROW(x), n))
|
rows <- seq_len(min(NROW(x), n))
|
||||||
|
|
||||||
message_(
|
message_(
|
||||||
"The following microorganism", ifelse(NROW(x) > 1, "s were", " was"), " taxonomically renamed", extra_txt, ":\n",
|
"The following microorganism", ifelse(NROW(x) > 1, "s were", " was"), " taxonomically renamed", extra_txt, ":\n",
|
||||||
paste0(" ", AMR_env$bullet_icon, " ", font_italic(x$old[rows], collapse = NULL), x$ref_old[rows],
|
paste0(" ", AMR_env$bullet_icon, " ", font_italic(x$old[rows], collapse = NULL), x$ref_old[rows],
|
||||||
" -> ", font_italic(x$new[rows], collapse = NULL), x$ref_new[rows],
|
" -> ", font_italic(x$new[rows], collapse = NULL), x$ref_new[rows],
|
||||||
collapse = "\n"
|
collapse = "\n"
|
||||||
),
|
),
|
||||||
ifelse(NROW(x) > n, paste0("\n\nOnly the first ", n, " (out of ", NROW(x), ") are shown. Run `print(mo_renamed(), n = ...)` to view more entries (might be slow), or save `mo_renamed()` to an object."), "")
|
ifelse(NROW(x) > n, paste0("\n\nOnly the first ", n, " (out of ", NROW(x), ") are shown. Run `print(mo_renamed(), n = ...)` to view more entries (might be slow), or save `mo_renamed()` to an object."), "")
|
||||||
)
|
)
|
||||||
@@ -1018,28 +1025,28 @@ convert_colloquial_input <- function(x) {
|
|||||||
x.bak <- trimws2(x)
|
x.bak <- trimws2(x)
|
||||||
x <- trimws2(tolower(x))
|
x <- trimws2(tolower(x))
|
||||||
out <- rep(NA_character_, length(x))
|
out <- rep(NA_character_, length(x))
|
||||||
|
|
||||||
# Streptococci, like GBS = Group B Streptococci (B_STRPT_GRPB)
|
# Streptococci, like GBS = Group B Streptococci (B_STRPT_GRPB)
|
||||||
out[x %like_case% "^g[abcdefghijkl]s$"] <- gsub("g([abcdefghijkl])s",
|
out[x %like_case% "^g[abcdefghijkl]s$"] <- gsub("g([abcdefghijkl])s",
|
||||||
"B_STRPT_GRP\\U\\1",
|
"B_STRPT_GRP\\U\\1",
|
||||||
x[x %like_case% "^g[abcdefghijkl]s$"],
|
x[x %like_case% "^g[abcdefghijkl]s$"],
|
||||||
perl = TRUE
|
perl = TRUE
|
||||||
)
|
)
|
||||||
# Streptococci in different languages, like "estreptococos grupo B"
|
# Streptococci in different languages, like "estreptococos grupo B"
|
||||||
out[x %like_case% "strepto[ck]o[ck][a-zA-Z ]* [abcdefghijkl]$"] <- gsub(".*e?strepto[ck]o[ck].* ([abcdefghijkl])$",
|
out[x %like_case% "strepto[ck]o[ck][a-zA-Z ]* [abcdefghijkl]$"] <- gsub(".*e?strepto[ck]o[ck].* ([abcdefghijkl])$",
|
||||||
"B_STRPT_GRP\\U\\1",
|
"B_STRPT_GRP\\U\\1",
|
||||||
x[x %like_case% "strepto[ck]o[ck][a-zA-Z ]* [abcdefghijkl]$"],
|
x[x %like_case% "strepto[ck]o[ck][a-zA-Z ]* [abcdefghijkl]$"],
|
||||||
perl = TRUE
|
perl = TRUE
|
||||||
)
|
)
|
||||||
out[x %like_case% "strep[a-z]* group [abcdefghijkl]$"] <- gsub(".* ([abcdefghijkl])$",
|
out[x %like_case% "strep[a-z]* group [abcdefghijkl]$"] <- gsub(".* ([abcdefghijkl])$",
|
||||||
"B_STRPT_GRP\\U\\1",
|
"B_STRPT_GRP\\U\\1",
|
||||||
x[x %like_case% "strep[a-z]* group [abcdefghijkl]$"],
|
x[x %like_case% "strep[a-z]* group [abcdefghijkl]$"],
|
||||||
perl = TRUE
|
perl = TRUE
|
||||||
)
|
)
|
||||||
out[x %like_case% "group [abcdefghijkl] strepto[ck]o[ck]"] <- gsub(".*group ([abcdefghijkl]) strepto[ck]o[ck].*",
|
out[x %like_case% "group [abcdefghijkl] strepto[ck]o[ck]"] <- gsub(".*group ([abcdefghijkl]) strepto[ck]o[ck].*",
|
||||||
"B_STRPT_GRP\\U\\1",
|
"B_STRPT_GRP\\U\\1",
|
||||||
x[x %like_case% "group [abcdefghijkl] strepto[ck]o[ck]"],
|
x[x %like_case% "group [abcdefghijkl] strepto[ck]o[ck]"],
|
||||||
perl = TRUE
|
perl = TRUE
|
||||||
)
|
)
|
||||||
out[x %like_case% "ha?emoly.*strep"] <- "B_STRPT_HAEM"
|
out[x %like_case% "ha?emoly.*strep"] <- "B_STRPT_HAEM"
|
||||||
out[x %like_case% "(strepto.* [abcg, ]{2,4}$)"] <- "B_STRPT_ABCG"
|
out[x %like_case% "(strepto.* [abcg, ]{2,4}$)"] <- "B_STRPT_ABCG"
|
||||||
@@ -1047,23 +1054,23 @@ convert_colloquial_input <- function(x) {
|
|||||||
out[x %like_case% "mil+er+i gr"] <- "B_STRPT_MILL"
|
out[x %like_case% "mil+er+i gr"] <- "B_STRPT_MILL"
|
||||||
out[x %like_case% "((strepto|^s).* viridans|^vgs[^a-z]*$)"] <- "B_STRPT_VIRI"
|
out[x %like_case% "((strepto|^s).* viridans|^vgs[^a-z]*$)"] <- "B_STRPT_VIRI"
|
||||||
out[x %like_case% "(viridans.* (strepto|^s).*|^vgs[^a-z]*$)"] <- "B_STRPT_VIRI"
|
out[x %like_case% "(viridans.* (strepto|^s).*|^vgs[^a-z]*$)"] <- "B_STRPT_VIRI"
|
||||||
|
|
||||||
# Salmonella in different languages, like "Salmonella grupo B"
|
# Salmonella in different languages, like "Salmonella grupo B"
|
||||||
out[x %like_case% "salmonella.* [abcdefgh]$"] <- gsub(".*salmonella.* ([abcdefgh])$",
|
out[x %like_case% "salmonella.* [abcdefgh]$"] <- gsub(".*salmonella.* ([abcdefgh])$",
|
||||||
"B_SLMNL_GRP\\U\\1",
|
"B_SLMNL_GRP\\U\\1",
|
||||||
x[x %like_case% "salmonella.* [abcdefgh]$"],
|
x[x %like_case% "salmonella.* [abcdefgh]$"],
|
||||||
perl = TRUE
|
perl = TRUE
|
||||||
)
|
)
|
||||||
out[x %like_case% "group [abcdefgh] salmonella"] <- gsub(".*group ([abcdefgh]) salmonella*",
|
out[x %like_case% "group [abcdefgh] salmonella"] <- gsub(".*group ([abcdefgh]) salmonella*",
|
||||||
"B_SLMNL_GRP\\U\\1",
|
"B_SLMNL_GRP\\U\\1",
|
||||||
x[x %like_case% "group [abcdefgh] salmonella"],
|
x[x %like_case% "group [abcdefgh] salmonella"],
|
||||||
perl = TRUE
|
perl = TRUE
|
||||||
)
|
)
|
||||||
|
|
||||||
# CoNS/CoPS in different languages (support for German, Dutch, Spanish, Portuguese)
|
# CoNS/CoPS in different languages (support for German, Dutch, Spanish, Portuguese)
|
||||||
out[x %like_case% "([ck]oagulas[ea].negatie?[vf]|^[ck]o?ns[^a-z]*$)"] <- "B_STPHY_CONS"
|
out[x %like_case% "([ck]oagulas[ea].negatie?[vf]|^[ck]o?ns[^a-z]*$)"] <- "B_STPHY_CONS"
|
||||||
out[x %like_case% "([ck]oagulas[ea].positie?[vf]|^[ck]o?ps[^a-z]*$)"] <- "B_STPHY_COPS"
|
out[x %like_case% "([ck]oagulas[ea].positie?[vf]|^[ck]o?ps[^a-z]*$)"] <- "B_STPHY_COPS"
|
||||||
|
|
||||||
# Gram stains
|
# Gram stains
|
||||||
out[x %like_case% "gram[ -]?neg.*"] <- "B_GRAMN"
|
out[x %like_case% "gram[ -]?neg.*"] <- "B_GRAMN"
|
||||||
out[x %like_case% "( |^)gram[-]( |$)"] <- "B_GRAMN"
|
out[x %like_case% "( |^)gram[-]( |$)"] <- "B_GRAMN"
|
||||||
@@ -1073,17 +1080,17 @@ convert_colloquial_input <- function(x) {
|
|||||||
out[x %like_case% "anaerob[a-z]+ .*gram[ -]?pos.*"] <- "B_ANAER-POS"
|
out[x %like_case% "anaerob[a-z]+ .*gram[ -]?pos.*"] <- "B_ANAER-POS"
|
||||||
out[is.na(out) & x %like_case% "anaerob[a-z]+ (micro)?.*organism"] <- "B_ANAER"
|
out[is.na(out) & x %like_case% "anaerob[a-z]+ (micro)?.*organism"] <- "B_ANAER"
|
||||||
out[is.na(out) & x %like_case% "anaerob[a-z]+ bacter"] <- "B_ANAER"
|
out[is.na(out) & x %like_case% "anaerob[a-z]+ bacter"] <- "B_ANAER"
|
||||||
|
|
||||||
# coryneform bacteria
|
# coryneform bacteria
|
||||||
out[x %like_case% "^coryneform"] <- "B_CORYNF"
|
out[x %like_case% "^coryneform"] <- "B_CORYNF"
|
||||||
|
|
||||||
# yeasts and fungi
|
# yeasts and fungi
|
||||||
out[x %like_case% "(^| )yeast?"] <- "F_YEAST"
|
out[x %like_case% "(^| )yeast?"] <- "F_YEAST"
|
||||||
out[x %like_case% "(^| )fung(us|i)"] <- "F_FUNGUS"
|
out[x %like_case% "(^| )fung(us|i)"] <- "F_FUNGUS"
|
||||||
|
|
||||||
# protozoa
|
# protozoa
|
||||||
out[x %like_case% "protozo"] <- "P_PROTOZOAN" # to hit it with most languages, and "protozo" does not occur in the microorganisms data set for anything else
|
out[x %like_case% "protozo"] <- "P_PROTOZOAN" # to hit it with most languages, and "protozo" does not occur in the microorganisms data set for anything else
|
||||||
|
|
||||||
# trivial names known to the field
|
# trivial names known to the field
|
||||||
out[x %like_case% "meningo[ck]o[ck]"] <- "B_NESSR_MNNG"
|
out[x %like_case% "meningo[ck]o[ck]"] <- "B_NESSR_MNNG"
|
||||||
out[x %like_case% "gono[ck]o[ck]"] <- "B_NESSR_GNRR"
|
out[x %like_case% "gono[ck]o[ck]"] <- "B_NESSR_GNRR"
|
||||||
@@ -1095,11 +1102,11 @@ convert_colloquial_input <- function(x) {
|
|||||||
|
|
||||||
# unexisting names (con is the WHONET code for contamination)
|
# unexisting names (con is the WHONET code for contamination)
|
||||||
out[x %in% c("con", "other", "none", "unknown") | x %like_case% "virus"] <- "UNKNOWN"
|
out[x %in% c("con", "other", "none", "unknown") | x %like_case% "virus"] <- "UNKNOWN"
|
||||||
|
|
||||||
# WHONET has a lot of E. coli and Vibrio cholerae names
|
# WHONET has a lot of E. coli and Vibrio cholerae names
|
||||||
out[x %like_case% "escherichia coli"] <- "B_ESCHR_COLI"
|
out[x %like_case% "escherichia coli"] <- "B_ESCHR_COLI"
|
||||||
out[x %like_case% "vibrio cholerae"] <- "B_VIBRI_CHLR"
|
out[x %like_case% "vibrio cholerae"] <- "B_VIBRI_CHLR"
|
||||||
|
|
||||||
out
|
out
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -1191,7 +1198,7 @@ replace_old_mo_codes <- function(x, property) {
|
|||||||
name <- gsub(" .*", " ", name, fixed = TRUE)
|
name <- gsub(" .*", " ", name, fixed = TRUE)
|
||||||
name <- paste0("^", name)
|
name <- paste0("^", name)
|
||||||
results <- AMR_env$MO_lookup$mo[AMR_env$MO_lookup$kingdom %like_case% kingdom &
|
results <- AMR_env$MO_lookup$mo[AMR_env$MO_lookup$kingdom %like_case% kingdom &
|
||||||
AMR_env$MO_lookup$fullname_lower %like_case% name]
|
AMR_env$MO_lookup$fullname_lower %like_case% name]
|
||||||
if (length(results) > 1) {
|
if (length(results) > 1) {
|
||||||
all_direct_matches <<- FALSE
|
all_direct_matches <<- FALSE
|
||||||
}
|
}
|
||||||
@@ -1228,8 +1235,8 @@ replace_old_mo_codes <- function(x, property) {
|
|||||||
"to ", ifelse(n_solved == 1, "a ", ""),
|
"to ", ifelse(n_solved == 1, "a ", ""),
|
||||||
"currently used MO code", ifelse(n_solved == 1, "", "s"),
|
"currently used MO code", ifelse(n_solved == 1, "", "s"),
|
||||||
ifelse(n_unsolved > 0,
|
ifelse(n_unsolved > 0,
|
||||||
paste0(" and ", n_unsolved, " old MO code", ifelse(n_unsolved == 1, "", "s"), " could not be updated."),
|
paste0(" and ", n_unsolved, " old MO code", ifelse(n_unsolved == 1, "", "s"), " could not be updated."),
|
||||||
"."
|
"."
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
@@ -1258,27 +1265,29 @@ repair_reference_df <- function(reference_df) {
|
|||||||
# has valid own reference_df
|
# has valid own reference_df
|
||||||
reference_df <- reference_df %pm>%
|
reference_df <- reference_df %pm>%
|
||||||
pm_filter(!is.na(mo))
|
pm_filter(!is.na(mo))
|
||||||
|
|
||||||
# keep only first two columns, second must be mo
|
# keep only first two columns, second must be mo
|
||||||
if (colnames(reference_df)[1] == "mo") {
|
if (colnames(reference_df)[1] == "mo") {
|
||||||
reference_df <- reference_df %pm>% pm_select(2, "mo")
|
reference_df <- reference_df %pm>% pm_select(2, "mo")
|
||||||
} else {
|
} else {
|
||||||
reference_df <- reference_df %pm>% pm_select(1, "mo")
|
reference_df <- reference_df %pm>% pm_select(1, "mo")
|
||||||
}
|
}
|
||||||
|
|
||||||
# remove factors, just keep characters
|
# remove factors, just keep characters
|
||||||
colnames(reference_df)[1] <- "x"
|
colnames(reference_df)[1] <- "x"
|
||||||
reference_df[, "x"] <- as.character(reference_df[, "x", drop = TRUE])
|
reference_df[, "x"] <- as.character(reference_df[, "x", drop = TRUE])
|
||||||
reference_df[, "mo"] <- as.character(reference_df[, "mo", drop = TRUE])
|
reference_df[, "mo"] <- as.character(reference_df[, "mo", drop = TRUE])
|
||||||
|
|
||||||
# some MO codes might be old
|
# some MO codes might be old
|
||||||
reference_df[, "mo"] <- as.mo(reference_df[, "mo", drop = TRUE], reference_df = NULL)
|
reference_df[, "mo"] <- as.mo(reference_df[, "mo", drop = TRUE], reference_df = NULL)
|
||||||
reference_df
|
reference_df
|
||||||
}
|
}
|
||||||
|
|
||||||
get_mo_uncertainties <- function() {
|
get_mo_uncertainties <- function() {
|
||||||
remember <- list(uncertainties = AMR_env$mo_uncertainties,
|
remember <- list(
|
||||||
failures = AMR_env$mo_failures)
|
uncertainties = AMR_env$mo_uncertainties,
|
||||||
|
failures = AMR_env$mo_failures
|
||||||
|
)
|
||||||
# empty them, otherwise e.g. mo_shortname("Chlamydophila psittaci") will give 3 notes
|
# empty them, otherwise e.g. mo_shortname("Chlamydophila psittaci") will give 3 notes
|
||||||
AMR_env$mo_uncertainties <- NULL
|
AMR_env$mo_uncertainties <- NULL
|
||||||
AMR_env$mo_failures <- NULL
|
AMR_env$mo_failures <- NULL
|
||||||
@@ -1300,9 +1309,9 @@ synonym_mo_to_accepted_mo <- function(x, fill_in_accepted = FALSE, dataset = AMR
|
|||||||
out <- x
|
out <- x
|
||||||
is_still_synonym <- dataset$status[match(out, dataset$mo)] == "synonym"
|
is_still_synonym <- dataset$status[match(out, dataset$mo)] == "synonym"
|
||||||
limit <- 0
|
limit <- 0
|
||||||
while(any(is_still_synonym, na.rm = TRUE) && limit < 5) {
|
while (any(is_still_synonym, na.rm = TRUE) && limit < 5) {
|
||||||
limit <- limit + 1
|
limit <- limit + 1
|
||||||
|
|
||||||
# make sure to get the latest name, e.g. Fusarium pulicaris robiniae was first renamed to Fusarium roseum, then to Fusarium sambucinum
|
# make sure to get the latest name, e.g. Fusarium pulicaris robiniae was first renamed to Fusarium roseum, then to Fusarium sambucinum
|
||||||
# we need the MO of Fusarium pulicaris robiniae to return the MO of Fusarium sambucinum
|
# we need the MO of Fusarium pulicaris robiniae to return the MO of Fusarium sambucinum
|
||||||
must_be_corrected <- !is.na(is_still_synonym) & is_still_synonym
|
must_be_corrected <- !is.na(is_still_synonym) & is_still_synonym
|
||||||
@@ -1316,13 +1325,13 @@ synonym_mo_to_accepted_mo <- function(x, fill_in_accepted = FALSE, dataset = AMR
|
|||||||
|
|
||||||
is_still_synonym <- dataset$status[match(out, dataset$mo)] == "synonym"
|
is_still_synonym <- dataset$status[match(out, dataset$mo)] == "synonym"
|
||||||
}
|
}
|
||||||
|
|
||||||
x_no_synonym <- dataset$status[match(x, dataset$mo)] != "synonym"
|
x_no_synonym <- dataset$status[match(x, dataset$mo)] != "synonym"
|
||||||
out[x_no_synonym] <- NA_character_
|
out[x_no_synonym] <- NA_character_
|
||||||
if (isTRUE(fill_in_accepted)) {
|
if (isTRUE(fill_in_accepted)) {
|
||||||
out[!is.na(x_no_synonym) & x_no_synonym] <- x[!is.na(x_no_synonym) & x_no_synonym]
|
out[!is.na(x_no_synonym) & x_no_synonym] <- x[!is.na(x_no_synonym) & x_no_synonym]
|
||||||
}
|
}
|
||||||
|
|
||||||
out[is.na(match(x, dataset$mo))] <- NA_character_
|
out[is.na(match(x, dataset$mo))] <- NA_character_
|
||||||
out
|
out
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -53,7 +53,7 @@
|
|||||||
#' Determination of yeasts ([mo_is_yeast()]) will be based on the taxonomic kingdom and class. *Budding yeasts* are yeasts that reproduce asexually through a process called budding, where a new cell develops from a small protrusion on the parent cell. Taxonomically, these are members of the phylum Ascomycota, class Saccharomycetes (also called Hemiascomycetes) or Pichiomycetes. *True yeasts* quite specifically refers to yeasts in the underlying order Saccharomycetales (such as *Saccharomyces cerevisiae*). Thus, for all microorganisms that are member of the taxonomic class Saccharomycetes or Pichiomycetes, the function will return `TRUE`. It returns `FALSE` otherwise (or `NA` when the input is `NA` or the MO code is `UNKNOWN`).
|
#' Determination of yeasts ([mo_is_yeast()]) will be based on the taxonomic kingdom and class. *Budding yeasts* are yeasts that reproduce asexually through a process called budding, where a new cell develops from a small protrusion on the parent cell. Taxonomically, these are members of the phylum Ascomycota, class Saccharomycetes (also called Hemiascomycetes) or Pichiomycetes. *True yeasts* quite specifically refers to yeasts in the underlying order Saccharomycetales (such as *Saccharomyces cerevisiae*). Thus, for all microorganisms that are member of the taxonomic class Saccharomycetes or Pichiomycetes, the function will return `TRUE`. It returns `FALSE` otherwise (or `NA` when the input is `NA` or the MO code is `UNKNOWN`).
|
||||||
#'
|
#'
|
||||||
#' Determination of intrinsic resistance ([mo_is_intrinsic_resistant()]) will be based on the [intrinsic_resistant] data set, which is based on `r format_eucast_version_nr(3.3)`. The [mo_is_intrinsic_resistant()] function can be vectorised over both argument `x` (input for microorganisms) and `ab` (input for antibiotics).
|
#' Determination of intrinsic resistance ([mo_is_intrinsic_resistant()]) will be based on the [intrinsic_resistant] data set, which is based on `r format_eucast_version_nr(3.3)`. The [mo_is_intrinsic_resistant()] function can be vectorised over both argument `x` (input for microorganisms) and `ab` (input for antibiotics).
|
||||||
#'
|
#'
|
||||||
#' Determination of bacterial oxygen tolerance ([mo_oxygen_tolerance()]) will be based on BacDive, see *Source*. The function [mo_is_anaerobic()] only returns `TRUE` if the oxygen tolerance is `"anaerobe"`, indicting an obligate anaerobic species or genus. It always returns `FALSE` for species outside the taxonomic kingdom of Bacteria.
|
#' Determination of bacterial oxygen tolerance ([mo_oxygen_tolerance()]) will be based on BacDive, see *Source*. The function [mo_is_anaerobic()] only returns `TRUE` if the oxygen tolerance is `"anaerobe"`, indicting an obligate anaerobic species or genus. It always returns `FALSE` for species outside the taxonomic kingdom of Bacteria.
|
||||||
#'
|
#'
|
||||||
#' The function [mo_url()] will return the direct URL to the online database entry, which also shows the scientific reference of the concerned species. [This MycoBank URL](`r TAXONOMY_VERSION$MycoBank$url`) will be used for fungi wherever available , [this LPSN URL](`r TAXONOMY_VERSION$MycoBank$url`) for bacteria wherever available, and [this GBIF link](`r TAXONOMY_VERSION$GBIF$url`) otherwise.
|
#' The function [mo_url()] will return the direct URL to the online database entry, which also shows the scientific reference of the concerned species. [This MycoBank URL](`r TAXONOMY_VERSION$MycoBank$url`) will be used for fungi wherever available , [this LPSN URL](`r TAXONOMY_VERSION$MycoBank$url`) for bacteria wherever available, and [this GBIF link](`r TAXONOMY_VERSION$GBIF$url`) otherwise.
|
||||||
@@ -107,12 +107,14 @@
|
|||||||
#' mo_rank("Klebsiella pneumoniae")
|
#' mo_rank("Klebsiella pneumoniae")
|
||||||
#' mo_url("Klebsiella pneumoniae")
|
#' mo_url("Klebsiella pneumoniae")
|
||||||
#' mo_is_yeast(c("Candida", "Trichophyton", "Klebsiella"))
|
#' mo_is_yeast(c("Candida", "Trichophyton", "Klebsiella"))
|
||||||
#'
|
#'
|
||||||
#' mo_group_members(c("Streptococcus group A",
|
#' mo_group_members(c(
|
||||||
#' "Streptococcus group C",
|
#' "Streptococcus group A",
|
||||||
#' "Streptococcus group G",
|
#' "Streptococcus group C",
|
||||||
#' "Streptococcus group L"))
|
#' "Streptococcus group G",
|
||||||
#'
|
#' "Streptococcus group L"
|
||||||
|
#' ))
|
||||||
|
#'
|
||||||
#'
|
#'
|
||||||
#' # scientific reference -----------------------------------------------------
|
#' # scientific reference -----------------------------------------------------
|
||||||
#'
|
#'
|
||||||
@@ -125,7 +127,7 @@
|
|||||||
#' mo_mycobank("Candida albicans")
|
#' mo_mycobank("Candida albicans")
|
||||||
#' mo_mycobank("Candida krusei")
|
#' mo_mycobank("Candida krusei")
|
||||||
#' mo_mycobank("Candida krusei", keep_synonyms = TRUE)
|
#' mo_mycobank("Candida krusei", keep_synonyms = TRUE)
|
||||||
#'
|
#'
|
||||||
#'
|
#'
|
||||||
#' # abbreviations known in the field -----------------------------------------
|
#' # abbreviations known in the field -----------------------------------------
|
||||||
#'
|
#'
|
||||||
@@ -442,13 +444,16 @@ mo_pathogenicity <- function(x, language = get_AMR_locale(), keep_synonyms = get
|
|||||||
kngd <- AMR_env$MO_lookup$kingdom[match(x.mo, AMR_env$MO_lookup$mo)]
|
kngd <- AMR_env$MO_lookup$kingdom[match(x.mo, AMR_env$MO_lookup$mo)]
|
||||||
rank <- AMR_env$MO_lookup$rank[match(x.mo, AMR_env$MO_lookup$mo)]
|
rank <- AMR_env$MO_lookup$rank[match(x.mo, AMR_env$MO_lookup$mo)]
|
||||||
|
|
||||||
out <- factor(case_when_AMR(prev <= 1.15 & kngd == "Bacteria" & rank != "genus" ~ "Pathogenic",
|
out <- factor(
|
||||||
prev < 2 & kngd == "Fungi" ~ "Potentially pathogenic",
|
case_when_AMR(
|
||||||
prev == 2 & kngd == "Bacteria" ~ "Non-pathogenic",
|
prev <= 1.15 & kngd == "Bacteria" & rank != "genus" ~ "Pathogenic",
|
||||||
kngd == "Bacteria" ~ "Potentially pathogenic",
|
prev < 2 & kngd == "Fungi" ~ "Potentially pathogenic",
|
||||||
TRUE ~ "Unknown"),
|
prev == 2 & kngd == "Bacteria" ~ "Non-pathogenic",
|
||||||
levels = c("Pathogenic", "Potentially pathogenic", "Non-pathogenic", "Unknown"),
|
kngd == "Bacteria" ~ "Potentially pathogenic",
|
||||||
ordered = TRUE
|
TRUE ~ "Unknown"
|
||||||
|
),
|
||||||
|
levels = c("Pathogenic", "Potentially pathogenic", "Non-pathogenic", "Unknown"),
|
||||||
|
ordered = TRUE
|
||||||
)
|
)
|
||||||
|
|
||||||
load_mo_uncertainties(metadata)
|
load_mo_uncertainties(metadata)
|
||||||
@@ -606,7 +611,7 @@ mo_oxygen_tolerance <- function(x, language = get_AMR_locale(), keep_synonyms =
|
|||||||
meet_criteria(x, allow_NA = TRUE)
|
meet_criteria(x, allow_NA = TRUE)
|
||||||
language <- validate_language(language)
|
language <- validate_language(language)
|
||||||
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
|
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
|
||||||
|
|
||||||
mo_validate(x = x, property = "oxygen_tolerance", language = language, keep_synonyms = keep_synonyms, ...)
|
mo_validate(x = x, property = "oxygen_tolerance", language = language, keep_synonyms = keep_synonyms, ...)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -620,7 +625,7 @@ mo_is_anaerobic <- function(x, language = get_AMR_locale(), keep_synonyms = getO
|
|||||||
meet_criteria(x, allow_NA = TRUE)
|
meet_criteria(x, allow_NA = TRUE)
|
||||||
language <- validate_language(language)
|
language <- validate_language(language)
|
||||||
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
|
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
|
||||||
|
|
||||||
x.mo <- as.mo(x, language = language, keep_synonyms = keep_synonyms, ...)
|
x.mo <- as.mo(x, language = language, keep_synonyms = keep_synonyms, ...)
|
||||||
metadata <- get_mo_uncertainties()
|
metadata <- get_mo_uncertainties()
|
||||||
oxygen <- mo_oxygen_tolerance(x.mo, language = NULL, keep_synonyms = keep_synonyms)
|
oxygen <- mo_oxygen_tolerance(x.mo, language = NULL, keep_synonyms = keep_synonyms)
|
||||||
@@ -716,7 +721,7 @@ mo_mycobank <- function(x, language = get_AMR_locale(), keep_synonyms = getOptio
|
|||||||
meet_criteria(x, allow_NA = TRUE)
|
meet_criteria(x, allow_NA = TRUE)
|
||||||
language <- validate_language(language)
|
language <- validate_language(language)
|
||||||
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
|
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
|
||||||
|
|
||||||
mo_validate(x = x, property = "mycobank", language = language, keep_synonyms = keep_synonyms, ...)
|
mo_validate(x = x, property = "mycobank", language = language, keep_synonyms = keep_synonyms, ...)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -836,21 +841,21 @@ mo_group_members <- function(x, language = get_AMR_locale(), keep_synonyms = get
|
|||||||
meet_criteria(x, allow_NA = TRUE)
|
meet_criteria(x, allow_NA = TRUE)
|
||||||
language <- validate_language(language)
|
language <- validate_language(language)
|
||||||
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
|
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
|
||||||
|
|
||||||
add_MO_lookup_to_AMR_env()
|
add_MO_lookup_to_AMR_env()
|
||||||
|
|
||||||
x.mo <- as.mo(x, language = language, keep_synonyms = keep_synonyms, ...)
|
x.mo <- as.mo(x, language = language, keep_synonyms = keep_synonyms, ...)
|
||||||
metadata <- get_mo_uncertainties()
|
metadata <- get_mo_uncertainties()
|
||||||
|
|
||||||
members <- lapply(x.mo, function(y) {
|
members <- lapply(x.mo, function(y) {
|
||||||
AMR::microorganisms.groups$mo_name[which(AMR::microorganisms.groups$mo_group == y)]
|
AMR::microorganisms.groups$mo_name[which(AMR::microorganisms.groups$mo_group == y)]
|
||||||
})
|
})
|
||||||
names(members) <- mo_name(x, keep_synonyms = TRUE, language = language)
|
names(members) <- mo_name(x, keep_synonyms = TRUE, language = language)
|
||||||
|
|
||||||
if (length(members) == 1) {
|
if (length(members) == 1) {
|
||||||
members <- unname(unlist(members))
|
members <- unname(unlist(members))
|
||||||
}
|
}
|
||||||
|
|
||||||
load_mo_uncertainties(metadata)
|
load_mo_uncertainties(metadata)
|
||||||
members
|
members
|
||||||
}
|
}
|
||||||
@@ -872,8 +877,10 @@ mo_info <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("A
|
|||||||
|
|
||||||
info <- lapply(x, function(y) {
|
info <- lapply(x, function(y) {
|
||||||
c(
|
c(
|
||||||
list(mo = as.character(y),
|
list(
|
||||||
rank = mo_rank(y, language = language, keep_synonyms = keep_synonyms)),
|
mo = as.character(y),
|
||||||
|
rank = mo_rank(y, language = language, keep_synonyms = keep_synonyms)
|
||||||
|
),
|
||||||
mo_taxonomy(y, language = language, keep_synonyms = keep_synonyms),
|
mo_taxonomy(y, language = language, keep_synonyms = keep_synonyms),
|
||||||
list(
|
list(
|
||||||
status = mo_status(y, language = language, keep_synonyms = keep_synonyms),
|
status = mo_status(y, language = language, keep_synonyms = keep_synonyms),
|
||||||
@@ -920,7 +927,7 @@ mo_url <- function(x, open = FALSE, language = get_AMR_locale(), keep_synonyms =
|
|||||||
|
|
||||||
x.rank <- AMR_env$MO_lookup$rank[match(x.mo, AMR_env$MO_lookup$mo)]
|
x.rank <- AMR_env$MO_lookup$rank[match(x.mo, AMR_env$MO_lookup$mo)]
|
||||||
x.name <- AMR_env$MO_lookup$fullname[match(x.mo, AMR_env$MO_lookup$mo)]
|
x.name <- AMR_env$MO_lookup$fullname[match(x.mo, AMR_env$MO_lookup$mo)]
|
||||||
|
|
||||||
x.lpsn <- AMR_env$MO_lookup$lpsn[match(x.mo, AMR_env$MO_lookup$mo)]
|
x.lpsn <- AMR_env$MO_lookup$lpsn[match(x.mo, AMR_env$MO_lookup$mo)]
|
||||||
x.mycobank <- AMR_env$MO_lookup$mycobank[match(x.mo, AMR_env$MO_lookup$mo)]
|
x.mycobank <- AMR_env$MO_lookup$mycobank[match(x.mo, AMR_env$MO_lookup$mo)]
|
||||||
x.gbif <- AMR_env$MO_lookup$gbif[match(x.mo, AMR_env$MO_lookup$mo)]
|
x.gbif <- AMR_env$MO_lookup$gbif[match(x.mo, AMR_env$MO_lookup$mo)]
|
||||||
@@ -980,7 +987,7 @@ mo_validate <- function(x, property, language, keep_synonyms = keep_synonyms, ..
|
|||||||
Lancefield <- FALSE
|
Lancefield <- FALSE
|
||||||
}
|
}
|
||||||
has_Becker_or_Lancefield <- Becker %in% c(TRUE, "all") || Lancefield %in% c(TRUE, "all")
|
has_Becker_or_Lancefield <- Becker %in% c(TRUE, "all") || Lancefield %in% c(TRUE, "all")
|
||||||
|
|
||||||
if (isFALSE(has_Becker_or_Lancefield) && isTRUE(keep_synonyms) && all(x %in% c(AMR_env$MO_lookup$mo, NA))) {
|
if (isFALSE(has_Becker_or_Lancefield) && isTRUE(keep_synonyms) && all(x %in% c(AMR_env$MO_lookup$mo, NA))) {
|
||||||
# fastest way to get properties
|
# fastest way to get properties
|
||||||
if (property == "snomed") {
|
if (property == "snomed") {
|
||||||
@@ -988,11 +995,10 @@ mo_validate <- function(x, property, language, keep_synonyms = keep_synonyms, ..
|
|||||||
} else {
|
} else {
|
||||||
x <- AMR_env$MO_lookup[[property]][match(x, AMR_env$MO_lookup$mo)]
|
x <- AMR_env$MO_lookup[[property]][match(x, AMR_env$MO_lookup$mo)]
|
||||||
}
|
}
|
||||||
|
|
||||||
} else {
|
} else {
|
||||||
# get microorganisms data set, but remove synonyms if keep_synonyms is FALSE
|
# get microorganisms data set, but remove synonyms if keep_synonyms is FALSE
|
||||||
mo_data_check <- AMR_env$MO_lookup[which(AMR_env$MO_lookup$status %in% if (isTRUE(keep_synonyms)) c("synonym", "accepted") else "accepted"), , drop = FALSE]
|
mo_data_check <- AMR_env$MO_lookup[which(AMR_env$MO_lookup$status %in% if (isTRUE(keep_synonyms)) c("synonym", "accepted") else "accepted"), , drop = FALSE]
|
||||||
|
|
||||||
if (all(x %in% c(mo_data_check$mo, NA)) && !has_Becker_or_Lancefield) {
|
if (all(x %in% c(mo_data_check$mo, NA)) && !has_Becker_or_Lancefield) {
|
||||||
# do nothing, just don't run the other if-else's
|
# do nothing, just don't run the other if-else's
|
||||||
} else if (all(x %in% c(unlist(mo_data_check[[property]]), NA)) && !has_Becker_or_Lancefield) {
|
} else if (all(x %in% c(unlist(mo_data_check[[property]]), NA)) && !has_Becker_or_Lancefield) {
|
||||||
@@ -1003,7 +1009,7 @@ mo_validate <- function(x, property, language, keep_synonyms = keep_synonyms, ..
|
|||||||
x <- replace_old_mo_codes(x, property = property)
|
x <- replace_old_mo_codes(x, property = property)
|
||||||
x <- as.mo(x, language = language, keep_synonyms = keep_synonyms, ...)
|
x <- as.mo(x, language = language, keep_synonyms = keep_synonyms, ...)
|
||||||
}
|
}
|
||||||
|
|
||||||
# get property reeaaally fast using match()
|
# get property reeaaally fast using match()
|
||||||
if (property == "snomed") {
|
if (property == "snomed") {
|
||||||
x <- lapply(x, function(y) unlist(AMR_env$MO_lookup$snomed[match(y, AMR_env$MO_lookup$mo)]))
|
x <- lapply(x, function(y) unlist(AMR_env$MO_lookup$snomed[match(y, AMR_env$MO_lookup$mo)]))
|
||||||
|
|||||||
392
R/plotting.R
392
R/plotting.R
@@ -31,7 +31,7 @@
|
|||||||
#'
|
#'
|
||||||
#' @description
|
#' @description
|
||||||
#' Functions to plot classes `sir`, `mic` and `disk`, with support for base \R and `ggplot2`.
|
#' Functions to plot classes `sir`, `mic` and `disk`, with support for base \R and `ggplot2`.
|
||||||
#'
|
#'
|
||||||
#' Especially the `scale_*_mic()` functions are relevant wrappers to plot MIC values for `ggplot2`. They allows custom MIC ranges and to plot intermediate log2 levels for missing MIC values.
|
#' Especially the `scale_*_mic()` functions are relevant wrappers to plot MIC values for `ggplot2`. They allows custom MIC ranges and to plot intermediate log2 levels for missing MIC values.
|
||||||
#' @param x,object values created with [as.mic()], [as.disk()] or [as.sir()] (or their `random_*` variants, such as [random_mic()])
|
#' @param x,object values created with [as.mic()], [as.disk()] or [as.sir()] (or their `random_*` variants, such as [random_mic()])
|
||||||
#' @param mo any (vector of) text that can be coerced to a valid microorganism code with [as.mo()]
|
#' @param mo any (vector of) text that can be coerced to a valid microorganism code with [as.mo()]
|
||||||
@@ -51,23 +51,23 @@
|
|||||||
#' @inheritParams proportion
|
#' @inheritParams proportion
|
||||||
#' @details
|
#' @details
|
||||||
#' ### The `scale_*_mic()` Functions
|
#' ### The `scale_*_mic()` Functions
|
||||||
#'
|
#'
|
||||||
#' The functions [scale_x_mic()], [scale_y_mic()], [scale_colour_mic()], and [scale_fill_mic()] functions allow to plot the [mic][as.mic()] class (MIC values) on a continuous, logarithmic scale. They also allow to rescale the MIC range with an 'inside' or 'outside' range if required, and retain the signs in MIC values if desired. Missing intermediate log2 levels will be plotted too.
|
#' The functions [scale_x_mic()], [scale_y_mic()], [scale_colour_mic()], and [scale_fill_mic()] functions allow to plot the [mic][as.mic()] class (MIC values) on a continuous, logarithmic scale. They also allow to rescale the MIC range with an 'inside' or 'outside' range if required, and retain the signs in MIC values if desired. Missing intermediate log2 levels will be plotted too.
|
||||||
#'
|
#'
|
||||||
#' ### The `scale_*_sir()` Functions
|
#' ### The `scale_*_sir()` Functions
|
||||||
#'
|
#'
|
||||||
#' The functions [scale_x_sir()], [scale_colour_sir()], and [scale_fill_sir()] functions allow to plot the [sir][as.sir()] class in the right order (`r paste(levels(NA_sir_), collapse = " < ")`). At default, they translate the S/I/R values to an interpretative text ("Susceptible", "Resistant", etc.) in any of the `r length(AMR:::LANGUAGES_SUPPORTED)` supported languages (use `language = NULL` to keep S/I/R). Also, except for [scale_x_sir()], they set colour-blind friendly colours to the `colour` and `fill` aesthetics.
|
#' The functions [scale_x_sir()], [scale_colour_sir()], and [scale_fill_sir()] functions allow to plot the [sir][as.sir()] class in the right order (`r paste(levels(NA_sir_), collapse = " < ")`). At default, they translate the S/I/R values to an interpretative text ("Susceptible", "Resistant", etc.) in any of the `r length(AMR:::LANGUAGES_SUPPORTED)` supported languages (use `language = NULL` to keep S/I/R). Also, except for [scale_x_sir()], they set colour-blind friendly colours to the `colour` and `fill` aesthetics.
|
||||||
#'
|
#'
|
||||||
#' ### Additional `ggplot2` Functions
|
#' ### Additional `ggplot2` Functions
|
||||||
#'
|
#'
|
||||||
#' This package contains more functions that extend the `ggplot2` package, to help in visualising AMR data results. All these functions are internally used by [ggplot_sir()] too.
|
#' This package contains more functions that extend the `ggplot2` package, to help in visualising AMR data results. All these functions are internally used by [ggplot_sir()] too.
|
||||||
#'
|
#'
|
||||||
#' * [facet_sir()] creates 2d plots (at default based on S/I/R) using [ggplot2::facet_wrap()].
|
#' * [facet_sir()] creates 2d plots (at default based on S/I/R) using [ggplot2::facet_wrap()].
|
||||||
#' * [scale_y_percent()] transforms the y axis to a 0 to 100% range using [ggplot2::scale_y_continuous()].
|
#' * [scale_y_percent()] transforms the y axis to a 0 to 100% range using [ggplot2::scale_y_continuous()].
|
||||||
#' * [scale_sir_colours()] allows to set colours to any aesthetic, even for `shape` or `linetype`.
|
#' * [scale_sir_colours()] allows to set colours to any aesthetic, even for `shape` or `linetype`.
|
||||||
#' * [theme_sir()] is a [ggplot2 theme][[ggplot2::theme()] with minimal distraction.
|
#' * [theme_sir()] is a [ggplot2 theme][[ggplot2::theme()] with minimal distraction.
|
||||||
#' * [labels_sir_count()] print datalabels on the bars with percentage and number of isolates, using [ggplot2::geom_text()].
|
#' * [labels_sir_count()] print datalabels on the bars with percentage and number of isolates, using [ggplot2::geom_text()].
|
||||||
#'
|
#'
|
||||||
#' The interpretation of "I" will be named "Increased exposure" for all EUCAST guidelines since 2019, and will be named "Intermediate" in all other cases.
|
#' The interpretation of "I" will be named "Increased exposure" for all EUCAST guidelines since 2019, and will be named "Intermediate" in all other cases.
|
||||||
#'
|
#'
|
||||||
#' For interpreting MIC values as well as disk diffusion diameters, the default guideline is `r AMR::clinical_breakpoints$guideline[1]`, unless the package option [`AMR_guideline`][AMR-options] is set. See [as.sir()] for more information.
|
#' For interpreting MIC values as well as disk diffusion diameters, the default guideline is `r AMR::clinical_breakpoints$guideline[1]`, unless the package option [`AMR_guideline`][AMR-options] is set. See [as.sir()] for more information.
|
||||||
@@ -79,8 +79,7 @@
|
|||||||
#' some_mic_values <- random_mic(size = 100)
|
#' some_mic_values <- random_mic(size = 100)
|
||||||
#' some_disk_values <- random_disk(size = 100, mo = "Escherichia coli", ab = "cipro")
|
#' some_disk_values <- random_disk(size = 100, mo = "Escherichia coli", ab = "cipro")
|
||||||
#' some_sir_values <- random_sir(50, prob_SIR = c(0.55, 0.05, 0.30))
|
#' some_sir_values <- random_sir(50, prob_SIR = c(0.55, 0.05, 0.30))
|
||||||
#'
|
#'
|
||||||
#'
|
|
||||||
#' \donttest{
|
#' \donttest{
|
||||||
#' # Plotting using ggplot2's autoplot() for MIC, disk, and SIR -----------
|
#' # Plotting using ggplot2's autoplot() for MIC, disk, and SIR -----------
|
||||||
#' if (require("ggplot2")) {
|
#' if (require("ggplot2")) {
|
||||||
@@ -92,17 +91,23 @@
|
|||||||
#' }
|
#' }
|
||||||
#' if (require("ggplot2")) {
|
#' if (require("ggplot2")) {
|
||||||
#' # support for 20 languages, various guidelines, and many options
|
#' # support for 20 languages, various guidelines, and many options
|
||||||
#' autoplot(some_disk_values, mo = "Escherichia coli", ab = "cipro",
|
#' autoplot(some_disk_values,
|
||||||
#' guideline = "CLSI 2024", language = "no",
|
#' mo = "Escherichia coli", ab = "cipro",
|
||||||
#' title = "Disk diffusion from the North")
|
#' guideline = "CLSI 2024", language = "no",
|
||||||
|
#' title = "Disk diffusion from the North"
|
||||||
|
#' )
|
||||||
#' }
|
#' }
|
||||||
#'
|
#'
|
||||||
#'
|
#'
|
||||||
#' # Plotting using scale_x_mic() -----------------------------------------
|
#' # Plotting using scale_x_mic() -----------------------------------------
|
||||||
#' if (require("ggplot2")) {
|
#' if (require("ggplot2")) {
|
||||||
#' mic_plot <- ggplot(data.frame(mics = as.mic(c(0.25, "<=4", 4, 8, 32, ">=32")),
|
#' mic_plot <- ggplot(
|
||||||
#' counts = c(1, 1, 2, 2, 3, 3)),
|
#' data.frame(
|
||||||
#' aes(mics, counts)) +
|
#' mics = as.mic(c(0.25, "<=4", 4, 8, 32, ">=32")),
|
||||||
|
#' counts = c(1, 1, 2, 2, 3, 3)
|
||||||
|
#' ),
|
||||||
|
#' aes(mics, counts)
|
||||||
|
#' ) +
|
||||||
#' geom_col()
|
#' geom_col()
|
||||||
#' mic_plot +
|
#' mic_plot +
|
||||||
#' labs(title = "without scale_x_mic()")
|
#' labs(title = "without scale_x_mic()")
|
||||||
@@ -127,51 +132,68 @@
|
|||||||
#' scale_x_mic(mic_range = c(0.032, 256)) +
|
#' scale_x_mic(mic_range = c(0.032, 256)) +
|
||||||
#' labs(title = "with scale_x_mic() using a manual 'outside' range")
|
#' labs(title = "with scale_x_mic() using a manual 'outside' range")
|
||||||
#' }
|
#' }
|
||||||
#'
|
#'
|
||||||
#'
|
#'
|
||||||
#' # Plotting using scale_y_mic() -----------------------------------------
|
#' # Plotting using scale_y_mic() -----------------------------------------
|
||||||
#' some_groups <- sample(LETTERS[1:5], 20, replace = TRUE)
|
#' some_groups <- sample(LETTERS[1:5], 20, replace = TRUE)
|
||||||
#'
|
#'
|
||||||
#' if (require("ggplot2")) {
|
#' if (require("ggplot2")) {
|
||||||
#' ggplot(data.frame(mic = some_mic_values,
|
#' ggplot(
|
||||||
#' group = some_groups),
|
#' data.frame(
|
||||||
#' aes(group, mic)) +
|
#' mic = some_mic_values,
|
||||||
|
#' group = some_groups
|
||||||
|
#' ),
|
||||||
|
#' aes(group, mic)
|
||||||
|
#' ) +
|
||||||
#' geom_boxplot() +
|
#' geom_boxplot() +
|
||||||
#' geom_violin(linetype = 2, colour = "grey", fill = NA) +
|
#' geom_violin(linetype = 2, colour = "grey", fill = NA) +
|
||||||
#' scale_y_mic()
|
#' scale_y_mic()
|
||||||
#' }
|
#' }
|
||||||
#' if (require("ggplot2")) {
|
#' if (require("ggplot2")) {
|
||||||
#' ggplot(data.frame(mic = some_mic_values,
|
#' ggplot(
|
||||||
#' group = some_groups),
|
#' data.frame(
|
||||||
#' aes(group, mic)) +
|
#' mic = some_mic_values,
|
||||||
|
#' group = some_groups
|
||||||
|
#' ),
|
||||||
|
#' aes(group, mic)
|
||||||
|
#' ) +
|
||||||
#' geom_boxplot() +
|
#' geom_boxplot() +
|
||||||
#' geom_violin(linetype = 2, colour = "grey", fill = NA) +
|
#' geom_violin(linetype = 2, colour = "grey", fill = NA) +
|
||||||
#' scale_y_mic(mic_range = c(NA, 0.25))
|
#' scale_y_mic(mic_range = c(NA, 0.25))
|
||||||
#' }
|
#' }
|
||||||
#'
|
#'
|
||||||
#'
|
#'
|
||||||
#' # Plotting using scale_x_sir() -----------------------------------------
|
#' # Plotting using scale_x_sir() -----------------------------------------
|
||||||
#' if (require("ggplot2")) {
|
#' if (require("ggplot2")) {
|
||||||
#' ggplot(data.frame(x = c("I", "R", "S"),
|
#' ggplot(
|
||||||
#' y = c(45,323, 573)),
|
#' data.frame(
|
||||||
#' aes(x, y)) +
|
#' x = c("I", "R", "S"),
|
||||||
|
#' y = c(45, 323, 573)
|
||||||
|
#' ),
|
||||||
|
#' aes(x, y)
|
||||||
|
#' ) +
|
||||||
#' geom_col() +
|
#' geom_col() +
|
||||||
#' scale_x_sir()
|
#' scale_x_sir()
|
||||||
#' }
|
#' }
|
||||||
#'
|
#'
|
||||||
#'
|
#'
|
||||||
#' # Plotting using scale_y_mic() and scale_colour_sir() ------------------
|
#' # Plotting using scale_y_mic() and scale_colour_sir() ------------------
|
||||||
#' if (require("ggplot2")) {
|
#' if (require("ggplot2")) {
|
||||||
#' plain <- ggplot(data.frame(mic = some_mic_values,
|
#' plain <- ggplot(
|
||||||
#' group = some_groups,
|
#' data.frame(
|
||||||
#' sir = as.sir(some_mic_values,
|
#' mic = some_mic_values,
|
||||||
#' mo = "E. coli",
|
#' group = some_groups,
|
||||||
#' ab = "cipro")),
|
#' sir = as.sir(some_mic_values,
|
||||||
#' aes(x = group, y = mic, colour = sir)) +
|
#' mo = "E. coli",
|
||||||
|
#' ab = "cipro"
|
||||||
|
#' )
|
||||||
|
#' ),
|
||||||
|
#' aes(x = group, y = mic, colour = sir)
|
||||||
|
#' ) +
|
||||||
#' theme_minimal() +
|
#' theme_minimal() +
|
||||||
#' geom_boxplot(fill = NA, colour = "grey") +
|
#' geom_boxplot(fill = NA, colour = "grey") +
|
||||||
#' geom_jitter(width = 0.25)
|
#' geom_jitter(width = 0.25)
|
||||||
#'
|
#'
|
||||||
#' plain
|
#' plain
|
||||||
#' }
|
#' }
|
||||||
#' if (require("ggplot2")) {
|
#' if (require("ggplot2")) {
|
||||||
@@ -183,37 +205,40 @@
|
|||||||
#' if (require("ggplot2")) {
|
#' if (require("ggplot2")) {
|
||||||
#' plain +
|
#' plain +
|
||||||
#' scale_y_mic(mic_range = c(0.005, 32), name = "Our MICs!") +
|
#' scale_y_mic(mic_range = c(0.005, 32), name = "Our MICs!") +
|
||||||
#' scale_colour_sir(language = "pt",
|
#' scale_colour_sir(
|
||||||
#' name = "Support in 20 languages")
|
#' language = "pt",
|
||||||
|
#' name = "Support in 20 languages"
|
||||||
|
#' )
|
||||||
#' }
|
#' }
|
||||||
#' }
|
#' }
|
||||||
#'
|
#'
|
||||||
#' # Plotting using base R's plot() ---------------------------------------
|
#' # Plotting using base R's plot() ---------------------------------------
|
||||||
#'
|
#'
|
||||||
#' plot(some_mic_values)
|
#' plot(some_mic_values)
|
||||||
#' # when providing the microorganism and antibiotic, colours will show interpretations:
|
#' # when providing the microorganism and antibiotic, colours will show interpretations:
|
||||||
#' plot(some_mic_values, mo = "S. aureus", ab = "ampicillin")
|
#' plot(some_mic_values, mo = "S. aureus", ab = "ampicillin")
|
||||||
#'
|
#'
|
||||||
#' plot(some_disk_values)
|
#' plot(some_disk_values)
|
||||||
#' plot(some_disk_values, mo = "Escherichia coli", ab = "cipro")
|
#' plot(some_disk_values, mo = "Escherichia coli", ab = "cipro")
|
||||||
#' plot(some_disk_values, mo = "Escherichia coli", ab = "cipro", language = "nl")
|
#' plot(some_disk_values, mo = "Escherichia coli", ab = "cipro", language = "nl")
|
||||||
#'
|
#'
|
||||||
#' plot(some_sir_values)
|
#' plot(some_sir_values)
|
||||||
NULL
|
NULL
|
||||||
|
|
||||||
create_scale_mic <- function(aest, keep_operators, mic_range = NULL, ...) {
|
create_scale_mic <- function(aest, keep_operators, mic_range = NULL, ...) {
|
||||||
ggplot_fn <- getExportedValue(paste0("scale_", aest, "_continuous"),
|
ggplot_fn <- getExportedValue(paste0("scale_", aest, "_continuous"),
|
||||||
ns = asNamespace("ggplot2"))
|
ns = asNamespace("ggplot2")
|
||||||
|
)
|
||||||
args <- list(...)
|
args <- list(...)
|
||||||
breaks_set <- args$breaks
|
breaks_set <- args$breaks
|
||||||
limits_set <- args$limits
|
limits_set <- args$limits
|
||||||
|
|
||||||
# do not take these arguments into account, as they will be overwritten and seem to allow weird behaviour if set anyway
|
# do not take these arguments into account, as they will be overwritten and seem to allow weird behaviour if set anyway
|
||||||
args[c("aesthetics", "trans", "transform", "transform_df", "breaks", "labels", "limits")] <- NULL
|
args[c("aesthetics", "trans", "transform", "transform_df", "breaks", "labels", "limits")] <- NULL
|
||||||
scale <- do.call(ggplot_fn, args)
|
scale <- do.call(ggplot_fn, args)
|
||||||
scale$mic_breaks_set <- breaks_set
|
scale$mic_breaks_set <- breaks_set
|
||||||
scale$mic_limits_set <- limits_set
|
scale$mic_limits_set <- limits_set
|
||||||
|
|
||||||
scale$transform <- function(x) {
|
scale$transform <- function(x) {
|
||||||
as.double(rescale_mic(x = as.double(as.mic(x)), keep_operators = keep_operators, mic_range = mic_range, as.mic = TRUE))
|
as.double(rescale_mic(x = as.double(as.mic(x)), keep_operators = keep_operators, mic_range = mic_range, as.mic = TRUE))
|
||||||
}
|
}
|
||||||
@@ -228,16 +253,16 @@ create_scale_mic <- function(aest, keep_operators, mic_range = NULL, ...) {
|
|||||||
if (!is.null(mic_range) && !is.na(mic_range[2]) && !is.na(lims[2]) && mic_range[2] > lims[2]) {
|
if (!is.null(mic_range) && !is.na(mic_range[2]) && !is.na(lims[2]) && mic_range[2] > lims[2]) {
|
||||||
lims[2] <- mic_range[2]
|
lims[2] <- mic_range[2]
|
||||||
}
|
}
|
||||||
ind_min <- which(COMMON_MIC_VALUES <= lims[1])[which.min(abs(COMMON_MIC_VALUES[COMMON_MIC_VALUES <= lims[1]] - lims[1]))] # Closest index where COMMON_MIC_VALUES <= lims[1]
|
ind_min <- which(COMMON_MIC_VALUES <= lims[1])[which.min(abs(COMMON_MIC_VALUES[COMMON_MIC_VALUES <= lims[1]] - lims[1]))] # Closest index where COMMON_MIC_VALUES <= lims[1]
|
||||||
ind_max <- which(COMMON_MIC_VALUES >= lims[2])[which.min(abs(COMMON_MIC_VALUES[COMMON_MIC_VALUES >= lims[2]] - lims[2]))] # Closest index where COMMON_MIC_VALUES >= lims[2]
|
ind_max <- which(COMMON_MIC_VALUES >= lims[2])[which.min(abs(COMMON_MIC_VALUES[COMMON_MIC_VALUES >= lims[2]] - lims[2]))] # Closest index where COMMON_MIC_VALUES >= lims[2]
|
||||||
|
|
||||||
self$mic_values_levels <- as.mic(COMMON_MIC_VALUES[ind_min:ind_max])
|
self$mic_values_levels <- as.mic(COMMON_MIC_VALUES[ind_min:ind_max])
|
||||||
|
|
||||||
if (keep_operators %in% c("edges", "all") && length(self$mic_values_levels) > 1) {
|
if (keep_operators %in% c("edges", "all") && length(self$mic_values_levels) > 1) {
|
||||||
self$mic_values_levels[1] <- paste0("<=", self$mic_values_levels[1])
|
self$mic_values_levels[1] <- paste0("<=", self$mic_values_levels[1])
|
||||||
self$mic_values_levels[length(self$mic_values_levels)] <- paste0(">=", self$mic_values_levels[length(self$mic_values_levels)])
|
self$mic_values_levels[length(self$mic_values_levels)] <- paste0(">=", self$mic_values_levels[length(self$mic_values_levels)])
|
||||||
}
|
}
|
||||||
|
|
||||||
self$mic_values_log <- log2(as.double(self$mic_values_rescaled))
|
self$mic_values_log <- log2(as.double(self$mic_values_rescaled))
|
||||||
if (aest == "y" && "group" %in% colnames(df)) {
|
if (aest == "y" && "group" %in% colnames(df)) {
|
||||||
df$group <- as.integer(factor(df$x))
|
df$group <- as.integer(factor(df$x))
|
||||||
@@ -245,7 +270,7 @@ create_scale_mic <- function(aest, keep_operators, mic_range = NULL, ...) {
|
|||||||
df[[aest]] <- self$mic_values_log
|
df[[aest]] <- self$mic_values_log
|
||||||
df
|
df
|
||||||
}
|
}
|
||||||
|
|
||||||
scale$breaks <- function(..., self) {
|
scale$breaks <- function(..., self) {
|
||||||
if (!is.null(self$mic_breaks_set)) {
|
if (!is.null(self$mic_breaks_set)) {
|
||||||
if (is.function(self$mic_breaks_set)) {
|
if (is.function(self$mic_breaks_set)) {
|
||||||
@@ -264,13 +289,13 @@ create_scale_mic <- function(aest, keep_operators, mic_range = NULL, ...) {
|
|||||||
breaks <- tryCatch(scale$breaks(), error = function(e) NULL)
|
breaks <- tryCatch(scale$breaks(), error = function(e) NULL)
|
||||||
if (!is.null(breaks)) {
|
if (!is.null(breaks)) {
|
||||||
# for when breaks are set by the user
|
# for when breaks are set by the user
|
||||||
2 ^ breaks
|
2^breaks
|
||||||
} else {
|
} else {
|
||||||
self$mic_values_levels
|
self$mic_values_levels
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
scale$limits <- function(x, ..., self) {
|
scale$limits <- function(x, ..., self) {
|
||||||
if (!is.null(self$mic_limits_set)) {
|
if (!is.null(self$mic_limits_set)) {
|
||||||
if (is.function(self$mic_limits_set)) {
|
if (is.function(self$mic_limits_set)) {
|
||||||
@@ -289,7 +314,7 @@ create_scale_mic <- function(aest, keep_operators, mic_range = NULL, ...) {
|
|||||||
rng
|
rng
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
scale
|
scale
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -333,25 +358,32 @@ scale_fill_mic <- function(keep_operators = "edges", mic_range = NULL, ...) {
|
|||||||
create_scale_sir <- function(aesthetics, colours_SIR, language, eucast_I, ...) {
|
create_scale_sir <- function(aesthetics, colours_SIR, language, eucast_I, ...) {
|
||||||
args <- list(...)
|
args <- list(...)
|
||||||
args[c("value", "labels", "limits")] <- NULL
|
args[c("value", "labels", "limits")] <- NULL
|
||||||
|
|
||||||
if (identical(aesthetics, "x")) {
|
if (identical(aesthetics, "x")) {
|
||||||
ggplot_fn <- ggplot2::scale_x_discrete
|
ggplot_fn <- ggplot2::scale_x_discrete
|
||||||
} else {
|
} else {
|
||||||
ggplot_fn <- ggplot2::scale_discrete_manual
|
ggplot_fn <- ggplot2::scale_discrete_manual
|
||||||
args <- c(args,
|
args <- c(
|
||||||
list(aesthetics = aesthetics,
|
args,
|
||||||
values = c(S = colours_SIR[1],
|
list(
|
||||||
SDD = colours_SIR[2],
|
aesthetics = aesthetics,
|
||||||
I = colours_SIR[2],
|
values = c(
|
||||||
R = colours_SIR[3],
|
S = colours_SIR[1],
|
||||||
NI = "grey30")))
|
SDD = colours_SIR[2],
|
||||||
|
I = colours_SIR[2],
|
||||||
|
R = colours_SIR[3],
|
||||||
|
NI = "grey30"
|
||||||
|
)
|
||||||
|
)
|
||||||
|
)
|
||||||
}
|
}
|
||||||
scale <- do.call(ggplot_fn, args)
|
scale <- do.call(ggplot_fn, args)
|
||||||
|
|
||||||
scale$labels <- function(x) {
|
scale$labels <- function(x) {
|
||||||
stop_ifnot(all(x %in% c(levels(NA_sir_), NA)),
|
stop_ifnot(all(x %in% c(levels(NA_sir_), NA)),
|
||||||
"Apply `scale_", aesthetics[1], "_sir()` to a variable of class 'sir', see `?as.sir`.",
|
"Apply `scale_", aesthetics[1], "_sir()` to a variable of class 'sir', see `?as.sir`.",
|
||||||
call = FALSE)
|
call = FALSE
|
||||||
|
)
|
||||||
x <- as.character(as.sir(x))
|
x <- as.character(as.sir(x))
|
||||||
if (!is.null(language)) {
|
if (!is.null(language)) {
|
||||||
x[x == "S"] <- "(S) Susceptible"
|
x[x == "S"] <- "(S) Susceptible"
|
||||||
@@ -371,7 +403,7 @@ create_scale_sir <- function(aesthetics, colours_SIR, language, eucast_I, ...) {
|
|||||||
# force SIR in the right order
|
# force SIR in the right order
|
||||||
as.character(sort(factor(x, levels = levels(NA_sir_))))
|
as.character(sort(factor(x, levels = levels(NA_sir_))))
|
||||||
}
|
}
|
||||||
|
|
||||||
scale
|
scale
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -456,14 +488,14 @@ plot.mic <- function(x,
|
|||||||
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
|
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
|
||||||
language <- validate_language(language)
|
language <- validate_language(language)
|
||||||
meet_criteria(expand, allow_class = "logical", has_length = 1)
|
meet_criteria(expand, allow_class = "logical", has_length = 1)
|
||||||
|
|
||||||
x <- as.mic(x) # make sure that currently implemented MIC levels are used
|
x <- as.mic(x) # make sure that currently implemented MIC levels are used
|
||||||
|
|
||||||
if (length(colours_SIR) == 1) {
|
if (length(colours_SIR) == 1) {
|
||||||
colours_SIR <- rep(colours_SIR, 3)
|
colours_SIR <- rep(colours_SIR, 3)
|
||||||
}
|
}
|
||||||
main <- gsub(" +", " ", paste0(main, collapse = " "))
|
main <- gsub(" +", " ", paste0(main, collapse = " "))
|
||||||
|
|
||||||
x <- plotrange_as_table(x, expand = expand)
|
x <- plotrange_as_table(x, expand = expand)
|
||||||
cols_sub <- plot_colours_subtitle_guideline(
|
cols_sub <- plot_colours_subtitle_guideline(
|
||||||
x = x,
|
x = x,
|
||||||
@@ -479,18 +511,18 @@ plot.mic <- function(x,
|
|||||||
...
|
...
|
||||||
)
|
)
|
||||||
barplot(x,
|
barplot(x,
|
||||||
col = cols_sub$cols,
|
col = cols_sub$cols,
|
||||||
main = main,
|
main = main,
|
||||||
ylim = c(0, max(x) * ifelse(any(colours_SIR %in% cols_sub$cols), 1.1, 1)),
|
ylim = c(0, max(x) * ifelse(any(colours_SIR %in% cols_sub$cols), 1.1, 1)),
|
||||||
ylab = ylab,
|
ylab = ylab,
|
||||||
xlab = xlab,
|
xlab = xlab,
|
||||||
axes = FALSE
|
axes = FALSE
|
||||||
)
|
)
|
||||||
axis(2, seq(0, max(x)))
|
axis(2, seq(0, max(x)))
|
||||||
if (!is.null(cols_sub$sub)) {
|
if (!is.null(cols_sub$sub)) {
|
||||||
mtext(side = 3, line = 0.5, adj = 0.5, cex = 0.75, cols_sub$sub)
|
mtext(side = 3, line = 0.5, adj = 0.5, cex = 0.75, cols_sub$sub)
|
||||||
}
|
}
|
||||||
|
|
||||||
if (any(colours_SIR %in% cols_sub$cols)) {
|
if (any(colours_SIR %in% cols_sub$cols)) {
|
||||||
legend_txt <- character(0)
|
legend_txt <- character(0)
|
||||||
legend_col <- character(0)
|
legend_col <- character(0)
|
||||||
@@ -506,16 +538,16 @@ plot.mic <- function(x,
|
|||||||
legend_txt <- c(legend_txt, "(R) Resistant")
|
legend_txt <- c(legend_txt, "(R) Resistant")
|
||||||
legend_col <- c(legend_col, colours_SIR[3])
|
legend_col <- c(legend_col, colours_SIR[3])
|
||||||
}
|
}
|
||||||
|
|
||||||
legend("top",
|
legend("top",
|
||||||
x.intersp = 0.5,
|
x.intersp = 0.5,
|
||||||
legend = translate_into_language(legend_txt, language = language),
|
legend = translate_into_language(legend_txt, language = language),
|
||||||
fill = legend_col,
|
fill = legend_col,
|
||||||
horiz = TRUE,
|
horiz = TRUE,
|
||||||
cex = 0.75,
|
cex = 0.75,
|
||||||
box.lwd = 0,
|
box.lwd = 0,
|
||||||
box.col = "#FFFFFF55",
|
box.col = "#FFFFFF55",
|
||||||
bg = "#FFFFFF55"
|
bg = "#FFFFFF55"
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
@@ -543,11 +575,11 @@ barplot.mic <- function(height,
|
|||||||
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
|
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
|
||||||
language <- validate_language(language)
|
language <- validate_language(language)
|
||||||
meet_criteria(expand, allow_class = "logical", has_length = 1)
|
meet_criteria(expand, allow_class = "logical", has_length = 1)
|
||||||
|
|
||||||
main <- gsub(" +", " ", paste0(main, collapse = " "))
|
main <- gsub(" +", " ", paste0(main, collapse = " "))
|
||||||
|
|
||||||
height <- as.mic(height) # make sure that currently implemented MIC levels are used
|
height <- as.mic(height) # make sure that currently implemented MIC levels are used
|
||||||
|
|
||||||
plot(
|
plot(
|
||||||
x = height,
|
x = height,
|
||||||
main = main,
|
main = main,
|
||||||
@@ -587,14 +619,14 @@ autoplot.mic <- function(object,
|
|||||||
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
|
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
|
||||||
language <- validate_language(language)
|
language <- validate_language(language)
|
||||||
meet_criteria(expand, allow_class = "logical", has_length = 1)
|
meet_criteria(expand, allow_class = "logical", has_length = 1)
|
||||||
|
|
||||||
if ("main" %in% names(list(...))) {
|
if ("main" %in% names(list(...))) {
|
||||||
title <- list(...)$main
|
title <- list(...)$main
|
||||||
}
|
}
|
||||||
if (!is.null(title)) {
|
if (!is.null(title)) {
|
||||||
title <- gsub(" +", " ", paste0(title, collapse = " "))
|
title <- gsub(" +", " ", paste0(title, collapse = " "))
|
||||||
}
|
}
|
||||||
|
|
||||||
object <- as.mic(object) # make sure that currently implemented MIC levels are used
|
object <- as.mic(object) # make sure that currently implemented MIC levels are used
|
||||||
x <- plotrange_as_table(object, expand = expand)
|
x <- plotrange_as_table(object, expand = expand)
|
||||||
cols_sub <- plot_colours_subtitle_guideline(
|
cols_sub <- plot_colours_subtitle_guideline(
|
||||||
@@ -617,18 +649,18 @@ autoplot.mic <- function(object,
|
|||||||
df$cols[df$cols == colours_SIR[2]] <- paste("(I)", plot_name_of_I(cols_sub$guideline))
|
df$cols[df$cols == colours_SIR[2]] <- paste("(I)", plot_name_of_I(cols_sub$guideline))
|
||||||
df$cols[df$cols == colours_SIR[3]] <- "(R) Resistant"
|
df$cols[df$cols == colours_SIR[3]] <- "(R) Resistant"
|
||||||
df$cols <- factor(translate_into_language(df$cols, language = language),
|
df$cols <- factor(translate_into_language(df$cols, language = language),
|
||||||
levels = translate_into_language(
|
levels = translate_into_language(
|
||||||
c(
|
c(
|
||||||
"(S) Susceptible",
|
"(S) Susceptible",
|
||||||
paste("(I)", plot_name_of_I(cols_sub$guideline)),
|
paste("(I)", plot_name_of_I(cols_sub$guideline)),
|
||||||
"(R) Resistant"
|
"(R) Resistant"
|
||||||
),
|
),
|
||||||
language = language
|
language = language
|
||||||
),
|
),
|
||||||
ordered = TRUE
|
ordered = TRUE
|
||||||
)
|
)
|
||||||
p <- ggplot2::ggplot(df)
|
p <- ggplot2::ggplot(df)
|
||||||
|
|
||||||
if (any(colours_SIR %in% cols_sub$cols)) {
|
if (any(colours_SIR %in% cols_sub$cols)) {
|
||||||
vals <- c(
|
vals <- c(
|
||||||
"(S) Susceptible" = colours_SIR[1],
|
"(S) Susceptible" = colours_SIR[1],
|
||||||
@@ -650,7 +682,7 @@ autoplot.mic <- function(object,
|
|||||||
p <- p +
|
p <- p +
|
||||||
ggplot2::geom_col(ggplot2::aes(x = mic, y = count))
|
ggplot2::geom_col(ggplot2::aes(x = mic, y = count))
|
||||||
}
|
}
|
||||||
|
|
||||||
p +
|
p +
|
||||||
ggplot2::labs(title = title, x = xlab, y = ylab, subtitle = cols_sub$sub)
|
ggplot2::labs(title = title, x = xlab, y = ylab, subtitle = cols_sub$sub)
|
||||||
}
|
}
|
||||||
@@ -693,12 +725,12 @@ plot.disk <- function(x,
|
|||||||
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
|
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
|
||||||
language <- validate_language(language)
|
language <- validate_language(language)
|
||||||
meet_criteria(expand, allow_class = "logical", has_length = 1)
|
meet_criteria(expand, allow_class = "logical", has_length = 1)
|
||||||
|
|
||||||
if (length(colours_SIR) == 1) {
|
if (length(colours_SIR) == 1) {
|
||||||
colours_SIR <- rep(colours_SIR, 3)
|
colours_SIR <- rep(colours_SIR, 3)
|
||||||
}
|
}
|
||||||
main <- gsub(" +", " ", paste0(main, collapse = " "))
|
main <- gsub(" +", " ", paste0(main, collapse = " "))
|
||||||
|
|
||||||
x <- plotrange_as_table(x, expand = expand)
|
x <- plotrange_as_table(x, expand = expand)
|
||||||
cols_sub <- plot_colours_subtitle_guideline(
|
cols_sub <- plot_colours_subtitle_guideline(
|
||||||
x = x,
|
x = x,
|
||||||
@@ -713,20 +745,20 @@ plot.disk <- function(x,
|
|||||||
breakpoint_type = breakpoint_type,
|
breakpoint_type = breakpoint_type,
|
||||||
...
|
...
|
||||||
)
|
)
|
||||||
|
|
||||||
barplot(x,
|
barplot(x,
|
||||||
col = cols_sub$cols,
|
col = cols_sub$cols,
|
||||||
main = main,
|
main = main,
|
||||||
ylim = c(0, max(x) * ifelse(any(colours_SIR %in% cols_sub$cols), 1.1, 1)),
|
ylim = c(0, max(x) * ifelse(any(colours_SIR %in% cols_sub$cols), 1.1, 1)),
|
||||||
ylab = ylab,
|
ylab = ylab,
|
||||||
xlab = xlab,
|
xlab = xlab,
|
||||||
axes = FALSE
|
axes = FALSE
|
||||||
)
|
)
|
||||||
axis(2, seq(0, max(x)))
|
axis(2, seq(0, max(x)))
|
||||||
if (!is.null(cols_sub$sub)) {
|
if (!is.null(cols_sub$sub)) {
|
||||||
mtext(side = 3, line = 0.5, adj = 0.5, cex = 0.75, cols_sub$sub)
|
mtext(side = 3, line = 0.5, adj = 0.5, cex = 0.75, cols_sub$sub)
|
||||||
}
|
}
|
||||||
|
|
||||||
if (any(colours_SIR %in% cols_sub$cols)) {
|
if (any(colours_SIR %in% cols_sub$cols)) {
|
||||||
legend_txt <- character(0)
|
legend_txt <- character(0)
|
||||||
legend_col <- character(0)
|
legend_col <- character(0)
|
||||||
@@ -743,14 +775,14 @@ plot.disk <- function(x,
|
|||||||
legend_col <- c(legend_col, colours_SIR[1])
|
legend_col <- c(legend_col, colours_SIR[1])
|
||||||
}
|
}
|
||||||
legend("top",
|
legend("top",
|
||||||
x.intersp = 0.5,
|
x.intersp = 0.5,
|
||||||
legend = translate_into_language(legend_txt, language = language),
|
legend = translate_into_language(legend_txt, language = language),
|
||||||
fill = legend_col,
|
fill = legend_col,
|
||||||
horiz = TRUE,
|
horiz = TRUE,
|
||||||
cex = 0.75,
|
cex = 0.75,
|
||||||
box.lwd = 0,
|
box.lwd = 0,
|
||||||
box.col = "#FFFFFF55",
|
box.col = "#FFFFFF55",
|
||||||
bg = "#FFFFFF55"
|
bg = "#FFFFFF55"
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
@@ -778,9 +810,9 @@ barplot.disk <- function(height,
|
|||||||
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
|
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
|
||||||
language <- validate_language(language)
|
language <- validate_language(language)
|
||||||
meet_criteria(expand, allow_class = "logical", has_length = 1)
|
meet_criteria(expand, allow_class = "logical", has_length = 1)
|
||||||
|
|
||||||
main <- gsub(" +", " ", paste0(main, collapse = " "))
|
main <- gsub(" +", " ", paste0(main, collapse = " "))
|
||||||
|
|
||||||
plot(
|
plot(
|
||||||
x = height,
|
x = height,
|
||||||
main = main,
|
main = main,
|
||||||
@@ -820,14 +852,14 @@ autoplot.disk <- function(object,
|
|||||||
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
|
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
|
||||||
language <- validate_language(language)
|
language <- validate_language(language)
|
||||||
meet_criteria(expand, allow_class = "logical", has_length = 1)
|
meet_criteria(expand, allow_class = "logical", has_length = 1)
|
||||||
|
|
||||||
if ("main" %in% names(list(...))) {
|
if ("main" %in% names(list(...))) {
|
||||||
title <- list(...)$main
|
title <- list(...)$main
|
||||||
}
|
}
|
||||||
if (!is.null(title)) {
|
if (!is.null(title)) {
|
||||||
title <- gsub(" +", " ", paste0(title, collapse = " "))
|
title <- gsub(" +", " ", paste0(title, collapse = " "))
|
||||||
}
|
}
|
||||||
|
|
||||||
x <- plotrange_as_table(object, expand = expand)
|
x <- plotrange_as_table(object, expand = expand)
|
||||||
cols_sub <- plot_colours_subtitle_guideline(
|
cols_sub <- plot_colours_subtitle_guideline(
|
||||||
x = x,
|
x = x,
|
||||||
@@ -845,23 +877,23 @@ autoplot.disk <- function(object,
|
|||||||
df <- as.data.frame(x, stringsAsFactors = TRUE)
|
df <- as.data.frame(x, stringsAsFactors = TRUE)
|
||||||
colnames(df) <- c("disk", "count")
|
colnames(df) <- c("disk", "count")
|
||||||
df$cols <- cols_sub$cols
|
df$cols <- cols_sub$cols
|
||||||
|
|
||||||
df$cols[df$cols == colours_SIR[1]] <- "(S) Susceptible"
|
df$cols[df$cols == colours_SIR[1]] <- "(S) Susceptible"
|
||||||
df$cols[df$cols == colours_SIR[2]] <- paste("(I)", plot_name_of_I(cols_sub$guideline))
|
df$cols[df$cols == colours_SIR[2]] <- paste("(I)", plot_name_of_I(cols_sub$guideline))
|
||||||
df$cols[df$cols == colours_SIR[3]] <- "(R) Resistant"
|
df$cols[df$cols == colours_SIR[3]] <- "(R) Resistant"
|
||||||
df$cols <- factor(translate_into_language(df$cols, language = language),
|
df$cols <- factor(translate_into_language(df$cols, language = language),
|
||||||
levels = translate_into_language(
|
levels = translate_into_language(
|
||||||
c(
|
c(
|
||||||
"(S) Susceptible",
|
"(S) Susceptible",
|
||||||
paste("(I)", plot_name_of_I(cols_sub$guideline)),
|
paste("(I)", plot_name_of_I(cols_sub$guideline)),
|
||||||
"(R) Resistant"
|
"(R) Resistant"
|
||||||
),
|
),
|
||||||
language = language
|
language = language
|
||||||
),
|
),
|
||||||
ordered = TRUE
|
ordered = TRUE
|
||||||
)
|
)
|
||||||
p <- ggplot2::ggplot(df)
|
p <- ggplot2::ggplot(df)
|
||||||
|
|
||||||
if (any(colours_SIR %in% cols_sub$cols)) {
|
if (any(colours_SIR %in% cols_sub$cols)) {
|
||||||
vals <- c(
|
vals <- c(
|
||||||
"(S) Susceptible" = colours_SIR[1],
|
"(S) Susceptible" = colours_SIR[1],
|
||||||
@@ -883,7 +915,7 @@ autoplot.disk <- function(object,
|
|||||||
p <- p +
|
p <- p +
|
||||||
ggplot2::geom_col(ggplot2::aes(x = disk, y = count))
|
ggplot2::geom_col(ggplot2::aes(x = disk, y = count))
|
||||||
}
|
}
|
||||||
|
|
||||||
p +
|
p +
|
||||||
ggplot2::labs(title = title, x = xlab, y = ylab, subtitle = cols_sub$sub)
|
ggplot2::labs(title = title, x = xlab, y = ylab, subtitle = cols_sub$sub)
|
||||||
}
|
}
|
||||||
@@ -911,11 +943,11 @@ plot.sir <- function(x,
|
|||||||
meet_criteria(ylab, allow_class = "character", has_length = 1)
|
meet_criteria(ylab, allow_class = "character", has_length = 1)
|
||||||
meet_criteria(xlab, allow_class = "character", has_length = 1)
|
meet_criteria(xlab, allow_class = "character", has_length = 1)
|
||||||
meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||||
|
|
||||||
data <- as.data.frame(table(x), stringsAsFactors = FALSE)
|
data <- as.data.frame(table(x), stringsAsFactors = FALSE)
|
||||||
colnames(data) <- c("x", "n")
|
colnames(data) <- c("x", "n")
|
||||||
data$s <- round((data$n / sum(data$n)) * 100, 1)
|
data$s <- round((data$n / sum(data$n)) * 100, 1)
|
||||||
|
|
||||||
if (!"S" %in% data$x) {
|
if (!"S" %in% data$x) {
|
||||||
data <- rbind_AMR(data, data.frame(x = "S", n = 0, s = 0, stringsAsFactors = FALSE))
|
data <- rbind_AMR(data, data.frame(x = "S", n = 0, s = 0, stringsAsFactors = FALSE))
|
||||||
}
|
}
|
||||||
@@ -931,12 +963,12 @@ plot.sir <- function(x,
|
|||||||
if (!"NI" %in% data$x) {
|
if (!"NI" %in% data$x) {
|
||||||
data <- rbind_AMR(data, data.frame(x = "NI", n = 0, s = 0, stringsAsFactors = FALSE))
|
data <- rbind_AMR(data, data.frame(x = "NI", n = 0, s = 0, stringsAsFactors = FALSE))
|
||||||
}
|
}
|
||||||
|
|
||||||
data <- data[!(data$n == 0 & data$x %in% c("SDD", "I", "NI")), , drop = FALSE]
|
data <- data[!(data$n == 0 & data$x %in% c("SDD", "I", "NI")), , drop = FALSE]
|
||||||
data$x <- factor(data$x, levels = intersect(unique(data$x), c("S", "SDD", "I", "R", "NI")), ordered = TRUE)
|
data$x <- factor(data$x, levels = intersect(unique(data$x), c("S", "SDD", "I", "R", "NI")), ordered = TRUE)
|
||||||
|
|
||||||
ymax <- pm_if_else(max(data$s) > 95, 105, 100)
|
ymax <- pm_if_else(max(data$s) > 95, 105, 100)
|
||||||
|
|
||||||
plot(
|
plot(
|
||||||
x = data$x,
|
x = data$x,
|
||||||
y = data$s,
|
y = data$s,
|
||||||
@@ -951,7 +983,7 @@ plot.sir <- function(x,
|
|||||||
axis(side = 1, at = 1:pm_n_distinct(data$x), labels = levels(data$x), lwd = 0)
|
axis(side = 1, at = 1:pm_n_distinct(data$x), labels = levels(data$x), lwd = 0)
|
||||||
# y axis, 0-100%
|
# y axis, 0-100%
|
||||||
axis(side = 2, at = seq(0, 100, 5))
|
axis(side = 2, at = seq(0, 100, 5))
|
||||||
|
|
||||||
text(
|
text(
|
||||||
x = data$x,
|
x = data$x,
|
||||||
y = data$s + 4,
|
y = data$s + 4,
|
||||||
@@ -978,25 +1010,25 @@ barplot.sir <- function(height,
|
|||||||
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
|
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
|
||||||
language <- validate_language(language)
|
language <- validate_language(language)
|
||||||
meet_criteria(expand, allow_class = "logical", has_length = 1)
|
meet_criteria(expand, allow_class = "logical", has_length = 1)
|
||||||
|
|
||||||
if (length(colours_SIR) == 1) {
|
if (length(colours_SIR) == 1) {
|
||||||
colours_SIR <- rep(colours_SIR, 3)
|
colours_SIR <- rep(colours_SIR, 3)
|
||||||
}
|
}
|
||||||
# add SDD and N to colours
|
# add SDD and N to colours
|
||||||
colours_SIR <- c(colours_SIR[1:2], colours_SIR[2], colours_SIR[3], "#888888")
|
colours_SIR <- c(colours_SIR[1:2], colours_SIR[2], colours_SIR[3], "#888888")
|
||||||
main <- gsub(" +", " ", paste0(main, collapse = " "))
|
main <- gsub(" +", " ", paste0(main, collapse = " "))
|
||||||
|
|
||||||
x <- table(height)
|
x <- table(height)
|
||||||
# remove missing I, SDD, and N
|
# remove missing I, SDD, and N
|
||||||
colours_SIR <- colours_SIR[!(names(x) %in% c("SDD", "I", "NI") & x == 0)]
|
colours_SIR <- colours_SIR[!(names(x) %in% c("SDD", "I", "NI") & x == 0)]
|
||||||
x <- x[!(names(x) %in% c("SDD", "I", "NI") & x == 0)]
|
x <- x[!(names(x) %in% c("SDD", "I", "NI") & x == 0)]
|
||||||
# plot it
|
# plot it
|
||||||
barplot(x,
|
barplot(x,
|
||||||
col = colours_SIR,
|
col = colours_SIR,
|
||||||
xlab = xlab,
|
xlab = xlab,
|
||||||
main = main,
|
main = main,
|
||||||
ylab = ylab,
|
ylab = ylab,
|
||||||
axes = FALSE
|
axes = FALSE
|
||||||
)
|
)
|
||||||
axis(2, seq(0, max(x)))
|
axis(2, seq(0, max(x)))
|
||||||
}
|
}
|
||||||
@@ -1016,18 +1048,18 @@ autoplot.sir <- function(object,
|
|||||||
meet_criteria(ylab, allow_class = "character", has_length = 1)
|
meet_criteria(ylab, allow_class = "character", has_length = 1)
|
||||||
meet_criteria(xlab, allow_class = "character", has_length = 1)
|
meet_criteria(xlab, allow_class = "character", has_length = 1)
|
||||||
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
|
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
|
||||||
|
|
||||||
if ("main" %in% names(list(...))) {
|
if ("main" %in% names(list(...))) {
|
||||||
title <- list(...)$main
|
title <- list(...)$main
|
||||||
}
|
}
|
||||||
if (!is.null(title)) {
|
if (!is.null(title)) {
|
||||||
title <- gsub(" +", " ", paste0(title, collapse = " "))
|
title <- gsub(" +", " ", paste0(title, collapse = " "))
|
||||||
}
|
}
|
||||||
|
|
||||||
if (length(colours_SIR) == 1) {
|
if (length(colours_SIR) == 1) {
|
||||||
colours_SIR <- rep(colours_SIR, 3)
|
colours_SIR <- rep(colours_SIR, 3)
|
||||||
}
|
}
|
||||||
|
|
||||||
df <- as.data.frame(table(object), stringsAsFactors = TRUE)
|
df <- as.data.frame(table(object), stringsAsFactors = TRUE)
|
||||||
colnames(df) <- c("x", "n")
|
colnames(df) <- c("x", "n")
|
||||||
df <- df[!(df$n == 0 & df$x %in% c("SDD", "I", "NI")), , drop = FALSE]
|
df <- df[!(df$n == 0 & df$x %in% c("SDD", "I", "NI")), , drop = FALSE]
|
||||||
@@ -1121,21 +1153,21 @@ plot_name_of_I <- function(guideline) {
|
|||||||
|
|
||||||
plot_colours_subtitle_guideline <- function(x, mo, ab, guideline, colours_SIR, fn, language, method, breakpoint_type, include_PKPD, ...) {
|
plot_colours_subtitle_guideline <- function(x, mo, ab, guideline, colours_SIR, fn, language, method, breakpoint_type, include_PKPD, ...) {
|
||||||
stop_if(length(x) == 0, "no observations to plot", call = FALSE)
|
stop_if(length(x) == 0, "no observations to plot", call = FALSE)
|
||||||
|
|
||||||
guideline <- get_guideline(guideline, AMR::clinical_breakpoints)
|
guideline <- get_guideline(guideline, AMR::clinical_breakpoints)
|
||||||
|
|
||||||
# store previous interpretations to backup
|
# store previous interpretations to backup
|
||||||
sir_history <- AMR_env$sir_interpretation_history
|
sir_history <- AMR_env$sir_interpretation_history
|
||||||
# and clear previous interpretations
|
# and clear previous interpretations
|
||||||
AMR_env$sir_interpretation_history <- AMR_env$sir_interpretation_history[0, , drop = FALSE]
|
AMR_env$sir_interpretation_history <- AMR_env$sir_interpretation_history[0, , drop = FALSE]
|
||||||
|
|
||||||
if (!is.null(mo) && !is.null(ab)) {
|
if (!is.null(mo) && !is.null(ab)) {
|
||||||
# interpret and give colour based on MIC values
|
# interpret and give colour based on MIC values
|
||||||
mo <- as.mo(mo)
|
mo <- as.mo(mo)
|
||||||
moname <- mo_name(mo, language = language)
|
moname <- mo_name(mo, language = language)
|
||||||
ab <- as.ab(ab)
|
ab <- as.ab(ab)
|
||||||
abname <- ab_name(ab, language = language)
|
abname <- ab_name(ab, language = language)
|
||||||
|
|
||||||
sir <- suppressWarnings(suppressMessages(as.sir(fn(names(x)), mo = mo, ab = ab, guideline = guideline, include_screening = FALSE, include_PKPD = include_PKPD, breakpoint_type = breakpoint_type, ...)))
|
sir <- suppressWarnings(suppressMessages(as.sir(fn(names(x)), mo = mo, ab = ab, guideline = guideline, include_screening = FALSE, include_PKPD = include_PKPD, breakpoint_type = breakpoint_type, ...)))
|
||||||
guideline_txt <- guideline
|
guideline_txt <- guideline
|
||||||
if (all(is.na(sir))) {
|
if (all(is.na(sir))) {
|
||||||
@@ -1173,10 +1205,10 @@ plot_colours_subtitle_guideline <- function(x, mo, ab, guideline, colours_SIR, f
|
|||||||
cols <- "#BEBEBE"
|
cols <- "#BEBEBE"
|
||||||
sub <- NULL
|
sub <- NULL
|
||||||
}
|
}
|
||||||
|
|
||||||
# restore previous interpretations to backup
|
# restore previous interpretations to backup
|
||||||
AMR_env$sir_interpretation_history <- sir_history
|
AMR_env$sir_interpretation_history <- sir_history
|
||||||
|
|
||||||
list(cols = cols, count = as.double(x), sub = sub, guideline = guideline)
|
list(cols = cols, count = as.double(x), sub = sub, guideline = guideline)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -1187,7 +1219,7 @@ facet_sir <- function(facet = c("interpretation", "antibiotic"), nrow = NULL) {
|
|||||||
stop_ifnot_installed("ggplot2")
|
stop_ifnot_installed("ggplot2")
|
||||||
meet_criteria(facet, allow_class = "character", has_length = 1)
|
meet_criteria(facet, allow_class = "character", has_length = 1)
|
||||||
meet_criteria(nrow, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE, is_positive = TRUE, is_finite = TRUE)
|
meet_criteria(nrow, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE, is_positive = TRUE, is_finite = TRUE)
|
||||||
|
|
||||||
facet_deparse <- deparse(substitute(facet))
|
facet_deparse <- deparse(substitute(facet))
|
||||||
if (facet_deparse != "facet") {
|
if (facet_deparse != "facet") {
|
||||||
facet <- facet_deparse
|
facet <- facet_deparse
|
||||||
@@ -1195,13 +1227,13 @@ facet_sir <- function(facet = c("interpretation", "antibiotic"), nrow = NULL) {
|
|||||||
if (facet %like% '".*"') {
|
if (facet %like% '".*"') {
|
||||||
facet <- substr(facet, 2, nchar(facet) - 1)
|
facet <- substr(facet, 2, nchar(facet) - 1)
|
||||||
}
|
}
|
||||||
|
|
||||||
if (tolower(facet) %in% tolower(c("SIR", "sir", "interpretations", "result"))) {
|
if (tolower(facet) %in% tolower(c("SIR", "sir", "interpretations", "result"))) {
|
||||||
facet <- "interpretation"
|
facet <- "interpretation"
|
||||||
} else if (tolower(facet) %in% tolower(c("ab", "abx", "antibiotics"))) {
|
} else if (tolower(facet) %in% tolower(c("ab", "abx", "antibiotics"))) {
|
||||||
facet <- "antibiotic"
|
facet <- "antibiotic"
|
||||||
}
|
}
|
||||||
|
|
||||||
ggplot2::facet_wrap(facets = facet, scales = "free_x", nrow = nrow)
|
ggplot2::facet_wrap(facets = facet, scales = "free_x", nrow = nrow)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -1211,7 +1243,7 @@ scale_y_percent <- function(breaks = function(x) seq(0, max(x, na.rm = TRUE), 0.
|
|||||||
stop_ifnot_installed("ggplot2")
|
stop_ifnot_installed("ggplot2")
|
||||||
meet_criteria(breaks, allow_class = c("numeric", "integer", "function"))
|
meet_criteria(breaks, allow_class = c("numeric", "integer", "function"))
|
||||||
meet_criteria(limits, allow_class = c("numeric", "integer"), has_length = 2, allow_NULL = TRUE, allow_NA = TRUE)
|
meet_criteria(limits, allow_class = c("numeric", "integer"), has_length = 2, allow_NULL = TRUE, allow_NA = TRUE)
|
||||||
|
|
||||||
if (!is.function(breaks) && all(breaks[breaks != 0] > 1)) {
|
if (!is.function(breaks) && all(breaks[breaks != 0] > 1)) {
|
||||||
breaks <- breaks / 100
|
breaks <- breaks / 100
|
||||||
}
|
}
|
||||||
@@ -1230,14 +1262,14 @@ scale_sir_colours <- function(...,
|
|||||||
stop_ifnot_installed("ggplot2")
|
stop_ifnot_installed("ggplot2")
|
||||||
meet_criteria(aesthetics, allow_class = "character", is_in = c("alpha", "colour", "color", "fill", "linetype", "shape", "size"))
|
meet_criteria(aesthetics, allow_class = "character", is_in = c("alpha", "colour", "color", "fill", "linetype", "shape", "size"))
|
||||||
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
|
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
|
||||||
|
|
||||||
if ("fill" %in% aesthetics && message_not_thrown_before("scale_sir_colours", "fill", entire_session = TRUE)) {
|
if ("fill" %in% aesthetics && message_not_thrown_before("scale_sir_colours", "fill", entire_session = TRUE)) {
|
||||||
warning_("Using `scale_sir_colours()` for the `fill` aesthetic has been superseded by `scale_fill_sir()`, please use that instead. This warning will be shown once per session.")
|
warning_("Using `scale_sir_colours()` for the `fill` aesthetic has been superseded by `scale_fill_sir()`, please use that instead. This warning will be shown once per session.")
|
||||||
}
|
}
|
||||||
if (any(c("colour", "color") %in% aesthetics) && message_not_thrown_before("scale_sir_colours", "colour", entire_session = TRUE)) {
|
if (any(c("colour", "color") %in% aesthetics) && message_not_thrown_before("scale_sir_colours", "colour", entire_session = TRUE)) {
|
||||||
warning_("Using `scale_sir_colours()` for the `colour` aesthetic has been superseded by `scale_colour_sir()`, please use that instead. This warning will be shown once per session.")
|
warning_("Using `scale_sir_colours()` for the `colour` aesthetic has been superseded by `scale_colour_sir()`, please use that instead. This warning will be shown once per session.")
|
||||||
}
|
}
|
||||||
|
|
||||||
if (length(colours_SIR) == 1) {
|
if (length(colours_SIR) == 1) {
|
||||||
colours_SIR <- rep(colours_SIR, 3)
|
colours_SIR <- rep(colours_SIR, 3)
|
||||||
}
|
}
|
||||||
@@ -1258,41 +1290,41 @@ scale_sir_colours <- function(...,
|
|||||||
if (identical(unlist(list(...)), FALSE)) {
|
if (identical(unlist(list(...)), FALSE)) {
|
||||||
return(invisible())
|
return(invisible())
|
||||||
}
|
}
|
||||||
|
|
||||||
names_susceptible <- c(
|
names_susceptible <- c(
|
||||||
"S", "SI", "IS", "S+I", "I+S", "susceptible", "Susceptible",
|
"S", "SI", "IS", "S+I", "I+S", "susceptible", "Susceptible",
|
||||||
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Susceptible"),
|
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Susceptible"),
|
||||||
"replacement",
|
"replacement",
|
||||||
drop = TRUE
|
drop = TRUE
|
||||||
])
|
])
|
||||||
)
|
)
|
||||||
names_incr_exposure <- c(
|
names_incr_exposure <- c(
|
||||||
"I", "intermediate", "increased exposure", "incr. exposure",
|
"I", "intermediate", "increased exposure", "incr. exposure",
|
||||||
"Increased exposure", "Incr. exposure", "Susceptible, incr. exp.",
|
"Increased exposure", "Incr. exposure", "Susceptible, incr. exp.",
|
||||||
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Intermediate"),
|
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Intermediate"),
|
||||||
"replacement",
|
"replacement",
|
||||||
drop = TRUE
|
drop = TRUE
|
||||||
]),
|
]),
|
||||||
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Susceptible, incr. exp."),
|
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Susceptible, incr. exp."),
|
||||||
"replacement",
|
"replacement",
|
||||||
drop = TRUE
|
drop = TRUE
|
||||||
])
|
])
|
||||||
)
|
)
|
||||||
names_resistant <- c(
|
names_resistant <- c(
|
||||||
"R", "IR", "RI", "R+I", "I+R", "resistant", "Resistant",
|
"R", "IR", "RI", "R+I", "I+R", "resistant", "Resistant",
|
||||||
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Resistant"),
|
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Resistant"),
|
||||||
"replacement",
|
"replacement",
|
||||||
drop = TRUE
|
drop = TRUE
|
||||||
])
|
])
|
||||||
)
|
)
|
||||||
|
|
||||||
susceptible <- rep(colours_SIR[1], length(names_susceptible))
|
susceptible <- rep(colours_SIR[1], length(names_susceptible))
|
||||||
names(susceptible) <- names_susceptible
|
names(susceptible) <- names_susceptible
|
||||||
incr_exposure <- rep(colours_SIR[2], length(names_incr_exposure))
|
incr_exposure <- rep(colours_SIR[2], length(names_incr_exposure))
|
||||||
names(incr_exposure) <- names_incr_exposure
|
names(incr_exposure) <- names_incr_exposure
|
||||||
resistant <- rep(colours_SIR[3], length(names_resistant))
|
resistant <- rep(colours_SIR[3], length(names_resistant))
|
||||||
names(resistant) <- names_resistant
|
names(resistant) <- names_resistant
|
||||||
|
|
||||||
original_cols <- c(susceptible, incr_exposure, resistant)
|
original_cols <- c(susceptible, incr_exposure, resistant)
|
||||||
dots <- c(...)
|
dots <- c(...)
|
||||||
# replace S, I, R as colours: scale_sir_colours(mydatavalue = "S")
|
# replace S, I, R as colours: scale_sir_colours(mydatavalue = "S")
|
||||||
@@ -1344,14 +1376,14 @@ labels_sir_count <- function(position = NULL,
|
|||||||
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
|
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
|
||||||
meet_criteria(datalabels.size, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
|
meet_criteria(datalabels.size, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
|
||||||
meet_criteria(datalabels.colour, allow_class = "character", has_length = 1)
|
meet_criteria(datalabels.colour, allow_class = "character", has_length = 1)
|
||||||
|
|
||||||
if (is.null(position)) {
|
if (is.null(position)) {
|
||||||
position <- "fill"
|
position <- "fill"
|
||||||
}
|
}
|
||||||
if (identical(position, "fill")) {
|
if (identical(position, "fill")) {
|
||||||
position <- ggplot2::position_fill(vjust = 0.5, reverse = TRUE)
|
position <- ggplot2::position_fill(vjust = 0.5, reverse = TRUE)
|
||||||
}
|
}
|
||||||
|
|
||||||
x_name <- x
|
x_name <- x
|
||||||
ggplot2::geom_text(
|
ggplot2::geom_text(
|
||||||
mapping = utils::modifyList(ggplot2::aes(), list(label = str2lang("lbl"), x = str2lang(x), y = str2lang("value"))),
|
mapping = utils::modifyList(ggplot2::aes(), list(label = str2lang("lbl"), x = str2lang(x), y = str2lang("value"))),
|
||||||
|
|||||||
@@ -47,9 +47,9 @@
|
|||||||
#' @inheritSection as.sir Interpretation of SIR
|
#' @inheritSection as.sir Interpretation of SIR
|
||||||
#' @details
|
#' @details
|
||||||
#' For a more automated and comprehensive analysis, consider using [antibiogram()] or [wisca()], which streamline many aspects of susceptibility reporting and, importantly, also support WISCA. The functions described here offer a more hands-on, manual approach for greater customisation.
|
#' For a more automated and comprehensive analysis, consider using [antibiogram()] or [wisca()], which streamline many aspects of susceptibility reporting and, importantly, also support WISCA. The functions described here offer a more hands-on, manual approach for greater customisation.
|
||||||
#'
|
#'
|
||||||
#' **Remember that you should filter your data to let it contain only first isolates!** This is needed to exclude duplicates and to reduce selection bias. Use [first_isolate()] to determine them in your data set with one of the four available algorithms.
|
#' **Remember that you should filter your data to let it contain only first isolates!** This is needed to exclude duplicates and to reduce selection bias. Use [first_isolate()] to determine them in your data set with one of the four available algorithms.
|
||||||
#'
|
#'
|
||||||
#' The function [resistance()] is equal to the function [proportion_R()]. The function [susceptibility()] is equal to the function [proportion_SI()]. Since AMR v3.0, [proportion_SI()] and [proportion_I()] include dose-dependent susceptibility ('SDD').
|
#' The function [resistance()] is equal to the function [proportion_R()]. The function [susceptibility()] is equal to the function [proportion_SI()]. Since AMR v3.0, [proportion_SI()] and [proportion_I()] include dose-dependent susceptibility ('SDD').
|
||||||
#'
|
#'
|
||||||
#' Use [sir_confidence_interval()] to calculate the confidence interval, which relies on [binom.test()], i.e., the Clopper-Pearson method. This function returns a vector of length 2 at default for antimicrobial *resistance*. Change the `side` argument to "left"/"min" or "right"/"max" to return a single value, and change the `ab_result` argument to e.g. `c("S", "I")` to test for antimicrobial *susceptibility*, see Examples.
|
#' Use [sir_confidence_interval()] to calculate the confidence interval, which relies on [binom.test()], i.e., the Clopper-Pearson method. This function returns a vector of length 2 at default for antimicrobial *resistance*. Change the `side` argument to "left"/"min" or "right"/"max" to return a single value, and change the `ab_result` argument to e.g. `c("S", "I")` to test for antimicrobial *susceptibility*, see Examples.
|
||||||
@@ -293,7 +293,7 @@ sir_confidence_interval <- function(...,
|
|||||||
),
|
),
|
||||||
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
|
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
|
||||||
)
|
)
|
||||||
|
|
||||||
if (x == 0) {
|
if (x == 0) {
|
||||||
out <- c(0, 0)
|
out <- c(0, 0)
|
||||||
} else {
|
} else {
|
||||||
@@ -301,7 +301,7 @@ sir_confidence_interval <- function(...,
|
|||||||
out <- stats::binom.test(x = x, n = n, conf.level = confidence_level)$conf.int
|
out <- stats::binom.test(x = x, n = n, conf.level = confidence_level)$conf.int
|
||||||
}
|
}
|
||||||
out <- set_clean_class(out, "numeric")
|
out <- set_clean_class(out, "numeric")
|
||||||
|
|
||||||
if (side %in% c("left", "l", "lower", "lowest", "less", "min")) {
|
if (side %in% c("left", "l", "lower", "lowest", "less", "min")) {
|
||||||
out <- out[1]
|
out <- out[1]
|
||||||
} else if (side %in% c("right", "r", "higher", "highest", "greater", "g", "max")) {
|
} else if (side %in% c("right", "r", "higher", "highest", "greater", "g", "max")) {
|
||||||
@@ -317,7 +317,7 @@ sir_confidence_interval <- function(...,
|
|||||||
# out[is.na(out)] <- 0
|
# out[is.na(out)] <- 0
|
||||||
out <- paste(out, collapse = ifelse(isTRUE(collapse), "-", collapse))
|
out <- paste(out, collapse = ifelse(isTRUE(collapse), "-", collapse))
|
||||||
}
|
}
|
||||||
|
|
||||||
if (n < minimum) {
|
if (n < minimum) {
|
||||||
warning_("Introducing NA: ",
|
warning_("Introducing NA: ",
|
||||||
ifelse(n == 0, "no", paste("only", n)),
|
ifelse(n == 0, "no", paste("only", n)),
|
||||||
|
|||||||
@@ -97,7 +97,7 @@ random_exec <- function(method_type, size, mo = NULL, ab = NULL) {
|
|||||||
subset(guideline == max(guideline) &
|
subset(guideline == max(guideline) &
|
||||||
method == method_type &
|
method == method_type &
|
||||||
type == "human")
|
type == "human")
|
||||||
|
|
||||||
if (!is.null(mo)) {
|
if (!is.null(mo)) {
|
||||||
mo_coerced <- as.mo(mo)
|
mo_coerced <- as.mo(mo)
|
||||||
mo_include <- c(
|
mo_include <- c(
|
||||||
|
|||||||
311
R/sir.R
311
R/sir.R
@@ -30,12 +30,12 @@
|
|||||||
#' Translate MIC and Disk Diffusion to SIR, or Clean Existing SIR Data
|
#' Translate MIC and Disk Diffusion to SIR, or Clean Existing SIR Data
|
||||||
#'
|
#'
|
||||||
#' @description Clean up existing SIR values, or interpret minimum inhibitory concentration (MIC) values and disk diffusion diameters according to EUCAST or CLSI. [as.sir()] transforms the input to a new class [`sir`], which is an ordered [factor] containing the levels `S`, `SDD`, `I`, `R`, `NI`.
|
#' @description Clean up existing SIR values, or interpret minimum inhibitory concentration (MIC) values and disk diffusion diameters according to EUCAST or CLSI. [as.sir()] transforms the input to a new class [`sir`], which is an ordered [factor] containing the levels `S`, `SDD`, `I`, `R`, `NI`.
|
||||||
#'
|
#'
|
||||||
#' These breakpoints are currently implemented:
|
#' These breakpoints are currently implemented:
|
||||||
#' - For **clinical microbiology**: EUCAST `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "human")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "human")$guideline)))` and CLSI `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "human")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "human")$guideline)))`;
|
#' - For **clinical microbiology**: EUCAST `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "human")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "human")$guideline)))` and CLSI `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "human")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "human")$guideline)))`;
|
||||||
#' - For **veterinary microbiology**: EUCAST `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "animal")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "animal")$guideline)))` and CLSI `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "animal")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "animal")$guideline)))`;
|
#' - For **veterinary microbiology**: EUCAST `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "animal")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "animal")$guideline)))` and CLSI `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "animal")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "animal")$guideline)))`;
|
||||||
#' - For **ECOFFs** (Epidemiological Cut-off Values): EUCAST `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "ECOFF")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "ECOFF")$guideline)))` and CLSI `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "ECOFF")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "ECOFF")$guideline)))`.
|
#' - For **ECOFFs** (Epidemiological Cut-off Values): EUCAST `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "ECOFF")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "ECOFF")$guideline)))` and CLSI `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "ECOFF")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "ECOFF")$guideline)))`.
|
||||||
#'
|
#'
|
||||||
#' All breakpoints used for interpretation are available in our [clinical_breakpoints] data set.
|
#' All breakpoints used for interpretation are available in our [clinical_breakpoints] data set.
|
||||||
#' @rdname as.sir
|
#' @rdname as.sir
|
||||||
#' @param x vector of values (for class [`mic`]: MIC values in mg/L, for class [`disk`]: a disk diffusion radius in millimetres)
|
#' @param x vector of values (for class [`mic`]: MIC values in mg/L, for class [`disk`]: a disk diffusion radius in millimetres)
|
||||||
@@ -56,7 +56,7 @@
|
|||||||
#' @param ... for using on a [data.frame]: names of columns to apply [as.sir()] on (supports tidy selection such as `column1:column4`). Otherwise: arguments passed on to methods.
|
#' @param ... for using on a [data.frame]: names of columns to apply [as.sir()] on (supports tidy selection such as `column1:column4`). Otherwise: arguments passed on to methods.
|
||||||
#' @details
|
#' @details
|
||||||
#' *Note: The clinical breakpoints in this package were validated through, and imported from, [WHONET](https://whonet.org). The public use of this `AMR` package has been endorsed by both CLSI and EUCAST. See [clinical_breakpoints] for more information.*
|
#' *Note: The clinical breakpoints in this package were validated through, and imported from, [WHONET](https://whonet.org). The public use of this `AMR` package has been endorsed by both CLSI and EUCAST. See [clinical_breakpoints] for more information.*
|
||||||
#'
|
#'
|
||||||
#' ### How it Works
|
#' ### How it Works
|
||||||
#'
|
#'
|
||||||
#' The [as.sir()] function can work in four ways:
|
#' The [as.sir()] function can work in four ways:
|
||||||
@@ -70,7 +70,7 @@
|
|||||||
#' your_data %>% mutate(across(where(is.mic), as.sir))
|
#' your_data %>% mutate(across(where(is.mic), as.sir))
|
||||||
#' your_data %>% mutate_if(is.mic, as.sir, ab = "column_with_antibiotics", mo = "column_with_microorganisms")
|
#' your_data %>% mutate_if(is.mic, as.sir, ab = "column_with_antibiotics", mo = "column_with_microorganisms")
|
||||||
#' your_data %>% mutate_if(is.mic, as.sir, ab = c("cipro", "ampicillin", ...), mo = c("E. coli", "K. pneumoniae", ...))
|
#' your_data %>% mutate_if(is.mic, as.sir, ab = c("cipro", "ampicillin", ...), mo = c("E. coli", "K. pneumoniae", ...))
|
||||||
#'
|
#'
|
||||||
#' # for veterinary breakpoints, also set `host`:
|
#' # for veterinary breakpoints, also set `host`:
|
||||||
#' your_data %>% mutate_if(is.mic, as.sir, host = "column_with_animal_species", guideline = "CLSI")
|
#' your_data %>% mutate_if(is.mic, as.sir, host = "column_with_animal_species", guideline = "CLSI")
|
||||||
#' ```
|
#' ```
|
||||||
@@ -82,7 +82,7 @@
|
|||||||
#' your_data %>% mutate(across(where(is.disk), as.sir))
|
#' your_data %>% mutate(across(where(is.disk), as.sir))
|
||||||
#' your_data %>% mutate_if(is.disk, as.sir, ab = "column_with_antibiotics", mo = "column_with_microorganisms")
|
#' your_data %>% mutate_if(is.disk, as.sir, ab = "column_with_antibiotics", mo = "column_with_microorganisms")
|
||||||
#' your_data %>% mutate_if(is.disk, as.sir, ab = c("cipro", "ampicillin", ...), mo = c("E. coli", "K. pneumoniae", ...))
|
#' your_data %>% mutate_if(is.disk, as.sir, ab = c("cipro", "ampicillin", ...), mo = c("E. coli", "K. pneumoniae", ...))
|
||||||
#'
|
#'
|
||||||
#' # for veterinary breakpoints, also set `host`:
|
#' # for veterinary breakpoints, also set `host`:
|
||||||
#' your_data %>% mutate_if(is.disk, as.sir, host = "column_with_animal_species", guideline = "CLSI")
|
#' your_data %>% mutate_if(is.disk, as.sir, host = "column_with_animal_species", guideline = "CLSI")
|
||||||
#' ```
|
#' ```
|
||||||
@@ -105,20 +105,20 @@
|
|||||||
#' # or to reset:
|
#' # or to reset:
|
||||||
#' options(AMR_guideline = NULL)
|
#' options(AMR_guideline = NULL)
|
||||||
#' ```
|
#' ```
|
||||||
#'
|
#'
|
||||||
#' For veterinary guidelines, these might be the best options:
|
#' For veterinary guidelines, these might be the best options:
|
||||||
#'
|
#'
|
||||||
#' ```
|
#' ```
|
||||||
#' options(AMR_guideline = "CLSI")
|
#' options(AMR_guideline = "CLSI")
|
||||||
#' options(AMR_breakpoint_type = "animal")
|
#' options(AMR_breakpoint_type = "animal")
|
||||||
#' ```
|
#' ```
|
||||||
#'
|
#'
|
||||||
#' When applying veterinary breakpoints (by setting `host` or by setting `breakpoint_type = "animal"`), the [CLSI VET09 guideline](https://clsi.org/standards/products/veterinary-medicine/documents/vet09/) will be applied to cope with missing animal species-specific breakpoints.
|
#' When applying veterinary breakpoints (by setting `host` or by setting `breakpoint_type = "animal"`), the [CLSI VET09 guideline](https://clsi.org/standards/products/veterinary-medicine/documents/vet09/) will be applied to cope with missing animal species-specific breakpoints.
|
||||||
#'
|
#'
|
||||||
#' ### After Interpretation
|
#' ### After Interpretation
|
||||||
#'
|
#'
|
||||||
#' After using [as.sir()], you can use the [eucast_rules()] defined by EUCAST to (1) apply inferred susceptibility and resistance based on results of other antimicrobials and (2) apply intrinsic resistance based on taxonomic properties of a microorganism.
|
#' After using [as.sir()], you can use the [eucast_rules()] defined by EUCAST to (1) apply inferred susceptibility and resistance based on results of other antimicrobials and (2) apply intrinsic resistance based on taxonomic properties of a microorganism.
|
||||||
#'
|
#'
|
||||||
#' To determine which isolates are multi-drug resistant, be sure to run [mdro()] (which applies the MDR/PDR/XDR guideline from 2012 at default) on a data set that contains S/I/R values. Read more about [interpreting multidrug-resistant organisms here][mdro()].
|
#' To determine which isolates are multi-drug resistant, be sure to run [mdro()] (which applies the MDR/PDR/XDR guideline from 2012 at default) on a data set that contains S/I/R values. Read more about [interpreting multidrug-resistant organisms here][mdro()].
|
||||||
#'
|
#'
|
||||||
#' ### Machine-Readable Clinical Breakpoints
|
#' ### Machine-Readable Clinical Breakpoints
|
||||||
@@ -128,7 +128,7 @@
|
|||||||
#' ### Other
|
#' ### Other
|
||||||
#'
|
#'
|
||||||
#' The function [is.sir()] detects if the input contains class `sir`. If the input is a [data.frame], it iterates over all columns and returns a [logical] vector.
|
#' The function [is.sir()] detects if the input contains class `sir`. If the input is a [data.frame], it iterates over all columns and returns a [logical] vector.
|
||||||
#'
|
#'
|
||||||
#' The base R function [as.double()] can be used to retrieve quantitative values from a `sir` object: `"S"` = 1, `"I"`/`"SDD"` = 2, `"R"` = 3. All other values are rendered `NA` . **Note:** Do not use `as.integer()`, since that (because of how R works internally) will return the factor level indices, and not these aforementioned quantitative values.
|
#' The base R function [as.double()] can be used to retrieve quantitative values from a `sir` object: `"S"` = 1, `"I"`/`"SDD"` = 2, `"R"` = 3. All other values are rendered `NA` . **Note:** Do not use `as.integer()`, since that (because of how R works internally) will return the factor level indices, and not these aforementioned quantitative values.
|
||||||
#'
|
#'
|
||||||
#' The function [is_sir_eligible()] returns `TRUE` when a column contains at most 5% invalid antimicrobial interpretations (not S and/or I and/or R and/or NI and/or SDD), and `FALSE` otherwise. The threshold of 5% can be set with the `threshold` argument. If the input is a [data.frame], it iterates over all columns and returns a [logical] vector.
|
#' The function [is_sir_eligible()] returns `TRUE` when a column contains at most 5% invalid antimicrobial interpretations (not S and/or I and/or R and/or NI and/or SDD), and `FALSE` otherwise. The threshold of 5% can be set with the `threshold` argument. If the input is a [data.frame], it iterates over all columns and returns a [logical] vector.
|
||||||
@@ -158,14 +158,14 @@
|
|||||||
#' - **CLSI VET09: Understanding Susceptibility Test Data as a Component of Antimicrobial Stewardship in Veterinary Settings**, `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "animal")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "animal")$guideline)))`, *Clinical and Laboratory Standards Institute* (CLSI). <https://clsi.org/standards/products/veterinary-medicine/documents/vet09/>.
|
#' - **CLSI VET09: Understanding Susceptibility Test Data as a Component of Antimicrobial Stewardship in Veterinary Settings**, `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "animal")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "animal")$guideline)))`, *Clinical and Laboratory Standards Institute* (CLSI). <https://clsi.org/standards/products/veterinary-medicine/documents/vet09/>.
|
||||||
#' - **EUCAST Breakpoint tables for interpretation of MICs and zone diameters**, `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`, *European Committee on Antimicrobial Susceptibility Testing* (EUCAST). <https://www.eucast.org/clinical_breakpoints>.
|
#' - **EUCAST Breakpoint tables for interpretation of MICs and zone diameters**, `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`, *European Committee on Antimicrobial Susceptibility Testing* (EUCAST). <https://www.eucast.org/clinical_breakpoints>.
|
||||||
#' - **WHONET** as a source for machine-reading the clinical breakpoints ([read more here](https://msberends.github.io/AMR/reference/clinical_breakpoints.html#imported-from-whonet)), 1989-`r max(as.integer(gsub("[^0-9]", "", AMR::clinical_breakpoints$guideline)))`, *WHO Collaborating Centre for Surveillance of Antimicrobial Resistance*. <https://whonet.org/>.
|
#' - **WHONET** as a source for machine-reading the clinical breakpoints ([read more here](https://msberends.github.io/AMR/reference/clinical_breakpoints.html#imported-from-whonet)), 1989-`r max(as.integer(gsub("[^0-9]", "", AMR::clinical_breakpoints$guideline)))`, *WHO Collaborating Centre for Surveillance of Antimicrobial Resistance*. <https://whonet.org/>.
|
||||||
#'
|
#'
|
||||||
#' @inheritSection AMR Reference Data Publicly Available
|
#' @inheritSection AMR Reference Data Publicly Available
|
||||||
#' @examples
|
#' @examples
|
||||||
#' example_isolates
|
#' example_isolates
|
||||||
#' summary(example_isolates) # see all SIR results at a glance
|
#' summary(example_isolates) # see all SIR results at a glance
|
||||||
#'
|
#'
|
||||||
#' # For INTERPRETING disk diffusion and MIC values -----------------------
|
#' # For INTERPRETING disk diffusion and MIC values -----------------------
|
||||||
#'
|
#'
|
||||||
#' # example data sets, with combined MIC values and disk zones
|
#' # example data sets, with combined MIC values and disk zones
|
||||||
#' df_wide <- data.frame(
|
#' df_wide <- data.frame(
|
||||||
#' microorganism = "Escherichia coli",
|
#' microorganism = "Escherichia coli",
|
||||||
@@ -191,69 +191,97 @@
|
|||||||
#' df_wide %>% mutate(across(where(is.mic), as.sir))
|
#' df_wide %>% mutate(across(where(is.mic), as.sir))
|
||||||
#' df_wide %>% mutate_at(vars(amoxicillin:tobra), as.sir)
|
#' df_wide %>% mutate_at(vars(amoxicillin:tobra), as.sir)
|
||||||
#' df_wide %>% mutate(across(amoxicillin:tobra, as.sir))
|
#' df_wide %>% mutate(across(amoxicillin:tobra, as.sir))
|
||||||
#'
|
#'
|
||||||
#' # approaches that all work with additional arguments:
|
#' # approaches that all work with additional arguments:
|
||||||
#' df_long %>%
|
#' df_long %>%
|
||||||
#' # given a certain data type, e.g. MIC values
|
#' # given a certain data type, e.g. MIC values
|
||||||
#' mutate_if(is.mic, as.sir,
|
#' mutate_if(is.mic, as.sir,
|
||||||
#' mo = "bacteria",
|
#' mo = "bacteria",
|
||||||
#' ab = "antibiotic",
|
#' ab = "antibiotic",
|
||||||
#' guideline = "CLSI")
|
#' guideline = "CLSI"
|
||||||
|
#' )
|
||||||
#' df_long %>%
|
#' df_long %>%
|
||||||
#' mutate(across(where(is.mic),
|
#' mutate(across(
|
||||||
#' function(x) as.sir(x,
|
#' where(is.mic),
|
||||||
#' mo = "bacteria",
|
#' function(x) {
|
||||||
#' ab = "antibiotic",
|
#' as.sir(x,
|
||||||
#' guideline = "CLSI")))
|
#' mo = "bacteria",
|
||||||
|
#' ab = "antibiotic",
|
||||||
|
#' guideline = "CLSI"
|
||||||
|
#' )
|
||||||
|
#' }
|
||||||
|
#' ))
|
||||||
#' df_wide %>%
|
#' df_wide %>%
|
||||||
#' # given certain columns, e.g. from 'cipro' to 'genta'
|
#' # given certain columns, e.g. from 'cipro' to 'genta'
|
||||||
#' mutate_at(vars(cipro:genta), as.sir,
|
#' mutate_at(vars(cipro:genta), as.sir,
|
||||||
#' mo = "bacteria",
|
#' mo = "bacteria",
|
||||||
#' guideline = "CLSI")
|
#' guideline = "CLSI"
|
||||||
|
#' )
|
||||||
#' df_wide %>%
|
#' df_wide %>%
|
||||||
#' mutate(across(cipro:genta,
|
#' mutate(across(
|
||||||
#' function(x) as.sir(x,
|
#' cipro:genta,
|
||||||
#' mo = "bacteria",
|
#' function(x) {
|
||||||
#' guideline = "CLSI")))
|
#' as.sir(x,
|
||||||
#'
|
#' mo = "bacteria",
|
||||||
|
#' guideline = "CLSI"
|
||||||
|
#' )
|
||||||
|
#' }
|
||||||
|
#' ))
|
||||||
|
#'
|
||||||
#' # for veterinary breakpoints, add 'host':
|
#' # for veterinary breakpoints, add 'host':
|
||||||
#' df_long$animal_species <- c("cats", "dogs", "horses", "cattle")
|
#' df_long$animal_species <- c("cats", "dogs", "horses", "cattle")
|
||||||
#' df_long %>%
|
#' df_long %>%
|
||||||
#' # given a certain data type, e.g. MIC values
|
#' # given a certain data type, e.g. MIC values
|
||||||
#' mutate_if(is.mic, as.sir,
|
#' mutate_if(is.mic, as.sir,
|
||||||
#' mo = "bacteria",
|
#' mo = "bacteria",
|
||||||
#' ab = "antibiotic",
|
#' ab = "antibiotic",
|
||||||
#' host = "animal_species",
|
#' host = "animal_species",
|
||||||
#' guideline = "CLSI")
|
#' guideline = "CLSI"
|
||||||
|
#' )
|
||||||
#' df_long %>%
|
#' df_long %>%
|
||||||
#' mutate(across(where(is.mic),
|
#' mutate(across(
|
||||||
#' function(x) as.sir(x,
|
#' where(is.mic),
|
||||||
#' mo = "bacteria",
|
#' function(x) {
|
||||||
#' ab = "antibiotic",
|
#' as.sir(x,
|
||||||
#' host = "animal_species",
|
#' mo = "bacteria",
|
||||||
#' guideline = "CLSI")))
|
#' ab = "antibiotic",
|
||||||
|
#' host = "animal_species",
|
||||||
|
#' guideline = "CLSI"
|
||||||
|
#' )
|
||||||
|
#' }
|
||||||
|
#' ))
|
||||||
#' df_wide %>%
|
#' df_wide %>%
|
||||||
#' mutate_at(vars(cipro:genta), as.sir,
|
#' mutate_at(vars(cipro:genta), as.sir,
|
||||||
#' mo = "bacteria",
|
#' mo = "bacteria",
|
||||||
#' ab = "antibiotic",
|
#' ab = "antibiotic",
|
||||||
#' host = "animal_species",
|
#' host = "animal_species",
|
||||||
#' guideline = "CLSI")
|
#' guideline = "CLSI"
|
||||||
|
#' )
|
||||||
#' df_wide %>%
|
#' df_wide %>%
|
||||||
#' mutate(across(cipro:genta,
|
#' mutate(across(
|
||||||
#' function(x) as.sir(x,
|
#' cipro:genta,
|
||||||
#' mo = "bacteria",
|
#' function(x) {
|
||||||
#' host = "animal_species",
|
#' as.sir(x,
|
||||||
#' guideline = "CLSI")))
|
#' mo = "bacteria",
|
||||||
#'
|
#' host = "animal_species",
|
||||||
|
#' guideline = "CLSI"
|
||||||
|
#' )
|
||||||
|
#' }
|
||||||
|
#' ))
|
||||||
|
#'
|
||||||
#' # to include information about urinary tract infections (UTI)
|
#' # to include information about urinary tract infections (UTI)
|
||||||
#' data.frame(mo = "E. coli",
|
#' data.frame(
|
||||||
#' nitrofuratoin = c("<= 2", 32),
|
#' mo = "E. coli",
|
||||||
#' from_the_bladder = c(TRUE, FALSE)) %>%
|
#' nitrofuratoin = c("<= 2", 32),
|
||||||
|
#' from_the_bladder = c(TRUE, FALSE)
|
||||||
|
#' ) %>%
|
||||||
#' as.sir(uti = "from_the_bladder")
|
#' as.sir(uti = "from_the_bladder")
|
||||||
#'
|
#'
|
||||||
#' data.frame(mo = "E. coli",
|
#' data.frame(
|
||||||
#' nitrofuratoin = c("<= 2", 32),
|
#' mo = "E. coli",
|
||||||
#' specimen = c("urine", "blood")) %>%
|
#' nitrofuratoin = c("<= 2", 32),
|
||||||
|
#' specimen = c("urine", "blood")
|
||||||
|
#' ) %>%
|
||||||
#' as.sir() # automatically determines urine isolates
|
#' as.sir() # automatically determines urine isolates
|
||||||
#'
|
#'
|
||||||
#' df_wide %>%
|
#' df_wide %>%
|
||||||
@@ -292,12 +320,12 @@
|
|||||||
#' is.sir(sir_data)
|
#' is.sir(sir_data)
|
||||||
#' plot(sir_data) # for percentages
|
#' plot(sir_data) # for percentages
|
||||||
#' barplot(sir_data) # for frequencies
|
#' barplot(sir_data) # for frequencies
|
||||||
#'
|
#'
|
||||||
#' # as common in R, you can use as.integer() to return factor indices:
|
#' # as common in R, you can use as.integer() to return factor indices:
|
||||||
#' as.integer(as.sir(c("S", "SDD", "I", "R", "NI", NA)))
|
#' as.integer(as.sir(c("S", "SDD", "I", "R", "NI", NA)))
|
||||||
#' # but for computational use, as.double() will return 1 for S, 2 for I/SDD, and 3 for R:
|
#' # but for computational use, as.double() will return 1 for S, 2 for I/SDD, and 3 for R:
|
||||||
#' as.double(as.sir(c("S", "SDD", "I", "R", "NI", NA)))
|
#' as.double(as.sir(c("S", "SDD", "I", "R", "NI", NA)))
|
||||||
#'
|
#'
|
||||||
#' # the dplyr way
|
#' # the dplyr way
|
||||||
#' if (require("dplyr")) {
|
#' if (require("dplyr")) {
|
||||||
#' example_isolates %>%
|
#' example_isolates %>%
|
||||||
@@ -326,16 +354,19 @@ as_sir_structure <- function(x,
|
|||||||
method = NULL,
|
method = NULL,
|
||||||
ref_tbl = NULL,
|
ref_tbl = NULL,
|
||||||
ref_breakpoints = NULL) {
|
ref_breakpoints = NULL) {
|
||||||
out <- structure(factor(as.character(unlist(unname(x))),
|
out <- structure(
|
||||||
levels = c("S", "SDD", "I", "R", "NI"),
|
factor(as.character(unlist(unname(x))),
|
||||||
ordered = TRUE),
|
levels = c("S", "SDD", "I", "R", "NI"),
|
||||||
guideline = guideline,
|
ordered = TRUE
|
||||||
mo = mo,
|
),
|
||||||
ab = ab,
|
guideline = guideline,
|
||||||
method = method,
|
mo = mo,
|
||||||
ref_tbl = ref_tbl,
|
ab = ab,
|
||||||
ref_breakpoints = ref_breakpoints,
|
method = method,
|
||||||
class = c("sir", "ordered", "factor"))
|
ref_tbl = ref_tbl,
|
||||||
|
ref_breakpoints = ref_breakpoints,
|
||||||
|
class = c("sir", "ordered", "factor")
|
||||||
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
#' @rdname as.sir
|
#' @rdname as.sir
|
||||||
@@ -633,7 +664,7 @@ as.sir.data.frame <- function(x,
|
|||||||
if (is.null(col_mo)) {
|
if (is.null(col_mo)) {
|
||||||
col_mo <- search_type_in_df(x = x, type = "mo", info = FALSE)
|
col_mo <- search_type_in_df(x = x, type = "mo", info = FALSE)
|
||||||
}
|
}
|
||||||
|
|
||||||
# -- host
|
# -- host
|
||||||
if (missing(breakpoint_type) && any(host %in% clinical_breakpoints$host[!clinical_breakpoints$host %in% c("human", "ECOFF")], na.rm = TRUE)) {
|
if (missing(breakpoint_type) && any(host %in% clinical_breakpoints$host[!clinical_breakpoints$host %in% c("human", "ECOFF")], na.rm = TRUE)) {
|
||||||
message_("Assuming `breakpoint_type = \"animal\"` since `host` contains animal species.")
|
message_("Assuming `breakpoint_type = \"animal\"` since `host` contains animal species.")
|
||||||
@@ -651,7 +682,7 @@ as.sir.data.frame <- function(x,
|
|||||||
} else {
|
} else {
|
||||||
host <- breakpoint_type
|
host <- breakpoint_type
|
||||||
}
|
}
|
||||||
|
|
||||||
# -- UTIs
|
# -- UTIs
|
||||||
col_uti <- uti
|
col_uti <- uti
|
||||||
if (is.null(col_uti)) {
|
if (is.null(col_uti)) {
|
||||||
@@ -861,7 +892,7 @@ convert_host <- function(x, lang = get_AMR_locale()) {
|
|||||||
x_out[is.na(x_out) & (x %like% "horse|equine|Equus ferus" | x %like% translate_AMR("horse|horses|equine", lang))] <- "horse"
|
x_out[is.na(x_out) & (x %like% "horse|equine|Equus ferus" | x %like% translate_AMR("horse|horses|equine", lang))] <- "horse"
|
||||||
x_out[is.na(x_out) & (x %like% "aqua|fish|Pisces" | x %like% translate_AMR("aquatic|fish", lang))] <- "aquatic"
|
x_out[is.na(x_out) & (x %like% "aqua|fish|Pisces" | x %like% translate_AMR("aquatic|fish", lang))] <- "aquatic"
|
||||||
x_out[is.na(x_out) & (x %like% "bird|chicken|poultry|avia|Gallus gallus" | x %like% translate_AMR("bird|birds|poultry", lang))] <- "poultry"
|
x_out[is.na(x_out) & (x %like% "bird|chicken|poultry|avia|Gallus gallus" | x %like% translate_AMR("bird|birds|poultry", lang))] <- "poultry"
|
||||||
|
|
||||||
# additional animals, not necessarily currently in breakpoint guidelines:
|
# additional animals, not necessarily currently in breakpoint guidelines:
|
||||||
x_out[is.na(x_out) & (x %like% "camel|camelid|Camelus dromedarius" | x %like% translate_AMR("camel|camels|camelid", lang))] <- "camels"
|
x_out[is.na(x_out) & (x %like% "camel|camelid|Camelus dromedarius" | x %like% translate_AMR("camel|camels|camelid", lang))] <- "camels"
|
||||||
x_out[is.na(x_out) & (x %like% "deer|cervine|Cervidae" | x %like% translate_AMR("deer|deers|cervine", lang))] <- "deer"
|
x_out[is.na(x_out) & (x %like% "deer|cervine|Cervidae" | x %like% translate_AMR("deer|deers|cervine", lang))] <- "deer"
|
||||||
@@ -878,8 +909,8 @@ convert_host <- function(x, lang = get_AMR_locale()) {
|
|||||||
x_out[is.na(x_out) & (x %like% "sheep|ovine|Ovis aries" | x %like% translate_AMR("sheep|sheeps|ovine", lang))] <- "sheep"
|
x_out[is.na(x_out) & (x %like% "sheep|ovine|Ovis aries" | x %like% translate_AMR("sheep|sheeps|ovine", lang))] <- "sheep"
|
||||||
x_out[is.na(x_out) & (x %like% "snake|serpentine|Serpentes" | x %like% translate_AMR("snake|snakes|serpentine", lang))] <- "snakes"
|
x_out[is.na(x_out) & (x %like% "snake|serpentine|Serpentes" | x %like% translate_AMR("snake|snakes|serpentine", lang))] <- "snakes"
|
||||||
x_out[is.na(x_out) & (x %like% "turkey|meleagrine|Meleagris gallopavo" | x %like% translate_AMR("turkey|turkeys|meleagrine", lang))] <- "turkey"
|
x_out[is.na(x_out) & (x %like% "turkey|meleagrine|Meleagris gallopavo" | x %like% translate_AMR("turkey|turkeys|meleagrine", lang))] <- "turkey"
|
||||||
|
|
||||||
|
|
||||||
x_out[x_out == "ecoff"] <- "ECOFF"
|
x_out[x_out == "ecoff"] <- "ECOFF"
|
||||||
x_out
|
x_out
|
||||||
}
|
}
|
||||||
@@ -914,29 +945,29 @@ as_sir_method <- function(method_short,
|
|||||||
meet_criteria(breakpoint_type, allow_class = "character", is_in = reference_data$type, has_length = 1, .call_depth = -2)
|
meet_criteria(breakpoint_type, allow_class = "character", is_in = reference_data$type, has_length = 1, .call_depth = -2)
|
||||||
meet_criteria(host, allow_class = c("character", "factor"), allow_NULL = TRUE, allow_NA = TRUE, .call_depth = -2)
|
meet_criteria(host, allow_class = c("character", "factor"), allow_NULL = TRUE, allow_NA = TRUE, .call_depth = -2)
|
||||||
meet_criteria(verbose, allow_class = "logical", has_length = 1, .call_depth = -2)
|
meet_criteria(verbose, allow_class = "logical", has_length = 1, .call_depth = -2)
|
||||||
|
|
||||||
# backward compatibilty
|
# backward compatibilty
|
||||||
dots <- list(...)
|
dots <- list(...)
|
||||||
dots <- dots[which(!names(dots) %in% c("warn", "mo.bak", "is_data.frame"))]
|
dots <- dots[which(!names(dots) %in% c("warn", "mo.bak", "is_data.frame"))]
|
||||||
if (length(dots) != 0) {
|
if (length(dots) != 0) {
|
||||||
warning_("These arguments in `as.sir()` are no longer used: ", vector_and(names(dots), quotes = "`"), ".", call = FALSE)
|
warning_("These arguments in `as.sir()` are no longer used: ", vector_and(names(dots), quotes = "`"), ".", call = FALSE)
|
||||||
}
|
}
|
||||||
|
|
||||||
guideline_coerced <- get_guideline(guideline, reference_data)
|
guideline_coerced <- get_guideline(guideline, reference_data)
|
||||||
|
|
||||||
if (message_not_thrown_before("as.sir", "sir_interpretation_history")) {
|
if (message_not_thrown_before("as.sir", "sir_interpretation_history")) {
|
||||||
message()
|
message()
|
||||||
message_("Run `sir_interpretation_history()` afterwards to retrieve a logbook with all the details of the breakpoint interpretations.\n\n", add_fn = font_green)
|
message_("Run `sir_interpretation_history()` afterwards to retrieve a logbook with all the details of the breakpoint interpretations.\n\n", add_fn = font_green)
|
||||||
}
|
}
|
||||||
|
|
||||||
current_df <- tryCatch(get_current_data(NA, 0), error = function(e) NULL)
|
current_df <- tryCatch(get_current_data(NA, 0), error = function(e) NULL)
|
||||||
|
|
||||||
# get host
|
# get host
|
||||||
if (breakpoint_type == "animal") {
|
if (breakpoint_type == "animal") {
|
||||||
if (is.null(host)) {
|
if (is.null(host)) {
|
||||||
host <- "dogs"
|
host <- "dogs"
|
||||||
if (message_not_thrown_before("as.sir", "host_missing")) {
|
if (message_not_thrown_before("as.sir", "host_missing")) {
|
||||||
message_("Animal hosts not set in `host`, assuming `host = \"dogs\"`, since these have the highest breakpoint availability.\n\n")
|
message_("Animal hosts not set in `host`, assuming `host = \"dogs\"`, since these have the highest breakpoint availability.\n\n")
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
} else {
|
} else {
|
||||||
@@ -949,7 +980,7 @@ as_sir_method <- function(method_short,
|
|||||||
host <- breakpoint_type
|
host <- breakpoint_type
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
if (!is.null(host) && !all(toupper(as.character(host)) %in% c("HUMAN", "ECOFF"))) {
|
if (!is.null(host) && !all(toupper(as.character(host)) %in% c("HUMAN", "ECOFF"))) {
|
||||||
if (!is.null(current_df) && length(host) == 1 && host %in% colnames(current_df) && any(current_df[[host]] %like% "[A-Z]", na.rm = TRUE)) {
|
if (!is.null(current_df) && length(host) == 1 && host %in% colnames(current_df) && any(current_df[[host]] %like% "[A-Z]", na.rm = TRUE)) {
|
||||||
host <- current_df[[host]]
|
host <- current_df[[host]]
|
||||||
@@ -959,7 +990,7 @@ as_sir_method <- function(method_short,
|
|||||||
if (!is.null(cur_column_dplyr) && is.data.frame(current_df)) {
|
if (!is.null(cur_column_dplyr) && is.data.frame(current_df)) {
|
||||||
# try to get current column, which will only be available when in across()
|
# try to get current column, which will only be available when in across()
|
||||||
host <- tryCatch(cur_column_dplyr(),
|
host <- tryCatch(cur_column_dplyr(),
|
||||||
error = function(e) host
|
error = function(e) host
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
@@ -976,7 +1007,7 @@ as_sir_method <- function(method_short,
|
|||||||
message_("Please note that in the absence of specific veterinary breakpoints for certain animal hosts, the CLSI guideline VET09 will be applied where possible.\n\n")
|
message_("Please note that in the absence of specific veterinary breakpoints for certain animal hosts, the CLSI guideline VET09 will be applied where possible.\n\n")
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
# get ab
|
# get ab
|
||||||
if (!is.null(current_df) && length(ab) == 1 && ab %in% colnames(current_df) && any(current_df[[ab]] %like% "[A-Z]", na.rm = TRUE)) {
|
if (!is.null(current_df) && length(ab) == 1 && ab %in% colnames(current_df) && any(current_df[[ab]] %like% "[A-Z]", na.rm = TRUE)) {
|
||||||
ab <- current_df[[ab]]
|
ab <- current_df[[ab]]
|
||||||
@@ -986,11 +1017,11 @@ as_sir_method <- function(method_short,
|
|||||||
if (!is.null(cur_column_dplyr) && is.data.frame(current_df)) {
|
if (!is.null(cur_column_dplyr) && is.data.frame(current_df)) {
|
||||||
# try to get current column, which will only be available when in across()
|
# try to get current column, which will only be available when in across()
|
||||||
ab <- tryCatch(cur_column_dplyr(),
|
ab <- tryCatch(cur_column_dplyr(),
|
||||||
error = function(e) ab
|
error = function(e) ab
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
# get mo
|
# get mo
|
||||||
if (!is.null(current_df) && length(mo) == 1 && mo %in% colnames(current_df)) {
|
if (!is.null(current_df) && length(mo) == 1 && mo %in% colnames(current_df)) {
|
||||||
mo_var_found <- paste0(" based on column '", font_bold(mo), "'")
|
mo_var_found <- paste0(" based on column '", font_bold(mo), "'")
|
||||||
@@ -1028,7 +1059,7 @@ as_sir_method <- function(method_short,
|
|||||||
call = FALSE
|
call = FALSE
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
# get uti
|
# get uti
|
||||||
if (!is.null(current_df) && length(uti) == 1 && uti %in% colnames(current_df)) {
|
if (!is.null(current_df) && length(uti) == 1 && uti %in% colnames(current_df)) {
|
||||||
uti <- current_df[[uti]]
|
uti <- current_df[[uti]]
|
||||||
@@ -1055,7 +1086,7 @@ as_sir_method <- function(method_short,
|
|||||||
}
|
}
|
||||||
}
|
}
|
||||||
# TODO set uti to specimen column here
|
# TODO set uti to specimen column here
|
||||||
|
|
||||||
|
|
||||||
if (length(ab) == 1 && ab %like% paste0("as.", method_short)) {
|
if (length(ab) == 1 && ab %like% paste0("as.", method_short)) {
|
||||||
stop_("No unambiguous name was supplied about the antibiotic (argument `ab`). See ?as.sir.", call = FALSE)
|
stop_("No unambiguous name was supplied about the antibiotic (argument `ab`). See ?as.sir.", call = FALSE)
|
||||||
@@ -1100,27 +1131,33 @@ as_sir_method <- function(method_short,
|
|||||||
warning_("in `as.sir()`: using 'add_intrinsic_resistance' is only useful when using EUCAST guidelines, since the rules for intrinsic resistance are based on EUCAST.")
|
warning_("in `as.sir()`: using 'add_intrinsic_resistance' is only useful when using EUCAST guidelines, since the rules for intrinsic resistance are based on EUCAST.")
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
# format agents ----
|
# format agents ----
|
||||||
agent_formatted <- paste0("'", font_bold(ab.bak, collapse = NULL), "'")
|
agent_formatted <- paste0("'", font_bold(ab.bak, collapse = NULL), "'")
|
||||||
agent_name <- ab_name(ab, tolower = TRUE, language = NULL)
|
agent_name <- ab_name(ab, tolower = TRUE, language = NULL)
|
||||||
same_ab <- generalise_antibiotic_name(ab) == generalise_antibiotic_name(agent_name)
|
same_ab <- generalise_antibiotic_name(ab) == generalise_antibiotic_name(agent_name)
|
||||||
same_ab.bak <- generalise_antibiotic_name(ab.bak) == generalise_antibiotic_name(agent_name)
|
same_ab.bak <- generalise_antibiotic_name(ab.bak) == generalise_antibiotic_name(agent_name)
|
||||||
agent_formatted[same_ab.bak] <- paste0(agent_formatted[same_ab.bak], " (", ab[same_ab.bak], ")")
|
agent_formatted[same_ab.bak] <- paste0(agent_formatted[same_ab.bak], " (", ab[same_ab.bak], ")")
|
||||||
agent_formatted[!same_ab.bak & !same_ab] <- paste0(agent_formatted[!same_ab.bak & !same_ab],
|
agent_formatted[!same_ab.bak & !same_ab] <- paste0(
|
||||||
" (", ifelse(ab.bak[!same_ab.bak & !same_ab] == ab[!same_ab.bak & !same_ab],
|
agent_formatted[!same_ab.bak & !same_ab],
|
||||||
"",
|
" (", ifelse(ab.bak[!same_ab.bak & !same_ab] == ab[!same_ab.bak & !same_ab],
|
||||||
paste0(ab[!same_ab.bak & !same_ab], ", ")),
|
"",
|
||||||
agent_name[!same_ab.bak & !same_ab],
|
paste0(ab[!same_ab.bak & !same_ab], ", ")
|
||||||
")")
|
),
|
||||||
|
agent_name[!same_ab.bak & !same_ab],
|
||||||
|
")"
|
||||||
|
)
|
||||||
# this intro text will also be printed in the progress bar if the `progress` package is installed
|
# this intro text will also be printed in the progress bar if the `progress` package is installed
|
||||||
intro_txt <- paste0("Interpreting ", method_long, ": ", ifelse(isTRUE(list(...)$is_data.frame), "column ", ""),
|
intro_txt <- paste0(
|
||||||
ifelse(length(unique(agent_formatted)) == 1, unique(agent_formatted), paste0(vector_and(agent_formatted, quotes = FALSE, sort = FALSE))),
|
"Interpreting ", method_long, ": ", ifelse(isTRUE(list(...)$is_data.frame), "column ", ""),
|
||||||
mo_var_found,
|
ifelse(length(unique(agent_formatted)) == 1, unique(agent_formatted), paste0(vector_and(agent_formatted, quotes = FALSE, sort = FALSE))),
|
||||||
ifelse(identical(reference_data, AMR::clinical_breakpoints),
|
mo_var_found,
|
||||||
paste0(", ", font_bold(guideline_coerced)),
|
ifelse(identical(reference_data, AMR::clinical_breakpoints),
|
||||||
""),
|
paste0(", ", font_bold(guideline_coerced)),
|
||||||
"... ")
|
""
|
||||||
|
),
|
||||||
|
"... "
|
||||||
|
)
|
||||||
|
|
||||||
# prepare used arguments ----
|
# prepare used arguments ----
|
||||||
method <- method_short
|
method <- method_short
|
||||||
@@ -1131,7 +1168,7 @@ as_sir_method <- function(method_short,
|
|||||||
rise_notes <- FALSE
|
rise_notes <- FALSE
|
||||||
method_coerced <- toupper(method)
|
method_coerced <- toupper(method)
|
||||||
ab_coerced <- as.ab(ab)
|
ab_coerced <- as.ab(ab)
|
||||||
|
|
||||||
if (identical(reference_data, AMR::clinical_breakpoints)) {
|
if (identical(reference_data, AMR::clinical_breakpoints)) {
|
||||||
breakpoints <- reference_data %pm>%
|
breakpoints <- reference_data %pm>%
|
||||||
subset(guideline == guideline_coerced & method == method_coerced & ab %in% ab_coerced)
|
subset(guideline == guideline_coerced & method == method_coerced & ab %in% ab_coerced)
|
||||||
@@ -1144,7 +1181,7 @@ as_sir_method <- function(method_short,
|
|||||||
breakpoints <- reference_data %pm>%
|
breakpoints <- reference_data %pm>%
|
||||||
subset(method == method_coerced & ab %in% ab_coerced)
|
subset(method == method_coerced & ab %in% ab_coerced)
|
||||||
}
|
}
|
||||||
|
|
||||||
# create the unique data frame to be filled to save time
|
# create the unique data frame to be filled to save time
|
||||||
df <- data.frame(
|
df <- data.frame(
|
||||||
values = x,
|
values = x,
|
||||||
@@ -1162,9 +1199,9 @@ as_sir_method <- function(method_short,
|
|||||||
# when as.sir.disk is called directly
|
# when as.sir.disk is called directly
|
||||||
df$values <- as.disk(df$values)
|
df$values <- as.disk(df$values)
|
||||||
}
|
}
|
||||||
|
|
||||||
df_unique <- unique(df[ , c("mo", "ab", "uti", "host"), drop = FALSE])
|
df_unique <- unique(df[, c("mo", "ab", "uti", "host"), drop = FALSE])
|
||||||
|
|
||||||
# get all breakpoints, use humans as backup for animals
|
# get all breakpoints, use humans as backup for animals
|
||||||
breakpoint_type_lookup <- breakpoint_type
|
breakpoint_type_lookup <- breakpoint_type
|
||||||
if (breakpoint_type == "animal") {
|
if (breakpoint_type == "animal") {
|
||||||
@@ -1172,7 +1209,7 @@ as_sir_method <- function(method_short,
|
|||||||
}
|
}
|
||||||
breakpoints <- breakpoints %pm>%
|
breakpoints <- breakpoints %pm>%
|
||||||
subset(type %in% breakpoint_type_lookup)
|
subset(type %in% breakpoint_type_lookup)
|
||||||
|
|
||||||
if (isFALSE(include_screening)) {
|
if (isFALSE(include_screening)) {
|
||||||
# remove screening rules from the breakpoints table
|
# remove screening rules from the breakpoints table
|
||||||
breakpoints <- breakpoints %pm>%
|
breakpoints <- breakpoints %pm>%
|
||||||
@@ -1190,7 +1227,7 @@ as_sir_method <- function(method_short,
|
|||||||
any_is_intrinsic_resistant <- FALSE
|
any_is_intrinsic_resistant <- FALSE
|
||||||
add_intrinsic_resistance_to_AMR_env()
|
add_intrinsic_resistance_to_AMR_env()
|
||||||
}
|
}
|
||||||
|
|
||||||
if (nrow(df_unique) < 10 || nrow(breakpoints) == 0) {
|
if (nrow(df_unique) < 10 || nrow(breakpoints) == 0) {
|
||||||
# only print intro under 10 items, otherwise progressbar will print this and then it will be printed double
|
# only print intro under 10 items, otherwise progressbar will print this and then it will be printed double
|
||||||
message_(intro_txt, appendLF = FALSE, as_note = FALSE)
|
message_(intro_txt, appendLF = FALSE, as_note = FALSE)
|
||||||
@@ -1198,19 +1235,22 @@ as_sir_method <- function(method_short,
|
|||||||
p <- progress_ticker(n = nrow(df_unique), n_min = 10, title = font_blue(intro_txt), only_bar_percent = TRUE)
|
p <- progress_ticker(n = nrow(df_unique), n_min = 10, title = font_blue(intro_txt), only_bar_percent = TRUE)
|
||||||
has_progress_bar <- !is.null(import_fn("progress_bar", "progress", error_on_fail = FALSE)) && nrow(df_unique) >= 10
|
has_progress_bar <- !is.null(import_fn("progress_bar", "progress", error_on_fail = FALSE)) && nrow(df_unique) >= 10
|
||||||
on.exit(close(p))
|
on.exit(close(p))
|
||||||
|
|
||||||
if (nrow(breakpoints) == 0) {
|
if (nrow(breakpoints) == 0) {
|
||||||
# apparently no breakpoints found
|
# apparently no breakpoints found
|
||||||
message(
|
message(
|
||||||
paste0(font_rose_bg(" WARNING "), "\n"),
|
paste0(font_rose_bg(" WARNING "), "\n"),
|
||||||
font_black(paste0(" ", AMR_env$bullet_icon, " No ", guideline_coerced, " ", method_coerced, " breakpoints available for ",
|
font_black(paste0(
|
||||||
suppressMessages(suppressWarnings(ab_name(unique(ab_coerced), language = NULL, tolower = TRUE))),
|
" ", AMR_env$bullet_icon, " No ", guideline_coerced, " ", method_coerced, " breakpoints available for ",
|
||||||
" (", unique(ab_coerced), ")."), collapse = "\n"))
|
suppressMessages(suppressWarnings(ab_name(unique(ab_coerced), language = NULL, tolower = TRUE))),
|
||||||
|
" (", unique(ab_coerced), ")."
|
||||||
|
), collapse = "\n")
|
||||||
|
)
|
||||||
|
|
||||||
load_mo_uncertainties(metadata_mo)
|
load_mo_uncertainties(metadata_mo)
|
||||||
return(rep(NA_sir_, nrow(df)))
|
return(rep(NA_sir_, nrow(df)))
|
||||||
}
|
}
|
||||||
|
|
||||||
vectorise_log_entry <- function(x, len) {
|
vectorise_log_entry <- function(x, len) {
|
||||||
if (length(x) == 1 && len > 1) {
|
if (length(x) == 1 && len > 1) {
|
||||||
rep(x, len)
|
rep(x, len)
|
||||||
@@ -1218,7 +1258,7 @@ as_sir_method <- function(method_short,
|
|||||||
x
|
x
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
# run the rules (df_unique is a row combination per mo/ab/uti/host) ----
|
# run the rules (df_unique is a row combination per mo/ab/uti/host) ----
|
||||||
for (i in seq_len(nrow(df_unique))) {
|
for (i in seq_len(nrow(df_unique))) {
|
||||||
p$tick()
|
p$tick()
|
||||||
@@ -1265,7 +1305,7 @@ as_sir_method <- function(method_short,
|
|||||||
suppressMessages(suppressWarnings(ab_name(ab_current, language = NULL, tolower = TRUE))),
|
suppressMessages(suppressWarnings(ab_name(ab_current, language = NULL, tolower = TRUE))),
|
||||||
" (", ab_current, ")"
|
" (", ab_current, ")"
|
||||||
)
|
)
|
||||||
|
|
||||||
# gather all available breakpoints for current MO
|
# gather all available breakpoints for current MO
|
||||||
# TODO for VET09 do not filter out E. coli and such
|
# TODO for VET09 do not filter out E. coli and such
|
||||||
breakpoints_current <- breakpoints %pm>%
|
breakpoints_current <- breakpoints %pm>%
|
||||||
@@ -1276,16 +1316,16 @@ as_sir_method <- function(method_short,
|
|||||||
mo_current_species_group,
|
mo_current_species_group,
|
||||||
mo_current_other
|
mo_current_other
|
||||||
))
|
))
|
||||||
|
|
||||||
# TODO are operators considered??
|
# TODO are operators considered??
|
||||||
# This seems to not work well: as.sir(as.mic(c(4, ">4", ">=4", 8, ">8", ">=8")), ab = "AMC", mo = "E. coli", breakpoint_type = "animal", host = "dogs", guideline = "CLSI 2024")
|
# This seems to not work well: as.sir(as.mic(c(4, ">4", ">=4", 8, ">8", ">=8")), ab = "AMC", mo = "E. coli", breakpoint_type = "animal", host = "dogs", guideline = "CLSI 2024")
|
||||||
|
|
||||||
## fall-back methods for veterinary guidelines ----
|
## fall-back methods for veterinary guidelines ----
|
||||||
if (breakpoint_type == "animal" && !host_current %in% breakpoints_current$host) {
|
if (breakpoint_type == "animal" && !host_current %in% breakpoints_current$host) {
|
||||||
if (guideline_coerced %like% "CLSI") {
|
if (guideline_coerced %like% "CLSI") {
|
||||||
# VET09 says that staph/strep/enterococcus BP can be extrapolated to all Gr+ cocci except for intrinsic resistance, so take all Gr+ cocci:
|
# VET09 says that staph/strep/enterococcus BP can be extrapolated to all Gr+ cocci except for intrinsic resistance, so take all Gr+ cocci:
|
||||||
gram_plus_cocci_vet09 <- microorganisms$mo[microorganisms$genus %in% c("Staphylococcus", "Streptococcus", "Peptostreptococcus", "Aerococcus", "Micrococcus") & microorganisms$rank == "genus"] # TODO should probably include genera that were either of these before
|
gram_plus_cocci_vet09 <- microorganisms$mo[microorganisms$genus %in% c("Staphylococcus", "Streptococcus", "Peptostreptococcus", "Aerococcus", "Micrococcus") & microorganisms$rank == "genus"] # TODO should probably include genera that were either of these before
|
||||||
|
|
||||||
# HUMAN SUBSTITUTES
|
# HUMAN SUBSTITUTES
|
||||||
if (ab_current == "AZM" && mo_current_genus %in% gram_plus_cocci_vet09 && host_current %in% c("dogs", "cats", "horse")) {
|
if (ab_current == "AZM" && mo_current_genus %in% gram_plus_cocci_vet09 && host_current %in% c("dogs", "cats", "horse")) {
|
||||||
# azithro can take human breakpoints for these agents
|
# azithro can take human breakpoints for these agents
|
||||||
@@ -1331,22 +1371,19 @@ as_sir_method <- function(method_short,
|
|||||||
# vancomycin can take human breakpoints in these hosts
|
# vancomycin can take human breakpoints in these hosts
|
||||||
breakpoints_current <- breakpoints_current %pm>% subset(host == "human")
|
breakpoints_current <- breakpoints_current %pm>% subset(host == "human")
|
||||||
notes_current <- c(notes_current, paste0("Using ", font_bold("human"), " breakpoints for ", ab_formatted, " based on CLSI VET09."))
|
notes_current <- c(notes_current, paste0("Using ", font_bold("human"), " breakpoints for ", ab_formatted, " based on CLSI VET09."))
|
||||||
|
|
||||||
} else if (host_current %in% c("dogs", "cats") && (mo_current_genus %in% c("B_AMYCS", "B_NOCRD", "B_CMPYL", "B_CRYNB", "B_ENTRC", "B_MYCBC", "B_PSDMN", "B_AERMN") | mo_current_class == "B_[CLS]_BTPRTBCT" | mo_current == "B_LISTR_MNCY")) {
|
} else if (host_current %in% c("dogs", "cats") && (mo_current_genus %in% c("B_AMYCS", "B_NOCRD", "B_CMPYL", "B_CRYNB", "B_ENTRC", "B_MYCBC", "B_PSDMN", "B_AERMN") | mo_current_class == "B_[CLS]_BTPRTBCT" | mo_current == "B_LISTR_MNCY")) {
|
||||||
# dog breakpoints if no canine/feline
|
# dog breakpoints if no canine/feline
|
||||||
# TODO do we still have dogs breakpoints at this point???
|
# TODO do we still have dogs breakpoints at this point???
|
||||||
breakpoints_current <- breakpoints_current %pm>% subset(host == "human") # WRONG
|
breakpoints_current <- breakpoints_current %pm>% subset(host == "human") # WRONG
|
||||||
notes_current <- c(notes_current, paste0("Using ", font_bold("human"), " breakpoints for ", mo_formatted, " based on CLSI VET09."))
|
notes_current <- c(notes_current, paste0("Using ", font_bold("human"), " breakpoints for ", mo_formatted, " based on CLSI VET09."))
|
||||||
|
|
||||||
} else {
|
} else {
|
||||||
# no specific CLSI solution for this, so only filter on current host (if no breakpoints available -> too bad)
|
# no specific CLSI solution for this, so only filter on current host (if no breakpoints available -> too bad)
|
||||||
breakpoints_current <- breakpoints_current %pm>%
|
breakpoints_current <- breakpoints_current %pm>%
|
||||||
subset(host == host_current)
|
subset(host == host_current)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
}
|
}
|
||||||
|
|
||||||
if (NROW(breakpoints_current) == 0) {
|
if (NROW(breakpoints_current) == 0) {
|
||||||
AMR_env$sir_interpretation_history <- rbind_AMR(
|
AMR_env$sir_interpretation_history <- rbind_AMR(
|
||||||
AMR_env$sir_interpretation_history,
|
AMR_env$sir_interpretation_history,
|
||||||
@@ -1374,16 +1411,18 @@ as_sir_method <- function(method_short,
|
|||||||
notes <- c(notes, notes_current)
|
notes <- c(notes, notes_current)
|
||||||
next
|
next
|
||||||
}
|
}
|
||||||
|
|
||||||
# sort on host and taxonomic rank
|
# sort on host and taxonomic rank
|
||||||
# (this will e.g. prefer 'species' breakpoints over 'order' breakpoints)
|
# (this will e.g. prefer 'species' breakpoints over 'order' breakpoints)
|
||||||
if (is.na(uti_current)) {
|
if (is.na(uti_current)) {
|
||||||
breakpoints_current <- breakpoints_current %pm>%
|
breakpoints_current <- breakpoints_current %pm>%
|
||||||
# `uti` is a column in the data set
|
# `uti` is a column in the data set
|
||||||
# this will put UTI = FALSE first, then UTI = NA, then UTI = TRUE
|
# this will put UTI = FALSE first, then UTI = NA, then UTI = TRUE
|
||||||
pm_mutate(uti_index = ifelse(!is.na(uti) & uti == FALSE, 1,
|
pm_mutate(uti_index = ifelse(!is.na(uti) & uti == FALSE, 1,
|
||||||
ifelse(is.na(uti), 2,
|
ifelse(is.na(uti), 2,
|
||||||
3))) %pm>%
|
3
|
||||||
|
)
|
||||||
|
)) %pm>%
|
||||||
# be as specific as possible (i.e. prefer species over genus):
|
# be as specific as possible (i.e. prefer species over genus):
|
||||||
pm_arrange(rank_index, uti_index)
|
pm_arrange(rank_index, uti_index)
|
||||||
} else if (uti_current == TRUE) {
|
} else if (uti_current == TRUE) {
|
||||||
@@ -1392,7 +1431,7 @@ as_sir_method <- function(method_short,
|
|||||||
# be as specific as possible (i.e. prefer species over genus):
|
# be as specific as possible (i.e. prefer species over genus):
|
||||||
pm_arrange(rank_index)
|
pm_arrange(rank_index)
|
||||||
}
|
}
|
||||||
|
|
||||||
# throw messages for different body sites
|
# throw messages for different body sites
|
||||||
site <- breakpoints_current[1L, "site", drop = FALSE] # this is the one we'll take
|
site <- breakpoints_current[1L, "site", drop = FALSE] # this is the one we'll take
|
||||||
if (is.na(site)) {
|
if (is.na(site)) {
|
||||||
@@ -1412,7 +1451,7 @@ as_sir_method <- function(method_short,
|
|||||||
# breakpoints for multiple body sites available
|
# breakpoints for multiple body sites available
|
||||||
notes_current <- c(notes_current, paste0("Multiple breakpoints available for ", font_bold(ab_formatted), " in ", mo_formatted, " - assuming ", site, "."))
|
notes_current <- c(notes_current, paste0("Multiple breakpoints available for ", font_bold(ab_formatted), " in ", mo_formatted, " - assuming ", site, "."))
|
||||||
}
|
}
|
||||||
|
|
||||||
# first check if mo is intrinsic resistant
|
# first check if mo is intrinsic resistant
|
||||||
if (isTRUE(add_intrinsic_resistance) && guideline_coerced %like% "EUCAST" && paste(mo_current, ab_current) %in% AMR_env$intrinsic_resistant) {
|
if (isTRUE(add_intrinsic_resistance) && guideline_coerced %like% "EUCAST" && paste(mo_current, ab_current) %in% AMR_env$intrinsic_resistant) {
|
||||||
notes_current <- c(notes_current, paste0("Intrinsic resistance applied for ", ab_formatted, " in ", mo_formatted, ""))
|
notes_current <- c(notes_current, paste0("Intrinsic resistance applied for ", ab_formatted, " in ", mo_formatted, ""))
|
||||||
@@ -1464,7 +1503,7 @@ as_sir_method <- function(method_short,
|
|||||||
TRUE ~ NA_sir_
|
TRUE ~ NA_sir_
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
# write to verbose output
|
# write to verbose output
|
||||||
AMR_env$sir_interpretation_history <- rbind_AMR(
|
AMR_env$sir_interpretation_history <- rbind_AMR(
|
||||||
AMR_env$sir_interpretation_history,
|
AMR_env$sir_interpretation_history,
|
||||||
@@ -1494,7 +1533,7 @@ as_sir_method <- function(method_short,
|
|||||||
notes <- c(notes, notes_current)
|
notes <- c(notes, notes_current)
|
||||||
df[rows, "result"] <- new_sir
|
df[rows, "result"] <- new_sir
|
||||||
}
|
}
|
||||||
|
|
||||||
close(p)
|
close(p)
|
||||||
# printing messages
|
# printing messages
|
||||||
if (has_progress_bar == TRUE) {
|
if (has_progress_bar == TRUE) {
|
||||||
@@ -1518,9 +1557,9 @@ as_sir_method <- function(method_short,
|
|||||||
} else {
|
} else {
|
||||||
message(font_green_bg(" OK "))
|
message(font_green_bg(" OK "))
|
||||||
}
|
}
|
||||||
|
|
||||||
load_mo_uncertainties(metadata_mo)
|
load_mo_uncertainties(metadata_mo)
|
||||||
|
|
||||||
df$result
|
df$result
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -1536,11 +1575,11 @@ sir_interpretation_history <- function(clean = FALSE) {
|
|||||||
# sort descending on time
|
# sort descending on time
|
||||||
out <- out[order(format(out$datetime, "%Y%m%d%H%M"), out$index, decreasing = TRUE), , drop = FALSE]
|
out <- out[order(format(out$datetime, "%Y%m%d%H%M"), out$index, decreasing = TRUE), , drop = FALSE]
|
||||||
}
|
}
|
||||||
|
|
||||||
if (isTRUE(clean)) {
|
if (isTRUE(clean)) {
|
||||||
AMR_env$sir_interpretation_history <- AMR_env$sir_interpretation_history[0, , drop = FALSE]
|
AMR_env$sir_interpretation_history <- AMR_env$sir_interpretation_history[0, , drop = FALSE]
|
||||||
}
|
}
|
||||||
|
|
||||||
if (pkg_is_available("tibble")) {
|
if (pkg_is_available("tibble")) {
|
||||||
out <- import_fn("as_tibble", "tibble")(out)
|
out <- import_fn("as_tibble", "tibble")(out)
|
||||||
}
|
}
|
||||||
@@ -1757,7 +1796,7 @@ summary.sir <- function(object, ...) {
|
|||||||
#' @noRd
|
#' @noRd
|
||||||
c.sir <- function(...) {
|
c.sir <- function(...) {
|
||||||
lst <- list(...)
|
lst <- list(...)
|
||||||
|
|
||||||
# TODO for #170
|
# TODO for #170
|
||||||
# guideline <- vapply(FUN.VALUE = character(1), lst, function(x) attributes(x)$guideline %or% NA_character_)
|
# guideline <- vapply(FUN.VALUE = character(1), lst, function(x) attributes(x)$guideline %or% NA_character_)
|
||||||
# mo <- vapply(FUN.VALUE = character(1), lst, function(x) attributes(x)$mo %or% NA_character_)
|
# mo <- vapply(FUN.VALUE = character(1), lst, function(x) attributes(x)$mo %or% NA_character_)
|
||||||
@@ -1765,9 +1804,9 @@ c.sir <- function(...) {
|
|||||||
# method <- vapply(FUN.VALUE = character(1), lst, function(x) attributes(x)$method %or% NA_character_)
|
# method <- vapply(FUN.VALUE = character(1), lst, function(x) attributes(x)$method %or% NA_character_)
|
||||||
# ref_tbl <- vapply(FUN.VALUE = character(1), lst, function(x) attributes(x)$ref_tbl %or% NA_character_)
|
# ref_tbl <- vapply(FUN.VALUE = character(1), lst, function(x) attributes(x)$ref_tbl %or% NA_character_)
|
||||||
# ref_breakpoints <- vapply(FUN.VALUE = character(1), lst, function(x) attributes(x)$ref_breakpoints %or% NA_character_)
|
# ref_breakpoints <- vapply(FUN.VALUE = character(1), lst, function(x) attributes(x)$ref_breakpoints %or% NA_character_)
|
||||||
|
|
||||||
out <- as.sir(unlist(lapply(list(...), as.character)))
|
out <- as.sir(unlist(lapply(list(...), as.character)))
|
||||||
|
|
||||||
# TODO for #170
|
# TODO for #170
|
||||||
# if (!all(is.na(guideline))) {
|
# if (!all(is.na(guideline))) {
|
||||||
# attributes(out)$guideline <- guideline
|
# attributes(out)$guideline <- guideline
|
||||||
@@ -1777,7 +1816,7 @@ c.sir <- function(...) {
|
|||||||
# attributes(out)$ref_tbl <- ref_tbl
|
# attributes(out)$ref_tbl <- ref_tbl
|
||||||
# attributes(out)$ref_breakpoints <- ref_breakpoints
|
# attributes(out)$ref_breakpoints <- ref_breakpoints
|
||||||
# }
|
# }
|
||||||
|
|
||||||
out
|
out
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
@@ -254,7 +254,6 @@ sir_calc_df <- function(type, # "proportion", "count" or "both"
|
|||||||
if (message_not_thrown_before("sir_calc_df", combine_SI, entire_session = TRUE)) {
|
if (message_not_thrown_before("sir_calc_df", combine_SI, entire_session = TRUE)) {
|
||||||
message_("Note that `sir_calc_df()` will also count dose-dependent susceptibility, 'SDD', as 'SI' when `combine_SI = TRUE`. This note will be shown once for this session.", as_note = FALSE)
|
message_("Note that `sir_calc_df()` will also count dose-dependent susceptibility, 'SDD', as 'SI' when `combine_SI = TRUE`. This note will be shown once for this session.", as_note = FALSE)
|
||||||
}
|
}
|
||||||
|
|
||||||
}
|
}
|
||||||
data[, i] <- gsub("(I|S|SDD)", "SI", data[, i, drop = TRUE])
|
data[, i] <- gsub("(I|S|SDD)", "SI", data[, i, drop = TRUE])
|
||||||
}
|
}
|
||||||
@@ -359,12 +358,12 @@ sir_calc_df <- function(type, # "proportion", "count" or "both"
|
|||||||
# don't use as.sir() here, as it would add the class 'sir' and we would like
|
# don't use as.sir() here, as it would add the class 'sir' and we would like
|
||||||
# the same data structure as output, regardless of input
|
# the same data structure as output, regardless of input
|
||||||
if (out$value[out$interpretation == "SDD"] > 0) {
|
if (out$value[out$interpretation == "SDD"] > 0) {
|
||||||
out$interpretation <- factor(out$interpretation, levels = c("S", "SDD", "I", "R"), ordered = TRUE)
|
out$interpretation <- factor(out$interpretation, levels = c("S", "SDD", "I", "R"), ordered = TRUE)
|
||||||
} else {
|
} else {
|
||||||
out$interpretation <- factor(out$interpretation, levels = c("S", "I", "R"), ordered = TRUE)
|
out$interpretation <- factor(out$interpretation, levels = c("S", "I", "R"), ordered = TRUE)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
out <- out[!is.na(out$interpretation), , drop = FALSE]
|
out <- out[!is.na(out$interpretation), , drop = FALSE]
|
||||||
|
|
||||||
if (data_has_groups) {
|
if (data_has_groups) {
|
||||||
@@ -383,6 +382,6 @@ sir_calc_df <- function(type, # "proportion", "count" or "both"
|
|||||||
# remove redundant columns
|
# remove redundant columns
|
||||||
out <- subset(out, select = -c(ci_min, ci_max, isolates))
|
out <- subset(out, select = -c(ci_min, ci_max, isolates))
|
||||||
}
|
}
|
||||||
|
|
||||||
as_original_data_class(out, class(data.bak), extra_class = "sir_df") # will remove tibble groups
|
as_original_data_class(out, class(data.bak), extra_class = "sir_df") # will remove tibble groups
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -28,7 +28,7 @@
|
|||||||
# ==================================================================== #
|
# ==================================================================== #
|
||||||
|
|
||||||
#' Filter Top *n* Microorganisms
|
#' Filter Top *n* Microorganisms
|
||||||
#'
|
#'
|
||||||
#' This function filters a data set to include only the top *n* microorganisms based on a specified property, such as taxonomic family or genus. For example, it can filter a data set to the top 3 species, or to any species in the top 5 genera, or to the top 3 species in each of the top 5 genera.
|
#' This function filters a data set to include only the top *n* microorganisms based on a specified property, such as taxonomic family or genus. For example, it can filter a data set to the top 3 species, or to any species in the top 5 genera, or to the top 3 species in each of the top 5 genera.
|
||||||
#' @param x a data frame containing microbial data
|
#' @param x a data frame containing microbial data
|
||||||
#' @param n an integer specifying the maximum number of unique values of the `property` to include in the output
|
#' @param n an integer specifying the maximum number of unique values of the `property` to include in the output
|
||||||
@@ -42,15 +42,18 @@
|
|||||||
#' @examples
|
#' @examples
|
||||||
#' # filter to the top 3 species:
|
#' # filter to the top 3 species:
|
||||||
#' top_n_microorganisms(example_isolates,
|
#' top_n_microorganisms(example_isolates,
|
||||||
#' n = 3)
|
#' n = 3
|
||||||
#'
|
#' )
|
||||||
|
#'
|
||||||
#' # filter to any species in the top 5 genera:
|
#' # filter to any species in the top 5 genera:
|
||||||
#' top_n_microorganisms(example_isolates,
|
#' top_n_microorganisms(example_isolates,
|
||||||
#' n = 5, property = "genus")
|
#' n = 5, property = "genus"
|
||||||
#'
|
#' )
|
||||||
|
#'
|
||||||
#' # filter to the top 3 species in each of the top 5 genera:
|
#' # filter to the top 3 species in each of the top 5 genera:
|
||||||
#' top_n_microorganisms(example_isolates,
|
#' top_n_microorganisms(example_isolates,
|
||||||
#' n = 5, property = "genus", n_for_each = 3)
|
#' n = 5, property = "genus", n_for_each = 3
|
||||||
|
#' )
|
||||||
top_n_microorganisms <- function(x, n, property = "fullname", n_for_each = NULL, col_mo = NULL, ...) {
|
top_n_microorganisms <- function(x, n, property = "fullname", n_for_each = NULL, col_mo = NULL, ...) {
|
||||||
meet_criteria(x, allow_class = "data.frame") # also checks dimensions to be >0
|
meet_criteria(x, allow_class = "data.frame") # also checks dimensions to be >0
|
||||||
meet_criteria(n, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE, is_positive = TRUE)
|
meet_criteria(n, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE, is_positive = TRUE)
|
||||||
@@ -61,25 +64,25 @@ top_n_microorganisms <- function(x, n, property = "fullname", n_for_each = NULL,
|
|||||||
col_mo <- search_type_in_df(x = x, type = "mo", info = TRUE)
|
col_mo <- search_type_in_df(x = x, type = "mo", info = TRUE)
|
||||||
stop_if(is.null(col_mo), "`col_mo` must be set")
|
stop_if(is.null(col_mo), "`col_mo` must be set")
|
||||||
}
|
}
|
||||||
|
|
||||||
x.bak <- x
|
x.bak <- x
|
||||||
|
|
||||||
x[, col_mo] <- as.mo(x[, col_mo, drop = TRUE], keep_synonyms = TRUE)
|
x[, col_mo] <- as.mo(x[, col_mo, drop = TRUE], keep_synonyms = TRUE)
|
||||||
|
|
||||||
if (is.null(property)) {
|
if (is.null(property)) {
|
||||||
x$prop_val <- x[[col_mo]]
|
x$prop_val <- x[[col_mo]]
|
||||||
} else {
|
} else {
|
||||||
x$prop_val <- mo_property(x[[col_mo]], property = property, ...)
|
x$prop_val <- mo_property(x[[col_mo]], property = property, ...)
|
||||||
}
|
}
|
||||||
counts <- sort(table(x$prop_val), decreasing = TRUE)
|
counts <- sort(table(x$prop_val), decreasing = TRUE)
|
||||||
|
|
||||||
n <- as.integer(n)
|
n <- as.integer(n)
|
||||||
if (length(counts) < n) {
|
if (length(counts) < n) {
|
||||||
n <- length(counts)
|
n <- length(counts)
|
||||||
}
|
}
|
||||||
count_values <- names(counts)[seq_len(n)]
|
count_values <- names(counts)[seq_len(n)]
|
||||||
filtered_rows <- which(x$prop_val %in% count_values)
|
filtered_rows <- which(x$prop_val %in% count_values)
|
||||||
|
|
||||||
if (!is.null(n_for_each)) {
|
if (!is.null(n_for_each)) {
|
||||||
n_for_each <- as.integer(n_for_each)
|
n_for_each <- as.integer(n_for_each)
|
||||||
filtered_x <- x[filtered_rows, , drop = FALSE]
|
filtered_x <- x[filtered_rows, , drop = FALSE]
|
||||||
@@ -92,6 +95,6 @@ top_n_microorganisms <- function(x, n, property = "fullname", n_for_each = NULL,
|
|||||||
})
|
})
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
x.bak[filtered_rows, , drop = FALSE]
|
x.bak[filtered_rows, , drop = FALSE]
|
||||||
}
|
}
|
||||||
|
|||||||
12
R/vctrs.R
12
R/vctrs.R
@@ -59,7 +59,7 @@ vec_cast.logical.amr_selector_any_all <- function(x, to, ...) {
|
|||||||
}
|
}
|
||||||
|
|
||||||
# S3: ab ----
|
# S3: ab ----
|
||||||
vec_ptype2.ab.default <- function (x, y, ..., x_arg = "", y_arg = "") {
|
vec_ptype2.ab.default <- function(x, y, ..., x_arg = "", y_arg = "") {
|
||||||
x
|
x
|
||||||
}
|
}
|
||||||
vec_ptype2.ab.ab <- function(x, y, ...) {
|
vec_ptype2.ab.ab <- function(x, y, ...) {
|
||||||
@@ -73,7 +73,7 @@ vec_cast.ab.character <- function(x, to, ...) {
|
|||||||
}
|
}
|
||||||
|
|
||||||
# S3: av ----
|
# S3: av ----
|
||||||
vec_ptype2.av.default <- function (x, y, ..., x_arg = "", y_arg = "") {
|
vec_ptype2.av.default <- function(x, y, ..., x_arg = "", y_arg = "") {
|
||||||
x
|
x
|
||||||
}
|
}
|
||||||
vec_ptype2.av.av <- function(x, y, ...) {
|
vec_ptype2.av.av <- function(x, y, ...) {
|
||||||
@@ -87,7 +87,7 @@ vec_cast.av.character <- function(x, to, ...) {
|
|||||||
}
|
}
|
||||||
|
|
||||||
# S3: mo ----
|
# S3: mo ----
|
||||||
vec_ptype2.mo.default <- function (x, y, ..., x_arg = "", y_arg = "") {
|
vec_ptype2.mo.default <- function(x, y, ..., x_arg = "", y_arg = "") {
|
||||||
x
|
x
|
||||||
}
|
}
|
||||||
vec_ptype2.mo.mo <- function(x, y, ...) {
|
vec_ptype2.mo.mo <- function(x, y, ...) {
|
||||||
@@ -108,7 +108,7 @@ vec_ptype_full.disk <- function(x, ...) {
|
|||||||
vec_ptype_abbr.disk <- function(x, ...) {
|
vec_ptype_abbr.disk <- function(x, ...) {
|
||||||
"dsk"
|
"dsk"
|
||||||
}
|
}
|
||||||
vec_ptype2.disk.default <- function (x, y, ..., x_arg = "", y_arg = "") {
|
vec_ptype2.disk.default <- function(x, y, ..., x_arg = "", y_arg = "") {
|
||||||
NA_disk_[0]
|
NA_disk_[0]
|
||||||
}
|
}
|
||||||
vec_ptype2.disk.disk <- function(x, y, ...) {
|
vec_ptype2.disk.disk <- function(x, y, ...) {
|
||||||
@@ -137,7 +137,7 @@ vec_cast.disk.character <- function(x, to, ...) {
|
|||||||
}
|
}
|
||||||
|
|
||||||
# S3: mic ----
|
# S3: mic ----
|
||||||
vec_ptype2.mic.default <- function (x, y, ..., x_arg = "", y_arg = "") {
|
vec_ptype2.mic.default <- function(x, y, ..., x_arg = "", y_arg = "") {
|
||||||
# this will make sure that currently implemented MIC levels are returned
|
# this will make sure that currently implemented MIC levels are returned
|
||||||
NA_mic_[0]
|
NA_mic_[0]
|
||||||
}
|
}
|
||||||
@@ -181,7 +181,7 @@ vec_arith.mic <- function(op, x, y, ...) {
|
|||||||
}
|
}
|
||||||
|
|
||||||
# S3: sir ----
|
# S3: sir ----
|
||||||
vec_ptype2.sir.default <- function (x, y, ..., x_arg = "", y_arg = "") {
|
vec_ptype2.sir.default <- function(x, y, ..., x_arg = "", y_arg = "") {
|
||||||
NA_sir_[0]
|
NA_sir_[0]
|
||||||
}
|
}
|
||||||
vec_ptype2.sir.sir <- function(x, y, ...) {
|
vec_ptype2.sir.sir <- function(x, y, ...) {
|
||||||
|
|||||||
10
R/zzz.R
10
R/zzz.R
@@ -82,10 +82,10 @@ AMR_env$chmatch <- import_fn("chmatch", "data.table", error_on_fail = FALSE)
|
|||||||
AMR_env$chin <- import_fn("%chin%", "data.table", error_on_fail = FALSE)
|
AMR_env$chin <- import_fn("%chin%", "data.table", error_on_fail = FALSE)
|
||||||
|
|
||||||
# take cli symbols and error function if available
|
# take cli symbols and error function if available
|
||||||
AMR_env$bullet_icon <- import_fn("symbol", "cli", error_on_fail = FALSE)$bullet %or% "*"
|
AMR_env$bullet_icon <- import_fn("symbol", "cli", error_on_fail = FALSE)$bullet %or% "*"
|
||||||
AMR_env$ellipsis_icon <- import_fn("symbol", "cli", error_on_fail = FALSE)$ellipsis %or% "..."
|
AMR_env$ellipsis_icon <- import_fn("symbol", "cli", error_on_fail = FALSE)$ellipsis %or% "..."
|
||||||
AMR_env$info_icon <- import_fn("symbol", "cli", error_on_fail = FALSE)$info %or% "i"
|
AMR_env$info_icon <- import_fn("symbol", "cli", error_on_fail = FALSE)$info %or% "i"
|
||||||
AMR_env$sup_1_icon <- import_fn("symbol", "cli", error_on_fail = FALSE)$sup_1 %or% "*"
|
AMR_env$sup_1_icon <- import_fn("symbol", "cli", error_on_fail = FALSE)$sup_1 %or% "*"
|
||||||
|
|
||||||
AMR_env$cli_abort <- import_fn("cli_abort", "cli", error_on_fail = FALSE)
|
AMR_env$cli_abort <- import_fn("cli_abort", "cli", error_on_fail = FALSE)
|
||||||
|
|
||||||
@@ -200,14 +200,14 @@ AMR_env$cross_icon <- if (isTRUE(base::l10n_info()$`UTF-8`)) "\u00d7" else "x"
|
|||||||
if (pkg_is_available("tibble")) {
|
if (pkg_is_available("tibble")) {
|
||||||
try(loadNamespace("tibble"), silent = TRUE)
|
try(loadNamespace("tibble"), silent = TRUE)
|
||||||
}
|
}
|
||||||
|
|
||||||
# reference data - they have additional data to improve algorithm speed
|
# reference data - they have additional data to improve algorithm speed
|
||||||
# they cannot be part of R/sysdata.rda since CRAN thinks it would make the package too large (+3 MB)
|
# they cannot be part of R/sysdata.rda since CRAN thinks it would make the package too large (+3 MB)
|
||||||
if (NROW(AB_LOOKUP) != NROW(AMR::antibiotics)) {
|
if (NROW(AB_LOOKUP) != NROW(AMR::antibiotics)) {
|
||||||
# antibiotics data set was updated - run create_AB_AV_lookup() again
|
# antibiotics data set was updated - run create_AB_AV_lookup() again
|
||||||
AB_LOOKUP <- create_AB_AV_lookup(AMR::antibiotics)
|
AB_LOOKUP <- create_AB_AV_lookup(AMR::antibiotics)
|
||||||
}
|
}
|
||||||
AMR_env$AB_lookup <- cbind(AMR::antibiotics, AB_LOOKUP)
|
AMR_env$AB_lookup <- cbind(AMR::antibiotics, AB_LOOKUP)
|
||||||
AMR_env$AV_lookup <- cbind(AMR::antivirals, AV_LOOKUP)
|
AMR_env$AV_lookup <- cbind(AMR::antivirals, AV_LOOKUP)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
@@ -627,12 +627,15 @@ suppressMessages(set_AMR_locale("English"))
|
|||||||
usethis::ui_info("Checking URLs for redirects")
|
usethis::ui_info("Checking URLs for redirects")
|
||||||
invisible(urlchecker::url_update("."))
|
invisible(urlchecker::url_update("."))
|
||||||
|
|
||||||
|
# Style pkg ---------------------------------------------------------------
|
||||||
|
usethis::ui_info("Styling package")
|
||||||
|
styler::style_pkg(include_roxygen_examples = FALSE,
|
||||||
|
exclude_dirs = list.dirs(full.names = FALSE, recursive = FALSE)[!list.dirs(full.names = FALSE, recursive = FALSE) %in% c("R", "tests")])
|
||||||
|
|
||||||
# Document pkg ------------------------------------------------------------
|
# Document pkg ------------------------------------------------------------
|
||||||
usethis::ui_info("Documenting package")
|
usethis::ui_info("Documenting package")
|
||||||
suppressMessages(devtools::document(quiet = TRUE))
|
suppressMessages(devtools::document(quiet = TRUE))
|
||||||
|
|
||||||
|
|
||||||
# Finished ----------------------------------------------------------------
|
# Finished ----------------------------------------------------------------
|
||||||
usethis::ui_done("All done")
|
usethis::ui_done("All done")
|
||||||
suppressMessages(reset_AMR_locale())
|
suppressMessages(reset_AMR_locale())
|
||||||
|
|||||||
@@ -1,6 +1,6 @@
|
|||||||
This knowledge base contains all context you must know about the AMR package for R. You are a GPT trained to be an assistant for the AMR package in R. You are an incredible R specialist, especially trained in this package and in the tidyverse.
|
This knowledge base contains all context you must know about the AMR package for R. You are a GPT trained to be an assistant for the AMR package in R. You are an incredible R specialist, especially trained in this package and in the tidyverse.
|
||||||
|
|
||||||
First and foremost, you are trained on version 2.1.1.9160. Remember this whenever someone asks which AMR package version you’re at.
|
First and foremost, you are trained on version 2.1.1.9163. Remember this whenever someone asks which AMR package version you’re at.
|
||||||
|
|
||||||
Below are the contents of the file, the file, and all the files (documentation) in the package. Every file content is split using 100 hypens.
|
Below are the contents of the file, the file, and all the files (documentation) in the package. Every file content is split using 100 hypens.
|
||||||
----------------------------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------------------------
|
||||||
@@ -1824,7 +1824,7 @@ Code example:
|
|||||||
\if{html}{\out{<div class="sourceCode r">}}\preformatted{antibiogram(your_data,
|
\if{html}{\out{<div class="sourceCode r">}}\preformatted{antibiogram(your_data,
|
||||||
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
|
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
|
||||||
wisca = TRUE)
|
wisca = TRUE)
|
||||||
|
|
||||||
# this is equal to:
|
# this is equal to:
|
||||||
wisca(your_data,
|
wisca(your_data,
|
||||||
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"))
|
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"))
|
||||||
@@ -1984,12 +1984,14 @@ antibiogram(example_isolates,
|
|||||||
antibiogram(example_isolates,
|
antibiogram(example_isolates,
|
||||||
antibiotics = aminoglycosides(),
|
antibiotics = aminoglycosides(),
|
||||||
ab_transform = "atc",
|
ab_transform = "atc",
|
||||||
mo_transform = "gramstain")
|
mo_transform = "gramstain"
|
||||||
|
)
|
||||||
|
|
||||||
antibiogram(example_isolates,
|
antibiogram(example_isolates,
|
||||||
antibiotics = carbapenems(),
|
antibiotics = carbapenems(),
|
||||||
ab_transform = "name",
|
ab_transform = "name",
|
||||||
mo_transform = "name")
|
mo_transform = "name"
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
# Combined antibiogram -------------------------------------------------
|
# Combined antibiogram -------------------------------------------------
|
||||||
@@ -1997,14 +1999,16 @@ antibiogram(example_isolates,
|
|||||||
# combined antibiotics yield higher empiric coverage
|
# combined antibiotics yield higher empiric coverage
|
||||||
antibiogram(example_isolates,
|
antibiogram(example_isolates,
|
||||||
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
|
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
|
||||||
mo_transform = "gramstain")
|
mo_transform = "gramstain"
|
||||||
|
)
|
||||||
|
|
||||||
# names of antibiotics do not need to resemble columns exactly:
|
# names of antibiotics do not need to resemble columns exactly:
|
||||||
antibiogram(example_isolates,
|
antibiogram(example_isolates,
|
||||||
antibiotics = c("Cipro", "cipro + genta"),
|
antibiotics = c("Cipro", "cipro + genta"),
|
||||||
mo_transform = "gramstain",
|
mo_transform = "gramstain",
|
||||||
ab_transform = "name",
|
ab_transform = "name",
|
||||||
sep = " & ")
|
sep = " & "
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
# Syndromic antibiogram ------------------------------------------------
|
# Syndromic antibiogram ------------------------------------------------
|
||||||
@@ -2012,7 +2016,8 @@ antibiogram(example_isolates,
|
|||||||
# the data set could contain a filter for e.g. respiratory specimens
|
# the data set could contain a filter for e.g. respiratory specimens
|
||||||
antibiogram(example_isolates,
|
antibiogram(example_isolates,
|
||||||
antibiotics = c(aminoglycosides(), carbapenems()),
|
antibiotics = c(aminoglycosides(), carbapenems()),
|
||||||
syndromic_group = "ward")
|
syndromic_group = "ward"
|
||||||
|
)
|
||||||
|
|
||||||
# now define a data set with only E. coli
|
# now define a data set with only E. coli
|
||||||
ex1 <- example_isolates[which(mo_genus() == "Escherichia"), ]
|
ex1 <- example_isolates[which(mo_genus() == "Escherichia"), ]
|
||||||
@@ -2025,7 +2030,8 @@ antibiogram(ex1,
|
|||||||
syndromic_group = ifelse(ex1$ward == "ICU",
|
syndromic_group = ifelse(ex1$ward == "ICU",
|
||||||
"UCI", "No UCI"
|
"UCI", "No UCI"
|
||||||
),
|
),
|
||||||
language = "es")
|
language = "es"
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
# WISCA antibiogram ----------------------------------------------------
|
# WISCA antibiogram ----------------------------------------------------
|
||||||
@@ -2034,7 +2040,8 @@ antibiogram(ex1,
|
|||||||
antibiogram(example_isolates,
|
antibiogram(example_isolates,
|
||||||
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
|
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
|
||||||
syndromic_group = "ward",
|
syndromic_group = "ward",
|
||||||
wisca = TRUE)
|
wisca = TRUE
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
# Print the output for R Markdown / Quarto -----------------------------
|
# Print the output for R Markdown / Quarto -----------------------------
|
||||||
@@ -2042,7 +2049,8 @@ antibiogram(example_isolates,
|
|||||||
ureido <- antibiogram(example_isolates,
|
ureido <- antibiogram(example_isolates,
|
||||||
antibiotics = ureidopenicillins(),
|
antibiotics = ureidopenicillins(),
|
||||||
syndromic_group = "ward",
|
syndromic_group = "ward",
|
||||||
wisca = TRUE)
|
wisca = TRUE
|
||||||
|
)
|
||||||
|
|
||||||
# in an Rmd file, you would just need to return `ureido` in a chunk,
|
# in an Rmd file, you would just need to return `ureido` in a chunk,
|
||||||
# but to be explicit here:
|
# but to be explicit here:
|
||||||
@@ -2055,11 +2063,13 @@ if (requireNamespace("knitr")) {
|
|||||||
|
|
||||||
ab1 <- antibiogram(example_isolates,
|
ab1 <- antibiogram(example_isolates,
|
||||||
antibiotics = c("AMC", "CIP", "TZP", "TZP+TOB"),
|
antibiotics = c("AMC", "CIP", "TZP", "TZP+TOB"),
|
||||||
mo_transform = "gramstain")
|
mo_transform = "gramstain"
|
||||||
|
)
|
||||||
ab2 <- antibiogram(example_isolates,
|
ab2 <- antibiogram(example_isolates,
|
||||||
antibiotics = c("AMC", "CIP", "TZP", "TZP+TOB"),
|
antibiotics = c("AMC", "CIP", "TZP", "TZP+TOB"),
|
||||||
mo_transform = "gramstain",
|
mo_transform = "gramstain",
|
||||||
syndromic_group = "ward")
|
syndromic_group = "ward"
|
||||||
|
)
|
||||||
|
|
||||||
if (requireNamespace("ggplot2")) {
|
if (requireNamespace("ggplot2")) {
|
||||||
ggplot2::autoplot(ab1)
|
ggplot2::autoplot(ab1)
|
||||||
@@ -2181,8 +2191,6 @@ THE PART HEREAFTER CONTAINS CONTENTS FROM FILE 'man/antimicrobial_selectors.Rd':
|
|||||||
% Please edit documentation in R/amr_selectors.R
|
% Please edit documentation in R/amr_selectors.R
|
||||||
\name{antimicrobial_selectors}
|
\name{antimicrobial_selectors}
|
||||||
\alias{antimicrobial_selectors}
|
\alias{antimicrobial_selectors}
|
||||||
\alias{amr_class}
|
|
||||||
\alias{amr_selector}
|
|
||||||
\alias{aminoglycosides}
|
\alias{aminoglycosides}
|
||||||
\alias{aminopenicillins}
|
\alias{aminopenicillins}
|
||||||
\alias{antifungals}
|
\alias{antifungals}
|
||||||
@@ -2214,17 +2222,13 @@ THE PART HEREAFTER CONTAINS CONTENTS FROM FILE 'man/antimicrobial_selectors.Rd':
|
|||||||
\alias{tetracyclines}
|
\alias{tetracyclines}
|
||||||
\alias{trimethoprims}
|
\alias{trimethoprims}
|
||||||
\alias{ureidopenicillins}
|
\alias{ureidopenicillins}
|
||||||
|
\alias{amr_class}
|
||||||
|
\alias{amr_selector}
|
||||||
\alias{administrable_per_os}
|
\alias{administrable_per_os}
|
||||||
\alias{administrable_iv}
|
\alias{administrable_iv}
|
||||||
\alias{not_intrinsic_resistant}
|
\alias{not_intrinsic_resistant}
|
||||||
\title{Antimicrobial Selectors}
|
\title{Antimicrobial Selectors}
|
||||||
\usage{
|
\usage{
|
||||||
amr_class(amr_class, only_sir_columns = FALSE, only_treatable = TRUE,
|
|
||||||
return_all = TRUE, ...)
|
|
||||||
|
|
||||||
amr_selector(filter, only_sir_columns = FALSE, only_treatable = TRUE,
|
|
||||||
return_all = TRUE, ...)
|
|
||||||
|
|
||||||
aminoglycosides(only_sir_columns = FALSE, only_treatable = TRUE,
|
aminoglycosides(only_sir_columns = FALSE, only_treatable = TRUE,
|
||||||
return_all = TRUE, ...)
|
return_all = TRUE, ...)
|
||||||
|
|
||||||
@@ -2293,6 +2297,12 @@ trimethoprims(only_sir_columns = FALSE, return_all = TRUE, ...)
|
|||||||
|
|
||||||
ureidopenicillins(only_sir_columns = FALSE, return_all = TRUE, ...)
|
ureidopenicillins(only_sir_columns = FALSE, return_all = TRUE, ...)
|
||||||
|
|
||||||
|
amr_class(amr_class, only_sir_columns = FALSE, only_treatable = TRUE,
|
||||||
|
return_all = TRUE, ...)
|
||||||
|
|
||||||
|
amr_selector(filter, only_sir_columns = FALSE, only_treatable = TRUE,
|
||||||
|
return_all = TRUE, ...)
|
||||||
|
|
||||||
administrable_per_os(only_sir_columns = FALSE, return_all = TRUE, ...)
|
administrable_per_os(only_sir_columns = FALSE, return_all = TRUE, ...)
|
||||||
|
|
||||||
administrable_iv(only_sir_columns = FALSE, return_all = TRUE, ...)
|
administrable_iv(only_sir_columns = FALSE, return_all = TRUE, ...)
|
||||||
@@ -2301,8 +2311,6 @@ not_intrinsic_resistant(only_sir_columns = FALSE, col_mo = NULL,
|
|||||||
version_expertrules = 3.3, ...)
|
version_expertrules = 3.3, ...)
|
||||||
}
|
}
|
||||||
\arguments{
|
\arguments{
|
||||||
\item{amr_class}{an antimicrobial class or a part of it, such as \code{"carba"} and \code{"carbapenems"}. The columns \code{group}, \code{atc_group1} and \code{atc_group2} of the \link{antibiotics} data set will be searched (case-insensitive) for this value.}
|
|
||||||
|
|
||||||
\item{only_sir_columns}{a \link{logical} to indicate whether only columns of class \code{sir} must be selected (default is \code{FALSE}), see \code{\link[=as.sir]{as.sir()}}}
|
\item{only_sir_columns}{a \link{logical} to indicate whether only columns of class \code{sir} must be selected (default is \code{FALSE}), see \code{\link[=as.sir]{as.sir()}}}
|
||||||
|
|
||||||
\item{only_treatable}{a \link{logical} to indicate whether antimicrobial drugs should be excluded that are only for laboratory tests (default is \code{TRUE}), such as gentamicin-high (\code{GEH}) and imipenem/EDTA (\code{IPE})}
|
\item{only_treatable}{a \link{logical} to indicate whether antimicrobial drugs should be excluded that are only for laboratory tests (default is \code{TRUE}), such as gentamicin-high (\code{GEH}) and imipenem/EDTA (\code{IPE})}
|
||||||
@@ -2311,6 +2319,8 @@ not_intrinsic_resistant(only_sir_columns = FALSE, col_mo = NULL,
|
|||||||
|
|
||||||
\item{...}{ignored, only in place to allow future extensions}
|
\item{...}{ignored, only in place to allow future extensions}
|
||||||
|
|
||||||
|
\item{amr_class}{an antimicrobial class or a part of it, such as \code{"carba"} and \code{"carbapenems"}. The columns \code{group}, \code{atc_group1} and \code{atc_group2} of the \link{antibiotics} data set will be searched (case-insensitive) for this value.}
|
||||||
|
|
||||||
\item{filter}{an \link{expression} to be evaluated in the \link{antibiotics} data set, such as \code{name \%like\% "trim"}}
|
\item{filter}{an \link{expression} to be evaluated in the \link{antibiotics} data set, such as \code{name \%like\% "trim"}}
|
||||||
|
|
||||||
\item{col_mo}{column name of the names or codes of the microorganisms (see \code{\link[=as.mo]{as.mo()}}) - the default is the first column of class \code{\link{mo}}. Values will be coerced using \code{\link[=as.mo]{as.mo()}}.}
|
\item{col_mo}{column name of the names or codes of the microorganisms (see \code{\link[=as.mo]{as.mo()}}) - the default is the first column of class \code{\link{mo}}. Values will be coerced using \code{\link[=as.mo]{as.mo()}}.}
|
||||||
@@ -2339,10 +2349,10 @@ All columns in the data in which these functions are called will be searched for
|
|||||||
|
|
||||||
The \code{\link[=amr_class]{amr_class()}} function can be used to filter/select on a manually defined antimicrobial class. It searches for results in the \link{antibiotics} data set within the columns \code{group}, \code{atc_group1} and \code{atc_group2}.
|
The \code{\link[=amr_class]{amr_class()}} function can be used to filter/select on a manually defined antimicrobial class. It searches for results in the \link{antibiotics} data set within the columns \code{group}, \code{atc_group1} and \code{atc_group2}.
|
||||||
|
|
||||||
The \code{\link[=amr_selector]{amr_selector()}} function can be used to internally filter the \link{antibiotics} data set on any results, see \emph{Examples}. It allows for filtering on a (part of) a certain name, and/or a group name or even a minimum of DDDs for oral treatment. This function yields the highest flexibility, but is also the least user-friendly, since it requires a hard-coded filter to set.
|
|
||||||
|
|
||||||
The \code{\link[=administrable_per_os]{administrable_per_os()}} and \code{\link[=administrable_iv]{administrable_iv()}} functions also rely on the \link{antibiotics} data set - antimicrobials will be matched where a DDD (defined daily dose) for resp. oral and IV treatment is available in the \link{antibiotics} data set.
|
The \code{\link[=administrable_per_os]{administrable_per_os()}} and \code{\link[=administrable_iv]{administrable_iv()}} functions also rely on the \link{antibiotics} data set - antimicrobials will be matched where a DDD (defined daily dose) for resp. oral and IV treatment is available in the \link{antibiotics} data set.
|
||||||
|
|
||||||
|
The \code{\link[=amr_selector]{amr_selector()}} function can be used to internally filter the \link{antibiotics} data set on any results, see \emph{Examples}. It allows for filtering on a (part of) a certain name, and/or a group name or even a minimum of DDDs for oral treatment. This function yields the highest flexibility, but is also the least user-friendly, since it requires a hard-coded filter to set.
|
||||||
|
|
||||||
The \code{\link[=not_intrinsic_resistant]{not_intrinsic_resistant()}} function can be used to only select antimicrobials that pose no intrinsic resistance for the microorganisms in the data set. For example, if a data set contains only microorganism codes or names of \emph{E. coli} and \emph{K. pneumoniae} and contains a column "vancomycin", this column will be removed (or rather, unselected) using this function. It currently applies \href{https://www.eucast.org/expert_rules_and_expected_phenotypes}{'EUCAST Expert Rules' and 'EUCAST Intrinsic Resistance and Unusual Phenotypes' v3.3} (2021) to determine intrinsic resistance, using the \code{\link[=eucast_rules]{eucast_rules()}} function internally. Because of this determination, this function is quite slow in terms of performance.
|
The \code{\link[=not_intrinsic_resistant]{not_intrinsic_resistant()}} function can be used to only select antimicrobials that pose no intrinsic resistance for the microorganisms in the data set. For example, if a data set contains only microorganism codes or names of \emph{E. coli} and \emph{K. pneumoniae} and contains a column "vancomycin", this column will be removed (or rather, unselected) using this function. It currently applies \href{https://www.eucast.org/expert_rules_and_expected_phenotypes}{'EUCAST Expert Rules' and 'EUCAST Intrinsic Resistance and Unusual Phenotypes' v3.3} (2021) to determine intrinsic resistance, using the \code{\link[=eucast_rules]{eucast_rules()}} function internally. Because of this determination, this function is quite slow in terms of performance.
|
||||||
}
|
}
|
||||||
\section{Full list of supported (antimicrobial) classes}{
|
\section{Full list of supported (antimicrobial) classes}{
|
||||||
@@ -3533,69 +3543,97 @@ if (require("dplyr")) {
|
|||||||
df_wide \%>\% mutate(across(where(is.mic), as.sir))
|
df_wide \%>\% mutate(across(where(is.mic), as.sir))
|
||||||
df_wide \%>\% mutate_at(vars(amoxicillin:tobra), as.sir)
|
df_wide \%>\% mutate_at(vars(amoxicillin:tobra), as.sir)
|
||||||
df_wide \%>\% mutate(across(amoxicillin:tobra, as.sir))
|
df_wide \%>\% mutate(across(amoxicillin:tobra, as.sir))
|
||||||
|
|
||||||
# approaches that all work with additional arguments:
|
# approaches that all work with additional arguments:
|
||||||
df_long \%>\%
|
df_long \%>\%
|
||||||
# given a certain data type, e.g. MIC values
|
# given a certain data type, e.g. MIC values
|
||||||
mutate_if(is.mic, as.sir,
|
mutate_if(is.mic, as.sir,
|
||||||
mo = "bacteria",
|
mo = "bacteria",
|
||||||
ab = "antibiotic",
|
ab = "antibiotic",
|
||||||
guideline = "CLSI")
|
guideline = "CLSI"
|
||||||
|
)
|
||||||
df_long \%>\%
|
df_long \%>\%
|
||||||
mutate(across(where(is.mic),
|
mutate(across(
|
||||||
function(x) as.sir(x,
|
where(is.mic),
|
||||||
mo = "bacteria",
|
function(x) {
|
||||||
ab = "antibiotic",
|
as.sir(x,
|
||||||
guideline = "CLSI")))
|
mo = "bacteria",
|
||||||
|
ab = "antibiotic",
|
||||||
|
guideline = "CLSI"
|
||||||
|
)
|
||||||
|
}
|
||||||
|
))
|
||||||
df_wide \%>\%
|
df_wide \%>\%
|
||||||
# given certain columns, e.g. from 'cipro' to 'genta'
|
# given certain columns, e.g. from 'cipro' to 'genta'
|
||||||
mutate_at(vars(cipro:genta), as.sir,
|
mutate_at(vars(cipro:genta), as.sir,
|
||||||
mo = "bacteria",
|
mo = "bacteria",
|
||||||
guideline = "CLSI")
|
guideline = "CLSI"
|
||||||
|
)
|
||||||
df_wide \%>\%
|
df_wide \%>\%
|
||||||
mutate(across(cipro:genta,
|
mutate(across(
|
||||||
function(x) as.sir(x,
|
cipro:genta,
|
||||||
mo = "bacteria",
|
function(x) {
|
||||||
guideline = "CLSI")))
|
as.sir(x,
|
||||||
|
mo = "bacteria",
|
||||||
|
guideline = "CLSI"
|
||||||
|
)
|
||||||
|
}
|
||||||
|
))
|
||||||
|
|
||||||
# for veterinary breakpoints, add 'host':
|
# for veterinary breakpoints, add 'host':
|
||||||
df_long$animal_species <- c("cats", "dogs", "horses", "cattle")
|
df_long$animal_species <- c("cats", "dogs", "horses", "cattle")
|
||||||
df_long \%>\%
|
df_long \%>\%
|
||||||
# given a certain data type, e.g. MIC values
|
# given a certain data type, e.g. MIC values
|
||||||
mutate_if(is.mic, as.sir,
|
mutate_if(is.mic, as.sir,
|
||||||
mo = "bacteria",
|
mo = "bacteria",
|
||||||
ab = "antibiotic",
|
ab = "antibiotic",
|
||||||
host = "animal_species",
|
host = "animal_species",
|
||||||
guideline = "CLSI")
|
guideline = "CLSI"
|
||||||
|
)
|
||||||
df_long \%>\%
|
df_long \%>\%
|
||||||
mutate(across(where(is.mic),
|
mutate(across(
|
||||||
function(x) as.sir(x,
|
where(is.mic),
|
||||||
mo = "bacteria",
|
function(x) {
|
||||||
ab = "antibiotic",
|
as.sir(x,
|
||||||
host = "animal_species",
|
mo = "bacteria",
|
||||||
guideline = "CLSI")))
|
ab = "antibiotic",
|
||||||
|
host = "animal_species",
|
||||||
|
guideline = "CLSI"
|
||||||
|
)
|
||||||
|
}
|
||||||
|
))
|
||||||
df_wide \%>\%
|
df_wide \%>\%
|
||||||
mutate_at(vars(cipro:genta), as.sir,
|
mutate_at(vars(cipro:genta), as.sir,
|
||||||
mo = "bacteria",
|
mo = "bacteria",
|
||||||
ab = "antibiotic",
|
ab = "antibiotic",
|
||||||
host = "animal_species",
|
host = "animal_species",
|
||||||
guideline = "CLSI")
|
guideline = "CLSI"
|
||||||
|
)
|
||||||
df_wide \%>\%
|
df_wide \%>\%
|
||||||
mutate(across(cipro:genta,
|
mutate(across(
|
||||||
function(x) as.sir(x,
|
cipro:genta,
|
||||||
mo = "bacteria",
|
function(x) {
|
||||||
host = "animal_species",
|
as.sir(x,
|
||||||
guideline = "CLSI")))
|
mo = "bacteria",
|
||||||
|
host = "animal_species",
|
||||||
|
guideline = "CLSI"
|
||||||
|
)
|
||||||
|
}
|
||||||
|
))
|
||||||
|
|
||||||
# to include information about urinary tract infections (UTI)
|
# to include information about urinary tract infections (UTI)
|
||||||
data.frame(mo = "E. coli",
|
data.frame(
|
||||||
nitrofuratoin = c("<= 2", 32),
|
mo = "E. coli",
|
||||||
from_the_bladder = c(TRUE, FALSE)) \%>\%
|
nitrofuratoin = c("<= 2", 32),
|
||||||
|
from_the_bladder = c(TRUE, FALSE)
|
||||||
|
) \%>\%
|
||||||
as.sir(uti = "from_the_bladder")
|
as.sir(uti = "from_the_bladder")
|
||||||
|
|
||||||
data.frame(mo = "E. coli",
|
data.frame(
|
||||||
nitrofuratoin = c("<= 2", 32),
|
mo = "E. coli",
|
||||||
specimen = c("urine", "blood")) \%>\%
|
nitrofuratoin = c("<= 2", 32),
|
||||||
|
specimen = c("urine", "blood")
|
||||||
|
) \%>\%
|
||||||
as.sir() # automatically determines urine isolates
|
as.sir() # automatically determines urine isolates
|
||||||
|
|
||||||
df_wide \%>\%
|
df_wide \%>\%
|
||||||
@@ -4438,7 +4476,7 @@ Rules can also be applied to multiple antibiotics and antibiotic groups simultan
|
|||||||
\if{html}{\out{<div class="sourceCode r">}}\preformatted{x <- custom_eucast_rules(TZP == "R" ~ c(aminopenicillins, ureidopenicillins) == "R")
|
\if{html}{\out{<div class="sourceCode r">}}\preformatted{x <- custom_eucast_rules(TZP == "R" ~ c(aminopenicillins, ureidopenicillins) == "R")
|
||||||
x
|
x
|
||||||
#> A set of custom EUCAST rules:
|
#> A set of custom EUCAST rules:
|
||||||
#>
|
#>
|
||||||
#> 1. If TZP is "R" then set to "R":
|
#> 1. If TZP is "R" then set to "R":
|
||||||
#> amoxicillin (AMX), ampicillin (AMP), azlocillin (AZL), mezlocillin (MEZ), piperacillin (PIP), piperacillin/tazobactam (TZP)
|
#> amoxicillin (AMX), ampicillin (AMP), azlocillin (AZL), mezlocillin (MEZ), piperacillin (PIP), piperacillin/tazobactam (TZP)
|
||||||
}\if{html}{\out{</div>}}
|
}\if{html}{\out{</div>}}
|
||||||
@@ -5624,8 +5662,10 @@ if (require("ggplot2") && require("dplyr")) {
|
|||||||
) \%>\%
|
) \%>\%
|
||||||
ggplot() +
|
ggplot() +
|
||||||
geom_col(aes(x = x, y = y, fill = z)) +
|
geom_col(aes(x = x, y = y, fill = z)) +
|
||||||
scale_sir_colours(aesthetics = "fill",
|
scale_sir_colours(
|
||||||
Value4 = "S", Value5 = "I", Value6 = "R")
|
aesthetics = "fill",
|
||||||
|
Value4 = "S", Value5 = "I", Value6 = "R"
|
||||||
|
)
|
||||||
}
|
}
|
||||||
if (require("ggplot2") && require("dplyr")) {
|
if (require("ggplot2") && require("dplyr")) {
|
||||||
# resistance of ciprofloxacine per age group
|
# resistance of ciprofloxacine per age group
|
||||||
@@ -7031,10 +7071,12 @@ mo_rank("Klebsiella pneumoniae")
|
|||||||
mo_url("Klebsiella pneumoniae")
|
mo_url("Klebsiella pneumoniae")
|
||||||
mo_is_yeast(c("Candida", "Trichophyton", "Klebsiella"))
|
mo_is_yeast(c("Candida", "Trichophyton", "Klebsiella"))
|
||||||
|
|
||||||
mo_group_members(c("Streptococcus group A",
|
mo_group_members(c(
|
||||||
"Streptococcus group C",
|
"Streptococcus group A",
|
||||||
"Streptococcus group G",
|
"Streptococcus group C",
|
||||||
"Streptococcus group L"))
|
"Streptococcus group G",
|
||||||
|
"Streptococcus group L"
|
||||||
|
))
|
||||||
|
|
||||||
|
|
||||||
# scientific reference -----------------------------------------------------
|
# scientific reference -----------------------------------------------------
|
||||||
@@ -7547,7 +7589,6 @@ some_mic_values <- random_mic(size = 100)
|
|||||||
some_disk_values <- random_disk(size = 100, mo = "Escherichia coli", ab = "cipro")
|
some_disk_values <- random_disk(size = 100, mo = "Escherichia coli", ab = "cipro")
|
||||||
some_sir_values <- random_sir(50, prob_SIR = c(0.55, 0.05, 0.30))
|
some_sir_values <- random_sir(50, prob_SIR = c(0.55, 0.05, 0.30))
|
||||||
|
|
||||||
|
|
||||||
\donttest{
|
\donttest{
|
||||||
# Plotting using ggplot2's autoplot() for MIC, disk, and SIR -----------
|
# Plotting using ggplot2's autoplot() for MIC, disk, and SIR -----------
|
||||||
if (require("ggplot2")) {
|
if (require("ggplot2")) {
|
||||||
@@ -7559,17 +7600,23 @@ if (require("ggplot2")) {
|
|||||||
}
|
}
|
||||||
if (require("ggplot2")) {
|
if (require("ggplot2")) {
|
||||||
# support for 20 languages, various guidelines, and many options
|
# support for 20 languages, various guidelines, and many options
|
||||||
autoplot(some_disk_values, mo = "Escherichia coli", ab = "cipro",
|
autoplot(some_disk_values,
|
||||||
guideline = "CLSI 2024", language = "no",
|
mo = "Escherichia coli", ab = "cipro",
|
||||||
title = "Disk diffusion from the North")
|
guideline = "CLSI 2024", language = "no",
|
||||||
|
title = "Disk diffusion from the North"
|
||||||
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
# Plotting using scale_x_mic() -----------------------------------------
|
# Plotting using scale_x_mic() -----------------------------------------
|
||||||
if (require("ggplot2")) {
|
if (require("ggplot2")) {
|
||||||
mic_plot <- ggplot(data.frame(mics = as.mic(c(0.25, "<=4", 4, 8, 32, ">=32")),
|
mic_plot <- ggplot(
|
||||||
counts = c(1, 1, 2, 2, 3, 3)),
|
data.frame(
|
||||||
aes(mics, counts)) +
|
mics = as.mic(c(0.25, "<=4", 4, 8, 32, ">=32")),
|
||||||
|
counts = c(1, 1, 2, 2, 3, 3)
|
||||||
|
),
|
||||||
|
aes(mics, counts)
|
||||||
|
) +
|
||||||
geom_col()
|
geom_col()
|
||||||
mic_plot +
|
mic_plot +
|
||||||
labs(title = "without scale_x_mic()")
|
labs(title = "without scale_x_mic()")
|
||||||
@@ -7600,17 +7647,25 @@ if (require("ggplot2")) {
|
|||||||
some_groups <- sample(LETTERS[1:5], 20, replace = TRUE)
|
some_groups <- sample(LETTERS[1:5], 20, replace = TRUE)
|
||||||
|
|
||||||
if (require("ggplot2")) {
|
if (require("ggplot2")) {
|
||||||
ggplot(data.frame(mic = some_mic_values,
|
ggplot(
|
||||||
group = some_groups),
|
data.frame(
|
||||||
aes(group, mic)) +
|
mic = some_mic_values,
|
||||||
|
group = some_groups
|
||||||
|
),
|
||||||
|
aes(group, mic)
|
||||||
|
) +
|
||||||
geom_boxplot() +
|
geom_boxplot() +
|
||||||
geom_violin(linetype = 2, colour = "grey", fill = NA) +
|
geom_violin(linetype = 2, colour = "grey", fill = NA) +
|
||||||
scale_y_mic()
|
scale_y_mic()
|
||||||
}
|
}
|
||||||
if (require("ggplot2")) {
|
if (require("ggplot2")) {
|
||||||
ggplot(data.frame(mic = some_mic_values,
|
ggplot(
|
||||||
group = some_groups),
|
data.frame(
|
||||||
aes(group, mic)) +
|
mic = some_mic_values,
|
||||||
|
group = some_groups
|
||||||
|
),
|
||||||
|
aes(group, mic)
|
||||||
|
) +
|
||||||
geom_boxplot() +
|
geom_boxplot() +
|
||||||
geom_violin(linetype = 2, colour = "grey", fill = NA) +
|
geom_violin(linetype = 2, colour = "grey", fill = NA) +
|
||||||
scale_y_mic(mic_range = c(NA, 0.25))
|
scale_y_mic(mic_range = c(NA, 0.25))
|
||||||
@@ -7619,9 +7674,13 @@ if (require("ggplot2")) {
|
|||||||
|
|
||||||
# Plotting using scale_x_sir() -----------------------------------------
|
# Plotting using scale_x_sir() -----------------------------------------
|
||||||
if (require("ggplot2")) {
|
if (require("ggplot2")) {
|
||||||
ggplot(data.frame(x = c("I", "R", "S"),
|
ggplot(
|
||||||
y = c(45,323, 573)),
|
data.frame(
|
||||||
aes(x, y)) +
|
x = c("I", "R", "S"),
|
||||||
|
y = c(45, 323, 573)
|
||||||
|
),
|
||||||
|
aes(x, y)
|
||||||
|
) +
|
||||||
geom_col() +
|
geom_col() +
|
||||||
scale_x_sir()
|
scale_x_sir()
|
||||||
}
|
}
|
||||||
@@ -7629,16 +7688,21 @@ if (require("ggplot2")) {
|
|||||||
|
|
||||||
# Plotting using scale_y_mic() and scale_colour_sir() ------------------
|
# Plotting using scale_y_mic() and scale_colour_sir() ------------------
|
||||||
if (require("ggplot2")) {
|
if (require("ggplot2")) {
|
||||||
plain <- ggplot(data.frame(mic = some_mic_values,
|
plain <- ggplot(
|
||||||
group = some_groups,
|
data.frame(
|
||||||
sir = as.sir(some_mic_values,
|
mic = some_mic_values,
|
||||||
mo = "E. coli",
|
group = some_groups,
|
||||||
ab = "cipro")),
|
sir = as.sir(some_mic_values,
|
||||||
aes(x = group, y = mic, colour = sir)) +
|
mo = "E. coli",
|
||||||
|
ab = "cipro"
|
||||||
|
)
|
||||||
|
),
|
||||||
|
aes(x = group, y = mic, colour = sir)
|
||||||
|
) +
|
||||||
theme_minimal() +
|
theme_minimal() +
|
||||||
geom_boxplot(fill = NA, colour = "grey") +
|
geom_boxplot(fill = NA, colour = "grey") +
|
||||||
geom_jitter(width = 0.25)
|
geom_jitter(width = 0.25)
|
||||||
|
|
||||||
plain
|
plain
|
||||||
}
|
}
|
||||||
if (require("ggplot2")) {
|
if (require("ggplot2")) {
|
||||||
@@ -7650,8 +7714,10 @@ if (require("ggplot2")) {
|
|||||||
if (require("ggplot2")) {
|
if (require("ggplot2")) {
|
||||||
plain +
|
plain +
|
||||||
scale_y_mic(mic_range = c(0.005, 32), name = "Our MICs!") +
|
scale_y_mic(mic_range = c(0.005, 32), name = "Our MICs!") +
|
||||||
scale_colour_sir(language = "pt",
|
scale_colour_sir(
|
||||||
name = "Support in 20 languages")
|
language = "pt",
|
||||||
|
name = "Support in 20 languages"
|
||||||
|
)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -8247,15 +8313,18 @@ This function is useful for preprocessing data before creating \link[=antibiogra
|
|||||||
\examples{
|
\examples{
|
||||||
# filter to the top 3 species:
|
# filter to the top 3 species:
|
||||||
top_n_microorganisms(example_isolates,
|
top_n_microorganisms(example_isolates,
|
||||||
n = 3)
|
n = 3
|
||||||
|
)
|
||||||
|
|
||||||
# filter to any species in the top 5 genera:
|
# filter to any species in the top 5 genera:
|
||||||
top_n_microorganisms(example_isolates,
|
top_n_microorganisms(example_isolates,
|
||||||
n = 5, property = "genus")
|
n = 5, property = "genus"
|
||||||
|
)
|
||||||
|
|
||||||
# filter to the top 3 species in each of the top 5 genera:
|
# filter to the top 3 species in each of the top 5 genera:
|
||||||
top_n_microorganisms(example_isolates,
|
top_n_microorganisms(example_isolates,
|
||||||
n = 5, property = "genus", n_for_each = 3)
|
n = 5, property = "genus", n_for_each = 3
|
||||||
|
)
|
||||||
}
|
}
|
||||||
\seealso{
|
\seealso{
|
||||||
\code{\link[=mo_property]{mo_property()}}, \code{\link[=as.mo]{as.mo()}}, \code{\link[=antibiogram]{antibiogram()}}
|
\code{\link[=mo_property]{mo_property()}}, \code{\link[=as.mo]{as.mo()}}, \code{\link[=antibiogram]{antibiogram()}}
|
||||||
@@ -183,7 +183,7 @@ Code example:
|
|||||||
\if{html}{\out{<div class="sourceCode r">}}\preformatted{antibiogram(your_data,
|
\if{html}{\out{<div class="sourceCode r">}}\preformatted{antibiogram(your_data,
|
||||||
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
|
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
|
||||||
wisca = TRUE)
|
wisca = TRUE)
|
||||||
|
|
||||||
# this is equal to:
|
# this is equal to:
|
||||||
wisca(your_data,
|
wisca(your_data,
|
||||||
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"))
|
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"))
|
||||||
@@ -343,12 +343,14 @@ antibiogram(example_isolates,
|
|||||||
antibiogram(example_isolates,
|
antibiogram(example_isolates,
|
||||||
antibiotics = aminoglycosides(),
|
antibiotics = aminoglycosides(),
|
||||||
ab_transform = "atc",
|
ab_transform = "atc",
|
||||||
mo_transform = "gramstain")
|
mo_transform = "gramstain"
|
||||||
|
)
|
||||||
|
|
||||||
antibiogram(example_isolates,
|
antibiogram(example_isolates,
|
||||||
antibiotics = carbapenems(),
|
antibiotics = carbapenems(),
|
||||||
ab_transform = "name",
|
ab_transform = "name",
|
||||||
mo_transform = "name")
|
mo_transform = "name"
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
# Combined antibiogram -------------------------------------------------
|
# Combined antibiogram -------------------------------------------------
|
||||||
@@ -356,14 +358,16 @@ antibiogram(example_isolates,
|
|||||||
# combined antibiotics yield higher empiric coverage
|
# combined antibiotics yield higher empiric coverage
|
||||||
antibiogram(example_isolates,
|
antibiogram(example_isolates,
|
||||||
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
|
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
|
||||||
mo_transform = "gramstain")
|
mo_transform = "gramstain"
|
||||||
|
)
|
||||||
|
|
||||||
# names of antibiotics do not need to resemble columns exactly:
|
# names of antibiotics do not need to resemble columns exactly:
|
||||||
antibiogram(example_isolates,
|
antibiogram(example_isolates,
|
||||||
antibiotics = c("Cipro", "cipro + genta"),
|
antibiotics = c("Cipro", "cipro + genta"),
|
||||||
mo_transform = "gramstain",
|
mo_transform = "gramstain",
|
||||||
ab_transform = "name",
|
ab_transform = "name",
|
||||||
sep = " & ")
|
sep = " & "
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
# Syndromic antibiogram ------------------------------------------------
|
# Syndromic antibiogram ------------------------------------------------
|
||||||
@@ -371,7 +375,8 @@ antibiogram(example_isolates,
|
|||||||
# the data set could contain a filter for e.g. respiratory specimens
|
# the data set could contain a filter for e.g. respiratory specimens
|
||||||
antibiogram(example_isolates,
|
antibiogram(example_isolates,
|
||||||
antibiotics = c(aminoglycosides(), carbapenems()),
|
antibiotics = c(aminoglycosides(), carbapenems()),
|
||||||
syndromic_group = "ward")
|
syndromic_group = "ward"
|
||||||
|
)
|
||||||
|
|
||||||
# now define a data set with only E. coli
|
# now define a data set with only E. coli
|
||||||
ex1 <- example_isolates[which(mo_genus() == "Escherichia"), ]
|
ex1 <- example_isolates[which(mo_genus() == "Escherichia"), ]
|
||||||
@@ -384,7 +389,8 @@ antibiogram(ex1,
|
|||||||
syndromic_group = ifelse(ex1$ward == "ICU",
|
syndromic_group = ifelse(ex1$ward == "ICU",
|
||||||
"UCI", "No UCI"
|
"UCI", "No UCI"
|
||||||
),
|
),
|
||||||
language = "es")
|
language = "es"
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
# WISCA antibiogram ----------------------------------------------------
|
# WISCA antibiogram ----------------------------------------------------
|
||||||
@@ -393,7 +399,8 @@ antibiogram(ex1,
|
|||||||
antibiogram(example_isolates,
|
antibiogram(example_isolates,
|
||||||
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
|
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
|
||||||
syndromic_group = "ward",
|
syndromic_group = "ward",
|
||||||
wisca = TRUE)
|
wisca = TRUE
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
# Print the output for R Markdown / Quarto -----------------------------
|
# Print the output for R Markdown / Quarto -----------------------------
|
||||||
@@ -401,7 +408,8 @@ antibiogram(example_isolates,
|
|||||||
ureido <- antibiogram(example_isolates,
|
ureido <- antibiogram(example_isolates,
|
||||||
antibiotics = ureidopenicillins(),
|
antibiotics = ureidopenicillins(),
|
||||||
syndromic_group = "ward",
|
syndromic_group = "ward",
|
||||||
wisca = TRUE)
|
wisca = TRUE
|
||||||
|
)
|
||||||
|
|
||||||
# in an Rmd file, you would just need to return `ureido` in a chunk,
|
# in an Rmd file, you would just need to return `ureido` in a chunk,
|
||||||
# but to be explicit here:
|
# but to be explicit here:
|
||||||
@@ -414,11 +422,13 @@ if (requireNamespace("knitr")) {
|
|||||||
|
|
||||||
ab1 <- antibiogram(example_isolates,
|
ab1 <- antibiogram(example_isolates,
|
||||||
antibiotics = c("AMC", "CIP", "TZP", "TZP+TOB"),
|
antibiotics = c("AMC", "CIP", "TZP", "TZP+TOB"),
|
||||||
mo_transform = "gramstain")
|
mo_transform = "gramstain"
|
||||||
|
)
|
||||||
ab2 <- antibiogram(example_isolates,
|
ab2 <- antibiogram(example_isolates,
|
||||||
antibiotics = c("AMC", "CIP", "TZP", "TZP+TOB"),
|
antibiotics = c("AMC", "CIP", "TZP", "TZP+TOB"),
|
||||||
mo_transform = "gramstain",
|
mo_transform = "gramstain",
|
||||||
syndromic_group = "ward")
|
syndromic_group = "ward"
|
||||||
|
)
|
||||||
|
|
||||||
if (requireNamespace("ggplot2")) {
|
if (requireNamespace("ggplot2")) {
|
||||||
ggplot2::autoplot(ab1)
|
ggplot2::autoplot(ab1)
|
||||||
|
|||||||
@@ -2,8 +2,6 @@
|
|||||||
% Please edit documentation in R/amr_selectors.R
|
% Please edit documentation in R/amr_selectors.R
|
||||||
\name{antimicrobial_selectors}
|
\name{antimicrobial_selectors}
|
||||||
\alias{antimicrobial_selectors}
|
\alias{antimicrobial_selectors}
|
||||||
\alias{amr_class}
|
|
||||||
\alias{amr_selector}
|
|
||||||
\alias{aminoglycosides}
|
\alias{aminoglycosides}
|
||||||
\alias{aminopenicillins}
|
\alias{aminopenicillins}
|
||||||
\alias{antifungals}
|
\alias{antifungals}
|
||||||
@@ -35,17 +33,13 @@
|
|||||||
\alias{tetracyclines}
|
\alias{tetracyclines}
|
||||||
\alias{trimethoprims}
|
\alias{trimethoprims}
|
||||||
\alias{ureidopenicillins}
|
\alias{ureidopenicillins}
|
||||||
|
\alias{amr_class}
|
||||||
|
\alias{amr_selector}
|
||||||
\alias{administrable_per_os}
|
\alias{administrable_per_os}
|
||||||
\alias{administrable_iv}
|
\alias{administrable_iv}
|
||||||
\alias{not_intrinsic_resistant}
|
\alias{not_intrinsic_resistant}
|
||||||
\title{Antimicrobial Selectors}
|
\title{Antimicrobial Selectors}
|
||||||
\usage{
|
\usage{
|
||||||
amr_class(amr_class, only_sir_columns = FALSE, only_treatable = TRUE,
|
|
||||||
return_all = TRUE, ...)
|
|
||||||
|
|
||||||
amr_selector(filter, only_sir_columns = FALSE, only_treatable = TRUE,
|
|
||||||
return_all = TRUE, ...)
|
|
||||||
|
|
||||||
aminoglycosides(only_sir_columns = FALSE, only_treatable = TRUE,
|
aminoglycosides(only_sir_columns = FALSE, only_treatable = TRUE,
|
||||||
return_all = TRUE, ...)
|
return_all = TRUE, ...)
|
||||||
|
|
||||||
@@ -114,6 +108,12 @@ trimethoprims(only_sir_columns = FALSE, return_all = TRUE, ...)
|
|||||||
|
|
||||||
ureidopenicillins(only_sir_columns = FALSE, return_all = TRUE, ...)
|
ureidopenicillins(only_sir_columns = FALSE, return_all = TRUE, ...)
|
||||||
|
|
||||||
|
amr_class(amr_class, only_sir_columns = FALSE, only_treatable = TRUE,
|
||||||
|
return_all = TRUE, ...)
|
||||||
|
|
||||||
|
amr_selector(filter, only_sir_columns = FALSE, only_treatable = TRUE,
|
||||||
|
return_all = TRUE, ...)
|
||||||
|
|
||||||
administrable_per_os(only_sir_columns = FALSE, return_all = TRUE, ...)
|
administrable_per_os(only_sir_columns = FALSE, return_all = TRUE, ...)
|
||||||
|
|
||||||
administrable_iv(only_sir_columns = FALSE, return_all = TRUE, ...)
|
administrable_iv(only_sir_columns = FALSE, return_all = TRUE, ...)
|
||||||
@@ -122,8 +122,6 @@ not_intrinsic_resistant(only_sir_columns = FALSE, col_mo = NULL,
|
|||||||
version_expertrules = 3.3, ...)
|
version_expertrules = 3.3, ...)
|
||||||
}
|
}
|
||||||
\arguments{
|
\arguments{
|
||||||
\item{amr_class}{an antimicrobial class or a part of it, such as \code{"carba"} and \code{"carbapenems"}. The columns \code{group}, \code{atc_group1} and \code{atc_group2} of the \link{antibiotics} data set will be searched (case-insensitive) for this value.}
|
|
||||||
|
|
||||||
\item{only_sir_columns}{a \link{logical} to indicate whether only columns of class \code{sir} must be selected (default is \code{FALSE}), see \code{\link[=as.sir]{as.sir()}}}
|
\item{only_sir_columns}{a \link{logical} to indicate whether only columns of class \code{sir} must be selected (default is \code{FALSE}), see \code{\link[=as.sir]{as.sir()}}}
|
||||||
|
|
||||||
\item{only_treatable}{a \link{logical} to indicate whether antimicrobial drugs should be excluded that are only for laboratory tests (default is \code{TRUE}), such as gentamicin-high (\code{GEH}) and imipenem/EDTA (\code{IPE})}
|
\item{only_treatable}{a \link{logical} to indicate whether antimicrobial drugs should be excluded that are only for laboratory tests (default is \code{TRUE}), such as gentamicin-high (\code{GEH}) and imipenem/EDTA (\code{IPE})}
|
||||||
@@ -132,6 +130,8 @@ not_intrinsic_resistant(only_sir_columns = FALSE, col_mo = NULL,
|
|||||||
|
|
||||||
\item{...}{ignored, only in place to allow future extensions}
|
\item{...}{ignored, only in place to allow future extensions}
|
||||||
|
|
||||||
|
\item{amr_class}{an antimicrobial class or a part of it, such as \code{"carba"} and \code{"carbapenems"}. The columns \code{group}, \code{atc_group1} and \code{atc_group2} of the \link{antibiotics} data set will be searched (case-insensitive) for this value.}
|
||||||
|
|
||||||
\item{filter}{an \link{expression} to be evaluated in the \link{antibiotics} data set, such as \code{name \%like\% "trim"}}
|
\item{filter}{an \link{expression} to be evaluated in the \link{antibiotics} data set, such as \code{name \%like\% "trim"}}
|
||||||
|
|
||||||
\item{col_mo}{column name of the names or codes of the microorganisms (see \code{\link[=as.mo]{as.mo()}}) - the default is the first column of class \code{\link{mo}}. Values will be coerced using \code{\link[=as.mo]{as.mo()}}.}
|
\item{col_mo}{column name of the names or codes of the microorganisms (see \code{\link[=as.mo]{as.mo()}}) - the default is the first column of class \code{\link{mo}}. Values will be coerced using \code{\link[=as.mo]{as.mo()}}.}
|
||||||
@@ -160,10 +160,10 @@ All columns in the data in which these functions are called will be searched for
|
|||||||
|
|
||||||
The \code{\link[=amr_class]{amr_class()}} function can be used to filter/select on a manually defined antimicrobial class. It searches for results in the \link{antibiotics} data set within the columns \code{group}, \code{atc_group1} and \code{atc_group2}.
|
The \code{\link[=amr_class]{amr_class()}} function can be used to filter/select on a manually defined antimicrobial class. It searches for results in the \link{antibiotics} data set within the columns \code{group}, \code{atc_group1} and \code{atc_group2}.
|
||||||
|
|
||||||
The \code{\link[=amr_selector]{amr_selector()}} function can be used to internally filter the \link{antibiotics} data set on any results, see \emph{Examples}. It allows for filtering on a (part of) a certain name, and/or a group name or even a minimum of DDDs for oral treatment. This function yields the highest flexibility, but is also the least user-friendly, since it requires a hard-coded filter to set.
|
|
||||||
|
|
||||||
The \code{\link[=administrable_per_os]{administrable_per_os()}} and \code{\link[=administrable_iv]{administrable_iv()}} functions also rely on the \link{antibiotics} data set - antimicrobials will be matched where a DDD (defined daily dose) for resp. oral and IV treatment is available in the \link{antibiotics} data set.
|
The \code{\link[=administrable_per_os]{administrable_per_os()}} and \code{\link[=administrable_iv]{administrable_iv()}} functions also rely on the \link{antibiotics} data set - antimicrobials will be matched where a DDD (defined daily dose) for resp. oral and IV treatment is available in the \link{antibiotics} data set.
|
||||||
|
|
||||||
|
The \code{\link[=amr_selector]{amr_selector()}} function can be used to internally filter the \link{antibiotics} data set on any results, see \emph{Examples}. It allows for filtering on a (part of) a certain name, and/or a group name or even a minimum of DDDs for oral treatment. This function yields the highest flexibility, but is also the least user-friendly, since it requires a hard-coded filter to set.
|
||||||
|
|
||||||
The \code{\link[=not_intrinsic_resistant]{not_intrinsic_resistant()}} function can be used to only select antimicrobials that pose no intrinsic resistance for the microorganisms in the data set. For example, if a data set contains only microorganism codes or names of \emph{E. coli} and \emph{K. pneumoniae} and contains a column "vancomycin", this column will be removed (or rather, unselected) using this function. It currently applies \href{https://www.eucast.org/expert_rules_and_expected_phenotypes}{'EUCAST Expert Rules' and 'EUCAST Intrinsic Resistance and Unusual Phenotypes' v3.3} (2021) to determine intrinsic resistance, using the \code{\link[=eucast_rules]{eucast_rules()}} function internally. Because of this determination, this function is quite slow in terms of performance.
|
The \code{\link[=not_intrinsic_resistant]{not_intrinsic_resistant()}} function can be used to only select antimicrobials that pose no intrinsic resistance for the microorganisms in the data set. For example, if a data set contains only microorganism codes or names of \emph{E. coli} and \emph{K. pneumoniae} and contains a column "vancomycin", this column will be removed (or rather, unselected) using this function. It currently applies \href{https://www.eucast.org/expert_rules_and_expected_phenotypes}{'EUCAST Expert Rules' and 'EUCAST Intrinsic Resistance and Unusual Phenotypes' v3.3} (2021) to determine intrinsic resistance, using the \code{\link[=eucast_rules]{eucast_rules()}} function internally. Because of this determination, this function is quite slow in terms of performance.
|
||||||
}
|
}
|
||||||
\section{Full list of supported (antimicrobial) classes}{
|
\section{Full list of supported (antimicrobial) classes}{
|
||||||
|
|||||||
112
man/as.sir.Rd
112
man/as.sir.Rd
@@ -258,69 +258,97 @@ if (require("dplyr")) {
|
|||||||
df_wide \%>\% mutate(across(where(is.mic), as.sir))
|
df_wide \%>\% mutate(across(where(is.mic), as.sir))
|
||||||
df_wide \%>\% mutate_at(vars(amoxicillin:tobra), as.sir)
|
df_wide \%>\% mutate_at(vars(amoxicillin:tobra), as.sir)
|
||||||
df_wide \%>\% mutate(across(amoxicillin:tobra, as.sir))
|
df_wide \%>\% mutate(across(amoxicillin:tobra, as.sir))
|
||||||
|
|
||||||
# approaches that all work with additional arguments:
|
# approaches that all work with additional arguments:
|
||||||
df_long \%>\%
|
df_long \%>\%
|
||||||
# given a certain data type, e.g. MIC values
|
# given a certain data type, e.g. MIC values
|
||||||
mutate_if(is.mic, as.sir,
|
mutate_if(is.mic, as.sir,
|
||||||
mo = "bacteria",
|
mo = "bacteria",
|
||||||
ab = "antibiotic",
|
ab = "antibiotic",
|
||||||
guideline = "CLSI")
|
guideline = "CLSI"
|
||||||
|
)
|
||||||
df_long \%>\%
|
df_long \%>\%
|
||||||
mutate(across(where(is.mic),
|
mutate(across(
|
||||||
function(x) as.sir(x,
|
where(is.mic),
|
||||||
mo = "bacteria",
|
function(x) {
|
||||||
ab = "antibiotic",
|
as.sir(x,
|
||||||
guideline = "CLSI")))
|
mo = "bacteria",
|
||||||
|
ab = "antibiotic",
|
||||||
|
guideline = "CLSI"
|
||||||
|
)
|
||||||
|
}
|
||||||
|
))
|
||||||
df_wide \%>\%
|
df_wide \%>\%
|
||||||
# given certain columns, e.g. from 'cipro' to 'genta'
|
# given certain columns, e.g. from 'cipro' to 'genta'
|
||||||
mutate_at(vars(cipro:genta), as.sir,
|
mutate_at(vars(cipro:genta), as.sir,
|
||||||
mo = "bacteria",
|
mo = "bacteria",
|
||||||
guideline = "CLSI")
|
guideline = "CLSI"
|
||||||
|
)
|
||||||
df_wide \%>\%
|
df_wide \%>\%
|
||||||
mutate(across(cipro:genta,
|
mutate(across(
|
||||||
function(x) as.sir(x,
|
cipro:genta,
|
||||||
mo = "bacteria",
|
function(x) {
|
||||||
guideline = "CLSI")))
|
as.sir(x,
|
||||||
|
mo = "bacteria",
|
||||||
|
guideline = "CLSI"
|
||||||
|
)
|
||||||
|
}
|
||||||
|
))
|
||||||
|
|
||||||
# for veterinary breakpoints, add 'host':
|
# for veterinary breakpoints, add 'host':
|
||||||
df_long$animal_species <- c("cats", "dogs", "horses", "cattle")
|
df_long$animal_species <- c("cats", "dogs", "horses", "cattle")
|
||||||
df_long \%>\%
|
df_long \%>\%
|
||||||
# given a certain data type, e.g. MIC values
|
# given a certain data type, e.g. MIC values
|
||||||
mutate_if(is.mic, as.sir,
|
mutate_if(is.mic, as.sir,
|
||||||
mo = "bacteria",
|
mo = "bacteria",
|
||||||
ab = "antibiotic",
|
ab = "antibiotic",
|
||||||
host = "animal_species",
|
host = "animal_species",
|
||||||
guideline = "CLSI")
|
guideline = "CLSI"
|
||||||
|
)
|
||||||
df_long \%>\%
|
df_long \%>\%
|
||||||
mutate(across(where(is.mic),
|
mutate(across(
|
||||||
function(x) as.sir(x,
|
where(is.mic),
|
||||||
mo = "bacteria",
|
function(x) {
|
||||||
ab = "antibiotic",
|
as.sir(x,
|
||||||
host = "animal_species",
|
mo = "bacteria",
|
||||||
guideline = "CLSI")))
|
ab = "antibiotic",
|
||||||
|
host = "animal_species",
|
||||||
|
guideline = "CLSI"
|
||||||
|
)
|
||||||
|
}
|
||||||
|
))
|
||||||
df_wide \%>\%
|
df_wide \%>\%
|
||||||
mutate_at(vars(cipro:genta), as.sir,
|
mutate_at(vars(cipro:genta), as.sir,
|
||||||
mo = "bacteria",
|
mo = "bacteria",
|
||||||
ab = "antibiotic",
|
ab = "antibiotic",
|
||||||
host = "animal_species",
|
host = "animal_species",
|
||||||
guideline = "CLSI")
|
guideline = "CLSI"
|
||||||
|
)
|
||||||
df_wide \%>\%
|
df_wide \%>\%
|
||||||
mutate(across(cipro:genta,
|
mutate(across(
|
||||||
function(x) as.sir(x,
|
cipro:genta,
|
||||||
mo = "bacteria",
|
function(x) {
|
||||||
host = "animal_species",
|
as.sir(x,
|
||||||
guideline = "CLSI")))
|
mo = "bacteria",
|
||||||
|
host = "animal_species",
|
||||||
|
guideline = "CLSI"
|
||||||
|
)
|
||||||
|
}
|
||||||
|
))
|
||||||
|
|
||||||
# to include information about urinary tract infections (UTI)
|
# to include information about urinary tract infections (UTI)
|
||||||
data.frame(mo = "E. coli",
|
data.frame(
|
||||||
nitrofuratoin = c("<= 2", 32),
|
mo = "E. coli",
|
||||||
from_the_bladder = c(TRUE, FALSE)) \%>\%
|
nitrofuratoin = c("<= 2", 32),
|
||||||
|
from_the_bladder = c(TRUE, FALSE)
|
||||||
|
) \%>\%
|
||||||
as.sir(uti = "from_the_bladder")
|
as.sir(uti = "from_the_bladder")
|
||||||
|
|
||||||
data.frame(mo = "E. coli",
|
data.frame(
|
||||||
nitrofuratoin = c("<= 2", 32),
|
mo = "E. coli",
|
||||||
specimen = c("urine", "blood")) \%>\%
|
nitrofuratoin = c("<= 2", 32),
|
||||||
|
specimen = c("urine", "blood")
|
||||||
|
) \%>\%
|
||||||
as.sir() # automatically determines urine isolates
|
as.sir() # automatically determines urine isolates
|
||||||
|
|
||||||
df_wide \%>\%
|
df_wide \%>\%
|
||||||
|
|||||||
@@ -81,7 +81,7 @@ Rules can also be applied to multiple antibiotics and antibiotic groups simultan
|
|||||||
\if{html}{\out{<div class="sourceCode r">}}\preformatted{x <- custom_eucast_rules(TZP == "R" ~ c(aminopenicillins, ureidopenicillins) == "R")
|
\if{html}{\out{<div class="sourceCode r">}}\preformatted{x <- custom_eucast_rules(TZP == "R" ~ c(aminopenicillins, ureidopenicillins) == "R")
|
||||||
x
|
x
|
||||||
#> A set of custom EUCAST rules:
|
#> A set of custom EUCAST rules:
|
||||||
#>
|
#>
|
||||||
#> 1. If TZP is "R" then set to "R":
|
#> 1. If TZP is "R" then set to "R":
|
||||||
#> amoxicillin (AMX), ampicillin (AMP), azlocillin (AZL), mezlocillin (MEZ), piperacillin (PIP), piperacillin/tazobactam (TZP)
|
#> amoxicillin (AMX), ampicillin (AMP), azlocillin (AZL), mezlocillin (MEZ), piperacillin (PIP), piperacillin/tazobactam (TZP)
|
||||||
}\if{html}{\out{</div>}}
|
}\if{html}{\out{</div>}}
|
||||||
|
|||||||
@@ -139,8 +139,10 @@ if (require("ggplot2") && require("dplyr")) {
|
|||||||
) \%>\%
|
) \%>\%
|
||||||
ggplot() +
|
ggplot() +
|
||||||
geom_col(aes(x = x, y = y, fill = z)) +
|
geom_col(aes(x = x, y = y, fill = z)) +
|
||||||
scale_sir_colours(aesthetics = "fill",
|
scale_sir_colours(
|
||||||
Value4 = "S", Value5 = "I", Value6 = "R")
|
aesthetics = "fill",
|
||||||
|
Value4 = "S", Value5 = "I", Value6 = "R"
|
||||||
|
)
|
||||||
}
|
}
|
||||||
if (require("ggplot2") && require("dplyr")) {
|
if (require("ggplot2") && require("dplyr")) {
|
||||||
# resistance of ciprofloxacine per age group
|
# resistance of ciprofloxacine per age group
|
||||||
|
|||||||
@@ -262,10 +262,12 @@ mo_rank("Klebsiella pneumoniae")
|
|||||||
mo_url("Klebsiella pneumoniae")
|
mo_url("Klebsiella pneumoniae")
|
||||||
mo_is_yeast(c("Candida", "Trichophyton", "Klebsiella"))
|
mo_is_yeast(c("Candida", "Trichophyton", "Klebsiella"))
|
||||||
|
|
||||||
mo_group_members(c("Streptococcus group A",
|
mo_group_members(c(
|
||||||
"Streptococcus group C",
|
"Streptococcus group A",
|
||||||
"Streptococcus group G",
|
"Streptococcus group C",
|
||||||
"Streptococcus group L"))
|
"Streptococcus group G",
|
||||||
|
"Streptococcus group L"
|
||||||
|
))
|
||||||
|
|
||||||
|
|
||||||
# scientific reference -----------------------------------------------------
|
# scientific reference -----------------------------------------------------
|
||||||
|
|||||||
74
man/plot.Rd
74
man/plot.Rd
@@ -201,7 +201,6 @@ some_mic_values <- random_mic(size = 100)
|
|||||||
some_disk_values <- random_disk(size = 100, mo = "Escherichia coli", ab = "cipro")
|
some_disk_values <- random_disk(size = 100, mo = "Escherichia coli", ab = "cipro")
|
||||||
some_sir_values <- random_sir(50, prob_SIR = c(0.55, 0.05, 0.30))
|
some_sir_values <- random_sir(50, prob_SIR = c(0.55, 0.05, 0.30))
|
||||||
|
|
||||||
|
|
||||||
\donttest{
|
\donttest{
|
||||||
# Plotting using ggplot2's autoplot() for MIC, disk, and SIR -----------
|
# Plotting using ggplot2's autoplot() for MIC, disk, and SIR -----------
|
||||||
if (require("ggplot2")) {
|
if (require("ggplot2")) {
|
||||||
@@ -213,17 +212,23 @@ if (require("ggplot2")) {
|
|||||||
}
|
}
|
||||||
if (require("ggplot2")) {
|
if (require("ggplot2")) {
|
||||||
# support for 20 languages, various guidelines, and many options
|
# support for 20 languages, various guidelines, and many options
|
||||||
autoplot(some_disk_values, mo = "Escherichia coli", ab = "cipro",
|
autoplot(some_disk_values,
|
||||||
guideline = "CLSI 2024", language = "no",
|
mo = "Escherichia coli", ab = "cipro",
|
||||||
title = "Disk diffusion from the North")
|
guideline = "CLSI 2024", language = "no",
|
||||||
|
title = "Disk diffusion from the North"
|
||||||
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
# Plotting using scale_x_mic() -----------------------------------------
|
# Plotting using scale_x_mic() -----------------------------------------
|
||||||
if (require("ggplot2")) {
|
if (require("ggplot2")) {
|
||||||
mic_plot <- ggplot(data.frame(mics = as.mic(c(0.25, "<=4", 4, 8, 32, ">=32")),
|
mic_plot <- ggplot(
|
||||||
counts = c(1, 1, 2, 2, 3, 3)),
|
data.frame(
|
||||||
aes(mics, counts)) +
|
mics = as.mic(c(0.25, "<=4", 4, 8, 32, ">=32")),
|
||||||
|
counts = c(1, 1, 2, 2, 3, 3)
|
||||||
|
),
|
||||||
|
aes(mics, counts)
|
||||||
|
) +
|
||||||
geom_col()
|
geom_col()
|
||||||
mic_plot +
|
mic_plot +
|
||||||
labs(title = "without scale_x_mic()")
|
labs(title = "without scale_x_mic()")
|
||||||
@@ -254,17 +259,25 @@ if (require("ggplot2")) {
|
|||||||
some_groups <- sample(LETTERS[1:5], 20, replace = TRUE)
|
some_groups <- sample(LETTERS[1:5], 20, replace = TRUE)
|
||||||
|
|
||||||
if (require("ggplot2")) {
|
if (require("ggplot2")) {
|
||||||
ggplot(data.frame(mic = some_mic_values,
|
ggplot(
|
||||||
group = some_groups),
|
data.frame(
|
||||||
aes(group, mic)) +
|
mic = some_mic_values,
|
||||||
|
group = some_groups
|
||||||
|
),
|
||||||
|
aes(group, mic)
|
||||||
|
) +
|
||||||
geom_boxplot() +
|
geom_boxplot() +
|
||||||
geom_violin(linetype = 2, colour = "grey", fill = NA) +
|
geom_violin(linetype = 2, colour = "grey", fill = NA) +
|
||||||
scale_y_mic()
|
scale_y_mic()
|
||||||
}
|
}
|
||||||
if (require("ggplot2")) {
|
if (require("ggplot2")) {
|
||||||
ggplot(data.frame(mic = some_mic_values,
|
ggplot(
|
||||||
group = some_groups),
|
data.frame(
|
||||||
aes(group, mic)) +
|
mic = some_mic_values,
|
||||||
|
group = some_groups
|
||||||
|
),
|
||||||
|
aes(group, mic)
|
||||||
|
) +
|
||||||
geom_boxplot() +
|
geom_boxplot() +
|
||||||
geom_violin(linetype = 2, colour = "grey", fill = NA) +
|
geom_violin(linetype = 2, colour = "grey", fill = NA) +
|
||||||
scale_y_mic(mic_range = c(NA, 0.25))
|
scale_y_mic(mic_range = c(NA, 0.25))
|
||||||
@@ -273,9 +286,13 @@ if (require("ggplot2")) {
|
|||||||
|
|
||||||
# Plotting using scale_x_sir() -----------------------------------------
|
# Plotting using scale_x_sir() -----------------------------------------
|
||||||
if (require("ggplot2")) {
|
if (require("ggplot2")) {
|
||||||
ggplot(data.frame(x = c("I", "R", "S"),
|
ggplot(
|
||||||
y = c(45,323, 573)),
|
data.frame(
|
||||||
aes(x, y)) +
|
x = c("I", "R", "S"),
|
||||||
|
y = c(45, 323, 573)
|
||||||
|
),
|
||||||
|
aes(x, y)
|
||||||
|
) +
|
||||||
geom_col() +
|
geom_col() +
|
||||||
scale_x_sir()
|
scale_x_sir()
|
||||||
}
|
}
|
||||||
@@ -283,16 +300,21 @@ if (require("ggplot2")) {
|
|||||||
|
|
||||||
# Plotting using scale_y_mic() and scale_colour_sir() ------------------
|
# Plotting using scale_y_mic() and scale_colour_sir() ------------------
|
||||||
if (require("ggplot2")) {
|
if (require("ggplot2")) {
|
||||||
plain <- ggplot(data.frame(mic = some_mic_values,
|
plain <- ggplot(
|
||||||
group = some_groups,
|
data.frame(
|
||||||
sir = as.sir(some_mic_values,
|
mic = some_mic_values,
|
||||||
mo = "E. coli",
|
group = some_groups,
|
||||||
ab = "cipro")),
|
sir = as.sir(some_mic_values,
|
||||||
aes(x = group, y = mic, colour = sir)) +
|
mo = "E. coli",
|
||||||
|
ab = "cipro"
|
||||||
|
)
|
||||||
|
),
|
||||||
|
aes(x = group, y = mic, colour = sir)
|
||||||
|
) +
|
||||||
theme_minimal() +
|
theme_minimal() +
|
||||||
geom_boxplot(fill = NA, colour = "grey") +
|
geom_boxplot(fill = NA, colour = "grey") +
|
||||||
geom_jitter(width = 0.25)
|
geom_jitter(width = 0.25)
|
||||||
|
|
||||||
plain
|
plain
|
||||||
}
|
}
|
||||||
if (require("ggplot2")) {
|
if (require("ggplot2")) {
|
||||||
@@ -304,8 +326,10 @@ if (require("ggplot2")) {
|
|||||||
if (require("ggplot2")) {
|
if (require("ggplot2")) {
|
||||||
plain +
|
plain +
|
||||||
scale_y_mic(mic_range = c(0.005, 32), name = "Our MICs!") +
|
scale_y_mic(mic_range = c(0.005, 32), name = "Our MICs!") +
|
||||||
scale_colour_sir(language = "pt",
|
scale_colour_sir(
|
||||||
name = "Support in 20 languages")
|
language = "pt",
|
||||||
|
name = "Support in 20 languages"
|
||||||
|
)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
@@ -29,15 +29,18 @@ This function is useful for preprocessing data before creating \link[=antibiogra
|
|||||||
\examples{
|
\examples{
|
||||||
# filter to the top 3 species:
|
# filter to the top 3 species:
|
||||||
top_n_microorganisms(example_isolates,
|
top_n_microorganisms(example_isolates,
|
||||||
n = 3)
|
n = 3
|
||||||
|
)
|
||||||
|
|
||||||
# filter to any species in the top 5 genera:
|
# filter to any species in the top 5 genera:
|
||||||
top_n_microorganisms(example_isolates,
|
top_n_microorganisms(example_isolates,
|
||||||
n = 5, property = "genus")
|
n = 5, property = "genus"
|
||||||
|
)
|
||||||
|
|
||||||
# filter to the top 3 species in each of the top 5 genera:
|
# filter to the top 3 species in each of the top 5 genera:
|
||||||
top_n_microorganisms(example_isolates,
|
top_n_microorganisms(example_isolates,
|
||||||
n = 5, property = "genus", n_for_each = 3)
|
n = 5, property = "genus", n_for_each = 3
|
||||||
|
)
|
||||||
}
|
}
|
||||||
\seealso{
|
\seealso{
|
||||||
\code{\link[=mo_property]{mo_property()}}, \code{\link[=as.mo]{as.mo()}}, \code{\link[=antibiogram]{antibiogram()}}
|
\code{\link[=mo_property]{mo_property()}}, \code{\link[=as.mo]{as.mo()}}, \code{\link[=antibiogram]{antibiogram()}}
|
||||||
|
|||||||
@@ -33,8 +33,11 @@ library(AMR)
|
|||||||
# add functions from the tinytest package (which we use for older R versions)
|
# add functions from the tinytest package (which we use for older R versions)
|
||||||
expect_inherits <- function(x, y, ...) {
|
expect_inherits <- function(x, y, ...) {
|
||||||
expect(inherits(x, y),
|
expect(inherits(x, y),
|
||||||
failure_message = paste0("object has class ", paste0(class(x), collapse = "/"),
|
failure_message = paste0(
|
||||||
", required is class ", paste0(y, collapse = "/")))
|
"object has class ", paste0(class(x), collapse = "/"),
|
||||||
|
", required is class ", paste0(y, collapse = "/")
|
||||||
|
)
|
||||||
|
)
|
||||||
}
|
}
|
||||||
expect_stdout <- expect_output
|
expect_stdout <- expect_output
|
||||||
|
|
||||||
|
|||||||
@@ -80,15 +80,19 @@ expect_equal(
|
|||||||
# based on Levenshtein distance
|
# based on Levenshtein distance
|
||||||
expect_identical(ab_name("ceftazidim/avibactam", language = NULL), "Ceftazidime/avibactam")
|
expect_identical(ab_name("ceftazidim/avibactam", language = NULL), "Ceftazidime/avibactam")
|
||||||
|
|
||||||
expect_identical(as.character(as.ab(c("gentamicine High Level",
|
expect_identical(
|
||||||
"gentamicine High",
|
as.character(as.ab(c(
|
||||||
"gentamicine (High Level)",
|
"gentamicine High Level",
|
||||||
"gentamicine (High)",
|
"gentamicine High",
|
||||||
"gentamicine HL",
|
"gentamicine (High Level)",
|
||||||
"gentamicine H-L",
|
"gentamicine (High)",
|
||||||
"gentamicine (HL)",
|
"gentamicine HL",
|
||||||
"gentamicine (H-L)"))),
|
"gentamicine H-L",
|
||||||
rep("GEH", 8))
|
"gentamicine (HL)",
|
||||||
|
"gentamicine (H-L)"
|
||||||
|
))),
|
||||||
|
rep("GEH", 8)
|
||||||
|
)
|
||||||
|
|
||||||
# assigning and subsetting
|
# assigning and subsetting
|
||||||
x <- antibiotics$ab
|
x <- antibiotics$ab
|
||||||
|
|||||||
@@ -96,4 +96,3 @@ if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0", also_load = TRUE)) {
|
|||||||
set_ab_names(NIT:VAN) %>%
|
set_ab_names(NIT:VAN) %>%
|
||||||
colnames())))
|
colnames())))
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
@@ -35,13 +35,14 @@ expect_equal(
|
|||||||
c(39, 34, 29)
|
c(39, 34, 29)
|
||||||
)
|
)
|
||||||
|
|
||||||
expect_equal(age(
|
expect_equal(
|
||||||
x = c("2019-01-01", "2019-04-01", "2019-07-01"),
|
age(
|
||||||
reference = "2019-09-01",
|
x = c("2019-01-01", "2019-04-01", "2019-07-01"),
|
||||||
exact = TRUE
|
reference = "2019-09-01",
|
||||||
),
|
exact = TRUE
|
||||||
c(0.6656393, 0.4191781, 0.1698630),
|
),
|
||||||
tolerance = 0.001
|
c(0.6656393, 0.4191781, 0.1698630),
|
||||||
|
tolerance = 0.001
|
||||||
)
|
)
|
||||||
|
|
||||||
expect_error(age(
|
expect_error(age(
|
||||||
|
|||||||
@@ -31,19 +31,22 @@
|
|||||||
# Traditional antibiogram ----------------------------------------------
|
# Traditional antibiogram ----------------------------------------------
|
||||||
|
|
||||||
ab1 <- antibiogram(example_isolates,
|
ab1 <- antibiogram(example_isolates,
|
||||||
antibiotics = c(aminoglycosides(), carbapenems()))
|
antibiotics = c(aminoglycosides(), carbapenems())
|
||||||
|
)
|
||||||
|
|
||||||
ab2 <- antibiogram(example_isolates,
|
ab2 <- antibiogram(example_isolates,
|
||||||
antibiotics = aminoglycosides(),
|
antibiotics = aminoglycosides(),
|
||||||
ab_transform = "atc",
|
ab_transform = "atc",
|
||||||
mo_transform = "gramstain",
|
mo_transform = "gramstain",
|
||||||
add_total_n = TRUE)
|
add_total_n = TRUE
|
||||||
|
)
|
||||||
|
|
||||||
ab3 <- antibiogram(example_isolates,
|
ab3 <- antibiogram(example_isolates,
|
||||||
antibiotics = carbapenems(),
|
antibiotics = carbapenems(),
|
||||||
ab_transform = "ab",
|
ab_transform = "ab",
|
||||||
mo_transform = "name",
|
mo_transform = "name",
|
||||||
formatting_type = 1)
|
formatting_type = 1
|
||||||
|
)
|
||||||
|
|
||||||
expect_inherits(ab1, "antibiogram")
|
expect_inherits(ab1, "antibiogram")
|
||||||
expect_inherits(ab2, "antibiogram")
|
expect_inherits(ab2, "antibiogram")
|
||||||
@@ -57,15 +60,17 @@ expect_equal(ab3$MEM, c(52, NA, 100, 100, NA))
|
|||||||
|
|
||||||
# combined antibiotics yield higher empiric coverage
|
# combined antibiotics yield higher empiric coverage
|
||||||
ab4 <- antibiogram(example_isolates,
|
ab4 <- antibiogram(example_isolates,
|
||||||
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
|
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
|
||||||
mo_transform = "gramstain")
|
mo_transform = "gramstain"
|
||||||
|
)
|
||||||
|
|
||||||
ab5 <- antibiogram(example_isolates,
|
ab5 <- antibiogram(example_isolates,
|
||||||
antibiotics = c("TZP", "TZP+TOB"),
|
antibiotics = c("TZP", "TZP+TOB"),
|
||||||
mo_transform = "gramstain",
|
mo_transform = "gramstain",
|
||||||
ab_transform = "name",
|
ab_transform = "name",
|
||||||
sep = " & ",
|
sep = " & ",
|
||||||
add_total_n = FALSE)
|
add_total_n = FALSE
|
||||||
|
)
|
||||||
|
|
||||||
expect_inherits(ab4, "antibiogram")
|
expect_inherits(ab4, "antibiogram")
|
||||||
expect_inherits(ab5, "antibiogram")
|
expect_inherits(ab5, "antibiogram")
|
||||||
@@ -76,20 +81,23 @@ expect_equal(colnames(ab5), c("Pathogen", "Piperacillin/tazobactam", "Piperacill
|
|||||||
|
|
||||||
# the data set could contain a filter for e.g. respiratory specimens
|
# the data set could contain a filter for e.g. respiratory specimens
|
||||||
ab6 <- antibiogram(example_isolates,
|
ab6 <- antibiogram(example_isolates,
|
||||||
antibiotics = c(aminoglycosides(), carbapenems()),
|
antibiotics = c(aminoglycosides(), carbapenems()),
|
||||||
syndromic_group = "ward",
|
syndromic_group = "ward",
|
||||||
ab_transform = NULL)
|
ab_transform = NULL
|
||||||
|
)
|
||||||
|
|
||||||
# with a custom language, though this will be determined automatically
|
# with a custom language, though this will be determined automatically
|
||||||
# (i.e., this table will be in Dutch on Dutch systems)
|
# (i.e., this table will be in Dutch on Dutch systems)
|
||||||
ex1 <- example_isolates[which(mo_genus() == "Escherichia"), ]
|
ex1 <- example_isolates[which(mo_genus() == "Escherichia"), ]
|
||||||
ab7 <- antibiogram(ex1,
|
ab7 <- antibiogram(ex1,
|
||||||
antibiotics = aminoglycosides(),
|
antibiotics = aminoglycosides(),
|
||||||
ab_transform = "name",
|
ab_transform = "name",
|
||||||
syndromic_group = ifelse(ex1$ward == "ICU",
|
syndromic_group = ifelse(ex1$ward == "ICU",
|
||||||
"IC", "Geen IC"),
|
"IC", "Geen IC"
|
||||||
language = "nl",
|
),
|
||||||
add_total_n = TRUE)
|
language = "nl",
|
||||||
|
add_total_n = TRUE
|
||||||
|
)
|
||||||
|
|
||||||
expect_inherits(ab6, "antibiogram")
|
expect_inherits(ab6, "antibiogram")
|
||||||
expect_inherits(ab7, "antibiogram")
|
expect_inherits(ab7, "antibiogram")
|
||||||
@@ -100,8 +108,9 @@ expect_equal(colnames(ab7), c("Syndroomgroep", "Pathogeen (N min-max)", "Amikaci
|
|||||||
|
|
||||||
# the data set could contain a filter for e.g. respiratory specimens
|
# the data set could contain a filter for e.g. respiratory specimens
|
||||||
ab8 <- suppressWarnings(antibiogram(example_isolates,
|
ab8 <- suppressWarnings(antibiogram(example_isolates,
|
||||||
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
|
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
|
||||||
wisca = TRUE))
|
wisca = TRUE
|
||||||
|
))
|
||||||
|
|
||||||
expect_inherits(ab8, "antibiogram")
|
expect_inherits(ab8, "antibiogram")
|
||||||
expect_equal(colnames(ab8), c("Piperacillin/tazobactam", "Piperacillin/tazobactam + Gentamicin", "Piperacillin/tazobactam + Tobramycin"))
|
expect_equal(colnames(ab8), c("Piperacillin/tazobactam", "Piperacillin/tazobactam + Gentamicin", "Piperacillin/tazobactam + Tobramycin"))
|
||||||
|
|||||||
@@ -34,7 +34,7 @@ expect_identical(av_cid("ACI"), as.integer(135398513))
|
|||||||
expect_inherits(av_tradenames("ACI"), "character")
|
expect_inherits(av_tradenames("ACI"), "character")
|
||||||
expect_inherits(av_tradenames(c("ACI", "ACI")), "list")
|
expect_inherits(av_tradenames(c("ACI", "ACI")), "list")
|
||||||
|
|
||||||
expect_identical(av_group("ACI", language = NULL),"Nucleosides and nucleotides excl. reverse transcriptase inhibitors")
|
expect_identical(av_group("ACI", language = NULL), "Nucleosides and nucleotides excl. reverse transcriptase inhibitors")
|
||||||
|
|
||||||
expect_identical(av_name(135398513, language = NULL), "Aciclovir")
|
expect_identical(av_name(135398513, language = NULL), "Aciclovir")
|
||||||
expect_identical(av_name("J05AB01", language = NULL), "Aciclovir")
|
expect_identical(av_name("J05AB01", language = NULL), "Aciclovir")
|
||||||
|
|||||||
@@ -69,7 +69,7 @@ if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0", also_load = TRUE)) {
|
|||||||
example_isolates %>% count_susceptible(AMC, GEN, only_all_tested = TRUE) +
|
example_isolates %>% count_susceptible(AMC, GEN, only_all_tested = TRUE) +
|
||||||
example_isolates %>% count_resistant(AMC, GEN, only_all_tested = TRUE)
|
example_isolates %>% count_resistant(AMC, GEN, only_all_tested = TRUE)
|
||||||
)
|
)
|
||||||
|
|
||||||
# count of cases
|
# count of cases
|
||||||
expect_equal(
|
expect_equal(
|
||||||
example_isolates %>%
|
example_isolates %>%
|
||||||
|
|||||||
@@ -33,9 +33,11 @@ expect_message(as.ab("testab", info = TRUE))
|
|||||||
|
|
||||||
suppressMessages(
|
suppressMessages(
|
||||||
add_custom_antimicrobials(
|
add_custom_antimicrobials(
|
||||||
data.frame(ab = "TESTAB",
|
data.frame(
|
||||||
name = "Test Antibiotic",
|
ab = "TESTAB",
|
||||||
group = "Test Group")
|
name = "Test Antibiotic",
|
||||||
|
group = "Test Group"
|
||||||
|
)
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|||||||
@@ -27,14 +27,18 @@
|
|||||||
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
|
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
|
||||||
# ==================================================================== #
|
# ==================================================================== #
|
||||||
|
|
||||||
expect_identical(as.mo("Enterobacter asburiae/cloacae"),
|
expect_identical(
|
||||||
as.mo("Enterobacter asburiae"))
|
as.mo("Enterobacter asburiae/cloacae"),
|
||||||
|
as.mo("Enterobacter asburiae")
|
||||||
|
)
|
||||||
|
|
||||||
suppressMessages(
|
suppressMessages(
|
||||||
add_custom_microorganisms(
|
add_custom_microorganisms(
|
||||||
data.frame(mo = "ENT_ASB_CLO",
|
data.frame(
|
||||||
genus = "Enterobacter",
|
mo = "ENT_ASB_CLO",
|
||||||
species = "asburiae/cloacae")
|
genus = "Enterobacter",
|
||||||
|
species = "asburiae/cloacae"
|
||||||
|
)
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
|
||||||
@@ -44,8 +48,12 @@ expect_identical(mo_gramstain("ENT_ASB_CLO", language = NULL), "Gram-negative")
|
|||||||
|
|
||||||
if (getRversion() >= "3.3.0") {
|
if (getRversion() >= "3.3.0") {
|
||||||
# until R 3.2, abbreviate() used a completely different algorithm, making these tests unreproducible
|
# until R 3.2, abbreviate() used a completely different algorithm, making these tests unreproducible
|
||||||
expect_identical(paste("B", AMR:::abbreviate_mo("Klebsiella"), AMR:::abbreviate_mo("pneumoniae", 4), sep = "_"),
|
expect_identical(
|
||||||
as.character(as.mo("Klebsiella pneumoniae")))
|
paste("B", AMR:::abbreviate_mo("Klebsiella"), AMR:::abbreviate_mo("pneumoniae", 4), sep = "_"),
|
||||||
expect_identical(paste("B", AMR:::abbreviate_mo("Aerococcus"), AMR:::abbreviate_mo("urinae", 4), sep = "_"),
|
as.character(as.mo("Klebsiella pneumoniae"))
|
||||||
as.character(as.mo("Aerococcus urinae")))
|
)
|
||||||
|
expect_identical(
|
||||||
|
paste("B", AMR:::abbreviate_mo("Aerococcus"), AMR:::abbreviate_mo("urinae", 4), sep = "_"),
|
||||||
|
as.character(as.mo("Aerococcus urinae"))
|
||||||
|
)
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -68,9 +68,9 @@ if (AMR:::pkg_is_available("tibble")) {
|
|||||||
|
|
||||||
df <- AMR:::AMR_env$MO_lookup
|
df <- AMR:::AMR_env$MO_lookup
|
||||||
expect_true(all(c(
|
expect_true(all(c(
|
||||||
"mo", "fullname", "status", "kingdom", "phylum", "class", "order",
|
"mo", "fullname", "status", "kingdom", "phylum", "class", "order",
|
||||||
"family", "genus", "species", "subspecies", "rank", "ref", "source",
|
"family", "genus", "species", "subspecies", "rank", "ref", "source",
|
||||||
"lpsn", "lpsn_parent", "lpsn_renamed_to", "gbif", "gbif_parent", "gbif_renamed_to", "prevalence",
|
"lpsn", "lpsn_parent", "lpsn_renamed_to", "gbif", "gbif_parent", "gbif_renamed_to", "prevalence",
|
||||||
"snomed", "kingdom_index", "fullname_lower", "full_first", "species_first"
|
"snomed", "kingdom_index", "fullname_lower", "full_first", "species_first"
|
||||||
) %in% colnames(df)))
|
) %in% colnames(df)))
|
||||||
|
|
||||||
|
|||||||
@@ -117,15 +117,16 @@ if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0", also_load = TRUE)) {
|
|||||||
}
|
}
|
||||||
|
|
||||||
# azithromycin and clarythromycin must be equal to Erythromycin
|
# azithromycin and clarythromycin must be equal to Erythromycin
|
||||||
a <- suppressWarnings(as.sir(eucast_rules(data.frame(
|
a <- suppressWarnings(as.sir(eucast_rules(
|
||||||
mo = example_isolates$mo,
|
data.frame(
|
||||||
ERY = example_isolates$ERY,
|
mo = example_isolates$mo,
|
||||||
AZM = as.sir("R"),
|
ERY = example_isolates$ERY,
|
||||||
CLR = factor("R"),
|
AZM = as.sir("R"),
|
||||||
stringsAsFactors = FALSE
|
CLR = factor("R"),
|
||||||
),
|
stringsAsFactors = FALSE
|
||||||
version_expertrules = 3.1,
|
),
|
||||||
only_sir_columns = FALSE
|
version_expertrules = 3.1,
|
||||||
|
only_sir_columns = FALSE
|
||||||
)$CLR))
|
)$CLR))
|
||||||
b <- example_isolates$ERY
|
b <- example_isolates$ERY
|
||||||
expect_identical(
|
expect_identical(
|
||||||
@@ -160,34 +161,37 @@ expect_stdout(suppressWarnings(eucast_rules(example_isolates, verbose = TRUE, ru
|
|||||||
# AmpC de-repressed cephalo mutants
|
# AmpC de-repressed cephalo mutants
|
||||||
|
|
||||||
expect_identical(
|
expect_identical(
|
||||||
eucast_rules(data.frame(
|
eucast_rules(
|
||||||
mo = c("Escherichia coli", "Enterobacter cloacae"),
|
data.frame(
|
||||||
cefotax = as.sir(c("S", "S"))
|
mo = c("Escherichia coli", "Enterobacter cloacae"),
|
||||||
),
|
cefotax = as.sir(c("S", "S"))
|
||||||
ampc_cephalosporin_resistance = TRUE,
|
),
|
||||||
info = FALSE
|
ampc_cephalosporin_resistance = TRUE,
|
||||||
|
info = FALSE
|
||||||
)$cefotax,
|
)$cefotax,
|
||||||
as.sir(c("S", "R"))
|
as.sir(c("S", "R"))
|
||||||
)
|
)
|
||||||
|
|
||||||
expect_identical(
|
expect_identical(
|
||||||
eucast_rules(data.frame(
|
eucast_rules(
|
||||||
mo = c("Escherichia coli", "Enterobacter cloacae"),
|
data.frame(
|
||||||
cefotax = as.sir(c("S", "S"))
|
mo = c("Escherichia coli", "Enterobacter cloacae"),
|
||||||
),
|
cefotax = as.sir(c("S", "S"))
|
||||||
ampc_cephalosporin_resistance = NA,
|
),
|
||||||
info = FALSE
|
ampc_cephalosporin_resistance = NA,
|
||||||
|
info = FALSE
|
||||||
)$cefotax,
|
)$cefotax,
|
||||||
as.sir(c("S", NA))
|
as.sir(c("S", NA))
|
||||||
)
|
)
|
||||||
|
|
||||||
expect_identical(
|
expect_identical(
|
||||||
eucast_rules(data.frame(
|
eucast_rules(
|
||||||
mo = c("Escherichia coli", "Enterobacter cloacae"),
|
data.frame(
|
||||||
cefotax = as.sir(c("S", "S"))
|
mo = c("Escherichia coli", "Enterobacter cloacae"),
|
||||||
),
|
cefotax = as.sir(c("S", "S"))
|
||||||
ampc_cephalosporin_resistance = NULL,
|
),
|
||||||
info = FALSE
|
ampc_cephalosporin_resistance = NULL,
|
||||||
|
info = FALSE
|
||||||
)$cefotax,
|
)$cefotax,
|
||||||
as.sir(c("S", "S"))
|
as.sir(c("S", "S"))
|
||||||
)
|
)
|
||||||
@@ -208,12 +212,13 @@ expect_stdout(print(c(x, x)))
|
|||||||
expect_stdout(print(as.list(x, x)))
|
expect_stdout(print(as.list(x, x)))
|
||||||
|
|
||||||
# this custom rules makes 8 changes
|
# this custom rules makes 8 changes
|
||||||
expect_equal(nrow(eucast_rules(example_isolates,
|
expect_equal(
|
||||||
rules = "custom",
|
nrow(eucast_rules(example_isolates,
|
||||||
custom_rules = x,
|
rules = "custom",
|
||||||
info = FALSE,
|
custom_rules = x,
|
||||||
verbose = TRUE
|
info = FALSE,
|
||||||
)),
|
verbose = TRUE
|
||||||
8,
|
)),
|
||||||
tolerance = 0.5
|
8,
|
||||||
|
tolerance = 0.5
|
||||||
)
|
)
|
||||||
|
|||||||
@@ -46,17 +46,28 @@ expect_equal(
|
|||||||
)
|
)
|
||||||
|
|
||||||
# for phenotype determination
|
# for phenotype determination
|
||||||
expect_equal(AMR:::duplicated_antibiogram("SSSS", points_threshold = 2, ignore_I = TRUE, type = "points"),
|
expect_equal(
|
||||||
FALSE)
|
AMR:::duplicated_antibiogram("SSSS", points_threshold = 2, ignore_I = TRUE, type = "points"),
|
||||||
expect_equal(AMR:::duplicated_antibiogram(c("RRR", "SSS"),
|
FALSE
|
||||||
points_threshold = 2, ignore_I = TRUE, type = "points"),
|
)
|
||||||
c(FALSE, FALSE))
|
expect_equal(
|
||||||
expect_equal(AMR:::duplicated_antibiogram(c("RRR", "RRR", "SSS"),
|
AMR:::duplicated_antibiogram(c("RRR", "SSS"),
|
||||||
points_threshold = 2, ignore_I = TRUE, type = "points"),
|
points_threshold = 2, ignore_I = TRUE, type = "points"
|
||||||
c(FALSE, TRUE, FALSE))
|
),
|
||||||
expect_equal(AMR:::duplicated_antibiogram(c("RRR", "RSS", "SSS", "RSS", "RRR", "RRR", "SSS", "RSS", "RSR", "RRR"),
|
c(FALSE, FALSE)
|
||||||
points_threshold = 2, ignore_I = TRUE, type = "points"),
|
)
|
||||||
c(FALSE, FALSE, FALSE, TRUE, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE))
|
expect_equal(
|
||||||
|
AMR:::duplicated_antibiogram(c("RRR", "RRR", "SSS"),
|
||||||
|
points_threshold = 2, ignore_I = TRUE, type = "points"
|
||||||
|
),
|
||||||
|
c(FALSE, TRUE, FALSE)
|
||||||
|
)
|
||||||
|
expect_equal(
|
||||||
|
AMR:::duplicated_antibiogram(c("RRR", "RSS", "SSS", "RSS", "RRR", "RRR", "SSS", "RSS", "RSR", "RRR"),
|
||||||
|
points_threshold = 2, ignore_I = TRUE, type = "points"
|
||||||
|
),
|
||||||
|
c(FALSE, FALSE, FALSE, TRUE, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE)
|
||||||
|
)
|
||||||
|
|
||||||
# Phenotype-based, using key antimicrobials
|
# Phenotype-based, using key antimicrobials
|
||||||
expect_equal(
|
expect_equal(
|
||||||
@@ -89,7 +100,9 @@ expect_true(
|
|||||||
col_icu = example_isolates$ward == "ICU",
|
col_icu = example_isolates$ward == "ICU",
|
||||||
info = TRUE,
|
info = TRUE,
|
||||||
icu_exclude = TRUE
|
icu_exclude = TRUE
|
||||||
), na.rm = TRUE) < 950
|
),
|
||||||
|
na.rm = TRUE
|
||||||
|
) < 950
|
||||||
)
|
)
|
||||||
|
|
||||||
# set 1500 random observations to be of specimen type 'Urine'
|
# set 1500 random observations to be of specimen type 'Urine'
|
||||||
|
|||||||
@@ -28,7 +28,7 @@
|
|||||||
# ==================================================================== #
|
# ==================================================================== #
|
||||||
|
|
||||||
if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0", also_load = TRUE) &&
|
if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0", also_load = TRUE) &&
|
||||||
AMR:::pkg_is_available("ggplot2", also_load = TRUE)) {
|
AMR:::pkg_is_available("ggplot2", also_load = TRUE)) {
|
||||||
pdf(NULL) # prevent Rplots.pdf being created
|
pdf(NULL) # prevent Rplots.pdf being created
|
||||||
|
|
||||||
# data should be equal
|
# data should be equal
|
||||||
@@ -43,15 +43,19 @@ if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0", also_load = TRUE) &&
|
|||||||
summarise_all(resistance) %>%
|
summarise_all(resistance) %>%
|
||||||
as.double()
|
as.double()
|
||||||
)
|
)
|
||||||
|
|
||||||
expect_inherits(example_isolates %>%
|
expect_inherits(
|
||||||
select(AMC, CIP) %>%
|
example_isolates %>%
|
||||||
ggplot_sir(x = "interpretation", facet = "antibiotic"),
|
select(AMC, CIP) %>%
|
||||||
"gg")
|
ggplot_sir(x = "interpretation", facet = "antibiotic"),
|
||||||
expect_inherits(example_isolates %>%
|
"gg"
|
||||||
select(AMC, CIP) %>%
|
)
|
||||||
ggplot_sir(x = "antibiotic", facet = "interpretation"),
|
expect_inherits(
|
||||||
"gg")
|
example_isolates %>%
|
||||||
|
select(AMC, CIP) %>%
|
||||||
|
ggplot_sir(x = "antibiotic", facet = "interpretation"),
|
||||||
|
"gg"
|
||||||
|
)
|
||||||
|
|
||||||
expect_equal(
|
expect_equal(
|
||||||
(example_isolates %>%
|
(example_isolates %>%
|
||||||
|
|||||||
@@ -55,36 +55,38 @@ expect_equal(
|
|||||||
|
|
||||||
# test Dutch P. aeruginosa MDRO
|
# test Dutch P. aeruginosa MDRO
|
||||||
expect_equal(
|
expect_equal(
|
||||||
as.character(mdro(data.frame(
|
as.character(mdro(
|
||||||
mo = as.mo("P. aeruginosa"),
|
data.frame(
|
||||||
cfta = "S",
|
mo = as.mo("P. aeruginosa"),
|
||||||
cipr = "S",
|
cfta = "S",
|
||||||
mero = "S",
|
cipr = "S",
|
||||||
imip = "S",
|
mero = "S",
|
||||||
gent = "S",
|
imip = "S",
|
||||||
tobr = "S",
|
gent = "S",
|
||||||
pita = "S"
|
tobr = "S",
|
||||||
),
|
pita = "S"
|
||||||
guideline = "BRMO",
|
),
|
||||||
col_mo = "mo",
|
guideline = "BRMO",
|
||||||
info = FALSE
|
col_mo = "mo",
|
||||||
|
info = FALSE
|
||||||
)),
|
)),
|
||||||
"Negative"
|
"Negative"
|
||||||
)
|
)
|
||||||
expect_equal(
|
expect_equal(
|
||||||
as.character(mdro(data.frame(
|
as.character(mdro(
|
||||||
mo = as.mo("P. aeruginosa"),
|
data.frame(
|
||||||
cefta = "R",
|
mo = as.mo("P. aeruginosa"),
|
||||||
cipr = "R",
|
cefta = "R",
|
||||||
mero = "R",
|
cipr = "R",
|
||||||
imip = "R",
|
mero = "R",
|
||||||
gent = "R",
|
imip = "R",
|
||||||
tobr = "R",
|
gent = "R",
|
||||||
pita = "R"
|
tobr = "R",
|
||||||
),
|
pita = "R"
|
||||||
guideline = "BRMO",
|
),
|
||||||
col_mo = "mo",
|
guideline = "BRMO",
|
||||||
info = FALSE
|
col_mo = "mo",
|
||||||
|
info = FALSE
|
||||||
)),
|
)),
|
||||||
"Positive"
|
"Positive"
|
||||||
)
|
)
|
||||||
|
|||||||
@@ -176,4 +176,3 @@ expect_true(as.mic("32") <= as.mic(32))
|
|||||||
expect_false(as.mic("32") <= as.mic("<32"))
|
expect_false(as.mic("32") <= as.mic("<32"))
|
||||||
expect_true(as.mic("32") <= as.mic("<=32"))
|
expect_true(as.mic("32") <= as.mic("<=32"))
|
||||||
expect_false(as.mic("32") < as.mic("<=32"))
|
expect_false(as.mic("32") < as.mic("<=32"))
|
||||||
|
|
||||||
|
|||||||
@@ -78,8 +78,10 @@ current_grampos_classes <- c(
|
|||||||
"Thermoleophilia",
|
"Thermoleophilia",
|
||||||
"Thermolithobacteria"
|
"Thermolithobacteria"
|
||||||
)
|
)
|
||||||
expect_identical(sort(unique(microorganisms[which(microorganisms$phylum %in% current_grampos_phyla), "class", drop = TRUE])),
|
expect_identical(
|
||||||
current_grampos_classes)
|
sort(unique(microorganisms[which(microorganisms$phylum %in% current_grampos_phyla), "class", drop = TRUE])),
|
||||||
|
current_grampos_classes
|
||||||
|
)
|
||||||
|
|
||||||
expect_equal(mo_species("Escherichia coli"), "coli")
|
expect_equal(mo_species("Escherichia coli"), "coli")
|
||||||
expect_equal(mo_subspecies("Escherichia coli"), "")
|
expect_equal(mo_subspecies("Escherichia coli"), "")
|
||||||
@@ -103,11 +105,15 @@ expect_inherits(mo_info(c("Escherichia coli", "Staphylococcus aureus")), "list")
|
|||||||
expect_true(length(mo_group_members("B_HACEK")) > 1)
|
expect_true(length(mo_group_members("B_HACEK")) > 1)
|
||||||
expect_inherits(mo_group_members(c("Candida albicans", "Escherichia coli")), "list")
|
expect_inherits(mo_group_members(c("Candida albicans", "Escherichia coli")), "list")
|
||||||
|
|
||||||
expect_identical(mo_oxygen_tolerance(c("Klebsiella pneumoniae", "Clostridioides difficile")),
|
expect_identical(
|
||||||
c("facultative anaerobe", "anaerobe"))
|
mo_oxygen_tolerance(c("Klebsiella pneumoniae", "Clostridioides difficile")),
|
||||||
|
c("facultative anaerobe", "anaerobe")
|
||||||
|
)
|
||||||
|
|
||||||
expect_equal(as.character(table(mo_pathogenicity(example_isolates$mo))),
|
expect_equal(
|
||||||
c("1911", "72", "1", "16"))
|
as.character(table(mo_pathogenicity(example_isolates$mo))),
|
||||||
|
c("1911", "72", "1", "16")
|
||||||
|
)
|
||||||
|
|
||||||
expect_equal(mo_ref("Escherichia coli"), "Castellani et al., 1919")
|
expect_equal(mo_ref("Escherichia coli"), "Castellani et al., 1919")
|
||||||
expect_equal(mo_authors("Escherichia coli"), "Castellani et al.")
|
expect_equal(mo_authors("Escherichia coli"), "Castellani et al.")
|
||||||
@@ -118,8 +124,10 @@ expect_true(mo_url("Candida albicans") %like% "mycobank.org")
|
|||||||
expect_true(mo_url("Escherichia coli") %like% "lpsn.dsmz.de")
|
expect_true(mo_url("Escherichia coli") %like% "lpsn.dsmz.de")
|
||||||
|
|
||||||
# test integrity of getting back full names
|
# test integrity of getting back full names
|
||||||
expect_identical(microorganisms$fullname[microorganisms$fullname %unlike% "(Fungi|{)"],
|
expect_identical(
|
||||||
suppressWarnings(mo_fullname(microorganisms$fullname[microorganisms$fullname %unlike% "(Fungi|{)"], language = "en", keep_synonyms = TRUE)))
|
microorganisms$fullname[microorganisms$fullname %unlike% "(Fungi|{)"],
|
||||||
|
suppressWarnings(mo_fullname(microorganisms$fullname[microorganisms$fullname %unlike% "(Fungi|{)"], language = "en", keep_synonyms = TRUE))
|
||||||
|
)
|
||||||
|
|
||||||
# check languages
|
# check languages
|
||||||
expect_equal(mo_type("Escherichia coli", language = "de"), "Bakterien")
|
expect_equal(mo_type("Escherichia coli", language = "de"), "Bakterien")
|
||||||
@@ -169,8 +177,10 @@ expect_identical(
|
|||||||
|
|
||||||
expect_true("Escherichia blattae" %in% mo_synonyms("Shimwellia blattae"))
|
expect_true("Escherichia blattae" %in% mo_synonyms("Shimwellia blattae"))
|
||||||
expect_true(is.list(mo_synonyms(rep("Shimwellia blattae", 2))))
|
expect_true(is.list(mo_synonyms(rep("Shimwellia blattae", 2))))
|
||||||
expect_identical(mo_current(c("Escherichia blattae", "Escherichia coli")),
|
expect_identical(
|
||||||
c("Shimwellia blattae", "Escherichia coli"))
|
mo_current(c("Escherichia blattae", "Escherichia coli")),
|
||||||
|
c("Shimwellia blattae", "Escherichia coli")
|
||||||
|
)
|
||||||
|
|
||||||
expect_identical(mo_ref("Chlamydia psittaci"), "Garcia-Lopez et al., 2019")
|
expect_identical(mo_ref("Chlamydia psittaci"), "Garcia-Lopez et al., 2019")
|
||||||
expect_identical(mo_ref("Chlamydophila psittaci", keep_synonyms = TRUE), "Everett et al., 1999")
|
expect_identical(mo_ref("Chlamydophila psittaci", keep_synonyms = TRUE), "Everett et al., 1999")
|
||||||
|
|||||||
@@ -27,25 +27,27 @@
|
|||||||
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
|
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
|
||||||
# ==================================================================== #
|
# ==================================================================== #
|
||||||
|
|
||||||
resistance_data <- structure(list(
|
resistance_data <- structure(
|
||||||
order = c("Bacillales", "Enterobacterales", "Enterobacterales"),
|
list(
|
||||||
genus = c("Staphylococcus", "Escherichia", "Klebsiella"),
|
order = c("Bacillales", "Enterobacterales", "Enterobacterales"),
|
||||||
AMC = c(0.00425, 0.13062, 0.10344),
|
genus = c("Staphylococcus", "Escherichia", "Klebsiella"),
|
||||||
CXM = c(0.00425, 0.05376, 0.10344),
|
AMC = c(0.00425, 0.13062, 0.10344),
|
||||||
CTX = c(0.00000, 0.02396, 0.05172),
|
CXM = c(0.00425, 0.05376, 0.10344),
|
||||||
TOB = c(0.02325, 0.02597, 0.10344),
|
CTX = c(0.00000, 0.02396, 0.05172),
|
||||||
TMP = c(0.08387, 0.39141, 0.18367)
|
TOB = c(0.02325, 0.02597, 0.10344),
|
||||||
),
|
TMP = c(0.08387, 0.39141, 0.18367)
|
||||||
class = c("grouped_df", "tbl_df", "tbl", "data.frame"),
|
),
|
||||||
row.names = c(NA, -3L),
|
class = c("grouped_df", "tbl_df", "tbl", "data.frame"),
|
||||||
groups = structure(list(
|
row.names = c(NA, -3L),
|
||||||
order = c("Bacillales", "Enterobacterales"),
|
groups = structure(
|
||||||
.rows = list(1L, 2:3)
|
list(
|
||||||
),
|
order = c("Bacillales", "Enterobacterales"),
|
||||||
row.names = c(NA, -2L),
|
.rows = list(1L, 2:3)
|
||||||
class = c("tbl_df", "tbl", "data.frame"),
|
),
|
||||||
.drop = TRUE
|
row.names = c(NA, -2L),
|
||||||
)
|
class = c("tbl_df", "tbl", "data.frame"),
|
||||||
|
.drop = TRUE
|
||||||
|
)
|
||||||
)
|
)
|
||||||
pca_model <- pca(resistance_data)
|
pca_model <- pca(resistance_data)
|
||||||
expect_inherits(pca_model, "pca")
|
expect_inherits(pca_model, "pca")
|
||||||
|
|||||||
@@ -29,7 +29,7 @@
|
|||||||
|
|
||||||
if (AMR:::pkg_is_available("ggplot2", also_load = TRUE)) {
|
if (AMR:::pkg_is_available("ggplot2", also_load = TRUE)) {
|
||||||
pdf(NULL) # prevent Rplots.pdf being created
|
pdf(NULL) # prevent Rplots.pdf being created
|
||||||
|
|
||||||
# scale_*_mic
|
# scale_*_mic
|
||||||
aesthetics <- c("x", "y", "colour", "fill")
|
aesthetics <- c("x", "y", "colour", "fill")
|
||||||
expected_methods <- c("transform", "transform_df", "breaks", "labels", "limits")
|
expected_methods <- c("transform", "transform_df", "breaks", "labels", "limits")
|
||||||
@@ -38,10 +38,11 @@ if (AMR:::pkg_is_available("ggplot2", also_load = TRUE)) {
|
|||||||
scale_obj <- getExportedValue("ggplot2", scale_fn_name)()
|
scale_obj <- getExportedValue("ggplot2", scale_fn_name)()
|
||||||
for (method in expected_methods) {
|
for (method in expected_methods) {
|
||||||
expect_true(is.function(scale_obj[[method]]) || method %in% names(scale_obj),
|
expect_true(is.function(scale_obj[[method]]) || method %in% names(scale_obj),
|
||||||
info = paste0("Method '", method, "' is missing in ggplot2::", scale_fn_name))
|
info = paste0("Method '", method, "' is missing in ggplot2::", scale_fn_name)
|
||||||
|
)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
# scale_*_sir
|
# scale_*_sir
|
||||||
aesthetics <- c("colour", "fill")
|
aesthetics <- c("colour", "fill")
|
||||||
expected_methods <- c("transform", "transform_df", "labels", "limits")
|
expected_methods <- c("transform", "transform_df", "labels", "limits")
|
||||||
@@ -50,38 +51,64 @@ if (AMR:::pkg_is_available("ggplot2", also_load = TRUE)) {
|
|||||||
scale_obj <- getExportedValue("ggplot2", scale_fn_name)(aesthetics = aest)
|
scale_obj <- getExportedValue("ggplot2", scale_fn_name)(aesthetics = aest)
|
||||||
for (method in expected_methods) {
|
for (method in expected_methods) {
|
||||||
expect_true(is.function(scale_obj[[method]]) || method %in% names(scale_obj),
|
expect_true(is.function(scale_obj[[method]]) || method %in% names(scale_obj),
|
||||||
info = paste0("Method '", method, "' is missing in ggplot2::", scale_fn_name))
|
info = paste0("Method '", method, "' is missing in ggplot2::", scale_fn_name)
|
||||||
|
)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
for (method in expected_methods) {
|
for (method in expected_methods) {
|
||||||
expect_true(is.function(ggplot2::scale_x_discrete()[[method]]) || method %in% names(ggplot2::scale_x_discrete()),
|
expect_true(is.function(ggplot2::scale_x_discrete()[[method]]) || method %in% names(ggplot2::scale_x_discrete()),
|
||||||
info = paste0("Method '", method, "' is missing in ggplot2::", "scale_x_discrete"))
|
info = paste0("Method '", method, "' is missing in ggplot2::", "scale_x_discrete")
|
||||||
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
expect_inherits(ggplot(data.frame(count = c(1,2,3, 4),
|
expect_inherits(
|
||||||
sir = c("S", "I", "R", "SDD")),
|
ggplot(
|
||||||
aes(x = sir, y = count, fill = sir)) +
|
data.frame(
|
||||||
geom_col() +
|
count = c(1, 2, 3, 4),
|
||||||
scale_x_sir(eucast_I = F, language = "el") +
|
sir = c("S", "I", "R", "SDD")
|
||||||
scale_fill_sir(eucast_I = T, language = "nl"),
|
),
|
||||||
"gg")
|
aes(x = sir, y = count, fill = sir)
|
||||||
expect_inherits(ggplot(data.frame(mic = as.mic(c(2,4,8, 16)),
|
) +
|
||||||
sir = as.sir(c("S", "I", "R", "SDD"))),
|
geom_col() +
|
||||||
aes(x = sir, y = mic)) +
|
scale_x_sir(eucast_I = F, language = "el") +
|
||||||
geom_point() +
|
scale_fill_sir(eucast_I = T, language = "nl"),
|
||||||
scale_y_mic(),
|
"gg"
|
||||||
"gg")
|
)
|
||||||
expect_inherits(ggplot(data.frame(mic = as.mic(c(2,4,8, 16)),
|
expect_inherits(
|
||||||
sir = as.sir(c("S", "I", "R", "SDD"))),
|
ggplot(
|
||||||
aes(x = sir, y = mic)) +
|
data.frame(
|
||||||
geom_col() +
|
mic = as.mic(c(2, 4, 8, 16)),
|
||||||
scale_y_mic(),
|
sir = as.sir(c("S", "I", "R", "SDD"))
|
||||||
"gg")
|
),
|
||||||
expect_inherits(ggplot(data.frame(mic = as.mic(c(2,4,8, 16)),
|
aes(x = sir, y = mic)
|
||||||
sir = as.sir(c("S", "I", "R", "SDD"))),
|
) +
|
||||||
aes(x = sir, y = mic)) +
|
geom_point() +
|
||||||
geom_col() +
|
scale_y_mic(),
|
||||||
scale_y_mic(mic_range = c(4,16)) +
|
"gg"
|
||||||
scale_x_sir(),
|
)
|
||||||
"gg")
|
expect_inherits(
|
||||||
|
ggplot(
|
||||||
|
data.frame(
|
||||||
|
mic = as.mic(c(2, 4, 8, 16)),
|
||||||
|
sir = as.sir(c("S", "I", "R", "SDD"))
|
||||||
|
),
|
||||||
|
aes(x = sir, y = mic)
|
||||||
|
) +
|
||||||
|
geom_col() +
|
||||||
|
scale_y_mic(),
|
||||||
|
"gg"
|
||||||
|
)
|
||||||
|
expect_inherits(
|
||||||
|
ggplot(
|
||||||
|
data.frame(
|
||||||
|
mic = as.mic(c(2, 4, 8, 16)),
|
||||||
|
sir = as.sir(c("S", "I", "R", "SDD"))
|
||||||
|
),
|
||||||
|
aes(x = sir, y = mic)
|
||||||
|
) +
|
||||||
|
geom_col() +
|
||||||
|
scale_y_mic(mic_range = c(4, 16)) +
|
||||||
|
scale_x_sir(),
|
||||||
|
"gg"
|
||||||
|
)
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -109,7 +109,7 @@ if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0", also_load = TRUE)) {
|
|||||||
example_isolates$AMX %>% proportion_R()
|
example_isolates$AMX %>% proportion_R()
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
|
||||||
# expect_warning(example_isolates %>% group_by(ward) %>% summarise(across(KAN, sir_confidence_interval)))
|
# expect_warning(example_isolates %>% group_by(ward) %>% summarise(across(KAN, sir_confidence_interval)))
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
@@ -88,18 +88,18 @@ if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0", also_load = TRUE)) {
|
|||||||
expect_equal(sum(is.sir(example_isolates)), 40)
|
expect_equal(sum(is.sir(example_isolates)), 40)
|
||||||
|
|
||||||
expect_stdout(print(tibble(ab = as.sir("S"))))
|
expect_stdout(print(tibble(ab = as.sir("S"))))
|
||||||
|
|
||||||
expect_true(example_isolates %>%
|
expect_true(example_isolates %>%
|
||||||
select(AMC, MEM) %>%
|
select(AMC, MEM) %>%
|
||||||
mutate(MEM = as.sir(ifelse(AMC == "S", "S", MEM))) %>%
|
mutate(MEM = as.sir(ifelse(AMC == "S", "S", MEM))) %>%
|
||||||
pull(MEM) %>%
|
pull(MEM) %>%
|
||||||
is.sir())
|
is.sir())
|
||||||
|
|
||||||
expect_true(example_isolates %>%
|
expect_true(example_isolates %>%
|
||||||
select(AMC, MEM) %>%
|
select(AMC, MEM) %>%
|
||||||
mutate(MEM = if_else(AMC == "S", "S", MEM)) %>%
|
mutate(MEM = if_else(AMC == "S", "S", MEM)) %>%
|
||||||
pull(MEM) %>%
|
pull(MEM) %>%
|
||||||
is.sir())
|
is.sir())
|
||||||
}
|
}
|
||||||
if (AMR:::pkg_is_available("skimr", min_version = "2.0.0", also_load = TRUE)) {
|
if (AMR:::pkg_is_available("skimr", min_version = "2.0.0", also_load = TRUE)) {
|
||||||
expect_inherits(
|
expect_inherits(
|
||||||
@@ -124,58 +124,78 @@ expect_equal(as.sir(c("", "-", NA, "NULL")), c(NA_sir_, NA_sir_, NA_sir_, NA_sir
|
|||||||
|
|
||||||
# Human -------------------------------------------------------------------
|
# Human -------------------------------------------------------------------
|
||||||
|
|
||||||
mics <- as.mic(2 ^ c(-4:6)) # 0.0625 to 64 in factors of 2
|
mics <- as.mic(2^c(-4:6)) # 0.0625 to 64 in factors of 2
|
||||||
expect_identical(as.character(as.sir(mics, mo = "Enterobacterales", ab = "AMC", guideline = "EUCAST 2022",
|
expect_identical(
|
||||||
uti = FALSE, include_PKPD = FALSE)),
|
as.character(as.sir(mics,
|
||||||
c("S", "S", "S", "S", "S", "S", "S", "S", "R", "R", "R"))
|
mo = "Enterobacterales", ab = "AMC", guideline = "EUCAST 2022",
|
||||||
expect_identical(as.character(as.sir(mics, mo = "Enterobacterales", ab = "AMC", guideline = "EUCAST 2022",
|
uti = FALSE, include_PKPD = FALSE
|
||||||
uti = TRUE, include_PKPD = FALSE)),
|
)),
|
||||||
c("S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "R"))
|
c("S", "S", "S", "S", "S", "S", "S", "S", "R", "R", "R")
|
||||||
expect_identical(as.character(as.sir(mics, mo = "Escherichia coli", ab = "AMC", guideline = "EUCAST 2022",
|
)
|
||||||
uti = FALSE, include_PKPD = FALSE)),
|
expect_identical(
|
||||||
c("S", "S", "S", "S", "S", "S", "S", "S", "R", "R", "R"))
|
as.character(as.sir(mics,
|
||||||
|
mo = "Enterobacterales", ab = "AMC", guideline = "EUCAST 2022",
|
||||||
|
uti = TRUE, include_PKPD = FALSE
|
||||||
|
)),
|
||||||
|
c("S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "R")
|
||||||
|
)
|
||||||
|
expect_identical(
|
||||||
|
as.character(as.sir(mics,
|
||||||
|
mo = "Escherichia coli", ab = "AMC", guideline = "EUCAST 2022",
|
||||||
|
uti = FALSE, include_PKPD = FALSE
|
||||||
|
)),
|
||||||
|
c("S", "S", "S", "S", "S", "S", "S", "S", "R", "R", "R")
|
||||||
|
)
|
||||||
|
|
||||||
# test SIR using dplyr's mutate_if(...) and mutate(across(...))
|
# test SIR using dplyr's mutate_if(...) and mutate(across(...))
|
||||||
out1 <- as.sir(as.mic(c(0.256, 0.5, 1, 2)), mo = "Escherichia coli", ab = "ertapenem", guideline = "EUCAST 2023")
|
out1 <- as.sir(as.mic(c(0.256, 0.5, 1, 2)), mo = "Escherichia coli", ab = "ertapenem", guideline = "EUCAST 2023")
|
||||||
expect_identical(out1, as.sir(c("S", "S", "R", "R")))
|
expect_identical(out1, as.sir(c("S", "S", "R", "R")))
|
||||||
if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0", also_load = TRUE)) {
|
if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0", also_load = TRUE)) {
|
||||||
out2 <- data.frame(mo = "Escherichia coli",
|
out2 <- data.frame(
|
||||||
ab = "ertapenem",
|
mo = "Escherichia coli",
|
||||||
some_mics = as.mic(c(0.256, 0.5, 1, 2))) %>%
|
ab = "ertapenem",
|
||||||
mutate(across(where(is.mic), function(x) as.sir(x, mo = "mo", ab = "ab", guideline = "EUCAST 2023"))) %>%
|
some_mics = as.mic(c(0.256, 0.5, 1, 2))
|
||||||
|
) %>%
|
||||||
|
mutate(across(where(is.mic), function(x) as.sir(x, mo = "mo", ab = "ab", guideline = "EUCAST 2023"))) %>%
|
||||||
pull(some_mics)
|
pull(some_mics)
|
||||||
out3 <- data.frame(mo = "Escherichia coli",
|
out3 <- data.frame(
|
||||||
ab = "ertapenem",
|
mo = "Escherichia coli",
|
||||||
some_mics = as.mic(c(0.256, 0.5, 1, 2))) %>%
|
ab = "ertapenem",
|
||||||
mutate_if(is.mic, as.sir, mo = "mo", ab = "ab", guideline = "EUCAST 2023") %>%
|
some_mics = as.mic(c(0.256, 0.5, 1, 2))
|
||||||
|
) %>%
|
||||||
|
mutate_if(is.mic, as.sir, mo = "mo", ab = "ab", guideline = "EUCAST 2023") %>%
|
||||||
pull(some_mics)
|
pull(some_mics)
|
||||||
|
|
||||||
expect_identical(out1, out2)
|
expect_identical(out1, out2)
|
||||||
expect_identical(out1, out3)
|
expect_identical(out1, out3)
|
||||||
}
|
}
|
||||||
|
|
||||||
# S. pneumoniae/ampicillin in EUCAST 2020: 0.5-2 ug/ml (R is only > 2)
|
# S. pneumoniae/ampicillin in EUCAST 2020: 0.5-2 ug/ml (R is only > 2)
|
||||||
expect_equal(suppressMessages(
|
expect_equal(
|
||||||
as.character(
|
suppressMessages(
|
||||||
as.sir(
|
as.character(
|
||||||
x = as.mic(c(0.125, 0.5, 1, 2, 4)),
|
as.sir(
|
||||||
mo = "B_STRPT_PNMN",
|
x = as.mic(c(0.125, 0.5, 1, 2, 4)),
|
||||||
ab = "AMP",
|
mo = "B_STRPT_PNMN",
|
||||||
guideline = "EUCAST 2020"
|
ab = "AMP",
|
||||||
|
guideline = "EUCAST 2020"
|
||||||
|
)
|
||||||
)
|
)
|
||||||
)),
|
),
|
||||||
c("S", "S", "I", "I", "R")
|
c("S", "S", "I", "I", "R")
|
||||||
)
|
)
|
||||||
# S. pneumoniae/amoxicillin in CLSI 2019: 2-8 ug/ml (R is 8 and > 8)
|
# S. pneumoniae/amoxicillin in CLSI 2019: 2-8 ug/ml (R is 8 and > 8)
|
||||||
expect_equal(suppressMessages(
|
expect_equal(
|
||||||
as.character(
|
suppressMessages(
|
||||||
as.sir(
|
as.character(
|
||||||
x = as.mic(c(1, 2, 4, 8, 16)),
|
as.sir(
|
||||||
mo = "B_STRPT_PNMN",
|
x = as.mic(c(1, 2, 4, 8, 16)),
|
||||||
ab = "AMX",
|
mo = "B_STRPT_PNMN",
|
||||||
guideline = "CLSI 2019"
|
ab = "AMX",
|
||||||
|
guideline = "CLSI 2019"
|
||||||
|
)
|
||||||
)
|
)
|
||||||
)),
|
),
|
||||||
c("S", "S", "I", "R", "R")
|
c("S", "S", "I", "R", "R")
|
||||||
)
|
)
|
||||||
|
|
||||||
@@ -241,20 +261,28 @@ if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0", also_load = TRUE)) {
|
|||||||
as.sir(guideline = "CLSI") %>%
|
as.sir(guideline = "CLSI") %>%
|
||||||
pull(amox_disk) %>%
|
pull(amox_disk) %>%
|
||||||
is.sir())
|
is.sir())
|
||||||
|
|
||||||
# used by group_by() on sir_calc_df(), check some internals to see if grouped calculation without tidyverse works
|
# used by group_by() on sir_calc_df(), check some internals to see if grouped calculation without tidyverse works
|
||||||
groups <- example_isolates %>%
|
groups <- example_isolates %>%
|
||||||
group_by(mo) %>%
|
group_by(mo) %>%
|
||||||
attributes() %>%
|
attributes() %>%
|
||||||
.$groups
|
.$groups
|
||||||
expect_equal(nrow(groups),
|
expect_equal(
|
||||||
90)
|
nrow(groups),
|
||||||
expect_equal(class(groups$.rows),
|
90
|
||||||
c("vctrs_list_of", "vctrs_vctr", "list"))
|
)
|
||||||
expect_equal(groups$.rows[[1]],
|
expect_equal(
|
||||||
c(101, 524, 1368))
|
class(groups$.rows),
|
||||||
expect_equal(example_isolates[c(101, 524, 1368), "mo", drop = TRUE],
|
c("vctrs_list_of", "vctrs_vctr", "list")
|
||||||
rep(groups$mo[1], 3))
|
)
|
||||||
|
expect_equal(
|
||||||
|
groups$.rows[[1]],
|
||||||
|
c(101, 524, 1368)
|
||||||
|
)
|
||||||
|
expect_equal(
|
||||||
|
example_isolates[c(101, 524, 1368), "mo", drop = TRUE],
|
||||||
|
rep(groups$mo[1], 3)
|
||||||
|
)
|
||||||
}
|
}
|
||||||
# frequency tables
|
# frequency tables
|
||||||
if (AMR:::pkg_is_available("cleaner")) {
|
if (AMR:::pkg_is_available("cleaner")) {
|
||||||
@@ -295,27 +323,35 @@ expect_message(as.sir(data.frame(
|
|||||||
)))
|
)))
|
||||||
|
|
||||||
# SDD vs I in CLSI 2024
|
# SDD vs I in CLSI 2024
|
||||||
expect_identical(as.sir(as.mic(2 ^ c(-2:4)), mo = "Enterococcus faecium", ab = "Dapto", guideline = "CLSI 2024"),
|
expect_identical(
|
||||||
as.sir(c("SDD", "SDD", "SDD", "SDD", "SDD", "R", "R")))
|
as.sir(as.mic(2^c(-2:4)), mo = "Enterococcus faecium", ab = "Dapto", guideline = "CLSI 2024"),
|
||||||
expect_identical(as.sir(as.mic(2 ^ c(-2:2)), mo = "Enterococcus faecium", ab = "Cipro
|
as.sir(c("SDD", "SDD", "SDD", "SDD", "SDD", "R", "R"))
|
||||||
|
)
|
||||||
|
expect_identical(
|
||||||
|
as.sir(as.mic(2^c(-2:2)), mo = "Enterococcus faecium", ab = "Cipro
|
||||||
", guideline = "CLSI 2024"),
|
", guideline = "CLSI 2024"),
|
||||||
as.sir(c("S", "S", "S", "I", "R")))
|
as.sir(c("S", "S", "S", "I", "R"))
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
# Veterinary --------------------------------------------------------------
|
# Veterinary --------------------------------------------------------------
|
||||||
|
|
||||||
sir_history <- sir_interpretation_history(clean = TRUE)
|
sir_history <- sir_interpretation_history(clean = TRUE)
|
||||||
|
|
||||||
mics <- as.mic(2 ^ c(-4:6)) # 0.0625 to 64 in factors of 2
|
mics <- as.mic(2^c(-4:6)) # 0.0625 to 64 in factors of 2
|
||||||
vet <- data.frame(animal = c(rep("cat", 3), rep("dogs", 3), "canine", "equine", "horse", "cattle", "bird"),
|
vet <- data.frame(
|
||||||
PRA = mics,
|
animal = c(rep("cat", 3), rep("dogs", 3), "canine", "equine", "horse", "cattle", "bird"),
|
||||||
FLR = mics,
|
PRA = mics,
|
||||||
mo = mo_name(rep(c("B_ESCHR_COLI", "B_PSTRL_MLTC", "B_MNNHM_HMLY"), 4)[-1]))
|
FLR = mics,
|
||||||
|
mo = mo_name(rep(c("B_ESCHR_COLI", "B_PSTRL_MLTC", "B_MNNHM_HMLY"), 4)[-1])
|
||||||
|
)
|
||||||
|
|
||||||
out_vet <- as.sir(vet, host = vet$animal, guideline = "CLSI 2023")
|
out_vet <- as.sir(vet, host = vet$animal, guideline = "CLSI 2023")
|
||||||
# host column name instead of values
|
# host column name instead of values
|
||||||
expect_identical(out_vet,
|
expect_identical(
|
||||||
as.sir(vet, host = "animal", guideline = "CLSI 2023"))
|
out_vet,
|
||||||
|
as.sir(vet, host = "animal", guideline = "CLSI 2023")
|
||||||
|
)
|
||||||
|
|
||||||
# check outcomes
|
# check outcomes
|
||||||
expect_identical(out_vet$PRA, as.sir(c("S", NA, "S", NA, NA, "R", NA, NA, NA, "I", NA)))
|
expect_identical(out_vet$PRA, as.sir(c("S", NA, "S", NA, NA, "R", NA, NA, NA, "I", NA)))
|
||||||
@@ -326,11 +362,15 @@ expect_identical(out_vet$PRA, rep(NA_sir_, 11))
|
|||||||
expect_identical(out_vet$FLR, as.sir(c("S", "S", NA, "S", "S", NA, "I", "R", NA, "R", "R")))
|
expect_identical(out_vet$FLR, as.sir(c("S", "S", NA, "S", "S", NA, "I", "R", NA, "R", "R")))
|
||||||
|
|
||||||
sir_history <- sir_interpretation_history()
|
sir_history <- sir_interpretation_history()
|
||||||
expect_identical(sort(sir_history$host),
|
expect_identical(
|
||||||
c("cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats",
|
sort(sir_history$host),
|
||||||
"cats", "cats", "cats", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "dogs",
|
c(
|
||||||
"dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs",
|
"cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats",
|
||||||
"horse", "horse", "horse", "horse", "horse", "horse", "horse", "horse", "horse", "poultry","poultry","poultry","poultry"))
|
"cats", "cats", "cats", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "dogs",
|
||||||
|
"dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs",
|
||||||
|
"horse", "horse", "horse", "horse", "horse", "horse", "horse", "horse", "horse", "poultry", "poultry", "poultry", "poultry"
|
||||||
|
)
|
||||||
|
)
|
||||||
|
|
||||||
# ECOFF -------------------------------------------------------------------
|
# ECOFF -------------------------------------------------------------------
|
||||||
|
|
||||||
@@ -340,4 +380,3 @@ expect_equal(
|
|||||||
)
|
)
|
||||||
# old method
|
# old method
|
||||||
expect_warning(as.sir(as.mic(2), "E. coli", "ampicillin", guideline = "EUCAST 2020", ecoff = TRUE))
|
expect_warning(as.sir(as.mic(2), "E. coli", "ampicillin", guideline = "EUCAST 2020", ecoff = TRUE))
|
||||||
|
|
||||||
|
|||||||
@@ -29,11 +29,13 @@
|
|||||||
|
|
||||||
# extra tests for {vctrs} pkg support
|
# extra tests for {vctrs} pkg support
|
||||||
if (AMR:::pkg_is_available("tibble")) {
|
if (AMR:::pkg_is_available("tibble")) {
|
||||||
test <- tibble::tibble(ab = as.ab("CIP"),
|
test <- tibble::tibble(
|
||||||
mo = as.mo("Escherichia coli"),
|
ab = as.ab("CIP"),
|
||||||
mic = as.mic(2),
|
mo = as.mo("Escherichia coli"),
|
||||||
disk = as.disk(20),
|
mic = as.mic(2),
|
||||||
sir = as.sir("S"))
|
disk = as.disk(20),
|
||||||
|
sir = as.sir("S")
|
||||||
|
)
|
||||||
check1 <- lapply(test, class)
|
check1 <- lapply(test, class)
|
||||||
test[1, "ab"] <- "GEN"
|
test[1, "ab"] <- "GEN"
|
||||||
test[1, "mo"] <- "B_KLBSL_PNMN"
|
test[1, "mo"] <- "B_KLBSL_PNMN"
|
||||||
@@ -45,9 +47,11 @@ if (AMR:::pkg_is_available("tibble")) {
|
|||||||
test[1, "sir"] <- "R"
|
test[1, "sir"] <- "R"
|
||||||
check2 <- lapply(test, class)
|
check2 <- lapply(test, class)
|
||||||
expect_identical(check1, check2)
|
expect_identical(check1, check2)
|
||||||
|
|
||||||
test <- tibble::tibble(cipro = as.sir("S"),
|
test <- tibble::tibble(
|
||||||
variable = "test")
|
cipro = as.sir("S"),
|
||||||
|
variable = "test"
|
||||||
|
)
|
||||||
expect_equal(nrow(test[quinolones() == "S", ]), 1)
|
expect_equal(nrow(test[quinolones() == "S", ]), 1)
|
||||||
expect_equal(nrow(test[quinolones() == "R", ]), 0)
|
expect_equal(nrow(test[quinolones() == "R", ]), 0)
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -146,14 +146,16 @@ for (i in seq_len(length(import_functions))) {
|
|||||||
fn <- names(import_functions)[i]
|
fn <- names(import_functions)[i]
|
||||||
pkg <- unname(import_functions[i])
|
pkg <- unname(import_functions[i])
|
||||||
expect_true(pkg %in% suggests,
|
expect_true(pkg %in% suggests,
|
||||||
info = paste0("package `", pkg, "` is not in Suggests"))
|
info = paste0("package `", pkg, "` is not in Suggests")
|
||||||
|
)
|
||||||
# function should exist in foreign pkg namespace
|
# function should exist in foreign pkg namespace
|
||||||
if (AMR:::pkg_is_available(pkg,
|
if (AMR:::pkg_is_available(pkg,
|
||||||
also_load = FALSE,
|
also_load = FALSE,
|
||||||
min_version = if (pkg == "dplyr") "1.0.0" else NULL
|
min_version = if (pkg == "dplyr") "1.0.0" else NULL
|
||||||
)) {
|
)) {
|
||||||
expect_true(!is.null(AMR:::import_fn(name = fn, pkg = pkg, error_on_fail = FALSE)),
|
expect_true(!is.null(AMR:::import_fn(name = fn, pkg = pkg, error_on_fail = FALSE)),
|
||||||
info = paste0("Function does not exist (anymore): function `", pkg, "::", fn, "()`"))
|
info = paste0("Function does not exist (anymore): function `", pkg, "::", fn, "()`")
|
||||||
|
)
|
||||||
} else if (pkg != "rstudioapi") {
|
} else if (pkg != "rstudioapi") {
|
||||||
warning("Package '", pkg, "' not available")
|
warning("Package '", pkg, "' not available")
|
||||||
}
|
}
|
||||||
|
|||||||
Reference in New Issue
Block a user