1
0
mirror of https://github.com/msberends/AMR.git synced 2025-07-11 11:01:53 +02:00

(v1.1.0.9004) lose dependencies

This commit is contained in:
2020-05-16 13:05:47 +02:00
parent 9fce546901
commit 7f3da74b17
111 changed files with 3211 additions and 2345 deletions

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, ...)
}

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)
}

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))

View File

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

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))
}

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)

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."))
}

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",

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`]

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")

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)
}

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

View File

@ -1,48 +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. #
# ==================================================================== #
#' 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"
}
#' @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"
}

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 = ", ")
}

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,

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, ...) {

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,

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)
})
}

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

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, ...)
)
}

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])) {

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

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

File diff suppressed because it is too large Load Diff

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, ...)

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]

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]]

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",

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)
}

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
}

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))
}

Binary file not shown.

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)
}

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() {