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

(v1.7.1.9031) dplyr grouping fix on windows?

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2021-08-30 14:07:46 +02:00
parent d6a916d70b
commit e6ce25162e
13 changed files with 80 additions and 62 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
R/aa_helper_functions.R
View File

@ -736,6 +736,7 @@ get_current_data <- function(arg_name, call) {
if (!is.null(cur_data_all)) {
out <- tryCatch(cur_data_all(), error = function(e) NULL)
if (is.data.frame(out)) {
messsage("==> RETURNING cur_data_all()")
return(structure(out, type = "dplyr_cur_data_all"))
}
}
@ -748,14 +749,17 @@ get_current_data <- function(arg_name, call) {
if (!is.null(env$`.data`) && is.data.frame(env$`.data`)) {
# an element `.data` will be in the environment when using `dplyr::select()`
# (but not when using `dplyr::filter()`, `dplyr::mutate()` or `dplyr::summarise()`)
messsage("==> RETURNING dplyr_selector")
return(structure(env$`.data`, type = "dplyr_selector"))
} else if (!is.null(env$xx) && is.data.frame(env$xx)) {
# an element `xx` will be in the environment for rows + cols, e.g. `example_isolates[c(1:3), carbapenems()]`
messsage("==> RETURNING base_R 1")
return(structure(env$xx, type = "base_R"))
} else if (!is.null(env$x) && is.data.frame(env$x)) {
# an element `x` will be in the environment for only cols, e.g. `example_isolates[, carbapenems()]`
messsage("==> RETURNING base_R 2")
return(structure(env$x, type = "base_R"))
}
}

46
R/first_isolate.R
View File

@ -23,9 +23,9 @@
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
#' Determine First (Weighted) Isolates
#' Determine First Isolates
#'
#' Determine first (weighted) isolates of all microorganisms of every patient per episode and (if needed) per specimen type. These functions support all four methods as summarised by Hindler *et al.* in 2007 (\doi{10.1086/511864}). To determine patient episodes not necessarily based on microorganisms, use [is_new_episode()] that also supports grouping with the `dplyr` package.
#' Determine first isolates of all microorganisms of every patient per episode and (if needed) per specimen type. These functions support all four methods as summarised by Hindler *et al.* in 2007 (\doi{10.1086/511864}). To determine patient episodes not necessarily based on microorganisms, use [is_new_episode()] that also supports [grouping with the `dplyr` package][dplyr::group_by()] .
#' @inheritSection lifecycle Stable Lifecycle
#' @param x a [data.frame] containing isolates. Can be left blank for automatic determination, see *Examples*.
#' @param col_date column name of the result date (or date that is was received on the lab), defaults to the first column with a date class
@ -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_keyantimicrobials (only useful when `method = "phenotype-based"`) column name of the key antimicrobials to determine first (weighted) isolates, see [key_antimicrobials()]. Defaults to the first column that starts with 'key' followed by 'ab' or 'antibiotics' or 'antimicrobials' (case insensitive). Use `col_keyantimicrobials = FALSE` to prevent this. Can also be the output of [key_antimicrobials()].
#' @param col_keyantimicrobials (only useful when `method = "phenotype-based"`) column name of the key antimicrobials to determine first isolates, see [key_antimicrobials()]. Defaults to the first column that starts with 'key' followed by 'ab' or 'antibiotics' or 'antimicrobials' (case insensitive). Use `col_keyantimicrobials = FALSE` to prevent this. Can also be the output of [key_antimicrobials()].
#' @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 a [character] vector with test codes that should be excluded (case-insensitive)
#' @param icu_exclude a [logical] to indicate whether ICU isolates should be excluded (rows with value `TRUE` in the column set with `col_icu`)
@ -102,9 +102,9 @@
#'
#' This is a more reliable method, since it also *weighs* the antibiogram (antimicrobial test results) yielding so-called 'first weighted isolates'. There are two different methods to weigh the antibiogram:
#'
#' 1. Using `type = "points"` and argument `points_threshold`
#' 1. Using `type = "points"` and argument `points_threshold` (default)
#'
#' This method weighs *all* antimicrobial agents available in the data set. Any difference from I to S or R (or vice versa) counts as 0.5 points, a difference from S to R (or vice versa) counts as 1 point. When the sum of points exceeds `points_threshold`, which defaults to `2`, an isolate will be selected as a first weighted isolate.
#' This method weighs *all* antimicrobial agents available in the data set. Any difference from I to S or R (or vice versa) counts as `0.5` points, a difference from S to R (or vice versa) counts as `1` point. When the sum of points exceeds `points_threshold`, which defaults to `2`, an isolate will be selected as a first weighted isolate.
#'
#' All antimicrobials are internally selected using the [all_antimicrobials()] function. The output of this function does not need to be passed to the [first_isolate()] function.
#'
@ -218,7 +218,7 @@ first_isolate <- function(x = NULL,
meet_criteria(col_icu, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
# method
method <- coerce_method(method)
meet_criteria(method, allow_class = "character", has_length = 1, is_in = c("phenotype-based", "episode-based", "patient-based", "isolate-based", "p", "e", "i"))
meet_criteria(method, allow_class = "character", has_length = 1, is_in = c("phenotype-based", "episode-based", "patient-based", "isolate-based"))
# key antimicrobials
if (length(col_keyantimicrobials) > 1) {
meet_criteria(col_keyantimicrobials, allow_class = "character", has_length = nrow(x))
@ -256,11 +256,11 @@ first_isolate <- function(x = NULL,
method <- "episode-based"
}
if (info == TRUE & message_not_thrown_before("first_isolate.method")) {
message_(paste0("Determining first isolates using the '", font_bold(method), "' method",
message_(paste0("Determining first isolates ",
ifelse(method %in% c("episode-based", "phenotype-based"),
ifelse(is.infinite(episode_days),
" without a specified episode length",
paste(" and an episode length of", episode_days, "days")),
"without a specified episode length",
paste("using an episode length of", episode_days, "days")),
"")),
as_note = FALSE,
add_fn = font_black)
@ -360,7 +360,7 @@ first_isolate <- function(x = NULL,
}
# remove testcodes
if (!is.null(testcodes_exclude) & info == TRUE & message_not_thrown_before("first_isolate.excludingtestcodes")) {
message_("Excluding test codes: ", toString(paste0("'", testcodes_exclude, "'")),
message_("Excluding test codes: ", vector_and(testcodes_exclude, quotes = TRUE),
add_fn = font_black,
as_note = FALSE)
}
@ -454,9 +454,7 @@ first_isolate <- function(x = NULL,
episode_days = episode_days),
use.names = FALSE)
weighted.notice <- ""
if (!is.null(col_keyantimicrobials)) {
weighted.notice <- "weighted "
if (info == TRUE & message_not_thrown_before("first_isolate.type")) {
if (type == "keyantimicrobials") {
message_("Basing inclusion on key antimicrobials, ",
@ -583,16 +581,16 @@ first_isolate <- function(x = NULL,
}
# mark up number of found
n_found <- format(n_found, big.mark = big.mark, decimal.mark = decimal.mark)
if (p_found_total != p_found_scope) {
msg_txt <- paste0("=> Found ",
font_bold(paste0(n_found, " first ", weighted.notice, "isolates")),
" (", method, ", ", p_found_scope, " within scope and ", p_found_total, " of total where a microbial ID was available)")
} else {
msg_txt <- paste0("=> Found ",
font_bold(paste0(n_found, " first ", weighted.notice, "isolates")),
" (", method, ", ", p_found_total, " of total where a microbial ID was available)")
}
message_(msg_txt, add_fn = font_black, as_note = FALSE)
message_(paste0("=> Found ",
font_bold(paste0(n_found,
ifelse(method == "isolate-based", "", paste0(" '", method, "'")),
" first isolates")),
" (",
ifelse(p_found_total != p_found_scope,
paste0(p_found_scope, " within scope and "),
""),
p_found_total, " of total where a microbial ID was available)"),
add_fn = font_black, as_note = FALSE)
}
x$newvar_first_isolate
@ -619,7 +617,7 @@ filter_first_isolate <- function(x = NULL,
meet_criteria(col_mo, 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 = FALSE)
method <- coerce_method(method)
meet_criteria(method, allow_class = "character", has_length = 1, is_in = c("phenotype-based", "episode-based", "patient-based", "isolate-based", "p", "e", "i"))
meet_criteria(method, allow_class = "character", has_length = 1, is_in = c("phenotype-based", "episode-based", "patient-based", "isolate-based"))
subset(x, first_isolate(x = x,
col_date = col_date,
@ -637,7 +635,7 @@ coerce_method <- function(method) {
method <- tolower(as.character(method[1L]))
method[method %like% "^(p$|pheno)"] <- "phenotype-based"
method[method %like% "^(e$|episode)"] <- "episode-based"
method[method %like% "^patient"] <- "patient-based"
method[method %like% "^pat"] <- "patient-based"
method[method %like% "^(i$|iso)"] <- "isolate-based"
method
}

22
R/guess_ab_col.R
View File

@ -179,7 +179,7 @@ get_column_abx <- function(x,
} else {
return(NA_character_)
}
})
}, USE.NAMES = FALSE)
x_columns <- x_columns[!is.na(x_columns)]
x <- x[, x_columns, drop = FALSE] # without drop = FALSE, x will become a vector when x_columns is length 1
@ -192,13 +192,27 @@ get_column_abx <- function(x,
# add from self-defined dots (...):
# such as get_column_abx(example_isolates %>% rename(thisone = AMX), amox = "thisone")
all_okay <- TRUE
dots <- list(...)
if (length(dots) > 0) {
newnames <- suppressWarnings(as.ab(names(dots), info = FALSE))
if (any(is.na(newnames))) {
warning_("Invalid antibiotic reference(s): ", toString(names(dots)[is.na(newnames)]),
if (info == TRUE) {
message_(" WARNING", add_fn = list(font_yellow, font_bold), as_note = FALSE)
}
warning_("Invalid antibiotic reference(s): ", vector_and(names(dots)[is.na(newnames)], quotes = FALSE),
call = FALSE,
immediate = TRUE)
all_okay <- FALSE
}
unexisting_cols <- which(!vapply(FUN.VALUE = logical(1), dots, function(col) all(col %in% x_columns)))
if (length(unexisting_cols) > 0) {
if (info == TRUE) {
message_(" ERROR", add_fn = list(font_red, font_bold), as_note = FALSE)
}
stop_("Column(s) not found: ", vector_and(unlist(dots[[unexisting_cols]]), quotes = FALSE),
call = FALSE)
all_okay <- FALSE
}
# turn all NULLs to NAs
dots <- unlist(lapply(dots, function(dot) if (is.null(dot)) NA else dot))
@ -211,7 +225,7 @@ get_column_abx <- function(x,
}
if (length(out) == 0) {
if (info == TRUE) {
if (info == TRUE & all_okay == TRUE) {
message_("No columns found.")
}
pkg_env$get_column_abx.call <- unique_call_id(entire_session = FALSE)
@ -232,7 +246,7 @@ get_column_abx <- function(x,
}
# succeeded with auto-guessing
if (info == TRUE) {
if (info == TRUE & all_okay == TRUE) {
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
}