mirror of
https://github.com/msberends/AMR.git
synced 2025-07-08 23:21:56 +02:00
(v1.2.0.9008) ab_class improvement
This commit is contained in:
@ -63,14 +63,12 @@ filter_join_worker <- function(x, y, by = NULL, type = c("anti", "semi")) {
|
||||
|
||||
# No export, no Rd
|
||||
addin_insert_in <- function() {
|
||||
stopifnot_installed_package("rstudioapi")
|
||||
get("insertText", envir = asNamespace("rstudioapi"))(" %in% ")
|
||||
import_fn("insertText", "rstudioapi")(" %in% ")
|
||||
}
|
||||
|
||||
# No export, no Rd
|
||||
addin_insert_like <- function() {
|
||||
stopifnot_installed_package("rstudioapi")
|
||||
get("insertText", envir = asNamespace("rstudioapi"))(" %like% ")
|
||||
import_fn("insertText", "rstudioapi")(" %like% ")
|
||||
}
|
||||
|
||||
check_dataset_integrity <- function() {
|
||||
@ -186,12 +184,23 @@ stopifnot_installed_package <- function(package) {
|
||||
# https://developer.r-project.org/Blog/public/2019/02/14/staged-install/index.html
|
||||
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)))
|
||||
error = function(e) {
|
||||
if (package == "rstudioapi") {
|
||||
stop("This function only works in RStudio.", call. = FALSE)
|
||||
} else {
|
||||
stop("package '", x, "' required but not installed.",
|
||||
"\nTry to install it with: install.packages(\"", x, "\")",
|
||||
call. = FALSE)
|
||||
}
|
||||
}))
|
||||
return(invisible())
|
||||
}
|
||||
|
||||
import_fn <- function(name, pkg) {
|
||||
stopifnot_installed_package(pkg)
|
||||
get(name, envir = asNamespace(pkg))
|
||||
}
|
||||
|
||||
stopifnot_msg <- function(expr, msg) {
|
||||
if (!isTRUE(expr)) {
|
||||
stop(msg, call. = FALSE)
|
||||
@ -245,7 +254,7 @@ dataset_UTF8_to_ASCII <- function(df) {
|
||||
df
|
||||
}
|
||||
|
||||
has_colour <- function () {
|
||||
has_colour <- function() {
|
||||
# this is a base R version of crayon::has_color
|
||||
enabled <- getOption("crayon.enabled")
|
||||
if (!is.null(enabled)) {
|
||||
@ -276,7 +285,7 @@ has_colour <- function () {
|
||||
}
|
||||
return(FALSE)
|
||||
}
|
||||
emacs_version <- function () {
|
||||
emacs_version <- function() {
|
||||
ver <- Sys.getenv("INSIDE_EMACS")
|
||||
if (ver == "") {
|
||||
return(NA_integer_)
|
||||
|
||||
@ -22,6 +22,7 @@
|
||||
#' Antibiotic class selectors
|
||||
#'
|
||||
#' Use these selection helpers inside any function that allows [Tidyverse selections](https://tidyselect.r-lib.org/reference/language.html), like `dplyr::select()` or `tidyr::pivot_longer()`. They help to select the columns of antibiotics that are of a specific antibiotic class, without the need to define the columns or antibiotic abbreviations.
|
||||
#' @inheritParams filter_ab_class
|
||||
#' @details All columns will be searched for known antibiotic names, abbreviations, brand names and codes (ATC, EARS-Net, WHO, etc.). This means that a selector like e.g. [aminoglycosides()] will pick up column names like 'gen', 'genta', 'J01GB03', 'tobra', 'Tobracin', etc.
|
||||
#'
|
||||
#' These functions only work if the `tidyselect` package is installed, that comes with the `dplyr` package. An error will be thrown if `tidyselect` package is not installed, or if the functions are used outside a function that allows Tidyverse selections like `select()` or `pivot_longer()`.
|
||||
@ -36,119 +37,138 @@
|
||||
#' example_isolates %>%
|
||||
#' select(carbapenems())
|
||||
#'
|
||||
#'
|
||||
#' # this will select columns 'mo', 'AMK', 'GEN', 'KAN' and 'TOB':
|
||||
#' example_isolates %>%
|
||||
#' select(mo, aminoglycosides())
|
||||
#'
|
||||
#' # this will select columns 'mo' and all antimycobacterial drugs ('RIF'):
|
||||
#' example_isolates %>%
|
||||
#' select(mo, ab_class("mycobact"))
|
||||
#'
|
||||
#'
|
||||
#' # get bug/drug combinations for only macrolides in Gram-positives:
|
||||
#' example_isolates %>%
|
||||
#' filter(mo_gramstain(mo) %like% "pos") %>%
|
||||
#' select(mo, macrolides()) %>%
|
||||
#' bug_drug_combinations() %>%
|
||||
#' format()
|
||||
#'
|
||||
#'
|
||||
#' data.frame(irrelevant = "value",
|
||||
#' J01CA01 = "S") %>% # ATC code of ampicillin
|
||||
#' select(penicillins()) # so the 'J01CA01' column is selected
|
||||
#'
|
||||
#'
|
||||
#' }
|
||||
ab_class <- function(ab_class) {
|
||||
ab_selector(ab_class, function_name = "ab_class")
|
||||
}
|
||||
|
||||
#' @rdname antibiotic_class_selectors
|
||||
#' @export
|
||||
aminoglycosides <- function() {
|
||||
ab_selector("aminoglycoside")
|
||||
ab_selector("aminoglycoside", function_name = "aminoglycosides")
|
||||
}
|
||||
|
||||
#' @rdname antibiotic_class_selectors
|
||||
#' @export
|
||||
carbapenems <- function() {
|
||||
ab_selector("carbapenem")
|
||||
ab_selector("carbapenem", function_name = "carbapenems")
|
||||
}
|
||||
|
||||
#' @rdname antibiotic_class_selectors
|
||||
#' @export
|
||||
cephalosporins <- function() {
|
||||
ab_selector("cephalosporin")
|
||||
ab_selector("cephalosporin", function_name = "cephalosporins")
|
||||
}
|
||||
|
||||
#' @rdname antibiotic_class_selectors
|
||||
#' @export
|
||||
cephalosporins_1st <- function() {
|
||||
ab_selector("cephalosporins.*1")
|
||||
ab_selector("cephalosporins.*1", function_name = "cephalosporins_1st")
|
||||
}
|
||||
|
||||
#' @rdname antibiotic_class_selectors
|
||||
#' @export
|
||||
cephalosporins_2nd <- function() {
|
||||
ab_selector("cephalosporins.*2")
|
||||
ab_selector("cephalosporins.*2", function_name = "cephalosporins_2nd")
|
||||
}
|
||||
|
||||
#' @rdname antibiotic_class_selectors
|
||||
#' @export
|
||||
cephalosporins_3rd <- function() {
|
||||
ab_selector("cephalosporins.*3")
|
||||
ab_selector("cephalosporins.*3", function_name = "cephalosporins_3rd")
|
||||
}
|
||||
|
||||
#' @rdname antibiotic_class_selectors
|
||||
#' @export
|
||||
cephalosporins_4th <- function() {
|
||||
ab_selector("cephalosporins.*4")
|
||||
ab_selector("cephalosporins.*4", function_name = "cephalosporins_4th")
|
||||
}
|
||||
|
||||
#' @rdname antibiotic_class_selectors
|
||||
#' @export
|
||||
cephalosporins_5th <- function() {
|
||||
ab_selector("cephalosporins.*5")
|
||||
ab_selector("cephalosporins.*5", function_name = "cephalosporins_5th")
|
||||
}
|
||||
|
||||
#' @rdname antibiotic_class_selectors
|
||||
#' @export
|
||||
fluoroquinolones <- function() {
|
||||
ab_selector("fluoroquinolone")
|
||||
ab_selector("fluoroquinolone", function_name = "fluoroquinolones")
|
||||
}
|
||||
|
||||
#' @rdname antibiotic_class_selectors
|
||||
#' @export
|
||||
glycopeptides <- function() {
|
||||
ab_selector("glycopeptide")
|
||||
ab_selector("glycopeptide", function_name = "glycopeptides")
|
||||
}
|
||||
|
||||
#' @rdname antibiotic_class_selectors
|
||||
#' @export
|
||||
macrolides <- function() {
|
||||
ab_selector("macrolide")
|
||||
ab_selector("macrolide", function_name = "macrolides")
|
||||
}
|
||||
|
||||
#' @rdname antibiotic_class_selectors
|
||||
#' @export
|
||||
penicillins <- function() {
|
||||
ab_selector("penicillin")
|
||||
ab_selector("penicillin", function_name = "penicillins")
|
||||
}
|
||||
|
||||
#' @rdname antibiotic_class_selectors
|
||||
#' @export
|
||||
tetracyclines <- function() {
|
||||
ab_selector("tetracycline")
|
||||
ab_selector("tetracycline", function_name = "tetracyclines")
|
||||
}
|
||||
|
||||
ab_selector <- function(ab_class, vars = NULL) {
|
||||
|
||||
stopifnot_installed_package("tidyselect")
|
||||
peek_vars_tidyselect <- get("peek_vars", envir = asNamespace("tidyselect"))
|
||||
|
||||
vars_vct <- peek_vars_tidyselect(fn = ab_class)
|
||||
ab_selector <- function(ab_class, function_name) {
|
||||
peek_vars_tidyselect <- import_fn("peek_vars", "tidyselect")
|
||||
vars_vct <- peek_vars_tidyselect(fn = function_name)
|
||||
vars_df <- data.frame(as.list(vars_vct))[0, , drop = FALSE]
|
||||
colnames(vars_df) <- vars_vct
|
||||
ab_in_data <- suppressMessages(get_column_abx(vars_df))
|
||||
|
||||
|
||||
if (length(ab_in_data) == 0) {
|
||||
message(font_blue("NOTE: no antimicrobial agents found."))
|
||||
return(NULL)
|
||||
}
|
||||
|
||||
|
||||
ab_reference <- subset(antibiotics,
|
||||
group %like% ab_class |
|
||||
atc_group1 %like% ab_class |
|
||||
atc_group2 %like% ab_class)
|
||||
ab_group <- find_ab_group(ab_class)
|
||||
if (ab_group == "") {
|
||||
ab_group <- paste0("'", ab_class, "'")
|
||||
examples <- ""
|
||||
} else {
|
||||
examples <- paste0(" (such as ", find_ab_names(ab_class, 2), ")")
|
||||
}
|
||||
# get the columns with a group names in the chosen ab class
|
||||
agents <- ab_in_data[names(ab_in_data) %in% ab_reference$ab]
|
||||
if (length(agents) == 0) {
|
||||
message(font_blue(paste0("NOTE: no antimicrobial agents of class ", ab_group,
|
||||
" found (such as ", find_ab_names(ab_class, 2),
|
||||
").")))
|
||||
message(font_blue(paste0("NOTE: No antimicrobial agents of class ", ab_group,
|
||||
" found", examples, ".")))
|
||||
} else {
|
||||
message(font_blue(paste0("Selecting ", ab_group, ": ",
|
||||
paste(paste0("`", font_bold(agents, collapse = NULL),
|
||||
|
||||
@ -76,15 +76,14 @@ 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"))
|
||||
has_internet <- get("has_internet", envir = asNamespace("curl"))
|
||||
html_attr <- get("html_attr", envir = asNamespace("rvest"))
|
||||
html_children <- get("html_children", envir = asNamespace("rvest"))
|
||||
html_node <- get("html_node", envir = asNamespace("rvest"))
|
||||
html_nodes <- get("html_nodes", envir = asNamespace("rvest"))
|
||||
html_table <- get("html_table", envir = asNamespace("rvest"))
|
||||
html_text <- get("html_text", envir = asNamespace("rvest"))
|
||||
read_html <- get("read_html", envir = asNamespace("xml2"))
|
||||
has_internet <- import_fn("has_internet", "curl")
|
||||
html_attr <- import_fn("html_attr", "rvest")
|
||||
html_children <- import_fn("html_children", "rvest")
|
||||
html_node <- import_fn("html_node", "rvest")
|
||||
html_nodes <- import_fn("html_nodes", "rvest")
|
||||
html_table <- import_fn("html_table", "rvest")
|
||||
html_text <- import_fn("html_text", "rvest")
|
||||
read_html <- import_fn("read_html", "xml2")
|
||||
|
||||
check_dataset_integrity()
|
||||
|
||||
|
||||
@ -62,6 +62,9 @@ bug_drug_combinations <- function(x,
|
||||
if (!is.data.frame(x)) {
|
||||
stop("`x` must be a data frame.", call. = FALSE)
|
||||
}
|
||||
if (!any(sapply(x, is.rsi), na.rm = TRUE)) {
|
||||
stop("No columns with class <rsi> found. See ?as.rsi.", call. = FALSE)
|
||||
}
|
||||
|
||||
# try to find columns based on type
|
||||
# -- mo
|
||||
@ -72,12 +75,13 @@ bug_drug_combinations <- function(x,
|
||||
stop("`col_mo` must be set.", call. = FALSE)
|
||||
}
|
||||
|
||||
x_class <- class(x)
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||
x[, col_mo] <- FUN(x[, col_mo, drop = TRUE])
|
||||
x <- x[, c(col_mo, names(which(sapply(x, is.rsi))))]
|
||||
x <- x[, c(col_mo, names(which(sapply(x, is.rsi)))), drop = FALSE]
|
||||
|
||||
unique_mo <- sort(unique(x[, col_mo, drop = TRUE]))
|
||||
|
||||
|
||||
out <- data.frame(
|
||||
mo = character(0),
|
||||
ab = character(0),
|
||||
@ -85,10 +89,10 @@ bug_drug_combinations <- function(x,
|
||||
I = integer(0),
|
||||
R = integer(0),
|
||||
total = integer(0))
|
||||
|
||||
|
||||
for (i in seq_len(length(unique_mo))) {
|
||||
# filter on MO group and only select R/SI columns
|
||||
x_mo_filter <- x[which(x[, col_mo, drop = TRUE] == unique_mo[i]), names(which(sapply(x, is.rsi)))]
|
||||
x_mo_filter <- x[which(x[, col_mo, drop = TRUE] == unique_mo[i]), names(which(sapply(x, is.rsi))), drop = FALSE]
|
||||
# turn and merge everything
|
||||
pivot <- lapply(x_mo_filter, function(x) {
|
||||
m <- as.matrix(table(x))
|
||||
@ -103,8 +107,8 @@ bug_drug_combinations <- function(x,
|
||||
total = merged$S + merged$I + merged$R)
|
||||
out <- rbind(out, out_group)
|
||||
}
|
||||
|
||||
structure(.Data = out, class = c("bug_drug_combinations", class(x)))
|
||||
|
||||
structure(.Data = out, class = c("bug_drug_combinations", x_class))
|
||||
}
|
||||
|
||||
#' @method format bug_drug_combinations
|
||||
@ -121,6 +125,7 @@ format.bug_drug_combinations <- function(x,
|
||||
decimal.mark = getOption("OutDec"),
|
||||
big.mark = ifelse(decimal.mark == ",", ".", ","),
|
||||
...) {
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||
x <- subset(x, total >= minimum)
|
||||
|
||||
if (remove_intrinsic_resistant == TRUE) {
|
||||
@ -221,6 +226,8 @@ format.bug_drug_combinations <- function(x,
|
||||
#' @method print bug_drug_combinations
|
||||
#' @export
|
||||
print.bug_drug_combinations <- function(x, ...) {
|
||||
print(as.data.frame(x, stringsAsFactors = FALSE))
|
||||
message(font_blue("NOTE: Use 'format()' on this result to get a publicable/printable format."))
|
||||
x_class <- class(x)
|
||||
print(structure(x, class = x_class[x_class != "bug_drug_combinations"]),
|
||||
...)
|
||||
message(font_blue("NOTE: Use 'format()' on this result to get a publishable/printable format."))
|
||||
}
|
||||
|
||||
@ -206,7 +206,7 @@ eucast_rules <- function(x,
|
||||
"\n\nThis may overwrite your existing data if you use e.g.:",
|
||||
"\ndata <- eucast_rules(data, verbose = TRUE)\n\nDo you want to continue?")
|
||||
if ("rstudioapi" %in% rownames(utils::installed.packages())) {
|
||||
showQuestion <- get("showQuestion", envir = asNamespace("rstudioapi"))
|
||||
showQuestion <- import_fn("showQuestion", "rstudioapi")
|
||||
q_continue <- showQuestion("Using verbose = TRUE with eucast_rules()", txt)
|
||||
} else {
|
||||
q_continue <- utils::menu(choices = c("OK", "Cancel"), graphics = FALSE, title = txt)
|
||||
|
||||
@ -26,10 +26,10 @@
|
||||
#' Lifecycles of functions in the `AMR` package
|
||||
#' @name lifecycle
|
||||
#' @rdname lifecycle
|
||||
#' @description Functions in this `AMR` package are categorised using [the lifecycle circle of the `tidyverse` as found on www.tidyverse.org/lifecycle](https://www.tidyverse.org/lifecycle).
|
||||
#' @description Functions in this `AMR` package are categorised using [the lifecycle circle of the Tidyverse as found on www.tidyverse.org/lifecycle](https://www.Tidyverse.org/lifecycle).
|
||||
#'
|
||||
#' \if{html}{\figure{lifecycle_tidyverse.svg}{options: height=200px style=margin-bottom:5px} \cr}
|
||||
#' This page contains a section for every lifecycle (with text borrowed from the aforementioned `tidyverse` website), so they can be used in the manual pages of the functions.
|
||||
#' \if{html}{\figure{lifecycle_Tidyverse.svg}{options: height=200px style=margin-bottom:5px} \cr}
|
||||
#' This page contains a section for every lifecycle (with text borrowed from the aforementioned Tidyverse website), so they can be used in the manual pages of the functions.
|
||||
#' @section Experimental lifecycle:
|
||||
#' \if{html}{\figure{lifecycle_experimental.svg}{options: style=margin-bottom:5px} \cr}
|
||||
#' The [lifecycle][AMR::lifecycle] of this function is **experimental**. An experimental function is in early stages of development. The unlying code might be changing frequently. Experimental functions might be removed without deprecation, so you are generally best off waiting until a function is more mature before you use it in production code. Experimental functions are only available in development versions of this `AMR` package and will thus not be included in releases that are submitted to CRAN, since such functions have not yet matured enough.
|
||||
|
||||
2
R/mdro.R
2
R/mdro.R
@ -95,7 +95,7 @@ mdro <- function(x,
|
||||
"\n\nThis may overwrite your existing data if you use e.g.:",
|
||||
"\ndata <- mdro(data, verbose = TRUE)\n\nDo you want to continue?")
|
||||
if ("rstudioapi" %in% rownames(utils::installed.packages())) {
|
||||
showQuestion <- get("showQuestion", envir = asNamespace("rstudioapi"))
|
||||
showQuestion <- import_fn("showQuestion", "rstudioapi")
|
||||
q_continue <- showQuestion("Using verbose = TRUE with mdro()", txt)
|
||||
} else {
|
||||
q_continue <- utils::menu(choices = c("OK", "Cancel"), graphics = FALSE, title = txt)
|
||||
|
||||
6
R/mo.R
6
R/mo.R
@ -152,7 +152,7 @@
|
||||
#' \dontrun{
|
||||
#' df$mo <- as.mo(df$microorganism_name)
|
||||
#'
|
||||
#' # the select function of tidyverse is also supported:
|
||||
#' # the select function of the Tidyverse is also supported:
|
||||
#' library(dplyr)
|
||||
#' df$mo <- df %>%
|
||||
#' select(microorganism_name) %>%
|
||||
@ -1805,13 +1805,13 @@ parse_and_convert <- function(x) {
|
||||
if (NCOL(x) > 2) {
|
||||
stop("A maximum of two columns is allowed.", call. = FALSE)
|
||||
} else if (NCOL(x) == 2) {
|
||||
# support tidyverse selection like: df %>% select(colA, colB)
|
||||
# support Tidyverse selection like: df %>% select(colA, colB)
|
||||
# paste these columns together
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||
colnames(x) <- c("A", "B")
|
||||
x <- paste(x$A, x$B)
|
||||
} else {
|
||||
# support tidyverse selection like: df %>% select(colA)
|
||||
# support Tidyverse selection like: df %>% select(colA)
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE)[[1]]
|
||||
}
|
||||
}
|
||||
|
||||
@ -135,8 +135,7 @@ set_mo_source <- function(path) {
|
||||
|
||||
} else if (path %like% "[.]xlsx?$") {
|
||||
# is Excel file (old or new)
|
||||
stopifnot_installed_package("readxl")
|
||||
read_excel <- get("read_excel", envir = asNamespace("readxl"))
|
||||
read_excel <- import_fn("read_excel", "readxl")
|
||||
df <- read_excel(path)
|
||||
|
||||
} else if (path %like% "[.]tsv$") {
|
||||
|
||||
@ -40,7 +40,7 @@
|
||||
#'
|
||||
#' **Remember that you should filter your table to let it contain only first isolates!** This is needed to exclude duplicates and to reduce selection bias. Use [first_isolate()] to determine them in your data set.
|
||||
#'
|
||||
#' 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).*
|
||||
#' 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. It also supports grouped variables. The function [rsi_df()] works exactly like [proportion_df()], but adds the number of isolates.
|
||||
#' @section Combination therapy:
|
||||
|
||||
@ -316,9 +316,9 @@ plot.resistance_predict <- function(x, main = paste("Resistance Prediction of",
|
||||
}
|
||||
# get plot() generic; this was moved from the 'graphics' pkg to the 'base' pkg in R 4.0.0
|
||||
if (as.integer(R.Version()$major) >= 4) {
|
||||
plot <- get("plot", envir = asNamespace("base"))
|
||||
plot <- import_fn("plot", "base")
|
||||
} else {
|
||||
plot <- get("plot", envir = asNamespace("graphics"))
|
||||
plot <- import_fn("plot", "graphics")
|
||||
}
|
||||
plot(x = x$year,
|
||||
y = x$value,
|
||||
|
||||
4
R/rsi.R
4
R/rsi.R
@ -594,9 +594,9 @@ plot.rsi <- function(x,
|
||||
|
||||
# get plot() generic; this was moved from the 'graphics' pkg to the 'base' pkg in R 4.0.0
|
||||
if (as.integer(R.Version()$major) >= 4) {
|
||||
plot <- get("plot", envir = asNamespace("base"))
|
||||
plot <- import_fn("plot", "base")
|
||||
} else {
|
||||
plot <- get("plot", envir = asNamespace("graphics"))
|
||||
plot <- import_fn("plot", "graphics")
|
||||
}
|
||||
plot(x = data$x,
|
||||
y = data$s,
|
||||
|
||||
Reference in New Issue
Block a user