P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-07-08 13:21:50 +02:00
Code Releases Activity

(v1.6.0.9001) support Inf for episodes

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2021-04-12 12:35:13 +02:00
parent 7a3139f7cc
commit 6ff5448192
29 changed files with 144 additions and 104 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
R/aa_helper_functions.R
View File

@ -591,7 +591,7 @@ meet_criteria <- function(object,
ifelse(allow_NA == TRUE, ", or NA", ""),
call = call_depth)
}
if (!is.null(is_positive)) {
if (isTRUE(is_positive)) {
stop_if(is.numeric(object) && !all(object > 0, na.rm = TRUE), "argument `", obj_name,
"` must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
@ -599,7 +599,7 @@ meet_criteria <- function(object,
"all be numbers higher than zero"),
call = call_depth)
}
if (!is.null(is_positive_or_zero)) {
if (isTRUE(is_positive_or_zero)) {
stop_if(is.numeric(object) && !all(object >= 0, na.rm = TRUE), "argument `", obj_name,
"` must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
@ -607,7 +607,7 @@ meet_criteria <- function(object,
"all be zero or numbers higher than zero"),
call = call_depth)
}
if (!is.null(is_finite)) {
if (isTRUE(is_finite)) {
stop_if(is.numeric(object) && !all(is.finite(object[!is.na(object)]), na.rm = TRUE), "argument `", obj_name,
"` must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,

3
R/ab.R
View File

@ -155,7 +155,8 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = TRUE, ...) {
}
if (initial_search == TRUE) {
progress <- progress_ticker(n = length(x), n_min = ifelse(isTRUE(info), 25, length(x) + 1)) # start if n >= 25
progress <- progress_ticker(n = length(x),
n_min = ifelse(isTRUE(info) & isFALSE(fast_mode), 25, length(x) + 1)) # start if n >= 25
on.exit(close(progress))
}

8
R/episode.R
View File

@ -28,7 +28,7 @@
#' These functions determine which items in a vector can be considered (the start of) a new episode, based on the argument `episode_days`. This can be used to determine clinical episodes for any epidemiological analysis. The [get_episode()] function returns the index number of the episode per group, while the [is_new_episode()] function returns values `TRUE`/`FALSE` to indicate whether an item in a vector is the start of a new episode.
#' @inheritSection lifecycle Stable Lifecycle
#' @param x vector of dates (class `Date` or `POSIXt`)
#' @param episode_days required episode length in days, can also be less than a day, see *Details*
#' @param episode_days required episode length in days, can also be less than a day or `Inf`, see *Details*
#' @param ... currently not used
#' @details
#' Dates are first sorted from old to new. The oldest date will mark the start of the first episode. After this date, the next date will be marked that is at least `episode_days` days later than the start of the first episode. From that second marked date on, the next date will be marked that is at least `episode_days` days later than the start of the second episode which will be the start of the third episode, and so on. Before the vector is being returned, the original order will be restored.
@ -88,7 +88,7 @@
#' # grouping on patients and microorganisms leads to the same results
#' # as first_isolate():
#' x <- example_isolates %>%
#' filter(first_isolate(., include_unknown = TRUE))
#' filter_first_isolate(include_unknown = TRUE)
#'
#' y <- example_isolates %>%
#' group_by(patient_id, mo) %>%
@ -105,7 +105,7 @@
#' }
get_episode <- function(x, episode_days, ...) {
meet_criteria(x, allow_class = c("Date", "POSIXt"))
meet_criteria(episode_days, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(episode_days, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = FALSE)
exec_episode(type = "sequential",
x = x,
@ -117,7 +117,7 @@ get_episode <- function(x, episode_days, ...) {
#' @export
is_new_episode <- function(x, episode_days, ...) {
meet_criteria(x, allow_class = c("Date", "POSIXt"))
meet_criteria(episode_days, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(episode_days, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = FALSE)
exec_episode(type = "logical",
x = x,

70
R/eucast_rules.R
View File

@ -339,7 +339,7 @@ eucast_rules <- function(x,
strsplit(",") %pm>%
unlist() %pm>%
trimws() %pm>%
vapply(FUN.VALUE = character(1), function(x) if (x %in% antibiotics$ab) ab_name(x, language = NULL, tolower = TRUE) else x) %pm>%
vapply(FUN.VALUE = character(1), function(x) if (x %in% antibiotics$ab) ab_name(x, language = NULL, tolower = TRUE, fast_mode = TRUE) else x) %pm>%
sort() %pm>%
paste(collapse = ", ")
x <- gsub("_", " ", x, fixed = TRUE)
@ -448,29 +448,43 @@ eucast_rules <- function(x,
font_red(paste0("v", utils::packageDescription("AMR")$Version, ", ",
format(as.Date(utils::packageDescription("AMR")$Date), format = "%Y"))), "), see ?eucast_rules\n"))))
}
ab_enzyme <- subset(antibiotics, name %like% "/")[, c("ab", "name")]
ab_enzyme$base_name <- gsub("^([a-zA-Z0-9]+).*", "\\1", ab_enzyme$name)
ab_enzyme$base_ab <- as.ab(ab_enzyme$base_name)
colnames(ab_enzyme) <- c("enzyme_ab", "enzyme_name")
ab_enzyme$base_name <- gsub("^([a-zA-Z0-9]+).*", "\\1", ab_enzyme$enzyme_name)
ab_enzyme$base_ab <- antibiotics[match(ab_enzyme$base_name, antibiotics$name), "ab", drop = TRUE]
ab_enzyme <- subset(ab_enzyme, !is.na(base_ab))
# make ampicillin and amoxicillin interchangable
ampi <- subset(ab_enzyme, base_ab == "AMX")
ampi$base_ab <- "AMP"
ampi$base_name <- ab_name("AMP", language = NULL)
amox <- subset(ab_enzyme, base_ab == "AMP")
amox$base_ab <- "AMX"
amox$base_name <- ab_name("AMX", language = NULL)
# merge and sort
ab_enzyme <- rbind(ab_enzyme, ampi, amox)
ab_enzyme <- ab_enzyme[order(ab_enzyme$enzyme_name), ]
for (i in seq_len(nrow(ab_enzyme))) {
if (all(c(ab_enzyme[i, ]$ab, ab_enzyme[i, ]$base_ab) %in% names(cols_ab), na.rm = TRUE)) {
ab_name_base <- ab_name(cols_ab[ab_enzyme[i, ]$base_ab], language = NULL, tolower = TRUE)
ab_name_enzyme <- ab_name(cols_ab[ab_enzyme[i, ]$ab], language = NULL, tolower = TRUE)
# check if both base and base + enzyme inhibitor are part of the data set
if (all(c(ab_enzyme$base_ab[i], ab_enzyme$enzyme_ab[i]) %in% names(cols_ab), na.rm = TRUE)) {
col_base <- unname(cols_ab[ab_enzyme$base_ab[i]])
col_enzyme <- unname(cols_ab[ab_enzyme$enzyme_ab[i]])
# Set base to R where base + enzyme inhibitor is R ----
rule_current <- paste0("Set ", ab_name_base, " (", cols_ab[ab_enzyme[i, ]$base_ab], ") = R where ",
ab_name_enzyme, " (", cols_ab[ab_enzyme[i, ]$ab], ") = R")
rule_current <- paste0(ab_enzyme$base_name[i], " ('", font_bold(col_base), "') = R if ",
tolower(ab_enzyme$enzyme_name[i]), " ('", font_bold(col_enzyme), "') = R")
if (info == TRUE) {
cat(word_wrap(rule_current))
cat("\n")
cat(word_wrap(rule_current,
width = getOption("width") - 30,
extra_indent = 6))
}
run_changes <- edit_rsi(x = x,
col_mo = col_mo,
to = "R",
rule = c(rule_current, "Other rules", "",
paste0("Non-EUCAST: AMR package v", utils::packageDescription("AMR")$Version)),
rows = which(as.rsi_no_warning(x[, cols_ab[ab_enzyme[i, ]$ab]]) == "R"),
cols = cols_ab[ab_enzyme[i, ]$base_ab],
rows = which(as.rsi_no_warning(x[, col_enzyme, drop = TRUE]) == "R"),
cols = col_base,
last_verbose_info = verbose_info,
original_data = x.bak,
warned = warned,
@ -491,19 +505,21 @@ eucast_rules <- function(x,
}
# Set base + enzyme inhibitor to S where base is S ----
rule_current <- paste0("Set ", ab_name_enzyme, " (", cols_ab[ab_enzyme[i, ]$ab], ") = S where ",
ab_name_base, " (", cols_ab[ab_enzyme[i, ]$base_ab], ") = S")
rule_current <- paste0(ab_enzyme$enzyme_name[i], " ('", font_bold(col_enzyme), "') = S if ",
tolower(ab_enzyme$base_name[i]), " ('", font_bold(col_base), "') = S")
if (info == TRUE) {
cat(word_wrap(rule_current))
cat("\n")
cat(word_wrap(rule_current,
width = getOption("width") - 30,
extra_indent = 6))
}
run_changes <- edit_rsi(x = x,
col_mo = col_mo,
to = "S",
rule = c(rule_current, "Other rules", "",
paste0("Non-EUCAST: AMR package v", utils::packageDescription("AMR")$Version)),
rows = which(as.rsi_no_warning(x[, cols_ab[ab_enzyme[i, ]$base_ab]]) == "S"),
cols = cols_ab[ab_enzyme[i, ]$ab],
rows = which(as.rsi_no_warning(x[, col_base, drop = TRUE]) == "S"),
cols = col_enzyme,
last_verbose_info = verbose_info,
original_data = x.bak,
warned = warned,
@ -580,6 +596,14 @@ eucast_rules <- function(x,
rule_next <- eucast_rules_df[min(nrow(eucast_rules_df), i + 1), "reference.rule", drop = TRUE]
rule_group_previous <- eucast_rules_df[max(1, i - 1), "reference.rule_group", drop = TRUE]
rule_group_current <- eucast_rules_df[i, "reference.rule_group", drop = TRUE]
# don't apply rules if user doesn't want to apply them
if (rule_group_current %like% "breakpoint" & !any(c("all", "breakpoints") %in% rules)) {
next
}
if (rule_group_current %like% "expert" & !any(c("all", "expert") %in% rules)) {
next
}
if (isFALSE(info) | isFALSE(verbose)) {
rule_text <- ""
} else {
@ -600,14 +624,6 @@ eucast_rules <- function(x,
rule_next <- ""
}
# don't apply rules if user doesn't want to apply them
if (rule_group_current %like% "breakpoint" & !any(c("all", "breakpoints") %in% rules)) {
next
}
if (rule_group_current %like% "expert" & !any(c("all", "expert") %in% rules)) {
next
}
if (info == TRUE) {
# Print EUCAST intro ------------------------------------------------------
if (!rule_group_current %like% "other" & eucast_notification_shown == FALSE) {

16
R/first_isolate.R
View File

@ -34,7 +34,7 @@
#' @param col_testcode column name of the test codes. Use `col_testcode = NULL` to **not** exclude certain test codes (such as test codes for screening). In that case `testcodes_exclude` will be ignored.
#' @param col_specimen column name of the specimen type or group
#' @param col_icu column name of the logicals (`TRUE`/`FALSE`) whether a ward or department is an Intensive Care Unit (ICU)
#' @param col_keyantibiotics column name of the key antibiotics to determine first (weighted) isolates, see [key_antibiotics()]. Defaults to the first column that starts with 'key' followed by 'ab' or 'antibiotics' (case insensitive). Use `col_keyantibiotics = FALSE` to prevent this.
#' @param col_keyantibiotics column name of the key antibiotics to determine first (weighted) isolates, see [key_antibiotics()]. Defaults to the first column that starts with 'key' followed by 'ab' or 'antibiotics' (case insensitive). Use `col_keyantibiotics = FALSE` to prevent this. Can also be the output of [key_antibiotics()].
#' @param episode_days episode in days after which a genus/species combination will be determined as 'first isolate' again. The default of 365 days is based on the guideline by CLSI, see *Source*.
#' @param testcodes_exclude character vector with test codes that should be excluded (case-insensitive)
#' @param icu_exclude logical to indicate whether ICU isolates should be excluded (rows with value `TRUE` in the column set with `col_icu`)
@ -177,11 +177,17 @@ first_isolate <- function(x = NULL,
}
meet_criteria(col_specimen, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
meet_criteria(col_icu, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
if (isFALSE(col_keyantibiotics)) {
col_keyantibiotics <- NULL
if (length(col_keyantibiotics) > 1) {
meet_criteria(col_keyantibiotics, allow_class = "character", has_length = nrow(x))
x$keyabcol <- col_keyantibiotics
col_keyantibiotics <- "keyabcol"
} else {
if (isFALSE(col_keyantibiotics)) {
col_keyantibiotics <- NULL
}
meet_criteria(col_keyantibiotics, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
}
meet_criteria(col_keyantibiotics, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
meet_criteria(episode_days, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(episode_days, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = FALSE)
meet_criteria(testcodes_exclude, allow_class = "character", allow_NULL = TRUE)
meet_criteria(icu_exclude, allow_class = "logical", has_length = 1)
meet_criteria(specimen_group, allow_class = "character", has_length = 1, allow_NULL = TRUE)

38
R/key_antibiotics.R
View File

@ -173,10 +173,16 @@ key_antibiotics <- function(x = NULL,
# -- mo
if (is.null(col_mo)) {
col_mo <- search_type_in_df(x = x, type = "mo")
stop_if(is.null(col_mo), "`col_mo` must be set")
} else {
stop_ifnot(col_mo %in% colnames(x), "column '", col_mo, "' (`col_mo`) not found")
}
if (is.null(col_mo)) {
warning_("No column found for `col_mo`, ignoring antimicrobial agents set for Gram-negative and Gram-positive bacteria", call = FALSE)
x$gramstain <- NA_character_
} else {
x$gramstain <- mo_gramstain(as.mo(x[, col_mo, drop = TRUE]), language = NULL)
}
x$key_ab <- NA_character_
# check columns
col.list <- c(universal_1, universal_2, universal_3, universal_4, universal_5, universal_6,
@ -239,7 +245,7 @@ key_antibiotics <- function(x = NULL,
GramPos_4, GramPos_5, GramPos_6)
gram_positive <- gram_positive[!is.null(gram_positive)]
gram_positive <- gram_positive[!is.na(gram_positive)]
if (length(gram_positive) < 12 & message_not_thrown_before("key_antibiotics.grampos")) {
if (length(gram_positive) < 12 & !all(is.na(x$gramstain)) & message_not_thrown_before("key_antibiotics.grampos")) {
warning_("Only using ", length(gram_positive), " different antibiotics as key antibiotics for Gram-positives. See ?key_antibiotics.", call = FALSE)
remember_thrown_message("key_antibiotics.grampos")
}
@ -249,33 +255,29 @@ key_antibiotics <- function(x = NULL,
GramNeg_4, GramNeg_5, GramNeg_6)
gram_negative <- gram_negative[!is.null(gram_negative)]
gram_negative <- gram_negative[!is.na(gram_negative)]
if (length(gram_negative) < 12 & message_not_thrown_before("key_antibiotics.gramneg")) {
if (length(gram_negative) < 12 & !all(is.na(x$gramstain)) & message_not_thrown_before("key_antibiotics.gramneg")) {
warning_("Only using ", length(gram_negative), " different antibiotics as key antibiotics for Gram-negatives. See ?key_antibiotics.", call = FALSE)
remember_thrown_message("key_antibiotics.gramneg")
}
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_
# Gram +
x$key_ab <- pm_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)
tryCatch(apply(X = x[, gram_positive],
MARGIN = 1,
FUN = function(x) paste(x, collapse = "")),
error = function(e) paste0(rep(".", 12), collapse = "")),
as.character(x$key_ab))
# Gram -
x$key_ab <- pm_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)
tryCatch(apply(X = x[, gram_negative],
MARGIN = 1,
FUN = function(x) paste(x, collapse = "")),
error = function(e) paste0(rep(".", 12), collapse = "")),
as.character(x$key_ab))
# format
key_abs <- toupper(gsub("[^SIR]", ".", gsub("(NA|NULL)", ".", x$key_ab)))
key_abs <- toupper(gsub("(NA|NULL|[^RSIrsi])", ".", x$key_ab))
if (pm_n_distinct(key_abs) == 1) {
warning_("No distinct key antibiotics determined.", call = FALSE)