mirror of
https://github.com/msberends/AMR.git
synced 2026-10-01 04:13:33 +02:00
Compare commits
42
Commits
v1.4.0
...
81af41da3a
No files matched your search
@@ -21,6 +21,7 @@
|
||||
^public$
|
||||
^data-raw$
|
||||
^\.lintr$
|
||||
^tests/testthat/_snaps$
|
||||
^vignettes/AMR.Rmd$
|
||||
^vignettes/benchmarks.Rmd$
|
||||
^vignettes/EUCAST.Rmd$
|
||||
|
||||
@@ -41,31 +41,34 @@ name: R-code-check
|
||||
jobs:
|
||||
R-code-check:
|
||||
runs-on: ${{ matrix.config.os }}
|
||||
|
||||
continue-on-error: ${{ matrix.config.allowfail }}
|
||||
|
||||
name: ${{ matrix.config.os }} (${{ matrix.config.r }})
|
||||
name: ${{ matrix.config.os }} (R-${{ matrix.config.r }})
|
||||
|
||||
strategy:
|
||||
fail-fast: false
|
||||
matrix:
|
||||
config:
|
||||
- {os: windows-latest, r: 'release'}
|
||||
- {os: macOS-latest, r: 'release'}
|
||||
- {os: ubuntu-16.04, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
|
||||
# - {os: windows-latest, r: 'oldrel'}
|
||||
# - {os: macOS-latest, r: 'oldrel'}
|
||||
# - {os: ubuntu-16.04, r: 'oldrel', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
|
||||
- {os: windows-latest, r: 'devel'}
|
||||
# - {os: macOS-latest, r: 'devel'}
|
||||
# - {os: ubuntu-16.04, r: '4.0', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
|
||||
# - {os: windows-latest, r: '3.6'}
|
||||
# - {os: ubuntu-16.04, r: '3.5', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
|
||||
# - {os: ubuntu-16.04, r: '3.4', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
|
||||
# - {os: ubuntu-16.04, r: '3.3', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
|
||||
|
||||
- {os: macOS-latest, r: 'devel', allowfail: false}
|
||||
- {os: macOS-latest, r: 'release', allowfail: false}
|
||||
- {os: macOS-latest, r: 'oldrel', allowfail: false}
|
||||
- {os: windows-latest, r: 'devel', allowfail: false}
|
||||
- {os: windows-latest, r: 'release', allowfail: false}
|
||||
- {os: windows-latest, r: 'oldrel', allowfail: false}
|
||||
- {os: ubuntu-16.04, r: 'devel', allowfail: true, rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
|
||||
- {os: ubuntu-16.04, r: 'release', allowfail: false, rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
|
||||
- {os: ubuntu-16.04, r: 'oldrel', allowfail: true, rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
|
||||
- {os: ubuntu-16.04, r: '4.0', allowfail: false, rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
|
||||
- {os: ubuntu-16.04, r: '3.6', allowfail: false, rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
|
||||
- {os: ubuntu-16.04, r: '3.5', allowfail: false, rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
|
||||
- {os: ubuntu-16.04, r: '3.4', allowfail: true, rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
|
||||
- {os: ubuntu-16.04, r: '3.3', allowfail: true, rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
|
||||
# - {os: ubuntu-16.04, r: '3.2', allowfail: true, rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
|
||||
# older R versions cannot be tested, since tidyverse only supports last 4 R x.x versions
|
||||
env:
|
||||
R_REMOTES_NO_ERRORS_FROM_WARNINGS: true
|
||||
RSPM: ${{ matrix.config.rspm }}
|
||||
GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
|
||||
|
||||
steps:
|
||||
- uses: actions/checkout@v2
|
||||
@@ -80,7 +83,6 @@ jobs:
|
||||
run: |
|
||||
install.packages('remotes')
|
||||
saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2)
|
||||
writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version")
|
||||
shell: Rscript {0}
|
||||
|
||||
- name: Cache R packages
|
||||
@@ -88,10 +90,10 @@ jobs:
|
||||
uses: actions/cache@v1
|
||||
with:
|
||||
path: ${{ env.R_LIBS_USER }}
|
||||
key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }}
|
||||
restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-
|
||||
key: ${{ runner.os }}-r-${{ matrix.config.r }}-3-${{ hashFiles('.github/depends.Rds') }}
|
||||
restore-keys: ${{ runner.os }}-r-${{ matrix.config.r }}-3-
|
||||
|
||||
- name: Install system dependencies
|
||||
- name: Install Linux dependencies
|
||||
if: runner.os == 'Linux'
|
||||
env:
|
||||
RHUB_PLATFORM: linux-x86_64-ubuntu-gcc
|
||||
@@ -100,6 +102,11 @@ jobs:
|
||||
sysreqs=$(Rscript -e "cat(sysreqs::sysreq_commands('DESCRIPTION'))")
|
||||
sudo -s eval "$sysreqs"
|
||||
|
||||
- name: Install macOS dependencies
|
||||
if: matrix.config.os == 'macOS-latest' && matrix.config.r == 'devel'
|
||||
run: |
|
||||
brew install mariadb-connector-c
|
||||
|
||||
- name: Install dependencies
|
||||
run: |
|
||||
remotes::install_deps(dependencies = TRUE)
|
||||
@@ -113,7 +120,7 @@ jobs:
|
||||
sessioninfo::session_info(pkgs, include_base = TRUE)
|
||||
shell: Rscript {0}
|
||||
|
||||
- name: Check
|
||||
- name: Run Check
|
||||
env:
|
||||
_R_CHECK_CRAN_INCOMING_: false
|
||||
run: rcmdcheck::rcmdcheck(args = c("--no-manual", "--as-cran"), error_on = "warning", check_dir = "check")
|
||||
@@ -126,7 +133,7 @@ jobs:
|
||||
|
||||
- name: Upload check results
|
||||
if: failure()
|
||||
uses: actions/upload-artifact@main
|
||||
uses: actions/upload-artifact@master
|
||||
with:
|
||||
name: ${{ runner.os }}-r${{ matrix.config.r }}-results
|
||||
path: check
|
||||
@@ -67,5 +67,5 @@ jobs:
|
||||
shell: Rscript {0}
|
||||
|
||||
- name: Test coverage
|
||||
run: covr::codecov(line_exclusions = list("R/atc_online.R", "R/mo_source.R", "R/resistance_predict.R", "R/aa_helper_functions.R", "R/aa_helper_pm_functions.R", "R/zzz.R"), quiet = FALSE)
|
||||
run: covr::codecov(line_exclusions = list("R/atc_online.R", "R/mo_source.R", "R/translate.R", "R/resistance_predict.R", "R/aa_helper_functions.R", "R/aa_helper_pm_functions.R", "R/zzz.R"), quiet = FALSE)
|
||||
shell: Rscript {0}
|
||||
+4
-2
@@ -1,6 +1,6 @@
|
||||
Package: AMR
|
||||
Version: 1.4.0
|
||||
Date: 2020-10-08
|
||||
Version: 1.4.0.9041
|
||||
Date: 2020-12-17
|
||||
Title: Antimicrobial Resistance Analysis
|
||||
Authors@R: c(
|
||||
person(role = c("aut", "cre"),
|
||||
@@ -47,6 +47,7 @@ Suggests:
|
||||
ggplot2,
|
||||
knitr,
|
||||
microbenchmark,
|
||||
pillar,
|
||||
readxl,
|
||||
rmarkdown,
|
||||
rstudioapi,
|
||||
@@ -54,6 +55,7 @@ Suggests:
|
||||
skimr,
|
||||
testthat,
|
||||
tidyr,
|
||||
tidyselect,
|
||||
xml2
|
||||
VignetteBuilder: knitr,rmarkdown
|
||||
URL: https://msberends.github.io/AMR/, https://github.com/msberends/AMR
|
||||
|
||||
@@ -40,6 +40,7 @@ S3method(format,bug_drug_combinations)
|
||||
S3method(kurtosis,data.frame)
|
||||
S3method(kurtosis,default)
|
||||
S3method(kurtosis,matrix)
|
||||
S3method(plot,disk)
|
||||
S3method(plot,mic)
|
||||
S3method(plot,resistance_predict)
|
||||
S3method(plot,rsi)
|
||||
@@ -150,6 +151,7 @@ export(is.mic)
|
||||
export(is.mo)
|
||||
export(is.rsi)
|
||||
export(is.rsi.eligible)
|
||||
export(is_new_episode)
|
||||
export(key_antibiotics)
|
||||
export(key_antibiotics_equal)
|
||||
export(kurtosis)
|
||||
@@ -169,6 +171,9 @@ export(mo_fullname)
|
||||
export(mo_genus)
|
||||
export(mo_gramstain)
|
||||
export(mo_info)
|
||||
export(mo_is_gram_negative)
|
||||
export(mo_is_gram_positive)
|
||||
export(mo_is_intrinsic_resistant)
|
||||
export(mo_kingdom)
|
||||
export(mo_matching_score)
|
||||
export(mo_name)
|
||||
@@ -199,6 +204,9 @@ export(proportion_R)
|
||||
export(proportion_S)
|
||||
export(proportion_SI)
|
||||
export(proportion_df)
|
||||
export(random_disk)
|
||||
export(random_mic)
|
||||
export(random_rsi)
|
||||
export(resistance)
|
||||
export(resistance_predict)
|
||||
export(right_join_microorganisms)
|
||||
|
||||
@@ -1,7 +1,58 @@
|
||||
# AMR 1.4.0.9041
|
||||
## <small>Last updated: 17 December 2020</small>
|
||||
|
||||
Note: some changes in this version were suggested by anonymous reviewers from the journal we submitted our manuscript about this package to. We are those reviewers very grateful for going through our code so thoroughly!
|
||||
|
||||
### New
|
||||
* Function `is_new_episode()` to determine patient episodes which are not necessarily based on microorganisms. It also supports grouped variables with e.g. `mutate()`, `filter()` and `summarise()` of the `dplyr` package:
|
||||
```r
|
||||
library(dplyr)
|
||||
example_isolates %>%
|
||||
group_by(patient_id, hospital_id) %>%
|
||||
filter(is_new_episode(date, episode_days = 60))
|
||||
```
|
||||
* Functions `mo_is_gram_negative()` and `mo_is_gram_positive()` as wrappers around `mo_gramstain()`. They always return `TRUE` or `FALSE` (except when the input is `NA` or the MO code is `UNKNOWN`), thus always return `FALSE` for species outside the taxonomic kingdom of Bacteria.
|
||||
* Function `mo_is_intrinsic_resistant()` to test for intrinsic resistance, based on [EUCAST Intrinsic Resistance and Unusual Phenotypes v3.2](https://www.eucast.org/expert_rules_and_intrinsic_resistance/) from 2020.
|
||||
* Functions `random_mic()`, `random_disk()` and `random_rsi()` for random number generation. They take microorganism names and antibiotic names as input to make generation more realistic.
|
||||
|
||||
### Changed
|
||||
* Reference data used for `as.rsi()` can now be set by the user, using the `reference_data` parameter. This allows for using own interpretation guidelines. The user-set data must have the same structure as `rsi_translation`.
|
||||
* Some functions are now context-aware when used inside `dplyr` verbs, such as `filter()`, `mutate()` and `summarise()`. This means that then the data parameter does not need to be set anymore. This is the case for the new functions `mo_is_gram_negative()`, `mo_is_gram_positive()`, `mo_is_intrinsic_resistant()` and for the existing functions `first_isolate()`, `key_antibiotics()`, `mdro()`, `brmo()`, `mrgn()`, `mdr_tb()`, `mdr_cmi2012()`, `eucast_exceptional_phenotypes()`. This was already the case for antibiotic selection functions (such as using `penicillins()` in `dplyr::select()`).
|
||||
```r
|
||||
# to select first isolates that are Gram-negative
|
||||
# and view results of cephalosporins and aminoglycosides:
|
||||
library(dplyr)
|
||||
example_isolates %>%
|
||||
filter(first_isolate(), mo_is_gram_negative()) %>%
|
||||
select(mo, cephalosporins(), aminoglycosides()) %>%
|
||||
as_tibble()
|
||||
```
|
||||
* For all function parameters in the code, it is now defined what the exact type of user input should be (inspired by the [`typed`](https://github.com/moodymudskipper/typed) package). If the user input for a certain function does not meet the requirements for a specific parameter (such as the class or length), an informative error will be thrown. This makes the package more robust and the use of it more reproducible and reliable. In total, more than 400 arguments were defined.
|
||||
* Fix for `set_mo_source()`, that previously would not remember the file location of the original file
|
||||
* Deprecated function `p_symbol()` that not really fits the scope of this package. It will be removed in a future version. See [here](https://github.com/msberends/AMR/blob/v1.4.0/R/p_symbol.R) for the source code to preserve it.
|
||||
* Better determination of disk zones and MIC values when running `as.rsi()` on a data.frame
|
||||
* Updated coagulase-negative staphylococci determination with Becker *et al.* 2020 (PMID 32056452), meaning that the species *S. argensis*, *S. caeli*, *S. debuckii*, *S. edaphicus* and *S. pseudoxylosus* are now all considered CoNS
|
||||
* Fix for using parameter `reference_df` in `as.mo()` and `mo_*()` functions that contain old microbial codes (from previous package versions)
|
||||
* Fix for using `as.rsi()` on a data.frame in older R versions
|
||||
* `as.rsi()` on a data.frame will not print a message anymore if the values are already clean R/SI values
|
||||
* Fixed a bug where `mo_uncertainties()` would not return the results based on the MO matching score
|
||||
* Fixed a bug where `as.mo()` would not return results for known laboratory codes for microorganisms
|
||||
* Fixed a bug where `as.ab()` would sometimes fail
|
||||
* If using `as.rsi()` on MICs or disk diffusion while there is intrinsic antimicrobial resistance, a warning will be thrown to remind about this
|
||||
* Better tibble printing for MIC values
|
||||
* Fix for plotting MIC values with `plot()`
|
||||
* Added `plot()` generic to class `<disk>`
|
||||
* LA-MRSA and CA-MRSA are now recognised as an abbreviation for *Staphylococcus aureus*, meaning that e.g. `mo_genus("LA-MRSA")` will return `"Staphylococcus"` and `mo_is_gram_positive("LA-MRSA")` will return `TRUE`.
|
||||
* Fix for using `as.rsi()` on a `data.frame` that only contains one column for antibiotic interpretations
|
||||
|
||||
### Other
|
||||
* All messages and warnings thrown by this package now break sentences on whole words
|
||||
* More extensive unit tests
|
||||
* Internal calls to `options()` were all removed in favour of a new internal environment `mo_env`
|
||||
|
||||
# AMR 1.4.0
|
||||
|
||||
|
||||
Note: some changes in this version were suggested by anonymous reviewers from the journal we submitted our manuscipt about this package to. We are those reviewers very grateful for going through our code so thoroughly!
|
||||
Note: some changes in this version were suggested by anonymous reviewers from the journal we submitted our manuscript about this package to. We are those reviewers very grateful for going through our code so thoroughly!
|
||||
|
||||
### New
|
||||
* Support for 'EUCAST Expert Rules' / 'EUCAST Intrinsic Resistance and Unusual Phenotypes' version 3.2 of May 2020. With this addition to the previously implemented version 3.1 of 2016, the `eucast_rules()` function can now correct for more than 180 different antibiotics and the `mdro()` function can determine multidrug resistance based on more than 150 different antibiotics. All previously implemented versions of the EUCAST rules are now maintained and kept available in this package. The `eucast_rules()` function consequently gained the parameters `version_breakpoints` (at the moment defaults to v10.0, 2020) and `version_expertrules` (at the moment defaults to v3.2, 2020). The `example_isolates` data set now also reflects the change from v3.1 to v3.2. The `mdro()` function now accepts `guideline == "EUCAST3.1"` and `guideline == "EUCAST3.2"`.
|
||||
|
||||
+271
-38
@@ -9,7 +9,7 @@
|
||||
# (c) 2018-2020 Berends MS, Luz CF et al. #
|
||||
# Developed at the University of Groningen, the Netherlands, in #
|
||||
# collaboration with non-profit organisations Certe Medical #
|
||||
# Diagnostics & Advice, and University Medical Center Groningen. #
|
||||
# Diagnostics & Advice, and University Medical Center Groningen. #
|
||||
# #
|
||||
# This R package is free software; you can freely use and distribute #
|
||||
# it for both personal and commercial purposes under the terms of the #
|
||||
@@ -37,18 +37,18 @@ pm_left_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
|
||||
if (length(by) == 1) {
|
||||
by <- rep(by, 2)
|
||||
}
|
||||
|
||||
|
||||
int_x <- colnames(x) %in% colnames(y) & colnames(x) != by[1]
|
||||
int_y <- colnames(y) %in% colnames(x) & colnames(y) != by[2]
|
||||
colnames(x)[int_x] <- paste0(colnames(x)[int_x], suffix[1L])
|
||||
colnames(y)[int_y] <- paste0(colnames(y)[int_y], suffix[2L])
|
||||
|
||||
|
||||
merged <- cbind(x,
|
||||
y[match(x[, by[1], drop = TRUE],
|
||||
y[, by[2], drop = TRUE]),
|
||||
colnames(y)[!colnames(y) %in% colnames(x) & !colnames(y) == by[2]],
|
||||
drop = FALSE])
|
||||
|
||||
|
||||
rownames(merged) <- NULL
|
||||
merged
|
||||
}
|
||||
@@ -88,29 +88,35 @@ check_dataset_integrity <- function() {
|
||||
# check if other packages did not overwrite our data sets
|
||||
tryCatch({
|
||||
check_microorganisms <- all(c("mo", "fullname", "kingdom", "phylum",
|
||||
"class", "order", "family", "genus",
|
||||
"class", "order", "family", "genus",
|
||||
"species", "subspecies", "rank",
|
||||
"species_id", "source", "ref", "prevalence") %in% colnames(microorganisms),
|
||||
na.rm = TRUE)
|
||||
check_antibiotics <- all(c("ab", "atc", "cid", "name", "group",
|
||||
check_antibiotics <- all(c("ab", "atc", "cid", "name", "group",
|
||||
"atc_group1", "atc_group2", "abbreviations",
|
||||
"synonyms", "oral_ddd", "oral_units",
|
||||
"synonyms", "oral_ddd", "oral_units",
|
||||
"iv_ddd", "iv_units", "loinc") %in% colnames(antibiotics),
|
||||
na.rm = TRUE)
|
||||
}, error = function(e) {
|
||||
# package not yet loaded
|
||||
require("AMR")
|
||||
})
|
||||
stop_if(!check_microorganisms | !check_antibiotics,
|
||||
"the data set `microorganisms` or `antibiotics` was overwritten in your environment because another package with the same object names was loaded _after_ the AMR package, preventing the AMR package from working correctly. Please load the AMR package last.")
|
||||
invisible(TRUE)
|
||||
}
|
||||
|
||||
search_type_in_df <- function(x, type, info = TRUE) {
|
||||
meet_criteria(x, allow_class = "data.frame")
|
||||
meet_criteria(type, allow_class = "character", has_length = 1)
|
||||
|
||||
# try to find columns based on type
|
||||
found <- NULL
|
||||
|
||||
|
||||
# remove attributes from other packages
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||
colnames(x) <- trimws(colnames(x))
|
||||
|
||||
|
||||
# -- mo
|
||||
if (type == "mo") {
|
||||
if (any(sapply(x, is.mo))) {
|
||||
@@ -128,7 +134,7 @@ search_type_in_df <- function(x, type, info = TRUE) {
|
||||
} else if (any(colnames(x) %like% "species")) {
|
||||
found <- sort(colnames(x)[colnames(x) %like% "species"])[1]
|
||||
}
|
||||
|
||||
|
||||
}
|
||||
# -- key antibiotics
|
||||
if (type == "keyantibiotics") {
|
||||
@@ -142,7 +148,7 @@ search_type_in_df <- function(x, type, info = TRUE) {
|
||||
# WHONET support
|
||||
found <- sort(colnames(x)[colnames(x) %like% "^(specimen date|specimen_date|spec_date)"])[1]
|
||||
if (!any(class(pm_pull(x, found)) %in% c("Date", "POSIXct"))) {
|
||||
stop(font_red(paste0("ERROR: Found column `", font_bold(found), "` to be used as input for `col_", type,
|
||||
stop(font_red(paste0("Found column '", font_bold(found), "' to be used as input for `col_", type,
|
||||
"`, but this column contains no valid dates. Transform its values to valid dates first.")),
|
||||
call. = FALSE)
|
||||
}
|
||||
@@ -174,19 +180,20 @@ search_type_in_df <- function(x, type, info = TRUE) {
|
||||
if (!is.null(found)) {
|
||||
# this column should contain logicals
|
||||
if (!is.logical(x[, found, drop = TRUE])) {
|
||||
message(font_red(paste0("NOTE: Column `", font_bold(found), "` found as input for `col_", type,
|
||||
"`, but this column does not contain 'logical' values (TRUE/FALSE) and was ignored.")))
|
||||
message_("Column '", font_bold(found), "' found as input for `col_", type,
|
||||
"`, but this column does not contain 'logical' values (TRUE/FALSE) and was ignored.",
|
||||
add_fn = font_red)
|
||||
found <- NULL
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
if (!is.null(found) & info == TRUE) {
|
||||
msg <- paste0("NOTE: Using column `", font_bold(found), "` as input for `col_", type, "`.")
|
||||
msg <- paste0("Using column '", font_bold(found), "' as input for `col_", type, "`.")
|
||||
if (type %in% c("keyantibiotics", "specimen")) {
|
||||
msg <- paste(msg, "Use", font_bold(paste0("col_", type), "= FALSE"), "to prevent this.")
|
||||
}
|
||||
message(font_blue(msg))
|
||||
message_(msg)
|
||||
}
|
||||
found
|
||||
}
|
||||
@@ -219,11 +226,12 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) {
|
||||
stop_ifnot_installed(pkg)
|
||||
}
|
||||
tryCatch(
|
||||
get(name, envir = asNamespace(pkg)),
|
||||
# don't use get() to avoid fetching non-API functions
|
||||
getExportedValue(name = name, ns = asNamespace(pkg)),
|
||||
error = function(e) {
|
||||
if (isTRUE(error_on_fail)) {
|
||||
stop_("function ", name, "() not found in package '", pkg,
|
||||
"'. Please create an issue at https://github.com/msberends/AMR/issues. Many thanks!",
|
||||
stop_("function ", name, "() is not an exported object from package '", pkg,
|
||||
"'. Please create an issue at https://github.com/msberends/AMR/issues. Many thanks!",
|
||||
call = FALSE)
|
||||
} else {
|
||||
return(NULL)
|
||||
@@ -231,6 +239,97 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) {
|
||||
})
|
||||
}
|
||||
|
||||
# this alternative wrapper to the message(), warning() and stop() functions:
|
||||
# - wraps text to never break lines within words
|
||||
# - ignores formatted text while wrapping
|
||||
# - adds indentation dependent on the type of message (such as NOTE)
|
||||
# - can add additional formatting functions like blue or bold text
|
||||
word_wrap <- function(...,
|
||||
add_fn = list(),
|
||||
as_note = FALSE,
|
||||
width = 0.95 * getOption("width"),
|
||||
extra_indent = 0) {
|
||||
msg <- paste0(c(...), collapse = "")
|
||||
# replace new lines to add them again later
|
||||
msg <- gsub("\n", "*|*", msg, fixed = TRUE)
|
||||
|
||||
if (isTRUE(as_note)) {
|
||||
msg <- paste0("NOTE: ", gsub("^note:? ?", "", msg, ignore.case = TRUE))
|
||||
}
|
||||
|
||||
# we need to correct for already applied style, that adds text like "\033[31m\"
|
||||
msg_stripped <- font_stripstyle(msg)
|
||||
# where are the spaces now?
|
||||
msg_stripped_wrapped <- paste0(strwrap(msg_stripped,
|
||||
simplify = TRUE,
|
||||
width = width),
|
||||
collapse = "\n")
|
||||
msg_stripped_wrapped <- paste0(unlist(strsplit(msg_stripped_wrapped, "(\n|\\*\\|\\*)")),
|
||||
collapse = "\n")
|
||||
msg_stripped_spaces <- which(unlist(strsplit(msg_stripped, "")) == " ")
|
||||
msg_stripped_wrapped_spaces <- which(unlist(strsplit(msg_stripped_wrapped, "")) != "\n")
|
||||
# so these are the indices of spaces that need to be replaced
|
||||
replace_spaces <- which(!msg_stripped_spaces %in% msg_stripped_wrapped_spaces)
|
||||
# put it together
|
||||
msg <- unlist(strsplit(msg, " "))
|
||||
msg[replace_spaces] <- paste0(msg[replace_spaces], "\n")
|
||||
msg <- paste0(msg, collapse = " ")
|
||||
msg <- gsub("\n ", "\n", msg, fixed = TRUE)
|
||||
|
||||
if (msg_stripped %like% "^NOTE: ") {
|
||||
indentation <- 6 + extra_indent
|
||||
} else if (msg_stripped %like% "^=> ") {
|
||||
indentation <- 3 + extra_indent
|
||||
} else {
|
||||
indentation <- 0 + extra_indent
|
||||
}
|
||||
msg <- gsub("\n", paste0("\n", strrep(" ", indentation)), msg, fixed = TRUE)
|
||||
msg <- gsub("*|*", paste0("*|*", strrep(" ", indentation)), msg, fixed = TRUE)
|
||||
# remove trailing empty characters
|
||||
msg <- gsub("(\n| )+$", "", msg)
|
||||
|
||||
if (length(add_fn) > 0) {
|
||||
if (!is.list(add_fn)) {
|
||||
add_fn <- list(add_fn)
|
||||
}
|
||||
for (i in seq_len(length(add_fn))) {
|
||||
msg <- add_fn[[i]](msg)
|
||||
}
|
||||
}
|
||||
|
||||
# place back spaces
|
||||
msg <- gsub("*|*", "\n", msg, fixed = TRUE)
|
||||
|
||||
# format backticks
|
||||
msg <- gsub("(`.+?`)", font_grey_bg("\\1"), msg)
|
||||
|
||||
msg
|
||||
}
|
||||
|
||||
message_ <- function(...,
|
||||
appendLF = TRUE,
|
||||
add_fn = list(font_blue),
|
||||
as_note = TRUE) {
|
||||
message(word_wrap(...,
|
||||
add_fn = add_fn,
|
||||
as_note = as_note),
|
||||
appendLF = appendLF)
|
||||
}
|
||||
|
||||
warning_ <- function(...,
|
||||
add_fn = list(),
|
||||
immediate = FALSE,
|
||||
call = TRUE) {
|
||||
warning(word_wrap(...,
|
||||
add_fn = add_fn,
|
||||
as_note = FALSE),
|
||||
immediate. = immediate,
|
||||
call. = call)
|
||||
}
|
||||
|
||||
# this alternative to the stop() function:
|
||||
# - adds the function name where the error was thrown
|
||||
# - wraps text to never break lines within words
|
||||
stop_ <- function(..., call = TRUE) {
|
||||
msg <- paste0(c(...), collapse = "")
|
||||
if (!isFALSE(call)) {
|
||||
@@ -242,6 +341,7 @@ stop_ <- function(..., call = TRUE) {
|
||||
}
|
||||
msg <- paste0("in ", call, "(): ", msg)
|
||||
}
|
||||
msg <- word_wrap(msg, add_fn = list(), as_note = FALSE)
|
||||
stop(msg, call. = FALSE)
|
||||
}
|
||||
|
||||
@@ -286,7 +386,7 @@ stop_ifnot <- function(expr, ..., call = TRUE) {
|
||||
|
||||
class_integrity_check <- function(value, type, check_vector) {
|
||||
if (!all(value[!is.na(value)] %in% check_vector)) {
|
||||
warning(paste0("invalid ", type, ", NA generated"), call. = FALSE)
|
||||
warning_(paste0("invalid ", type, ", NA generated"), call = FALSE)
|
||||
value[!value %in% check_vector] <- NA
|
||||
}
|
||||
value
|
||||
@@ -317,6 +417,7 @@ dataset_UTF8_to_ASCII <- function(df) {
|
||||
df
|
||||
}
|
||||
|
||||
# for eucast_rules() and mdro(), creates markdown output with URLs and names
|
||||
create_ab_documentation <- function(ab) {
|
||||
ab_names <- ab_name(ab, language = NULL, tolower = TRUE)
|
||||
ab <- ab[order(ab_names)]
|
||||
@@ -329,6 +430,104 @@ create_ab_documentation <- function(ab) {
|
||||
out
|
||||
}
|
||||
|
||||
# a check for every single argument in all functions
|
||||
meet_criteria <- function(object,
|
||||
allow_class = NULL,
|
||||
has_length = NULL,
|
||||
looks_like = NULL,
|
||||
is_in = NULL,
|
||||
contains_column_class = NULL,
|
||||
allow_NULL = FALSE,
|
||||
allow_NA = FALSE,
|
||||
ignore.case = FALSE,
|
||||
.call_depth = 0) { # depth in calling
|
||||
|
||||
obj_name <- deparse(substitute(object))
|
||||
call_depth <- -2 - abs(.call_depth)
|
||||
|
||||
if (is.null(object)) {
|
||||
stop_if(allow_NULL == FALSE, "argument `", obj_name, "` must not be NULL", call = call_depth)
|
||||
return(invisible())
|
||||
}
|
||||
if (is.null(dim(object)) && length(object) == 1 && is.na(object)) {
|
||||
stop_if(allow_NA == FALSE, "argument `", obj_name, "` must not be NA", call = call_depth)
|
||||
return(invisible())
|
||||
}
|
||||
|
||||
vector_or <- function(v, quotes) {
|
||||
if (length(v) == 1) {
|
||||
return(paste0(ifelse(quotes, '"', ""), v, ifelse(quotes, '"', "")))
|
||||
}
|
||||
# all commas except for last item, so will become '"val1", "val2", "val3" or "val4"'
|
||||
paste0(paste0(ifelse(quotes, '"', ""), v[seq_len(length(v) - 1)], ifelse(quotes, '"', ""), collapse = ", "),
|
||||
" or ", paste0(ifelse(quotes, '"', ""), v[length(v)], ifelse(quotes, '"', "")))
|
||||
}
|
||||
|
||||
if (!is.null(allow_class)) {
|
||||
stop_ifnot(inherits(object, allow_class), "argument `", obj_name,
|
||||
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
|
||||
"be of class ", vector_or(allow_class, quotes = TRUE),
|
||||
", not \"", paste(class(object), collapse = "/"), "\"",
|
||||
call = call_depth)
|
||||
# check data.frames for data
|
||||
if (inherits(object, "data.frame")) {
|
||||
stop_if(any(dim(object) == 0),
|
||||
"the data provided in argument `", obj_name,
|
||||
"` must contain rows and columns (current dimensions: ",
|
||||
paste(dim(object), collapse = "x"), ")",
|
||||
call = call_depth)
|
||||
}
|
||||
}
|
||||
if (!is.null(has_length)) {
|
||||
stop_ifnot(length(object) %in% has_length, "argument `", obj_name,
|
||||
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
|
||||
"be of length ", vector_or(has_length, quotes = FALSE),
|
||||
", not ", length(object),
|
||||
call = call_depth)
|
||||
}
|
||||
if (!is.null(looks_like)) {
|
||||
stop_ifnot(object %like% looks_like, "argument `", obj_name,
|
||||
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
|
||||
"resemble the regular expression \"", looks_like, "\"",
|
||||
call = call_depth)
|
||||
}
|
||||
if (!is.null(is_in)) {
|
||||
if (ignore.case == TRUE) {
|
||||
object <- tolower(object)
|
||||
is_in <- tolower(is_in)
|
||||
}
|
||||
stop_ifnot(all(object %in% is_in, na.rm = TRUE), "argument `", obj_name,
|
||||
"` must be ",
|
||||
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1, "one of: ", ""),
|
||||
vector_or(is_in, quotes = TRUE),
|
||||
", not ", paste0("\"", object, "\"", collapse = "/"), "",
|
||||
call = call_depth)
|
||||
}
|
||||
if (!is.null(contains_column_class)) {
|
||||
stop_ifnot(any(sapply(object, function(col, columns_class = contains_column_class) inherits(col, columns_class)), na.rm = TRUE),
|
||||
"the data provided in argument `", obj_name,
|
||||
"` must contain at least one column of class <", contains_column_class, ">. ",
|
||||
"See ?as.", contains_column_class, ".",
|
||||
call = call_depth)
|
||||
}
|
||||
return(invisible())
|
||||
}
|
||||
|
||||
get_current_data <- function(arg_name, call) {
|
||||
# this mimics dplyr::cur_data_all for users that use our content-aware functions in dplyr verbs
|
||||
cur_data_all_dplyr <- import_fn("cur_data_all", "dplyr", error_on_fail = FALSE)
|
||||
if (is.null(cur_data_all_dplyr)) {
|
||||
# dplyr not installed
|
||||
stop_("argument `", arg_name, "` is missing, with no default", call = call)
|
||||
}
|
||||
tryCatch(cur_data_all_dplyr(),
|
||||
# dplyr installed, but not used inside dplyr verb
|
||||
error = function(e) stop_("argument `", arg_name, "` is missing with no default ",
|
||||
"or function not used inside a valid dplyr verb",
|
||||
# tryCatch adds 4 system calls, subtract them
|
||||
call = call - 4))
|
||||
}
|
||||
|
||||
has_colour <- function() {
|
||||
# this is a base R version of crayon::has_color
|
||||
enabled <- getOption("crayon.enabled")
|
||||
@@ -380,13 +579,13 @@ has_colour <- function() {
|
||||
if (Sys.getenv("TERM") == "dumb") {
|
||||
return(FALSE)
|
||||
}
|
||||
grepl(pattern = "^screen|^xterm|^vt100|color|ansi|cygwin|linux",
|
||||
grepl(pattern = "^screen|^xterm|^vt100|color|ansi|cygwin|linux",
|
||||
x = Sys.getenv("TERM"),
|
||||
ignore.case = TRUE,
|
||||
perl = TRUE)
|
||||
}
|
||||
|
||||
# the crayon colours
|
||||
# set colours if console has_colour()
|
||||
try_colour <- function(..., before, after, collapse = " ") {
|
||||
txt <- paste0(unlist(list(...)), collapse = collapse)
|
||||
if (isTRUE(has_colour())) {
|
||||
@@ -429,6 +628,9 @@ font_subtle <- function(..., collapse = " ") {
|
||||
font_grey <- function(..., collapse = " ") {
|
||||
try_colour(..., before = "\033[38;5;249m", after = "\033[39m", collapse = collapse)
|
||||
}
|
||||
font_grey_bg <- function(..., collapse = " ") {
|
||||
try_colour(..., before = "\033[48;5;255m", after = "\033[49m", collapse = collapse)
|
||||
}
|
||||
font_green_bg <- function(..., collapse = " ") {
|
||||
try_colour(..., before = "\033[42m", after = "\033[49m", collapse = collapse)
|
||||
}
|
||||
@@ -464,7 +666,7 @@ progress_ticker <- function(n = 1, n_min = 0, ...) {
|
||||
pb$kill <- function() {
|
||||
invisible()
|
||||
}
|
||||
structure(pb, class = "txtProgressBar")
|
||||
set_clean_class(pb, new_class = "txtProgressBar")
|
||||
} else if (n >= n_min) {
|
||||
pb <- utils::txtProgressBar(max = n, style = 3)
|
||||
pb$tick <- function() {
|
||||
@@ -474,10 +676,38 @@ progress_ticker <- function(n = 1, n_min = 0, ...) {
|
||||
}
|
||||
}
|
||||
|
||||
set_clean_class <- function(x, new_class) {
|
||||
# return the object with only the new class and no additional attributes where possible
|
||||
if (is.null(x)) {
|
||||
x <- NA_character_
|
||||
}
|
||||
if (is.factor(x)) {
|
||||
# keep only levels and remove all other attributes
|
||||
lvls <- levels(x)
|
||||
attributes(x) <- NULL
|
||||
levels(x) <- lvls
|
||||
} else if (!is.list(x) && !is.function(x)) {
|
||||
attributes(x) <- NULL
|
||||
}
|
||||
class(x) <- new_class
|
||||
x
|
||||
}
|
||||
|
||||
formatted_filesize <- function(...) {
|
||||
size_kb <- file.size(...) / 1024
|
||||
if (size_kb < 1) {
|
||||
paste(round(size_kb, 1), "kB")
|
||||
} else if (size_kb < 100) {
|
||||
paste(round(size_kb, 0), "kB")
|
||||
} else {
|
||||
paste(round(size_kb / 1024, 1), "MB")
|
||||
}
|
||||
}
|
||||
|
||||
create_pillar_column <- function(x, ...) {
|
||||
new_pillar_shaft_simple <- import_fn("new_pillar_shaft_simple", "pillar", error_on_fail = FALSE)
|
||||
if (!is.null(new_pillar_shaft_simple)) {
|
||||
new_pillar_shaft_simple(x, ...)
|
||||
new_pillar_shaft_simple(x, ...)
|
||||
} else {
|
||||
# does not exist in package 'pillar' anymore
|
||||
structure(list(x),
|
||||
@@ -539,12 +769,12 @@ round2 <- function(x, digits = 0, force_zero = TRUE) {
|
||||
if (digits > 0 & force_zero == TRUE) {
|
||||
values_trans <- val[val != as.integer(val) & !is.na(val)]
|
||||
val[val != as.integer(val) & !is.na(val)] <- paste0(values_trans,
|
||||
strrep("0",
|
||||
max(0,
|
||||
strrep("0",
|
||||
max(0,
|
||||
digits - nchar(
|
||||
format(
|
||||
as.double(
|
||||
gsub(".*[.](.*)$",
|
||||
gsub(".*[.](.*)$",
|
||||
"\\1",
|
||||
values_trans)),
|
||||
scientific = FALSE)))))
|
||||
@@ -555,7 +785,7 @@ round2 <- function(x, digits = 0, force_zero = TRUE) {
|
||||
|
||||
# percentage from our other package: 'cleaner'
|
||||
percentage <- function(x, digits = NULL, ...) {
|
||||
|
||||
|
||||
# getdecimalplaces() function
|
||||
getdecimalplaces <- function(x, minimum = 0, maximum = 3) {
|
||||
if (maximum < minimum) {
|
||||
@@ -564,20 +794,20 @@ percentage <- function(x, digits = NULL, ...) {
|
||||
if (minimum > maximum) {
|
||||
minimum <- maximum
|
||||
}
|
||||
max_places <- max(unlist(lapply(strsplit(sub("0+$", "",
|
||||
max_places <- max(unlist(lapply(strsplit(sub("0+$", "",
|
||||
as.character(x * 100)), ".", fixed = TRUE),
|
||||
function(y) ifelse(length(y) == 2, nchar(y[2]), 0))), na.rm = TRUE)
|
||||
max(min(max_places,
|
||||
maximum, na.rm = TRUE),
|
||||
minimum, na.rm = TRUE)
|
||||
}
|
||||
|
||||
|
||||
# format_percentage() function
|
||||
format_percentage <- function(x, digits = NULL, ...) {
|
||||
if (is.null(digits)) {
|
||||
digits <- getdecimalplaces(x)
|
||||
}
|
||||
|
||||
|
||||
# round right: percentage(0.4455) and format(as.percentage(0.4455), 1) should return "44.6%", not "44.5%"
|
||||
x_formatted <- format(round2(as.double(x), digits = digits + 2) * 100,
|
||||
scientific = FALSE,
|
||||
@@ -588,7 +818,7 @@ percentage <- function(x, digits = NULL, ...) {
|
||||
x_formatted[!grepl(pattern = "^[0-9.,e-]+$", x = x)] <- NA_character_
|
||||
x_formatted
|
||||
}
|
||||
|
||||
|
||||
# the actual working part
|
||||
x <- as.double(x)
|
||||
if (is.null(digits)) {
|
||||
@@ -601,16 +831,16 @@ percentage <- function(x, digits = NULL, ...) {
|
||||
}
|
||||
|
||||
# prevent dependency on package 'backports'
|
||||
# these functions were not available in previous versions of R (last checked: R 4.0.2)
|
||||
# these functions were not available in previous versions of R (last checked: R 4.0.3)
|
||||
# see here for the full list: https://github.com/r-lib/backports
|
||||
strrep <- function(x, times) {
|
||||
x <- as.character(x)
|
||||
if (length(x) == 0L)
|
||||
if (length(x) == 0L)
|
||||
return(x)
|
||||
unlist(.mapply(function(x, times) {
|
||||
if (is.na(x) || is.na(times))
|
||||
if (is.na(x) || is.na(times))
|
||||
return(NA_character_)
|
||||
if (times <= 0L)
|
||||
if (times <= 0L)
|
||||
return("")
|
||||
paste0(replicate(times, x), collapse = "")
|
||||
}, list(x = x, times = times), MoreArgs = list()), use.names = FALSE)
|
||||
@@ -618,9 +848,9 @@ strrep <- function(x, times) {
|
||||
trimws <- function(x, which = c("both", "left", "right")) {
|
||||
which <- match.arg(which)
|
||||
mysub <- function(re, x) sub(re, "", x, perl = TRUE)
|
||||
if (which == "left")
|
||||
if (which == "left")
|
||||
return(mysub("^[ \t\r\n]+", x))
|
||||
if (which == "right")
|
||||
if (which == "right")
|
||||
return(mysub("[ \t\r\n]+$", x))
|
||||
mysub("[ \t\r\n]+$", mysub("^[ \t\r\n]+", x))
|
||||
}
|
||||
@@ -645,3 +875,6 @@ str2lang <- function(s) {
|
||||
isNamespaceLoaded <- function(pkg) {
|
||||
pkg %in% loadedNamespaces()
|
||||
}
|
||||
lengths = function(x, use.names = TRUE) {
|
||||
vapply(x, length, FUN.VALUE = NA_integer_, USE.NAMES = use.names)
|
||||
}
|
||||
+23
-23
@@ -388,29 +388,29 @@ pm_group_size <- function(x) {
|
||||
pm_n_groups <- function(x) {
|
||||
nrow(pm_group_data(x))
|
||||
}
|
||||
pm_group_split <- function(.data, ..., .keep = TRUE) {
|
||||
dots_len <- ...length() > 0L
|
||||
if (pm_has_groups(.data) && isTRUE(dots_len)) {
|
||||
warning("... is ignored in pm_group_split(<grouped_df>), please use pm_group_by(..., .add = TRUE) %pm>% pm_group_split()")
|
||||
}
|
||||
if (!pm_has_groups(.data) && isTRUE(dots_len)) {
|
||||
.data <- pm_group_by(.data, ...)
|
||||
}
|
||||
if (!pm_has_groups(.data) && isFALSE(dots_len)) {
|
||||
return(list(.data))
|
||||
}
|
||||
pm_context$setup(.data)
|
||||
on.exit(pm_context$clean(), add = TRUE)
|
||||
pm_groups <- pm_get_groups(.data)
|
||||
attr(pm_context$.data, "pm_groups") <- NULL
|
||||
res <- pm_split_into_groups(pm_context$.data, pm_groups)
|
||||
names(res) <- NULL
|
||||
if (isFALSE(.keep)) {
|
||||
res <- lapply(res, function(x) x[, !colnames(x) %in% pm_groups])
|
||||
}
|
||||
any_empty <- unlist(lapply(res, function(x) !(nrow(x) == 0L)))
|
||||
res[any_empty]
|
||||
}
|
||||
# pm_group_split <- function(.data, ..., .keep = TRUE) {
|
||||
# dots_len <- ...length() > 0L
|
||||
# if (pm_has_groups(.data) && isTRUE(dots_len)) {
|
||||
# warning("... is ignored in pm_group_split(<grouped_df>), please use pm_group_by(..., .add = TRUE) %pm>% pm_group_split()")
|
||||
# }
|
||||
# if (!pm_has_groups(.data) && isTRUE(dots_len)) {
|
||||
# .data <- pm_group_by(.data, ...)
|
||||
# }
|
||||
# if (!pm_has_groups(.data) && isFALSE(dots_len)) {
|
||||
# return(list(.data))
|
||||
# }
|
||||
# pm_context$setup(.data)
|
||||
# on.exit(pm_context$clean(), add = TRUE)
|
||||
# pm_groups <- pm_get_groups(.data)
|
||||
# attr(pm_context$.data, "pm_groups") <- NULL
|
||||
# res <- pm_split_into_groups(pm_context$.data, pm_groups)
|
||||
# names(res) <- NULL
|
||||
# if (isFALSE(.keep)) {
|
||||
# res <- lapply(res, function(x) x[, !colnames(x) %in% pm_groups])
|
||||
# }
|
||||
# any_empty <- unlist(lapply(res, function(x) !(nrow(x) == 0L)))
|
||||
# res[any_empty]
|
||||
# }
|
||||
|
||||
pm_group_keys <- function(.data) {
|
||||
pm_groups <- pm_get_groups(.data)
|
||||
|
||||
@@ -37,13 +37,14 @@
|
||||
#'
|
||||
#' All these properties will be searched for the user input. The [as.ab()] can correct for different forms of misspelling:
|
||||
#'
|
||||
#' * Wrong spelling of drug names (like "tobramicin" or "gentamycin"), which corrects for most audible similarities such as f/ph, x/ks, c/z/s, t/th, etc.
|
||||
#' * Wrong spelling of drug names (such as "tobramicin" or "gentamycin"), which corrects for most audible similarities such as f/ph, x/ks, c/z/s, t/th, etc.
|
||||
#' * Too few or too many vowels or consonants
|
||||
#' * Switching two characters (like "mreopenem", often the case in clinical data, when doctors typed too fast)
|
||||
#' * Switching two characters (such as "mreopenem", often the case in clinical data, when doctors typed too fast)
|
||||
#' * Digitalised paper records, leaving artefacts like 0/o/O (zero and O's), B/8, n/r, etc.
|
||||
#'
|
||||
#' Use the [ab_property()] functions to get properties based on the returned antibiotic ID, see Examples.
|
||||
#' Use the [`ab_*`][ab_property()] functions to get properties based on the returned antibiotic ID, see Examples.
|
||||
#'
|
||||
#' Note: the [as.ab()] and [`ab_*`][ab_property()] functions may use very long regular expression to match brand names of antimicrobial agents. This may fail on some systems.
|
||||
#' @section Source:
|
||||
#' World Health Organization (WHO) Collaborating Centre for Drug Statistics Methodology: \url{https://www.whocc.no/atc_ddd_index/}
|
||||
#'
|
||||
@@ -82,6 +83,9 @@
|
||||
#' ab_name("J01FA01") # "Erythromycin"
|
||||
#' ab_name("eryt") # "Erythromycin"
|
||||
as.ab <- function(x, flag_multiple_results = TRUE, info = TRUE, ...) {
|
||||
meet_criteria(x, allow_class = c("character", "numeric", "integer", "factor"), allow_NA = TRUE)
|
||||
meet_criteria(flag_multiple_results, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(info, allow_class = "logical", has_length = 1)
|
||||
|
||||
check_dataset_integrity()
|
||||
|
||||
@@ -94,8 +98,8 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = TRUE, ...) {
|
||||
|
||||
if (all(toupper(x) %in% antibiotics$ab)) {
|
||||
# valid AB code, but not yet right class
|
||||
return(structure(.Data = toupper(x),
|
||||
class = c("ab", "character")))
|
||||
return(set_clean_class(toupper(x),
|
||||
new_class = c("ab", "character")))
|
||||
}
|
||||
|
||||
x_bak <- x
|
||||
@@ -120,8 +124,8 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = TRUE, ...) {
|
||||
abnames <- abnames[!abnames == "clavulanic acid"]
|
||||
}
|
||||
if (length(abnames) > 1) {
|
||||
message(font_blue(paste0("NOTE: more than one result was found for item ", index, ": ",
|
||||
paste0(abnames, collapse = ", "))))
|
||||
message_("More than one result was found for item ", index, ": ",
|
||||
paste0(abnames, collapse = ", "))
|
||||
}
|
||||
}
|
||||
found[1L]
|
||||
@@ -150,7 +154,8 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = TRUE, ...) {
|
||||
}
|
||||
|
||||
if (isTRUE(flag_multiple_results) & x[i] %like% "[ ]") {
|
||||
from_text <- suppressWarnings(ab_from_text(x[i], initial_search = FALSE, translate_ab = FALSE)[[1]])
|
||||
from_text <- tryCatch(suppressWarnings(ab_from_text(x[i], initial_search = FALSE, translate_ab = FALSE)[[1]]),
|
||||
error = function(e) character(0))
|
||||
} else {
|
||||
from_text <- character(0)
|
||||
}
|
||||
@@ -342,7 +347,8 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = TRUE, ...) {
|
||||
if (isTRUE(flag_multiple_results)) {
|
||||
found <- from_text[1L]
|
||||
} else {
|
||||
found <- suppressWarnings(ab_from_text(x[i], initial_search = FALSE, translate_ab = FALSE)[[1]][1L])
|
||||
found <- tryCatch(suppressWarnings(ab_from_text(x[i], initial_search = FALSE, translate_ab = FALSE)[[1]][1L]),
|
||||
error = function(e) NA_character_)
|
||||
}
|
||||
if (!is.na(found)) {
|
||||
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
||||
@@ -431,17 +437,17 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = TRUE, ...) {
|
||||
x_unknown_ATCs <- x_unknown[x_unknown %like% "[A-Z][0-9][0-9][A-Z][A-Z][0-9][0-9]"]
|
||||
x_unknown <- x_unknown[!x_unknown %in% x_unknown_ATCs]
|
||||
if (length(x_unknown_ATCs) > 0) {
|
||||
warning("These ATC codes are not (yet) in the antibiotics data set: ",
|
||||
paste('"', sort(unique(x_unknown_ATCs)), '"', sep = "", collapse = ", "),
|
||||
".",
|
||||
call. = FALSE)
|
||||
warning_("These ATC codes are not (yet) in the antibiotics data set: ",
|
||||
paste('"', sort(unique(x_unknown_ATCs)), '"', sep = "", collapse = ", "),
|
||||
".",
|
||||
call = FALSE)
|
||||
}
|
||||
|
||||
if (length(x_unknown) > 0) {
|
||||
warning("These values could not be coerced to a valid antimicrobial ID: ",
|
||||
paste('"', sort(unique(x_unknown)), '"', sep = "", collapse = ", "),
|
||||
".",
|
||||
call. = FALSE)
|
||||
warning_("These values could not be coerced to a valid antimicrobial ID: ",
|
||||
paste('"', sort(unique(x_unknown)), '"', sep = "", collapse = ", "),
|
||||
".",
|
||||
call = FALSE)
|
||||
}
|
||||
|
||||
x_result <- data.frame(x = x_bak_clean, stringsAsFactors = FALSE) %pm>%
|
||||
@@ -452,8 +458,8 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = TRUE, ...) {
|
||||
x_result <- NA_character_
|
||||
}
|
||||
|
||||
structure(.Data = x_result,
|
||||
class = c("ab", "character"))
|
||||
set_clean_class(x_result,
|
||||
new_class = c("ab", "character"))
|
||||
}
|
||||
|
||||
#' @rdname as.ab
|
||||
|
||||
+15
-11
@@ -25,11 +25,11 @@
|
||||
|
||||
#' Antibiotic class selectors
|
||||
#'
|
||||
#' Use these selection helpers inside any function that allows [Tidyverse selection helpers](https://tidyselect.r-lib.org/reference/language.html), like `dplyr::select()` or `tidyr::pivot_longer()`. They help to select the columns of antibiotics that are of a specific antibiotic class, without the need to define the columns or antibiotic abbreviations.
|
||||
#' Use these selection helpers inside any function that allows [Tidyverse selection helpers](https://tidyselect.r-lib.org/reference/language.html), such as [`select()`][dplyr::select()] and [`pivot_longer()`][tidyr::pivot_longer()]. They help to select the columns of antibiotics that are of a specific antibiotic class, without the need to define the columns or antibiotic abbreviations.
|
||||
#' @inheritParams filter_ab_class
|
||||
#' @details All columns will be searched for known antibiotic names, abbreviations, brand names and codes (ATC, EARS-Net, WHO, etc.) in the [antibiotics] data set. This means that a selector like e.g. [aminoglycosides()] will pick up column names like 'gen', 'genta', 'J01GB03', 'tobra', 'Tobracin', etc.
|
||||
#'
|
||||
#' **N.B. These functions only work if the `tidyselect` package is installed**, that comes with the `dplyr` package. An error will be thrown if the `tidyselect` package is not installed, or if the functions are used outside a function that allows Tidyverse selections like `select()` or `pivot_longer()`.
|
||||
#' **N.B. These functions require the `tidyselect` package to be installed**, that comes with the `dplyr` package. An error will be thrown if the `tidyselect` package is not installed, or if the functions are used outside a function that allows [Tidyverse selection helpers](https://tidyselect.r-lib.org/reference/language.html) such as [`select()`][dplyr::select()] and [`pivot_longer()`][tidyr::pivot_longer()]`.
|
||||
#' @rdname antibiotic_class_selectors
|
||||
#' @seealso [filter_ab_class()] for the `filter()` equivalent.
|
||||
#' @name antibiotic_class_selectors
|
||||
@@ -54,7 +54,7 @@
|
||||
#'
|
||||
#' # get bug/drug combinations for only macrolides in Gram-positives:
|
||||
#' example_isolates %>%
|
||||
#' filter(mo_gramstain(mo) %like% "pos") %>%
|
||||
#' filter(mo_is_gram_positive()) %>%
|
||||
#' select(mo, macrolides()) %>%
|
||||
#' bug_drug_combinations() %>%
|
||||
#' format()
|
||||
@@ -148,14 +148,17 @@ tetracyclines <- function() {
|
||||
}
|
||||
|
||||
ab_selector <- function(ab_class, function_name) {
|
||||
meet_criteria(ab_class, allow_class = "character", has_length = 1, .call_depth = 1)
|
||||
meet_criteria(function_name, allow_class = "character", has_length = 1, .call_depth = 1)
|
||||
|
||||
peek_vars_tidyselect <- import_fn("peek_vars", "tidyselect")
|
||||
vars_vct <- peek_vars_tidyselect(fn = function_name)
|
||||
vars_df <- data.frame(as.list(vars_vct))[0, , drop = FALSE]
|
||||
vars_df <- data.frame(as.list(vars_vct), stringsAsFactors = FALSE)[1, , drop = FALSE]
|
||||
colnames(vars_df) <- vars_vct
|
||||
ab_in_data <- get_column_abx(vars_df, info = FALSE)
|
||||
|
||||
if (length(ab_in_data) == 0) {
|
||||
message(font_blue("NOTE: no antimicrobial agents found."))
|
||||
message_("No antimicrobial agents found.")
|
||||
return(NULL)
|
||||
}
|
||||
|
||||
@@ -173,13 +176,14 @@ ab_selector <- function(ab_class, function_name) {
|
||||
# get the columns with a group names in the chosen ab class
|
||||
agents <- ab_in_data[names(ab_in_data) %in% ab_reference$ab]
|
||||
if (length(agents) == 0) {
|
||||
message(font_blue(paste0("NOTE: No antimicrobial agents of class ", ab_group,
|
||||
" found", examples, ".")))
|
||||
message_("No antimicrobial agents of class ", ab_group, " found", examples, ".")
|
||||
} else {
|
||||
message(font_blue(paste0("Selecting ", ab_group, ": ",
|
||||
paste(paste0("`", font_bold(agents, collapse = NULL),
|
||||
"` (", ab_name(names(agents), tolower = TRUE, language = NULL), ")"),
|
||||
collapse = ", "))))
|
||||
message_("Selecting ", ab_group, ": ",
|
||||
paste(paste0("'", font_bold(agents, collapse = NULL),
|
||||
"' (", ab_name(names(agents), tolower = TRUE, language = NULL), ")"),
|
||||
collapse = ", "),
|
||||
as_note = FALSE,
|
||||
extra_indent = nchar(paste0("Selecting ", ab_group, ": ")))
|
||||
}
|
||||
unname(agents)
|
||||
}
|
||||
+10
-4
@@ -46,7 +46,7 @@
|
||||
#' Without using `collapse`, this function will return a [list]. This can be convenient to use e.g. inside a `mutate()`):\cr
|
||||
#' `df %>% mutate(abx = ab_from_text(clinical_text))`
|
||||
#'
|
||||
#' The returned AB codes can be transformed to official names, groups, etc. with all [ab_property()] functions like [ab_name()] and [ab_group()], or by using the `translate_ab` parameter.
|
||||
#' The returned AB codes can be transformed to official names, groups, etc. with all [`ab_*`][ab_property()] functions such as [ab_name()] and [ab_group()], or by using the `translate_ab` parameter.
|
||||
#'
|
||||
#' With using `collapse`, this function will return a [character]:\cr
|
||||
#' `df %>% mutate(abx = ab_from_text(clinical_text, collapse = "|"))`
|
||||
@@ -63,7 +63,7 @@
|
||||
#' ab_from_text("500 mg amoxi po and 400mg cipro iv", type = "admin")
|
||||
#'
|
||||
#' ab_from_text("500 mg amoxi po and 400mg cipro iv", collapse = ", ")
|
||||
#'
|
||||
#' \donttest{
|
||||
#' # if you want to know which antibiotic groups were administered, do e.g.:
|
||||
#' abx <- ab_from_text("500 mg amoxi po and 400mg cipro iv")
|
||||
#' ab_group(abx[[1]])
|
||||
@@ -86,18 +86,24 @@
|
||||
#' collapse = "|"))
|
||||
#'
|
||||
#' }
|
||||
#' }
|
||||
ab_from_text <- function(text,
|
||||
type = c("drug", "dose", "administration"),
|
||||
collapse = NULL,
|
||||
translate_ab = FALSE,
|
||||
thorough_search = NULL,
|
||||
...) {
|
||||
|
||||
if (missing(type)) {
|
||||
type <- type[1L]
|
||||
}
|
||||
|
||||
meet_criteria(text)
|
||||
meet_criteria(type, allow_class = "character", has_length = 1)
|
||||
meet_criteria(collapse, has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(translate_ab, allow_NULL = FALSE) # get_translate_ab() will be more informative about what's allowed
|
||||
meet_criteria(thorough_search, allow_class = "logical", has_length = 1, allow_NULL = TRUE)
|
||||
|
||||
type <- tolower(trimws(type))
|
||||
stop_if(length(type) != 1, "`type` must be of length 1")
|
||||
|
||||
text <- tolower(as.character(text))
|
||||
text_split_all <- strsplit(text, "[ ;.,:\\|]")
|
||||
|
||||
+32
-9
@@ -89,6 +89,10 @@
|
||||
#' ab_atc("cephthriaxone")
|
||||
#' ab_atc("seephthriaaksone")
|
||||
ab_name <- function(x, language = get_locale(), tolower = FALSE, ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(tolower, allow_class = "logical", has_length = 1)
|
||||
|
||||
x <- translate_AMR(ab_validate(x = x, property = "name", ...), language = language)
|
||||
if (tolower == TRUE) {
|
||||
# use perl to only transform the first character
|
||||
@@ -102,18 +106,21 @@ ab_name <- function(x, language = get_locale(), tolower = FALSE, ...) {
|
||||
#' @aliases ATC
|
||||
#' @export
|
||||
ab_atc <- function(x, ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
ab_validate(x = x, property = "atc", ...)
|
||||
}
|
||||
|
||||
#' @rdname ab_property
|
||||
#' @export
|
||||
ab_cid <- function(x, ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
ab_validate(x = x, property = "cid", ...)
|
||||
}
|
||||
|
||||
#' @rdname ab_property
|
||||
#' @export
|
||||
ab_synonyms <- function(x, ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
syns <- ab_validate(x = x, property = "synonyms", ...)
|
||||
names(syns) <- x
|
||||
if (length(syns) == 1) {
|
||||
@@ -126,30 +133,38 @@ ab_synonyms <- function(x, ...) {
|
||||
#' @rdname ab_property
|
||||
#' @export
|
||||
ab_tradenames <- function(x, ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
ab_synonyms(x, ...)
|
||||
}
|
||||
|
||||
#' @rdname ab_property
|
||||
#' @export
|
||||
ab_group <- function(x, language = get_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
translate_AMR(ab_validate(x = x, property = "group", ...), language = language)
|
||||
}
|
||||
|
||||
#' @rdname ab_property
|
||||
#' @export
|
||||
ab_atc_group1 <- function(x, language = get_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
translate_AMR(ab_validate(x = x, property = "atc_group1", ...), language = language)
|
||||
}
|
||||
|
||||
#' @rdname ab_property
|
||||
#' @export
|
||||
ab_atc_group2 <- function(x, language = get_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
translate_AMR(ab_validate(x = x, property = "atc_group2", ...), language = language)
|
||||
}
|
||||
|
||||
#' @rdname ab_property
|
||||
#' @export
|
||||
ab_loinc <- function(x, ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
loincs <- ab_validate(x = x, property = "loinc", ...)
|
||||
names(loincs) <- x
|
||||
if (length(loincs) == 1) {
|
||||
@@ -162,7 +177,10 @@ ab_loinc <- function(x, ...) {
|
||||
#' @rdname ab_property
|
||||
#' @export
|
||||
ab_ddd <- function(x, administration = "oral", units = FALSE, ...) {
|
||||
stop_ifnot(administration %in% c("oral", "iv"), "`administration` must be 'oral' or 'iv'")
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(administration, is_in = c("oral", "iv"), has_length = 1)
|
||||
meet_criteria(units, allow_class = "logical", has_length = 1)
|
||||
|
||||
ddd_prop <- administration
|
||||
if (units == TRUE) {
|
||||
ddd_prop <- paste0(ddd_prop, "_units")
|
||||
@@ -175,6 +193,9 @@ ab_ddd <- function(x, administration = "oral", units = FALSE, ...) {
|
||||
#' @rdname ab_property
|
||||
#' @export
|
||||
ab_info <- function(x, language = get_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
x <- as.ab(x, ...)
|
||||
list(ab = as.character(x),
|
||||
atc = ab_atc(x),
|
||||
@@ -194,6 +215,9 @@ ab_info <- function(x, language = get_locale(), ...) {
|
||||
#' @rdname ab_property
|
||||
#' @export
|
||||
ab_url <- function(x, open = FALSE, ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(open, allow_class = "logical", has_length = 1)
|
||||
|
||||
ab <- as.ab(x = x, ... = ...)
|
||||
u <- paste0("https://www.whocc.no/atc_ddd_index/?code=", ab_atc(ab), "&showdescription=no")
|
||||
u[is.na(ab_atc(ab))] <- NA_character_
|
||||
@@ -201,12 +225,12 @@ ab_url <- function(x, open = FALSE, ...) {
|
||||
|
||||
NAs <- ab_name(ab, tolower = TRUE, language = NULL)[!is.na(ab) & is.na(ab_atc(ab))]
|
||||
if (length(NAs) > 0) {
|
||||
warning("No ATC code available for ", paste0(NAs, collapse = ", "), ".")
|
||||
warning_("No ATC code available for ", paste0(NAs, collapse = ", "), ".")
|
||||
}
|
||||
|
||||
if (open == TRUE) {
|
||||
if (length(u) > 1 & !is.na(u[1L])) {
|
||||
warning("only the first URL will be opened, as `browseURL()` only suports one string.")
|
||||
warning_("Only the first URL will be opened, as `browseURL()` only suports one string.")
|
||||
}
|
||||
if (!is.na(u[1L])) {
|
||||
utils::browseURL(u[1L])
|
||||
@@ -218,10 +242,9 @@ ab_url <- function(x, open = FALSE, ...) {
|
||||
#' @rdname ab_property
|
||||
#' @export
|
||||
ab_property <- function(x, property = "name", language = get_locale(), ...) {
|
||||
stop_if(length(property) != 1L, "'property' must be of length 1.")
|
||||
stop_ifnot(property %in% colnames(antibiotics),
|
||||
"invalid property: '", property, "' - use a column name of the `antibiotics` data set")
|
||||
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(property, is_in = colnames(antibiotics), has_length = 1)
|
||||
meet_criteria(language, is_in = c(LANGUAGES_SUPPORTED, ""), has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
|
||||
translate_AMR(ab_validate(x = x, property = property, ...), language = language)
|
||||
}
|
||||
|
||||
@@ -237,10 +260,10 @@ ab_validate <- function(x, property, ...) {
|
||||
if (!all(x %in% antibiotics[, property])) {
|
||||
x <- data.frame(ab = as.ab(x, ...), stringsAsFactors = FALSE) %pm>%
|
||||
pm_left_join(antibiotics, by = "ab") %pm>%
|
||||
pm_pull(property)
|
||||
pm_pull(property)
|
||||
}
|
||||
if (property == "ab") {
|
||||
return(structure(x, class = property))
|
||||
return(set_clean_class(x, new_class = c("ab", "character")))
|
||||
} else if (property == "cid") {
|
||||
return(as.integer(x))
|
||||
} else if (property %like% "ddd") {
|
||||
|
||||
@@ -28,9 +28,11 @@
|
||||
#' Calculates age in years based on a reference date, which is the sytem date at default.
|
||||
#' @inheritSection lifecycle Stable lifecycle
|
||||
#' @param x date(s), will be coerced with [as.POSIXlt()]
|
||||
#' @param reference reference date(s) (defaults to today), will be coerced with [as.POSIXlt()] and cannot be lower than `x`
|
||||
#' @param reference reference date(s) (defaults to today), will be coerced with [as.POSIXlt()]
|
||||
#' @param exact a logical to indicate whether age calculation should be exact, i.e. with decimals. It divides the number of days of [year-to-date](https://en.wikipedia.org/wiki/Year-to-date) (YTD) of `x` by the number of days in the year of `reference` (either 365 or 366).
|
||||
#' @param na.rm a logical to indicate whether missing values should be removed
|
||||
#' @param ... parameters passed on to [as.POSIXlt()], such as `origin`
|
||||
#' @details Ages below 0 will be returned as `NA` with a warning. Ages above 120 will only give a warning.
|
||||
#' @return An [integer] (no decimals) if `exact = FALSE`, a [double] (with decimals) otherwise
|
||||
#' @seealso To split ages into groups, use the [age_groups()] function.
|
||||
#' @inheritSection AMR Read more on our website!
|
||||
@@ -44,13 +46,18 @@
|
||||
#' df$age_exact <- age(df$birth_date, exact = TRUE)
|
||||
#'
|
||||
#' df
|
||||
age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE) {
|
||||
age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
|
||||
meet_criteria(x, allow_class = c("character", "Date", "POSIXt"))
|
||||
meet_criteria(reference, allow_class = c("character", "Date", "POSIXt"))
|
||||
meet_criteria(exact, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
|
||||
|
||||
if (length(x) != length(reference)) {
|
||||
stop_if(length(reference) != 1, "`x` and `reference` must be of same length, or `reference` must be of length 1.")
|
||||
reference <- rep(reference, length(x))
|
||||
}
|
||||
x <- as.POSIXlt(x)
|
||||
reference <- as.POSIXlt(reference)
|
||||
x <- as.POSIXlt(x, ...)
|
||||
reference <- as.POSIXlt(reference, ...)
|
||||
|
||||
# from https://stackoverflow.com/a/25450756/4575331
|
||||
years_gap <- reference$year - x$year
|
||||
@@ -76,10 +83,10 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE) {
|
||||
|
||||
if (any(ages < 0, na.rm = TRUE)) {
|
||||
ages[ages < 0] <- NA
|
||||
warning("NAs introduced for ages below 0.")
|
||||
warning_("NAs introduced for ages below 0.", call = TRUE)
|
||||
}
|
||||
if (any(ages > 120, na.rm = TRUE)) {
|
||||
warning("Some ages are above 120.")
|
||||
warning_("Some ages are above 120.", call = TRUE)
|
||||
}
|
||||
|
||||
if (isTRUE(na.rm)) {
|
||||
@@ -98,13 +105,13 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE) {
|
||||
#' @param na.rm a [logical] to indicate whether missing values should be removed
|
||||
#' @details To split ages, the input for the `split_at` parameter can be:
|
||||
#'
|
||||
#' * A numeric vector. A vector of e.g. `c(10, 20)` will split on 0-9, 10-19 and 20+. A value of only `50` will split on 0-49 and 50+.
|
||||
#' * A numeric vector. A value of e.g. `c(10, 20)` will split `x` on 0-9, 10-19 and 20+. A value of only `50` will split `x` on 0-49 and 50+.
|
||||
#' The default is to split on young children (0-11), youth (12-24), young adults (25-54), middle-aged adults (55-74) and elderly (75+).
|
||||
#' * A character:
|
||||
#' - `"children"` or `"kids"`, equivalent of: `c(0, 1, 2, 4, 6, 13, 18)`. This will split on 0, 1, 2-3, 4-5, 6-12, 13-17 and 18+.
|
||||
#' - `"elderly"` or `"seniors"`, equivalent of: `c(65, 75, 85)`. This will split on 0-64, 65-74, 75-84, 85+.
|
||||
#' - `"fives"`, equivalent of: `1:20 * 5`. This will split on 0-4, 5-9, 10-14, ..., 90-94, 95-99, 100+.
|
||||
#' - `"tens"`, equivalent of: `1:10 * 10`. This will split on 0-9, 10-19, 20-29, ..., 80-89, 90-99, 100+.
|
||||
#' - `"fives"`, equivalent of: `1:20 * 5`. This will split on 0-4, 5-9, ..., 95-99, 100+.
|
||||
#' - `"tens"`, equivalent of: `1:10 * 10`. This will split on 0-9, 10-19, ..., 90-99, 100+.
|
||||
#' @return Ordered [factor]
|
||||
#' @seealso To determine ages, based on one or more reference dates, use the [age()] function.
|
||||
#' @export
|
||||
@@ -127,25 +134,28 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE) {
|
||||
#' age_groups(ages, split_at = "fives")
|
||||
#'
|
||||
#' # split specifically for children
|
||||
#' age_groups(ages, "children")
|
||||
#' # same:
|
||||
#' age_groups(ages, c(1, 2, 4, 6, 13, 17))
|
||||
#' age_groups(ages, "children")
|
||||
#'
|
||||
#' \donttest{
|
||||
#' # resistance of ciprofloxacine per age group
|
||||
#' library(dplyr)
|
||||
#' example_isolates %>%
|
||||
#' filter_first_isolate() %>%
|
||||
#' filter(mo == as.mo("E. coli")) %>%
|
||||
#' group_by(age_group = age_groups(age)) %>%
|
||||
#' select(age_group, CIP) %>%
|
||||
#' ggplot_rsi(x = "age_group", minimum = 0)
|
||||
#' # resistance of ciprofloxacin per age group
|
||||
#' if (require("dplyr")) {
|
||||
#' example_isolates %>%
|
||||
#' filter_first_isolate() %>%
|
||||
#' filter(mo == as.mo("E. coli")) %>%
|
||||
#' group_by(age_group = age_groups(age)) %>%
|
||||
#' select(age_group, CIP) %>%
|
||||
#' ggplot_rsi(x = "age_group", minimum = 0)
|
||||
#' }
|
||||
#' }
|
||||
age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
|
||||
stop_ifnot(is.numeric(x), "`x` must be numeric, not ", paste0(class(x), collapse = "/"))
|
||||
meet_criteria(x, allow_class = c("numeric", "integer"))
|
||||
meet_criteria(split_at, allow_class = c("numeric", "integer", "character"))
|
||||
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
|
||||
|
||||
if (any(x < 0, na.rm = TRUE)) {
|
||||
x[x < 0] <- NA
|
||||
warning("NAs introduced for ages below 0.")
|
||||
warning_("NAs introduced for ages below 0.", call = TRUE)
|
||||
}
|
||||
if (is.character(split_at)) {
|
||||
split_at <- split_at[1L]
|
||||
@@ -169,17 +179,17 @@ age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
|
||||
|
||||
# turn input values to 'split_at' indices
|
||||
y <- x
|
||||
labs <- split_at
|
||||
lbls <- split_at
|
||||
for (i in seq_len(length(split_at))) {
|
||||
y[x >= split_at[i]] <- i
|
||||
# create labels
|
||||
labs[i - 1] <- paste0(unique(c(split_at[i - 1], split_at[i] - 1)), collapse = "-")
|
||||
lbls[i - 1] <- paste0(unique(c(split_at[i - 1], split_at[i] - 1)), collapse = "-")
|
||||
}
|
||||
|
||||
# last category
|
||||
labs[length(labs)] <- paste0(split_at[length(split_at)], "+")
|
||||
lbls[length(lbls)] <- paste0(split_at[length(split_at)], "+")
|
||||
|
||||
agegroups <- factor(labs[y], levels = labs, ordered = TRUE)
|
||||
agegroups <- factor(lbls[y], levels = lbls, ordered = TRUE)
|
||||
|
||||
if (isTRUE(na.rm)) {
|
||||
agegroups <- agegroups[!is.na(agegroups)]
|
||||
|
||||
@@ -42,8 +42,8 @@
|
||||
#' - Determining multi-drug resistance (MDR) / multi-drug resistant organisms (MDRO)
|
||||
#' - Calculating (empirical) susceptibility of both mono therapy and combination therapies
|
||||
#' - Predicting future antimicrobial resistance using regression models
|
||||
#' - Getting properties for any microorganism (like Gram stain, species, genus or family)
|
||||
#' - Getting properties for any antibiotic (like name, code of EARS-Net/ATC/LOINC/PubChem, defined daily dose or trade name)
|
||||
#' - Getting properties for any microorganism (such as Gram stain, species, genus or family)
|
||||
#' - Getting properties for any antibiotic (such as name, code of EARS-Net/ATC/LOINC/PubChem, defined daily dose or trade name)
|
||||
#' - Plotting antimicrobial resistance
|
||||
#' - Applying EUCAST expert rules
|
||||
#' - Getting SNOMED codes of a microorganism, or getting properties of a microorganism based on a SNOMED code
|
||||
@@ -66,6 +66,7 @@
|
||||
#' Post Office Box 30001 \cr
|
||||
#' 9700 RB Groningen \cr
|
||||
#' The Netherlands
|
||||
#' <https://msberends.github.io/AMR/>
|
||||
#'
|
||||
#' If you have found a bug, please file a new issue at: \cr
|
||||
#' <https://github.com/msberends/AMR/issues>
|
||||
@@ -73,7 +74,7 @@
|
||||
#' @rdname AMR
|
||||
NULL
|
||||
|
||||
#' Plotting for classes `rsi` and `disk`
|
||||
#' Plotting for classes `rsi`, `mic` and `disk`
|
||||
#'
|
||||
#' Functions to print classes of the `AMR` package.
|
||||
#' @inheritSection lifecycle Stable lifecycle
|
||||
|
||||
+11
-14
@@ -78,6 +78,11 @@ atc_online_property <- function(atc_code,
|
||||
administration = "O",
|
||||
url = "https://www.whocc.no/atc_ddd_index/?code=%s&showdescription=no",
|
||||
url_vet = "https://www.whocc.no/atcvet/atcvet_index/?code=%s&showdescription=no") {
|
||||
meet_criteria(atc_code, allow_class = "character")
|
||||
meet_criteria(property, allow_class = "character", has_length = 1, is_in = c("ATC", "Name", "DDD", "U", "Adm.R", "Note", "groups"), ignore.case = TRUE)
|
||||
meet_criteria(administration, allow_class = "character", has_length = 1)
|
||||
meet_criteria(url, allow_class = "character", has_length = 1, looks_like = "https?://")
|
||||
meet_criteria(url_vet, allow_class = "character", has_length = 1, looks_like = "https?://")
|
||||
|
||||
has_internet <- import_fn("has_internet", "curl")
|
||||
html_attr <- import_fn("html_attr", "rvest")
|
||||
@@ -95,28 +100,18 @@ atc_online_property <- function(atc_code,
|
||||
}
|
||||
|
||||
if (!has_internet()) {
|
||||
message("There appears to be no internet connection, returning NA.")
|
||||
message_("There appears to be no internet connection, returning NA.",
|
||||
add_fn = font_red,
|
||||
as_note = FALSE)
|
||||
return(rep(NA, length(atc_code)))
|
||||
}
|
||||
|
||||
stop_if(length(property) != 1L, "`property` must be of length 1")
|
||||
stop_if(length(administration) != 1L, "`administration` must be of length 1")
|
||||
|
||||
# also allow unit as property
|
||||
if (property %like% "unit") {
|
||||
property <- "U"
|
||||
}
|
||||
|
||||
# validation of properties
|
||||
valid_properties <- c("ATC", "Name", "DDD", "U", "Adm.R", "Note", "groups")
|
||||
valid_properties.bak <- valid_properties
|
||||
|
||||
property <- tolower(property)
|
||||
valid_properties <- tolower(valid_properties)
|
||||
|
||||
stop_ifnot(property %in% valid_properties,
|
||||
"Invalid `property`, use one of ", paste(valid_properties.bak, collapse = ", "))
|
||||
|
||||
if (property == "ddd") {
|
||||
returnvalue <- rep(NA_real_, length(atc_code))
|
||||
} else if (property == "groups") {
|
||||
@@ -166,7 +161,7 @@ atc_online_property <- function(atc_code,
|
||||
colnames(tbl) <- gsub("^atc.*", "atc", tolower(colnames(tbl)))
|
||||
|
||||
if (length(tbl) == 0) {
|
||||
warning("ATC not found: ", atc_code[i], ". Please check ", atc_url, ".", call. = FALSE)
|
||||
warning_("ATC not found: ", atc_code[i], ". Please check ", atc_url, ".", call = FALSE)
|
||||
returnvalue[i] <- NA
|
||||
next
|
||||
}
|
||||
@@ -199,11 +194,13 @@ atc_online_property <- function(atc_code,
|
||||
#' @rdname atc_online
|
||||
#' @export
|
||||
atc_online_groups <- function(atc_code, ...) {
|
||||
meet_criteria(atc_code, allow_class = "character")
|
||||
atc_online_property(atc_code = atc_code, property = "groups", ...)
|
||||
}
|
||||
|
||||
#' @rdname atc_online
|
||||
#' @export
|
||||
atc_online_ddd <- function(atc_code, ...) {
|
||||
meet_criteria(atc_code, allow_class = "character")
|
||||
atc_online_property(atc_code = atc_code, property = "ddd", ...)
|
||||
}
|
||||
+5
-2
@@ -43,7 +43,9 @@
|
||||
#' availability()
|
||||
#' }
|
||||
availability <- function(tbl, width = NULL) {
|
||||
stop_ifnot(is.data.frame(tbl), "`tbl` must be a data.frame")
|
||||
meet_criteria(tbl, allow_class = "data.frame")
|
||||
meet_criteria(width, allow_class = "numeric", allow_NULL = TRUE)
|
||||
|
||||
x <- sapply(tbl, function(x) {
|
||||
1 - sum(is.na(x)) / length(x)
|
||||
})
|
||||
@@ -83,7 +85,8 @@ availability <- function(tbl, width = NULL) {
|
||||
available = percentage(x),
|
||||
visual_availabilty = paste0("|", x_chars, x_chars_empty, "|"),
|
||||
resistant = R_print,
|
||||
visual_resistance = vis_resistance)
|
||||
visual_resistance = vis_resistance,
|
||||
stringsAsFactors = FALSE)
|
||||
if (length(R[is.na(R)]) == ncol(tbl)) {
|
||||
df[, 1:3]
|
||||
} else {
|
||||
|
||||
+34
-18
@@ -31,8 +31,8 @@
|
||||
#' @param combine_IR logical to indicate whether values R and I should be summed
|
||||
#' @param add_ab_group logical to indicate where the group of the antimicrobials must be included as a first column
|
||||
#' @param remove_intrinsic_resistant logical to indicate that rows and columns with 100% resistance for all tested antimicrobials must be removed from the table
|
||||
#' @param FUN the function to call on the `mo` column to transform the microorganism IDs, defaults to [mo_shortname()]
|
||||
#' @param translate_ab a character of length 1 containing column names of the [antibiotics] data set
|
||||
#' @param FUN function to call on the `mo` column to transform the microorganism IDs, defaults to [mo_shortname()]
|
||||
#' @param translate_ab character of length 1 containing column names of the [antibiotics] data set
|
||||
#' @param ... arguments passed on to `FUN`
|
||||
#' @inheritParams rsi_df
|
||||
#' @inheritParams base::formatC
|
||||
@@ -61,9 +61,10 @@ bug_drug_combinations <- function(x,
|
||||
col_mo = NULL,
|
||||
FUN = mo_shortname,
|
||||
...) {
|
||||
stop_ifnot(is.data.frame(x), "`x` must be a data frame")
|
||||
stop_ifnot(any(sapply(x, is.rsi), na.rm = TRUE), "No columns with class <rsi> found. See ?as.rsi.")
|
||||
|
||||
meet_criteria(x, allow_class = "data.frame", contains_column_class = "rsi")
|
||||
meet_criteria(col_mo, allow_class = "character", is_in = colnames(x), has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(FUN, allow_class = "function", has_length = 1)
|
||||
|
||||
# try to find columns based on type
|
||||
# -- mo
|
||||
if (is.null(col_mo)) {
|
||||
@@ -78,13 +79,13 @@ bug_drug_combinations <- function(x,
|
||||
|
||||
unique_mo <- sort(unique(x[, col_mo, drop = TRUE]))
|
||||
|
||||
out <- data.frame(
|
||||
mo = character(0),
|
||||
ab = character(0),
|
||||
S = integer(0),
|
||||
I = integer(0),
|
||||
R = integer(0),
|
||||
total = integer(0))
|
||||
out <- data.frame(mo = character(0),
|
||||
ab = character(0),
|
||||
S = integer(0),
|
||||
I = integer(0),
|
||||
R = integer(0),
|
||||
total = integer(0),
|
||||
stringsAsFactors = FALSE)
|
||||
|
||||
for (i in seq_len(length(unique_mo))) {
|
||||
# filter on MO group and only select R/SI columns
|
||||
@@ -100,11 +101,13 @@ bug_drug_combinations <- function(x,
|
||||
S = merged$S,
|
||||
I = merged$I,
|
||||
R = merged$R,
|
||||
total = merged$S + merged$I + merged$R)
|
||||
out <- rbind(out, out_group)
|
||||
total = merged$S + merged$I + merged$R,
|
||||
stringsAsFactors = FALSE)
|
||||
out <- rbind(out, out_group, stringsAsFactors = FALSE)
|
||||
}
|
||||
|
||||
structure(.Data = out, class = c("bug_drug_combinations", x_class))
|
||||
set_clean_class(out,
|
||||
new_class = c("bug_drug_combinations", x_class))
|
||||
}
|
||||
|
||||
#' @method format bug_drug_combinations
|
||||
@@ -121,6 +124,17 @@ format.bug_drug_combinations <- function(x,
|
||||
decimal.mark = getOption("OutDec"),
|
||||
big.mark = ifelse(decimal.mark == ",", ".", ","),
|
||||
...) {
|
||||
meet_criteria(x, allow_class = "data.frame")
|
||||
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1)
|
||||
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(combine_IR, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(add_ab_group, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(remove_intrinsic_resistant, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(decimal.mark, allow_class = "character", has_length = 1)
|
||||
meet_criteria(big.mark, allow_class = "character", has_length = 1)
|
||||
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||
x <- subset(x, total >= minimum)
|
||||
|
||||
@@ -151,7 +165,8 @@ format.bug_drug_combinations <- function(x,
|
||||
|
||||
remove_NAs <- function(.data) {
|
||||
cols <- colnames(.data)
|
||||
.data <- as.data.frame(sapply(.data, function(x) ifelse(is.na(x), "", x), simplify = FALSE))
|
||||
.data <- as.data.frame(sapply(.data, function(x) ifelse(is.na(x), "", x), simplify = FALSE),
|
||||
stringsAsFactors = FALSE)
|
||||
colnames(.data) <- cols
|
||||
.data
|
||||
}
|
||||
@@ -231,7 +246,8 @@ format.bug_drug_combinations <- function(x,
|
||||
#' @export
|
||||
print.bug_drug_combinations <- function(x, ...) {
|
||||
x_class <- class(x)
|
||||
print(structure(x, class = x_class[x_class != "bug_drug_combinations"]),
|
||||
print(set_clean_class(x,
|
||||
new_class = x_class[x_class != "bug_drug_combinations"]),
|
||||
...)
|
||||
message(font_blue("NOTE: Use 'format()' on this result to get a publishable/printable format."))
|
||||
message_("Use 'format()' on this result to get a publishable/printable format.", as_note = FALSE)
|
||||
}
|
||||
+31
-15
@@ -23,20 +23,36 @@
|
||||
# how to conduct AMR analysis: https://msberends.github.io/AMR/ #
|
||||
# ==================================================================== #
|
||||
|
||||
format_included_data_number <- function(data) {
|
||||
if (is.data.frame(data)) {
|
||||
n <- nrow(data)
|
||||
} else {
|
||||
n <- length(unique(data))
|
||||
}
|
||||
if (n > 10000) {
|
||||
rounder <- -3 # round on thousands
|
||||
} else if (n > 1000) {
|
||||
rounder <- -2 # round on hundreds
|
||||
} else {
|
||||
rounder <- -1 # round on tens
|
||||
}
|
||||
paste0("~", format(round(n, rounder), decimal.mark = ".", big.mark = ","))
|
||||
}
|
||||
|
||||
#' The Catalogue of Life
|
||||
#'
|
||||
#' This package contains the complete taxonomic tree of almost all microorganisms from the authoritative and comprehensive Catalogue of Life.
|
||||
#' @section Catalogue of Life:
|
||||
#' \if{html}{\figure{logo_col.png}{options: height=40px style=margin-bottom:5px} \cr}
|
||||
#' This package contains the complete taxonomic tree of almost all microorganisms (~70,000 species) from the authoritative and comprehensive Catalogue of Life (<http://www.catalogueoflife.org>). The Catalogue of Life is the most comprehensive and authoritative global index of species currently available.
|
||||
#' This package contains the complete taxonomic tree of almost all microorganisms (~70,000 species) from the authoritative and comprehensive Catalogue of Life (CoL, <http://www.catalogueoflife.org>). The CoL is the most comprehensive and authoritative global index of species currently available. Nonetheless, we supplemented the CoL data with data from the List of Prokaryotic names with Standing in Nomenclature (LPSN, [lpsn.dsmz.de](https://lpsn.dsmz.de)). This supplementation is needed until the [CoL+ project](https://github.com/Sp2000/colplus) is finished, which we await.
|
||||
#'
|
||||
#' [Click here][catalogue_of_life] for more information about the included taxa. Check which version of the Catalogue of Life was included in this package with [catalogue_of_life_version()].
|
||||
#' [Click here][catalogue_of_life] for more information about the included taxa. Check which versions of the CoL and LSPN were included in this package with [catalogue_of_life_version()].
|
||||
#' @section Included taxa:
|
||||
#' Included are:
|
||||
#' - All ~61,000 (sub)species from the kingdoms of Archaea, Bacteria, Chromista and Protozoa
|
||||
#' - All ~8,500 (sub)species from these orders of the kingdom of Fungi: Eurotiales, Microascales, Mucorales, Onygenales, Pneumocystales, Saccharomycetales, Schizosaccharomycetales and Tremellales. The kingdom of Fungi is a very large taxon with almost 300,000 different (sub)species, of which most are not microbial (but rather macroscopic, like mushrooms). Because of this, not all fungi fit the scope of this package and including everything would tremendously slow down our algorithms too. By only including the aforementioned taxonomic orders, the most relevant fungi are covered (like all species of *Aspergillus*, *Candida*, *Cryptococcus*, *Histplasma*, *Pneumocystis*, *Saccharomyces* and *Trichophyton*).
|
||||
#' - All ~150 (sub)species from ~100 other relevant genera from the kingdom of Animalia (like *Strongyloides* and *Taenia*)
|
||||
#' - All ~23,000 previously accepted names of all included (sub)species (these were taxonomically renamed)
|
||||
#' - All `r format_included_data_number(microorganisms[which(microorganisms$kingdom %in% c("Archeae", "Bacteria", "Chromista", "Protozoa")), ])` (sub)species from the kingdoms of Archaea, Bacteria, Chromista and Protozoa
|
||||
#' - All `r format_included_data_number(microorganisms[which(microorganisms$kingdom == "Fungi" & microorganisms$order %in% c("Eurotiales", "Microascales", "Mucorales", "Onygenales", "Pneumocystales", "Saccharomycetales", "Schizosaccharomycetales", "Tremellales")), ])` (sub)species from these orders of the kingdom of Fungi: Eurotiales, Microascales, Mucorales, Onygenales, Pneumocystales, Saccharomycetales, Schizosaccharomycetales and Tremellales, as well as `r format_included_data_number(microorganisms[which(microorganisms$kingdom == "Fungi" & !microorganisms$order %in% c("Eurotiales", "Microascales", "Mucorales", "Onygenales", "Pneumocystales", "Saccharomycetales", "Schizosaccharomycetales", "Tremellales")), ])` other fungal (sub)species. The kingdom of Fungi is a very large taxon with almost 300,000 different (sub)species, of which most are not microbial (but rather macroscopic, like mushrooms). Because of this, not all fungi fit the scope of this package and including everything would tremendously slow down our algorithms too. By only including the aforementioned taxonomic orders, the most relevant fungi are covered (such as all species of *Aspergillus*, *Candida*, *Cryptococcus*, *Histplasma*, *Pneumocystis*, *Saccharomyces* and *Trichophyton*).
|
||||
#' - All `r format_included_data_number(microorganisms[which(microorganisms$kingdom == "Animalia"), ])` (sub)species from `r format_included_data_number(microorganisms[which(microorganisms$kingdom == "Animalia"), "genus"])` other relevant genera from the kingdom of Animalia (such as *Strongyloides* and *Taenia*)
|
||||
#' - All `r format_included_data_number(microorganisms.old)` previously accepted names of all included (sub)species (these were taxonomically renamed)
|
||||
#' - The complete taxonomic tree of all included (sub)species: from kingdom to subspecies
|
||||
#' - The responsible author(s) and year of scientific publication
|
||||
#'
|
||||
@@ -57,26 +73,26 @@
|
||||
#' mo_shortname("Chlamydophila psittaci")
|
||||
#' # Note: 'Chlamydophila psittaci' (Everett et al., 1999) was renamed back to
|
||||
#' # 'Chlamydia psittaci' (Page, 1968)
|
||||
#' # [1] "C. psittaci"
|
||||
#' #> [1] "C. psittaci"
|
||||
#'
|
||||
#' # Get any property from the entire taxonomic tree for all included species
|
||||
#' mo_class("E. coli")
|
||||
#' # [1] "Gammaproteobacteria"
|
||||
#' #> [1] "Gammaproteobacteria"
|
||||
#'
|
||||
#' mo_family("E. coli")
|
||||
#' # [1] "Enterobacteriaceae"
|
||||
#' #> [1] "Enterobacteriaceae"
|
||||
#'
|
||||
#' mo_gramstain("E. coli") # based on kingdom and phylum, see ?mo_gramstain
|
||||
#' # [1] "Gram negative"
|
||||
#' #> [1] "Gram-negative"
|
||||
#'
|
||||
#' mo_ref("E. coli")
|
||||
#' # [1] "Castellani et al., 1919"
|
||||
#' #> [1] "Castellani et al., 1919"
|
||||
#'
|
||||
#' # Do not get mistaken - this package is about microorganisms
|
||||
#' mo_kingdom("C. elegans")
|
||||
#' # [1] "Fungi" # Fungi?!
|
||||
#' #> [1] "Fungi" # Fungi?!
|
||||
#' mo_name("C. elegans")
|
||||
#' # [1] "Cladosporium elegans" # Because a microorganism was found
|
||||
#' #> [1] "Cladosporium elegans" # Because a microorganism was found
|
||||
NULL
|
||||
|
||||
#' Version info of included Catalogue of Life
|
||||
@@ -107,8 +123,8 @@ catalogue_of_life_version <- function() {
|
||||
n_total_species = nrow(microorganisms),
|
||||
n_total_synonyms = nrow(microorganisms.old)))
|
||||
|
||||
structure(.Data = lst,
|
||||
class = c("catalogue_of_life_version", "list"))
|
||||
set_clean_class(lst,
|
||||
new_class = c("catalogue_of_life_version", "list"))
|
||||
}
|
||||
|
||||
#' @method print catalogue_of_life_version
|
||||
|
||||
@@ -134,7 +134,7 @@ count_R <- function(..., only_all_tested = FALSE) {
|
||||
#' @rdname count
|
||||
#' @export
|
||||
count_IR <- function(..., only_all_tested = FALSE) {
|
||||
warning("Using 'count_IR' is discouraged; use 'count_resistant()' instead to not consider \"I\" being resistant.", call. = FALSE)
|
||||
warning_("Using 'count_IR' is discouraged; use 'count_resistant()' instead to not consider \"I\" being resistant.", call = FALSE)
|
||||
rsi_calc(...,
|
||||
ab_result = c("I", "R"),
|
||||
only_all_tested = only_all_tested,
|
||||
@@ -162,7 +162,7 @@ count_SI <- function(..., only_all_tested = FALSE) {
|
||||
#' @rdname count
|
||||
#' @export
|
||||
count_S <- function(..., only_all_tested = FALSE) {
|
||||
warning("Using 'count_S' is discouraged; use 'count_susceptible()' instead to also consider \"I\" being susceptible.", call. = FALSE)
|
||||
warning_("Using 'count_S' is discouraged; use 'count_susceptible()' instead to also consider \"I\" being susceptible.", call = FALSE)
|
||||
rsi_calc(...,
|
||||
ab_result = "S",
|
||||
only_all_tested = only_all_tested,
|
||||
@@ -189,7 +189,6 @@ count_df <- function(data,
|
||||
language = get_locale(),
|
||||
combine_SI = TRUE,
|
||||
combine_IR = FALSE) {
|
||||
|
||||
rsi_calc_df(type = "count",
|
||||
data = data,
|
||||
translate_ab = translate_ab,
|
||||
|
||||
@@ -25,10 +25,10 @@
|
||||
|
||||
#' Data sets with `r format(nrow(antibiotics) + nrow(antivirals), big.mark = ",")` antimicrobials
|
||||
#'
|
||||
#' Two data sets containing all antibiotics/antimycotics and antivirals. Use [as.ab()] or one of the [ab_property()] functions to retrieve values from the [antibiotics] data set. Three identifiers are included in this data set: an antibiotic ID (`ab`, primarily used in this package) as defined by WHONET/EARS-Net, an ATC code (`atc`) as defined by the WHO, and a Compound ID (`cid`) as found in PubChem. Other properties in this data set are derived from one or more of these codes.
|
||||
#' Two data sets containing all antibiotics/antimycotics and antivirals. Use [as.ab()] or one of the [`ab_*`][ab_property()] functions to retrieve values from the [antibiotics] data set. Three identifiers are included in this data set: an antibiotic ID (`ab`, primarily used in this package) as defined by WHONET/EARS-Net, an ATC code (`atc`) as defined by the WHO, and a Compound ID (`cid`) as found in PubChem. Other properties in this data set are derived from one or more of these codes.
|
||||
#' @format
|
||||
#' ### For the [antibiotics] data set: a [data.frame] with `r nrow(antibiotics)` observations and `r ncol(antibiotics)` variables:
|
||||
#' - `ab`\cr Antibiotic ID as used in this package (like `AMC`), using the official EARS-Net (European Antimicrobial Resistance Surveillance Network) codes where available
|
||||
#' - `ab`\cr Antibiotic ID as used in this package (such as `AMC`), using the official EARS-Net (European Antimicrobial Resistance Surveillance Network) codes where available
|
||||
#' - `atc`\cr ATC code (Anatomical Therapeutic Chemical) as defined by the WHOCC, like `J01CR02`
|
||||
#' - `cid`\cr Compound ID as found in PubChem
|
||||
#' - `name`\cr Official name as used by WHONET/EARS-Net or the WHO
|
||||
@@ -258,7 +258,7 @@ catalogue_of_life <- list(
|
||||
#' - `antibiotic`\cr Name of the antibiotic drug
|
||||
#' @details The repository of this `AMR` package contains a file comprising this exact data set: <https://github.com/msberends/AMR/blob/master/data-raw/intrinsic_resistant.txt>. This file **allows for machine reading EUCAST guidelines about intrinsic resistance**, which is almost impossible with the Excel and PDF files distributed by EUCAST. The file is updated automatically.
|
||||
#'
|
||||
#' This data set is based on '`r EUCAST_VERSION_EXPERT_RULES[["3.2"]]$title`', `r EUCAST_VERSION_EXPERT_RULES[["3.2"]]$version_txt` from `r EUCAST_VERSION_EXPERT_RULES[["3.2"]]$year`.
|
||||
#' This data set is based on `r format_eucast_version_nr(3.2)`.
|
||||
#' @inheritSection AMR Reference data publicly available
|
||||
#' @inheritSection AMR Read more on our website!
|
||||
#' @examples
|
||||
|
||||
+15
-1
@@ -30,4 +30,18 @@
|
||||
#' @inheritSection AMR Read more on our website!
|
||||
#' @keywords internal
|
||||
#' @name AMR-deprecated
|
||||
# @export
|
||||
#' @export
|
||||
p_symbol <- function(p, emptychar = " ") {
|
||||
.Deprecated(package = "AMR", new = "cleaner::p_symbol")
|
||||
|
||||
p <- as.double(p)
|
||||
s <- rep(NA_character_, length(p))
|
||||
|
||||
s[p <= 1] <- emptychar
|
||||
s[p <= 0.100] <- "."
|
||||
s[p <= 0.050] <- "*"
|
||||
s[p <= 0.010] <- "**"
|
||||
s[p <= 0.001] <- "***"
|
||||
|
||||
s
|
||||
}
|
||||
@@ -39,7 +39,6 @@
|
||||
#' @examples
|
||||
#' \donttest{
|
||||
#' # transform existing disk zones to the `disk` class
|
||||
#' library(dplyr)
|
||||
#' df <- data.frame(microorganism = "E. coli",
|
||||
#' AMP = 20,
|
||||
#' CIP = 14,
|
||||
@@ -58,6 +57,9 @@
|
||||
#' as.rsi(df)
|
||||
#' }
|
||||
as.disk <- function(x, na.rm = FALSE) {
|
||||
meet_criteria(x, allow_class = c("disk", "character", "numeric", "integer"), allow_NA = TRUE)
|
||||
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
|
||||
|
||||
if (!is.disk(x)) {
|
||||
x <- x %pm>% unlist()
|
||||
if (na.rm == TRUE) {
|
||||
@@ -98,19 +100,23 @@ as.disk <- function(x, na.rm = FALSE) {
|
||||
unique() %pm>%
|
||||
sort()
|
||||
list_missing <- paste0('"', list_missing, '"', collapse = ", ")
|
||||
warning(na_after - na_before, " results truncated (",
|
||||
round(((na_after - na_before) / length(x)) * 100),
|
||||
"%) that were invalid disk zones: ",
|
||||
list_missing, call. = FALSE)
|
||||
warning_(na_after - na_before, " results truncated (",
|
||||
round(((na_after - na_before) / length(x)) * 100),
|
||||
"%) that were invalid disk zones: ",
|
||||
list_missing, call = FALSE)
|
||||
}
|
||||
}
|
||||
structure(as.integer(x),
|
||||
class = c("disk", "integer"))
|
||||
set_clean_class(as.integer(x),
|
||||
new_class = c("disk", "integer"))
|
||||
}
|
||||
|
||||
all_valid_disks <- function(x) {
|
||||
x_disk <- suppressWarnings(as.disk(x[!is.na(x)]))
|
||||
!any(is.na(x_disk)) & !all(is.na(x))
|
||||
if (!inherits(x, c("disk", "character", "numeric", "integer"))) {
|
||||
return(FALSE)
|
||||
}
|
||||
x_disk <- tryCatch(suppressWarnings(as.disk(x[!is.na(x)])),
|
||||
error = function(e) NA)
|
||||
!any(is.na(x_disk)) && !all(is.na(x))
|
||||
}
|
||||
|
||||
#' @rdname as.disk
|
||||
@@ -139,6 +145,30 @@ print.disk <- function(x, ...) {
|
||||
print(as.integer(x), quote = FALSE)
|
||||
}
|
||||
|
||||
#' @method plot disk
|
||||
#' @export
|
||||
#' @importFrom graphics barplot axis
|
||||
#' @rdname plot
|
||||
plot.disk <- function(x,
|
||||
main = paste("Disk zones values of", deparse(substitute(x))),
|
||||
ylab = "Frequency",
|
||||
xlab = "Disk diffusion (mm)",
|
||||
axes = FALSE,
|
||||
...) {
|
||||
meet_criteria(main, 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(axes, allow_class = "logical", has_length = 1)
|
||||
|
||||
barplot(table(x),
|
||||
ylab = ylab,
|
||||
xlab = xlab,
|
||||
axes = axes,
|
||||
main = main,
|
||||
...)
|
||||
axis(2, seq(0, max(table(x))))
|
||||
}
|
||||
|
||||
#' @method [ disk
|
||||
#' @export
|
||||
#' @noRd
|
||||
@@ -194,14 +224,12 @@ unique.disk <- function(x, incomparables = FALSE, ...) {
|
||||
|
||||
# will be exported using s3_register() in R/zzz.R
|
||||
get_skimmers.disk <- function(column) {
|
||||
sfl <- import_fn("sfl", "skimr", error_on_fail = FALSE)
|
||||
inline_hist <- import_fn("inline_hist", "skimr", error_on_fail = FALSE)
|
||||
sfl(
|
||||
skimr::sfl(
|
||||
skim_type = "disk",
|
||||
min = ~min(as.double(.), na.rm = TRUE),
|
||||
max = ~max(as.double(.), na.rm = TRUE),
|
||||
median = ~stats::median(as.double(.), na.rm = TRUE),
|
||||
n_unique = ~pm_n_distinct(., na.rm = TRUE),
|
||||
hist = ~inline_hist(stats::na.omit(as.double(.)))
|
||||
hist = ~skimr::inline_hist(stats::na.omit(as.double(.)))
|
||||
)
|
||||
}
|
||||
+111
-66
@@ -27,13 +27,29 @@
|
||||
# (running "data-raw/internals.R" will process that TSV file)
|
||||
EUCAST_VERSION_BREAKPOINTS <- list("10.0" = list(version_txt = "v10.0",
|
||||
year = 2020,
|
||||
title = "EUCAST Clinical Breakpoints"))
|
||||
title = "'EUCAST Clinical Breakpoints'",
|
||||
url = "https://www.eucast.org/clinical_breakpoints/"))
|
||||
EUCAST_VERSION_EXPERT_RULES <- list("3.1" = list(version_txt = "v3.1",
|
||||
year = 2016,
|
||||
title = "EUCAST Expert Rules, Intrinsic Resistance and Exceptional Phenotypes"),
|
||||
title = "'EUCAST Expert Rules, Intrinsic Resistance and Exceptional Phenotypes'",
|
||||
url = "https://www.eucast.org/expert_rules_and_intrinsic_resistance/"),
|
||||
"3.2" = list(version_txt = "v3.2",
|
||||
year = 2020,
|
||||
title = "EUCAST Expert Rules / EUCAST Intrinsic Resistance and Unusual Phenotypes"))
|
||||
title = "'EUCAST Expert Rules' and 'EUCAST Intrinsic Resistance and Unusual Phenotypes'",
|
||||
url = "https://www.eucast.org/expert_rules_and_intrinsic_resistance/"))
|
||||
|
||||
format_eucast_version_nr <- function(version, markdown = TRUE) {
|
||||
# for documentation - adds title, version number, year and url in markdown language
|
||||
lst <- c(EUCAST_VERSION_BREAKPOINTS, EUCAST_VERSION_EXPERT_RULES)
|
||||
version <- format(version, nsmall = 1)
|
||||
if (markdown == TRUE) {
|
||||
paste0("[", lst[[version]]$title, " ", lst[[version]]$version_txt, "](", lst[[version]]$url, ")",
|
||||
" from ", lst[[version]]$year)
|
||||
} else {
|
||||
paste0(lst[[version]]$title, " ", lst[[version]]$version_txt,
|
||||
" from ", lst[[version]]$year)
|
||||
}
|
||||
}
|
||||
|
||||
#' Apply EUCAST rules
|
||||
#'
|
||||
@@ -134,6 +150,13 @@ eucast_rules <- function(x,
|
||||
version_breakpoints = 10.0,
|
||||
version_expertrules = 3.2,
|
||||
...) {
|
||||
meet_criteria(x, allow_class = "data.frame")
|
||||
meet_criteria(col_mo, allow_class = "character", has_length = 1, is_in = colnames(x), allow_NULL = TRUE)
|
||||
meet_criteria(info, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(rules, allow_class = "character", has_length = c(1, 2, 3, 4), is_in = c("breakpoints", "expert", "other", "all"))
|
||||
meet_criteria(verbose, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(version_breakpoints, allow_class = "numeric", has_length = 1)
|
||||
meet_criteria(version_expertrules, allow_class = "numeric", has_length = 1)
|
||||
|
||||
x_deparsed <- deparse(substitute(x))
|
||||
if (length(x_deparsed) > 1 || !all(x_deparsed %like% "[a-z]+")) {
|
||||
@@ -167,23 +190,17 @@ eucast_rules <- function(x,
|
||||
q_continue <- utils::menu(choices = c("OK", "Cancel"), graphics = FALSE, title = txt)
|
||||
}
|
||||
if (q_continue %in% c(FALSE, 2)) {
|
||||
message("Cancelled, returning original data")
|
||||
message_("Cancelled, returning original data", add_fn = font_red, as_note = FALSE)
|
||||
return(x)
|
||||
}
|
||||
}
|
||||
|
||||
stop_ifnot(is.data.frame(x), "`x` must be a data frame")
|
||||
|
||||
# try to find columns based on type
|
||||
# -- mo
|
||||
if (is.null(col_mo)) {
|
||||
col_mo <- search_type_in_df(x = x, type = "mo", info = info)
|
||||
}
|
||||
stop_if(is.null(col_mo), "`col_mo` must be set")
|
||||
stop_ifnot(col_mo %in% colnames(x), "column '", col_mo, "' (`col_mo`) not found")
|
||||
|
||||
stop_ifnot(all(rules %in% c("breakpoints", "expert", "other", "all")),
|
||||
'`rules` must be one or more of: "breakpoints", "expert", "other", "all".')
|
||||
|
||||
decimal.mark <- getOption("OutDec")
|
||||
big.mark <- ifelse(decimal.mark != ",", ",", ".")
|
||||
@@ -442,14 +459,14 @@ eucast_rules <- function(x,
|
||||
if (ab_missing(AMP) & !ab_missing(AMX)) {
|
||||
# ampicillin column is missing, but amoxicillin is available
|
||||
if (info == TRUE) {
|
||||
message(font_blue(paste0("NOTE: Using column `", font_bold(AMX), "` as input for ampicillin since many EUCAST rules depend on it.")))
|
||||
message_("Using column '", font_bold(AMX), "' as input for ampicillin since many EUCAST rules depend on it.")
|
||||
}
|
||||
AMP <- AMX
|
||||
}
|
||||
|
||||
# data preparation ----
|
||||
if (info == TRUE & NROW(x) > 10000) {
|
||||
message(font_blue("NOTE: Preparing data..."), appendLF = FALSE)
|
||||
message_("Preparing data...", appendLF = FALSE, as_note = FALSE)
|
||||
}
|
||||
|
||||
# nolint start
|
||||
@@ -522,7 +539,9 @@ eucast_rules <- function(x,
|
||||
x <- paste(paste0(ab_names, collapse = " and "), "are both")
|
||||
} else {
|
||||
# like PEN,FOX,GEN S (although dependency on > 2 ABx does not exist at the moment)
|
||||
x <- paste(paste0(ab_names, collapse = " and "), "are all")
|
||||
# nolint start
|
||||
# x <- paste(paste0(ab_names, collapse = " and "), "are all")
|
||||
# nolint end
|
||||
}
|
||||
return(paste0(x, " '", ab_results, "'"))
|
||||
} else {
|
||||
@@ -563,10 +582,12 @@ eucast_rules <- function(x,
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE) # no tibbles, data.tables, etc.
|
||||
rownames(x) <- NULL # will later be restored with old_attributes
|
||||
# create unique row IDs - combination of the MO and all ABx columns (so they will only run once per unique combination)
|
||||
x$`.rowid` <- sapply(as.list(as.data.frame(t(x[, c(col_mo, cols_ab), drop = FALSE]))), function(x) {
|
||||
x[is.na(x)] <- "."
|
||||
paste0(x, collapse = "")
|
||||
})
|
||||
x$`.rowid` <- sapply(as.list(as.data.frame(t(x[, c(col_mo, cols_ab), drop = FALSE]),
|
||||
stringsAsFactors = FALSE)),
|
||||
function(x) {
|
||||
x[is.na(x)] <- "."
|
||||
paste0(x, collapse = "")
|
||||
})
|
||||
|
||||
# save original table, with the new .rowid column
|
||||
x.bak <- x
|
||||
@@ -576,13 +597,13 @@ eucast_rules <- function(x,
|
||||
# big speed gain! only analyse unique rows:
|
||||
pm_distinct(`.rowid`, .keep_all = TRUE) %pm>%
|
||||
as.data.frame(stringsAsFactors = FALSE)
|
||||
x[, col_mo] <- as.mo(x[, col_mo, drop = TRUE])
|
||||
x[, col_mo] <- as.mo(as.character(x[, col_mo, drop = TRUE]))
|
||||
x <- x %pm>%
|
||||
left_join_microorganisms(by = col_mo, suffix = c("_oldcols", ""))
|
||||
x$gramstain <- mo_gramstain(x[, col_mo, drop = TRUE], language = NULL)
|
||||
x$genus_species <- paste(x$genus, x$species)
|
||||
if (info == TRUE & NROW(x) > 10000) {
|
||||
message(font_blue("OK."))
|
||||
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
|
||||
}
|
||||
|
||||
if (any(x$genus == "Staphylococcus", na.rm = TRUE)) {
|
||||
@@ -600,9 +621,11 @@ eucast_rules <- function(x,
|
||||
# Other rules: enzyme inhibitors ------------------------------------------
|
||||
if (any(c("all", "other") %in% rules)) {
|
||||
if (info == TRUE) {
|
||||
cat(font_bold(paste0("\nRules by this AMR package (",
|
||||
font_red(paste0("v", utils::packageVersion("AMR"), ", ",
|
||||
format(utils::packageDate("AMR"), "%Y"))), "), see ?eucast_rules\n")))
|
||||
cat("\n")
|
||||
cat(word_wrap(
|
||||
font_bold(paste0("Rules by this AMR package (",
|
||||
font_red(paste0("v", utils::packageDescription("AMR")$Version, ", ",
|
||||
format(as.Date(utils::packageDescription("AMR")$Date), format = "%Y"))), "), see ?eucast_rules\n"))))
|
||||
}
|
||||
|
||||
ab_enzyme <- subset(antibiotics, name %like% "/")[, c("ab", "name")]
|
||||
@@ -613,14 +636,18 @@ eucast_rules <- function(x,
|
||||
ab_name_base <- ab_name(cols_ab[ab_enzyme[i, ]$base_ab], language = NULL, tolower = TRUE)
|
||||
ab_name_enzyme <- ab_name(cols_ab[ab_enzyme[i, ]$ab], language = NULL, tolower = TRUE)
|
||||
|
||||
# Set base to R where base + enzyme inhibitor is R
|
||||
# Set base to R where base + enzyme inhibitor is R ----
|
||||
rule_current <- paste0("Set ", ab_name_base, " (", cols_ab[ab_enzyme[i, ]$base_ab], ") = R where ",
|
||||
ab_name_enzyme, " (", cols_ab[ab_enzyme[i, ]$ab], ") = R")
|
||||
cat(rule_current)
|
||||
if (info == TRUE) {
|
||||
cat(word_wrap(rule_current))
|
||||
cat("\n")
|
||||
}
|
||||
run_changes <- edit_rsi(x = x,
|
||||
col_mo = col_mo,
|
||||
to = "R",
|
||||
rule = c(rule_current, "Other rules", "", paste0("Non-EUCAST: AMR package v", utils::packageVersion("AMR"))),
|
||||
rule = c(rule_current, "Other rules", "",
|
||||
paste0("Non-EUCAST: AMR package v", utils::packageDescription("AMR")$Version)),
|
||||
rows = which(as.rsi_no_warning(x[, cols_ab[ab_enzyme[i, ]$ab]]) == "R"),
|
||||
cols = cols_ab[ab_enzyme[i, ]$base_ab],
|
||||
last_verbose_info = verbose_info,
|
||||
@@ -641,16 +668,18 @@ eucast_rules <- function(x,
|
||||
n_changed <- 0
|
||||
}
|
||||
|
||||
# Set base + enzyme inhibitor to S where base is S
|
||||
# Set base + enzyme inhibitor to S where base is S ----
|
||||
rule_current <- paste0("Set ", ab_name_enzyme, " (", cols_ab[ab_enzyme[i, ]$ab], ") = S where ",
|
||||
ab_name_base, " (", cols_ab[ab_enzyme[i, ]$base_ab], ") = S")
|
||||
if (info == TRUE) {
|
||||
cat(rule_current)
|
||||
cat(word_wrap(rule_current))
|
||||
cat("\n")
|
||||
}
|
||||
run_changes <- edit_rsi(x = x,
|
||||
col_mo = col_mo,
|
||||
to = "S",
|
||||
rule = c(rule_current, "Other rules", "", paste0("Non-EUCAST: AMR package v", utils::packageVersion("AMR"))),
|
||||
rule = c(rule_current, "Other rules", "",
|
||||
paste0("Non-EUCAST: AMR package v", utils::packageDescription("AMR")$Version)),
|
||||
rows = which(as.rsi_no_warning(x[, cols_ab[ab_enzyme[i, ]$base_ab]]) == "S"),
|
||||
cols = cols_ab[ab_enzyme[i, ]$ab],
|
||||
last_verbose_info = verbose_info,
|
||||
@@ -675,7 +704,12 @@ eucast_rules <- function(x,
|
||||
|
||||
} else {
|
||||
if (info == TRUE) {
|
||||
cat(font_red("\nSkipping inheritance rules defined by this package, such as setting trimethoprim (TMP) = R where trimethoprim/sulfamethoxazole (SXT) = R.\nUse eucast_rules(..., rules = \"all\") to also apply those rules.\n"))
|
||||
message_("\n\nSkipping inheritance rules defined by this package, such as setting trimethoprim (TMP) = R where trimethoprim/sulfamethoxazole (SXT) = R.",
|
||||
as_note = FALSE,
|
||||
add_fn = font_red)
|
||||
message_("Use eucast_rules(..., rules = \"all\") to also apply those rules.",
|
||||
as_note = FALSE,
|
||||
add_fn = font_red)
|
||||
}
|
||||
}
|
||||
|
||||
@@ -739,9 +773,10 @@ eucast_rules <- function(x,
|
||||
if (info == TRUE) {
|
||||
# Print EUCAST intro ------------------------------------------------------
|
||||
if (!rule_group_current %like% "other" & eucast_notification_shown == FALSE) {
|
||||
cat(paste0("\n", font_grey(strrep("-", 0.95 * options()$width)),
|
||||
"\nRules by the ", font_bold("European Committee on Antimicrobial Susceptibility Testing (EUCAST)"),
|
||||
"\n", font_blue("https://eucast.org/"), "\n"))
|
||||
cat(
|
||||
paste0("\n", font_grey(strrep("-", 0.95 * options()$width)), "\n",
|
||||
word_wrap("Rules by the ", font_bold("European Committee on Antimicrobial Susceptibility Testing (EUCAST)")), "\n",
|
||||
font_blue("https://eucast.org/"), "\n"))
|
||||
eucast_notification_shown <- TRUE
|
||||
}
|
||||
|
||||
@@ -751,18 +786,24 @@ eucast_rules <- function(x,
|
||||
cat(font_bold(
|
||||
ifelse(
|
||||
rule_group_current %like% "breakpoint",
|
||||
paste0("\n", breakpoints_info$title, " (",
|
||||
font_red(paste0(breakpoints_info$version_txt, ", ", breakpoints_info$year)), ")\n"),
|
||||
paste0("\n",
|
||||
word_wrap(
|
||||
breakpoints_info$title, " (",
|
||||
font_red(paste0(breakpoints_info$version_txt, ", ", breakpoints_info$year)), ")\n")),
|
||||
ifelse(
|
||||
rule_group_current %like% "expert",
|
||||
paste0("\n", expertrules_info$title, " (",
|
||||
font_red(paste0(expertrules_info$version_txt, ", ", expertrules_info$year)), ")\n"),
|
||||
paste0("\n",
|
||||
word_wrap(
|
||||
expertrules_info$title, " (",
|
||||
font_red(paste0(expertrules_info$version_txt, ", ", expertrules_info$year)), ")\n")),
|
||||
""))))
|
||||
}
|
||||
# Print rule -------------------------------------------------------------
|
||||
if (rule_current != rule_previous) {
|
||||
# is new rule within group, print its name
|
||||
cat(markup_italics_where_needed(rule_current))
|
||||
cat(markup_italics_where_needed(word_wrap(rule_current,
|
||||
width = getOption("width") - 30,
|
||||
extra_indent = 4)))
|
||||
warned <- FALSE
|
||||
}
|
||||
}
|
||||
@@ -772,7 +813,7 @@ eucast_rules <- function(x,
|
||||
like_is_one_of <- trimws(eucast_rules_df[i, "like.is.one_of", drop = TRUE])
|
||||
mo_value <- trimws(eucast_rules_df[i, "this_value", drop = TRUE])
|
||||
|
||||
# be sure to comprise all coagulase-negative/-positive Staphylococci when they are mentioned
|
||||
# be sure to comprise all coagulase-negative/-positive staphylococci when they are mentioned
|
||||
if (mo_value %like% "coagulase" && any(x$genus == "Staphylococcus", na.rm = TRUE)) {
|
||||
if (mo_value %like% "negative") {
|
||||
eucast_rules_df[i, "this_value"] <- paste0("^(", paste0(all_staph[which(all_staph$CNS_CPS %like% "negative"),
|
||||
@@ -836,14 +877,16 @@ eucast_rules <- function(x,
|
||||
& as.rsi_no_warning(x[, source_antibiotics[1L]]) == source_value[1L]
|
||||
& as.rsi_no_warning(x[, source_antibiotics[2L]]) == source_value[2L]),
|
||||
error = function(e) integer(0))
|
||||
} else if (length(source_antibiotics) == 3) {
|
||||
rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like_perl% mo_value
|
||||
& as.rsi_no_warning(x[, source_antibiotics[1L]]) == source_value[1L]
|
||||
& as.rsi_no_warning(x[, source_antibiotics[2L]]) == source_value[2L]
|
||||
& as.rsi_no_warning(x[, source_antibiotics[3L]]) == source_value[3L]),
|
||||
error = function(e) integer(0))
|
||||
# nolint start
|
||||
# } else if (length(source_antibiotics) == 3) {
|
||||
# rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like_perl% mo_value
|
||||
# & as.rsi_no_warning(x[, source_antibiotics[1L]]) == source_value[1L]
|
||||
# & as.rsi_no_warning(x[, source_antibiotics[2L]]) == source_value[2L]
|
||||
# & as.rsi_no_warning(x[, source_antibiotics[3L]]) == source_value[3L]),
|
||||
# error = function(e) integer(0))
|
||||
# nolint end
|
||||
} else {
|
||||
stop_("only 3 antibiotics supported for source_antibiotics")
|
||||
stop_("only 2 antibiotics supported for source_antibiotics")
|
||||
}
|
||||
}
|
||||
|
||||
@@ -902,12 +945,12 @@ eucast_rules <- function(x,
|
||||
}
|
||||
|
||||
cat(paste0("\n", font_grey(strrep("-", 0.95 * options()$width)), "\n"))
|
||||
cat(paste0("The rules ", paste0(wouldve, "affected "),
|
||||
font_bold(formatnr(pm_n_distinct(verbose_info$row)),
|
||||
"out of", formatnr(nrow(x.bak)),
|
||||
"rows"),
|
||||
", making a total of ",
|
||||
font_bold(formatnr(nrow(verbose_info)), "edits\n")))
|
||||
cat(word_wrap(paste0("The rules ", paste0(wouldve, "affected "),
|
||||
font_bold(formatnr(pm_n_distinct(verbose_info$row)),
|
||||
"out of", formatnr(nrow(x.bak)),
|
||||
"rows"),
|
||||
", making a total of ",
|
||||
font_bold(formatnr(nrow(verbose_info)), "edits\n"))))
|
||||
|
||||
total_n_added <- verbose_info %pm>% pm_filter(is.na(old)) %pm>% nrow()
|
||||
total_n_changed <- verbose_info %pm>% pm_filter(!is.na(old)) %pm>% nrow()
|
||||
@@ -959,21 +1002,21 @@ eucast_rules <- function(x,
|
||||
cat(paste0(font_grey(strrep("-", 0.95 * options()$width)), "\n"))
|
||||
|
||||
if (verbose == FALSE & total_n_added + total_n_changed > 0) {
|
||||
cat(paste("\nUse", font_bold("eucast_rules(..., verbose = TRUE)"), "(on your original data) to get a data.frame with all specified edits instead.\n\n"))
|
||||
cat("\n", word_wrap("Use ", font_bold("eucast_rules(..., verbose = TRUE)"), " (on your original data) to get a data.frame with all specified edits instead."), "\n\n", sep = "")
|
||||
} else if (verbose == TRUE) {
|
||||
cat(paste0("\nUsed 'Verbose mode' (", font_bold("verbose = TRUE"), "), which returns a data.frame with all specified edits.\nUse ", font_bold("verbose = FALSE"), " to apply the rules on your data.\n\n"))
|
||||
cat("\n", word_wrap("Used 'Verbose mode' (", font_bold("verbose = TRUE"), "), which returns a data.frame with all specified edits.\nUse ", font_bold("verbose = FALSE"), " to apply the rules on your data."), "\n\n", sep = "")
|
||||
}
|
||||
}
|
||||
|
||||
if (length(warn_lacking_rsi_class) > 0) {
|
||||
warn_lacking_rsi_class <- unique(warn_lacking_rsi_class)
|
||||
warning("Not all columns with antimicrobial results are of class <rsi>. Transform them on beforehand, with e.g.:\n",
|
||||
" ", x_deparsed, " %>% mutate_if(is.rsi.eligible, as.rsi)\n",
|
||||
" ", x_deparsed, " %>% as.rsi(", ifelse(length(warn_lacking_rsi_class) == 1,
|
||||
warn_lacking_rsi_class,
|
||||
paste0(warn_lacking_rsi_class[1], ":", warn_lacking_rsi_class[length(warn_lacking_rsi_class)])),
|
||||
")",
|
||||
call. = FALSE)
|
||||
warning_("Not all columns with antimicrobial results are of class <rsi>. Transform them on beforehand, with e.g.:\n",
|
||||
" ", x_deparsed, " %>% mutate_if(is.rsi.eligible, as.rsi)\n",
|
||||
" ", x_deparsed, " %>% as.rsi(", ifelse(length(warn_lacking_rsi_class) == 1,
|
||||
warn_lacking_rsi_class,
|
||||
paste0(warn_lacking_rsi_class[1], ":", warn_lacking_rsi_class[length(warn_lacking_rsi_class)])),
|
||||
")",
|
||||
call = FALSE)
|
||||
}
|
||||
|
||||
# Return data set ---------------------------------------------------------
|
||||
@@ -1033,16 +1076,16 @@ edit_rsi <- function(x,
|
||||
warning = function(w) {
|
||||
if (w$message %like% "invalid factor level") {
|
||||
xyz <- sapply(cols, function(col) {
|
||||
new_edits[, col] <- factor(x = as.character(pm_pull(new_edits, col)), levels = c(to, levels(pm_pull(new_edits, col))))
|
||||
# x[, col] <<- factor(x = as.character(pm_pull(x, col)), levels = c(to, levels(pm_pull(x, col))))
|
||||
new_edits[, col] <<- factor(x = as.character(pm_pull(new_edits, col)),
|
||||
levels = unique(c(to, levels(pm_pull(new_edits, col)))))
|
||||
invisible()
|
||||
})
|
||||
new_edits[rows, cols] <- to
|
||||
warning('Value "', to, '" added to the factor levels of column(s) `', paste(cols, collapse = "`, `"), "` because this value was not an existing factor level.\nA better way is to use as.rsi() on beforehand on antimicrobial columns to guarantee the right structure.", call. = FALSE)
|
||||
suppressWarnings(new_edits[rows, cols] <<- to)
|
||||
warning_('Value "', to, '" added to the factor levels of column(s) `', paste(cols, collapse = "`, `"), "` because this value was not an existing factor level. A better way is to use as.rsi() on beforehand on antimicrobial columns to guarantee the right structure.", call = FALSE)
|
||||
txt_warning()
|
||||
warned <- FALSE
|
||||
} else {
|
||||
warning(w$message, call. = FALSE)
|
||||
warning_(w$message, call = FALSE)
|
||||
txt_warning()
|
||||
cat("\n") # txt_warning() does not append a "\n" on itself
|
||||
}
|
||||
@@ -1078,7 +1121,9 @@ edit_rsi <- function(x,
|
||||
"rule", "rule_group", "rule_name", "rule_source")
|
||||
verbose_new <- verbose_new %pm>% pm_filter(old != new | is.na(old))
|
||||
# save changes to data set 'verbose_info'
|
||||
track_changes$verbose_info <- rbind(track_changes$verbose_info, verbose_new)
|
||||
track_changes$verbose_info <- rbind(track_changes$verbose_info,
|
||||
verbose_new,
|
||||
stringsAsFactors = FALSE)
|
||||
# count adds and changes
|
||||
track_changes$added <- track_changes$added + verbose_new %pm>%
|
||||
pm_filter(is.na(old)) %pm>%
|
||||
|
||||
+34
-15
@@ -80,16 +80,22 @@ filter_ab_class <- function(x,
|
||||
result = NULL,
|
||||
scope = "any",
|
||||
...) {
|
||||
|
||||
.call_depth <- list(...)$`.call_depth`
|
||||
if (is.null(.call_depth)) {
|
||||
.call_depth <- 0
|
||||
}
|
||||
meet_criteria(x, allow_class = "data.frame", .call_depth = .call_depth)
|
||||
meet_criteria(ab_class, allow_class = "character", has_length = 1, .call_depth = .call_depth)
|
||||
meet_criteria(result, allow_class = "character", has_length = c(1, 2, 3), allow_NULL = TRUE, .call_depth = .call_depth)
|
||||
meet_criteria(scope, allow_class = "character", has_length = 1, is_in = c("all", "any"), .call_depth = .call_depth)
|
||||
|
||||
check_dataset_integrity()
|
||||
stop_ifnot(is.data.frame(x), "`x` must be a data frame")
|
||||
|
||||
|
||||
# save to return later
|
||||
x_class <- class(x)
|
||||
x.bak <- x
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||
|
||||
scope <- scope[1L]
|
||||
if (is.null(result)) {
|
||||
result <- c("S", "I", "R")
|
||||
}
|
||||
@@ -102,7 +108,7 @@ filter_ab_class <- function(x,
|
||||
# get all columns in data with names that resemble antibiotics
|
||||
ab_in_data <- get_column_abx(x, info = FALSE)
|
||||
if (length(ab_in_data) == 0) {
|
||||
message(font_blue("NOTE: no columns with class <rsi> found (see ?as.rsi), data left unchanged."))
|
||||
message_("No columns with class <rsi> found (see ?as.rsi), data left unchanged.")
|
||||
return(x.bak)
|
||||
}
|
||||
# get reference data
|
||||
@@ -116,15 +122,15 @@ filter_ab_class <- function(x,
|
||||
atc_group2 %like% ab_class)
|
||||
ab_group <- find_ab_group(ab_class)
|
||||
if (ab_group == "") {
|
||||
message(font_blue(paste0("NOTE: unknown antimicrobial class '", ab_class.bak, "', data left unchanged.")))
|
||||
message_("Unknown antimicrobial class '", ab_class.bak, "', data left unchanged.")
|
||||
return(x.bak)
|
||||
}
|
||||
# get the columns with a group names in the chosen ab class
|
||||
agents <- ab_in_data[names(ab_in_data) %in% ab_reference$ab]
|
||||
if (length(agents) == 0) {
|
||||
message(font_blue(paste0("NOTE: no antimicrobial agents of class ", ab_group,
|
||||
" found (such as ", find_ab_names(ab_class, 2),
|
||||
"), data left unchanged.")))
|
||||
message_("NOTE: no antimicrobial agents of class ", ab_group,
|
||||
" found (such as ", find_ab_names(ab_class, 2),
|
||||
"), data left unchanged.")
|
||||
return(x.bak)
|
||||
}
|
||||
|
||||
@@ -152,12 +158,12 @@ filter_ab_class <- function(x,
|
||||
# sort columns on official name
|
||||
agents <- agents[order(ab_name(names(agents), language = NULL))]
|
||||
|
||||
message(font_blue(paste0("Filtering on ", ab_group, ": ", scope,
|
||||
paste(paste0("`", font_bold(agents, collapse = NULL),
|
||||
"` (", ab_name(names(agents), tolower = TRUE, language = NULL), ")"),
|
||||
collapse = scope_txt),
|
||||
operator, toString(result))))
|
||||
x_transposed <- as.list(as.data.frame(t(x[, agents, drop = FALSE])))
|
||||
message_("Filtering on ", ab_group, ": ", scope,
|
||||
paste(paste0("`", font_bold(agents, collapse = NULL),
|
||||
"` (", ab_name(names(agents), tolower = TRUE, language = NULL), ")"),
|
||||
collapse = scope_txt),
|
||||
operator, toString(result), as_note = FALSE)
|
||||
x_transposed <- as.list(as.data.frame(t(x[, agents, drop = FALSE]), stringsAsFactors = FALSE))
|
||||
filtered <- sapply(x_transposed, function(y) scope_fn(y %in% result, na.rm = TRUE))
|
||||
x <- x[which(filtered), , drop = FALSE]
|
||||
class(x) <- x_class
|
||||
@@ -174,6 +180,7 @@ filter_aminoglycosides <- function(x,
|
||||
ab_class = "aminoglycoside",
|
||||
result = result,
|
||||
scope = scope,
|
||||
.call_depth = 1,
|
||||
...)
|
||||
}
|
||||
|
||||
@@ -187,6 +194,7 @@ filter_carbapenems <- function(x,
|
||||
ab_class = "carbapenem",
|
||||
result = result,
|
||||
scope = scope,
|
||||
.call_depth = 1,
|
||||
...)
|
||||
}
|
||||
|
||||
@@ -200,6 +208,7 @@ filter_cephalosporins <- function(x,
|
||||
ab_class = "cephalosporin",
|
||||
result = result,
|
||||
scope = scope,
|
||||
.call_depth = 1,
|
||||
...)
|
||||
}
|
||||
|
||||
@@ -213,6 +222,7 @@ filter_1st_cephalosporins <- function(x,
|
||||
ab_class = "cephalosporins (1st gen.)",
|
||||
result = result,
|
||||
scope = scope,
|
||||
.call_depth = 1,
|
||||
...)
|
||||
}
|
||||
|
||||
@@ -226,6 +236,7 @@ filter_2nd_cephalosporins <- function(x,
|
||||
ab_class = "cephalosporins (2nd gen.)",
|
||||
result = result,
|
||||
scope = scope,
|
||||
.call_depth = 1,
|
||||
...)
|
||||
}
|
||||
|
||||
@@ -239,6 +250,7 @@ filter_3rd_cephalosporins <- function(x,
|
||||
ab_class = "cephalosporins (3rd gen.)",
|
||||
result = result,
|
||||
scope = scope,
|
||||
.call_depth = 1,
|
||||
...)
|
||||
}
|
||||
|
||||
@@ -252,6 +264,7 @@ filter_4th_cephalosporins <- function(x,
|
||||
ab_class = "cephalosporins (4th gen.)",
|
||||
result = result,
|
||||
scope = scope,
|
||||
.call_depth = 1,
|
||||
...)
|
||||
}
|
||||
|
||||
@@ -265,6 +278,7 @@ filter_5th_cephalosporins <- function(x,
|
||||
ab_class = "cephalosporins (5th gen.)",
|
||||
result = result,
|
||||
scope = scope,
|
||||
.call_depth = 1,
|
||||
...)
|
||||
}
|
||||
|
||||
@@ -278,6 +292,7 @@ filter_fluoroquinolones <- function(x,
|
||||
ab_class = "fluoroquinolone",
|
||||
result = result,
|
||||
scope = scope,
|
||||
.call_depth = 1,
|
||||
...)
|
||||
}
|
||||
|
||||
@@ -291,6 +306,7 @@ filter_glycopeptides <- function(x,
|
||||
ab_class = "glycopeptide",
|
||||
result = result,
|
||||
scope = scope,
|
||||
.call_depth = 1,
|
||||
...)
|
||||
}
|
||||
|
||||
@@ -304,6 +320,7 @@ filter_macrolides <- function(x,
|
||||
ab_class = "macrolide",
|
||||
result = result,
|
||||
scope = scope,
|
||||
.call_depth = 1,
|
||||
...)
|
||||
}
|
||||
|
||||
@@ -317,6 +334,7 @@ filter_penicillins <- function(x,
|
||||
ab_class = "penicillin",
|
||||
result = result,
|
||||
scope = scope,
|
||||
.call_depth = 1,
|
||||
...)
|
||||
}
|
||||
|
||||
@@ -330,6 +348,7 @@ filter_tetracyclines <- function(x,
|
||||
ab_class = "tetracycline",
|
||||
result = result,
|
||||
scope = scope,
|
||||
.call_depth = 1,
|
||||
...)
|
||||
}
|
||||
|
||||
|
||||
+130
-82
@@ -25,13 +25,13 @@
|
||||
|
||||
#' Determine first (weighted) isolates
|
||||
#'
|
||||
#' Determine first (weighted) isolates of all microorganisms of every patient per episode and (if needed) per specimen type.
|
||||
#' Determine first (weighted) isolates of all microorganisms of every patient per episode and (if needed) per specimen type. To determine patient episodes not necessarily based on microorganisms, use [is_new_episode()] that also supports grouping with the `dplyr` package.
|
||||
#' @inheritSection lifecycle Stable lifecycle
|
||||
#' @param x a [data.frame] containing isolates.
|
||||
#' @param col_date column name of the result date (or date that is was received on the lab), defaults to the first column of with a date class
|
||||
#' @param x a [data.frame] containing isolates. Can be omitted when used inside `dplyr` verbs, such as [`filter()`][dplyr::filter()], [`mutate()`][dplyr::mutate()] and [`summarise()`][dplyr::summarise()].
|
||||
#' @param col_date column name of the result date (or date that is was received on the lab), defaults to the first column with a date class
|
||||
#' @param col_patient_id column name of the unique IDs of the patients, defaults to the first column that starts with 'patient' or 'patid' (case insensitive)
|
||||
#' @param col_mo column name of the IDs of the microorganisms (see [as.mo()]), defaults to the first column of class [`mo`]. Values will be coerced using [as.mo()].
|
||||
#' @param col_testcode column name of the test codes. Use `col_testcode = NULL` to **not** exclude certain test codes (like test codes for screening). In that case `testcodes_exclude` will be ignored.
|
||||
#' @param col_testcode column name of the test codes. Use `col_testcode = NULL` to **not** exclude certain test codes (such as test codes for screening). In that case `testcodes_exclude` will be ignored.
|
||||
#' @param col_specimen column name of the specimen type or group
|
||||
#' @param col_icu column name of the logicals (`TRUE`/`FALSE`) whether a ward or department is an Intensive Care Unit (ICU)
|
||||
#' @param col_keyantibiotics column name of the key antibiotics to determine first *weighted* isolates, see [key_antibiotics()]. Defaults to the first column that starts with 'key' followed by 'ab' or 'antibiotics' (case insensitive). Use `col_keyantibiotics = FALSE` to prevent this.
|
||||
@@ -44,18 +44,31 @@
|
||||
#' @param points_threshold points until the comparison of key antibiotics will lead to inclusion of an isolate when `type = "points"`, see Details
|
||||
#' @param info print progress
|
||||
#' @param include_unknown logical to determine whether 'unknown' microorganisms should be included too, i.e. microbial code `"UNKNOWN"`, which defaults to `FALSE`. For WHONET users, this means that all records with organism code `"con"` (*contamination*) will be excluded at default. Isolates with a microbial ID of `NA` will always be excluded as first isolate.
|
||||
#' @param ... parameters passed on to the [first_isolate()] function
|
||||
#' @details **WHY THIS IS SO IMPORTANT** \cr
|
||||
#' To conduct an analysis of antimicrobial resistance, you should only include the first isolate of every patient per episode [(ref)](https:/pubmed.ncbi.nlm.nih.gov/17304462/). If you would not do this, you could easily get an overestimate or underestimate of the resistance of an antibiotic. Imagine that a patient was admitted with an MRSA and that it was found in 5 different blood cultures the following week. The resistance percentage of oxacillin of all *S. aureus* isolates would be overestimated, because you included this MRSA more than once. It would be [selection bias](https://en.wikipedia.org/wiki/Selection_bias).
|
||||
#'
|
||||
#' @param ... parameters passed on to [first_isolate()] when using [filter_first_isolate()], or parameters passed on to [key_antibiotics()] when using [filter_first_weighted_isolate()]
|
||||
#' @details
|
||||
#' These functions are context-aware when used inside `dplyr` verbs, such as `filter()`, `mutate()` and `summarise()`. This means that then the `x` parameter can be omitted, please see *Examples*.
|
||||
#'
|
||||
#' The [first_isolate()] function is a wrapper around the [is_new_episode()] function, but more efficient for data sets containing microorganism codes or names.
|
||||
#'
|
||||
#' All isolates with a microbial ID of `NA` will be excluded as first isolate.
|
||||
#'
|
||||
#' ### Why this is so important
|
||||
#' To conduct an analysis of antimicrobial resistance, you should only include the first isolate of every patient per episode [(Hindler *et al.* 2007)](https://pubmed.ncbi.nlm.nih.gov/17304462/). If you would not do this, you could easily get an overestimate or underestimate of the resistance of an antibiotic. Imagine that a patient was admitted with an MRSA and that it was found in 5 different blood cultures the following week. The resistance percentage of oxacillin of all *S. aureus* isolates would be overestimated, because you included this MRSA more than once. It would be [selection bias](https://en.wikipedia.org/wiki/Selection_bias).
|
||||
#'
|
||||
#' The functions [filter_first_isolate()] and [filter_first_weighted_isolate()] are helper functions to quickly filter on first isolates. The function [filter_first_isolate()] is essentially equal to either:
|
||||
#' ### `filter_*()` shortcuts
|
||||
#'
|
||||
#' The functions [filter_first_isolate()] and [filter_first_weighted_isolate()] are helper functions to quickly filter on first isolates.
|
||||
#'
|
||||
#' The function [filter_first_isolate()] is essentially equal to either:
|
||||
#'
|
||||
#' ```
|
||||
#' x[first_isolate(x, ...), ]
|
||||
#' x %>% filter(first_isolate(x, ...))
|
||||
#'
|
||||
#' x %>% filter(first_isolate(...))
|
||||
#' ```
|
||||
#'
|
||||
#' The function [filter_first_weighted_isolate()] is essentially equal to:
|
||||
#'
|
||||
#' ```
|
||||
#' x %>%
|
||||
#' mutate(keyab = key_antibiotics(.)) %>%
|
||||
@@ -89,21 +102,24 @@
|
||||
#' # basic filtering on first isolates
|
||||
#' example_isolates[first_isolate(example_isolates), ]
|
||||
#'
|
||||
#' # filtering based on isolates ----------------------------------------------
|
||||
#' \donttest{
|
||||
#' if (require("dplyr")) {
|
||||
#' # Filter on first isolates:
|
||||
#' # filter on first isolates:
|
||||
#' example_isolates %>%
|
||||
#' mutate(first_isolate = first_isolate(.)) %>%
|
||||
#' filter(first_isolate == TRUE)
|
||||
#'
|
||||
#' # Short-hand versions:
|
||||
#' # short-hand versions:
|
||||
#' example_isolates %>%
|
||||
#' filter(first_isolate())
|
||||
#' example_isolates %>%
|
||||
#' filter_first_isolate()
|
||||
#'
|
||||
#' example_isolates %>%
|
||||
#' filter_first_weighted_isolate()
|
||||
#'
|
||||
#' # Now let's see if first isolates matter:
|
||||
#' # now let's see if first isolates matter:
|
||||
#' A <- example_isolates %>%
|
||||
#' group_by(hospital_id) %>%
|
||||
#' summarise(count = n_rsi(GEN), # gentamicin availability
|
||||
@@ -139,6 +155,32 @@ first_isolate <- function(x,
|
||||
info = interactive(),
|
||||
include_unknown = FALSE,
|
||||
...) {
|
||||
if (missing(x)) {
|
||||
x <- get_current_data(arg_name = "x", call = -2)
|
||||
}
|
||||
meet_criteria(x, allow_class = "data.frame") # also checks dimensions to be >0
|
||||
meet_criteria(col_date, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
|
||||
meet_criteria(col_patient_id, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
|
||||
meet_criteria(col_mo, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
|
||||
meet_criteria(col_testcode, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
|
||||
if (isFALSE(col_specimen)) {
|
||||
col_specimen <- NULL
|
||||
}
|
||||
meet_criteria(col_specimen, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
|
||||
meet_criteria(col_icu, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
|
||||
if (isFALSE(col_keyantibiotics)) {
|
||||
col_keyantibiotics <- NULL
|
||||
}
|
||||
meet_criteria(col_keyantibiotics, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
|
||||
meet_criteria(episode_days, allow_class = c("numeric", "integer"), has_length = 1)
|
||||
meet_criteria(testcodes_exclude, allow_class = "character", allow_NULL = TRUE)
|
||||
meet_criteria(icu_exclude, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(specimen_group, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(type, allow_class = "character", has_length = 1)
|
||||
meet_criteria(ignore_I, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(points_threshold, allow_class = c("numeric", "integer"), has_length = 1)
|
||||
meet_criteria(info, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(include_unknown, allow_class = "logical", has_length = 1)
|
||||
|
||||
dots <- unlist(list(...))
|
||||
if (length(dots) != 0) {
|
||||
@@ -152,13 +194,10 @@ first_isolate <- function(x,
|
||||
}
|
||||
}
|
||||
|
||||
stop_ifnot(is.data.frame(x), "`x` must be a data.frame")
|
||||
stop_if(any(dim(x) == 0), "`x` must contain rows and columns")
|
||||
|
||||
# remove data.table, grouping from tibbles, etc.
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||
|
||||
# try to find columns based on type
|
||||
# try to find columns based on type
|
||||
# -- mo
|
||||
if (is.null(col_mo)) {
|
||||
col_mo <- search_type_in_df(x = x, type = "mo")
|
||||
@@ -178,7 +217,7 @@ first_isolate <- function(x,
|
||||
# WHONET support
|
||||
x$patient_id <- paste(x$`First name`, x$`Last name`, x$Sex)
|
||||
col_patient_id <- "patient_id"
|
||||
message(font_blue(paste0("NOTE: Using combined columns `", font_bold("First name"), "`, `", font_bold("Last name"), "` and `", font_bold("Sex"), "` as input for `col_patient_id`")))
|
||||
message_("Using combined columns '", font_bold("First name"), "', '", font_bold("Last name"), "' and '", font_bold("Sex"), "' as input for `col_patient_id`")
|
||||
} else {
|
||||
col_patient_id <- search_type_in_df(x = x, type = "patient_id")
|
||||
}
|
||||
@@ -189,17 +228,11 @@ first_isolate <- function(x,
|
||||
if (is.null(col_keyantibiotics)) {
|
||||
col_keyantibiotics <- search_type_in_df(x = x, type = "keyantibiotics")
|
||||
}
|
||||
if (isFALSE(col_keyantibiotics)) {
|
||||
col_keyantibiotics <- NULL
|
||||
}
|
||||
|
||||
|
||||
# -- specimen
|
||||
if (is.null(col_specimen) & !is.null(specimen_group)) {
|
||||
col_specimen <- search_type_in_df(x = x, type = "specimen")
|
||||
}
|
||||
if (isFALSE(col_specimen)) {
|
||||
col_specimen <- NULL
|
||||
}
|
||||
|
||||
# check if columns exist
|
||||
check_columns_existance <- function(column, tblname = x) {
|
||||
@@ -233,7 +266,9 @@ first_isolate <- function(x,
|
||||
}
|
||||
# remove testcodes
|
||||
if (!is.null(testcodes_exclude) & info == TRUE) {
|
||||
message(font_black(paste0("[Criterion] Exclude test codes: ", toString(paste0("'", testcodes_exclude, "'")))))
|
||||
message_("[Criterion] Exclude test codes: ", toString(paste0("'", testcodes_exclude, "'")),
|
||||
add_fn = font_black,
|
||||
as_note = FALSE)
|
||||
}
|
||||
|
||||
if (is.null(col_specimen)) {
|
||||
@@ -244,7 +279,9 @@ first_isolate <- function(x,
|
||||
if (!is.null(specimen_group)) {
|
||||
check_columns_existance(col_specimen, x)
|
||||
if (info == TRUE) {
|
||||
message(font_black(paste0("[Criterion] Exclude other than specimen group '", specimen_group, "'")))
|
||||
message_("[Criterion] Exclude other than specimen group '", specimen_group, "'",
|
||||
add_fn = font_black,
|
||||
as_note = FALSE)
|
||||
}
|
||||
}
|
||||
if (!is.null(col_keyantibiotics)) {
|
||||
@@ -278,13 +315,32 @@ first_isolate <- function(x,
|
||||
)
|
||||
}
|
||||
|
||||
# no isolates found
|
||||
# speed up - return immediately if obvious
|
||||
if (abs(row.start) == Inf | abs(row.end) == Inf) {
|
||||
if (info == TRUE) {
|
||||
message(paste("=> Found", font_bold("no isolates")))
|
||||
message_("=> Found ", font_bold("no isolates"),
|
||||
add_fn = font_black,
|
||||
as_note = FALSE)
|
||||
}
|
||||
return(rep(FALSE, nrow(x)))
|
||||
}
|
||||
if (row.start == row.end) {
|
||||
if (info == TRUE) {
|
||||
message_("=> Found ", font_bold("1 isolate"), ", as the data only contained 1 row",
|
||||
add_fn = font_black,
|
||||
as_note = FALSE)
|
||||
}
|
||||
return(TRUE)
|
||||
}
|
||||
if (length(c(row.start:row.end)) == pm_n_distinct(x[c(row.start:row.end), col_mo, drop = TRUE])) {
|
||||
if (info == TRUE) {
|
||||
message_("=> Found ", font_bold(paste(length(c(row.start:row.end)), "isolates")),
|
||||
", as all isolates were different microorganisms",
|
||||
add_fn = font_black,
|
||||
as_note = FALSE)
|
||||
}
|
||||
return(rep(TRUE, length(c(row.start:row.end))))
|
||||
}
|
||||
|
||||
# did find some isolates - add new index numbers of rows
|
||||
x$newvar_row_index_sorted <- seq_len(nrow(x))
|
||||
@@ -292,28 +348,6 @@ first_isolate <- function(x,
|
||||
scope.size <- nrow(x[which(x$newvar_row_index_sorted %in% c(row.start + 1:row.end) &
|
||||
!is.na(x$newvar_mo)), , drop = FALSE])
|
||||
|
||||
identify_new_year <- function(x, episode_days) {
|
||||
# I asked on StackOverflow:
|
||||
# https://stackoverflow.com/questions/42122245/filter-one-row-every-year
|
||||
if (length(x) == 1) {
|
||||
return(TRUE)
|
||||
}
|
||||
indices <- integer(0)
|
||||
start <- x[1]
|
||||
ind <- 1
|
||||
indices[ind] <- ind
|
||||
for (i in 2:length(x)) {
|
||||
if (isTRUE(as.numeric(x[i] - start) >= episode_days)) {
|
||||
ind <- ind + 1
|
||||
indices[ind] <- i
|
||||
start <- x[i]
|
||||
}
|
||||
}
|
||||
result <- rep(FALSE, length(x))
|
||||
result[indices] <- TRUE
|
||||
return(result)
|
||||
}
|
||||
|
||||
# Analysis of first isolate ----
|
||||
x$other_pat_or_mo <- ifelse(x$newvar_patient_id == pm_lag(x$newvar_patient_id) &
|
||||
x$newvar_genus_species == pm_lag(x$newvar_genus_species),
|
||||
@@ -324,8 +358,8 @@ first_isolate <- function(x,
|
||||
function(g,
|
||||
df = x,
|
||||
days = episode_days) {
|
||||
identify_new_year(x = df[which(df$episode_group == g), "newvar_date", drop = TRUE],
|
||||
episode_days = days)
|
||||
is_new_episode(x = df[which(df$episode_group == g), ]$newvar_date,
|
||||
episode_days = days)
|
||||
}))
|
||||
|
||||
weighted.notice <- ""
|
||||
@@ -333,13 +367,17 @@ first_isolate <- function(x,
|
||||
weighted.notice <- "weighted "
|
||||
if (info == TRUE) {
|
||||
if (type == "keyantibiotics") {
|
||||
message(font_black(paste0("[Criterion] Base inclusion on key antibiotics, ",
|
||||
ifelse(ignore_I == FALSE, "not ", ""),
|
||||
"ignoring I")))
|
||||
message_("[Criterion] Base inclusion on key antibiotics, ",
|
||||
ifelse(ignore_I == FALSE, "not ", ""),
|
||||
"ignoring I",
|
||||
add_fn = font_black,
|
||||
as_note = FALSE)
|
||||
}
|
||||
if (type == "points") {
|
||||
message(font_black(paste0("[Criterion] Base inclusion on key antibiotics, using points threshold of "
|
||||
, points_threshold)))
|
||||
message_("[Criterion] Base inclusion on key antibiotics, using points threshold of "
|
||||
, points_threshold,
|
||||
add_fn = font_black,
|
||||
as_note = FALSE)
|
||||
}
|
||||
}
|
||||
type_param <- type
|
||||
@@ -352,20 +390,20 @@ first_isolate <- function(x,
|
||||
info = info)
|
||||
# with key antibiotics
|
||||
x$newvar_first_isolate <- pm_if_else(x$newvar_row_index_sorted >= row.start &
|
||||
x$newvar_row_index_sorted <= row.end &
|
||||
x$newvar_genus_species != "" &
|
||||
(x$other_pat_or_mo | x$more_than_episode_ago | x$other_key_ab),
|
||||
TRUE,
|
||||
FALSE)
|
||||
x$newvar_row_index_sorted <= row.end &
|
||||
x$newvar_genus_species != "" &
|
||||
(x$other_pat_or_mo | x$more_than_episode_ago | x$other_key_ab),
|
||||
TRUE,
|
||||
FALSE)
|
||||
|
||||
} else {
|
||||
# no key antibiotics
|
||||
x$newvar_first_isolate <- pm_if_else(x$newvar_row_index_sorted >= row.start &
|
||||
x$newvar_row_index_sorted <= row.end &
|
||||
x$newvar_genus_species != "" &
|
||||
(x$other_pat_or_mo | x$more_than_episode_ago),
|
||||
TRUE,
|
||||
FALSE)
|
||||
x$newvar_row_index_sorted <= row.end &
|
||||
x$newvar_genus_species != "" &
|
||||
(x$other_pat_or_mo | x$more_than_episode_ago),
|
||||
TRUE,
|
||||
FALSE)
|
||||
}
|
||||
|
||||
# first one as TRUE
|
||||
@@ -376,10 +414,14 @@ first_isolate <- function(x,
|
||||
}
|
||||
if (!is.null(col_icu)) {
|
||||
if (icu_exclude == TRUE) {
|
||||
message(font_black("[Criterion] Exclude isolates from ICU.\n"))
|
||||
message_("[Criterion] Exclude isolates from ICU.",
|
||||
add_fn = font_black,
|
||||
as_note = FALSE)
|
||||
x[which(as.logical(x[, col_icu, drop = TRUE])), "newvar_first_isolate"] <- FALSE
|
||||
} else {
|
||||
message(font_black("[Criterion] Include isolates from ICU.\n"))
|
||||
message_("[Criterion] Include isolates from ICU.",
|
||||
add_fn = font_black,
|
||||
as_note = FALSE)
|
||||
}
|
||||
}
|
||||
|
||||
@@ -388,18 +430,18 @@ first_isolate <- function(x,
|
||||
|
||||
# handle empty microorganisms
|
||||
if (any(x$newvar_mo == "UNKNOWN", na.rm = TRUE) & info == TRUE) {
|
||||
message(font_blue(paste0("NOTE: ", ifelse(include_unknown == TRUE, "Included ", "Excluded "),
|
||||
format(sum(x$newvar_mo == "UNKNOWN", na.rm = TRUE),
|
||||
decimal.mark = decimal.mark, big.mark = big.mark),
|
||||
" isolates with a microbial ID 'UNKNOWN' (column `", font_bold(col_mo), "`)")))
|
||||
message_(ifelse(include_unknown == TRUE, "Included ", "Excluded "),
|
||||
format(sum(x$newvar_mo == "UNKNOWN", na.rm = TRUE),
|
||||
decimal.mark = decimal.mark, big.mark = big.mark),
|
||||
" isolates with a microbial ID 'UNKNOWN' (column '", font_bold(col_mo), "')")
|
||||
}
|
||||
x[which(x$newvar_mo == "UNKNOWN"), "newvar_first_isolate"] <- include_unknown
|
||||
|
||||
# exclude all NAs
|
||||
if (any(is.na(x$newvar_mo)) & info == TRUE) {
|
||||
message(font_blue(paste0("NOTE: Excluded ", format(sum(is.na(x$newvar_mo), na.rm = TRUE),
|
||||
decimal.mark = decimal.mark, big.mark = big.mark),
|
||||
" isolates with a microbial ID 'NA' (column `", font_bold(col_mo), "`)")))
|
||||
message_("Excluded ", format(sum(is.na(x$newvar_mo), na.rm = TRUE),
|
||||
decimal.mark = decimal.mark, big.mark = big.mark),
|
||||
" isolates with a microbial ID 'NA' (column '", font_bold(col_mo), "')")
|
||||
}
|
||||
x[which(is.na(x$newvar_mo)), "newvar_first_isolate"] <- FALSE
|
||||
|
||||
@@ -428,7 +470,7 @@ first_isolate <- function(x,
|
||||
font_bold(paste0(n_found, " first ", weighted.notice, "isolates")),
|
||||
" (", p_found_total, " of total where a microbial ID was available)")
|
||||
}
|
||||
message(font_black(msg_txt))
|
||||
message_(msg_txt, add_fn = font_black, as_note = FALSE)
|
||||
}
|
||||
|
||||
x$newvar_first_isolate
|
||||
@@ -442,6 +484,10 @@ filter_first_isolate <- function(x,
|
||||
col_patient_id = NULL,
|
||||
col_mo = NULL,
|
||||
...) {
|
||||
meet_criteria(x, allow_class = "data.frame")
|
||||
meet_criteria(col_date, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
|
||||
meet_criteria(col_patient_id, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
|
||||
meet_criteria(col_mo, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
|
||||
subset(x, first_isolate(x = x,
|
||||
col_date = col_date,
|
||||
col_patient_id = col_patient_id,
|
||||
@@ -457,6 +503,11 @@ filter_first_weighted_isolate <- function(x,
|
||||
col_mo = NULL,
|
||||
col_keyantibiotics = NULL,
|
||||
...) {
|
||||
meet_criteria(x, allow_class = "data.frame")
|
||||
meet_criteria(col_date, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
|
||||
meet_criteria(col_patient_id, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
|
||||
meet_criteria(col_mo, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
|
||||
meet_criteria(col_keyantibiotics, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
|
||||
y <- x
|
||||
if (is.null(col_keyantibiotics)) {
|
||||
# first try to look for it
|
||||
@@ -472,8 +523,5 @@ filter_first_weighted_isolate <- function(x,
|
||||
|
||||
subset(x, first_isolate(x = y,
|
||||
col_date = col_date,
|
||||
col_patient_id = col_patient_id,
|
||||
col_mo = col_mo,
|
||||
col_keyantibiotics = col_keyantibiotics,
|
||||
...))
|
||||
col_patient_id = col_patient_id))
|
||||
}
|
||||
+2
-2
@@ -34,7 +34,7 @@
|
||||
#'
|
||||
#' The p-value is computed from the asymptotic chi-squared distribution of the test statistic.
|
||||
#'
|
||||
#' In the contingency table case simulation is done by random sampling from the set of all contingency tables with given marginals, and works only if the marginals are strictly positive. Note that this is not the usual sampling situation assumed for a chi-squared test (like the *G*-test) but rather that for Fisher's exact test.
|
||||
#' In the contingency table case simulation is done by random sampling from the set of all contingency tables with given marginals, and works only if the marginals are strictly positive. Note that this is not the usual sampling situation assumed for a chi-squared test (such as the *G*-test) but rather that for Fisher's exact test.
|
||||
#'
|
||||
#' In the goodness-of-fit case simulation is done by random sampling from the discrete distribution specified by `p`, each sample being of size `n = sum(x)`. This simulation is done in \R and may be slow.
|
||||
#'
|
||||
@@ -144,7 +144,7 @@ g.test <- function(x,
|
||||
DNAME <- paste(paste(DNAME, collapse = "\n"), "and",
|
||||
paste(DNAME2, collapse = "\n"))
|
||||
}
|
||||
if (any(x < 0) || anyNA(x))
|
||||
if (any(x < 0) || any(is.na((x)))) # this last one was anyNA, but only introduced in R 3.1.0
|
||||
stop("all entries of 'x' must be nonnegative and finite")
|
||||
if ((n <- sum(x)) == 0)
|
||||
stop("at least one entry of 'x' must be positive")
|
||||
|
||||
+33
-24
@@ -53,9 +53,10 @@
|
||||
#' As per their GPL-2 licence that demands documentation of code changes, the changes made based on the source code were:
|
||||
#' 1. Rewritten code to remove the dependency on packages `plyr`, `scales` and `grid`
|
||||
#' 2. Parametrised more options, like arrow and ellipse settings
|
||||
#' 3. Added total amount of explained variance as a caption in the plot
|
||||
#' 4. Cleaned all syntax based on the `lintr` package and added integrity checks
|
||||
#' 5. Updated documentation
|
||||
#' 3. Hardened all input possibilities by defining the exact type of user input for every parameter
|
||||
#' 4. Added total amount of explained variance as a caption in the plot
|
||||
#' 5. Cleaned all syntax based on the `lintr` package, fixed grammatical errors and added integrity checks
|
||||
#' 6. Updated documentation
|
||||
#' @details The colours for labels and points can be changed by adding another scale layer for colour, like `scale_colour_viridis_d()` or `scale_colour_brewer()`.
|
||||
#' @rdname ggplot_pca
|
||||
#' @export
|
||||
@@ -85,7 +86,7 @@
|
||||
#' }
|
||||
ggplot_pca <- function(x,
|
||||
choices = 1:2,
|
||||
scale = TRUE,
|
||||
scale = 1,
|
||||
pc.biplot = TRUE,
|
||||
labels = NULL,
|
||||
labels_textsize = 3,
|
||||
@@ -107,22 +108,27 @@ ggplot_pca <- function(x,
|
||||
...) {
|
||||
|
||||
stop_ifnot_installed("ggplot2")
|
||||
stop_ifnot(length(choices) == 2, "`choices` must be of length 2")
|
||||
stop_ifnot(is.logical(arrows), "`arrows` must be TRUE or FALSE")
|
||||
stop_ifnot(is.logical(arrows_textangled), "`arrows_textangled` must be TRUE or FALSE")
|
||||
stop_ifnot(is.logical(ellipse), "`ellipse` must be TRUE or FALSE")
|
||||
stop_ifnot(is.logical(pc.biplot), "`pc.biplot` must be TRUE or FALSE")
|
||||
stop_ifnot(is.logical(scale), "`scale` must be TRUE or FALSE")
|
||||
stop_ifnot(is.numeric(arrows_alpha), "`arrows_alpha` must be numeric")
|
||||
stop_ifnot(is.numeric(arrows_size), "`arrows_size` must be numeric")
|
||||
stop_ifnot(is.numeric(arrows_textsize), "`arrows_textsize` must be numeric")
|
||||
stop_ifnot(is.numeric(base_textsize), "`base_textsize` must be numeric")
|
||||
stop_ifnot(is.numeric(choices), "`choices` must be numeric")
|
||||
stop_ifnot(is.numeric(ellipse_alpha), "`ellipse_alpha` must be numeric")
|
||||
stop_ifnot(is.numeric(ellipse_prob), "`ellipse_prob` must be numeric")
|
||||
stop_ifnot(is.numeric(ellipse_size), "`ellipse_size` must be numeric")
|
||||
stop_ifnot(is.numeric(labels_text_placement), "`labels_text_placement` must be numeric")
|
||||
stop_ifnot(is.numeric(labels_textsize), "`labels_textsize` must be numeric")
|
||||
meet_criteria(x, allow_class = c("prcomp", "princomp", "PCA", "lda"))
|
||||
meet_criteria(choices, allow_class = c("numeric", "integer"), has_length = 2)
|
||||
meet_criteria(scale, allow_class = c("numeric", "integer", "logical"), has_length = 1)
|
||||
meet_criteria(pc.biplot, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(labels, allow_class = "character", allow_NULL = TRUE)
|
||||
meet_criteria(labels_textsize, allow_class = c("numeric", "integer"), has_length = 1)
|
||||
meet_criteria(labels_text_placement, allow_class = c("numeric", "integer"), has_length = 1)
|
||||
meet_criteria(groups, allow_class = "character", allow_NULL = TRUE)
|
||||
meet_criteria(ellipse, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(ellipse_prob, allow_class = c("numeric", "integer"), has_length = 1)
|
||||
meet_criteria(ellipse_size, allow_class = c("numeric", "integer"), has_length = 1)
|
||||
meet_criteria(ellipse_alpha, allow_class = c("numeric", "integer"), has_length = 1)
|
||||
meet_criteria(points_size, allow_class = c("numeric", "integer"), has_length = 1)
|
||||
meet_criteria(points_alpha, allow_class = c("numeric", "integer"), has_length = 1)
|
||||
meet_criteria(arrows, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(arrows_colour, allow_class = "character", has_length = 1)
|
||||
meet_criteria(arrows_size, allow_class = c("numeric", "integer"), has_length = 1)
|
||||
meet_criteria(arrows_textsize, allow_class = c("numeric", "integer"), has_length = 1)
|
||||
meet_criteria(arrows_textangled, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(arrows_alpha, allow_class = c("numeric", "integer"), has_length = 1)
|
||||
meet_criteria(base_textsize, allow_class = c("numeric", "integer"), has_length = 1)
|
||||
|
||||
calculations <- pca_calculations(pca_model = x,
|
||||
groups = groups,
|
||||
@@ -302,17 +308,19 @@ pca_calculations <- function(pca_model,
|
||||
v <- pca_model$scaling
|
||||
d.total <- sum(d ^ 2)
|
||||
} else {
|
||||
stop("Expected a object of class prcomp, princomp, PCA, or lda")
|
||||
stop("Expected an object of class prcomp, princomp, PCA, or lda")
|
||||
}
|
||||
|
||||
# Scores
|
||||
choices <- pmin(choices, ncol(u))
|
||||
obs.scale <- 1 - as.integer(scale)
|
||||
df.u <- as.data.frame(sweep(u[, choices], 2, d[choices] ^ obs.scale, FUN = "*"))
|
||||
df.u <- as.data.frame(sweep(u[, choices], 2, d[choices] ^ obs.scale, FUN = "*"),
|
||||
stringsAsFactors = FALSE)
|
||||
|
||||
# Directions
|
||||
v <- sweep(v, 2, d ^ as.integer(scale), FUN = "*")
|
||||
df.v <- as.data.frame(v[, choices])
|
||||
df.v <- as.data.frame(v[, choices],
|
||||
stringsAsFactors = FALSE)
|
||||
|
||||
names(df.u) <- c("xvar", "yvar")
|
||||
names(df.v) <- names(df.u)
|
||||
@@ -350,7 +358,8 @@ pca_calculations <- function(pca_model,
|
||||
if (nrow(x) <= 2) {
|
||||
return(data.frame(X1 = numeric(0),
|
||||
X2 = numeric(0),
|
||||
groups = character(0)))
|
||||
groups = character(0),
|
||||
stringsAsFactors = FALSE))
|
||||
}
|
||||
sigma <- var(cbind(x$xvar, x$yvar))
|
||||
mu <- c(mean(x$xvar), mean(x$yvar))
|
||||
|
||||
+56
-18
@@ -36,7 +36,7 @@
|
||||
#' @param facet variable to split plots by, either `"interpretation"` (default) or `"antibiotic"` or a grouping variable
|
||||
#' @inheritParams proportion
|
||||
#' @param nrow (when using `facet`) number of rows
|
||||
#' @param colours a named vector with colours for the bars. The names must be one or more of: S, SI, I, IR, R or be `FALSE` to use default [ggplot2][[ggplot2::ggplot()] colours.
|
||||
#' @param colours a named vector with colours for the bars. The names must be one or more of: S, SI, I, IR, R or be `FALSE` to use default [ggplot2][ggplot2::ggplot()] colours.
|
||||
#' @param datalabels show datalabels using [labels_rsi_count()]
|
||||
#' @param datalabels.size size of the datalabels
|
||||
#' @param datalabels.colour colour of the datalabels
|
||||
@@ -107,13 +107,12 @@
|
||||
#' }
|
||||
#'
|
||||
#' \donttest{
|
||||
#'
|
||||
#' # resistance of ciprofloxacine per age group
|
||||
#' example_isolates %>%
|
||||
#' mutate(first_isolate = first_isolate(.)) %>%
|
||||
#' filter(first_isolate == TRUE,
|
||||
#' mo == as.mo("E. coli")) %>%
|
||||
#' # `age_groups` is also a function of this AMR package:
|
||||
#' # age_groups() is also a function in this AMR package:
|
||||
#' group_by(age_group = age_groups(age)) %>%
|
||||
#' select(age_group,
|
||||
#' CIP) %>%
|
||||
@@ -162,7 +161,7 @@ ggplot_rsi <- function(data,
|
||||
R = "#ff6961"),
|
||||
datalabels = TRUE,
|
||||
datalabels.size = 2.5,
|
||||
datalabels.colour = "gray15",
|
||||
datalabels.colour = "grey15",
|
||||
title = NULL,
|
||||
subtitle = NULL,
|
||||
caption = NULL,
|
||||
@@ -171,10 +170,29 @@ ggplot_rsi <- function(data,
|
||||
...) {
|
||||
|
||||
stop_ifnot_installed("ggplot2")
|
||||
|
||||
x <- x[1]
|
||||
facet <- facet[1]
|
||||
|
||||
meet_criteria(data, allow_class = "data.frame", contains_column_class = "rsi")
|
||||
meet_criteria(position, allow_class = "character", has_length = 1, is_in = c("fill", "stack", "dodge"), allow_NULL = TRUE)
|
||||
meet_criteria(x, allow_class = "character", has_length = 1)
|
||||
meet_criteria(fill, allow_class = "character", has_length = 1)
|
||||
meet_criteria(facet, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(breaks, allow_class = c("numeric", "integer"))
|
||||
meet_criteria(limits, allow_class = c("numeric", "integer"), has_length = 2, allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE)
|
||||
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(combine_IR, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(nrow, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(colours, allow_class = c("character", "logical"))
|
||||
meet_criteria(datalabels, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(datalabels.size, allow_class = c("numeric", "integer"), has_length = 1)
|
||||
meet_criteria(datalabels.colour, allow_class = "character", has_length = 1)
|
||||
meet_criteria(title, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(subtitle, 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(y.title, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||
|
||||
# we work with aes_string later on
|
||||
x_deparse <- deparse(substitute(x))
|
||||
if (x_deparse != "x") {
|
||||
@@ -207,8 +225,8 @@ ggplot_rsi <- function(data,
|
||||
if (fill == "interpretation") {
|
||||
# set RSI colours
|
||||
if (isFALSE(colours) & missing(datalabels.colour)) {
|
||||
# set datalabel colour to middle gray
|
||||
datalabels.colour <- "gray50"
|
||||
# set datalabel colour to middle grey
|
||||
datalabels.colour <- "grey50"
|
||||
}
|
||||
p <- p + scale_rsi_colours(colours = colours)
|
||||
}
|
||||
@@ -254,9 +272,17 @@ geom_rsi <- function(position = NULL,
|
||||
combine_SI = TRUE,
|
||||
combine_IR = FALSE,
|
||||
...) {
|
||||
|
||||
x <- x[1]
|
||||
stop_ifnot_installed("ggplot2")
|
||||
stop_if(is.data.frame(position), "`position` is invalid. Did you accidentally use '%pm>%' instead of '+'?")
|
||||
stop_if(is.data.frame(position), "`position` is invalid. Did you accidentally use '%>%' instead of '+'?")
|
||||
meet_criteria(position, allow_class = "character", has_length = 1, is_in = c("fill", "stack", "dodge"), allow_NULL = TRUE)
|
||||
meet_criteria(x, allow_class = "character", has_length = 1)
|
||||
meet_criteria(fill, allow_class = "character", has_length = 1)
|
||||
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE)
|
||||
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(combine_IR, allow_class = "logical", has_length = 1)
|
||||
|
||||
y <- "value"
|
||||
if (missing(position) | is.null(position)) {
|
||||
@@ -267,8 +293,6 @@ geom_rsi <- function(position = NULL,
|
||||
position <- ggplot2::position_fill(vjust = 0.5, reverse = TRUE)
|
||||
}
|
||||
|
||||
x <- x[1]
|
||||
|
||||
# we work with aes_string later on
|
||||
x_deparse <- deparse(substitute(x))
|
||||
if (x_deparse != "x") {
|
||||
@@ -300,10 +324,10 @@ geom_rsi <- function(position = NULL,
|
||||
#' @rdname ggplot_rsi
|
||||
#' @export
|
||||
facet_rsi <- function(facet = c("interpretation", "antibiotic"), nrow = NULL) {
|
||||
|
||||
stop_ifnot_installed("ggplot2")
|
||||
|
||||
facet <- facet[1]
|
||||
stop_ifnot_installed("ggplot2")
|
||||
meet_criteria(facet, allow_class = "character", has_length = 1)
|
||||
meet_criteria(nrow, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE)
|
||||
|
||||
# we work with aes_string later on
|
||||
facet_deparse <- deparse(substitute(facet))
|
||||
@@ -327,6 +351,8 @@ facet_rsi <- function(facet = c("interpretation", "antibiotic"), nrow = NULL) {
|
||||
#' @export
|
||||
scale_y_percent <- function(breaks = seq(0, 1, 0.1), limits = NULL) {
|
||||
stop_ifnot_installed("ggplot2")
|
||||
meet_criteria(breaks, allow_class = c("numeric", "integer"))
|
||||
meet_criteria(limits, allow_class = c("numeric", "integer"), has_length = 2, allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
if (all(breaks[breaks != 0] > 1)) {
|
||||
breaks <- breaks / 100
|
||||
@@ -344,6 +370,8 @@ scale_rsi_colours <- function(colours = c(S = "#61a8ff",
|
||||
IR = "#ff6961",
|
||||
R = "#ff6961")) {
|
||||
stop_ifnot_installed("ggplot2")
|
||||
meet_criteria(colours, allow_class = c("character", "logical"))
|
||||
|
||||
# previous colour: palette = "RdYlGn"
|
||||
# previous colours: values = c("#b22222", "#ae9c20", "#7cfc00")
|
||||
|
||||
@@ -381,8 +409,18 @@ labels_rsi_count <- function(position = NULL,
|
||||
combine_SI = TRUE,
|
||||
combine_IR = FALSE,
|
||||
datalabels.size = 3,
|
||||
datalabels.colour = "gray15") {
|
||||
datalabels.colour = "grey15") {
|
||||
stop_ifnot_installed("ggplot2")
|
||||
meet_criteria(position, allow_class = "character", has_length = 1, is_in = c("fill", "stack", "dodge"), allow_NULL = TRUE)
|
||||
meet_criteria(x, allow_class = "character", has_length = 1)
|
||||
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE)
|
||||
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(combine_IR, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(datalabels.size, allow_class = c("numeric", "integer"), has_length = 1)
|
||||
meet_criteria(datalabels.colour, allow_class = "character", has_length = 1)
|
||||
|
||||
if (is.null(position)) {
|
||||
position <- "fill"
|
||||
}
|
||||
|
||||
@@ -39,6 +39,7 @@ globalVariables(c(".rowid",
|
||||
"genus",
|
||||
"gr",
|
||||
"group",
|
||||
"guideline",
|
||||
"hjust",
|
||||
"input",
|
||||
"intrinsic_resistant",
|
||||
@@ -46,6 +47,7 @@ globalVariables(c(".rowid",
|
||||
"lang",
|
||||
"language",
|
||||
"lookup",
|
||||
"method",
|
||||
"microorganism",
|
||||
"microorganisms",
|
||||
"microorganisms.codes",
|
||||
@@ -73,5 +75,6 @@ globalVariables(c(".rowid",
|
||||
"value",
|
||||
"varname",
|
||||
"xvar",
|
||||
"y",
|
||||
"year",
|
||||
"yvar"))
|
||||
+47
-42
@@ -30,7 +30,7 @@
|
||||
#' @param x a [data.frame]
|
||||
#' @param search_string a text to search `x` for, will be checked with [as.ab()] if this value is not a column in `x`
|
||||
#' @param verbose a logical to indicate whether additional info should be printed
|
||||
#' @details You can look for an antibiotic (trade) name or abbreviation and it will search `x` and the [antibiotics] data set for any column containing a name or code of that antibiotic. **Longer columns names take precendence over shorter column names.**
|
||||
#' @details You can look for an antibiotic (trade) name or abbreviation and it will search `x` and the [antibiotics] data set for any column containing a name or code of that antibiotic. **Longer columns names take precedence over shorter column names.**
|
||||
#' @return A column name of `x`, or `NULL` when no result is found.
|
||||
#' @export
|
||||
#' @inheritSection AMR Read more on our website!
|
||||
@@ -44,7 +44,7 @@
|
||||
#' # [1] "tetr"
|
||||
#'
|
||||
#' guess_ab_col(df, "J01AA07", verbose = TRUE)
|
||||
#' # NOTE: Using column `tetr` as input for `J01AA07` (tetracycline).
|
||||
#' # NOTE: Using column 'tetr' as input for J01AA07 (tetracycline).
|
||||
#' # [1] "tetr"
|
||||
#'
|
||||
#' # WHONET codes
|
||||
@@ -63,16 +63,13 @@
|
||||
#' guess_ab_col(df, "ampicillin")
|
||||
#' # [1] "AMP_ED20"
|
||||
guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE) {
|
||||
meet_criteria(x, allow_class = "data.frame", allow_NULL = TRUE)
|
||||
meet_criteria(search_string, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(verbose, allow_class = "logical", has_length = 1)
|
||||
|
||||
if (is.null(x) & is.null(search_string)) {
|
||||
return(as.name("guess_ab_col"))
|
||||
}
|
||||
stop_ifnot(is.data.frame(x), "`x` must be a data.frame")
|
||||
|
||||
if (length(search_string) > 1) {
|
||||
warning("argument 'search_string' has length > 1 and only the first element will be used")
|
||||
search_string <- search_string[1]
|
||||
}
|
||||
search_string <- as.character(search_string)
|
||||
|
||||
if (search_string %in% colnames(x)) {
|
||||
ab_result <- search_string
|
||||
@@ -97,14 +94,16 @@ guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE) {
|
||||
|
||||
if (length(ab_result) == 0) {
|
||||
if (verbose == TRUE) {
|
||||
message(paste0("No column found as input for `", search_string,
|
||||
"` (", ab_name(search_string, language = NULL, tolower = TRUE), ")."))
|
||||
message_("No column found as input for ", search_string,
|
||||
" (", ab_name(search_string, language = NULL, tolower = TRUE), ").",
|
||||
add_fn = font_black,
|
||||
as_note = FALSE)
|
||||
}
|
||||
return(NULL)
|
||||
} else {
|
||||
if (verbose == TRUE) {
|
||||
message(font_blue(paste0("NOTE: Using column `", font_bold(ab_result), "` as input for `", search_string,
|
||||
"` (", ab_name(search_string, language = NULL, tolower = TRUE), ").")))
|
||||
message_("Using column '", font_bold(ab_result), "' as input for ", search_string,
|
||||
" (", ab_name(search_string, language = NULL, tolower = TRUE), ").")
|
||||
}
|
||||
return(ab_result)
|
||||
}
|
||||
@@ -116,20 +115,27 @@ get_column_abx <- function(x,
|
||||
verbose = FALSE,
|
||||
info = TRUE,
|
||||
...) {
|
||||
meet_criteria(x, allow_class = "data.frame")
|
||||
meet_criteria(soft_dependencies, allow_class = "character", allow_NULL = TRUE)
|
||||
meet_criteria(hard_dependencies, allow_class = "character", allow_NULL = TRUE)
|
||||
meet_criteria(verbose, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(info, allow_class = "logical", has_length = 1)
|
||||
|
||||
if (info == TRUE) {
|
||||
message(font_blue("NOTE: Auto-guessing columns suitable for analysis"), appendLF = FALSE)
|
||||
message_("Auto-guessing columns suitable for analysis", appendLF = FALSE)
|
||||
}
|
||||
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||
if (NROW(x) > 10000) {
|
||||
# only test maximum of 10,000 values per column
|
||||
if (info == TRUE) {
|
||||
message(font_blue(paste0(" (using only ", font_bold("the first 10,000 rows"), ")...")), appendLF = FALSE)
|
||||
message_(" (using only ", font_bold("the first 10,000 rows"), ")...",
|
||||
appendLF = FALSE,
|
||||
as_note = FALSE)
|
||||
}
|
||||
x <- x[1:10000, , drop = FALSE]
|
||||
} else if (info == TRUE) {
|
||||
message(font_blue("..."), appendLF = FALSE)
|
||||
message_("...", appendLF = FALSE, as_note = FALSE)
|
||||
}
|
||||
x_bak <- x
|
||||
# only check columns that are a valid AB code, ATC code, name, abbreviation or synonym,
|
||||
@@ -139,8 +145,9 @@ get_column_abx <- function(x,
|
||||
vectr_antibiotics <- vectr_antibiotics[!is.na(vectr_antibiotics) & nchar(vectr_antibiotics) >= 3]
|
||||
x_columns <- sapply(colnames(x), function(col, df = x_bak) {
|
||||
if (toupper(col) %in% vectr_antibiotics |
|
||||
is.rsi(as.data.frame(df)[, col, drop = TRUE]) |
|
||||
is.rsi.eligible(as.data.frame(df)[, col, drop = TRUE], threshold = 0.5)) {
|
||||
is.rsi(as.data.frame(df, stringsAsFactors = FALSE)[, col, drop = TRUE]) |
|
||||
is.rsi.eligible(as.data.frame(df, stringsAsFactors = FALSE)[, col, drop = TRUE],
|
||||
threshold = 0.5)) {
|
||||
return(col)
|
||||
} else {
|
||||
return(NA_character_)
|
||||
@@ -150,7 +157,8 @@ get_column_abx <- function(x,
|
||||
x <- x[, x_columns, drop = FALSE] # without drop = TRUE, x will become a vector when x_columns is length 1
|
||||
|
||||
df_trans <- data.frame(colnames = colnames(x),
|
||||
abcode = suppressWarnings(as.ab(colnames(x), info = FALSE)))
|
||||
abcode = suppressWarnings(as.ab(colnames(x), info = FALSE)),
|
||||
stringsAsFactors = FALSE)
|
||||
df_trans <- df_trans[!is.na(df_trans$abcode), , drop = FALSE]
|
||||
x <- as.character(df_trans$colnames)
|
||||
names(x) <- df_trans$abcode
|
||||
@@ -161,8 +169,9 @@ get_column_abx <- function(x,
|
||||
if (length(dots) > 0) {
|
||||
newnames <- suppressWarnings(as.ab(names(dots), info = FALSE))
|
||||
if (any(is.na(newnames))) {
|
||||
warning("Invalid antibiotic reference(s): ", toString(names(dots)[is.na(newnames)]),
|
||||
call. = FALSE, immediate. = TRUE)
|
||||
warning_("Invalid antibiotic reference(s): ", toString(names(dots)[is.na(newnames)]),
|
||||
call = FALSE,
|
||||
immediate = TRUE)
|
||||
}
|
||||
# turn all NULLs to NAs
|
||||
dots <- unlist(lapply(dots, function(x) if (is.null(x)) NA else x))
|
||||
@@ -176,7 +185,7 @@ get_column_abx <- function(x,
|
||||
|
||||
if (length(x) == 0) {
|
||||
if (info == TRUE) {
|
||||
message(font_blue("No columns found."))
|
||||
message_("No columns found.")
|
||||
}
|
||||
return(x)
|
||||
}
|
||||
@@ -190,20 +199,21 @@ get_column_abx <- function(x,
|
||||
|
||||
# succeeded with auto-guessing
|
||||
if (info == TRUE) {
|
||||
message(font_blue("OK."))
|
||||
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
|
||||
}
|
||||
|
||||
for (i in seq_len(length(x))) {
|
||||
if (info == TRUE & verbose == TRUE & !names(x[i]) %in% names(duplicates)) {
|
||||
message(font_blue(paste0("NOTE: Using column `", font_bold(x[i]), "` as input for `", names(x)[i],
|
||||
"` (", ab_name(names(x)[i], tolower = TRUE, language = NULL), ").")))
|
||||
message_("Using column '", font_bold(x[i]), "' as input for ", names(x)[i],
|
||||
" (", ab_name(names(x)[i], tolower = TRUE, language = NULL), ").")
|
||||
}
|
||||
if (info == TRUE & names(x[i]) %in% names(duplicates)) {
|
||||
warning(font_red(paste0("Using column `", font_bold(x[i]), "` as input for `", names(x)[i],
|
||||
"` (", ab_name(names(x)[i], tolower = TRUE, language = NULL),
|
||||
"), although it was matched for multiple antibiotics or columns.")),
|
||||
call. = FALSE,
|
||||
immediate. = verbose)
|
||||
warning_(paste0("Using column '", font_bold(x[i]), "' as input for ", names(x)[i],
|
||||
" (", ab_name(names(x)[i], tolower = TRUE, language = NULL),
|
||||
"), although it was matched for multiple antibiotics or columns."),
|
||||
add_fn = font_red,
|
||||
call = FALSE,
|
||||
immediate = verbose)
|
||||
}
|
||||
}
|
||||
|
||||
@@ -223,15 +233,10 @@ get_column_abx <- function(x,
|
||||
# missing a soft dependency may lower the reliability
|
||||
missing <- soft_dependencies[!soft_dependencies %in% names(x)]
|
||||
missing_msg <- paste(paste0(ab_name(missing, tolower = TRUE, language = NULL),
|
||||
" (", missing, ")"),
|
||||
" (", font_bold(missing, collapse = NULL), ")"),
|
||||
collapse = ", ")
|
||||
missing_msg <- paste("NOTE: Reliability would be improved if these antimicrobial results would be available too:",
|
||||
missing_msg)
|
||||
wrapped <- strwrap(missing_msg,
|
||||
width = 0.95 * getOption("width"),
|
||||
exdent = 6)
|
||||
wrapped <- gsub("\\((.*?)\\)", paste0("(", font_bold("\\1"), ")"), wrapped) # add bold abbreviations
|
||||
message(font_blue(wrapped, collapse = "\n"))
|
||||
message_("Reliability would be improved if these antimicrobial results would be available too: ",
|
||||
missing_msg)
|
||||
}
|
||||
}
|
||||
x
|
||||
@@ -244,8 +249,8 @@ generate_warning_abs_missing <- function(missing, any = FALSE) {
|
||||
} else {
|
||||
any_txt <- c("", "are")
|
||||
}
|
||||
warning(paste0("Introducing NAs since", any_txt[1], " these antimicrobials ", any_txt[2], " required: ",
|
||||
paste(missing, collapse = ", ")),
|
||||
immediate. = TRUE,
|
||||
call. = FALSE)
|
||||
warning_(paste0("Introducing NAs since", any_txt[1], " these antimicrobials ", any_txt[2], " required: ",
|
||||
paste(missing, collapse = ", ")),
|
||||
immediate = TRUE,
|
||||
call = FALSE)
|
||||
}
|
||||
@@ -0,0 +1,126 @@
|
||||
# ==================================================================== #
|
||||
# TITLE #
|
||||
# Antimicrobial Resistance (AMR) Analysis for R #
|
||||
# #
|
||||
# SOURCE #
|
||||
# https://github.com/msberends/AMR #
|
||||
# #
|
||||
# LICENCE #
|
||||
# (c) 2018-2020 Berends MS, Luz CF et al. #
|
||||
# Developed at the University of Groningen, the Netherlands, in #
|
||||
# collaboration with non-profit organisations Certe Medical #
|
||||
# Diagnostics & Advice, and University Medical Center Groningen. #
|
||||
# #
|
||||
# This R package is free software; you can freely use and distribute #
|
||||
# it for both personal and commercial purposes under the terms of the #
|
||||
# GNU General Public License version 2.0 (GNU GPL-2), as published by #
|
||||
# the Free Software Foundation. #
|
||||
# We created this package for both routine data analysis and academic #
|
||||
# research and it was publicly released in the hope that it will be #
|
||||
# useful, but it comes WITHOUT ANY WARRANTY OR LIABILITY. #
|
||||
# #
|
||||
# Visit our website for the full manual and a complete tutorial about #
|
||||
# how to conduct AMR analysis: https://msberends.github.io/AMR/ #
|
||||
# ==================================================================== #
|
||||
|
||||
#' Determine (new) episodes for patients
|
||||
#'
|
||||
#' This function determines which items in a vector can be considered (the start of) a new episode, based on the parameter `episode_days`. This can be used to determine clinical episodes for any epidemiological analysis.
|
||||
#' @inheritSection lifecycle Stable lifecycle
|
||||
#' @param x vector of dates (class `Date` or `POSIXt`)
|
||||
#' @param episode_days length of the required episode in days, defaults to 365. Every element in the input will return `TRUE` after this number of days has passed since the last included date, independent of calendar years. Please see *Details*.
|
||||
#' @param ... arguments passed on to [as.Date()]
|
||||
#' @details
|
||||
#' Dates are first sorted from old to new. The oldest date will mark the start of the first episode. After this date, the next date will be marked that is at least `episode_days` days later than the start of the first episode. From that second marked date on, the next date will be marked that is at least `episode_days` days later than the start of the second episode which will be the start of the third episode, and so on. Before the vector is being returned, the original order will be restored.
|
||||
#'
|
||||
#' The [first_isolate()] function is a wrapper around the [is_new_episode()] function, but more efficient for data sets containing microorganism codes or names.
|
||||
#'
|
||||
#' The `dplyr` package is not required for this function to work, but this function works conveniently inside `dplyr` verbs such as [`filter()`][dplyr::filter()], [`mutate()`][dplyr::mutate()] and [`summarise()`][dplyr::summarise()].
|
||||
#' @return a [logical] vector
|
||||
#' @export
|
||||
#' @inheritSection AMR Read more on our website!
|
||||
#' @examples
|
||||
#' # `example_isolates` is a dataset available in the AMR package.
|
||||
#' # See ?example_isolates.
|
||||
#'
|
||||
#' is_new_episode(example_isolates$date)
|
||||
#' is_new_episode(example_isolates$date, episode_days = 60)
|
||||
#' \donttest{
|
||||
#' if (require("dplyr")) {
|
||||
#' # is_new_episode() can also be used in dplyr verbs to determine patient
|
||||
#' # episodes based on any (combination of) grouping variables:
|
||||
#' example_isolates %>%
|
||||
#' mutate(condition = sample(x = c("A", "B", "C"),
|
||||
#' size = 2000,
|
||||
#' replace = TRUE)) %>%
|
||||
#' group_by(condition) %>%
|
||||
#' mutate(new_episode = is_new_episode(date))
|
||||
#'
|
||||
#' example_isolates %>%
|
||||
#' group_by(hospital_id) %>%
|
||||
#' summarise(patients = n_distinct(patient_id),
|
||||
#' n_episodes_365 = sum(is_new_episode(date, episode_days = 365)),
|
||||
#' n_episodes_60 = sum(is_new_episode(date, episode_days = 60)),
|
||||
#' n_episodes_30 = sum(is_new_episode(date, episode_days = 30)))
|
||||
#'
|
||||
#'
|
||||
#' # grouping on patients and microorganisms leads to the same results
|
||||
#' # as first_isolate():
|
||||
#' x <- example_isolates %>%
|
||||
#' filter(first_isolate(., include_unknown = TRUE))
|
||||
#'
|
||||
#' y <- example_isolates %>%
|
||||
#' group_by(patient_id, mo) %>%
|
||||
#' filter(is_new_episode(date))
|
||||
#'
|
||||
#' identical(x$patient_id, y$patient_id)
|
||||
#'
|
||||
#' # but is_new_episode() has a lot more flexibility than first_isolate(),
|
||||
#' # since you can now group on anything that seems relevant:
|
||||
#' example_isolates %>%
|
||||
#' group_by(patient_id, mo, hospital_id, ward_icu) %>%
|
||||
#' mutate(flag_episode = is_new_episode(date))
|
||||
#' }
|
||||
#' }
|
||||
is_new_episode <- function(x, episode_days = 365, ...) {
|
||||
meet_criteria(x, allow_class = c("Date", "POSIXt"))
|
||||
meet_criteria(episode_days, allow_class = c("numeric", "double", "integer"), has_length = 1)
|
||||
|
||||
x <- as.double(as.Date(x, ...)) # as.Date() for POSIX classes
|
||||
if (length(x) == 1) {
|
||||
return(TRUE)
|
||||
} else if (length(x) == 2) {
|
||||
if (max(x) - min(x) >= episode_days) {
|
||||
return(c(TRUE, TRUE))
|
||||
} else {
|
||||
return(c(TRUE, FALSE))
|
||||
}
|
||||
}
|
||||
|
||||
# I asked on StackOverflow:
|
||||
# https://stackoverflow.com/questions/42122245/filter-one-row-every-year
|
||||
exec <- function(x, episode_days) {
|
||||
indices <- integer()
|
||||
start <- x[1]
|
||||
ind <- 1
|
||||
indices[1] <- 1
|
||||
for (i in 2:length(x)) {
|
||||
if (isTRUE((x[i] - start) >= episode_days)) {
|
||||
ind <- ind + 1
|
||||
indices[ind] <- i
|
||||
start <- x[i]
|
||||
}
|
||||
}
|
||||
result <- rep(FALSE, length(x))
|
||||
result[indices] <- TRUE
|
||||
result
|
||||
}
|
||||
|
||||
df <- data.frame(x = x,
|
||||
y = seq_len(length(x))) %pm>%
|
||||
pm_arrange(x)
|
||||
df$new <- exec(df$x, episode_days)
|
||||
df %pm>%
|
||||
pm_arrange(y) %pm>%
|
||||
pm_pull(new)
|
||||
}
|
||||
+39
-13
@@ -31,7 +31,7 @@
|
||||
#' @name join
|
||||
#' @aliases join inner_join
|
||||
#' @param x existing table to join, or character vector
|
||||
#' @param by a variable to join by - if left empty will search for a column with class [`mo`] (created with [as.mo()]) or will be `"mo"` if that column name exists in `x`, could otherwise be a column name of `x` with values that exist in `microorganisms$mo` (like `by = "bacteria_id"`), or another column in [microorganisms] (but then it should be named, like `by = c("bacteria_id" = "fullname")`)
|
||||
#' @param by a variable to join by - if left empty will search for a column with class [`mo`] (created with [as.mo()]) or will be `"mo"` if that column name exists in `x`, could otherwise be a column name of `x` with values that exist in `microorganisms$mo` (such as `by = "bacteria_id"`), or another column in [microorganisms] (but then it should be named, like `by = c("bacteria_id" = "fullname")`)
|
||||
#' @param suffix if there are non-joined duplicate variables in `x` and `y`, these suffixes will be added to the output to disambiguate them. Should be a character vector of length 2.
|
||||
#' @param ... ignored
|
||||
#' @details **Note:** As opposed to the `join()` functions of `dplyr`, [character] vectors are supported and at default existing columns will get a suffix `"2"` and the newly joined columns will not get a suffix.
|
||||
@@ -61,8 +61,12 @@
|
||||
#' }
|
||||
#' }
|
||||
inner_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
|
||||
meet_criteria(x, allow_class = c("data.frame", "character"))
|
||||
meet_criteria(by, allow_class = "character", allow_NULL = TRUE)
|
||||
meet_criteria(suffix, allow_class = "character", has_length = 2)
|
||||
|
||||
check_dataset_integrity()
|
||||
check_groups_before_join(x, "inner_join_microorganisms")
|
||||
x <- check_groups_before_join(x, "inner_join_microorganisms")
|
||||
checked <- joins_check_df(x, by)
|
||||
x_class <- get_prejoined_class(x)
|
||||
x <- checked$x
|
||||
@@ -79,7 +83,7 @@ inner_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
|
||||
)
|
||||
}
|
||||
if (NROW(join) > NROW(x)) {
|
||||
warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
|
||||
warning_("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
|
||||
}
|
||||
class(join) <- x_class
|
||||
join
|
||||
@@ -88,8 +92,12 @@ inner_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
|
||||
#' @rdname join
|
||||
#' @export
|
||||
left_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
|
||||
meet_criteria(x, allow_class = c("data.frame", "character"))
|
||||
meet_criteria(by, allow_class = "character", allow_NULL = TRUE)
|
||||
meet_criteria(suffix, allow_class = "character", has_length = 2)
|
||||
|
||||
check_dataset_integrity()
|
||||
check_groups_before_join(x, "left_join_microorganisms")
|
||||
x <- check_groups_before_join(x, "left_join_microorganisms")
|
||||
checked <- joins_check_df(x, by)
|
||||
x_class <- get_prejoined_class(x)
|
||||
x <- checked$x
|
||||
@@ -106,7 +114,7 @@ left_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
|
||||
)
|
||||
}
|
||||
if (NROW(join) > NROW(x)) {
|
||||
warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
|
||||
warning_("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
|
||||
}
|
||||
class(join) <- x_class
|
||||
join
|
||||
@@ -115,8 +123,12 @@ left_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
|
||||
#' @rdname join
|
||||
#' @export
|
||||
right_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
|
||||
meet_criteria(x, allow_class = c("data.frame", "character"))
|
||||
meet_criteria(by, allow_class = "character", allow_NULL = TRUE)
|
||||
meet_criteria(suffix, allow_class = "character", has_length = 2)
|
||||
|
||||
check_dataset_integrity()
|
||||
check_groups_before_join(x, "right_join_microorganisms")
|
||||
x <- check_groups_before_join(x, "right_join_microorganisms")
|
||||
checked <- joins_check_df(x, by)
|
||||
x_class <- get_prejoined_class(x)
|
||||
x <- checked$x
|
||||
@@ -133,7 +145,7 @@ right_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
|
||||
)
|
||||
}
|
||||
if (NROW(join) > NROW(x)) {
|
||||
warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
|
||||
warning_("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
|
||||
}
|
||||
class(join) <- x_class
|
||||
join
|
||||
@@ -142,8 +154,12 @@ right_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
|
||||
#' @rdname join
|
||||
#' @export
|
||||
full_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
|
||||
meet_criteria(x, allow_class = c("data.frame", "character"))
|
||||
meet_criteria(by, allow_class = "character", allow_NULL = TRUE)
|
||||
meet_criteria(suffix, allow_class = "character", has_length = 2)
|
||||
|
||||
check_dataset_integrity()
|
||||
check_groups_before_join(x, "full_join_microorganisms")
|
||||
x <- check_groups_before_join(x, "full_join_microorganisms")
|
||||
checked <- joins_check_df(x, by)
|
||||
x_class <- get_prejoined_class(x)
|
||||
x <- checked$x
|
||||
@@ -160,7 +176,7 @@ full_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
|
||||
)
|
||||
}
|
||||
if (NROW(join) > NROW(x)) {
|
||||
warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
|
||||
warning_("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
|
||||
}
|
||||
class(join) <- x_class
|
||||
join
|
||||
@@ -169,8 +185,11 @@ full_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
|
||||
#' @rdname join
|
||||
#' @export
|
||||
semi_join_microorganisms <- function(x, by = NULL, ...) {
|
||||
meet_criteria(x, allow_class = c("data.frame", "character"))
|
||||
meet_criteria(by, allow_class = "character", allow_NULL = TRUE)
|
||||
|
||||
check_dataset_integrity()
|
||||
check_groups_before_join(x, "semi_join_microorganisms")
|
||||
x <- check_groups_before_join(x, "semi_join_microorganisms")
|
||||
x_class <- get_prejoined_class(x)
|
||||
checked <- joins_check_df(x, by)
|
||||
x <- checked$x
|
||||
@@ -193,8 +212,11 @@ semi_join_microorganisms <- function(x, by = NULL, ...) {
|
||||
#' @rdname join
|
||||
#' @export
|
||||
anti_join_microorganisms <- function(x, by = NULL, ...) {
|
||||
meet_criteria(x, allow_class = c("data.frame", "character"))
|
||||
meet_criteria(by, allow_class = "character", allow_NULL = TRUE)
|
||||
|
||||
check_dataset_integrity()
|
||||
check_groups_before_join(x, "anti_join_microorganisms")
|
||||
x <- check_groups_before_join(x, "anti_join_microorganisms")
|
||||
checked <- joins_check_df(x, by)
|
||||
x_class <- get_prejoined_class(x)
|
||||
x <- checked$x
|
||||
@@ -233,7 +255,7 @@ joins_check_df <- function(x, by) {
|
||||
stop("Cannot join - no column found with name 'mo' or with class <mo>.", call. = FALSE)
|
||||
}
|
||||
}
|
||||
message('Joining, by = "', by, '"') # message same as dplyr::join functions
|
||||
message_('Joining, by = "', by, '"', add_fn = font_black, as_note = FALSE) # message same as dplyr::join functions
|
||||
}
|
||||
if (is.null(names(by))) {
|
||||
joinby <- colnames(microorganisms)[1]
|
||||
@@ -255,6 +277,10 @@ get_prejoined_class <- function(x) {
|
||||
|
||||
check_groups_before_join <- function(x, fn) {
|
||||
if (is.data.frame(x) && !is.null(attributes(x)$groups)) {
|
||||
warning("Groups are dropped, since the ", fn, "() function relies on merge() from base R, not on join() from dplyr.", call. = FALSE)
|
||||
x <- pm_ungroup(x)
|
||||
attr(x, "groups") <- NULL
|
||||
class(x) <- class(x)[!class(x) %like% "group"]
|
||||
warning_("Groups are dropped, since the ", fn, "() function relies on merge() from base R.", call = FALSE)
|
||||
}
|
||||
x
|
||||
}
|
||||
+59
-26
@@ -25,17 +25,20 @@
|
||||
|
||||
#' Key antibiotics for first *weighted* isolates
|
||||
#'
|
||||
#' These function can be used to determine first isolates (see [first_isolate()]). Using key antibiotics to determine first isolates is more reliable than without key antibiotics. These selected isolates will then be called first *weighted* isolates.
|
||||
#' These function can be used to determine first isolates (see [first_isolate()]). Using key antibiotics to determine first isolates is more reliable than without key antibiotics. These selected isolates can then be called first *weighted* isolates.
|
||||
#' @inheritSection lifecycle Stable lifecycle
|
||||
#' @param x table with antibiotics coloms, like `AMX` or `amox`
|
||||
#' @param y,z characters to compare
|
||||
#' @param x a [data.frame] with antibiotics columns, like `AMX` or `amox`. Can be omitted when used inside `dplyr` verbs, such as `filter()`, `mutate()` and `summarise()`.
|
||||
#' @param y,z character vectors to compare
|
||||
#' @inheritParams first_isolate
|
||||
#' @param universal_1,universal_2,universal_3,universal_4,universal_5,universal_6 column names of **broad-spectrum** antibiotics, case-insensitive. At default, the columns containing these antibiotics will be guessed with [guess_ab_col()].
|
||||
#' @param GramPos_1,GramPos_2,GramPos_3,GramPos_4,GramPos_5,GramPos_6 column names of antibiotics for **Gram-positives**, case-insensitive. At default, the columns containing these antibiotics will be guessed with [guess_ab_col()].
|
||||
#' @param GramNeg_1,GramNeg_2,GramNeg_3,GramNeg_4,GramNeg_5,GramNeg_6 column names of antibiotics for **Gram-negatives**, case-insensitive. At default, the columns containing these antibiotics will be guessed with [guess_ab_col()].
|
||||
#' @param warnings give warning about missing antibiotic columns, they will anyway be ignored
|
||||
#' @param ... other parameters passed on to function
|
||||
#' @details The function [key_antibiotics()] returns a character vector with 12 antibiotic results for every isolate. These isolates can then be compared using [key_antibiotics_equal()], to check if two isolates have generally the same antibiogram. Missing and invalid values are replaced with a dot (`"."`) by [key_antibiotics()] and ignored by [key_antibiotics_equal()].
|
||||
#' @param universal_1,universal_2,universal_3,universal_4,universal_5,universal_6 column names of **broad-spectrum** antibiotics, case-insensitive. See details for which antibiotics will be used at default (which are guessed with [guess_ab_col()]).
|
||||
#' @param GramPos_1,GramPos_2,GramPos_3,GramPos_4,GramPos_5,GramPos_6 column names of antibiotics for **Gram-positives**, case-insensitive. See details for which antibiotics will be used at default (which are guessed with [guess_ab_col()]).
|
||||
#' @param GramNeg_1,GramNeg_2,GramNeg_3,GramNeg_4,GramNeg_5,GramNeg_6 column names of antibiotics for **Gram-negatives**, case-insensitive. See details for which antibiotics will be used at default (which are guessed with [guess_ab_col()]).
|
||||
#' @param warnings give a warning about missing antibiotic columns (they will be ignored)
|
||||
#' @param ... other parameters passed on to functions
|
||||
#' @details
|
||||
#' The [key_antibiotics()] function is context-aware when used inside `dplyr` verbs, such as `filter()`, `mutate()` and `summarise()`. This means that then the `x` parameter can be omitted, please see *Examples*.
|
||||
#'
|
||||
#' The function [key_antibiotics()] returns a character vector with 12 antibiotic results for every isolate. These isolates can then be compared using [key_antibiotics_equal()], to check if two isolates have generally the same antibiogram. Missing and invalid values are replaced with a dot (`"."`) by [key_antibiotics()] and ignored by [key_antibiotics_equal()].
|
||||
#'
|
||||
#' The [first_isolate()] function only uses this function on the same microbial species from the same patient. Using this, e.g. an MRSA will be included after a susceptible *S. aureus* (MSSA) is found within the same patient episode. Without key antibiotic comparison it would not. See [first_isolate()] for more info.
|
||||
#'
|
||||
@@ -77,30 +80,30 @@
|
||||
#' # `example_isolates` is a dataset available in the AMR package.
|
||||
#' # See ?example_isolates.
|
||||
#'
|
||||
#' # output of the `key_antibiotics` function could be like this:
|
||||
#' # output of the `key_antibiotics()` function could be like this:
|
||||
#' strainA <- "SSSRR.S.R..S"
|
||||
#' strainB <- "SSSIRSSSRSSS"
|
||||
#'
|
||||
#' # can those strings can be compared with:
|
||||
#' # those strings can be compared with:
|
||||
#' key_antibiotics_equal(strainA, strainB)
|
||||
#' # TRUE, because I is ignored (as well as missing values)
|
||||
#'
|
||||
#' key_antibiotics_equal(strainA, strainB, ignore_I = FALSE)
|
||||
#' # FALSE, because I is not ignored and so the 4th value differs
|
||||
#' # FALSE, because I is not ignored and so the 4th character differs
|
||||
#'
|
||||
#' \donttest{
|
||||
#' if (require("dplyr")) {
|
||||
#' # set key antibiotics to a new variable
|
||||
#' my_patients <- example_isolates %>%
|
||||
#' mutate(keyab = key_antibiotics(.)) %>%
|
||||
#' mutate(keyab = key_antibiotics()) %>% # no need to define `x`
|
||||
#' mutate(
|
||||
#' # now calculate first isolates
|
||||
#' first_regular = first_isolate(., col_keyantibiotics = FALSE),
|
||||
#' first_regular = first_isolate(col_keyantibiotics = FALSE),
|
||||
#' # and first WEIGHTED isolates
|
||||
#' first_weighted = first_isolate(., col_keyantibiotics = "keyab")
|
||||
#' first_weighted = first_isolate(col_keyantibiotics = "keyab")
|
||||
#' )
|
||||
#'
|
||||
#' # Check the difference, in this data set it results in 7% more isolates:
|
||||
#' # Check the difference, in this data set it results in a lot more isolates:
|
||||
#' sum(my_patients$first_regular, na.rm = TRUE)
|
||||
#' sum(my_patients$first_weighted, na.rm = TRUE)
|
||||
#' }
|
||||
@@ -127,6 +130,30 @@ key_antibiotics <- function(x,
|
||||
GramNeg_6 = guess_ab_col(x, "meropenem"),
|
||||
warnings = TRUE,
|
||||
...) {
|
||||
if (missing(x)) {
|
||||
x <- get_current_data(arg_name = "x", call = -2)
|
||||
}
|
||||
meet_criteria(x, allow_class = "data.frame")
|
||||
meet_criteria(col_mo, allow_class = "character", has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(universal_1, allow_class = "character", has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(universal_2, allow_class = "character", has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(universal_3, allow_class = "character", has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(universal_4, allow_class = "character", has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(universal_5, allow_class = "character", has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(universal_6, allow_class = "character", has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(GramPos_1, allow_class = "character", has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(GramPos_2, allow_class = "character", has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(GramPos_3, allow_class = "character", has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(GramPos_4, allow_class = "character", has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(GramPos_5, allow_class = "character", has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(GramPos_6, allow_class = "character", has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(GramNeg_1, allow_class = "character", has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(GramNeg_2, allow_class = "character", has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(GramNeg_3, allow_class = "character", has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(GramNeg_4, allow_class = "character", has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(GramNeg_5, allow_class = "character", has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(GramNeg_6, allow_class = "character", has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(warnings, allow_class = "logical", has_length = 1)
|
||||
|
||||
dots <- unlist(list(...))
|
||||
if (length(dots) != 0) {
|
||||
@@ -167,11 +194,11 @@ key_antibiotics <- function(x,
|
||||
}
|
||||
if (!all(col.list %in% colnames(x))) {
|
||||
if (warnings == TRUE) {
|
||||
warning("Some columns do not exist and will be ignored: ",
|
||||
col.list.bak[!(col.list %in% colnames(x))] %pm>% toString(),
|
||||
".\nTHIS MAY STRONGLY INFLUENCE THE OUTCOME.",
|
||||
immediate. = TRUE,
|
||||
call. = FALSE)
|
||||
warning_("Some columns do not exist and will be ignored: ",
|
||||
col.list.bak[!(col.list %in% colnames(x))] %pm>% toString(),
|
||||
".\nTHIS MAY STRONGLY INFLUENCE THE OUTCOME.",
|
||||
immediate = TRUE,
|
||||
call = FALSE)
|
||||
}
|
||||
}
|
||||
col.list
|
||||
@@ -206,7 +233,7 @@ key_antibiotics <- function(x,
|
||||
gram_positive <- gram_positive[!is.null(gram_positive)]
|
||||
gram_positive <- gram_positive[!is.na(gram_positive)]
|
||||
if (length(gram_positive) < 12) {
|
||||
warning("only using ", length(gram_positive), " different antibiotics as key antibiotics for Gram-positives. See ?key_antibiotics.", call. = FALSE)
|
||||
warning_("Only using ", length(gram_positive), " different antibiotics as key antibiotics for Gram-positives. See ?key_antibiotics.", call = FALSE)
|
||||
}
|
||||
|
||||
gram_negative <- c(universal,
|
||||
@@ -215,7 +242,7 @@ key_antibiotics <- function(x,
|
||||
gram_negative <- gram_negative[!is.null(gram_negative)]
|
||||
gram_negative <- gram_negative[!is.na(gram_negative)]
|
||||
if (length(gram_negative) < 12) {
|
||||
warning("only using ", length(gram_negative), " different antibiotics as key antibiotics for Gram-negatives. See ?key_antibiotics.", call. = FALSE)
|
||||
warning_("Only using ", length(gram_negative), " different antibiotics as key antibiotics for Gram-negatives. See ?key_antibiotics.", call = FALSE)
|
||||
}
|
||||
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||
@@ -243,7 +270,7 @@ key_antibiotics <- function(x,
|
||||
key_abs <- toupper(gsub("[^SIR]", ".", gsub("(NA|NULL)", ".", x$key_ab)))
|
||||
|
||||
if (pm_n_distinct(key_abs) == 1) {
|
||||
warning("No distinct key antibiotics determined.", call. = FALSE)
|
||||
warning_("No distinct key antibiotics determined.", call = FALSE)
|
||||
}
|
||||
|
||||
key_abs
|
||||
@@ -258,14 +285,20 @@ key_antibiotics_equal <- function(y,
|
||||
ignore_I = TRUE,
|
||||
points_threshold = 2,
|
||||
info = FALSE) {
|
||||
meet_criteria(y, allow_class = "character")
|
||||
meet_criteria(z, allow_class = "character")
|
||||
meet_criteria(type, allow_class = "character", has_length = c(1, 2))
|
||||
meet_criteria(ignore_I, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(points_threshold, allow_class = c("numeric", "integer"), has_length = 1)
|
||||
meet_criteria(info, allow_class = "logical", has_length = 1)
|
||||
|
||||
stop_ifnot(length(y) == length(z), "length of `y` and `z` must be equal")
|
||||
# y is active row, z is lag
|
||||
x <- y
|
||||
y <- z
|
||||
|
||||
type <- type[1]
|
||||
|
||||
stop_ifnot(length(x) == length(y), "length of `x` and `y` must be equal")
|
||||
|
||||
# only show progress bar on points or when at least 5000 isolates
|
||||
info_needed <- info == TRUE & (type == "points" | length(x) > 5000)
|
||||
|
||||
|
||||
@@ -35,6 +35,8 @@
|
||||
#' @inheritSection AMR Read more on our website!
|
||||
#' @export
|
||||
kurtosis <- function(x, na.rm = FALSE, excess = FALSE) {
|
||||
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(excess, allow_class = "logical", has_length = 1)
|
||||
UseMethod("kurtosis")
|
||||
}
|
||||
|
||||
@@ -42,6 +44,8 @@ kurtosis <- function(x, na.rm = FALSE, excess = FALSE) {
|
||||
#' @rdname kurtosis
|
||||
#' @export
|
||||
kurtosis.default <- function(x, na.rm = FALSE, excess = FALSE) {
|
||||
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(excess, allow_class = "logical", has_length = 1)
|
||||
x <- as.vector(x)
|
||||
if (na.rm == TRUE) {
|
||||
x <- x[!is.na(x)]
|
||||
@@ -56,6 +60,8 @@ kurtosis.default <- function(x, na.rm = FALSE, excess = FALSE) {
|
||||
#' @rdname kurtosis
|
||||
#' @export
|
||||
kurtosis.matrix <- function(x, na.rm = FALSE, excess = FALSE) {
|
||||
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(excess, allow_class = "logical", has_length = 1)
|
||||
apply(x, 2, kurtosis.default, na.rm = na.rm, excess = excess)
|
||||
}
|
||||
|
||||
@@ -63,5 +69,7 @@ kurtosis.matrix <- function(x, na.rm = FALSE, excess = FALSE) {
|
||||
#' @rdname kurtosis
|
||||
#' @export
|
||||
kurtosis.data.frame <- function(x, na.rm = FALSE, excess = FALSE) {
|
||||
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(excess, allow_class = "logical", has_length = 1)
|
||||
sapply(x, kurtosis.default, na.rm = na.rm, excess = excess)
|
||||
}
|
||||
@@ -23,7 +23,7 @@
|
||||
# how to conduct AMR analysis: https://msberends.github.io/AMR/ #
|
||||
# ==================================================================== #
|
||||
|
||||
#' Pattern Matching
|
||||
#' Pattern matching with keyboard shortcut
|
||||
#'
|
||||
#' Convenient wrapper around [grep()] to match a pattern: `x %like% pattern`. It always returns a [`logical`] vector and is always case-insensitive (use `x %like_case% pattern` for case-sensitive matching). Also, `pattern` can be as long as `x` to compare items of each index in both vectors, or they both can have the same length to iterate over all cases.
|
||||
#' @inheritSection lifecycle Stable lifecycle
|
||||
@@ -41,7 +41,7 @@
|
||||
#' * Checks if `pattern` is a regular expression and sets `fixed = TRUE` if not, to greatly improve speed
|
||||
#' * Tries again with `perl = TRUE` if regex fails
|
||||
#'
|
||||
#' Using RStudio? This function can also be inserted from the Addins menu and can have its own Keyboard Shortcut like `Ctrl+Shift+L` or `Cmd+Shift+L` (see `Tools` > `Modify Keyboard Shortcuts...`).
|
||||
#' Using RStudio? The text `%like%` can also be directly inserted in your code from the Addins menu and can have its own Keyboard Shortcut like `Ctrl+Shift+L` or `Cmd+Shift+L` (see `Tools` > `Modify Keyboard Shortcuts...`).
|
||||
#' @source Idea from the [`like` function from the `data.table` package](https://github.com/Rdatatable/data.table/blob/master/R/like.R)
|
||||
#' @seealso [grep()]
|
||||
#' @inheritSection AMR Read more on our website!
|
||||
@@ -68,10 +68,14 @@
|
||||
#' }
|
||||
#' }
|
||||
like <- function(x, pattern, ignore.case = TRUE) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(pattern, allow_NA = FALSE)
|
||||
meet_criteria(ignore.case, allow_class = "logical", has_length = 1)
|
||||
|
||||
# set to fixed if no regex found
|
||||
fixed <- !any(is_possibly_regex(pattern))
|
||||
if (ignore.case == TRUE) {
|
||||
# set here, otherwise if fixed = TRUE, this warning will be thrown: argument 'ignore.case = TRUE' will be ignored
|
||||
# set here, otherwise if fixed = TRUE, this warning will be thrown: argument `ignore.case = TRUE` will be ignored
|
||||
x <- tolower(x)
|
||||
pattern <- tolower(pattern)
|
||||
}
|
||||
@@ -79,6 +83,10 @@ like <- function(x, pattern, ignore.case = TRUE) {
|
||||
if (length(pattern) > 1 & length(x) == 1) {
|
||||
x <- rep(x, length(pattern))
|
||||
}
|
||||
|
||||
if (all(is.na(x))) {
|
||||
return(rep(FALSE, length(x)))
|
||||
}
|
||||
|
||||
if (length(pattern) > 1) {
|
||||
res <- vector(length = length(pattern))
|
||||
@@ -137,18 +145,24 @@ like <- function(x, pattern, ignore.case = TRUE) {
|
||||
#' @rdname like
|
||||
#' @export
|
||||
"%like%" <- function(x, pattern) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(pattern, allow_NA = FALSE)
|
||||
like(x, pattern, ignore.case = TRUE)
|
||||
}
|
||||
|
||||
#' @rdname like
|
||||
#' @export
|
||||
"%like_case%" <- function(x, pattern) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(pattern, allow_NA = FALSE)
|
||||
like(x, pattern, ignore.case = FALSE)
|
||||
}
|
||||
|
||||
# don't export his one, it's just for convenience in eucast_rules()
|
||||
# match all Klebsiella and Raoultella, but not K. aerogenes: fullname %like_perl% "^(Klebsiella(?! aerogenes)|Raoultella)"
|
||||
"%like_perl%" <- function(x, pattern) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(pattern, allow_NA = FALSE)
|
||||
# convenient for e.g. matching all Klebsiella and Raoultella, but not
|
||||
# K. aerogenes: fullname %like_perl% "^(Klebsiella(?! aerogenes)|Raoultella)"
|
||||
grepl(x = tolower(x),
|
||||
pattern = tolower(pattern),
|
||||
perl = TRUE,
|
||||
|
||||
@@ -27,6 +27,7 @@
|
||||
#'
|
||||
#' Determine which isolates are multidrug-resistant organisms (MDRO) according to international and national guidelines.
|
||||
#' @inheritSection lifecycle Stable lifecycle
|
||||
#' @param x a [data.frame] with antibiotics columns, like `AMX` or `amox`. Can be omitted when used inside `dplyr` verbs, such as [`filter()`][dplyr::filter()], [`mutate()`][dplyr::mutate()] and [`summarise()`][dplyr::summarise()].
|
||||
#' @param guideline a specific guideline to follow. When left empty, the publication by Magiorakos *et al.* (2012, Clinical Microbiology and Infection) will be followed, please see *Details*.
|
||||
#' @inheritParams eucast_rules
|
||||
#' @param pct_required_classes minimal required percentage of antimicrobial classes that must be available per isolate, rounded down. For example, with the default guideline, 17 antimicrobial classes must be available for *S. aureus*. Setting this `pct_required_classes` argument to `0.5` (default) means that for every *S. aureus* isolate at least 8 different classes must be available. Any lower number of available classes will return `NA` for that isolate.
|
||||
@@ -34,23 +35,36 @@
|
||||
#' @param verbose a logical to turn Verbose mode on and off (default is off). In Verbose mode, the function does not return the MDRO results, but instead returns a data set in logbook form with extensive info about which isolates would be MDRO-positive, or why they are not.
|
||||
#' @inheritSection eucast_rules Antibiotics
|
||||
#' @details
|
||||
#' These functions are context-aware when used inside `dplyr` verbs, such as `filter()`, `mutate()` and `summarise()`. This means that then the `x` parameter can be omitted, please see *Examples*.
|
||||
#'
|
||||
#' For the `pct_required_classes` argument, values above 1 will be divided by 100. This is to support both fractions (`0.75` or `3/4`) and percentages (`75`).
|
||||
#'
|
||||
#' Currently supported guidelines are (case-insensitive):
|
||||
#'
|
||||
#' - `guideline = "CMI2012"`\cr
|
||||
#' Magiorakos AP, Srinivasan A *et al.* "Multidrug-resistant, extensively drug-resistant and pandrug-resistant bacteria: an international expert proposal for interim standard definitions for acquired resistance." Clinical Microbiology and Infection (2012) ([link](https://www.clinicalmicrobiologyandinfection.com/article/S1198-743X(14)61632-3/fulltext))
|
||||
#' - `guideline = "EUCAST3.2"` (or simply `guideline = "EUCAST"`)\cr
|
||||
#' The European international guideline - EUCAST Expert Rules Version 3.2 "Intrinsic Resistance and Unusual Phenotypes" ([link](https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/2020/Intrinsic_Resistance_and_Unusual_Phenotypes_Tables_v3.2_20200225.pdf))
|
||||
#' - `guideline = "EUCAST3.1"`\cr
|
||||
#' The European international guideline - EUCAST Expert Rules Version 3.1 "Intrinsic Resistance and Exceptional Phenotypes Tables" ([link](https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/Expert_rules_intrinsic_exceptional_V3.1.pdf))
|
||||
#' - `guideline = "TB"`\cr
|
||||
#' The international guideline for multi-drug resistant tuberculosis - World Health Organization "Companion handbook to the WHO guidelines for the programmatic management of drug-resistant tuberculosis" ([link](https://www.who.int/tb/publications/pmdt_companionhandbook/en/))
|
||||
#' - `guideline = "MRGN"`\cr
|
||||
#' The German national guideline - Mueller et al. (2015) Antimicrobial Resistance and Infection Control 4:7. DOI: 10.1186/s13756-015-0047-6
|
||||
#' - `guideline = "BRMO"`\cr
|
||||
#' The Dutch national guideline - Rijksinstituut voor Volksgezondheid en Milieu "WIP-richtlijn BRMO (Bijzonder Resistente Micro-Organismen) (ZKH)" ([link](https://www.rivm.nl/wip-richtlijn-brmo-bijzonder-resistente-micro-organismen-zkh))
|
||||
#' * `guideline = "CMI2012"` (default)
|
||||
#'
|
||||
#' Magiorakos AP, Srinivasan A *et al.* "Multidrug-resistant, extensively drug-resistant and pandrug-resistant bacteria: an international expert proposal for interim standard definitions for acquired resistance." Clinical Microbiology and Infection (2012) ([link](https://www.clinicalmicrobiologyandinfection.com/article/S1198-743X(14)61632-3/fulltext))
|
||||
#'
|
||||
#' * `guideline = "EUCAST3.2"` (or simply `guideline = "EUCAST"`)
|
||||
#'
|
||||
#' The European international guideline - EUCAST Expert Rules Version 3.2 "Intrinsic Resistance and Unusual Phenotypes" ([link](https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/2020/Intrinsic_Resistance_and_Unusual_Phenotypes_Tables_v3.2_20200225.pdf))
|
||||
#'
|
||||
#' * `guideline = "EUCAST3.1"`
|
||||
#'
|
||||
#' The European international guideline - EUCAST Expert Rules Version 3.1 "Intrinsic Resistance and Exceptional Phenotypes Tables" ([link](https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/Expert_rules_intrinsic_exceptional_V3.1.pdf))
|
||||
#'
|
||||
#' * `guideline = "TB"`
|
||||
#'
|
||||
#' The international guideline for multi-drug resistant tuberculosis - World Health Organization "Companion handbook to the WHO guidelines for the programmatic management of drug-resistant tuberculosis" ([link](https://www.who.int/tb/publications/pmdt_companionhandbook/en/))
|
||||
#'
|
||||
#' * `guideline = "MRGN"`
|
||||
#'
|
||||
#' The German national guideline - Mueller et al. (2015) Antimicrobial Resistance and Infection Control 4:7. DOI: 10.1186/s13756-015-0047-6
|
||||
#'
|
||||
#' * `guideline = "BRMO"`
|
||||
#'
|
||||
#' The Dutch national guideline - Rijksinstituut voor Volksgezondheid en Milieu "WIP-richtlijn BRMO (Bijzonder Resistente Micro-Organismen) (ZKH)" ([link](https://www.rivm.nl/wip-richtlijn-brmo-bijzonder-resistente-micro-organismen-zkh))
|
||||
#'
|
||||
#' Please suggest your own (country-specific) guidelines by letting us know: <https://github.com/msberends/AMR/issues/new>.
|
||||
#'
|
||||
#' **Note:** Every test that involves the Enterobacteriaceae family, will internally be performed using its newly named *order* Enterobacterales, since the Enterobacteriaceae family has been taxonomically reclassified by Adeolu *et al.* in 2016. Before that, Enterobacteriaceae was the only family under the Enterobacteriales (with an i) order. All species under the old Enterobacteriaceae family are still under the new Enterobacterales (without an i) order, but divided into multiple families. The way tests are performed now by this [mdro()] function makes sure that results from before 2016 and after 2016 are identical.
|
||||
@@ -79,10 +93,12 @@
|
||||
#' mdro() %>%
|
||||
#' table()
|
||||
#'
|
||||
#' # no need to define `x` when used inside dplyr verbs:
|
||||
#' example_isolates %>%
|
||||
#' mutate(EUCAST = eucast_exceptional_phenotypes(.),
|
||||
#' BRMO = brmo(.),
|
||||
#' MRGN = mrgn(.))
|
||||
#' mutate(MDRO = mdro(),
|
||||
#' EUCAST = eucast_exceptional_phenotypes(),
|
||||
#' BRMO = brmo(),
|
||||
#' MRGN = mrgn())
|
||||
#' }
|
||||
#' }
|
||||
mdro <- function(x,
|
||||
@@ -93,6 +109,16 @@ mdro <- function(x,
|
||||
combine_SI = TRUE,
|
||||
verbose = FALSE,
|
||||
...) {
|
||||
if (missing(x)) {
|
||||
x <- get_current_data(arg_name = "x", call = -2)
|
||||
}
|
||||
meet_criteria(x, allow_class = "data.frame")
|
||||
meet_criteria(guideline, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(col_mo, allow_class = "character", has_length = 1, is_in = colnames(x), allow_NULL = TRUE)
|
||||
meet_criteria(info, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(pct_required_classes, allow_class = "numeric", has_length = 1)
|
||||
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(verbose, allow_class = "logical", has_length = 1)
|
||||
|
||||
check_dataset_integrity()
|
||||
|
||||
@@ -107,7 +133,7 @@ mdro <- function(x,
|
||||
q_continue <- utils::menu(choices = c("OK", "Cancel"), graphics = FALSE, title = txt)
|
||||
}
|
||||
if (q_continue %in% c(FALSE, 2)) {
|
||||
message("Cancelled, returning original data")
|
||||
message_("Cancelled, returning original data", add_fn = font_red, as_note = FALSE)
|
||||
return(x)
|
||||
}
|
||||
}
|
||||
@@ -125,12 +151,11 @@ mdro <- function(x,
|
||||
}
|
||||
|
||||
if (!is.null(list(...)$country)) {
|
||||
warning("Using `country` is deprecated, use `guideline` instead. Please see ?mdro.", call. = FALSE)
|
||||
warning_("Using `country` is deprecated, use `guideline` instead. Please see ?mdro.", call = FALSE)
|
||||
guideline <- list(...)$country
|
||||
}
|
||||
stop_ifnot(length(guideline) == 1, "`guideline` must be of length 1")
|
||||
|
||||
guideline.bak <- guideline
|
||||
|
||||
guideline.bak <- guideline
|
||||
guideline <- tolower(gsub("[^a-zA-Z0-9.]+", "", guideline))
|
||||
if (is.null(guideline)) {
|
||||
# default to the paper by Magiorakos et al. (2012)
|
||||
@@ -156,10 +181,10 @@ mdro <- function(x,
|
||||
col_mo <- search_type_in_df(x = x, type = "mo", info = info)
|
||||
}
|
||||
if (is.null(col_mo) & guideline$code == "tb") {
|
||||
message(font_blue("NOTE: No column found as input for `col_mo`,",
|
||||
font_bold("assuming all records contain", font_italic("Mycobacterium tuberculosis."))))
|
||||
x$mo <- as.mo("Mycobacterium tuberculosis")
|
||||
col_mo <- "mo"
|
||||
message_("No column found as input for `col_mo`, ",
|
||||
font_bold("assuming all records contain", font_italic("Mycobacterium tuberculosis.")))
|
||||
x$mo <- as.mo("Mycobacterium tuberculosis")
|
||||
col_mo <- "mo"
|
||||
}
|
||||
stop_if(is.null(col_mo), "`col_mo` must be set")
|
||||
stop_ifnot(col_mo %in% colnames(x), "column '", col_mo, "' (`col_mo`) not found")
|
||||
@@ -169,24 +194,28 @@ mdro <- function(x,
|
||||
guideline$author <- "Magiorakos AP, Srinivasan A, Carey RB, ..., Vatopoulos A, Weber JT, Monnet DL"
|
||||
guideline$version <- "N/A"
|
||||
guideline$source <- "Clinical Microbiology and Infection 18:3, 2012. DOI: 10.1111/j.1469-0691.2011.03570.x"
|
||||
|
||||
} else if (guideline$code == "eucast3.2") {
|
||||
guideline$name <- "EUCAST Expert Rules, \"Intrinsic Resistance and Unusual Phenotypes\""
|
||||
guideline$author <- "EUCAST (European Committee on Antimicrobial Susceptibility Testing)"
|
||||
guideline$version <- "3.2, 2020"
|
||||
guideline$source <- "https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/2020/Intrinsic_Resistance_and_Unusual_Phenotypes_Tables_v3.2_20200225.pdf"
|
||||
guideline$type <- "MDRs/XDRs/PDRs"
|
||||
|
||||
} else if (guideline$code == "eucast3.1") {
|
||||
guideline$name <- "EUCAST Expert Rules, \"Intrinsic Resistance and Exceptional Phenotypes Tables\""
|
||||
guideline$author <- "EUCAST (European Committee on Antimicrobial Susceptibility Testing)"
|
||||
guideline$version <- "3.1, 2016"
|
||||
guideline$source <- "https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/Expert_rules_intrinsic_exceptional_V3.1.pdf"
|
||||
guideline$type <- "EUCAST Exceptional Phenotypes"
|
||||
|
||||
} else if (guideline$code == "eucast3.2") {
|
||||
guideline$name <- "EUCAST Expert Rules, \"Intrinsic Resistance and Unusual Phenotypes\""
|
||||
guideline$author <- "EUCAST (European Committee on Antimicrobial Susceptibility Testing)"
|
||||
guideline$version <- "3.2, 2020"
|
||||
guideline$source <- "https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/2020/Intrinsic_Resistance_and_Unusual_Phenotypes_Tables_v3.2_20200225.pdf"
|
||||
guideline$type <- "EUCAST Unusual Phenotypes"
|
||||
|
||||
} else if (guideline$code == "tb") {
|
||||
guideline$name <- "Companion handbook to the WHO guidelines for the programmatic management of drug-resistant tuberculosis"
|
||||
guideline$author <- "WHO (World Health Organization)"
|
||||
guideline$version <- "WHO/HTM/TB/2014.11, 2014"
|
||||
guideline$source <- "https://www.who.int/tb/publications/pmdt_companionhandbook/en/"
|
||||
guideline$type <- "MDR-TB's"
|
||||
|
||||
# support per country:
|
||||
} else if (guideline$code == "mrgn") {
|
||||
@@ -194,12 +223,14 @@ mdro <- function(x,
|
||||
guideline$author <- "M\u00fcller J, Voss A, K\u00f6ck R, ..., Kern WV, Wendt C, Friedrich AW"
|
||||
guideline$version <- "N/A"
|
||||
guideline$source <- "Antimicrobial Resistance and Infection Control 4:7, 2015. DOI: 10.1186/s13756-015-0047-6"
|
||||
guideline$type <- "MRGNs"
|
||||
|
||||
} else if (guideline$code == "brmo") {
|
||||
guideline$name <- "WIP-Richtlijn Bijzonder Resistente Micro-organismen (BRMO)"
|
||||
guideline$author <- "RIVM (Rijksinstituut voor de Volksgezondheid)"
|
||||
guideline$version <- "Revision as of December 2017"
|
||||
guideline$source <- "https://www.rivm.nl/Documenten_en_publicaties/Professioneel_Praktisch/Richtlijnen/Infectieziekten/WIP_Richtlijnen/WIP_Richtlijnen/Ziekenhuizen/WIP_richtlijn_BRMO_Bijzonder_Resistente_Micro_Organismen_ZKH"
|
||||
guideline$type <- "BRMOs"
|
||||
} else {
|
||||
stop("This guideline is currently unsupported: ", guideline$code, call. = FALSE)
|
||||
}
|
||||
@@ -568,7 +599,9 @@ mdro <- function(x,
|
||||
cols <- cols[!ab_missing(cols)]
|
||||
cols <- cols[!is.na(cols)]
|
||||
if (length(rows) > 0 & length(cols) > 0) {
|
||||
x[, cols] <- as.data.frame(lapply(x[, cols, drop = FALSE], function(col) as.rsi(col)))
|
||||
x[, cols] <- as.data.frame(lapply(x[, cols, drop = FALSE],
|
||||
function(col) as.rsi(col)),
|
||||
stringsAsFactors = FALSE)
|
||||
x[rows, "columns_nonsusceptible"] <<- sapply(rows,
|
||||
function(row, group_vct = cols) {
|
||||
cols_nonsus <- sapply(x[row, group_vct, drop = FALSE],
|
||||
@@ -583,7 +616,8 @@ mdro <- function(x,
|
||||
} else if (any_all == "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))
|
||||
row_filter <- sapply(x_transposed, function(y) search_function(y %in% search_result, na.rm = TRUE))
|
||||
row_filter <- x[which(row_filter), "row_number", drop = TRUE]
|
||||
rows <- rows[rows %in% row_filter]
|
||||
@@ -593,12 +627,14 @@ mdro <- function(x,
|
||||
}
|
||||
trans_tbl2 <- function(txt, rows, lst) {
|
||||
if (info == TRUE) {
|
||||
message(font_blue(txt, "..."), appendLF = FALSE)
|
||||
message_(txt, "...", appendLF = FALSE, as_note = FALSE)
|
||||
}
|
||||
if (length(rows) > 0) {
|
||||
# function specific for the CMI paper of 2012 (Magiorakos et al.)
|
||||
lst_vector <- unlist(lst)[!is.na(unlist(lst))]
|
||||
x[, lst_vector] <- as.data.frame(lapply(x[, lst_vector, drop = FALSE], function(col) as.rsi(col)))
|
||||
x[, lst_vector] <- as.data.frame(lapply(x[, lst_vector, drop = FALSE],
|
||||
function(col) as.rsi(col)),
|
||||
stringsAsFactors = FALSE)
|
||||
x[rows, "classes_in_guideline"] <<- length(lst)
|
||||
x[rows, "classes_available"] <<- sapply(rows,
|
||||
function(row, group_tbl = lst) {
|
||||
@@ -621,17 +657,18 @@ mdro <- function(x,
|
||||
na.rm = TRUE)
|
||||
})
|
||||
# for PDR; all agents are R (or I if combine_SI = FALSE)
|
||||
x_transposed <- as.list(as.data.frame(t(x[rows, lst_vector, drop = FALSE])))
|
||||
x_transposed <- as.list(as.data.frame(t(x[rows, lst_vector, drop = FALSE]),
|
||||
stringsAsFactors = FALSE))
|
||||
row_filter <- sapply(x_transposed, function(y) all(y %in% search_result, na.rm = TRUE))
|
||||
x[which(row_filter), "classes_affected"] <<- 999
|
||||
}
|
||||
|
||||
if (info == TRUE) {
|
||||
message(font_blue(" OK"))
|
||||
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
|
||||
}
|
||||
}
|
||||
|
||||
x[, col_mo] <- as.mo(x[, col_mo, drop = TRUE])
|
||||
x[, col_mo] <- as.mo(as.character(x[, col_mo, drop = TRUE]))
|
||||
# join to microorganisms data set
|
||||
x <- left_join_microorganisms(x, by = col_mo)
|
||||
x$MDRO <- ifelse(!is.na(x$genus), 1, NA_integer_)
|
||||
@@ -647,20 +684,20 @@ mdro <- function(x,
|
||||
# take amoxicillin if ampicillin is unavailable
|
||||
if (is.na(AMP) & !is.na(AMX)) {
|
||||
if (verbose == TRUE) {
|
||||
message(font_blue("NOTE: Filling ampicillin (AMP) results with amoxicillin (AMX) results"))
|
||||
message_("Filling ampicillin (AMP) results with amoxicillin (AMX) results")
|
||||
}
|
||||
AMP <- AMX
|
||||
}
|
||||
# take ceftriaxone if cefotaxime is unavailable and vice versa
|
||||
if (is.na(CRO) & !is.na(CTX)) {
|
||||
if (verbose == TRUE) {
|
||||
message(font_blue("NOTE: Filling ceftriaxone (CRO) results with cefotaxime (CTX) results"))
|
||||
message_("Filling ceftriaxone (CRO) results with cefotaxime (CTX) results")
|
||||
}
|
||||
CRO <- CTX
|
||||
}
|
||||
if (is.na(CTX) & !is.na(CRO)) {
|
||||
if (verbose == TRUE) {
|
||||
message(font_blue("NOTE: Filling cefotaxime (CTX) results with ceftriaxone (CRO) results"))
|
||||
message_("Filling cefotaxime (CTX) results with ceftriaxone (CRO) results")
|
||||
}
|
||||
CTX <- CRO
|
||||
}
|
||||
@@ -1182,7 +1219,7 @@ mdro <- function(x,
|
||||
if (sum(!is.na(x$MDRO) == 0)) {
|
||||
cat(font_bold(paste0("=> Found 0 MDROs since no isolates are covered by the guideline")))
|
||||
} else {
|
||||
cat(font_bold(paste0("=> Found ", sum(x$MDRO %in% c(2:5), na.rm = TRUE), " MDROs out of ", sum(!is.na(x$MDRO)),
|
||||
cat(font_bold(paste0("=> Found ", sum(x$MDRO %in% c(2:5), na.rm = TRUE), " ", guideline$type, " out of ", sum(!is.na(x$MDRO)),
|
||||
" isolates (", trimws(percentage(sum(x$MDRO %in% c(2:5), na.rm = TRUE) / sum(!is.na(x$MDRO)))), ")\n")))
|
||||
}
|
||||
}
|
||||
@@ -1199,7 +1236,7 @@ mdro <- function(x,
|
||||
# Results ----
|
||||
if (guideline$code == "cmi2012") {
|
||||
if (any(x$MDRO == -1, na.rm = TRUE)) {
|
||||
warning("NA introduced for isolates where the available percentage of antimicrobial classes was below ",
|
||||
warning_("NA introduced for isolates where the available percentage of antimicrobial classes was below ",
|
||||
percentage(pct_required_classes), " (set with `pct_required_classes`)")
|
||||
# set these -1s to NA
|
||||
x[which(x$MDRO == -1), "MDRO"] <- NA_integer_
|
||||
@@ -1243,29 +1280,54 @@ mdro <- function(x,
|
||||
#' @rdname mdro
|
||||
#' @export
|
||||
brmo <- function(x, guideline = "BRMO", ...) {
|
||||
if (missing(x)) {
|
||||
x <- get_current_data(arg_name = "x", call = -2)
|
||||
}
|
||||
meet_criteria(x, allow_class = "data.frame")
|
||||
meet_criteria(guideline, allow_class = "character", has_length = 1)
|
||||
mdro(x, guideline = "BRMO", ...)
|
||||
}
|
||||
|
||||
#' @rdname mdro
|
||||
#' @export
|
||||
mrgn <- function(x, guideline = "MRGN", ...) {
|
||||
if (missing(x)) {
|
||||
x <- get_current_data(arg_name = "x", call = -2)
|
||||
}
|
||||
meet_criteria(x, allow_class = "data.frame")
|
||||
meet_criteria(guideline, allow_class = "character", has_length = 1)
|
||||
mdro(x = x, guideline = "MRGN", ...)
|
||||
}
|
||||
|
||||
#' @rdname mdro
|
||||
#' @export
|
||||
mdr_tb <- function(x, guideline = "TB", ...) {
|
||||
if (missing(x)) {
|
||||
x <- get_current_data(arg_name = "x", call = -2)
|
||||
}
|
||||
meet_criteria(x, allow_class = "data.frame")
|
||||
meet_criteria(guideline, allow_class = "character", has_length = 1)
|
||||
mdro(x = x, guideline = "TB", ...)
|
||||
}
|
||||
|
||||
#' @rdname mdro
|
||||
#' @export
|
||||
mdr_cmi2012 <- function(x, guideline = "CMI2012", ...) {
|
||||
if (missing(x)) {
|
||||
x <- get_current_data(arg_name = "x", call = -2)
|
||||
}
|
||||
meet_criteria(x, allow_class = "data.frame")
|
||||
meet_criteria(guideline, allow_class = "character", has_length = 1)
|
||||
mdro(x = x, guideline = "CMI2012", ...)
|
||||
}
|
||||
|
||||
#' @rdname mdro
|
||||
#' @export
|
||||
eucast_exceptional_phenotypes <- function(x, guideline = "EUCAST", ...) {
|
||||
if (missing(x)) {
|
||||
x <- get_current_data(arg_name = "x", call = -2)
|
||||
}
|
||||
meet_criteria(x, allow_class = "data.frame")
|
||||
meet_criteria(guideline, allow_class = "character", has_length = 1)
|
||||
mdro(x = x, guideline = "EUCAST", ...)
|
||||
}
|
||||
@@ -56,6 +56,9 @@
|
||||
#' plot(mic_data)
|
||||
#' barplot(mic_data)
|
||||
as.mic <- function(x, na.rm = FALSE) {
|
||||
meet_criteria(x, allow_class = c("mic", "character", "numeric", "integer"), allow_NA = TRUE)
|
||||
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
|
||||
|
||||
if (is.mic(x)) {
|
||||
x
|
||||
} else {
|
||||
@@ -122,21 +125,24 @@ as.mic <- function(x, na.rm = FALSE) {
|
||||
unique() %pm>%
|
||||
sort()
|
||||
list_missing <- paste0('"', list_missing, '"', collapse = ", ")
|
||||
warning(na_after - na_before, " results truncated (",
|
||||
round(((na_after - na_before) / length(x)) * 100),
|
||||
"%) that were invalid MICs: ",
|
||||
list_missing, call. = FALSE)
|
||||
warning_(na_after - na_before, " results truncated (",
|
||||
round(((na_after - na_before) / length(x)) * 100),
|
||||
"%) that were invalid MICs: ",
|
||||
list_missing, call = FALSE)
|
||||
}
|
||||
|
||||
structure(.Data = factor(x, levels = lvls, ordered = TRUE),
|
||||
class = c("mic", "ordered", "factor"))
|
||||
set_clean_class(factor(x, levels = lvls, ordered = TRUE),
|
||||
new_class = c("mic", "ordered", "factor"))
|
||||
}
|
||||
}
|
||||
|
||||
all_valid_mics <- function(x) {
|
||||
if (!inherits(x, c("mic", "character", "factor", "numeric", "integer"))) {
|
||||
return(FALSE)
|
||||
}
|
||||
x_mic <- tryCatch(suppressWarnings(as.mic(x[!is.na(x)])),
|
||||
error = function(e) NA)
|
||||
!any(is.na(x_mic)) & !all(is.na(x))
|
||||
!any(is.na(x_mic)) && !all(is.na(x))
|
||||
}
|
||||
|
||||
#' @rdname as.mic
|
||||
@@ -149,27 +155,27 @@ is.mic <- function(x) {
|
||||
#' @export
|
||||
#' @noRd
|
||||
as.double.mic <- function(x, ...) {
|
||||
as.double(gsub("(<|=|>)+", "", as.character(x)))
|
||||
as.double(gsub("[<=>]+", "", as.character(x)))
|
||||
}
|
||||
|
||||
#' @method as.integer mic
|
||||
#' @export
|
||||
#' @noRd
|
||||
as.integer.mic <- function(x, ...) {
|
||||
as.integer(gsub("(<|=|>)+", "", as.character(x)))
|
||||
as.integer(gsub("[<=>]+", "", as.character(x)))
|
||||
}
|
||||
|
||||
#' @method as.numeric mic
|
||||
#' @export
|
||||
#' @noRd
|
||||
as.numeric.mic <- function(x, ...) {
|
||||
as.numeric(gsub("(<|=|>)+", "", as.character(x)))
|
||||
as.numeric(gsub("[<=>]+", "", as.character(x)))
|
||||
}
|
||||
|
||||
#' @method droplevels mic
|
||||
#' @export
|
||||
#' @noRd
|
||||
droplevels.mic <- function(x, exclude = ifelse(anyNA(levels(x)), NULL, NA), ...) {
|
||||
droplevels.mic <- function(x, exclude = if (any(is.na(levels(x)))) NULL else NA, ...) {
|
||||
x <- droplevels.factor(x, exclude = exclude, ...)
|
||||
class(x) <- c("mic", "ordered", "factor")
|
||||
x
|
||||
@@ -177,9 +183,13 @@ droplevels.mic <- function(x, exclude = ifelse(anyNA(levels(x)), NULL, NA), ...)
|
||||
|
||||
# will be exported using s3_register() in R/zzz.R
|
||||
pillar_shaft.mic <- function(x, ...) {
|
||||
out <- trimws(format(x))
|
||||
crude_numbers <- as.double(x)
|
||||
operators <- gsub("[^<=>]+", "", as.character(x))
|
||||
pasted <- trimws(paste0(operators, trimws(format(crude_numbers))))
|
||||
out <- pasted
|
||||
out[is.na(x)] <- font_na(NA)
|
||||
create_pillar_column(out, align = "right", min_width = 4)
|
||||
out <- gsub("(<|=|>)", font_silver("\\1"), out)
|
||||
create_pillar_column(out, align = "right", width = max(nchar(pasted)))
|
||||
}
|
||||
|
||||
# will be exported using s3_register() in R/zzz.R
|
||||
@@ -213,7 +223,7 @@ summary.mic <- function(object, ...) {
|
||||
|
||||
#' @method plot mic
|
||||
#' @export
|
||||
#' @importFrom graphics barplot axis par
|
||||
#' @importFrom graphics barplot axis
|
||||
#' @rdname plot
|
||||
plot.mic <- function(x,
|
||||
main = paste("MIC values of", deparse(substitute(x))),
|
||||
@@ -221,13 +231,18 @@ plot.mic <- function(x,
|
||||
xlab = "MIC value",
|
||||
axes = FALSE,
|
||||
...) {
|
||||
barplot(table(droplevels.factor(x)),
|
||||
meet_criteria(main, 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(axes, allow_class = "logical", has_length = 1)
|
||||
|
||||
barplot(table(as.double(x)),
|
||||
ylab = ylab,
|
||||
xlab = xlab,
|
||||
axes = axes,
|
||||
main = main,
|
||||
...)
|
||||
axis(2, seq(0, max(table(droplevels.factor(x)))))
|
||||
axis(2, seq(0, max(table(as.double(x)))))
|
||||
}
|
||||
|
||||
#' @method barplot mic
|
||||
@@ -240,13 +255,18 @@ barplot.mic <- function(height,
|
||||
xlab = "MIC value",
|
||||
axes = FALSE,
|
||||
...) {
|
||||
barplot(table(droplevels.factor(height)),
|
||||
meet_criteria(main, 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(axes, allow_class = "logical", has_length = 1)
|
||||
|
||||
barplot(table(as.double(height)),
|
||||
ylab = ylab,
|
||||
xlab = xlab,
|
||||
axes = axes,
|
||||
main = main,
|
||||
...)
|
||||
axis(2, seq(0, max(table(droplevels.factor(height)))))
|
||||
axis(2, seq(0, max(table(as.double(height)))))
|
||||
}
|
||||
|
||||
#' @method [ mic
|
||||
@@ -303,14 +323,12 @@ unique.mic <- function(x, incomparables = FALSE, ...) {
|
||||
|
||||
# will be exported using s3_register() in R/zzz.R
|
||||
get_skimmers.mic <- function(column) {
|
||||
sfl <- import_fn("sfl", "skimr", error_on_fail = FALSE)
|
||||
inline_hist <- import_fn("inline_hist", "skimr", error_on_fail = FALSE)
|
||||
sfl(
|
||||
skimr::sfl(
|
||||
skim_type = "mic",
|
||||
min = ~as.character(sort(na.omit(.))[1]),
|
||||
min = ~as.character(sort(stats::na.omit(.))[1]),
|
||||
max = ~as.character(sort(stats::na.omit(.))[length(stats::na.omit(.))]),
|
||||
median = ~as.character(stats::na.omit(.)[as.double(stats::na.omit(.)) == median(as.double(stats::na.omit(.)))])[1],
|
||||
n_unique = ~pm_n_distinct(., na.rm = TRUE),
|
||||
hist_log2 = ~inline_hist(log2(as.double(stats::na.omit(.))))
|
||||
hist_log2 = ~skimr::inline_hist(log2(as.double(stats::na.omit(.))))
|
||||
)
|
||||
}
|
||||
@@ -25,7 +25,9 @@
|
||||
|
||||
#' Calculate the matching score for microorganisms
|
||||
#'
|
||||
#' This helper function is used by [as.mo()] to determine the most probable match of taxonomic records, based on user input.
|
||||
#' This algorithm is used by [as.mo()] and all the [`mo_*`][mo_property()] functions to determine the most probable match of taxonomic records based on user input.
|
||||
#' @inheritSection lifecycle Stable lifecycle
|
||||
#' @author Matthijs S. Berends
|
||||
#' @param x Any user input value(s)
|
||||
#' @param n A full taxonomic name, that exists in [`microorganisms$fullname`][microorganisms]
|
||||
#' @section Matching score for microorganisms:
|
||||
@@ -53,6 +55,9 @@
|
||||
#' mo_matching_score(x = "E. coli",
|
||||
#' n = c("Escherichia coli", "Entamoeba coli"))
|
||||
mo_matching_score <- function(x, n) {
|
||||
meet_criteria(x, allow_class = c("character", "data.frame", "list"))
|
||||
meet_criteria(n, allow_class = "character")
|
||||
|
||||
x <- parse_and_convert(x)
|
||||
# no dots and other non-whitespace characters
|
||||
x <- gsub("[^a-zA-Z0-9 \\(\\)]+", "", x)
|
||||
|
||||
+215
-48
@@ -9,7 +9,7 @@
|
||||
# (c) 2018-2020 Berends MS, Luz CF et al. #
|
||||
# Developed at the University of Groningen, the Netherlands, in #
|
||||
# collaboration with non-profit organisations Certe Medical #
|
||||
# Diagnostics & Advice, and University Medical Center Groningen. #
|
||||
# Diagnostics & Advice, and University Medical Center Groningen. #
|
||||
# #
|
||||
# This R package is free software; you can freely use and distribute #
|
||||
# it for both personal and commercial purposes under the terms of the #
|
||||
@@ -27,21 +27,24 @@
|
||||
#'
|
||||
#' Use these functions to return a specific property of a microorganism based on the latest accepted taxonomy. All input values will be evaluated internally with [as.mo()], which makes it possible to use microbial abbreviations, codes and names as input. Please see *Examples*.
|
||||
#' @inheritSection lifecycle Stable lifecycle
|
||||
#' @param x any (vector of) text that can be coerced to a valid microorganism code with [as.mo()]
|
||||
#' @param property one of the column names of the [microorganisms] data set or `"shortname"`
|
||||
#' @param language language of the returned text, defaults to system language (see [get_locale()]) and can be overwritten by setting the option `AMR_locale`, e.g. `options(AMR_locale = "de")`, see [translate]. Use `language = NULL` or `language = ""` to prevent translation.
|
||||
#' @param x any character (vector) that can be coerced to a valid microorganism code with [as.mo()]. Can be omitted for auto-guessing in `mo_is_*()` functions when used inside `dplyr` verbs, such as [`filter()`][dplyr::filter()], [`mutate()`][dplyr::mutate()] and [`summarise()`][dplyr::summarise()], please see *Examples*.
|
||||
#' @param property one of the column names of the [microorganisms] data set: `r paste0('"``', colnames(microorganisms), '\``"', collapse = ", ")`, or must be `"shortname"`
|
||||
#' @param language language of the returned text, defaults to system language (see [get_locale()]) and can be overwritten by setting the option `AMR_locale`, e.g. `options(AMR_locale = "de")`, see [translate]. Also used to translate text like "no growth". Use `language = NULL` or `language = ""` to prevent translation.
|
||||
#' @param ... other parameters passed on to [as.mo()], such as 'allow_uncertain' and 'ignore_pattern'
|
||||
#' @param ab any (vector of) text that can be coerced to a valid antibiotic code with [as.ab()]
|
||||
#' @param open browse the URL using [utils::browseURL()]
|
||||
#' @details All functions will return the most recently known taxonomic property according to the Catalogue of Life, except for [mo_ref()], [mo_authors()] and [mo_year()]. Please refer to this example, knowing that *Escherichia blattae* was renamed to *Shimwellia blattae* in 2010:
|
||||
#' - `mo_name("Escherichia blattae")` will return `"Shimwellia blattae"` (with a message about the renaming)
|
||||
#' - `mo_ref("Escherichia blattae")` will return `"Burgess et al., 1973"` (with a message about the renaming)
|
||||
#' - `mo_ref("Shimwellia blattae")` will return `"Priest et al., 2010"` (without a message)
|
||||
#'
|
||||
#' The short name - [mo_shortname()] - almost always returns the first character of the genus and the full species, like `"E. coli"`. Exceptions are abbreviations of staphylococci (like *"CoNS"*, Coagulase-Negative Staphylococci) and beta-haemolytic streptococci (like *"GBS"*, Group B Streptococci). Please bear in mind that e.g. *E. coli* could mean *Escherichia coli* (kingdom of Bacteria) as well as *Entamoeba coli* (kingdom of Protozoa). Returning to the full name will be done using [as.mo()] internally, giving priority to bacteria and human pathogens, i.e. `"E. coli"` will be considered *Escherichia coli*. In other words, `mo_fullname(mo_shortname("Entamoeba coli"))` returns `"Escherichia coli"`.
|
||||
#'
|
||||
#' The short name - [mo_shortname()] - almost always returns the first character of the genus and the full species, like `"E. coli"`. Exceptions are abbreviations of staphylococci (such as *"CoNS"*, Coagulase-Negative Staphylococci) and beta-haemolytic streptococci (such as *"GBS"*, Group B Streptococci). Please bear in mind that e.g. *E. coli* could mean *Escherichia coli* (kingdom of Bacteria) as well as *Entamoeba coli* (kingdom of Protozoa). Returning to the full name will be done using [as.mo()] internally, giving priority to bacteria and human pathogens, i.e. `"E. coli"` will be considered *Escherichia coli*. In other words, `mo_fullname(mo_shortname("Entamoeba coli"))` returns `"Escherichia coli"`.
|
||||
#'
|
||||
#' Since the top-level of the taxonomy is sometimes referred to as 'kingdom' and sometimes as 'domain', the functions [mo_kingdom()] and [mo_domain()] return the exact same results.
|
||||
#'
|
||||
#' The Gram stain - [mo_gramstain()] - will be determined based on the taxonomic kingdom and phylum. According to Cavalier-Smith (2002, [PMID 11837318](https://pubmed.ncbi.nlm.nih.gov/11837318)), who defined subkingdoms Negibacteria and Posibacteria, only these phyla are Posibacteria: Actinobacteria, Chloroflexi, Firmicutes and Tenericutes. These bacteria are considered Gram-positive - all other bacteria are considered Gram-negative. Species outside the kingdom of Bacteria will return a value `NA`.
|
||||
#' The Gram stain - [mo_gramstain()] - will be determined based on the taxonomic kingdom and phylum. According to Cavalier-Smith (2002, [PMID 11837318](https://pubmed.ncbi.nlm.nih.gov/11837318)), who defined subkingdoms Negibacteria and Posibacteria, only these phyla are Posibacteria: Actinobacteria, Chloroflexi, Firmicutes and Tenericutes. These bacteria are considered Gram-positive - all other bacteria are considered Gram-negative. Species outside the kingdom of Bacteria will return a value `NA`. Functions [mo_is_gram_negative()] and [mo_is_gram_positive()] always return `TRUE` or `FALSE` (except when the input is `NA` or the MO code is `UNKNOWN`), thus always return `FALSE` for species outside the taxonomic kingdom of Bacteria.
|
||||
#'
|
||||
#' Intrinsic resistance - [mo_is_intrinsic_resistant()] - will be determined based on the [intrinsic_resistant] data set, which is based on `r format_eucast_version_nr(3.2)`. The [mo_is_intrinsic_resistant()] can be vectorised over parameters `x` (input for microorganisms) and over `ab` (input for antibiotics).
|
||||
#'
|
||||
#' All output will be [translate]d where possible.
|
||||
#'
|
||||
@@ -122,7 +125,7 @@
|
||||
#' mo_shortname("S. pyo", Lancefield = TRUE) # "GAS" (='Group A Streptococci')
|
||||
#'
|
||||
#'
|
||||
#' # language support for German, Dutch, Spanish, Portuguese, Italian and French
|
||||
#' # language support --------------------------------------------------------
|
||||
#' mo_gramstain("E. coli", language = "de") # "Gramnegativ"
|
||||
#' mo_gramstain("E. coli", language = "nl") # "Gram-negatief"
|
||||
#' mo_gramstain("E. coli", language = "es") # "Gram negativo"
|
||||
@@ -140,12 +143,27 @@
|
||||
#' language = "nl") # "Streptococcus groep A"
|
||||
#'
|
||||
#'
|
||||
#' # other --------------------------------------------------------------------
|
||||
#'
|
||||
#' # gram stains and intrinsic resistance can also be used as a filter in dplyr verbs
|
||||
#' if (require("dplyr")) {
|
||||
#' example_isolates %>%
|
||||
#' filter(mo_is_gram_positive())
|
||||
#'
|
||||
#' example_isolates %>%
|
||||
#' filter(mo_is_intrinsic_resistant(ab = "vanco"))
|
||||
#' }
|
||||
#'
|
||||
#'
|
||||
#' # get a list with the complete taxonomy (from kingdom to subspecies)
|
||||
#' mo_taxonomy("E. coli")
|
||||
#' # get a list with the taxonomy, the authors, Gram-stain and URL to the online database
|
||||
#' mo_info("E. coli")
|
||||
#' }
|
||||
mo_name <- function(x, language = get_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
translate_AMR(mo_validate(x = x, property = "fullname", language = language, ...), language = language, only_unknown = FALSE)
|
||||
}
|
||||
|
||||
@@ -156,29 +174,32 @@ mo_fullname <- mo_name
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_shortname <- function(x, language = get_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
x.mo <- as.mo(x, language = language, ...)
|
||||
|
||||
|
||||
metadata <- get_mo_failures_uncertainties_renamed()
|
||||
|
||||
|
||||
replace_empty <- function(x) {
|
||||
x[x == ""] <- "spp."
|
||||
x
|
||||
}
|
||||
|
||||
|
||||
# get first char of genus and complete species in English
|
||||
genera <- mo_genus(x.mo, language = NULL)
|
||||
shortnames <- paste0(substr(genera, 1, 1), ". ", replace_empty(mo_species(x.mo, language = NULL)))
|
||||
|
||||
|
||||
# exceptions for where no species is known
|
||||
shortnames[shortnames %like% ".[.] spp[.]"] <- genera[shortnames %like% ".[.] spp[.]"]
|
||||
# exceptions for Staphylococci
|
||||
# exceptions for staphylococci
|
||||
shortnames[shortnames == "S. coagulase-negative"] <- "CoNS"
|
||||
shortnames[shortnames == "S. coagulase-positive"] <- "CoPS"
|
||||
# exceptions for Streptococci: Streptococcus Group A -> GAS
|
||||
# exceptions for streptococci: Group A Streptococcus -> GAS
|
||||
shortnames[shortnames %like% "S. group [ABCDFGHK]"] <- paste0("G", gsub("S. group ([ABCDFGHK])", "\\1", shortnames[shortnames %like% "S. group [ABCDFGHK]"]), "S")
|
||||
# unknown species etc.
|
||||
shortnames[shortnames %like% "unknown"] <- paste0("(", trimws(gsub("[^a-zA-Z -]", "", shortnames[shortnames %like% "unknown"])), ")")
|
||||
|
||||
|
||||
load_mo_failures_uncertainties_renamed(metadata)
|
||||
translate_AMR(shortnames, language = language, only_unknown = FALSE)
|
||||
}
|
||||
@@ -186,48 +207,72 @@ mo_shortname <- function(x, language = get_locale(), ...) {
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_subspecies <- function(x, language = get_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
translate_AMR(mo_validate(x = x, property = "subspecies", language = language, ...), language = language, only_unknown = TRUE)
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_species <- function(x, language = get_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
translate_AMR(mo_validate(x = x, property = "species", language = language, ...), language = language, only_unknown = TRUE)
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_genus <- function(x, language = get_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
translate_AMR(mo_validate(x = x, property = "genus", language = language, ...), language = language, only_unknown = TRUE)
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_family <- function(x, language = get_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
translate_AMR(mo_validate(x = x, property = "family", language = language, ...), language = language, only_unknown = TRUE)
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_order <- function(x, language = get_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
translate_AMR(mo_validate(x = x, property = "order", language = language, ...), language = language, only_unknown = TRUE)
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_class <- function(x, language = get_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
translate_AMR(mo_validate(x = x, property = "class", language = language, ...), language = language, only_unknown = TRUE)
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_phylum <- function(x, language = get_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
translate_AMR(mo_validate(x = x, property = "phylum", language = language, ...), language = language, only_unknown = TRUE)
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_kingdom <- function(x, language = get_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
translate_AMR(mo_validate(x = x, property = "kingdom", language = language, ...), language = language, only_unknown = TRUE)
|
||||
}
|
||||
|
||||
@@ -238,15 +283,21 @@ mo_domain <- mo_kingdom
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_type <- function(x, language = get_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
translate_AMR(mo_validate(x = x, property = "kingdom", language = language, ...), language = language, only_unknown = FALSE)
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_gramstain <- function(x, language = get_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
x.mo <- as.mo(x, language = language, ...)
|
||||
metadata <- get_mo_failures_uncertainties_renamed()
|
||||
|
||||
|
||||
x.phylum <- mo_phylum(x.mo)
|
||||
# DETERMINE GRAM STAIN FOR BACTERIA
|
||||
# Source: https://itis.gov/servlet/SingleRpt/SingleRpt?search_topic=TSN&search_value=956097
|
||||
@@ -267,26 +318,108 @@ mo_gramstain <- function(x, language = get_locale(), ...) {
|
||||
"Firmicutes",
|
||||
"Tenericutes")
|
||||
| x.mo == "B_GRAMP"] <- "Gram-positive"
|
||||
|
||||
|
||||
load_mo_failures_uncertainties_renamed(metadata)
|
||||
translate_AMR(x, language = language, only_unknown = FALSE)
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_is_gram_negative <- function(x, language = get_locale(), ...) {
|
||||
if (missing(x)) {
|
||||
# this supports using in dplyr verbs: ... %>% filter(mo_is_gram_negative())
|
||||
x <- find_mo_col("mo_is_gram_negative")
|
||||
}
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
x.mo <- as.mo(x, language = language, ...)
|
||||
metadata <- get_mo_failures_uncertainties_renamed()
|
||||
grams <- mo_gramstain(x.mo, language = NULL)
|
||||
load_mo_failures_uncertainties_renamed(metadata)
|
||||
out <- grams == "Gram-negative" & !is.na(grams)
|
||||
out[x.mo %in% c(NA_character_, "UNKNOWN")] <- NA
|
||||
out
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_is_gram_positive <- function(x, language = get_locale(), ...) {
|
||||
if (missing(x)) {
|
||||
# this supports using in dplyr verbs: ... %>% filter(mo_is_gram_positive())
|
||||
x <- find_mo_col("mo_is_gram_positive")
|
||||
}
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
x.mo <- as.mo(x, language = language, ...)
|
||||
metadata <- get_mo_failures_uncertainties_renamed()
|
||||
grams <- mo_gramstain(x.mo, language = NULL)
|
||||
load_mo_failures_uncertainties_renamed(metadata)
|
||||
out <- grams == "Gram-positive" & !is.na(grams)
|
||||
out[x.mo %in% c(NA_character_, "UNKNOWN")] <- NA
|
||||
out
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_is_intrinsic_resistant <- function(x, ab, language = get_locale(), ...) {
|
||||
if (missing(x)) {
|
||||
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
|
||||
x <- find_mo_col("mo_is_intrinsic_resistant")
|
||||
}
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(ab, allow_NA = FALSE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
x <- as.mo(x, language = language, ...)
|
||||
ab <- as.ab(ab, language = NULL, flag_multiple_results = FALSE, info = FALSE)
|
||||
|
||||
if (length(x) == 1 & length(ab) > 1) {
|
||||
x <- rep(x, length(ab))
|
||||
} else if (length(ab) == 1 & length(x) > 1) {
|
||||
ab <- rep(ab, length(x))
|
||||
}
|
||||
if (length(x) != length(ab)) {
|
||||
stop_("length of `x` and `ab` must be equal, or one of them must be of length 1.")
|
||||
}
|
||||
|
||||
# show used version number once per session
|
||||
if (is.null(getOption("AMR_intrinsic_resistance_note", NULL))) {
|
||||
message_("Determining intrinsic resistance based on ",
|
||||
format_eucast_version_nr(3.2, FALSE), ". ",
|
||||
font_bold("This note is shown only once per session."))
|
||||
options(AMR_intrinsic_resistance_note = "shown")
|
||||
}
|
||||
|
||||
# runs against internal vector: INTRINSIC_R (see zzz.R)
|
||||
paste(x, ab) %in% INTRINSIC_R
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_snomed <- function(x, language = get_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
mo_validate(x = x, property = "snomed", language = language, ...)
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_ref <- function(x, language = get_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
mo_validate(x = x, property = "ref", language = language, ...)
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_authors <- function(x, language = get_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
x <- mo_validate(x = x, property = "ref", language = language, ...)
|
||||
# remove last 4 digits and presumably the comma and space that preceed them
|
||||
x[!is.na(x)] <- gsub(",? ?[0-9]{4}", "", x[!is.na(x)])
|
||||
@@ -296,6 +429,9 @@ mo_authors <- function(x, language = get_locale(), ...) {
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_year <- function(x, language = get_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
x <- mo_validate(x = x, property = "ref", language = language, ...)
|
||||
# get last 4 digits
|
||||
x[!is.na(x)] <- gsub(".*([0-9]{4})$", "\\1", x[!is.na(x)])
|
||||
@@ -305,24 +441,30 @@ mo_year <- function(x, language = get_locale(), ...) {
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_rank <- function(x, language = get_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
mo_validate(x = x, property = "rank", language = language, ...)
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_taxonomy <- function(x, language = get_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
x <- as.mo(x, language = language, ...)
|
||||
metadata <- get_mo_failures_uncertainties_renamed()
|
||||
|
||||
|
||||
result <- list(kingdom = mo_kingdom(x, language = language),
|
||||
phylum = mo_phylum(x, language = language),
|
||||
class = mo_class(x, language = language),
|
||||
order = mo_order(x, language = language),
|
||||
family = mo_family(x, language = language),
|
||||
genus = mo_genus(x, language = language),
|
||||
species = mo_species(x, language = language),
|
||||
subspecies = mo_subspecies(x, language = language))
|
||||
|
||||
phylum = mo_phylum(x, language = language),
|
||||
class = mo_class(x, language = language),
|
||||
order = mo_order(x, language = language),
|
||||
family = mo_family(x, language = language),
|
||||
genus = mo_genus(x, language = language),
|
||||
species = mo_species(x, language = language),
|
||||
subspecies = mo_subspecies(x, language = language))
|
||||
|
||||
load_mo_failures_uncertainties_renamed(metadata)
|
||||
result
|
||||
}
|
||||
@@ -330,9 +472,12 @@ mo_taxonomy <- function(x, language = get_locale(), ...) {
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_synonyms <- function(x, language = get_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
x <- as.mo(x, language = language, ...)
|
||||
metadata <- get_mo_failures_uncertainties_renamed()
|
||||
|
||||
|
||||
IDs <- mo_name(x = x, language = NULL)
|
||||
syns <- lapply(IDs, function(newname) {
|
||||
res <- sort(microorganisms.old[which(microorganisms.old$fullname_new == newname), "fullname"])
|
||||
@@ -348,7 +493,7 @@ mo_synonyms <- function(x, language = get_locale(), ...) {
|
||||
} else {
|
||||
result <- unlist(syns)
|
||||
}
|
||||
|
||||
|
||||
load_mo_failures_uncertainties_renamed(metadata)
|
||||
result
|
||||
}
|
||||
@@ -356,9 +501,12 @@ mo_synonyms <- function(x, language = get_locale(), ...) {
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_info <- function(x, language = get_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
x <- as.mo(x, language = language, ...)
|
||||
metadata <- get_mo_failures_uncertainties_renamed()
|
||||
|
||||
|
||||
info <- lapply(x, function(y)
|
||||
c(mo_taxonomy(y, language = language),
|
||||
list(synonyms = mo_synonyms(y),
|
||||
@@ -371,7 +519,7 @@ mo_info <- function(x, language = get_locale(), ...) {
|
||||
} else {
|
||||
result <- info[[1L]]
|
||||
}
|
||||
|
||||
|
||||
load_mo_failures_uncertainties_renamed(metadata)
|
||||
result
|
||||
}
|
||||
@@ -379,12 +527,16 @@ mo_info <- function(x, language = get_locale(), ...) {
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_url <- function(x, open = FALSE, language = get_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(open, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
mo <- as.mo(x = x, language = language, ... = ...)
|
||||
mo_names <- mo_name(mo)
|
||||
metadata <- get_mo_failures_uncertainties_renamed()
|
||||
|
||||
|
||||
df <- data.frame(mo, stringsAsFactors = FALSE) %pm>%
|
||||
pm_left_join(pm_select(microorganisms, mo, source, species_id), by = "mo")
|
||||
pm_left_join(pm_select(microorganisms, mo, source, species_id), by = "mo")
|
||||
df$url <- ifelse(df$source == "CoL",
|
||||
paste0(catalogue_of_life$url_CoL, "details/species/id/", df$species_id, "/"),
|
||||
ifelse(df$source == "DSMZ",
|
||||
@@ -392,14 +544,14 @@ mo_url <- function(x, open = FALSE, language = get_locale(), ...) {
|
||||
NA_character_))
|
||||
u <- df$url
|
||||
names(u) <- mo_names
|
||||
|
||||
|
||||
if (open == TRUE) {
|
||||
if (length(u) > 1) {
|
||||
warning("only the first URL will be opened, as `browseURL()` only suports one string.")
|
||||
warning_("Only the first URL will be opened, as `browseURL()` only suports one string.")
|
||||
}
|
||||
utils::browseURL(u[1L])
|
||||
}
|
||||
|
||||
|
||||
load_mo_failures_uncertainties_renamed(metadata)
|
||||
u
|
||||
}
|
||||
@@ -408,22 +560,21 @@ mo_url <- function(x, open = FALSE, language = get_locale(), ...) {
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_property <- function(x, property = "fullname", language = get_locale(), ...) {
|
||||
stop_ifnot(length(property) == 1L, "'property' must be of length 1")
|
||||
stop_ifnot(property %in% colnames(microorganisms),
|
||||
"invalid property: '", property, "' - use a column name of the `microorganisms` data set")
|
||||
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(property, allow_class = "character", has_length = 1, is_in = colnames(microorganisms))
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
translate_AMR(mo_validate(x = x, property = property, language = language, ...), language = language, only_unknown = TRUE)
|
||||
}
|
||||
|
||||
mo_validate <- function(x, property, language, ...) {
|
||||
|
||||
check_dataset_integrity()
|
||||
|
||||
|
||||
if (tryCatch(all(x[!is.na(x)] %in% MO_lookup$mo) & length(list(...)) == 0, error = function(e) FALSE)) {
|
||||
# special case for mo_* functions where class is already <mo>
|
||||
return(MO_lookup[match(x, MO_lookup$mo), property, drop = TRUE])
|
||||
}
|
||||
|
||||
|
||||
dots <- list(...)
|
||||
Becker <- dots$Becker
|
||||
if (is.null(Becker)) {
|
||||
@@ -433,14 +584,14 @@ mo_validate <- function(x, property, language, ...) {
|
||||
if (is.null(Lancefield)) {
|
||||
Lancefield <- FALSE
|
||||
}
|
||||
|
||||
|
||||
# try to catch an error when inputting an invalid parameter
|
||||
# so the 'call.' can be set to FALSE
|
||||
tryCatch(x[1L] %in% MO_lookup[1, property, drop = TRUE],
|
||||
error = function(e) stop(e$message, call. = FALSE))
|
||||
|
||||
if (is.mo(x)
|
||||
& !Becker %in% c(TRUE, "all")
|
||||
|
||||
if (is.mo(x)
|
||||
& !Becker %in% c(TRUE, "all")
|
||||
& !Lancefield %in% c(TRUE, "all")) {
|
||||
# this will not reset mo_uncertainties and mo_failures
|
||||
# because it's already a valid MO
|
||||
@@ -450,12 +601,28 @@ mo_validate <- function(x, property, language, ...) {
|
||||
| Lancefield %in% c(TRUE, "all")) {
|
||||
x <- exec_as.mo(x, property = property, language = language, ...)
|
||||
}
|
||||
|
||||
|
||||
if (property == "mo") {
|
||||
return(to_class_mo(x))
|
||||
return(set_clean_class(x, new_class = c("mo", "character")))
|
||||
} else if (property == "snomed") {
|
||||
return(as.double(eval(parse(text = x))))
|
||||
} else {
|
||||
return(x)
|
||||
}
|
||||
}
|
||||
|
||||
find_mo_col <- function(fn) {
|
||||
# this function tries to find an mo column using dplyr::cur_data_all() for mo_is_*() functions,
|
||||
# which is useful when functions are used within dplyr verbs
|
||||
df <- get_current_data("x", call = -3) # will return an error if not found
|
||||
mo <- NULL
|
||||
try({
|
||||
mo <- suppressMessages(search_type_in_df(df, "mo"))
|
||||
}, silent = TRUE)
|
||||
if (!is.null(df) && !is.null(mo) && is.data.frame(df)) {
|
||||
message_("Using column '", font_bold(mo), "' as input for ", fn, "()")
|
||||
return(df[, mo, drop = TRUE])
|
||||
} else {
|
||||
stop_("argument `x` is missing and no column with info about microorganisms could be found.", call = -2)
|
||||
}
|
||||
}
|
||||
+83
-62
@@ -30,16 +30,17 @@
|
||||
#' This is **the fastest way** to have your organisation (or analysis) specific codes picked up and translated by this package.
|
||||
#' @inheritSection lifecycle Stable lifecycle
|
||||
#' @param path location of your reference file, see Details. Can be `""`, `NULL` or `FALSE` to delete the reference file.
|
||||
#' @param destination destination of the compressed data file, default to the user's home directory.
|
||||
#' @rdname mo_source
|
||||
#' @name mo_source
|
||||
#' @aliases set_mo_source get_mo_source
|
||||
#' @details The reference file can be a text file separated with commas (CSV) or tabs or pipes, an Excel file (either 'xls' or 'xlsx' format) or an R object file (extension '.rds'). To use an Excel file, you will need to have the `readxl` package installed.
|
||||
#'
|
||||
#' [set_mo_source()] will check the file for validity: it must be a [data.frame], must have a column named `"mo"` which contains values from [`microorganisms$mo`][microorganisms] and must have a reference column with your own defined values. If all tests pass, [set_mo_source()] will read the file into R and will ask to export it to `"~/.mo_source.rds"`. The CRAN policy disallows packages to write to the file system, although '*exceptions may be allowed in interactive sessions if the package obtains confirmation from the user*'. For this reason, this function only works in interactive sessions so that the user can **specifically confirm and allow** that this file will be created.
|
||||
#' [set_mo_source()] will check the file for validity: it must be a [data.frame], must have a column named `"mo"` which contains values from [`microorganisms$mo`][microorganisms] and must have a reference column with your own defined values. If all tests pass, [set_mo_source()] will read the file into R and will ask to export it to `"~/mo_source.rds"`. The CRAN policy disallows packages to write to the file system, although '*exceptions may be allowed in interactive sessions if the package obtains confirmation from the user*'. For this reason, this function only works in interactive sessions so that the user can **specifically confirm and allow** that this file will be created. The destination of this file can be set with the `destination` parameter and defaults to the user's home directory. It can also be set as an \R option, using `options(AMR_mo_source = "my/location/file.rds)`.
|
||||
#'
|
||||
#' The created compressed data file `"~/.mo_source.rds"` will be used at default for MO determination (function [as.mo()] and consequently all `mo_*` functions like [mo_genus()] and [mo_gramstain()]). The location of the original file will be saved as an R option with `options(mo_source = path)`. Its timestamp will be saved with `options(mo_source_datetime = ...)`.
|
||||
#' The created compressed data file `"mo_source.rds"` will be used at default for MO determination (function [as.mo()] and consequently all `mo_*` functions like [mo_genus()] and [mo_gramstain()]). The location and timestamp of the original file will be saved as an attribute to the compressed data file.
|
||||
#'
|
||||
#' The function [get_mo_source()] will return the data set by reading `"~/.mo_source.rds"` with [readRDS()]. If the original file has changed (by checking the aforementioned options `mo_source` and `mo_source_datetime`), it will call [set_mo_source()] to update the data file automatically if used in an interactive session.
|
||||
#' The function [get_mo_source()] will return the data set by reading `"mo_source.rds"` with [readRDS()]. If the original file has changed (by checking the location and timestamp of the original file), it will call [set_mo_source()] to update the data file automatically if used in an interactive session.
|
||||
#'
|
||||
#' Reading an Excel file (`.xlsx`) with only one row has a size of 8-9 kB. The compressed file created with [set_mo_source()] will then have a size of 0.1 kB and can be read by [get_mo_source()] in only a couple of microseconds (millionths of a second).
|
||||
#'
|
||||
@@ -60,16 +61,18 @@
|
||||
#'
|
||||
#' ```
|
||||
#' set_mo_source("home/me/ourcodes.xlsx")
|
||||
#' #> NOTE: Created mo_source file '~/.mo_source.rds' from 'home/me/ourcodes.xlsx'
|
||||
#' #> (columns "Organisation XYZ" and "mo")
|
||||
#' #> NOTE: Created mo_source file '/Users/me/mo_source.rds' (0.3 kB) from
|
||||
#' #> '/Users/me/Documents/ourcodes.xlsx' (9 kB), columns
|
||||
#' #> "Organisation XYZ" and "mo"
|
||||
#' ```
|
||||
#'
|
||||
#' It has now created a file `"~/.mo_source.rds"` with the contents of our Excel file. Only the first column with foreign values and the 'mo' column will be kept when creating the RDS file.
|
||||
#' It has now created a file `"~/mo_source.rds"` with the contents of our Excel file. Only the first column with foreign values and the 'mo' column will be kept when creating the RDS file.
|
||||
#'
|
||||
#' And now we can use it in our functions:
|
||||
#'
|
||||
#' ```
|
||||
#' as.mo("lab_mo_ecoli")
|
||||
#' #> Class <mo>
|
||||
#' #> [1] B_ESCHR_COLI
|
||||
#'
|
||||
#' mo_genus("lab_mo_kpneumoniae")
|
||||
@@ -77,6 +80,9 @@
|
||||
#'
|
||||
#' # other input values still work too
|
||||
#' as.mo(c("Escherichia coli", "E. coli", "lab_mo_ecoli"))
|
||||
#' #> NOTE: Translation to one microorganism was guessed with uncertainty.
|
||||
#' #> Use mo_uncertainties() to review it.
|
||||
#' #> Class <mo>
|
||||
#' #> [1] B_ESCHR_COLI B_ESCHR_COLI B_ESCHR_COLI
|
||||
#' ```
|
||||
#'
|
||||
@@ -96,8 +102,10 @@
|
||||
#'
|
||||
#' ```
|
||||
#' as.mo("lab_mo_ecoli")
|
||||
#' #> NOTE: Updated mo_source file '~/.mo_source.rds' from 'home/me/ourcodes.xlsx'
|
||||
#' #> (columns "Organisation XYZ" and "mo")
|
||||
#' #> NOTE: Updated mo_source file '/Users/me/mo_source.rds' (0.3 kB) from
|
||||
#' #> '/Users/me/Documents/ourcodes.xlsx' (9 kB), columns
|
||||
#' #> "Organisation XYZ" and "mo"
|
||||
#' #> Class <mo>
|
||||
#' #> [1] B_ESCHR_COLI
|
||||
#'
|
||||
#' mo_genus("lab_Staph_aureus")
|
||||
@@ -108,31 +116,33 @@
|
||||
#'
|
||||
#' ```
|
||||
#' set_mo_source(NULL)
|
||||
#' # Removed mo_source file '~/.mo_source.rds'.
|
||||
#' #> Removed mo_source file '/Users/me/mo_source.rds'
|
||||
#' ```
|
||||
#'
|
||||
#' If the original Excel file is moved or deleted, the mo_source file will be removed upon the next use of [as.mo()]. If the mo_source file is manually deleted (i.e. without using [set_mo_source()]), the references to the mo_source file will be removed upon the next use of [as.mo()].
|
||||
#' If the original Excel file is moved or deleted, the mo_source file will be removed upon the next use of [as.mo()].
|
||||
#' @export
|
||||
#' @inheritSection AMR Read more on our website!
|
||||
set_mo_source <- function(path) {
|
||||
set_mo_source <- function(path, destination = getOption("AMR_mo_source", "~/mo_source.rds")) {
|
||||
meet_criteria(path, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(destination, allow_class = "character", has_length = 1)
|
||||
stop_ifnot(destination %like% "[.]rds$", "the `destination` must be a file location with file extension .rds")
|
||||
|
||||
file_location <- path.expand("~/mo_source.rds")
|
||||
mo_source_destination <- path.expand(destination)
|
||||
|
||||
stop_ifnot(interactive(), "This function can only be used in interactive mode, since it must ask for the user's permission to write a file to their home folder.")
|
||||
stop_ifnot(length(path) == 1, "`path` must be of length 1")
|
||||
|
||||
|
||||
if (is.null(path) || path %in% c(FALSE, "")) {
|
||||
options(mo_source = NULL)
|
||||
options(mo_source_timestamp = NULL)
|
||||
if (file.exists(file_location)) {
|
||||
unlink(file_location)
|
||||
message(font_red(paste0("Removed mo_source file '", font_bold(file_location), "'")))
|
||||
mo_env$mo_source <- NULL
|
||||
if (file.exists(mo_source_destination)) {
|
||||
unlink(mo_source_destination)
|
||||
message_("Removed mo_source file '", font_bold(mo_source_destination), "'",
|
||||
add_fn = font_red,
|
||||
as_note = FALSE)
|
||||
}
|
||||
return(invisible())
|
||||
}
|
||||
|
||||
stop_ifnot(file.exists(path),
|
||||
"file not found: ", path)
|
||||
stop_ifnot(file.exists(path), "file not found: ", path)
|
||||
|
||||
if (path %like% "[.]rds$") {
|
||||
df <- readRDS(path)
|
||||
@@ -177,16 +187,19 @@ set_mo_source <- function(path) {
|
||||
}
|
||||
|
||||
df <- as.data.frame(df, stringAsFactors = FALSE)
|
||||
df[, "mo"] <- set_clean_class(df[, "mo", drop = TRUE], c("mo", "character"))
|
||||
|
||||
# success
|
||||
if (file.exists(file_location)) {
|
||||
if (file.exists(mo_source_destination)) {
|
||||
action <- "Updated"
|
||||
} else {
|
||||
action <- "Created"
|
||||
# only ask when file is created, not when it is updated
|
||||
txt <- paste0("This will write create the new file '",
|
||||
file_location,
|
||||
"', for which your permission is needed.\n\nDo you agree that this file will be created? ")
|
||||
txt <- paste0(word_wrap(paste0("This will write create the new file '",
|
||||
mo_source_destination,
|
||||
"', for which your permission is needed.")),
|
||||
"\n\n",
|
||||
word_wrap("Do you agree that this file will be created?"))
|
||||
if ("rsasdtudioapi" %in% rownames(utils::installed.packages())) {
|
||||
showQuestion <- import_fn("showQuestion", "rstudioapi")
|
||||
q_continue <- showQuestion("Create new file in home directory", txt)
|
||||
@@ -197,72 +210,66 @@ set_mo_source <- function(path) {
|
||||
return(invisible())
|
||||
}
|
||||
}
|
||||
saveRDS(df, file_location)
|
||||
options(mo_source = path)
|
||||
options(mo_source_timestamp = as.character(file.info(path)$mtime))
|
||||
message(font_blue(paste0("NOTE: ",
|
||||
action, " mo_source file '", font_bold(file_location), "'",
|
||||
" from '", font_bold(path), "'",
|
||||
'\n (columns "', colnames(df)[1], '" and "', colnames(df)[2], '")')))
|
||||
attr(df, "mo_source_location") <- path
|
||||
attr(df, "mo_source_timestamp") <- file.mtime(path)
|
||||
saveRDS(df, mo_source_destination)
|
||||
mo_env$mo_source <- df
|
||||
message_(action, " mo_source file '", font_bold(mo_source_destination),
|
||||
"' (", formatted_filesize(mo_source_destination),
|
||||
") from '", font_bold(path),
|
||||
"' (", formatted_filesize(path),
|
||||
'), columns "', colnames(df)[1], '" and "', colnames(df)[2], '"')
|
||||
}
|
||||
|
||||
#' @rdname mo_source
|
||||
#' @export
|
||||
get_mo_source <- function() {
|
||||
if (is.null(getOption("mo_source", NULL))) {
|
||||
get_mo_source <- function(destination = getOption("AMR_mo_source", "~/mo_source.rds")) {
|
||||
if (!file.exists(path.expand(destination))) {
|
||||
if (interactive()) {
|
||||
# source file might have been deleted, update reference
|
||||
set_mo_source("")
|
||||
}
|
||||
return(NULL)
|
||||
}
|
||||
|
||||
if (!file.exists(path.expand("~/mo_source.rds"))) {
|
||||
options(mo_source = NULL)
|
||||
options(mo_source_timestamp = NULL)
|
||||
message(font_blue("NOTE: Removed references to deleted mo_source file (see ?mo_source)"))
|
||||
return(NULL)
|
||||
if (is.null(mo_env$mo_source)) {
|
||||
mo_env$mo_source <- readRDS(path.expand(destination))
|
||||
}
|
||||
|
||||
old_time <- as.POSIXct(getOption("mo_source_timestamp"))
|
||||
new_time <- as.POSIXct(as.character(file.info(getOption("mo_source", ""))$mtime))
|
||||
|
||||
if (is.na(new_time)) {
|
||||
# source file was deleted, remove reference too
|
||||
set_mo_source("")
|
||||
return(NULL)
|
||||
old_time <- attributes(mo_env$mo_source)$mo_source_timestamp
|
||||
new_time <- file.mtime(attributes(mo_env$mo_source)$mo_source_location)
|
||||
if (interactive() && !identical(old_time, new_time)) {
|
||||
# source file was updated, also update reference
|
||||
set_mo_source(attributes(mo_env$mo_source)$mo_source_location)
|
||||
}
|
||||
if (interactive() && new_time != old_time) {
|
||||
# set updated source
|
||||
set_mo_source(getOption("mo_source"))
|
||||
}
|
||||
file_location <- path.expand("~/mo_source.rds")
|
||||
readRDS(file_location)
|
||||
mo_env$mo_source
|
||||
}
|
||||
|
||||
mo_source_isvalid <- function(x, refer_to_name = "`reference_df`", stop_on_error = TRUE) {
|
||||
|
||||
check_dataset_integrity()
|
||||
|
||||
if (deparse(substitute(x)) == "get_mo_source()") {
|
||||
if (paste(deparse(substitute(x)), collapse = "") == "get_mo_source()") {
|
||||
return(TRUE)
|
||||
}
|
||||
if (identical(x, get_mo_source())) {
|
||||
if (is.null(mo_env$mo_source) && (identical(x, get_mo_source()))) {
|
||||
return(TRUE)
|
||||
}
|
||||
if (is.null(x)) {
|
||||
if (stop_on_error == TRUE) {
|
||||
stop(refer_to_name, " cannot be NULL", call. = FALSE)
|
||||
stop_(refer_to_name, " cannot be NULL", call = FALSE)
|
||||
} else {
|
||||
return(FALSE)
|
||||
}
|
||||
}
|
||||
if (!is.data.frame(x)) {
|
||||
if (stop_on_error == TRUE) {
|
||||
stop(refer_to_name, " must be a data.frame", call. = FALSE)
|
||||
stop_(refer_to_name, " must be a data.frame", call = FALSE)
|
||||
} else {
|
||||
return(FALSE)
|
||||
}
|
||||
}
|
||||
if (!"mo" %in% colnames(x)) {
|
||||
if (stop_on_error == TRUE) {
|
||||
stop(refer_to_name, " must contain a column 'mo'", call. = FALSE)
|
||||
stop_(refer_to_name, " must contain a column 'mo'", call = FALSE)
|
||||
} else {
|
||||
return(FALSE)
|
||||
}
|
||||
@@ -275,13 +282,27 @@ mo_source_isvalid <- function(x, refer_to_name = "`reference_df`", stop_on_error
|
||||
} else {
|
||||
plural <- ""
|
||||
}
|
||||
stop("Value", plural, " ", paste0("'", invalid[, 1, drop = TRUE], "'", collapse = ", "),
|
||||
stop_("Value", plural, " ", paste0("'", invalid[, 1, drop = TRUE], "'", collapse = ", "),
|
||||
" found in ", tolower(refer_to_name),
|
||||
", but with invalid microorganism code", plural, " ", paste0("'", invalid$mo, "'", collapse = ", "),
|
||||
call. = FALSE)
|
||||
call = FALSE)
|
||||
} else {
|
||||
return(FALSE)
|
||||
}
|
||||
}
|
||||
TRUE
|
||||
if (colnames(x)[1] != "mo" & nrow(x) > length(unique(x[, 1, drop = TRUE]))) {
|
||||
if (stop_on_error == TRUE) {
|
||||
stop_(refer_to_name, " contains duplicate values in column '", colnames(x)[1], "'", call = FALSE)
|
||||
} else {
|
||||
return(FALSE)
|
||||
}
|
||||
}
|
||||
if (colnames(x)[2] != "mo" & nrow(x) > length(unique(x[, 2, drop = TRUE]))) {
|
||||
if (stop_on_error == TRUE) {
|
||||
stop_(refer_to_name, " contains duplicate values in column '", colnames(x)[2], "'", call = FALSE)
|
||||
} else {
|
||||
return(FALSE)
|
||||
}
|
||||
}
|
||||
return(TRUE)
|
||||
}
|
||||
@@ -66,9 +66,12 @@ pca <- function(x,
|
||||
scale. = TRUE,
|
||||
tol = NULL,
|
||||
rank. = NULL) {
|
||||
|
||||
stop_ifnot(is.data.frame(x), "`x` must be a data.frame")
|
||||
stop_if(any(dim(x) == 0), "`x` must contain rows and columns")
|
||||
meet_criteria(x, allow_class = "data.frame")
|
||||
meet_criteria(retx, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(center, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(scale., allow_class = "logical", has_length = 1)
|
||||
meet_criteria(tol, allow_class = "numeric", has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(rank., allow_class = "numeric", has_length = 1, allow_NULL = TRUE)
|
||||
|
||||
# unset data.table, tibble, etc.
|
||||
# also removes groups made by dplyr::group_by
|
||||
@@ -95,7 +98,7 @@ pca <- function(x,
|
||||
|
||||
x <- as.data.frame(new_list, stringsAsFactors = FALSE)
|
||||
if (any(sapply(x, function(y) !is.numeric(y)))) {
|
||||
warning("Be sure to first calculate the resistance (or susceptibility) of variables with antimicrobial test results, since PCA works with numeric variables only. Please see Examples in ?pca.")
|
||||
warning_("Be sure to first calculate the resistance (or susceptibility) of variables with antimicrobial test results, since PCA works with numeric variables only. Please see Examples in ?pca.")
|
||||
}
|
||||
|
||||
# set column names
|
||||
@@ -108,13 +111,13 @@ pca <- function(x,
|
||||
x <- cbind(x.bak[, sapply(x.bak, function(y) !is.numeric(y) & !all(is.na(y))), drop = FALSE], x)
|
||||
}
|
||||
|
||||
x <- pm_ungroup(x) # would otherwise select the grouping vars
|
||||
x <- pm_ungroup(x) # would otherwise select the grouping vars
|
||||
x <- x[rowSums(is.na(x)) == 0, ] # remove columns containing NAs
|
||||
|
||||
pca_data <- x[, which(sapply(x, function(x) is.numeric(x)))]
|
||||
|
||||
message(font_blue(paste0("NOTE: Columns selected for PCA: ", paste0(font_bold(colnames(pca_data)), collapse = "/"),
|
||||
".\n Total observations available: ", nrow(pca_data), ".")))
|
||||
message_("Columns selected for PCA: ", paste0(font_bold(colnames(pca_data)), collapse = "/"),
|
||||
". Total observations available: ", nrow(pca_data), ".")
|
||||
|
||||
pca_model <- prcomp(pca_data, retx = retx, center = center, scale. = scale., tol = tol, rank. = rank.)
|
||||
attr(pca_model, "non_numeric_cols") <- x[, sapply(x, function(y) !is.numeric(y) & !all(is.na(y))), drop = FALSE]
|
||||
|
||||
+2
-3
@@ -34,9 +34,9 @@
|
||||
#' @param as_percent a logical to indicate whether the output must be returned as a hundred fold with % sign (a character). A value of `0.123456` will then be returned as `"12.3%"`.
|
||||
#' @param only_all_tested (for combination therapies, i.e. using more than one variable for `...`): a logical to indicate that isolates must be tested for all antibiotics, see section *Combination therapy* below
|
||||
#' @param data a [data.frame] containing columns with class [`rsi`] (see [as.rsi()])
|
||||
#' @param translate_ab a column name of the [antibiotics] data set to translate the antibiotic abbreviations to, using [ab_property()]. Use a value
|
||||
#' @param translate_ab a column name of the [antibiotics] data set to translate the antibiotic abbreviations to, using [ab_property()]
|
||||
#' @inheritParams ab_property
|
||||
#' @param combine_SI a logical to indicate whether all values of S and I must be merged into one, so the output only consists of S+I vs. R (susceptible vs. resistant). This used to be the parameter `combine_IR`, but this now follows the redefinition by EUCAST about the interpretion of I (increased exposure) in 2019, see section 'Interpretation of S, I and R' below. Default is `TRUE`.
|
||||
#' @param combine_SI a logical to indicate whether all values of S and I must be merged into one, so the output only consists of S+I vs. R (susceptible vs. resistant). This used to be the parameter `combine_IR`, but this now follows the redefinition by EUCAST about the interpretation of I (increased exposure) in 2019, see section 'Interpretation of S, I and R' below. Default is `TRUE`.
|
||||
#' @param combine_IR a logical to indicate whether all values of I and R must be merged into one, so the output only consists of S vs. I+R (susceptible vs. non-susceptible). This is outdated, see parameter `combine_SI`.
|
||||
#' @inheritSection as.rsi Interpretation of R and S/I
|
||||
#' @details
|
||||
@@ -266,7 +266,6 @@ proportion_df <- function(data,
|
||||
as_percent = FALSE,
|
||||
combine_SI = TRUE,
|
||||
combine_IR = FALSE) {
|
||||
|
||||
rsi_calc_df(type = "proportion",
|
||||
data = data,
|
||||
translate_ab = translate_ab,
|
||||
|
||||
+132
@@ -0,0 +1,132 @@
|
||||
# ==================================================================== #
|
||||
# TITLE #
|
||||
# Antimicrobial Resistance (AMR) Analysis for R #
|
||||
# #
|
||||
# SOURCE #
|
||||
# https://github.com/msberends/AMR #
|
||||
# #
|
||||
# LICENCE #
|
||||
# (c) 2018-2020 Berends MS, Luz CF et al. #
|
||||
# Developed at the University of Groningen, the Netherlands, in #
|
||||
# collaboration with non-profit organisations Certe Medical #
|
||||
# Diagnostics & Advice, and University Medical Center Groningen. #
|
||||
# #
|
||||
# This R package is free software; you can freely use and distribute #
|
||||
# it for both personal and commercial purposes under the terms of the #
|
||||
# GNU General Public License version 2.0 (GNU GPL-2), as published by #
|
||||
# the Free Software Foundation. #
|
||||
# We created this package for both routine data analysis and academic #
|
||||
# research and it was publicly released in the hope that it will be #
|
||||
# useful, but it comes WITHOUT ANY WARRANTY OR LIABILITY. #
|
||||
# #
|
||||
# Visit our website for the full manual and a complete tutorial about #
|
||||
# how to conduct AMR analysis: https://msberends.github.io/AMR/ #
|
||||
# ==================================================================== #
|
||||
|
||||
#' Random MIC values/disk zones/RSI generation
|
||||
#'
|
||||
#' These functions can be used for generating random MIC values and disk diffusion diameters, for AMR analysis practice.
|
||||
#' @inheritSection lifecycle Maturing lifecycle
|
||||
#' @param size desired size of the returned vector
|
||||
#' @param mo any character that can be coerced to a valid microorganism code with [as.mo()]
|
||||
#' @param ab any character that can be coerced to a valid antimicrobial agent code with [as.ab()]
|
||||
#' @param prob_RSI a vector of length 3: the probabilities for R (1st value), S (2nd value) and I (3rd value)
|
||||
#' @param ... extension for future versions, not used at the moment
|
||||
#' @details The base R function [sample()] is used for generating values.
|
||||
#'
|
||||
#' Generated values are based on the latest EUCAST guideline implemented in the [rsi_translation] data set. To create specific generated values per bug or drug, set the `mo` and/or `ab` parameter.
|
||||
#' @return class `<mic>` for [random_mic()] (see [as.mic()]) and class `<disk>` for [random_disk()] (see [as.disk()])
|
||||
#' @name random
|
||||
#' @rdname random
|
||||
#' @export
|
||||
#' @inheritSection AMR Read more on our website!
|
||||
#' @examples
|
||||
#' random_mic(100)
|
||||
#' random_disk(100)
|
||||
#' random_rsi(100)
|
||||
#'
|
||||
#' \donttest{
|
||||
#' # make the random generation more realistic by setting a bug and/or drug:
|
||||
#' random_mic(100, "Klebsiella pneumoniae") # range 0.0625-64
|
||||
#' random_mic(100, "Klebsiella pneumoniae", "meropenem") # range 0.0625-16
|
||||
#' random_mic(100, "Streptococcus pneumoniae", "meropenem") # range 0.0625-4
|
||||
#'
|
||||
#' random_disk(100, "Klebsiella pneumoniae") # range 11-50
|
||||
#' random_disk(100, "Klebsiella pneumoniae", "ampicillin") # range 6-14
|
||||
#' random_disk(100, "Streptococcus pneumoniae", "ampicillin") # range 16-22
|
||||
#' }
|
||||
random_mic <- function(size, mo = NULL, ab = NULL, ...) {
|
||||
random_exec("MIC", size = size, mo = mo, ab = ab)
|
||||
}
|
||||
|
||||
#' @rdname random
|
||||
#' @export
|
||||
random_disk <- function(size, mo = NULL, ab = NULL, ...) {
|
||||
random_exec("DISK", size = size, mo = mo, ab = ab)
|
||||
}
|
||||
|
||||
#' @rdname random
|
||||
#' @export
|
||||
random_rsi <- function(size, prob_RSI = c(0.33, 0.33, 0.33), ...) {
|
||||
sample(as.rsi(c("R", "S", "I")), size = size, replace = TRUE, prob = prob_RSI)
|
||||
}
|
||||
|
||||
random_exec <- function(type, size, mo = NULL, ab = NULL) {
|
||||
df <- rsi_translation %pm>%
|
||||
pm_filter(guideline %like% "EUCAST") %pm>%
|
||||
pm_arrange(pm_desc(guideline)) %pm>%
|
||||
subset(guideline == max(guideline) &
|
||||
method == type)
|
||||
|
||||
if (!is.null(mo)) {
|
||||
mo_coerced <- as.mo(mo)
|
||||
mo_include <- c(mo_coerced,
|
||||
as.mo(mo_genus(mo_coerced)),
|
||||
as.mo(mo_family(mo_coerced)),
|
||||
as.mo(mo_order(mo_coerced)))
|
||||
df_new <- df %pm>%
|
||||
subset(mo %in% mo_include)
|
||||
if (nrow(df_new) > 0) {
|
||||
df <- df_new
|
||||
} else {
|
||||
warning_("No rows found that match mo '", mo, "', ignoring parameter `mo`", call = FALSE)
|
||||
}
|
||||
}
|
||||
|
||||
if (!is.null(ab)) {
|
||||
ab_coerced <- as.ab(ab)
|
||||
df_new <- df %pm>%
|
||||
subset(ab %in% ab_coerced)
|
||||
if (nrow(df_new) > 0) {
|
||||
df <- df_new
|
||||
} else {
|
||||
warning_("No rows found that match ab '", ab, "', ignoring parameter `ab`", call = FALSE)
|
||||
}
|
||||
}
|
||||
|
||||
if (type == "MIC") {
|
||||
# all valid MIC levels
|
||||
valid_range <- as.mic(levels(as.mic(1)))
|
||||
set_range_max <- max(df$breakpoint_R)
|
||||
if (log(set_range_max, 2) %% 1 == 0) {
|
||||
# return powers of 2
|
||||
valid_range <- unique(as.double(valid_range))
|
||||
# add one higher MIC level to set_range_max
|
||||
set_range_max <- 2 ^ (log(set_range_max, 2) + 1)
|
||||
set_range <- as.mic(valid_range[log(valid_range, 2) %% 1 == 0 & valid_range <= set_range_max])
|
||||
} else {
|
||||
# no power of 2, return factors of 2 to left and right side
|
||||
valid_mics <- suppressWarnings(as.mic(set_range_max / (2 ^ c(-3:3))))
|
||||
set_range <- valid_mics[!is.na(valid_mics)]
|
||||
}
|
||||
return(as.mic(sample(set_range, size = size, replace = TRUE)))
|
||||
} else if (type == "DISK") {
|
||||
set_range <- seq(from = as.integer(min(df$breakpoint_R)),
|
||||
to = as.integer(max(df$breakpoint_S)),
|
||||
by = 1)
|
||||
out <- sample(set_range, size = size, replace = TRUE)
|
||||
out[out < 6] <- sample(c(6:10), length(out[out < 6]), replace = TRUE)
|
||||
out[out > 50] <- sample(c(40:50), length(out[out > 50]), replace = TRUE)
|
||||
return(as.disk(out))
|
||||
}
|
||||
}
|
||||
+20
-9
@@ -34,7 +34,7 @@
|
||||
#' @param year_every unit of sequence between lowest year found in the data and `year_max`
|
||||
#' @param minimum minimal amount of available isolates per year to include. Years containing less observations will be estimated by the model.
|
||||
#' @param model the statistical model of choice. This could be a generalised linear regression model with binomial distribution (i.e. using `glm(..., family = binomial)``, assuming that a period of zero resistance was followed by a period of increasing resistance leading slowly to more and more resistance. See Details for all valid options.
|
||||
#' @param I_as_S a logical to indicate whether values `I` should be treated as `S` (will otherwise be treated as `R`). The default, `TRUE`, follows the redefinition by EUCAST about the interpretion of I (increased exposure) in 2019, see section *Interpretation of S, I and R* below.
|
||||
#' @param I_as_S a logical to indicate whether values `"I"` should be treated as `"S"` (will otherwise be treated as `"R"`). The default, `TRUE`, follows the redefinition by EUCAST about the interpretation of I (increased exposure) in 2019, see section *Interpretation of S, I and R* below.
|
||||
#' @param preserve_measurements a logical to indicate whether predictions of years that are actually available in the data should be overwritten by the original data. The standard errors of those years will be `NA`.
|
||||
#' @param info a logical to indicate whether textual analysis should be printed with the name and [summary()] of the statistical model.
|
||||
#' @param main title of the plot
|
||||
@@ -126,13 +126,20 @@ resistance_predict <- function(x,
|
||||
preserve_measurements = TRUE,
|
||||
info = interactive(),
|
||||
...) {
|
||||
meet_criteria(x, allow_class = "data.frame")
|
||||
meet_criteria(col_ab, allow_class = "character", has_length = 1, is_in = colnames(x))
|
||||
meet_criteria(col_date, allow_class = "character", has_length = 1, is_in = colnames(x), allow_NULL = TRUE)
|
||||
meet_criteria(year_min, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(year_max, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(year_every, allow_class = c("numeric", "integer"), has_length = 1)
|
||||
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1)
|
||||
meet_criteria(model, allow_class = c("character", "function"), has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(I_as_S, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(preserve_measurements, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(info, allow_class = "logical", has_length = 1)
|
||||
|
||||
stop_ifnot(is.data.frame(x), "`x` must be a data.frame")
|
||||
stop_if(any(dim(x) == 0), "`x` must contain rows and columns")
|
||||
stop_if(is.null(model), 'choose a regression model with the `model` parameter, e.g. resistance_predict(..., model = "binomial")')
|
||||
stop_ifnot(col_ab %in% colnames(x),
|
||||
"column `", col_ab, "` not found")
|
||||
|
||||
|
||||
dots <- unlist(list(...))
|
||||
if (length(dots) != 0) {
|
||||
# backwards compatibility with old parameters
|
||||
@@ -141,7 +148,7 @@ resistance_predict <- function(x,
|
||||
x <- dots[which(dots.names == "tbl")]
|
||||
}
|
||||
if ("I_as_R" %in% dots.names) {
|
||||
warning("`I_as_R is deprecated - use I_as_S instead.", call. = FALSE)
|
||||
warning_("`I_as_R is deprecated - use I_as_S instead.", call = FALSE)
|
||||
}
|
||||
}
|
||||
|
||||
@@ -179,7 +186,8 @@ resistance_predict <- function(x,
|
||||
# remove rows with NAs
|
||||
df <- subset(df, !is.na(df[, col_ab, drop = TRUE]))
|
||||
df$year <- year(df[, col_date, drop = TRUE])
|
||||
df <- as.data.frame(rbind(table(df[, c("year", col_ab)])), stringsAsFactors = FALSE)
|
||||
df <- as.data.frame(rbind(table(df[, c("year", col_ab)])),
|
||||
stringsAsFactors = FALSE)
|
||||
df$year <- as.integer(rownames(df))
|
||||
rownames(df) <- NULL
|
||||
|
||||
@@ -300,6 +308,7 @@ rsi_predict <- resistance_predict
|
||||
#' @rdname resistance_predict
|
||||
plot.resistance_predict <- function(x, main = paste("Resistance Prediction of", x_name), ...) {
|
||||
x_name <- paste0(ab_name(attributes(x)$ab), " (", attributes(x)$ab, ")")
|
||||
meet_criteria(main, allow_class = "character", has_length = 1)
|
||||
|
||||
if (attributes(x)$I_as_S == TRUE) {
|
||||
ylab <- "%R"
|
||||
@@ -342,11 +351,13 @@ ggplot_rsi_predict <- function(x,
|
||||
main = paste("Resistance Prediction of", x_name),
|
||||
ribbon = TRUE,
|
||||
...) {
|
||||
x_name <- paste0(ab_name(attributes(x)$ab), " (", attributes(x)$ab, ")")
|
||||
meet_criteria(main, allow_class = "character", has_length = 1)
|
||||
meet_criteria(ribbon, allow_class = "logical", has_length = 1)
|
||||
|
||||
stop_ifnot_installed("ggplot2")
|
||||
stop_ifnot(inherits(x, "resistance_predict"), "`x` must be a resistance prediction model created with resistance_predict()")
|
||||
|
||||
x_name <- paste0(ab_name(attributes(x)$ab), " (", attributes(x)$ab, ")")
|
||||
|
||||
if (attributes(x)$I_as_S == TRUE) {
|
||||
ylab <- "%R"
|
||||
|
||||
@@ -31,11 +31,12 @@
|
||||
#' @param x vector of values (for class [`mic`]: an MIC value in mg/L, for class [`disk`]: a disk diffusion radius in millimetres)
|
||||
#' @param mo any (vector of) text that can be coerced to a valid microorganism code with [as.mo()], will be determined automatically if the `dplyr` package is installed
|
||||
#' @param ab any (vector of) text that can be coerced to a valid antimicrobial code with [as.ab()]
|
||||
#' @param uti (Urinary Tract Infection) A vector with [logical]s (`TRUE` or `FALSE`) to specify whether a UTI specific interpretation from the guideline should be chosen. For using [as.rsi()] on a [data.frame], this can also be a column containing [logical]s or when left blank, the data set will be search for a 'specimen' and rows containing 'urin' in that column will be regarded isolates from a UTI. See *Examples*.
|
||||
#' @param uti (Urinary Tract Infection) A vector with [logical]s (`TRUE` or `FALSE`) to specify whether a UTI specific interpretation from the guideline should be chosen. For using [as.rsi()] on a [data.frame], this can also be a column containing [logical]s or when left blank, the data set will be searched for a 'specimen' and rows containing 'urin' (such as 'urine', 'urina') in that column will be regarded isolates from a UTI. See *Examples*.
|
||||
#' @inheritParams first_isolate
|
||||
#' @param guideline defaults to the latest included EUCAST guideline, see Details for all options
|
||||
#' @param conserve_capped_values a logical to indicate that MIC values starting with `">"` (but not `">="`) must always return "R" , and that MIC values starting with `"<"` (but not `"<="`) must always return "S"
|
||||
#' @param add_intrinsic_resistance *(only useful when using a EUCAST guideline)* a logical to indicate whether intrinsic antibiotic resistance must also be considered for applicable bug-drug combinations, meaning that e.g. ampicillin will always return "R" in *Klebsiella* species. Determination is based on the [intrinsic_resistant] data set, that itself is based on 'EUCAST Expert Rules, Intrinsic Resistance and Exceptional Phenotypes', version `r EUCAST_VERSION_EXPERT_RULES`.
|
||||
#' @param add_intrinsic_resistance *(only useful when using a EUCAST guideline)* a logical to indicate whether intrinsic antibiotic resistance must also be considered for applicable bug-drug combinations, meaning that e.g. ampicillin will always return "R" in *Klebsiella* species. Determination is based on the [intrinsic_resistant] data set, that itself is based on `r format_eucast_version_nr(3.2)`.
|
||||
#' @param reference_data a [data.frame] to be used for interpretation, which defaults to the [rsi_translation] data set. Changing this parameter allows for using own interpretation guidelines. This parameter must contain a data set that is equal in structure to the [rsi_translation] data set (same column names and column types). Please note that the `guideline` parameter will be ignored when `reference_data` is manually set.
|
||||
#' @param threshold maximum fraction of invalid antimicrobial interpretations of `x`, please see *Examples*
|
||||
#' @param ... for using on a [data.frame]: names of columns to apply [as.rsi()] on (supports tidy selection like `AMX:VAN`). Otherwise: parameters passed on to methods.
|
||||
#' @details
|
||||
@@ -66,7 +67,7 @@
|
||||
#'
|
||||
#' For interpreting MIC values as well as disk diffusion diameters, supported guidelines to be used as input for the `guideline` parameter are: `r paste0('"', sort(unique(AMR::rsi_translation$guideline)), '"', collapse = ", ")`.
|
||||
#'
|
||||
#' Simply using `"CLSI"` or `"EUCAST"` as input will automatically select the latest version of that guideline.
|
||||
#' Simply using `"CLSI"` or `"EUCAST"` as input will automatically select the latest version of that guideline. You can set your own data set using the `reference_data` parameter. The `guideline` parameter will then be ignored.
|
||||
#'
|
||||
#' ## After interpretation
|
||||
#'
|
||||
@@ -100,14 +101,14 @@
|
||||
#' summary(example_isolates) # see all R/SI results at a glance
|
||||
#'
|
||||
#' if (require("skimr")) {
|
||||
#' # support for skim() too:
|
||||
#' # class <rsi> supported in skim() too:
|
||||
#' skim(example_isolates)
|
||||
#' }
|
||||
#'
|
||||
#' # For INTERPRETING disk diffusion and MIC values -----------------------
|
||||
#'
|
||||
#' # a whole data set, even with combined MIC values and disk zones
|
||||
#' df <- data.frame(microorganism = "E. coli",
|
||||
#' df <- data.frame(microorganism = "Escherichia coli",
|
||||
#' AMP = as.mic(8),
|
||||
#' CIP = as.mic(0.256),
|
||||
#' GEN = as.disk(18),
|
||||
@@ -136,7 +137,7 @@
|
||||
#' df %>% mutate(across(AMP:TOB, as.rsi))
|
||||
#'
|
||||
#' df %>%
|
||||
#' mutate_at(vars(AMP:TOB), as.rsi, mo = "E. coli")
|
||||
#' mutate_at(vars(AMP:TOB), as.rsi, mo = .$microorganism)
|
||||
#'
|
||||
#' # to include information about urinary tract infections (UTI)
|
||||
#' data.frame(mo = "E. coli",
|
||||
@@ -193,6 +194,8 @@ is.rsi <- function(x) {
|
||||
#' @rdname as.rsi
|
||||
#' @export
|
||||
is.rsi.eligible <- function(x, threshold = 0.05) {
|
||||
meet_criteria(threshold, allow_class = "numeric", has_length = 1)
|
||||
|
||||
stop_if(NCOL(x) > 1, "`x` must be a one-dimensional vector.")
|
||||
if (any(c("logical",
|
||||
"numeric",
|
||||
@@ -220,24 +223,22 @@ is.rsi.eligible <- function(x, threshold = 0.05) {
|
||||
#' @export
|
||||
as.rsi.default <- function(x, ...) {
|
||||
if (is.rsi(x)) {
|
||||
x
|
||||
} else if (all(is.na(x)) || identical(levels(x), c("S", "I", "R"))) {
|
||||
structure(.Data = factor(x, levels = c("S", "I", "R"), ordered = TRUE),
|
||||
class = c("rsi", "ordered", "factor"))
|
||||
} else if (inherits(x, "integer") & all(x %in% c(1:3, NA))) {
|
||||
return(x)
|
||||
}
|
||||
|
||||
if (inherits(x, "integer") & all(x %in% c(1:3, NA))) {
|
||||
x[x == 1] <- "S"
|
||||
x[x == 2] <- "I"
|
||||
x[x == 3] <- "R"
|
||||
structure(.Data = factor(x, levels = c("S", "I", "R"), ordered = TRUE),
|
||||
class = c("rsi", "ordered", "factor"))
|
||||
} else {
|
||||
|
||||
} else if (!all(is.na(x)) && !identical(levels(x), c("S", "I", "R"))) {
|
||||
|
||||
if (!any(x %like% "(R|S|I)", na.rm = TRUE)) {
|
||||
# check if they are actually MICs or disks now that the antibiotic name is valid
|
||||
if (all_valid_mics(x)) {
|
||||
warning("The input seems to be MIC values. Transform them with as.mic() before running as.rsi() to interpret them.")
|
||||
warning_("The input seems to be MIC values. Transform them with as.mic() before running as.rsi() to interpret them.")
|
||||
} else if (all_valid_disks(x)) {
|
||||
warning("The input seems to be disk diffusion values. Transform them with as.disk() before running as.rsi() to interpret them.")
|
||||
warning_("The input seems to be disk diffusion values. Transform them with as.disk() before running as.rsi() to interpret them.")
|
||||
}
|
||||
}
|
||||
|
||||
@@ -271,16 +272,16 @@ as.rsi.default <- function(x, ...) {
|
||||
unique() %pm>%
|
||||
sort()
|
||||
list_missing <- paste0('"', list_missing, '"', collapse = ", ")
|
||||
warning(na_after - na_before, " results truncated (",
|
||||
round(((na_after - na_before) / length(x)) * 100),
|
||||
"%) that were invalid antimicrobial interpretations: ",
|
||||
list_missing, call. = FALSE)
|
||||
warning_(na_after - na_before, " results truncated (",
|
||||
round(((na_after - na_before) / length(x)) * 100),
|
||||
"%) that were invalid antimicrobial interpretations: ",
|
||||
list_missing, call = FALSE)
|
||||
}
|
||||
}
|
||||
|
||||
structure(.Data = factor(x, levels = c("S", "I", "R"), ordered = TRUE),
|
||||
class = c("rsi", "ordered", "factor"))
|
||||
}
|
||||
|
||||
set_clean_class(factor(x, levels = c("S", "I", "R"), ordered = TRUE),
|
||||
new_class = c("rsi", "ordered", "factor"))
|
||||
}
|
||||
|
||||
#' @rdname as.rsi
|
||||
@@ -292,7 +293,17 @@ as.rsi.mic <- function(x,
|
||||
uti = FALSE,
|
||||
conserve_capped_values = FALSE,
|
||||
add_intrinsic_resistance = FALSE,
|
||||
reference_data = AMR::rsi_translation,
|
||||
...) {
|
||||
meet_criteria(x)
|
||||
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
|
||||
meet_criteria(ab, allow_class = c("ab", "character"))
|
||||
meet_criteria(guideline, allow_class = "character", has_length = 1)
|
||||
meet_criteria(uti, allow_class = "logical", has_length = c(1, length(x)))
|
||||
meet_criteria(conserve_capped_values, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(add_intrinsic_resistance, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(reference_data, allow_class = "data.frame")
|
||||
check_reference_data(reference_data)
|
||||
|
||||
# for dplyr's across()
|
||||
cur_column_dplyr <- import_fn("cur_column", "dplyr", error_on_fail = FALSE)
|
||||
@@ -305,30 +316,34 @@ as.rsi.mic <- function(x,
|
||||
# for auto-determining mo
|
||||
mo_var_found <- ""
|
||||
if (is.null(mo)) {
|
||||
peek_mask_dplyr <- import_fn("peek_mask", "dplyr", error_on_fail = FALSE)
|
||||
if (!is.null(peek_mask_dplyr)) {
|
||||
tryCatch({
|
||||
df <- get_current_data(arg_name = "mo", call = -3) # will return an error if not found
|
||||
mo <- NULL
|
||||
try({
|
||||
df <- as.data.frame(peek_mask_dplyr()$across_cols(), stringsAsFactors = FALSE)
|
||||
mo <- suppressMessages(search_type_in_df(df, "mo"))
|
||||
if (!is.null(mo)) {
|
||||
mo_var_found <- paste0(" based on column `", font_bold(mo), "`")
|
||||
mo <- df[, mo, drop = TRUE]
|
||||
}
|
||||
}, silent = TRUE)
|
||||
}
|
||||
if (!is.null(df) && !is.null(mo) && is.data.frame(df)) {
|
||||
mo_var_found <- paste0(" based on column `", font_bold(mo), "`")
|
||||
mo <- df[, mo, drop = TRUE]
|
||||
}
|
||||
}, error = function(e)
|
||||
stop_('No information was supplied about the microorganisms (missing parameter "mo"). See ?as.rsi.\n\n',
|
||||
"To transform certain columns with e.g. mutate_at(), use `data %>% mutate_at(vars(...), as.rsi, mo = .$x)`, where x is your column with microorganisms.\n",
|
||||
"To tranform all disk diffusion zones in a data set, use `data %>% as.rsi()` or data %>% mutate_if(is.disk, as.rsi).", call = FALSE)
|
||||
)
|
||||
}
|
||||
if (is.null(mo)) {
|
||||
stop_('No information was supplied about the microorganisms (missing parameter "mo"). See ?as.rsi.\n\n',
|
||||
"To transform certain columns with e.g. mutate_at(), use\n",
|
||||
"`data %>% mutate_at(vars(...), as.rsi, mo = .$x)`, where x is your column with microorganisms.\n\n",
|
||||
"To tranform all MIC values in a data set, use `data %>% as.rsi()` or data %>% mutate_if(is.mic, as.rsi).", call = FALSE)
|
||||
if (length(ab) == 1 && ab %like% "as.mic") {
|
||||
stop_('No unambiguous name was supplied about the antibiotic (parameter "ab"). See ?as.rsi.', call = FALSE)
|
||||
}
|
||||
|
||||
ab_coerced <- suppressWarnings(as.ab(ab))
|
||||
mo_coerced <- suppressWarnings(as.mo(mo))
|
||||
guideline_coerced <- get_guideline(guideline)
|
||||
guideline_coerced <- get_guideline(guideline, reference_data)
|
||||
if (is.na(ab_coerced)) {
|
||||
message(font_red(paste0("Returning NAs for unknown drug: `", font_bold(ab), "`. Rename this column to a drug name or code, and check the output with as.ab().")))
|
||||
message_("Returning NAs for unknown drug: `", font_bold(ab),
|
||||
"`. Rename this column to a drug name or code, and check the output with as.ab().",
|
||||
add_fn = font_red,
|
||||
as_note = FALSE)
|
||||
return(as.rsi(rep(NA, length(x))))
|
||||
}
|
||||
if (length(mo_coerced) == 1) {
|
||||
@@ -338,11 +353,15 @@ as.rsi.mic <- function(x,
|
||||
uti <- rep(uti, length(x))
|
||||
}
|
||||
|
||||
message(font_blue(paste0("=> Interpreting MIC values of `", font_bold(ab), "` (",
|
||||
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
|
||||
ab_name(ab_coerced, tolower = TRUE), ")", mo_var_found,
|
||||
" according to ", font_bold(guideline_coerced), " ... ")),
|
||||
appendLF = FALSE)
|
||||
message_("=> Interpreting MIC values of '", font_bold(ab), "' (",
|
||||
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
|
||||
ab_name(ab_coerced, tolower = TRUE), ")", mo_var_found,
|
||||
" according to ", ifelse(identical(reference_data, AMR::rsi_translation),
|
||||
font_bold(guideline_coerced),
|
||||
"manually defined 'reference_data'"),
|
||||
" ... ",
|
||||
appendLF = FALSE,
|
||||
as_note = FALSE)
|
||||
|
||||
result <- exec_as.rsi(method = "mic",
|
||||
x = x,
|
||||
@@ -351,7 +370,8 @@ as.rsi.mic <- function(x,
|
||||
guideline = guideline_coerced,
|
||||
uti = uti,
|
||||
conserve_capped_values = conserve_capped_values,
|
||||
add_intrinsic_resistance = add_intrinsic_resistance) # exec_as.rsi will return message(font_blue(" OK."))
|
||||
add_intrinsic_resistance = add_intrinsic_resistance,
|
||||
reference_data = reference_data) # exec_as.rsi will return message 'OK'
|
||||
result
|
||||
}
|
||||
|
||||
@@ -363,7 +383,16 @@ as.rsi.disk <- function(x,
|
||||
guideline = "EUCAST",
|
||||
uti = FALSE,
|
||||
add_intrinsic_resistance = FALSE,
|
||||
reference_data = AMR::rsi_translation,
|
||||
...) {
|
||||
meet_criteria(x)
|
||||
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
|
||||
meet_criteria(ab, allow_class = c("ab", "character"))
|
||||
meet_criteria(guideline, allow_class = "character", has_length = 1)
|
||||
meet_criteria(uti, allow_class = "logical", has_length = c(1, length(x)))
|
||||
meet_criteria(add_intrinsic_resistance, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(reference_data, allow_class = "data.frame")
|
||||
check_reference_data(reference_data)
|
||||
|
||||
# for dplyr's across()
|
||||
cur_column_dplyr <- import_fn("cur_column", "dplyr", error_on_fail = FALSE)
|
||||
@@ -376,30 +405,34 @@ as.rsi.disk <- function(x,
|
||||
# for auto-determining mo
|
||||
mo_var_found <- ""
|
||||
if (is.null(mo)) {
|
||||
peek_mask_dplyr <- import_fn("peek_mask", "dplyr", error_on_fail = FALSE)
|
||||
if (!is.null(peek_mask_dplyr)) {
|
||||
tryCatch({
|
||||
df <- get_current_data(arg_name = "mo", call = -3) # will return an error if not found
|
||||
mo <- NULL
|
||||
try({
|
||||
df <- as.data.frame(peek_mask_dplyr()$across_cols(), stringsAsFactors = FALSE)
|
||||
mo <- suppressMessages(search_type_in_df(df, "mo"))
|
||||
if (!is.null(mo)) {
|
||||
mo_var_found <- paste0(" based on column `", font_bold(mo), "`")
|
||||
mo <- df[, mo, drop = TRUE]
|
||||
}
|
||||
}, silent = TRUE)
|
||||
}
|
||||
if (!is.null(df) && !is.null(mo) && is.data.frame(df)) {
|
||||
mo_var_found <- paste0(" based on column `", font_bold(mo), "`")
|
||||
mo <- df[, mo, drop = TRUE]
|
||||
}
|
||||
}, error = function(e)
|
||||
stop_('No information was supplied about the microorganisms (missing parameter "mo"). See ?as.rsi.\n\n',
|
||||
"To transform certain columns with e.g. mutate_at(), use `data %>% mutate_at(vars(...), as.rsi, mo = .$x)`, where x is your column with microorganisms.\n",
|
||||
"To tranform all disk diffusion zones in a data set, use `data %>% as.rsi()` or data %>% mutate_if(is.disk, as.rsi).", call = FALSE)
|
||||
)
|
||||
}
|
||||
if (is.null(mo)) {
|
||||
stop_('No information was supplied about the microorganisms (missing parameter "mo"). See ?as.rsi.\n\n',
|
||||
"To transform certain columns with e.g. mutate_at(), use\n",
|
||||
"`data %>% mutate_at(vars(...), as.rsi, mo = .$x)`, where x is your column with microorganisms.\n\n",
|
||||
"To tranform all disk diffusion zones in a data set, use `data %>% as.rsi()` or data %>% mutate_if(is.disk, as.rsi).", call = FALSE)
|
||||
if (length(ab) == 1 && ab %like% "as.disk") {
|
||||
stop_('No unambiguous name was supplied about the antibiotic (parameter "ab"). See ?as.rsi.', call = FALSE)
|
||||
}
|
||||
|
||||
ab_coerced <- suppressWarnings(as.ab(ab))
|
||||
mo_coerced <- suppressWarnings(as.mo(mo))
|
||||
guideline_coerced <- get_guideline(guideline)
|
||||
guideline_coerced <- get_guideline(guideline, reference_data)
|
||||
if (is.na(ab_coerced)) {
|
||||
message(font_red(paste0("Returning NAs for unknown drug: `", font_bold(ab), "`. Rename this column to a drug name or code, and check the output with as.ab().")))
|
||||
message_("Returning NAs for unknown drug: `", font_bold(ab),
|
||||
"`. Rename this column to a drug name or code, and check the output with as.ab().",
|
||||
add_fn = font_red,
|
||||
as_note = FALSE)
|
||||
return(as.rsi(rep(NA, length(x))))
|
||||
}
|
||||
if (length(mo_coerced) == 1) {
|
||||
@@ -409,10 +442,16 @@ as.rsi.disk <- function(x,
|
||||
uti <- rep(uti, length(x))
|
||||
}
|
||||
|
||||
message(font_blue(paste0("=> Interpreting disk zones of `", font_bold(ab), "` (",
|
||||
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
|
||||
ab_name(ab_coerced, tolower = TRUE), ") using guideline ", font_bold(guideline_coerced), " ... ")),
|
||||
appendLF = FALSE)
|
||||
message_("=> Interpreting disk zones of '", font_bold(ab), "' (",
|
||||
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
|
||||
ab_name(ab_coerced, tolower = TRUE), ")", mo_var_found,
|
||||
" according to ", ifelse(identical(reference_data, AMR::rsi_translation),
|
||||
font_bold(guideline_coerced),
|
||||
"manually defined 'reference_data'"),
|
||||
" ... ",
|
||||
appendLF = FALSE,
|
||||
as_note = FALSE)
|
||||
|
||||
result <- exec_as.rsi(method = "disk",
|
||||
x = x,
|
||||
mo = mo_coerced,
|
||||
@@ -420,7 +459,8 @@ as.rsi.disk <- function(x,
|
||||
guideline = guideline_coerced,
|
||||
uti = uti,
|
||||
conserve_capped_values = FALSE,
|
||||
add_intrinsic_resistance = add_intrinsic_resistance) # exec_as.rsi will return message(font_blue(" OK."))
|
||||
add_intrinsic_resistance = add_intrinsic_resistance,
|
||||
reference_data = reference_data) # exec_as.rsi will return message 'OK'
|
||||
result
|
||||
}
|
||||
|
||||
@@ -432,8 +472,29 @@ as.rsi.data.frame <- function(x,
|
||||
guideline = "EUCAST",
|
||||
uti = NULL,
|
||||
conserve_capped_values = FALSE,
|
||||
add_intrinsic_resistance = FALSE) {
|
||||
add_intrinsic_resistance = FALSE,
|
||||
reference_data = rsi_translation) {
|
||||
meet_criteria(x, allow_class = "data.frame") # will also check for dimensions > 0
|
||||
meet_criteria(col_mo, allow_class = "character", is_in = colnames(x), allow_NULL = TRUE)
|
||||
meet_criteria(guideline, allow_class = "character", has_length = 1)
|
||||
meet_criteria(uti, allow_class = c("logical", "character"), allow_NULL = TRUE)
|
||||
meet_criteria(conserve_capped_values, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(add_intrinsic_resistance, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(reference_data, allow_class = "data.frame")
|
||||
|
||||
for (i in seq_len(ncol(x))) {
|
||||
# don't keep factors
|
||||
if (is.factor(x[, i, drop = TRUE])) {
|
||||
x[, i] <- as.character(x[, i, drop = TRUE])
|
||||
}
|
||||
}
|
||||
|
||||
# -- MO
|
||||
col_mo.bak <- col_mo
|
||||
if (is.null(col_mo)) {
|
||||
col_mo <- search_type_in_df(x = x, type = "mo", info = FALSE)
|
||||
}
|
||||
|
||||
# -- UTIs
|
||||
col_uti <- uti
|
||||
if (is.null(col_uti)) {
|
||||
@@ -449,6 +510,8 @@ as.rsi.data.frame <- function(x,
|
||||
}
|
||||
} else {
|
||||
# column found, transform to logical
|
||||
stop_if(length(col_uti) != 1 | !col_uti %in% colnames(x),
|
||||
"argument `uti` must be a logical vector, of must be a single column name of `x`")
|
||||
uti <- as.logical(x[, col_uti, drop = TRUE])
|
||||
}
|
||||
} else {
|
||||
@@ -462,101 +525,127 @@ as.rsi.data.frame <- function(x,
|
||||
} else {
|
||||
plural <- c("", "s", "a ")
|
||||
}
|
||||
message(font_blue(paste0("NOTE: Assuming value", plural[1], " ",
|
||||
paste(paste0('"', values, '"'), collapse = ", "),
|
||||
" in column `", font_bold(col_specimen),
|
||||
"` reflect", plural[2], " ", plural[3], "urinary tract infection", plural[1], ".\n Use `as.rsi(uti = FALSE)` to prevent this.")))
|
||||
message_("Assuming value", plural[1], " ",
|
||||
paste(paste0('"', values, '"'), collapse = ", "),
|
||||
" in column `", font_bold(col_specimen),
|
||||
"` reflect", plural[2], " ", plural[3], "urinary tract infection", plural[1],
|
||||
".\n Use `as.rsi(uti = FALSE)` to prevent this.")
|
||||
} else {
|
||||
# no data about UTI's found
|
||||
uti <- FALSE
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
i <- 0
|
||||
sel <- colnames(pm_select(x, ...))
|
||||
if (!is.null(col_mo)) {
|
||||
sel <- sel[sel != col_mo]
|
||||
}
|
||||
|
||||
ab_cols <- colnames(x)[sapply(x, function(y) {
|
||||
i <<- i + 1
|
||||
check <- is.mic(y) | is.disk(y)
|
||||
ab <- colnames(x)[i]
|
||||
if (!is.null(col_mo) && ab == col_mo) {
|
||||
return(FALSE)
|
||||
}
|
||||
if (!is.null(col_uti) && ab == col_uti) {
|
||||
return(FALSE)
|
||||
}
|
||||
if (length(sel) == 0 || (length(sel) > 0 && ab %in% sel)) {
|
||||
ab_coerced <- suppressWarnings(as.ab(ab))
|
||||
if (is.na(ab_coerced) || (length(sel) > 0 & !ab %in% sel)) {
|
||||
# not even a valid AB code
|
||||
return(FALSE)
|
||||
} else {
|
||||
if (!check & all_valid_mics(y)) {
|
||||
message(font_blue(paste0("NOTE: Assuming column `", ab, "` (",
|
||||
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
|
||||
ab_name(ab_coerced, tolower = TRUE), ") contains MIC values.")))
|
||||
} else if (!check & all_valid_disks(y)) {
|
||||
message(font_blue(paste0("NOTE: Assuming column `", ab, "` (",
|
||||
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
|
||||
ab_name(ab_coerced, tolower = TRUE), ") contains disk zones.")))
|
||||
} else if (!check & !is.rsi(y)) {
|
||||
message(font_blue(paste0("NOTE: Assuming column `", ab, "` (",
|
||||
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
|
||||
ab_name(ab_coerced, tolower = TRUE), ") must be cleaned to valid R/SI values.")))
|
||||
}
|
||||
return(TRUE)
|
||||
}
|
||||
} else {
|
||||
return(FALSE)
|
||||
}
|
||||
})]
|
||||
|
||||
|
||||
stop_if(length(ab_cols) == 0,
|
||||
"no columns with MIC values, disk zones or antibiotic column names found in this data set. Use as.mic() or as.disk() to transform antimicrobial columns.")
|
||||
# set type per column
|
||||
types <- character(length(ab_cols))
|
||||
types[sapply(x[, ab_cols], is.mic)] <- "mic"
|
||||
types[types == "" & sapply(x[, ab_cols], all_valid_mics)] <- "mic"
|
||||
types[sapply(x[, ab_cols], is.disk)] <- "disk"
|
||||
types[types == "" & sapply(x[, ab_cols], all_valid_disks)] <- "disk"
|
||||
types[types == "" & !sapply(x[, ab_cols], is.rsi)] <- "rsi"
|
||||
|
||||
types[sapply(x[, ab_cols, drop = FALSE], is.disk)] <- "disk"
|
||||
types[types == "" & sapply(x[, ab_cols, drop = FALSE], all_valid_disks)] <- "disk"
|
||||
types[sapply(x[, ab_cols, drop = FALSE], is.mic)] <- "mic"
|
||||
types[types == "" & sapply(x[, ab_cols, drop = FALSE], all_valid_mics)] <- "mic"
|
||||
types[types == "" & !sapply(x[, ab_cols, drop = FALSE], is.rsi)] <- "rsi"
|
||||
if (any(types %in% c("mic", "disk"), na.rm = TRUE)) {
|
||||
# now we need an mo column - try to find columns based on type
|
||||
if (is.null(col_mo)) {
|
||||
# now we need an mo column
|
||||
stop_if(is.null(col_mo), "`col_mo` must be set")
|
||||
# if not null, we already found it, now find again so a message will show
|
||||
if (is.null(col_mo.bak)) {
|
||||
col_mo <- search_type_in_df(x = x, type = "mo")
|
||||
stop_if(is.null(col_mo), "`col_mo` must be set")
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
x_mo <- as.mo(x %pm>% pm_pull(col_mo))
|
||||
|
||||
for (i in seq_len(length(ab_cols))) {
|
||||
if (types[i] == "mic") {
|
||||
x[, ab_cols[i]] <- as.rsi.mic(x = x %pm>% pm_pull(ab_cols[i]),
|
||||
mo = x %pm>% pm_pull(col_mo),
|
||||
ab = ab_cols[i],
|
||||
guideline = guideline,
|
||||
uti = uti,
|
||||
conserve_capped_values = conserve_capped_values)
|
||||
x[, ab_cols[i]] <- as.rsi(x = x %pm>%
|
||||
pm_pull(ab_cols[i]) %pm>%
|
||||
as.character() %pm>%
|
||||
as.mic(),
|
||||
mo = x_mo,
|
||||
ab = ab_cols[i],
|
||||
guideline = guideline,
|
||||
uti = uti,
|
||||
conserve_capped_values = conserve_capped_values,
|
||||
add_intrinsic_resistance = add_intrinsic_resistance,
|
||||
reference_data = reference_data)
|
||||
} else if (types[i] == "disk") {
|
||||
x[, ab_cols[i]] <- as.rsi.disk(x = x %pm>% pm_pull(ab_cols[i]),
|
||||
mo = x %pm>% pm_pull(col_mo),
|
||||
ab = ab_cols[i],
|
||||
guideline = guideline,
|
||||
uti = uti)
|
||||
x[, ab_cols[i]] <- as.rsi(x = x %pm>%
|
||||
pm_pull(ab_cols[i]) %pm>%
|
||||
as.character() %pm>%
|
||||
as.disk(),
|
||||
mo = x_mo,
|
||||
ab = ab_cols[i],
|
||||
guideline = guideline,
|
||||
uti = uti,
|
||||
add_intrinsic_resistance = add_intrinsic_resistance,
|
||||
reference_data = reference_data)
|
||||
} else if (types[i] == "rsi") {
|
||||
x[, ab_cols[i]] <- as.rsi.default(x = x %pm>% pm_pull(ab_cols[i]))
|
||||
ab <- ab_cols[i]
|
||||
ab_coerced <- suppressWarnings(as.ab(ab))
|
||||
if (!all(x[, ab_cols[i], drop = TRUE] %in% c("R", "S", "I"), na.rm = TRUE)) {
|
||||
# only print message if values are not already clean
|
||||
message_("=> Cleaning values in column `", font_bold(ab), "` (",
|
||||
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
|
||||
ab_name(ab_coerced, tolower = TRUE), ")... ",
|
||||
appendLF = FALSE,
|
||||
as_note = FALSE)
|
||||
}
|
||||
x[, ab_cols[i]] <- as.rsi.default(x = as.character(x[, ab_cols[i], drop = TRUE]))
|
||||
if (!all(x[, ab_cols[i], drop = TRUE] %in% c("R", "S", "I"), na.rm = TRUE)) {
|
||||
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
x
|
||||
}
|
||||
|
||||
get_guideline <- function(guideline) {
|
||||
get_guideline <- function(guideline, reference_data) {
|
||||
if (!identical(reference_data, AMR::rsi_translation)) {
|
||||
return(guideline)
|
||||
}
|
||||
guideline_param <- toupper(guideline)
|
||||
if (guideline_param %in% c("CLSI", "EUCAST")) {
|
||||
guideline_param <- rev(sort(subset(rsi_translation, guideline %like% guideline_param)$guideline))[1L]
|
||||
guideline_param <- rev(sort(subset(reference_data, guideline %like% guideline_param)$guideline))[1L]
|
||||
}
|
||||
if (!guideline_param %like% " ") {
|
||||
# like 'EUCAST2020', should be 'EUCAST 2020'
|
||||
guideline_param <- gsub("([a-z]+)([0-9]+)", "\\1 \\2", guideline_param, ignore.case = TRUE)
|
||||
}
|
||||
|
||||
stop_ifnot(guideline_param %in% rsi_translation$guideline,
|
||||
stop_ifnot(guideline_param %in% reference_data$guideline,
|
||||
"invalid guideline: '", guideline,
|
||||
"'.\nValid guidelines are: ", paste0("'", unique(rsi_translation$guideline), "'", collapse = ", "), call = FALSE)
|
||||
"'.\nValid guidelines are: ", paste0("'", unique(reference_data$guideline), "'", collapse = ", "), call = FALSE)
|
||||
|
||||
guideline_param
|
||||
|
||||
@@ -569,11 +658,12 @@ exec_as.rsi <- function(method,
|
||||
guideline,
|
||||
uti,
|
||||
conserve_capped_values,
|
||||
add_intrinsic_resistance) {
|
||||
add_intrinsic_resistance,
|
||||
reference_data) {
|
||||
|
||||
metadata_mo <- get_mo_failures_uncertainties_renamed()
|
||||
|
||||
x_bak <- data.frame(x_mo = paste0(x, mo))
|
||||
x_bak <- data.frame(x_mo = paste0(x, mo), stringsAsFactors = FALSE)
|
||||
df <- unique(data.frame(x, mo), stringsAsFactors = FALSE)
|
||||
x <- df$x
|
||||
mo <- df$mo
|
||||
@@ -603,15 +693,20 @@ exec_as.rsi <- function(method,
|
||||
}
|
||||
mo_other <- as.mo(rep("UNKNOWN", length(mo)))
|
||||
|
||||
guideline_coerced <- get_guideline(guideline)
|
||||
guideline_coerced <- get_guideline(guideline, reference_data)
|
||||
if (guideline_coerced != guideline) {
|
||||
message(font_blue(paste0("Note: Using guideline ", font_bold(guideline_coerced), " as input for `guideline`.")))
|
||||
message_("Using guideline ", font_bold(guideline_coerced), " as input for `guideline`.")
|
||||
}
|
||||
|
||||
new_rsi <- rep(NA_character_, length(x))
|
||||
ab_param <- ab
|
||||
trans <- rsi_translation %pm>%
|
||||
subset(guideline == guideline_coerced & method == method_param & ab == ab_param)
|
||||
if (identical(reference_data, AMR::rsi_translation)) {
|
||||
trans <- reference_data %pm>%
|
||||
subset(guideline == guideline_coerced & method == method_param & ab == ab_param)
|
||||
} else {
|
||||
trans <- reference_data %pm>%
|
||||
subset(method == method_param & ab == ab_param)
|
||||
}
|
||||
trans$lookup <- paste(trans$mo, trans$ab)
|
||||
|
||||
lookup_mo <- paste(mo, ab)
|
||||
@@ -623,22 +718,23 @@ exec_as.rsi <- function(method,
|
||||
lookup_other <- paste(mo_other, ab)
|
||||
|
||||
if (all(trans$uti == TRUE, na.rm = TRUE) & all(uti == FALSE)) {
|
||||
message(font_red("WARNING."))
|
||||
warning("Interpretation of ", font_bold(ab_name(ab, tolower = TRUE)), " for some microorganisms is only available for (uncomplicated) urinary tract infections (UTI).\n Use parameter 'uti' to set which isolates are from urine. See ?as.rsi.", call. = FALSE)
|
||||
message_("WARNING.", add_fn = list(font_yellow, font_bold), as_note = FALSE)
|
||||
warning_("Interpretation of ", font_bold(ab_name(ab, tolower = TRUE)), " for some microorganisms is only available for (uncomplicated) urinary tract infections (UTI). Use parameter 'uti' to set which isolates are from urine. See ?as.rsi.", call = FALSE)
|
||||
warned <- TRUE
|
||||
}
|
||||
|
||||
any_is_intrinsic_resistant <- FALSE
|
||||
|
||||
for (i in seq_len(length(x))) {
|
||||
if (isTRUE(add_intrinsic_resistance)) {
|
||||
is_intrinsic_r <- paste(mo[i], ab) %in% INTRINSIC_R
|
||||
any_is_intrinsic_resistant <- any_is_intrinsic_resistant | is_intrinsic_r
|
||||
|
||||
if (isTRUE(add_intrinsic_resistance) & is_intrinsic_r) {
|
||||
if (!guideline_coerced %like% "EUCAST") {
|
||||
warning("Using 'add_intrinsic_resistance' is only useful when using EUCAST guidelines, since the rules for intrinsic resistance are based on EUCAST.", call. = FALSE)
|
||||
warning_("Using 'add_intrinsic_resistance' is only useful when using EUCAST guidelines, since the rules for intrinsic resistance are based on EUCAST.", call = FALSE)
|
||||
} else {
|
||||
get_record <- subset(intrinsic_resistant,
|
||||
microorganism == mo_name(mo[i], language = NULL) & antibiotic == ab_name(ab, language = NULL))
|
||||
if (nrow(get_record) > 0) {
|
||||
new_rsi[i] <- "R"
|
||||
next
|
||||
}
|
||||
new_rsi[i] <- "R"
|
||||
next
|
||||
}
|
||||
}
|
||||
|
||||
@@ -698,18 +794,27 @@ exec_as.rsi <- function(method,
|
||||
}
|
||||
}
|
||||
|
||||
if (any_is_intrinsic_resistant & guideline_coerced %like% "EUCAST" & !isTRUE(add_intrinsic_resistance)) {
|
||||
# found some intrinsic resistance, but was not applied
|
||||
message_("WARNING.", add_fn = list(font_yellow, font_bold), as_note = FALSE)
|
||||
warning_("Found intrinsic resistance in some bug/drug combinations, although it was not applied.\nUse `as.rsi(..., add_intrinsic_resistance = TRUE)` to apply it.", call = FALSE)
|
||||
warned <- TRUE
|
||||
}
|
||||
|
||||
new_rsi <- x_bak %pm>%
|
||||
pm_left_join(data.frame(x_mo = paste0(df$x, df$mo), new_rsi), by = "x_mo") %pm>%
|
||||
pm_left_join(data.frame(x_mo = paste0(df$x, df$mo), new_rsi,
|
||||
stringsAsFactors = FALSE),
|
||||
by = "x_mo") %pm>%
|
||||
pm_pull(new_rsi)
|
||||
|
||||
if (warned == FALSE) {
|
||||
message(font_green("OK."))
|
||||
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
|
||||
}
|
||||
|
||||
load_mo_failures_uncertainties_renamed(metadata_mo)
|
||||
|
||||
structure(.Data = factor(new_rsi, levels = c("S", "I", "R"), ordered = TRUE),
|
||||
class = c("rsi", "ordered", "factor"))
|
||||
set_clean_class(factor(new_rsi, levels = c("S", "I", "R"), ordered = TRUE),
|
||||
new_class = c("rsi", "ordered", "factor"))
|
||||
}
|
||||
|
||||
# will be exported using s3_register() in R/zzz.R
|
||||
@@ -731,20 +836,31 @@ type_sum.rsi <- function(x, ...) {
|
||||
freq.rsi <- function(x, ...) {
|
||||
x_name <- deparse(substitute(x))
|
||||
x_name <- gsub(".*[$]", "", x_name)
|
||||
if (x_name %in% c("x", ".")) {
|
||||
# try again going through system calls
|
||||
x_name <- stats::na.omit(sapply(sys.calls(),
|
||||
function(call) {
|
||||
call_txt <- as.character(call)
|
||||
ifelse(call_txt[1] %like% "freq$", call_txt[length(call_txt)], character(0))
|
||||
}))[1L]
|
||||
}
|
||||
ab <- suppressMessages(suppressWarnings(as.ab(x_name)))
|
||||
freq.default <- import_fn("freq.default", "cleaner", error_on_fail = FALSE)
|
||||
digits <- list(...)$digits
|
||||
if (is.null(digits)) {
|
||||
digits <- 2
|
||||
}
|
||||
if (!is.na(ab)) {
|
||||
freq.default(x = x, ...,
|
||||
.add_header = list(Drug = paste0(ab_name(ab, language = NULL), " (", ab, ", ", ab_atc(ab), ")"),
|
||||
`Drug group` = ab_group(ab, language = NULL),
|
||||
`%SI` = percentage(susceptibility(x, minimum = 0, as_percent = FALSE), digits = digits)))
|
||||
cleaner::freq.default(x = x, ...,
|
||||
.add_header = list(
|
||||
Drug = paste0(ab_name(ab, language = NULL), " (", ab, ", ", ab_atc(ab), ")"),
|
||||
`Drug group` = ab_group(ab, language = NULL),
|
||||
`%SI` = percentage(susceptibility(x, minimum = 0, as_percent = FALSE),
|
||||
digits = digits)))
|
||||
} else {
|
||||
freq.default(x = x, ...,
|
||||
.add_header = list(`%SI` = percentage(susceptibility(x, minimum = 0, as_percent = FALSE), digits = digits)))
|
||||
cleaner::freq.default(x = x, ...,
|
||||
.add_header = list(
|
||||
`%SI` = percentage(susceptibility(x, minimum = 0, as_percent = FALSE),
|
||||
digits = digits)))
|
||||
}
|
||||
}
|
||||
|
||||
@@ -779,8 +895,7 @@ get_skimmers.rsi <- function(column) {
|
||||
}
|
||||
}
|
||||
|
||||
sfl <- import_fn("sfl", "skimr", error_on_fail = FALSE)
|
||||
sfl(
|
||||
skimr::sfl(
|
||||
skim_type = "rsi",
|
||||
ab_name = name_call,
|
||||
count_R = count_R,
|
||||
@@ -803,7 +918,7 @@ print.rsi <- function(x, ...) {
|
||||
#' @method droplevels rsi
|
||||
#' @export
|
||||
#' @noRd
|
||||
droplevels.rsi <- function(x, exclude = if (anyNA(levels(x))) NULL else NA, ...) {
|
||||
droplevels.rsi <- function(x, exclude = if (any(is.na(levels(x)))) NULL else NA, ...) {
|
||||
x <- droplevels.factor(x, exclude = exclude, ...)
|
||||
class(x) <- c("rsi", "ordered", "factor")
|
||||
x
|
||||
@@ -850,18 +965,28 @@ plot.rsi <- function(x,
|
||||
main = paste("Resistance Overview of", deparse(substitute(x))),
|
||||
axes = FALSE,
|
||||
...) {
|
||||
meet_criteria(lwd, allow_class = c("numeric", "integer"), has_length = 1)
|
||||
meet_criteria(ylim, allow_class = c("numeric", "integer"), allow_NULL = TRUE)
|
||||
meet_criteria(ylab, allow_class = "character", has_length = 1)
|
||||
meet_criteria(xlab, allow_class = "character", has_length = 1)
|
||||
meet_criteria(main, allow_class = "character", has_length = 1)
|
||||
meet_criteria(axes, allow_class = "logical", has_length = 1)
|
||||
|
||||
data <- as.data.frame(table(x), stringsAsFactors = FALSE)
|
||||
colnames(data) <- c("x", "n")
|
||||
data$s <- round((data$n / sum(data$n)) * 100, 1)
|
||||
|
||||
if (!"S" %in% data$x) {
|
||||
data <- rbind(data, data.frame(x = "S", n = 0, s = 0))
|
||||
data <- rbind(data, data.frame(x = "S", n = 0, s = 0, stringsAsFactors = FALSE),
|
||||
stringsAsFactors = FALSE)
|
||||
}
|
||||
if (!"I" %in% data$x) {
|
||||
data <- rbind(data, data.frame(x = "I", n = 0, s = 0))
|
||||
data <- rbind(data, data.frame(x = "I", n = 0, s = 0, stringsAsFactors = FALSE),
|
||||
stringsAsFactors = FALSE)
|
||||
}
|
||||
if (!"R" %in% data$x) {
|
||||
data <- rbind(data, data.frame(x = "R", n = 0, s = 0))
|
||||
data <- rbind(data, data.frame(x = "R", n = 0, s = 0, stringsAsFactors = FALSE),
|
||||
stringsAsFactors = FALSE)
|
||||
}
|
||||
|
||||
# don't use as.rsi() here, it will confuse plot()
|
||||
@@ -901,6 +1026,12 @@ barplot.rsi <- function(height,
|
||||
beside = TRUE,
|
||||
axes = beside,
|
||||
...) {
|
||||
meet_criteria(col, allow_class = "character", has_length = 3)
|
||||
meet_criteria(xlab, allow_class = "character", has_length = 1)
|
||||
meet_criteria(main, allow_class = "character", has_length = 1)
|
||||
meet_criteria(ylab, allow_class = "character", has_length = 1)
|
||||
meet_criteria(beside, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(axes, allow_class = "logical", has_length = 1)
|
||||
|
||||
if (axes == TRUE) {
|
||||
par(mar = c(5, 4, 4, 2) + 0.1)
|
||||
@@ -958,3 +1089,17 @@ unique.rsi <- function(x, incomparables = FALSE, ...) {
|
||||
attributes(y) <- attributes(x)
|
||||
y
|
||||
}
|
||||
|
||||
check_reference_data <- function(reference_data) {
|
||||
if (!identical(reference_data, AMR::rsi_translation)) {
|
||||
class_rsi <- sapply(rsi_translation, function(x) paste0("<", class(x), ">", collapse = " and "))
|
||||
class_ref <- sapply(reference_data, function(x) paste0("<", class(x), ">", collapse = " and "))
|
||||
if (!all(names(class_rsi) == names(class_ref))) {
|
||||
stop_("`reference_data` must have the same column names as the 'rsi_translation' data set.", call = -2)
|
||||
}
|
||||
if (!all(class_rsi == class_ref)) {
|
||||
class_rsi[class_rsi != class_ref][1]
|
||||
stop_("`reference_data` must be the same structure as the 'rsi_translation' data set. Column '", names(class_ref[class_rsi != class_ref][1]), "' is of class ", class_ref[class_rsi != class_ref][1], ", but should be of class ", class_rsi[class_rsi != class_ref][1], ".", call = -2)
|
||||
}
|
||||
}
|
||||
}
|
||||
+26
-17
@@ -36,10 +36,11 @@ rsi_calc <- function(...,
|
||||
as_percent = FALSE,
|
||||
only_all_tested = FALSE,
|
||||
only_count = FALSE) {
|
||||
|
||||
stop_ifnot(is.numeric(minimum), "`minimum` must be numeric", call = -2)
|
||||
stop_ifnot(is.logical(as_percent), "`as_percent` must be logical", call = -2)
|
||||
stop_ifnot(is.logical(only_all_tested), "`only_all_tested` must be logical", call = -2)
|
||||
meet_criteria(ab_result, allow_class = c("character", "numeric", "integer"), has_length = c(1, 2, 3), .call_depth = 1)
|
||||
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, .call_depth = 1)
|
||||
meet_criteria(as_percent, allow_class = "logical", has_length = 1, .call_depth = 1)
|
||||
meet_criteria(only_all_tested, allow_class = "logical", has_length = 1, .call_depth = 1)
|
||||
meet_criteria(only_count, allow_class = "logical", has_length = 1, .call_depth = 1)
|
||||
|
||||
data_vars <- dots2vars(...)
|
||||
|
||||
@@ -94,8 +95,12 @@ rsi_calc <- function(...,
|
||||
}
|
||||
|
||||
if (is.null(x)) {
|
||||
warning("argument is NULL (check if columns exist): returning NA", call. = FALSE)
|
||||
return(NA)
|
||||
warning_("argument is NULL (check if columns exist): returning NA", call = FALSE)
|
||||
if (as_percent == TRUE) {
|
||||
return(NA_character_)
|
||||
} else {
|
||||
return(NA_real_)
|
||||
}
|
||||
}
|
||||
|
||||
print_warning <- FALSE
|
||||
@@ -117,7 +122,7 @@ rsi_calc <- function(...,
|
||||
rsi_integrity_check <- as.rsi(rsi_integrity_check)
|
||||
}
|
||||
|
||||
x_transposed <- as.list(as.data.frame(t(x)))
|
||||
x_transposed <- as.list(as.data.frame(t(x), stringsAsFactors = FALSE))
|
||||
if (only_all_tested == TRUE) {
|
||||
# no NAs in any column
|
||||
y <- apply(X = as.data.frame(lapply(x, as.integer), stringsAsFactors = FALSE),
|
||||
@@ -142,8 +147,8 @@ rsi_calc <- function(...,
|
||||
}
|
||||
|
||||
if (print_warning == TRUE) {
|
||||
warning("Increase speed by transforming to class <rsi> on beforehand: your_data %pm>% mutate_if(is.rsi.eligible, as.rsi)",
|
||||
call. = FALSE)
|
||||
warning_("Increase speed by transforming to class <rsi> on beforehand: your_data %pm>% mutate_if(is.rsi.eligible, as.rsi)",
|
||||
call = FALSE)
|
||||
}
|
||||
|
||||
if (only_count == TRUE) {
|
||||
@@ -154,7 +159,7 @@ rsi_calc <- function(...,
|
||||
if (data_vars != "") {
|
||||
data_vars <- paste(" for", data_vars)
|
||||
}
|
||||
warning("Introducing NA: only ", denominator, " results available", data_vars, " (`minimum` = ", minimum, ").", call. = FALSE)
|
||||
warning_("Introducing NA: only ", denominator, " results available", data_vars, " (`minimum` = ", minimum, ").", call = FALSE)
|
||||
fraction <- NA_real_
|
||||
} else {
|
||||
fraction <- numerator / denominator
|
||||
@@ -177,17 +182,21 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
|
||||
combine_SI = TRUE,
|
||||
combine_IR = FALSE,
|
||||
combine_SI_missing = FALSE) {
|
||||
meet_criteria(type, is_in = c("proportion", "count", "both"), has_length = 1, .call_depth = 1)
|
||||
meet_criteria(data, allow_class = "data.frame", contains_column_class = "rsi", .call_depth = 1)
|
||||
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE, .call_depth = 1)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE, .call_depth = 1)
|
||||
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, .call_depth = 1)
|
||||
meet_criteria(as_percent, allow_class = "logical", has_length = 1, .call_depth = 1)
|
||||
meet_criteria(combine_SI, allow_class = "logical", has_length = 1, .call_depth = 1)
|
||||
meet_criteria(combine_SI_missing, allow_class = "logical", has_length = 1, .call_depth = 1)
|
||||
|
||||
check_dataset_integrity()
|
||||
stop_ifnot(is.data.frame(data), "`data` must be a data.frame", call = -2)
|
||||
stop_if(any(dim(data) == 0), "`data` must contain rows and columns", call = -2)
|
||||
stop_ifnot(any(sapply(data, is.rsi), na.rm = TRUE), "no columns with class <rsi> found. See ?as.rsi.", call = -2)
|
||||
|
||||
if (isTRUE(combine_IR) & isTRUE(combine_SI_missing)) {
|
||||
combine_SI <- FALSE
|
||||
}
|
||||
stop_if(isTRUE(combine_SI) & isTRUE(combine_IR), "either `combine_SI` or `combine_IR` can be TRUE, not both", call = -2)
|
||||
stop_ifnot(is.numeric(minimum), "`minimum` must be numeric", call = -2)
|
||||
stop_ifnot(is.logical(as_percent), "`as_percent` must be logical", call = -2)
|
||||
|
||||
translate_ab <- get_translate_ab(translate_ab)
|
||||
|
||||
@@ -235,7 +244,7 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
|
||||
} else {
|
||||
values <- factor(values, levels = c("S", "I", "R"), ordered = TRUE)
|
||||
}
|
||||
col_results <- as.data.frame(as.matrix(table(values)))
|
||||
col_results <- as.data.frame(as.matrix(table(values)), stringsAsFactors = FALSE)
|
||||
col_results$interpretation <- rownames(col_results)
|
||||
col_results$isolates <- col_results[, 1, drop = TRUE]
|
||||
if (NROW(col_results) > 0 && sum(col_results$isolates, na.rm = TRUE) > 0) {
|
||||
@@ -260,7 +269,7 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
|
||||
}
|
||||
out_new <- cbind(group_values, out_new)
|
||||
}
|
||||
out <- rbind(out, out_new)
|
||||
out <- rbind(out, out_new, stringsAsFactors = FALSE)
|
||||
}
|
||||
}
|
||||
out
|
||||
|
||||
@@ -32,7 +32,6 @@ rsi_df <- function(data,
|
||||
as_percent = FALSE,
|
||||
combine_SI = TRUE,
|
||||
combine_IR = FALSE) {
|
||||
|
||||
rsi_calc_df(type = "both",
|
||||
data = data,
|
||||
translate_ab = translate_ab,
|
||||
|
||||
@@ -36,6 +36,7 @@
|
||||
#' @inheritSection AMR Read more on our website!
|
||||
#' @export
|
||||
skewness <- function(x, na.rm = FALSE) {
|
||||
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
|
||||
UseMethod("skewness")
|
||||
}
|
||||
|
||||
@@ -43,6 +44,7 @@ skewness <- function(x, na.rm = FALSE) {
|
||||
#' @rdname skewness
|
||||
#' @export
|
||||
skewness.default <- function(x, na.rm = FALSE) {
|
||||
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
|
||||
x <- as.vector(x)
|
||||
if (na.rm == TRUE) {
|
||||
x <- x[!is.na(x)]
|
||||
@@ -55,6 +57,7 @@ skewness.default <- function(x, na.rm = FALSE) {
|
||||
#' @rdname skewness
|
||||
#' @export
|
||||
skewness.matrix <- function(x, na.rm = FALSE) {
|
||||
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
|
||||
apply(x, 2, skewness.default, na.rm = na.rm)
|
||||
}
|
||||
|
||||
@@ -62,5 +65,6 @@ skewness.matrix <- function(x, na.rm = FALSE) {
|
||||
#' @rdname skewness
|
||||
#' @export
|
||||
skewness.data.frame <- function(x, na.rm = FALSE) {
|
||||
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
|
||||
sapply(x, skewness.default, na.rm = na.rm)
|
||||
}
|
||||
Binary file not shown.
+11
-11
@@ -27,7 +27,7 @@
|
||||
#'
|
||||
#' For language-dependent output of AMR functions, like [mo_name()], [mo_gramstain()], [mo_type()] and [ab_name()].
|
||||
#' @inheritSection lifecycle Stable lifecycle
|
||||
#' @details Strings will be translated to foreign languages if they are defined in a local translation file. Additions to this file can be suggested at our repository. The file can be found here: <https://github.com/msberends/AMR/blob/master/data-raw/translations.tsv>. This file will be read by all functions where a translated output can be desired, like all [mo_property()] functions ([mo_name()], [mo_gramstain()], [mo_type()], etc.) and [ab_property()] functions ([ab_name()], [ab_group()] etc.).
|
||||
#' @details Strings will be translated to foreign languages if they are defined in a local translation file. Additions to this file can be suggested at our repository. The file can be found here: <https://github.com/msberends/AMR/blob/master/data-raw/translations.tsv>. This file will be read by all functions where a translated output can be desired, like all [`mo_*`][mo_property()] functions (such as [mo_name()], [mo_gramstain()], [mo_type()], etc.) and [`ab_*`][ab_property()] functions (such as [ab_name()], [ab_group()], etc.).
|
||||
#'
|
||||
#' Currently supported languages are: `r paste(sort(gsub(";.*", "", ISOcodes::ISO_639_2[which(ISOcodes::ISO_639_2$Alpha_2 %in% LANGUAGES_SUPPORTED), "Name"])), collapse = ", ")`. Please note that currently not all these languages have translations available for all antimicrobial agents and colloquial microorganism names.
|
||||
#'
|
||||
@@ -73,7 +73,7 @@
|
||||
#' mo_name("CoNS", language = "pt")
|
||||
#' #> "Staphylococcus coagulase negativo (CoNS)"
|
||||
get_locale <- function() {
|
||||
# AMR versions prior to 1.3.0 used the environmental variable:
|
||||
# AMR versions 1.3.0 and prior used the environmental variable:
|
||||
if (!identical("", Sys.getenv("AMR_locale"))) {
|
||||
options(AMR_locale = Sys.getenv("AMR_locale"))
|
||||
}
|
||||
@@ -96,25 +96,25 @@ get_locale <- function() {
|
||||
}
|
||||
}
|
||||
|
||||
coerce_language_setting(Sys.getlocale())
|
||||
coerce_language_setting(Sys.getlocale("LC_COLLATE"))
|
||||
}
|
||||
|
||||
coerce_language_setting <- function(lang) {
|
||||
# grepl() with ignore.case = FALSE is faster than %like%
|
||||
if (grepl("^(English|en_|EN_)", lang, ignore.case = FALSE)) {
|
||||
if (grepl("^(English|en_|EN_)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
# as first option to optimise speed
|
||||
"en"
|
||||
} else if (grepl("^(German|Deutsch|de_|DE_)", lang, ignore.case = FALSE)) {
|
||||
} else if (grepl("^(German|Deutsch|de_|DE_)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
"de"
|
||||
} else if (grepl("^(Dutch|Nederlands|nl_|NL_)", lang, ignore.case = FALSE)) {
|
||||
} else if (grepl("^(Dutch|Nederlands|nl_|NL_)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
"nl"
|
||||
} else if (grepl("^(Spanish|Espa.+ol|es_|ES_)", lang, ignore.case = FALSE)) {
|
||||
} else if (grepl("^(Spanish|Espa.+ol|es_|ES_)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
"es"
|
||||
} else if (grepl("^(Italian|Italiano|it_|IT_)", lang, ignore.case = FALSE)) {
|
||||
} else if (grepl("^(Italian|Italiano|it_|IT_)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
"it"
|
||||
} else if (grepl("^(French|Fran.+ais|fr_|FR_)", lang, ignore.case = FALSE)) {
|
||||
} else if (grepl("^(French|Fran.+ais|fr_|FR_)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
"fr"
|
||||
} else if (grepl("^(Portuguese|Portugu.+s|pt_|PT_)", lang, ignore.case = FALSE)) {
|
||||
} else if (grepl("^(Portuguese|Portugu.+s|pt_|PT_)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
"pt"
|
||||
} else {
|
||||
# other language -> set to English
|
||||
@@ -155,7 +155,7 @@ translate_AMR <- function(from, language = get_locale(), only_unknown = FALSE) {
|
||||
# check if text to look for is in one of the patterns
|
||||
any_form_in_patterns <- tryCatch(any(from_unique %like% paste0("(", paste(df_trans$pattern, collapse = "|"), ")")),
|
||||
error = function(e) {
|
||||
warning("Translation not possible. Please open an issue on GitHub (https://github.com/msberends/AMR/issues).", call. = FALSE)
|
||||
warning_("Translation not possible. Please open an issue on GitHub (https://github.com/msberends/AMR/issues).", call = FALSE)
|
||||
return(FALSE)
|
||||
})
|
||||
if (NROW(df_trans) == 0 | !any_form_in_patterns) {
|
||||
|
||||
@@ -24,6 +24,7 @@
|
||||
# ==================================================================== #
|
||||
|
||||
.onLoad <- function(libname, pkgname) {
|
||||
|
||||
assign(x = "AB_lookup",
|
||||
value = create_AB_lookup(),
|
||||
envir = asNamespace("AMR"))
|
||||
@@ -36,6 +37,10 @@
|
||||
value = create_MO.old_lookup(),
|
||||
envir = asNamespace("AMR"))
|
||||
|
||||
assign(x = "INTRINSIC_R",
|
||||
value = create_intr_resistance(),
|
||||
envir = asNamespace("AMR"))
|
||||
|
||||
assign(x = "LANGUAGES_SUPPORTED",
|
||||
value = sort(c("en", unique(translations_file$lang))),
|
||||
envir = asNamespace("AMR"))
|
||||
@@ -77,30 +82,41 @@
|
||||
if (!interactive() || stats::runif(1) > 0.1 || isTRUE(as.logical(getOption("AMR_silentstart", FALSE)))) {
|
||||
return()
|
||||
}
|
||||
packageStartupMessage("Thank you for using the AMR package! ",
|
||||
"If you have a minute, please anonymously fill in this short questionnaire to improve the package and its functionalities:",
|
||||
"\nhttps://msberends.github.io/AMR/survey.html",
|
||||
"\n[ prevent his notice with suppressPackageStartupMessages(library(AMR)) or use options(AMR_silentstart = TRUE) ]")
|
||||
packageStartupMessage(word_wrap("Thank you for using the AMR package! ",
|
||||
"If you have a minute, please anonymously fill in this short questionnaire to improve the package and its functionalities: ",
|
||||
font_blue("https://msberends.github.io/AMR/survey.html\n"),
|
||||
"[prevent his notice with ",
|
||||
font_bold("suppressPackageStartupMessages(library(AMR))"),
|
||||
" or use ",
|
||||
font_bold("options(AMR_silentstart = TRUE)"), "]"))
|
||||
}
|
||||
|
||||
create_intr_resistance <- function() {
|
||||
# for mo_is_intrinsic_resistant() - saves a lot of time when executed on this vector
|
||||
paste(AMR::microorganisms[match(AMR::intrinsic_resistant$microorganism, AMR::microorganisms$fullname), "mo", drop = TRUE],
|
||||
AMR::antibiotics[match(AMR::intrinsic_resistant$antibiotic, AMR::antibiotics$name), "ab", drop = TRUE])
|
||||
}
|
||||
|
||||
create_species_cons_cops <- function(type = c("CoNS", "CoPS")) {
|
||||
# Determination of which staphylococcal species are CoNS/CoPS according to Becker et al.:
|
||||
# https://cmr.asm.org/content/cmr/27/4/870/F6.large.jpg
|
||||
# Determination of which staphylococcal species are CoNS/CoPS according to:
|
||||
# - Becker et al. 2014, PMID 25278577
|
||||
# - Becker et al. 2019, PMID 30872103
|
||||
# - Becker et al. 2020, PMID 32056452
|
||||
# this function returns class <mo>
|
||||
MO_staph <- AMR::microorganisms
|
||||
MO_staph <- MO_staph[which(MO_staph$genus == "Staphylococcus"), , drop = FALSE]
|
||||
if (type == "CoNS") {
|
||||
MO_staph[which(MO_staph$species %in% c("coagulase-negative",
|
||||
"arlettae", "auricularis", "capitis",
|
||||
"caprae", "carnosus", "chromogenes", "cohnii", "condimenti",
|
||||
"devriesei", "epidermidis", "equorum", "felis",
|
||||
"fleurettii", "gallinarum", "haemolyticus",
|
||||
"hominis", "jettensis", "kloosii", "lentus",
|
||||
"lugdunensis", "massiliensis", "microti",
|
||||
MO_staph[which(MO_staph$species %in% c("coagulase-negative", "argensis", "arlettae",
|
||||
"auricularis", "caeli", "capitis", "caprae",
|
||||
"carnosus", "chromogenes", "cohnii", "condimenti",
|
||||
"debuckii", "devriesei", "edaphicus", "epidermidis",
|
||||
"equorum", "felis", "fleurettii", "gallinarum",
|
||||
"haemolyticus", "hominis", "jettensis", "kloosii",
|
||||
"lentus", "lugdunensis", "massiliensis", "microti",
|
||||
"muscae", "nepalensis", "pasteuri", "petrasii",
|
||||
"pettenkoferi", "piscifermentans", "rostri",
|
||||
"saccharolyticus", "saprophyticus", "sciuri",
|
||||
"stepanovicii", "simulans", "succinus",
|
||||
"pettenkoferi", "piscifermentans", "pseudoxylosus",
|
||||
"rostri", "saccharolyticus", "saprophyticus",
|
||||
"sciuri", "simulans", "stepanovicii", "succinus",
|
||||
"vitulinus", "warneri", "xylosus")
|
||||
| (MO_staph$species == "schleiferi" & MO_staph$subspecies %in% c("schleiferi", ""))),
|
||||
"mo", drop = TRUE]
|
||||
|
||||
@@ -2,8 +2,8 @@
|
||||
|
||||
# `AMR` (for R)
|
||||
|
||||
<img src="https://www.r-pkg.org/badges/version-ago/AMR" />
|
||||
<img src="https://cranlogs.r-pkg.org/badges/grand-total/AMR" />
|
||||
[](https://cran.R-project.org/package=AMR) [](https://cran.R-project.org/package=AMR)
|
||||
[](https://codecov.io/gh/msberends/AMR/branch/master)
|
||||
|
||||
<img src="https://msberends.github.io/AMR/works_great_on.png" align="center" height="150px" />
|
||||
|
||||
@@ -20,6 +20,8 @@ This is the development source of the `AMR` package for R. Not a developer? Then
|
||||
### How to get this package
|
||||
Please see [our website](https://msberends.github.io/AMR/#get-this-package).
|
||||
|
||||
Bottom line: `install.packages("AMR")`
|
||||
|
||||
### Copyright
|
||||
|
||||
This R package is licensed under the [GNU General Public License (GPL) v2.0](https://github.com/msberends/AMR/blob/master/LICENSE). In a nutshell, this means that this package:
|
||||
|
||||
+11
-10
@@ -147,11 +147,12 @@ reference:
|
||||
- title: "Analysing data: antimicrobial resistance"
|
||||
desc: >
|
||||
Use these function for the analysis part. You can use `susceptibility()` or `resistance()` on any antibiotic column.
|
||||
Be sure to first select the isolates that are appropiate for analysis, by using `first_isolate()`.
|
||||
Be sure to first select the isolates that are appropiate for analysis, by using `first_isolate()` or `is_new_episode()`.
|
||||
You can also filter your data on certain resistance in certain antibiotic classes (`filter_ab_class()`), or determine multi-drug resistant microorganisms (MDRO, `mdro()`).
|
||||
contents:
|
||||
- "`proportion`"
|
||||
- "`count`"
|
||||
- "`is_new_episode`"
|
||||
- "`first_isolate`"
|
||||
- "`key_antibiotics`"
|
||||
- "`mdro`"
|
||||
@@ -178,23 +179,23 @@ reference:
|
||||
- "`like`"
|
||||
- "`mo_matching_score`"
|
||||
- "`pca`"
|
||||
- "`random`"
|
||||
|
||||
- title: "Other: statistical tests"
|
||||
desc: >
|
||||
Some statistical tests or methods are not part of base R and are added to this package for convenience.
|
||||
Some statistical tests or methods are not part of base R and were added to this package for convenience.
|
||||
contents:
|
||||
- "`g.test`"
|
||||
- "`kurtosis`"
|
||||
- "`skewness`"
|
||||
- "`p_symbol`"
|
||||
|
||||
# - title: "Other: deprecated functions"
|
||||
# desc: >
|
||||
# These functions are deprecated, meaning that they will still
|
||||
# work but show a warning with every use and will be removed
|
||||
# in a future version.
|
||||
# contents:
|
||||
# - "`AMR-deprecated`"
|
||||
- title: "Other: deprecated functions"
|
||||
desc: >
|
||||
These functions are deprecated, meaning that they will still
|
||||
work but show a warning with every use and will be removed
|
||||
in a future version.
|
||||
contents:
|
||||
- "`AMR-deprecated`"
|
||||
|
||||
authors:
|
||||
Matthijs S. Berends:
|
||||
|
||||
@@ -75,3 +75,7 @@ contents <- gsub("pm_distinct <- function(.data, ..., .keep_all = FALSE)", "pm_d
|
||||
contents <- contents[!grepl("summarize", contents)]
|
||||
|
||||
writeLines(contents, "R/aa_helper_pm_functions.R")
|
||||
|
||||
# after this, comment out:
|
||||
# pm_left_join() since we use a faster version
|
||||
# pm_group_split() since we don't use it and it relies on R 3.5.0 for the use of ...length(), which is hard to support with C++ code
|
||||
+20
-20
@@ -81,7 +81,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<a class="navbar-link" href="https://msberends.github.io/AMR//index.html">AMR (for R)</a>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9041</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
@@ -89,14 +89,14 @@
|
||||
<ul class="nav navbar-nav">
|
||||
<li>
|
||||
<a href="index.html">
|
||||
<span class="fa fa-home"></span>
|
||||
<span class="fas fa-home"></span>
|
||||
|
||||
Home
|
||||
</a>
|
||||
</li>
|
||||
<li class="dropdown">
|
||||
<a href="#" class="dropdown-toggle" data-toggle="dropdown" role="button" aria-expanded="false">
|
||||
<span class="fa fa-question-circle"></span>
|
||||
<span class="fas fa-question-circle"></span>
|
||||
|
||||
How to
|
||||
|
||||
@@ -105,77 +105,77 @@
|
||||
<ul class="dropdown-menu" role="menu">
|
||||
<li>
|
||||
<a href="articles/AMR.html">
|
||||
<span class="fa fa-directions"></span>
|
||||
<span class="fas fa-directions"></span>
|
||||
|
||||
Conduct AMR analysis
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="articles/resistance_predict.html">
|
||||
<span class="fa fa-dice"></span>
|
||||
<span class="fas fa-dice"></span>
|
||||
|
||||
Predict antimicrobial resistance
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="articles/datasets.html">
|
||||
<span class="fa fa-database"></span>
|
||||
<span class="fas fa-database"></span>
|
||||
|
||||
Data sets for download / own use
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="articles/PCA.html">
|
||||
<span class="fa fa-compress"></span>
|
||||
<span class="fas fa-compress"></span>
|
||||
|
||||
Conduct principal component analysis for AMR
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="articles/MDR.html">
|
||||
<span class="fa fa-skull-crossbones"></span>
|
||||
<span class="fas fa-skull-crossbones"></span>
|
||||
|
||||
Determine multi-drug resistance (MDR)
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="articles/WHONET.html">
|
||||
<span class="fa fa-globe-americas"></span>
|
||||
<span class="fas fa-globe-americas"></span>
|
||||
|
||||
Work with WHONET data
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="articles/SPSS.html">
|
||||
<span class="fa fa-file-upload"></span>
|
||||
<span class="fas fa-file-upload"></span>
|
||||
|
||||
Import data from SPSS/SAS/Stata
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="articles/EUCAST.html">
|
||||
<span class="fa fa-exchange-alt"></span>
|
||||
<span class="fas fa-exchange-alt"></span>
|
||||
|
||||
Apply EUCAST rules
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="reference/mo_property.html">
|
||||
<span class="fa fa-bug"></span>
|
||||
<span class="fas fa-bug"></span>
|
||||
|
||||
Get properties of a microorganism
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="reference/ab_property.html">
|
||||
<span class="fa fa-capsules"></span>
|
||||
<span class="fas fa-capsules"></span>
|
||||
|
||||
Get properties of an antibiotic
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="articles/benchmarks.html">
|
||||
<span class="fa fa-shipping-fast"></span>
|
||||
<span class="fas fa-shipping-fast"></span>
|
||||
|
||||
Other: benchmarks
|
||||
</a>
|
||||
@@ -184,21 +184,21 @@
|
||||
</li>
|
||||
<li>
|
||||
<a href="reference/index.html">
|
||||
<span class="fa fa-book-open"></span>
|
||||
<span class="fas fa-book-open"></span>
|
||||
|
||||
Manual
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="authors.html">
|
||||
<span class="fa fa-users"></span>
|
||||
<span class="fas fa-users"></span>
|
||||
|
||||
Authors
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="news/index.html">
|
||||
<span class="far fa far fa-newspaper"></span>
|
||||
<span class="far fa-newspaper"></span>
|
||||
|
||||
Changelog
|
||||
</a>
|
||||
@@ -207,14 +207,14 @@
|
||||
<ul class="nav navbar-nav navbar-right">
|
||||
<li>
|
||||
<a href="https://github.com/msberends/AMR">
|
||||
<span class="fab fa fab fa-github"></span>
|
||||
<span class="fab fa-github"></span>
|
||||
|
||||
Source Code
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="survey.html">
|
||||
<span class="fa fa-clipboard-list"></span>
|
||||
<span class="fas fa-clipboard-list"></span>
|
||||
|
||||
Survey
|
||||
</a>
|
||||
@@ -255,7 +255,7 @@ Content not found. Please use links in the navbar.
|
||||
</div>
|
||||
|
||||
<div class="pkgdown">
|
||||
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.9000.</p>
|
||||
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.6.1.</p>
|
||||
</div>
|
||||
|
||||
</footer>
|
||||
|
||||
+20
-20
@@ -81,7 +81,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<a class="navbar-link" href="index.html">AMR (for R)</a>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9041</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
@@ -89,14 +89,14 @@
|
||||
<ul class="nav navbar-nav">
|
||||
<li>
|
||||
<a href="index.html">
|
||||
<span class="fa fa-home"></span>
|
||||
<span class="fas fa-home"></span>
|
||||
|
||||
Home
|
||||
</a>
|
||||
</li>
|
||||
<li class="dropdown">
|
||||
<a href="#" class="dropdown-toggle" data-toggle="dropdown" role="button" aria-expanded="false">
|
||||
<span class="fa fa-question-circle"></span>
|
||||
<span class="fas fa-question-circle"></span>
|
||||
|
||||
How to
|
||||
|
||||
@@ -105,77 +105,77 @@
|
||||
<ul class="dropdown-menu" role="menu">
|
||||
<li>
|
||||
<a href="articles/AMR.html">
|
||||
<span class="fa fa-directions"></span>
|
||||
<span class="fas fa-directions"></span>
|
||||
|
||||
Conduct AMR analysis
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="articles/resistance_predict.html">
|
||||
<span class="fa fa-dice"></span>
|
||||
<span class="fas fa-dice"></span>
|
||||
|
||||
Predict antimicrobial resistance
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="articles/datasets.html">
|
||||
<span class="fa fa-database"></span>
|
||||
<span class="fas fa-database"></span>
|
||||
|
||||
Data sets for download / own use
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="articles/PCA.html">
|
||||
<span class="fa fa-compress"></span>
|
||||
<span class="fas fa-compress"></span>
|
||||
|
||||
Conduct principal component analysis for AMR
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="articles/MDR.html">
|
||||
<span class="fa fa-skull-crossbones"></span>
|
||||
<span class="fas fa-skull-crossbones"></span>
|
||||
|
||||
Determine multi-drug resistance (MDR)
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="articles/WHONET.html">
|
||||
<span class="fa fa-globe-americas"></span>
|
||||
<span class="fas fa-globe-americas"></span>
|
||||
|
||||
Work with WHONET data
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="articles/SPSS.html">
|
||||
<span class="fa fa-file-upload"></span>
|
||||
<span class="fas fa-file-upload"></span>
|
||||
|
||||
Import data from SPSS/SAS/Stata
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="articles/EUCAST.html">
|
||||
<span class="fa fa-exchange-alt"></span>
|
||||
<span class="fas fa-exchange-alt"></span>
|
||||
|
||||
Apply EUCAST rules
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="reference/mo_property.html">
|
||||
<span class="fa fa-bug"></span>
|
||||
<span class="fas fa-bug"></span>
|
||||
|
||||
Get properties of a microorganism
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="reference/ab_property.html">
|
||||
<span class="fa fa-capsules"></span>
|
||||
<span class="fas fa-capsules"></span>
|
||||
|
||||
Get properties of an antibiotic
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="articles/benchmarks.html">
|
||||
<span class="fa fa-shipping-fast"></span>
|
||||
<span class="fas fa-shipping-fast"></span>
|
||||
|
||||
Other: benchmarks
|
||||
</a>
|
||||
@@ -184,21 +184,21 @@
|
||||
</li>
|
||||
<li>
|
||||
<a href="reference/index.html">
|
||||
<span class="fa fa-book-open"></span>
|
||||
<span class="fas fa-book-open"></span>
|
||||
|
||||
Manual
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="authors.html">
|
||||
<span class="fa fa-users"></span>
|
||||
<span class="fas fa-users"></span>
|
||||
|
||||
Authors
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="news/index.html">
|
||||
<span class="far fa far fa-newspaper"></span>
|
||||
<span class="far fa-newspaper"></span>
|
||||
|
||||
Changelog
|
||||
</a>
|
||||
@@ -207,14 +207,14 @@
|
||||
<ul class="nav navbar-nav navbar-right">
|
||||
<li>
|
||||
<a href="https://github.com/msberends/AMR">
|
||||
<span class="fab fa fab fa-github"></span>
|
||||
<span class="fab fa-github"></span>
|
||||
|
||||
Source Code
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="survey.html">
|
||||
<span class="fa fa-clipboard-list"></span>
|
||||
<span class="fas fa-clipboard-list"></span>
|
||||
|
||||
Survey
|
||||
</a>
|
||||
@@ -503,7 +503,7 @@ END OF TERMS AND CONDITIONS
|
||||
</div>
|
||||
|
||||
<div class="pkgdown">
|
||||
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.9000.</p>
|
||||
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.6.1.</p>
|
||||
</div>
|
||||
|
||||
</footer>
|
||||
|
||||
+408
-443
File diff suppressed because it is too large.
Load diff
Binary file not shown.
|
Before Width: | Height: | Size: 64 KiB After Width: | Height: | Size: 38 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 51 KiB After Width: | Height: | Size: 26 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 102 KiB After Width: | Height: | Size: 68 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 83 KiB After Width: | Height: | Size: 45 KiB |
@@ -0,0 +1,12 @@
|
||||
// Pandoc 2.9 adds attributes on both header and div. We remove the former (to
|
||||
// be compatible with the behavior of Pandoc < 2.8).
|
||||
document.addEventListener('DOMContentLoaded', function(e) {
|
||||
var hs = document.querySelectorAll("div.section[class*='level'] > :first-child");
|
||||
var i, h, a;
|
||||
for (i = 0; i < hs.length; i++) {
|
||||
h = hs[i];
|
||||
if (!/^h[1-6]$/i.test(h.tagName)) continue; // it should be a header h1-h6
|
||||
a = h.attributes;
|
||||
while (a.length > 0) h.removeAttribute(a[0].name);
|
||||
}
|
||||
});
|
||||
+33
-28
@@ -39,7 +39,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<a class="navbar-link" href="../index.html">AMR (for R)</a>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9034</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
@@ -187,7 +187,7 @@
|
||||
|
||||
|
||||
|
||||
</header><script src="EUCAST_files/header-attrs-2.3/header-attrs.js"></script><script src="EUCAST_files/accessible-code-block-0.0.1/empty-anchor.js"></script><div class="row">
|
||||
</header><script src="EUCAST_files/header-attrs-2.4/header-attrs.js"></script><script src="EUCAST_files/accessible-code-block-0.0.1/empty-anchor.js"></script><div class="row">
|
||||
<div class="col-md-9 contents">
|
||||
<div class="page-header toc-ignore">
|
||||
<h1 data-toc-skip>How to apply EUCAST rules</h1>
|
||||
@@ -216,38 +216,44 @@
|
||||
<p>These rules can be used to discard impossible bug-drug combinations in your data. For example, <em>Klebsiella</em> produces beta-lactamase that prevents ampicillin (or amoxicillin) from working against it. In other words, practically every strain of <em>Klebsiella</em> is resistant to ampicillin.</p>
|
||||
<p>Sometimes, laboratory data can still contain such strains with ampicillin being susceptible to ampicillin. This could be because an antibiogram is available before an identification is available, and the antibiogram is then not re-interpreted based on the identification (namely, <em>Klebsiella</em>). EUCAST expert rules solve this, that can be applied using <code><a href="../reference/eucast_rules.html">eucast_rules()</a></code>:</p>
|
||||
<div class="sourceCode" id="cb1"><pre class="downlit">
|
||||
<span class="kw">oops</span> <span class="op"><-</span> <span class="fu"><a href="https://rdrr.io/r/base/data.frame.html">data.frame</a></span>(mo = <span class="fu"><a href="https://rdrr.io/r/base/c.html">c</a></span>(<span class="st">"Klebsiella"</span>,
|
||||
<span class="st">"Escherichia"</span>),
|
||||
ampicillin = <span class="st">"S"</span>)
|
||||
<span class="kw">oops</span>
|
||||
<span class="va">oops</span> <span class="op"><-</span> <span class="fu"><a href="https://rdrr.io/r/base/data.frame.html">data.frame</a></span><span class="op">(</span>mo <span class="op">=</span> <span class="fu"><a href="https://rdrr.io/r/base/c.html">c</a></span><span class="op">(</span><span class="st">"Klebsiella"</span>,
|
||||
<span class="st">"Escherichia"</span><span class="op">)</span>,
|
||||
ampicillin <span class="op">=</span> <span class="st">"S"</span><span class="op">)</span>
|
||||
<span class="va">oops</span>
|
||||
<span class="co"># mo ampicillin</span>
|
||||
<span class="co"># 1 Klebsiella S</span>
|
||||
<span class="co"># 2 Escherichia S</span>
|
||||
|
||||
<span class="fu"><a href="../reference/eucast_rules.html">eucast_rules</a></span>(<span class="kw">oops</span>, info = <span class="fl">FALSE</span>)
|
||||
<span class="fu"><a href="../reference/eucast_rules.html">eucast_rules</a></span><span class="op">(</span><span class="va">oops</span>, info <span class="op">=</span> <span class="cn">FALSE</span><span class="op">)</span>
|
||||
<span class="co"># mo ampicillin</span>
|
||||
<span class="co"># 1 Klebsiella R</span>
|
||||
<span class="co"># 2 Escherichia S</span>
|
||||
</pre></div>
|
||||
<p>EUCAST rules can not only be used for correction, they can also be used for filling in known resistance and susceptibility based on results of other antimicrobials drugs. This process is called <em>interpretive reading</em> and is part of the <code><a href="../reference/eucast_rules.html">eucast_rules()</a></code> function as well:</p>
|
||||
<span class="co"># 2 Escherichia S</span></pre></div>
|
||||
<p>A more convenient function is <code><a href="../reference/mo_property.html">mo_is_intrinsic_resistant()</a></code> that uses the same guideline, but allows to check for one or more specific microorganisms or antibiotics:</p>
|
||||
<div class="sourceCode" id="cb2"><pre class="downlit">
|
||||
<span class="kw">data</span> <span class="op"><-</span> <span class="fu"><a href="https://rdrr.io/r/base/data.frame.html">data.frame</a></span>(mo = <span class="fu"><a href="https://rdrr.io/r/base/c.html">c</a></span>(<span class="st">"Staphylococcus aureus"</span>,
|
||||
<span class="fu"><a href="../reference/mo_property.html">mo_is_intrinsic_resistant</a></span><span class="op">(</span><span class="fu"><a href="https://rdrr.io/r/base/c.html">c</a></span><span class="op">(</span><span class="st">"Klebsiella"</span>, <span class="st">"Escherichia"</span><span class="op">)</span>,
|
||||
<span class="st">"ampicillin"</span><span class="op">)</span>
|
||||
<span class="co"># [1] TRUE FALSE</span>
|
||||
|
||||
<span class="fu"><a href="../reference/mo_property.html">mo_is_intrinsic_resistant</a></span><span class="op">(</span><span class="st">"Klebsiella"</span>,
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/c.html">c</a></span><span class="op">(</span><span class="st">"ampicillin"</span>, <span class="st">"kanamycin"</span><span class="op">)</span><span class="op">)</span>
|
||||
<span class="co"># [1] TRUE FALSE</span></pre></div>
|
||||
<p>EUCAST rules can not only be used for correction, they can also be used for filling in known resistance and susceptibility based on results of other antimicrobials drugs. This process is called <em>interpretive reading</em>, is basically a form of imputation, and is part of the <code><a href="../reference/eucast_rules.html">eucast_rules()</a></code> function as well:</p>
|
||||
<div class="sourceCode" id="cb3"><pre class="downlit">
|
||||
<span class="va">data</span> <span class="op"><-</span> <span class="fu"><a href="https://rdrr.io/r/base/data.frame.html">data.frame</a></span><span class="op">(</span>mo <span class="op">=</span> <span class="fu"><a href="https://rdrr.io/r/base/c.html">c</a></span><span class="op">(</span><span class="st">"Staphylococcus aureus"</span>,
|
||||
<span class="st">"Enterococcus faecalis"</span>,
|
||||
<span class="st">"Escherichia coli"</span>,
|
||||
<span class="st">"Klebsiella pneumoniae"</span>,
|
||||
<span class="st">"Pseudomonas aeruginosa"</span>),
|
||||
VAN = <span class="st">"-"</span>, <span class="co"># Vancomycin</span>
|
||||
AMX = <span class="st">"-"</span>, <span class="co"># Amoxicillin</span>
|
||||
COL = <span class="st">"-"</span>, <span class="co"># Colistin</span>
|
||||
CAZ = <span class="st">"-"</span>, <span class="co"># Ceftazidime</span>
|
||||
CXM = <span class="st">"-"</span>, <span class="co"># Cefuroxime</span>
|
||||
PEN = <span class="st">"S"</span>, <span class="co"># Benzylenicillin</span>
|
||||
FOX = <span class="st">"S"</span>, <span class="co"># Cefoxitin</span>
|
||||
stringsAsFactors = <span class="fl">FALSE</span>)
|
||||
</pre></div>
|
||||
<div class="sourceCode" id="cb3"><pre class="downlit">
|
||||
<span class="kw">data</span>
|
||||
</pre></div>
|
||||
<span class="st">"Pseudomonas aeruginosa"</span><span class="op">)</span>,
|
||||
VAN <span class="op">=</span> <span class="st">"-"</span>, <span class="co"># Vancomycin</span>
|
||||
AMX <span class="op">=</span> <span class="st">"-"</span>, <span class="co"># Amoxicillin</span>
|
||||
COL <span class="op">=</span> <span class="st">"-"</span>, <span class="co"># Colistin</span>
|
||||
CAZ <span class="op">=</span> <span class="st">"-"</span>, <span class="co"># Ceftazidime</span>
|
||||
CXM <span class="op">=</span> <span class="st">"-"</span>, <span class="co"># Cefuroxime</span>
|
||||
PEN <span class="op">=</span> <span class="st">"S"</span>, <span class="co"># Benzylenicillin</span>
|
||||
FOX <span class="op">=</span> <span class="st">"S"</span>, <span class="co"># Cefoxitin</span>
|
||||
stringsAsFactors <span class="op">=</span> <span class="cn">FALSE</span><span class="op">)</span></pre></div>
|
||||
<div class="sourceCode" id="cb4"><pre class="downlit">
|
||||
<span class="va">data</span></pre></div>
|
||||
<table class="table">
|
||||
<thead><tr class="header">
|
||||
<th align="left">mo</th>
|
||||
@@ -312,9 +318,8 @@
|
||||
</tr>
|
||||
</tbody>
|
||||
</table>
|
||||
<div class="sourceCode" id="cb4"><pre class="downlit">
|
||||
<span class="fu"><a href="../reference/eucast_rules.html">eucast_rules</a></span>(<span class="kw">data</span>)
|
||||
</pre></div>
|
||||
<div class="sourceCode" id="cb5"><pre class="downlit">
|
||||
<span class="fu"><a href="../reference/eucast_rules.html">eucast_rules</a></span><span class="op">(</span><span class="va">data</span><span class="op">)</span></pre></div>
|
||||
<table class="table">
|
||||
<thead><tr class="header">
|
||||
<th align="left">mo</th>
|
||||
@@ -397,7 +402,7 @@
|
||||
</div>
|
||||
|
||||
<div class="pkgdown">
|
||||
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.9000.</p>
|
||||
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.6.1.</p>
|
||||
</div>
|
||||
|
||||
</footer>
|
||||
|
||||
@@ -0,0 +1,12 @@
|
||||
// Pandoc 2.9 adds attributes on both header and div. We remove the former (to
|
||||
// be compatible with the behavior of Pandoc < 2.8).
|
||||
document.addEventListener('DOMContentLoaded', function(e) {
|
||||
var hs = document.querySelectorAll("div.section[class*='level'] > :first-child");
|
||||
var i, h, a;
|
||||
for (i = 0; i < hs.length; i++) {
|
||||
h = hs[i];
|
||||
if (!/^h[1-6]$/i.test(h.tagName)) continue; // it should be a header h1-h6
|
||||
a = h.attributes;
|
||||
while (a.length > 0) h.removeAttribute(a[0].name);
|
||||
}
|
||||
});
|
||||
+72
-74
@@ -39,7 +39,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<a class="navbar-link" href="../index.html">AMR (for R)</a>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9034</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
@@ -187,7 +187,7 @@
|
||||
|
||||
|
||||
|
||||
</header><script src="MDR_files/header-attrs-2.3/header-attrs.js"></script><script src="MDR_files/accessible-code-block-0.0.1/empty-anchor.js"></script><div class="row">
|
||||
</header><script src="MDR_files/header-attrs-2.4/header-attrs.js"></script><script src="MDR_files/accessible-code-block-0.0.1/empty-anchor.js"></script><div class="row">
|
||||
<div class="col-md-9 contents">
|
||||
<div class="page-header toc-ignore">
|
||||
<h1 data-toc-skip>How to determine multi-drug resistance (MDR)</h1>
|
||||
@@ -217,7 +217,11 @@
|
||||
<p>Magiorakos AP, Srinivasan A <em>et al.</em> “Multidrug-resistant, extensively drug-resistant and pandrug-resistant bacteria: an international expert proposal for interim standard definitions for acquired resistance.” Clinical Microbiology and Infection (2012) (<a href="https://www.clinicalmicrobiologyandinfection.com/article/S1198-743X(14)61632-3/fulltext">link</a>)</p>
|
||||
</li>
|
||||
<li>
|
||||
<p><code>guideline = "EUCAST"</code></p>
|
||||
<p><code>guideline = "EUCAST3.2"</code> (or simply <code>guideline = "EUCAST"</code>)</p>
|
||||
<p>The European international guideline - EUCAST Expert Rules Version 3.2 “Intrinsic Resistance and Unusual Phenotypes” (<a href="https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/2020/Intrinsic_Resistance_and_Unusual_Phenotypes_Tables_v3.2_20200225.pdf">link</a>)</p>
|
||||
</li>
|
||||
<li>
|
||||
<p><code>guideline = "EUCAST3.1"</code></p>
|
||||
<p>The European international guideline - EUCAST Expert Rules Version 3.1 “Intrinsic Resistance and Exceptional Phenotypes Tables” (<a href="https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/Expert_rules_intrinsic_exceptional_V3.1.pdf">link</a>)</p>
|
||||
</li>
|
||||
<li>
|
||||
@@ -226,13 +230,14 @@
|
||||
</li>
|
||||
<li>
|
||||
<p><code>guideline = "MRGN"</code></p>
|
||||
<p>The German national guideline - Mueller et al. (2015) Antimicrobial Resistance and Infection Control 4:7. (<a href="https://doi.org/10.1186/s13756-015-0047-6">link</a>)</p>
|
||||
<p>The German national guideline - Mueller et al. (2015) Antimicrobial Resistance and Infection Control 4:7. DOI: 10.1186/s13756-015-0047-6</p>
|
||||
</li>
|
||||
<li>
|
||||
<p><code>guideline = "BRMO"</code></p>
|
||||
<p>The Dutch national guideline - Rijksinstituut voor Volksgezondheid en Milieu “WIP-richtlijn BRMO (Bijzonder Resistente Micro-Organismen) [ZKH]” (<a href="https://www.rivm.nl/Documenten_en_publicaties/Professioneel_Praktisch/Richtlijnen/Infectieziekten/WIP_Richtlijnen/WIP_Richtlijnen/Ziekenhuizen/WIP_richtlijn_BRMO_Bijzonder_Resistente_Micro_Organismen_ZKH">link</a>)</p>
|
||||
<p>The Dutch national guideline - Rijksinstituut voor Volksgezondheid en Milieu “WIP-richtlijn BRMO (Bijzonder Resistente Micro-Organismen) (ZKH)” (<a href="https://www.rivm.nl/wip-richtlijn-brmo-bijzonder-resistente-micro-organismen-zkh">link</a>)</p>
|
||||
</li>
|
||||
</ul>
|
||||
<p>Please suggest your own (country-specific) guidelines by letting us know: <a href="https://github.com/msberends/AMR/issues/new" class="uri">https://github.com/msberends/AMR/issues/new</a>.</p>
|
||||
</div>
|
||||
<div id="examples" class="section level4">
|
||||
<h4 class="hasAnchor">
|
||||
@@ -240,16 +245,14 @@
|
||||
<p>The <code><a href="../reference/mdro.html">mdro()</a></code> function always returns an ordered <code>factor</code>. For example, the output of the default guideline by Magiorakos <em>et al.</em> returns a <code>factor</code> with levels ‘Negative’, ‘MDR’, ‘XDR’ or ‘PDR’ in that order.</p>
|
||||
<p>The next example uses the <code>example_isolates</code> data set. This is a data set included with this package and contains 2,000 microbial isolates with their full antibiograms. It reflects reality and can be used to practice AMR analysis. If we test the MDR/XDR/PDR guideline on this data set, we get:</p>
|
||||
<div class="sourceCode" id="cb1"><pre class="downlit">
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/library.html">library</a></span>(<span class="kw"><a href="https://dplyr.tidyverse.org">dplyr</a></span>) <span class="co"># to support pipes: %>%</span>
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/library.html">library</a></span>(<span class="kw"><a href="https://github.com/msberends/cleaner">cleaner</a></span>) <span class="co"># to create frequency tables</span>
|
||||
</pre></div>
|
||||
<span class="kw"><a href="https://rdrr.io/r/base/library.html">library</a></span><span class="op">(</span><span class="va"><a href="https://dplyr.tidyverse.org">dplyr</a></span><span class="op">)</span> <span class="co"># to support pipes: %>%</span>
|
||||
<span class="kw"><a href="https://rdrr.io/r/base/library.html">library</a></span><span class="op">(</span><span class="va"><a href="https://github.com/msberends/cleaner">cleaner</a></span><span class="op">)</span> <span class="co"># to create frequency tables</span></pre></div>
|
||||
<div class="sourceCode" id="cb2"><pre class="downlit">
|
||||
<span class="kw">example_isolates</span> <span class="op">%>%</span>
|
||||
<span class="fu"><a href="../reference/mdro.html">mdro</a></span>() <span class="op">%>%</span>
|
||||
<span class="fu"><a href="https://rdrr.io/pkg/cleaner/man/freq.html">freq</a></span>() <span class="co"># show frequency table of the result</span>
|
||||
<span class="co"># Warning in mdro(.): NA introduced for isolates where the available percentage of</span>
|
||||
<span class="co"># antimicrobial classes was below 50% (set with `pct_required_classes`)</span>
|
||||
</pre></div>
|
||||
<span class="va">example_isolates</span> <span class="op">%>%</span>
|
||||
<span class="fu"><a href="../reference/mdro.html">mdro</a></span><span class="op">(</span><span class="op">)</span> <span class="op">%>%</span>
|
||||
<span class="fu"><a href="https://rdrr.io/pkg/cleaner/man/freq.html">freq</a></span><span class="op">(</span><span class="op">)</span> <span class="co"># show frequency table of the result</span>
|
||||
<span class="co"># Warning in warning_("NA introduced for isolates where the available percentage of antimicrobial classes was below ", : NA introduced for isolates where the available percentage of antimicrobial</span>
|
||||
<span class="co"># classes was below 50% (set with `pct_required_classes`)</span></pre></div>
|
||||
<p><strong>Frequency table</strong></p>
|
||||
<p>Class: factor > ordered (numeric)<br>
|
||||
Length: 2,000<br>
|
||||
@@ -288,62 +291,57 @@ Unique: 2</p>
|
||||
<div class="sourceCode" id="cb3"><pre class="downlit">
|
||||
<span class="co"># a helper function to get a random vector with values S, I and R</span>
|
||||
<span class="co"># with the probabilities 50% - 10% - 40%</span>
|
||||
<span class="kw">sample_rsi</span> <span class="op"><-</span> <span class="fu">function</span>() {
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/sample.html">sample</a></span>(<span class="fu"><a href="https://rdrr.io/r/base/c.html">c</a></span>(<span class="st">"S"</span>, <span class="st">"I"</span>, <span class="st">"R"</span>),
|
||||
size = <span class="fl">5000</span>,
|
||||
prob = <span class="fu"><a href="https://rdrr.io/r/base/c.html">c</a></span>(<span class="fl">0.5</span>, <span class="fl">0.1</span>, <span class="fl">0.4</span>),
|
||||
replace = <span class="fl">TRUE</span>)
|
||||
}
|
||||
<span class="va">sample_rsi</span> <span class="op"><-</span> <span class="kw">function</span><span class="op">(</span><span class="op">)</span> <span class="op">{</span>
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/sample.html">sample</a></span><span class="op">(</span><span class="fu"><a href="https://rdrr.io/r/base/c.html">c</a></span><span class="op">(</span><span class="st">"S"</span>, <span class="st">"I"</span>, <span class="st">"R"</span><span class="op">)</span>,
|
||||
size <span class="op">=</span> <span class="fl">5000</span>,
|
||||
prob <span class="op">=</span> <span class="fu"><a href="https://rdrr.io/r/base/c.html">c</a></span><span class="op">(</span><span class="fl">0.5</span>, <span class="fl">0.1</span>, <span class="fl">0.4</span><span class="op">)</span>,
|
||||
replace <span class="op">=</span> <span class="cn">TRUE</span><span class="op">)</span>
|
||||
<span class="op">}</span>
|
||||
|
||||
<span class="kw">my_TB_data</span> <span class="op"><-</span> <span class="fu"><a href="https://rdrr.io/r/base/data.frame.html">data.frame</a></span>(rifampicin = <span class="fu">sample_rsi</span>(),
|
||||
isoniazid = <span class="fu">sample_rsi</span>(),
|
||||
gatifloxacin = <span class="fu">sample_rsi</span>(),
|
||||
ethambutol = <span class="fu">sample_rsi</span>(),
|
||||
pyrazinamide = <span class="fu">sample_rsi</span>(),
|
||||
moxifloxacin = <span class="fu">sample_rsi</span>(),
|
||||
kanamycin = <span class="fu">sample_rsi</span>())
|
||||
</pre></div>
|
||||
<span class="va">my_TB_data</span> <span class="op"><-</span> <span class="fu"><a href="https://rdrr.io/r/base/data.frame.html">data.frame</a></span><span class="op">(</span>rifampicin <span class="op">=</span> <span class="fu">sample_rsi</span><span class="op">(</span><span class="op">)</span>,
|
||||
isoniazid <span class="op">=</span> <span class="fu">sample_rsi</span><span class="op">(</span><span class="op">)</span>,
|
||||
gatifloxacin <span class="op">=</span> <span class="fu">sample_rsi</span><span class="op">(</span><span class="op">)</span>,
|
||||
ethambutol <span class="op">=</span> <span class="fu">sample_rsi</span><span class="op">(</span><span class="op">)</span>,
|
||||
pyrazinamide <span class="op">=</span> <span class="fu">sample_rsi</span><span class="op">(</span><span class="op">)</span>,
|
||||
moxifloxacin <span class="op">=</span> <span class="fu">sample_rsi</span><span class="op">(</span><span class="op">)</span>,
|
||||
kanamycin <span class="op">=</span> <span class="fu">sample_rsi</span><span class="op">(</span><span class="op">)</span><span class="op">)</span></pre></div>
|
||||
<p>Because all column names are automatically verified for valid drug names or codes, this would have worked exactly the same:</p>
|
||||
<div class="sourceCode" id="cb4"><pre class="downlit">
|
||||
<span class="kw">my_TB_data</span> <span class="op"><-</span> <span class="fu"><a href="https://rdrr.io/r/base/data.frame.html">data.frame</a></span>(RIF = <span class="fu">sample_rsi</span>(),
|
||||
INH = <span class="fu">sample_rsi</span>(),
|
||||
GAT = <span class="fu">sample_rsi</span>(),
|
||||
ETH = <span class="fu">sample_rsi</span>(),
|
||||
PZA = <span class="fu">sample_rsi</span>(),
|
||||
MFX = <span class="fu">sample_rsi</span>(),
|
||||
KAN = <span class="fu">sample_rsi</span>())
|
||||
</pre></div>
|
||||
<span class="va">my_TB_data</span> <span class="op"><-</span> <span class="fu"><a href="https://rdrr.io/r/base/data.frame.html">data.frame</a></span><span class="op">(</span>RIF <span class="op">=</span> <span class="fu">sample_rsi</span><span class="op">(</span><span class="op">)</span>,
|
||||
INH <span class="op">=</span> <span class="fu">sample_rsi</span><span class="op">(</span><span class="op">)</span>,
|
||||
GAT <span class="op">=</span> <span class="fu">sample_rsi</span><span class="op">(</span><span class="op">)</span>,
|
||||
ETH <span class="op">=</span> <span class="fu">sample_rsi</span><span class="op">(</span><span class="op">)</span>,
|
||||
PZA <span class="op">=</span> <span class="fu">sample_rsi</span><span class="op">(</span><span class="op">)</span>,
|
||||
MFX <span class="op">=</span> <span class="fu">sample_rsi</span><span class="op">(</span><span class="op">)</span>,
|
||||
KAN <span class="op">=</span> <span class="fu">sample_rsi</span><span class="op">(</span><span class="op">)</span><span class="op">)</span></pre></div>
|
||||
<p>The data set now looks like this:</p>
|
||||
<div class="sourceCode" id="cb5"><pre class="downlit">
|
||||
<span class="fu"><a href="https://rdrr.io/r/utils/head.html">head</a></span>(<span class="kw">my_TB_data</span>)
|
||||
<span class="fu"><a href="https://rdrr.io/r/utils/head.html">head</a></span><span class="op">(</span><span class="va">my_TB_data</span><span class="op">)</span>
|
||||
<span class="co"># rifampicin isoniazid gatifloxacin ethambutol pyrazinamide moxifloxacin</span>
|
||||
<span class="co"># 1 R S S R S I</span>
|
||||
<span class="co"># 2 I S S S I R</span>
|
||||
<span class="co"># 3 R R R R R R</span>
|
||||
<span class="co"># 4 R I S R S S</span>
|
||||
<span class="co"># 5 S S I S S R</span>
|
||||
<span class="co"># 6 S S S R S S</span>
|
||||
<span class="co"># 1 R I R S S S</span>
|
||||
<span class="co"># 2 S R I R R S</span>
|
||||
<span class="co"># 3 R S R R R R</span>
|
||||
<span class="co"># 4 R S I R I S</span>
|
||||
<span class="co"># 5 S R S R S R</span>
|
||||
<span class="co"># 6 R R S R S S</span>
|
||||
<span class="co"># kanamycin</span>
|
||||
<span class="co"># 1 R</span>
|
||||
<span class="co"># 2 S</span>
|
||||
<span class="co"># 3 R</span>
|
||||
<span class="co"># 4 R</span>
|
||||
<span class="co"># 5 S</span>
|
||||
<span class="co"># 6 R</span>
|
||||
</pre></div>
|
||||
<span class="co"># 3 S</span>
|
||||
<span class="co"># 4 S</span>
|
||||
<span class="co"># 5 R</span>
|
||||
<span class="co"># 6 R</span></pre></div>
|
||||
<p>We can now add the interpretation of MDR-TB to our data set. You can use:</p>
|
||||
<div class="sourceCode" id="cb6"><pre class="downlit">
|
||||
<span class="fu"><a href="../reference/mdro.html">mdro</a></span>(<span class="kw">my_TB_data</span>, guideline = <span class="st">"TB"</span>)
|
||||
</pre></div>
|
||||
<span class="fu"><a href="../reference/mdro.html">mdro</a></span><span class="op">(</span><span class="va">my_TB_data</span>, guideline <span class="op">=</span> <span class="st">"TB"</span><span class="op">)</span></pre></div>
|
||||
<p>or its shortcut <code><a href="../reference/mdro.html">mdr_tb()</a></code>:</p>
|
||||
<div class="sourceCode" id="cb7"><pre class="downlit">
|
||||
<span class="kw">my_TB_data</span><span class="op">$</span><span class="kw">mdr</span> <span class="op"><-</span> <span class="fu"><a href="../reference/mdro.html">mdr_tb</a></span>(<span class="kw">my_TB_data</span>)
|
||||
<span class="co"># NOTE: No column found as input for `col_mo`, assuming all records contain Mycobacterium tuberculosis.</span>
|
||||
</pre></div>
|
||||
<span class="va">my_TB_data</span><span class="op">$</span><span class="va">mdr</span> <span class="op"><-</span> <span class="fu"><a href="../reference/mdro.html">mdr_tb</a></span><span class="op">(</span><span class="va">my_TB_data</span><span class="op">)</span>
|
||||
<span class="co"># NOTE: No column found as input for `col_mo`, assuming all records contain</span>
|
||||
<span class="co"># Mycobacterium tuberculosis.</span></pre></div>
|
||||
<p>Create a frequency table of the results:</p>
|
||||
<div class="sourceCode" id="cb8"><pre class="downlit">
|
||||
<span class="fu"><a href="https://rdrr.io/pkg/cleaner/man/freq.html">freq</a></span>(<span class="kw">my_TB_data</span><span class="op">$</span><span class="kw">mdr</span>)
|
||||
</pre></div>
|
||||
<span class="fu"><a href="https://rdrr.io/pkg/cleaner/man/freq.html">freq</a></span><span class="op">(</span><span class="va">my_TB_data</span><span class="op">$</span><span class="va">mdr</span><span class="op">)</span></pre></div>
|
||||
<p><strong>Frequency table</strong></p>
|
||||
<p>Class: factor > ordered (numeric)<br>
|
||||
Length: 5,000<br>
|
||||
@@ -363,40 +361,40 @@ Unique: 5</p>
|
||||
<tr class="odd">
|
||||
<td align="left">1</td>
|
||||
<td align="left">Mono-resistant</td>
|
||||
<td align="right">3225</td>
|
||||
<td align="right">64.50%</td>
|
||||
<td align="right">3225</td>
|
||||
<td align="right">64.50%</td>
|
||||
<td align="right">3244</td>
|
||||
<td align="right">64.88%</td>
|
||||
<td align="right">3244</td>
|
||||
<td align="right">64.88%</td>
|
||||
</tr>
|
||||
<tr class="even">
|
||||
<td align="left">2</td>
|
||||
<td align="left">Negative</td>
|
||||
<td align="right">698</td>
|
||||
<td align="right">13.96%</td>
|
||||
<td align="right">3923</td>
|
||||
<td align="right">78.46%</td>
|
||||
<td align="right">644</td>
|
||||
<td align="right">12.88%</td>
|
||||
<td align="right">3888</td>
|
||||
<td align="right">77.76%</td>
|
||||
</tr>
|
||||
<tr class="odd">
|
||||
<td align="left">3</td>
|
||||
<td align="left">Multi-drug-resistant</td>
|
||||
<td align="right">581</td>
|
||||
<td align="right">11.62%</td>
|
||||
<td align="right">4504</td>
|
||||
<td align="right">90.08%</td>
|
||||
<td align="right">613</td>
|
||||
<td align="right">12.26%</td>
|
||||
<td align="right">4501</td>
|
||||
<td align="right">90.02%</td>
|
||||
</tr>
|
||||
<tr class="even">
|
||||
<td align="left">4</td>
|
||||
<td align="left">Poly-resistant</td>
|
||||
<td align="right">298</td>
|
||||
<td align="right">5.96%</td>
|
||||
<td align="right">4802</td>
|
||||
<td align="right">96.04%</td>
|
||||
<td align="right">304</td>
|
||||
<td align="right">6.08%</td>
|
||||
<td align="right">4805</td>
|
||||
<td align="right">96.10%</td>
|
||||
</tr>
|
||||
<tr class="odd">
|
||||
<td align="left">5</td>
|
||||
<td align="left">Extensively drug-resistant</td>
|
||||
<td align="right">198</td>
|
||||
<td align="right">3.96%</td>
|
||||
<td align="right">195</td>
|
||||
<td align="right">3.90%</td>
|
||||
<td align="right">5000</td>
|
||||
<td align="right">100.00%</td>
|
||||
</tr>
|
||||
@@ -418,7 +416,7 @@ Unique: 5</p>
|
||||
</div>
|
||||
|
||||
<div class="pkgdown">
|
||||
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.9000.</p>
|
||||
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.6.1.</p>
|
||||
</div>
|
||||
|
||||
</footer>
|
||||
|
||||
@@ -0,0 +1,12 @@
|
||||
// Pandoc 2.9 adds attributes on both header and div. We remove the former (to
|
||||
// be compatible with the behavior of Pandoc < 2.8).
|
||||
document.addEventListener('DOMContentLoaded', function(e) {
|
||||
var hs = document.querySelectorAll("div.section[class*='level'] > :first-child");
|
||||
var i, h, a;
|
||||
for (i = 0; i < hs.length; i++) {
|
||||
h = hs[i];
|
||||
if (!/^h[1-6]$/i.test(h.tagName)) continue; // it should be a header h1-h6
|
||||
a = h.attributes;
|
||||
while (a.length > 0) h.removeAttribute(a[0].name);
|
||||
}
|
||||
});
|
||||
+24
-31
@@ -39,7 +39,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<a class="navbar-link" href="../index.html">AMR (for R)</a>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9032</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
@@ -187,7 +187,7 @@
|
||||
|
||||
|
||||
|
||||
</header><script src="PCA_files/header-attrs-2.3/header-attrs.js"></script><script src="PCA_files/accessible-code-block-0.0.1/empty-anchor.js"></script><div class="row">
|
||||
</header><script src="PCA_files/header-attrs-2.4/header-attrs.js"></script><script src="PCA_files/accessible-code-block-0.0.1/empty-anchor.js"></script><div class="row">
|
||||
<div class="col-md-9 contents">
|
||||
<div class="page-header toc-ignore">
|
||||
<h1 data-toc-skip>How to conduct principal component analysis (PCA) for AMR</h1>
|
||||
@@ -210,9 +210,9 @@
|
||||
<a href="#transforming" class="anchor"></a>Transforming</h1>
|
||||
<p>For PCA, we need to transform our AMR data first. This is what the <code>example_isolates</code> data set in this package looks like:</p>
|
||||
<div class="sourceCode" id="cb1"><pre class="downlit">
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/library.html">library</a></span>(<span class="kw"><a href="https://msberends.github.io/AMR">AMR</a></span>)
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/library.html">library</a></span>(<span class="kw"><a href="https://dplyr.tidyverse.org">dplyr</a></span>)
|
||||
<span class="fu"><a href="https://tibble.tidyverse.org/reference/glimpse.html">glimpse</a></span>(<span class="kw">example_isolates</span>)
|
||||
<span class="kw"><a href="https://rdrr.io/r/base/library.html">library</a></span><span class="op">(</span><span class="va"><a href="https://msberends.github.io/AMR/">AMR</a></span><span class="op">)</span>
|
||||
<span class="kw"><a href="https://rdrr.io/r/base/library.html">library</a></span><span class="op">(</span><span class="va"><a href="https://dplyr.tidyverse.org">dplyr</a></span><span class="op">)</span>
|
||||
<span class="fu"><a href="https://tibble.tidyverse.org/reference/glimpse.html">glimpse</a></span><span class="op">(</span><span class="va">example_isolates</span><span class="op">)</span>
|
||||
<span class="co"># Rows: 2,000</span>
|
||||
<span class="co"># Columns: 49</span>
|
||||
<span class="co"># $ date <date> 2002-01-02, 2002-01-03, 2002-01-07, 2002-01-07, 2002…</span>
|
||||
@@ -263,18 +263,17 @@
|
||||
<span class="co"># $ CHL <rsi> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, N…</span>
|
||||
<span class="co"># $ COL <rsi> NA, NA, R, R, R, R, R, R, R, R, R, R, NA, NA, NA, R, …</span>
|
||||
<span class="co"># $ MUP <rsi> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, N…</span>
|
||||
<span class="co"># $ RIF <rsi> R, R, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, R, R, R…</span>
|
||||
</pre></div>
|
||||
<span class="co"># $ RIF <rsi> R, R, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, R, R, R…</span></pre></div>
|
||||
<p>Now to transform this to a data set with only resistance percentages per taxonomic order and genus:</p>
|
||||
<div class="sourceCode" id="cb2"><pre class="downlit">
|
||||
<span class="kw">resistance_data</span> <span class="op"><-</span> <span class="kw">example_isolates</span> <span class="op">%>%</span>
|
||||
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/group_by.html">group_by</a></span>(order = <span class="fu"><a href="../reference/mo_property.html">mo_order</a></span>(<span class="kw">mo</span>), <span class="co"># group on anything, like order</span>
|
||||
genus = <span class="fu"><a href="../reference/mo_property.html">mo_genus</a></span>(<span class="kw">mo</span>)) <span class="op">%>%</span> <span class="co"># and genus as we do here</span>
|
||||
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/summarise_all.html">summarise_if</a></span>(<span class="kw">is.rsi</span>, <span class="kw">resistance</span>) <span class="op">%>%</span> <span class="co"># then get resistance of all drugs</span>
|
||||
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/select.html">select</a></span>(<span class="kw">order</span>, <span class="kw">genus</span>, <span class="kw">AMC</span>, <span class="kw">CXM</span>, <span class="kw">CTX</span>,
|
||||
<span class="kw">CAZ</span>, <span class="kw">GEN</span>, <span class="kw">TOB</span>, <span class="kw">TMP</span>, <span class="kw">SXT</span>) <span class="co"># and select only relevant columns</span>
|
||||
<span class="va">resistance_data</span> <span class="op"><-</span> <span class="va">example_isolates</span> <span class="op">%>%</span>
|
||||
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/group_by.html">group_by</a></span><span class="op">(</span>order <span class="op">=</span> <span class="fu"><a href="../reference/mo_property.html">mo_order</a></span><span class="op">(</span><span class="va">mo</span><span class="op">)</span>, <span class="co"># group on anything, like order</span>
|
||||
genus <span class="op">=</span> <span class="fu"><a href="../reference/mo_property.html">mo_genus</a></span><span class="op">(</span><span class="va">mo</span><span class="op">)</span><span class="op">)</span> <span class="op">%>%</span> <span class="co"># and genus as we do here</span>
|
||||
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/summarise_all.html">summarise_if</a></span><span class="op">(</span><span class="va">is.rsi</span>, <span class="va">resistance</span><span class="op">)</span> <span class="op">%>%</span> <span class="co"># then get resistance of all drugs</span>
|
||||
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/select.html">select</a></span><span class="op">(</span><span class="va">order</span>, <span class="va">genus</span>, <span class="va">AMC</span>, <span class="va">CXM</span>, <span class="va">CTX</span>,
|
||||
<span class="va">CAZ</span>, <span class="va">GEN</span>, <span class="va">TOB</span>, <span class="va">TMP</span>, <span class="va">SXT</span><span class="op">)</span> <span class="co"># and select only relevant columns</span>
|
||||
|
||||
<span class="fu"><a href="https://rdrr.io/r/utils/head.html">head</a></span>(<span class="kw">resistance_data</span>)
|
||||
<span class="fu"><a href="https://rdrr.io/r/utils/head.html">head</a></span><span class="op">(</span><span class="va">resistance_data</span><span class="op">)</span>
|
||||
<span class="co"># # A tibble: 6 x 10</span>
|
||||
<span class="co"># # Groups: order [2]</span>
|
||||
<span class="co"># order genus AMC CXM CTX CAZ GEN TOB TMP SXT</span>
|
||||
@@ -284,46 +283,40 @@
|
||||
<span class="co"># 3 Actinomycetales Cutibacterium NA NA NA NA NA NA NA NA</span>
|
||||
<span class="co"># 4 Actinomycetales Dermabacter NA NA NA NA NA NA NA NA</span>
|
||||
<span class="co"># 5 Actinomycetales Micrococcus NA NA NA NA NA NA NA NA</span>
|
||||
<span class="co"># 6 Actinomycetales Rothia NA NA NA NA NA NA NA NA</span>
|
||||
</pre></div>
|
||||
<span class="co"># 6 Actinomycetales Rothia NA NA NA NA NA NA NA NA</span></pre></div>
|
||||
</div>
|
||||
<div id="perform-principal-component-analysis" class="section level1">
|
||||
<h1 class="hasAnchor">
|
||||
<a href="#perform-principal-component-analysis" class="anchor"></a>Perform principal component analysis</h1>
|
||||
<p>The new <code><a href="../reference/pca.html">pca()</a></code> function will automatically filter on rows that contain numeric values in all selected variables, so we now only need to do:</p>
|
||||
<div class="sourceCode" id="cb3"><pre class="downlit">
|
||||
<span class="kw">pca_result</span> <span class="op"><-</span> <span class="fu"><a href="../reference/pca.html">pca</a></span>(<span class="kw">resistance_data</span>)
|
||||
<span class="co"># NOTE: Columns selected for PCA: AMC CXM CTX CAZ GEN TOB TMP SXT.</span>
|
||||
<span class="co"># Total observations available: 7.</span>
|
||||
</pre></div>
|
||||
<span class="va">pca_result</span> <span class="op"><-</span> <span class="fu"><a href="../reference/pca.html">pca</a></span><span class="op">(</span><span class="va">resistance_data</span><span class="op">)</span>
|
||||
<span class="co"># NOTE: Columns selected for PCA: AMC CXM CTX CAZ GEN TOB TMP SXT. Total</span>
|
||||
<span class="co"># observations available: 7.</span></pre></div>
|
||||
<p>The result can be reviewed with the good old <code><a href="https://rdrr.io/r/base/summary.html">summary()</a></code> function:</p>
|
||||
<div class="sourceCode" id="cb4"><pre class="downlit">
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/summary.html">summary</a></span>(<span class="kw">pca_result</span>)
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/summary.html">summary</a></span><span class="op">(</span><span class="va">pca_result</span><span class="op">)</span>
|
||||
<span class="co"># Importance of components:</span>
|
||||
<span class="co"># PC1 PC2 PC3 PC4 PC5 PC6 PC7</span>
|
||||
<span class="co"># Standard deviation 2.154 1.6807 0.61365 0.33902 0.20757 0.03136 1.733e-16</span>
|
||||
<span class="co"># Proportion of Variance 0.580 0.3531 0.04707 0.01437 0.00539 0.00012 0.000e+00</span>
|
||||
<span class="co"># Cumulative Proportion 0.580 0.9331 0.98012 0.99449 0.99988 1.00000 1.000e+00</span>
|
||||
</pre></div>
|
||||
<span class="co"># Cumulative Proportion 0.580 0.9331 0.98012 0.99449 0.99988 1.00000 1.000e+00</span></pre></div>
|
||||
<p>Good news. The first two components explain a total of 93.3% of the variance (see the PC1 and PC2 values of the <em>Proportion of Variance</em>. We can create a so-called biplot with the base R <code><a href="https://rdrr.io/r/stats/biplot.html">biplot()</a></code> function, to see which antimicrobial resistance per drug explain the difference per microorganism.</p>
|
||||
</div>
|
||||
<div id="plotting-the-results" class="section level1">
|
||||
<h1 class="hasAnchor">
|
||||
<a href="#plotting-the-results" class="anchor"></a>Plotting the results</h1>
|
||||
<div class="sourceCode" id="cb5"><pre class="downlit">
|
||||
<span class="fu"><a href="https://rdrr.io/r/stats/biplot.html">biplot</a></span>(<span class="kw">pca_result</span>)
|
||||
</pre></div>
|
||||
<span class="fu"><a href="https://rdrr.io/r/stats/biplot.html">biplot</a></span><span class="op">(</span><span class="va">pca_result</span><span class="op">)</span></pre></div>
|
||||
<p><img src="PCA_files/figure-html/unnamed-chunk-5-1.png" width="750"></p>
|
||||
<p>But we can’t see the explanation of the points. Perhaps this works better with our new <code><a href="../reference/ggplot_pca.html">ggplot_pca()</a></code> function, that automatically adds the right labels and even groups:</p>
|
||||
<div class="sourceCode" id="cb6"><pre class="downlit">
|
||||
<span class="fu"><a href="../reference/ggplot_pca.html">ggplot_pca</a></span>(<span class="kw">pca_result</span>)
|
||||
</pre></div>
|
||||
<span class="fu"><a href="../reference/ggplot_pca.html">ggplot_pca</a></span><span class="op">(</span><span class="va">pca_result</span><span class="op">)</span></pre></div>
|
||||
<p><img src="PCA_files/figure-html/unnamed-chunk-6-1.png" width="750"></p>
|
||||
<p>You can also print an ellipse per group, and edit the appearance:</p>
|
||||
<div class="sourceCode" id="cb7"><pre class="downlit">
|
||||
<span class="fu"><a href="../reference/ggplot_pca.html">ggplot_pca</a></span>(<span class="kw">pca_result</span>, ellipse = <span class="fl">TRUE</span>) <span class="op">+</span>
|
||||
<span class="kw">ggplot2</span>::<span class="fu"><a href="https://ggplot2.tidyverse.org/reference/labs.html">labs</a></span>(title = <span class="st">"An AMR/PCA biplot!"</span>)
|
||||
</pre></div>
|
||||
<span class="fu"><a href="../reference/ggplot_pca.html">ggplot_pca</a></span><span class="op">(</span><span class="va">pca_result</span>, ellipse <span class="op">=</span> <span class="cn">TRUE</span><span class="op">)</span> <span class="op">+</span>
|
||||
<span class="fu">ggplot2</span><span class="fu">::</span><span class="fu"><a href="https://ggplot2.tidyverse.org/reference/labs.html">labs</a></span><span class="op">(</span>title <span class="op">=</span> <span class="st">"An AMR/PCA biplot!"</span><span class="op">)</span></pre></div>
|
||||
<p><img src="PCA_files/figure-html/unnamed-chunk-7-1.png" width="750"></p>
|
||||
</div>
|
||||
</div>
|
||||
@@ -343,7 +336,7 @@
|
||||
</div>
|
||||
|
||||
<div class="pkgdown">
|
||||
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.9000.</p>
|
||||
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.6.1.</p>
|
||||
</div>
|
||||
|
||||
</footer>
|
||||
|
||||
@@ -0,0 +1,4 @@
|
||||
/* Styles for section anchors */
|
||||
a.anchor-section {margin-left: 10px; visibility: hidden; color: inherit;}
|
||||
a.anchor-section::before {content: '#';}
|
||||
.hasAnchor:hover a.anchor-section {visibility: visible;}
|
||||
@@ -0,0 +1,33 @@
|
||||
// Anchor sections v1.0 written by Atsushi Yasumoto on Oct 3rd, 2020.
|
||||
document.addEventListener('DOMContentLoaded', function() {
|
||||
// Do nothing if AnchorJS is used
|
||||
if (typeof window.anchors === 'object' && anchors.hasOwnProperty('hasAnchorJSLink')) {
|
||||
return;
|
||||
}
|
||||
|
||||
const h = document.querySelectorAll('h1, h2, h3, h4, h5, h6');
|
||||
|
||||
// Do nothing if sections are already anchored
|
||||
if (Array.from(h).some(x => x.classList.contains('hasAnchor'))) {
|
||||
return null;
|
||||
}
|
||||
|
||||
// Use section id when pandoc runs with --section-divs
|
||||
const section_id = function(x) {
|
||||
return ((x.classList.contains('section') || (x.tagName === 'SECTION'))
|
||||
? x.id : '');
|
||||
};
|
||||
|
||||
// Add anchors
|
||||
h.forEach(function(x) {
|
||||
const id = x.id || section_id(x.parentElement);
|
||||
if (id === '') {
|
||||
return null;
|
||||
}
|
||||
let anchor = document.createElement('a');
|
||||
anchor.href = '#' + id;
|
||||
anchor.classList = ['anchor-section'];
|
||||
x.classList.add('hasAnchor');
|
||||
x.appendChild(anchor);
|
||||
});
|
||||
});
|
||||
Binary file not shown.
|
Before Width: | Height: | Size: 86 KiB After Width: | Height: | Size: 50 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 143 KiB After Width: | Height: | Size: 91 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 148 KiB After Width: | Height: | Size: 93 KiB |
@@ -0,0 +1,12 @@
|
||||
// Pandoc 2.9 adds attributes on both header and div. We remove the former (to
|
||||
// be compatible with the behavior of Pandoc < 2.8).
|
||||
document.addEventListener('DOMContentLoaded', function(e) {
|
||||
var hs = document.querySelectorAll("div.section[class*='level'] > :first-child");
|
||||
var i, h, a;
|
||||
for (i = 0; i < hs.length; i++) {
|
||||
h = hs[i];
|
||||
if (!/^h[1-6]$/i.test(h.tagName)) continue; // it should be a header h1-h6
|
||||
a = h.attributes;
|
||||
while (a.length > 0) h.removeAttribute(a[0].name);
|
||||
}
|
||||
});
|
||||
+33
-42
@@ -39,7 +39,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<a class="navbar-link" href="../index.html">AMR (for R)</a>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9032</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
@@ -187,13 +187,13 @@
|
||||
|
||||
|
||||
|
||||
</header><script src="SPSS_files/header-attrs-2.3/header-attrs.js"></script><script src="SPSS_files/accessible-code-block-0.0.1/empty-anchor.js"></script><div class="row">
|
||||
</header><script src="SPSS_files/header-attrs-2.4/header-attrs.js"></script><script src="SPSS_files/accessible-code-block-0.0.1/empty-anchor.js"></script><div class="row">
|
||||
<div class="col-md-9 contents">
|
||||
<div class="page-header toc-ignore">
|
||||
<h1 data-toc-skip>How to import data from SPSS / SAS / Stata</h1>
|
||||
<h4 class="author">Matthijs S. Berends</h4>
|
||||
|
||||
<h4 class="date">08 October 2020</h4>
|
||||
<h4 class="date">08 December 2020</h4>
|
||||
|
||||
<small class="dont-index">Source: <a href="https://github.com/msberends/AMR/blob/master/vignettes/SPSS.Rmd"><code>vignettes/SPSS.Rmd</code></a></small>
|
||||
<div class="hidden name"><code>SPSS.Rmd</code></div>
|
||||
@@ -249,38 +249,37 @@
|
||||
<p>To demonstrate the first point:</p>
|
||||
<div class="sourceCode" id="cb1"><pre class="downlit">
|
||||
<span class="co"># not all values are valid MIC values:</span>
|
||||
<span class="fu"><a href="../reference/as.mic.html">as.mic</a></span>(<span class="fl">0.125</span>)
|
||||
<span class="fu"><a href="../reference/as.mic.html">as.mic</a></span><span class="op">(</span><span class="fl">0.125</span><span class="op">)</span>
|
||||
<span class="co"># Class <mic></span>
|
||||
<span class="co"># [1] 0.125</span>
|
||||
<span class="fu"><a href="../reference/as.mic.html">as.mic</a></span>(<span class="st">"testvalue"</span>)
|
||||
<span class="fu"><a href="../reference/as.mic.html">as.mic</a></span><span class="op">(</span><span class="st">"testvalue"</span><span class="op">)</span>
|
||||
<span class="co"># Class <mic></span>
|
||||
<span class="co"># [1] <NA></span>
|
||||
|
||||
<span class="co"># the Gram stain is avaiable for all bacteria:</span>
|
||||
<span class="fu"><a href="../reference/mo_property.html">mo_gramstain</a></span>(<span class="st">"E. coli"</span>)
|
||||
<span class="fu"><a href="../reference/mo_property.html">mo_gramstain</a></span><span class="op">(</span><span class="st">"E. coli"</span><span class="op">)</span>
|
||||
<span class="co"># [1] "Gram-negative"</span>
|
||||
|
||||
<span class="co"># Klebsiella is intrinsic resistant to amoxicllin, according to EUCAST:</span>
|
||||
<span class="kw">klebsiella_test</span> <span class="op"><-</span> <span class="fu"><a href="https://rdrr.io/r/base/data.frame.html">data.frame</a></span>(mo = <span class="st">"klebsiella"</span>,
|
||||
amox = <span class="st">"S"</span>,
|
||||
stringsAsFactors = <span class="fl">FALSE</span>)
|
||||
<span class="kw">klebsiella_test</span> <span class="co"># (our original data)</span>
|
||||
<span class="va">klebsiella_test</span> <span class="op"><-</span> <span class="fu"><a href="https://rdrr.io/r/base/data.frame.html">data.frame</a></span><span class="op">(</span>mo <span class="op">=</span> <span class="st">"klebsiella"</span>,
|
||||
amox <span class="op">=</span> <span class="st">"S"</span>,
|
||||
stringsAsFactors <span class="op">=</span> <span class="cn">FALSE</span><span class="op">)</span>
|
||||
<span class="va">klebsiella_test</span> <span class="co"># (our original data)</span>
|
||||
<span class="co"># mo amox</span>
|
||||
<span class="co"># 1 klebsiella S</span>
|
||||
<span class="fu"><a href="../reference/eucast_rules.html">eucast_rules</a></span>(<span class="kw">klebsiella_test</span>, info = <span class="fl">FALSE</span>) <span class="co"># (the edited data by EUCAST rules)</span>
|
||||
<span class="fu"><a href="../reference/eucast_rules.html">eucast_rules</a></span><span class="op">(</span><span class="va">klebsiella_test</span>, info <span class="op">=</span> <span class="cn">FALSE</span><span class="op">)</span> <span class="co"># (the edited data by EUCAST rules)</span>
|
||||
<span class="co"># mo amox</span>
|
||||
<span class="co"># 1 klebsiella R</span>
|
||||
|
||||
<span class="co"># hundreds of trade names can be translated to a name, trade name or an ATC code:</span>
|
||||
<span class="fu"><a href="../reference/ab_property.html">ab_name</a></span>(<span class="st">"floxapen"</span>)
|
||||
<span class="fu"><a href="../reference/ab_property.html">ab_name</a></span><span class="op">(</span><span class="st">"floxapen"</span><span class="op">)</span>
|
||||
<span class="co"># [1] "Flucloxacillin"</span>
|
||||
<span class="fu"><a href="../reference/ab_property.html">ab_tradenames</a></span>(<span class="st">"floxapen"</span>)
|
||||
<span class="fu"><a href="../reference/ab_property.html">ab_tradenames</a></span><span class="op">(</span><span class="st">"floxapen"</span><span class="op">)</span>
|
||||
<span class="co"># [1] "floxacillin" "floxapen" "floxapen sodium salt"</span>
|
||||
<span class="co"># [4] "fluclox" "flucloxacilina" "flucloxacillin" </span>
|
||||
<span class="co"># [7] "flucloxacilline" "flucloxacillinum" "fluorochloroxacillin"</span>
|
||||
<span class="fu"><a href="../reference/ab_property.html">ab_atc</a></span>(<span class="st">"floxapen"</span>)
|
||||
<span class="co"># [1] "J01CF05"</span>
|
||||
</pre></div>
|
||||
<span class="fu"><a href="../reference/ab_property.html">ab_atc</a></span><span class="op">(</span><span class="st">"floxapen"</span><span class="op">)</span>
|
||||
<span class="co"># [1] "J01CF05"</span></pre></div>
|
||||
</div>
|
||||
<div id="import-data-from-spsssasstata" class="section level2">
|
||||
<h2 class="hasAnchor">
|
||||
@@ -297,7 +296,7 @@
|
||||
<p>If you want named variables to be imported as factors so it resembles SPSS more, use <code><a href="https://haven.tidyverse.org/reference/as_factor.html">as_factor()</a></code>.</p>
|
||||
<p>The difference is this:</p>
|
||||
<div class="sourceCode" id="cb2"><pre class="downlit">
|
||||
<span class="kw">SPSS_data</span>
|
||||
<span class="va">SPSS_data</span>
|
||||
<span class="co"># # A tibble: 4,203 x 4</span>
|
||||
<span class="co"># v001 sex status statusage</span>
|
||||
<span class="co"># <dbl> <dbl+lbl> <dbl+lbl> <dbl></span>
|
||||
@@ -313,7 +312,7 @@
|
||||
<span class="co"># 10 10018 0 1 66.6</span>
|
||||
<span class="co"># # … with 4,193 more rows</span>
|
||||
|
||||
<span class="fu">as_factor</span>(<span class="kw">SPSS_data</span>)
|
||||
<span class="fu">as_factor</span><span class="op">(</span><span class="va">SPSS_data</span><span class="op">)</span>
|
||||
<span class="co"># # A tibble: 4,203 x 4</span>
|
||||
<span class="co"># v001 sex status statusage</span>
|
||||
<span class="co"># <dbl> <fct> <fct> <dbl></span>
|
||||
@@ -327,8 +326,7 @@
|
||||
<span class="co"># 8 10011 Male alive 73.1</span>
|
||||
<span class="co"># 9 10017 Male alive 56.7</span>
|
||||
<span class="co"># 10 10018 Female alive 66.6</span>
|
||||
<span class="co"># # … with 4,193 more rows</span>
|
||||
</pre></div>
|
||||
<span class="co"># # … with 4,193 more rows</span></pre></div>
|
||||
</div>
|
||||
<div id="base-r" class="section level3">
|
||||
<h3 class="hasAnchor">
|
||||
@@ -336,10 +334,9 @@
|
||||
<p>To import data from SPSS, SAS or Stata, you can use the <a href="https://haven.tidyverse.org/">great <code>haven</code> package</a> yourself:</p>
|
||||
<div class="sourceCode" id="cb3"><pre class="downlit">
|
||||
<span class="co"># download and install the latest version:</span>
|
||||
<span class="fu"><a href="https://rdrr.io/r/utils/install.packages.html">install.packages</a></span>(<span class="st">"haven"</span>)
|
||||
<span class="fu"><a href="https://rdrr.io/r/utils/install.packages.html">install.packages</a></span><span class="op">(</span><span class="st">"haven"</span><span class="op">)</span>
|
||||
<span class="co"># load the package you just installed:</span>
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/library.html">library</a></span>(<span class="kw"><a href="http://haven.tidyverse.org">haven</a></span>)
|
||||
</pre></div>
|
||||
<span class="kw"><a href="https://rdrr.io/r/base/library.html">library</a></span><span class="op">(</span><span class="va"><a href="http://haven.tidyverse.org">haven</a></span><span class="op">)</span> </pre></div>
|
||||
<p>You can now import files as follows:</p>
|
||||
<div id="spss" class="section level4">
|
||||
<h4 class="hasAnchor">
|
||||
@@ -347,23 +344,21 @@
|
||||
<p>To read files from SPSS into R:</p>
|
||||
<div class="sourceCode" id="cb4"><pre class="downlit">
|
||||
<span class="co"># read any SPSS file based on file extension (best way):</span>
|
||||
<span class="fu"><a href="https://haven.tidyverse.org/reference/read_spss.html">read_spss</a></span>(file = <span class="st">"path/to/file"</span>)
|
||||
<span class="fu"><a href="https://haven.tidyverse.org/reference/read_spss.html">read_spss</a></span><span class="op">(</span>file <span class="op">=</span> <span class="st">"path/to/file"</span><span class="op">)</span>
|
||||
|
||||
<span class="co"># read .sav or .zsav file:</span>
|
||||
<span class="fu"><a href="https://haven.tidyverse.org/reference/read_spss.html">read_sav</a></span>(file = <span class="st">"path/to/file"</span>)
|
||||
<span class="fu"><a href="https://haven.tidyverse.org/reference/read_spss.html">read_sav</a></span><span class="op">(</span>file <span class="op">=</span> <span class="st">"path/to/file"</span><span class="op">)</span>
|
||||
|
||||
<span class="co"># read .por file:</span>
|
||||
<span class="fu"><a href="https://haven.tidyverse.org/reference/read_spss.html">read_por</a></span>(file = <span class="st">"path/to/file"</span>)
|
||||
</pre></div>
|
||||
<span class="fu"><a href="https://haven.tidyverse.org/reference/read_spss.html">read_por</a></span><span class="op">(</span>file <span class="op">=</span> <span class="st">"path/to/file"</span><span class="op">)</span></pre></div>
|
||||
<p>Do not forget about <code><a href="https://haven.tidyverse.org/reference/as_factor.html">as_factor()</a></code>, as mentioned above.</p>
|
||||
<p>To export your R objects to the SPSS file format:</p>
|
||||
<div class="sourceCode" id="cb5"><pre class="downlit">
|
||||
<span class="co"># save as .sav file:</span>
|
||||
<span class="fu"><a href="https://haven.tidyverse.org/reference/read_spss.html">write_sav</a></span>(data = <span class="kw">yourdata</span>, path = <span class="st">"path/to/file"</span>)
|
||||
<span class="fu"><a href="https://haven.tidyverse.org/reference/read_spss.html">write_sav</a></span><span class="op">(</span>data <span class="op">=</span> <span class="va">yourdata</span>, path <span class="op">=</span> <span class="st">"path/to/file"</span><span class="op">)</span>
|
||||
|
||||
<span class="co"># save as compressed .zsav file:</span>
|
||||
<span class="fu"><a href="https://haven.tidyverse.org/reference/read_spss.html">write_sav</a></span>(data = <span class="kw">yourdata</span>, path = <span class="st">"path/to/file"</span>, compress = <span class="fl">TRUE</span>)
|
||||
</pre></div>
|
||||
<span class="fu"><a href="https://haven.tidyverse.org/reference/read_spss.html">write_sav</a></span><span class="op">(</span>data <span class="op">=</span> <span class="va">yourdata</span>, path <span class="op">=</span> <span class="st">"path/to/file"</span>, compress <span class="op">=</span> <span class="cn">TRUE</span><span class="op">)</span></pre></div>
|
||||
</div>
|
||||
<div id="sas" class="section level4">
|
||||
<h4 class="hasAnchor">
|
||||
@@ -371,20 +366,18 @@
|
||||
<p>To read files from SAS into R:</p>
|
||||
<div class="sourceCode" id="cb6"><pre class="downlit">
|
||||
<span class="co"># read .sas7bdat + .sas7bcat files:</span>
|
||||
<span class="fu"><a href="https://haven.tidyverse.org/reference/read_sas.html">read_sas</a></span>(data_file = <span class="st">"path/to/file"</span>, catalog_file = <span class="kw">NULL</span>)
|
||||
<span class="fu"><a href="https://haven.tidyverse.org/reference/read_sas.html">read_sas</a></span><span class="op">(</span>data_file <span class="op">=</span> <span class="st">"path/to/file"</span>, catalog_file <span class="op">=</span> <span class="cn">NULL</span><span class="op">)</span>
|
||||
|
||||
<span class="co"># read SAS transport files (version 5 and version 8):</span>
|
||||
<span class="fu"><a href="https://haven.tidyverse.org/reference/read_xpt.html">read_xpt</a></span>(file = <span class="st">"path/to/file"</span>)
|
||||
</pre></div>
|
||||
<span class="fu"><a href="https://haven.tidyverse.org/reference/read_xpt.html">read_xpt</a></span><span class="op">(</span>file <span class="op">=</span> <span class="st">"path/to/file"</span><span class="op">)</span></pre></div>
|
||||
<p>To export your R objects to the SAS file format:</p>
|
||||
<div class="sourceCode" id="cb7"><pre class="downlit">
|
||||
<span class="co"># save as regular SAS file:</span>
|
||||
<span class="fu"><a href="https://haven.tidyverse.org/reference/read_sas.html">write_sas</a></span>(data = <span class="kw">yourdata</span>, path = <span class="st">"path/to/file"</span>)
|
||||
<span class="fu"><a href="https://haven.tidyverse.org/reference/read_sas.html">write_sas</a></span><span class="op">(</span>data <span class="op">=</span> <span class="va">yourdata</span>, path <span class="op">=</span> <span class="st">"path/to/file"</span><span class="op">)</span>
|
||||
|
||||
<span class="co"># the SAS transport format is an open format </span>
|
||||
<span class="co"># (required for submission of the data to the FDA)</span>
|
||||
<span class="fu"><a href="https://haven.tidyverse.org/reference/read_xpt.html">write_xpt</a></span>(data = <span class="kw">yourdata</span>, path = <span class="st">"path/to/file"</span>, version = <span class="fl">8</span>)
|
||||
</pre></div>
|
||||
<span class="fu"><a href="https://haven.tidyverse.org/reference/read_xpt.html">write_xpt</a></span><span class="op">(</span>data <span class="op">=</span> <span class="va">yourdata</span>, path <span class="op">=</span> <span class="st">"path/to/file"</span>, version <span class="op">=</span> <span class="fl">8</span><span class="op">)</span></pre></div>
|
||||
</div>
|
||||
<div id="stata" class="section level4">
|
||||
<h4 class="hasAnchor">
|
||||
@@ -392,17 +385,15 @@
|
||||
<p>To read files from Stata into R:</p>
|
||||
<div class="sourceCode" id="cb8"><pre class="downlit">
|
||||
<span class="co"># read .dta file:</span>
|
||||
<span class="fu"><a href="https://haven.tidyverse.org/reference/read_dta.html">read_stata</a></span>(file = <span class="st">"/path/to/file"</span>)
|
||||
<span class="fu"><a href="https://haven.tidyverse.org/reference/read_dta.html">read_stata</a></span><span class="op">(</span>file <span class="op">=</span> <span class="st">"/path/to/file"</span><span class="op">)</span>
|
||||
|
||||
<span class="co"># works exactly the same:</span>
|
||||
<span class="fu"><a href="https://haven.tidyverse.org/reference/read_dta.html">read_dta</a></span>(file = <span class="st">"/path/to/file"</span>)
|
||||
</pre></div>
|
||||
<span class="fu"><a href="https://haven.tidyverse.org/reference/read_dta.html">read_dta</a></span><span class="op">(</span>file <span class="op">=</span> <span class="st">"/path/to/file"</span><span class="op">)</span></pre></div>
|
||||
<p>To export your R objects to the Stata file format:</p>
|
||||
<div class="sourceCode" id="cb9"><pre class="downlit">
|
||||
<span class="co"># save as .dta file, Stata version 14:</span>
|
||||
<span class="co"># (supports Stata v8 until v15 at the time of writing)</span>
|
||||
<span class="fu"><a href="https://haven.tidyverse.org/reference/read_dta.html">write_dta</a></span>(data = <span class="kw">yourdata</span>, path = <span class="st">"/path/to/file"</span>, version = <span class="fl">14</span>)
|
||||
</pre></div>
|
||||
<span class="fu"><a href="https://haven.tidyverse.org/reference/read_dta.html">write_dta</a></span><span class="op">(</span>data <span class="op">=</span> <span class="va">yourdata</span>, path <span class="op">=</span> <span class="st">"/path/to/file"</span>, version <span class="op">=</span> <span class="fl">14</span><span class="op">)</span></pre></div>
|
||||
</div>
|
||||
</div>
|
||||
</div>
|
||||
@@ -423,7 +414,7 @@
|
||||
</div>
|
||||
|
||||
<div class="pkgdown">
|
||||
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.9000.</p>
|
||||
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.6.1.</p>
|
||||
</div>
|
||||
|
||||
</footer>
|
||||
|
||||
@@ -0,0 +1,4 @@
|
||||
/* Styles for section anchors */
|
||||
a.anchor-section {margin-left: 10px; visibility: hidden; color: inherit;}
|
||||
a.anchor-section::before {content: '#';}
|
||||
.hasAnchor:hover a.anchor-section {visibility: visible;}
|
||||
@@ -0,0 +1,33 @@
|
||||
// Anchor sections v1.0 written by Atsushi Yasumoto on Oct 3rd, 2020.
|
||||
document.addEventListener('DOMContentLoaded', function() {
|
||||
// Do nothing if AnchorJS is used
|
||||
if (typeof window.anchors === 'object' && anchors.hasOwnProperty('hasAnchorJSLink')) {
|
||||
return;
|
||||
}
|
||||
|
||||
const h = document.querySelectorAll('h1, h2, h3, h4, h5, h6');
|
||||
|
||||
// Do nothing if sections are already anchored
|
||||
if (Array.from(h).some(x => x.classList.contains('hasAnchor'))) {
|
||||
return null;
|
||||
}
|
||||
|
||||
// Use section id when pandoc runs with --section-divs
|
||||
const section_id = function(x) {
|
||||
return ((x.classList.contains('section') || (x.tagName === 'SECTION'))
|
||||
? x.id : '');
|
||||
};
|
||||
|
||||
// Add anchors
|
||||
h.forEach(function(x) {
|
||||
const id = x.id || section_id(x.parentElement);
|
||||
if (id === '') {
|
||||
return null;
|
||||
}
|
||||
let anchor = document.createElement('a');
|
||||
anchor.href = '#' + id;
|
||||
anchor.classList = ['anchor-section'];
|
||||
x.classList.add('hasAnchor');
|
||||
x.appendChild(anchor);
|
||||
});
|
||||
});
|
||||
@@ -0,0 +1,12 @@
|
||||
// Pandoc 2.9 adds attributes on both header and div. We remove the former (to
|
||||
// be compatible with the behavior of Pandoc < 2.8).
|
||||
document.addEventListener('DOMContentLoaded', function(e) {
|
||||
var hs = document.querySelectorAll("div.section[class*='level'] > :first-child");
|
||||
var i, h, a;
|
||||
for (i = 0; i < hs.length; i++) {
|
||||
h = hs[i];
|
||||
if (!/^h[1-6]$/i.test(h.tagName)) continue; // it should be a header h1-h6
|
||||
a = h.attributes;
|
||||
while (a.length > 0) h.removeAttribute(a[0].name);
|
||||
}
|
||||
});
|
||||
+21
-25
@@ -39,7 +39,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<a class="navbar-link" href="../index.html">AMR (for R)</a>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9032</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
@@ -187,7 +187,7 @@
|
||||
|
||||
|
||||
|
||||
</header><script src="WHONET_files/header-attrs-2.3/header-attrs.js"></script><script src="WHONET_files/accessible-code-block-0.0.1/empty-anchor.js"></script><div class="row">
|
||||
</header><script src="WHONET_files/header-attrs-2.4/header-attrs.js"></script><script src="WHONET_files/accessible-code-block-0.0.1/empty-anchor.js"></script><div class="row">
|
||||
<div class="col-md-9 contents">
|
||||
<div class="page-header toc-ignore">
|
||||
<h1 data-toc-skip>How to work with WHONET data</h1>
|
||||
@@ -206,9 +206,8 @@
|
||||
<p>This tutorial assumes you already imported the WHONET data with e.g. the <a href="https://readxl.tidyverse.org/"><code>readxl</code> package</a>. In RStudio, this can be done using the menu button ‘Import Dataset’ in the tab ‘Environment’. Choose the option ‘From Excel’ and select your exported file. Make sure date fields are imported correctly.</p>
|
||||
<p>An example syntax could look like this:</p>
|
||||
<div class="sourceCode" id="cb1"><pre class="downlit">
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/library.html">library</a></span>(<span class="kw"><a href="https://readxl.tidyverse.org">readxl</a></span>)
|
||||
<span class="kw">data</span> <span class="op"><-</span> <span class="fu"><a href="https://readxl.tidyverse.org/reference/read_excel.html">read_excel</a></span>(path = <span class="st">"path/to/your/file.xlsx"</span>)
|
||||
</pre></div>
|
||||
<span class="kw"><a href="https://rdrr.io/r/base/library.html">library</a></span><span class="op">(</span><span class="va"><a href="https://readxl.tidyverse.org">readxl</a></span><span class="op">)</span>
|
||||
<span class="va">data</span> <span class="op"><-</span> <span class="fu"><a href="https://readxl.tidyverse.org/reference/read_excel.html">read_excel</a></span><span class="op">(</span>path <span class="op">=</span> <span class="st">"path/to/your/file.xlsx"</span><span class="op">)</span></pre></div>
|
||||
<p>This package comes with an <a href="https://msberends.github.io/AMR/reference/WHONET.html">example data set <code>WHONET</code></a>. We will use it for this analysis.</p>
|
||||
</div>
|
||||
<div id="preparation" class="section level3">
|
||||
@@ -216,11 +215,10 @@
|
||||
<a href="#preparation" class="anchor"></a>Preparation</h3>
|
||||
<p>First, load the relevant packages if you did not yet did this. I use the tidyverse for all of my analyses. All of them. If you don’t know it yet, I suggest you read about it on their website: <a href="https://www.tidyverse.org/" class="uri">https://www.tidyverse.org/</a>.</p>
|
||||
<div class="sourceCode" id="cb2"><pre class="downlit">
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/library.html">library</a></span>(<span class="kw"><a href="https://dplyr.tidyverse.org">dplyr</a></span>) <span class="co"># part of tidyverse</span>
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/library.html">library</a></span>(<span class="kw"><a href="http://ggplot2.tidyverse.org">ggplot2</a></span>) <span class="co"># part of tidyverse</span>
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/library.html">library</a></span>(<span class="kw"><a href="https://msberends.github.io/AMR">AMR</a></span>) <span class="co"># this package</span>
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/library.html">library</a></span>(<span class="kw"><a href="https://github.com/msberends/cleaner">cleaner</a></span>) <span class="co"># to create frequency tables</span>
|
||||
</pre></div>
|
||||
<span class="kw"><a href="https://rdrr.io/r/base/library.html">library</a></span><span class="op">(</span><span class="va"><a href="https://dplyr.tidyverse.org">dplyr</a></span><span class="op">)</span> <span class="co"># part of tidyverse</span>
|
||||
<span class="kw"><a href="https://rdrr.io/r/base/library.html">library</a></span><span class="op">(</span><span class="va"><a href="http://ggplot2.tidyverse.org">ggplot2</a></span><span class="op">)</span> <span class="co"># part of tidyverse</span>
|
||||
<span class="kw"><a href="https://rdrr.io/r/base/library.html">library</a></span><span class="op">(</span><span class="va"><a href="https://msberends.github.io/AMR/">AMR</a></span><span class="op">)</span> <span class="co"># this package</span>
|
||||
<span class="kw"><a href="https://rdrr.io/r/base/library.html">library</a></span><span class="op">(</span><span class="va"><a href="https://github.com/msberends/cleaner">cleaner</a></span><span class="op">)</span> <span class="co"># to create frequency tables</span></pre></div>
|
||||
<p>We will have to transform some variables to simplify and automate the analysis:</p>
|
||||
<ul>
|
||||
<li>Microorganisms should be transformed to our own microorganism IDs (called an <code>mo</code>) using <a href="https://msberends.github.io/AMR/reference/catalogue_of_life">our Catalogue of Life reference data set</a>, which contains all ~70,000 microorganisms from the taxonomic kingdoms Bacteria, Fungi and Protozoa. We do the tranformation with <code><a href="../reference/as.mo.html">as.mo()</a></code>. This function also recognises almost all WHONET abbreviations of microorganisms.</li>
|
||||
@@ -228,19 +226,17 @@
|
||||
</ul>
|
||||
<div class="sourceCode" id="cb3"><pre class="downlit">
|
||||
<span class="co"># transform variables</span>
|
||||
<span class="kw">data</span> <span class="op"><-</span> <span class="kw">WHONET</span> <span class="op">%>%</span>
|
||||
<span class="va">data</span> <span class="op"><-</span> <span class="va">WHONET</span> <span class="op">%>%</span>
|
||||
<span class="co"># get microbial ID based on given organism</span>
|
||||
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/mutate.html">mutate</a></span>(mo = <span class="fu"><a href="../reference/as.mo.html">as.mo</a></span>(<span class="kw">Organism</span>)) <span class="op">%>%</span>
|
||||
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/mutate.html">mutate</a></span><span class="op">(</span>mo <span class="op">=</span> <span class="fu"><a href="../reference/as.mo.html">as.mo</a></span><span class="op">(</span><span class="va">Organism</span><span class="op">)</span><span class="op">)</span> <span class="op">%>%</span>
|
||||
<span class="co"># transform everything from "AMP_ND10" to "CIP_EE" to the new `rsi` class</span>
|
||||
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/mutate_all.html">mutate_at</a></span>(<span class="fu"><a href="https://dplyr.tidyverse.org/reference/vars.html">vars</a></span>(<span class="kw">AMP_ND10</span><span class="op">:</span><span class="kw">CIP_EE</span>), <span class="kw">as.rsi</span>)
|
||||
</pre></div>
|
||||
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/mutate_all.html">mutate_at</a></span><span class="op">(</span><span class="fu"><a href="https://dplyr.tidyverse.org/reference/vars.html">vars</a></span><span class="op">(</span><span class="va">AMP_ND10</span><span class="op">:</span><span class="va">CIP_EE</span><span class="op">)</span>, <span class="va">as.rsi</span><span class="op">)</span></pre></div>
|
||||
<p>No errors or warnings, so all values are transformed succesfully.</p>
|
||||
<p>We also created a package dedicated to data cleaning and checking, called the <code>cleaner</code> package. Its <code><a href="https://rdrr.io/pkg/cleaner/man/freq.html">freq()</a></code> function can be used to create frequency tables.</p>
|
||||
<p>So let’s check our data, with a couple of frequency tables:</p>
|
||||
<div class="sourceCode" id="cb4"><pre class="downlit">
|
||||
<span class="co"># our newly created `mo` variable, put in the mo_name() function</span>
|
||||
<span class="kw">data</span> <span class="op">%>%</span> <span class="fu"><a href="https://rdrr.io/pkg/cleaner/man/freq.html">freq</a></span>(<span class="fu"><a href="../reference/mo_property.html">mo_name</a></span>(<span class="kw">mo</span>), nmax = <span class="fl">10</span>)
|
||||
</pre></div>
|
||||
<span class="va">data</span> <span class="op">%>%</span> <span class="fu"><a href="https://rdrr.io/pkg/cleaner/man/freq.html">freq</a></span><span class="op">(</span><span class="fu"><a href="../reference/mo_property.html">mo_name</a></span><span class="op">(</span><span class="va">mo</span><span class="op">)</span>, nmax <span class="op">=</span> <span class="fl">10</span><span class="op">)</span></pre></div>
|
||||
<p><strong>Frequency table</strong></p>
|
||||
<p>Class: character<br>
|
||||
Length: 500<br>
|
||||
@@ -344,15 +340,16 @@ Longest: 40</p>
|
||||
<div class="sourceCode" id="cb5"><pre class="downlit">
|
||||
<span class="co"># our transformed antibiotic columns</span>
|
||||
<span class="co"># amoxicillin/clavulanic acid (J01CR02) as an example</span>
|
||||
<span class="kw">data</span> <span class="op">%>%</span> <span class="fu"><a href="https://rdrr.io/pkg/cleaner/man/freq.html">freq</a></span>(<span class="kw">AMC_ND2</span>)
|
||||
</pre></div>
|
||||
<span class="va">data</span> <span class="op">%>%</span> <span class="fu"><a href="https://rdrr.io/pkg/cleaner/man/freq.html">freq</a></span><span class="op">(</span><span class="va">AMC_ND2</span><span class="op">)</span></pre></div>
|
||||
<p><strong>Frequency table</strong></p>
|
||||
<p>Class: factor > ordered > rsi (numeric)<br>
|
||||
Length: 500<br>
|
||||
Levels: 3: S < I < R<br>
|
||||
Available: 481 (96.2%, NA: 19 = 3.8%)<br>
|
||||
Unique: 3</p>
|
||||
<p>%SI: 78.59%</p>
|
||||
<p>Drug: Amoxicillin/clavulanic acid (AMC, J01CR02)<br>
|
||||
Drug group: Beta-lactams/penicillins<br>
|
||||
%SI: 78.59%</p>
|
||||
<table class="table">
|
||||
<thead><tr class="header">
|
||||
<th align="left"></th>
|
||||
@@ -395,11 +392,10 @@ Unique: 3</p>
|
||||
<a href="#a-first-glimpse-at-results" class="anchor"></a>A first glimpse at results</h3>
|
||||
<p>An easy <code>ggplot</code> will already give a lot of information, using the included <code><a href="../reference/ggplot_rsi.html">ggplot_rsi()</a></code> function:</p>
|
||||
<div class="sourceCode" id="cb6"><pre class="downlit">
|
||||
<span class="kw">data</span> <span class="op">%>%</span>
|
||||
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/group_by.html">group_by</a></span>(<span class="kw">Country</span>) <span class="op">%>%</span>
|
||||
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/select.html">select</a></span>(<span class="kw">Country</span>, <span class="kw">AMP_ND2</span>, <span class="kw">AMC_ED20</span>, <span class="kw">CAZ_ED10</span>, <span class="kw">CIP_ED5</span>) <span class="op">%>%</span>
|
||||
<span class="fu"><a href="../reference/ggplot_rsi.html">ggplot_rsi</a></span>(translate_ab = <span class="st">'ab'</span>, facet = <span class="st">"Country"</span>, datalabels = <span class="fl">FALSE</span>)
|
||||
</pre></div>
|
||||
<span class="va">data</span> <span class="op">%>%</span>
|
||||
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/group_by.html">group_by</a></span><span class="op">(</span><span class="va">Country</span><span class="op">)</span> <span class="op">%>%</span>
|
||||
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/select.html">select</a></span><span class="op">(</span><span class="va">Country</span>, <span class="va">AMP_ND2</span>, <span class="va">AMC_ED20</span>, <span class="va">CAZ_ED10</span>, <span class="va">CIP_ED5</span><span class="op">)</span> <span class="op">%>%</span>
|
||||
<span class="fu"><a href="../reference/ggplot_rsi.html">ggplot_rsi</a></span><span class="op">(</span>translate_ab <span class="op">=</span> <span class="st">'ab'</span>, facet <span class="op">=</span> <span class="st">"Country"</span>, datalabels <span class="op">=</span> <span class="cn">FALSE</span><span class="op">)</span></pre></div>
|
||||
<p><img src="WHONET_files/figure-html/unnamed-chunk-7-1.png" width="720"></p>
|
||||
</div>
|
||||
</div>
|
||||
@@ -417,7 +413,7 @@ Unique: 3</p>
|
||||
</div>
|
||||
|
||||
<div class="pkgdown">
|
||||
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.9000.</p>
|
||||
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.6.1.</p>
|
||||
</div>
|
||||
|
||||
</footer>
|
||||
|
||||
@@ -0,0 +1,4 @@
|
||||
/* Styles for section anchors */
|
||||
a.anchor-section {margin-left: 10px; visibility: hidden; color: inherit;}
|
||||
a.anchor-section::before {content: '#';}
|
||||
.hasAnchor:hover a.anchor-section {visibility: visible;}
|
||||
@@ -0,0 +1,33 @@
|
||||
// Anchor sections v1.0 written by Atsushi Yasumoto on Oct 3rd, 2020.
|
||||
document.addEventListener('DOMContentLoaded', function() {
|
||||
// Do nothing if AnchorJS is used
|
||||
if (typeof window.anchors === 'object' && anchors.hasOwnProperty('hasAnchorJSLink')) {
|
||||
return;
|
||||
}
|
||||
|
||||
const h = document.querySelectorAll('h1, h2, h3, h4, h5, h6');
|
||||
|
||||
// Do nothing if sections are already anchored
|
||||
if (Array.from(h).some(x => x.classList.contains('hasAnchor'))) {
|
||||
return null;
|
||||
}
|
||||
|
||||
// Use section id when pandoc runs with --section-divs
|
||||
const section_id = function(x) {
|
||||
return ((x.classList.contains('section') || (x.tagName === 'SECTION'))
|
||||
? x.id : '');
|
||||
};
|
||||
|
||||
// Add anchors
|
||||
h.forEach(function(x) {
|
||||
const id = x.id || section_id(x.parentElement);
|
||||
if (id === '') {
|
||||
return null;
|
||||
}
|
||||
let anchor = document.createElement('a');
|
||||
anchor.href = '#' + id;
|
||||
anchor.classList = ['anchor-section'];
|
||||
x.classList.add('hasAnchor');
|
||||
x.appendChild(anchor);
|
||||
});
|
||||
});
|
||||
Binary file not shown.
|
Before Width: | Height: | Size: 94 KiB After Width: | Height: | Size: 59 KiB |
@@ -0,0 +1,12 @@
|
||||
// Pandoc 2.9 adds attributes on both header and div. We remove the former (to
|
||||
// be compatible with the behavior of Pandoc < 2.8).
|
||||
document.addEventListener('DOMContentLoaded', function(e) {
|
||||
var hs = document.querySelectorAll("div.section[class*='level'] > :first-child");
|
||||
var i, h, a;
|
||||
for (i = 0; i < hs.length; i++) {
|
||||
h = hs[i];
|
||||
if (!/^h[1-6]$/i.test(h.tagName)) continue; // it should be a header h1-h6
|
||||
a = h.attributes;
|
||||
while (a.length > 0) h.removeAttribute(a[0].name);
|
||||
}
|
||||
});
|
||||
+107
-169
@@ -39,7 +39,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<a class="navbar-link" href="../index.html">AMR (for R)</a>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9032</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
@@ -187,7 +187,7 @@
|
||||
|
||||
|
||||
|
||||
</header><script src="benchmarks_files/header-attrs-2.3/header-attrs.js"></script><script src="benchmarks_files/accessible-code-block-0.0.1/empty-anchor.js"></script><div class="row">
|
||||
</header><script src="benchmarks_files/header-attrs-2.4/header-attrs.js"></script><script src="benchmarks_files/accessible-code-block-0.0.1/empty-anchor.js"></script><div class="row">
|
||||
<div class="col-md-9 contents">
|
||||
<div class="page-header toc-ignore">
|
||||
<h1 data-toc-skip>Benchmarks</h1>
|
||||
@@ -203,106 +203,58 @@
|
||||
<p>One of the most important features of this package is the complete microbial taxonomic database, supplied by the <a href="http://catalogueoflife.org">Catalogue of Life</a>. We created a function <code><a href="../reference/as.mo.html">as.mo()</a></code> that transforms any user input value to a valid microbial ID by using intelligent rules combined with the taxonomic tree of Catalogue of Life.</p>
|
||||
<p>Using the <code>microbenchmark</code> package, we can review the calculation performance of this function. Its function <code>microbenchmark()</code> runs different input expressions independently of each other and measures their time-to-result.</p>
|
||||
<div class="sourceCode" id="cb1"><pre class="downlit">
|
||||
<span class="kw">microbenchmark</span> <span class="op"><-</span> <span class="kw">microbenchmark</span>::<span class="kw"><a href="https://rdrr.io/pkg/microbenchmark/man/microbenchmark.html">microbenchmark</a></span>
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/library.html">library</a></span>(<span class="kw"><a href="https://msberends.github.io/AMR">AMR</a></span>)
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/library.html">library</a></span>(<span class="kw"><a href="https://dplyr.tidyverse.org">dplyr</a></span>)
|
||||
</pre></div>
|
||||
<span class="va">microbenchmark</span> <span class="op"><-</span> <span class="fu">microbenchmark</span><span class="fu">::</span><span class="va"><a href="https://rdrr.io/pkg/microbenchmark/man/microbenchmark.html">microbenchmark</a></span>
|
||||
<span class="kw"><a href="https://rdrr.io/r/base/library.html">library</a></span><span class="op">(</span><span class="va"><a href="https://msberends.github.io/AMR/">AMR</a></span><span class="op">)</span>
|
||||
<span class="kw"><a href="https://rdrr.io/r/base/library.html">library</a></span><span class="op">(</span><span class="va"><a href="https://dplyr.tidyverse.org">dplyr</a></span><span class="op">)</span></pre></div>
|
||||
<p>In the next test, we try to ‘coerce’ different input values into the microbial code of <em>Staphylococcus aureus</em>. Coercion is a computational process of forcing output based on an input. For microorganism names, coercing user input to taxonomically valid microorganism names is crucial to ensure correct interpretation and to enable grouping based on taxonomic properties.</p>
|
||||
<p>The actual result is the same every time: it returns its microorganism code <code>B_STPHY_AURS</code> (<em>B</em> stands for <em>Bacteria</em>, the taxonomic kingdom).</p>
|
||||
<p>But the calculation time differs a lot:</p>
|
||||
<div class="sourceCode" id="cb2"><pre class="downlit">
|
||||
<span class="kw">S.aureus</span> <span class="op"><-</span> <span class="fu">microbenchmark</span>(
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span>(<span class="st">"sau"</span>), <span class="co"># WHONET code</span>
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span>(<span class="st">"stau"</span>),
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span>(<span class="st">"STAU"</span>),
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span>(<span class="st">"staaur"</span>),
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span>(<span class="st">"STAAUR"</span>),
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span>(<span class="st">"S. aureus"</span>),
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span>(<span class="st">"S aureus"</span>),
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span>(<span class="st">"Staphylococcus aureus"</span>), <span class="co"># official taxonomic name</span>
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span>(<span class="st">"Staphylococcus aureus (MRSA)"</span>), <span class="co"># additional text</span>
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span>(<span class="st">"Sthafilokkockus aaureuz"</span>), <span class="co"># incorrect spelling</span>
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span>(<span class="st">"MRSA"</span>), <span class="co"># Methicillin Resistant S. aureus</span>
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span>(<span class="st">"VISA"</span>), <span class="co"># Vancomycin Intermediate S. aureus</span>
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span>(<span class="st">"VRSA"</span>), <span class="co"># Vancomycin Resistant S. aureus</span>
|
||||
times = <span class="fl">10</span>)
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="fu"><a href="https://docs.ropensci.org/skimr/reference/print.html">print</a></span>(<span class="kw">S.aureus</span>, unit = <span class="st">"ms"</span>, signif = <span class="fl">2</span>)
|
||||
<span class="va">S.aureus</span> <span class="op"><-</span> <span class="fu">microbenchmark</span><span class="op">(</span>
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span><span class="op">(</span><span class="st">"sau"</span><span class="op">)</span>, <span class="co"># WHONET code</span>
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span><span class="op">(</span><span class="st">"stau"</span><span class="op">)</span>,
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span><span class="op">(</span><span class="st">"STAU"</span><span class="op">)</span>,
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span><span class="op">(</span><span class="st">"staaur"</span><span class="op">)</span>,
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span><span class="op">(</span><span class="st">"STAAUR"</span><span class="op">)</span>,
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span><span class="op">(</span><span class="st">"S. aureus"</span><span class="op">)</span>,
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span><span class="op">(</span><span class="st">"S aureus"</span><span class="op">)</span>,
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span><span class="op">(</span><span class="st">"Staphylococcus aureus"</span><span class="op">)</span>, <span class="co"># official taxonomic name</span>
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span><span class="op">(</span><span class="st">"Staphylococcus aureus (MRSA)"</span><span class="op">)</span>, <span class="co"># additional text</span>
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span><span class="op">(</span><span class="st">"Sthafilokkockus aaureuz"</span><span class="op">)</span>, <span class="co"># incorrect spelling</span>
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span><span class="op">(</span><span class="st">"MRSA"</span><span class="op">)</span>, <span class="co"># Methicillin Resistant S. aureus</span>
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span><span class="op">(</span><span class="st">"VISA"</span><span class="op">)</span>, <span class="co"># Vancomycin Intermediate S. aureus</span>
|
||||
<span class="fu"><a href="../reference/as.mo.html">as.mo</a></span><span class="op">(</span><span class="st">"VRSA"</span><span class="op">)</span>, <span class="co"># Vancomycin Resistant S. aureus</span>
|
||||
times <span class="op">=</span> <span class="fl">10</span><span class="op">)</span>
|
||||
<span class="fu"><a href="https://docs.ropensci.org/skimr/reference/print.html">print</a></span><span class="op">(</span><span class="va">S.aureus</span>, unit <span class="op">=</span> <span class="st">"ms"</span>, signif <span class="op">=</span> <span class="fl">2</span><span class="op">)</span>
|
||||
<span class="co"># Unit: milliseconds</span>
|
||||
<span class="co"># expr min lq mean median uq max neval</span>
|
||||
<span class="co"># as.mo("sau") 11.0 12.0 25.0 13.0 14.0 130 10</span>
|
||||
<span class="co"># as.mo("stau") 210.0 230.0 240.0 250.0 250.0 260 10</span>
|
||||
<span class="co"># as.mo("STAU") 210.0 210.0 240.0 240.0 260.0 270 10</span>
|
||||
<span class="co"># as.mo("staaur") 12.0 14.0 22.0 14.0 41.0 43 10</span>
|
||||
<span class="co"># as.mo("STAAUR") 12.0 12.0 19.0 13.0 14.0 47 10</span>
|
||||
<span class="co"># as.mo("S. aureus") 26.0 28.0 38.0 30.0 58.0 62 10</span>
|
||||
<span class="co"># as.mo("S aureus") 28.0 29.0 45.0 52.0 56.0 60 10</span>
|
||||
<span class="co"># as.mo("Staphylococcus aureus") 2.1 2.2 7.9 2.4 2.6 32 10</span>
|
||||
<span class="co"># as.mo("Staphylococcus aureus (MRSA)") 840.0 880.0 890.0 890.0 890.0 930 10</span>
|
||||
<span class="co"># as.mo("Sthafilokkockus aaureuz") 340.0 370.0 390.0 390.0 410.0 490 10</span>
|
||||
<span class="co"># as.mo("MRSA") 11.0 12.0 16.0 13.0 14.0 44 10</span>
|
||||
<span class="co"># as.mo("VISA") 19.0 20.0 32.0 22.0 50.0 51 10</span>
|
||||
<span class="co"># as.mo("VRSA") 18.0 22.0 24.0 22.0 23.0 46 10</span>
|
||||
</pre></div>
|
||||
<span class="co"># expr min lq mean median uq max</span>
|
||||
<span class="co"># as.mo("sau") 13.0 13.0 17.0 15.0 16.0 43.0</span>
|
||||
<span class="co"># as.mo("stau") 120.0 120.0 140.0 150.0 150.0 160.0</span>
|
||||
<span class="co"># as.mo("STAU") 120.0 150.0 150.0 150.0 160.0 160.0</span>
|
||||
<span class="co"># as.mo("staaur") 13.0 13.0 17.0 14.0 16.0 44.0</span>
|
||||
<span class="co"># as.mo("STAAUR") 13.0 14.0 19.0 16.0 16.0 48.0</span>
|
||||
<span class="co"># as.mo("S. aureus") 34.0 58.0 61.0 63.0 68.0 86.0</span>
|
||||
<span class="co"># as.mo("S aureus") 33.0 34.0 46.0 36.0 63.0 63.0</span>
|
||||
<span class="co"># as.mo("Staphylococcus aureus") 2.3 2.5 2.5 2.5 2.6 2.7</span>
|
||||
<span class="co"># as.mo("Staphylococcus aureus (MRSA)") 980.0 980.0 1000.0 1000.0 1000.0 1100.0</span>
|
||||
<span class="co"># as.mo("Sthafilokkockus aaureuz") 430.0 430.0 440.0 440.0 440.0 460.0</span>
|
||||
<span class="co"># as.mo("MRSA") 13.0 14.0 18.0 16.0 17.0 43.0</span>
|
||||
<span class="co"># as.mo("VISA") 21.0 22.0 23.0 22.0 24.0 25.0</span>
|
||||
<span class="co"># as.mo("VRSA") 22.0 23.0 35.0 27.0 52.0 55.0</span>
|
||||
<span class="co"># neval</span>
|
||||
<span class="co"># 10</span>
|
||||
<span class="co"># 10</span>
|
||||
<span class="co"># 10</span>
|
||||
<span class="co"># 10</span>
|
||||
<span class="co"># 10</span>
|
||||
<span class="co"># 10</span>
|
||||
<span class="co"># 10</span>
|
||||
<span class="co"># 10</span>
|
||||
<span class="co"># 10</span>
|
||||
<span class="co"># 10</span>
|
||||
<span class="co"># 10</span>
|
||||
<span class="co"># 10</span>
|
||||
<span class="co"># 10</span></pre></div>
|
||||
<p><img src="benchmarks_files/figure-html/unnamed-chunk-4-1.png" width="562.5"></p>
|
||||
<p>In the table above, all measurements are shown in milliseconds (thousands of seconds). A value of 5 milliseconds means it can determine 200 input values per second. It case of 100 milliseconds, this is only 10 input values per second. It is clear that accepted taxonomic names are extremely fast, but some variations can take up to 500-1000 times as much time.</p>
|
||||
<p>To improve performance, two important calculations take almost no time at all: <strong>repetitive results</strong> and <strong>already precalculated results</strong>.</p>
|
||||
@@ -312,79 +264,66 @@
|
||||
<p>Repetitive results are unique values that are present more than once. Unique values will only be calculated once by <code><a href="../reference/as.mo.html">as.mo()</a></code>. We will use <code><a href="../reference/mo_property.html">mo_name()</a></code> for this test - a helper function that returns the full microbial name (genus, species and possibly subspecies) which uses <code><a href="../reference/as.mo.html">as.mo()</a></code> internally.</p>
|
||||
<div class="sourceCode" id="cb3"><pre class="downlit">
|
||||
<span class="co"># take all MO codes from the example_isolates data set</span>
|
||||
<span class="kw">x</span> <span class="op"><-</span> <span class="kw">example_isolates</span><span class="op">$</span><span class="kw">mo</span> <span class="op">%>%</span>
|
||||
<span class="va">x</span> <span class="op"><-</span> <span class="va">example_isolates</span><span class="op">$</span><span class="va">mo</span> <span class="op">%>%</span>
|
||||
<span class="co"># and copy them a thousand times</span>
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/rep.html">rep</a></span>(<span class="fl">1000</span>) <span class="op">%>%</span>
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/rep.html">rep</a></span><span class="op">(</span><span class="fl">1000</span><span class="op">)</span> <span class="op">%>%</span>
|
||||
<span class="co"># then scramble them</span>
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/sample.html">sample</a></span>()
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/sample.html">sample</a></span><span class="op">(</span><span class="op">)</span>
|
||||
|
||||
<span class="co"># as the example_isolates has 2,000 rows, we should have 2 million items</span>
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/length.html">length</a></span>(<span class="kw">x</span>)
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/length.html">length</a></span><span class="op">(</span><span class="va">x</span><span class="op">)</span>
|
||||
<span class="co"># [1] 2000000</span>
|
||||
|
||||
<span class="co"># and how many unique values do we have?</span>
|
||||
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/n_distinct.html">n_distinct</a></span>(<span class="kw">x</span>)
|
||||
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/n_distinct.html">n_distinct</a></span><span class="op">(</span><span class="va">x</span><span class="op">)</span>
|
||||
<span class="co"># [1] 90</span>
|
||||
|
||||
<span class="co"># now let's see:</span>
|
||||
<span class="kw">run_it</span> <span class="op"><-</span> <span class="fu">microbenchmark</span>(<span class="fu"><a href="../reference/mo_property.html">mo_name</a></span>(<span class="kw">x</span>),
|
||||
times = <span class="fl">10</span>)
|
||||
<span class="fu"><a href="https://docs.ropensci.org/skimr/reference/print.html">print</a></span>(<span class="kw">run_it</span>, unit = <span class="st">"ms"</span>, signif = <span class="fl">3</span>)
|
||||
<span class="va">run_it</span> <span class="op"><-</span> <span class="fu">microbenchmark</span><span class="op">(</span><span class="fu"><a href="../reference/mo_property.html">mo_name</a></span><span class="op">(</span><span class="va">x</span><span class="op">)</span>,
|
||||
times <span class="op">=</span> <span class="fl">10</span><span class="op">)</span>
|
||||
<span class="fu"><a href="https://docs.ropensci.org/skimr/reference/print.html">print</a></span><span class="op">(</span><span class="va">run_it</span>, unit <span class="op">=</span> <span class="st">"ms"</span>, signif <span class="op">=</span> <span class="fl">3</span><span class="op">)</span>
|
||||
<span class="co"># Unit: milliseconds</span>
|
||||
<span class="co"># expr min lq mean median uq max neval</span>
|
||||
<span class="co"># mo_name(x) 131 161 200 168 187 341 10</span>
|
||||
</pre></div>
|
||||
<p>So getting official taxonomic names of 2,000,000 (!!) items consisting of 90 unique values only takes 0.168 seconds. You only lose time on your unique input values.</p>
|
||||
<span class="co"># mo_name(x) 145 190 221 213 248 313 10</span></pre></div>
|
||||
<p>So getting official taxonomic names of 2,000,000 (!!) items consisting of 90 unique values only takes 0.213 seconds. You only lose time on your unique input values.</p>
|
||||
</div>
|
||||
<div id="precalculated-results" class="section level3">
|
||||
<h3 class="hasAnchor">
|
||||
<a href="#precalculated-results" class="anchor"></a>Precalculated results</h3>
|
||||
<p>What about precalculated results? If the input is an already precalculated result of a helper function like <code><a href="../reference/mo_property.html">mo_name()</a></code>, it almost doesn’t take any time at all (see ‘C’ below):</p>
|
||||
<div class="sourceCode" id="cb4"><pre class="downlit">
|
||||
<span class="kw">run_it</span> <span class="op"><-</span> <span class="fu">microbenchmark</span>(A = <span class="fu"><a href="../reference/mo_property.html">mo_name</a></span>(<span class="st">"STAAUR"</span>),
|
||||
B = <span class="fu"><a href="../reference/mo_property.html">mo_name</a></span>(<span class="st">"S. aureus"</span>),
|
||||
C = <span class="fu"><a href="../reference/mo_property.html">mo_name</a></span>(<span class="st">"Staphylococcus aureus"</span>),
|
||||
times = <span class="fl">10</span>)
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="co"># Result of one value was guessed with uncertainty. Use mo_uncertainties() to review it.</span>
|
||||
<span class="fu"><a href="https://docs.ropensci.org/skimr/reference/print.html">print</a></span>(<span class="kw">run_it</span>, unit = <span class="st">"ms"</span>, signif = <span class="fl">3</span>)
|
||||
<span class="va">run_it</span> <span class="op"><-</span> <span class="fu">microbenchmark</span><span class="op">(</span>A <span class="op">=</span> <span class="fu"><a href="../reference/mo_property.html">mo_name</a></span><span class="op">(</span><span class="st">"STAAUR"</span><span class="op">)</span>,
|
||||
B <span class="op">=</span> <span class="fu"><a href="../reference/mo_property.html">mo_name</a></span><span class="op">(</span><span class="st">"S. aureus"</span><span class="op">)</span>,
|
||||
C <span class="op">=</span> <span class="fu"><a href="../reference/mo_property.html">mo_name</a></span><span class="op">(</span><span class="st">"Staphylococcus aureus"</span><span class="op">)</span>,
|
||||
times <span class="op">=</span> <span class="fl">10</span><span class="op">)</span>
|
||||
<span class="fu"><a href="https://docs.ropensci.org/skimr/reference/print.html">print</a></span><span class="op">(</span><span class="va">run_it</span>, unit <span class="op">=</span> <span class="st">"ms"</span>, signif <span class="op">=</span> <span class="fl">3</span><span class="op">)</span>
|
||||
<span class="co"># Unit: milliseconds</span>
|
||||
<span class="co"># expr min lq mean median uq max neval</span>
|
||||
<span class="co"># A 6.85 7.05 7.57 7.51 8.05 8.52 10</span>
|
||||
<span class="co"># B 21.50 21.70 27.40 23.80 25.00 64.70 10</span>
|
||||
<span class="co"># C 1.75 1.86 1.99 1.93 2.08 2.27 10</span>
|
||||
</pre></div>
|
||||
<p>So going from <code><a href="../reference/mo_property.html">mo_name("Staphylococcus aureus")</a></code> to <code>"Staphylococcus aureus"</code> takes 0.0019 seconds - it doesn’t even start calculating <em>if the result would be the same as the expected resulting value</em>. That goes for all helper functions:</p>
|
||||
<span class="co"># A 8.36 8.59 8.99 9.07 9.29 9.62 10</span>
|
||||
<span class="co"># B 26.80 27.50 28.10 28.00 29.10 29.80 10</span>
|
||||
<span class="co"># C 2.06 2.15 6.68 2.50 2.69 45.20 10</span></pre></div>
|
||||
<p>So going from <code><a href="../reference/mo_property.html">mo_name("Staphylococcus aureus")</a></code> to <code>"Staphylococcus aureus"</code> takes 0.0025 seconds - it doesn’t even start calculating <em>if the result would be the same as the expected resulting value</em>. That goes for all helper functions:</p>
|
||||
<div class="sourceCode" id="cb5"><pre class="downlit">
|
||||
<span class="kw">run_it</span> <span class="op"><-</span> <span class="fu">microbenchmark</span>(A = <span class="fu"><a href="../reference/mo_property.html">mo_species</a></span>(<span class="st">"aureus"</span>),
|
||||
B = <span class="fu"><a href="../reference/mo_property.html">mo_genus</a></span>(<span class="st">"Staphylococcus"</span>),
|
||||
C = <span class="fu"><a href="../reference/mo_property.html">mo_name</a></span>(<span class="st">"Staphylococcus aureus"</span>),
|
||||
D = <span class="fu"><a href="../reference/mo_property.html">mo_family</a></span>(<span class="st">"Staphylococcaceae"</span>),
|
||||
E = <span class="fu"><a href="../reference/mo_property.html">mo_order</a></span>(<span class="st">"Bacillales"</span>),
|
||||
F = <span class="fu"><a href="../reference/mo_property.html">mo_class</a></span>(<span class="st">"Bacilli"</span>),
|
||||
G = <span class="fu"><a href="../reference/mo_property.html">mo_phylum</a></span>(<span class="st">"Firmicutes"</span>),
|
||||
H = <span class="fu"><a href="../reference/mo_property.html">mo_kingdom</a></span>(<span class="st">"Bacteria"</span>),
|
||||
times = <span class="fl">10</span>)
|
||||
<span class="fu"><a href="https://docs.ropensci.org/skimr/reference/print.html">print</a></span>(<span class="kw">run_it</span>, unit = <span class="st">"ms"</span>, signif = <span class="fl">3</span>)
|
||||
<span class="va">run_it</span> <span class="op"><-</span> <span class="fu">microbenchmark</span><span class="op">(</span>A <span class="op">=</span> <span class="fu"><a href="../reference/mo_property.html">mo_species</a></span><span class="op">(</span><span class="st">"aureus"</span><span class="op">)</span>,
|
||||
B <span class="op">=</span> <span class="fu"><a href="../reference/mo_property.html">mo_genus</a></span><span class="op">(</span><span class="st">"Staphylococcus"</span><span class="op">)</span>,
|
||||
C <span class="op">=</span> <span class="fu"><a href="../reference/mo_property.html">mo_name</a></span><span class="op">(</span><span class="st">"Staphylococcus aureus"</span><span class="op">)</span>,
|
||||
D <span class="op">=</span> <span class="fu"><a href="../reference/mo_property.html">mo_family</a></span><span class="op">(</span><span class="st">"Staphylococcaceae"</span><span class="op">)</span>,
|
||||
E <span class="op">=</span> <span class="fu"><a href="../reference/mo_property.html">mo_order</a></span><span class="op">(</span><span class="st">"Bacillales"</span><span class="op">)</span>,
|
||||
F <span class="op">=</span> <span class="fu"><a href="../reference/mo_property.html">mo_class</a></span><span class="op">(</span><span class="st">"Bacilli"</span><span class="op">)</span>,
|
||||
G <span class="op">=</span> <span class="fu"><a href="../reference/mo_property.html">mo_phylum</a></span><span class="op">(</span><span class="st">"Firmicutes"</span><span class="op">)</span>,
|
||||
H <span class="op">=</span> <span class="fu"><a href="../reference/mo_property.html">mo_kingdom</a></span><span class="op">(</span><span class="st">"Bacteria"</span><span class="op">)</span>,
|
||||
times <span class="op">=</span> <span class="fl">10</span><span class="op">)</span>
|
||||
<span class="fu"><a href="https://docs.ropensci.org/skimr/reference/print.html">print</a></span><span class="op">(</span><span class="va">run_it</span>, unit <span class="op">=</span> <span class="st">"ms"</span>, signif <span class="op">=</span> <span class="fl">3</span><span class="op">)</span>
|
||||
<span class="co"># Unit: milliseconds</span>
|
||||
<span class="co"># expr min lq mean median uq max neval</span>
|
||||
<span class="co"># A 1.38 1.57 1.60 1.61 1.67 1.71 10</span>
|
||||
<span class="co"># B 1.55 1.60 1.73 1.63 1.92 2.05 10</span>
|
||||
<span class="co"># C 1.39 1.50 1.70 1.62 1.84 2.39 10</span>
|
||||
<span class="co"># D 1.32 1.51 1.59 1.57 1.61 2.04 10</span>
|
||||
<span class="co"># E 1.34 1.40 1.52 1.53 1.65 1.66 10</span>
|
||||
<span class="co"># F 1.28 1.53 1.56 1.60 1.66 1.72 10</span>
|
||||
<span class="co"># G 1.30 1.33 1.59 1.61 1.74 1.98 10</span>
|
||||
<span class="co"># H 1.31 1.45 1.62 1.55 1.70 2.46 10</span>
|
||||
</pre></div>
|
||||
<span class="co"># A 1.68 1.91 2.13 2.08 2.43 2.62 10</span>
|
||||
<span class="co"># B 1.89 1.99 2.16 2.05 2.30 2.69 10</span>
|
||||
<span class="co"># C 1.87 1.91 2.09 2.00 2.28 2.46 10</span>
|
||||
<span class="co"># D 1.65 1.71 1.92 1.87 1.98 2.58 10</span>
|
||||
<span class="co"># E 1.64 1.74 1.90 1.87 1.98 2.34 10</span>
|
||||
<span class="co"># F 1.86 1.92 2.05 2.05 2.16 2.27 10</span>
|
||||
<span class="co"># G 1.73 1.80 1.99 1.97 2.14 2.29 10</span>
|
||||
<span class="co"># H 1.85 1.93 2.08 1.98 2.15 2.93 10</span></pre></div>
|
||||
<p>Of course, when running <code><a href="../reference/mo_property.html">mo_phylum("Firmicutes")</a></code> the function has zero knowledge about the actual microorganism, namely <em>S. aureus</em>. But since the result would be <code>"Firmicutes"</code> anyway, there is no point in calculating the result. And because this package ‘knows’ all phyla of all known bacteria (according to the Catalogue of Life), it can just return the initial value immediately.</p>
|
||||
</div>
|
||||
<div id="results-in-other-languages" class="section level3">
|
||||
@@ -392,34 +331,33 @@
|
||||
<a href="#results-in-other-languages" class="anchor"></a>Results in other languages</h3>
|
||||
<p>When the system language is non-English and supported by this <code>AMR</code> package, some functions will have a translated result. This almost does’t take extra time:</p>
|
||||
<div class="sourceCode" id="cb6"><pre class="downlit">
|
||||
<span class="fu"><a href="../reference/mo_property.html">mo_name</a></span>(<span class="st">"CoNS"</span>, language = <span class="st">"en"</span>) <span class="co"># or just mo_name("CoNS") on an English system</span>
|
||||
<span class="fu"><a href="../reference/mo_property.html">mo_name</a></span><span class="op">(</span><span class="st">"CoNS"</span>, language <span class="op">=</span> <span class="st">"en"</span><span class="op">)</span> <span class="co"># or just mo_name("CoNS") on an English system</span>
|
||||
<span class="co"># [1] "Coagulase-negative Staphylococcus (CoNS)"</span>
|
||||
|
||||
<span class="fu"><a href="../reference/mo_property.html">mo_name</a></span>(<span class="st">"CoNS"</span>, language = <span class="st">"es"</span>) <span class="co"># or just mo_name("CoNS") on a Spanish system</span>
|
||||
<span class="fu"><a href="../reference/mo_property.html">mo_name</a></span><span class="op">(</span><span class="st">"CoNS"</span>, language <span class="op">=</span> <span class="st">"es"</span><span class="op">)</span> <span class="co"># or just mo_name("CoNS") on a Spanish system</span>
|
||||
<span class="co"># [1] "Staphylococcus coagulasa negativo (SCN)"</span>
|
||||
|
||||
<span class="fu"><a href="../reference/mo_property.html">mo_name</a></span>(<span class="st">"CoNS"</span>, language = <span class="st">"nl"</span>) <span class="co"># or just mo_name("CoNS") on a Dutch system</span>
|
||||
<span class="fu"><a href="../reference/mo_property.html">mo_name</a></span><span class="op">(</span><span class="st">"CoNS"</span>, language <span class="op">=</span> <span class="st">"nl"</span><span class="op">)</span> <span class="co"># or just mo_name("CoNS") on a Dutch system</span>
|
||||
<span class="co"># [1] "Coagulase-negatieve Staphylococcus (CNS)"</span>
|
||||
|
||||
<span class="kw">run_it</span> <span class="op"><-</span> <span class="fu">microbenchmark</span>(en = <span class="fu"><a href="../reference/mo_property.html">mo_name</a></span>(<span class="st">"CoNS"</span>, language = <span class="st">"en"</span>),
|
||||
de = <span class="fu"><a href="../reference/mo_property.html">mo_name</a></span>(<span class="st">"CoNS"</span>, language = <span class="st">"de"</span>),
|
||||
nl = <span class="fu"><a href="../reference/mo_property.html">mo_name</a></span>(<span class="st">"CoNS"</span>, language = <span class="st">"nl"</span>),
|
||||
es = <span class="fu"><a href="../reference/mo_property.html">mo_name</a></span>(<span class="st">"CoNS"</span>, language = <span class="st">"es"</span>),
|
||||
it = <span class="fu"><a href="../reference/mo_property.html">mo_name</a></span>(<span class="st">"CoNS"</span>, language = <span class="st">"it"</span>),
|
||||
fr = <span class="fu"><a href="../reference/mo_property.html">mo_name</a></span>(<span class="st">"CoNS"</span>, language = <span class="st">"fr"</span>),
|
||||
pt = <span class="fu"><a href="../reference/mo_property.html">mo_name</a></span>(<span class="st">"CoNS"</span>, language = <span class="st">"pt"</span>),
|
||||
times = <span class="fl">100</span>)
|
||||
<span class="fu"><a href="https://docs.ropensci.org/skimr/reference/print.html">print</a></span>(<span class="kw">run_it</span>, unit = <span class="st">"ms"</span>, signif = <span class="fl">4</span>)
|
||||
<span class="va">run_it</span> <span class="op"><-</span> <span class="fu">microbenchmark</span><span class="op">(</span>en <span class="op">=</span> <span class="fu"><a href="../reference/mo_property.html">mo_name</a></span><span class="op">(</span><span class="st">"CoNS"</span>, language <span class="op">=</span> <span class="st">"en"</span><span class="op">)</span>,
|
||||
de <span class="op">=</span> <span class="fu"><a href="../reference/mo_property.html">mo_name</a></span><span class="op">(</span><span class="st">"CoNS"</span>, language <span class="op">=</span> <span class="st">"de"</span><span class="op">)</span>,
|
||||
nl <span class="op">=</span> <span class="fu"><a href="../reference/mo_property.html">mo_name</a></span><span class="op">(</span><span class="st">"CoNS"</span>, language <span class="op">=</span> <span class="st">"nl"</span><span class="op">)</span>,
|
||||
es <span class="op">=</span> <span class="fu"><a href="../reference/mo_property.html">mo_name</a></span><span class="op">(</span><span class="st">"CoNS"</span>, language <span class="op">=</span> <span class="st">"es"</span><span class="op">)</span>,
|
||||
it <span class="op">=</span> <span class="fu"><a href="../reference/mo_property.html">mo_name</a></span><span class="op">(</span><span class="st">"CoNS"</span>, language <span class="op">=</span> <span class="st">"it"</span><span class="op">)</span>,
|
||||
fr <span class="op">=</span> <span class="fu"><a href="../reference/mo_property.html">mo_name</a></span><span class="op">(</span><span class="st">"CoNS"</span>, language <span class="op">=</span> <span class="st">"fr"</span><span class="op">)</span>,
|
||||
pt <span class="op">=</span> <span class="fu"><a href="../reference/mo_property.html">mo_name</a></span><span class="op">(</span><span class="st">"CoNS"</span>, language <span class="op">=</span> <span class="st">"pt"</span><span class="op">)</span>,
|
||||
times <span class="op">=</span> <span class="fl">100</span><span class="op">)</span>
|
||||
<span class="fu"><a href="https://docs.ropensci.org/skimr/reference/print.html">print</a></span><span class="op">(</span><span class="va">run_it</span>, unit <span class="op">=</span> <span class="st">"ms"</span>, signif <span class="op">=</span> <span class="fl">4</span><span class="op">)</span>
|
||||
<span class="co"># Unit: milliseconds</span>
|
||||
<span class="co"># expr min lq mean median uq max neval</span>
|
||||
<span class="co"># en 14.00 14.36 18.52 14.64 15.18 57.58 100</span>
|
||||
<span class="co"># de 17.04 17.33 20.94 17.63 18.49 56.23 100</span>
|
||||
<span class="co"># nl 28.21 29.20 32.15 30.06 31.02 72.91 100</span>
|
||||
<span class="co"># es 16.85 17.26 19.83 17.44 17.95 152.20 100</span>
|
||||
<span class="co"># it 16.58 17.10 19.03 17.43 18.24 54.28 100</span>
|
||||
<span class="co"># fr 16.71 17.20 21.24 17.52 19.02 63.25 100</span>
|
||||
<span class="co"># pt 16.76 17.29 23.27 17.62 19.14 65.28 100</span>
|
||||
</pre></div>
|
||||
<span class="co"># expr min lq mean median uq max neval</span>
|
||||
<span class="co"># en 16.16 17.85 22.42 18.54 19.61 68.28 100</span>
|
||||
<span class="co"># de 19.55 21.38 24.37 21.96 22.95 61.55 100</span>
|
||||
<span class="co"># nl 31.64 35.08 40.58 36.34 37.88 79.00 100</span>
|
||||
<span class="co"># es 18.03 21.46 25.61 22.09 23.30 64.97 100</span>
|
||||
<span class="co"># it 17.82 21.01 23.29 21.80 22.82 58.47 100</span>
|
||||
<span class="co"># fr 18.19 21.29 25.63 21.93 23.20 60.48 100</span>
|
||||
<span class="co"># pt 17.76 21.07 24.81 21.83 23.39 65.00 100</span></pre></div>
|
||||
<p>Currently supported are German, Dutch, Spanish, Italian, French and Portuguese.</p>
|
||||
</div>
|
||||
</div>
|
||||
@@ -437,7 +375,7 @@
|
||||
</div>
|
||||
|
||||
<div class="pkgdown">
|
||||
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.9000.</p>
|
||||
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.6.1.</p>
|
||||
</div>
|
||||
|
||||
</footer>
|
||||
|
||||
@@ -0,0 +1,4 @@
|
||||
/* Styles for section anchors */
|
||||
a.anchor-section {margin-left: 10px; visibility: hidden; color: inherit;}
|
||||
a.anchor-section::before {content: '#';}
|
||||
.hasAnchor:hover a.anchor-section {visibility: visible;}
|
||||
@@ -0,0 +1,33 @@
|
||||
// Anchor sections v1.0 written by Atsushi Yasumoto on Oct 3rd, 2020.
|
||||
document.addEventListener('DOMContentLoaded', function() {
|
||||
// Do nothing if AnchorJS is used
|
||||
if (typeof window.anchors === 'object' && anchors.hasOwnProperty('hasAnchorJSLink')) {
|
||||
return;
|
||||
}
|
||||
|
||||
const h = document.querySelectorAll('h1, h2, h3, h4, h5, h6');
|
||||
|
||||
// Do nothing if sections are already anchored
|
||||
if (Array.from(h).some(x => x.classList.contains('hasAnchor'))) {
|
||||
return null;
|
||||
}
|
||||
|
||||
// Use section id when pandoc runs with --section-divs
|
||||
const section_id = function(x) {
|
||||
return ((x.classList.contains('section') || (x.tagName === 'SECTION'))
|
||||
? x.id : '');
|
||||
};
|
||||
|
||||
// Add anchors
|
||||
h.forEach(function(x) {
|
||||
const id = x.id || section_id(x.parentElement);
|
||||
if (id === '') {
|
||||
return null;
|
||||
}
|
||||
let anchor = document.createElement('a');
|
||||
anchor.href = '#' + id;
|
||||
anchor.classList = ['anchor-section'];
|
||||
x.classList.add('hasAnchor');
|
||||
x.appendChild(anchor);
|
||||
});
|
||||
});
|
||||
Binary file not shown.
|
Before Width: | Height: | Size: 88 KiB After Width: | Height: | Size: 70 KiB |
@@ -0,0 +1,12 @@
|
||||
// Pandoc 2.9 adds attributes on both header and div. We remove the former (to
|
||||
// be compatible with the behavior of Pandoc < 2.8).
|
||||
document.addEventListener('DOMContentLoaded', function(e) {
|
||||
var hs = document.querySelectorAll("div.section[class*='level'] > :first-child");
|
||||
var i, h, a;
|
||||
for (i = 0; i < hs.length; i++) {
|
||||
h = hs[i];
|
||||
if (!/^h[1-6]$/i.test(h.tagName)) continue; // it should be a header h1-h6
|
||||
a = h.attributes;
|
||||
while (a.length > 0) h.removeAttribute(a[0].name);
|
||||
}
|
||||
});
|
||||
+22
-22
@@ -39,7 +39,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<a class="navbar-link" href="../index.html">AMR (for R)</a>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9041</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
@@ -47,14 +47,14 @@
|
||||
<ul class="nav navbar-nav">
|
||||
<li>
|
||||
<a href="../index.html">
|
||||
<span class="fa fa-home"></span>
|
||||
<span class="fas fa-home"></span>
|
||||
|
||||
Home
|
||||
</a>
|
||||
</li>
|
||||
<li class="dropdown">
|
||||
<a href="#" class="dropdown-toggle" data-toggle="dropdown" role="button" aria-expanded="false">
|
||||
<span class="fa fa-question-circle"></span>
|
||||
<span class="fas fa-question-circle"></span>
|
||||
|
||||
How to
|
||||
|
||||
@@ -63,77 +63,77 @@
|
||||
<ul class="dropdown-menu" role="menu">
|
||||
<li>
|
||||
<a href="../articles/AMR.html">
|
||||
<span class="fa fa-directions"></span>
|
||||
<span class="fas fa-directions"></span>
|
||||
|
||||
Conduct AMR analysis
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../articles/resistance_predict.html">
|
||||
<span class="fa fa-dice"></span>
|
||||
<span class="fas fa-dice"></span>
|
||||
|
||||
Predict antimicrobial resistance
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../articles/datasets.html">
|
||||
<span class="fa fa-database"></span>
|
||||
<span class="fas fa-database"></span>
|
||||
|
||||
Data sets for download / own use
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../articles/PCA.html">
|
||||
<span class="fa fa-compress"></span>
|
||||
<span class="fas fa-compress"></span>
|
||||
|
||||
Conduct principal component analysis for AMR
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../articles/MDR.html">
|
||||
<span class="fa fa-skull-crossbones"></span>
|
||||
<span class="fas fa-skull-crossbones"></span>
|
||||
|
||||
Determine multi-drug resistance (MDR)
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../articles/WHONET.html">
|
||||
<span class="fa fa-globe-americas"></span>
|
||||
<span class="fas fa-globe-americas"></span>
|
||||
|
||||
Work with WHONET data
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../articles/SPSS.html">
|
||||
<span class="fa fa-file-upload"></span>
|
||||
<span class="fas fa-file-upload"></span>
|
||||
|
||||
Import data from SPSS/SAS/Stata
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../articles/EUCAST.html">
|
||||
<span class="fa fa-exchange-alt"></span>
|
||||
<span class="fas fa-exchange-alt"></span>
|
||||
|
||||
Apply EUCAST rules
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../reference/mo_property.html">
|
||||
<span class="fa fa-bug"></span>
|
||||
<span class="fas fa-bug"></span>
|
||||
|
||||
Get properties of a microorganism
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../reference/ab_property.html">
|
||||
<span class="fa fa-capsules"></span>
|
||||
<span class="fas fa-capsules"></span>
|
||||
|
||||
Get properties of an antibiotic
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../articles/benchmarks.html">
|
||||
<span class="fa fa-shipping-fast"></span>
|
||||
<span class="fas fa-shipping-fast"></span>
|
||||
|
||||
Other: benchmarks
|
||||
</a>
|
||||
@@ -142,21 +142,21 @@
|
||||
</li>
|
||||
<li>
|
||||
<a href="../reference/index.html">
|
||||
<span class="fa fa-book-open"></span>
|
||||
<span class="fas fa-book-open"></span>
|
||||
|
||||
Manual
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../authors.html">
|
||||
<span class="fa fa-users"></span>
|
||||
<span class="fas fa-users"></span>
|
||||
|
||||
Authors
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../news/index.html">
|
||||
<span class="far fa far fa-newspaper"></span>
|
||||
<span class="far fa-newspaper"></span>
|
||||
|
||||
Changelog
|
||||
</a>
|
||||
@@ -165,14 +165,14 @@
|
||||
<ul class="nav navbar-nav navbar-right">
|
||||
<li>
|
||||
<a href="https://github.com/msberends/AMR">
|
||||
<span class="fab fa fab fa-github"></span>
|
||||
<span class="fab fa-github"></span>
|
||||
|
||||
Source Code
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../survey.html">
|
||||
<span class="fa fa-clipboard-list"></span>
|
||||
<span class="fas fa-clipboard-list"></span>
|
||||
|
||||
Survey
|
||||
</a>
|
||||
@@ -187,7 +187,7 @@
|
||||
|
||||
|
||||
|
||||
</header><script src="datasets_files/header-attrs-2.3/header-attrs.js"></script><script src="datasets_files/accessible-code-block-0.0.1/empty-anchor.js"></script><div class="row">
|
||||
</header><script src="datasets_files/header-attrs-2.6/header-attrs.js"></script><div class="row">
|
||||
<div class="col-md-9 contents">
|
||||
<div class="page-header toc-ignore">
|
||||
<h1 data-toc-skip>Data sets for download / own use</h1>
|
||||
@@ -807,7 +807,7 @@ If you are reading this page from within R, please <a href="https://msberends.gi
|
||||
<div id="source-4" class="section level3">
|
||||
<h3 class="hasAnchor">
|
||||
<a href="#source-4" class="anchor"></a>Source</h3>
|
||||
<p>This data set contains all defined intrinsic resistance by EUCAST of all bug-drug combinations, and is based on ‘EUCAST Expert Rules / EUCAST Intrinsic Resistance and Unusual Phenotypes’, v3.2 from 2020.</p>
|
||||
<p>This data set contains all defined intrinsic resistance by EUCAST of all bug-drug combinations, and is based on ‘’EUCAST Expert Rules’ and ‘EUCAST Intrinsic Resistance and Unusual Phenotypes’’, v3.2 from 2020.</p>
|
||||
</div>
|
||||
<div id="example-content-4" class="section level3">
|
||||
<h3 class="hasAnchor">
|
||||
@@ -1146,7 +1146,7 @@ If you are reading this page from within R, please <a href="https://msberends.gi
|
||||
</div>
|
||||
|
||||
<div class="pkgdown">
|
||||
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.9000.</p>
|
||||
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.6.1.</p>
|
||||
</div>
|
||||
|
||||
</footer>
|
||||
|
||||
@@ -0,0 +1,12 @@
|
||||
// Pandoc 2.9 adds attributes on both header and div. We remove the former (to
|
||||
// be compatible with the behavior of Pandoc < 2.8).
|
||||
document.addEventListener('DOMContentLoaded', function(e) {
|
||||
var hs = document.querySelectorAll("div.section[class*='level'] > :first-child");
|
||||
var i, h, a;
|
||||
for (i = 0; i < hs.length; i++) {
|
||||
h = hs[i];
|
||||
if (!/^h[1-6]$/i.test(h.tagName)) continue; // it should be a header h1-h6
|
||||
a = h.attributes;
|
||||
while (a.length > 0) h.removeAttribute(a[0].name);
|
||||
}
|
||||
});
|
||||
@@ -0,0 +1,12 @@
|
||||
// Pandoc 2.9 adds attributes on both header and div. We remove the former (to
|
||||
// be compatible with the behavior of Pandoc < 2.8).
|
||||
document.addEventListener('DOMContentLoaded', function(e) {
|
||||
var hs = document.querySelectorAll("div.section[class*='level'] > :first-child");
|
||||
var i, h, a;
|
||||
for (i = 0; i < hs.length; i++) {
|
||||
h = hs[i];
|
||||
if (!/^h[1-6]$/i.test(h.tagName)) continue; // it should be a header h1-h6
|
||||
a = h.attributes;
|
||||
while (a.length > 0) h.removeAttribute(a[0].name);
|
||||
}
|
||||
});
|
||||
+20
-20
@@ -81,7 +81,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<a class="navbar-link" href="../index.html">AMR (for R)</a>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9041</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
@@ -89,14 +89,14 @@
|
||||
<ul class="nav navbar-nav">
|
||||
<li>
|
||||
<a href="../index.html">
|
||||
<span class="fa fa-home"></span>
|
||||
<span class="fas fa-home"></span>
|
||||
|
||||
Home
|
||||
</a>
|
||||
</li>
|
||||
<li class="dropdown">
|
||||
<a href="#" class="dropdown-toggle" data-toggle="dropdown" role="button" aria-expanded="false">
|
||||
<span class="fa fa-question-circle"></span>
|
||||
<span class="fas fa-question-circle"></span>
|
||||
|
||||
How to
|
||||
|
||||
@@ -105,77 +105,77 @@
|
||||
<ul class="dropdown-menu" role="menu">
|
||||
<li>
|
||||
<a href="../articles/AMR.html">
|
||||
<span class="fa fa-directions"></span>
|
||||
<span class="fas fa-directions"></span>
|
||||
|
||||
Conduct AMR analysis
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../articles/resistance_predict.html">
|
||||
<span class="fa fa-dice"></span>
|
||||
<span class="fas fa-dice"></span>
|
||||
|
||||
Predict antimicrobial resistance
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../articles/datasets.html">
|
||||
<span class="fa fa-database"></span>
|
||||
<span class="fas fa-database"></span>
|
||||
|
||||
Data sets for download / own use
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../articles/PCA.html">
|
||||
<span class="fa fa-compress"></span>
|
||||
<span class="fas fa-compress"></span>
|
||||
|
||||
Conduct principal component analysis for AMR
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../articles/MDR.html">
|
||||
<span class="fa fa-skull-crossbones"></span>
|
||||
<span class="fas fa-skull-crossbones"></span>
|
||||
|
||||
Determine multi-drug resistance (MDR)
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../articles/WHONET.html">
|
||||
<span class="fa fa-globe-americas"></span>
|
||||
<span class="fas fa-globe-americas"></span>
|
||||
|
||||
Work with WHONET data
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../articles/SPSS.html">
|
||||
<span class="fa fa-file-upload"></span>
|
||||
<span class="fas fa-file-upload"></span>
|
||||
|
||||
Import data from SPSS/SAS/Stata
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../articles/EUCAST.html">
|
||||
<span class="fa fa-exchange-alt"></span>
|
||||
<span class="fas fa-exchange-alt"></span>
|
||||
|
||||
Apply EUCAST rules
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../reference/mo_property.html">
|
||||
<span class="fa fa-bug"></span>
|
||||
<span class="fas fa-bug"></span>
|
||||
|
||||
Get properties of a microorganism
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../reference/ab_property.html">
|
||||
<span class="fa fa-capsules"></span>
|
||||
<span class="fas fa-capsules"></span>
|
||||
|
||||
Get properties of an antibiotic
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../articles/benchmarks.html">
|
||||
<span class="fa fa-shipping-fast"></span>
|
||||
<span class="fas fa-shipping-fast"></span>
|
||||
|
||||
Other: benchmarks
|
||||
</a>
|
||||
@@ -184,21 +184,21 @@
|
||||
</li>
|
||||
<li>
|
||||
<a href="../reference/index.html">
|
||||
<span class="fa fa-book-open"></span>
|
||||
<span class="fas fa-book-open"></span>
|
||||
|
||||
Manual
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../authors.html">
|
||||
<span class="fa fa-users"></span>
|
||||
<span class="fas fa-users"></span>
|
||||
|
||||
Authors
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../news/index.html">
|
||||
<span class="far fa far fa-newspaper"></span>
|
||||
<span class="far fa-newspaper"></span>
|
||||
|
||||
Changelog
|
||||
</a>
|
||||
@@ -207,14 +207,14 @@
|
||||
<ul class="nav navbar-nav navbar-right">
|
||||
<li>
|
||||
<a href="https://github.com/msberends/AMR">
|
||||
<span class="fab fa fab fa-github"></span>
|
||||
<span class="fab fa-github"></span>
|
||||
|
||||
Source Code
|
||||
</a>
|
||||
</li>
|
||||
<li>
|
||||
<a href="../survey.html">
|
||||
<span class="fa fa-clipboard-list"></span>
|
||||
<span class="fas fa-clipboard-list"></span>
|
||||
|
||||
Survey
|
||||
</a>
|
||||
@@ -272,7 +272,7 @@
|
||||
</div>
|
||||
|
||||
<div class="pkgdown">
|
||||
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.9000.</p>
|
||||
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.6.1.</p>
|
||||
</div>
|
||||
|
||||
</footer>
|
||||
|
||||
@@ -39,7 +39,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<a class="navbar-link" href="../index.html">AMR (for R)</a>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9032</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
@@ -187,7 +187,7 @@
|
||||
|
||||
|
||||
|
||||
</header><script src="resistance_predict_files/header-attrs-2.3/header-attrs.js"></script><script src="resistance_predict_files/accessible-code-block-0.0.1/empty-anchor.js"></script><div class="row">
|
||||
</header><script src="resistance_predict_files/header-attrs-2.4/header-attrs.js"></script><script src="resistance_predict_files/accessible-code-block-0.0.1/empty-anchor.js"></script><div class="row">
|
||||
<div class="col-md-9 contents">
|
||||
<div class="page-header toc-ignore">
|
||||
<h1 data-toc-skip>How to predict antimicrobial resistance</h1>
|
||||
@@ -206,13 +206,12 @@
|
||||
<p>As with many uses in R, we need some additional packages for AMR analysis. Our package works closely together with the <a href="https://www.tidyverse.org">tidyverse packages</a> <a href="https://dplyr.tidyverse.org/"><code>dplyr</code></a> and <a href="https://ggplot2.tidyverse.org"><code>ggplot2</code></a> by Dr Hadley Wickham. The tidyverse tremendously improves the way we conduct data science - it allows for a very natural way of writing syntaxes and creating beautiful plots in R.</p>
|
||||
<p>Our <code>AMR</code> package depends on these packages and even extends their use and functions.</p>
|
||||
<div class="sourceCode" id="cb1"><pre class="downlit">
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/library.html">library</a></span>(<span class="kw"><a href="https://dplyr.tidyverse.org">dplyr</a></span>)
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/library.html">library</a></span>(<span class="kw"><a href="http://ggplot2.tidyverse.org">ggplot2</a></span>)
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/library.html">library</a></span>(<span class="kw"><a href="https://msberends.github.io/AMR">AMR</a></span>)
|
||||
<span class="kw"><a href="https://rdrr.io/r/base/library.html">library</a></span><span class="op">(</span><span class="va"><a href="https://dplyr.tidyverse.org">dplyr</a></span><span class="op">)</span>
|
||||
<span class="kw"><a href="https://rdrr.io/r/base/library.html">library</a></span><span class="op">(</span><span class="va"><a href="http://ggplot2.tidyverse.org">ggplot2</a></span><span class="op">)</span>
|
||||
<span class="kw"><a href="https://rdrr.io/r/base/library.html">library</a></span><span class="op">(</span><span class="va"><a href="https://msberends.github.io/AMR/">AMR</a></span><span class="op">)</span>
|
||||
|
||||
<span class="co"># (if not yet installed, install with:)</span>
|
||||
<span class="co"># install.packages(c("tidyverse", "AMR"))</span>
|
||||
</pre></div>
|
||||
<span class="co"># install.packages(c("tidyverse", "AMR"))</span></pre></div>
|
||||
</div>
|
||||
<div id="prediction-analysis" class="section level2">
|
||||
<h2 class="hasAnchor">
|
||||
@@ -233,10 +232,10 @@
|
||||
<span id="cb2-12"><a href="#cb2-12"></a> <span class="dt">model =</span> <span class="st">"binomial"</span>)</span></code></pre></div>
|
||||
<p>The function will look for a date column itself if <code>col_date</code> is not set.</p>
|
||||
<p>When running any of these commands, a summary of the regression model will be printed unless using <code><a href="../reference/resistance_predict.html">resistance_predict(..., info = FALSE)</a></code>.</p>
|
||||
<pre><code># NOTE: Using column `date` as input for `col_date`.</code></pre>
|
||||
<pre><code># NOTE: Using column 'date' as input for `col_date`.</code></pre>
|
||||
<p>This text is only a printed summary - the actual result (output) of the function is a <code>data.frame</code> containing for each year: the number of observations, the actual observed resistance, the estimated resistance and the standard error below and above the estimation:</p>
|
||||
<div class="sourceCode" id="cb4"><pre class="downlit">
|
||||
<span class="kw">predict_TZP</span>
|
||||
<span class="va">predict_TZP</span>
|
||||
<span class="co"># year value se_min se_max observations observed estimated</span>
|
||||
<span class="co"># 1 2002 0.20000000 NA NA 15 0.20000000 0.05616378</span>
|
||||
<span class="co"># 2 2003 0.06250000 NA NA 32 0.06250000 0.06163839</span>
|
||||
@@ -266,36 +265,31 @@
|
||||
<span class="co"># 26 2027 0.41315710 0.3244399 0.5018743 NA NA 0.41315710</span>
|
||||
<span class="co"># 27 2028 0.43730688 0.3418075 0.5328063 NA NA 0.43730688</span>
|
||||
<span class="co"># 28 2029 0.46175755 0.3597639 0.5637512 NA NA 0.46175755</span>
|
||||
<span class="co"># 29 2030 0.48639359 0.3782932 0.5944939 NA NA 0.48639359</span>
|
||||
</pre></div>
|
||||
<span class="co"># 29 2030 0.48639359 0.3782932 0.5944939 NA NA 0.48639359</span></pre></div>
|
||||
<p>The function <code>plot</code> is available in base R, and can be extended by other packages to depend the output based on the type of input. We extended its function to cope with resistance predictions:</p>
|
||||
<div class="sourceCode" id="cb5"><pre class="downlit">
|
||||
<span class="fu"><a href="../reference/plot.html">plot</a></span>(<span class="kw">predict_TZP</span>)
|
||||
</pre></div>
|
||||
<span class="fu"><a href="../reference/plot.html">plot</a></span><span class="op">(</span><span class="va">predict_TZP</span><span class="op">)</span></pre></div>
|
||||
<p><img src="resistance_predict_files/figure-html/unnamed-chunk-4-1.png" width="720"></p>
|
||||
<p>This is the fastest way to plot the result. It automatically adds the right axes, error bars, titles, number of available observations and type of model.</p>
|
||||
<p>We also support the <code>ggplot2</code> package with our custom function <code><a href="../reference/resistance_predict.html">ggplot_rsi_predict()</a></code> to create more appealing plots:</p>
|
||||
<div class="sourceCode" id="cb6"><pre class="downlit">
|
||||
<span class="fu"><a href="../reference/resistance_predict.html">ggplot_rsi_predict</a></span>(<span class="kw">predict_TZP</span>)
|
||||
</pre></div>
|
||||
<span class="fu"><a href="../reference/resistance_predict.html">ggplot_rsi_predict</a></span><span class="op">(</span><span class="va">predict_TZP</span><span class="op">)</span></pre></div>
|
||||
<p><img src="resistance_predict_files/figure-html/unnamed-chunk-5-1.png" width="720"></p>
|
||||
<div class="sourceCode" id="cb7"><pre class="downlit">
|
||||
|
||||
<span class="co"># choose for error bars instead of a ribbon</span>
|
||||
<span class="fu"><a href="../reference/resistance_predict.html">ggplot_rsi_predict</a></span>(<span class="kw">predict_TZP</span>, ribbon = <span class="fl">FALSE</span>)
|
||||
</pre></div>
|
||||
<span class="fu"><a href="../reference/resistance_predict.html">ggplot_rsi_predict</a></span><span class="op">(</span><span class="va">predict_TZP</span>, ribbon <span class="op">=</span> <span class="cn">FALSE</span><span class="op">)</span></pre></div>
|
||||
<p><img src="resistance_predict_files/figure-html/unnamed-chunk-5-2.png" width="720"></p>
|
||||
<div id="choosing-the-right-model" class="section level3">
|
||||
<h3 class="hasAnchor">
|
||||
<a href="#choosing-the-right-model" class="anchor"></a>Choosing the right model</h3>
|
||||
<p>Resistance is not easily predicted; if we look at vancomycin resistance in Gram-positive bacteria, the spread (i.e. standard error) is enormous:</p>
|
||||
<div class="sourceCode" id="cb8"><pre class="downlit">
|
||||
<span class="kw">example_isolates</span> <span class="op">%>%</span>
|
||||
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/filter.html">filter</a></span>(<span class="fu"><a href="../reference/mo_property.html">mo_gramstain</a></span>(<span class="kw">mo</span>, language = <span class="kw">NULL</span>) <span class="op">==</span> <span class="st">"Gram-positive"</span>) <span class="op">%>%</span>
|
||||
<span class="fu"><a href="../reference/resistance_predict.html">resistance_predict</a></span>(col_ab = <span class="st">"VAN"</span>, year_min = <span class="fl">2010</span>, info = <span class="fl">FALSE</span>, model = <span class="st">"binomial"</span>) <span class="op">%>%</span>
|
||||
<span class="fu"><a href="../reference/resistance_predict.html">ggplot_rsi_predict</a></span>()
|
||||
<span class="co"># NOTE: Using column `date` as input for `col_date`.</span>
|
||||
</pre></div>
|
||||
<span class="va">example_isolates</span> <span class="op">%>%</span>
|
||||
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/filter.html">filter</a></span><span class="op">(</span><span class="fu"><a href="../reference/mo_property.html">mo_gramstain</a></span><span class="op">(</span><span class="va">mo</span>, language <span class="op">=</span> <span class="cn">NULL</span><span class="op">)</span> <span class="op">==</span> <span class="st">"Gram-positive"</span><span class="op">)</span> <span class="op">%>%</span>
|
||||
<span class="fu"><a href="../reference/resistance_predict.html">resistance_predict</a></span><span class="op">(</span>col_ab <span class="op">=</span> <span class="st">"VAN"</span>, year_min <span class="op">=</span> <span class="fl">2010</span>, info <span class="op">=</span> <span class="cn">FALSE</span>, model <span class="op">=</span> <span class="st">"binomial"</span><span class="op">)</span> <span class="op">%>%</span>
|
||||
<span class="fu"><a href="../reference/resistance_predict.html">ggplot_rsi_predict</a></span><span class="op">(</span><span class="op">)</span>
|
||||
<span class="co"># NOTE: Using column 'date' as input for `col_date`.</span></pre></div>
|
||||
<p><img src="resistance_predict_files/figure-html/unnamed-chunk-6-1.png" width="720"></p>
|
||||
<p>Vancomycin resistance could be 100% in ten years, but might also stay around 0%.</p>
|
||||
<p>You can define the model with the <code>model</code> parameter. The model chosen above is a generalised linear regression model using a binomial distribution, assuming that a period of zero resistance was followed by a period of increasing resistance leading slowly to more and more resistance.</p>
|
||||
@@ -337,28 +331,26 @@
|
||||
</table>
|
||||
<p>For the vancomycin resistance in Gram-positive bacteria, a linear model might be more appropriate since no binomial distribution is to be expected based on the observed years:</p>
|
||||
<div class="sourceCode" id="cb9"><pre class="downlit">
|
||||
<span class="kw">example_isolates</span> <span class="op">%>%</span>
|
||||
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/filter.html">filter</a></span>(<span class="fu"><a href="../reference/mo_property.html">mo_gramstain</a></span>(<span class="kw">mo</span>, language = <span class="kw">NULL</span>) <span class="op">==</span> <span class="st">"Gram-positive"</span>) <span class="op">%>%</span>
|
||||
<span class="fu"><a href="../reference/resistance_predict.html">resistance_predict</a></span>(col_ab = <span class="st">"VAN"</span>, year_min = <span class="fl">2010</span>, info = <span class="fl">FALSE</span>, model = <span class="st">"linear"</span>) <span class="op">%>%</span>
|
||||
<span class="fu"><a href="../reference/resistance_predict.html">ggplot_rsi_predict</a></span>()
|
||||
<span class="co"># NOTE: Using column `date` as input for `col_date`.</span>
|
||||
</pre></div>
|
||||
<span class="va">example_isolates</span> <span class="op">%>%</span>
|
||||
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/filter.html">filter</a></span><span class="op">(</span><span class="fu"><a href="../reference/mo_property.html">mo_gramstain</a></span><span class="op">(</span><span class="va">mo</span>, language <span class="op">=</span> <span class="cn">NULL</span><span class="op">)</span> <span class="op">==</span> <span class="st">"Gram-positive"</span><span class="op">)</span> <span class="op">%>%</span>
|
||||
<span class="fu"><a href="../reference/resistance_predict.html">resistance_predict</a></span><span class="op">(</span>col_ab <span class="op">=</span> <span class="st">"VAN"</span>, year_min <span class="op">=</span> <span class="fl">2010</span>, info <span class="op">=</span> <span class="cn">FALSE</span>, model <span class="op">=</span> <span class="st">"linear"</span><span class="op">)</span> <span class="op">%>%</span>
|
||||
<span class="fu"><a href="../reference/resistance_predict.html">ggplot_rsi_predict</a></span><span class="op">(</span><span class="op">)</span>
|
||||
<span class="co"># NOTE: Using column 'date' as input for `col_date`.</span></pre></div>
|
||||
<p><img src="resistance_predict_files/figure-html/unnamed-chunk-7-1.png" width="720"></p>
|
||||
<p>This seems more likely, doesn’t it?</p>
|
||||
<p>The model itself is also available from the object, as an <code>attribute</code>:</p>
|
||||
<div class="sourceCode" id="cb10"><pre class="downlit">
|
||||
<span class="kw">model</span> <span class="op"><-</span> <span class="fu"><a href="https://rdrr.io/r/base/attributes.html">attributes</a></span>(<span class="kw">predict_TZP</span>)<span class="op">$</span><span class="kw">model</span>
|
||||
<span class="va">model</span> <span class="op"><-</span> <span class="fu"><a href="https://rdrr.io/r/base/attributes.html">attributes</a></span><span class="op">(</span><span class="va">predict_TZP</span><span class="op">)</span><span class="op">$</span><span class="va">model</span>
|
||||
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/summary.html">summary</a></span>(<span class="kw">model</span>)<span class="op">$</span><span class="kw">family</span>
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/summary.html">summary</a></span><span class="op">(</span><span class="va">model</span><span class="op">)</span><span class="op">$</span><span class="va">family</span>
|
||||
<span class="co"># </span>
|
||||
<span class="co"># Family: binomial </span>
|
||||
<span class="co"># Link function: logit</span>
|
||||
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/summary.html">summary</a></span>(<span class="kw">model</span>)<span class="op">$</span><span class="kw">coefficients</span>
|
||||
<span class="fu"><a href="https://rdrr.io/r/base/summary.html">summary</a></span><span class="op">(</span><span class="va">model</span><span class="op">)</span><span class="op">$</span><span class="va">coefficients</span>
|
||||
<span class="co"># Estimate Std. Error z value Pr(>|z|)</span>
|
||||
<span class="co"># (Intercept) -200.67944891 46.17315349 -4.346237 1.384932e-05</span>
|
||||
<span class="co"># year 0.09883005 0.02295317 4.305725 1.664395e-05</span>
|
||||
</pre></div>
|
||||
<span class="co"># year 0.09883005 0.02295317 4.305725 1.664395e-05</span></pre></div>
|
||||
</div>
|
||||
</div>
|
||||
</div>
|
||||
@@ -378,7 +370,7 @@
|
||||
</div>
|
||||
|
||||
<div class="pkgdown">
|
||||
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.9000.</p>
|
||||
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.6.1.</p>
|
||||
</div>
|
||||
|
||||
</footer>
|
||||
|
||||
@@ -0,0 +1,4 @@
|
||||
/* Styles for section anchors */
|
||||
a.anchor-section {margin-left: 10px; visibility: hidden; color: inherit;}
|
||||
a.anchor-section::before {content: '#';}
|
||||
.hasAnchor:hover a.anchor-section {visibility: visible;}
|
||||
@@ -0,0 +1,33 @@
|
||||
// Anchor sections v1.0 written by Atsushi Yasumoto on Oct 3rd, 2020.
|
||||
document.addEventListener('DOMContentLoaded', function() {
|
||||
// Do nothing if AnchorJS is used
|
||||
if (typeof window.anchors === 'object' && anchors.hasOwnProperty('hasAnchorJSLink')) {
|
||||
return;
|
||||
}
|
||||
|
||||
const h = document.querySelectorAll('h1, h2, h3, h4, h5, h6');
|
||||
|
||||
// Do nothing if sections are already anchored
|
||||
if (Array.from(h).some(x => x.classList.contains('hasAnchor'))) {
|
||||
return null;
|
||||
}
|
||||
|
||||
// Use section id when pandoc runs with --section-divs
|
||||
const section_id = function(x) {
|
||||
return ((x.classList.contains('section') || (x.tagName === 'SECTION'))
|
||||
? x.id : '');
|
||||
};
|
||||
|
||||
// Add anchors
|
||||
h.forEach(function(x) {
|
||||
const id = x.id || section_id(x.parentElement);
|
||||
if (id === '') {
|
||||
return null;
|
||||
}
|
||||
let anchor = document.createElement('a');
|
||||
anchor.href = '#' + id;
|
||||
anchor.classList = ['anchor-section'];
|
||||
x.classList.add('hasAnchor');
|
||||
x.appendChild(anchor);
|
||||
});
|
||||
});
|
||||
Binary file not shown.
|
Before Width: | Height: | Size: 97 KiB After Width: | Height: | Size: 48 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 94 KiB After Width: | Height: | Size: 70 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 92 KiB After Width: | Height: | Size: 68 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 95 KiB After Width: | Height: | Size: 71 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 88 KiB After Width: | Height: | Size: 64 KiB |
Loaded 100 of 231 files, more files were not shown because too many files have changed in this diff.
Show more
Reference in new issue
Block a user