# ==================================================================== # # TITLE # # Antimicrobial Resistance (AMR) Data Analysis for R # # # # SOURCE # # https://github.com/msberends/AMR # # # # LICENCE # # (c) 2018-2021 Berends MS, Luz CF et al. # # Developed at the University of Groningen, the Netherlands, in # # collaboration with non-profit organisations Certe Medical # # Diagnostics & Advice, and University Medical Center Groningen. # # # # 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. # # We created this package for both routine data analysis and academic # # research and it was publicly released in the hope that it will be # # useful, but it comes WITHOUT ANY WARRANTY OR LIABILITY. # # # # Visit our website for the full manual and a complete tutorial about # # how to conduct AMR data analysis: https://msberends.github.io/AMR/ # # ==================================================================== # #' Transform Input to Minimum Inhibitory Concentrations (MIC) #' #' This ransforms vectors to a new class [`mic`], which treats the input as decimal numbers, while maintaining operators (such as ">=") and only allowing valid MIC values known to the field of (medical) microbiology. #' @inheritSection lifecycle Stable Lifecycle #' @rdname as.mic #' @param x character or numeric vector #' @param na.rm a logical indicating whether missing values should be removed #' @details To interpret MIC values as RSI values, use [as.rsi()] on MIC values. It supports guidelines from EUCAST and CLSI. #' #' This class for MIC values is a quite a special data type: formally it is an ordered factor with valid MIC values as factor levels (to make sure only valid MIC values are retained), but for any mathematical operation it acts as decimal numbers: #' #' ``` #' x <- random_mic(10) #' x #' #> Class #' #> [1] 16 1 8 8 64 >=128 0.0625 32 32 16 #' #' is.factor(x) #' #> [1] TRUE #' #' x[1] * 2 #' #> [1] 32 #' #' median(x) #' #> [1] 26 #' ``` #' #' This makes it possible to maintain operators that often come with MIC values, such ">=" and "<=", even when filtering using numeric values in data analysis, e.g.: #' #' ``` #' x[x > 4] #' #> Class #' #> [1] 16 8 8 64 >=128 32 32 16 #' #' df <- data.frame(x, hospital = "A") #' subset(df, x > 4) # or with dplyr: df %>% filter(x > 4) #' #> x hospital #' #> 1 16 A #' #> 5 64 A #' #> 6 >=128 A #' #> 8 32 A #' #> 9 32 A #' #> 10 16 A #' ``` #' #' The following [generic functions][groupGeneric()] are implemented for the MIC class: `!`, `!=`, `%%`, `%/%`, `&`, `*`, `+`, `-`, `/`, `<`, `<=`, `==`, `>`, `>=`, `^`, `|`, [abs()], [acos()], [acosh()], [all()], [any()], [asin()], [asinh()], [atan()], [atanh()], [ceiling()], [cos()], [cosh()], [cospi()], [cummax()], [cummin()], [cumprod()], [cumsum()], [digamma()], [exp()], [expm1()], [floor()], [gamma()], [lgamma()], [log()], [log1p()], [log2()], [log10()], [max()], [mean()], [min()], [prod()], [range()], [round()], [sign()], [signif()], [sin()], [sinh()], [sinpi()], [sqrt()], [sum()], [tan()], [tanh()], [tanpi()], [trigamma()] and [trunc()]. Some functions of the `stats` package are also implemented: [median()], [quantile()], [mad()], [IQR()], [fivenum()]. Also, [boxplot.stats()] is supported. Since [sd()] and [var()] are non-generic functions, these could not be extended. Use [mad()] as an alternative, or use e.g. `sd(as.numeric(x))` where `x` is your vector of MIC values. #' @return Ordered [factor] with additional class [`mic`], that in mathematical operations acts as decimal numbers. Bare in mind that the outcome of any mathematical operation on MICs will return a numeric value. #' @aliases mic #' @export #' @seealso [as.rsi()] #' @inheritSection AMR Read more on Our Website! #' @examples #' mic_data <- as.mic(c(">=32", "1.0", "1", "1.00", 8, "<=0.128", "8", "16", "16")) #' is.mic(mic_data) #' #' # this can also coerce combined MIC/RSI values: #' as.mic("<=0.002; S") # will return <=0.002 #' #' # mathematical processing treats MICs as numeric values #' fivenum(mic_data) #' quantile(mic_data) #' all(mic_data < 512) #' #' # interpret MIC values #' as.rsi(x = as.mic(2), #' mo = as.mo("S. pneumoniae"), #' ab = "AMX", #' guideline = "EUCAST") #' as.rsi(x = as.mic(4), #' mo = as.mo("S. pneumoniae"), #' ab = "AMX", #' guideline = "EUCAST") #' #' # plot MIC values, see ?plot #' plot(mic_data) #' plot(mic_data, mo = "E. coli", ab = "cipro") as.mic <- function(x, na.rm = FALSE) { meet_criteria(x, allow_class = c("mic", "character", "numeric", "integer", "factor"), allow_NA = TRUE) meet_criteria(na.rm, allow_class = "logical", has_length = 1) if (is.mic(x)) { x } else { x <- as.character(unlist(x)) if (na.rm == TRUE) { x <- x[!is.na(x)] } x.bak <- x # comma to period x <- gsub(",", ".", x, fixed = TRUE) # transform Unicode for >= and <= x <- gsub("\u2264", "<=", x, fixed = TRUE) x <- gsub("\u2265", ">=", x, fixed = TRUE) # remove space between operator and number ("<= 0.002" -> "<=0.002") x <- gsub("(<|=|>) +", "\\1", x, perl = TRUE) # transform => to >= and =< to <= x <- gsub("=<", "<=", x, fixed = TRUE) x <- gsub("=>", ">=", x, fixed = TRUE) # dots without a leading zero must start with 0 x <- gsub("([^0-9]|^)[.]", "\\10.", x, perl = TRUE) # values like "<=0.2560.512" should be 0.512 x <- gsub(".*[.].*[.]", "0.", x, perl = TRUE) # remove ending .0 x <- gsub("[.]+0$", "", x, perl = TRUE) # remove all after last digit x <- gsub("[^0-9]+$", "", x, perl = TRUE) # keep only one zero before dot x <- gsub("0+[.]", "0.", x, perl = TRUE) # starting 00 is probably 0.0 if there's no dot yet x[x %unlike% "[.]"] <- gsub("^00", "0.0", x[!x %like% "[.]"]) # remove last zeroes x <- gsub("([.].?)0+$", "\\1", x, perl = TRUE) x <- gsub("(.*[.])0+$", "\\10", x, perl = TRUE) # remove ending .0 again x[x %like% "[.]"] <- gsub("0+$", "", x[x %like% "[.]"]) # never end with dot x <- gsub("[.]$", "", x, perl = TRUE) # force to be character x <- as.character(x) # trim it x <- trimws(x) ## previously unempty values now empty - should return a warning later on x[x.bak != "" & x == ""] <- "invalid" # these are allowed MIC values and will become factor levels ops <- c("<", "<=", "", ">=", ">") lvls <- c(c(t(vapply(FUN.VALUE = character(9), ops, function(x) paste0(x, "0.00", 1:9)))), unique(c(t(vapply(FUN.VALUE = character(104), ops, function(x) paste0(x, sort(as.double(paste0("0.0", sort(c(1:99, 125, 128, 256, 512, 625)))))))))), unique(c(t(vapply(FUN.VALUE = character(103), ops, function(x) paste0(x, sort(as.double(paste0("0.", c(1:99, 125, 128, 256, 512))))))))), c(t(vapply(FUN.VALUE = character(10), ops, function(x) paste0(x, sort(c(1:9, 1.5)))))), c(t(vapply(FUN.VALUE = character(45), ops, function(x) paste0(x, c(10:98)[9:98 %% 2 == TRUE])))), c(t(vapply(FUN.VALUE = character(15), ops, function(x) paste0(x, sort(c(2 ^ c(7:10), 80 * c(2:12)))))))) na_before <- x[is.na(x) | x == ""] %pm>% length() x[!x %in% lvls] <- NA na_after <- x[is.na(x) | x == ""] %pm>% length() if (na_before != na_after) { list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ""] %pm>% unique() %pm>% sort() %pm>% vector_and(quotes = TRUE) warning_(na_after - na_before, " results truncated (", round(((na_after - na_before) / length(x)) * 100), "%) that were invalid MICs: ", list_missing, call = FALSE) } set_clean_class(factor(x, levels = lvls, ordered = TRUE), new_class = c("mic", "ordered", "factor")) } } all_valid_mics <- function(x) { if (!inherits(x, c("mic", "character", "factor", "numeric", "integer"))) { return(FALSE) } x_mic <- tryCatch(suppressWarnings(as.mic(x[!is.na(x)])), error = function(e) NA) !any(is.na(x_mic)) && !all(is.na(x)) } #' @rdname as.mic #' @export is.mic <- function(x) { inherits(x, "mic") } #' @method as.double mic #' @export #' @noRd as.double.mic <- function(x, ...) { as.double(gsub("[<=>]+", "", as.character(x), perl = TRUE)) } #' @method as.integer mic #' @export #' @noRd as.integer.mic <- function(x, ...) { as.integer(gsub("[<=>]+", "", as.character(x), perl = TRUE)) } #' @method as.numeric mic #' @export #' @noRd as.numeric.mic <- function(x, ...) { as.numeric(gsub("[<=>]+", "", as.character(x), perl = TRUE)) } #' @method droplevels mic #' @export #' @noRd droplevels.mic <- function(x, exclude = if (any(is.na(levels(x)))) NULL else NA, as.mic = TRUE, ...) { x <- droplevels.factor(x, exclude = exclude, ...) if (as.mic == TRUE) { class(x) <- c("mic", "ordered", "factor") } x } # will be exported using s3_register() in R/zzz.R pillar_shaft.mic <- function(x, ...) { crude_numbers <- as.double(x) operators <- gsub("[^<=>]+", "", as.character(x)) pasted <- trimws(paste0(operators, trimws(format(crude_numbers)))) out <- pasted out[is.na(x)] <- font_na(NA) out <- gsub("(<|=|>)", font_silver("\\1"), out) out <- gsub("([.]?0+)$", font_white("\\1"), out) create_pillar_column(out, align = "right", width = max(nchar(pasted))) } # will be exported using s3_register() in R/zzz.R type_sum.mic <- function(x, ...) { "mic" } #' @method print mic #' @export #' @noRd print.mic <- function(x, ...) { cat("Class \n") print(as.character(x), quote = FALSE) att <- attributes(x) if ("na.action" %in% names(att)) { cat(font_silver(paste0("(NA ", class(att$na.action), ": ", paste0(att$na.action, collapse = ", "), ")\n"))) } } #' @method summary mic #' @export #' @noRd summary.mic <- function(object, ...) { summary(as.double(object), ...) } #' @method as.matrix mic #' @export #' @noRd as.matrix.mic <- function(x, ...) { as.matrix(as.double(x), ...) } #' @method [ mic #' @export #' @noRd "[.mic" <- function(x, ...) { y <- NextMethod() attributes(y) <- attributes(x) y } #' @method [[ mic #' @export #' @noRd "[[.mic" <- function(x, ...) { y <- NextMethod() attributes(y) <- attributes(x) y } #' @method [<- mic #' @export #' @noRd "[<-.mic" <- function(i, j, ..., value) { value <- as.mic(value) y <- NextMethod() attributes(y) <- attributes(i) y } #' @method [[<- mic #' @export #' @noRd "[[<-.mic" <- function(i, j, ..., value) { value <- as.mic(value) y <- NextMethod() attributes(y) <- attributes(i) y } #' @method c mic #' @export #' @noRd c.mic <- function(...) { as.mic(unlist(lapply(list(...), as.character))) } #' @method unique mic #' @export #' @noRd unique.mic <- function(x, incomparables = FALSE, ...) { y <- NextMethod() attributes(y) <- attributes(x) y } #' @method sort mic #' @export #' @noRd sort.mic <- function(x, decreasing = FALSE, ...) { if (decreasing == TRUE) { ord <- order(-as.double(x)) } else { ord <- order(as.double(x)) } x[ord] } #' @method hist mic #' @importFrom graphics hist #' @export #' @noRd hist.mic <- function(x, ...) { warning_("Use `plot()` or `ggplot()` for optimal plotting of MIC values", call = FALSE) hist(log2(x)) } # will be exported using s3_register() in R/zzz.R get_skimmers.mic <- function(column) { skimr::sfl( skim_type = "mic", min = ~min(., na.rm = TRUE), max = ~max(., na.rm = TRUE), median = ~stats::median(., na.rm = TRUE), n_unique = ~pm_n_distinct(., na.rm = TRUE), hist_log2 = ~skimr::inline_hist(log2(stats::na.omit(.))) ) } # Miscellaneous mathematical functions ------------------------------------ #' @method mean mic #' @export #' @noRd mean.mic <- function(x, trim = 0, na.rm = FALSE, ...) { mean(as.double(x), trim = trim, na.rm = na.rm, ...) } #' @method median mic #' @importFrom stats median #' @export #' @noRd median.mic <- function(x, na.rm = FALSE, ...) { median(as.double(x), na.rm = na.rm, ...) } #' @method quantile mic #' @importFrom stats quantile #' @export #' @noRd quantile.mic <- function(x, probs = seq(0, 1, 0.25), na.rm = FALSE, names = TRUE, type = 7, ...) { quantile(as.double(x), probs = probs, na.rm = na.rm, names = names, type = type, ...) } # Math (see ?groupGeneric) ---------------------------------------------- #' @method abs mic #' @export #' @noRd abs.mic <- function(x) { abs(as.double(x)) } #' @method sign mic #' @export #' @noRd sign.mic <- function(x) { sign(as.double(x)) } #' @method sqrt mic #' @export #' @noRd sqrt.mic <- function(x) { sqrt(as.double(x)) } #' @method floor mic #' @export #' @noRd floor.mic <- function(x) { floor(as.double(x)) } #' @method ceiling mic #' @export #' @noRd ceiling.mic <- function(x) { ceiling(as.double(x)) } #' @method trunc mic #' @export #' @noRd trunc.mic <- function(x, ...) { trunc(as.double(x), ...) } #' @method round mic #' @export #' @noRd round.mic <- function(x, digits = 0) { round(as.double(x), digits = digits) } #' @method signif mic #' @export #' @noRd signif.mic <- function(x, digits = 6) { signif(as.double(x), digits = digits) } #' @method exp mic #' @export #' @noRd exp.mic <- function(x) { exp(as.double(x)) } #' @method log mic #' @export #' @noRd log.mic <- function(x, base = exp(1)) { log(as.double(x), base = base) } #' @method log10 mic #' @export #' @noRd log10.mic <- function(x) { log10(as.double(x)) } #' @method log2 mic #' @export #' @noRd log2.mic <- function(x) { log2(as.double(x)) } #' @method expm1 mic #' @export #' @noRd expm1.mic <- function(x) { expm1(as.double(x)) } #' @method log1p mic #' @export #' @noRd log1p.mic <- function(x) { log1p(as.double(x)) } #' @method cos mic #' @export #' @noRd cos.mic <- function(x) { cos(as.double(x)) } #' @method sin mic #' @export #' @noRd sin.mic <- function(x) { sin(as.double(x)) } #' @method tan mic #' @export #' @noRd tan.mic <- function(x) { tan(as.double(x)) } #' @method cospi mic #' @export #' @noRd cospi.mic <- function(x) { cospi(as.double(x)) } #' @method sinpi mic #' @export #' @noRd sinpi.mic <- function(x) { sinpi(as.double(x)) } #' @method tanpi mic #' @export #' @noRd tanpi.mic <- function(x) { tanpi(as.double(x)) } #' @method acos mic #' @export #' @noRd acos.mic <- function(x) { acos(as.double(x)) } #' @method asin mic #' @export #' @noRd asin.mic <- function(x) { asin(as.double(x)) } #' @method atan mic #' @export #' @noRd atan.mic <- function(x) { atan(as.double(x)) } #' @method cosh mic #' @export #' @noRd cosh.mic <- function(x) { cosh(as.double(x)) } #' @method sinh mic #' @export #' @noRd sinh.mic <- function(x) { sinh(as.double(x)) } #' @method tanh mic #' @export #' @noRd tanh.mic <- function(x) { tanh(as.double(x)) } #' @method acosh mic #' @export #' @noRd acosh.mic <- function(x) { acosh(as.double(x)) } #' @method asinh mic #' @export #' @noRd asinh.mic <- function(x) { asinh(as.double(x)) } #' @method atanh mic #' @export #' @noRd atanh.mic <- function(x) { atanh(as.double(x)) } #' @method lgamma mic #' @export #' @noRd lgamma.mic <- function(x) { lgamma(as.double(x)) } #' @method gamma mic #' @export #' @noRd gamma.mic <- function(x) { gamma(as.double(x)) } #' @method digamma mic #' @export #' @noRd digamma.mic <- function(x) { digamma(as.double(x)) } #' @method trigamma mic #' @export #' @noRd trigamma.mic <- function(x) { trigamma(as.double(x)) } #' @method cumsum mic #' @export #' @noRd cumsum.mic <- function(x) { cumsum(as.double(x)) } #' @method cumprod mic #' @export #' @noRd cumprod.mic <- function(x) { cumprod(as.double(x)) } #' @method cummax mic #' @export #' @noRd cummax.mic <- function(x) { cummax(as.double(x)) } #' @method cummin mic #' @export #' @noRd cummin.mic <- function(x) { cummin(as.double(x)) } # Ops (see ?groupGeneric) ----------------------------------------------- #' @method + mic #' @export #' @noRd `+.mic` <- function(e1, e2) { as.double(e1) + as.double(e2) } #' @method - mic #' @export #' @noRd `-.mic` <- function(e1, e2) { as.double(e1) - as.double(e2) } #' @method * mic #' @export #' @noRd `*.mic` <- function(e1, e2) { as.double(e1) * as.double(e2) } #' @method / mic #' @export #' @noRd `/.mic` <- function(e1, e2) { as.double(e1) / as.double(e2) } #' @method ^ mic #' @export #' @noRd `^.mic` <- function(e1, e2) { as.double(e1) ^ as.double(e2) } #' @method %% mic #' @export #' @noRd `%%.mic` <- function(e1, e2) { as.double(e1) %% as.double(e2) } #' @method %/% mic #' @export #' @noRd `%/%.mic` <- function(e1, e2) { as.double(e1) %/% as.double(e2) } #' @method & mic #' @export #' @noRd `&.mic` <- function(e1, e2) { as.double(e1) & as.double(e2) } #' @method | mic #' @export #' @noRd `|.mic` <- function(e1, e2) { as.double(e1) | as.double(e2) } #' @method ! mic #' @export #' @noRd `!.mic` <- function(x) { !as.double(x) } #' @method == mic #' @export #' @noRd `==.mic` <- function(e1, e2) { as.double(e1) == as.double(e2) } #' @method != mic #' @export #' @noRd `!=.mic` <- function(e1, e2) { as.double(e1) != as.double(e2) } #' @method < mic #' @export #' @noRd `<.mic` <- function(e1, e2) { as.double(e1) < as.double(e2) } #' @method <= mic #' @export #' @noRd `<=.mic` <- function(e1, e2) { as.double(e1) <= as.double(e2) } #' @method >= mic #' @export #' @noRd `>=.mic` <- function(e1, e2) { as.double(e1) >= as.double(e2) } #' @method > mic #' @export #' @noRd `>.mic` <- function(e1, e2) { as.double(e1) > as.double(e2) } # Summary (see ?groupGeneric) ------------------------------------------- #' @method all mic #' @export #' @noRd all.mic <- function(..., na.rm = FALSE) { all(as.double(c(...)), na.rm = na.rm) } #' @method any mic #' @export #' @noRd any.mic <- function(..., na.rm = FALSE) { any(as.double(c(...)), na.rm = na.rm) } #' @method sum mic #' @export #' @noRd sum.mic <- function(..., na.rm = FALSE) { sum(as.double(c(...)), na.rm = na.rm) } #' @method prod mic #' @export #' @noRd prod.mic <- function(..., na.rm = FALSE) { prod(as.double(c(...)), na.rm = na.rm) } #' @method min mic #' @export #' @noRd min.mic <- function(..., na.rm = FALSE) { min(as.double(c(...)), na.rm = na.rm) } #' @method max mic #' @export #' @noRd max.mic <- function(..., na.rm = FALSE) { max(as.double(c(...)), na.rm = na.rm) } #' @method range mic #' @export #' @noRd range.mic <- function(..., na.rm = FALSE) { range(as.double(c(...)), na.rm = na.rm) }