mirror of
https://github.com/msberends/AMR.git
synced 2025-07-11 07:01:57 +02:00
update MIC implementation
This commit is contained in:
54
R/mic.R
54
R/mic.R
@ -340,6 +340,7 @@ as.numeric.mic <- function(x, ...) {
|
||||
#' @param as.mic a [logical] to indicate whether the `mic` class should be kept - the default is `FALSE`
|
||||
#' @export
|
||||
droplevels.mic <- function(x, as.mic = FALSE, ...) {
|
||||
x <- as.mic(x) # make sure that currently implemented MIC levels are used
|
||||
x <- droplevels.factor(x, ...)
|
||||
if (as.mic == TRUE) {
|
||||
class(x) <- c("mic", "ordered", "factor")
|
||||
@ -378,11 +379,10 @@ type_sum.mic <- function(x, ...) {
|
||||
#' @export
|
||||
#' @noRd
|
||||
print.mic <- function(x, ...) {
|
||||
cat("Class 'mic'",
|
||||
ifelse(!identical(levels(x), VALID_MIC_LEVELS), font_red(" with outdated structure - convert with `as.mic()` to update"), ""),
|
||||
"\n",
|
||||
sep = ""
|
||||
)
|
||||
cat("Class 'mic'\n")
|
||||
if(!identical(levels(x), VALID_MIC_LEVELS)) {
|
||||
cat(font_red("This object has an outdated or altered structure - convert with `as.mic()` to update\n"))
|
||||
}
|
||||
print(as.character(x), quote = FALSE)
|
||||
att <- attributes(x)
|
||||
if ("na.action" %in% names(att)) {
|
||||
@ -403,22 +403,44 @@ summary.mic <- function(object, ...) {
|
||||
as.matrix.mic <- function(x, ...) {
|
||||
as.matrix(as.double(x), ...)
|
||||
}
|
||||
#' @method as.vector mic
|
||||
#' @export
|
||||
#' @noRd
|
||||
as.vector.mic <- function(x, mode = "numneric", ...) {
|
||||
y <- NextMethod()
|
||||
y <- as.mic(y)
|
||||
calls <- unlist(lapply(sys.calls(), as.character))
|
||||
if (any(calls %in% c("rbind", "cbind")) && message_not_thrown_before("as.vector.mic")) {
|
||||
warning_("Functions `rbind()` and `cbind()` cannot preserve the structure of MIC values. Use dplyr's `bind_rows()` or `bind_cols()` instead. To solve, you can also use `your_data %>% mutate_if(is.ordered, as.mic)`.", call = FALSE)
|
||||
}
|
||||
y
|
||||
}
|
||||
#' @method as.list mic
|
||||
#' @export
|
||||
#' @noRd
|
||||
as.list.mic <- function(x, ...) {
|
||||
lapply(as.list(as.character(x), ...), as.mic)
|
||||
}
|
||||
#' @method as.data.frame mic
|
||||
#' @export
|
||||
#' @noRd
|
||||
as.data.frame.mic <- function(x, ...) {
|
||||
as.data.frame.vector(as.mic(x), ...)
|
||||
}
|
||||
|
||||
#' @method [ mic
|
||||
#' @export
|
||||
#' @noRd
|
||||
"[.mic" <- function(x, ...) {
|
||||
y <- NextMethod()
|
||||
attributes(y) <- attributes(x)
|
||||
y
|
||||
as.mic(y)
|
||||
}
|
||||
#' @method [[ mic
|
||||
#' @export
|
||||
#' @noRd
|
||||
"[[.mic" <- function(x, ...) {
|
||||
y <- NextMethod()
|
||||
attributes(y) <- attributes(x)
|
||||
y
|
||||
as.mic(y)
|
||||
}
|
||||
#' @method [<- mic
|
||||
#' @export
|
||||
@ -426,8 +448,7 @@ as.matrix.mic <- function(x, ...) {
|
||||
"[<-.mic" <- function(i, j, ..., value) {
|
||||
value <- as.mic(value)
|
||||
y <- NextMethod()
|
||||
attributes(y) <- attributes(i)
|
||||
y
|
||||
as.mic(y)
|
||||
}
|
||||
#' @method [[<- mic
|
||||
#' @export
|
||||
@ -435,8 +456,7 @@ as.matrix.mic <- function(x, ...) {
|
||||
"[[<-.mic" <- function(i, j, ..., value) {
|
||||
value <- as.mic(value)
|
||||
y <- NextMethod()
|
||||
attributes(y) <- attributes(i)
|
||||
y
|
||||
as.mic(y)
|
||||
}
|
||||
#' @method c mic
|
||||
#' @export
|
||||
@ -450,8 +470,7 @@ c.mic <- function(...) {
|
||||
#' @noRd
|
||||
unique.mic <- function(x, incomparables = FALSE, ...) {
|
||||
y <- NextMethod()
|
||||
attributes(y) <- attributes(x)
|
||||
y
|
||||
as.mic(y)
|
||||
}
|
||||
|
||||
#' @method rep mic
|
||||
@ -459,14 +478,14 @@ unique.mic <- function(x, incomparables = FALSE, ...) {
|
||||
#' @noRd
|
||||
rep.mic <- function(x, ...) {
|
||||
y <- NextMethod()
|
||||
attributes(y) <- attributes(x)
|
||||
y
|
||||
as.mic(y)
|
||||
}
|
||||
|
||||
#' @method sort mic
|
||||
#' @export
|
||||
#' @noRd
|
||||
sort.mic <- function(x, decreasing = FALSE, ...) {
|
||||
x <- as.mic(x) # make sure that currently implemented MIC levels are used
|
||||
if (decreasing == TRUE) {
|
||||
ord <- order(-as.double(x))
|
||||
} else {
|
||||
@ -486,6 +505,7 @@ hist.mic <- function(x, ...) {
|
||||
|
||||
# will be exported using s3_register() in R/zzz.R
|
||||
get_skimmers.mic <- function(column) {
|
||||
column <- as.mic(column) # make sure that currently implemented MIC levels are used
|
||||
skimr::sfl(
|
||||
skim_type = "mic",
|
||||
p0 = ~ stats::quantile(., probs = 0, na.rm = TRUE, names = FALSE),
|
||||
|
||||
7
R/plot.R
7
R/plot.R
@ -178,6 +178,7 @@ plot.mic <- function(x,
|
||||
include_PKPD = getOption("AMR_include_PKPD", TRUE),
|
||||
breakpoint_type = getOption("AMR_breakpoint_type", "human"),
|
||||
...) {
|
||||
x <- as.mic(x) # make sure that currently implemented MIC levels are used
|
||||
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
|
||||
meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
|
||||
meet_criteria(guideline, allow_class = "character", has_length = 1)
|
||||
@ -263,6 +264,7 @@ barplot.mic <- function(height,
|
||||
language = get_AMR_locale(),
|
||||
expand = TRUE,
|
||||
...) {
|
||||
height <- as.mic(height) # make sure that currently implemented MIC levels are used
|
||||
meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(ylab, allow_class = "character", has_length = 1)
|
||||
meet_criteria(xlab, allow_class = "character", has_length = 1)
|
||||
@ -305,6 +307,7 @@ autoplot.mic <- function(object,
|
||||
breakpoint_type = getOption("AMR_breakpoint_type", "human"),
|
||||
...) {
|
||||
stop_ifnot_installed("ggplot2")
|
||||
object <- as.mic(object) # make sure that currently implemented MIC levels are used
|
||||
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
|
||||
meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
|
||||
meet_criteria(guideline, allow_class = "character", has_length = 1)
|
||||
@ -384,6 +387,7 @@ autoplot.mic <- function(object,
|
||||
#' @rdname plot
|
||||
# will be exported using s3_register() in R/zzz.R
|
||||
fortify.mic <- function(object, ...) {
|
||||
object <- as.mic(object) # make sure that currently implemented MIC levels are used
|
||||
stats::setNames(
|
||||
as.data.frame(range_as_table(object, expand = FALSE)),
|
||||
c("x", "y")
|
||||
@ -772,7 +776,6 @@ range_as_table <- function(x, expand, keep_operators = "all", mic_range = NULL)
|
||||
x <- as.mic(x, keep_operators = keep_operators)
|
||||
if (expand == TRUE) {
|
||||
# expand range for MIC by adding factors of 2 from lowest to highest so all MICs in between also print
|
||||
valid_lvls <- levels(x)
|
||||
extra_range <- max(x)
|
||||
min_range <- min(x)
|
||||
if (!is.null(mic_range)) {
|
||||
@ -791,7 +794,7 @@ range_as_table <- function(x, expand, keep_operators = "all", mic_range = NULL)
|
||||
extra_range <- rep(0, length(extra_range))
|
||||
names(extra_range) <- nms
|
||||
x <- table(droplevels(x, as.mic = FALSE))
|
||||
extra_range <- extra_range[!names(extra_range) %in% names(x) & names(extra_range) %in% valid_lvls]
|
||||
extra_range <- extra_range[!names(extra_range) %in% names(x) & names(extra_range) %in% VALID_MIC_LEVELS]
|
||||
x <- as.table(c(x, extra_range))
|
||||
} else {
|
||||
x <- table(droplevels(x, as.mic = FALSE))
|
||||
|
||||
2
R/sir.R
2
R/sir.R
@ -343,7 +343,7 @@ as.sir.default <- function(x, ...) {
|
||||
x[x.bak == "2"] <- "I"
|
||||
x[x.bak == "3"] <- "R"
|
||||
} else if (!all(is.na(x)) && !identical(levels(x), c("S", "I", "R")) && !all(x %in% c("S", "I", "R", NA))) {
|
||||
if (all(x %unlike% "(R|S|I)", na.rm = TRUE)) {
|
||||
if (all(x %unlike% "(S|I|R)", na.rm = TRUE)) {
|
||||
# check if they are actually MICs or disks
|
||||
if (all_valid_mics(x)) {
|
||||
warning_("in `as.sir()`: the input seems to contain MIC values. You can transform them with `as.mic()` before running `as.sir()` to interpret them.")
|
||||
|
||||
@ -106,7 +106,7 @@ vec_ptype_full.disk <- function(x, ...) {
|
||||
"disk"
|
||||
}
|
||||
vec_ptype_abbr.disk <- function(x, ...) {
|
||||
"dsk"
|
||||
"disk"
|
||||
}
|
||||
vec_ptype2.disk.default <- function (x, y, ..., x_arg = "", y_arg = "") {
|
||||
x
|
||||
@ -155,6 +155,9 @@ vec_cast.double.mic <- function(x, to, ...) {
|
||||
vec_cast.integer.mic <- function(x, to, ...) {
|
||||
as.integer(x)
|
||||
}
|
||||
vec_cast.factor.mic <- function(x, to, ...) {
|
||||
factor(as.character(x))
|
||||
}
|
||||
vec_cast.mic.double <- function(x, to, ...) {
|
||||
as.mic(x)
|
||||
}
|
||||
@ -164,6 +167,9 @@ vec_cast.mic.character <- function(x, to, ...) {
|
||||
vec_cast.mic.integer <- function(x, to, ...) {
|
||||
as.mic(x)
|
||||
}
|
||||
vec_cast.mic.factor <- function(x, to, ...) {
|
||||
as.mic(x)
|
||||
}
|
||||
vec_math.mic <- function(.fn, x, ...) {
|
||||
.fn(as.double(x), ...)
|
||||
}
|
||||
|
||||
6
R/zzz.R
6
R/zzz.R
@ -155,8 +155,8 @@ if (pkg_is_available("cli")) {
|
||||
s3_register("vctrs::vec_cast", "character.mo")
|
||||
s3_register("vctrs::vec_cast", "mo.character")
|
||||
# S3: disk
|
||||
s3_register("vctrs::vec_ptype_full", "disk") # returns "disk"
|
||||
s3_register("vctrs::vec_ptype_abbr", "disk") # returns "dsk"
|
||||
s3_register("vctrs::vec_ptype_full", "disk")
|
||||
s3_register("vctrs::vec_ptype_abbr", "disk")
|
||||
s3_register("vctrs::vec_ptype2", "disk.default")
|
||||
s3_register("vctrs::vec_ptype2", "disk.disk")
|
||||
s3_register("vctrs::vec_cast", "integer.disk")
|
||||
@ -171,9 +171,11 @@ if (pkg_is_available("cli")) {
|
||||
s3_register("vctrs::vec_cast", "character.mic")
|
||||
s3_register("vctrs::vec_cast", "double.mic")
|
||||
s3_register("vctrs::vec_cast", "integer.mic")
|
||||
s3_register("vctrs::vec_cast", "factor.mic")
|
||||
s3_register("vctrs::vec_cast", "mic.character")
|
||||
s3_register("vctrs::vec_cast", "mic.double")
|
||||
s3_register("vctrs::vec_cast", "mic.integer")
|
||||
s3_register("vctrs::vec_cast", "mic.factor")
|
||||
s3_register("vctrs::vec_cast", "mic.mic")
|
||||
s3_register("vctrs::vec_math", "mic")
|
||||
s3_register("vctrs::vec_arith", "mic")
|
||||
|
||||
Reference in New Issue
Block a user