mirror of
https://github.com/msberends/AMR.git
synced 2025-07-12 01:42:08 +02:00
(v1.1.0.9004) lose dependencies
This commit is contained in:
@ -19,6 +19,48 @@
|
||||
# Visit our website for more info: https://msberends.gitlab.io/AMR. #
|
||||
# ==================================================================== #
|
||||
|
||||
# functions from dplyr, will perhaps become poorman
|
||||
distinct <- function(.data, ..., .keep_all = FALSE) {
|
||||
check_is_dataframe(.data)
|
||||
if ("grouped_data" %in% class(.data)) {
|
||||
distinct.grouped_data(.data, ..., .keep_all = .keep_all)
|
||||
} else {
|
||||
distinct.default(.data, ..., .keep_all = .keep_all)
|
||||
}
|
||||
}
|
||||
distinct.default <- function(.data, ..., .keep_all = FALSE) {
|
||||
names <- rownames(.data)
|
||||
rownames(.data) <- NULL
|
||||
if (length(deparse_dots(...)) == 0) {
|
||||
selected <- .data
|
||||
} else {
|
||||
selected <- select(.data, ...)
|
||||
}
|
||||
rows <- as.integer(rownames(unique(selected)))
|
||||
if (isTRUE(.keep_all)) {
|
||||
res <- .data[rows, , drop = FALSE]
|
||||
} else {
|
||||
res <- selected[rows, , drop = FALSE]
|
||||
}
|
||||
rownames(res) <- names[rows]
|
||||
res
|
||||
}
|
||||
distinct.grouped_data <- function(.data, ..., .keep_all = FALSE) {
|
||||
apply_grouped_function(.data, "distinct", ..., .keep_all = .keep_all)
|
||||
}
|
||||
filter_join_worker <- function(x, y, by = NULL, type = c("anti", "semi")) {
|
||||
type <- match.arg(type, choices = c("anti", "semi"), several.ok = FALSE)
|
||||
if (is.null(by)) {
|
||||
by <- intersect(names(x), names(y))
|
||||
join_message(by)
|
||||
}
|
||||
rows <- interaction(x[, by]) %in% interaction(y[, by])
|
||||
if (type == "anti") rows <- !rows
|
||||
res <- x[rows, , drop = FALSE]
|
||||
rownames(res) <- NULL
|
||||
res
|
||||
}
|
||||
|
||||
# No export, no Rd
|
||||
addin_insert_in <- function() {
|
||||
rstudioapi::insertText(" %in% ")
|
||||
@ -36,7 +78,7 @@ check_dataset_integrity <- function() {
|
||||
"species", "subspecies", "rank",
|
||||
"col_id", "species_id", "source",
|
||||
"ref", "prevalence", "snomed") %in% colnames(microorganisms),
|
||||
na.rm = TRUE) & NROW(microorganisms) == NROW(microorganismsDT)
|
||||
na.rm = TRUE) & NROW(microorganisms) == NROW(MO_lookup)
|
||||
check_antibiotics <- all(c("ab", "atc", "cid", "name", "group",
|
||||
"atc_group1", "atc_group2", "abbreviations",
|
||||
"synonyms", "oral_ddd", "oral_units",
|
||||
@ -51,12 +93,11 @@ check_dataset_integrity <- function() {
|
||||
invisible(TRUE)
|
||||
}
|
||||
|
||||
#' @importFrom crayon blue bold red
|
||||
#' @importFrom dplyr %>% pull
|
||||
search_type_in_df <- function(x, type) {
|
||||
# try to find columns based on type
|
||||
found <- NULL
|
||||
|
||||
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||
colnames(x) <- trimws(colnames(x))
|
||||
|
||||
# -- mo
|
||||
@ -89,14 +130,14 @@ search_type_in_df <- function(x, type) {
|
||||
if (any(colnames(x) %like% "^(specimen date|specimen_date|spec_date)")) {
|
||||
# WHONET support
|
||||
found <- colnames(x)[colnames(x) %like% "^(specimen date|specimen_date|spec_date)"][1]
|
||||
if (!any(class(x %>% pull(found)) %in% c("Date", "POSIXct"))) {
|
||||
stop(red(paste0("ERROR: Found column `", bold(found), "` to be used as input for `col_", type,
|
||||
if (!any(class(pull(x, found)) %in% c("Date", "POSIXct"))) {
|
||||
stop(font_red(paste0("ERROR: Found column `", font_bold(found), "` to be used as input for `col_", type,
|
||||
"`, but this column contains no valid dates. Transform its values to valid dates first.")),
|
||||
call. = FALSE)
|
||||
}
|
||||
} else {
|
||||
for (i in seq_len(ncol(x))) {
|
||||
if (any(class(x %>% pull(i)) %in% c("Date", "POSIXct"))) {
|
||||
if (any(class(pull(x, i)) %in% c("Date", "POSIXct"))) {
|
||||
found <- colnames(x)[i]
|
||||
break
|
||||
}
|
||||
@ -127,7 +168,7 @@ search_type_in_df <- function(x, type) {
|
||||
if (!is.null(found)) {
|
||||
# this column should contain logicals
|
||||
if (!is.logical(x[, found, drop = TRUE])) {
|
||||
message(red(paste0("NOTE: Column `", bold(found), "` found as input for `col_", type,
|
||||
message(font_red(paste0("NOTE: Column `", font_bold(found), "` found as input for `col_", type,
|
||||
"`, but this column does not contain 'logical' values (TRUE/FALSE) and was ignored.")))
|
||||
found <- NULL
|
||||
}
|
||||
@ -135,11 +176,11 @@ search_type_in_df <- function(x, type) {
|
||||
}
|
||||
|
||||
if (!is.null(found)) {
|
||||
msg <- paste0("NOTE: Using column `", bold(found), "` as input for `col_", type, "`.")
|
||||
msg <- paste0("NOTE: Using column `", font_bold(found), "` as input for `col_", type, "`.")
|
||||
if (type %in% c("keyantibiotics", "specimen")) {
|
||||
msg <- paste(msg, "Use", bold(paste0("col_", type), "= FALSE"), "to prevent this.")
|
||||
msg <- paste(msg, "Use", font_bold(paste0("col_", type), "= FALSE"), "to prevent this.")
|
||||
}
|
||||
message(blue(msg))
|
||||
message(font_blue(msg))
|
||||
}
|
||||
found
|
||||
}
|
||||
@ -147,10 +188,11 @@ search_type_in_df <- function(x, type) {
|
||||
stopifnot_installed_package <- function(package) {
|
||||
# no "utils::installed.packages()" since it requires non-staged install since R 3.6.0
|
||||
# https://developer.r-project.org/Blog/public/2019/02/14/staged-install/index.html
|
||||
tryCatch(get(".packageName", envir = asNamespace(package)),
|
||||
error = function(e) stop("package '", package, "' required but not installed",
|
||||
' - try to install it with: install.packages("', package, '")',
|
||||
call. = FALSE))
|
||||
sapply(package, function(x)
|
||||
tryCatch(get(".packageName", envir = asNamespace(x)),
|
||||
error = function(e) stop("package '", x, "' required but not installed.",
|
||||
"\nTry to install it with: install.packages(\"", x, "\")",
|
||||
call. = FALSE)))
|
||||
return(invisible())
|
||||
}
|
||||
|
||||
@ -206,3 +248,184 @@ dataset_UTF8_to_ASCII <- function(df) {
|
||||
}
|
||||
df
|
||||
}
|
||||
|
||||
|
||||
# replace crayon::has_color
|
||||
has_colour <- function() {
|
||||
if (Sys.getenv("TERM") == "dumb") {
|
||||
return(FALSE)
|
||||
}
|
||||
if (tolower(Sys.info()["sysname"]) == "windows") {
|
||||
if (Sys.getenv("ConEmuANSI") == "ON" | Sys.getenv("CMDER_ROOT") != "") {
|
||||
return(TRUE)
|
||||
} else {
|
||||
return(FALSE)
|
||||
}
|
||||
}
|
||||
"COLORTERM" %in% names(Sys.getenv()) | grepl("^screen|^xterm|^vt100|color|ansi|cygwin|linux",
|
||||
Sys.getenv("TERM"),
|
||||
ignore.case = TRUE,
|
||||
perl = TRUE)
|
||||
}
|
||||
|
||||
|
||||
# the crayon colours
|
||||
try_colour <- function(..., before, after, collapse = " ") {
|
||||
txt <- paste0(unlist(list(...)), collapse = collapse)
|
||||
if (isTRUE(has_colour())) {
|
||||
if (is.null(collapse)) {
|
||||
paste0(before, txt, after, collapse = NULL)
|
||||
} else {
|
||||
paste0(before, txt, after, collapse = "")
|
||||
}
|
||||
} else {
|
||||
txt
|
||||
}
|
||||
}
|
||||
font_black <- function(..., collapse = " ") {
|
||||
try_colour(..., before = "\033[38;5;232m", after = "\033[39m", collapse = collapse)
|
||||
}
|
||||
font_blue <- function(..., collapse = " ") {
|
||||
try_colour(..., before = "\033[34m", after = "\033[39m", collapse = collapse)
|
||||
}
|
||||
font_green <- function(..., collapse = " ") {
|
||||
try_colour(..., before = "\033[32m", after = "\033[39m", collapse = collapse)
|
||||
}
|
||||
font_magenta <- function(..., collapse = " ") {
|
||||
try_colour(..., before = "\033[35m", after = "\033[39m", collapse = collapse)
|
||||
}
|
||||
font_red <- function(..., collapse = " ") {
|
||||
try_colour(..., before = "\033[31m", after = "\033[39m", collapse = collapse)
|
||||
}
|
||||
font_silver <- function(..., collapse = " ") {
|
||||
try_colour(..., before = "\033[90m", after = "\033[39m", collapse = collapse)
|
||||
}
|
||||
font_white <- function(..., collapse = " ") {
|
||||
try_colour(..., before = "\033[37m", after = "\033[39m", collapse = collapse)
|
||||
}
|
||||
font_yellow <- function(..., collapse = " ") {
|
||||
try_colour(..., before = "\033[33m", after = "\033[39m", collapse = collapse)
|
||||
}
|
||||
font_subtle <- function(..., collapse = " ") {
|
||||
try_colour(..., before = "\033[38;5;246m", after = "\033[39m", collapse = collapse)
|
||||
}
|
||||
font_grey <- function(..., collapse = " ") {
|
||||
try_colour(..., before = "\033[38;5;249m", after = "\033[39m", collapse = collapse)
|
||||
}
|
||||
font_green_bg <- function(..., collapse = " ") {
|
||||
try_colour(..., before = "\033[42m", after = "\033[49m", collapse = collapse)
|
||||
}
|
||||
font_red_bg <- function(..., collapse = " ") {
|
||||
try_colour(..., before = "\033[41m", after = "\033[49m", collapse = collapse)
|
||||
}
|
||||
font_yellow_bg <- function(..., collapse = " ") {
|
||||
try_colour(..., before = "\033[43m", after = "\033[49m", collapse = collapse)
|
||||
}
|
||||
font_bold <- function(..., collapse = " ") {
|
||||
try_colour(..., before = "\033[1m", after = "\033[22m", collapse = collapse)
|
||||
}
|
||||
font_italic <- function(..., collapse = " ") {
|
||||
try_colour(..., before = "\033[3m", after = "\033[23m", collapse = collapse)
|
||||
}
|
||||
font_underline <- function(..., collapse = " ") {
|
||||
try_colour(..., before = "\033[4m", after = "\033[24m", collapse = collapse)
|
||||
}
|
||||
font_stripstyle <- function(x) {
|
||||
# from crayon:::ansi_regex
|
||||
gsub("(?:(?:\\x{001b}\\[)|\\x{009b})(?:(?:[0-9]{1,3})?(?:(?:;[0-9]{0,3})*)?[A-M|f-m])|\\x{001b}[A-M]", "", x, perl = TRUE)
|
||||
}
|
||||
|
||||
progress_estimated <- function(n = 1, n_min = 0, ...) {
|
||||
# initiate with:
|
||||
# progress <- progressbar(n)
|
||||
# on.exit(close(progress))
|
||||
#
|
||||
# update with:
|
||||
# progress$tick()
|
||||
if (n >= n_min) {
|
||||
pb <- utils::txtProgressBar(max = n, style = 3)
|
||||
pb$tick <- function() {
|
||||
pb$up(pb$getVal() + 1)
|
||||
}
|
||||
pb
|
||||
} else {
|
||||
pb <- list()
|
||||
pb$tick <- function() {
|
||||
invisible()
|
||||
}
|
||||
pb$kill <- function() {
|
||||
invisible()
|
||||
}
|
||||
structure(pb, class = "txtProgressBar")
|
||||
}
|
||||
}
|
||||
|
||||
# works exactly like round(), but rounds `round(44.55, 1)` as 44.6 instead of 44.5
|
||||
# and adds decimal zeroes until `digits` is reached when force_zero = TRUE
|
||||
round2 <- function(x, digits = 0, force_zero = TRUE) {
|
||||
x <- as.double(x)
|
||||
# https://stackoverflow.com/a/12688836/4575331
|
||||
val <- (trunc((abs(x) * 10 ^ digits) + 0.5) / 10 ^ digits) * sign(x)
|
||||
if (digits > 0 & force_zero == TRUE) {
|
||||
values_trans <- val[val != as.integer(val) & !is.na(val)]
|
||||
val[val != as.integer(val) & !is.na(val)] <- paste0(values_trans,
|
||||
strrep("0",
|
||||
max(0,
|
||||
digits - nchar(
|
||||
format(
|
||||
as.double(
|
||||
gsub(".*[.](.*)$",
|
||||
"\\1",
|
||||
values_trans)),
|
||||
scientific = FALSE)))))
|
||||
}
|
||||
as.double(val)
|
||||
}
|
||||
|
||||
|
||||
# percentage from our other package: 'cleaner'
|
||||
percentage <- function(x, digits = NULL, ...) {
|
||||
|
||||
# getdecimalplaces() function
|
||||
getdecimalplaces <- function(x, minimum = 0, maximum = 3) {
|
||||
if (maximum < minimum) {
|
||||
maximum <- minimum
|
||||
}
|
||||
if (minimum > maximum) {
|
||||
minimum <- maximum
|
||||
}
|
||||
max_places <- max(unlist(lapply(strsplit(sub("0+$", "",
|
||||
as.character(x * 100)), ".", fixed = TRUE),
|
||||
function(y) ifelse(length(y) == 2, nchar(y[2]), 0))), na.rm = TRUE)
|
||||
max(min(max_places,
|
||||
maximum, na.rm = TRUE),
|
||||
minimum, na.rm = TRUE)
|
||||
}
|
||||
|
||||
# format_percentage() function
|
||||
format_percentage <- function(x, digits = NULL, ...) {
|
||||
if (is.null(digits)) {
|
||||
digits <- getdecimalplaces(x)
|
||||
}
|
||||
|
||||
# round right: percentage(0.4455) and format(as.percentage(0.4455), 1) should return "44.6%", not "44.5%"
|
||||
x_formatted <- format(round2(as.double(x), digits = digits + 2) * 100,
|
||||
scientific = FALSE,
|
||||
digits = digits,
|
||||
nsmall = digits,
|
||||
...)
|
||||
x_formatted <- paste0(x_formatted, "%")
|
||||
x_formatted[!grepl(pattern = "^[0-9.,e-]+$", x = x)] <- NA_character_
|
||||
x_formatted
|
||||
}
|
||||
|
||||
# the actual working part
|
||||
x <- as.double(x)
|
||||
if (is.null(digits)) {
|
||||
# max one digit if undefined
|
||||
digits <- getdecimalplaces(x, minimum = 0, maximum = 1)
|
||||
}
|
||||
format_percentage(structure(.Data = as.double(x),
|
||||
class = c("percentage", "numeric")),
|
||||
digits = digits, ...)
|
||||
}
|
||||
|
||||
775
R/aa_helper_functions_dplyr.R
Normal file
775
R/aa_helper_functions_dplyr.R
Normal 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
3
R/ab.R
@ -27,7 +27,6 @@
|
||||
#' @param ... arguments passed on to internal functions
|
||||
#' @rdname as.ab
|
||||
#' @inheritSection WHOCC WHOCC
|
||||
#' @importFrom dplyr %>% filter slice pull
|
||||
#' @details All entries in the [antibiotics] data set have three different identifiers: a human readable EARS-Net code (column `ab`, used by ECDC and WHONET), an ATC code (column `atc`, used by WHO), and a CID code (column `cid`, Compound ID, used by PubChem). The data set contains more than 5,000 official brand names from many different countries, as found in PubChem.
|
||||
#'
|
||||
#' Use the [ab_property()] functions to get properties based on the returned antibiotic ID, see Examples.
|
||||
@ -409,6 +408,6 @@ c.ab <- function(x, ...) {
|
||||
#' @export
|
||||
pillar_shaft.ab <- function(x, ...) {
|
||||
out <- format(x)
|
||||
out[is.na(x)] <- pillar::style_na("NA")
|
||||
out[is.na(x)] <- font_red("NA")
|
||||
pillar::new_pillar_shaft_simple(out, align = "left", min_width = 4)
|
||||
}
|
||||
|
||||
3
R/age.R
3
R/age.R
@ -29,7 +29,6 @@
|
||||
#' @param na.rm a logical to indicate whether missing values should be removed
|
||||
#' @return An [integer] (no decimals) if `exact = FALSE`, a [double] (with decimals) otherwise
|
||||
#' @seealso To split ages into groups, use the [age_groups()] function.
|
||||
#' @importFrom dplyr if_else
|
||||
#' @inheritSection AMR Read more on our website!
|
||||
#' @export
|
||||
#' @examples
|
||||
@ -54,7 +53,7 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE) {
|
||||
|
||||
# from https://stackoverflow.com/a/25450756/4575331
|
||||
years_gap <- reference$year - x$year
|
||||
ages <- if_else(reference$mon < x$mon | (reference$mon == x$mon & reference$mday < x$mday),
|
||||
ages <- ifelse(reference$mon < x$mon | (reference$mon == x$mon & reference$mday < x$mday),
|
||||
as.integer(years_gap - 1),
|
||||
as.integer(years_gap))
|
||||
|
||||
|
||||
2
R/amr.R
2
R/amr.R
@ -60,6 +60,4 @@
|
||||
#' <https://gitlab.com/msberends/AMR/issues>
|
||||
#' @name AMR
|
||||
#' @rdname AMR
|
||||
#' @importFrom microbenchmark microbenchmark
|
||||
#' @importFrom knitr kable
|
||||
NULL
|
||||
|
||||
@ -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))
|
||||
}
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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."))
|
||||
}
|
||||
|
||||
@ -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",
|
||||
|
||||
@ -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`]
|
||||
|
||||
@ -27,13 +27,6 @@
|
||||
#' @export
|
||||
#' @keywords internal
|
||||
#' @name AMR-deprecated
|
||||
#' @rdname AMR-deprecated
|
||||
p.symbol <- function(...) {
|
||||
.Deprecated("p_symbol()", package = "AMR")
|
||||
p_symbol(...)
|
||||
}
|
||||
|
||||
#' @rdname AMR-deprecated
|
||||
#' @export
|
||||
portion_R <- function(...) {
|
||||
.Deprecated("resistance()", package = "AMR")
|
||||
|
||||
3
R/disk.R
3
R/disk.R
@ -92,7 +92,6 @@ all_valid_disks <- function(x) {
|
||||
|
||||
#' @rdname as.disk
|
||||
#' @export
|
||||
#' @importFrom dplyr %>%
|
||||
is.disk <- function(x) {
|
||||
inherits(x, "disk")
|
||||
}
|
||||
@ -123,7 +122,7 @@ print.disk <- function(x, ...) {
|
||||
#' @export
|
||||
pillar_shaft.disk <- function(x, ...) {
|
||||
out <- trimws(format(x))
|
||||
out[is.na(x)] <- pillar::style_na(NA)
|
||||
out[is.na(x)] <- font_red(NA)
|
||||
pillar::new_pillar_shaft_simple(out, align = "right", min_width = 3)
|
||||
}
|
||||
|
||||
|
||||
131
R/eucast_rules.R
131
R/eucast_rules.R
@ -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
|
||||
|
||||
48
R/extended.R
48
R/extended.R
@ -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"
|
||||
}
|
||||
@ -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 = ", ")
|
||||
}
|
||||
|
||||
@ -75,11 +75,8 @@
|
||||
#' @rdname first_isolate
|
||||
#' @seealso [key_antibiotics()]
|
||||
#' @export
|
||||
#' @importFrom dplyr arrange_at lag between row_number filter mutate arrange pull ungroup
|
||||
#' @importFrom crayon blue bold silver
|
||||
# @importFrom clean percentage
|
||||
#' @return A [`logical`] vector
|
||||
#' @source Methodology of this function is based on:
|
||||
#' @source Methodology of this function is strictly based on:
|
||||
#'
|
||||
#' **M39 Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data, 4th Edition**, 2014, *Clinical and Laboratory Standards Institute (CLSI)*. <https://clsi.org/standards/products/microbiology/documents/m39/>.
|
||||
#' @inheritSection AMR Read more on our website!
|
||||
@ -87,6 +84,7 @@
|
||||
#' # `example_isolates` is a dataset available in the AMR package.
|
||||
#' # See ?example_isolates.
|
||||
#'
|
||||
#' \dontrun{
|
||||
#' library(dplyr)
|
||||
#' # Filter on first isolates:
|
||||
#' example_isolates %>%
|
||||
@ -107,13 +105,11 @@
|
||||
#'
|
||||
#' # Have a look at A and B.
|
||||
#' # B is more reliable because every isolate is counted only once.
|
||||
#' # Gentamicin resitance in hospital D appears to be 3.7% higher than
|
||||
#' # Gentamicin resistance in hospital D appears to be 3.7% higher than
|
||||
#' # when you (erroneously) would have used all isolates for analysis.
|
||||
#'
|
||||
#'
|
||||
#' ## OTHER EXAMPLES:
|
||||
#'
|
||||
#' \dontrun{
|
||||
#'
|
||||
#' # Short-hand versions:
|
||||
#' example_isolates %>%
|
||||
@ -151,10 +147,6 @@ first_isolate <- function(x,
|
||||
include_unknown = FALSE,
|
||||
...) {
|
||||
|
||||
if (!is.data.frame(x)) {
|
||||
stop("`x` must be a data.frame.", call. = FALSE)
|
||||
}
|
||||
|
||||
dots <- unlist(list(...))
|
||||
if (length(dots) != 0) {
|
||||
# backwards compatibility with old parameters
|
||||
@ -167,24 +159,30 @@ first_isolate <- function(x,
|
||||
}
|
||||
}
|
||||
|
||||
if (!is.data.frame(x)) {
|
||||
stop("`x` must be a data.frame.", call. = FALSE)
|
||||
}
|
||||
# remove data.table, grouping from tibbles, etc.
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||
|
||||
# try to find columns based on type
|
||||
# -- mo
|
||||
if (is.null(col_mo)) {
|
||||
col_mo <- search_type_in_df(x = x, type = "mo")
|
||||
}
|
||||
if (is.null(col_mo)) {
|
||||
stop("`col_mo` must be set.", call. = FALSE)
|
||||
if (is.null(col_mo)) {
|
||||
stop("`col_mo` must be set.", call. = FALSE)
|
||||
}
|
||||
}
|
||||
|
||||
# -- date
|
||||
if (is.null(col_date)) {
|
||||
col_date <- search_type_in_df(x = x, type = "date")
|
||||
if (is.null(col_date)) {
|
||||
stop("`col_date` must be set.", call. = FALSE)
|
||||
}
|
||||
}
|
||||
if (is.null(col_date)) {
|
||||
stop("`col_date` must be set.", call. = FALSE)
|
||||
}
|
||||
# convert to Date (pipes/pull for supporting tibbles too)
|
||||
dates <- x %>% pull(col_date) %>% as.Date()
|
||||
# convert to Date
|
||||
dates <- as.Date(x[, col_date, drop = TRUE])
|
||||
dates[is.na(dates)] <- as.Date("1970-01-01")
|
||||
x[, col_date] <- dates
|
||||
|
||||
@ -192,15 +190,15 @@ first_isolate <- function(x,
|
||||
if (is.null(col_patient_id)) {
|
||||
if (all(c("First name", "Last name", "Sex") %in% colnames(x))) {
|
||||
# WHONET support
|
||||
x <- x %>% mutate(patient_id = paste(`First name`, `Last name`, Sex))
|
||||
x$patient_id <- paste(x$`First name`, x$`Last name`, x$Sex)
|
||||
col_patient_id <- "patient_id"
|
||||
message(blue(paste0("NOTE: Using combined columns `", bold("First name"), "`, `", bold("Last name"), "` and `", bold("Sex"), "` as input for `col_patient_id`")))
|
||||
message(font_blue(paste0("NOTE: Using combined columns `", font_bold("First name"), "`, `", font_bold("Last name"), "` and `", font_bold("Sex"), "` as input for `col_patient_id`")))
|
||||
} else {
|
||||
col_patient_id <- search_type_in_df(x = x, type = "patient_id")
|
||||
}
|
||||
}
|
||||
if (is.null(col_patient_id)) {
|
||||
stop("`col_patient_id` must be set.", call. = FALSE)
|
||||
if (is.null(col_patient_id)) {
|
||||
stop("`col_patient_id` must be set.", call. = FALSE)
|
||||
}
|
||||
}
|
||||
|
||||
# -- key antibiotics
|
||||
@ -239,27 +237,19 @@ first_isolate <- function(x,
|
||||
check_columns_existance(col_icu)
|
||||
check_columns_existance(col_keyantibiotics)
|
||||
|
||||
# create new dataframe with original row index
|
||||
x <- x %>%
|
||||
mutate(newvar_row_index = seq_len(nrow(x)),
|
||||
newvar_mo = x %>% pull(col_mo) %>% as.mo(),
|
||||
newvar_genus_species = paste(mo_genus(newvar_mo), mo_species(newvar_mo)),
|
||||
newvar_date = x %>% pull(col_date),
|
||||
newvar_patient_id = x %>% pull(col_patient_id))
|
||||
# create original row index
|
||||
x$newvar_row_index <- seq_len(nrow(x))
|
||||
x$newvar_mo <- x %>% pull(col_mo) %>% as.mo()
|
||||
x$newvar_genus_species <- paste(mo_genus(x$newvar_mo), mo_species(x$newvar_mo))
|
||||
x$newvar_date <- x %>% pull(col_date)
|
||||
x$newvar_patient_id <- x %>% pull(col_patient_id)
|
||||
|
||||
if (is.null(col_testcode)) {
|
||||
testcodes_exclude <- NULL
|
||||
}
|
||||
# remove testcodes
|
||||
if (!is.null(testcodes_exclude) & info == TRUE) {
|
||||
message(blue(paste0("[Criterion] Excluded test codes: ", toString(testcodes_exclude))))
|
||||
}
|
||||
|
||||
if (is.null(col_icu)) {
|
||||
icu_exclude <- FALSE
|
||||
} else {
|
||||
x <- x %>%
|
||||
mutate(col_icu = x %>% pull(col_icu) %>% as.logical())
|
||||
message(font_black(paste0("[Criterion] Exclude test codes: ", toString(paste0("'", testcodes_exclude, "'")))))
|
||||
}
|
||||
|
||||
if (is.null(col_specimen)) {
|
||||
@ -270,11 +260,11 @@ first_isolate <- function(x,
|
||||
if (!is.null(specimen_group)) {
|
||||
check_columns_existance(col_specimen, x)
|
||||
if (info == TRUE) {
|
||||
message(blue(paste0("[Criterion] Excluded other than specimen group '", specimen_group, "'")))
|
||||
message(font_black(paste0("[Criterion] Exclude other than specimen group '", specimen_group, "'")))
|
||||
}
|
||||
}
|
||||
if (!is.null(col_keyantibiotics)) {
|
||||
x <- x %>% mutate(key_ab = x %>% pull(col_keyantibiotics))
|
||||
x$newvar_key_ab <- x[, col_keyantibiotics, drop = TRUE]
|
||||
}
|
||||
|
||||
if (is.null(testcodes_exclude)) {
|
||||
@ -283,87 +273,38 @@ first_isolate <- function(x,
|
||||
|
||||
# arrange data to the right sorting
|
||||
if (is.null(specimen_group)) {
|
||||
# not filtering on specimen
|
||||
if (icu_exclude == FALSE) {
|
||||
if (info == TRUE & !is.null(col_icu)) {
|
||||
message(blue("[Criterion] Included isolates from ICU"))
|
||||
}
|
||||
x <- x %>%
|
||||
arrange(newvar_patient_id,
|
||||
newvar_genus_species,
|
||||
newvar_date)
|
||||
x <- x[order(x$newvar_patient_id,
|
||||
x$newvar_genus_species,
|
||||
x$newvar_date), ]
|
||||
rownames(x) <- NULL
|
||||
row.start <- 1
|
||||
row.end <- nrow(x)
|
||||
} else {
|
||||
if (info == TRUE) {
|
||||
message(blue("[Criterion] Excluded isolates from ICU"))
|
||||
}
|
||||
x <- x %>%
|
||||
arrange_at(c(col_icu,
|
||||
"newvar_patient_id",
|
||||
"newvar_genus_species",
|
||||
"newvar_date"))
|
||||
|
||||
suppressWarnings(
|
||||
row.start <- which(x %>% pull(col_icu) == FALSE) %>% min(na.rm = TRUE)
|
||||
)
|
||||
suppressWarnings(
|
||||
row.end <- which(x %>% pull(col_icu) == FALSE) %>% max(na.rm = TRUE)
|
||||
)
|
||||
}
|
||||
|
||||
} else {
|
||||
# filtering on specimen and only analyse these row to save time
|
||||
if (icu_exclude == FALSE) {
|
||||
if (info == TRUE & !is.null(col_icu)) {
|
||||
message(blue("[Criterion] Included isolates from ICU.\n"))
|
||||
}
|
||||
x <- x %>%
|
||||
arrange_at(c(col_specimen,
|
||||
"newvar_patient_id",
|
||||
"newvar_genus_species",
|
||||
"newvar_date"))
|
||||
# filtering on specimen and only analyse these rows to save time
|
||||
x <- x[order(pull(x, col_specimen),
|
||||
x$newvar_patient_id,
|
||||
x$newvar_genus_species,
|
||||
x$newvar_date), ]
|
||||
rownames(x) <- NULL
|
||||
suppressWarnings(
|
||||
row.start <- which(x %>% pull(col_specimen) == specimen_group) %>% min(na.rm = TRUE)
|
||||
)
|
||||
suppressWarnings(
|
||||
row.end <- which(x %>% pull(col_specimen) == specimen_group) %>% max(na.rm = TRUE)
|
||||
)
|
||||
} else {
|
||||
if (info == TRUE) {
|
||||
message(blue("[Criterion] Excluded isolates from ICU"))
|
||||
}
|
||||
x <- x %>%
|
||||
arrange_at(c(col_icu,
|
||||
col_specimen,
|
||||
"newvar_patient_id",
|
||||
"newvar_genus_species",
|
||||
"newvar_date"))
|
||||
suppressWarnings(
|
||||
row.start <- min(which(x %>% pull(col_specimen) == specimen_group
|
||||
& x %>% pull(col_icu) == FALSE),
|
||||
na.rm = TRUE)
|
||||
)
|
||||
suppressWarnings(
|
||||
row.end <- max(which(x %>% pull(col_specimen) == specimen_group &
|
||||
x %>% pull(col_icu) == FALSE),
|
||||
na.rm = TRUE)
|
||||
)
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
# no isolates found
|
||||
if (abs(row.start) == Inf | abs(row.end) == Inf) {
|
||||
if (info == TRUE) {
|
||||
message(paste("=> Found", bold("no isolates")))
|
||||
message(paste("=> Found", font_bold("no isolates")))
|
||||
}
|
||||
return(rep(FALSE, nrow(x)))
|
||||
}
|
||||
|
||||
# did find some isolates - add new index numbers of rows
|
||||
x <- x %>% mutate(newvar_row_index_sorted = seq_len(nrow(.)))
|
||||
|
||||
x$newvar_row_index_sorted <- seq_len(nrow(x))
|
||||
|
||||
scope.size <- row.end - row.start + 1
|
||||
|
||||
identify_new_year <- function(x, episode_days) {
|
||||
@ -389,123 +330,121 @@ first_isolate <- function(x,
|
||||
}
|
||||
|
||||
# Analysis of first isolate ----
|
||||
all_first <- x %>%
|
||||
mutate(other_pat_or_mo = if_else(newvar_patient_id == lag(newvar_patient_id)
|
||||
& newvar_genus_species == lag(newvar_genus_species),
|
||||
FALSE,
|
||||
TRUE)) %>%
|
||||
group_by(newvar_patient_id,
|
||||
newvar_genus_species) %>%
|
||||
mutate(more_than_episode_ago = identify_new_year(x = newvar_date,
|
||||
episode_days = episode_days)) %>%
|
||||
ungroup()
|
||||
x$other_pat_or_mo <- if_else(x$newvar_patient_id == lag(x$newvar_patient_id) &
|
||||
x$newvar_genus_species == lag(x$newvar_genus_species),
|
||||
FALSE,
|
||||
TRUE)
|
||||
x$episode_group <- paste(x$newvar_patient_id, x$newvar_genus_species)
|
||||
x$more_than_episode_ago <- unname(unlist(lapply(unique(x$episode_group),
|
||||
function(g,
|
||||
df = x,
|
||||
days = episode_days) {
|
||||
identify_new_year(x = df[which(df$episode_group == g), "newvar_date"],
|
||||
episode_days = days)
|
||||
})))
|
||||
|
||||
weighted.notice <- ""
|
||||
if (!is.null(col_keyantibiotics)) {
|
||||
weighted.notice <- "weighted "
|
||||
if (info == TRUE) {
|
||||
if (type == "keyantibiotics") {
|
||||
message(blue(paste0("[Criterion] Inclusion based on key antibiotics, ",
|
||||
message(font_black(paste0("[Criterion] Base inclusion on key antibiotics, ",
|
||||
ifelse(ignore_I == FALSE, "not ", ""),
|
||||
"ignoring I")))
|
||||
}
|
||||
if (type == "points") {
|
||||
message(blue(paste0("[Criterion] Inclusion based on key antibiotics, using points threshold of "
|
||||
message(font_black(paste0("[Criterion] Base inclusion on key antibiotics, using points threshold of "
|
||||
, points_threshold)))
|
||||
}
|
||||
}
|
||||
type_param <- type
|
||||
|
||||
all_first <- all_first %>%
|
||||
mutate(key_ab_lag = lag(key_ab)) %>%
|
||||
mutate(key_ab_other = !key_antibiotics_equal(y = key_ab,
|
||||
z = key_ab_lag,
|
||||
type = type_param,
|
||||
ignore_I = ignore_I,
|
||||
points_threshold = points_threshold,
|
||||
info = info)) %>%
|
||||
mutate(
|
||||
real_first_isolate =
|
||||
if_else(
|
||||
newvar_row_index_sorted %>% between(row.start, row.end)
|
||||
& newvar_genus_species != ""
|
||||
& (other_pat_or_mo | more_than_episode_ago | key_ab_other),
|
||||
TRUE,
|
||||
FALSE))
|
||||
x$other_key_ab <- !key_antibiotics_equal(y = x$newvar_key_ab,
|
||||
z = lag(x$newvar_key_ab),
|
||||
type = type_param,
|
||||
ignore_I = ignore_I,
|
||||
points_threshold = points_threshold,
|
||||
info = info)
|
||||
# with key antibiotics
|
||||
x$newvar_first_isolate <- if_else(x$newvar_row_index_sorted >= row.start &
|
||||
x$newvar_row_index_sorted <= row.end &
|
||||
x$newvar_genus_species != "" &
|
||||
(x$other_pat_or_mo | x$more_than_episode_ago | x$other_key_ab),
|
||||
TRUE,
|
||||
FALSE)
|
||||
|
||||
} else {
|
||||
# no key antibiotics
|
||||
all_first <- all_first %>%
|
||||
mutate(
|
||||
real_first_isolate =
|
||||
if_else(
|
||||
newvar_row_index_sorted %>% between(row.start, row.end)
|
||||
& newvar_genus_species != ""
|
||||
& (other_pat_or_mo | more_than_episode_ago),
|
||||
TRUE,
|
||||
FALSE))
|
||||
|
||||
x$newvar_first_isolate <- if_else(x$newvar_row_index_sorted >= row.start &
|
||||
x$newvar_row_index_sorted <= row.end &
|
||||
x$newvar_genus_species != "" &
|
||||
(x$other_pat_or_mo | x$more_than_episode_ago),
|
||||
TRUE,
|
||||
FALSE)
|
||||
}
|
||||
|
||||
# first one as TRUE
|
||||
all_first[row.start, "real_first_isolate"] <- TRUE
|
||||
x[row.start, "newvar_first_isolate"] <- TRUE
|
||||
# no tests that should be included, or ICU
|
||||
if (!is.null(col_testcode)) {
|
||||
all_first[which(all_first[, col_testcode] %in% tolower(testcodes_exclude)), "real_first_isolate"] <- FALSE
|
||||
x[which(x[, col_testcode] %in% tolower(testcodes_exclude)), "newvar_first_isolate"] <- FALSE
|
||||
}
|
||||
if (icu_exclude == TRUE) {
|
||||
all_first[which(all_first[, col_icu] == TRUE), "real_first_isolate"] <- FALSE
|
||||
if (!is.null(col_icu)) {
|
||||
if (icu_exclude == TRUE) {
|
||||
message(font_black("[Criterion] Exclude isolates from ICU.\n"))
|
||||
x[which(as.logical(x[, col_icu, drop = TRUE])), "newvar_first_isolate"] <- FALSE
|
||||
} else {
|
||||
message(font_black("[Criterion] Include isolates from ICU.\n"))
|
||||
}
|
||||
}
|
||||
|
||||
decimal.mark <- getOption("OutDec")
|
||||
big.mark <- ifelse(decimal.mark != ",", ",", ".")
|
||||
|
||||
# handle empty microorganisms
|
||||
if (any(all_first$newvar_mo == "UNKNOWN", na.rm = TRUE) & info == TRUE) {
|
||||
message(blue(paste0("NOTE: ", ifelse(include_unknown == TRUE, "Included ", "Excluded "),
|
||||
format(sum(all_first$newvar_mo == "UNKNOWN"),
|
||||
if (any(x$newvar_mo == "UNKNOWN", na.rm = TRUE) & info == TRUE) {
|
||||
message(font_blue(paste0("NOTE: ", ifelse(include_unknown == TRUE, "Included ", "Excluded "),
|
||||
format(sum(x$newvar_mo == "UNKNOWN"),
|
||||
decimal.mark = decimal.mark, big.mark = big.mark),
|
||||
" isolates with a microbial ID 'UNKNOWN' (column `", bold(col_mo), "`)")))
|
||||
" isolates with a microbial ID 'UNKNOWN' (column `", font_bold(col_mo), "`)")))
|
||||
}
|
||||
all_first[which(all_first$newvar_mo == "UNKNOWN"), "real_first_isolate"] <- include_unknown
|
||||
x[which(x$newvar_mo == "UNKNOWN"), "newvar_first_isolate"] <- include_unknown
|
||||
|
||||
# exclude all NAs
|
||||
if (any(is.na(all_first$newvar_mo)) & info == TRUE) {
|
||||
message(blue(paste0("NOTE: Excluded ", format(sum(is.na(all_first$newvar_mo)),
|
||||
if (any(is.na(x$newvar_mo)) & info == TRUE) {
|
||||
message(font_blue(paste0("NOTE: Excluded ", format(sum(is.na(x$newvar_mo)),
|
||||
decimal.mark = decimal.mark, big.mark = big.mark),
|
||||
" isolates with a microbial ID 'NA' (column `", bold(col_mo), "`)")))
|
||||
" isolates with a microbial ID 'NA' (column `", font_bold(col_mo), "`)")))
|
||||
}
|
||||
all_first[which(is.na(all_first$newvar_mo)), "real_first_isolate"] <- FALSE
|
||||
x[which(is.na(x$newvar_mo)), "newvar_first_isolate"] <- FALSE
|
||||
|
||||
# arrange back according to original sorting again
|
||||
all_first <- all_first %>%
|
||||
arrange(newvar_row_index) %>%
|
||||
pull(real_first_isolate)
|
||||
x <- x[order(x$newvar_row_index), ]
|
||||
rownames(x) <- NULL
|
||||
|
||||
if (info == TRUE) {
|
||||
n_found <- base::sum(all_first, na.rm = TRUE)
|
||||
n_found <- base::sum(x$newvar_first_isolate, na.rm = TRUE)
|
||||
p_found_total <- percentage(n_found / nrow(x))
|
||||
p_found_scope <- percentage(n_found / scope.size)
|
||||
# mark up number of found
|
||||
n_found <- base::format(n_found, big.mark = big.mark, decimal.mark = decimal.mark)
|
||||
if (p_found_total != p_found_scope) {
|
||||
msg_txt <- paste0("=> Found ",
|
||||
bold(paste0(n_found, " first ", weighted.notice, "isolates")),
|
||||
font_bold(paste0(n_found, " first ", weighted.notice, "isolates")),
|
||||
" (", p_found_scope, " within scope and ", p_found_total, " of total)")
|
||||
} else {
|
||||
msg_txt <- paste0("=> Found ",
|
||||
bold(paste0(n_found, " first ", weighted.notice, "isolates")),
|
||||
font_bold(paste0(n_found, " first ", weighted.notice, "isolates")),
|
||||
" (", p_found_total, " of total)")
|
||||
}
|
||||
base::message(msg_txt)
|
||||
message(font_black(msg_txt))
|
||||
}
|
||||
|
||||
all_first
|
||||
x$newvar_first_isolate
|
||||
|
||||
}
|
||||
|
||||
#' @rdname first_isolate
|
||||
#' @importFrom dplyr filter
|
||||
#' @export
|
||||
filter_first_isolate <- function(x,
|
||||
col_date = NULL,
|
||||
@ -520,7 +459,6 @@ filter_first_isolate <- function(x,
|
||||
}
|
||||
|
||||
#' @rdname first_isolate
|
||||
#' @importFrom dplyr %>% mutate filter
|
||||
#' @export
|
||||
filter_first_weighted_isolate <- function(x,
|
||||
col_date = NULL,
|
||||
|
||||
3
R/freq.R
3
R/freq.R
@ -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, ...) {
|
||||
|
||||
@ -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,
|
||||
|
||||
@ -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)
|
||||
})
|
||||
}
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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, ...)
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
@ -31,7 +31,9 @@
|
||||
#' @param GramNeg_1,GramNeg_2,GramNeg_3,GramNeg_4,GramNeg_5,GramNeg_6 column names of antibiotics for **Gram-negatives**, case-insensitive. At default, the columns containing these antibiotics will be guessed with [guess_ab_col()].
|
||||
#' @param warnings give warning about missing antibiotic columns, they will anyway be ignored
|
||||
#' @param ... other parameters passed on to function
|
||||
#' @details The function [key_antibiotics()] returns a character vector with 12 antibiotic results for every isolate. These isolates can then be compared using [key_antibiotics_equal()], to check if two isolates have generally the same antibiogram. Missing and invalid values are replaced with a dot (`"."`). The [first_isolate()] function only uses this function on the same microbial species from the same patient. Using this, an MRSA will be included after a susceptible *S. aureus* (MSSA) found within the same episode (see `episode` parameter of [first_isolate()]). Without key antibiotic comparison it would not.
|
||||
#' @details The function [key_antibiotics()] returns a character vector with 12 antibiotic results for every isolate. These isolates can then be compared using [key_antibiotics_equal()], to check if two isolates have generally the same antibiogram. Missing and invalid values are replaced with a dot (`"."`) by [key_antibiotics()] and ignored by [key_antibiotics_equal()].
|
||||
#'
|
||||
#' The [first_isolate()] function only uses this function on the same microbial species from the same patient. Using this, e.g. an MRSA will be included after a susceptible *S. aureus* (MSSA) is found within the same patient episode. Without key antibiotic comparison it would not. See [first_isolate()] for more info.
|
||||
#'
|
||||
#' At default, the antibiotics that are used for **Gram-positive bacteria** are:
|
||||
#' - Amoxicillin
|
||||
@ -65,8 +67,6 @@
|
||||
#' @inheritSection first_isolate Key antibiotics
|
||||
#' @rdname key_antibiotics
|
||||
#' @export
|
||||
#' @importFrom dplyr %>% mutate if_else pull
|
||||
#' @importFrom crayon blue bold
|
||||
#' @seealso [first_isolate()]
|
||||
#' @inheritSection AMR Read more on our website!
|
||||
#' @examples
|
||||
@ -120,6 +120,15 @@ key_antibiotics <- function(x,
|
||||
GramNeg_6 = guess_ab_col(x, "meropenem"),
|
||||
warnings = TRUE,
|
||||
...) {
|
||||
|
||||
dots <- unlist(list(...))
|
||||
if (length(dots) != 0) {
|
||||
# backwards compatibility with old parameters
|
||||
dots.names <- dots %>% names()
|
||||
if ("info" %in% dots.names) {
|
||||
warnings <- dots[which(dots.names == "info")]
|
||||
}
|
||||
}
|
||||
|
||||
# try to find columns based on type
|
||||
# -- mo
|
||||
@ -134,7 +143,7 @@ key_antibiotics <- function(x,
|
||||
col.list <- c(universal_1, universal_2, universal_3, universal_4, universal_5, universal_6,
|
||||
GramPos_1, GramPos_2, GramPos_3, GramPos_4, GramPos_5, GramPos_6,
|
||||
GramNeg_1, GramNeg_2, GramNeg_3, GramNeg_4, GramNeg_5, GramNeg_6)
|
||||
check_available_columns <- function(x, col.list, info = TRUE) {
|
||||
check_available_columns <- function(x, col.list, warnings = TRUE) {
|
||||
# check columns
|
||||
col.list <- col.list[!is.na(col.list) & !is.null(col.list)]
|
||||
names(col.list) <- col.list
|
||||
@ -152,7 +161,7 @@ key_antibiotics <- function(x,
|
||||
}
|
||||
}
|
||||
if (!all(col.list %in% colnames(x))) {
|
||||
if (info == TRUE) {
|
||||
if (warnings == TRUE) {
|
||||
warning("Some columns do not exist and will be ignored: ",
|
||||
col.list.bak[!(col.list %in% colnames(x))] %>% toString(),
|
||||
".\nTHIS MAY STRONGLY INFLUENCE THE OUTCOME.",
|
||||
@ -163,7 +172,7 @@ key_antibiotics <- function(x,
|
||||
col.list
|
||||
}
|
||||
|
||||
col.list <- check_available_columns(x = x, col.list = col.list, info = warnings)
|
||||
col.list <- check_available_columns(x = x, col.list = col.list, warnings = warnings)
|
||||
universal_1 <- col.list[universal_1]
|
||||
universal_2 <- col.list[universal_2]
|
||||
universal_3 <- col.list[universal_3]
|
||||
@ -205,37 +214,34 @@ key_antibiotics <- function(x,
|
||||
}
|
||||
|
||||
# join to microorganisms data set
|
||||
x <- x %>%
|
||||
as.data.frame(stringsAsFactors = FALSE) %>%
|
||||
mutate_at(vars(col_mo), as.mo) %>%
|
||||
left_join_microorganisms(by = col_mo) %>%
|
||||
mutate(key_ab = NA_character_,
|
||||
gramstain = mo_gramstain(pull(., col_mo), language = NULL))
|
||||
x <- x %>% as.data.frame(stringsAsFactors = FALSE)
|
||||
x[, col_mo] <- as.mo(x[, col_mo, drop = TRUE])
|
||||
x$gramstain <- mo_gramstain(x[, col_mo, drop = TRUE], language = NULL)
|
||||
|
||||
x$key_ab <- NA_character_
|
||||
# mutate_at(vars(col_mo), as.mo) %>%
|
||||
# left_join_microorganisms(by = col_mo) %>%
|
||||
# mutate(key_ab = NA_character_,
|
||||
# gramstain = mo_gramstain(pull(., col_mo), language = NULL))
|
||||
#
|
||||
# Gram +
|
||||
x <- x %>% mutate(key_ab =
|
||||
if_else(gramstain == "Gram-positive",
|
||||
tryCatch(apply(X = x[, gram_positive],
|
||||
MARGIN = 1,
|
||||
FUN = function(x) paste(x, collapse = "")),
|
||||
error = function(e) paste0(rep(".", 12), collapse = "")),
|
||||
key_ab))
|
||||
x$key_ab <- if_else(x$gramstain == "Gram-positive",
|
||||
tryCatch(apply(X = x[, gram_positive],
|
||||
MARGIN = 1,
|
||||
FUN = function(x) paste(x, collapse = "")),
|
||||
error = function(e) paste0(rep(".", 12), collapse = "")),
|
||||
x$key_ab)
|
||||
|
||||
# Gram -
|
||||
x <- x %>% mutate(key_ab =
|
||||
if_else(gramstain == "Gram-negative",
|
||||
tryCatch(apply(X = x[, gram_negative],
|
||||
MARGIN = 1,
|
||||
FUN = function(x) paste(x, collapse = "")),
|
||||
error = function(e) paste0(rep(".", 12), collapse = "")),
|
||||
key_ab))
|
||||
x$key_ab <- if_else(x$gramstain == "Gram-negative",
|
||||
tryCatch(apply(X = x[, gram_negative],
|
||||
MARGIN = 1,
|
||||
FUN = function(x) paste(x, collapse = "")),
|
||||
error = function(e) paste0(rep(".", 12), collapse = "")),
|
||||
x$key_ab)
|
||||
|
||||
# format
|
||||
key_abs <- x %>%
|
||||
pull(key_ab) %>%
|
||||
gsub("(NA|NULL)", ".", .) %>%
|
||||
gsub("[^SIR]", ".", ., ignore.case = TRUE) %>%
|
||||
toupper()
|
||||
key_abs <- toupper(gsub("[^SIR]", ".", gsub("(NA|NULL)", ".", x$key_ab)))
|
||||
|
||||
if (n_distinct(key_abs) == 1) {
|
||||
warning("No distinct key antibiotics determined.", call. = FALSE)
|
||||
@ -245,7 +251,6 @@ key_antibiotics <- function(x,
|
||||
|
||||
}
|
||||
|
||||
#' @importFrom dplyr %>%
|
||||
#' @rdname key_antibiotics
|
||||
#' @export
|
||||
key_antibiotics_equal <- function(y,
|
||||
@ -271,12 +276,13 @@ key_antibiotics_equal <- function(y,
|
||||
|
||||
if (info_needed == TRUE) {
|
||||
p <- progress_estimated(length(x))
|
||||
on.exit(close(p))
|
||||
}
|
||||
|
||||
for (i in seq_len(length(x))) {
|
||||
|
||||
if (info_needed == TRUE) {
|
||||
p$tick()$print()
|
||||
p$tick()
|
||||
}
|
||||
|
||||
if (is.na(x[i])) {
|
||||
|
||||
37
R/like.R
37
R/like.R
@ -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
209
R/mdro.R
@ -61,9 +61,6 @@
|
||||
#' Ordered [`factor`] with levels `Negative` < `Positive, unconfirmed` < `Positive`. The value `"Positive, unconfirmed"` means that, according to the guideline, it is not entirely sure if the isolate is multi-drug resistant and this should be confirmed with additional (e.g. molecular) tests
|
||||
#' @rdname mdro
|
||||
#' @aliases MDR XDR PDR BRMO 3MRGN 4MRGN
|
||||
#' @importFrom dplyr %>% filter_at vars all_vars pull mutate_at
|
||||
#' @importFrom crayon blue bold italic red
|
||||
#' @importFrom cleaner percentage
|
||||
#' @export
|
||||
#' @inheritSection AMR Read more on our website!
|
||||
#' @source
|
||||
@ -99,7 +96,7 @@ mdro <- function(x,
|
||||
if ("rstudioapi" %in% rownames(utils::installed.packages())) {
|
||||
q_continue <- rstudioapi::showQuestion("Using verbose = TRUE with mdro()", txt)
|
||||
} else {
|
||||
q_continue <- menu(choices = c("OK", "Cancel"), graphics = TRUE, title = txt)
|
||||
q_continue <- utils::menu(choices = c("OK", "Cancel"), graphics = FALSE, title = txt)
|
||||
}
|
||||
if (q_continue %in% c(FALSE, 2)) {
|
||||
message("Cancelled, returning original data")
|
||||
@ -110,6 +107,9 @@ mdro <- function(x,
|
||||
if (!is.data.frame(x)) {
|
||||
stop("`x` must be a data frame.", call. = FALSE)
|
||||
}
|
||||
# force regular data.frame, not a tibble or data.table
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||
|
||||
if (!is.numeric(pct_required_classes)) {
|
||||
stop("`pct_required_classes` must be numeric.", call. = FALSE)
|
||||
}
|
||||
@ -147,8 +147,8 @@ mdro <- function(x,
|
||||
col_mo <- search_type_in_df(x = x, type = "mo")
|
||||
}
|
||||
if (is.null(col_mo) & guideline$code == "tb") {
|
||||
message(blue("NOTE: No column found as input for `col_mo`,",
|
||||
bold("assuming all records contain", italic("Mycobacterium tuberculosis.\n"))))
|
||||
message(font_blue("NOTE: No column found as input for `col_mo`,",
|
||||
font_bold("assuming all records contain", font_italic("Mycobacterium tuberculosis."))))
|
||||
x$mo <- as.mo("Mycobacterium tuberculosis")
|
||||
col_mo <- "mo"
|
||||
}
|
||||
@ -418,7 +418,7 @@ mdro <- function(x,
|
||||
if (guideline$code == "tb" & length(abx_tb) == 0) {
|
||||
stop("No antimycobacterials found in data set.", call. = FALSE)
|
||||
}
|
||||
|
||||
|
||||
if (combine_SI == TRUE) {
|
||||
search_result <- "R"
|
||||
} else {
|
||||
@ -427,15 +427,15 @@ mdro <- function(x,
|
||||
|
||||
if (info == TRUE) {
|
||||
if (combine_SI == TRUE) {
|
||||
cat(red("\nOnly results with 'R' are considered as resistance. Use `combine_SI = FALSE` to also consider 'I' as resistance.\n"))
|
||||
cat(font_red("\nOnly results with 'R' are considered as resistance. Use `combine_SI = FALSE` to also consider 'I' as resistance.\n"))
|
||||
} else {
|
||||
cat(red("\nResults with 'R' or 'I' are considered as resistance. Use `combine_SI = TRUE` to only consider 'R' as resistance.\n"))
|
||||
cat(font_red("\nResults with 'R' or 'I' are considered as resistance. Use `combine_SI = TRUE` to only consider 'R' as resistance.\n"))
|
||||
}
|
||||
cat("\nDetermining multidrug-resistant organisms (MDRO), according to:\n",
|
||||
bold("Guideline: "), italic(guideline$name), "\n",
|
||||
bold("Version: "), guideline$version, "\n",
|
||||
bold("Author: "), guideline$author, "\n",
|
||||
bold("Source: "), guideline$source, "\n",
|
||||
font_bold("Guideline: "), font_italic(guideline$name), "\n",
|
||||
font_bold("Version: "), guideline$version, "\n",
|
||||
font_bold("Author: "), guideline$author, "\n",
|
||||
font_bold("Source: "), guideline$source, "\n",
|
||||
"\n", sep = "")
|
||||
}
|
||||
|
||||
@ -460,7 +460,7 @@ mdro <- function(x,
|
||||
cols <- cols[!ab_missing(cols)]
|
||||
cols <- cols[!is.na(cols)]
|
||||
if (length(rows) > 0 & length(cols) > 0) {
|
||||
x <<- x %>% mutate_at(vars(cols), as.rsi)
|
||||
x[, cols] <- as.data.frame(lapply(x[, cols, drop = FALSE], function(col) as.rsi(col)))
|
||||
x[rows, "columns_nonsusceptible"] <<- sapply(rows,
|
||||
function(row, group_vct = cols) {
|
||||
cols_nonsus <- sapply(x[row, group_vct, drop = FALSE],
|
||||
@ -471,13 +471,14 @@ mdro <- function(x,
|
||||
})
|
||||
|
||||
if (any_all == "any") {
|
||||
search_function <- dplyr::any_vars
|
||||
search_function <- any
|
||||
} else if (any_all == "all") {
|
||||
search_function <- dplyr::all_vars
|
||||
search_function <- all
|
||||
}
|
||||
row_filter <- x %>%
|
||||
filter_at(vars(cols), search_function(. %in% search_result)) %>%
|
||||
pull("row_number")
|
||||
row_filter <- as.logical(by(x,
|
||||
seq_len(nrow(x)),
|
||||
function(row) search_function(unlist(row[, cols]) %in% search_result, na.rm = TRUE)))
|
||||
row_filter <- x[row_filter, "row_number", drop = TRUE]
|
||||
rows <- rows[rows %in% row_filter]
|
||||
x[rows, "MDRO"] <<- to
|
||||
x[rows, "reason"] <<- paste0(any_all, " of the required antibiotics ", ifelse(any_all == "any", "is", "are"), " R")
|
||||
@ -485,12 +486,12 @@ mdro <- function(x,
|
||||
}
|
||||
trans_tbl2 <- function(txt, rows, lst) {
|
||||
if (info == TRUE) {
|
||||
message(blue(txt, "..."), appendLF = FALSE)
|
||||
message(font_blue(txt, "..."), appendLF = FALSE)
|
||||
}
|
||||
if (length(rows) > 0) {
|
||||
# function specific for the CMI paper of 2012 (Magiorakos et al.)
|
||||
lst_vector <- unlist(lst)[!is.na(unlist(lst))]
|
||||
x <<- x %>% mutate_at(vars(lst_vector), as.rsi)
|
||||
x[, lst_vector] <- as.data.frame(lapply(x[, lst_vector, drop = FALSE], function(col) as.rsi(col)))
|
||||
x[rows, "classes_in_guideline"] <<- length(lst)
|
||||
x[rows, "classes_available"] <<- sapply(rows,
|
||||
function(row, group_tbl = lst) {
|
||||
@ -513,28 +514,25 @@ mdro <- function(x,
|
||||
na.rm = TRUE)
|
||||
})
|
||||
# for PDR; all agents are R (or I if combine_SI = FALSE)
|
||||
x[filter_at(x[rows, ],
|
||||
vars(lst_vector),
|
||||
all_vars(. %in% search_result))$row_number, "classes_affected"] <<- 999
|
||||
row_filter <- as.logical(by(x[rows, ],
|
||||
seq_len(nrow(x[rows, ])),
|
||||
function(row) all(unlist(row[, lst_vector]) %in% search_result, na.rm = TRUE)))
|
||||
x[row_filter, "classes_affected"] <<- 999
|
||||
}
|
||||
|
||||
if (info == TRUE) {
|
||||
message(blue(" OK"))
|
||||
message(font_blue(" OK"))
|
||||
}
|
||||
}
|
||||
|
||||
x <- x %>%
|
||||
mutate_at(vars(col_mo), as.mo) %>%
|
||||
# join to microorganisms data set
|
||||
left_join_microorganisms(by = col_mo) %>%
|
||||
# add unavailable to where genus is available
|
||||
mutate(MDRO = ifelse(!is.na(genus), 1, NA_integer_),
|
||||
row_number = seq_len(nrow(.)),
|
||||
reason = paste0("not covered by ", toupper(guideline$code), " guideline"),
|
||||
columns_nonsusceptible = "") %>%
|
||||
# transform to data.frame so subsetting is possible with x[y, z] (might not be the case with tibble/data.table/...)
|
||||
as.data.frame(stringsAsFactors = FALSE)
|
||||
|
||||
x[, col_mo] <- as.mo(x[, col_mo, drop = TRUE])
|
||||
# join to microorganisms data set
|
||||
x <- left_join_microorganisms(x, by = col_mo)
|
||||
x$MDRO <- ifelse(!is.na(x$genus), 1, NA_integer_)
|
||||
x$row_number <- seq_len(nrow(x))
|
||||
x$reason <- paste0("not covered by ", toupper(guideline$code), " guideline")
|
||||
x$columns_nonsusceptible <- ""
|
||||
|
||||
if (guideline$code == "cmi2012") {
|
||||
# CMI, 2012 ---------------------------------------------------------------
|
||||
# Non-susceptible = R and I
|
||||
@ -543,20 +541,20 @@ mdro <- function(x,
|
||||
# take amoxicillin if ampicillin is unavailable
|
||||
if (is.na(AMP) & !is.na(AMX)) {
|
||||
if (verbose == TRUE) {
|
||||
message(blue("NOTE: Filling ampicillin (AMP) results with amoxicillin (AMX) results"))
|
||||
message(font_blue("NOTE: Filling ampicillin (AMP) results with amoxicillin (AMX) results"))
|
||||
}
|
||||
AMP <- AMX
|
||||
}
|
||||
# take ceftriaxone if cefotaxime is unavailable and vice versa
|
||||
if (is.na(CRO) & !is.na(CTX)) {
|
||||
if (verbose == TRUE) {
|
||||
message(blue("NOTE: Filling ceftriaxone (CRO) results with cefotaxime (CTX) results"))
|
||||
message(font_blue("NOTE: Filling ceftriaxone (CRO) results with cefotaxime (CTX) results"))
|
||||
}
|
||||
CRO <- CTX
|
||||
}
|
||||
if (is.na(CTX) & !is.na(CRO)) {
|
||||
if (verbose == TRUE) {
|
||||
message(blue("NOTE: Filling cefotaxime (CTX) results with ceftriaxone (CRO) results"))
|
||||
message(font_blue("NOTE: Filling cefotaxime (CTX) results with ceftriaxone (CRO) results"))
|
||||
}
|
||||
CTX <- CRO
|
||||
}
|
||||
@ -642,7 +640,7 @@ mdro <- function(x,
|
||||
which(x$genus == "Staphylococcus" & x$species == "aureus"),
|
||||
c(OXA, FOX),
|
||||
"any")
|
||||
trans_tbl2(paste("Table 1 -", italic("Staphylococcus aureus")),
|
||||
trans_tbl2(paste("Table 1 -", font_italic("Staphylococcus aureus")),
|
||||
which(x$genus == "Staphylococcus" & x$species == "aureus"),
|
||||
list(GEN,
|
||||
RIF,
|
||||
@ -661,7 +659,7 @@ mdro <- function(x,
|
||||
FOS,
|
||||
QDA,
|
||||
c(TCY, DOX, MNO)))
|
||||
trans_tbl2(paste("Table 2 -", italic("Enterococcus"), "spp."),
|
||||
trans_tbl2(paste("Table 2 -", font_italic("Enterococcus"), "spp."),
|
||||
which(x$genus == "Enterococcus"),
|
||||
list(GEH,
|
||||
STH,
|
||||
@ -674,7 +672,7 @@ mdro <- function(x,
|
||||
AMP,
|
||||
QDA,
|
||||
c(DOX, MNO)))
|
||||
trans_tbl2(paste0("Table 3 - ", italic("Enterobacteriaceae")),
|
||||
trans_tbl2(paste0("Table 3 - ", font_italic("Enterobacteriaceae")),
|
||||
# this new order was previously 'Enterobacteriales' and contained only the family 'Enterobacteriaceae':
|
||||
which(x$order == "Enterobacterales"),
|
||||
list(c(GEN, TOB, AMK, NET),
|
||||
@ -695,7 +693,7 @@ mdro <- function(x,
|
||||
FOS,
|
||||
COL,
|
||||
c(TCY, DOX, MNO)))
|
||||
trans_tbl2(paste("Table 4 -", italic("Pseudomonas aeruginosa")),
|
||||
trans_tbl2(paste("Table 4 -", font_italic("Pseudomonas aeruginosa")),
|
||||
which(x$genus == "Pseudomonas" & x$species == "aeruginosa"),
|
||||
list(c(GEN, TOB, AMK, NET),
|
||||
c(IPM, MEM, DOR),
|
||||
@ -705,7 +703,7 @@ mdro <- function(x,
|
||||
ATM,
|
||||
FOS,
|
||||
c(COL, PLB)))
|
||||
trans_tbl2(paste("Table 5 -", italic("Acinetobacter"), "spp."),
|
||||
trans_tbl2(paste("Table 5 -", font_italic("Acinetobacter"), "spp."),
|
||||
which(x$genus == "Acinetobacter"),
|
||||
list(c(GEN, TOB, AMK, NET),
|
||||
c(IPM, MEM, DOR),
|
||||
@ -941,70 +939,73 @@ mdro <- function(x,
|
||||
"all")
|
||||
}
|
||||
|
||||
prepare_drug <- function(ab) {
|
||||
# returns vector values of drug
|
||||
# if `ab` is a column name, looks up the values in `x`
|
||||
if (length(ab) == 1 & is.character(ab)) {
|
||||
if (ab %in% colnames(x)) {
|
||||
ab <- as.data.frame(x)[, ab]
|
||||
}
|
||||
}
|
||||
ab <- as.character(as.rsi(ab))
|
||||
ab[is.na(ab)] <- ""
|
||||
ab
|
||||
}
|
||||
drug_is_R <- function(ab) {
|
||||
# returns logical vector
|
||||
ab <- prepare_drug(ab)
|
||||
if (length(ab) == 1) {
|
||||
rep(ab, NROW(x)) == "R"
|
||||
} else {
|
||||
ab == "R"
|
||||
}
|
||||
}
|
||||
drug_is_not_R <- function(ab) {
|
||||
# returns logical vector
|
||||
ab <- prepare_drug(ab)
|
||||
if (length(ab) == 1) {
|
||||
rep(ab, NROW(x)) != "R"
|
||||
} else {
|
||||
ab != "R"
|
||||
}
|
||||
}
|
||||
|
||||
if (guideline$code == "tb") {
|
||||
# Tuberculosis ------------------------------------------------------------
|
||||
x <- x %>%
|
||||
mutate(mono_count = 0,
|
||||
mono_count = ifelse(drug_is_R(INH), mono_count + 1, mono_count),
|
||||
mono_count = ifelse(drug_is_R(RIF), mono_count + 1, mono_count),
|
||||
mono_count = ifelse(drug_is_R(ETH), mono_count + 1, mono_count),
|
||||
mono_count = ifelse(drug_is_R(PZA), mono_count + 1, mono_count),
|
||||
mono_count = ifelse(drug_is_R(RIB), mono_count + 1, mono_count),
|
||||
mono_count = ifelse(drug_is_R(RFP), mono_count + 1, mono_count),
|
||||
# from here on logicals
|
||||
mono = mono_count > 0,
|
||||
poly = ifelse(mono_count > 1 & drug_is_not_R(RIF) & drug_is_not_R(INH),
|
||||
TRUE, FALSE),
|
||||
mdr = ifelse(drug_is_R(RIF) & drug_is_R(INH),
|
||||
TRUE, FALSE),
|
||||
xdr = ifelse(drug_is_R(LVX) | drug_is_R(MFX) | drug_is_R(GAT),
|
||||
TRUE, FALSE),
|
||||
second = ifelse(drug_is_R(CAP) | drug_is_R(KAN) | drug_is_R(AMK),
|
||||
TRUE, FALSE),
|
||||
xdr = ifelse(mdr & xdr & second, TRUE, FALSE)) %>%
|
||||
mutate(MDRO = case_when(xdr ~ 5,
|
||||
mdr ~ 4,
|
||||
poly ~ 3,
|
||||
mono ~ 2,
|
||||
TRUE ~ 1),
|
||||
# keep all real TB, make other species NA
|
||||
MDRO = ifelse(x$fullname == "Mycobacterium tuberculosis", MDRO, NA_real_))
|
||||
prepare_drug <- function(ab) {
|
||||
# returns vector values of drug
|
||||
# if `ab` is a column name, looks up the values in `x`
|
||||
if (length(ab) == 1 & is.character(ab)) {
|
||||
if (ab %in% colnames(x)) {
|
||||
ab <- x[, ab, drop = TRUE]
|
||||
}
|
||||
}
|
||||
ab <- as.character(as.rsi(ab))
|
||||
ab[is.na(ab)] <- ""
|
||||
ab
|
||||
}
|
||||
drug_is_R <- function(ab) {
|
||||
# returns logical vector
|
||||
ab <- prepare_drug(ab)
|
||||
if (length(ab) == 0) {
|
||||
rep(FALSE, NROW(x))
|
||||
} else if (length(ab) == 1) {
|
||||
rep(ab, NROW(x)) == "R"
|
||||
} else {
|
||||
ab == "R"
|
||||
}
|
||||
}
|
||||
drug_is_not_R <- function(ab) {
|
||||
# returns logical vector
|
||||
ab <- prepare_drug(ab)
|
||||
if (length(ab) == 0) {
|
||||
rep(TRUE, NROW(x))
|
||||
} else if (length(ab) == 1) {
|
||||
rep(ab, NROW(x)) != "R"
|
||||
} else {
|
||||
ab != "R"
|
||||
}
|
||||
}
|
||||
|
||||
x$mono_count <- 0
|
||||
x[drug_is_R(INH), "mono_count"] <- x[drug_is_R(INH), "mono_count"] + 1
|
||||
x[drug_is_R(RIF), "mono_count"] <- x[drug_is_R(RIF), "mono_count"] + 1
|
||||
x[drug_is_R(ETH), "mono_count"] <- x[drug_is_R(ETH), "mono_count"] + 1
|
||||
x[drug_is_R(PZA), "mono_count"] <- x[drug_is_R(PZA), "mono_count"] + 1
|
||||
x[drug_is_R(RIB), "mono_count"] <- x[drug_is_R(RIB), "mono_count"] + 1
|
||||
x[drug_is_R(RFP), "mono_count"] <- x[drug_is_R(RFP), "mono_count"] + 1
|
||||
|
||||
x$mono <- x$mono_count > 0
|
||||
x$poly <- x$mono_count > 1 & drug_is_not_R(RIF) & drug_is_not_R(INH)
|
||||
x$mdr <- drug_is_R(RIF) & drug_is_R(INH)
|
||||
x$xdr <- drug_is_R(LVX) | drug_is_R(MFX) | drug_is_R(GAT)
|
||||
x$second <- drug_is_R(CAP) | drug_is_R(KAN) | drug_is_R(AMK)
|
||||
x$xdr <- x$mdr & x$xdr & x$second
|
||||
x$MDRO <- ifelse(x$xdr, 5,
|
||||
ifelse(x$mdr, 4,
|
||||
ifelse(x$poly, 3,
|
||||
ifelse(x$mono, 2,
|
||||
1))))
|
||||
# keep all real TB, make other species NA
|
||||
x$MDRO <- ifelse(x$fullname == "Mycobacterium tuberculosis", x$MDRO, NA_real_)
|
||||
}
|
||||
|
||||
if (info == TRUE) {
|
||||
cat(bold(paste0("=> Found ", sum(x$MDRO %in% c(2:5), na.rm = TRUE), " MDROs out of ", sum(!is.na(x$MDRO)),
|
||||
" tested isolates (", percentage(sum(x$MDRO %in% c(2:5), na.rm = TRUE) / sum(!is.na(x$MDRO))), ")\n")))
|
||||
if (sum(!is.na(x$MDRO) == 0)) {
|
||||
cat(font_bold(paste0("=> Found 0 MDROs since no isolates are covered by the guideline")))
|
||||
} else {
|
||||
cat(font_bold(paste0("=> Found ", sum(x$MDRO %in% c(2:5), na.rm = TRUE), " MDROs out of ", sum(!is.na(x$MDRO)),
|
||||
" isolates (", trimws(percentage(sum(x$MDRO %in% c(2:5), na.rm = TRUE) / sum(!is.na(x$MDRO)))), ")\n")))
|
||||
}
|
||||
}
|
||||
|
||||
# some more info on negative results
|
||||
|
||||
7
R/mic.R
7
R/mic.R
@ -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)
|
||||
}
|
||||
|
||||
|
||||
@ -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, ...)
|
||||
|
||||
@ -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
39
R/pca.R
@ -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]
|
||||
|
||||
@ -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]]
|
||||
@ -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",
|
||||
|
||||
@ -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
94
R/rsi.R
@ -29,12 +29,15 @@
|
||||
#' @param ab any (vector of) text that can be coerced to a valid antimicrobial code with [as.ab()]
|
||||
#' @param uti (Urinary Tract Infection) A vector with [logical]s (`TRUE` or `FALSE`) to specify whether a UTI specific interpretation from the guideline should be chosen. For using [as.rsi()] on a [data.frame], this can also be a column containing [logical]s or when left blank, the data set will be search for a 'specimen' and rows containing 'urin' in that column will be regarded isolates from a UTI. See *Examples*.
|
||||
#' @inheritParams first_isolate
|
||||
#' @param guideline defaults to the latest included EUCAST guideline, run `unique(rsi_translation$guideline)` for all options
|
||||
#' @param guideline defaults to the latest included EUCAST guideline, see Details for all options
|
||||
#' @param threshold maximum fraction of invalid antimicrobial interpretations of `x`, please see *Examples*
|
||||
#' @param ... parameters passed on to methods
|
||||
#' @details Run `unique(rsi_translation$guideline)` for a list of all supported guidelines. The repository of this package contains [this machine readable version](https://gitlab.com/msberends/AMR/blob/master/data-raw/rsi_translation.txt) of these guidelines.
|
||||
#' @details
|
||||
#' When using [as.rsi()] on untransformed data, the data will be cleaned to only contain values S, I and R. When using the function on data with class [`mic`] (using [as.mic()]) or class [`disk`] (using [as.disk()]), the data will be interpreted based on the guideline set with the `guideline` parameter.
|
||||
#'
|
||||
#' These guidelines are machine readable, since [](https://gitlab.com/msberends/AMR/blob/master/data-raw/rsi_translation.txt).
|
||||
#' Supported guidelines to be used as input for the `guideline` parameter are: `r paste0('"', sort(unique(AMR::rsi_translation$guideline)), '"', collapse = ", ")`. Simply using `"CLSI"` or `"EUCAST"` for input will automatically select the latest version of that guideline.
|
||||
#'
|
||||
#' The repository of this package [contains a machine readable version](https://gitlab.com/msberends/AMR/blob/master/data-raw/rsi_translation.txt) of all guidelines. This is a CSV file consisting of `r format(nrow(AMR::rsi_translation), big.mark = ",")` rows and `r ncol(AMR::rsi_translation)` columns. This file is machine readable, since it contains one row for every unique combination of the test method (MIC or disk diffusion), the antimicrobial agent and the microorganism. This **allows for easy implementation of these rules in laboratory information systems (LIS)**.
|
||||
#'
|
||||
#' After using [as.rsi()], you can use [eucast_rules()] to (1) apply inferred susceptibility and resistance based on results of other antimicrobials and (2) apply intrinsic resistance based on taxonomic properties of a microorganism.
|
||||
#'
|
||||
@ -113,7 +116,6 @@
|
||||
#' is.rsi(rsi_data)
|
||||
#' plot(rsi_data) # for percentages
|
||||
#' barplot(rsi_data) # for frequencies
|
||||
#' freq(rsi_data) # frequency table with informative header
|
||||
#'
|
||||
#' library(dplyr)
|
||||
#' example_isolates %>%
|
||||
@ -216,7 +218,7 @@ as.rsi.mic <- function(x, mo, ab = deparse(substitute(x)), guideline = "EUCAST",
|
||||
mo_coerced <- suppressWarnings(as.mo(mo))
|
||||
guideline_coerced <- get_guideline(guideline)
|
||||
if (is.na(ab_coerced)) {
|
||||
message(red(paste0("Unknown drug: `", bold(ab), "`. Rename this column to a drug name or code, and check the output with as.ab().")))
|
||||
message(font_red(paste0("Unknown drug: `", font_bold(ab), "`. Rename this column to a drug name or code, and check the output with as.ab().")))
|
||||
return(as.rsi(rep(NA, length(x))))
|
||||
}
|
||||
if (length(mo_coerced) == 1) {
|
||||
@ -226,16 +228,16 @@ as.rsi.mic <- function(x, mo, ab = deparse(substitute(x)), guideline = "EUCAST",
|
||||
uti <- rep(uti, length(x))
|
||||
}
|
||||
|
||||
message(blue(paste0("=> Interpreting MIC values of `", bold(ab), "` (",
|
||||
message(font_blue(paste0("=> Interpreting MIC values of `", font_bold(ab), "` (",
|
||||
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
|
||||
ab_name(ab_coerced, tolower = TRUE), ") using guideline ", bold(guideline_coerced), " ... ")),
|
||||
ab_name(ab_coerced, tolower = TRUE), ") using guideline ", font_bold(guideline_coerced), " ... ")),
|
||||
appendLF = FALSE)
|
||||
result <- exec_as.rsi(method = "mic",
|
||||
x = x,
|
||||
mo = mo_coerced,
|
||||
ab = ab_coerced,
|
||||
guideline = guideline_coerced,
|
||||
uti = uti) # exec_as.rsi will return message(blue(" OK."))
|
||||
uti = uti) # exec_as.rsi will return message(font_blue(" OK."))
|
||||
result
|
||||
}
|
||||
|
||||
@ -253,7 +255,7 @@ as.rsi.disk <- function(x, mo, ab = deparse(substitute(x)), guideline = "EUCAST"
|
||||
mo_coerced <- suppressWarnings(as.mo(mo))
|
||||
guideline_coerced <- get_guideline(guideline)
|
||||
if (is.na(ab_coerced)) {
|
||||
message(red(paste0("Unknown drug: `", bold(ab), "`. Rename this column to a drug name or code, and check the output with as.ab().")))
|
||||
message(font_red(paste0("Unknown drug: `", font_bold(ab), "`. Rename this column to a drug name or code, and check the output with as.ab().")))
|
||||
return(as.rsi(rep(NA, length(x))))
|
||||
}
|
||||
if (length(mo_coerced) == 1) {
|
||||
@ -263,21 +265,20 @@ as.rsi.disk <- function(x, mo, ab = deparse(substitute(x)), guideline = "EUCAST"
|
||||
uti <- rep(uti, length(x))
|
||||
}
|
||||
|
||||
message(blue(paste0("=> Interpreting disk zones of `", bold(ab), "` (",
|
||||
message(font_blue(paste0("=> Interpreting disk zones of `", font_bold(ab), "` (",
|
||||
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
|
||||
ab_name(ab_coerced, tolower = TRUE), ") using guideline ", bold(guideline_coerced), " ... ")),
|
||||
ab_name(ab_coerced, tolower = TRUE), ") using guideline ", font_bold(guideline_coerced), " ... ")),
|
||||
appendLF = FALSE)
|
||||
result <- exec_as.rsi(method = "disk",
|
||||
x = x,
|
||||
mo = mo_coerced,
|
||||
ab = ab_coerced,
|
||||
guideline = guideline_coerced,
|
||||
uti = uti) # exec_as.rsi will return message(blue(" OK."))
|
||||
uti = uti) # exec_as.rsi will return message(font_blue(" OK."))
|
||||
result
|
||||
}
|
||||
|
||||
#' @rdname as.rsi
|
||||
#' @importFrom crayon red blue bold
|
||||
#' @export
|
||||
as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", uti = NULL, ...) {
|
||||
# try to find columns based on type
|
||||
@ -316,9 +317,9 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", uti = NULL
|
||||
} else {
|
||||
plural <- c("", "s", "a ")
|
||||
}
|
||||
message(blue(paste0("NOTE: Assuming value", plural[1], " ",
|
||||
message(font_blue(paste0("NOTE: Assuming value", plural[1], " ",
|
||||
paste(paste0('"', values, '"'), collapse = ", "),
|
||||
" in column `", bold(col_specimen),
|
||||
" in column `", font_bold(col_specimen),
|
||||
"` reflect", plural[2], " ", plural[3], "urinary tract infection", plural[1], ".\n Use `as.rsi(uti = FALSE)` to prevent this.")))
|
||||
} else {
|
||||
# no data about UTI's found
|
||||
@ -336,12 +337,12 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", uti = NULL
|
||||
# not even a valid AB code
|
||||
return(FALSE)
|
||||
} else if (!check & all_valid_mics(y)) {
|
||||
message(blue(paste0("NOTE: Assuming column `", ab, "` (",
|
||||
message(font_blue(paste0("NOTE: Assuming column `", ab, "` (",
|
||||
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
|
||||
ab_name(ab_coerced, tolower = TRUE), ") contains MIC values.")))
|
||||
return(TRUE)
|
||||
} else if (!check & all_valid_disks(y)) {
|
||||
message(blue(paste0("NOTE: Assuming column `", ab, "` (",
|
||||
message(font_blue(paste0("NOTE: Assuming column `", ab, "` (",
|
||||
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
|
||||
ab_name(ab_coerced, tolower = TRUE), ") contains disk zones.")))
|
||||
return(TRUE)
|
||||
@ -380,16 +381,10 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", uti = NULL
|
||||
x
|
||||
}
|
||||
|
||||
#' @importFrom dplyr %>% filter pull
|
||||
get_guideline <- function(guideline) {
|
||||
guideline_param <- toupper(guideline)
|
||||
if (guideline_param %in% c("CLSI", "EUCAST")) {
|
||||
guideline_param <- rsi_translation %>%
|
||||
filter(guideline %like% guideline_param) %>%
|
||||
pull(guideline) %>%
|
||||
sort() %>%
|
||||
rev() %>%
|
||||
.[1]
|
||||
guideline_param <- rev(sort(subset(rsi_translation, guideline %like% guideline_param)$guideline))[1L]
|
||||
}
|
||||
if (!guideline_param %like% " ") {
|
||||
# like 'EUCAST2020', should be 'EUCAST 2020'
|
||||
@ -406,8 +401,6 @@ get_guideline <- function(guideline) {
|
||||
|
||||
}
|
||||
|
||||
#' @importFrom dplyr %>% case_when desc arrange filter n_distinct
|
||||
#' @importFrom crayon green red bold
|
||||
exec_as.rsi <- function(method, x, mo, ab, guideline, uti) {
|
||||
if (method == "mic") {
|
||||
x <- as.mic(x) # when as.rsi.mic is called directly
|
||||
@ -427,14 +420,14 @@ exec_as.rsi <- function(method, x, mo, ab, guideline, uti) {
|
||||
|
||||
guideline_coerced <- get_guideline(guideline)
|
||||
if (guideline_coerced != guideline) {
|
||||
message(blue(paste0("Note: Using guideline ", bold(guideline_coerced), " as input for `guideline`.")))
|
||||
message(font_blue(paste0("Note: Using guideline ", font_bold(guideline_coerced), " as input for `guideline`.")))
|
||||
}
|
||||
|
||||
new_rsi <- rep(NA_character_, length(x))
|
||||
ab_param <- ab
|
||||
trans <- rsi_translation %>%
|
||||
filter(guideline == guideline_coerced & method == method_param & ab == ab_param) %>%
|
||||
mutate(lookup = paste(mo, ab))
|
||||
subset(guideline == guideline_coerced & method == method_param & ab == ab_param)
|
||||
trans$lookup <- paste(trans$mo, trans$ab)
|
||||
|
||||
lookup_mo <- paste(mo, ab)
|
||||
lookup_genus <- paste(mo_genus, ab)
|
||||
@ -445,15 +438,15 @@ exec_as.rsi <- function(method, x, mo, ab, guideline, uti) {
|
||||
lookup_other <- paste(mo_other, ab)
|
||||
|
||||
if (all(trans$uti == TRUE, na.rm = TRUE) & all(uti == FALSE)) {
|
||||
message(red("WARNING."))
|
||||
warning("Interpretation of ", bold(ab_name(ab, tolower = TRUE)), " for some microorganisms is only available for (uncomplicated) urinary tract infections (UTI).\n Use parameter 'uti' to set which isolates are from urine. See ?as.rsi.", call. = FALSE)
|
||||
message(font_red("WARNING."))
|
||||
warning("Interpretation of ", font_bold(ab_name(ab, tolower = TRUE)), " for some microorganisms is only available for (uncomplicated) urinary tract infections (UTI).\n Use parameter 'uti' to set which isolates are from urine. See ?as.rsi.", call. = FALSE)
|
||||
warned <- TRUE
|
||||
}
|
||||
|
||||
for (i in seq_len(length(x))) {
|
||||
get_record <- trans %>%
|
||||
# no UTI for now
|
||||
filter(lookup %in% c(lookup_mo[i],
|
||||
subset(lookup %in% c(lookup_mo[i],
|
||||
lookup_genus[i],
|
||||
lookup_family[i],
|
||||
lookup_order[i],
|
||||
@ -465,14 +458,13 @@ exec_as.rsi <- function(method, x, mo, ab, guideline, uti) {
|
||||
get_record <- get_record %>%
|
||||
# be as specific as possible (i.e. prefer species over genus):
|
||||
# desc(uti) = TRUE on top and FALSE on bottom
|
||||
arrange(desc(uti), desc(nchar(mo))) %>% # 'uti' is a column in rsi_translation
|
||||
.[1L, ]
|
||||
arrange(desc(uti), desc(nchar(mo))) # 'uti' is a column in rsi_translation
|
||||
} else {
|
||||
get_record <- get_record %>%
|
||||
filter(uti == FALSE) %>% # 'uti' is a column in rsi_translation
|
||||
arrange(desc(nchar(mo))) %>%
|
||||
.[1L, ]
|
||||
arrange(desc(nchar(mo)))
|
||||
}
|
||||
get_record <- get_record[1L, ]
|
||||
|
||||
if (NROW(get_record) > 0) {
|
||||
if (is.na(x[i])) {
|
||||
@ -481,20 +473,20 @@ exec_as.rsi <- function(method, x, mo, ab, guideline, uti) {
|
||||
mic_input <- x[i]
|
||||
mic_S <- as.mic(get_record$breakpoint_S)
|
||||
mic_R <- as.mic(get_record$breakpoint_R)
|
||||
new_rsi[i] <- case_when(isTRUE(which(levels(mic_input) == mic_input) <= which(levels(mic_S) == mic_S)) ~ "S",
|
||||
isTRUE(which(levels(mic_input) == mic_input) >= which(levels(mic_R) == mic_R)) ~ "R",
|
||||
!is.na(get_record$breakpoint_S) & !is.na(get_record$breakpoint_R) ~ "I",
|
||||
TRUE ~ NA_character_)
|
||||
new_rsi[i] <- ifelse(isTRUE(which(levels(mic_input) == mic_input) <= which(levels(mic_S) == mic_S)), "S",
|
||||
ifelse(isTRUE(which(levels(mic_input) == mic_input) >= which(levels(mic_R) == mic_R)), "R",
|
||||
ifelse(!is.na(get_record$breakpoint_S) & !is.na(get_record$breakpoint_R), "I",
|
||||
NA_character_)))
|
||||
} else if (method == "disk") {
|
||||
new_rsi[i] <- case_when(isTRUE(as.double(x[i]) >= as.double(get_record$breakpoint_S)) ~ "S",
|
||||
isTRUE(as.double(x[i]) <= as.double(get_record$breakpoint_R)) ~ "R",
|
||||
!is.na(get_record$breakpoint_S) & !is.na(get_record$breakpoint_R) ~ "I",
|
||||
TRUE ~ NA_character_)
|
||||
new_rsi[i] <- ifelse(isTRUE(as.double(x[i]) >= as.double(get_record$breakpoint_S)), "S",
|
||||
ifelse(isTRUE(as.double(x[i]) <= as.double(get_record$breakpoint_R)), "R",
|
||||
ifelse(!is.na(get_record$breakpoint_S) & !is.na(get_record$breakpoint_R), "I",
|
||||
NA_character_)))
|
||||
}
|
||||
}
|
||||
}
|
||||
if (warned == FALSE) {
|
||||
message(green("OK."))
|
||||
message(font_green("OK."))
|
||||
}
|
||||
structure(.Data = factor(new_rsi, levels = c("S", "I", "R"), ordered = TRUE),
|
||||
class = c("rsi", "ordered", "factor"))
|
||||
@ -537,7 +529,6 @@ is.rsi.eligible <- function(x, threshold = 0.05) {
|
||||
|
||||
#' @exportMethod print.rsi
|
||||
#' @export
|
||||
#' @importFrom dplyr %>%
|
||||
#' @noRd
|
||||
print.rsi <- function(x, ...) {
|
||||
cat("Class 'rsi'\n")
|
||||
@ -570,7 +561,6 @@ summary.rsi <- function(object, ...) {
|
||||
|
||||
#' @exportMethod plot.rsi
|
||||
#' @export
|
||||
#' @importFrom dplyr %>% group_by summarise filter mutate if_else n_distinct
|
||||
#' @importFrom graphics plot text
|
||||
#' @noRd
|
||||
plot.rsi <- function(x,
|
||||
@ -626,7 +616,6 @@ plot.rsi <- function(x,
|
||||
|
||||
#' @exportMethod barplot.rsi
|
||||
#' @export
|
||||
#' @importFrom dplyr %>% group_by summarise
|
||||
#' @importFrom graphics barplot axis par
|
||||
#' @noRd
|
||||
barplot.rsi <- function(height,
|
||||
@ -660,14 +649,13 @@ barplot.rsi <- function(height,
|
||||
}
|
||||
|
||||
#' @importFrom pillar pillar_shaft
|
||||
#' @importFrom crayon bgGreen bgYellow bgRed black white
|
||||
#' @export
|
||||
pillar_shaft.rsi <- function(x, ...) {
|
||||
out <- trimws(format(x))
|
||||
out[is.na(x)] <- pillar::style_subtle(" NA")
|
||||
out[x == "S"] <- bgGreen(white(" S "))
|
||||
out[x == "I"] <- bgYellow(black(" I "))
|
||||
out[x == "R"] <- bgRed(white(" R "))
|
||||
out[is.na(x)] <- font_subtle(" NA")
|
||||
out[x == "S"] <- font_green_bg(font_white(" S "))
|
||||
out[x == "I"] <- font_yellow_bg(font_black(" I "))
|
||||
out[x == "R"] <- font_red_bg(font_white(" R "))
|
||||
pillar::new_pillar_shaft_simple(out, align = "left", width = 3)
|
||||
}
|
||||
|
||||
|
||||
177
R/rsi_calc.R
177
R/rsi_calc.R
@ -19,27 +19,13 @@
|
||||
# Visit our website for more info: https://msberends.gitlab.io/AMR. #
|
||||
# ==================================================================== #
|
||||
|
||||
#' @importFrom rlang enquos as_label
|
||||
dots2vars <- function(...) {
|
||||
# this function is to give more informative output about
|
||||
# variable names in count_* and proportion_* functions
|
||||
paste(
|
||||
unlist(
|
||||
lapply(enquos(...),
|
||||
function(x) {
|
||||
l <- as_label(x)
|
||||
if (l != ".") {
|
||||
l
|
||||
} else {
|
||||
character(0)
|
||||
}
|
||||
})
|
||||
),
|
||||
collapse = ", ")
|
||||
dots <- substitute(list(...))
|
||||
paste(as.character(dots)[2:length(dots)], collapse = ", ")
|
||||
}
|
||||
|
||||
#' @importFrom dplyr %>% pull all_vars any_vars filter_all funs mutate_all
|
||||
#' @importFrom cleaner percentage
|
||||
rsi_calc <- function(...,
|
||||
ab_result,
|
||||
minimum = 0,
|
||||
@ -72,10 +58,10 @@ rsi_calc <- function(...,
|
||||
dots <- dots[dots != "."]
|
||||
if (length(dots) == 0 | all(dots == "df")) {
|
||||
# for complete data.frames, like example_isolates %>% select(amcl, gent) %>% proportion_S()
|
||||
# and the old rsi function, that has "df" as name of the first parameter
|
||||
# and the old rsi function, which has "df" as name of the first parameter
|
||||
x <- dots_df
|
||||
} else {
|
||||
x <- dots_df[, dots]
|
||||
x <- dots_df[, dots[dots %in% colnames(dots_df)]]
|
||||
}
|
||||
} else if (ndots == 1) {
|
||||
# only 1 variable passed (can also be data.frame), like: proportion_S(example_isolates$amcl) and example_isolates$amcl %>% proportion_S()
|
||||
@ -85,8 +71,8 @@ rsi_calc <- function(...,
|
||||
x <- NULL
|
||||
try(x <- as.data.frame(dots), silent = TRUE)
|
||||
if (is.null(x)) {
|
||||
# support for: with(example_isolates, proportion_S(amcl, gent))
|
||||
x <- as.data.frame(rlang::list2(...))
|
||||
# support for example_isolates %>% group_by(hospital_id) %>% summarise(amox = susceptibility(GEN, AMX))
|
||||
x <- as.data.frame(list(...))
|
||||
}
|
||||
}
|
||||
|
||||
@ -113,7 +99,7 @@ rsi_calc <- function(...,
|
||||
# this will give a warning for invalid results, of all input columns (so only 1 warning)
|
||||
rsi_integrity_check <- as.rsi(rsi_integrity_check)
|
||||
}
|
||||
|
||||
|
||||
if (only_all_tested == TRUE) {
|
||||
# THE NUMBER OF ISOLATES WHERE *ALL* ABx ARE S/I/R
|
||||
x <- apply(X = x %>% mutate_all(as.integer),
|
||||
@ -128,8 +114,8 @@ rsi_calc <- function(...,
|
||||
other_values_filter <- base::apply(x, 1, function(y) {
|
||||
base::all(y %in% other_values) & base::any(is.na(y))
|
||||
})
|
||||
numerator <- x %>% filter_all(any_vars(. %in% ab_result)) %>% nrow()
|
||||
denominator <- x %>% filter(!other_values_filter) %>% nrow()
|
||||
numerator <- sum(as.logical(by(x, seq_len(nrow(x)), function(row) any(unlist(row) %in% ab_result, na.rm = TRUE))))
|
||||
denominator <- nrow(x[!other_values_filter, ])
|
||||
}
|
||||
} else {
|
||||
# x is not a data.frame
|
||||
@ -167,9 +153,7 @@ rsi_calc <- function(...,
|
||||
}
|
||||
}
|
||||
|
||||
#' @importFrom dplyr %>% summarise_if mutate select everything bind_rows arrange
|
||||
#' @importFrom tidyr pivot_longer
|
||||
rsi_calc_df <- function(type, # "proportion" or "count"
|
||||
rsi_calc_df <- function(type, # "proportion", "count" or "both"
|
||||
data,
|
||||
translate_ab = "name",
|
||||
language = get_locale(),
|
||||
@ -199,63 +183,106 @@ rsi_calc_df <- function(type, # "proportion" or "count"
|
||||
if (as.character(translate_ab) %in% c("TRUE", "official")) {
|
||||
translate_ab <- "name"
|
||||
}
|
||||
|
||||
# select only groups and antibiotics
|
||||
if (has_groups(data)) {
|
||||
data_has_groups <- TRUE
|
||||
groups <- setdiff(names(get_groups(data)), ".rows") # get_groups is from poorman.R
|
||||
data <- data[, c(groups, colnames(data)[sapply(data, is.rsi)]), drop = FALSE]
|
||||
} else {
|
||||
data_has_groups <- FALSE
|
||||
data <- data[, colnames(data)[sapply(data, is.rsi)], drop = FALSE]
|
||||
}
|
||||
|
||||
get_summaryfunction <- function(int, type) {
|
||||
# look for proportion_S, count_S, etc:
|
||||
int_fn <- get(paste0(type, "_", int), envir = asNamespace("AMR"))
|
||||
|
||||
suppressWarnings(
|
||||
if (type == "proportion") {
|
||||
summ <- summarise_if(.tbl = data,
|
||||
.predicate = is.rsi,
|
||||
.funs = int_fn,
|
||||
minimum = minimum,
|
||||
as_percent = as_percent)
|
||||
} else if (type == "count") {
|
||||
summ <- summarise_if(.tbl = data,
|
||||
.predicate = is.rsi,
|
||||
.funs = int_fn)
|
||||
data <- as.data.frame(data, stringsAsFactors = FALSE)
|
||||
if (isTRUE(combine_SI) | isTRUE(combine_IR)) {
|
||||
for (i in seq_len(ncol(data))) {
|
||||
if (is.rsi(data[, i, drop = TRUE])) {
|
||||
data[, i] <- as.character(data[, i, drop = TRUE])
|
||||
if (isTRUE(combine_SI)) {
|
||||
data[, i] <- gsub("(I|S)", "SI", data[, i, drop = TRUE])
|
||||
} else if (isTRUE(combine_IR)) {
|
||||
data[, i] <- gsub("(I|R)", "IR", data[, i, drop = TRUE])
|
||||
}
|
||||
}
|
||||
)
|
||||
summ %>%
|
||||
mutate(interpretation = int) %>%
|
||||
select(interpretation, everything())
|
||||
}
|
||||
}
|
||||
|
||||
resS <- get_summaryfunction("S", type)
|
||||
resI <- get_summaryfunction("I", type)
|
||||
resR <- get_summaryfunction("R", type)
|
||||
resSI <- get_summaryfunction("SI", type)
|
||||
resIR <- get_summaryfunction("IR", type)
|
||||
data.groups <- group_vars(data)
|
||||
sum_it <- function(.data) {
|
||||
out <- data.frame(antibiotic = character(0),
|
||||
interpretation = character(0),
|
||||
value = double(0),
|
||||
isolates <- integer(0),
|
||||
stringsAsFactors = FALSE)
|
||||
if (data_has_groups) {
|
||||
group_values <- unique(.data[, which(colnames(.data) %in% groups), drop = FALSE])
|
||||
rownames(group_values) <- NULL
|
||||
.data <- .data[, which(!colnames(.data) %in% groups), drop = FALSE]
|
||||
}
|
||||
for (i in seq_len(ncol(.data))) {
|
||||
col_results <- as.data.frame(as.matrix(table(.data[, i, drop = TRUE])))
|
||||
col_results$interpretation <- rownames(col_results)
|
||||
col_results$isolates <- col_results[, 1, drop = TRUE]
|
||||
if (nrow(col_results) > 0) {
|
||||
if (sum(col_results$isolates, na.rm = TRUE) >= minimum) {
|
||||
col_results$value <- col_results$isolates / sum(col_results$isolates, na.rm = TRUE)
|
||||
} else {
|
||||
col_results$value <- rep(NA_real_, NROW(col_results))
|
||||
}
|
||||
out_new <- data.frame(antibiotic = ab_property(colnames(.data)[i], property = translate_ab, language = language),
|
||||
interpretation = col_results$interpretation,
|
||||
value = col_results$value,
|
||||
isolates = col_results$isolates,
|
||||
stringsAsFactors = FALSE)
|
||||
if (data_has_groups) {
|
||||
out_new <- cbind(group_values, out_new)
|
||||
}
|
||||
out <- rbind(out, out_new)
|
||||
}
|
||||
}
|
||||
out
|
||||
}
|
||||
|
||||
if (isFALSE(combine_SI) & isFALSE(combine_IR)) {
|
||||
res <- bind_rows(resS, resI, resR) %>%
|
||||
mutate(interpretation = factor(interpretation,
|
||||
levels = c("S", "I", "R"),
|
||||
ordered = TRUE))
|
||||
|
||||
# support dplyr groups
|
||||
apply_group <- function(.data, fn, groups, ...) {
|
||||
grouped <- split(x = .data, f = lapply(groups, function(x, .data) as.factor(.data[, x]), .data))
|
||||
res <- do.call(rbind, unname(lapply(grouped, fn, ...)))
|
||||
if (any(groups %in% colnames(res))) {
|
||||
class(res) <- c("grouped_data", class(res))
|
||||
attr(res, "groups") <- groups[groups %in% colnames(res)]
|
||||
}
|
||||
res
|
||||
}
|
||||
|
||||
if (data_has_groups) {
|
||||
out <- apply_group(data, "sum_it", groups)
|
||||
} else {
|
||||
out <- sum_it(data)
|
||||
}
|
||||
|
||||
# apply factors for right sorting in interpretation
|
||||
if (isTRUE(combine_SI)) {
|
||||
out$interpretation <- factor(out$interpretation, levels = c("SI", "R"), ordered = TRUE)
|
||||
} else if (isTRUE(combine_IR)) {
|
||||
res <- bind_rows(resS, resIR) %>%
|
||||
mutate(interpretation = factor(interpretation,
|
||||
levels = c("S", "IR"),
|
||||
ordered = TRUE))
|
||||
|
||||
} else if (isTRUE(combine_SI)) {
|
||||
res <- bind_rows(resSI, resR) %>%
|
||||
mutate(interpretation = factor(interpretation,
|
||||
levels = c("SI", "R"),
|
||||
ordered = TRUE))
|
||||
out$interpretation <- factor(out$interpretation, levels = c("S", "IR"), ordered = TRUE)
|
||||
} else {
|
||||
out$interpretation <- as.rsi(out$interpretation)
|
||||
}
|
||||
|
||||
res <- res %>%
|
||||
pivot_longer(-c(interpretation, data.groups), names_to = "antibiotic") %>%
|
||||
select(antibiotic, everything()) %>%
|
||||
arrange(antibiotic, interpretation)
|
||||
|
||||
if (!translate_ab == FALSE) {
|
||||
res <- res %>% mutate(antibiotic = ab_property(antibiotic, property = translate_ab, language = language))
|
||||
if (data_has_groups) {
|
||||
# ordering by the groups and two more: "antibiotic" and "interpretation"
|
||||
out <- out[do.call("order", out[, seq_len(length(groups) + 2)]), ]
|
||||
} else {
|
||||
out <- out[order(out$antibiotic, out$interpretation), ]
|
||||
}
|
||||
|
||||
as.data.frame(res, stringsAsFactors = FALSE)
|
||||
if (type == "proportion") {
|
||||
out <- subset(out, select = -c(isolates))
|
||||
} else if (type == "count") {
|
||||
out$value <- out$isolates
|
||||
out <- subset(out, select = -c(isolates))
|
||||
}
|
||||
|
||||
rownames(out) <- NULL
|
||||
out
|
||||
}
|
||||
|
||||
32
R/rsi_df.R
32
R/rsi_df.R
@ -29,28 +29,14 @@ rsi_df <- function(data,
|
||||
combine_SI = TRUE,
|
||||
combine_IR = FALSE) {
|
||||
|
||||
proportions <- rsi_calc_df(type = "proportion",
|
||||
data = data,
|
||||
translate_ab = translate_ab,
|
||||
language = language,
|
||||
minimum = minimum,
|
||||
as_percent = as_percent,
|
||||
combine_SI = combine_SI,
|
||||
combine_IR = combine_IR,
|
||||
combine_SI_missing = missing(combine_SI))
|
||||
|
||||
counts <- rsi_calc_df(type = "count",
|
||||
data = data,
|
||||
translate_ab = FALSE,
|
||||
language = "en",
|
||||
minimum = minimum,
|
||||
as_percent = as_percent,
|
||||
combine_SI = combine_SI,
|
||||
combine_IR = combine_IR,
|
||||
combine_SI_missing = missing(combine_SI))
|
||||
|
||||
data.frame(proportions,
|
||||
isolates = counts$value,
|
||||
stringsAsFactors = FALSE)
|
||||
rsi_calc_df(type = "both",
|
||||
data = data,
|
||||
translate_ab = translate_ab,
|
||||
language = language,
|
||||
minimum = minimum,
|
||||
as_percent = as_percent,
|
||||
combine_SI = combine_SI,
|
||||
combine_IR = combine_IR,
|
||||
combine_SI_missing = missing(combine_SI))
|
||||
|
||||
}
|
||||
|
||||
BIN
R/sysdata.rda
BIN
R/sysdata.rda
Binary file not shown.
@ -19,15 +19,35 @@
|
||||
# Visit our website for more info: https://msberends.gitlab.io/AMR. #
|
||||
# ==================================================================== #
|
||||
|
||||
#' `vctrs` methods
|
||||
#' Methods for tidyverse
|
||||
#'
|
||||
#' These methods are needed to support methods used by the tidyverse, like joining and transforming data, with new classes that come with this package.
|
||||
#' @inheritSection lifecycle Stable lifecycle
|
||||
#' @inheritSection AMR Read more on our website!
|
||||
#' @keywords internal
|
||||
#' @name AMR-vctrs
|
||||
#' @name AMR-tidyverse
|
||||
NULL
|
||||
|
||||
#' @rdname AMR-tidyverse
|
||||
#' @exportMethod scale_type.mo
|
||||
#' @export
|
||||
scale_type.mo <- function(x) {
|
||||
# fix for:
|
||||
# "Don't know how to automatically pick scale for object of type mo. Defaulting to continuous."
|
||||
# "Error: Discrete value supplied to continuous scale"
|
||||
"discrete"
|
||||
}
|
||||
|
||||
#' @rdname AMR-tidyverse
|
||||
#' @exportMethod scale_type.ab
|
||||
#' @export
|
||||
scale_type.ab <- function(x) {
|
||||
# fix for:
|
||||
# "Don't know how to automatically pick scale for object of type mo. Defaulting to continuous."
|
||||
# "Error: Discrete value supplied to continuous scale"
|
||||
"discrete"
|
||||
}
|
||||
|
||||
|
||||
# Class mo ----------------------------------------------------------------
|
||||
|
||||
@ -46,7 +66,7 @@ vec_ptype_full.mo <- function(x, ...) {
|
||||
"mo"
|
||||
}
|
||||
|
||||
#' @rdname AMR-vctrs
|
||||
#' @rdname AMR-tidyverse
|
||||
#' @export
|
||||
vec_ptype2.mo <- function(x, y, ...) {
|
||||
UseMethod("vec_ptype2.mo", y)
|
||||
@ -65,13 +85,14 @@ vec_ptype2.mo.character <- function(x, y, ...) {
|
||||
}
|
||||
|
||||
#' @method vec_ptype2.character mo
|
||||
#' @exportMethod vec_ptype2.character.mo
|
||||
#' @importFrom vctrs vec_ptype2.character
|
||||
#' @export
|
||||
vec_ptype2.character.mo <- function(x, y, ...) {
|
||||
y
|
||||
}
|
||||
|
||||
#' @rdname AMR-vctrs
|
||||
#' @rdname AMR-tidyverse
|
||||
#' @export
|
||||
vec_cast.mo <- function(x, to, ...) {
|
||||
UseMethod("vec_cast.mo")
|
||||
@ -96,12 +117,11 @@ vec_cast.mo.default <- function(x, to, ...) {
|
||||
vec_default_cast(x, to)
|
||||
}
|
||||
|
||||
# @method vec_cast.character mo
|
||||
#' @method vec_cast.character mo
|
||||
#' @exportMethod vec_cast.character.mo
|
||||
#' @importFrom vctrs vec_cast
|
||||
#' @importFrom vctrs vec_cast vec_cast.character
|
||||
#' @export
|
||||
vec_cast.character.mo <- function(x, to, ...) {
|
||||
# purrr::map_chr(x, stringr::str_c, collapse = " ")
|
||||
unclass(x)
|
||||
}
|
||||
|
||||
@ -123,7 +143,7 @@ vec_ptype_full.ab <- function(x, ...) {
|
||||
"ab"
|
||||
}
|
||||
|
||||
#' @rdname AMR-vctrs
|
||||
#' @rdname AMR-tidyverse
|
||||
#' @export
|
||||
vec_ptype2.ab <- function(x, y, ...) {
|
||||
UseMethod("vec_ptype2.ab", y)
|
||||
@ -142,13 +162,14 @@ vec_ptype2.ab.character <- function(x, y, ...) {
|
||||
}
|
||||
|
||||
#' @method vec_ptype2.character ab
|
||||
#' @exportMethod vec_ptype2.character.ab
|
||||
#' @importFrom vctrs vec_ptype2.character
|
||||
#' @export
|
||||
vec_ptype2.character.ab <- function(x, y, ...) {
|
||||
y
|
||||
}
|
||||
|
||||
#' @rdname AMR-vctrs
|
||||
#' @rdname AMR-tidyverse
|
||||
#' @export
|
||||
vec_cast.ab <- function(x, to, ...) {
|
||||
UseMethod("vec_cast.ab")
|
||||
@ -173,12 +194,11 @@ vec_cast.ab.default <- function(x, to, ...) {
|
||||
vec_default_cast(x, to)
|
||||
}
|
||||
|
||||
# @method vec_cast.character ab
|
||||
#' @method vec_cast.character ab
|
||||
#' @exportMethod vec_cast.character.ab
|
||||
#' @importFrom vctrs vec_cast
|
||||
#' @importFrom vctrs vec_cast vec_cast.character
|
||||
#' @export
|
||||
vec_cast.character.ab <- function(x, to, ...) {
|
||||
# purrr::map_chr(x, stringr::str_c, collapse = " ")
|
||||
unclass(x)
|
||||
}
|
||||
|
||||
@ -21,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
81
R/zzz.R
@ -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() {
|
||||
|
||||
Reference in New Issue
Block a user