add vctrs

NEWS.md

@@ -12,6 +12,7 @@ This version will eventually become v2.0! We're happy to reach a new major miles
 * The MO matching score algorithm (`mo_matching_score()`) now counts deletions and substitutions as 2 instead of 1, which impacts the outcome of `as.mo()` and any `mo_*()` function
 * **Argument `combine_IR` has been removed** from this package (affecting functions `count_df()`, `proportion_df()`, and `rsi_df()` and some plotting functions), since it was replaced with `combine_SI` three years ago
 * Interpretation **guidelines older than 10 years were removed**, the oldest now included guidelines of EUCAST and CLSI are from 2013
+* Using `units` in `ab_ddd(..., units = "...")` had been deprecated and is now not supported anymore. Use `ab_ddd_units()` instead.
 
 ### New
 * **EUCAST 2022 and CLSI 2022 guidelines** have been added for `as.rsi()`. EUCAST 2022 is now the new default guideline for all MIC and disks diffusion interpretations.

R/ab_property.R

@@ -241,20 +241,7 @@ ab_ddd <- function(x, administration = "oral", ...) {
   meet_criteria(administration, is_in = c("oral", "iv"), has_length = 1)
 
   x <- as.ab(x, ...)
-  ddd_prop <- administration
-  # old behaviour
-  units <- list(...)$units
-  if (!is.null(units) && isTRUE(units)) {
-    if (message_not_thrown_before("ab_ddd", entire_session = TRUE)) {
-      warning_(
-        "in `ab_ddd()`: using `ab_ddd(..., units = TRUE)` is deprecated, use `ab_ddd_units()` to retrieve units instead.",
-        "This warning will be shown once per session."
-      )
-    }
-    ddd_prop <- paste0(ddd_prop, "_units")
-  } else {
-    ddd_prop <- paste0(ddd_prop, "_ddd")
-  }
+  ddd_prop <- paste0(administration, "_ddd")
   out <- ab_validate(x = x, property = ddd_prop)
 
   if (any(ab_name(x, language = NULL) %like% "/" & is.na(out))) {
@@ -274,16 +261,17 @@ ab_ddd_units <- function(x, administration = "oral", ...) {
   meet_criteria(administration, is_in = c("oral", "iv"), has_length = 1)
 
   x <- as.ab(x, ...)
-  if (any(ab_name(x, language = NULL) %like% "/")) {
+  ddd_prop <- paste0(administration, "_units")
+  out <- ab_validate(x = x, property = ddd_prop)
+
+  if (any(ab_name(x, language = NULL) %like% "/" & is.na(out))) {
     warning_(
-      "in `ab_ddd_units()`: DDDs of combined products are available for different dose combinations and not (yet) part of the AMR package.",
+      "in `ab_ddd_units()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
       "Please refer to the WHOCC website:\n",
       "www.whocc.no/ddd/list_of_ddds_combined_products/"
     )
   }
-
-  ddd_prop <- paste0(administration, "_units")
-  ab_validate(x = x, property = ddd_prop)
+  out
 }
 
 #' @rdname ab_property

R/av.R

@@ -506,6 +506,7 @@ is.av <- function(x) {
 # will be exported using s3_register() in R/zzz.R
 pillar_shaft.av <- function(x, ...) {
   out <- trimws(format(x))
+  out[!is.na(x)] <- gsub("+", font_subtle("+"), out[!is.na(x)], fixed = TRUE)
   out[is.na(x)] <- font_na(NA)
   create_pillar_column(out, align = "left", min_width = 4)
 }
@@ -556,7 +557,7 @@ as.data.frame.av <- function(x, ...) {
 "[<-.av" <- function(i, j, ..., value) {
   y <- NextMethod()
   attributes(y) <- attributes(i)
-  return_after_integrity_check(y, "antimicrobial code", AMR_env$AV_lookup$av)
+  return_after_integrity_check(y, "antiviral agent code", AMR_env$AV_lookup$av)
 }
 #' @method [[<- av
 #' @export
@@ -564,7 +565,7 @@ as.data.frame.av <- function(x, ...) {
 "[[<-.av" <- function(i, j, ..., value) {
   y <- NextMethod()
   attributes(y) <- attributes(i)
-  return_after_integrity_check(y, "antimicrobial code", AMR_env$AV_lookup$av)
+  return_after_integrity_check(y, "antiviral agent code", AMR_env$AV_lookup$av)
 }
 #' @method c av
 #' @export
@@ -573,7 +574,7 @@ c.av <- function(...) {
   x <- list(...)[[1L]]
   y <- NextMethod()
   attributes(y) <- attributes(x)
-  return_after_integrity_check(y, "antimicrobial code", AMR_env$AV_lookup$av)
+  return_after_integrity_check(y, "antiviral agent code", AMR_env$AV_lookup$av)
 }
 
 #' @method unique av

R/av_property.R

@@ -130,35 +130,11 @@ av_group <- function(x, language = get_AMR_locale(), ...) {
 }
 
 #' @rdname av_property
-#' @aliases ATC
 #' @export
-av_atc <- function(x, only_first = FALSE, ...) {
+av_atc <- function(x, ...) {
   meet_criteria(x, allow_NA = TRUE)
-  meet_criteria(only_first, allow_class = "logical", has_length = 1)
-  
-  atcs <- av_validate(x = x, property = "atc", ...)
-  
-  if (only_first == TRUE) {
-    atcs <- vapply(
-      FUN.VALUE = character(1),
-      # get only the first ATC code
-      atcs,
-      function(x) {
-        # try to get the J-group
-        if (any(x %like% "^J")) {
-          x[x %like% "^J"][1L]
-        } else {
-          as.character(x[1L])
-        }
-      }
-    )
-  } else if (length(atcs) == 1) {
-    atcs <- unname(unlist(atcs))
-  } else {
-    names(atcs) <- x
-  }
-  
-  atcs
+  # ATCs in the antivirals data set are not a list
+  av_validate(x = x, property = "atc", ...)
 }
 
 #' @rdname av_property
@@ -181,20 +157,7 @@ av_ddd <- function(x, administration = "oral", ...) {
   meet_criteria(administration, is_in = c("oral", "iv"), has_length = 1)
   
   x <- as.av(x, ...)
-  ddd_prop <- administration
-  # old behaviour
-  units <- list(...)$units
-  if (!is.null(units) && isTRUE(units)) {
-    if (message_not_thrown_before("av_ddd", entire_session = TRUE)) {
-      warning_(
-        "in `av_ddd()`: using `av_ddd(..., units = TRUE)` is deprecated, use `av_ddd_units()` to retrieve units instead.",
-        "This warning will be shown once per session."
-      )
-    }
-    ddd_prop <- paste0(ddd_prop, "_units")
-  } else {
-    ddd_prop <- paste0(ddd_prop, "_ddd")
-  }
+  ddd_prop <- paste0(administration, "_ddd")
   out <- av_validate(x = x, property = ddd_prop)
   
   if (any(av_name(x, language = NULL) %like% "/" & is.na(out))) {
@@ -214,16 +177,17 @@ av_ddd_units <- function(x, administration = "oral", ...) {
   meet_criteria(administration, is_in = c("oral", "iv"), has_length = 1)
   
   x <- as.av(x, ...)
-  if (any(av_name(x, language = NULL) %like% "/")) {
+  ddd_prop <- paste0(administration, "_units")
+  out <- av_validate(x = x, property = ddd_prop)
+  
+  if (any(av_name(x, language = NULL) %like% "/" & is.na(out))) {
     warning_(
-      "in `av_ddd_units()`: DDDs of combined products are available for different dose combinations and not (yet) part of the AMR package.",
+      "in `av_ddd_units()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
       "Please refer to the WHOCC website:\n",
       "www.whocc.no/ddd/list_of_ddds_combined_products/"
     )
   }
-  
-  ddd_prop <- paste0(administration, "_units")
-  av_validate(x = x, property = ddd_prop)
+  out
 }
 
 #' @rdname av_property

R/vctrs.R

@@ -70,6 +70,20 @@ vec_cast.ab.character <- function(x, to, ...) {
   return_after_integrity_check(x, "antimicrobial code", as.character(AMR_env$AB_lookup$ab))
 }
 
+# S3: av
+vec_ptype2.character.av <- function(x, y, ...) {
+  x
+}
+vec_ptype2.av.character <- function(x, y, ...) {
+  y
+}
+vec_cast.character.av <- function(x, to, ...) {
+  as.character(x)
+}
+vec_cast.av.character <- function(x, to, ...) {
+  return_after_integrity_check(x, "antiviral agent code", as.character(AMR_env$AV_lookup$av))
+}
+
 # S3: mo
 vec_ptype2.character.mo <- function(x, y, ...) {
   x

R/zzz.R

@@ -50,6 +50,11 @@ AMR_env$ab_previously_coerced <- data.frame(
   ab = character(0),
   stringsAsFactors = FALSE
 )
+AMR_env$av_previously_coerced <- data.frame(
+  x = character(0),
+  av = character(0),
+  stringsAsFactors = FALSE
+)
 AMR_env$rsi_interpretation_history <- data.frame(
   datetime = Sys.time()[0],
   index = integer(0),
@@ -87,11 +92,13 @@ if (utf8_supported && !is_latex) {
   # developers of the vctrs package:
   # https://github.com/r-lib/vctrs/blob/05968ce8e669f73213e3e894b5f4424af4f46316/R/register-s3.R
   s3_register("pillar::pillar_shaft", "ab")
+  s3_register("pillar::pillar_shaft", "av")
   s3_register("pillar::pillar_shaft", "mo")
   s3_register("pillar::pillar_shaft", "rsi")
   s3_register("pillar::pillar_shaft", "mic")
   s3_register("pillar::pillar_shaft", "disk")
   s3_register("tibble::type_sum", "ab")
+  s3_register("tibble::type_sum", "av")
   s3_register("tibble::type_sum", "mo")
   s3_register("tibble::type_sum", "rsi")
   s3_register("tibble::type_sum", "mic")
@@ -129,6 +136,11 @@ if (utf8_supported && !is_latex) {
   s3_register("vctrs::vec_ptype2", "ab.character")
   s3_register("vctrs::vec_cast", "character.ab")
   s3_register("vctrs::vec_cast", "ab.character")
+  # S3: av
+  s3_register("vctrs::vec_ptype2", "character.av")
+  s3_register("vctrs::vec_ptype2", "av.character")
+  s3_register("vctrs::vec_cast", "character.av")
+  s3_register("vctrs::vec_cast", "av.character")
   # S3: mo
   s3_register("vctrs::vec_ptype2", "character.mo")
   s3_register("vctrs::vec_ptype2", "mo.character")

man/av_property.Rd

@@ -8,7 +8,6 @@
 \alias{av_tradenames}
 \alias{av_group}
 \alias{av_atc}
-\alias{ATC}
 \alias{av_loinc}
 \alias{av_ddd}
 \alias{av_ddd_units}
@@ -26,7 +25,7 @@ av_tradenames(x, ...)
 
 av_group(x, language = get_AMR_locale(), ...)
 
-av_atc(x, only_first = FALSE, ...)
+av_atc(x, ...)
 
 av_loinc(x, ...)