mirror of
https://github.com/msberends/AMR.git
synced 2024-12-26 06:46:11 +01:00
allow column name for ab in as.sir()
This commit is contained in:
parent
fc269e667d
commit
d214f74e25
@ -1,5 +1,5 @@
|
||||
Package: AMR
|
||||
Version: 2.1.1.9031
|
||||
Version: 2.1.1.9032
|
||||
Date: 2024-05-20
|
||||
Title: Antimicrobial Resistance Data Analysis
|
||||
Description: Functions to simplify and standardise antimicrobial resistance (AMR)
|
||||
|
||||
3
NEWS.md
3
NEWS.md
@ -1,4 +1,4 @@
|
||||
# AMR 2.1.1.9031
|
||||
# AMR 2.1.1.9032
|
||||
|
||||
*(this beta version will eventually become v3.0. We're happy to reach a new major milestone soon, which will be all about the new One Health support!)*
|
||||
|
||||
@ -21,6 +21,7 @@ This package now supports not only tools for AMR data analysis in clinical setti
|
||||
* Function `mo_group_members()` to retrieve the member microorganisms. For example, `mo_group_members("Strep group C")` returns a vector of all microorganisms that are in that group.
|
||||
|
||||
## Changed
|
||||
* For SIR interpretation, it is now possible to use column names for argument `ab` and `mo`: `as.sir(..., ab = "column1", mo = "column2")`. This greatly improves the flexibility for users.
|
||||
* For MICs:
|
||||
* Added as valid levels: 4096, 6 powers of 0.0625, and 5 powers of 192 (192, 384, 576, 768, 960)
|
||||
* Added new argument `keep_operators` to `as.mic()`. This can be `"all"` (default), `"none"`, or `"edges"`. This argument is also available in the new `limit_mic_range()` and `scale_*_mic()` functions.
|
||||
|
||||
@ -1049,10 +1049,15 @@ get_current_column <- function() {
|
||||
if (tryCatch(!is.null(env$i), error = function(e) FALSE)) {
|
||||
if (!is.null(env$tibble_vars)) {
|
||||
# for mutate_if()
|
||||
# TODO remove later, was part of older dplyr versions (at least not in dplyr 1.1.4)
|
||||
env$tibble_vars[env$i]
|
||||
} else {
|
||||
# for mutate(across())
|
||||
df <- tryCatch(get_current_data(NA, 0), error = function(e) NULL)
|
||||
if (!is.null(env$data) && is.data.frame(env$data)) {
|
||||
df <- env$data
|
||||
} else {
|
||||
df <- tryCatch(get_current_data(NA, 0), error = function(e) NULL)
|
||||
}
|
||||
if (is.data.frame(df)) {
|
||||
colnames(df)[env$i]
|
||||
} else {
|
||||
|
||||
27
R/ab.R
27
R/ab.R
@ -322,13 +322,12 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
}
|
||||
|
||||
# INITIAL SEARCH - More uncertain results ----
|
||||
|
||||
if (loop_time <= 2 && fast_mode == FALSE) {
|
||||
# only run on first and second try
|
||||
|
||||
# try by removing all spaces
|
||||
if (x[i] %like% " ") {
|
||||
found <- suppressWarnings(as.ab(gsub(" +", "", x[i], perl = TRUE), loop_time = loop_time + 1))
|
||||
found <- suppressWarnings(as.ab(gsub(" +", "", x[i], perl = TRUE), loop_time = loop_time + 2))
|
||||
if (length(found) > 0 && !is.na(found)) {
|
||||
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
||||
next
|
||||
@ -337,7 +336,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
|
||||
# try by removing all spaces and numbers
|
||||
if (x[i] %like% " " || x[i] %like% "[0-9]") {
|
||||
found <- suppressWarnings(as.ab(gsub("[ 0-9]", "", x[i], perl = TRUE), loop_time = loop_time + 1))
|
||||
found <- suppressWarnings(as.ab(gsub("[ 0-9]", "", x[i], perl = TRUE), loop_time = loop_time + 2))
|
||||
if (length(found) > 0 && !is.na(found)) {
|
||||
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
||||
next
|
||||
@ -363,7 +362,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
)[[1]],
|
||||
collapse = "/"
|
||||
)
|
||||
x_translated_guess <- suppressWarnings(as.ab(x_translated, loop_time = loop_time + 1))
|
||||
x_translated_guess <- suppressWarnings(as.ab(x_translated, loop_time = loop_time + 2))
|
||||
if (!is.na(x_translated_guess)) {
|
||||
x_new[i] <- x_translated_guess
|
||||
next
|
||||
@ -375,7 +374,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
strsplit(x_translated, "[^A-Z0-9 ]"),
|
||||
function(y) {
|
||||
for (i in seq_len(length(y))) {
|
||||
y_name <- suppressWarnings(ab_name(y[i], language = NULL, loop_time = loop_time + 1))
|
||||
y_name <- suppressWarnings(ab_name(y[i], language = NULL, loop_time = loop_time + 2))
|
||||
y[i] <- ifelse(!is.na(y_name),
|
||||
y_name,
|
||||
y[i]
|
||||
@ -386,7 +385,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
)[[1]],
|
||||
collapse = "/"
|
||||
)
|
||||
x_translated_guess <- suppressWarnings(as.ab(x_translated, loop_time = loop_time + 1))
|
||||
x_translated_guess <- suppressWarnings(as.ab(x_translated, loop_time = loop_time + 2))
|
||||
if (!is.na(x_translated_guess)) {
|
||||
x_new[i] <- x_translated_guess
|
||||
next
|
||||
@ -394,7 +393,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
|
||||
# try by removing all trailing capitals
|
||||
if (x[i] %like_case% "[a-z]+[A-Z]+$") {
|
||||
found <- suppressWarnings(as.ab(gsub("[A-Z]+$", "", x[i], perl = TRUE), loop_time = loop_time + 1))
|
||||
found <- suppressWarnings(as.ab(gsub("[A-Z]+$", "", x[i], perl = TRUE), loop_time = loop_time + 2))
|
||||
if (!is.na(found)) {
|
||||
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
||||
next
|
||||
@ -402,7 +401,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
}
|
||||
|
||||
# keep only letters
|
||||
found <- suppressWarnings(as.ab(gsub("[^A-Z]", "", x[i], perl = TRUE), loop_time = loop_time + 1))
|
||||
found <- suppressWarnings(as.ab(gsub("[^A-Z]", "", x[i], perl = TRUE), loop_time = loop_time + 2))
|
||||
if (!is.na(found)) {
|
||||
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
||||
next
|
||||
@ -413,7 +412,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
if (flag_multiple_results == TRUE) {
|
||||
found <- from_text[1L]
|
||||
} else {
|
||||
found <- tryCatch(suppressWarnings(ab_from_text(x[i], loop_time = loop_time + 1, translate_ab = FALSE)[[1]][1L]),
|
||||
found <- tryCatch(suppressWarnings(ab_from_text(x[i], loop_time = loop_time + 2, translate_ab = FALSE)[[1]][1L]),
|
||||
error = function(e) NA_character_
|
||||
)
|
||||
}
|
||||
@ -423,12 +422,12 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
}
|
||||
|
||||
# first 5 except for cephalosporins, then first 7 (those cephalosporins all start quite the same!)
|
||||
found <- suppressWarnings(as.ab(substr(x[i], 1, 5), loop_time = loop_time + 1))
|
||||
found <- suppressWarnings(as.ab(substr(x[i], 1, 5), loop_time = loop_time + 2))
|
||||
if (!is.na(found) && ab_group(found, loop_time = loop_time + 1) %unlike% "cephalosporins") {
|
||||
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
||||
next
|
||||
}
|
||||
found <- suppressWarnings(as.ab(substr(x[i], 1, 7), loop_time = loop_time + 1))
|
||||
found <- suppressWarnings(as.ab(substr(x[i], 1, 7), loop_time = loop_time + 2))
|
||||
if (!is.na(found)) {
|
||||
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
||||
next
|
||||
@ -436,7 +435,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
|
||||
# make all consonants facultative
|
||||
search_str <- gsub("([BCDFGHJKLMNPQRSTVWXZ])", "\\1*", x[i], perl = TRUE)
|
||||
found <- suppressWarnings(as.ab(search_str, loop_time = loop_time + 1, already_regex = TRUE))
|
||||
found <- suppressWarnings(as.ab(search_str, loop_time = loop_time + 2, already_regex = TRUE))
|
||||
# keep at least 4 normal characters
|
||||
if (nchar(gsub(".\\*", "", search_str, perl = TRUE)) < 4) {
|
||||
found <- NA
|
||||
@ -448,7 +447,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
|
||||
# make all vowels facultative
|
||||
search_str <- gsub("([AEIOUY])", "\\1*", x[i], perl = TRUE)
|
||||
found <- suppressWarnings(as.ab(search_str, loop_time = loop_time + 1, already_regex = TRUE))
|
||||
found <- suppressWarnings(as.ab(search_str, loop_time = loop_time + 2, already_regex = TRUE))
|
||||
# keep at least 5 normal characters
|
||||
if (nchar(gsub(".\\*", "", search_str, perl = TRUE)) < 5) {
|
||||
found <- NA
|
||||
@ -464,7 +463,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
x_spelling <- gsub("I+", "[AEIOU]+", x_spelling, fixed = TRUE)
|
||||
x_spelling <- gsub("O+", "[AEIOU]+", x_spelling, fixed = TRUE)
|
||||
x_spelling <- gsub("U+", "[AEIOU]+", x_spelling, fixed = TRUE)
|
||||
found <- suppressWarnings(as.ab(x_spelling, loop_time = loop_time + 1, already_regex = TRUE))
|
||||
found <- suppressWarnings(as.ab(x_spelling, loop_time = loop_time + 2, already_regex = TRUE))
|
||||
if (!is.na(found)) {
|
||||
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
||||
next
|
||||
|
||||
@ -129,6 +129,10 @@ ab_from_text <- function(text,
|
||||
text_split_all <- text_split_all[nchar(text_split_all) >= 4 & grepl("[a-z]+", text_split_all)]
|
||||
result <- lapply(text_split_all, function(text_split) {
|
||||
progress$tick()
|
||||
text_split <- text_split[text_split %like% "[A-Z]" & text_split %unlike% "[0-9]"]
|
||||
if (length(text_split) == 0) {
|
||||
return(as.ab(NA_character_))
|
||||
}
|
||||
suppressWarnings(
|
||||
as.ab(text_split, ...)
|
||||
)
|
||||
|
||||
@ -135,7 +135,7 @@ count_resistant <- function(..., only_all_tested = FALSE) {
|
||||
count_susceptible <- function(..., only_all_tested = FALSE) {
|
||||
tryCatch(
|
||||
sir_calc(...,
|
||||
ab_result = c("S", "I"),
|
||||
ab_result = c("S", "SDD", "I"),
|
||||
only_all_tested = only_all_tested,
|
||||
only_count = TRUE
|
||||
),
|
||||
|
||||
169
R/sir.R
169
R/sir.R
@ -39,8 +39,8 @@
|
||||
#' All breakpoints used for interpretation are available in our [clinical_breakpoints] data set.
|
||||
#' @rdname as.sir
|
||||
#' @param x vector of values (for class [`mic`]: MIC values in mg/L, for class [`disk`]: a disk diffusion radius in millimetres)
|
||||
#' @param mo any (vector of) text that can be coerced to valid microorganism codes with [as.mo()], can be left empty to determine it automatically
|
||||
#' @param ab any (vector of) text that can be coerced to a valid antimicrobial drug code with [as.ab()]
|
||||
#' @param mo a vector (or column name) with [character]s that can be coerced to valid microorganism codes with [as.mo()], can be left empty to determine it automatically
|
||||
#' @param ab a vector (or column name) with [character]s that can be coerced to a valid antimicrobial drug 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.sir()] on a [data.frame], this can also be a column containing [logical]s or when left blank, the data set will be searched for a column 'specimen', and rows within this column containing 'urin' (such as 'urine', 'urina') will be regarded isolates from a UTI. See *Examples*.
|
||||
#' @inheritParams first_isolate
|
||||
#' @param guideline defaults to EUCAST `r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST")$guideline)))` (the latest implemented EUCAST guideline in the [AMR::clinical_breakpoints] data set), but can be set with the [package option][AMR-options] [`AMR_guideline`][AMR-options]. Currently supports EUCAST (`r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`) and CLSI (`r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI")$guideline)))`), see *Details*.
|
||||
@ -191,7 +191,7 @@
|
||||
#' df %>% mutate(across(AMP:TOB, as.sir))
|
||||
#'
|
||||
#' df %>%
|
||||
#' mutate_at(vars(AMP:TOB), as.sir, mo = .$microorganism)
|
||||
#' mutate_at(vars(AMP:TOB), as.sir, mo = "microorganism")
|
||||
#'
|
||||
#' # to include information about urinary tract infections (UTI)
|
||||
#' data.frame(
|
||||
@ -759,7 +759,7 @@ as_sir_method <- function(method_short,
|
||||
...) {
|
||||
meet_criteria(x, allow_NA = TRUE, .call_depth = -2)
|
||||
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE, .call_depth = -2)
|
||||
meet_criteria(ab, allow_class = c("ab", "character"), has_length = 1, .call_depth = -2)
|
||||
meet_criteria(ab, allow_class = c("ab", "character"), .call_depth = -2)
|
||||
meet_criteria(guideline, allow_class = "character", has_length = 1, .call_depth = -2)
|
||||
meet_criteria(uti, allow_class = "logical", has_length = c(1, length(x)), allow_NULL = TRUE, allow_NA = TRUE, .call_depth = -2)
|
||||
meet_criteria(conserve_capped_values, allow_class = "logical", has_length = 1, .call_depth = -2)
|
||||
@ -808,37 +808,49 @@ as_sir_method <- function(method_short,
|
||||
message_("Please note that in the absence of specific veterinary breakpoints for certain animal hosts, breakpoints for dogs, cattle, swine, cats, horse, aquatic, and poultry, in that order, are used as substitutes.\n\n")
|
||||
}
|
||||
|
||||
# for dplyr's across()
|
||||
cur_column_dplyr <- import_fn("cur_column", "dplyr", error_on_fail = FALSE)
|
||||
if (!is.null(cur_column_dplyr) && tryCatch(is.data.frame(get_current_data("ab", call = 0)), error = function(e) FALSE)) {
|
||||
# try to get current column, which will only be available when in across()
|
||||
ab <- tryCatch(cur_column_dplyr(),
|
||||
error = function(e) ab
|
||||
)
|
||||
current_df <- tryCatch(get_current_data(NA, 0), error = function(e) NULL)
|
||||
|
||||
# get ab
|
||||
if (!is.null(current_df) && length(ab) == 1 && ab %in% colnames(current_df) && any(current_df[[ab]] %like% "[A-Z]", na.rm = TRUE)) {
|
||||
ab <- current_df[[ab]]
|
||||
} else {
|
||||
# for dplyr's across()
|
||||
cur_column_dplyr <- import_fn("cur_column", "dplyr", error_on_fail = FALSE)
|
||||
if (!is.null(cur_column_dplyr) && is.data.frame(current_df)) {
|
||||
# try to get current column, which will only be available when in across()
|
||||
ab <- tryCatch(cur_column_dplyr(),
|
||||
error = function(e) ab
|
||||
)
|
||||
}
|
||||
}
|
||||
|
||||
# for auto-determining mo
|
||||
mo_var_found <- ""
|
||||
if (is.null(mo)) {
|
||||
tryCatch(
|
||||
{
|
||||
df <- get_current_data(arg_name = "mo", call = -3) # will return an error if not found
|
||||
mo <- NULL
|
||||
try(
|
||||
{
|
||||
mo <- suppressMessages(search_type_in_df(df, "mo"))
|
||||
},
|
||||
silent = TRUE
|
||||
)
|
||||
if (!is.null(df) && !is.null(mo) && is.data.frame(df)) {
|
||||
mo_var_found <- paste0(" based on column '", font_bold(mo), "'")
|
||||
mo <- df[, mo, drop = TRUE]
|
||||
# get mo
|
||||
if (!is.null(current_df) && length(mo) == 1 && mo %in% colnames(current_df)) {
|
||||
mo_var_found <- paste0(" based on column '", font_bold(mo), "'")
|
||||
mo <- current_df[[mo]]
|
||||
} else {
|
||||
mo_var_found <- ""
|
||||
if (is.null(mo)) {
|
||||
tryCatch(
|
||||
{
|
||||
df <- get_current_data(arg_name = "mo", call = -3) # will return an error if not found
|
||||
mo <- NULL
|
||||
try(
|
||||
{
|
||||
mo <- suppressMessages(search_type_in_df(df, "mo"))
|
||||
},
|
||||
silent = TRUE
|
||||
)
|
||||
if (!is.null(df) && !is.null(mo) && is.data.frame(df)) {
|
||||
mo_var_found <- paste0(" based on column '", font_bold(mo), "'")
|
||||
mo <- df[, mo, drop = TRUE]
|
||||
}
|
||||
},
|
||||
error = function(e) {
|
||||
mo <- NULL
|
||||
}
|
||||
},
|
||||
error = function(e) {
|
||||
mo <- NULL
|
||||
}
|
||||
)
|
||||
)
|
||||
}
|
||||
}
|
||||
if (is.null(mo)) {
|
||||
stop_("No information was supplied about the microorganisms (missing argument `mo` and no column of class 'mo' found). See ?as.sir.\n\n",
|
||||
@ -861,9 +873,9 @@ as_sir_method <- function(method_short,
|
||||
}
|
||||
# be sure to take current taxonomy, as the 'clinical_breakpoints' data set only contains current taxonomy
|
||||
mo <- suppressWarnings(suppressMessages(as.mo(mo, keep_synonyms = FALSE, info = FALSE)))
|
||||
if (is.na(ab)) {
|
||||
message_("Returning NAs for unknown antibiotic: '", font_bold(ab.bak),
|
||||
"'. Rename this column to a valid name or code, and check the output with `as.ab()`.",
|
||||
if (all(is.na(ab))) {
|
||||
message_("Returning NAs for unknown antibiotic: ", vector_and(ab.bak, sort = FALSE, quotes = TRUE),
|
||||
". Rename this column to a valid name or code, and check the output with `as.ab()`.",
|
||||
add_fn = font_red,
|
||||
as_note = FALSE
|
||||
)
|
||||
@ -887,25 +899,20 @@ as_sir_method <- function(method_short,
|
||||
}
|
||||
}
|
||||
|
||||
agent_formatted <- paste0("'", font_bold(ab.bak), "'")
|
||||
agent_formatted <- paste0("'", font_bold(ab.bak, collapse = NULL), "'")
|
||||
agent_name <- ab_name(ab, tolower = TRUE, language = NULL)
|
||||
if (generalise_antibiotic_name(ab.bak) == generalise_antibiotic_name(agent_name)) {
|
||||
agent_formatted <- paste0(
|
||||
agent_formatted,
|
||||
" (", ab, ")"
|
||||
)
|
||||
} else if (generalise_antibiotic_name(ab) != generalise_antibiotic_name(agent_name)) {
|
||||
agent_formatted <- paste0(
|
||||
agent_formatted,
|
||||
" (", ifelse(ab.bak == ab, "",
|
||||
paste0(ab, ", ")
|
||||
), agent_name, ")"
|
||||
)
|
||||
}
|
||||
|
||||
same_ab <- generalise_antibiotic_name(ab) == generalise_antibiotic_name(agent_name)
|
||||
same_ab.bak <- generalise_antibiotic_name(ab.bak) == generalise_antibiotic_name(agent_name)
|
||||
agent_formatted[same_ab.bak] <- paste0(agent_formatted[same_ab.bak], " (", ab, ")")
|
||||
agent_formatted[same_ab.bak & !same_ab] <- paste0(agent_formatted[same_ab.bak & !same_ab],
|
||||
" (", ifelse(ab.bak[same_ab.bak & !same_ab] == ab[same_ab.bak & !same_ab],
|
||||
"",
|
||||
paste0(ab[same_ab.bak & !same_ab], ", ")),
|
||||
agent_name[same_ab.bak & !same_ab],
|
||||
")")
|
||||
# this intro text will also be printed in the progress bar in the `progress` package is installed
|
||||
intro_txt <- paste0("Interpreting ", method_long, ": ", ifelse(isTRUE(list(...)$is_data.frame), "column ", ""),
|
||||
agent_formatted,
|
||||
ifelse(length(agent_formatted) == 1, agent_formatted, ""),
|
||||
mo_var_found,
|
||||
ifelse(identical(reference_data, AMR::clinical_breakpoints),
|
||||
paste0(", ", font_bold(guideline_coerced)),
|
||||
@ -928,23 +935,6 @@ as_sir_method <- function(method_short,
|
||||
|
||||
metadata_mo <- get_mo_uncertainties()
|
||||
|
||||
df <- data.frame(
|
||||
values = x,
|
||||
mo = mo,
|
||||
result = NA_sir_,
|
||||
uti = uti,
|
||||
host = host,
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
if (method == "mic") {
|
||||
# when as.sir.mic is called directly
|
||||
df$values <- as.mic(df$values)
|
||||
} else if (method == "disk") {
|
||||
# when as.sir.disk is called directly
|
||||
df$values <- as.disk(df$values)
|
||||
}
|
||||
df_unique <- unique(df[ , c("mo", "uti", "host"), drop = FALSE])
|
||||
|
||||
rise_warning <- FALSE
|
||||
rise_note <- FALSE
|
||||
method_coerced <- toupper(method)
|
||||
@ -952,17 +942,38 @@ as_sir_method <- function(method_short,
|
||||
|
||||
if (identical(reference_data, AMR::clinical_breakpoints)) {
|
||||
breakpoints <- reference_data %pm>%
|
||||
subset(guideline == guideline_coerced & method == method_coerced & ab == ab_coerced)
|
||||
if (ab_coerced == "AMX" && nrow(breakpoints) == 0) {
|
||||
ab_coerced <- "AMP"
|
||||
subset(guideline == guideline_coerced & method == method_coerced & ab %in% ab_coerced)
|
||||
if (any(ab_coerced == "AMX") && nrow(breakpoints[breakpoints$ab == "AMX", , drop = FALSE]) == 0) {
|
||||
ab_coerced[ab_coerced == "AMX"] <- "AMP"
|
||||
breakpoints <- reference_data %pm>%
|
||||
subset(guideline == guideline_coerced & method == method_coerced & ab == ab_coerced)
|
||||
subset(guideline == guideline_coerced & method == method_coerced & ab %in% ab_coerced)
|
||||
}
|
||||
} else {
|
||||
breakpoints <- reference_data %pm>%
|
||||
subset(method == method_coerced & ab == ab_coerced)
|
||||
subset(method == method_coerced & ab %in% ab_coerced)
|
||||
}
|
||||
|
||||
# create the unique data frame to be filled to save time
|
||||
df <- data.frame(
|
||||
values = x,
|
||||
mo = mo,
|
||||
ab = ab,
|
||||
result = NA_sir_,
|
||||
uti = uti,
|
||||
host = host,
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
|
||||
if (method == "mic") {
|
||||
# when as.sir.mic is called directly
|
||||
df$values <- as.mic(df$values)
|
||||
} else if (method == "disk") {
|
||||
# when as.sir.disk is called directly
|
||||
df$values <- as.disk(df$values)
|
||||
}
|
||||
df_unique <- unique(df[ , c("mo", "ab", "uti", "host"), drop = FALSE])
|
||||
|
||||
# get all breakpoints
|
||||
breakpoints <- breakpoints %pm>%
|
||||
subset(type == breakpoint_type)
|
||||
|
||||
@ -1003,6 +1014,7 @@ as_sir_method <- function(method_short,
|
||||
for (i in seq_len(nrow(df_unique))) {
|
||||
p$tick()
|
||||
mo_current <- df_unique[i, "mo", drop = TRUE]
|
||||
ab_current <- df_unique[i, "ab", drop = TRUE]
|
||||
uti_current <- df_unique[i, "uti", drop = TRUE]
|
||||
if (is.na(uti_current)) {
|
||||
# no preference, so no filter on UTIs
|
||||
@ -1030,16 +1042,17 @@ as_sir_method <- function(method_short,
|
||||
# formatted for notes
|
||||
mo_formatted <- mo_current_name
|
||||
if (!mo_current_rank %in% c("kingdom", "phylum", "class", "order")) {
|
||||
mo_formatted <- font_italic(mo_formatted)
|
||||
mo_formatted <- font_italic(mo_formatted, collapse = NULL)
|
||||
}
|
||||
ab_formatted <- paste0(
|
||||
suppressMessages(suppressWarnings(ab_name(ab_coerced, language = NULL, tolower = TRUE))),
|
||||
" (", ab_coerced, ")"
|
||||
suppressMessages(suppressWarnings(ab_name(ab_current, language = NULL, tolower = TRUE))),
|
||||
" (", ab_current, ")"
|
||||
)
|
||||
|
||||
|
||||
# gather all available breakpoints for current MO
|
||||
breakpoints_current <- breakpoints %pm>%
|
||||
subset(ab == ab_current) %pm>%
|
||||
subset(mo %in% c(
|
||||
mo_current, mo_current_genus, mo_current_family,
|
||||
mo_current_order, mo_current_class,
|
||||
@ -1155,9 +1168,9 @@ as_sir_method <- function(method_short,
|
||||
data.frame(
|
||||
datetime = rep(Sys.time(), length(rows)),
|
||||
index = rows,
|
||||
ab_user = rep(ab.bak, length(rows)),
|
||||
ab_user = rep(ab.bak[match(ab_current, df$ab)][1], length(rows)),
|
||||
mo_user = rep(mo.bak[match(mo_current, df$mo)][1], length(rows)),
|
||||
ab = rep(ab_coerced, length(rows)),
|
||||
ab = rep(ab_current, length(rows)),
|
||||
mo = rep(breakpoints_current[, "mo", drop = TRUE], length(rows)),
|
||||
input = as.double(values),
|
||||
outcome = as.sir(new_sir),
|
||||
|
||||
13
R/sir_calc.R
13
R/sir_calc.R
@ -135,13 +135,20 @@ sir_calc <- function(...,
|
||||
|
||||
x_transposed <- as.list(as.data.frame(t(x), stringsAsFactors = FALSE))
|
||||
if (isTRUE(only_all_tested)) {
|
||||
get_integers <- function(x) {
|
||||
ints <- rep(NA_integer_, length(x))
|
||||
ints[x == "S"] <- 1L
|
||||
ints[x %in% c("SDD", "I")] <- 2L
|
||||
ints[x == "R"] <- 3L
|
||||
ints
|
||||
}
|
||||
# no NAs in any column
|
||||
y <- apply(
|
||||
X = as.data.frame(lapply(x, as.integer), stringsAsFactors = FALSE),
|
||||
X = as.data.frame(lapply(x, get_integers), stringsAsFactors = FALSE),
|
||||
MARGIN = 1,
|
||||
FUN = min
|
||||
)
|
||||
numerator <- sum(as.integer(y) %in% as.integer(ab_result), na.rm = TRUE)
|
||||
numerator <- sum(!is.na(y) & y %in% get_integers(ab_result), na.rm = TRUE)
|
||||
denominator <- sum(vapply(FUN.VALUE = logical(1), x_transposed, function(y) !(anyNA(y))))
|
||||
} else {
|
||||
# may contain NAs in any column
|
||||
@ -360,6 +367,8 @@ sir_calc_df <- function(type, # "proportion", "count" or "both"
|
||||
out$interpretation <- factor(out$interpretation, levels = c("S", "SDD", "I", "R", "N"), ordered = TRUE)
|
||||
}
|
||||
|
||||
out <- out[!is.na(out$interpretation), , drop = FALSE]
|
||||
|
||||
if (data_has_groups) {
|
||||
# ordering by the groups and two more: "antibiotic" and "interpretation"
|
||||
out <- pm_ungroup(out[do.call("order", out[, seq_len(length(groups) + 2), drop = FALSE]), , drop = FALSE])
|
||||
|
||||
@ -95,8 +95,10 @@ if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0", also_load = TRUE)) {
|
||||
example_isolates %>% select(AMX) %>% count_df(combine_SI = FALSE) %>% pull(value),
|
||||
c(
|
||||
suppressWarnings(example_isolates$AMX %>% count_S()),
|
||||
0,
|
||||
example_isolates$AMX %>% count_I(),
|
||||
example_isolates$AMX %>% count_R()
|
||||
example_isolates$AMX %>% count_R(),
|
||||
0
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
@ -98,9 +98,9 @@ sir_interpretation_history(clean = FALSE)
|
||||
|
||||
\item{S, I, R, N, SDD}{a case-indepdendent \link[base:regex]{regular expression} to translate input to this result. This regular expression will be run \emph{after} all non-letters are removed from the input.}
|
||||
|
||||
\item{mo}{any (vector of) text that can be coerced to valid microorganism codes with \code{\link[=as.mo]{as.mo()}}, can be left empty to determine it automatically}
|
||||
\item{mo}{a vector (or column name) with \link{character}s that can be coerced to valid microorganism codes with \code{\link[=as.mo]{as.mo()}}, can be left empty to determine it automatically}
|
||||
|
||||
\item{ab}{any (vector of) text that can be coerced to a valid antimicrobial drug code with \code{\link[=as.ab]{as.ab()}}}
|
||||
\item{ab}{a vector (or column name) with \link{character}s that can be coerced to a valid antimicrobial drug code with \code{\link[=as.ab]{as.ab()}}}
|
||||
|
||||
\item{guideline}{defaults to EUCAST 2023 (the latest implemented EUCAST guideline in the \link{clinical_breakpoints} data set), but can be set with the \link[=AMR-options]{package option} \code{\link[=AMR-options]{AMR_guideline}}. Currently supports EUCAST (2011-2023) and CLSI (2011-2023), see \emph{Details}.}
|
||||
|
||||
@ -284,7 +284,7 @@ if (require("dplyr")) {
|
||||
df \%>\% mutate(across(AMP:TOB, as.sir))
|
||||
|
||||
df \%>\%
|
||||
mutate_at(vars(AMP:TOB), as.sir, mo = .$microorganism)
|
||||
mutate_at(vars(AMP:TOB), as.sir, mo = "microorganism")
|
||||
|
||||
# to include information about urinary tract infections (UTI)
|
||||
data.frame(
|
||||
|
||||
Loading…
Reference in New Issue
Block a user