mirror of
https://github.com/msberends/AMR.git
synced 2025-07-09 04:42:22 +02:00
quasiquotation, alpha for geom_rsi
This commit is contained in:
41
R/count.R
41
R/count.R
@ -18,7 +18,7 @@
|
||||
|
||||
#' Count isolates
|
||||
#'
|
||||
#' @description These functions can be used to count resistant/susceptible microbial isolates. All functions can be used in \code{dplyr}s \code{\link[dplyr]{summarise}} and support grouped variables, see \emph{Examples}.
|
||||
#' @description These functions can be used to count resistant/susceptible microbial isolates. All functions support quasiquotation with pipes, can be used in \code{dplyr}s \code{\link[dplyr]{summarise}} and support grouped variables, see \emph{Examples}.
|
||||
#'
|
||||
#' \code{count_R} and \code{count_IR} can be used to count resistant isolates, \code{count_S} and \code{count_SI} can be used to count susceptible isolates.\cr
|
||||
#' @inheritParams portion
|
||||
@ -87,11 +87,9 @@
|
||||
#' group_by(hospital_id) %>%
|
||||
#' count_df(translate = FALSE)
|
||||
#'
|
||||
count_R <- function(ab1,
|
||||
ab2 = NULL) {
|
||||
rsi_calc(type = "R",
|
||||
ab1 = ab1,
|
||||
ab2 = ab2,
|
||||
count_R <- function(...) {
|
||||
rsi_calc(...,
|
||||
type = "R",
|
||||
include_I = FALSE,
|
||||
minimum = 0,
|
||||
as_percent = FALSE,
|
||||
@ -100,11 +98,9 @@ count_R <- function(ab1,
|
||||
|
||||
#' @rdname count
|
||||
#' @export
|
||||
count_IR <- function(ab1,
|
||||
ab2 = NULL) {
|
||||
rsi_calc(type = "R",
|
||||
ab1 = ab1,
|
||||
ab2 = ab2,
|
||||
count_IR <- function(...) {
|
||||
rsi_calc(...,
|
||||
type = "R",
|
||||
include_I = TRUE,
|
||||
minimum = 0,
|
||||
as_percent = FALSE,
|
||||
@ -113,10 +109,9 @@ count_IR <- function(ab1,
|
||||
|
||||
#' @rdname count
|
||||
#' @export
|
||||
count_I <- function(ab1) {
|
||||
rsi_calc(type = "I",
|
||||
ab1 = ab1,
|
||||
ab2 = NULL,
|
||||
count_I <- function(...) {
|
||||
rsi_calc(...,
|
||||
type = "I",
|
||||
include_I = FALSE,
|
||||
minimum = 0,
|
||||
as_percent = FALSE,
|
||||
@ -125,11 +120,9 @@ count_I <- function(ab1) {
|
||||
|
||||
#' @rdname count
|
||||
#' @export
|
||||
count_SI <- function(ab1,
|
||||
ab2 = NULL) {
|
||||
rsi_calc(type = "S",
|
||||
ab1 = ab1,
|
||||
ab2 = ab2,
|
||||
count_SI <- function(...) {
|
||||
rsi_calc(...,
|
||||
type = "S",
|
||||
include_I = TRUE,
|
||||
minimum = 0,
|
||||
as_percent = FALSE,
|
||||
@ -138,11 +131,9 @@ count_SI <- function(ab1,
|
||||
|
||||
#' @rdname count
|
||||
#' @export
|
||||
count_S <- function(ab1,
|
||||
ab2 = NULL) {
|
||||
rsi_calc(type = "S",
|
||||
ab1 = ab1,
|
||||
ab2 = ab2,
|
||||
count_S <- function(...) {
|
||||
rsi_calc(...,
|
||||
type = "S",
|
||||
include_I = FALSE,
|
||||
minimum = 0,
|
||||
as_percent = FALSE,
|
||||
|
||||
7
R/freq.R
7
R/freq.R
@ -55,9 +55,8 @@
|
||||
#' The function \code{top_freq} uses \code{\link[dplyr]{top_n}} internally and will include more than \code{n} rows if there are ties.
|
||||
#' @importFrom stats fivenum sd mad
|
||||
#' @importFrom grDevices boxplot.stats
|
||||
#' @importFrom dplyr %>% select pull n_distinct group_by arrange desc mutate summarise n_distinct
|
||||
#' @importFrom dplyr %>% select pull n_distinct group_by arrange desc mutate summarise n_distinct tibble
|
||||
#' @importFrom utils browseVignettes installed.packages
|
||||
#' @importFrom tibble tibble
|
||||
#' @keywords summary summarise frequency freq
|
||||
#' @rdname freq
|
||||
#' @name freq
|
||||
@ -378,12 +377,12 @@ frequency_tbl <- function(x,
|
||||
column_names_df <- c('item', 'count', 'percent', 'cum_count', 'cum_percent', 'factor_level')
|
||||
|
||||
if (any(class(x) == 'factor')) {
|
||||
df <- tibble::tibble(item = x,
|
||||
df <- tibble(item = x,
|
||||
fctlvl = x %>% as.integer()) %>%
|
||||
group_by(item, fctlvl)
|
||||
column_align <- c('l', 'r', 'r', 'r', 'r', 'r')
|
||||
} else {
|
||||
df <- tibble::tibble(item = x) %>%
|
||||
df <- tibble(item = x) %>%
|
||||
group_by(item)
|
||||
# strip factor lvl from col names
|
||||
column_names <- column_names[1:length(column_names) - 1]
|
||||
|
||||
@ -25,6 +25,7 @@
|
||||
#' @param fill variable to categorise using the plots legend, either \code{"Antibiotic"} (default) or \code{"Interpretation"} or a grouping variable
|
||||
#' @param facet variable to split plots by, either \code{"Interpretation"} (default) or \code{"Antibiotic"} or a grouping variable
|
||||
#' @param translate_ab a column name of the \code{\link{antibiotics}} data set to translate the antibiotic abbreviations into, using \code{\link{abname}}. Default behaviour is to translate to official names according to the WHO. Use \code{translate_ab = FALSE} to disable translation.
|
||||
#' @param alpha opacity of the fill colours
|
||||
#' @param fun function to transform \code{data}, either \code{\link{portion_df}} (default) or \code{\link{count_df}}
|
||||
#' @param ... other parameters passed on to \code{\link[ggplot2]{facet_wrap}}
|
||||
#' @details At default, the names of antibiotics will be shown on the plots using \code{\link{abname}}. This can be set with the option \code{get_antibiotic_names} (a logical value), so change it e.g. to \code{FALSE} with \code{options(get_antibiotic_names = FALSE)}.
|
||||
@ -113,6 +114,7 @@ ggplot_rsi <- function(data,
|
||||
fill = "Interpretation",
|
||||
facet = NULL,
|
||||
translate_ab = "official",
|
||||
alpha = 1,
|
||||
fun = portion_df,
|
||||
...) {
|
||||
|
||||
@ -126,7 +128,7 @@ ggplot_rsi <- function(data,
|
||||
}
|
||||
|
||||
p <- ggplot2::ggplot(data = data) +
|
||||
geom_rsi(position = position, x = x, fill = fill, translate_ab = translate_ab, fun = fun) +
|
||||
geom_rsi(position = position, x = x, fill = fill, translate_ab = translate_ab, alpha = alpha, fun = fun) +
|
||||
theme_rsi()
|
||||
|
||||
if (fill == "Interpretation") {
|
||||
@ -151,6 +153,7 @@ geom_rsi <- function(position = NULL,
|
||||
x = c("Antibiotic", "Interpretation"),
|
||||
fill = "Interpretation",
|
||||
translate_ab = "official",
|
||||
alpha = 1,
|
||||
fun = portion_df) {
|
||||
|
||||
fun_name <- deparse(substitute(fun))
|
||||
@ -180,7 +183,7 @@ geom_rsi <- function(position = NULL,
|
||||
|
||||
ggplot2::layer(geom = "bar", stat = "identity", position = position,
|
||||
mapping = ggplot2::aes_string(x = x, y = y, fill = fill),
|
||||
data = fun, params = list())
|
||||
data = fun, params = list(alpha = alpha))
|
||||
|
||||
}
|
||||
|
||||
|
||||
28
R/n_rsi.R
28
R/n_rsi.R
@ -18,10 +18,11 @@
|
||||
|
||||
#' Count cases with antimicrobial results
|
||||
#'
|
||||
#' This counts all cases where antimicrobial interpretations are available. Its use is equal to \code{\link{n_distinct}}.
|
||||
#' @param ab1,ab2 vector of antibiotic interpretations, they will be transformed internally with \code{\link{as.rsi}} if needed
|
||||
#' This counts all cases where antimicrobial interpretations are available. The way it can be used is equal to \code{\link{n_distinct}}. Its function is equal to \code{count_S(...) + count_IR(...)}.
|
||||
#' @inheritParams portion
|
||||
#' @export
|
||||
#' @seealso The \code{\link{portion}} functions to calculate resistance and susceptibility.
|
||||
#' @seealso \code{\link[AMR]{count}_*} to count resistant and susceptibile isolates per interpretation type.\cr
|
||||
#' \code{\link{portion}_*} to calculate microbial resistance and susceptibility.
|
||||
#' @examples
|
||||
#' library(dplyr)
|
||||
#'
|
||||
@ -33,22 +34,7 @@
|
||||
#' genta_n = n_rsi(gent),
|
||||
#' combination_p = portion_S(cipr, gent, as_percent = TRUE),
|
||||
#' combination_n = n_rsi(cipr, gent))
|
||||
n_rsi <- function(ab1, ab2 = NULL) {
|
||||
if (NCOL(ab1) > 1) {
|
||||
stop('`ab1` must be a vector of antimicrobial interpretations', call. = FALSE)
|
||||
}
|
||||
if (!is.rsi(ab1)) {
|
||||
ab1 <- as.rsi(ab1)
|
||||
}
|
||||
if (!is.null(ab2)) {
|
||||
if (NCOL(ab2) > 1) {
|
||||
stop('`ab2` must be a vector of antimicrobial interpretations', call. = FALSE)
|
||||
}
|
||||
if (!is.rsi(ab2)) {
|
||||
ab2 <- as.rsi(ab2)
|
||||
}
|
||||
sum(!is.na(ab1) & !is.na(ab2))
|
||||
} else {
|
||||
sum(!is.na(ab1))
|
||||
}
|
||||
n_rsi <- function(...) {
|
||||
# only print warnings once, if needed
|
||||
count_S(...) + suppressWarnings(count_IR(...))
|
||||
}
|
||||
|
||||
148
R/portion.R
148
R/portion.R
@ -18,11 +18,10 @@
|
||||
|
||||
#' Calculate resistance of isolates
|
||||
#'
|
||||
#' @description These functions can be used to calculate the (co-)resistance of microbial isolates (i.e. percentage S, SI, I, IR or R). All functions can be used in \code{dplyr}s \code{\link[dplyr]{summarise}} and support grouped variables, see \emph{Examples}.
|
||||
#' @description These functions can be used to calculate the (co-)resistance of microbial isolates (i.e. percentage S, SI, I, IR or R). All functions support quasiquotation with pipes, can be used in \code{dplyr}s \code{\link[dplyr]{summarise}} and support grouped variables, see \emph{Examples}.
|
||||
#'
|
||||
#' \code{portion_R} and \code{portion_IR} can be used to calculate resistance, \code{portion_S} and \code{portion_SI} can be used to calculate susceptibility.\cr
|
||||
#' @param ab1 vector of antibiotic interpretations, they will be transformed internally with \code{\link{as.rsi}} if needed
|
||||
#' @param ab2 like \code{ab}, a vector of antibiotic interpretations. Use this to calculate (the lack of) co-resistance: the probability where one of two drugs have a resistant or susceptible result. See Examples.
|
||||
#' @param ... one or more vectors (or columns) with antibiotic interpretations. They will be transformed internally with \code{\link{as.rsi}} if needed. Use multiple columns to calculate (the lack of) co-resistance: the probability where one of two drugs have a resistant or susceptible result. See Examples.
|
||||
#' @param minimum minimal amount of available isolates. Any number lower than \code{minimum} will return \code{NA}. The default number of \code{30} isolates is advised by the CLSI as best practice, see Source.
|
||||
#' @param as_percent logical to indicate whether the output must be returned as a hundred fold with \% sign (a character). A value of \code{0.123456} will then be returned as \code{"12.3\%"}.
|
||||
#' @param data a \code{data.frame} containing columns with class \code{rsi} (see \code{\link{as.rsi}})
|
||||
@ -43,8 +42,10 @@
|
||||
#' For two antibiotics:
|
||||
#' \out{<div style="text-align: center">}\figure{combi_therapy_2.png}\out{</div>}
|
||||
#' \cr
|
||||
#' Theoretically for three antibiotics:
|
||||
#' For three antibiotics:
|
||||
#' \out{<div style="text-align: center">}\figure{combi_therapy_3.png}\out{</div>}
|
||||
#' \cr
|
||||
#' And so on.
|
||||
#' }
|
||||
#' @source \strong{M39 Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data, 4th Edition}, 2014, \emph{Clinical and Laboratory Standards Institute (CLSI)}. \url{https://clsi.org/standards/products/microbiology/documents/m39/}.
|
||||
#'
|
||||
@ -68,11 +69,14 @@
|
||||
#' portion_S(septic_patients$amox)
|
||||
#' portion_SI(septic_patients$amox)
|
||||
#'
|
||||
#' # Since n_rsi counts available isolates (and is used as denominator),
|
||||
#' # you can calculate back to count e.g. non-susceptible isolates:
|
||||
#' portion_IR(septic_patients$amox) * n_rsi(septic_patients$amox)
|
||||
#'
|
||||
|
||||
#' # Do the above with pipes:
|
||||
#' library(dplyr)
|
||||
#' septic_patients %>% portion_R(amox)
|
||||
#' septic_patients %>% portion_IR(amox)
|
||||
#' septic_patients %>% portion_S(amox)
|
||||
#' septic_patients %>% portion_SI(amox)
|
||||
#'
|
||||
#' septic_patients %>%
|
||||
#' group_by(hospital_id) %>%
|
||||
#' summarise(p = portion_S(cipr),
|
||||
@ -88,16 +92,15 @@
|
||||
#'
|
||||
#' # Calculate co-resistance between amoxicillin/clav acid and gentamicin,
|
||||
#' # so we can see that combination therapy does a lot more than mono therapy:
|
||||
#' portion_S(septic_patients$amcl) # S = 67.3%
|
||||
#' n_rsi(septic_patients$amcl) # n = 1570
|
||||
#' septic_patients %>% portion_S(amcl) # S = 67.3%
|
||||
#' septic_patients %>% n_rsi(amcl) # n = 1570
|
||||
#'
|
||||
#' portion_S(septic_patients$gent) # S = 74.0%
|
||||
#' n_rsi(septic_patients$gent) # n = 1842
|
||||
#' septic_patients %>% portion_S(gent) # S = 74.0%
|
||||
#' septic_patients %>% n_rsi(gent) # n = 1842
|
||||
#'
|
||||
#' septic_patients %>% portion_S(amcl, gent) # S = 92.1%
|
||||
#' septic_patients %>% n_rsi(amcl, gent) # n = 1504
|
||||
#'
|
||||
#' with(septic_patients,
|
||||
#' portion_S(amcl, gent)) # S = 92.1%
|
||||
#' with(septic_patients, # n = 1504
|
||||
#' n_rsi(amcl, gent))
|
||||
#'
|
||||
#' septic_patients %>%
|
||||
#' group_by(hospital_id) %>%
|
||||
@ -129,13 +132,11 @@
|
||||
#' summarise(p = portion_S(amox, metr), # amoxicillin with metronidazole
|
||||
#' n = n_rsi(amox, metr))
|
||||
#' }
|
||||
portion_R <- function(ab1,
|
||||
ab2 = NULL,
|
||||
portion_R <- function(...,
|
||||
minimum = 30,
|
||||
as_percent = FALSE) {
|
||||
rsi_calc(type = "R",
|
||||
ab1 = ab1,
|
||||
ab2 = ab2,
|
||||
rsi_calc(...,
|
||||
type = "R",
|
||||
include_I = FALSE,
|
||||
minimum = minimum,
|
||||
as_percent = as_percent,
|
||||
@ -144,13 +145,11 @@ portion_R <- function(ab1,
|
||||
|
||||
#' @rdname portion
|
||||
#' @export
|
||||
portion_IR <- function(ab1,
|
||||
ab2 = NULL,
|
||||
portion_IR <- function(...,
|
||||
minimum = 30,
|
||||
as_percent = FALSE) {
|
||||
rsi_calc(type = "R",
|
||||
ab1 = ab1,
|
||||
ab2 = ab2,
|
||||
rsi_calc(...,
|
||||
type = "R",
|
||||
include_I = TRUE,
|
||||
minimum = minimum,
|
||||
as_percent = as_percent,
|
||||
@ -159,12 +158,11 @@ portion_IR <- function(ab1,
|
||||
|
||||
#' @rdname portion
|
||||
#' @export
|
||||
portion_I <- function(ab1,
|
||||
portion_I <- function(...,
|
||||
minimum = 30,
|
||||
as_percent = FALSE) {
|
||||
rsi_calc(type = "I",
|
||||
ab1 = ab1,
|
||||
ab2 = NULL,
|
||||
rsi_calc(...,
|
||||
type = "I",
|
||||
include_I = FALSE,
|
||||
minimum = minimum,
|
||||
as_percent = as_percent,
|
||||
@ -173,13 +171,11 @@ portion_I <- function(ab1,
|
||||
|
||||
#' @rdname portion
|
||||
#' @export
|
||||
portion_SI <- function(ab1,
|
||||
ab2 = NULL,
|
||||
portion_SI <- function(...,
|
||||
minimum = 30,
|
||||
as_percent = FALSE) {
|
||||
rsi_calc(type = "S",
|
||||
ab1 = ab1,
|
||||
ab2 = ab2,
|
||||
rsi_calc(...,
|
||||
type = "S",
|
||||
include_I = TRUE,
|
||||
minimum = minimum,
|
||||
as_percent = as_percent,
|
||||
@ -188,13 +184,11 @@ portion_SI <- function(ab1,
|
||||
|
||||
#' @rdname portion
|
||||
#' @export
|
||||
portion_S <- function(ab1,
|
||||
ab2 = NULL,
|
||||
portion_S <- function(...,
|
||||
minimum = 30,
|
||||
as_percent = FALSE) {
|
||||
rsi_calc(type = "S",
|
||||
ab1 = ab1,
|
||||
ab2 = ab2,
|
||||
rsi_calc(...,
|
||||
type = "S",
|
||||
include_I = FALSE,
|
||||
minimum = minimum,
|
||||
as_percent = as_percent,
|
||||
@ -257,77 +251,3 @@ portion_df <- function(data,
|
||||
|
||||
res
|
||||
}
|
||||
|
||||
rsi_calc <- function(type,
|
||||
ab1,
|
||||
ab2,
|
||||
include_I,
|
||||
minimum,
|
||||
as_percent,
|
||||
only_count) {
|
||||
|
||||
if (NCOL(ab1) > 1) {
|
||||
stop('`ab1` must be a vector of antimicrobial interpretations', call. = FALSE)
|
||||
}
|
||||
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)
|
||||
}
|
||||
|
||||
print_warning <- FALSE
|
||||
if (!is.rsi(ab1)) {
|
||||
ab1 <- as.rsi(ab1)
|
||||
print_warning <- TRUE
|
||||
}
|
||||
if (!is.null(ab2)) {
|
||||
# ab_name <- paste(deparse(substitute(ab1)), "and", deparse(substitute(ab2)))
|
||||
if (NCOL(ab2) > 1) {
|
||||
stop('`ab2` must be a vector of antimicrobial interpretations', call. = FALSE)
|
||||
}
|
||||
if (!is.rsi(ab2)) {
|
||||
ab2 <- as.rsi(ab2)
|
||||
print_warning <- TRUE
|
||||
}
|
||||
x <- apply(X = data.frame(ab1 = as.integer(ab1),
|
||||
ab2 = as.integer(ab2)),
|
||||
MARGIN = 1,
|
||||
FUN = min)
|
||||
} else {
|
||||
x <- ab1
|
||||
# ab_name <- deparse(substitute(ab1))
|
||||
}
|
||||
|
||||
if (print_warning == TRUE) {
|
||||
warning("Increase speed by transforming to class `rsi` on beforehand: df %>% mutate_at(vars(col10:col20), as.rsi)")
|
||||
}
|
||||
|
||||
if (type == "S") {
|
||||
found <- sum(as.integer(x) <= 1 + include_I, na.rm = TRUE)
|
||||
} else if (type == "I") {
|
||||
found <- sum(as.integer(x) == 2, na.rm = TRUE)
|
||||
} else if (type == "R") {
|
||||
found <- sum(as.integer(x) >= 3 - include_I, na.rm = TRUE)
|
||||
} else {
|
||||
stop("invalid type")
|
||||
}
|
||||
|
||||
if (only_count == TRUE) {
|
||||
return(found)
|
||||
}
|
||||
|
||||
total <- length(x) - sum(is.na(x))
|
||||
if (total < minimum) {
|
||||
return(NA)
|
||||
}
|
||||
|
||||
if (as_percent == TRUE) {
|
||||
percent(found / total, force_zero = TRUE)
|
||||
} else {
|
||||
found / total
|
||||
}
|
||||
}
|
||||
|
||||
20
R/rsi.R
20
R/rsi.R
@ -20,9 +20,10 @@
|
||||
#'
|
||||
#' This function is deprecated. Use the \code{\link{portion}} functions instead.
|
||||
#' @inheritParams portion
|
||||
#' @param ab1,ab2 vector (or column) with antibiotic interpretations. It will be transformed internally with \code{\link{as.rsi}} if needed.
|
||||
#' @param interpretation antimicrobial interpretation to check for
|
||||
#' @param ... deprecated parameters to support usage on older versions
|
||||
#' @importFrom dplyr case_when
|
||||
#' @importFrom dplyr tibble case_when
|
||||
#' @export
|
||||
rsi <- function(ab1,
|
||||
ab2 = NULL,
|
||||
@ -31,12 +32,19 @@ rsi <- function(ab1,
|
||||
as_percent = FALSE,
|
||||
...) {
|
||||
|
||||
if (all(is.null(ab2))) {
|
||||
df <- tibble(ab1 = ab1)
|
||||
} else {
|
||||
df <- tibble(ab1 = ab1,
|
||||
ab2 = ab2)
|
||||
}
|
||||
|
||||
result <- case_when(
|
||||
interpretation == "S" ~ portion_S(ab1 = ab1, ab2 = ab2, minimum = minimum, as_percent = FALSE),
|
||||
interpretation %in% c("SI", "IS") ~ portion_SI(ab1 = ab1, ab2 = ab2, minimum = minimum, as_percent = FALSE),
|
||||
interpretation == "I" ~ portion_I(ab1 = ab1, minimum = minimum, as_percent = FALSE),
|
||||
interpretation %in% c("RI", "IR") ~ portion_IR(ab1 = ab1, ab2 = ab2, minimum = minimum, as_percent = FALSE),
|
||||
interpretation == "R" ~ portion_R(ab1 = ab1, ab2 = ab2, minimum = minimum, as_percent = FALSE),
|
||||
interpretation == "S" ~ portion_S(df, minimum = minimum, as_percent = FALSE),
|
||||
interpretation %in% c("SI", "IS") ~ portion_SI(df, minimum = minimum, as_percent = FALSE),
|
||||
interpretation == "I" ~ portion_I(df, minimum = minimum, as_percent = FALSE),
|
||||
interpretation %in% c("RI", "IR") ~ portion_IR(df, minimum = minimum, as_percent = FALSE),
|
||||
interpretation == "R" ~ portion_R(df, minimum = minimum, as_percent = FALSE),
|
||||
TRUE ~ -1
|
||||
)
|
||||
if (result == -1) {
|
||||
|
||||
115
R/rsi_calc.R
Normal file
115
R/rsi_calc.R
Normal file
@ -0,0 +1,115 @@
|
||||
# ==================================================================== #
|
||||
# TITLE #
|
||||
# Antimicrobial Resistance (AMR) Analysis #
|
||||
# #
|
||||
# AUTHORS #
|
||||
# Berends MS (m.s.berends@umcg.nl), Luz CF (c.f.luz@umcg.nl) #
|
||||
# #
|
||||
# LICENCE #
|
||||
# This program is free software; you can redistribute it and/or modify #
|
||||
# it under the terms of the GNU General Public License version 2.0, #
|
||||
# as published by the Free Software Foundation. #
|
||||
# #
|
||||
# This program is distributed in the hope that it will be useful, #
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of #
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the #
|
||||
# GNU General Public License for more details. #
|
||||
# ==================================================================== #
|
||||
|
||||
#' @importFrom dplyr %>% bind_cols pull
|
||||
rsi_calc <- function(...,
|
||||
type,
|
||||
include_I,
|
||||
minimum,
|
||||
as_percent,
|
||||
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)
|
||||
}
|
||||
|
||||
dots_length <- ...length()
|
||||
dots <- ...elt(1) # it needs this evaluation
|
||||
dots <- rlang::exprs(...) # or this will be a list without actual values
|
||||
|
||||
if ("data.frame" %in% class(dots[[1]]) & dots_length > 1) {
|
||||
# data.frame passed with other columns, like:
|
||||
# septic_patients %>% portion_S(amcl, gent)
|
||||
df <- dots[[1]]
|
||||
dots_df <- data.frame(col1 = df[,1])
|
||||
for (i in 2:dots_length) {
|
||||
dots_col <- as.character(dots[[i]])
|
||||
if (!dots_col %in% colnames(df)) {
|
||||
stop("variable not found: ", dots_col)
|
||||
}
|
||||
dots_df <- dots_df %>% bind_cols(data.frame(df %>% pull(dots_col)))
|
||||
}
|
||||
x <- dots_df[, -1]
|
||||
} else if (dots_length == 1) {
|
||||
# only 1 variable passed (count also be data.frame), like:
|
||||
# portion_S(septic_patients$amcl)
|
||||
# septic_patients$amcl %>% portion_S()
|
||||
x <- dots[[1]]
|
||||
} else {
|
||||
# multiple variables passed without pipe, like:
|
||||
# portion_S(septic_patients$amcl, septic_patients$gent)
|
||||
# with(septic_patients, portion_S(amcl, gent))
|
||||
x <- as.data.frame(rlang::list2(...))
|
||||
}
|
||||
|
||||
print_warning <- FALSE
|
||||
# check integrity of columns: force rsi class
|
||||
if (is.data.frame(x)) {
|
||||
for (i in 1:ncol(x)) {
|
||||
if (!is.rsi(x %>% pull(i))) {
|
||||
x[, i] <- as.rsi(x[, i])
|
||||
print_warning <- TRUE
|
||||
}
|
||||
x[, i] <- x %>% pull(i) %>% as.integer()
|
||||
}
|
||||
x <- apply(X = x,
|
||||
MARGIN = 1,
|
||||
FUN = min)
|
||||
} else {
|
||||
if (!is.rsi(x)) {
|
||||
x <- as.rsi(x)
|
||||
print_warning <- TRUE
|
||||
}
|
||||
}
|
||||
|
||||
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 (type == "S") {
|
||||
found <- sum(as.integer(x) <= 1 + include_I, na.rm = TRUE)
|
||||
} else if (type == "I") {
|
||||
found <- sum(as.integer(x) == 2, na.rm = TRUE)
|
||||
} else if (type == "R") {
|
||||
found <- sum(as.integer(x) >= 3 - include_I, na.rm = TRUE)
|
||||
} else {
|
||||
stop("invalid type")
|
||||
}
|
||||
|
||||
if (only_count == TRUE) {
|
||||
return(found)
|
||||
}
|
||||
|
||||
total <- length(x) - sum(is.na(x))
|
||||
if (total < minimum) {
|
||||
return(NA)
|
||||
}
|
||||
|
||||
if (as_percent == TRUE) {
|
||||
percent(found / total, force_zero = TRUE)
|
||||
} else {
|
||||
found / total
|
||||
}
|
||||
}
|
||||
Reference in New Issue
Block a user