update MIC implementation

2024-12-26 06:06:12 +01:00 · 2024-04-07 20:22:59 +02:00 · 2024-04-07 20:22:59 +02:00 · 94e9a4d99b
commit 94e9a4d99b
parent 0039cb05d6
10 changed files with 94 additions and 50 deletions
--- a/19
+++ b/19
@ -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
--- a/3
+++ b/3
@ -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)
--- 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!)*

--- 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),
--- 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))
--- 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.")
--- 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), ...)
 }
--- 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")
--- 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:
--- 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] {