diff --git a/DESCRIPTION b/DESCRIPTION index 2ed99ea7..128c2638 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: AMR -Version: 2.1.1.9016 -Date: 2024-04-05 +Version: 2.1.1.9017 +Date: 2024-04-07 Title: Antimicrobial Resistance Data Analysis Description: Functions to simplify and standardise antimicrobial resistance (AMR) data analysis and to work with microbial and antimicrobial properties by @@ -32,25 +32,24 @@ Authors@R: c( person(family = "Underwood", c("Anthony"), role = "ctb", comment = c(ORCID = "0000-0002-8547-4277")), person(family = "Williams", c("Anita"), role = "ctb", comment = c(ORCID = "0000-0002-5295-8451"))) Depends: R (>= 3.0.0) -Enhances: - cleaner, - ggplot2, - janitor, - skimr, - tibble, - tidyselect, - tsibble Suggests: + cleaner, cli, curl, data.table, dplyr, + ggplot2, + janitor, knitr, progress, readxl, rmarkdown, rvest, + skimr, + tibble, + tidyselect, tinytest, + tsibble vctrs, xml2 VignetteBuilder: knitr,rmarkdown diff --git a/NAMESPACE b/NAMESPACE index 64074337..2921200b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -36,16 +36,19 @@ S3method(any,ab_selector) S3method(any,ab_selector_any_all) S3method(as.data.frame,ab) S3method(as.data.frame,av) +S3method(as.data.frame,mic) S3method(as.data.frame,mo) S3method(as.double,mic) S3method(as.list,custom_eucast_rules) S3method(as.list,custom_mdro_guideline) +S3method(as.list,mic) S3method(as.matrix,mic) S3method(as.numeric,mic) S3method(as.sir,data.frame) S3method(as.sir,default) S3method(as.sir,disk) S3method(as.sir,mic) +S3method(as.vector,mic) S3method(barplot,antibiogram) S3method(barplot,disk) S3method(barplot,mic) diff --git a/NEWS.md b/NEWS.md index d03dc88c..7a36169d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# AMR 2.1.1.9016 +# AMR 2.1.1.9017 *(this beta version will eventually become v3.0. We're happy to reach a new major milestone soon, which will be all about the new One Health support!)* diff --git a/R/mic.R b/R/mic.R index 81091fed..6182d6d3 100644 --- a/R/mic.R +++ b/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), diff --git a/R/plot.R b/R/plot.R index 73ef282e..8fc504ed 100755 --- a/R/plot.R +++ b/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)) diff --git a/R/sir.R b/R/sir.R index 8e383291..f9cda533 100755 --- a/R/sir.R +++ b/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.") diff --git a/R/vctrs.R b/R/vctrs.R index 522d2fd3..bb2e2268 100755 --- a/R/vctrs.R +++ b/R/vctrs.R @@ -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), ...) } diff --git a/R/zzz.R b/R/zzz.R index 0054b6d2..be2dd282 100755 --- a/R/zzz.R +++ b/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") diff --git a/_pkgdown.yml b/_pkgdown.yml index e187eb21..edceb5ec 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -40,12 +40,6 @@ template: code_font: {google: "Fira Code"} # body-text-align: "justify" line-height-base: 1.75 - # the green "success" colour of this bootstrap theme should be the same as the green in our logo - success: "#128f76" - link-color: "#128f76" - light: "#128f76a6" # this is success with 60% alpha - # the template "info" is blue - this should be a green fitting our theme - info: "#60a799" # make top bar a bit wider navbar-padding-y: "0.5rem" opengraph: diff --git a/pkgdown/extra.css b/pkgdown/extra.css index 5fac1a74..71de3ccc 100644 --- a/pkgdown/extra.css +++ b/pkgdown/extra.css @@ -30,19 +30,36 @@ */ :root, .navbar * { - --bs-primary: #a7dbc3 !important; - --bs-primary-color: #a7dbc3 !important; - --bs-primary-rgb: 167, 219, 195 !important; + --amr-green-light: #a7dbc3; + --amr-green-light-rgb: 167, 219, 195; + --amr-green-dark: #128f76; + --amr-green-dark-rgb: 18, 143, 118; + --amr-green-middle: #60a799; + --amr-green-middle-rgb: 96, 167, 153; + --amr-blue-light: #a8d5ef + --amr-blue-light-rgb: 168, 213, 239 + + --bs-success: --amr-green-dark !important; + --bs-link-color: --amr-green-dark !important; + --bs-light: --amr-green-light !important; + /* --bs-light was this: #128f76a6; that's success with 60% alpha */ + --bs-info: --amr-green-middle !important; + + --bs-primary: --amr-green-dark !important; + --bs-primary-color: --amr-green-dark !important; + --bs-primary-rgb: --amr-green-light-rgb !important; + --bs-secondary: #ffffff !important; - --bs-secondary-color: var(--bs-success) !important; + --bs-secondary-color: var(--amr-green-dark) !important; --bs-secondary-rgb: 255, 255, 255 !important; + --bs-navbar-brand-color: var(--bs-body-color) !important; --bs-navbar-brand-color-hover: var(--bs-body-color) !important; --bs-nav-link-color: var(--bs-body-color) !important; --bs-bg-opacity: 1 !important; } .nav-text.text-muted { - color: var(--bs-success) !important; + color: var(--amr-green-dark) !important; } .template-home img.logo { @@ -78,7 +95,7 @@ /* marked words for after using the search box */ mark, .mark { - background: var(--bs-light) !important; + background: var(--amr-green-light) !important; } /* smaller tables */ @@ -103,17 +120,17 @@ pre code { } pre .fu, .fu { /* functions */ - color: var(--bs-primary) !important; + color: var(--amr-green-dark) !important; font-weight: bold !important; letter-spacing: -1px !important; } pre .st, .st { /* strings, regular text */ - color: var(--bs-info) !important; + color: var(--amr-green-middle) !important; } pre .co, .co { /* comments */ - color: var(--bs-success) !important; + color: var(--amr-green-dark) !important; font-style: italic !important; } pre code .r-out, @@ -128,7 +145,7 @@ pre a[href], a code[href], a pre[href] { /* adjusted colour for all real links; having href attribute */ - color: var(--bs-success); + color: var(--amr-green-dark); text-decoration: none; } a[href] {