AMR/R/rsi_calc.R

238 lines
8.2 KiB
R
Raw Normal View History

2018-08-23 00:40:36 +02:00
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Analysis #
# #
2019-01-02 23:24:07 +01:00
# SOURCE #
# https://gitlab.com/msberends/AMR #
2018-08-23 00:40:36 +02:00
# #
# LICENCE #
2019-01-02 23:24:07 +01:00
# (c) 2019 Berends MS (m.s.berends@umcg.nl), Luz CF (c.f.luz@umcg.nl) #
2018-08-23 00:40:36 +02:00
# #
2019-01-02 23:24:07 +01:00
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
# GNU General Public License version 2.0 (GNU GPL-2), as published by #
# the Free Software Foundation. #
# #
# This R package was created for academic research and was publicly #
# released in the hope that it will be useful, but it comes WITHOUT #
# ANY WARRANTY OR LIABILITY. #
2019-04-05 18:47:39 +02:00
# Visit our website for more info: https://msberends.gitlab.io/AMR. #
2018-08-23 00:40:36 +02:00
# ==================================================================== #
#' @importFrom dplyr %>% pull all_vars any_vars filter_all funs mutate_all
2018-08-23 00:40:36 +02:00
rsi_calc <- function(...,
type,
include_I,
minimum,
as_percent,
also_single_tested,
2018-08-23 00:40:36 +02:00
only_count) {
if (!is.logical(include_I)) {
stop('`include_I` must be logical', call. = FALSE)
}
if (!is.numeric(minimum)) {
stop('`minimum` must be numeric', call. = FALSE)
}
if (!is.logical(as_percent)) {
stop('`as_percent` must be logical', call. = FALSE)
}
if (!is.logical(also_single_tested)) {
stop('`also_single_tested` must be logical', call. = FALSE)
}
2018-08-23 00:40:36 +02:00
dots_df <- ...elt(1) # it needs this evaluation
dots <- base::eval(base::substitute(base::alist(...)))
ndots <- length(dots)
2018-08-23 00:40:36 +02:00
if ("data.frame" %in% class(dots_df)) {
# data.frame passed with other columns, like:
# septic_patients %>% portion_S(amcl, gent)
dots <- as.character(dots)
dots <- dots[dots != "."]
if (length(dots) == 0 | all(dots == "df")) {
# for complete data.frames, like septic_patients %>% select(amcl, gent) %>% portion_S()
# and the old rsi function, that has "df" as name of the first parameter
x <- dots_df
} else {
x <- dots_df[, dots]
2018-08-23 00:40:36 +02:00
}
} else if (ndots == 1) {
# only 1 variable passed (can also be data.frame), like:
2018-08-23 00:40:36 +02:00
# portion_S(septic_patients$amcl)
# septic_patients$amcl %>% portion_S()
x <- dots_df
2018-08-23 00:40:36 +02:00
} else {
# multiple variables passed without pipe, like:
# portion_S(septic_patients$amcl, septic_patients$gent)
x <- NULL
try(x <- as.data.frame(dots), silent = TRUE)
if (is.null(x)) {
# support for: with(septic_patients, portion_S(amcl, gent))
x <- as.data.frame(rlang::list2(...))
}
2018-08-23 00:40:36 +02:00
}
2019-05-10 16:44:59 +02:00
if (is.null(x)) {
warning("argument is NULL (check if columns exist): returning NA", call. = FALSE)
return(NA)
}
2018-08-23 00:40:36 +02:00
print_warning <- FALSE
type_trans <- as.integer(as.rsi(type))
2018-12-22 22:39:34 +01:00
type_others <- base::setdiff(1:3, type_trans)
2018-08-23 00:40:36 +02:00
if (is.data.frame(x)) {
rsi_integrity_check <- character(0)
2018-08-23 00:40:36 +02:00
for (i in 1:ncol(x)) {
# check integrity of columns: force rsi class
2018-08-23 00:40:36 +02:00
if (!is.rsi(x %>% pull(i))) {
rsi_integrity_check <- c(rsi_integrity_check, x %>% pull(i) %>% as.character())
x[, i] <- suppressWarnings(as.rsi(x[, i])) # warning will be given later
2018-08-23 00:40:36 +02:00
print_warning <- TRUE
}
x[, i] <- x %>% pull(i) %>% as.integer()
}
if (length(rsi_integrity_check) > 0) {
# this will give a warning for invalid results, of all input columns (so only 1 warning)
rsi_integrity_check <- as.rsi(rsi_integrity_check)
}
if (include_I == TRUE) {
x <- x %>% mutate_all(funs(ifelse(. == 2, type_trans, .)))
}
if (also_single_tested == TRUE) {
# THE CHANCE THAT AT LEAST ONE RESULT IS type
found <- x %>% filter_all(any_vars(. == type_trans)) %>% nrow()
# THE CHANCE THAT AT LEAST ONE RESULT IS type OR ALL ARE TESTED
total <- found + x %>% filter_all(all_vars(. %in% type_others)) %>% nrow()
} else {
x <- apply(X = x,
MARGIN = 1,
FUN = min)
found <- sum(as.integer(x) == type_trans, na.rm = TRUE)
total <- length(x) - sum(is.na(x))
}
2018-08-23 00:40:36 +02:00
} else {
if (!is.rsi(x)) {
x <- as.rsi(x)
print_warning <- TRUE
}
x <- as.integer(x)
if (include_I == TRUE) {
x[x == 2] <- type_trans
}
found <- sum(x == type_trans, na.rm = TRUE)
total <- length(x) - sum(is.na(x))
2018-08-23 00:40:36 +02:00
}
if (print_warning == TRUE) {
warning("Increase speed by transforming to class `rsi` on beforehand: df %>% mutate_if(is.rsi.eligible, as.rsi)",
call. = FALSE)
}
if (only_count == TRUE) {
return(found)
}
if (total < minimum) {
2018-10-12 16:35:18 +02:00
warning("Introducing NA: only ", total, " results available (minimum set to ", minimum, ").", call. = FALSE)
result <- NA
} else {
result <- found / total
2018-08-23 00:40:36 +02:00
}
if (as_percent == TRUE) {
2018-10-12 16:35:18 +02:00
percent(result, force_zero = TRUE)
2018-08-23 00:40:36 +02:00
} else {
2018-10-12 16:35:18 +02:00
result
2018-08-23 00:40:36 +02:00
}
}
2019-05-13 10:10:16 +02:00
rsi_calc_df <- function(type, # "portion" or "count"
data,
translate_ab = "name",
language = get_locale(),
minimum = 30,
as_percent = FALSE,
combine_SI = TRUE,
combine_IR = FALSE,
combine_SI_missing = FALSE) {
if (!"data.frame" %in% class(data)) {
stop(paste0("`", type, "_df` must be called on a data.frame"), call. = FALSE)
}
if (isTRUE(combine_IR) & isTRUE(combine_SI_missing)) {
combine_SI <- FALSE
}
if (isTRUE(combine_SI) & isTRUE(combine_IR)) {
stop("either `combine_SI` or `combine_IR` can be TRUE", call. = FALSE)
}
if (data %>% select_if(is.rsi) %>% ncol() == 0) {
stop("No columns with class 'rsi' found. See ?as.rsi.", call. = FALSE)
}
if (as.character(translate_ab) %in% c("TRUE", "official")) {
translate_ab <- "name"
}
get_summaryfunction <- function(int) {
# look for portion_S, count_S, etc:
int_fn <- get(paste0(type, "_", int), envir = asNamespace("AMR"))
if (type == "portion") {
summ <- summarise_if(.tbl = data,
.predicate = is.rsi,
.funs = int_fn,
minimum = minimum,
as_percent = as_percent)
} else if (type == "count") {
summ <- summarise_if(.tbl = data,
.predicate = is.rsi,
.funs = int_fn)
}
summ %>%
mutate(Interpretation = int) %>%
select(Interpretation, everything())
}
resS <- get_summaryfunction("S")
resI <- get_summaryfunction("I")
resR <- get_summaryfunction("R")
resSI <- get_summaryfunction("SI")
resIR <- get_summaryfunction("IR")
data.groups <- group_vars(data)
if (isFALSE(combine_SI) & isFALSE(combine_IR)) {
res <- bind_rows(resS, resI, resR) %>%
mutate(Interpretation = factor(Interpretation,
levels = c("S", "I", "R"),
ordered = TRUE))
} else if (isTRUE(combine_IR)) {
res <- bind_rows(resS, resIR) %>%
mutate(Interpretation = factor(Interpretation,
levels = c("S", "IR"),
ordered = TRUE))
} else if (isTRUE(combine_SI)) {
res <- bind_rows(resSI, resR) %>%
mutate(Interpretation = factor(Interpretation,
levels = c("SI", "R"),
ordered = TRUE))
}
res <- res %>%
tidyr::gather(Antibiotic, Value, -Interpretation, -data.groups)
if (!translate_ab == FALSE) {
res <- res %>% mutate(Antibiotic = ab_property(Antibiotic, property = translate_ab, language = language))
}
res
}