mirror of
https://github.com/msberends/AMR.git
synced 2025-07-09 13:42:04 +02:00
(v1.3.0.9003) as.rsi() speed improvement
This commit is contained in:
@ -62,14 +62,12 @@ left_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
|
||||
if (length(by) == 1) {
|
||||
by <- rep(by, 2)
|
||||
}
|
||||
requires_suffix <- any(colnames(x) %in% colnames(y))
|
||||
if (requires_suffix == TRUE) {
|
||||
int_x <- colnames(x) %in% colnames(y) & colnames(x) != by[1]
|
||||
int_y <- colnames(y) %in% colnames(x) & colnames(y) != by[2]
|
||||
|
||||
colnames(x)[int_x] <- paste0(colnames(x)[int_x], suffix[1L])
|
||||
colnames(y)[int_y] <- paste0(colnames(y)[int_y], suffix[2L])
|
||||
}
|
||||
|
||||
int_x <- colnames(x) %in% colnames(y) & colnames(x) != by[1]
|
||||
int_y <- colnames(y) %in% colnames(x) & colnames(y) != by[2]
|
||||
colnames(x)[int_x] <- paste0(colnames(x)[int_x], suffix[1L])
|
||||
colnames(y)[int_y] <- paste0(colnames(y)[int_y], suffix[2L])
|
||||
|
||||
merged <- cbind(x,
|
||||
y[match(x[, by[1], drop = TRUE],
|
||||
y[, by[2], drop = TRUE]),
|
||||
|
1
R/data.R
1
R/data.R
@ -255,5 +255,4 @@ catalogue_of_life <- list(
|
||||
#' pull(microorganism)
|
||||
#' # [1] "Enterococcus casseliflavus" "Enterococcus gallinarum"
|
||||
#' }
|
||||
#' @seealso [intrinsic_resistant]
|
||||
"intrinsic_resistant"
|
||||
|
21
R/rsi.R
21
R/rsi.R
@ -311,7 +311,7 @@ as.rsi.mic <- function(x,
|
||||
stop_('No information was supplied about the microorganisms (missing parameter "mo"). See ?as.rsi.\n\n',
|
||||
"To transform certain columns with e.g. mutate_at(), use\n",
|
||||
"`data %>% mutate_at(vars(...), as.rsi, mo = .$x)`, where x is your column with microorganisms.\n\n",
|
||||
"To tranform all MIC variables in a data set, use `as.rsi(data)` or `data %>% as.rsi()`.", call = FALSE)
|
||||
"To tranform all MIC values in a data set, use `data %>% as.rsi()` or data %>% mutate_if(is.mic, as.rsi).", call = FALSE)
|
||||
}
|
||||
|
||||
ab_coerced <- suppressWarnings(as.ab(ab))
|
||||
@ -379,7 +379,7 @@ as.rsi.disk <- function(x,
|
||||
stop_('No information was supplied about the microorganisms (missing parameter "mo"). See ?as.rsi.\n\n',
|
||||
"To transform certain columns with e.g. mutate_at(), use\n",
|
||||
"`data %>% mutate_at(vars(...), as.rsi, mo = .$x)`, where x is your column with microorganisms.\n\n",
|
||||
"To tranform all disk diffusion zones in a data set, use `as.rsi(data)` or `data %>% as.rsi()`.", call = FALSE)
|
||||
"To tranform all disk diffusion zones in a data set, use `data %>% as.rsi()` or data %>% mutate_if(is.disk, as.rsi).", call = FALSE)
|
||||
}
|
||||
|
||||
ab_coerced <- suppressWarnings(as.ab(ab))
|
||||
@ -535,6 +535,11 @@ get_guideline <- function(guideline) {
|
||||
}
|
||||
|
||||
exec_as.rsi <- function(method, x, mo, ab, guideline, uti, conserve_capped_values) {
|
||||
x_bak <- data.frame(x_mo = paste0(x, mo))
|
||||
df <- unique(data.frame(x, mo), stringsAsFactors = FALSE)
|
||||
x <- df$x
|
||||
mo <- df$mo
|
||||
|
||||
if (method == "mic") {
|
||||
x <- as.mic(x) # when as.rsi.mic is called directly
|
||||
} else if (method == "disk") {
|
||||
@ -575,10 +580,10 @@ exec_as.rsi <- function(method, x, mo, ab, guideline, uti, conserve_capped_value
|
||||
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
|
||||
# no sebsetting to UTI for now
|
||||
subset(lookup %in% c(lookup_mo[i],
|
||||
lookup_genus[i],
|
||||
lookup_family[i],
|
||||
@ -591,7 +596,7 @@ exec_as.rsi <- function(method, x, mo, ab, guideline, uti, conserve_capped_value
|
||||
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
|
||||
arrange(desc(uti), desc(nchar(mo))) # 'uti' is a column in data set 'rsi_translation'
|
||||
} else {
|
||||
get_record <- get_record %>%
|
||||
filter(uti == FALSE) %>% # 'uti' is a column in rsi_translation
|
||||
@ -620,9 +625,15 @@ exec_as.rsi <- function(method, x, mo, ab, guideline, uti, conserve_capped_value
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
new_rsi <- x_bak %>%
|
||||
left_join(data.frame(x_mo = paste0(df$x, df$mo), new_rsi), by = "x_mo") %>%
|
||||
pull(new_rsi)
|
||||
|
||||
if (warned == FALSE) {
|
||||
message(font_green("OK."))
|
||||
}
|
||||
|
||||
structure(.Data = factor(new_rsi, levels = c("S", "I", "R"), ordered = TRUE),
|
||||
class = c("rsi", "ordered", "factor"))
|
||||
}
|
||||
|
Reference in New Issue
Block a user