P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2026-07-29 08:40:55 +02:00
Code Releases Activity

(v1.1.0.9004) lose dependencies

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2020-05-16 13:05:47 +02:00
parent 9fce546901
commit 7f3da74b17
111 changed files with 3211 additions and 2345 deletions
Download Patch File Download Diff File Expand all files Collapse all files

23
.gitlab-ci.yml
View File

@@ -54,7 +54,9 @@ before_script:
- echo 'LANG="en_US.utf8"' >> .Renviron
- echo 'LANGUAGE="en_US.utf8"' > ~/.Renviron
R-release-test-only:
# ---- TEST
R-release:
stage: test
when: always
allow_failure: false
@@ -68,6 +70,23 @@ R-release-test-only:
paths:
- installed_deps/
R-devel:
stage: test
when: always
image: rocker/r-devel
allow_failure: false
script:
- Rscriptdevel -e 'sessionInfo()'
# install missing and outdated packages
- Rscriptdevel -e 'source(".gitlab-ci.R"); gl_update_pkg_all(repos = "https://cran.rstudio.com", quiet = TRUE, install_pkgdown = TRUE, install_lintr = TRUE)'
- Rscriptdevel -e 'devtools::test(stop_on_failure = FALSE)'
cache:
key: devel
paths:
- installed_deps/
# ---- CHECK
R-release:
stage: check
when: on_success
@@ -120,6 +139,8 @@ R-devel:
key: devel
paths:
- installed_deps/
# ---- OTHER
lintr:
stage: lint

32
DESCRIPTION
View File

@@ -1,6 +1,6 @@
Package: AMR
Version: 1.1.0.9003
Date: 2020-05-01
Version: 1.1.0.9004
Date: 2020-05-16
Title: Antimicrobial Resistance Analysis
Authors@R: c(
person(role = c("aut", "cre"),
@@ -36,30 +36,24 @@ Description: Functions to simplify the analysis and prediction of Antimicrobial
Standards Institute (2014) <isbn: 1-56238-899-1>.
Depends:
R (>= 3.1.0)
Enhances:
ggplot2
Imports:
backports,
cleaner,
crayon (>= 1.3.0),
data.table (>= 1.9.0),
dplyr (>= 0.7.0),
ggplot2,
knitr (>= 1.0.0),
microbenchmark,
pillar,
R6,
rlang (>= 0.3.1),
tidyr (>= 1.0.0),
vctrs (>= 0.2.4)
vctrs
Suggests:
covr (>= 3.0.1),
curl,
readxl,
covr,
dplyr,
knitr,
microbenchmark,
rmarkdown,
rstudioapi,
rvest (>= 0.3.2),
testthat (>= 1.0.2),
xml2 (>= 1.0.0)
VignetteBuilder: knitr
rvest,
testthat,
utils
VignetteBuilder: knitr,rmarkdown
URL: https://msberends.gitlab.io/AMR, https://gitlab.com/msberends/AMR
BugReports: https://gitlab.com/msberends/AMR/issues
License: GPL-2 | file LICENSE

77
NAMESPACE
View File

@@ -66,11 +66,11 @@ S3method(skewness,matrix)
S3method(summary,mic)
S3method(summary,mo)
S3method(summary,rsi)
S3method(vec_cast,character.ab)
S3method(vec_cast,character.mo)
S3method(vec_cast.ab,ab)
S3method(vec_cast.ab,character)
S3method(vec_cast.ab,default)
S3method(vec_cast.character,ab)
S3method(vec_cast.character,mo)
S3method(vec_cast.mo,character)
S3method(vec_cast.mo,default)
S3method(vec_cast.mo,mo)
@@ -201,7 +201,6 @@ export(mo_url)
export(mo_year)
export(mrgn)
export(n_rsi)
export(p.symbol)
export(p_symbol)
export(pca)
export(portion_I)
@@ -297,6 +296,8 @@ exportMethods(summary.mo)
exportMethods(summary.rsi)
exportMethods(vec_cast.character.ab)
exportMethods(vec_cast.character.mo)
exportMethods(vec_ptype2.character.ab)
exportMethods(vec_ptype2.character.mo)
exportMethods(vec_ptype_abbr.ab)
exportMethods(vec_ptype_abbr.disk)
exportMethods(vec_ptype_abbr.mic)
@@ -307,69 +308,8 @@ exportMethods(vec_ptype_full.disk)
exportMethods(vec_ptype_full.mic)
exportMethods(vec_ptype_full.mo)
exportMethods(vec_ptype_full.rsi)
importFrom(R6,R6Class)
importFrom(cleaner,freq)
importFrom(cleaner,freq.default)
importFrom(cleaner,percentage)
importFrom(cleaner,top_freq)
importFrom(crayon,bgGreen)
importFrom(crayon,bgRed)
importFrom(crayon,bgYellow)
importFrom(crayon,black)
importFrom(crayon,blue)
importFrom(crayon,bold)
importFrom(crayon,green)
importFrom(crayon,italic)
importFrom(crayon,magenta)
importFrom(crayon,make_style)
importFrom(crayon,red)
importFrom(crayon,silver)
importFrom(crayon,strip_style)
importFrom(crayon,underline)
importFrom(crayon,white)
importFrom(crayon,yellow)
importFrom(data.table,as.data.table)
importFrom(data.table,data.table)
importFrom(data.table,setkey)
importFrom(dplyr,"%>%")
importFrom(dplyr,all_vars)
importFrom(dplyr,any_vars)
importFrom(dplyr,arrange)
importFrom(dplyr,arrange_at)
importFrom(dplyr,between)
importFrom(dplyr,bind_rows)
importFrom(dplyr,case_when)
importFrom(dplyr,desc)
importFrom(dplyr,distinct)
importFrom(dplyr,everything)
importFrom(dplyr,filter)
importFrom(dplyr,filter_all)
importFrom(dplyr,filter_at)
importFrom(dplyr,funs)
importFrom(dplyr,group_by)
importFrom(dplyr,group_by_at)
importFrom(dplyr,group_vars)
importFrom(dplyr,if_else)
importFrom(dplyr,lag)
importFrom(dplyr,left_join)
importFrom(dplyr,mutate)
importFrom(dplyr,mutate_all)
importFrom(dplyr,mutate_at)
importFrom(dplyr,n)
importFrom(dplyr,n_distinct)
importFrom(dplyr,n_groups)
importFrom(dplyr,pull)
importFrom(dplyr,rename)
importFrom(dplyr,row_number)
importFrom(dplyr,select)
importFrom(dplyr,select_if)
importFrom(dplyr,slice)
importFrom(dplyr,summarise)
importFrom(dplyr,summarise_if)
importFrom(dplyr,tibble)
importFrom(dplyr,transmute)
importFrom(dplyr,ungroup)
importFrom(dplyr,vars)
importFrom(graphics,arrows)
importFrom(graphics,axis)
importFrom(graphics,barplot)
@@ -377,12 +317,7 @@ importFrom(graphics,par)
importFrom(graphics,plot)
importFrom(graphics,points)
importFrom(graphics,text)
importFrom(knitr,kable)
importFrom(microbenchmark,microbenchmark)
importFrom(pillar,pillar_shaft)
importFrom(rlang,as_label)
importFrom(rlang,enquos)
importFrom(rlang,eval_tidy)
importFrom(stats,complete.cases)
importFrom(stats,glm)
importFrom(stats,lm)
@@ -393,10 +328,8 @@ importFrom(stats,qchisq)
importFrom(stats,var)
importFrom(tidyr,pivot_longer)
importFrom(tidyr,pivot_wider)
importFrom(utils,adist)
importFrom(utils,browseURL)
importFrom(utils,menu)
importFrom(vctrs,vec_cast)
importFrom(vctrs,vec_cast.character)
importFrom(vctrs,vec_default_cast)
importFrom(vctrs,vec_ptype2.character)
importFrom(vctrs,vec_ptype_abbr)

14
NEWS.md
View File

@@ -1,10 +1,18 @@
# AMR 1.1.0.9003
## <small>Last updated: 01-May-2020</small>
# AMR 1.1.0.9004
## <small>Last updated: 16-May-2020</small>
### Breaking
* Removed previously deprecated function `p.symbol()` - it was replaced with `p_symbol()`
### Changed
* Small fix for some text input that could not be coerced as valid MIC values
* Better support for the tidyverse. The tidyverse now heavily relies on the `vctrs` package for data transformation and data joining. In newer versions of e.g. the `dplyr` package, a function like `bind_rows()` would not preserve the right class for microorganisms (class `mo`) and antibiotics (class `ab`). This is fixed in this version.
* Fix for cases where some functions of newer versions of the `dplyr` package (such as `bind_rows()`) would not preserve the right class for microorganisms (class `mo`) and antibiotics (class `ab`)
* Fixed interpretation of generic CLSI interpretation rules (thanks to Anthony Underwood)
* Added official drug names to verbose output of `eucast_rules()`
### Other
* Removed dependency on **all** packages that were needed for the `AMR` package to work properly: `crayon`, `data.table`, `dplyr`, `ggplot2`, `R6`, `rlang` and `tidyr`. This is a major code change, but will probably not be noticeable by users. Making this package independent on especially the tidyverse (packages `dplyr`, `ggplot2` and `tidyr`) tremendously increases sustainability on the long term, since tidyverse functions change quite often. Most of our functions are replaced with versions that only rely on base R, which keeps this package fully functional for many years to come, without requiring a lot of maintenance to keep up with other packages anymore. The only dependencies that remained are for extending methods of other packages, like `pillar` and `vctrs` for printing and working with tibbles using our classes `mo` and `ab`.
# AMR 1.1.0

253
R/aa_helper_functions.R
View File

@@ -19,6 +19,48 @@
# Visit our website for more info: https://msberends.gitlab.io/AMR. #
# ==================================================================== #
# functions from dplyr, will perhaps become poorman
distinct <- function(.data, ..., .keep_all = FALSE) {
check_is_dataframe(.data)
if ("grouped_data" %in% class(.data)) {
distinct.grouped_data(.data, ..., .keep_all = .keep_all)
} else {
distinct.default(.data, ..., .keep_all = .keep_all)
}
}
distinct.default <- function(.data, ..., .keep_all = FALSE) {
names <- rownames(.data)
rownames(.data) <- NULL
if (length(deparse_dots(...)) == 0) {
selected <- .data
} else {
selected <- select(.data, ...)
}
rows <- as.integer(rownames(unique(selected)))
if (isTRUE(.keep_all)) {
res <- .data[rows, , drop = FALSE]
} else {
res <- selected[rows, , drop = FALSE]
}
rownames(res) <- names[rows]
res
}
distinct.grouped_data <- function(.data, ..., .keep_all = FALSE) {
apply_grouped_function(.data, "distinct", ..., .keep_all = .keep_all)
}
filter_join_worker <- function(x, y, by = NULL, type = c("anti", "semi")) {
type <- match.arg(type, choices = c("anti", "semi"), several.ok = FALSE)
if (is.null(by)) {
by <- intersect(names(x), names(y))
join_message(by)
}
rows <- interaction(x[, by]) %in% interaction(y[, by])
if (type == "anti") rows <- !rows
res <- x[rows, , drop = FALSE]
rownames(res) <- NULL
res
}
# No export, no Rd
addin_insert_in <- function() {
rstudioapi::insertText(" %in% ")
@@ -36,7 +78,7 @@ check_dataset_integrity <- function() {
"species", "subspecies", "rank",
"col_id", "species_id", "source",
"ref", "prevalence", "snomed") %in% colnames(microorganisms),
na.rm = TRUE) & NROW(microorganisms) == NROW(microorganismsDT)
na.rm = TRUE) & NROW(microorganisms) == NROW(MO_lookup)
check_antibiotics <- all(c("ab", "atc", "cid", "name", "group",
"atc_group1", "atc_group2", "abbreviations",
"synonyms", "oral_ddd", "oral_units",
@@ -51,12 +93,11 @@ check_dataset_integrity <- function() {
invisible(TRUE)
}
#' @importFrom crayon blue bold red
#' @importFrom dplyr %>% pull
search_type_in_df <- function(x, type) {
# try to find columns based on type
found <- NULL
x <- as.data.frame(x, stringsAsFactors = FALSE)
colnames(x) <- trimws(colnames(x))
# -- mo
@@ -89,14 +130,14 @@ search_type_in_df <- function(x, type) {
if (any(colnames(x) %like% "^(specimen date|specimen_date|spec_date)")) {
# WHONET support
found <- colnames(x)[colnames(x) %like% "^(specimen date|specimen_date|spec_date)"][1]
if (!any(class(x %>% pull(found)) %in% c("Date", "POSIXct"))) {
stop(red(paste0("ERROR: Found column `", bold(found), "` to be used as input for `col_", type,
if (!any(class(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,
"`, but this column contains no valid dates. Transform its values to valid dates first.")),
call. = FALSE)
}
} else {
for (i in seq_len(ncol(x))) {
if (any(class(x %>% pull(i)) %in% c("Date", "POSIXct"))) {
if (any(class(pull(x, i)) %in% c("Date", "POSIXct"))) {
found <- colnames(x)[i]
break
}
@@ -127,7 +168,7 @@ search_type_in_df <- function(x, type) {
if (!is.null(found)) {
# this column should contain logicals
if (!is.logical(x[, found, drop = TRUE])) {
message(red(paste0("NOTE: Column `", bold(found), "` found as input for `col_", type,
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.")))
found <- NULL
}
@@ -135,11 +176,11 @@ search_type_in_df <- function(x, type) {
}
if (!is.null(found)) {
msg <- paste0("NOTE: Using column `", bold(found), "` as input for `col_", type, "`.")
msg <- paste0("NOTE: Using column `", font_bold(found), "` as input for `col_", type, "`.")
if (type %in% c("keyantibiotics", "specimen")) {
msg <- paste(msg, "Use", bold(paste0("col_", type), "= FALSE"), "to prevent this.")
msg <- paste(msg, "Use", font_bold(paste0("col_", type), "= FALSE"), "to prevent this.")
}
message(blue(msg))
message(font_blue(msg))
}
found
}
@@ -147,10 +188,11 @@ search_type_in_df <- function(x, type) {
stopifnot_installed_package <- function(package) {
# no "utils::installed.packages()" since it requires non-staged install since R 3.6.0
# https://developer.r-project.org/Blog/public/2019/02/14/staged-install/index.html
tryCatch(get(".packageName", envir = asNamespace(package)),
error = function(e) stop("package '", package, "' required but not installed",
' - try to install it with: install.packages("', package, '")',
call. = FALSE))
sapply(package, function(x)
tryCatch(get(".packageName", envir = asNamespace(x)),
error = function(e) stop("package '", x, "' required but not installed.",
"\nTry to install it with: install.packages(\"", x, "\")",
call. = FALSE)))
return(invisible())
}
@@ -206,3 +248,184 @@ dataset_UTF8_to_ASCII <- function(df) {
}
df
}
# replace crayon::has_color
has_colour <- function() {
if (Sys.getenv("TERM") == "dumb") {
return(FALSE)
}
if (tolower(Sys.info()["sysname"]) == "windows") {
if (Sys.getenv("ConEmuANSI") == "ON" | Sys.getenv("CMDER_ROOT") != "") {
return(TRUE)
} else {
return(FALSE)
}
}
"COLORTERM" %in% names(Sys.getenv()) | grepl("^screen|^xterm|^vt100|color|ansi|cygwin|linux",
Sys.getenv("TERM"),
ignore.case = TRUE,
perl = TRUE)
}
# the crayon colours
try_colour <- function(..., before, after, collapse = " ") {
txt <- paste0(unlist(list(...)), collapse = collapse)
if (isTRUE(has_colour())) {
if (is.null(collapse)) {
paste0(before, txt, after, collapse = NULL)
} else {
paste0(before, txt, after, collapse = "")
}
} else {
txt
}
}
font_black <- function(..., collapse = " ") {
try_colour(..., before = "\033[38;5;232m", after = "\033[39m", collapse = collapse)
}
font_blue <- function(..., collapse = " ") {
try_colour(..., before = "\033[34m", after = "\033[39m", collapse = collapse)
}
font_green <- function(..., collapse = " ") {
try_colour(..., before = "\033[32m", after = "\033[39m", collapse = collapse)
}
font_magenta <- function(..., collapse = " ") {
try_colour(..., before = "\033[35m", after = "\033[39m", collapse = collapse)
}
font_red <- function(..., collapse = " ") {
try_colour(..., before = "\033[31m", after = "\033[39m", collapse = collapse)
}
font_silver <- function(..., collapse = " ") {
try_colour(..., before = "\033[90m", after = "\033[39m", collapse = collapse)
}
font_white <- function(..., collapse = " ") {
try_colour(..., before = "\033[37m", after = "\033[39m", collapse = collapse)
}
font_yellow <- function(..., collapse = " ") {
try_colour(..., before = "\033[33m", after = "\033[39m", collapse = collapse)
}
font_subtle <- function(..., collapse = " ") {
try_colour(..., before = "\033[38;5;246m", after = "\033[39m", collapse = collapse)
}
font_grey <- function(..., collapse = " ") {
try_colour(..., before = "\033[38;5;249m", after = "\033[39m", collapse = collapse)
}
font_green_bg <- function(..., collapse = " ") {
try_colour(..., before = "\033[42m", after = "\033[49m", collapse = collapse)
}
font_red_bg <- function(..., collapse = " ") {
try_colour(..., before = "\033[41m", after = "\033[49m", collapse = collapse)
}
font_yellow_bg <- function(..., collapse = " ") {
try_colour(..., before = "\033[43m", after = "\033[49m", collapse = collapse)
}
font_bold <- function(..., collapse = " ") {
try_colour(..., before = "\033[1m", after = "\033[22m", collapse = collapse)
}
font_italic <- function(..., collapse = " ") {
try_colour(..., before = "\033[3m", after = "\033[23m", collapse = collapse)
}
font_underline <- function(..., collapse = " ") {
try_colour(..., before = "\033[4m", after = "\033[24m", collapse = collapse)
}
font_stripstyle <- function(x) {
# from crayon:::ansi_regex
gsub("(?:(?:\\x{001b}\\[)|\\x{009b})(?:(?:[0-9]{1,3})?(?:(?:;[0-9]{0,3})*)?[A-M|f-m])|\\x{001b}[A-M]", "", x, perl = TRUE)
}
progress_estimated <- function(n = 1, n_min = 0, ...) {
# initiate with:
# progress <- progressbar(n)
# on.exit(close(progress))
#
# update with:
# progress$tick()
if (n >= n_min) {
pb <- utils::txtProgressBar(max = n, style = 3)
pb$tick <- function() {
pb$up(pb$getVal() + 1)
}
pb
} else {
pb <- list()
pb$tick <- function() {
invisible()
}
pb$kill <- function() {
invisible()
}
structure(pb, class = "txtProgressBar")
}
}
# works exactly like round(), but rounds `round(44.55, 1)` as 44.6 instead of 44.5
# and adds decimal zeroes until `digits` is reached when force_zero = TRUE
round2 <- function(x, digits = 0, force_zero = TRUE) {
x <- as.double(x)
# https://stackoverflow.com/a/12688836/4575331
val <- (trunc((abs(x) * 10 ^ digits) + 0.5) / 10 ^ digits) * sign(x)
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,
digits - nchar(
format(
as.double(
gsub(".*[.](.*)$",
"\\1",
values_trans)),
scientific = FALSE)))))
}
as.double(val)
}
# percentage from our other package: 'cleaner'
percentage <- function(x, digits = NULL, ...) {
# getdecimalplaces() function
getdecimalplaces <- function(x, minimum = 0, maximum = 3) {
if (maximum < minimum) {
maximum <- minimum
}
if (minimum > maximum) {
minimum <- maximum
}
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,
digits = digits,
nsmall = digits,
...)
x_formatted <- paste0(x_formatted, "%")
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)) {
# max one digit if undefined
digits <- getdecimalplaces(x, minimum = 0, maximum = 1)
}
format_percentage(structure(.Data = as.double(x),
class = c("percentage", "numeric")),
digits = digits, ...)
}

775
R/aa_helper_functions_dplyr.R Normal file
View File

@@ -0,0 +1,775 @@
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Analysis #
# #
# SOURCE #
# https://gitlab.com/msberends/AMR #
# #
# LICENCE #
# (c) 2018-2020 Berends MS, Luz CF et al. #
# #
# 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 more info: https://msberends.gitlab.io/AMR. #
# ==================================================================== #
# ------------------------------------------------
# THIS FILE WAS CREATED AUTOMATICALLY!
# Source file: data-raw/reproduction_of_poorman.R
# ------------------------------------------------
# Poorman: a package to replace all dplyr functions with base R so we can lose dependency on dplyr.
# These functions were downloaded from https://github.com/nathaneastwood/poorman,
# from this commit: https://github.com/nathaneastwood/poorman/tree/7d76d77f8f7bc663bf30fb5a161abb49801afa17
#
# All code below was released under MIT license, that permits 'free of charge, to any person obtaining a
# copy of the software and associated documentation files (the "Software"), to deal in the Software
# without restriction, including without limitation the rights to use, copy, modify, merge, publish,
# distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software
# is furnished to do so', given that a copyright notice is given in the software.
#
# Copyright notice as found on https://github.com/nathaneastwood/poorman/blob/master/LICENSE on 2 May 2020:
# YEAR: 2020
# COPYRIGHT HOLDER: Nathan Eastwood
arrange <- function(.data, ...) {
check_is_dataframe(.data)
if ("grouped_data" %in% class(.data)) {
arrange.grouped_data(.data, ...)
} else {
arrange.default(.data, ...)
}
}
arrange.default <- function(.data, ...) {
rows <- eval.parent(substitute(with(.data, order(...))))
.data[rows, , drop = FALSE]
}
arrange.grouped_data <- function(.data, ...) {
apply_grouped_function(.data, "arrange", ...)
}
between <- function(x, left, right) {
if (!is.null(attr(x, "class")) && !inherits(x, c("Date", "POSIXct"))) {
warning("`between()` called on numeric vector with S3 class")
}
if (!is.double(x)) x <- as.numeric(x)
x >= as.numeric(left) & x <= as.numeric(right)
}
count <- function(x, ..., wt = NULL, sort = FALSE, name = NULL) {
groups <- get_groups(x)
if (!missing(...)) x <- group_by(x, ..., .add = TRUE)
wt <- deparse_var(wt)
res <- do.call(tally, list(x, wt, sort, name))
if (length(groups) > 0L) res <- do.call(group_by, list(res, as.name(groups)))
res
}
tally <- function(x, wt = NULL, sort = FALSE, name = NULL) {
name <- check_name(x, name)
wt <- deparse_var(wt)
res <- do.call(summarise, set_names(list(x, as.name(tally_n(x, wt))), c(".data", name)))
res <- ungroup(res)
if (isTRUE(sort)) res <- do.call(arrange, list(res, call("desc", as.name(name))))
rownames(res) <- NULL
res
}
add_count <- function(x, ..., wt = NULL, sort = FALSE, name = NULL) {
name <- check_name(x, name)
row_names <- rownames(x)
wt <- deparse_var(wt)
if (!missing(...)) x <- group_by(x, ..., .add = TRUE)
res <- do.call(add_tally, list(x, wt, sort, name))
res[row_names, ]
}
add_tally <- function(x, wt = NULL, sort = FALSE, name = NULL) {
wt <- deparse_var(wt)
n <- tally_n(x, wt)
name <- check_name(x, name)
res <- do.call(mutate, set_names(list(x, as.name(n)), c(".data", name)))
if (isTRUE(sort)) {
do.call(arrange, list(res, call("desc", as.name(name))))
} else {
res
}
}
tally_n <- function(x, wt) {
if (is.null(wt) && "n" %in% colnames(x)) {
message("Using `n` as weighting variable")
wt <- "n"
}
context$.data <- x
on.exit(rm(list = ".data", envir = context))
if (is.null(wt)) {
"n()"
} else {
paste0("sum(", wt, ", na.rm = TRUE)")
}
}
check_name <- function(df, name) {
if (is.null(name)) {
if ("n" %in% colnames(df)) {
stop(
"Column 'n' is already present in output\n",
"* Use `name = \"new_name\"` to pick a new name"
)
}
return("n")
}
if (!is.character(name) || length(name) != 1) {
stop("`name` must be a single string")
}
name
}
desc <- function(x) -xtfrm(x)
select_env <- new.env()
peek_vars <- function() {
get(".col_names", envir = select_env)
}
context <- new.env()
n <- function() {
do.call(nrow, list(quote(.data)), envir = context)
}
filter <- function(.data, ...) {
check_is_dataframe(.data)
if ("grouped_data" %in% class(.data)) {
filter.grouped_data(.data, ...)
} else {
filter.default(.data, ...)
}
}
filter.default <- function(.data, ...) {
conditions <- paste(deparse_dots(...), collapse = " & ")
context$.data <- .data
on.exit(rm(.data, envir = context))
.data[do.call(with, list(.data, str2lang(unname(conditions)))), ]
}
filter.grouped_data <- function(.data, ...) {
rows <- rownames(.data)
res <- apply_grouped_function(.data, "filter", ...)
res[rows[rows %in% rownames(res)], ]
}
group_by <- function(.data, ..., .add = FALSE) {
check_is_dataframe(.data)
pre_groups <- get_groups(.data)
groups <- deparse_dots(...)
if (isTRUE(.add)) groups <- unique(c(pre_groups, groups))
unknown <- !(groups %in% colnames(.data))
if (any(unknown)) stop("Invalid groups: ", groups[unknown])
structure(.data, class = c("grouped_data", class(.data)), groups = groups)
}
ungroup <- function(x, ...) {
check_is_dataframe(x)
rm_groups <- deparse_dots(...)
groups <- attr(x, "groups")
if (length(rm_groups) == 0L) rm_groups <- groups
attr(x, "groups") <- groups[!(groups %in% rm_groups)]
if (length(attr(x, "groups")) == 0L) {
attr(x, "groups") <- NULL
class(x) <- class(x)[!(class(x) %in% "grouped_data")]
}
x
}
get_groups <- function(x) {
attr(x, "groups", exact = TRUE)
}
has_groups <- function(x) {
groups <- get_groups(x)
if (is.null(groups)) FALSE else TRUE
}
set_groups <- function(x, groups) {
attr(x, "groups") <- groups
x
}
apply_grouped_function <- function(.data, fn, ...) {
groups <- get_groups(.data)
grouped <- split_into_groups(.data, groups)
res <- do.call(rbind, unname(lapply(grouped, fn, ...)))
if (any(groups %in% colnames(res))) {
class(res) <- c("grouped_data", class(res))
attr(res, "groups") <- groups[groups %in% colnames(res)]
}
res
}
split_into_groups <- function(.data, groups) {
class(.data) <- "data.frame"
group_factors <- lapply(groups, function(x, .data) as.factor(.data[, x]), .data)
res <- split(x = .data, f = group_factors)
res
}
print.grouped_data <- function(x, ..., digits = NULL, quote = FALSE, right = TRUE, row.names = TRUE, max = NULL) {
class(x) <- "data.frame"
print(x, ..., digits = digits, quote = quote, right = right, row.names = row.names, max = max)
cat("\nGroups: ", paste(attr(x, "groups", exact = TRUE), collapse = ", "), "\n\n")
}
if_else <- function(condition, true, false, missing = NULL) {
if (!is.logical(condition)) stop("`condition` must be a logical vector.")
cls_true <- class(true)
cls_false <- class(false)
cls_missing <- class(missing)
if (!identical(cls_true, cls_false)) {
stop("The class of `true` <", class(true), "> is not the same as the class of `false` <", class(false), ">")
}
if (!is.null(missing) && !identical(cls_true, cls_missing)) {
stop("`missing` must be a ", cls_true, " vector, not a ", cls_missing, " vector.")
}
res <- ifelse(condition, true, false)
if (!is.null(missing)) res[is.na(res)] <- missing
attributes(res) <- attributes(true)
res
}
inner_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
join_worker(x = x, y = y, by = by, suffix = suffix, sort = FALSE)
}
left_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
join_worker(x = x, y = y, by = by, suffix = suffix, all.x = TRUE)
}
right_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
join_worker(x = x, y = y, by = by, suffix = suffix, all.y = TRUE)
}
full_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
join_worker(x = x, y = y, by = by, suffix = suffix, all = TRUE)
}
join_worker <- function(x, y, by = NULL, suffix = c(".x", ".y"), ...) {
x[, ".join_id"] <- seq_len(nrow(x))
if (is.null(by)) {
by <- intersect(names(x), names(y))
join_message(by)
merged <- merge(x = x, y = y, by = by, suffixes = suffix, ...)[, union(names(x), names(y))]
} else if (is.null(names(by))) {
merged <- merge(x = x, y = y, by = by, suffixes = suffix, ...)
} else {
merged <- merge(x = x, y = y, by.x = names(by), by.y = by, suffixes = suffix, ...)
}
merged <- merged[order(merged[, ".join_id"]), colnames(merged) != ".join_id"]
rownames(merged) <- NULL
merged
}
join_message <- function(by) {
if (length(by) > 1L) {
message("Joining, by = c(\"", paste0(by, collapse = "\", \""), "\")\n", sep = "")
} else {
message("Joining, by = \"", by, "\"\n", sep = "")
}
}
anti_join <- function(x, y, by = NULL) {
filter_join_worker(x, y, by, type = "anti")
}
semi_join <- function(x, y, by = NULL) {
filter_join_worker(x, y, by, type = "semi")
}
# filter_join_worker <- function(x, y, by = NULL, type = c("anti", "semi")) {
# type <- match.arg(type, choices = c("anti", "semi"), several.ok = FALSE)
# if (is.null(by)) {
# by <- intersect(names(x), names(y))
# join_message(by)
# }
# rows <- interaction(x[, by]) %in% interaction(y[, by])
# if (type == "anti") rows <- !rows
# res <- x[rows, ]
# rownames(res) <- NULL
# res
# }
lag <- function (x, n = 1L, default = NA) {
if (inherits(x, "ts")) stop("`x` must be a vector, not a `ts` object, do you want `stats::lag()`?")
if (length(n) != 1L || !is.numeric(n) || n < 0L) stop("`n` must be a nonnegative integer scalar")
if (n == 0L) return(x)
tryCatch(
storage.mode(default) <- typeof(x),
warning = function(w) {
stop("Cannot convert `default` <", typeof(default), "> to `x` <", typeof(x), ">")
}
)
xlen <- length(x)
n <- pmin(n, xlen)
res <- c(rep(default, n), x[seq_len(xlen - n)])
attributes(res) <- attributes(x)
res
}
lead <- function (x, n = 1L, default = NA) {
if (length(n) != 1L || !is.numeric(n) || n < 0L) stop("n must be a nonnegative integer scalar")
if (n == 0L) return(x)
tryCatch(
storage.mode(default) <- typeof(x),
warning = function(w) {
stop("Cannot convert `default` <", typeof(default), "> to `x` <", typeof(x), ">")
}
)
xlen <- length(x)
n <- pmin(n, xlen)
res <- c(x[-seq_len(n)], rep(default, n))
attributes(res) <- attributes(x)
res
}
mutate <- function(.data, ...) {
check_is_dataframe(.data)
if ("grouped_data" %in% class(.data)) {
mutate.grouped_data(.data, ...)
} else {
mutate.default(.data, ...)
}
}
mutate.default <- function(.data, ...) {
conditions <- deparse_dots(...)
cond_names <- names(conditions)
unnamed <- which(nchar(cond_names) == 0L)
if (is.null(cond_names)) {
names(conditions) <- conditions
} else if (length(unnamed) > 0L) {
names(conditions)[unnamed] <- conditions[unnamed]
}
not_matched <- names(conditions)[!names(conditions) %in% names(.data)]
.data[, not_matched] <- NA
context$.data <- .data
on.exit(rm(.data, envir = context))
for (i in seq_along(conditions)) {
.data[, names(conditions)[i]] <- do.call(with, list(.data, str2lang(unname(conditions)[i])))
}
.data
}
mutate.grouped_data <- function(.data, ...) {
rows <- rownames(.data)
res <- apply_grouped_function(.data, "mutate", ...)
res[rows, ]
}
n_distinct <- function(..., na.rm = FALSE) {
res <- c(...)
if (is.list(res)) return(nrow(unique(as.data.frame(res, stringsAsFactors = FALSE))))
if (isTRUE(na.rm)) res <- res[!is.na(res)]
length(unique(res))
}
`%>%` <- function(lhs, rhs) {
lhs <- substitute(lhs)
rhs <- substitute(rhs)
eval(as.call(c(rhs[[1L]], lhs, as.list(rhs[-1L]))), envir = parent.frame())
}
pull <- function(.data, var = -1) {
var_deparse <- deparse_var(var)
col_names <- colnames(.data)
if (!(var_deparse %in% col_names) & grepl("^[[:digit:]]+L|[[:digit:]]", var_deparse)) {
var <- as.integer(gsub("L", "", var_deparse))
var <- if_else(var < 1L, rev(col_names)[abs(var)], col_names[var])
} else if (var_deparse %in% col_names) {
var <- var_deparse
}
.data[, var]
}
relocate <- function(.data, ..., .before = NULL, .after = NULL) {
check_is_dataframe(.data)
data_names <- colnames(.data)
col_pos <- select_positions(.data, ...)
.before <- deparse_var(.before)
.after <- deparse_var(.after)
has_before <- !is.null(.before)
has_after <- !is.null(.after)
if (has_before && has_after) {
stop("You must supply only one of `.before` and `.after`")
} else if (has_before) {
where <- min(match(.before, data_names))
col_pos <- c(setdiff(col_pos, where), where)
} else if (has_after) {
where <- max(match(.after, data_names))
col_pos <- c(where, setdiff(col_pos, where))
} else {
where <- 1L
col_pos <- union(col_pos, where)
}
lhs <- setdiff(seq(1L, where - 1L), col_pos)
rhs <- setdiff(seq(where + 1L, ncol(.data)), col_pos)
col_pos <- unique(c(lhs, col_pos, rhs))
col_pos <- col_pos[col_pos <= length(data_names)]
res <- .data[col_pos]
if (has_groups(.data)) res <- set_groups(res, get_groups(.data))
res
}
rename <- function(.data, ...) {
check_is_dataframe(.data)
new_names <- names(deparse_dots(...))
if (length(new_names) == 0L) {
warning("You didn't give any new names")
return(.data)
}
col_pos <- select_positions(.data, ...)
old_names <- colnames(.data)[col_pos]
new_names_zero <- nchar(new_names) == 0L
if (any(new_names_zero)) {
warning("You didn't provide new names for: ", paste0("`", old_names[new_names_zero], collapse = ", "), "`")
new_names[new_names_zero] <- old_names[new_names_zero]
}
colnames(.data)[col_pos] <- new_names
.data
}
rownames_to_column <- function(.data, var = "rowname") {
check_is_dataframe(.data)
col_names <- colnames(.data)
if (var %in% col_names) stop("Column `", var, "` already exists in `.data`")
.data[, var] <- rownames(.data)
rownames(.data) <- NULL
.data[, c(var, setdiff(col_names, var))]
}
select <- function(.data, ...) {
map <- names(deparse_dots(...))
col_pos <- select_positions(.data, ..., group_pos = TRUE)
res <- .data[, col_pos, drop = FALSE]
to_map <- nchar(map) > 0L
colnames(res)[to_map] <- map[to_map]
if (has_groups(.data)) res <- set_groups(res, get_groups(.data))
res
}
starts_with <- function(match, ignore.case = TRUE, vars = peek_vars()) {
grep(pattern = paste0("^", paste0(match, collapse = "|^")), x = vars, ignore.case = ignore.case)
}
ends_with <- function(match, ignore.case = TRUE, vars = peek_vars()) {
grep(pattern = paste0(paste0(match, collapse = "$|"), "$"), x = vars, ignore.case = ignore.case)
}
contains <- function(match, ignore.case = TRUE, vars = peek_vars()) {
matches <- lapply(
match,
function(x) {
if (isTRUE(ignore.case)) {
match_u <- toupper(x)
match_l <- tolower(x)
pos_u <- grep(pattern = match_u, x = toupper(vars), fixed = TRUE)
pos_l <- grep(pattern = match_l, x = tolower(vars), fixed = TRUE)
unique(c(pos_l, pos_u))
} else {
grep(pattern = x, x = vars, fixed = TRUE)
}
}
)
unique(matches)
}
matches <- function(match, ignore.case = TRUE, perl = FALSE, vars = peek_vars()) {
grep(pattern = match, x = vars, ignore.case = ignore.case, perl = perl)
}
num_range <- function(prefix, range, width = NULL, vars = peek_vars()) {
if (!is.null(width)) {
range <- sprintf(paste0("%0", width, "d"), range)
}
find <- paste0(prefix, range)
if (any(duplicated(vars))) {
stop("Column names must be unique")
} else {
x <- match(find, vars)
x[!is.na(x)]
}
}
all_of <- function(x, vars = peek_vars()) {
x_ <- !x %in% vars
if (any(x_)) {
which_x_ <- which(x_)
if (length(which_x_) == 1L) {
stop("The column ", x[which_x_], " does not exist.")
} else {
stop("The columns ", paste(x[which_x_], collapse = ", "), " do not exist.")
}
} else {
which(vars %in% x)
}
}
any_of <- function(x, vars = peek_vars()) {
which(vars %in% x)
}
everything <- function(vars = peek_vars()) {
seq_along(vars)
}
last_col <- function(offset = 0L, vars = peek_vars()) {
if (!is_wholenumber(offset)) stop("`offset` must be an integer")
n <- length(vars)
if (offset && n <= offset) {
stop("`offset` must be smaller than the number of `vars`")
} else if (n == 0) {
stop("Can't select last column when `vars` is empty")
} else {
n - offset
}
}
select_positions <- function(.data, ..., group_pos = FALSE) {
cols <- eval(substitute(alist(...)))
data_names <- colnames(.data)
select_env$.col_names <- data_names
on.exit(rm(list = ".col_names", envir = select_env))
exec_env <- parent.frame(2L)
pos <- unlist(lapply(cols, eval_expr, exec_env = exec_env))
if (isTRUE(group_pos)) {
groups <- get_groups(.data)
missing_groups <- !(groups %in% cols)
if (any(missing_groups)) {
message("Adding missing grouping variables: `", paste(groups[missing_groups], collapse = "`, `"), "`")
pos <- c(match(groups[missing_groups], data_names), pos)
}
}
unique(pos)
}
eval_expr <- function(x, exec_env) {
type <- typeof(x)
switch(
type,
"integer" = x,
"double" = as.integer(x),
"character" = select_char(x),
"symbol" = select_symbol(x, exec_env = exec_env),
"language" = eval_call(x),
stop("Expressions of type <", typeof(x), "> cannot be evaluated for use when subsetting.")
)
}
select_char <- function(expr) {
pos <- match(expr, select_env$.col_names)
if (is.na(pos)) stop("Column `", expr, "` does not exist")
pos
}
select_symbol <- function(expr, exec_env) {
res <- try(select_char(as.character(expr)), silent = TRUE)
if (inherits(res, "try-error")) {
res <- tryCatch(
select_char(eval(expr, envir = exec_env)),
error = function(e) stop("Column ", expr, " does not exist.")
)
}
res
}
eval_call <- function(x) {
type <- as.character(x[[1]])
switch(
type,
`:` = select_seq(x),
`!` = select_negate(x),
`-` = select_minus(x),
`c` = select_c(x),
`(` = select_bracket(x),
select_context(x)
)
}
select_seq <- function(expr) {
x <- eval_expr(expr[[2]])
y <- eval_expr(expr[[3]])
x:y
}
select_negate <- function(expr) {
x <- if (is_negated_colon(expr)) {
expr <- call(":", expr[[2]][[2]], expr[[2]][[3]][[2]])
eval_expr(expr)
} else {
eval_expr(expr[[2]])
}
x * -1L
}
is_negated_colon <- function(expr) {
expr[[1]] == "!" && length(expr[[2]]) > 1L && expr[[2]][[1]] == ":" && expr[[2]][[3]][[1]] == "!"
}
select_minus <- function(expr) {
x <- eval_expr(expr[[2]])
x * -1L
}
select_c <- function(expr) {
lst_expr <- as.list(expr)
lst_expr[[1]] <- NULL
unlist(lapply(lst_expr, eval_expr))
}
select_bracket <- function(expr) {
eval_expr(expr[[2]])
}
select_context <- function(expr) {
eval(expr, envir = context$.data)
}
slice <- function(.data, ...) {
check_is_dataframe(.data)
if ("grouped_data" %in% class(.data)) {
slice.grouped_data(.data, ...)
} else {
slice.default(.data, ...)
}
}
slice.default <- function(.data, ...) {
rows <- c(...)
stopifnot(is.numeric(rows) | is.integer(rows))
if (all(rows > 0L)) rows <- rows[rows <= nrow(.data)]
.data[rows, ]
}
slice.grouped_data <- function(.data, ...) {
apply_grouped_function(.data, "slice", ...)
}
summarise <- function(.data, ...) {
check_is_dataframe(.data)
if ("grouped_data" %in% class(.data)) {
summarise.grouped_data(.data, ...)
} else {
summarise.default(.data, ...)
}
}
summarise.default <- function(.data, ...) {
fns <- vapply(substitute(...()), deparse, NA_character_)
context$.data <- .data
on.exit(rm(.data, envir = context))
if (has_groups(.data)) {
group <- unique(.data[, get_groups(.data), drop = FALSE])
if (nrow(group) == 0L) return(NULL)
}
res <- lapply(fns, function(x) do.call(with, list(.data, str2lang(x))))
res <- as.data.frame(res)
fn_names <- names(fns)
colnames(res) <- if (is.null(fn_names)) fns else fn_names
if (has_groups(.data)) res <- cbind(group, res)
res
}
summarise.grouped_data <- function(.data, ...) {
groups <- get_groups(.data)
res <- apply_grouped_function(.data, "summarise", ...)
res <- res[do.call(order, lapply(groups, function(x) res[, x])), ]
rownames(res) <- NULL
res
}
summarize <- summarise
summarize.default <- summarise.default
summarize.grouped_data <- summarise.grouped_data
transmute <- function(.data, ...) {
check_is_dataframe(.data)
if ("grouped_data" %in% class(.data)) {
transmute.grouped_data(.data, ...)
} else {
transmute.default(.data, ...)
}
}
transmute.default <- function(.data, ...) {
conditions <- deparse_dots(...)
mutated <- mutate(.data, ...)
mutated[, names(conditions), drop = FALSE]
}
transmute.grouped_data <- function(.data, ...) {
rows <- rownames(.data)
res <- apply_grouped_function(.data, "transmute", ...)
res[rows, ]
}
deparse_dots <- function(...) {
vapply(substitute(...()), deparse, NA_character_)
}
deparse_var <- function(var) {
sub_var <- eval(substitute(substitute(var)), parent.frame())
if (is.symbol(sub_var)) var <- as.character(sub_var)
var
}
check_is_dataframe <- function(.data) {
parent_fn <- all.names(sys.call(-1L), max.names = 1L)
if (!is.data.frame(.data)) stop(parent_fn, " must be given a data.frame")
invisible()
}
is_wholenumber <- function(x) {
x %% 1L == 0L
}
set_names <- function(object = nm, nm) {
names(object) <- nm
object
}
cume_dist <- function(x) {
rank(x, ties.method = "max", na.last = "keep") / sum(!is.na(x))
}
dense_rank <- function(x) {
match(x, sort(unique(x)))
}
min_rank <- function(x) {
rank(x, ties.method = "min", na.last = "keep")
}
ntile <- function (x = row_number(), n) {
if (!missing(x)) x <- row_number(x)
len <- length(x) - sum(is.na(x))
n <- as.integer(floor(n))
if (len == 0L) {
rep(NA_integer_, length(x))
} else {
n_larger <- as.integer(len %% n)
n_smaller <- as.integer(n - n_larger)
size <- len / n
larger_size <- as.integer(ceiling(size))
smaller_size <- as.integer(floor(size))
larger_threshold <- larger_size * n_larger
bins <- if_else(
x <= larger_threshold,
(x + (larger_size - 1L)) / larger_size,
(x + (-larger_threshold + smaller_size - 1L)) / smaller_size + n_larger
)
as.integer(floor(bins))
}
}
percent_rank <- function(x) {
(min_rank(x) - 1) / (sum(!is.na(x)) - 1)
}
row_number <- function(x) {
if (missing(x)) seq_len(n()) else rank(x, ties.method = "first", na.last = "keep")
}

3
R/ab.R
View File

@@ -27,7 +27,6 @@
#' @param ... arguments passed on to internal functions
#' @rdname as.ab
#' @inheritSection WHOCC WHOCC
#' @importFrom dplyr %>% filter slice pull
#' @details All entries in the [antibiotics] data set have three different identifiers: a human readable EARS-Net code (column `ab`, used by ECDC and WHONET), an ATC code (column `atc`, used by WHO), and a CID code (column `cid`, Compound ID, used by PubChem). The data set contains more than 5,000 official brand names from many different countries, as found in PubChem.
#'
#' Use the [ab_property()] functions to get properties based on the returned antibiotic ID, see Examples.
@@ -409,6 +408,6 @@ c.ab <- function(x, ...) {
#' @export
pillar_shaft.ab <- function(x, ...) {
out <- format(x)
out[is.na(x)] <- pillar::style_na("NA")
out[is.na(x)] <- font_red("NA")
pillar::new_pillar_shaft_simple(out, align = "left", min_width = 4)
}

3
R/age.R
View File

@@ -29,7 +29,6 @@
#' @param na.rm a logical to indicate whether missing values should be removed
#' @return An [integer] (no decimals) if `exact = FALSE`, a [double] (with decimals) otherwise
#' @seealso To split ages into groups, use the [age_groups()] function.
#' @importFrom dplyr if_else
#' @inheritSection AMR Read more on our website!
#' @export
#' @examples
@@ -54,7 +53,7 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE) {
# from https://stackoverflow.com/a/25450756/4575331
years_gap <- reference$year - x$year
ages <- if_else(reference$mon < x$mon | (reference$mon == x$mon & reference$mday < x$mday),
ages <- ifelse(reference$mon < x$mon | (reference$mon == x$mon & reference$mday < x$mday),
as.integer(years_gap - 1),
as.integer(years_gap))

2
R/amr.R
View File

@@ -60,6 +60,4 @@
#' <https://gitlab.com/msberends/AMR/issues>
#' @name AMR
#' @rdname AMR
#' @importFrom microbenchmark microbenchmark
#' @importFrom knitr kable
NULL

9
R/atc_online.R
View File

@@ -56,7 +56,6 @@
#' - `"ml"` = milliliter (e.g. eyedrops)
#' @export
#' @rdname atc_online
#' @importFrom dplyr %>%
#' @inheritSection AMR Read more on our website!
#' @source <https://www.whocc.no/atc_ddd_alterations__cumulative/ddd_alterations/abbrevations/>
#' @examples
@@ -77,12 +76,10 @@ atc_online_property <- function(atc_code,
administration = "O",
url = "https://www.whocc.no/atc_ddd_index/?code=%s&showdescription=no") {
stopifnot_installed_package(c("curl", "rvest", "xml2"))
check_dataset_integrity()
if (!all(c("curl", "rvest", "xml2") %in% rownames(utils::installed.packages()))) {
stop("Packages 'xml2', 'rvest' and 'curl' are required for this function")
}
if (!all(atc_code %in% antibiotics)) {
atc_code <- as.character(ab_atc(atc_code))
}

1
R/availability.R
View File

@@ -28,7 +28,6 @@
#' @details The function returns a [`data.frame`] with columns `"resistant"` and `"visual_resistance"`. The values in that columns are calculated with [resistance()].
#' @return [`data.frame`] with column names of `tbl` as row names
#' @inheritSection AMR Read more on our website!
#' @importFrom cleaner percentage
#' @export
#' @examples
#' availability(example_isolates)

70
R/bug_drug_combinations.R
View File

@@ -32,7 +32,6 @@
#' @param ... arguments passed on to `FUN`
#' @inheritParams rsi_df
#' @inheritParams base::formatC
#' @importFrom dplyr %>% rename group_by select mutate filter summarise ungroup
#' @importFrom tidyr pivot_longer
#' @details The function [format()] calculates the resistance per bug-drug combination. Use `combine_IR = FALSE` (default) to test R vs. S+I and `combine_IR = TRUE` to test R+I vs. S.
#'
@@ -74,13 +73,15 @@ bug_drug_combinations <- function(x,
stop("`col_mo` must be set.", call. = FALSE)
}
x <- x %>%
as.data.frame(stringsAsFactors = FALSE) %>%
mutate(mo = x %>%
pull(col_mo) %>%
FUN(...)) %>%
group_by(mo) %>%
select_if(is.rsi) %>%
select_rsi <- function(.data) {
.data[, c(col_mo, names(which(sapply(.data, is.rsi))))]
}
x <- x %>% as.data.frame(stringsAsFactors = FALSE)
x$mo <- FUN(x[, col_mo, drop = TRUE])
x <- x %>%
select_rsi() %>%
pivot_longer(-mo, names_to = "ab") %>%
group_by(mo, ab) %>%
summarise(S = sum(value == "S", na.rm = TRUE),
@@ -93,9 +94,7 @@ bug_drug_combinations <- function(x,
structure(.Data = x, class = c("bug_drug_combinations", class(x)))
}
#' @importFrom dplyr everything rename %>% ungroup group_by summarise mutate_all arrange everything lag
#' @importFrom tidyr pivot_wider
#' @importFrom cleaner percentage
#' @exportMethod format.bug_drug_combinations
#' @export
#' @rdname bug_drug_combinations
@@ -110,10 +109,10 @@ format.bug_drug_combinations <- function(x,
decimal.mark = getOption("OutDec"),
big.mark = ifelse(decimal.mark == ",", ".", ","),
...) {
x <- x %>% filter(total >= minimum)
x <- x %>% subset(total >= minimum)
if (remove_intrinsic_resistant == TRUE) {
x <- x %>% filter(R != total)
x <- x %>% subset(R != total)
}
if (combine_SI == TRUE | combine_IR == FALSE) {
x$isolates <- x$R
@@ -137,26 +136,46 @@ format.bug_drug_combinations <- function(x,
ab_txt
}
remove_NAs <- function(.data) {
as.data.frame(sapply(.data, function(x) ifelse(is.na(x), "", x), simplify = FALSE))
}
create_var <- function(.data, ...) {
dots <- list(...)
for (i in seq_len(length(dots))) {
.data[, names(dots)[i]] <- dots[[i]]
}
.data
}
y <- x %>%
mutate(ab = as.ab(ab),
ab_txt = give_ab_name(ab = ab, format = translate_ab, language = language)) %>%
create_var(ab = as.ab(x$ab),
ab_txt = give_ab_name(ab = x$ab, format = translate_ab, language = language)) %>%
group_by(ab, ab_txt, mo) %>%
summarise(isolates = sum(isolates, na.rm = TRUE),
total = sum(total, na.rm = TRUE)) %>%
ungroup() %>%
mutate(txt = paste0(percentage(isolates / total, decimal.mark = decimal.mark, big.mark = big.mark),
" (", trimws(format(isolates, big.mark = big.mark)), "/",
trimws(format(total, big.mark = big.mark)), ")")) %>%
ungroup()
y <- y %>%
create_var(txt = paste0(percentage(y$isolates / y$total, decimal.mark = decimal.mark, big.mark = big.mark),
" (", trimws(format(y$isolates, big.mark = big.mark)), "/",
trimws(format(y$total, big.mark = big.mark)), ")")) %>%
select(ab, ab_txt, mo, txt) %>%
arrange(mo) %>%
pivot_wider(names_from = mo, values_from = txt) %>%
mutate_all(~ifelse(is.na(.), "", .)) %>%
mutate(ab_group = ab_group(ab, language = language),
ab_txt) %>%
select(ab_group, ab_txt, everything(), -ab) %>%
arrange(ab_group, ab_txt) %>%
mutate(ab_group = ifelse(ab_group != lag(ab_group) | is.na(lag(ab_group)), ab_group, ""))
remove_NAs()
select_ab_vars <- function(.data) {
.data[, c("ab_group", "ab_txt", colnames(.data)[!colnames(.data) %in% c("ab_group", "ab_txt", "ab")])]
}
y <- y %>%
create_var(ab_group = ab_group(y$ab, language = language)) %>%
select_ab_vars() %>%
arrange(ab_group, ab_txt)
y <- y %>%
create_var(ab_group = ifelse(y$ab_group != lag(y$ab_group) | is.na(lag(y$ab_group)), y$ab_group, ""))
if (add_ab_group == FALSE) {
y <- y %>% select(-ab_group) %>% rename("Drug" = ab_txt)
colnames(y)[1] <- translate_AMR(colnames(y)[1], language = get_locale(), only_unknown = FALSE)
@@ -170,8 +189,7 @@ format.bug_drug_combinations <- function(x,
#' @exportMethod print.bug_drug_combinations
#' @export
#' @importFrom crayon blue
print.bug_drug_combinations <- function(x, ...) {
print(as.data.frame(x, stringsAsFactors = FALSE))
message(blue("NOTE: Use 'format()' on this result to get a publicable/printable format."))
message(font_blue("NOTE: Use 'format()' on this result to get a publicable/printable format."))
}

12
R/catalogue_of_life.R
View File

@@ -83,13 +83,7 @@ NULL
#' @return a [`list`], which prints in pretty format
#' @inheritSection catalogue_of_life Catalogue of Life
#' @inheritSection AMR Read more on our website!
#' @importFrom crayon bold underline
#' @importFrom dplyr filter
#' @export
#' @examples
#' library(dplyr)
#' microorganisms %>% freq(kingdom)
#' microorganisms %>% group_by(kingdom) %>% freq(phylum, nmax = NULL)
catalogue_of_life_version <- function() {
check_dataset_integrity()
@@ -118,11 +112,11 @@ catalogue_of_life_version <- function() {
#' @noRd
print.catalogue_of_life_version <- function(x, ...) {
lst <- x
cat(paste0(bold("Included in this AMR package are:\n\n"),
underline(lst$catalogue_of_life$version), "\n",
cat(paste0(font_bold("Included in this AMR package are:\n\n"),
font_underline(lst$catalogue_of_life$version), "\n",
" Available at: ", lst$catalogue_of_life$url, "\n",
" Number of included species: ", format(lst$catalogue_of_life$n, big.mark = ","), "\n",
underline(paste0(lst$deutsche_sammlung_von_mikroorganismen_und_zellkulturen$version, " (",
font_underline(paste0(lst$deutsche_sammlung_von_mikroorganismen_und_zellkulturen$version, " (",
lst$deutsche_sammlung_von_mikroorganismen_und_zellkulturen$yearmonth, ")")), "\n",
" Available at: ", lst$deutsche_sammlung_von_mikroorganismen_und_zellkulturen$url, "\n",
" Number of included species: ", format(lst$deutsche_sammlung_von_mikroorganismen_und_zellkulturen$n, big.mark = ","), "\n\n",

2
R/count.R
View File

@@ -34,7 +34,7 @@
#'
#' The function [n_rsi()] is an alias of [count_all()]. They can be used to count all available isolates, i.e. where all input antibiotics have an available result (S, I or R). Their use is equal to [n_distinct()]. Their function is equal to `count_susceptible(...) + count_resistant(...)`.
#'
#' The function [count_df()] takes any variable from `data` that has an [`rsi`] class (created with [as.rsi()]) and counts the number of S's, I's and R's. The function [rsi_df()] works exactly like [count_df()], but adds the percentage of S, I and R.
#' The function [count_df()] takes any variable from `data` that has an [`rsi`] class (created with [as.rsi()]) and counts the number of S's, I's and R's. It also supports grouped variables. The function [rsi_df()] works exactly like [count_df()], but adds the percentage of S, I and R.
#' @inheritSection proportion Combination therapy
#' @seealso [`proportion_*`][proportion] to calculate microbial resistance and susceptibility.
#' @return An [`integer`]

7
R/deprecated.R
View File

@@ -27,13 +27,6 @@
#' @export
#' @keywords internal
#' @name AMR-deprecated
#' @rdname AMR-deprecated
p.symbol <- function(...) {
.Deprecated("p_symbol()", package = "AMR")
p_symbol(...)
}
#' @rdname AMR-deprecated
#' @export
portion_R <- function(...) {
.Deprecated("resistance()", package = "AMR")

3
R/disk.R
View File

@@ -92,7 +92,6 @@ all_valid_disks <- function(x) {
#' @rdname as.disk
#' @export
#' @importFrom dplyr %>%
is.disk <- function(x) {
inherits(x, "disk")
}
@@ -123,7 +122,7 @@ print.disk <- function(x, ...) {
#' @export
pillar_shaft.disk <- function(x, ...) {
out <- trimws(format(x))
out[is.na(x)] <- pillar::style_na(NA)
out[is.na(x)] <- font_red(NA)
pillar::new_pillar_shaft_simple(out, align = "right", min_width = 3)
}

131
R/eucast_rules.R
View File

@@ -141,9 +141,6 @@ EUCAST_VERSION_EXPERT_RULES <- "3.1, 2016"
#' @aliases EUCAST
#' @rdname eucast_rules
#' @export
#' @importFrom dplyr %>% select pull mutate_at vars group_by summarise n
#' @importFrom crayon bold bgGreen bgYellow bgRed black green blue italic strip_style white red make_style
#' @importFrom utils menu
#' @return The input of `x`, possibly with edited values of antibiotics. Or, if `verbose = TRUE`, a [`data.frame`] with all original and new values of the affected bug-drug combinations.
#' @source
#' - EUCAST Expert Rules. Version 2.0, 2012. \cr
@@ -211,7 +208,7 @@ eucast_rules <- function(x,
if ("rstudioapi" %in% rownames(utils::installed.packages())) {
q_continue <- rstudioapi::showQuestion("Using verbose = TRUE with eucast_rules()", txt)
} else {
q_continue <- menu(choices = c("OK", "Cancel"), graphics = TRUE, title = txt)
q_continue <- utils::menu(choices = c("OK", "Cancel"), graphics = FALSE, title = txt)
}
if (q_continue %in% c(FALSE, 2)) {
message("Cancelled, returning original data")
@@ -242,52 +239,50 @@ eucast_rules <- function(x,
decimal.mark <- getOption("OutDec")
big.mark <- ifelse(decimal.mark != ",", ",", ".")
formatnr <- function(x) {
trimws(format(x, big.mark = big.mark, decimal.mark = decimal.mark))
formatnr <- function(x, big = big.mark, dec = decimal.mark) {
trimws(format(x, big.mark = big, decimal.mark = dec))
}
grey <- make_style("grey")
warned <- FALSE
txt_error <- function() {
if (info == TRUE) cat("", bgRed(white(" ERROR ")), "\n\n")
if (info == TRUE) cat("", font_red_bg(font_white(" ERROR ")), "\n\n")
}
txt_warning <- function() {
if (warned == FALSE) {
if (info == TRUE) cat("", bgYellow(black(" WARNING ")))
if (info == TRUE) cat("", font_yellow_bg(font_black(" WARNING ")))
}
warned <<- TRUE
}
txt_ok <- function(no_added, no_changed) {
if (warned == FALSE) {
if (no_added + no_changed == 0) {
cat(pillar::style_subtle(" (no changes)\n"))
cat(font_subtle(" (no changes)\n"))
} else {
# opening
cat(grey(" ("))
cat(font_grey(" ("))
# additions
if (no_added > 0) {
if (no_added == 1) {
cat(green("1 value added"))
cat(font_green("1 value added"))
} else {
cat(green(formatnr(no_added), "values added"))
cat(font_green(formatnr(no_added), "values added"))
}
}
# separator
if (no_added > 0 & no_changed > 0) {
cat(grey(", "))
cat(font_grey(", "))
}
# changes
if (no_changed > 0) {
if (no_changed == 1) {
cat(blue("1 value changed"))
cat(font_blue("1 value changed"))
} else {
cat(blue(formatnr(no_changed), "values changed"))
cat(font_blue(formatnr(no_changed), "values changed"))
}
}
# closing
cat(grey(")\n"))
cat(font_grey(")\n"))
}
warned <<- FALSE
}
@@ -450,8 +445,11 @@ eucast_rules <- function(x,
x_original[rows, cols] <<- to,
warning = function(w) {
if (w$message %like% "invalid factor level") {
x_original <<- x_original %>% mutate_at(vars(cols), ~factor(x = as.character(.), levels = c(to, levels(.))))
x <<- x %>% mutate_at(vars(cols), ~factor(x = as.character(.), levels = c(to, levels(.))))
xyz <- sapply(cols, function(col) {
x_original[, col] <<- factor(x = as.character(pull(x_original, col)), levels = c(to, levels(pull(x_original, col))))
x[, col] <<- factor(x = as.character(pull(x, col)), levels = c(to, levels(pull(x, col))))
invisible()
})
x_original[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)
txt_warning()
@@ -493,9 +491,9 @@ eucast_rules <- function(x,
mo_fullname = x[rows, "fullname"],
old = as.rsi(as.character(old[, cols[i]]), warn = FALSE),
new = as.rsi(as.character(x[rows, cols[i]])),
rule = strip_style(rule[1]),
rule_group = strip_style(rule[2]),
rule_name = strip_style(rule[3]),
rule = font_stripstyle(rule[1]),
rule_group = font_stripstyle(rule[2]),
rule_name = font_stripstyle(rule[3]),
stringsAsFactors = FALSE)
colnames(verbose_new) <- c("row", "col", "mo_fullname", "old", "new", "rule", "rule_group", "rule_name")
verbose_new <- verbose_new %>% filter(old != new | is.na(old))
@@ -517,18 +515,16 @@ eucast_rules <- function(x,
x_original <- x
# join to microorganisms data set
suppressWarnings(
x <- x %>%
mutate_at(vars(col_mo), as.mo) %>%
left_join_microorganisms(by = col_mo, suffix = c("_oldcols", "")) %>%
mutate(gramstain = mo_gramstain(pull(., col_mo), language = "en"),
genus_species = paste(genus, species)) %>%
as.data.frame(stringsAsFactors = FALSE)
)
x <- as.data.frame(x, stringsAsFactors = FALSE)
x[, col_mo] <- as.mo(x[, col_mo, drop = TRUE])
x <- x %>%
left_join_microorganisms(by = col_mo, suffix = c("_oldcols", ""))
x$gramstain <- mo_gramstain(x[, col_mo, drop = TRUE])
x$genus_species <- paste(x$genus, x$species)
if (ab_missing(AMP) & !ab_missing(AMX)) {
# ampicillin column is missing, but amoxicillin is available
message(blue(paste0("NOTE: Using column `", bold(AMX), "` as input for ampicillin (J01CA01) since many EUCAST rules depend on it.")))
message(font_blue(paste0("NOTE: Using column `", font_bold(AMX), "` as input for ampicillin (J01CA01) since many EUCAST rules depend on it.")))
AMP <- AMX
}
@@ -642,8 +638,8 @@ eucast_rules <- function(x,
if (info == TRUE & !rule_group_current %like% "other" & eucast_notification_shown == FALSE) {
cat(paste0(
"\n----\nRules by the ", bold("European Committee on Antimicrobial Susceptibility Testing (EUCAST)"),
"\n", blue("http://eucast.org/"), "\n"))
"\n----\nRules by the ", font_bold("European Committee on Antimicrobial Susceptibility Testing (EUCAST)"),
"\n", font_blue("http://eucast.org/"), "\n"))
eucast_notification_shown <- TRUE
}
@@ -652,25 +648,23 @@ eucast_rules <- function(x,
# Print rule (group) ------------------------------------------------------
if (rule_group_current != rule_group_previous) {
# is new rule group, one of Breakpoints, Expert Rules and Other
cat(bold(
case_when(
rule_group_current %like% "breakpoint" ~
paste0("\nEUCAST Clinical Breakpoints (",
red(paste0("v", EUCAST_VERSION_BREAKPOINTS)), ")\n"),
rule_group_current %like% "expert" ~
cat(font_bold(
ifelse(
rule_group_current %like% "breakpoint",
paste0("\nEUCAST Clinical Breakpoints (",
font_red(paste0("v", EUCAST_VERSION_BREAKPOINTS)), ")\n"),
ifelse(
rule_group_current %like% "expert",
paste0("\nEUCAST Expert Rules, Intrinsic Resistance and Exceptional Phenotypes (",
red(paste0("v", EUCAST_VERSION_EXPERT_RULES)), ")\n"),
TRUE ~
"\nOther rules by this AMR package\n"
)
))
font_red(paste0("v", EUCAST_VERSION_EXPERT_RULES)), ")\n"),
"\nOther rules by this AMR package\n"))))
}
# Print rule -------------------------------------------------------------
if (rule_current != rule_previous) {
# is new rule within group, print its name
if (rule_current %in% c(microorganisms$family,
microorganisms$fullname)) {
cat(italic(rule_current))
cat(font_italic(rule_current))
} else {
cat(rule_current)
}
@@ -789,8 +783,8 @@ eucast_rules <- function(x,
verbose_info <- verbose_info %>%
arrange(row, rule_group, rule_name, col)
cat(paste0("\n", grey(strrep("-", options()$width - 1)), "\n"))
cat(bold(paste("EUCAST rules", paste0(wouldve, "affected"),
cat(paste0("\n", font_grey(strrep("-", options()$width - 1)), "\n"))
cat(font_bold(paste("EUCAST rules", paste0(wouldve, "affected"),
formatnr(n_distinct(verbose_info$row)),
"out of", formatnr(nrow(x_original)),
"rows, making a total of", formatnr(nrow(verbose_info)), "edits\n")))
@@ -802,62 +796,59 @@ eucast_rules <- function(x,
if (n_added == 0) {
colour <- cat # is function
} else {
colour <- green # is function
colour <- font_green # is function
}
cat(colour(paste0("=> ", wouldve, "added ",
bold(formatnr(verbose_info %>%
font_bold(formatnr(verbose_info %>%
filter(is.na(old)) %>%
nrow()), "test results"),
"\n")))
if (n_added > 0) {
verbose_info %>%
added_summary <- verbose_info %>%
filter(is.na(old)) %>%
group_by(new) %>%
summarise(n = n()) %>%
mutate(plural = ifelse(n > 1, "s", ""),
txt = paste0(formatnr(n), " test result", plural, " added as ", new)) %>%
pull(txt) %>%
paste(" -", ., collapse = "\n") %>%
cat()
summarise(n = n())
cat(paste(" -",
paste0(formatnr(added_summary$n), " test result", ifelse(added_summary$n > 1, "s", ""),
" added as ", added_summary$new), collapse = "\n"))
}
# print changed values ----
if (n_changed == 0) {
colour <- cat # is function
} else {
colour <- blue # is function
colour <- font_blue # is function
}
if (n_added + n_changed > 0) {
cat("\n")
}
cat(colour(paste0("=> ", wouldve, "changed ",
bold(formatnr(verbose_info %>%
font_bold(formatnr(verbose_info %>%
filter(!is.na(old)) %>%
nrow()), "test results"),
"\n")))
if (n_changed > 0) {
verbose_info %>%
changed_summary <- verbose_info %>%
filter(!is.na(old)) %>%
group_by(old, new) %>%
summarise(n = n()) %>%
mutate(plural = ifelse(n > 1, "s", ""),
txt = paste0(formatnr(n), " test result", plural, " changed from ", old, " to ", new)) %>%
pull(txt) %>%
paste(" -", ., collapse = "\n") %>%
cat()
summarise(n = n())
cat(paste(" -",
paste0(formatnr(changed_summary$n), " test result", ifelse(changed_summary$n > 1, "s", ""), " changed from ",
changed_summary$old, " to ", changed_summary$new), collapse = "\n"))
cat("\n")
}
cat(paste0(grey(strrep("-", options()$width - 1)), "\n"))
cat(paste0(font_grey(strrep("-", options()$width - 1)), "\n"))
if (verbose == FALSE & nrow(verbose_info) > 0) {
cat(paste("\nUse", bold("eucast_rules(..., verbose = TRUE)"), "(on your original data) to get a data.frame with all specified edits instead.\n\n"))
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"))
} else if (verbose == TRUE) {
cat(paste0("\nUsed 'Verbose mode' (", bold("verbose = TRUE"), "), which returns a data.frame with all specified edits.\nUse ", bold("verbose = FALSE"), " to apply the rules on your data.\n\n"))
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"))
}
}
# Return data set ---------------------------------------------------------
if (verbose == TRUE) {
rownames(verbose_info) <- NULL
verbose_info
} else {
x_original

82
R/filter_ab_class.R
View File

@@ -19,9 +19,9 @@
# Visit our website for more info: https://msberends.gitlab.io/AMR. #
# ==================================================================== #
#' Filter isolates on result in antibiotic class
#' Filter isolates on result in antimicrobial class
#'
#' Filter isolates on results in specific antibiotic variables based on their antibiotic class. This makes it easy to filter on isolates that were tested for e.g. any aminoglycoside.
#' Filter isolates on results in specific antimicrobial classes. This makes it easy to filter on isolates that were tested for e.g. any aminoglycoside.
#' @inheritSection lifecycle Stable lifecycle
#' @param x a data set
#' @param ab_class an antimicrobial class, like `"carbapenems"`, as can be found in [`antibiotics$group`][antibiotics]
@@ -30,10 +30,9 @@
#' @param ... parameters passed on to `filter_at` from the `dplyr` package
#' @details The `group` column in [antibiotics] data set will be searched for `ab_class` (case-insensitive). If no results are found, the `atc_group1` and `atc_group2` columns will be searched. Next, `x` will be checked for column names with a value in any abbreviations, codes or official names found in the [antibiotics] data set.
#' @rdname filter_ab_class
#' @importFrom dplyr filter_at %>% select vars any_vars all_vars
#' @importFrom crayon bold blue
#' @export
#' @examples
#' \dontrun{
#' library(dplyr)
#'
#' # filter on isolates that have any result for any aminoglycoside
@@ -62,6 +61,7 @@
#' example_isolates %>%
#' filter_aminoglycosides("R", "all") %>%
#' filter_fluoroquinolones("R", "all")
#' }
filter_ab_class <- function(x,
ab_class,
result = NULL,
@@ -76,17 +76,23 @@ filter_ab_class <- function(x,
}
# make result = "SI" work too:
result <- unlist(strsplit(result, ""))
if (!all(result %in% c("S", "I", "R"))) {
stop("`result` must be one or more of: S, I, R", call. = FALSE)
}
if (!all(scope %in% c("any", "all"))) {
stop("`scope` must be one of: any, all", call. = FALSE)
}
vars_df <- colnames(x)[tolower(colnames(x)) %in% tolower(ab_class_vars(ab_class))]
# get only columns with class ab, mic or disk - those are AMR results
vars_df <- colnames(x)[sapply(x, function(y) is.rsi(y) | is.mic(y) | is.disk(y))]
vars_df_ab <- suppressWarnings(as.ab(vars_df))
# get the columns with a group names in the chosen ab class
vars_df <- vars_df[which(ab_group(vars_df_ab) %like% ab_class |
ab_atc_group1(vars_df_ab) %like% ab_class |
ab_atc_group2(vars_df_ab) %like% ab_class)]
ab_group <- find_ab_group(ab_class)
if (length(vars_df) > 0) {
if (length(result) == 1) {
operator <- " is "
@@ -95,10 +101,10 @@ filter_ab_class <- function(x,
}
if (scope == "any") {
scope_txt <- " or "
scope_fn <- any_vars
scope_fn <- any
} else {
scope_txt <- " and "
scope_fn <- all_vars
scope_fn <- all
if (length(vars_df) > 1) {
operator <- gsub("is", "are", operator)
}
@@ -108,14 +114,13 @@ filter_ab_class <- function(x,
} else {
scope <- "column "
}
message(blue(paste0("Filtering on ", ab_group, ": ", scope,
paste(bold(paste0("`", vars_df, "`")), collapse = scope_txt), operator, toString(result))))
x %>%
filter_at(vars(vars_df),
scope_fn(. %in% result),
...)
message(font_blue(paste0("Filtering on ", ab_group, ": ", scope,
paste0(font_bold(paste0("`", vars_df, "`"), collapse = NULL), collapse = scope_txt), operator, toString(result))))
x[as.logical(by(x, seq_len(nrow(x)), function(row) scope_fn(unlist(row[, vars_df]) %in% result, na.rm = TRUE))), , drop = FALSE]
} else {
warning(paste0("no antibiotics of class ", ab_group, " found, leaving data unchanged"), call. = FALSE)
message(font_blue(paste0("NOTE: no antimicrobial agents of class ", ab_group,
" (such as ", find_ab_names(ab_group),
") found, data left unchanged.")))
x
}
}
@@ -276,38 +281,6 @@ filter_tetracyclines <- function(x,
...)
}
#' @importFrom dplyr %>% filter_at vars any_vars select
ab_class_vars <- function(ab_class) {
ab_class <- gsub("[^a-z0-9]+", ".*", ab_class)
ab_vars <- antibiotics %>%
filter(group %like% ab_class) %>%
select(ab:name, abbreviations, synonyms) %>%
unlist() %>%
as.matrix() %>%
as.character() %>%
paste(collapse = "|") %>%
strsplit("|", fixed = TRUE) %>%
unlist() %>%
unique()
ab_vars <- ab_vars[!ab_vars %in% c(NA, "", "NA") & nchar(ab_vars) > 2]
if (length(ab_vars) == 0) {
# try again, searching atc_group1 and atc_group2 columns
ab_vars <- antibiotics %>%
filter_at(vars(c("atc_group1", "atc_group2")), any_vars(. %like% ab_class)) %>%
select(ab:name, abbreviations, synonyms) %>%
unlist() %>%
as.matrix() %>%
as.character() %>%
paste(collapse = "|") %>%
strsplit("|", fixed = TRUE) %>%
unlist() %>%
unique()
ab_vars <- ab_vars[!ab_vars %in% c(NA, "", "NA") & nchar(ab_vars) > 2]
}
ab_vars
}
#' @importFrom dplyr %>% filter pull
find_ab_group <- function(ab_class) {
ifelse(ab_class %in% c("aminoglycoside",
"carbapenem",
@@ -318,10 +291,19 @@ find_ab_group <- function(ab_class) {
"tetracycline"),
paste0(ab_class, "s"),
antibiotics %>%
filter(ab %in% ab_class_vars(ab_class)) %>%
subset(group %like% ab_class |
atc_group1 %like% ab_class |
atc_group2 %like% ab_class) %>%
pull(group) %>%
unique() %>%
tolower() %>%
paste(collapse = "/")
)
}
find_ab_names <- function(ab_group) {
drugs <- antibiotics[which(antibiotics$group %like% ab_group), "name"]
paste0(ab_name(sample(drugs, size = min(4, length(drugs)), replace = FALSE),
tolower = TRUE, language = NULL),
collapse = ", ")
}

266
R/first_isolate.R
View File

@@ -75,11 +75,8 @@
#' @rdname first_isolate
#' @seealso [key_antibiotics()]
#' @export
#' @importFrom dplyr arrange_at lag between row_number filter mutate arrange pull ungroup
#' @importFrom crayon blue bold silver
# @importFrom clean percentage
#' @return A [`logical`] vector
#' @source Methodology of this function is based on:
#' @source Methodology of this function is strictly based on:
#'
#' **M39 Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data, 4th Edition**, 2014, *Clinical and Laboratory Standards Institute (CLSI)*. <https://clsi.org/standards/products/microbiology/documents/m39/>.
#' @inheritSection AMR Read more on our website!
@@ -87,6 +84,7 @@
#' # `example_isolates` is a dataset available in the AMR package.
#' # See ?example_isolates.
#'
#' \dontrun{
#' library(dplyr)
#' # Filter on first isolates:
#' example_isolates %>%
@@ -107,13 +105,11 @@
#'
#' # Have a look at A and B.
#' # B is more reliable because every isolate is counted only once.
#' # Gentamicin resitance in hospital D appears to be 3.7% higher than
#' # Gentamicin resistance in hospital D appears to be 3.7% higher than
#' # when you (erroneously) would have used all isolates for analysis.
#'
#'
#' ## OTHER EXAMPLES:
#'
#' \dontrun{
#'
#' # Short-hand versions:
#' example_isolates %>%
@@ -151,10 +147,6 @@ first_isolate <- function(x,
include_unknown = FALSE,
...) {
if (!is.data.frame(x)) {
stop("`x` must be a data.frame.", call. = FALSE)
}
dots <- unlist(list(...))
if (length(dots) != 0) {
# backwards compatibility with old parameters
@@ -167,24 +159,30 @@ first_isolate <- function(x,
}
}
if (!is.data.frame(x)) {
stop("`x` must be a data.frame.", call. = FALSE)
}
# remove data.table, grouping from tibbles, etc.
x <- as.data.frame(x, stringsAsFactors = FALSE)
# try to find columns based on type
# -- mo
if (is.null(col_mo)) {
col_mo <- search_type_in_df(x = x, type = "mo")
}
if (is.null(col_mo)) {
stop("`col_mo` must be set.", call. = FALSE)
if (is.null(col_mo)) {
stop("`col_mo` must be set.", call. = FALSE)
}
}
# -- date
if (is.null(col_date)) {
col_date <- search_type_in_df(x = x, type = "date")
if (is.null(col_date)) {
stop("`col_date` must be set.", call. = FALSE)
}
}
if (is.null(col_date)) {
stop("`col_date` must be set.", call. = FALSE)
}
# convert to Date (pipes/pull for supporting tibbles too)
dates <- x %>% pull(col_date) %>% as.Date()
# convert to Date
dates <- as.Date(x[, col_date, drop = TRUE])
dates[is.na(dates)] <- as.Date("1970-01-01")
x[, col_date] <- dates
@@ -192,15 +190,15 @@ first_isolate <- function(x,
if (is.null(col_patient_id)) {
if (all(c("First name", "Last name", "Sex") %in% colnames(x))) {
# WHONET support
x <- x %>% mutate(patient_id = paste(`First name`, `Last name`, Sex))
x$patient_id <- paste(x$`First name`, x$`Last name`, x$Sex)
col_patient_id <- "patient_id"
message(blue(paste0("NOTE: Using combined columns `", bold("First name"), "`, `", bold("Last name"), "` and `", bold("Sex"), "` as input for `col_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`")))
} else {
col_patient_id <- search_type_in_df(x = x, type = "patient_id")
}
}
if (is.null(col_patient_id)) {
stop("`col_patient_id` must be set.", call. = FALSE)
if (is.null(col_patient_id)) {
stop("`col_patient_id` must be set.", call. = FALSE)
}
}
# -- key antibiotics
@@ -239,27 +237,19 @@ first_isolate <- function(x,
check_columns_existance(col_icu)
check_columns_existance(col_keyantibiotics)
# create new dataframe with original row index
x <- x %>%
mutate(newvar_row_index = seq_len(nrow(x)),
newvar_mo = x %>% pull(col_mo) %>% as.mo(),
newvar_genus_species = paste(mo_genus(newvar_mo), mo_species(newvar_mo)),
newvar_date = x %>% pull(col_date),
newvar_patient_id = x %>% pull(col_patient_id))
# create original row index
x$newvar_row_index <- seq_len(nrow(x))
x$newvar_mo <- x %>% pull(col_mo) %>% as.mo()
x$newvar_genus_species <- paste(mo_genus(x$newvar_mo), mo_species(x$newvar_mo))
x$newvar_date <- x %>% pull(col_date)
x$newvar_patient_id <- x %>% pull(col_patient_id)
if (is.null(col_testcode)) {
testcodes_exclude <- NULL
}
# remove testcodes
if (!is.null(testcodes_exclude) & info == TRUE) {
message(blue(paste0("[Criterion] Excluded test codes: ", toString(testcodes_exclude))))
}
if (is.null(col_icu)) {
icu_exclude <- FALSE
} else {
x <- x %>%
mutate(col_icu = x %>% pull(col_icu) %>% as.logical())
message(font_black(paste0("[Criterion] Exclude test codes: ", toString(paste0("'", testcodes_exclude, "'")))))
}
if (is.null(col_specimen)) {
@@ -270,11 +260,11 @@ first_isolate <- function(x,
if (!is.null(specimen_group)) {
check_columns_existance(col_specimen, x)
if (info == TRUE) {
message(blue(paste0("[Criterion] Excluded other than specimen group '", specimen_group, "'")))
message(font_black(paste0("[Criterion] Exclude other than specimen group '", specimen_group, "'")))
}
}
if (!is.null(col_keyantibiotics)) {
x <- x %>% mutate(key_ab = x %>% pull(col_keyantibiotics))
x$newvar_key_ab <- x[, col_keyantibiotics, drop = TRUE]
}
if (is.null(testcodes_exclude)) {
@@ -283,87 +273,38 @@ first_isolate <- function(x,
# arrange data to the right sorting
if (is.null(specimen_group)) {
# not filtering on specimen
if (icu_exclude == FALSE) {
if (info == TRUE & !is.null(col_icu)) {
message(blue("[Criterion] Included isolates from ICU"))
}
x <- x %>%
arrange(newvar_patient_id,
newvar_genus_species,
newvar_date)
x <- x[order(x$newvar_patient_id,
x$newvar_genus_species,
x$newvar_date), ]
rownames(x) <- NULL
row.start <- 1
row.end <- nrow(x)
} else {
if (info == TRUE) {
message(blue("[Criterion] Excluded isolates from ICU"))
}
x <- x %>%
arrange_at(c(col_icu,
"newvar_patient_id",
"newvar_genus_species",
"newvar_date"))
suppressWarnings(
row.start <- which(x %>% pull(col_icu) == FALSE) %>% min(na.rm = TRUE)
)
suppressWarnings(
row.end <- which(x %>% pull(col_icu) == FALSE) %>% max(na.rm = TRUE)
)
}
} else {
# filtering on specimen and only analyse these row to save time
if (icu_exclude == FALSE) {
if (info == TRUE & !is.null(col_icu)) {
message(blue("[Criterion] Included isolates from ICU.\n"))
}
x <- x %>%
arrange_at(c(col_specimen,
"newvar_patient_id",
"newvar_genus_species",
"newvar_date"))
# filtering on specimen and only analyse these rows to save time
x <- x[order(pull(x, col_specimen),
x$newvar_patient_id,
x$newvar_genus_species,
x$newvar_date), ]
rownames(x) <- NULL
suppressWarnings(
row.start <- which(x %>% pull(col_specimen) == specimen_group) %>% min(na.rm = TRUE)
)
suppressWarnings(
row.end <- which(x %>% pull(col_specimen) == specimen_group) %>% max(na.rm = TRUE)
)
} else {
if (info == TRUE) {
message(blue("[Criterion] Excluded isolates from ICU"))
}
x <- x %>%
arrange_at(c(col_icu,
col_specimen,
"newvar_patient_id",
"newvar_genus_species",
"newvar_date"))
suppressWarnings(
row.start <- min(which(x %>% pull(col_specimen) == specimen_group
& x %>% pull(col_icu) == FALSE),
na.rm = TRUE)
)
suppressWarnings(
row.end <- max(which(x %>% pull(col_specimen) == specimen_group &
x %>% pull(col_icu) == FALSE),
na.rm = TRUE)
)
}
}
# no isolates found
if (abs(row.start) == Inf | abs(row.end) == Inf) {
if (info == TRUE) {
message(paste("=> Found", bold("no isolates")))
message(paste("=> Found", font_bold("no isolates")))
}
return(rep(FALSE, nrow(x)))
}
# did find some isolates - add new index numbers of rows
x <- x %>% mutate(newvar_row_index_sorted = seq_len(nrow(.)))
x$newvar_row_index_sorted <- seq_len(nrow(x))
scope.size <- row.end - row.start + 1
identify_new_year <- function(x, episode_days) {
@@ -389,123 +330,121 @@ first_isolate <- function(x,
}
# Analysis of first isolate ----
all_first <- x %>%
mutate(other_pat_or_mo = if_else(newvar_patient_id == lag(newvar_patient_id)
& newvar_genus_species == lag(newvar_genus_species),
FALSE,
TRUE)) %>%
group_by(newvar_patient_id,
newvar_genus_species) %>%
mutate(more_than_episode_ago = identify_new_year(x = newvar_date,
episode_days = episode_days)) %>%
ungroup()
x$other_pat_or_mo <- if_else(x$newvar_patient_id == lag(x$newvar_patient_id) &
x$newvar_genus_species == lag(x$newvar_genus_species),
FALSE,
TRUE)
x$episode_group <- paste(x$newvar_patient_id, x$newvar_genus_species)
x$more_than_episode_ago <- unname(unlist(lapply(unique(x$episode_group),
function(g,
df = x,
days = episode_days) {
identify_new_year(x = df[which(df$episode_group == g), "newvar_date"],
episode_days = days)
})))
weighted.notice <- ""
if (!is.null(col_keyantibiotics)) {
weighted.notice <- "weighted "
if (info == TRUE) {
if (type == "keyantibiotics") {
message(blue(paste0("[Criterion] Inclusion based on key antibiotics, ",
message(font_black(paste0("[Criterion] Base inclusion on key antibiotics, ",
ifelse(ignore_I == FALSE, "not ", ""),
"ignoring I")))
}
if (type == "points") {
message(blue(paste0("[Criterion] Inclusion based on key antibiotics, using points threshold of "
message(font_black(paste0("[Criterion] Base inclusion on key antibiotics, using points threshold of "
, points_threshold)))
}
}
type_param <- type
all_first <- all_first %>%
mutate(key_ab_lag = lag(key_ab)) %>%
mutate(key_ab_other = !key_antibiotics_equal(y = key_ab,
z = key_ab_lag,
type = type_param,
ignore_I = ignore_I,
points_threshold = points_threshold,
info = info)) %>%
mutate(
real_first_isolate =
if_else(
newvar_row_index_sorted %>% between(row.start, row.end)
& newvar_genus_species != ""
& (other_pat_or_mo | more_than_episode_ago | key_ab_other),
TRUE,
FALSE))
x$other_key_ab <- !key_antibiotics_equal(y = x$newvar_key_ab,
z = lag(x$newvar_key_ab),
type = type_param,
ignore_I = ignore_I,
points_threshold = points_threshold,
info = info)
# with key antibiotics
x$newvar_first_isolate <- 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)
} else {
# no key antibiotics
all_first <- all_first %>%
mutate(
real_first_isolate =
if_else(
newvar_row_index_sorted %>% between(row.start, row.end)
& newvar_genus_species != ""
& (other_pat_or_mo | more_than_episode_ago),
TRUE,
FALSE))
x$newvar_first_isolate <- 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)
}
# first one as TRUE
all_first[row.start, "real_first_isolate"] <- TRUE
x[row.start, "newvar_first_isolate"] <- TRUE
# no tests that should be included, or ICU
if (!is.null(col_testcode)) {
all_first[which(all_first[, col_testcode] %in% tolower(testcodes_exclude)), "real_first_isolate"] <- FALSE
x[which(x[, col_testcode] %in% tolower(testcodes_exclude)), "newvar_first_isolate"] <- FALSE
}
if (icu_exclude == TRUE) {
all_first[which(all_first[, col_icu] == TRUE), "real_first_isolate"] <- FALSE
if (!is.null(col_icu)) {
if (icu_exclude == TRUE) {
message(font_black("[Criterion] Exclude isolates from ICU.\n"))
x[which(as.logical(x[, col_icu, drop = TRUE])), "newvar_first_isolate"] <- FALSE
} else {
message(font_black("[Criterion] Include isolates from ICU.\n"))
}
}
decimal.mark <- getOption("OutDec")
big.mark <- ifelse(decimal.mark != ",", ",", ".")
# handle empty microorganisms
if (any(all_first$newvar_mo == "UNKNOWN", na.rm = TRUE) & info == TRUE) {
message(blue(paste0("NOTE: ", ifelse(include_unknown == TRUE, "Included ", "Excluded "),
format(sum(all_first$newvar_mo == "UNKNOWN"),
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"),
decimal.mark = decimal.mark, big.mark = big.mark),
" isolates with a microbial ID 'UNKNOWN' (column `", bold(col_mo), "`)")))
" isolates with a microbial ID 'UNKNOWN' (column `", font_bold(col_mo), "`)")))
}
all_first[which(all_first$newvar_mo == "UNKNOWN"), "real_first_isolate"] <- include_unknown
x[which(x$newvar_mo == "UNKNOWN"), "newvar_first_isolate"] <- include_unknown
# exclude all NAs
if (any(is.na(all_first$newvar_mo)) & info == TRUE) {
message(blue(paste0("NOTE: Excluded ", format(sum(is.na(all_first$newvar_mo)),
if (any(is.na(x$newvar_mo)) & info == TRUE) {
message(font_blue(paste0("NOTE: Excluded ", format(sum(is.na(x$newvar_mo)),
decimal.mark = decimal.mark, big.mark = big.mark),
" isolates with a microbial ID 'NA' (column `", bold(col_mo), "`)")))
" isolates with a microbial ID 'NA' (column `", font_bold(col_mo), "`)")))
}
all_first[which(is.na(all_first$newvar_mo)), "real_first_isolate"] <- FALSE
x[which(is.na(x$newvar_mo)), "newvar_first_isolate"] <- FALSE
# arrange back according to original sorting again
all_first <- all_first %>%
arrange(newvar_row_index) %>%
pull(real_first_isolate)
x <- x[order(x$newvar_row_index), ]
rownames(x) <- NULL
if (info == TRUE) {
n_found <- base::sum(all_first, na.rm = TRUE)
n_found <- base::sum(x$newvar_first_isolate, na.rm = TRUE)
p_found_total <- percentage(n_found / nrow(x))
p_found_scope <- percentage(n_found / scope.size)
# mark up number of found
n_found <- base::format(n_found, big.mark = big.mark, decimal.mark = decimal.mark)
if (p_found_total != p_found_scope) {
msg_txt <- paste0("=> Found ",
bold(paste0(n_found, " first ", weighted.notice, "isolates")),
font_bold(paste0(n_found, " first ", weighted.notice, "isolates")),
" (", p_found_scope, " within scope and ", p_found_total, " of total)")
} else {
msg_txt <- paste0("=> Found ",
bold(paste0(n_found, " first ", weighted.notice, "isolates")),
font_bold(paste0(n_found, " first ", weighted.notice, "isolates")),
" (", p_found_total, " of total)")
}
base::message(msg_txt)
message(font_black(msg_txt))
}
all_first
x$newvar_first_isolate
}
#' @rdname first_isolate
#' @importFrom dplyr filter
#' @export
filter_first_isolate <- function(x,
col_date = NULL,
@@ -520,7 +459,6 @@ filter_first_isolate <- function(x,
}
#' @rdname first_isolate
#' @importFrom dplyr %>% mutate filter
#' @export
filter_first_weighted_isolate <- function(x,
col_date = NULL,

3
R/freq.R
View File

@@ -24,8 +24,7 @@
cleaner::freq
#' @exportMethod freq.mo
#' @importFrom dplyr n_distinct
#' @importFrom cleaner freq.default percentage
#' @importFrom cleaner freq.default
#' @export
#' @noRd
freq.mo <- function(x, ...) {

46
R/ggplot_pca.R
View File

@@ -58,6 +58,7 @@
#' # `example_isolates` is a dataset available in the AMR package.
#' # See ?example_isolates.
#'
#' \dontrun{
#' # See ?pca for more info about Principal Component Analysis (PCA).
#' library(dplyr)
#' pca_model <- example_isolates %>%
@@ -71,6 +72,7 @@
#'
#' # new
#' ggplot_pca(pca_model)
#' }
ggplot_pca <- function(x,
choices = 1:2,
scale = TRUE,
@@ -120,14 +122,9 @@ ggplot_pca <- function(x,
pc.biplot = pc.biplot,
ellipse_prob = ellipse_prob,
labels_text_placement = labels_text_placement)
nobs.factor <- calculations$nobs.factor
d <- calculations$d
u <- calculations$u
v <- calculations$v
choices <- calculations$choices
df.u <- calculations$df.u
df.v <- calculations$df.v
r <- calculations$r
ell <- calculations$ell
groups <- calculations$groups
group_name <- calculations$group_name
@@ -232,7 +229,6 @@ ggplot_pca <- function(x,
g
}
#' @importFrom dplyr bind_rows
#' @importFrom stats qchisq var
pca_calculations <- function(pca_model,
groups = NULL,
@@ -328,18 +324,25 @@ pca_calculations <- function(pca_model,
if (!is.null(df.u$groups)) {
theta <- c(seq(-pi, pi, length = 50), seq(pi, -pi, length = 50))
circle <- cbind(cos(theta), sin(theta))
ell <- bind_rows(
sapply(unique(df.u$groups), function(g, df = df.u) {
x <- df[which(df$groups == g), , drop = FALSE]
if (nrow(x) <= 2) {
return(NULL)
}
sigma <- var(cbind(x$xvar, x$yvar))
mu <- c(mean(x$xvar), mean(x$yvar))
ed <- sqrt(qchisq(ellipse_prob, df = 2))
data.frame(sweep(circle %*% chol(sigma) * ed, 2, mu, FUN = "+"),
groups = x$groups[1])
}))
df.groups <- lapply(unique(df.u$groups), function(g, df = df.u) {
x <- df[which(df$groups == g), , drop = FALSE]
if (nrow(x) <= 2) {
return(data.frame(X1 = numeric(0),
X2 = numeric(0),
groups = character(0)))
}
sigma <- var(cbind(x$xvar, x$yvar))
mu <- c(mean(x$xvar), mean(x$yvar))
ed <- sqrt(qchisq(ellipse_prob, df = 2))
data.frame(sweep(circle %*% chol(sigma) * ed,
MARGIN = 2,
STATS = mu,
FUN = "+"),
groups = x$groups[1],
stringsAsFactors = FALSE)
})
ell <- do.call(rbind, df.groups)
if (NROW(ell) == 0) {
ell <- NULL
} else {
@@ -349,14 +352,9 @@ pca_calculations <- function(pca_model,
ell <- NULL
}
list(nobs.factor = nobs.factor,
d = d,
u = u,
v = v,
choices = choices,
list(choices = choices,
df.u = df.u,
df.v = df.v,
r = r,
ell = ell,
groups = groups,
group_name = group_name,

39
R/ggplot_rsi.R
View File

@@ -134,30 +134,6 @@
#' title = "AMR of Anti-UTI Drugs Per Hospital",
#' x.title = "Hospital",
#' datalabels = FALSE)
#'
#' # genuine analysis: check 3 most prevalent microorganisms
#' example_isolates %>%
#' # create new bacterial ID's, with all CoNS under the same group (Becker et al.)
#' mutate(mo = as.mo(mo, Becker = TRUE)) %>%
#' # filter on top three bacterial ID's
#' filter(mo %in% top_freq(freq(.$mo), 3)) %>%
#' # filter on first isolates
#' filter_first_isolate() %>%
#' # get short MO names (like "E. coli")
#' mutate(bug = mo_shortname(mo, Becker = TRUE)) %>%
#' # select this short name and some antiseptic drugs
#' select(bug, CXM, GEN, CIP) %>%
#' # group by MO
#' group_by(bug) %>%
#' # plot the thing, putting MOs on the facet
#' ggplot_rsi(x = "antibiotic",
#' facet = "bug",
#' translate_ab = FALSE,
#' nrow = 1,
#' title = "AMR of Top Three Microorganisms In Blood Culture Isolates",
#' subtitle = expression(paste("Only First Isolates, CoNS grouped according to Becker ",
#' italic("et al."), " (2014)")),
#' x.title = "Antibiotic (EARS-Net code)")
#' }
ggplot_rsi <- function(data,
position = NULL,
@@ -339,7 +315,6 @@ facet_rsi <- function(facet = c("interpretation", "antibiotic"), nrow = NULL) {
}
#' @rdname ggplot_rsi
#' @importFrom cleaner percentage
#' @export
scale_y_percent <- function(breaks = seq(0, 1, 0.1), limits = NULL) {
stopifnot_installed_package("ggplot2")
@@ -388,8 +363,6 @@ theme_rsi <- function() {
}
#' @rdname ggplot_rsi
#' @importFrom dplyr mutate %>% group_by_at
#' @importFrom cleaner percentage
#' @export
labels_rsi_count <- function(position = NULL,
x = "antibiotic",
@@ -415,11 +388,15 @@ labels_rsi_count <- function(position = NULL,
colour = datalabels.colour,
lineheight = 0.75,
data = function(x) {
rsi_df(data = x,
transformed <- rsi_df(data = x,
translate_ab = translate_ab,
combine_SI = combine_SI,
combine_IR = combine_IR) %>%
group_by_at(x_name) %>%
mutate(lbl = paste0("n=", isolates))
combine_IR = combine_IR)
transformed$gr <- transformed[, x_name, drop = TRUE]
transformed %>%
group_by(gr) %>%
mutate(lbl = paste0("n=", isolates)) %>%
ungroup() %>%
select(-gr)
})
}

28
R/guess_ab_col.R
View File

@@ -27,8 +27,6 @@
#' @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.**
#' @importFrom dplyr %>% select filter_all any_vars
#' @importFrom crayon blue
#' @return A column name of `x`, or `NULL` when no result is found.
#' @export
#' @inheritSection AMR Read more on our website!
@@ -103,23 +101,20 @@ guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE) {
return(NULL)
} else {
if (verbose == TRUE) {
message(blue(paste0("NOTE: Using column `", bold(ab_result), "` as input for `", search_string,
message(font_blue(paste0("NOTE: Using column `", font_bold(ab_result), "` as input for `", search_string,
"` (", ab_name(search_string, language = "en", tolower = TRUE), ").")))
}
return(ab_result)
}
}
#' @importFrom crayon blue bold
#' @importFrom dplyr %>% mutate arrange pull
get_column_abx <- function(x,
soft_dependencies = NULL,
hard_dependencies = NULL,
verbose = FALSE,
...) {
message(blue("NOTE: Auto-guessing columns suitable for analysis..."), appendLF = FALSE)
message(font_blue("NOTE: Auto-guessing columns suitable for analysis..."), appendLF = FALSE)
x <- as.data.frame(x, stringsAsFactors = FALSE)
x_bak <- x
@@ -173,15 +168,15 @@ get_column_abx <- function(x,
x <- x[order(names(x), x)]
# succeeded with aut-guessing
message(blue("OK."))
message(font_blue("OK."))
for (i in seq_len(length(x))) {
if (verbose == TRUE & !names(x[i]) %in% names(duplicates)) {
message(blue(paste0("NOTE: Using column `", bold(x[i]), "` as input for `", names(x)[i],
message(font_blue(paste0("NOTE: Using column `", font_bold(x[i]), "` as input for `", names(x)[i],
"` (", ab_name(names(x)[i], tolower = TRUE), ").")))
}
if (names(x[i]) %in% names(duplicates)) {
warning(red(paste0("Using column `", bold(x[i]), "` as input for `", names(x)[i],
warning(font_red(paste0("Using column `", font_bold(x[i]), "` as input for `", names(x)[i],
"` (", ab_name(names(x)[i], tolower = TRUE),
"), although it was matched for multiple antibiotics or columns.")),
call. = FALSE,
@@ -204,14 +199,11 @@ get_column_abx <- function(x,
if (!all(soft_dependencies %in% names(x))) {
# missing a soft dependency may lower the reliability
missing <- soft_dependencies[!soft_dependencies %in% names(x)]
missing_txt <- data.frame(missing = missing,
missing_names = ab_name(missing, tolower = TRUE),
stringsAsFactors = FALSE) %>%
mutate(txt = paste0(bold(missing), " (", missing_names, ")")) %>%
arrange(missing_names) %>%
pull(txt)
message(blue("NOTE: Reliability will be improved if these antimicrobial results would be available too:",
paste(missing_txt, collapse = ", ")))
missing_txt <- paste(paste0(ab_name(missing, tolower = TRUE, language = NULL),
" (", font_bold(missing, collapse = NULL), ")"),
collapse = ", ")
message(font_blue("NOTE: Reliability would be improved if these antimicrobial results would be available too:",
missing_txt))
}
}
x

20
R/join_microorganisms.R
View File

@@ -19,7 +19,7 @@
# Visit our website for more info: https://msberends.gitlab.io/AMR. #
# ==================================================================== #
#' Join a table with [microorganisms]
#' Join [microorganisms] to a data set
#'
#' Join the data set [microorganisms] easily to an existing table or character vector.
#' @inheritSection lifecycle Stable lifecycle
@@ -30,13 +30,16 @@
#' @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("my_genus_species" = "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 ... other parameters to pass on to [dplyr::join()]
#' @details **Note:** As opposed to the [dplyr::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. See [dplyr::join()] for more information.
#' @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.
#'
#' These functions rely on [merge()], a base R function to do joins.
#' @inheritSection AMR Read more on our website!
#' @export
#' @examples
#' left_join_microorganisms(as.mo("K. pneumoniae"))
#' left_join_microorganisms("B_KLBSL_PNE")
#'
#' \dontrun{
#' library(dplyr)
#' example_isolates %>% left_join_microorganisms()
#'
@@ -49,13 +52,14 @@
#' colnames(df)
#' df_joined <- left_join_microorganisms(df, "bacteria")
#' colnames(df_joined)
#' }
inner_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
check_dataset_integrity()
checked <- joins_check_df(x, by)
x <- checked$x
by <- checked$by
join <- suppressWarnings(
dplyr::inner_join(x = x, y = microorganisms, by = by, suffix = suffix, ...)
inner_join(x = x, y = microorganisms, by = by, suffix = suffix, ...)
)
if (NROW(join) > NROW(x)) {
warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
@@ -71,7 +75,7 @@ left_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
x <- checked$x
by <- checked$by
join <- suppressWarnings(
dplyr::left_join(x = x, y = microorganisms, by = by, suffix = suffix, ...)
left_join(x = x, y = microorganisms, by = by, suffix = suffix, ...)
)
if (NROW(join) > NROW(x)) {
warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
@@ -87,7 +91,7 @@ right_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
x <- checked$x
by <- checked$by
join <- suppressWarnings(
dplyr::right_join(x = x, y = microorganisms, by = by, suffix = suffix, ...)
right_join(x = x, y = microorganisms, by = by, suffix = suffix, ...)
)
if (NROW(join) > NROW(x)) {
warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
@@ -103,7 +107,7 @@ full_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
x <- checked$x
by <- checked$by
join <- suppressWarnings(
dplyr::full_join(x = x, y = microorganisms, by = by, suffix = suffix, ...)
full_join(x = x, y = microorganisms, by = by, suffix = suffix, ...)
)
if (NROW(join) > NROW(x)) {
warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
@@ -119,7 +123,7 @@ semi_join_microorganisms <- function(x, by = NULL, ...) {
x <- checked$x
by <- checked$by
suppressWarnings(
dplyr::semi_join(x = x, y = microorganisms, by = by, ...)
semi_join(x = x, y = microorganisms, by = by, ...)
)
}
@@ -131,7 +135,7 @@ anti_join_microorganisms <- function(x, by = NULL, ...) {
x <- checked$x
by <- checked$by
suppressWarnings(
dplyr::anti_join(x = x, y = microorganisms, by = by, ...)
anti_join(x = x, y = microorganisms, by = by, ...)
)
}

72
R/key_antibiotics.R
View File

@@ -31,7 +31,9 @@
#' @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 (`"."`). The [first_isolate()] function only uses this function on the same microbial species from the same patient. Using this, an MRSA will be included after a susceptible *S. aureus* (MSSA) found within the same episode (see `episode` parameter of [first_isolate()]). Without key antibiotic comparison it would not.
#' @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()].
#'
#' 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.
#'
#' At default, the antibiotics that are used for **Gram-positive bacteria** are:
#' - Amoxicillin
@@ -65,8 +67,6 @@
#' @inheritSection first_isolate Key antibiotics
#' @rdname key_antibiotics
#' @export
#' @importFrom dplyr %>% mutate if_else pull
#' @importFrom crayon blue bold
#' @seealso [first_isolate()]
#' @inheritSection AMR Read more on our website!
#' @examples
@@ -120,6 +120,15 @@ key_antibiotics <- function(x,
GramNeg_6 = guess_ab_col(x, "meropenem"),
warnings = TRUE,
...) {
dots <- unlist(list(...))
if (length(dots) != 0) {
# backwards compatibility with old parameters
dots.names <- dots %>% names()
if ("info" %in% dots.names) {
warnings <- dots[which(dots.names == "info")]
}
}
# try to find columns based on type
# -- mo
@@ -134,7 +143,7 @@ key_antibiotics <- function(x,
col.list <- c(universal_1, universal_2, universal_3, universal_4, universal_5, universal_6,
GramPos_1, GramPos_2, GramPos_3, GramPos_4, GramPos_5, GramPos_6,
GramNeg_1, GramNeg_2, GramNeg_3, GramNeg_4, GramNeg_5, GramNeg_6)
check_available_columns <- function(x, col.list, info = TRUE) {
check_available_columns <- function(x, col.list, warnings = TRUE) {
# check columns
col.list <- col.list[!is.na(col.list) & !is.null(col.list)]
names(col.list) <- col.list
@@ -152,7 +161,7 @@ key_antibiotics <- function(x,
}
}
if (!all(col.list %in% colnames(x))) {
if (info == TRUE) {
if (warnings == TRUE) {
warning("Some columns do not exist and will be ignored: ",
col.list.bak[!(col.list %in% colnames(x))] %>% toString(),
".\nTHIS MAY STRONGLY INFLUENCE THE OUTCOME.",
@@ -163,7 +172,7 @@ key_antibiotics <- function(x,
col.list
}
col.list <- check_available_columns(x = x, col.list = col.list, info = warnings)
col.list <- check_available_columns(x = x, col.list = col.list, warnings = warnings)
universal_1 <- col.list[universal_1]
universal_2 <- col.list[universal_2]
universal_3 <- col.list[universal_3]
@@ -205,37 +214,34 @@ key_antibiotics <- function(x,
}
# join to microorganisms data set
x <- x %>%
as.data.frame(stringsAsFactors = FALSE) %>%
mutate_at(vars(col_mo), as.mo) %>%
left_join_microorganisms(by = col_mo) %>%
mutate(key_ab = NA_character_,
gramstain = mo_gramstain(pull(., col_mo), language = NULL))
x <- x %>% as.data.frame(stringsAsFactors = FALSE)
x[, col_mo] <- as.mo(x[, col_mo, drop = TRUE])
x$gramstain <- mo_gramstain(x[, col_mo, drop = TRUE], language = NULL)
x$key_ab <- NA_character_
# mutate_at(vars(col_mo), as.mo) %>%
# left_join_microorganisms(by = col_mo) %>%
# mutate(key_ab = NA_character_,
# gramstain = mo_gramstain(pull(., col_mo), language = NULL))
#
# Gram +
x <- x %>% mutate(key_ab =
if_else(gramstain == "Gram-positive",
tryCatch(apply(X = x[, gram_positive],
MARGIN = 1,
FUN = function(x) paste(x, collapse = "")),
error = function(e) paste0(rep(".", 12), collapse = "")),
key_ab))
x$key_ab <- if_else(x$gramstain == "Gram-positive",
tryCatch(apply(X = x[, gram_positive],
MARGIN = 1,
FUN = function(x) paste(x, collapse = "")),
error = function(e) paste0(rep(".", 12), collapse = "")),
x$key_ab)
# Gram -
x <- x %>% mutate(key_ab =
if_else(gramstain == "Gram-negative",
tryCatch(apply(X = x[, gram_negative],
MARGIN = 1,
FUN = function(x) paste(x, collapse = "")),
error = function(e) paste0(rep(".", 12), collapse = "")),
key_ab))
x$key_ab <- if_else(x$gramstain == "Gram-negative",
tryCatch(apply(X = x[, gram_negative],
MARGIN = 1,
FUN = function(x) paste(x, collapse = "")),
error = function(e) paste0(rep(".", 12), collapse = "")),
x$key_ab)
# format
key_abs <- x %>%
pull(key_ab) %>%
gsub("(NA|NULL)", ".", .) %>%
gsub("[^SIR]", ".", ., ignore.case = TRUE) %>%
toupper()
key_abs <- toupper(gsub("[^SIR]", ".", gsub("(NA|NULL)", ".", x$key_ab)))
if (n_distinct(key_abs) == 1) {
warning("No distinct key antibiotics determined.", call. = FALSE)
@@ -245,7 +251,6 @@ key_antibiotics <- function(x,
}
#' @importFrom dplyr %>%
#' @rdname key_antibiotics
#' @export
key_antibiotics_equal <- function(y,
@@ -271,12 +276,13 @@ key_antibiotics_equal <- function(y,
if (info_needed == TRUE) {
p <- progress_estimated(length(x))
on.exit(close(p))
}
for (i in seq_len(length(x))) {
if (info_needed == TRUE) {
p$tick()$print()
p$tick()
}
if (is.na(x[i])) {

37
R/like.R
View File

@@ -30,10 +30,15 @@
#' @name like
#' @rdname like
#' @export
#' @details When running a regular expression fails, these functions try again with `base::grepl(..., perl = TRUE)`.
#' @details
#' The `%like%` function:
#' * Is case insensitive (use `%like_case%` for case-sensitive matching)
#' * Supports multiple patterns
#' * 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...`).
#' @source Idea from the [`like` function from the `data.table` package](https://github.com/Rdatatable/data.table/blob/master/R/like.R), but made it case insensitive at default and let it support multiple patterns. Also, if the regex fails the first time, it tries again with `perl = TRUE`.
#' @source Idea from the [`like` function from the `data.table` package](https://github.com/Rdatatable/data.table/blob/master/R/like.R)
#' @seealso [base::grep()]
#' @inheritSection AMR Read more on our website!
#' @examples
@@ -51,19 +56,27 @@
#' a %like% b
#' #> TRUE TRUE TRUE
#'
#' # get frequencies of bacteria whose name start with 'Ent' or 'ent'
#' # get isolates whose name start with 'Ent' or 'ent'
#' library(dplyr)
#' example_isolates %>%
#' filter(mo_name(mo) %like% "^ent") %>%
#' freq(mo_genus(mo))
#' filter(mo_name(mo) %like% "^ent") %>%
#' freq(mo)
like <- function(x, pattern, ignore.case = TRUE) {
# set to fixed if no regex found
fixed <- all(!grepl("[$.^*?+}{|)(]", pattern))
if (ignore.case == TRUE) {
# set here, otherwise if fixed = TRUE, this warning will be thrown: argument 'ignore.case = TRUE' will be ignored
x <- tolower(x)
pattern <- tolower(pattern)
}
if (length(pattern) > 1) {
if (length(x) != length(pattern)) {
if (length(x) == 1) {
x <- rep(x, length(pattern))
}
# return TRUE for every 'x' that matches any 'pattern', FALSE otherwise
res <- sapply(pattern, function(pttrn) base::grepl(pttrn, x, ignore.case = ignore.case))
res <- sapply(pattern, function(pttrn) base::grepl(pttrn, x, ignore.case = FALSE, fixed = fixed))
res2 <- as.logical(rowSums(res))
# get only first item of every hit in pattern
res2[duplicated(res)] <- FALSE
@@ -74,9 +87,9 @@ like <- function(x, pattern, ignore.case = TRUE) {
res <- vector(length = length(pattern))
for (i in seq_len(length(res))) {
if (is.factor(x[i])) {
res[i] <- as.integer(x[i]) %in% base::grep(pattern[i], levels(x[i]), ignore.case = ignore.case)
res[i] <- as.integer(x[i]) %in% base::grep(pattern[i], levels(x[i]), ignore.case = FALSE, fixed = fixed)
} else {
res[i] <- base::grepl(pattern[i], x[i], ignore.case = ignore.case)
res[i] <- base::grepl(pattern[i], x[i], ignore.case = FALSE, fixed = fixed)
}
}
return(res)
@@ -85,13 +98,15 @@ like <- function(x, pattern, ignore.case = TRUE) {
# the regular way how grepl works; just one pattern against one or more x
if (is.factor(x)) {
as.integer(x) %in% base::grep(pattern, levels(x), ignore.case = ignore.case)
as.integer(x) %in% base::grep(pattern, levels(x), ignore.case = FALSE, fixed = fixed)
} else {
tryCatch(base::grepl(pattern, x, ignore.case = ignore.case),
tryCatch(base::grepl(pattern, x, ignore.case = FALSE, fixed = fixed),
error = function(e) ifelse(grepl("Invalid regexp", e$message),
# try with perl = TRUE:
return(base::grepl(pattern = pattern, x = x,
ignore.case = ignore.case, perl = TRUE)),
ignore.case = FALSE,
fixed = fixed,
perl = TRUE)),
# stop otherwise
stop(e$message)))
}

209
R/mdro.R
View File

@@ -61,9 +61,6 @@
#' Ordered [`factor`] with levels `Negative` < `Positive, unconfirmed` < `Positive`. The value `"Positive, unconfirmed"` means that, according to the guideline, it is not entirely sure if the isolate is multi-drug resistant and this should be confirmed with additional (e.g. molecular) tests
#' @rdname mdro
#' @aliases MDR XDR PDR BRMO 3MRGN 4MRGN
#' @importFrom dplyr %>% filter_at vars all_vars pull mutate_at
#' @importFrom crayon blue bold italic red
#' @importFrom cleaner percentage
#' @export
#' @inheritSection AMR Read more on our website!
#' @source
@@ -99,7 +96,7 @@ mdro <- function(x,
if ("rstudioapi" %in% rownames(utils::installed.packages())) {
q_continue <- rstudioapi::showQuestion("Using verbose = TRUE with mdro()", txt)
} else {
q_continue <- menu(choices = c("OK", "Cancel"), graphics = TRUE, title = txt)
q_continue <- utils::menu(choices = c("OK", "Cancel"), graphics = FALSE, title = txt)
}
if (q_continue %in% c(FALSE, 2)) {
message("Cancelled, returning original data")
@@ -110,6 +107,9 @@ mdro <- function(x,
if (!is.data.frame(x)) {
stop("`x` must be a data frame.", call. = FALSE)
}
# force regular data.frame, not a tibble or data.table
x <- as.data.frame(x, stringsAsFactors = FALSE)
if (!is.numeric(pct_required_classes)) {
stop("`pct_required_classes` must be numeric.", call. = FALSE)
}
@@ -147,8 +147,8 @@ mdro <- function(x,
col_mo <- search_type_in_df(x = x, type = "mo")
}
if (is.null(col_mo) & guideline$code == "tb") {
message(blue("NOTE: No column found as input for `col_mo`,",
bold("assuming all records contain", italic("Mycobacterium tuberculosis.\n"))))
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"
}
@@ -418,7 +418,7 @@ mdro <- function(x,
if (guideline$code == "tb" & length(abx_tb) == 0) {
stop("No antimycobacterials found in data set.", call. = FALSE)
}
if (combine_SI == TRUE) {
search_result <- "R"
} else {
@@ -427,15 +427,15 @@ mdro <- function(x,
if (info == TRUE) {
if (combine_SI == TRUE) {
cat(red("\nOnly results with 'R' are considered as resistance. Use `combine_SI = FALSE` to also consider 'I' as resistance.\n"))
cat(font_red("\nOnly results with 'R' are considered as resistance. Use `combine_SI = FALSE` to also consider 'I' as resistance.\n"))
} else {
cat(red("\nResults with 'R' or 'I' are considered as resistance. Use `combine_SI = TRUE` to only consider 'R' as resistance.\n"))
cat(font_red("\nResults with 'R' or 'I' are considered as resistance. Use `combine_SI = TRUE` to only consider 'R' as resistance.\n"))
}
cat("\nDetermining multidrug-resistant organisms (MDRO), according to:\n",
bold("Guideline: "), italic(guideline$name), "\n",
bold("Version: "), guideline$version, "\n",
bold("Author: "), guideline$author, "\n",
bold("Source: "), guideline$source, "\n",
font_bold("Guideline: "), font_italic(guideline$name), "\n",
font_bold("Version: "), guideline$version, "\n",
font_bold("Author: "), guideline$author, "\n",
font_bold("Source: "), guideline$source, "\n",
"\n", sep = "")
}
@@ -460,7 +460,7 @@ mdro <- function(x,
cols <- cols[!ab_missing(cols)]
cols <- cols[!is.na(cols)]
if (length(rows) > 0 & length(cols) > 0) {
x <<- x %>% mutate_at(vars(cols), as.rsi)
x[, cols] <- as.data.frame(lapply(x[, cols, drop = FALSE], function(col) as.rsi(col)))
x[rows, "columns_nonsusceptible"] <<- sapply(rows,
function(row, group_vct = cols) {
cols_nonsus <- sapply(x[row, group_vct, drop = FALSE],
@@ -471,13 +471,14 @@ mdro <- function(x,
})
if (any_all == "any") {
search_function <- dplyr::any_vars
search_function <- any
} else if (any_all == "all") {
search_function <- dplyr::all_vars
search_function <- all
}
row_filter <- x %>%
filter_at(vars(cols), search_function(. %in% search_result)) %>%
pull("row_number")
row_filter <- as.logical(by(x,
seq_len(nrow(x)),
function(row) search_function(unlist(row[, cols]) %in% search_result, na.rm = TRUE)))
row_filter <- x[row_filter, "row_number", drop = TRUE]
rows <- rows[rows %in% row_filter]
x[rows, "MDRO"] <<- to
x[rows, "reason"] <<- paste0(any_all, " of the required antibiotics ", ifelse(any_all == "any", "is", "are"), " R")
@@ -485,12 +486,12 @@ mdro <- function(x,
}
trans_tbl2 <- function(txt, rows, lst) {
if (info == TRUE) {
message(blue(txt, "..."), appendLF = FALSE)
message(font_blue(txt, "..."), appendLF = 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 <<- x %>% mutate_at(vars(lst_vector), as.rsi)
x[, lst_vector] <- as.data.frame(lapply(x[, lst_vector, drop = FALSE], function(col) as.rsi(col)))
x[rows, "classes_in_guideline"] <<- length(lst)
x[rows, "classes_available"] <<- sapply(rows,
function(row, group_tbl = lst) {
@@ -513,28 +514,25 @@ mdro <- function(x,
na.rm = TRUE)
})
# for PDR; all agents are R (or I if combine_SI = FALSE)
x[filter_at(x[rows, ],
vars(lst_vector),
all_vars(. %in% search_result))$row_number, "classes_affected"] <<- 999
row_filter <- as.logical(by(x[rows, ],
seq_len(nrow(x[rows, ])),
function(row) all(unlist(row[, lst_vector]) %in% search_result, na.rm = TRUE)))
x[row_filter, "classes_affected"] <<- 999
}
if (info == TRUE) {
message(blue(" OK"))
message(font_blue(" OK"))
}
}
x <- x %>%
mutate_at(vars(col_mo), as.mo) %>%
# join to microorganisms data set
left_join_microorganisms(by = col_mo) %>%
# add unavailable to where genus is available
mutate(MDRO = ifelse(!is.na(genus), 1, NA_integer_),
row_number = seq_len(nrow(.)),
reason = paste0("not covered by ", toupper(guideline$code), " guideline"),
columns_nonsusceptible = "") %>%
# transform to data.frame so subsetting is possible with x[y, z] (might not be the case with tibble/data.table/...)
as.data.frame(stringsAsFactors = FALSE)
x[, col_mo] <- as.mo(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_)
x$row_number <- seq_len(nrow(x))
x$reason <- paste0("not covered by ", toupper(guideline$code), " guideline")
x$columns_nonsusceptible <- ""
if (guideline$code == "cmi2012") {
# CMI, 2012 ---------------------------------------------------------------
# Non-susceptible = R and I
@@ -543,20 +541,20 @@ mdro <- function(x,
# take amoxicillin if ampicillin is unavailable
if (is.na(AMP) & !is.na(AMX)) {
if (verbose == TRUE) {
message(blue("NOTE: Filling ampicillin (AMP) results with amoxicillin (AMX) results"))
message(font_blue("NOTE: 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(blue("NOTE: Filling ceftriaxone (CRO) results with cefotaxime (CTX) results"))
message(font_blue("NOTE: Filling ceftriaxone (CRO) results with cefotaxime (CTX) results"))
}
CRO <- CTX
}
if (is.na(CTX) & !is.na(CRO)) {
if (verbose == TRUE) {
message(blue("NOTE: Filling cefotaxime (CTX) results with ceftriaxone (CRO) results"))
message(font_blue("NOTE: Filling cefotaxime (CTX) results with ceftriaxone (CRO) results"))
}
CTX <- CRO
}
@@ -642,7 +640,7 @@ mdro <- function(x,
which(x$genus == "Staphylococcus" & x$species == "aureus"),
c(OXA, FOX),
"any")
trans_tbl2(paste("Table 1 -", italic("Staphylococcus aureus")),
trans_tbl2(paste("Table 1 -", font_italic("Staphylococcus aureus")),
which(x$genus == "Staphylococcus" & x$species == "aureus"),
list(GEN,
RIF,
@@ -661,7 +659,7 @@ mdro <- function(x,
FOS,
QDA,
c(TCY, DOX, MNO)))
trans_tbl2(paste("Table 2 -", italic("Enterococcus"), "spp."),
trans_tbl2(paste("Table 2 -", font_italic("Enterococcus"), "spp."),
which(x$genus == "Enterococcus"),
list(GEH,
STH,
@@ -674,7 +672,7 @@ mdro <- function(x,
AMP,
QDA,
c(DOX, MNO)))
trans_tbl2(paste0("Table 3 - ", italic("Enterobacteriaceae")),
trans_tbl2(paste0("Table 3 - ", font_italic("Enterobacteriaceae")),
# this new order was previously 'Enterobacteriales' and contained only the family 'Enterobacteriaceae':
which(x$order == "Enterobacterales"),
list(c(GEN, TOB, AMK, NET),
@@ -695,7 +693,7 @@ mdro <- function(x,
FOS,
COL,
c(TCY, DOX, MNO)))
trans_tbl2(paste("Table 4 -", italic("Pseudomonas aeruginosa")),
trans_tbl2(paste("Table 4 -", font_italic("Pseudomonas aeruginosa")),
which(x$genus == "Pseudomonas" & x$species == "aeruginosa"),
list(c(GEN, TOB, AMK, NET),
c(IPM, MEM, DOR),
@@ -705,7 +703,7 @@ mdro <- function(x,
ATM,
FOS,
c(COL, PLB)))
trans_tbl2(paste("Table 5 -", italic("Acinetobacter"), "spp."),
trans_tbl2(paste("Table 5 -", font_italic("Acinetobacter"), "spp."),
which(x$genus == "Acinetobacter"),
list(c(GEN, TOB, AMK, NET),
c(IPM, MEM, DOR),
@@ -941,70 +939,73 @@ mdro <- function(x,
"all")
}
prepare_drug <- function(ab) {
# returns vector values of drug
# if `ab` is a column name, looks up the values in `x`
if (length(ab) == 1 & is.character(ab)) {
if (ab %in% colnames(x)) {
ab <- as.data.frame(x)[, ab]
}
}
ab <- as.character(as.rsi(ab))
ab[is.na(ab)] <- ""
ab
}
drug_is_R <- function(ab) {
# returns logical vector
ab <- prepare_drug(ab)
if (length(ab) == 1) {
rep(ab, NROW(x)) == "R"
} else {
ab == "R"
}
}
drug_is_not_R <- function(ab) {
# returns logical vector
ab <- prepare_drug(ab)
if (length(ab) == 1) {
rep(ab, NROW(x)) != "R"
} else {
ab != "R"
}
}
if (guideline$code == "tb") {
# Tuberculosis ------------------------------------------------------------
x <- x %>%
mutate(mono_count = 0,
mono_count = ifelse(drug_is_R(INH), mono_count + 1, mono_count),
mono_count = ifelse(drug_is_R(RIF), mono_count + 1, mono_count),
mono_count = ifelse(drug_is_R(ETH), mono_count + 1, mono_count),
mono_count = ifelse(drug_is_R(PZA), mono_count + 1, mono_count),
mono_count = ifelse(drug_is_R(RIB), mono_count + 1, mono_count),
mono_count = ifelse(drug_is_R(RFP), mono_count + 1, mono_count),
# from here on logicals
mono = mono_count > 0,
poly = ifelse(mono_count > 1 & drug_is_not_R(RIF) & drug_is_not_R(INH),
TRUE, FALSE),
mdr = ifelse(drug_is_R(RIF) & drug_is_R(INH),
TRUE, FALSE),
xdr = ifelse(drug_is_R(LVX) | drug_is_R(MFX) | drug_is_R(GAT),
TRUE, FALSE),
second = ifelse(drug_is_R(CAP) | drug_is_R(KAN) | drug_is_R(AMK),
TRUE, FALSE),
xdr = ifelse(mdr & xdr & second, TRUE, FALSE)) %>%
mutate(MDRO = case_when(xdr ~ 5,
mdr ~ 4,
poly ~ 3,
mono ~ 2,
TRUE ~ 1),
# keep all real TB, make other species NA
MDRO = ifelse(x$fullname == "Mycobacterium tuberculosis", MDRO, NA_real_))
prepare_drug <- function(ab) {
# returns vector values of drug
# if `ab` is a column name, looks up the values in `x`
if (length(ab) == 1 & is.character(ab)) {
if (ab %in% colnames(x)) {
ab <- x[, ab, drop = TRUE]
}
}
ab <- as.character(as.rsi(ab))
ab[is.na(ab)] <- ""
ab
}
drug_is_R <- function(ab) {
# returns logical vector
ab <- prepare_drug(ab)
if (length(ab) == 0) {
rep(FALSE, NROW(x))
} else if (length(ab) == 1) {
rep(ab, NROW(x)) == "R"
} else {
ab == "R"
}
}
drug_is_not_R <- function(ab) {
# returns logical vector
ab <- prepare_drug(ab)
if (length(ab) == 0) {
rep(TRUE, NROW(x))
} else if (length(ab) == 1) {
rep(ab, NROW(x)) != "R"
} else {
ab != "R"
}
}
x$mono_count <- 0
x[drug_is_R(INH), "mono_count"] <- x[drug_is_R(INH), "mono_count"] + 1
x[drug_is_R(RIF), "mono_count"] <- x[drug_is_R(RIF), "mono_count"] + 1
x[drug_is_R(ETH), "mono_count"] <- x[drug_is_R(ETH), "mono_count"] + 1
x[drug_is_R(PZA), "mono_count"] <- x[drug_is_R(PZA), "mono_count"] + 1
x[drug_is_R(RIB), "mono_count"] <- x[drug_is_R(RIB), "mono_count"] + 1
x[drug_is_R(RFP), "mono_count"] <- x[drug_is_R(RFP), "mono_count"] + 1
x$mono <- x$mono_count > 0
x$poly <- x$mono_count > 1 & drug_is_not_R(RIF) & drug_is_not_R(INH)
x$mdr <- drug_is_R(RIF) & drug_is_R(INH)
x$xdr <- drug_is_R(LVX) | drug_is_R(MFX) | drug_is_R(GAT)
x$second <- drug_is_R(CAP) | drug_is_R(KAN) | drug_is_R(AMK)
x$xdr <- x$mdr & x$xdr & x$second
x$MDRO <- ifelse(x$xdr, 5,
ifelse(x$mdr, 4,
ifelse(x$poly, 3,
ifelse(x$mono, 2,
1))))
# keep all real TB, make other species NA
x$MDRO <- ifelse(x$fullname == "Mycobacterium tuberculosis", x$MDRO, NA_real_)
}
if (info == TRUE) {
cat(bold(paste0("=> Found ", sum(x$MDRO %in% c(2:5), na.rm = TRUE), " MDROs out of ", sum(!is.na(x$MDRO)),
" tested isolates (", percentage(sum(x$MDRO %in% c(2:5), na.rm = TRUE) / sum(!is.na(x$MDRO))), ")\n")))
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)),
" isolates (", trimws(percentage(sum(x$MDRO %in% c(2:5), na.rm = TRUE) / sum(!is.na(x$MDRO)))), ")\n")))
}
}
# some more info on negative results

7
R/mic.R
View File

@@ -30,7 +30,6 @@
#' @return Ordered [`factor`] with new class [`mic`]
#' @aliases mic
#' @export
#' @importFrom dplyr %>%
#' @seealso [as.rsi()]
#' @inheritSection AMR Read more on our website!
#' @examples
@@ -52,7 +51,6 @@
#'
#' plot(mic_data)
#' barplot(mic_data)
#' freq(mic_data)
as.mic <- function(x, na.rm = FALSE) {
if (is.mic(x)) {
x
@@ -138,7 +136,6 @@ all_valid_mics <- function(x) {
#' @rdname as.mic
#' @export
#' @importFrom dplyr %>%
is.mic <- function(x) {
inherits(x, "mic")
}
@@ -175,7 +172,6 @@ droplevels.mic <- function(x, exclude = ifelse(anyNA(levels(x)), NULL, NA), ...)
#' @exportMethod print.mic
#' @export
#' @importFrom dplyr %>% tibble group_by summarise pull
#' @noRd
print.mic <- function(x, ...) {
cat("Class 'mic'\n")
@@ -184,7 +180,6 @@ print.mic <- function(x, ...) {
#' @exportMethod summary.mic
#' @export
#' @importFrom dplyr %>%
#' @noRd
summary.mic <- function(object, ...) {
x <- object
@@ -241,7 +236,7 @@ barplot.mic <- function(height,
#' @export
pillar_shaft.mic <- function(x, ...) {
out <- trimws(format(x))
out[is.na(x)] <- pillar::style_na(NA)
out[is.na(x)] <- font_red(NA)
pillar::new_pillar_shaft_simple(out, align = "right", min_width = 4)
}

1101
R/mo.R
View File

File diff suppressed because it is too large Load Diff

31
R/mo_property.R
View File

@@ -358,30 +358,32 @@ mo_info <- function(x, language = get_locale(), ...) {
}
#' @rdname mo_property
#' @importFrom utils browseURL
#' @importFrom dplyr %>% left_join select mutate case_when
#' @export
mo_url <- function(x, open = FALSE, ...) {
mo <- as.mo(x = x, ... = ...)
mo_names <- mo_name(mo)
metadata <- get_mo_failures_uncertainties_renamed()
df <- data.frame(mo, stringsAsFactors = FALSE) %>%
left_join(select(microorganisms, mo, source, species_id), by = "mo") %>%
mutate(url = case_when(source == "CoL" ~
paste0(gsub("{year}", catalogue_of_life$year, catalogue_of_life$url_CoL, fixed = TRUE), "details/species/id/", species_id),
source == "DSMZ" ~
paste0(catalogue_of_life$url_DSMZ, "/", unlist(lapply(strsplit(mo_names, ""), function(x) x[1]))),
TRUE ~
NA_character_))
left_join(select(microorganisms, mo, source, species_id), by = "mo")
df$url <- ifelse(df$source == "CoL",
paste0(gsub("{year}",
catalogue_of_life$year,
catalogue_of_life$url_CoL,
fixed = TRUE),
"details/species/id/",
df$species_id),
ifelse(df$source == "DSMZ",
paste0(catalogue_of_life$url_DSMZ, "/", unlist(lapply(strsplit(mo_names, ""), function(x) x[1]))),
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.")
}
browseURL(u[1L])
utils::browseURL(u[1L])
}
load_mo_failures_uncertainties_renamed(metadata)
@@ -390,7 +392,6 @@ mo_url <- function(x, open = FALSE, ...) {
#' @rdname mo_property
#' @importFrom data.table data.table as.data.table setkey
#' @export
mo_property <- function(x, property = "fullname", language = get_locale(), ...) {
if (length(property) != 1L) {
@@ -419,7 +420,7 @@ mo_validate <- function(x, property, ...) {
# try to catch an error when inputting an invalid parameter
# so the 'call.' can be set to FALSE
tryCatch(x[1L] %in% microorganisms[1, property],
tryCatch(x[1L] %in% MO_lookup[1, property, drop = TRUE],
error = function(e) stop(e$message, call. = FALSE))
if (is.mo(x)
@@ -428,7 +429,7 @@ mo_validate <- function(x, property, ...) {
# this will not reset mo_uncertainties and mo_failures
# because it's already a valid MO
x <- exec_as.mo(x, property = property, initial_search = FALSE, ...)
} else if (!all(x %in% pull(microorganisms, property))
} else if (!all(x %in% MO_lookup[, property, drop = TRUE])
| Becker %in% c(TRUE, "all")
| Lancefield %in% c(TRUE, "all")) {
x <- exec_as.mo(x, property = property, ...)

48
R/mo_source.R
View File

@@ -96,7 +96,6 @@
#' set_mo_source(NULL)
#' # Removed mo_source file '~/.mo_source.rds'.
#' ```
#' @importFrom dplyr select everything
#' @export
#' @inheritSection AMR Read more on our website!
set_mo_source <- function(path) {
@@ -137,13 +136,13 @@ set_mo_source <- function(path) {
try(
df <- utils::read.table(header = TRUE, sep = ",", stringsAsFactors = FALSE),
silent = TRUE)
if (!mo_source_isvalid(df)) {
if (!mo_source_isvalid(df, stop_on_error = FALSE)) {
# try tab
try(
df <- utils::read.table(header = TRUE, sep = "\t", stringsAsFactors = FALSE),
silent = TRUE)
}
if (!mo_source_isvalid(df)) {
if (!mo_source_isvalid(df, stop_on_error = FALSE)) {
# try pipe
try(
df <- utils::read.table(header = TRUE, sep = "|", stringsAsFactors = FALSE),
@@ -151,9 +150,8 @@ set_mo_source <- function(path) {
}
}
if (!mo_source_isvalid(df)) {
stop("File must contain a column with self-defined values and a reference column `mo` with valid values from the `microorganisms` data set.")
}
# check integrity
mo_source_isvalid(df)
df <- df %>% filter(!is.na(mo))
@@ -201,7 +199,7 @@ get_mo_source <- function() {
}
}
mo_source_isvalid <- function(x) {
mo_source_isvalid <- function(x, refer_to_name = "`reference_df`", stop_on_error = TRUE) {
check_dataset_integrity()
@@ -212,13 +210,41 @@ mo_source_isvalid <- function(x) {
return(TRUE)
}
if (is.null(x)) {
return(TRUE)
if (stop_on_error == TRUE) {
stop(refer_to_name, " cannot be NULL.", call. = FALSE)
} else {
return(FALSE)
}
}
if (!is.data.frame(x)) {
return(FALSE)
if (stop_on_error == TRUE) {
stop(refer_to_name, " must be a data.frame.", call. = FALSE)
} else {
return(FALSE)
}
}
if (!"mo" %in% colnames(x)) {
return(FALSE)
if (stop_on_error == TRUE) {
stop(refer_to_name, " must contain a column 'mo'.", call. = FALSE)
} else {
return(FALSE)
}
}
all(x$mo %in% c("", microorganisms$mo, microorganisms.translation$mo_old), na.rm = TRUE)
if (!all(x$mo %in% c("", microorganisms$mo, microorganisms.translation$mo_old), na.rm = TRUE)) {
if (stop_on_error == TRUE) {
invalid <- x[which(!x$mo %in% c("", microorganisms$mo, microorganisms.translation$mo_old)), , drop = FALSE]
if (nrow(invalid) > 1) {
plural <- "s"
} else {
plural <- ""
}
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)
} else {
return(FALSE)
}
}
TRUE
}

39
R/pca.R
View File

@@ -24,20 +24,19 @@
#' Performs a principal component analysis (PCA) based on a data set with automatic determination for afterwards plotting the groups and labels, and automatic filtering on only suitable (i.e. non-empty and numeric) variables.
#' @inheritSection lifecycle Maturing lifecycle
#' @param x a [data.frame] containing numeric columns
#' @param ... columns of `x` to be selected for PCA
#' @param ... columns of `x` to be selected for PCA, can be unquoted since it supports quasiquotation.
#' @inheritParams stats::prcomp
#' @details The [pca()] function takes a [data.frame] as input and performs the actual PCA with the \R function [prcomp()].
#'
#' The result of the [pca()] function is a [prcomp] object, with an additional attribute `non_numeric_cols` which is a vector with the column names of all columns that do not contain numeric values. These are probably the groups and labels, and will be used by [ggplot_pca()].
#' @return An object of classes [pca] and [prcomp]
#' @importFrom stats prcomp
#' @importFrom dplyr ungroup %>% filter_all all_vars
#' @importFrom rlang enquos eval_tidy
#' @export
#' @examples
#' # `example_isolates` is a dataset available in the AMR package.
#' # See ?example_isolates.
#'
#' \dontrun{
#' # calculate the resistance per group first
#' library(dplyr)
#' resistance_data <- example_isolates %>%
@@ -53,6 +52,7 @@
#' summary(pca_result)
#' biplot(pca_result)
#' ggplot_pca(pca_result) # a new and convenient plot function
#' }
pca <- function(x,
...,
retx = TRUE,
@@ -70,47 +70,46 @@ pca <- function(x,
x <- as.data.frame(x, stringsAsFactors = FALSE)
x.bak <- x
user_exprs <- enquos(...)
if (length(user_exprs) > 0) {
# defuse R expressions, this replaces rlang::enquos()
dots <- substitute(list(...))
if (length(dots) > 1) {
new_list <- list(0)
for (i in seq_len(length(user_exprs))) {
new_list[[i]] <- tryCatch(eval_tidy(user_exprs[[i]], data = x),
for (i in seq_len(length(dots) - 1)) {
new_list[[i]] <- tryCatch(eval(dots[[i + 1]], envir = x),
error = function(e) stop(e$message, call. = FALSE))
if (length(new_list[[i]]) == 1) {
if (i == 1) {
# only for first item:
if (is.character(new_list[[i]]) & new_list[[i]] %in% colnames(x)) {
# this is to support: df %>% pca("mycol")
new_list[[i]] <- x[, new_list[[i]]]
}
if (is.character(new_list[[i]]) & new_list[[i]] %in% colnames(x)) {
# this is to support quoted variables: df %>% pca("mycol1", "mycol2")
new_list[[i]] <- x[, new_list[[i]]]
} else {
# remove item - it's a parameter like `center`
new_list[[i]] <- NULL
}
}
}
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.")
}
# set column names
tryCatch(colnames(x) <- sapply(user_exprs, function(y) as_label(y)),
tryCatch(colnames(x) <- as.character(dots)[2:length(dots)],
error = function(e) warning("column names could not be set"))
# keep only numeric columns
x <- x[, sapply(x, function(y) is.numeric(y))]
# bind the data set with the non-numeric columns
x <- cbind(x.bak[, sapply(x.bak, function(y) !is.numeric(y) & !all(is.na(y))), drop = FALSE], x)
}
x <- x %>%
ungroup() %>% # would otherwise select the grouping vars
filter_all(all_vars(!is.na(.)))
x <- 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(blue(paste0("NOTE: Columns selected for PCA: ", paste0(bold(colnames(pca_data)), collapse = "/"),
".\n Total observations available: ", nrow(pca_data), ".")))
message(font_blue(paste0("NOTE: Columns selected for PCA: ", paste0(font_bold(colnames(pca_data)), collapse = "/"),
".\n 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]

142
R/progress_estimated.R
View File

@@ -1,142 +0,0 @@
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Analysis #
# #
# SOURCE #
# https://gitlab.com/msberends/AMR #
# #
# LICENCE #
# (c) 2018-2020 Berends MS, Luz CF et al. #
# #
# 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 more info: https://msberends.gitlab.io/AMR. #
# ==================================================================== #
# taken from https://github.com/tidyverse/dplyr/blob/f306d8da8f27c2e6abbd3c70f219fef7ca61fbb5/R/progress.R
# when it was still in the dplyr package
progress_estimated <- function(n, min_time = 0) {
Progress$new(n, min_time = min_time)
}
#' @importFrom R6 R6Class
Progress <- R6::R6Class("Progress",
public = list(
n = NULL,
i = 0,
init_time = NULL,
stopped = FALSE,
stop_time = NULL,
min_time = NULL,
last_update = NULL,
initialize = function(n, min_time = 0, ...) {
self$n <- n
self$min_time <- min_time
self$begin()
},
begin = function() {
"Initialise timer. Call this before beginning timing."
self$i <- 0
self$last_update <- self$init_time <- now()
self$stopped <- FALSE
self
},
pause = function(x) {
"Sleep for x seconds. Useful for testing."
Sys.sleep(x)
self
},
width = function() {
getOption("width") - nchar("|100% ~ 99.9 h remaining") - 2
},
tick = function() {
"Process one element"
if (self$stopped) return(self)
if (self$i == self$n) stop("No more ticks")
self$i <- self$i + 1
self
},
stop = function() {
if (self$stopped) return(self)
self$stopped <- TRUE
self$stop_time <- now()
self
},
print = function(...) {
if (!isTRUE(getOption("dplyr.show_progress")) || # user sepecifies no progress
!interactive() || # not an interactive session
!is.null(getOption("knitr.in.progress"))) { # dplyr used within knitr document
return(invisible(self))
}
now_ <- now()
if (now_ - self$init_time < self$min_time || now_ - self$last_update < 0.05) {
return(invisible(self))
}
self$last_update <- now_
if (self$stopped) {
overall <- show_time(self$stop_time - self$init_time)
if (self$i == self$n) {
cat_line("Completed after ", overall)
cat("\n")
} else {
cat_line("Killed after ", overall)
cat("\n")
}
return(invisible(self))
}
avg <- (now() - self$init_time) / self$i
time_left <- (self$n - self$i) * avg
nbars <- trunc(self$i / self$n * self$width())
cat_line(
"|", str_rep("=", nbars), str_rep(" ", self$width() - nbars), "|",
format(round(self$i / self$n * 100), width = 3), "% ",
"~", show_time(time_left), " remaining"
)
invisible(self)
}
)
)
cat_line <- function(...) {
msg <- paste(..., sep = "", collapse = "")
gap <- max(c(0, getOption("width") - nchar(msg, "width")))
cat("\r", msg, rep.int(" ", gap), sep = "")
utils::flush.console()
}
str_rep <- function(x, i) {
paste(rep.int(x, i), collapse = "")
}
show_time <- function(x) {
if (x < 60) {
paste(round(x), "s")
} else if (x < 60 * 60) {
paste(round(x / 60), "m")
} else {
paste(round(x / (60 * 60)), "h")
}
}
now <- function() proc.time()[[3]]

10
R/proportion.R
View File

@@ -21,7 +21,7 @@
#' Calculate microbial resistance
#'
#' @description These functions can be used to calculate the (co-)resistance or susceptibility of microbial isolates (i.e. percentage of S, SI, I, IR or R). All functions support quasiquotation with pipes, can be used in `summarise()`][dplyr::summarise()] and also support grouped variables, please see *Examples*.
#' @description These functions can be used to calculate the (co-)resistance or susceptibility of microbial isolates (i.e. percentage of S, SI, I, IR or R). All functions support quasiquotation with pipes, can be used in [summarise()] from the `dplyr` package and also supports grouped variables, please see *Examples*.
#'
#' [resistance()] should be used to calculate resistance, [susceptibility()] should be used to calculate susceptibility.\cr
#' @inheritSection lifecycle Stable lifecycle
@@ -42,7 +42,7 @@
#'
#' These functions are not meant to count isolates, but to calculate the proportion of resistance/susceptibility. Use the `count()`][AMR::count()] functions to count isolates. The function [susceptibility()] is essentially equal to `count_susceptible() / count_all()`. *Low counts can influence the outcome - the `proportion` functions may camouflage this, since they only return the proportion (albeit being dependent on the `minimum` parameter).*
#'
#' The function [proportion_df()] takes any variable from `data` that has an [`rsi`] class (created with [as.rsi()]) and calculates the proportions R, I and S. The function [rsi_df()] works exactly like [proportion_df()], but adds the number of isolates.
#' The function [proportion_df()] takes any variable from `data` that has an [`rsi`] class (created with [as.rsi()]) and calculates the proportions R, I and S. It also supports grouped variables. The function [rsi_df()] works exactly like [proportion_df()], but adds the number of isolates.
#' @section Combination therapy:
#' When using more than one variable for `...` (= combination therapy)), use `only_all_tested` to only count isolates that are tested for all antibiotics/variables that you test them for. See this example for two antibiotics, Drug A and Drug B, about how [susceptibility()] works to calculate the %SI:
#'
@@ -99,6 +99,7 @@
#' proportion_IR(example_isolates$AMX)
#' proportion_R(example_isolates$AMX)
#'
#' \dontrun{
#' library(dplyr)
#' example_isolates %>%
#' group_by(hospital_id) %>%
@@ -135,7 +136,6 @@
#' summarise(numerator = count_susceptible(AMC, GEN, only_all_tested = TRUE),
#' denominator = count_all(AMC, GEN, only_all_tested = TRUE),
#' proportion = susceptibility(AMC, GEN, only_all_tested = TRUE))
#'
#'
#' example_isolates %>%
@@ -158,9 +158,6 @@
#' group_by(hospital_id) %>%
#' proportion_df(translate = FALSE)
#'
#'
#' \dontrun{
#'
#' # calculate current empiric combination therapy of Helicobacter gastritis:
#' my_table %>%
#' filter(first_isolate == TRUE,
@@ -265,7 +262,6 @@ proportion_S <- function(...,
}
#' @rdname proportion
#' @importFrom dplyr %>% select_if bind_rows summarise_if mutate group_vars select everything
#' @export
proportion_df <- function(data,
translate_ab = "name",

172
R/resistance_predict.R
View File

@@ -59,8 +59,6 @@
#' @rdname resistance_predict
#' @export
#' @importFrom stats predict glm lm
#' @importFrom dplyr %>% pull mutate mutate_at n group_by_at summarise filter filter_at all_vars n_distinct arrange case_when n_groups transmute ungroup
#' @importFrom tidyr pivot_wider
#' @inheritSection AMR Read more on our website!
#' @examples
#' x <- resistance_predict(example_isolates,
@@ -70,22 +68,22 @@
#' plot(x)
#' ggplot_rsi_predict(x)
#'
#' # use dplyr so you can actually read it:
#' library(dplyr)
#' x <- example_isolates %>%
#' filter_first_isolate() %>%
#' filter(mo_genus(mo) == "Staphylococcus") %>%
#' resistance_predict("PEN", model = "binomial")
#' plot(x)
#'
#'
#' # get the model from the object
#' mymodel <- attributes(x)$model
#' summary(mymodel)
#' # using dplyr:
#' if (!require("dplyr")) {
#' library(dplyr)
#' x <- example_isolates %>%
#' filter_first_isolate() %>%
#' filter(mo_genus(mo) == "Staphylococcus") %>%
#' resistance_predict("PEN", model = "binomial")
#' plot(x)
#'
#' # get the model from the object
#' mymodel <- attributes(x)$model
#' summary(mymodel)
#' }
#'
#' # create nice plots with ggplot2 yourself
#' if (!require(ggplot2)) {
#' if (!require(ggplot2) & !require("dplyr")) {
#'
#' data <- example_isolates %>%
#' filter(mo == as.mo("E. coli")) %>%
@@ -160,11 +158,9 @@ resistance_predict <- function(x,
stop("Column ", col_date, " not found.")
}
if (n_groups(x) > 1) {
# no grouped tibbles please, mutate will throw errors
x <- base::as.data.frame(x, stringsAsFactors = FALSE)
}
# no grouped tibbles, mutate will throw errors
x <- as.data.frame(x, stringsAsFactors = FALSE)
year <- function(x) {
# don't depend on lubridate or so, would be overkill for only this function
if (all(grepl("^[0-9]{4}$", x))) {
@@ -174,42 +170,54 @@ resistance_predict <- function(x,
}
}
df <- x %>%
mutate_at(col_ab, as.rsi) %>%
mutate_at(col_ab, droplevels)
df <- x
df[, col_ab] <- droplevels(as.rsi(df[, col_ab, drop = TRUE]))
if (I_as_S == TRUE) {
df <- df %>%
mutate_at(col_ab, ~gsub("I", "S", .))
# then I as S
df[, col_ab] <- gsub("I", "S", df[, col_ab, drop = TRUE])
} else {
# then I as R
df <- df %>%
mutate_at(col_ab, ~gsub("I", "R", .))
df[, col_ab] <- gsub("I", "R", df[, col_ab, drop = TRUE])
}
df <- df %>%
filter_at(col_ab, all_vars(!is.na(.))) %>%
mutate(year = year(pull(., col_date))) %>%
group_by_at(c("year", col_ab)) %>%
summarise(n())
df[, col_ab] <- ifelse(is.na(df[, col_ab, drop = TRUE]), 0, df[, col_ab, drop = TRUE])
# 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$year <- as.integer(rownames(df))
rownames(df) <- NULL
if (df %>% pull(col_ab) %>% n_distinct(na.rm = TRUE) < 2) {
stop("No variety in antimicrobial interpretations - all isolates are '",
df %>% pull(col_ab) %>% unique(), "'.",
call. = FALSE)
}
colnames(df) <- c("year", "antibiotic", "observations")
df <- df %>%
filter(!is.na(antibiotic)) %>%
pivot_wider(names_from = antibiotic,
values_from = observations,
values_fill = list(observations = 0)) %>%
filter((R + S) >= minimum)
df_matrix <- df %>%
ungroup() %>%
select(R, S) %>%
as.matrix()
# df <- df %>%
# filter_at(col_ab, all_vars(!is.na(.))) %>%
# mutate(year = year(pull(., col_date))) %>%
# group_by_at(c("year", col_ab)) %>%
# summarise(n())
# if (df %>% pull(col_ab) %>% n_distinct(na.rm = TRUE) < 2) {
# stop("No variety in antimicrobial interpretations - all isolates are '",
# df %>% pull(col_ab) %>% unique(), "'.",
# call. = FALSE)
# }
#
# colnames(df) <- c("year", "antibiotic", "observations")
df <- subset(df, sum(df$R + df$S, na.rm = TRUE) >= minimum)
# return(df)
#
# df <- df %>%
# filter(!is.na(antibiotic)) %>%
# pivot_wider(names_from = antibiotic,
# values_from = observations,
# values_fill = list(observations = 0)) %>%
# filter((R + S) >= minimum)
# df_matrix <- df %>%
# ungroup() %>%
# select(R, S) %>%
# as.matrix()
df_matrix <- as.matrix(df[, c("R", "S"), drop = FALSE])
if (NROW(df) == 0) {
stop("There are no observations.")
}
@@ -272,49 +280,39 @@ resistance_predict <- function(x,
# prepare the output dataframe
df_prediction <- data.frame(year = unlist(years),
value = prediction,
stringsAsFactors = FALSE) %>%
mutate(se_min = value - se,
se_max = value + se)
se_min = prediction - se,
se_max = prediction + se,
stringsAsFactors = FALSE)
if (model == "poisson") {
df_prediction <- df_prediction %>%
mutate(value = value %>%
format(scientific = FALSE) %>%
as.integer(),
se_min = as.integer(se_min),
se_max = as.integer(se_max))
df_prediction$value <- as.integer(format(df_prediction$value, scientific = FALSE))
df_prediction$se_min <- as.integer(df_prediction$se_min)
df_prediction$se_max <- as.integer(df_prediction$se_max)
} else {
df_prediction <- df_prediction %>%
# se_max not above 1
mutate(se_max = ifelse(se_max > 1, 1, se_max))
# se_max not above 1
df_prediction$se_max <- ifelse(df_prediction$se_max > 1, 1, df_prediction$se_max)
}
df_prediction <- df_prediction %>%
# se_min not below 0
mutate(se_min = ifelse(se_min < 0, 0, se_min))
# se_min not below 0
df_prediction$se_min <- ifelse(df_prediction$se_min < 0, 0, df_prediction$se_min)
df_observations <- df %>%
ungroup() %>%
transmute(year,
observations = R + S,
observed = R / (R + S))
df_observations <- data.frame(year = df$year,
observations = df$R + df$S,
observed = df$R / (df$R + df$S),
stringsAsFactors = FALSE)
df_prediction <- df_prediction %>%
left_join(df_observations, by = "year") %>%
mutate(estimated = value)
left_join(df_observations, by = "year")
df_prediction$estimated <- df_prediction$value
if (preserve_measurements == TRUE) {
# replace estimated data by observed data
df_prediction <- df_prediction %>%
mutate(value = ifelse(!is.na(observed), observed, value),
se_min = ifelse(!is.na(observed), NA, se_min),
se_max = ifelse(!is.na(observed), NA, se_max))
df_prediction$value <- ifelse(!is.na(df_prediction$observed), df_prediction$observed, df_prediction$value)
df_prediction$se_min <- ifelse(!is.na(df_prediction$observed), NA, df_prediction$se_min)
df_prediction$se_max <- ifelse(!is.na(df_prediction$observed), NA, df_prediction$se_max)
}
df_prediction <- df_prediction %>%
mutate(value = case_when(value > 1 ~ 1,
value < 0 ~ 0,
TRUE ~ value)) %>%
arrange(year)
df_prediction$value <- ifelse(df_prediction$value > 1, 1, ifelse(df_prediction$value < 0, 0, df_prediction$value))
df_prediction <- df_prediction[order(df_prediction$year), ]
structure(
.Data = df_prediction,
@@ -332,7 +330,6 @@ rsi_predict <- resistance_predict
#' @exportMethod plot.mic
#' @export
#' @importFrom dplyr filter
#' @importFrom graphics plot axis arrows points
#' @rdname resistance_predict
plot.resistance_predict <- function(x, main = paste("Resistance Prediction of", x_name), ...) {
@@ -366,14 +363,13 @@ plot.resistance_predict <- function(x, main = paste("Resistance Prediction of",
length = 0.05, angle = 90, code = 3, lwd = 1.5)
# overlay grey points for prediction
points(x = filter(x, is.na(observations))$year,
y = filter(x, is.na(observations))$value,
points(x = subset(x, is.na(observations))$year,
y = subset(x, is.na(observations))$value,
pch = 19,
col = "grey40")
}
#' @rdname resistance_predict
#' @importFrom dplyr filter
#' @export
ggplot_rsi_predict <- function(x,
main = paste("Resistance Prediction of", x_name),
@@ -392,7 +388,7 @@ ggplot_rsi_predict <- function(x,
}
p <- ggplot2::ggplot(x, ggplot2::aes(x = year, y = value)) +
ggplot2::geom_point(data = filter(x, !is.na(observations)),
ggplot2::geom_point(data = subset(x, !is.na(observations)),
size = 2) +
scale_y_percent(limits = c(0, 1)) +
ggplot2::labs(title = main,
@@ -408,7 +404,7 @@ ggplot_rsi_predict <- function(x,
}
p <- p +
# overlay grey points for prediction
ggplot2::geom_point(data = filter(x, is.na(observations)),
ggplot2::geom_point(data = subset(x, is.na(observations)),
size = 2,
colour = "grey40")
p

94
R/rsi.R
View File

@@ -29,12 +29,15 @@
#' @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*.
#' @inheritParams first_isolate
#' @param guideline defaults to the latest included EUCAST guideline, run `unique(rsi_translation$guideline)` for all options
#' @param guideline defaults to the latest included EUCAST guideline, see Details for all options
#' @param threshold maximum fraction of invalid antimicrobial interpretations of `x`, please see *Examples*
#' @param ... parameters passed on to methods
#' @details Run `unique(rsi_translation$guideline)` for a list of all supported guidelines. The repository of this package contains [this machine readable version](https://gitlab.com/msberends/AMR/blob/master/data-raw/rsi_translation.txt) of these guidelines.
#' @details
#' When using [as.rsi()] on untransformed data, the data will be cleaned to only contain values S, I and R. When using the function on data with class [`mic`] (using [as.mic()]) or class [`disk`] (using [as.disk()]), the data will be interpreted based on the guideline set with the `guideline` parameter.
#'
#' These guidelines are machine readable, since [](https://gitlab.com/msberends/AMR/blob/master/data-raw/rsi_translation.txt).
#' 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"` for input will automatically select the latest version of that guideline.
#'
#' The repository of this package [contains a machine readable version](https://gitlab.com/msberends/AMR/blob/master/data-raw/rsi_translation.txt) of all guidelines. This is a CSV file consisting of `r format(nrow(AMR::rsi_translation), big.mark = ",")` rows and `r ncol(AMR::rsi_translation)` columns. This file is machine readable, since it contains one row for every unique combination of the test method (MIC or disk diffusion), the antimicrobial agent and the microorganism. This **allows for easy implementation of these rules in laboratory information systems (LIS)**.
#'
#' After using [as.rsi()], you can use [eucast_rules()] to (1) apply inferred susceptibility and resistance based on results of other antimicrobials and (2) apply intrinsic resistance based on taxonomic properties of a microorganism.
#'
@@ -113,7 +116,6 @@
#' is.rsi(rsi_data)
#' plot(rsi_data) # for percentages
#' barplot(rsi_data) # for frequencies
#' freq(rsi_data) # frequency table with informative header
#'
#' library(dplyr)
#' example_isolates %>%
@@ -216,7 +218,7 @@ as.rsi.mic <- function(x, mo, ab = deparse(substitute(x)), guideline = "EUCAST",
mo_coerced <- suppressWarnings(as.mo(mo))
guideline_coerced <- get_guideline(guideline)
if (is.na(ab_coerced)) {
message(red(paste0("Unknown drug: `", bold(ab), "`. Rename this column to a drug name or code, and check the output with as.ab().")))
message(font_red(paste0("Unknown drug: `", font_bold(ab), "`. Rename this column to a drug name or code, and check the output with as.ab().")))
return(as.rsi(rep(NA, length(x))))
}
if (length(mo_coerced) == 1) {
@@ -226,16 +228,16 @@ as.rsi.mic <- function(x, mo, ab = deparse(substitute(x)), guideline = "EUCAST",
uti <- rep(uti, length(x))
}
message(blue(paste0("=> Interpreting MIC values of `", bold(ab), "` (",
message(font_blue(paste0("=> Interpreting MIC values of `", font_bold(ab), "` (",
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
ab_name(ab_coerced, tolower = TRUE), ") using guideline ", bold(guideline_coerced), " ... ")),
ab_name(ab_coerced, tolower = TRUE), ") using guideline ", font_bold(guideline_coerced), " ... ")),
appendLF = FALSE)
result <- exec_as.rsi(method = "mic",
x = x,
mo = mo_coerced,
ab = ab_coerced,
guideline = guideline_coerced,
uti = uti) # exec_as.rsi will return message(blue(" OK."))
uti = uti) # exec_as.rsi will return message(font_blue(" OK."))
result
}
@@ -253,7 +255,7 @@ as.rsi.disk <- function(x, mo, ab = deparse(substitute(x)), guideline = "EUCAST"
mo_coerced <- suppressWarnings(as.mo(mo))
guideline_coerced <- get_guideline(guideline)
if (is.na(ab_coerced)) {
message(red(paste0("Unknown drug: `", bold(ab), "`. Rename this column to a drug name or code, and check the output with as.ab().")))
message(font_red(paste0("Unknown drug: `", font_bold(ab), "`. Rename this column to a drug name or code, and check the output with as.ab().")))
return(as.rsi(rep(NA, length(x))))
}
if (length(mo_coerced) == 1) {
@@ -263,21 +265,20 @@ as.rsi.disk <- function(x, mo, ab = deparse(substitute(x)), guideline = "EUCAST"
uti <- rep(uti, length(x))
}
message(blue(paste0("=> Interpreting disk zones of `", bold(ab), "` (",
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 ", bold(guideline_coerced), " ... ")),
ab_name(ab_coerced, tolower = TRUE), ") using guideline ", font_bold(guideline_coerced), " ... ")),
appendLF = FALSE)
result <- exec_as.rsi(method = "disk",
x = x,
mo = mo_coerced,
ab = ab_coerced,
guideline = guideline_coerced,
uti = uti) # exec_as.rsi will return message(blue(" OK."))
uti = uti) # exec_as.rsi will return message(font_blue(" OK."))
result
}
#' @rdname as.rsi
#' @importFrom crayon red blue bold
#' @export
as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", uti = NULL, ...) {
# try to find columns based on type
@@ -316,9 +317,9 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", uti = NULL
} else {
plural <- c("", "s", "a ")
}
message(blue(paste0("NOTE: Assuming value", plural[1], " ",
message(font_blue(paste0("NOTE: Assuming value", plural[1], " ",
paste(paste0('"', values, '"'), collapse = ", "),
" in column `", bold(col_specimen),
" 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
@@ -336,12 +337,12 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", uti = NULL
# not even a valid AB code
return(FALSE)
} else if (!check & all_valid_mics(y)) {
message(blue(paste0("NOTE: Assuming column `", ab, "` (",
message(font_blue(paste0("NOTE: Assuming column `", ab, "` (",
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
ab_name(ab_coerced, tolower = TRUE), ") contains MIC values.")))
return(TRUE)
} else if (!check & all_valid_disks(y)) {
message(blue(paste0("NOTE: Assuming column `", ab, "` (",
message(font_blue(paste0("NOTE: Assuming column `", ab, "` (",
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
ab_name(ab_coerced, tolower = TRUE), ") contains disk zones.")))
return(TRUE)
@@ -380,16 +381,10 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", uti = NULL
x
}
#' @importFrom dplyr %>% filter pull
get_guideline <- function(guideline) {
guideline_param <- toupper(guideline)
if (guideline_param %in% c("CLSI", "EUCAST")) {
guideline_param <- rsi_translation %>%
filter(guideline %like% guideline_param) %>%
pull(guideline) %>%
sort() %>%
rev() %>%
.[1]
guideline_param <- rev(sort(subset(rsi_translation, guideline %like% guideline_param)$guideline))[1L]
}
if (!guideline_param %like% " ") {
# like 'EUCAST2020', should be 'EUCAST 2020'
@@ -406,8 +401,6 @@ get_guideline <- function(guideline) {
}
#' @importFrom dplyr %>% case_when desc arrange filter n_distinct
#' @importFrom crayon green red bold
exec_as.rsi <- function(method, x, mo, ab, guideline, uti) {
if (method == "mic") {
x <- as.mic(x) # when as.rsi.mic is called directly
@@ -427,14 +420,14 @@ exec_as.rsi <- function(method, x, mo, ab, guideline, uti) {
guideline_coerced <- get_guideline(guideline)
if (guideline_coerced != guideline) {
message(blue(paste0("Note: Using guideline ", bold(guideline_coerced), " as input for `guideline`.")))
message(font_blue(paste0("Note: Using guideline ", font_bold(guideline_coerced), " as input for `guideline`.")))
}
new_rsi <- rep(NA_character_, length(x))
ab_param <- ab
trans <- rsi_translation %>%
filter(guideline == guideline_coerced & method == method_param & ab == ab_param) %>%
mutate(lookup = paste(mo, ab))
subset(guideline == guideline_coerced & method == method_param & ab == ab_param)
trans$lookup <- paste(trans$mo, trans$ab)
lookup_mo <- paste(mo, ab)
lookup_genus <- paste(mo_genus, ab)
@@ -445,15 +438,15 @@ exec_as.rsi <- function(method, x, mo, ab, guideline, uti) {
lookup_other <- paste(mo_other, ab)
if (all(trans$uti == TRUE, na.rm = TRUE) & all(uti == FALSE)) {
message(red("WARNING."))
warning("Interpretation of ", 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(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)
warned <- TRUE
}
for (i in seq_len(length(x))) {
get_record <- trans %>%
# no UTI for now
filter(lookup %in% c(lookup_mo[i],
subset(lookup %in% c(lookup_mo[i],
lookup_genus[i],
lookup_family[i],
lookup_order[i],
@@ -465,14 +458,13 @@ exec_as.rsi <- function(method, x, mo, ab, guideline, uti) {
get_record <- get_record %>%
# be as specific as possible (i.e. prefer species over genus):
# desc(uti) = TRUE on top and FALSE on bottom
arrange(desc(uti), desc(nchar(mo))) %>% # 'uti' is a column in rsi_translation
.[1L, ]
arrange(desc(uti), desc(nchar(mo))) # 'uti' is a column in rsi_translation
} else {
get_record <- get_record %>%
filter(uti == FALSE) %>% # 'uti' is a column in rsi_translation
arrange(desc(nchar(mo))) %>%
.[1L, ]
arrange(desc(nchar(mo)))
}
get_record <- get_record[1L, ]
if (NROW(get_record) > 0) {
if (is.na(x[i])) {
@@ -481,20 +473,20 @@ exec_as.rsi <- function(method, x, mo, ab, guideline, uti) {
mic_input <- x[i]
mic_S <- as.mic(get_record$breakpoint_S)
mic_R <- as.mic(get_record$breakpoint_R)
new_rsi[i] <- case_when(isTRUE(which(levels(mic_input) == mic_input) <= which(levels(mic_S) == mic_S)) ~ "S",
isTRUE(which(levels(mic_input) == mic_input) >= which(levels(mic_R) == mic_R)) ~ "R",
!is.na(get_record$breakpoint_S) & !is.na(get_record$breakpoint_R) ~ "I",
TRUE ~ NA_character_)
new_rsi[i] <- ifelse(isTRUE(which(levels(mic_input) == mic_input) <= which(levels(mic_S) == mic_S)), "S",
ifelse(isTRUE(which(levels(mic_input) == mic_input) >= which(levels(mic_R) == mic_R)), "R",
ifelse(!is.na(get_record$breakpoint_S) & !is.na(get_record$breakpoint_R), "I",
NA_character_)))
} else if (method == "disk") {
new_rsi[i] <- case_when(isTRUE(as.double(x[i]) >= as.double(get_record$breakpoint_S)) ~ "S",
isTRUE(as.double(x[i]) <= as.double(get_record$breakpoint_R)) ~ "R",
!is.na(get_record$breakpoint_S) & !is.na(get_record$breakpoint_R) ~ "I",
TRUE ~ NA_character_)
new_rsi[i] <- ifelse(isTRUE(as.double(x[i]) >= as.double(get_record$breakpoint_S)), "S",
ifelse(isTRUE(as.double(x[i]) <= as.double(get_record$breakpoint_R)), "R",
ifelse(!is.na(get_record$breakpoint_S) & !is.na(get_record$breakpoint_R), "I",
NA_character_)))
}
}
}
if (warned == FALSE) {
message(green("OK."))
message(font_green("OK."))
}
structure(.Data = factor(new_rsi, levels = c("S", "I", "R"), ordered = TRUE),
class = c("rsi", "ordered", "factor"))
@@ -537,7 +529,6 @@ is.rsi.eligible <- function(x, threshold = 0.05) {
#' @exportMethod print.rsi
#' @export
#' @importFrom dplyr %>%
#' @noRd
print.rsi <- function(x, ...) {
cat("Class 'rsi'\n")
@@ -570,7 +561,6 @@ summary.rsi <- function(object, ...) {
#' @exportMethod plot.rsi
#' @export
#' @importFrom dplyr %>% group_by summarise filter mutate if_else n_distinct
#' @importFrom graphics plot text
#' @noRd
plot.rsi <- function(x,
@@ -626,7 +616,6 @@ plot.rsi <- function(x,
#' @exportMethod barplot.rsi
#' @export
#' @importFrom dplyr %>% group_by summarise
#' @importFrom graphics barplot axis par
#' @noRd
barplot.rsi <- function(height,
@@ -660,14 +649,13 @@ barplot.rsi <- function(height,
}
#' @importFrom pillar pillar_shaft
#' @importFrom crayon bgGreen bgYellow bgRed black white
#' @export
pillar_shaft.rsi <- function(x, ...) {
out <- trimws(format(x))
out[is.na(x)] <- pillar::style_subtle(" NA")
out[x == "S"] <- bgGreen(white(" S "))
out[x == "I"] <- bgYellow(black(" I "))
out[x == "R"] <- bgRed(white(" R "))
out[is.na(x)] <- font_subtle(" NA")
out[x == "S"] <- font_green_bg(font_white(" S "))
out[x == "I"] <- font_yellow_bg(font_black(" I "))
out[x == "R"] <- font_red_bg(font_white(" R "))
pillar::new_pillar_shaft_simple(out, align = "left", width = 3)
}

177
R/rsi_calc.R
View File

@@ -19,27 +19,13 @@
# Visit our website for more info: https://msberends.gitlab.io/AMR. #
# ==================================================================== #
#' @importFrom rlang enquos as_label
dots2vars <- function(...) {
# this function is to give more informative output about
# variable names in count_* and proportion_* functions
paste(
unlist(
lapply(enquos(...),
function(x) {
l <- as_label(x)
if (l != ".") {
l
} else {
character(0)
}
})
),
collapse = ", ")
dots <- substitute(list(...))
paste(as.character(dots)[2:length(dots)], collapse = ", ")
}
#' @importFrom dplyr %>% pull all_vars any_vars filter_all funs mutate_all
#' @importFrom cleaner percentage
rsi_calc <- function(...,
ab_result,
minimum = 0,
@@ -72,10 +58,10 @@ rsi_calc <- function(...,
dots <- dots[dots != "."]
if (length(dots) == 0 | all(dots == "df")) {
# for complete data.frames, like example_isolates %>% select(amcl, gent) %>% proportion_S()
# and the old rsi function, that has "df" as name of the first parameter
# and the old rsi function, which has "df" as name of the first parameter
x <- dots_df
} else {
x <- dots_df[, dots]
x <- dots_df[, dots[dots %in% colnames(dots_df)]]
}
} else if (ndots == 1) {
# only 1 variable passed (can also be data.frame), like: proportion_S(example_isolates$amcl) and example_isolates$amcl %>% proportion_S()
@@ -85,8 +71,8 @@ rsi_calc <- function(...,
x <- NULL
try(x <- as.data.frame(dots), silent = TRUE)
if (is.null(x)) {
# support for: with(example_isolates, proportion_S(amcl, gent))
x <- as.data.frame(rlang::list2(...))
# support for example_isolates %>% group_by(hospital_id) %>% summarise(amox = susceptibility(GEN, AMX))
x <- as.data.frame(list(...))
}
}
@@ -113,7 +99,7 @@ rsi_calc <- function(...,
# this will give a warning for invalid results, of all input columns (so only 1 warning)
rsi_integrity_check <- as.rsi(rsi_integrity_check)
}
if (only_all_tested == TRUE) {
# THE NUMBER OF ISOLATES WHERE *ALL* ABx ARE S/I/R
x <- apply(X = x %>% mutate_all(as.integer),
@@ -128,8 +114,8 @@ rsi_calc <- function(...,
other_values_filter <- base::apply(x, 1, function(y) {
base::all(y %in% other_values) & base::any(is.na(y))
})
numerator <- x %>% filter_all(any_vars(. %in% ab_result)) %>% nrow()
denominator <- x %>% filter(!other_values_filter) %>% nrow()
numerator <- sum(as.logical(by(x, seq_len(nrow(x)), function(row) any(unlist(row) %in% ab_result, na.rm = TRUE))))
denominator <- nrow(x[!other_values_filter, ])
}
} else {
# x is not a data.frame
@@ -167,9 +153,7 @@ rsi_calc <- function(...,
}
}
#' @importFrom dplyr %>% summarise_if mutate select everything bind_rows arrange
#' @importFrom tidyr pivot_longer
rsi_calc_df <- function(type, # "proportion" or "count"
rsi_calc_df <- function(type, # "proportion", "count" or "both"
data,
translate_ab = "name",
language = get_locale(),
@@ -199,63 +183,106 @@ rsi_calc_df <- function(type, # "proportion" or "count"
if (as.character(translate_ab) %in% c("TRUE", "official")) {
translate_ab <- "name"
}
# select only groups and antibiotics
if (has_groups(data)) {
data_has_groups <- TRUE
groups <- setdiff(names(get_groups(data)), ".rows") # get_groups is from poorman.R
data <- data[, c(groups, colnames(data)[sapply(data, is.rsi)]), drop = FALSE]
} else {
data_has_groups <- FALSE
data <- data[, colnames(data)[sapply(data, is.rsi)], drop = FALSE]
}
get_summaryfunction <- function(int, type) {
# look for proportion_S, count_S, etc:
int_fn <- get(paste0(type, "_", int), envir = asNamespace("AMR"))
suppressWarnings(
if (type == "proportion") {
summ <- summarise_if(.tbl = data,
.predicate = is.rsi,
.funs = int_fn,
minimum = minimum,
as_percent = as_percent)
} else if (type == "count") {
summ <- summarise_if(.tbl = data,
.predicate = is.rsi,
.funs = int_fn)
data <- as.data.frame(data, stringsAsFactors = FALSE)
if (isTRUE(combine_SI) | isTRUE(combine_IR)) {
for (i in seq_len(ncol(data))) {
if (is.rsi(data[, i, drop = TRUE])) {
data[, i] <- as.character(data[, i, drop = TRUE])
if (isTRUE(combine_SI)) {
data[, i] <- gsub("(I|S)", "SI", data[, i, drop = TRUE])
} else if (isTRUE(combine_IR)) {
data[, i] <- gsub("(I|R)", "IR", data[, i, drop = TRUE])
}
}
)
summ %>%
mutate(interpretation = int) %>%
select(interpretation, everything())
}
}
resS <- get_summaryfunction("S", type)
resI <- get_summaryfunction("I", type)
resR <- get_summaryfunction("R", type)
resSI <- get_summaryfunction("SI", type)
resIR <- get_summaryfunction("IR", type)
data.groups <- group_vars(data)
sum_it <- function(.data) {
out <- data.frame(antibiotic = character(0),
interpretation = character(0),
value = double(0),
isolates <- integer(0),
stringsAsFactors = FALSE)
if (data_has_groups) {
group_values <- unique(.data[, which(colnames(.data) %in% groups), drop = FALSE])
rownames(group_values) <- NULL
.data <- .data[, which(!colnames(.data) %in% groups), drop = FALSE]
}
for (i in seq_len(ncol(.data))) {
col_results <- as.data.frame(as.matrix(table(.data[, i, drop = TRUE])))
col_results$interpretation <- rownames(col_results)
col_results$isolates <- col_results[, 1, drop = TRUE]
if (nrow(col_results) > 0) {
if (sum(col_results$isolates, na.rm = TRUE) >= minimum) {
col_results$value <- col_results$isolates / sum(col_results$isolates, na.rm = TRUE)
} else {
col_results$value <- rep(NA_real_, NROW(col_results))
}
out_new <- data.frame(antibiotic = ab_property(colnames(.data)[i], property = translate_ab, language = language),
interpretation = col_results$interpretation,
value = col_results$value,
isolates = col_results$isolates,
stringsAsFactors = FALSE)
if (data_has_groups) {
out_new <- cbind(group_values, out_new)
}
out <- rbind(out, out_new)
}
}
out
}
if (isFALSE(combine_SI) & isFALSE(combine_IR)) {
res <- bind_rows(resS, resI, resR) %>%
mutate(interpretation = factor(interpretation,
levels = c("S", "I", "R"),
ordered = TRUE))
# support dplyr groups
apply_group <- function(.data, fn, groups, ...) {
grouped <- split(x = .data, f = lapply(groups, function(x, .data) as.factor(.data[, x]), .data))
res <- do.call(rbind, unname(lapply(grouped, fn, ...)))
if (any(groups %in% colnames(res))) {
class(res) <- c("grouped_data", class(res))
attr(res, "groups") <- groups[groups %in% colnames(res)]
}
res
}
if (data_has_groups) {
out <- apply_group(data, "sum_it", groups)
} else {
out <- sum_it(data)
}
# apply factors for right sorting in interpretation
if (isTRUE(combine_SI)) {
out$interpretation <- factor(out$interpretation, levels = c("SI", "R"), ordered = TRUE)
} else if (isTRUE(combine_IR)) {
res <- bind_rows(resS, resIR) %>%
mutate(interpretation = factor(interpretation,
levels = c("S", "IR"),
ordered = TRUE))
} else if (isTRUE(combine_SI)) {
res <- bind_rows(resSI, resR) %>%
mutate(interpretation = factor(interpretation,
levels = c("SI", "R"),
ordered = TRUE))
out$interpretation <- factor(out$interpretation, levels = c("S", "IR"), ordered = TRUE)
} else {
out$interpretation <- as.rsi(out$interpretation)
}
res <- res %>%
pivot_longer(-c(interpretation, data.groups), names_to = "antibiotic") %>%
select(antibiotic, everything()) %>%
arrange(antibiotic, interpretation)
if (!translate_ab == FALSE) {
res <- res %>% mutate(antibiotic = ab_property(antibiotic, property = translate_ab, language = language))
if (data_has_groups) {
# ordering by the groups and two more: "antibiotic" and "interpretation"
out <- out[do.call("order", out[, seq_len(length(groups) + 2)]), ]
} else {
out <- out[order(out$antibiotic, out$interpretation), ]
}
as.data.frame(res, stringsAsFactors = FALSE)
if (type == "proportion") {
out <- subset(out, select = -c(isolates))
} else if (type == "count") {
out$value <- out$isolates
out <- subset(out, select = -c(isolates))
}
rownames(out) <- NULL
out
}

32
R/rsi_df.R
View File

@@ -29,28 +29,14 @@ rsi_df <- function(data,
combine_SI = TRUE,
combine_IR = FALSE) {
proportions <- rsi_calc_df(type = "proportion",
data = data,
translate_ab = translate_ab,
language = language,
minimum = minimum,
as_percent = as_percent,
combine_SI = combine_SI,
combine_IR = combine_IR,
combine_SI_missing = missing(combine_SI))
counts <- rsi_calc_df(type = "count",
data = data,
translate_ab = FALSE,
language = "en",
minimum = minimum,
as_percent = as_percent,
combine_SI = combine_SI,
combine_IR = combine_IR,
combine_SI_missing = missing(combine_SI))
data.frame(proportions,
isolates = counts$value,
stringsAsFactors = FALSE)
rsi_calc_df(type = "both",
data = data,
translate_ab = translate_ab,
language = language,
minimum = minimum,
as_percent = as_percent,
combine_SI = combine_SI,
combine_IR = combine_IR,
combine_SI_missing = missing(combine_SI))
}

BIN
R/sysdata.rda
View File

Binary file not shown.

44
R/vctrs.R → R/tidyverse.R
View File

@@ -19,15 +19,35 @@
# Visit our website for more info: https://msberends.gitlab.io/AMR. #
# ==================================================================== #
#' `vctrs` methods
#' Methods for tidyverse
#'
#' These methods are needed to support methods used by the tidyverse, like joining and transforming data, with new classes that come with this package.
#' @inheritSection lifecycle Stable lifecycle
#' @inheritSection AMR Read more on our website!
#' @keywords internal
#' @name AMR-vctrs
#' @name AMR-tidyverse
NULL
#' @rdname AMR-tidyverse
#' @exportMethod scale_type.mo
#' @export
scale_type.mo <- function(x) {
# fix for:
# "Don't know how to automatically pick scale for object of type mo. Defaulting to continuous."
# "Error: Discrete value supplied to continuous scale"
"discrete"
}
#' @rdname AMR-tidyverse
#' @exportMethod scale_type.ab
#' @export
scale_type.ab <- function(x) {
# fix for:
# "Don't know how to automatically pick scale for object of type mo. Defaulting to continuous."
# "Error: Discrete value supplied to continuous scale"
"discrete"
}
# Class mo ----------------------------------------------------------------
@@ -46,7 +66,7 @@ vec_ptype_full.mo <- function(x, ...) {
"mo"
}
#' @rdname AMR-vctrs
#' @rdname AMR-tidyverse
#' @export
vec_ptype2.mo <- function(x, y, ...) {
UseMethod("vec_ptype2.mo", y)
@@ -65,13 +85,14 @@ vec_ptype2.mo.character <- function(x, y, ...) {
}
#' @method vec_ptype2.character mo
#' @exportMethod vec_ptype2.character.mo
#' @importFrom vctrs vec_ptype2.character
#' @export
vec_ptype2.character.mo <- function(x, y, ...) {
y
}
#' @rdname AMR-vctrs
#' @rdname AMR-tidyverse
#' @export
vec_cast.mo <- function(x, to, ...) {
UseMethod("vec_cast.mo")
@@ -96,12 +117,11 @@ vec_cast.mo.default <- function(x, to, ...) {
vec_default_cast(x, to)
}
# @method vec_cast.character mo
#' @method vec_cast.character mo
#' @exportMethod vec_cast.character.mo
#' @importFrom vctrs vec_cast
#' @importFrom vctrs vec_cast vec_cast.character
#' @export
vec_cast.character.mo <- function(x, to, ...) {
# purrr::map_chr(x, stringr::str_c, collapse = " ")
unclass(x)
}
@@ -123,7 +143,7 @@ vec_ptype_full.ab <- function(x, ...) {
"ab"
}
#' @rdname AMR-vctrs
#' @rdname AMR-tidyverse
#' @export
vec_ptype2.ab <- function(x, y, ...) {
UseMethod("vec_ptype2.ab", y)
@@ -142,13 +162,14 @@ vec_ptype2.ab.character <- function(x, y, ...) {
}
#' @method vec_ptype2.character ab
#' @exportMethod vec_ptype2.character.ab
#' @importFrom vctrs vec_ptype2.character
#' @export
vec_ptype2.character.ab <- function(x, y, ...) {
y
}
#' @rdname AMR-vctrs
#' @rdname AMR-tidyverse
#' @export
vec_cast.ab <- function(x, to, ...) {
UseMethod("vec_cast.ab")
@@ -173,12 +194,11 @@ vec_cast.ab.default <- function(x, to, ...) {
vec_default_cast(x, to)
}
# @method vec_cast.character ab
#' @method vec_cast.character ab
#' @exportMethod vec_cast.character.ab
#' @importFrom vctrs vec_cast
#' @importFrom vctrs vec_cast vec_cast.character
#' @export
vec_cast.character.ab <- function(x, to, ...) {
# purrr::map_chr(x, stringr::str_c, collapse = " ")
unclass(x)
}

21
R/translate.R
View File

@@ -21,15 +21,15 @@
#' Translate strings from AMR package
#'
#' For language-dependent output of AMR functions, like [mo_name()], [mo_type()] and [ab_name()].
#' 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://gitlab.com/msberends/AMR/blob/master/data-raw/translations.tsv>.
#'
#' Currently supported languages can be found if running: `unique(AMR:::translations_file$lang)`.
#' Currently supported languages are (besides English): `r paste(sort(gsub(";.*", "", ISOcodes::ISO_639_2[which(ISOcodes::ISO_639_2$Alpha_2 %in% unique(AMR:::translations_file$lang)), "Name"])), collapse = ", ")`. Not all these languages currently have translations available for all antimicrobial agents and colloquial microorganism names.
#'
#' Please suggest your own translations [by creating a new issue on our repository](https://gitlab.com/msberends/AMR/issues/new?issue[title]=Translation\%20suggestion).
#'
#' This file will be read by all functions where a translated output can be desired, like all [mo_property()] functions ([mo_fullname()], [mo_type()], etc.).
#' 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.).
#'
#' The system language will be used at default, if that language is supported. The system language can be overwritten with `Sys.setenv(AMR_locale = yourlanguage)`.
#' @inheritSection AMR Read more on our website!
@@ -68,7 +68,7 @@ get_locale <- function() {
if (!is.null(getOption("AMR_locale", default = NULL))) {
return(getOption("AMR_locale"))
}
lang <- Sys.getlocale("LC_COLLATE")
# Check the locale settings for a start with one of these languages:
@@ -82,13 +82,13 @@ get_locale <- function() {
"de"
} else if (grepl("^(Dutch|Nederlands|nl_|NL_)", lang, ignore.case = FALSE)) {
"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)) {
"es"
} else if (grepl("^(Italian|Italiano|it_|IT_)", lang, ignore.case = FALSE)) {
"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)) {
"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)) {
"pt"
} else {
# other language -> set to English
@@ -97,9 +97,8 @@ get_locale <- function() {
}
# translate strings based on inst/translations.tsv
#' @importFrom dplyr %>% filter
translate_AMR <- function(from, language = get_locale(), only_unknown = FALSE) {
if (is.null(language)) {
return(from)
}
@@ -115,9 +114,9 @@ translate_AMR <- function(from, language = get_locale(), only_unknown = FALSE) {
call. = FALSE)
}
df_trans <- df_trans %>% filter(lang == language)
df_trans <- df_trans %>% subset(lang == language)
if (only_unknown == TRUE) {
df_trans <- df_trans %>% filter(pattern %like% "unknown")
df_trans <- df_trans %>% subset(pattern %like% "unknown")
}
# default case sensitive if value if 'ignore.case' is missing:

81
R/zzz.R
View File

@@ -19,18 +19,16 @@
# Visit our website for more info: https://msberends.gitlab.io/AMR. #
# ==================================================================== #
#' @importFrom data.table as.data.table setkey
.onLoad <- function(libname, pkgname) {
# get new functions not available in older versions of R
backports::import(pkgname)
# register data
assign(x = "microorganismsDT",
value = make_DT(),
assign(x = "MO_lookup",
value = create_MO_lookup(),
envir = asNamespace("AMR"))
assign(x = "microorganisms.oldDT",
value = make_oldDT(),
assign(x = "MO.old_lookup",
value = create_MO.old_lookup(),
envir = asNamespace("AMR"))
assign(x = "mo_codes_v0.5.0",
@@ -41,52 +39,43 @@
# maybe add survey later: "https://www.surveymonkey.com/r/AMR_for_R"
#' @importFrom data.table as.data.table setkey
#' @importFrom dplyr %>% mutate case_when
make_DT <- function() {
microorganismsDT <- AMR::microorganisms %>%
mutate(kingdom_index = case_when(kingdom == "Bacteria" ~ 1,
kingdom == "Fungi" ~ 2,
kingdom == "Protozoa" ~ 3,
kingdom == "Archaea" ~ 4,
TRUE ~ 99),
# for fullname_lower: keep only dots, letters,
# numbers, slashes, spaces and dashes
fullname_lower = gsub("[^.a-z0-9/ \\-]+", "",
# use this paste instead of `fullname` to
# work with Viridans Group Streptococci, etc.
tolower(trimws(ifelse(genus == "",
fullname,
paste(genus, species, subspecies))))),
# add a column with only "e coli" like combinations
g_species = gsub("^([a-z])[a-z]+ ([a-z]+) ?.*", "\\1 \\2", fullname_lower)) %>%
as.data.table()
create_MO_lookup <- function() {
MO_lookup <- AMR::microorganisms
MO_lookup$kingdom_index <- 99
MO_lookup[which(MO_lookup$kingdom == "Bacteria" | MO_lookup$mo == "UNKNOWN"), "kingdom_index"] <- 1
MO_lookup[which(MO_lookup$kingdom == "Fungi"), "kingdom_index"] <- 2
MO_lookup[which(MO_lookup$kingdom == "Protozoa"), "kingdom_index"] <- 3
MO_lookup[which(MO_lookup$kingdom == "Archaea"), "kingdom_index"] <- 4
# use this paste instead of `fullname` to
# work with Viridans Group Streptococci, etc.
MO_lookup$fullname_lower <- tolower(trimws(paste(MO_lookup$genus,
MO_lookup$species,
MO_lookup$subspecies)))
MO_lookup[MO_lookup$genus == "" | grepl("^[(]unknown ", MO_lookup$fullname), "fullname_lower"] <- tolower(trimws(MO_lookup[MO_lookup$genus == "" | grepl("^[(]unknown ", MO_lookup$fullname),
"fullname"]))
MO_lookup$fullname_lower <- gsub("[^.a-z0-9/ \\-]+", "",MO_lookup$fullname_lower)
# add a column with only "e coli" like combinations
MO_lookup$g_species <- gsub("^([a-z])[a-z]+ ([a-z]+) ?.*", "\\1 \\2", MO_lookup$fullname_lower)
# so arrange data on prevalence first, then kingdom, then full name
setkey(microorganismsDT,
prevalence,
kingdom_index,
fullname_lower)
microorganismsDT
MO_lookup[order(MO_lookup$prevalence, MO_lookup$kingdom_index, MO_lookup$fullname_lower),]
}
#' @importFrom data.table as.data.table setkey
#' @importFrom dplyr %>% mutate
make_oldDT <- function() {
microorganisms.oldDT <- AMR::microorganisms.old %>%
mutate(
# for fullname_lower: keep only dots, letters,
# numbers, slashes, spaces and dashes
fullname_lower = gsub("[^.a-z0-9/ \\-]+", "", tolower(fullname)),
# add a column with only "e coli" like combinations
g_species = gsub("^([a-z])[a-z]+ ([a-z]+) ?.*", "\\1 \\2", fullname_lower)) %>%
as.data.table()
create_MO.old_lookup <- function() {
MO.old_lookup <- AMR::microorganisms.old
# use this paste instead of `fullname` to
# work with Viridans Group Streptococci, etc.
MO.old_lookup$fullname_lower <- gsub("[^.a-z0-9/ \\-]+", "", tolower(trimws(MO.old_lookup$fullname)))
# add a column with only "e coli" like combinations
MO.old_lookup$g_species <- gsub("^([a-z])[a-z]+ ([a-z]+) ?.*", "\\1 \\2", MO.old_lookup$fullname_lower)
# so arrange data on prevalence first, then full name
setkey(microorganisms.oldDT,
prevalence,
fullname)
microorganisms.oldDT
MO.old_lookup[order(MO.old_lookup$prevalence, MO.old_lookup$fullname_lower),]
}
make_trans_tbl <- function() {

32
README.md
View File

@@ -3,38 +3,14 @@
# `AMR` (for R)
<img src="man/figures/logo.png" align="right" height="120px" />
### Not a developer? Then please visit our website [https://msberends.gitlab.io/AMR](https://msberends.gitlab.io/AMR) to read about this package.
This is the development source of the `AMR` package for R. Not a developer? Then please visit our website [https://msberends.gitlab.io/AMR](https://msberends.gitlab.io/AMR) to read about this package.
**It contains documentation about all of the included functions and also a comprehensive tutorial about how to conduct AMR analysis.**
*NOTE: this source code is on GitLab (https://gitlab.com/msberends/AMR) and GitHub (https://github.com/msberends/AMR).*
## Development source
*NOTE: the original source code is on GitLab (https://gitlab.com/msberends/AMR). There is a mirror repository on GitHub (https://github.com/msberends/AMR). As the mirror process is automated by GitLab, both repositories always contain the latest changes.*
This is the **development source** of `AMR`, a free and open-source [R package](https://www.r-project.org) to simplify the analysis and prediction of Antimicrobial Resistance (AMR) and to work with microbial and antimicrobial properties by using evidence-based methods.
## Authors
Matthijs S. Berends<sup>1,2</sup>,
Christian F. Luz<sup>1</sup>,
Alex W. Friedrich1</sup>,
Bhanu N.M. Sinha<sup>1</sup>,
Casper J. Albers<sup>3</sup>,
Corinna Glasner<sup>1</sup>
<sup>1</sup> Department of Medical Microbiology, University of Groningen, University Medical Center Groningen, Groningen, the Netherlands - [rug.nl](http://www.rug.nl) [umcg.nl](http://www.umcg.nl)<br>
<sup>2</sup> Certe Medical Diagnostics & Advice, Groningen, the Netherlands - [certe.nl](http://www.certe.nl)<br>
<sup>3</sup> Heymans Institute for Psychological Research, University of Groningen, Groningen, the Netherlands - [rug.nl](http://www.rug.nl)<br>
<a href="https://www.rug.nl"><img src="man/figures/logo_rug.png" height="60px"></a>
<a href="https://www.umcg.nl"><img src="man/figures/logo_umcg.png" height="60px"></a>
<a href="https://www.certe.nl"><img src="man/figures/logo_certe.png" height="60px"></a>
<a href="http://www.eurhealth-1health.eu"><img src="man/figures/logo_eh1h.png" height="60px"></a>
<a href="http://www.eurhealth-1health.eu"><img src="man/figures/logo_interreg.png" height="60px"></a>
## How to get this package
### How to get this package
Please see [our website](https://msberends.gitlab.io/AMR/#get-this-package).
## Copyright
### Copyright
This R package is licensed under the [GNU General Public License (GPL) v2.0](https://gitlab.com/msberends/AMR/blob/master/LICENSE). In a nutshell, this means that this package:

3
_pkgdown.yml
View File

@@ -162,10 +162,9 @@ reference:
'like' function can be useful: `if (x %like% y) {...}`.
contents:
- "`get_locale`"
- "`extended-functions`"
- "`like`"
- "`reexports`"
- "`AMR-vctrs`"
- "`AMR-tidyverse`"
- title: Deprecated functions
desc: >
These functions are deprecated, meaning that they will still

2
data-raw/country_analysis.R
View File

@@ -52,7 +52,7 @@ unique_ip <- unique(data$ipaddress)
ip_tbl <- GET_df(unique_ip[1])
p <- AMR:::progress_estimated(n = length(unique_ip) - 1, min_time = 0)
for (i in 2:length(unique_ip)) {
p$tick()$print()
p$tick()
ip_tbl <- ip_tbl %>%
bind_rows(GET_df(unique_ip[i]))
}

36
data-raw/eucast_rules.tsv
View File

@@ -128,24 +128,24 @@ genus_species is Kingella kingae TCY R DOX R Kingella kingae Breakpoints
genus_species is Burkholderia pseudomallei TCY S DOX S Burkholderia pseudomallei Breakpoints
genus_species is Burkholderia pseudomallei TCY I DOX I Burkholderia pseudomallei Breakpoints
genus_species is Burkholderia pseudomallei TCY R DOX R Burkholderia pseudomallei Breakpoints
order is Enterobacterales PEN, glycopeptides, FUS, macrolides, LIN, streptogramins, RIF, DAP, LNZ R Table 01: Intrinsic resistance in Enterobacteriaceae Expert Rules
fullname like ^Citrobacter (koseri|amalonaticus|sedlakii|farmeri|rodentium) aminopenicillins, TIC R Table 01: Intrinsic resistance in Enterobacteriaceae Expert Rules
fullname like ^Citrobacter (freundii|braakii|murliniae|werkmanii|youngae) aminopenicillins, AMC, CZO, FOX R Table 01: Intrinsic resistance in Enterobacteriaceae Expert Rules
genus_species is Enterobacter cloacae aminopenicillins, AMC, CZO, FOX R Table 01: Intrinsic resistance in Enterobacteriaceae Expert Rules
genus_species is Enterobacter aerogenes aminopenicillins, AMC, CZO, FOX R Table 01: Intrinsic resistance in Enterobacteriaceae Expert Rules
genus_species is Escherichia hermanni aminopenicillins, TIC R Table 01: Intrinsic resistance in Enterobacteriaceae Expert Rules
genus_species is Hafnia alvei aminopenicillins, AMC, CZO, FOX R Table 01: Intrinsic resistance in Enterobacteriaceae Expert Rules
genus is Klebsiella aminopenicillins, TIC R Table 01: Intrinsic resistance in Enterobacteriaceae Expert Rules
genus_species is Morganella morganii aminopenicillins, AMC, CZO, tetracyclines, polymyxins, NIT R Table 01: Intrinsic resistance in Enterobacteriaceae Expert Rules
genus_species is Proteus mirabilis tetracyclines, TGC, polymyxins, NIT R Table 01: Intrinsic resistance in Enterobacteriaceae Expert Rules
genus_species is Proteus penneri aminopenicillins, CZO, CXM, tetracyclines, TGC, polymyxins, NIT R Table 01: Intrinsic resistance in Enterobacteriaceae Expert Rules
genus_species is Proteus vulgaris aminopenicillins, CZO, CXM, tetracyclines, TGC, polymyxins, NIT R Table 01: Intrinsic resistance in Enterobacteriaceae Expert Rules
genus_species is Providencia rettgeri aminopenicillins, AMC, CZO, CXM, tetracyclines, TGC, polymyxins, NIT R Table 01: Intrinsic resistance in Enterobacteriaceae Expert Rules
genus_species is Providencia stuartii aminopenicillins, AMC, CZO, CXM, tetracyclines, TGC, polymyxins, NIT R Table 01: Intrinsic resistance in Enterobacteriaceae Expert Rules
genus is Raoultella aminopenicillins, TIC R Table 01: Intrinsic resistance in Enterobacteriaceae Expert Rules
genus_species is Serratia marcescens aminopenicillins, AMC, CZO, FOX, CXM, DOX, TCY, polymyxins, NIT R Table 01: Intrinsic resistance in Enterobacteriaceae Expert Rules
genus_species is Yersinia enterocolitica aminopenicillins, AMC, TIC, CZO, FOX R Table 01: Intrinsic resistance in Enterobacteriaceae Expert Rules
genus_species is Yersinia pseudotuberculosis PLB, COL R Table 01: Intrinsic resistance in Enterobacteriaceae Expert Rules
order is Enterobacterales PEN, glycopeptides, FUS, macrolides, LIN, streptogramins, RIF, DAP, LNZ R Table 01: Intrinsic resistance in Enterobacterales (at the time: Enterobacteriaceae) Expert Rules
fullname like ^Citrobacter (koseri|amalonaticus|sedlakii|farmeri|rodentium) aminopenicillins, TIC R Table 01: Intrinsic resistance in Enterobacterales (at the time: Enterobacteriaceae) Expert Rules
fullname like ^Citrobacter (freundii|braakii|murliniae|werkmanii|youngae) aminopenicillins, AMC, CZO, FOX R Table 01: Intrinsic resistance in Enterobacterales (at the time: Enterobacteriaceae) Expert Rules
genus_species is Enterobacter cloacae aminopenicillins, AMC, CZO, FOX R Table 01: Intrinsic resistance in Enterobacterales (at the time: Enterobacteriaceae) Expert Rules
genus_species is Enterobacter aerogenes aminopenicillins, AMC, CZO, FOX R Table 01: Intrinsic resistance in Enterobacterales (at the time: Enterobacteriaceae) Expert Rules
genus_species is Escherichia hermanni aminopenicillins, TIC R Table 01: Intrinsic resistance in Enterobacterales (at the time: Enterobacteriaceae) Expert Rules
genus_species is Hafnia alvei aminopenicillins, AMC, CZO, FOX R Table 01: Intrinsic resistance in Enterobacterales (at the time: Enterobacteriaceae) Expert Rules
genus is Klebsiella aminopenicillins, TIC R Table 01: Intrinsic resistance in Enterobacterales (at the time: Enterobacteriaceae) Expert Rules
genus_species is Morganella morganii aminopenicillins, AMC, CZO, tetracyclines, polymyxins, NIT R Table 01: Intrinsic resistance in Enterobacterales (at the time: Enterobacteriaceae) Expert Rules
genus_species is Proteus mirabilis tetracyclines, TGC, polymyxins, NIT R Table 01: Intrinsic resistance in Enterobacterales (at the time: Enterobacteriaceae) Expert Rules
genus_species is Proteus penneri aminopenicillins, CZO, CXM, tetracyclines, TGC, polymyxins, NIT R Table 01: Intrinsic resistance in Enterobacterales (at the time: Enterobacteriaceae) Expert Rules
genus_species is Proteus vulgaris aminopenicillins, CZO, CXM, tetracyclines, TGC, polymyxins, NIT R Table 01: Intrinsic resistance in Enterobacterales (at the time: Enterobacteriaceae) Expert Rules
genus_species is Providencia rettgeri aminopenicillins, AMC, CZO, CXM, tetracyclines, TGC, polymyxins, NIT R Table 01: Intrinsic resistance in Enterobacterales (at the time: Enterobacteriaceae) Expert Rules
genus_species is Providencia stuartii aminopenicillins, AMC, CZO, CXM, tetracyclines, TGC, polymyxins, NIT R Table 01: Intrinsic resistance in Enterobacterales (at the time: Enterobacteriaceae) Expert Rules
genus is Raoultella aminopenicillins, TIC R Table 01: Intrinsic resistance in Enterobacterales (at the time: Enterobacteriaceae) Expert Rules
genus_species is Serratia marcescens aminopenicillins, AMC, CZO, FOX, CXM, DOX, TCY, polymyxins, NIT R Table 01: Intrinsic resistance in Enterobacterales (at the time: Enterobacteriaceae) Expert Rules
genus_species is Yersinia enterocolitica aminopenicillins, AMC, TIC, CZO, FOX R Table 01: Intrinsic resistance in Enterobacterales (at the time: Enterobacteriaceae) Expert Rules
genus_species is Yersinia pseudotuberculosis PLB, COL R Table 01: Intrinsic resistance in Enterobacterales (at the time: Enterobacteriaceae) Expert Rules
genus one_of Achromobacter, Acinetobacter, Alcaligenes, Bordatella, Burkholderia, Elizabethkingia, Flavobacterium, Ochrobactrum, Pseudomonas, Stenotrophomonas PEN, FOX, CXM, glycopeptides, FUS, macrolides, LIN, streptogramins, RIF, DAP, LNZ R Table 02: Intrinsic resistance in non-fermentative Gram-negative bacteria Expert Rules
genus_species is Acinetobacter baumannii aminopenicillins, AMC, CZO, CTX, CRO, ATM, ETP, TMP, FOS, DOX, TCY R Table 02: Intrinsic resistance in non-fermentative Gram-negative bacteria Expert Rules
genus_species is Acinetobacter pittii aminopenicillins, AMC, CZO, CTX, CRO, ATM, ETP, TMP, FOS, DOX, TCY R Table 02: Intrinsic resistance in non-fermentative Gram-negative bacteria Expert Rules
Can't render this file because it contains an unexpected character in line 6 and column 96.

9
data-raw/internals.R
View File

@@ -70,15 +70,14 @@ rm(translations_file)
rm(microorganisms.translation)
# Save to raw data to repository ----
library(dplyr, warn.conflicts = FALSE, quietly = TRUE)
usethis::ui_done(paste0("Saving raw data to {usethis::ui_value('/data-raw/')}"))
devtools::load_all(quiet = TRUE)
# give official names to ABs and MOs
write.table(rsi_translation %>% mutate(ab = ab_name(ab), mo = mo_name(mo)),
write.table(dplyr::mutate(rsi_translation, ab = ab_name(ab), mo = mo_name(mo)),
"data-raw/rsi_translation.txt", sep = "\t", na = "", row.names = FALSE)
write.table(microorganisms %>% mutate_if(~!is.numeric(.), as.character),
write.table(dplyr::mutate_if(microorganisms, ~!is.numeric(.), as.character),
"data-raw/microorganisms.txt", sep = "\t", na = "", row.names = FALSE)
write.table(antibiotics %>% mutate_if(~!is.numeric(.), as.character),
write.table(dplyr::mutate_if(antibiotics, ~!is.numeric(.), as.character),
"data-raw/antibiotics.txt", sep = "\t", na = "", row.names = FALSE)
write.table(antivirals %>% mutate_all(as.character),
write.table(dplyr::mutate_all(antivirals, as.character),
"data-raw/antivirals.txt", sep = "\t", na = "", row.names = FALSE)

44
R/extended.R → data-raw/poorman_prepend.R
View File

@@ -19,30 +19,22 @@
# Visit our website for more info: https://msberends.gitlab.io/AMR. #
# ==================================================================== #
#' Extended functions
#'
#' These functions are extensions of functions in other packages.
#' @inheritSection lifecycle Stable lifecycle
#' @inheritSection AMR Read more on our website!
#' @export
#' @keywords internal
#' @name extended-functions
#' @rdname extended-functions
#' @exportMethod scale_type.mo
#' @export
scale_type.mo <- function(x) {
# fix for:
# "Don't know how to automatically pick scale for object of type mo. Defaulting to continuous."
# "Error: Discrete value supplied to continuous scale"
"discrete"
}
# ------------------------------------------------
# THIS FILE WAS CREATED AUTOMATICALLY!
# Source file: data-raw/reproduction_of_poorman.R
# ------------------------------------------------
# Poorman: a package to replace all dplyr functions with base R so we can lose dependency on dplyr.
# These functions were downloaded from https://github.com/nathaneastwood/poorman,
# from this commit: https://github.com/nathaneastwood/poorman/tree/{commit}
#
# All code below was released under MIT license, that permits 'free of charge, to any person obtaining a
# copy of the software and associated documentation files (the "Software"), to deal in the Software
# without restriction, including without limitation the rights to use, copy, modify, merge, publish,
# distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software
# is furnished to do so', given that a copyright notice is given in the software.
#
# Copyright notice as found on https://github.com/nathaneastwood/poorman/blob/master/LICENSE on 2 May 2020:
# YEAR: 2020
# COPYRIGHT HOLDER: Nathan Eastwood
#' @rdname extended-functions
#' @exportMethod scale_type.ab
#' @export
scale_type.ab <- function(x) {
# fix for:
# "Don't know how to automatically pick scale for object of type mo. Defaulting to continuous."
# "Error: Discrete value supplied to continuous scale"
"discrete"
}

38
data-raw/reproduction_of_poorman.R Normal file
View File

@@ -0,0 +1,38 @@
# get complete filenames of all R files in the GitHub repository of nathaneastwood/poorman
commit <- "7d76d77f8f7bc663bf30fb5a161abb49801afa17"
files <- xml2::read_html(paste0("https://github.com/nathaneastwood/poorman/tree/", commit, "/R")) %>%
rvest::html_nodes("table") %>%
rvest::html_table()
files <- files[[1]][,"Name"]
# remove files with only pkg specific code
files <- files[!files %in% c("zzz.R", "init.R")]
files <- paste0("https://raw.githubusercontent.com/nathaneastwood/poorman/", commit, "/R/",
files[grepl("[.]R$", files)])
# add our prepend file, containing info about the source of the data
files <- c("data-raw/poorman_prepend.R", files)
# read all contents to a character vector
contents <- character(0)
sapply(files, function(file) {
contents <<- c(contents, readLines(file))
invisible()
})
# remove lines starting with "#'" and NULL and write to file
contents <- contents[!grepl("^(#'|NULL|\"_PACKAGE)", contents)]
# now make it independent on UseMethod, since we will not export these functions
contents <- gsub('UseMethod[(]"(.*?)"[)]',
'if ("grouped_data" %in% class(.data)) {||| \\1.grouped_data(.data, ...)||| } else {||| \\1.default(.data, ...)||| }',
paste(contents, collapse = "|||"),
perl = TRUE) %>%
# add commit to intro part
gsub("{commit}", commit, ., fixed = TRUE) %>%
strsplit(split = "|||", fixed = TRUE) %>%
unlist()
writeLines(contents, "R/aa_helper_functions_dplyr.R")

2
docs/404.html
View File

@@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="https://msberends.gitlab.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.1.0.9003</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>

2
docs/LICENSE-text.html
View File

@@ -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.1.0.9003</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>

2
docs/articles/index.html
View File

@@ -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.1.0.9003</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>

2
docs/authors.html
View File

@@ -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.1.0.9003</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>

2
docs/index.html
View File

@@ -43,7 +43,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.1.0.9003</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>

2
docs/pkgdown.yml
View File

@@ -10,7 +10,7 @@ articles:
WHONET: WHONET.html
benchmarks: benchmarks.html
resistance_predict: resistance_predict.html
last_built: 2020-05-01T07:13Z
last_built: 2020-05-16T11:03Z
urls:
reference: https://msberends.gitlab.io/AMR/reference
article: https://msberends.gitlab.io/AMR/articles

8
docs/reference/AMR-deprecated.html
View File

@@ -82,7 +82,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.1.0</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>
@@ -235,9 +235,7 @@
<p>These functions are so-called '<a href='https://rdrr.io/r/base/Deprecated.html'>Deprecated</a>'. They will be removed in a future release. Using the functions will give a warning with the name of the function it has been replaced by (if there is one).</p>
</div>
<pre class="usage"><span class='fu'>p.symbol</span>(<span class='no'>...</span>)
<span class='fu'>portion_R</span>(<span class='no'>...</span>)
<pre class="usage"><span class='fu'>portion_R</span>(<span class='no'>...</span>)
<span class='fu'>portion_IR</span>(<span class='no'>...</span>)
@@ -277,7 +275,7 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>retired</
</div>
<div class="pkgdown">
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.0.</p>
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.</p>
</div>
</footer>

291
docs/reference/AMR-tidyverse.html Normal file
View File

@@ -0,0 +1,291 @@
<!-- Generated by pkgdown: do not edit by hand -->
<!DOCTYPE html>
<html lang="en">
<head>
<meta charset="utf-8">
<meta http-equiv="X-UA-Compatible" content="IE=edge">
<meta name="viewport" content="width=device-width, initial-scale=1.0">
<title>Methods for tidyverse — AMR-tidyverse • AMR (for R)</title>
<!-- favicons -->
<link rel="icon" type="image/png" sizes="16x16" href="../favicon-16x16.png">
<link rel="icon" type="image/png" sizes="32x32" href="../favicon-32x32.png">
<link rel="apple-touch-icon" type="image/png" sizes="180x180" href="../apple-touch-icon.png" />
<link rel="apple-touch-icon" type="image/png" sizes="120x120" href="../apple-touch-icon-120x120.png" />
<link rel="apple-touch-icon" type="image/png" sizes="76x76" href="../apple-touch-icon-76x76.png" />
<link rel="apple-touch-icon" type="image/png" sizes="60x60" href="../apple-touch-icon-60x60.png" />
<!-- jquery -->
<script src="https://cdnjs.cloudflare.com/ajax/libs/jquery/3.4.1/jquery.min.js" integrity="sha256-CSXorXvZcTkaix6Yvo6HppcZGetbYMGWSFlBw8HfCJo=" crossorigin="anonymous"></script>
<!-- Bootstrap -->
<link href="https://cdnjs.cloudflare.com/ajax/libs/bootswatch/3.4.0/flatly/bootstrap.min.css" rel="stylesheet" crossorigin="anonymous" />
<script src="https://cdnjs.cloudflare.com/ajax/libs/twitter-bootstrap/3.4.1/js/bootstrap.min.js" integrity="sha256-nuL8/2cJ5NDSSwnKD8VqreErSWHtnEP9E7AySL+1ev4=" crossorigin="anonymous"></script>
<!-- bootstrap-toc -->
<link rel="stylesheet" href="../bootstrap-toc.css">
<script src="../bootstrap-toc.js"></script>
<!-- Font Awesome icons -->
<link rel="stylesheet" href="https://cdnjs.cloudflare.com/ajax/libs/font-awesome/5.12.1/css/all.min.css" integrity="sha256-mmgLkCYLUQbXn0B1SRqzHar6dCnv9oZFPEC1g1cwlkk=" crossorigin="anonymous" />
<link rel="stylesheet" href="https://cdnjs.cloudflare.com/ajax/libs/font-awesome/5.12.1/css/v4-shims.min.css" integrity="sha256-wZjR52fzng1pJHwx4aV2AO3yyTOXrcDW7jBpJtTwVxw=" crossorigin="anonymous" />
<!-- clipboard.js -->
<script src="https://cdnjs.cloudflare.com/ajax/libs/clipboard.js/2.0.6/clipboard.min.js" integrity="sha256-inc5kl9MA1hkeYUt+EC3BhlIgyp/2jDIyBLS6k3UxPI=" crossorigin="anonymous"></script>
<!-- headroom.js -->
<script src="https://cdnjs.cloudflare.com/ajax/libs/headroom/0.11.0/headroom.min.js" integrity="sha256-AsUX4SJE1+yuDu5+mAVzJbuYNPHj/WroHuZ8Ir/CkE0=" crossorigin="anonymous"></script>
<script src="https://cdnjs.cloudflare.com/ajax/libs/headroom/0.11.0/jQuery.headroom.min.js" integrity="sha256-ZX/yNShbjqsohH1k95liqY9Gd8uOiE1S4vZc+9KQ1K4=" crossorigin="anonymous"></script>
<!-- pkgdown -->
<link href="../pkgdown.css" rel="stylesheet">
<script src="../pkgdown.js"></script>
<link href="../extra.css" rel="stylesheet">
<script src="../extra.js"></script>
<meta property="og:title" content="Methods for tidyverse — AMR-tidyverse" />
<meta property="og:description" content="These methods are needed to support methods used by the tidyverse, like joining and transforming data, with new classes that come with this package." />
<meta property="og:image" content="https://msberends.gitlab.io/AMR/logo.svg" />
<!-- mathjax -->
<script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js" integrity="sha256-nvJJv9wWKEm88qvoQl9ekL2J+k/RWIsaSScxxlsrv8k=" crossorigin="anonymous"></script>
<script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/config/TeX-AMS-MML_HTMLorMML.js" integrity="sha256-84DKXVJXs0/F8OTMzX4UR909+jtl4G7SPypPavF+GfA=" crossorigin="anonymous"></script>
<!--[if lt IE 9]>
<script src="https://oss.maxcdn.com/html5shiv/3.7.3/html5shiv.min.js"></script>
<script src="https://oss.maxcdn.com/respond/1.4.2/respond.min.js"></script>
<![endif]-->
</head>
<body data-spy="scroll" data-target="#toc">
<div class="container template-reference-topic">
<header>
<div class="navbar navbar-default navbar-fixed-top" role="navigation">
<div class="container">
<div class="navbar-header">
<button type="button" class="navbar-toggle collapsed" data-toggle="collapse" data-target="#navbar" aria-expanded="false">
<span class="sr-only">Toggle navigation</span>
<span class="icon-bar"></span>
<span class="icon-bar"></span>
<span class="icon-bar"></span>
</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.1.0.9004</span>
</span>
</div>
<div id="navbar" class="navbar-collapse collapse">
<ul class="nav navbar-nav">
<li>
<a href="../index.html">
<span class="fa 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>
How to
<span class="caret"></span>
</a>
<ul class="dropdown-menu" role="menu">
<li>
<a href="../articles/AMR.html">
<span class="fa fa-directions"></span>
Conduct AMR analysis
</a>
</li>
<li>
<a href="../articles/resistance_predict.html">
<span class="fa fa-dice"></span>
Predict antimicrobial resistance
</a>
</li>
<li>
<a href="../articles/PCA.html">
<span class="fa fa-compress"></span>
Conduct principal component analysis for AMR
</a>
</li>
<li>
<a href="../articles/MDR.html">
<span class="fa fa-skull-crossbones"></span>
Determine multi-drug resistance (MDR)
</a>
</li>
<li>
<a href="../articles/WHONET.html">
<span class="fa fa-globe-americas"></span>
Work with WHONET data
</a>
</li>
<li>
<a href="../articles/SPSS.html">
<span class="fa 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>
Apply EUCAST rules
</a>
</li>
<li>
<a href="../reference/mo_property.html">
<span class="fa fa-bug"></span>
Get properties of a microorganism
</a>
</li>
<li>
<a href="../reference/ab_property.html">
<span class="fa fa-capsules"></span>
Get properties of an antibiotic
</a>
</li>
<li>
<a href="../articles/benchmarks.html">
<span class="fa fa-shipping-fast"></span>
Other: benchmarks
</a>
</li>
</ul>
</li>
<li>
<a href="../reference/">
<span class="fa fa-book-open"></span>
Manual
</a>
</li>
<li>
<a href="../authors.html">
<span class="fa fa-users"></span>
Authors
</a>
</li>
<li>
<a href="../news/">
<span class="far fa far fa-newspaper"></span>
Changelog
</a>
</li>
</ul>
<ul class="nav navbar-nav navbar-right">
<li>
<a href="https://gitlab.com/msberends/AMR">
<span class="fab fa fab fa-gitlab"></span>
Source Code
</a>
</li>
<li>
<a href="../LICENSE-text.html">
<span class="fa fa-book"></span>
Licence
</a>
</li>
</ul>
</div><!--/.nav-collapse -->
</div><!--/.container -->
</div><!--/.navbar -->
</header>
<div class="row">
<div class="col-md-9 contents">
<div class="page-header">
<h1>Methods for tidyverse</h1>
<small class="dont-index">Source: <a href='https://gitlab.com/msberends/AMR/blob/master/R/tidyverse.R'><code>R/tidyverse.R</code></a></small>
<div class="hidden name"><code>AMR-tidyverse.Rd</code></div>
</div>
<div class="ref-description">
<p>These methods are needed to support methods used by the tidyverse, like joining and transforming data, with new classes that come with this package.</p>
</div>
<pre class="usage"><span class='fu'>scale_type.mo</span>(<span class='no'>x</span>)
<span class='fu'>scale_type.ab</span>(<span class='no'>x</span>)
<span class='fu'>vec_ptype2.mo</span>(<span class='no'>x</span>, <span class='no'>y</span>, <span class='no'>...</span>)
<span class='fu'>vec_cast.mo</span>(<span class='no'>x</span>, <span class='no'>to</span>, <span class='no'>...</span>)
<span class='fu'>vec_ptype2.ab</span>(<span class='no'>x</span>, <span class='no'>y</span>, <span class='no'>...</span>)
<span class='fu'>vec_cast.ab</span>(<span class='no'>x</span>, <span class='no'>to</span>, <span class='no'>...</span>)</pre>
<h2 class="hasAnchor" id="stable-lifecycle"><a class="anchor" href="#stable-lifecycle"></a>Stable lifecycle</h2>
<p><img src='figures/lifecycle_stable.svg' style=margin-bottom:5px /> <br />
The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>stable</strong>. In a stable function, we are largely happy with the unlying code, and major changes are unlikely. This means that the unlying code will generally evolve by adding new arguments; we will avoid removing arguments or changing the meaning of existing arguments.</p>
<p>If the unlying code needs breaking changes, they will occur gradually. To begin with, the function or argument will be deprecated; it will continue to work but will emit an message informing you of the change. Next, typically after at least one newly released version on CRAN, the message will be transformed to an error.</p>
<h2 class="hasAnchor" id="read-more-on-our-website-"><a class="anchor" href="#read-more-on-our-website-"></a>Read more on our website!</h2>
<p>On our website <a href='https://msberends.gitlab.io/AMR'>https://msberends.gitlab.io/AMR</a> you can find <a href='https://msberends.gitlab.io/AMR/articles/AMR.html'>a comprehensive tutorial</a> about how to conduct AMR analysis, the <a href='https://msberends.gitlab.io/AMR/reference'>complete documentation of all functions</a> (which reads a lot easier than here in R) and <a href='https://msberends.gitlab.io/AMR/articles/WHONET.html'>an example analysis using WHONET data</a>.</p>
</div>
<div class="col-md-3 hidden-xs hidden-sm" id="pkgdown-sidebar">
<nav id="toc" data-toggle="toc" class="sticky-top">
<h2 data-toc-skip>Contents</h2>
</nav>
</div>
</div>
<footer>
<div class="copyright">
<p>Developed by <a href='https://www.rug.nl/staff/m.s.berends/'>Matthijs S. Berends</a>, <a href='https://www.rug.nl/staff/c.f.luz/'>Christian F. Luz</a>, <a href='https://www.rug.nl/staff/a.w.friedrich/'>Alexander W. Friedrich</a>, <a href='https://www.rug.nl/staff/b.sinha/'>Bhanu N. M. Sinha</a>, <a href='https://www.rug.nl/staff/c.j.albers/'>Casper J. Albers</a>, <a href='https://www.rug.nl/staff/c.glasner/'>Corinna Glasner</a>.</p>
</div>
<div class="pkgdown">
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.</p>
</div>
</footer>
</div>
</body>
</html>

2
docs/reference/antibiotics.html
View File

@@ -82,7 +82,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.1.0.9000</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>

9
docs/reference/as.mic.html
View File

@@ -82,7 +82,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.1.0</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>
@@ -291,9 +291,8 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>stable</s
<span class='kw'>ab</span> <span class='kw'>=</span> <span class='st'>"AMX"</span>,
<span class='kw'>guideline</span> <span class='kw'>=</span> <span class='st'>"EUCAST"</span>)
<span class='fu'><a href='https://rdrr.io/r/graphics/plot.html'>plot</a></span>(<span class='no'>mic_data</span>)
<span class='fu'><a href='https://rdrr.io/r/graphics/barplot.html'>barplot</a></span>(<span class='no'>mic_data</span>)
<span class='fu'><a href='https://rdrr.io/pkg/cleaner/man/freq.html'>freq</a></span>(<span class='no'>mic_data</span>)</pre>
<span class='fu'><a href='https://rdrr.io/r/base/plot.html'>plot</a></span>(<span class='no'>mic_data</span>)
<span class='fu'><a href='https://rdrr.io/r/graphics/barplot.html'>barplot</a></span>(<span class='no'>mic_data</span>)</pre>
</div>
<div class="col-md-3 hidden-xs hidden-sm" id="pkgdown-sidebar">
<nav id="toc" data-toggle="toc" class="sticky-top">
@@ -309,7 +308,7 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>stable</s
</div>
<div class="pkgdown">
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.0.</p>
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.</p>
</div>
</footer>

14
docs/reference/as.mo.html
View File

@@ -82,7 +82,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.1.0</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>
@@ -275,7 +275,7 @@
</tr>
<tr>
<th>reference_df</th>
<td><p>a <code><a href='https://rdrr.io/r/base/data.frame.html'>data.frame</a></code> to use for extra reference when translating <code>x</code> to a valid <code>mo</code>. See <code><a href='mo_source.html'>set_mo_source()</a></code> and <code><a href='mo_source.html'>get_mo_source()</a></code> to automate the usage of your own codes (e.g. used in your analysis or organisation).</p></td>
<td><p>a <code><a href='https://rdrr.io/r/base/data.frame.html'>data.frame</a></code> to be used for extra reference when translating <code>x</code> to a valid <code>mo</code>. See <code><a href='mo_source.html'>set_mo_source()</a></code> and <code><a href='mo_source.html'>get_mo_source()</a></code> to automate the usage of your own codes (e.g. used in your analysis or organisation).</p></td>
</tr>
<tr>
<th>...</th>
@@ -299,10 +299,10 @@
B_KLBSL_PNMN_RHNS Klebsiella pneumoniae rhinoscleromatis
| | | |
| | | |
| | | ---&gt; subspecies, a 4-5 letter acronym
| | ----&gt; species, a 4-5 letter acronym
| ----&gt; genus, a 5-7 letter acronym
----&gt; taxonomic kingdom: A (Archaea), AN (Animalia), B (Bacteria),
| | | ---&amp;gt; subspecies, a 4-5 letter acronym
| | ----&amp;gt; species, a 4-5 letter acronym
| ----&amp;gt; genus, a 5-7 letter acronym
----&amp;gt; taxonomic kingdom: A (Archaea), AN (Animalia), B (Bacteria),
C (Chromista), F (Fungi), P (Protozoa)
</pre>
@@ -455,7 +455,7 @@ This package contains the complete taxonomic tree of almost all microorganisms (
</div>
<div class="pkgdown">
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.0.</p>
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.</p>
</div>
</footer>

14
docs/reference/as.rsi.html
View File

@@ -82,7 +82,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.1.0</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>
@@ -285,7 +285,7 @@
</tr>
<tr>
<th>guideline</th>
<td><p>defaults to the latest included EUCAST guideline, run <code><a href='https://rdrr.io/r/base/unique.html'>unique(rsi_translation$guideline)</a></code> for all options</p></td>
<td><p>defaults to the latest included EUCAST guideline, see Details for all options</p></td>
</tr>
<tr>
<th>uti</th>
@@ -306,8 +306,9 @@
<p>Ordered factor with new class <code>rsi</code></p>
<h2 class="hasAnchor" id="details"><a class="anchor" href="#details"></a>Details</h2>
<p>Run <code><a href='https://rdrr.io/r/base/unique.html'>unique(rsi_translation$guideline)</a></code> for a list of all supported guidelines. The repository of this package contains <a href='https://gitlab.com/msberends/AMR/blob/master/data-raw/rsi_translation.txt'>this machine readable version</a> of these guidelines.</p>
<p>These guidelines are machine readable, since <a href='https://gitlab.com/msberends/AMR/blob/master/data-raw/rsi_translation.txt'></a>.</p>
<p>When using <code>as.rsi()</code> on untransformed data, the data will be cleaned to only contain values S, I and R. When using the function on data with class <code><a href='as.mic.html'>mic</a></code> (using <code><a href='as.mic.html'>as.mic()</a></code>) or class <code><a href='as.disk.html'>disk</a></code> (using <code><a href='as.disk.html'>as.disk()</a></code>), the data will be interpreted based on the guideline set with the <code>guideline</code> parameter.</p>
<p>Supported guidelines to be used as input for the <code>guideline</code> parameter are: "CLSI 2010", "CLSI 2011", "CLSI 2012", "CLSI 2013", "CLSI 2014", "CLSI 2015", "CLSI 2016", "CLSI 2017", "CLSI 2018", "CLSI 2019", "EUCAST 2011", "EUCAST 2012", "EUCAST 2013", "EUCAST 2014", "EUCAST 2015", "EUCAST 2016", "EUCAST 2017", "EUCAST 2018", "EUCAST 2019", "EUCAST 2020". Simply using <code>"CLSI"</code> or <code>"EUCAST"</code> for input will automatically select the latest version of that guideline.</p>
<p>The repository of this package <a href='https://gitlab.com/msberends/AMR/blob/master/data-raw/rsi_translation.txt'>contains a machine readable version</a> of all guidelines. This is a CSV file consisting of 18,964 rows and 10 columns. This file is machine readable, since it contains one row for every unique combination of the test method (MIC or disk diffusion), the antimicrobial agent and the microorganism. This <strong>allows for easy implementation of these rules in laboratory information systems (LIS)</strong>.</p>
<p>After using <code>as.rsi()</code>, you can use <code><a href='eucast_rules.html'>eucast_rules()</a></code> to (1) apply inferred susceptibility and resistance based on results of other antimicrobials and (2) apply intrinsic resistance based on taxonomic properties of a microorganism.</p>
<p>The function <code>is.rsi.eligible()</code> returns <code>TRUE</code> when a columns contains at most 5% invalid antimicrobial interpretations (not S and/or I and/or R), and <code>FALSE</code> otherwise. The threshold of 5% can be set with the <code>threshold</code> parameter.</p>
<h2 class="hasAnchor" id="interpretation-of-r-and-s-i"><a class="anchor" href="#interpretation-of-r-and-s-i"></a>Interpretation of R and S/I</h2>
@@ -396,9 +397,8 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>stable</s
<span class='no'>rsi_data</span> <span class='kw'>&lt;-</span> <span class='fu'>as.rsi</span>(<span class='fu'><a href='https://rdrr.io/r/base/c.html'>c</a></span>(<span class='fu'><a href='https://rdrr.io/r/base/rep.html'>rep</a></span>(<span class='st'>"S"</span>, <span class='fl'>474</span>), <span class='fu'><a href='https://rdrr.io/r/base/rep.html'>rep</a></span>(<span class='st'>"I"</span>, <span class='fl'>36</span>), <span class='fu'><a href='https://rdrr.io/r/base/rep.html'>rep</a></span>(<span class='st'>"R"</span>, <span class='fl'>370</span>)))
<span class='fu'>is.rsi</span>(<span class='no'>rsi_data</span>)
<span class='fu'><a href='https://rdrr.io/r/graphics/plot.html'>plot</a></span>(<span class='no'>rsi_data</span>) <span class='co'># for percentages</span>
<span class='fu'><a href='https://rdrr.io/r/base/plot.html'>plot</a></span>(<span class='no'>rsi_data</span>) <span class='co'># for percentages</span>
<span class='fu'><a href='https://rdrr.io/r/graphics/barplot.html'>barplot</a></span>(<span class='no'>rsi_data</span>) <span class='co'># for frequencies</span>
<span class='fu'><a href='https://rdrr.io/pkg/cleaner/man/freq.html'>freq</a></span>(<span class='no'>rsi_data</span>) <span class='co'># frequency table with informative header</span>
<span class='fu'><a href='https://rdrr.io/r/base/library.html'>library</a></span>(<span class='no'>dplyr</span>)
<span class='no'>example_isolates</span> <span class='kw'>%&gt;%</span>
@@ -430,7 +430,7 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>stable</s
</div>
<div class="pkgdown">
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.0.</p>
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.</p>
</div>
</footer>

8
docs/reference/catalogue_of_life_version.html
View File

@@ -82,7 +82,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.1.0</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>
@@ -260,10 +260,6 @@ This package contains the complete taxonomic tree of almost all microorganisms (
<div class='dont-index'><p><a href='microorganisms.html'>microorganisms</a></p></div>
<h2 class="hasAnchor" id="examples"><a class="anchor" href="#examples"></a>Examples</h2>
<pre class="examples"><span class='fu'><a href='https://rdrr.io/r/base/library.html'>library</a></span>(<span class='no'>dplyr</span>)
<span class='no'>microorganisms</span> <span class='kw'>%&gt;%</span> <span class='fu'><a href='https://rdrr.io/pkg/cleaner/man/freq.html'>freq</a></span>(<span class='no'>kingdom</span>)
<span class='no'>microorganisms</span> <span class='kw'>%&gt;%</span> <span class='fu'><a href='https://dplyr.tidyverse.org/reference/group_by.html'>group_by</a></span>(<span class='no'>kingdom</span>) <span class='kw'>%&gt;%</span> <span class='fu'><a href='https://rdrr.io/pkg/cleaner/man/freq.html'>freq</a></span>(<span class='no'>phylum</span>, <span class='kw'>nmax</span> <span class='kw'>=</span> <span class='kw'>NULL</span>)</pre>
</div>
<div class="col-md-3 hidden-xs hidden-sm" id="pkgdown-sidebar">
<nav id="toc" data-toggle="toc" class="sticky-top">
@@ -279,7 +275,7 @@ This package contains the complete taxonomic tree of almost all microorganisms (
</div>
<div class="pkgdown">
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.0.</p>
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.</p>
</div>
</footer>

22
docs/reference/count.html
View File

@@ -83,7 +83,7 @@ count_resistant() should be used to count resistant isolates, count_susceptible(
</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.1.0</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>
@@ -304,7 +304,7 @@ count_resistant() should be used to count resistant isolates, count_susceptible(
<p>These functions are meant to count isolates. Use the <code><a href='proportion.html'>resistance()</a></code>/<code><a href='proportion.html'>susceptibility()</a></code> functions to calculate microbial resistance/susceptibility.</p>
<p>The function <code>count_resistant()</code> is equal to the function <code>count_R()</code>. The function <code>count_susceptible()</code> is equal to the function <code>count_SI()</code>.</p>
<p>The function <code>n_rsi()</code> is an alias of <code>count_all()</code>. They can be used to count all available isolates, i.e. where all input antibiotics have an available result (S, I or R). Their use is equal to <code><a href='https://dplyr.tidyverse.org/reference/n_distinct.html'>n_distinct()</a></code>. Their function is equal to <code>count_susceptible(...) + count_resistant(...)</code>.</p>
<p>The function <code>count_df()</code> takes any variable from <code>data</code> that has an <code><a href='as.rsi.html'>rsi</a></code> class (created with <code><a href='as.rsi.html'>as.rsi()</a></code>) and counts the number of S's, I's and R's. The function <code><a href='proportion.html'>rsi_df()</a></code> works exactly like <code>count_df()</code>, but adds the percentage of S, I and R.</p>
<p>The function <code>count_df()</code> takes any variable from <code>data</code> that has an <code><a href='as.rsi.html'>rsi</a></code> class (created with <code><a href='as.rsi.html'>as.rsi()</a></code>) and counts the number of S's, I's and R's. It also supports grouped variables. The function <code><a href='proportion.html'>rsi_df()</a></code> works exactly like <code>count_df()</code>, but adds the percentage of S, I and R.</p>
<h2 class="hasAnchor" id="stable-lifecycle"><a class="anchor" href="#stable-lifecycle"></a>Stable lifecycle</h2>
@@ -338,21 +338,21 @@ A microorganism is categorised as <em>Susceptible, Increased exposure</em> when
-------- -------- ---------- ----------- ---------- -----------
S or I S or I X X X X
R S or I X X X X
&lt;NA&gt; S or I X X - -
&amp;lt;NA&amp;gt; S or I X X - -
S or I R X X X X
R R - X - X
&lt;NA&gt; R - - - -
S or I &lt;NA&gt; X X - -
R &lt;NA&gt; - - - -
&lt;NA&gt; &lt;NA&gt; - - - -
&amp;lt;NA&amp;gt; R - - - -
S or I &amp;lt;NA&amp;gt; X X - -
R &amp;lt;NA&amp;gt; - - - -
&amp;lt;NA&amp;gt; &amp;lt;NA&amp;gt; - - - -
--------------------------------------------------------------------
</pre>
<p>Please note that, in combination therapies, for <code>only_all_tested = TRUE</code> applies that:</p><pre> <span class='fu'>count_S</span>() + <span class='fu'>count_I</span>() + <span class='fu'>count_R</span>() <span class='kw'>=</span> <span class='fu'>count_all</span>()
<span class='fu'><a href='proportion.html'>proportion_S</a></span>() + <span class='fu'><a href='proportion.html'>proportion_I</a></span>() + <span class='fu'><a href='proportion.html'>proportion_R</a></span>() <span class='kw'>=</span> <span class='fl'>1</span></pre>
<p>and that, in combination therapies, for <code>only_all_tested = FALSE</code> applies that:</p><pre> count_S() + count_I() + count_R() &gt;= count_all()
proportion_S() + proportion_I() + proportion_R() &gt;= 1
<p>and that, in combination therapies, for <code>only_all_tested = FALSE</code> applies that:</p><pre> count_S() + count_I() + count_R() &amp;gt;= count_all()
proportion_S() + proportion_I() + proportion_R() &amp;gt;= 1
</pre>
<p>Using <code>only_all_tested</code> has no impact when only using one antibiotic as input.</p>
@@ -399,7 +399,7 @@ A microorganism is categorised as <em>Susceptible, Increased exposure</em> when
<span class='kw'>S</span> <span class='kw'>=</span> <span class='fu'>count_S</span>(<span class='no'>CIP</span>),
<span class='kw'>n1</span> <span class='kw'>=</span> <span class='fu'>count_all</span>(<span class='no'>CIP</span>), <span class='co'># the actual total; sum of all three</span>
<span class='kw'>n2</span> <span class='kw'>=</span> <span class='fu'>n_rsi</span>(<span class='no'>CIP</span>), <span class='co'># same - analogous to n_distinct</span>
<span class='kw'>total</span> <span class='kw'>=</span> <span class='fu'><a href='https://dplyr.tidyverse.org/reference/context.html'>n</a></span>()) <span class='co'># NOT the number of tested isolates!</span>
<span class='kw'>total</span> <span class='kw'>=</span> <span class='fu'><a href='https://dplyr.tidyverse.org/reference/n.html'>n</a></span>()) <span class='co'># NOT the number of tested isolates!</span>
<span class='co'># Count co-resistance between amoxicillin/clav acid and gentamicin,</span>
<span class='co'># so we can see that combination therapy does a lot more than mono therapy.</span>
@@ -437,7 +437,7 @@ A microorganism is categorised as <em>Susceptible, Increased exposure</em> when
</div>
<div class="pkgdown">
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.0.</p>
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.</p>
</div>
</footer>

20
docs/reference/filter_ab_class.html
View File

@@ -6,7 +6,7 @@
<meta http-equiv="X-UA-Compatible" content="IE=edge">
<meta name="viewport" content="width=device-width, initial-scale=1.0">
<title>Filter isolates on result in antibiotic class — filter_ab_class • AMR (for R)</title>
<title>Filter isolates on result in antimicrobial class — filter_ab_class • AMR (for R)</title>
<!-- favicons -->
<link rel="icon" type="image/png" sizes="16x16" href="../favicon-16x16.png">
@@ -48,8 +48,8 @@
<link href="../extra.css" rel="stylesheet">
<script src="../extra.js"></script>
<meta property="og:title" content="Filter isolates on result in antibiotic class — filter_ab_class" />
<meta property="og:description" content="Filter isolates on results in specific antibiotic variables based on their antibiotic class. This makes it easy to filter on isolates that were tested for e.g. any aminoglycoside." />
<meta property="og:title" content="Filter isolates on result in antimicrobial class — filter_ab_class" />
<meta property="og:description" content="Filter isolates on results in specific antimicrobial classes. This makes it easy to filter on isolates that were tested for e.g. any aminoglycoside." />
<meta property="og:image" content="https://msberends.gitlab.io/AMR/logo.svg" />
@@ -82,7 +82,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.1.0</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>
@@ -226,13 +226,13 @@
<div class="row">
<div class="col-md-9 contents">
<div class="page-header">
<h1>Filter isolates on result in antibiotic class</h1>
<h1>Filter isolates on result in antimicrobial class</h1>
<small class="dont-index">Source: <a href='https://gitlab.com/msberends/AMR/blob/master/R/filter_ab_class.R'><code>R/filter_ab_class.R</code></a></small>
<div class="hidden name"><code>filter_ab_class.Rd</code></div>
</div>
<div class="ref-description">
<p>Filter isolates on results in specific antibiotic variables based on their antibiotic class. This makes it easy to filter on isolates that were tested for e.g. any aminoglycoside.</p>
<p>Filter isolates on results in specific antimicrobial classes. This makes it easy to filter on isolates that were tested for e.g. any aminoglycoside.</p>
</div>
<pre class="usage"><span class='fu'>filter_ab_class</span>(<span class='no'>x</span>, <span class='no'>ab_class</span>, <span class='kw'>result</span> <span class='kw'>=</span> <span class='kw'>NULL</span>, <span class='kw'>scope</span> <span class='kw'>=</span> <span class='st'>"any"</span>, <span class='no'>...</span>)
@@ -298,7 +298,8 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>stable</s
<p>If the unlying code needs breaking changes, they will occur gradually. To begin with, the function or argument will be deprecated; it will continue to work but will emit an message informing you of the change. Next, typically after at least one newly released version on CRAN, the message will be transformed to an error.</p>
<h2 class="hasAnchor" id="examples"><a class="anchor" href="#examples"></a>Examples</h2>
<pre class="examples"><span class='fu'><a href='https://rdrr.io/r/base/library.html'>library</a></span>(<span class='no'>dplyr</span>)
<pre class="examples"><span class='kw'>if</span> (<span class='fl'>FALSE</span>) {
<span class='fu'><a href='https://rdrr.io/r/base/library.html'>library</a></span>(<span class='no'>dplyr</span>)
<span class='co'># filter on isolates that have any result for any aminoglycoside</span>
<span class='no'>example_isolates</span> <span class='kw'>%&gt;%</span> <span class='fu'>filter_aminoglycosides</span>()
@@ -325,7 +326,8 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>stable</s
<span class='co'># all aminoglycosides and all fluoroquinolones</span>
<span class='no'>example_isolates</span> <span class='kw'>%&gt;%</span>
<span class='fu'>filter_aminoglycosides</span>(<span class='st'>"R"</span>, <span class='st'>"all"</span>) <span class='kw'>%&gt;%</span>
<span class='fu'>filter_fluoroquinolones</span>(<span class='st'>"R"</span>, <span class='st'>"all"</span>)</pre>
<span class='fu'>filter_fluoroquinolones</span>(<span class='st'>"R"</span>, <span class='st'>"all"</span>)
}</pre>
</div>
<div class="col-md-3 hidden-xs hidden-sm" id="pkgdown-sidebar">
<nav id="toc" data-toggle="toc" class="sticky-top">
@@ -341,7 +343,7 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>stable</s
</div>
<div class="pkgdown">
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.0.</p>
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.</p>
</div>
</footer>

9
docs/reference/first_isolate.html
View File

@@ -82,7 +82,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.1.0.9000</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>
@@ -352,7 +352,7 @@
<h2 class="hasAnchor" id="source"><a class="anchor" href="#source"></a>Source</h2>
<p>Methodology of this function is based on:</p>
<p>Methodology of this function is strictly based on:</p>
<p><strong>M39 Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data, 4th Edition</strong>, 2014, <em>Clinical and Laboratory Standards Institute (CLSI)</em>. <a href='https://clsi.org/standards/products/microbiology/documents/m39/'>https://clsi.org/standards/products/microbiology/documents/m39/</a>.</p>
<h2 class="hasAnchor" id="value"><a class="anchor" href="#value"></a>Value</h2>
@@ -405,6 +405,7 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>stable</s
<pre class="examples"><span class='co'># `example_isolates` is a dataset available in the AMR package.</span>
<span class='co'># See ?example_isolates.</span>
<span class='kw'>if</span> (<span class='fl'>FALSE</span>) {
<span class='fu'><a href='https://rdrr.io/r/base/library.html'>library</a></span>(<span class='no'>dplyr</span>)
<span class='co'># Filter on first isolates:</span>
<span class='no'>example_isolates</span> <span class='kw'>%&gt;%</span>
@@ -425,14 +426,12 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>stable</s
<span class='co'># Have a look at A and B.</span>
<span class='co'># B is more reliable because every isolate is counted only once.</span>
<span class='co'># Gentamicin resitance in hospital D appears to be 3.7% higher than</span>
<span class='co'># Gentamicin resistance in hospital D appears to be 3.7% higher than</span>
<span class='co'># when you (erroneously) would have used all isolates for analysis.</span>
<span class='co'>## OTHER EXAMPLES:</span>
<span class='kw'>if</span> (<span class='fl'>FALSE</span>) {
<span class='co'># Short-hand versions:</span>
<span class='no'>example_isolates</span> <span class='kw'>%&gt;%</span>
<span class='fu'>filter_first_isolate</span>()

8
docs/reference/ggplot_pca.html
View File

@@ -82,7 +82,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.1.0</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>
@@ -382,6 +382,7 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>maturing<
<pre class="examples"><span class='co'># `example_isolates` is a dataset available in the AMR package.</span>
<span class='co'># See ?example_isolates.</span>
<span class='kw'>if</span> (<span class='fl'>FALSE</span>) {
<span class='co'># See ?pca for more info about Principal Component Analysis (PCA).</span>
<span class='fu'><a href='https://rdrr.io/r/base/library.html'>library</a></span>(<span class='no'>dplyr</span>)
<span class='no'>pca_model</span> <span class='kw'>&lt;-</span> <span class='no'>example_isolates</span> <span class='kw'>%&gt;%</span>
@@ -394,7 +395,8 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>maturing<
<span class='fu'><a href='https://rdrr.io/r/stats/biplot.html'>biplot</a></span>(<span class='no'>pca_model</span>)
<span class='co'># new </span>
<span class='fu'>ggplot_pca</span>(<span class='no'>pca_model</span>)</pre>
<span class='fu'>ggplot_pca</span>(<span class='no'>pca_model</span>)
}</pre>
</div>
<div class="col-md-3 hidden-xs hidden-sm" id="pkgdown-sidebar">
<nav id="toc" data-toggle="toc" class="sticky-top">
@@ -410,7 +412,7 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>maturing<
</div>
<div class="pkgdown">
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.0.</p>
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.</p>
</div>
</footer>

28
docs/reference/ggplot_rsi.html
View File

@@ -82,7 +82,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.1.0</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>
@@ -484,30 +484,6 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>maturing<
<span class='kw'>title</span> <span class='kw'>=</span> <span class='st'>"AMR of Anti-UTI Drugs Per Hospital"</span>,
<span class='kw'>x.title</span> <span class='kw'>=</span> <span class='st'>"Hospital"</span>,
<span class='kw'>datalabels</span> <span class='kw'>=</span> <span class='fl'>FALSE</span>)
<span class='co'># genuine analysis: check 3 most prevalent microorganisms</span>
<span class='no'>example_isolates</span> <span class='kw'>%&gt;%</span>
<span class='co'># create new bacterial ID's, with all CoNS under the same group (Becker et al.)</span>
<span class='fu'><a href='https://dplyr.tidyverse.org/reference/mutate.html'>mutate</a></span>(<span class='kw'>mo</span> <span class='kw'>=</span> <span class='fu'><a href='as.mo.html'>as.mo</a></span>(<span class='no'>mo</span>, <span class='kw'>Becker</span> <span class='kw'>=</span> <span class='fl'>TRUE</span>)) <span class='kw'>%&gt;%</span>
<span class='co'># filter on top three bacterial ID's</span>
<span class='fu'><a href='https://dplyr.tidyverse.org/reference/filter.html'>filter</a></span>(<span class='no'>mo</span> <span class='kw'>%in%</span> <span class='fu'>top_freq</span>(<span class='fu'><a href='https://rdrr.io/pkg/cleaner/man/freq.html'>freq</a></span>(<span class='no'>.</span>$<span class='no'>mo</span>), <span class='fl'>3</span>)) <span class='kw'>%&gt;%</span>
<span class='co'># filter on first isolates</span>
<span class='fu'><a href='first_isolate.html'>filter_first_isolate</a></span>() <span class='kw'>%&gt;%</span>
<span class='co'># get short MO names (like "E. coli")</span>
<span class='fu'><a href='https://dplyr.tidyverse.org/reference/mutate.html'>mutate</a></span>(<span class='kw'>bug</span> <span class='kw'>=</span> <span class='fu'><a href='mo_property.html'>mo_shortname</a></span>(<span class='no'>mo</span>, <span class='kw'>Becker</span> <span class='kw'>=</span> <span class='fl'>TRUE</span>)) <span class='kw'>%&gt;%</span>
<span class='co'># select this short name and some antiseptic drugs</span>
<span class='fu'><a href='https://dplyr.tidyverse.org/reference/select.html'>select</a></span>(<span class='no'>bug</span>, <span class='no'>CXM</span>, <span class='no'>GEN</span>, <span class='no'>CIP</span>) <span class='kw'>%&gt;%</span>
<span class='co'># group by MO</span>
<span class='fu'><a href='https://dplyr.tidyverse.org/reference/group_by.html'>group_by</a></span>(<span class='no'>bug</span>) <span class='kw'>%&gt;%</span>
<span class='co'># plot the thing, putting MOs on the facet</span>
<span class='fu'>ggplot_rsi</span>(<span class='kw'>x</span> <span class='kw'>=</span> <span class='st'>"antibiotic"</span>,
<span class='kw'>facet</span> <span class='kw'>=</span> <span class='st'>"bug"</span>,
<span class='kw'>translate_ab</span> <span class='kw'>=</span> <span class='fl'>FALSE</span>,
<span class='kw'>nrow</span> <span class='kw'>=</span> <span class='fl'>1</span>,
<span class='kw'>title</span> <span class='kw'>=</span> <span class='st'>"AMR of Top Three Microorganisms In Blood Culture Isolates"</span>,
<span class='kw'>subtitle</span> <span class='kw'>=</span> <span class='fu'><a href='https://rdrr.io/r/base/expression.html'>expression</a></span>(<span class='fu'><a href='https://rdrr.io/r/base/paste.html'>paste</a></span>(<span class='st'>"Only First Isolates, CoNS grouped according to Becker "</span>,
<span class='fu'><a href='https://rdrr.io/r/grDevices/plotmath.html'>italic</a></span>(<span class='st'>"et al."</span>), <span class='st'>" (2014)"</span>)),
<span class='kw'>x.title</span> <span class='kw'>=</span> <span class='st'>"Antibiotic (EARS-Net code)"</span>)
}</pre>
</div>
<div class="col-md-3 hidden-xs hidden-sm" id="pkgdown-sidebar">
@@ -524,7 +500,7 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>maturing<
</div>
<div class="pkgdown">
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.0.</p>
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.</p>
</div>
</footer>

18
docs/reference/index.html
View File

@@ -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.1.0.9003</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>
@@ -350,7 +350,7 @@
<td>
<p><code><a href="join.html">inner_join_microorganisms()</a></code> <code><a href="join.html">left_join_microorganisms()</a></code> <code><a href="join.html">right_join_microorganisms()</a></code> <code><a href="join.html">full_join_microorganisms()</a></code> <code><a href="join.html">semi_join_microorganisms()</a></code> <code><a href="join.html">anti_join_microorganisms()</a></code> </p>
</td>
<td><p>Join a table with microorganisms</p></td>
<td><p>Join microorganisms to a data set</p></td>
</tr><tr>
<td>
@@ -429,7 +429,7 @@
<td>
<p><code><a href="filter_ab_class.html">filter_ab_class()</a></code> <code><a href="filter_ab_class.html">filter_aminoglycosides()</a></code> <code><a href="filter_ab_class.html">filter_carbapenems()</a></code> <code><a href="filter_ab_class.html">filter_cephalosporins()</a></code> <code><a href="filter_ab_class.html">filter_1st_cephalosporins()</a></code> <code><a href="filter_ab_class.html">filter_2nd_cephalosporins()</a></code> <code><a href="filter_ab_class.html">filter_3rd_cephalosporins()</a></code> <code><a href="filter_ab_class.html">filter_4th_cephalosporins()</a></code> <code><a href="filter_ab_class.html">filter_5th_cephalosporins()</a></code> <code><a href="filter_ab_class.html">filter_fluoroquinolones()</a></code> <code><a href="filter_ab_class.html">filter_glycopeptides()</a></code> <code><a href="filter_ab_class.html">filter_macrolides()</a></code> <code><a href="filter_ab_class.html">filter_tetracyclines()</a></code> </p>
</td>
<td><p>Filter isolates on result in antibiotic class</p></td>
<td><p>Filter isolates on result in antimicrobial class</p></td>
</tr><tr>
<td>
@@ -585,12 +585,6 @@
<td><p>Translate strings from AMR package</p></td>
</tr><tr>
<td>
<p><code><a href="extended-functions.html">scale_type.mo()</a></code> <code><a href="extended-functions.html">scale_type.ab()</a></code> </p>
</td>
<td><p>Extended functions</p></td>
</tr><tr>
<td>
<p><code><a href="like.html">like()</a></code> <code><a href="like.html">`%like%`</a></code> <code><a href="like.html">`%like_case%`</a></code> </p>
</td>
@@ -604,9 +598,9 @@
</tr><tr>
<td>
<p><code><a href="AMR-vctrs.html">vec_ptype2.mo()</a></code> <code><a href="AMR-vctrs.html">vec_cast.mo()</a></code> <code><a href="AMR-vctrs.html">vec_ptype2.ab()</a></code> <code><a href="AMR-vctrs.html">vec_cast.ab()</a></code> </p>
<p><code><a href="AMR-tidyverse.html">scale_type.mo()</a></code> <code><a href="AMR-tidyverse.html">scale_type.ab()</a></code> <code><a href="AMR-tidyverse.html">vec_ptype2.mo()</a></code> <code><a href="AMR-tidyverse.html">vec_cast.mo()</a></code> <code><a href="AMR-tidyverse.html">vec_ptype2.ab()</a></code> <code><a href="AMR-tidyverse.html">vec_cast.ab()</a></code> </p>
</td>
<td><p><code>vctrs</code> methods</p></td>
<td><p>Methods for tidyverse</p></td>
</tr>
</tbody><tbody>
<tr>
@@ -623,7 +617,7 @@
<tr>
<td>
<p><code><a href="AMR-deprecated.html">p.symbol()</a></code> <code><a href="AMR-deprecated.html">portion_R()</a></code> <code><a href="AMR-deprecated.html">portion_IR()</a></code> <code><a href="AMR-deprecated.html">portion_I()</a></code> <code><a href="AMR-deprecated.html">portion_SI()</a></code> <code><a href="AMR-deprecated.html">portion_S()</a></code> <code><a href="AMR-deprecated.html">portion_df()</a></code> </p>
<p><code><a href="AMR-deprecated.html">portion_R()</a></code> <code><a href="AMR-deprecated.html">portion_IR()</a></code> <code><a href="AMR-deprecated.html">portion_I()</a></code> <code><a href="AMR-deprecated.html">portion_SI()</a></code> <code><a href="AMR-deprecated.html">portion_S()</a></code> <code><a href="AMR-deprecated.html">portion_df()</a></code> </p>
</td>
<td><p>Deprecated functions</p></td>
</tr>

19
docs/reference/join.html
View File

@@ -6,7 +6,7 @@
<meta http-equiv="X-UA-Compatible" content="IE=edge">
<meta name="viewport" content="width=device-width, initial-scale=1.0">
<title>Join a table with <a href='microorganisms.html'>microorganisms</a> — join • AMR (for R)</title>
<title>Join <a href='microorganisms.html'>microorganisms</a> to a data set — join • AMR (for R)</title>
<!-- favicons -->
<link rel="icon" type="image/png" sizes="16x16" href="../favicon-16x16.png">
@@ -48,7 +48,7 @@
<link href="../extra.css" rel="stylesheet">
<script src="../extra.js"></script>
<meta property="og:title" content="Join a table with <a href='microorganisms.html'>microorganisms</a> — join" />
<meta property="og:title" content="Join <a href='microorganisms.html'>microorganisms</a> to a data set — join" />
<meta property="og:description" content="Join the data set microorganisms easily to an existing table or character vector." />
<meta property="og:image" content="https://msberends.gitlab.io/AMR/logo.svg" />
@@ -82,7 +82,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.1.0</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>
@@ -226,7 +226,7 @@
<div class="row">
<div class="col-md-9 contents">
<div class="page-header">
<h1>Join a table with <a href='microorganisms.html'>microorganisms</a></h1>
<h1>Join <a href='microorganisms.html'>microorganisms</a> to a data set</h1>
<small class="dont-index">Source: <a href='https://gitlab.com/msberends/AMR/blob/master/R/join_microorganisms.R'><code>R/join_microorganisms.R</code></a></small>
<div class="hidden name"><code>join.Rd</code></div>
</div>
@@ -264,13 +264,14 @@
</tr>
<tr>
<th>...</th>
<td><p>other parameters to pass on to <code><a href='https://dplyr.tidyverse.org/reference/mutate-joins.html'>dplyr::join()</a></code></p></td>
<td><p>other parameters to pass on to <code><a href='https://dplyr.tidyverse.org/reference/join.html'>dplyr::join()</a></code></p></td>
</tr>
</table>
<h2 class="hasAnchor" id="details"><a class="anchor" href="#details"></a>Details</h2>
<p><strong>Note:</strong> As opposed to the <code><a href='https://dplyr.tidyverse.org/reference/mutate-joins.html'>dplyr::join()</a></code> functions of <code>dplyr</code>, <code><a href='https://rdrr.io/r/base/character.html'>character</a></code> vectors are supported and at default existing columns will get a suffix <code>"2"</code> and the newly joined columns will not get a suffix. See <code><a href='https://dplyr.tidyverse.org/reference/mutate-joins.html'>dplyr::join()</a></code> for more information.</p>
<p><strong>Note:</strong> As opposed to the <code>join()</code> functions of <code>dplyr</code>, <code><a href='https://rdrr.io/r/base/character.html'>character</a></code> vectors are supported and at default existing columns will get a suffix <code>"2"</code> and the newly joined columns will not get a suffix.</p>
<p>These functions rely on <code><a href='https://rdrr.io/r/base/merge.html'>merge()</a></code>, a base R function to do joins.</p>
<h2 class="hasAnchor" id="stable-lifecycle"><a class="anchor" href="#stable-lifecycle"></a>Stable lifecycle</h2>
@@ -288,6 +289,7 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>stable</s
<pre class="examples"><span class='fu'>left_join_microorganisms</span>(<span class='fu'><a href='as.mo.html'>as.mo</a></span>(<span class='st'>"K. pneumoniae"</span>))
<span class='fu'>left_join_microorganisms</span>(<span class='st'>"B_KLBSL_PNE"</span>)
<span class='kw'>if</span> (<span class='fl'>FALSE</span>) {
<span class='fu'><a href='https://rdrr.io/r/base/library.html'>library</a></span>(<span class='no'>dplyr</span>)
<span class='no'>example_isolates</span> <span class='kw'>%&gt;%</span> <span class='fu'>left_join_microorganisms</span>()
@@ -299,7 +301,8 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>stable</s
<span class='kw'>stringsAsFactors</span> <span class='kw'>=</span> <span class='fl'>FALSE</span>)
<span class='fu'><a href='https://rdrr.io/r/base/colnames.html'>colnames</a></span>(<span class='no'>df</span>)
<span class='no'>df_joined</span> <span class='kw'>&lt;-</span> <span class='fu'>left_join_microorganisms</span>(<span class='no'>df</span>, <span class='st'>"bacteria"</span>)
<span class='fu'><a href='https://rdrr.io/r/base/colnames.html'>colnames</a></span>(<span class='no'>df_joined</span>)</pre>
<span class='fu'><a href='https://rdrr.io/r/base/colnames.html'>colnames</a></span>(<span class='no'>df_joined</span>)
}</pre>
</div>
<div class="col-md-3 hidden-xs hidden-sm" id="pkgdown-sidebar">
<nav id="toc" data-toggle="toc" class="sticky-top">
@@ -315,7 +318,7 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>stable</s
</div>
<div class="pkgdown">
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.0.</p>
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.</p>
</div>
</footer>

7
docs/reference/key_antibiotics.html
View File

@@ -82,7 +82,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.1.0</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>
@@ -324,7 +324,8 @@
<h2 class="hasAnchor" id="details"><a class="anchor" href="#details"></a>Details</h2>
<p>The function <code>key_antibiotics()</code> returns a character vector with 12 antibiotic results for every isolate. These isolates can then be compared using <code>key_antibiotics_equal()</code>, to check if two isolates have generally the same antibiogram. Missing and invalid values are replaced with a dot (<code>"."</code>). The <code><a href='first_isolate.html'>first_isolate()</a></code> function only uses this function on the same microbial species from the same patient. Using this, an MRSA will be included after a susceptible <em>S. aureus</em> (MSSA) found within the same episode (see <code>episode</code> parameter of <code><a href='first_isolate.html'>first_isolate()</a></code>). Without key antibiotic comparison it would not.</p>
<p>The function <code>key_antibiotics()</code> returns a character vector with 12 antibiotic results for every isolate. These isolates can then be compared using <code>key_antibiotics_equal()</code>, to check if two isolates have generally the same antibiogram. Missing and invalid values are replaced with a dot (<code>"."</code>) by <code>key_antibiotics()</code> and ignored by <code>key_antibiotics_equal()</code>.</p>
<p>The <code><a href='first_isolate.html'>first_isolate()</a></code> 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 <em>S. aureus</em> (MSSA) is found within the same patient episode. Without key antibiotic comparison it would not. See <code><a href='first_isolate.html'>first_isolate()</a></code> for more info.</p>
<p>At default, the antibiotics that are used for <strong>Gram-positive bacteria</strong> are:</p><ul>
<li><p>Amoxicillin</p></li>
<li><p>Amoxicillin/clavulanic acid</p></li>
@@ -427,7 +428,7 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>stable</s
</div>
<div class="pkgdown">
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.0.</p>
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.</p>
</div>
</footer>

18
docs/reference/like.html
View File

@@ -82,7 +82,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.1.0</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>
@@ -260,13 +260,19 @@
<h2 class="hasAnchor" id="source"><a class="anchor" href="#source"></a>Source</h2>
<p>Idea from the <a href='https://github.com/Rdatatable/data.table/blob/master/R/like.R'><code>like</code> function from the <code>data.table</code> package</a>, but made it case insensitive at default and let it support multiple patterns. Also, if the regex fails the first time, it tries again with <code>perl = TRUE</code>.</p>
<p>Idea from the <a href='https://github.com/Rdatatable/data.table/blob/master/R/like.R'><code>like</code> function from the <code>data.table</code> package</a></p>
<h2 class="hasAnchor" id="value"><a class="anchor" href="#value"></a>Value</h2>
<p>A <code><a href='https://rdrr.io/r/base/logical.html'>logical</a></code> vector</p>
<h2 class="hasAnchor" id="details"><a class="anchor" href="#details"></a>Details</h2>
<p>When running a regular expression fails, these functions try again with <code><a href='https://rdrr.io/r/base/grep.html'>base::grepl(..., perl = TRUE)</a></code>.</p>
<p>The <code>%like%</code> function:</p><ul>
<li><p>Is case insensitive (use <code>%like_case%</code> for case-sensitive matching)</p></li>
<li><p>Supports multiple patterns</p></li>
<li><p>Checks if <code>pattern</code> is a regular expression and sets <code>fixed = TRUE</code> if not, to greatly improve speed</p></li>
<li><p>Tries again with <code>perl = TRUE</code> if regex fails</p></li>
</ul>
<p>Using RStudio? This function can also be inserted from the Addins menu and can have its own Keyboard Shortcut like <code>Ctrl+Shift+L</code> or <code>Cmd+Shift+L</code> (see <code>Tools</code> &gt; <code>Modify Keyboard Shortcuts...</code>).</p>
<h2 class="hasAnchor" id="stable-lifecycle"><a class="anchor" href="#stable-lifecycle"></a>Stable lifecycle</h2>
@@ -299,11 +305,11 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>stable</s
<span class='no'>a</span> <span class='kw'>%like%</span> <span class='no'>b</span>
<span class='co'>#&gt; TRUE TRUE TRUE</span>
<span class='co'># get frequencies of bacteria whose name start with 'Ent' or 'ent'</span>
<span class='co'># get isolates whose name start with 'Ent' or 'ent'</span>
<span class='fu'><a href='https://rdrr.io/r/base/library.html'>library</a></span>(<span class='no'>dplyr</span>)
<span class='no'>example_isolates</span> <span class='kw'>%&gt;%</span>
<span class='fu'><a href='https://dplyr.tidyverse.org/reference/filter.html'>filter</a></span>(<span class='fu'><a href='mo_property.html'>mo_name</a></span>(<span class='no'>mo</span>) <span class='kw'>%like%</span> <span class='st'>"^ent"</span>) <span class='kw'>%&gt;%</span>
<span class='fu'><a href='https://rdrr.io/pkg/cleaner/man/freq.html'>freq</a></span>(<span class='fu'><a href='mo_property.html'>mo_genus</a></span>(<span class='no'>mo</span>))</pre>
<span class='fu'><a href='https://rdrr.io/pkg/cleaner/man/freq.html'>freq</a></span>(<span class='no'>mo</span>)</pre>
</div>
<div class="col-md-3 hidden-xs hidden-sm" id="pkgdown-sidebar">
<nav id="toc" data-toggle="toc" class="sticky-top">
@@ -319,7 +325,7 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>stable</s
</div>
<div class="pkgdown">
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.0.</p>
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.</p>
</div>
</footer>

4
docs/reference/mdro.html
View File

@@ -82,7 +82,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.1.0</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>
@@ -467,7 +467,7 @@ A microorganism is categorised as <em>Susceptible, Increased exposure</em> when
</div>
<div class="pkgdown">
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.0.</p>
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.</p>
</div>
</footer>

2
docs/reference/microorganisms.html
View File

@@ -82,7 +82,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.1.0.9000</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>

2
docs/reference/mo_property.html
View File

@@ -82,7 +82,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.1.0.9000</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>

10
docs/reference/pca.html
View File

@@ -82,7 +82,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.1.0</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>
@@ -254,7 +254,7 @@
</tr>
<tr>
<th>...</th>
<td><p>columns of <code>x</code> to be selected for PCA</p></td>
<td><p>columns of <code>x</code> to be selected for PCA, can be unquoted since it supports quasiquotation.</p></td>
</tr>
<tr>
<th>retx</th>
@@ -315,6 +315,7 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>maturing<
<pre class="examples"><span class='co'># `example_isolates` is a dataset available in the AMR package.</span>
<span class='co'># See ?example_isolates.</span>
<span class='kw'>if</span> (<span class='fl'>FALSE</span>) {
<span class='co'># calculate the resistance per group first</span>
<span class='fu'><a href='https://rdrr.io/r/base/library.html'>library</a></span>(<span class='no'>dplyr</span>)
<span class='no'>resistance_data</span> <span class='kw'>&lt;-</span> <span class='no'>example_isolates</span> <span class='kw'>%&gt;%</span>
@@ -329,7 +330,8 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>maturing<
<span class='no'>pca_result</span>
<span class='fu'><a href='https://rdrr.io/r/base/summary.html'>summary</a></span>(<span class='no'>pca_result</span>)
<span class='fu'><a href='https://rdrr.io/r/stats/biplot.html'>biplot</a></span>(<span class='no'>pca_result</span>)
<span class='fu'><a href='ggplot_pca.html'>ggplot_pca</a></span>(<span class='no'>pca_result</span>) <span class='co'># a new and convenient plot function</span></pre>
<span class='fu'><a href='ggplot_pca.html'>ggplot_pca</a></span>(<span class='no'>pca_result</span>) <span class='co'># a new and convenient plot function</span>
}</pre>
</div>
<div class="col-md-3 hidden-xs hidden-sm" id="pkgdown-sidebar">
<nav id="toc" data-toggle="toc" class="sticky-top">
@@ -345,7 +347,7 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>maturing<
</div>
<div class="pkgdown">
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.0.</p>
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.</p>
</div>
</footer>

30
docs/reference/proportion.html
View File

@@ -49,7 +49,7 @@
<script src="../extra.js"></script>
<meta property="og:title" content="Calculate microbial resistance — proportion" />
<meta property="og:description" content="These functions can be used to calculate the (co-)resistance or susceptibility of microbial isolates (i.e. percentage of S, SI, I, IR or R). All functions support quasiquotation with pipes, can be used in summarise()][dplyr::summarise()] and also support grouped variables, please see Examples.
<meta property="og:description" content="These functions can be used to calculate the (co-)resistance or susceptibility of microbial isolates (i.e. percentage of S, SI, I, IR or R). All functions support quasiquotation with pipes, can be used in summarise() from the dplyr package and also supports grouped variables, please see Examples.
resistance() should be used to calculate resistance, susceptibility() should be used to calculate susceptibility." />
<meta property="og:image" content="https://msberends.gitlab.io/AMR/logo.svg" />
@@ -83,7 +83,7 @@ resistance() should be used to calculate resistance, susceptibility() should be
</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.1.0</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>
@@ -233,7 +233,7 @@ resistance() should be used to calculate resistance, susceptibility() should be
</div>
<div class="ref-description">
<p>These functions can be used to calculate the (co-)resistance or susceptibility of microbial isolates (i.e. percentage of S, SI, I, IR or R). All functions support quasiquotation with pipes, can be used in <code>summarise()</code>][dplyr::summarise()] and also support grouped variables, please see <em>Examples</em>.</p>
<p>These functions can be used to calculate the (co-)resistance or susceptibility of microbial isolates (i.e. percentage of S, SI, I, IR or R). All functions support quasiquotation with pipes, can be used in <code>summarise()</code> from the <code>dplyr</code> package and also supports grouped variables, please see <em>Examples</em>.</p>
<p><code>resistance()</code> should be used to calculate resistance, <code>susceptibility()</code> should be used to calculate susceptibility.<br /></p>
</div>
@@ -323,7 +323,7 @@ resistance() should be used to calculate resistance, susceptibility() should be
<p>The function <code>resistance()</code> is equal to the function <code>proportion_R()</code>. The function <code>susceptibility()</code> is equal to the function <code>proportion_SI()</code>.</p>
<p><strong>Remember that you should filter your table to let it contain only first isolates!</strong> This is needed to exclude duplicates and to reduce selection bias. Use <code><a href='first_isolate.html'>first_isolate()</a></code> to determine them in your data set.</p>
<p>These functions are not meant to count isolates, but to calculate the proportion of resistance/susceptibility. Use the <code><a href='count.html'>count()</a></code>][AMR::count()] functions to count isolates. The function <code>susceptibility()</code> is essentially equal to <code>count_susceptible() / count_all()</code>. <em>Low counts can influence the outcome - the <code>proportion</code> functions may camouflage this, since they only return the proportion (albeit being dependent on the <code>minimum</code> parameter).</em></p>
<p>The function <code>proportion_df()</code> takes any variable from <code>data</code> that has an <code><a href='as.rsi.html'>rsi</a></code> class (created with <code><a href='as.rsi.html'>as.rsi()</a></code>) and calculates the proportions R, I and S. The function <code>rsi_df()</code> works exactly like <code>proportion_df()</code>, but adds the number of isolates.</p>
<p>The function <code>proportion_df()</code> takes any variable from <code>data</code> that has an <code><a href='as.rsi.html'>rsi</a></code> class (created with <code><a href='as.rsi.html'>as.rsi()</a></code>) and calculates the proportions R, I and S. It also supports grouped variables. The function <code>rsi_df()</code> works exactly like <code>proportion_df()</code>, but adds the number of isolates.</p>
<h2 class="hasAnchor" id="combination-therapy"><a class="anchor" href="#combination-therapy"></a>Combination therapy</h2>
@@ -336,21 +336,21 @@ resistance() should be used to calculate resistance, susceptibility() should be
-------- -------- ---------- ----------- ---------- -----------
S or I S or I X X X X
R S or I X X X X
&lt;NA&gt; S or I X X - -
&amp;lt;NA&amp;gt; S or I X X - -
S or I R X X X X
R R - X - X
&lt;NA&gt; R - - - -
S or I &lt;NA&gt; X X - -
R &lt;NA&gt; - - - -
&lt;NA&gt; &lt;NA&gt; - - - -
&amp;lt;NA&amp;gt; R - - - -
S or I &amp;lt;NA&amp;gt; X X - -
R &amp;lt;NA&amp;gt; - - - -
&amp;lt;NA&amp;gt; &amp;lt;NA&amp;gt; - - - -
--------------------------------------------------------------------
</pre>
<p>Please note that, in combination therapies, for <code>only_all_tested = TRUE</code> applies that:</p><pre> <span class='fu'><a href='count.html'>count_S</a></span>() + <span class='fu'><a href='count.html'>count_I</a></span>() + <span class='fu'><a href='count.html'>count_R</a></span>() <span class='kw'>=</span> <span class='fu'><a href='count.html'>count_all</a></span>()
<span class='fu'>proportion_S</span>() + <span class='fu'>proportion_I</span>() + <span class='fu'>proportion_R</span>() <span class='kw'>=</span> <span class='fl'>1</span></pre>
<p>and that, in combination therapies, for <code>only_all_tested = FALSE</code> applies that:</p><pre> count_S() + count_I() + count_R() &gt;= count_all()
proportion_S() + proportion_I() + proportion_R() &gt;= 1
<p>and that, in combination therapies, for <code>only_all_tested = FALSE</code> applies that:</p><pre> count_S() + count_I() + count_R() &amp;gt;= count_all()
proportion_S() + proportion_I() + proportion_R() &amp;gt;= 1
</pre>
<p>Using <code>only_all_tested</code> has no impact when only using one antibiotic as input.</p>
@@ -398,6 +398,7 @@ A microorganism is categorised as <em>Susceptible, Increased exposure</em> when
<span class='fu'>proportion_IR</span>(<span class='no'>example_isolates</span>$<span class='no'>AMX</span>)
<span class='fu'>proportion_R</span>(<span class='no'>example_isolates</span>$<span class='no'>AMX</span>)
<span class='kw'>if</span> (<span class='fl'>FALSE</span>) {
<span class='fu'><a href='https://rdrr.io/r/base/library.html'>library</a></span>(<span class='no'>dplyr</span>)
<span class='no'>example_isolates</span> <span class='kw'>%&gt;%</span>
<span class='fu'><a href='https://dplyr.tidyverse.org/reference/group_by.html'>group_by</a></span>(<span class='no'>hospital_id</span>) <span class='kw'>%&gt;%</span>
@@ -410,7 +411,7 @@ A microorganism is categorised as <em>Susceptible, Increased exposure</em> when
<span class='kw'>SI</span> <span class='kw'>=</span> <span class='fu'>susceptibility</span>(<span class='no'>CIP</span>, <span class='kw'>as_percent</span> <span class='kw'>=</span> <span class='fl'>TRUE</span>),
<span class='kw'>n1</span> <span class='kw'>=</span> <span class='fu'><a href='count.html'>count_all</a></span>(<span class='no'>CIP</span>), <span class='co'># the actual total; sum of all three</span>
<span class='kw'>n2</span> <span class='kw'>=</span> <span class='fu'><a href='count.html'>n_rsi</a></span>(<span class='no'>CIP</span>), <span class='co'># same - analogous to n_distinct</span>
<span class='kw'>total</span> <span class='kw'>=</span> <span class='fu'><a href='https://dplyr.tidyverse.org/reference/context.html'>n</a></span>()) <span class='co'># NOT the number of tested isolates!</span>
<span class='kw'>total</span> <span class='kw'>=</span> <span class='fu'><a href='https://dplyr.tidyverse.org/reference/n.html'>n</a></span>()) <span class='co'># NOT the number of tested isolates!</span>
<span class='co'># Calculate co-resistance between amoxicillin/clav acid and gentamicin,</span>
<span class='co'># so we can see that combination therapy does a lot more than mono therapy:</span>
@@ -455,9 +456,6 @@ A microorganism is categorised as <em>Susceptible, Increased exposure</em> when
<span class='fu'><a href='https://dplyr.tidyverse.org/reference/group_by.html'>group_by</a></span>(<span class='no'>hospital_id</span>) <span class='kw'>%&gt;%</span>
<span class='fu'>proportion_df</span>(<span class='kw'>translate</span> <span class='kw'>=</span> <span class='fl'>FALSE</span>)
<span class='kw'>if</span> (<span class='fl'>FALSE</span>) {
<span class='co'># calculate current empiric combination therapy of Helicobacter gastritis:</span>
<span class='no'>my_table</span> <span class='kw'>%&gt;%</span>
<span class='fu'><a href='https://dplyr.tidyverse.org/reference/filter.html'>filter</a></span>(<span class='no'>first_isolate</span> <span class='kw'>==</span> <span class='fl'>TRUE</span>,
@@ -480,7 +478,7 @@ A microorganism is categorised as <em>Susceptible, Increased exposure</em> when
</div>
<div class="pkgdown">
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.0.</p>
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.</p>
</div>
</footer>

4
docs/reference/reexports.html
View File

@@ -87,7 +87,7 @@ below to see their documentation.
</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.1.0</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>
@@ -263,7 +263,7 @@ below to see their documentation.</p>
</div>
<div class="pkgdown">
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.0.</p>
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.</p>
</div>
</footer>

34
docs/reference/resistance_predict.html
View File

@@ -82,7 +82,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.1.0</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>
@@ -266,7 +266,7 @@
)
<span class='co'># S3 method for resistance_predict</span>
<span class='fu'><a href='https://rdrr.io/r/graphics/plot.html'>plot</a></span>(<span class='no'>x</span>, <span class='kw'>main</span> <span class='kw'>=</span> <span class='fu'><a href='https://rdrr.io/r/base/paste.html'>paste</a></span>(<span class='st'>"Resistance Prediction of"</span>, <span class='no'>x_name</span>), <span class='no'>...</span>)
<span class='fu'><a href='https://rdrr.io/r/base/plot.html'>plot</a></span>(<span class='no'>x</span>, <span class='kw'>main</span> <span class='kw'>=</span> <span class='fu'><a href='https://rdrr.io/r/base/paste.html'>paste</a></span>(<span class='st'>"Resistance Prediction of"</span>, <span class='no'>x_name</span>), <span class='no'>...</span>)
<span class='fu'>ggplot_rsi_predict</span>(
<span class='no'>x</span>,
@@ -392,25 +392,25 @@ A microorganism is categorised as <em>Susceptible, Increased exposure</em> when
<span class='kw'>col_ab</span> <span class='kw'>=</span> <span class='st'>"AMX"</span>,
<span class='kw'>year_min</span> <span class='kw'>=</span> <span class='fl'>2010</span>,
<span class='kw'>model</span> <span class='kw'>=</span> <span class='st'>"binomial"</span>)
<span class='fu'><a href='https://rdrr.io/r/graphics/plot.html'>plot</a></span>(<span class='no'>x</span>)
<span class='fu'><a href='https://rdrr.io/r/base/plot.html'>plot</a></span>(<span class='no'>x</span>)
<span class='fu'>ggplot_rsi_predict</span>(<span class='no'>x</span>)
<span class='co'># use dplyr so you can actually read it:</span>
<span class='fu'><a href='https://rdrr.io/r/base/library.html'>library</a></span>(<span class='no'>dplyr</span>)
<span class='no'>x</span> <span class='kw'>&lt;-</span> <span class='no'>example_isolates</span> <span class='kw'>%&gt;%</span>
<span class='fu'><a href='first_isolate.html'>filter_first_isolate</a></span>() <span class='kw'>%&gt;%</span>
<span class='fu'><a href='https://dplyr.tidyverse.org/reference/filter.html'>filter</a></span>(<span class='fu'><a href='mo_property.html'>mo_genus</a></span>(<span class='no'>mo</span>) <span class='kw'>==</span> <span class='st'>"Staphylococcus"</span>) <span class='kw'>%&gt;%</span>
<span class='fu'>resistance_predict</span>(<span class='st'>"PEN"</span>, <span class='kw'>model</span> <span class='kw'>=</span> <span class='st'>"binomial"</span>)
<span class='fu'><a href='https://rdrr.io/r/graphics/plot.html'>plot</a></span>(<span class='no'>x</span>)
<span class='co'># get the model from the object</span>
<span class='no'>mymodel</span> <span class='kw'>&lt;-</span> <span class='fu'><a href='https://rdrr.io/r/base/attributes.html'>attributes</a></span>(<span class='no'>x</span>)$<span class='no'>model</span>
<span class='fu'><a href='https://rdrr.io/r/base/summary.html'>summary</a></span>(<span class='no'>mymodel</span>)
<span class='co'># using dplyr:</span>
<span class='kw'>if</span> (!<span class='fu'><a href='https://rdrr.io/r/base/library.html'>require</a></span>(<span class='st'>"dplyr"</span>)) {
<span class='fu'><a href='https://rdrr.io/r/base/library.html'>library</a></span>(<span class='no'>dplyr</span>)
<span class='no'>x</span> <span class='kw'>&lt;-</span> <span class='no'>example_isolates</span> <span class='kw'>%&gt;%</span>
<span class='fu'><a href='first_isolate.html'>filter_first_isolate</a></span>() <span class='kw'>%&gt;%</span>
<span class='fu'><a href='https://dplyr.tidyverse.org/reference/filter.html'>filter</a></span>(<span class='fu'><a href='mo_property.html'>mo_genus</a></span>(<span class='no'>mo</span>) <span class='kw'>==</span> <span class='st'>"Staphylococcus"</span>) <span class='kw'>%&gt;%</span>
<span class='fu'>resistance_predict</span>(<span class='st'>"PEN"</span>, <span class='kw'>model</span> <span class='kw'>=</span> <span class='st'>"binomial"</span>)
<span class='fu'><a href='https://rdrr.io/r/base/plot.html'>plot</a></span>(<span class='no'>x</span>)
<span class='co'># get the model from the object</span>
<span class='no'>mymodel</span> <span class='kw'>&lt;-</span> <span class='fu'><a href='https://rdrr.io/r/base/attributes.html'>attributes</a></span>(<span class='no'>x</span>)$<span class='no'>model</span>
<span class='fu'><a href='https://rdrr.io/r/base/summary.html'>summary</a></span>(<span class='no'>mymodel</span>)
}
<span class='co'># create nice plots with ggplot2 yourself</span>
<span class='kw'>if</span> (!<span class='fu'><a href='https://rdrr.io/r/base/library.html'>require</a></span>(<span class='no'>ggplot2</span>)) {
<span class='kw'>if</span> (!<span class='fu'><a href='https://rdrr.io/r/base/library.html'>require</a></span>(<span class='no'>ggplot2</span>) <span class='kw'>&amp;</span> !<span class='fu'><a href='https://rdrr.io/r/base/library.html'>require</a></span>(<span class='st'>"dplyr"</span>)) {
<span class='no'>data</span> <span class='kw'>&lt;-</span> <span class='no'>example_isolates</span> <span class='kw'>%&gt;%</span>
<span class='fu'><a href='https://dplyr.tidyverse.org/reference/filter.html'>filter</a></span>(<span class='no'>mo</span> <span class='kw'>==</span> <span class='fu'><a href='as.mo.html'>as.mo</a></span>(<span class='st'>"E. coli"</span>)) <span class='kw'>%&gt;%</span>
@@ -451,7 +451,7 @@ A microorganism is categorised as <em>Susceptible, Increased exposure</em> when
</div>
<div class="pkgdown">
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.0.</p>
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.</p>
</div>
</footer>

12
docs/reference/translate.html
View File

@@ -49,7 +49,7 @@
<script src="../extra.js"></script>
<meta property="og:title" content="Translate strings from AMR package — translate" />
<meta property="og:description" content="For language-dependent output of AMR functions, like mo_name(), mo_type() and ab_name()." />
<meta property="og:description" content="For language-dependent output of AMR functions, like mo_name(), mo_gramstain(), mo_type() and ab_name()." />
<meta property="og:image" content="https://msberends.gitlab.io/AMR/logo.svg" />
@@ -82,7 +82,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.1.0</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.1.0.9004</span>
</span>
</div>
@@ -232,7 +232,7 @@
</div>
<div class="ref-description">
<p>For language-dependent output of AMR functions, like <code><a href='mo_property.html'>mo_name()</a></code>, <code><a href='mo_property.html'>mo_type()</a></code> and <code><a href='ab_property.html'>ab_name()</a></code>.</p>
<p>For language-dependent output of AMR functions, like <code><a href='mo_property.html'>mo_name()</a></code>, <code><a href='mo_property.html'>mo_gramstain()</a></code>, <code><a href='mo_property.html'>mo_type()</a></code> and <code><a href='ab_property.html'>ab_name()</a></code>.</p>
</div>
<pre class="usage"><span class='fu'>get_locale</span>()</pre>
@@ -241,9 +241,9 @@
<h2 class="hasAnchor" id="details"><a class="anchor" href="#details"></a>Details</h2>
<p>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: <a href='https://gitlab.com/msberends/AMR/blob/master/data-raw/translations.tsv'>https://gitlab.com/msberends/AMR/blob/master/data-raw/translations.tsv</a>.</p>
<p>Currently supported languages can be found if running: <code><a href='https://rdrr.io/r/base/unique.html'>unique(AMR:::translations_file$lang)</a></code>.</p>
<p>Currently supported languages are (besides English): Dutch, French, German, Italian, Portuguese, Spanish. Not all these languages currently have translations available for all antimicrobial agents and colloquial microorganism names.</p>
<p>Please suggest your own translations <a href='https://gitlab.com/msberends/AMR/issues/new?issue[title]=Translation%20suggestion'>by creating a new issue on our repository</a>.</p>
<p>This file will be read by all functions where a translated output can be desired, like all <code><a href='mo_property.html'>mo_property()</a></code> functions (<code><a href='mo_property.html'>mo_fullname()</a></code>, <code><a href='mo_property.html'>mo_type()</a></code>, etc.).</p>
<p>This file will be read by all functions where a translated output can be desired, like all <code><a href='mo_property.html'>mo_property()</a></code> functions (<code><a href='mo_property.html'>mo_name()</a></code>, <code><a href='mo_property.html'>mo_gramstain()</a></code>, <code><a href='mo_property.html'>mo_type()</a></code>, etc.).</p>
<p>The system language will be used at default, if that language is supported. The system language can be overwritten with <code><a href='https://rdrr.io/r/base/Sys.setenv.html'>Sys.setenv(AMR_locale = yourlanguage)</a></code>.</p>
<h2 class="hasAnchor" id="stable-lifecycle"><a class="anchor" href="#stable-lifecycle"></a>Stable lifecycle</h2>
@@ -301,7 +301,7 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>stable</s
</div>
<div class="pkgdown">
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.0.</p>
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.</p>
</div>
</footer>

5
docs/sitemap.xml
View File

@@ -7,7 +7,7 @@
<loc>https://msberends.gitlab.io/AMR/reference/AMR-deprecated.html</loc>
</url>
<url>
<loc>https://msberends.gitlab.io/AMR/reference/AMR-vctrs.html</loc>
<loc>https://msberends.gitlab.io/AMR/reference/AMR-tidyverse.html</loc>
</url>
<url>
<loc>https://msberends.gitlab.io/AMR/reference/AMR.html</loc>
@@ -72,9 +72,6 @@
<url>
<loc>https://msberends.gitlab.io/AMR/reference/example_isolates_unclean.html</loc>
</url>
<url>
<loc>https://msberends.gitlab.io/AMR/reference/extended-functions.html</loc>
</url>
<url>
<loc>https://msberends.gitlab.io/AMR/reference/filter_ab_class.html</loc>
</url>

3
man/AMR-deprecated.Rd
View File

@@ -2,7 +2,6 @@
% Please edit documentation in R/deprecated.R
\name{AMR-deprecated}
\alias{AMR-deprecated}
\alias{p.symbol}
\alias{portion_R}
\alias{portion_IR}
\alias{portion_I}
@@ -11,8 +10,6 @@
\alias{portion_df}
\title{Deprecated functions}
\usage{
p.symbol(...)
portion_R(...)
portion_IR(...)

14
man/AMR-vctrs.Rd → man/AMR-tidyverse.Rd
View File

@@ -1,13 +1,19 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/vctrs.R
\name{AMR-vctrs}
\alias{AMR-vctrs}
% Please edit documentation in R/tidyverse.R
\name{AMR-tidyverse}
\alias{AMR-tidyverse}
\alias{scale_type.mo}
\alias{scale_type.ab}
\alias{vec_ptype2.mo}
\alias{vec_cast.mo}
\alias{vec_ptype2.ab}
\alias{vec_cast.ab}
\title{\code{vctrs} methods}
\title{Methods for tidyverse}
\usage{
scale_type.mo(x)
scale_type.ab(x)
vec_ptype2.mo(x, y, ...)
vec_cast.mo(x, to, ...)

1
man/as.mic.Rd
View File

@@ -56,7 +56,6 @@ as.rsi(x = as.mic(4),
plot(mic_data)
barplot(mic_data)
freq(mic_data)
}
\seealso{
\code{\link[=as.rsi]{as.rsi()}}

2
man/as.mo.Rd
View File

@@ -39,7 +39,7 @@ This excludes \emph{Enterococci} at default (who are in group D), use \code{Lanc
\item{allow_uncertain}{a number between \code{0} (or \code{"none"}) and \code{3} (or \code{"all"}), or \code{TRUE} (= \code{2}) or \code{FALSE} (= \code{0}) to indicate whether the input should be checked for less probable results, please see \emph{Details}}
\item{reference_df}{a \code{\link{data.frame}} to use for extra reference when translating \code{x} to a valid \code{\link{mo}}. See \code{\link[=set_mo_source]{set_mo_source()}} and \code{\link[=get_mo_source]{get_mo_source()}} to automate the usage of your own codes (e.g. used in your analysis or organisation).}
\item{reference_df}{a \code{\link{data.frame}} to be used for extra reference when translating \code{x} to a valid \code{\link{mo}}. See \code{\link[=set_mo_source]{set_mo_source()}} and \code{\link[=get_mo_source]{get_mo_source()}} to automate the usage of your own codes (e.g. used in your analysis or organisation).}
\item{...}{other parameters passed on to functions}
}

9
man/as.rsi.Rd
View File

@@ -45,7 +45,7 @@ is.rsi.eligible(x, threshold = 0.05)
\item{ab}{any (vector of) text that can be coerced to a valid antimicrobial code with \code{\link[=as.ab]{as.ab()}}}
\item{guideline}{defaults to the latest included EUCAST guideline, run \code{unique(rsi_translation$guideline)} for all options}
\item{guideline}{defaults to the latest included EUCAST guideline, see Details for all options}
\item{uti}{(Urinary Tract Infection) A vector with \link{logical}s (\code{TRUE} or \code{FALSE}) to specify whether a UTI specific interpretation from the guideline should be chosen. For using \code{\link[=as.rsi]{as.rsi()}} on a \link{data.frame}, this can also be a column containing \link{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 \emph{Examples}.}
@@ -60,9 +60,11 @@ Ordered factor with new class \code{\link{rsi}}
Interpret MIC values and disk diffusion diameters according to EUCAST or CLSI, or clean up existing R/SI values. This transforms the input to a new class \code{\link{rsi}}, which is an ordered factor with levels \verb{S < I < R}. Invalid antimicrobial interpretations will be translated as \code{NA} with a warning.
}
\details{
Run \code{unique(rsi_translation$guideline)} for a list of all supported guidelines. The repository of this package contains \href{https://gitlab.com/msberends/AMR/blob/master/data-raw/rsi_translation.txt}{this machine readable version} of these guidelines.
When using \code{\link[=as.rsi]{as.rsi()}} on untransformed data, the data will be cleaned to only contain values S, I and R. When using the function on data with class \code{\link{mic}} (using \code{\link[=as.mic]{as.mic()}}) or class \code{\link{disk}} (using \code{\link[=as.disk]{as.disk()}}), the data will be interpreted based on the guideline set with the \code{guideline} parameter.
These guidelines are machine readable, since \href{https://gitlab.com/msberends/AMR/blob/master/data-raw/rsi_translation.txt}{}.
Supported guidelines to be used as input for the \code{guideline} parameter are: "CLSI 2010", "CLSI 2011", "CLSI 2012", "CLSI 2013", "CLSI 2014", "CLSI 2015", "CLSI 2016", "CLSI 2017", "CLSI 2018", "CLSI 2019", "EUCAST 2011", "EUCAST 2012", "EUCAST 2013", "EUCAST 2014", "EUCAST 2015", "EUCAST 2016", "EUCAST 2017", "EUCAST 2018", "EUCAST 2019", "EUCAST 2020". Simply using \code{"CLSI"} or \code{"EUCAST"} for input will automatically select the latest version of that guideline.
The repository of this package \href{https://gitlab.com/msberends/AMR/blob/master/data-raw/rsi_translation.txt}{contains a machine readable version} of all guidelines. This is a CSV file consisting of 18,964 rows and 10 columns. This file is machine readable, since it contains one row for every unique combination of the test method (MIC or disk diffusion), the antimicrobial agent and the microorganism. This \strong{allows for easy implementation of these rules in laboratory information systems (LIS)}.
After using \code{\link[=as.rsi]{as.rsi()}}, you can use \code{\link[=eucast_rules]{eucast_rules()}} to (1) apply inferred susceptibility and resistance based on results of other antimicrobials and (2) apply intrinsic resistance based on taxonomic properties of a microorganism.
@@ -154,7 +156,6 @@ rsi_data <- as.rsi(c(rep("S", 474), rep("I", 36), rep("R", 370)))
is.rsi(rsi_data)
plot(rsi_data) # for percentages
barplot(rsi_data) # for frequencies
freq(rsi_data) # frequency table with informative header
library(dplyr)
example_isolates \%>\%

5
man/catalogue_of_life_version.Rd
View File

@@ -28,11 +28,6 @@ This package contains the complete taxonomic tree of almost all microorganisms (
On our website \url{https://msberends.gitlab.io/AMR} you can find \href{https://msberends.gitlab.io/AMR/articles/AMR.html}{a comprehensive tutorial} about how to conduct AMR analysis, the \href{https://msberends.gitlab.io/AMR/reference}{complete documentation of all functions} (which reads a lot easier than here in R) and \href{https://msberends.gitlab.io/AMR/articles/WHONET.html}{an example analysis using WHONET data}.
}
\examples{
library(dplyr)
microorganisms \%>\% freq(kingdom)
microorganisms \%>\% group_by(kingdom) \%>\% freq(phylum, nmax = NULL)
}
\seealso{
\link{microorganisms}
}

2
man/count.Rd
View File

@@ -70,7 +70,7 @@ The function \code{\link[=count_resistant]{count_resistant()}} is equal to the f
The function \code{\link[=n_rsi]{n_rsi()}} is an alias of \code{\link[=count_all]{count_all()}}. They can be used to count all available isolates, i.e. where all input antibiotics have an available result (S, I or R). Their use is equal to \code{\link[=n_distinct]{n_distinct()}}. Their function is equal to \code{count_susceptible(...) + count_resistant(...)}.
The function \code{\link[=count_df]{count_df()}} takes any variable from \code{data} that has an \code{\link{rsi}} class (created with \code{\link[=as.rsi]{as.rsi()}}) and counts the number of S's, I's and R's. The function \code{\link[=rsi_df]{rsi_df()}} works exactly like \code{\link[=count_df]{count_df()}}, but adds the percentage of S, I and R.
The function \code{\link[=count_df]{count_df()}} takes any variable from \code{data} that has an \code{\link{rsi}} class (created with \code{\link[=as.rsi]{as.rsi()}}) and counts the number of S's, I's and R's. It also supports grouped variables. The function \code{\link[=rsi_df]{rsi_df()}} works exactly like \code{\link[=count_df]{count_df()}}, but adds the percentage of S, I and R.
}
\section{Stable lifecycle}{

29
man/extended-functions.Rd
View File

@@ -1,29 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/extended.R
\name{extended-functions}
\alias{extended-functions}
\alias{scale_type.mo}
\alias{scale_type.ab}
\title{Extended functions}
\usage{
scale_type.mo(x)
scale_type.ab(x)
}
\description{
These functions are extensions of functions in other packages.
}
\section{Stable lifecycle}{
\if{html}{\figure{lifecycle_stable.svg}{options: style=margin-bottom:5px} \cr}
The \link[AMR:lifecycle]{lifecycle} of this function is \strong{stable}. In a stable function, we are largely happy with the unlying code, and major changes are unlikely. This means that the unlying code will generally evolve by adding new arguments; we will avoid removing arguments or changing the meaning of existing arguments.
If the unlying code needs breaking changes, they will occur gradually. To begin with, the function or argument will be deprecated; it will continue to work but will emit an message informing you of the change. Next, typically after at least one newly released version on CRAN, the message will be transformed to an error.
}
\section{Read more on our website!}{
On our website \url{https://msberends.gitlab.io/AMR} you can find \href{https://msberends.gitlab.io/AMR/articles/AMR.html}{a comprehensive tutorial} about how to conduct AMR analysis, the \href{https://msberends.gitlab.io/AMR/reference}{complete documentation of all functions} (which reads a lot easier than here in R) and \href{https://msberends.gitlab.io/AMR/articles/WHONET.html}{an example analysis using WHONET data}.
}
\keyword{internal}

6
man/filter_ab_class.Rd
View File

@@ -14,7 +14,7 @@
\alias{filter_glycopeptides}
\alias{filter_macrolides}
\alias{filter_tetracyclines}
\title{Filter isolates on result in antibiotic class}
\title{Filter isolates on result in antimicrobial class}
\usage{
filter_ab_class(x, ab_class, result = NULL, scope = "any", ...)
@@ -54,7 +54,7 @@ filter_tetracyclines(x, result = NULL, scope = "any", ...)
\item{...}{parameters passed on to \code{filter_at} from the \code{dplyr} package}
}
\description{
Filter isolates on results in specific antibiotic variables based on their antibiotic class. This makes it easy to filter on isolates that were tested for e.g. any aminoglycoside.
Filter isolates on results in specific antimicrobial classes. This makes it easy to filter on isolates that were tested for e.g. any aminoglycoside.
}
\details{
The \code{group} column in \link{antibiotics} data set will be searched for \code{ab_class} (case-insensitive). If no results are found, the \code{atc_group1} and \code{atc_group2} columns will be searched. Next, \code{x} will be checked for column names with a value in any abbreviations, codes or official names found in the \link{antibiotics} data set.
@@ -68,6 +68,7 @@ If the unlying code needs breaking changes, they will occur gradually. To begin
}
\examples{
\dontrun{
library(dplyr)
# filter on isolates that have any result for any aminoglycoside
@@ -97,3 +98,4 @@ example_isolates \%>\%
filter_aminoglycosides("R", "all") \%>\%
filter_fluoroquinolones("R", "all")
}
}

7
man/first_isolate.Rd
View File

@@ -6,7 +6,7 @@
\alias{filter_first_weighted_isolate}
\title{Determine first (weighted) isolates}
\source{
Methodology of this function is based on:
Methodology of this function is strictly based on:
\strong{M39 Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data, 4th Edition}, 2014, \emph{Clinical and Laboratory Standards Institute (CLSI)}. \url{https://clsi.org/standards/products/microbiology/documents/m39/}.
}
@@ -142,6 +142,7 @@ On our website \url{https://msberends.gitlab.io/AMR} you can find \href{https://
# `example_isolates` is a dataset available in the AMR package.
# See ?example_isolates.
\dontrun{
library(dplyr)
# Filter on first isolates:
example_isolates \%>\%
@@ -162,14 +163,12 @@ B <- example_isolates \%>\%
# Have a look at A and B.
# B is more reliable because every isolate is counted only once.
# Gentamicin resitance in hospital D appears to be 3.7\% higher than
# Gentamicin resistance in hospital D appears to be 3.7\% higher than
# when you (erroneously) would have used all isolates for analysis.
## OTHER EXAMPLES:
\dontrun{
# Short-hand versions:
example_isolates \%>\%
filter_first_isolate()

2
man/ggplot_pca.Rd
View File

@@ -114,6 +114,7 @@ The \link[AMR:lifecycle]{lifecycle} of this function is \strong{maturing}. The u
# `example_isolates` is a dataset available in the AMR package.
# See ?example_isolates.
\dontrun{
# See ?pca for more info about Principal Component Analysis (PCA).
library(dplyr)
pca_model <- example_isolates \%>\%
@@ -128,3 +129,4 @@ biplot(pca_model)
# new
ggplot_pca(pca_model)
}
}

24
man/ggplot_rsi.Rd
View File

@@ -219,29 +219,5 @@ example_isolates \%>\%
title = "AMR of Anti-UTI Drugs Per Hospital",
x.title = "Hospital",
datalabels = FALSE)
# genuine analysis: check 3 most prevalent microorganisms
example_isolates \%>\%
# create new bacterial ID's, with all CoNS under the same group (Becker et al.)
mutate(mo = as.mo(mo, Becker = TRUE)) \%>\%
# filter on top three bacterial ID's
filter(mo \%in\% top_freq(freq(.$mo), 3)) \%>\%
# filter on first isolates
filter_first_isolate() \%>\%
# get short MO names (like "E. coli")
mutate(bug = mo_shortname(mo, Becker = TRUE)) \%>\%
# select this short name and some antiseptic drugs
select(bug, CXM, GEN, CIP) \%>\%
# group by MO
group_by(bug) \%>\%
# plot the thing, putting MOs on the facet
ggplot_rsi(x = "antibiotic",
facet = "bug",
translate_ab = FALSE,
nrow = 1,
title = "AMR of Top Three Microorganisms In Blood Culture Isolates",
subtitle = expression(paste("Only First Isolates, CoNS grouped according to Becker ",
italic("et al."), " (2014)")),
x.title = "Antibiotic (EARS-Net code)")
}
}

8
man/join.Rd
View File

@@ -9,7 +9,7 @@
\alias{full_join_microorganisms}
\alias{semi_join_microorganisms}
\alias{anti_join_microorganisms}
\title{Join a table with \link{microorganisms}}
\title{Join \link{microorganisms} to a data set}
\usage{
inner_join_microorganisms(x, by = NULL, suffix = c("2", ""), ...)
@@ -36,7 +36,9 @@ anti_join_microorganisms(x, by = NULL, ...)
Join the data set \link{microorganisms} easily to an existing table or character vector.
}
\details{
\strong{Note:} As opposed to the \code{\link[dplyr:join]{dplyr::join()}} functions of \code{dplyr}, \code{\link{character}} vectors are supported and at default existing columns will get a suffix \code{"2"} and the newly joined columns will not get a suffix. See \code{\link[dplyr:join]{dplyr::join()}} for more information.
\strong{Note:} As opposed to the \code{\link[=join]{join()}} functions of \code{dplyr}, \code{\link{character}} vectors are supported and at default existing columns will get a suffix \code{"2"} and the newly joined columns will not get a suffix.
These functions rely on \code{\link[=merge]{merge()}}, a base R function to do joins.
}
\section{Stable lifecycle}{
@@ -55,6 +57,7 @@ On our website \url{https://msberends.gitlab.io/AMR} you can find \href{https://
left_join_microorganisms(as.mo("K. pneumoniae"))
left_join_microorganisms("B_KLBSL_PNE")
\dontrun{
library(dplyr)
example_isolates \%>\% left_join_microorganisms()
@@ -68,3 +71,4 @@ colnames(df)
df_joined <- left_join_microorganisms(df, "bacteria")
colnames(df_joined)
}
}

4
man/key_antibiotics.Rd
View File

@@ -68,7 +68,9 @@ key_antibiotics_equal(
These function can be used to determine first isolates (see \code{\link[=first_isolate]{first_isolate()}}). Using key antibiotics to determine first isolates is more reliable than without key antibiotics. These selected isolates will then be called first \emph{weighted} isolates.
}
\details{
The function \code{\link[=key_antibiotics]{key_antibiotics()}} returns a character vector with 12 antibiotic results for every isolate. These isolates can then be compared using \code{\link[=key_antibiotics_equal]{key_antibiotics_equal()}}, to check if two isolates have generally the same antibiogram. Missing and invalid values are replaced with a dot (\code{"."}). The \code{\link[=first_isolate]{first_isolate()}} function only uses this function on the same microbial species from the same patient. Using this, an MRSA will be included after a susceptible \emph{S. aureus} (MSSA) found within the same episode (see \code{episode} parameter of \code{\link[=first_isolate]{first_isolate()}}). Without key antibiotic comparison it would not.
The function \code{\link[=key_antibiotics]{key_antibiotics()}} returns a character vector with 12 antibiotic results for every isolate. These isolates can then be compared using \code{\link[=key_antibiotics_equal]{key_antibiotics_equal()}}, to check if two isolates have generally the same antibiogram. Missing and invalid values are replaced with a dot (\code{"."}) by \code{\link[=key_antibiotics]{key_antibiotics()}} and ignored by \code{\link[=key_antibiotics_equal]{key_antibiotics_equal()}}.
The \code{\link[=first_isolate]{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 \emph{S. aureus} (MSSA) is found within the same patient episode. Without key antibiotic comparison it would not. See \code{\link[=first_isolate]{first_isolate()}} for more info.
At default, the antibiotics that are used for \strong{Gram-positive bacteria} are:
\itemize{

16
man/like.Rd
View File

@@ -6,7 +6,7 @@
\alias{\%like_case\%}
\title{Pattern Matching}
\source{
Idea from the \href{https://github.com/Rdatatable/data.table/blob/master/R/like.R}{\code{like} function from the \code{data.table} package}, but made it case insensitive at default and let it support multiple patterns. Also, if the regex fails the first time, it tries again with \code{perl = TRUE}.
Idea from the \href{https://github.com/Rdatatable/data.table/blob/master/R/like.R}{\code{like} function from the \code{data.table} package}
}
\usage{
like(x, pattern, ignore.case = TRUE)
@@ -29,7 +29,13 @@ A \code{\link{logical}} vector
Convenient wrapper around \code{\link[=grep]{grep()}} to match a pattern: \code{x \%like\% pattern}. It always returns a \code{\link{logical}} vector and is always case-insensitive (use \code{x \%like_case\% pattern} for case-sensitive matching). Also, \code{pattern} can be as long as \code{x} to compare items of each index in both vectors, or they both can have the same length to iterate over all cases.
}
\details{
When running a regular expression fails, these functions try again with \code{base::grepl(..., perl = TRUE)}.
The \verb{\%like\%} function:
\itemize{
\item Is case insensitive (use \verb{\%like_case\%} for case-sensitive matching)
\item Supports multiple patterns
\item Checks if \code{pattern} is a regular expression and sets \code{fixed = TRUE} if not, to greatly improve speed
\item Tries again with \code{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 \code{Ctrl+Shift+L} or \code{Cmd+Shift+L} (see \code{Tools} > \verb{Modify Keyboard Shortcuts...}).
}
@@ -61,11 +67,11 @@ b <- c( "case", "diff", "yet")
a \%like\% b
#> TRUE TRUE TRUE
# get frequencies of bacteria whose name start with 'Ent' or 'ent'
# get isolates whose name start with 'Ent' or 'ent'
library(dplyr)
example_isolates \%>\%
filter(mo_name(mo) \%like\% "^ent") \%>\%
freq(mo_genus(mo))
filter(mo_name(mo) \%like\% "^ent") \%>\%
freq(mo)
}
\seealso{
\code{\link[base:grep]{base::grep()}}

4
man/pca.Rd
View File

@@ -17,7 +17,7 @@ pca(
\arguments{
\item{x}{a \link{data.frame} containing numeric columns}
\item{...}{columns of \code{x} to be selected for PCA}
\item{...}{columns of \code{x} to be selected for PCA, can be unquoted since it supports quasiquotation.}
\item{retx}{a logical value indicating whether the rotated variables
should be returned.}
@@ -69,6 +69,7 @@ The \link[AMR:lifecycle]{lifecycle} of this function is \strong{maturing}. The u
# `example_isolates` is a dataset available in the AMR package.
# See ?example_isolates.
\dontrun{
# calculate the resistance per group first
library(dplyr)
resistance_data <- example_isolates \%>\%
@@ -85,3 +86,4 @@ summary(pca_result)
biplot(pca_result)
ggplot_pca(pca_result) # a new and convenient plot function
}
}

8
man/proportion.Rd
View File

@@ -74,7 +74,7 @@ rsi_df(
A \code{\link{double}} or, when \code{as_percent = TRUE}, a \code{\link{character}}.
}
\description{
These functions can be used to calculate the (co-)resistance or susceptibility of microbial isolates (i.e. percentage of S, SI, I, IR or R). All functions support quasiquotation with pipes, can be used in \code{summarise()}][dplyr::summarise()] and also support grouped variables, please see \emph{Examples}.
These functions can be used to calculate the (co-)resistance or susceptibility of microbial isolates (i.e. percentage of S, SI, I, IR or R). All functions support quasiquotation with pipes, can be used in \code{\link[=summarise]{summarise()}} from the \code{dplyr} package and also supports grouped variables, please see \emph{Examples}.
\code{\link[=resistance]{resistance()}} should be used to calculate resistance, \code{\link[=susceptibility]{susceptibility()}} should be used to calculate susceptibility.\cr
}
@@ -85,7 +85,7 @@ The function \code{\link[=resistance]{resistance()}} is equal to the function \c
These functions are not meant to count isolates, but to calculate the proportion of resistance/susceptibility. Use the \code{count()}][AMR::count()] functions to count isolates. The function \code{\link[=susceptibility]{susceptibility()}} is essentially equal to \code{count_susceptible() / count_all()}. \emph{Low counts can influence the outcome - the \code{proportion} functions may camouflage this, since they only return the proportion (albeit being dependent on the \code{minimum} parameter).}
The function \code{\link[=proportion_df]{proportion_df()}} takes any variable from \code{data} that has an \code{\link{rsi}} class (created with \code{\link[=as.rsi]{as.rsi()}}) and calculates the proportions R, I and S. The function \code{\link[=rsi_df]{rsi_df()}} works exactly like \code{\link[=proportion_df]{proportion_df()}}, but adds the number of isolates.
The function \code{\link[=proportion_df]{proportion_df()}} takes any variable from \code{data} that has an \code{\link{rsi}} class (created with \code{\link[=as.rsi]{as.rsi()}}) and calculates the proportions R, I and S. It also supports grouped variables. The function \code{\link[=rsi_df]{rsi_df()}} works exactly like \code{\link[=proportion_df]{proportion_df()}}, but adds the number of isolates.
}
\section{Combination therapy}{
@@ -160,6 +160,7 @@ proportion_I(example_isolates$AMX)
proportion_IR(example_isolates$AMX)
proportion_R(example_isolates$AMX)
\dontrun{
library(dplyr)
example_isolates \%>\%
group_by(hospital_id) \%>\%
@@ -217,9 +218,6 @@ example_isolates \%>\%
group_by(hospital_id) \%>\%
proportion_df(translate = FALSE)
\dontrun{
# calculate current empiric combination therapy of Helicobacter gastritis:
my_table \%>\%
filter(first_isolate == TRUE,

26
man/resistance_predict.Rd
View File

@@ -134,22 +134,22 @@ x <- resistance_predict(example_isolates,
plot(x)
ggplot_rsi_predict(x)
# use dplyr so you can actually read it:
library(dplyr)
x <- example_isolates \%>\%
filter_first_isolate() \%>\%
filter(mo_genus(mo) == "Staphylococcus") \%>\%
resistance_predict("PEN", model = "binomial")
plot(x)
# get the model from the object
mymodel <- attributes(x)$model
summary(mymodel)
# using dplyr:
if (!require("dplyr")) {
library(dplyr)
x <- example_isolates \%>\%
filter_first_isolate() \%>\%
filter(mo_genus(mo) == "Staphylococcus") \%>\%
resistance_predict("PEN", model = "binomial")
plot(x)
# get the model from the object
mymodel <- attributes(x)$model
summary(mymodel)
}
# create nice plots with ggplot2 yourself
if (!require(ggplot2)) {
if (!require(ggplot2) & !require("dplyr")) {
data <- example_isolates \%>\%
filter(mo == as.mo("E. coli")) \%>\%

6
man/translate.Rd
View File

@@ -8,16 +8,16 @@
get_locale()
}
\description{
For language-dependent output of AMR functions, like \code{\link[=mo_name]{mo_name()}}, \code{\link[=mo_type]{mo_type()}} and \code{\link[=ab_name]{ab_name()}}.
For language-dependent output of AMR functions, like \code{\link[=mo_name]{mo_name()}}, \code{\link[=mo_gramstain]{mo_gramstain()}}, \code{\link[=mo_type]{mo_type()}} and \code{\link[=ab_name]{ab_name()}}.
}
\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: \url{https://gitlab.com/msberends/AMR/blob/master/data-raw/translations.tsv}.
Currently supported languages can be found if running: \code{unique(AMR:::translations_file$lang)}.
Currently supported languages are (besides English): Dutch, French, German, Italian, Portuguese, Spanish. Not all these languages currently have translations available for all antimicrobial agents and colloquial microorganism names.
Please suggest your own translations \href{https://gitlab.com/msberends/AMR/issues/new?issue[title]=Translation\%20suggestion}{by creating a new issue on our repository}.
This file will be read by all functions where a translated output can be desired, like all \code{\link[=mo_property]{mo_property()}} functions (\code{\link[=mo_fullname]{mo_fullname()}}, \code{\link[=mo_type]{mo_type()}}, etc.).
This file will be read by all functions where a translated output can be desired, like all \code{\link[=mo_property]{mo_property()}} functions (\code{\link[=mo_name]{mo_name()}}, \code{\link[=mo_gramstain]{mo_gramstain()}}, \code{\link[=mo_type]{mo_type()}}, etc.).
The system language will be used at default, if that language is supported. The system language can be overwritten with \code{Sys.setenv(AMR_locale = yourlanguage)}.
}

2
tests/testthat/test-count.R
View File

@@ -54,7 +54,7 @@ test_that("counts work", {
combination = count_susceptible(CIP, GEN)) %>%
pull(combination),
c(253, 465, 192, 558))
# count_df
expect_equal(
example_isolates %>% select(AMX) %>% count_df() %>% pull(value),

Some files were not shown because too many files have changed in this diff Show More