(v1.1.0.9000) CLSI as.rsi() fix, better vctrs support, new CI

R/ab.R

@@ -405,18 +405,6 @@ c.ab <- function(x, ...) {
   class_integrity_check(y, "antimicrobial code", antibiotics$ab)
 }
 
-#' @importFrom vctrs vec_ptype_abbr
-#' @export
-vec_ptype_abbr.ab <- function(x, ...) {
-  "ab"
-}
-
-#' @importFrom vctrs vec_ptype_full
-#' @export
-vec_ptype_full.ab <- function(x, ...) {
-  "ab"
-}
-
 #' @importFrom pillar pillar_shaft
 #' @export
 pillar_shaft.ab <- function(x, ...) {

R/data.R

@@ -59,7 +59,7 @@
 #' * <https://gitlab.com/msberends/AMR/raw/master/data-raw/antibiotics.txt>
 #' * <https://gitlab.com/msberends/AMR/raw/master/data-raw/antivirals.txt>
 #' 
-#' Files in R format (which data structure) can be found here:
+#' Files in R format (with preserved data structure) can be found here:
 #' 
 #' * <https://gitlab.com/msberends/AMR/raw/master/data/antibiotics.rda>
 #' * <https://gitlab.com/msberends/AMR/raw/master/data/antivirals.rda>
@@ -105,7 +105,7 @@
 #' 
 #' * <https://gitlab.com/msberends/AMR/raw/master/data-raw/microorganisms.txt>
 #' 
-#' The file in R format (which data structure) can be found here:
+#' The file in R format (with preserved data structure) can be found here:
 #' 
 #' * <https://gitlab.com/msberends/AMR/raw/master/data/microorganisms.rda>
 #' @section About the records from DSMZ (see source):

R/disk.R

@@ -127,18 +127,6 @@ pillar_shaft.disk <- function(x, ...) {
   pillar::new_pillar_shaft_simple(out, align = "right", min_width = 3)
 }
 
-#' @importFrom vctrs vec_ptype_abbr
-#' @export
-vec_ptype_abbr.disk <- function(x, ...) {
-  "disk"
-}
-
-#' @importFrom vctrs vec_ptype_full
-#' @export
-vec_ptype_full.disk <- function(x, ...) {
-  "disk"
-}
-
 #' @exportMethod [.disk
 #' @export
 #' @noRd

R/mic.R

@@ -75,7 +75,7 @@ as.mic <- function(x, na.rm = FALSE) {
     x <- gsub("=>", ">=", x, fixed = TRUE)
     # starting dots must start with 0
     x <- gsub("^[.]+", "0.", x)
-    # <=0.2560.512 should be 0.512
+    # values like "<=0.2560.512" should be 0.512
     x <- gsub(".*[.].*[.]", "0.", x)
     # remove ending .0
     x <- gsub("[.]+0$", "", x)
@@ -90,11 +90,13 @@ as.mic <- function(x, na.rm = FALSE) {
     x <- gsub("(.*[.])0+$", "\\10", x)
     # remove ending .0 again
     x[x %like% "[.]"] <- gsub("0+$", "", x[x %like% "[.]"])
+    # never end with dot
+    x <- gsub("[.]$", "", x)
     # force to be character
     x <- as.character(x)
     # trim it
     x <- trimws(x)
-
+    
     ## previously unempty values now empty - should return a warning later on
     x[x.bak != "" & x == ""] <- "invalid"
 
@@ -235,18 +237,6 @@ barplot.mic <- function(height,
   axis(2, seq(0, max(table(droplevels.factor(height)))))
 }
 
-#' @importFrom vctrs vec_ptype_abbr
-#' @export
-vec_ptype_abbr.mic <- function(x, ...) {
-  "mic"
-}
-
-#' @importFrom vctrs vec_ptype_full
-#' @export
-vec_ptype_full.mic <- function(x, ...) {
-  "mic"
-}
-
 #' @importFrom pillar pillar_shaft
 #' @export
 pillar_shaft.mic <- function(x, ...) {

R/mo.R

@@ -1671,48 +1671,6 @@ print.mo <- function(x, ...) {
   print.default(x, quote = FALSE)
 }
 
-#' @importFrom vctrs vec_ptype_abbr
-#' @export
-vec_ptype_abbr.mo <- function(x, ...) {
-  "mo"
-}
-
-#' @importFrom vctrs vec_ptype_full
-#' @export
-vec_ptype_full.mo <- function(x, ...) {
-  "mo"
-}
-
-#' @importFrom vctrs vec_ptype2
-#' @export
-vec_ptype2.mo <- function(x, y, ...) {
-  vctrs::vec_ptype2(x = as.character(x), y = as.character(y), ...)
-}
-
-#' @importFrom vctrs vec_cast
-#' @export
-vec_cast.mo <- function(x, to, ...) {
-  as.mo(vctrs::vec_cast(x = as.character(x), to = as.character(to), ...))
-}
-
-#' @importFrom vctrs vec_cast
-#' @export
-vec_cast.mo.mo <- function(x, to, ...) {
-  as.mo(vctrs::vec_cast(x = as.character(x), to = as.character(to), ...))
-}
-
-#' @importFrom vctrs vec_cast
-#' @export
-vec_cast.mo.character <- function(x, to, ...) {
-  vctrs::vec_cast(x = as.character(x), to = as.character(to), ...)
-}
-
-#' @importFrom vctrs vec_cast
-#' @export
-vec_cast.character.mo <- function(x, to, ...) {
-  as.mo(vctrs::vec_cast(x = as.character(x), to = as.character(to), ...))
-}
-
 #' @importFrom pillar pillar_shaft
 #' @export
 pillar_shaft.mo <- function(x, ...) {

R/mo_property.R

@@ -32,6 +32,8 @@
 #' - `mo_ref("Chlamydia psittaci")` will return `"Page, 1968"` (with a warning about the renaming)
 #' - `mo_ref("Chlamydophila psittaci")` will return `"Everett et al., 1999"` (without a warning)
 #'
+#' The short name - [mo_shortname()] - almost always returns the first character of the genus and the full species, like *"E. coli"*. Exceptions are abbreviations of staphylococci and beta-haemolytic streptococci, like *"CoNS"* (Coagulase-Negative Staphylococci) and *"GBS"* (Group B Streptococci).
+#'
 #' The Gram stain - [mo_gramstain()] - will be determined on the taxonomic kingdom and phylum. According to Cavalier-Smith (2002) who defined subkingdoms Negibacteria and Posibacteria, only these phyla are Posibacteria: Actinobacteria, Chloroflexi, Firmicutes and Tenericutes. These bacteria are considered Gram-positive - all other bacteria are considered Gram-negative. Species outside the kingdom of Bacteria will return a value `NA`.
 #'
 #' All output will be [translate]d where possible.

R/rsi.R

@@ -423,7 +423,7 @@ exec_as.rsi <- function(method, x, mo, ab, guideline, uti) {
   mo_order <- as.mo(mo_order(mo))
   mo_becker <- as.mo(mo, Becker = TRUE)
   mo_lancefield <- as.mo(mo, Lancefield = TRUE)
-  mo_other <- as.mo("other")
+  mo_other <- as.mo(rep("UNKNOWN", length(mo)))
   
   guideline_coerced <- get_guideline(guideline)
   if (guideline_coerced != guideline) {
@@ -659,18 +659,6 @@ barplot.rsi <- function(height,
   }
 }
 
-#' @importFrom vctrs vec_ptype_abbr
-#' @export
-vec_ptype_abbr.rsi <- function(x, ...) {
-  "rsi"
-}
-
-#' @importFrom vctrs vec_ptype_full
-#' @export
-vec_ptype_full.rsi <- function(x, ...) {
-  "rsi"
-}
-
 #' @importFrom pillar pillar_shaft
 #' @importFrom crayon bgGreen bgYellow bgRed black white
 #' @export 

R/vctrs.R

@@ -0,0 +1,235 @@
+# ==================================================================== #
+# TITLE                                                                #
+# Antimicrobial Resistance (AMR) Analysis                              #
+#                                                                      #
+# SOURCE                                                               #
+# https://gitlab.com/msberends/AMR                                     #
+#                                                                      #
+# LICENCE                                                              #
+# (c) 2018-2020 Berends MS, Luz CF et al.                              #
+#                                                                      #
+# This R package is free software; you can freely use and distribute   #
+# it for both personal and commercial purposes under the terms of the  #
+# GNU General Public License version 2.0 (GNU GPL-2), as published by  #
+# the Free Software Foundation.                                        #
+#                                                                      #
+# We created this package for both routine data analysis and academic  #
+# research and it was publicly released in the hope that it will be    #
+# useful, but it comes WITHOUT ANY WARRANTY OR LIABILITY.              #
+# Visit our website for more info: https://msberends.gitlab.io/AMR.    #
+# ==================================================================== #
+
+#' `vctrs` methods
+#' 
+#' These methods are needed to support methods used by the tidyverse, like joining and transforming data, with new classes that come with this package.
+#' @inheritSection lifecycle Stable lifecycle
+#' @inheritSection AMR Read more on our website!
+#' @keywords internal
+#' @name AMR-vctrs
+NULL
+
+
+# Class mo ----------------------------------------------------------------
+
+
+#' @exportMethod vec_ptype_abbr.mo
+#' @importFrom vctrs vec_ptype_abbr
+#' @export
+vec_ptype_abbr.mo <- function(x, ...) {
+  "mo"
+}
+
+#' @exportMethod vec_ptype_full.mo
+#' @importFrom vctrs vec_ptype_full
+#' @export
+vec_ptype_full.mo <- function(x, ...) {
+  "mo"
+}
+
+#' @rdname AMR-vctrs
+#' @export
+vec_ptype2.mo <- function(x, y, ...) {
+  UseMethod("vec_ptype2.mo", y)
+}
+
+#' @method vec_ptype2.mo default
+#' @export
+vec_ptype2.mo.default <- function(x, y, ..., x_arg = "x", y_arg = "y") {
+  vctrs::vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg)
+}
+
+#' @method vec_ptype2.mo character
+#' @export
+vec_ptype2.mo.character <- function(x, y, ...) {
+  x
+}
+
+#' @method vec_ptype2.character mo
+#' @importFrom vctrs vec_ptype2.character
+#' @export
+vec_ptype2.character.mo <- function(x, y, ...) {
+  y
+}
+
+#' @rdname AMR-vctrs
+#' @export
+vec_cast.mo <- function(x, to, ...) {
+  UseMethod("vec_cast.mo")
+}
+
+#' @method vec_cast.mo mo
+#' @export
+vec_cast.mo.mo <- function(x, to, ...) {
+  as.mo(x)
+}
+
+#' @method vec_cast.mo character
+#' @export
+vec_cast.mo.character <- function(x, to, ...) {
+  as.mo(x)
+}
+
+#' @method vec_cast.mo default
+#' @export
+vec_cast.mo.default <- function(x, to, ...) {
+  vec_default_cast(x, to)
+}
+
+# @method vec_cast.character mo
+#' @exportMethod vec_cast.character.mo
+#' @importFrom vctrs vec_cast
+#' @export
+vec_cast.character.mo <- function(x, to, ...) {
+  # purrr::map_chr(x, stringr::str_c, collapse = " ")
+  unclass(x)
+}
+
+
+# Class ab ----------------------------------------------------------------
+
+
+#' @exportMethod vec_ptype_abbr.ab
+#' @importFrom vctrs vec_ptype_abbr
+#' @export
+vec_ptype_abbr.ab <- function(x, ...) {
+  "ab"
+}
+
+#' @exportMethod vec_ptype_full.ab
+#' @importFrom vctrs vec_ptype_full
+#' @export
+vec_ptype_full.ab <- function(x, ...) {
+  "ab"
+}
+
+#' @rdname AMR-vctrs
+#' @export
+vec_ptype2.ab <- function(x, y, ...) {
+  UseMethod("vec_ptype2.ab", y)
+}
+
+#' @method vec_ptype2.ab default
+#' @export
+vec_ptype2.ab.default <- function(x, y, ..., x_arg = "x", y_arg = "y") {
+  vctrs::vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg)
+}
+
+#' @method vec_ptype2.ab character
+#' @export
+vec_ptype2.ab.character <- function(x, y, ...) {
+  x
+}
+
+#' @method vec_ptype2.character ab
+#' @importFrom vctrs vec_ptype2.character
+#' @export
+vec_ptype2.character.ab <- function(x, y, ...) {
+  y
+}
+
+#' @rdname AMR-vctrs
+#' @export
+vec_cast.ab <- function(x, to, ...) {
+  UseMethod("vec_cast.ab")
+}
+
+#' @method vec_cast.ab ab
+#' @export
+vec_cast.ab.ab <- function(x, to, ...) {
+  as.ab(x)
+}
+
+#' @method vec_cast.ab character
+#' @export
+vec_cast.ab.character <- function(x, to, ...) {
+  as.ab(x)
+}
+
+#' @method vec_cast.ab default
+#' @export
+vec_cast.ab.default <- function(x, to, ...) {
+  vec_default_cast(x, to)
+}
+
+# @method vec_cast.character ab
+#' @exportMethod vec_cast.character.ab
+#' @importFrom vctrs vec_cast
+#' @export
+vec_cast.character.ab <- function(x, to, ...) {
+  # purrr::map_chr(x, stringr::str_c, collapse = " ")
+  unclass(x)
+}
+
+
+# Class disk --------------------------------------------------------------
+
+
+#' @exportMethod vec_ptype_abbr.disk
+#' @importFrom vctrs vec_ptype_abbr
+#' @export
+vec_ptype_abbr.disk <- function(x, ...) {
+  "disk"
+}
+
+#' @exportMethod vec_ptype_full.disk
+#' @importFrom vctrs vec_ptype_full
+#' @export
+vec_ptype_full.disk <- function(x, ...) {
+  "disk"
+}
+
+
+# Class rsi --------------------------------------------------------------
+
+
+#' @exportMethod vec_ptype_abbr.rsi
+#' @importFrom vctrs vec_ptype_abbr
+#' @export
+vec_ptype_abbr.rsi <- function(x, ...) {
+  "rsi"
+}
+
+#' @exportMethod vec_ptype_full.rsi
+#' @importFrom vctrs vec_ptype_full
+#' @export
+vec_ptype_full.rsi <- function(x, ...) {
+  "rsi"
+}
+
+
+# Class mic --------------------------------------------------------------
+
+
+#' @exportMethod vec_ptype_abbr.mic
+#' @importFrom vctrs vec_ptype_abbr
+#' @export
+vec_ptype_abbr.mic <- function(x, ...) {
+  "mic"
+}
+
+#' @exportMethod vec_ptype_full.mic
+#' @importFrom vctrs vec_ptype_full
+#' @export
+vec_ptype_full.mic <- function(x, ...) {
+  "mic"
+}