update MIC implementation

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: AMR
-Version: 2.1.1.9016
+Version: 2.1.1.9017
-Date: 2024-04-05
+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

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)

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!)*
 

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'",
+  cat("Class 'mic'\n")
-    ifelse(!identical(levels(x), VALID_MIC_LEVELS), font_red(" with outdated structure - convert with `as.mic()` to update"), ""),
+  if(!identical(levels(x), VALID_MIC_LEVELS)) {
-    "\n",
+    cat(font_red("This object has an outdated or altered structure - convert with `as.mic()` to update\n"))
-    sep = ""
+  }
-  )
   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)
+  as.mic(y)
-  y
 }
 #' @method [[ mic
 #' @export
 #' @noRd
 "[[.mic" <- function(x, ...) {
   y <- NextMethod()
-  attributes(y) <- attributes(x)
+  as.mic(y)
-  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)
+  as.mic(y)
-  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)
+  as.mic(y)
-  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)
+  as.mic(y)
-  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)
+  as.mic(y)
-  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),

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))

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.")

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), ...)
 }

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_full", "disk")
-  s3_register("vctrs::vec_ptype_abbr", "disk") # returns "dsk"
+  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")

_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:

pkgdown/extra.css

@@ -30,19 +30,36 @@
 */
 
 :root, .navbar * {
-  --bs-primary: #a7dbc3 !important;
+  --amr-green-light: #a7dbc3;
-  --bs-primary-color: #a7dbc3 !important;
+  --amr-green-light-rgb: 167, 219, 195;
-  --bs-primary-rgb: 167, 219, 195 !important;
+  --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] {