(v0.7.0.9001) new pathovars, small fixes

R/ab.R

@@ -91,6 +91,11 @@ as.ab <- function(x) {
       x_unknown <- c(x_unknown, x_bak[x[i] == x_bak_clean][1])
       next
     }
+    # prevent "bacteria" from coercing to TMP, since Bacterial is a brand name of it
+    if (identical(tolower(x[i]), "bacteria")) {
+      x_unknown <- c(x_unknown, x_bak[x[i] == x_bak_clean][1])
+      next
+    }
 
     # exact AB code
     found <- AMR::antibiotics[which(AMR::antibiotics$ab == toupper(x[i])),]$ab
@@ -162,23 +167,20 @@ as.ab <- function(x) {
     }
     x_spelling <- tolower(x[i])
     x_spelling <- gsub("[iy]+", "[iy]+", x_spelling)
-    x_spelling <- gsub("[sz]+", "[sz]+", x_spelling)
-    x_spelling <- gsub("(c|k|q|qu)+", "(c|k|q|qu)+", x_spelling)
+    x_spelling <- gsub("(c|k|q|qu|s|z|x|ks)+", "(c|k|q|qu|s|z|x|ks)+", x_spelling)
     x_spelling <- gsub("(ph|f|v)+", "(ph|f|v)+", x_spelling)
     x_spelling <- gsub("(th|t)+", "(th|t)+", x_spelling)
-    x_spelling <- gsub("(x|ks)+", "(x|ks)+", x_spelling)
     x_spelling <- gsub("a+", "a+", x_spelling)
     x_spelling <- gsub("e+", "e+", x_spelling)
     x_spelling <- gsub("o+", "o+", x_spelling)
-    # allow start with C/S/Z
-    x_spelling <- gsub("^(\\(c\\|k\\|q\\|qu\\)|\\[sz\\])", "(c|k|q|qu|s|z)", x_spelling)
-    x_spelling <- gsub("(c|k|q|qu)+[sz]", "(c|k|q|qu|s|x|z)", x_spelling, fixed = TRUE)
     # allow any ending of -in/-ine and -im/-ime
     x_spelling <- gsub("(\\[iy\\]\\+(n|m)|\\[iy\\]\\+(n|m)e\\+)$", "[iy]+(n|m)e*", x_spelling)
     # allow any ending of -ol/-ole
     x_spelling <- gsub("(o\\+l|o\\+le\\+)$", "o+le*", x_spelling)
     # allow any ending of -on/-one
     x_spelling <- gsub("(o\\+n|o\\+ne\\+)$", "o+ne*", x_spelling)
+    # replace multiple same characters to single one with '+', like "ll" -> "l+"
+    x_spelling <- gsub("(.)\\1+", "\\1+", x_spelling)
     # try if name starts with it
     found <- AMR::antibiotics[which(AMR::antibiotics$name %like% paste0("^", x_spelling)),]$ab
     if (length(found) > 0) {
@@ -256,3 +258,13 @@ as.data.frame.ab <- function (x, ...) {
 pull.ab <- function(.data, ...) {
   pull(as.data.frame(.data), ...)
 }
+
+#' @exportMethod scale_type.ab
+#' @export
+#' @noRd
+scale_type.ab <- function(x) {
+  # fix for:
+  # "Don't know how to automatically pick scale for object of type ab. Defaulting to continuous."
+  # "Error: Discrete value supplied to continuous scale"
+  "discrete"
+}

R/amr.R

@@ -67,4 +67,5 @@
 #' @rdname AMR
 #  # prevent NOTE on R >= 3.6
 #' @importFrom microbenchmark microbenchmark
+#' @importFrom scales percent
 NULL

R/eucast_rules.R

@@ -209,6 +209,12 @@ eucast_rules <- function(x,
     stop("`col_mo` must be set")
   }
 
+  decimal.mark <- getOption("OutDec")
+  big.mark <- ifelse(decimal.mark != ",", ",", ".")
+  formatnr <- function(x) {
+    trimws(format(x, big.mark = big.mark, decimal.mark = decimal.mark))
+  }
+
   warned <- FALSE
 
   txt_error <- function() { cat("", bgRed(white(" ERROR ")), "\n") }
@@ -219,7 +225,7 @@ eucast_rules <- function(x,
         if (no_of_changes == 1) {
           cat(blue(" (1 new change)\n"))
         } else {
-          cat(blue(paste0(" (", no_of_changes, " new changes)\n")))
+          cat(blue(paste0(" (", formatnr(no_of_changes), " new changes)\n")))
         }
       } else {
         cat(green(" (no new changes)\n"))
@@ -664,12 +670,6 @@ eucast_rules <- function(x,
     verbose_info <- verbose_info %>%
       arrange(row, rule_group, rule_name, col)
 
-    decimal.mark <- getOption("OutDec")
-    big.mark <- ifelse(decimal.mark != ",", ",", ".")
-    formatnr <- function(x) {
-      trimws(format(x, big.mark = big.mark, decimal.mark = decimal.mark))
-    }
-
     cat(paste0("\n", silver(strrep("-", options()$width - 1)), "\n"))
     cat(bold(paste('EUCAST rules', paste0(wouldve, 'affected'),
                    formatnr(n_distinct(verbose_info$row)),

R/first_isolate.R

@@ -414,15 +414,15 @@ first_isolate <- function(x,
     if (length(x) == 1) {
       return(TRUE)
     }
-    indices = integer(0)
-    start = x[1]
-    ind = 1
-    indices[ind] = ind
+    indices <- integer(0)
+    start <- x[1]
+    ind <- 1
+    indices[ind] <- ind
     for (i in 2:length(x)) {
-      if (as.numeric(x[i] - start >= episode_days)) {
-        ind = ind + 1
-        indices[ind] = i
-        start = x[i]
+      if (isTRUE(as.numeric(x[i] - start) >= episode_days)) {
+        ind <- ind + 1
+        indices[ind] <- i
+        start <- x[i]
       }
     }
     result <- rep(FALSE, length(x))

R/freq.R

@@ -238,7 +238,13 @@ freq <- function(x,
       x.name <- x.name %>% strsplit("%>%", fixed = TRUE) %>% unlist() %>% .[1] %>% trimws()
     }
     if (x.name == ".") {
-      x.name <- "a data.frame"
+      # passed on with pipe
+      x.name <- get_data_source_name(x)
+      if (!is.null(x.name)) {
+        x.name <- paste0("`", x.name, "`")
+      } else {
+        x.name <- "a data.frame"
+      }
     } else {
       x.name <- paste0("`", x.name, "`")
     }
@@ -1230,3 +1236,21 @@ format.freq <- function(x, digits = 1, ...) {
   x$cum_percent <- percent(x$cum_percent, round = digits, force_zero = TRUE)
   base::format.data.frame(x, ...)
 }
+
+#' @importFrom data.table address
+get_data_source_name <- function(x, else_txt = NULL) {
+  obj_addr <- address(x)
+  # try global environment
+  addrs <- unlist(lapply(ls(".GlobalEnv"), function(x) address(get(x))))
+  res <- ls(".GlobalEnv")[addrs == obj_addr]
+  if (length(res) == 0) {
+    # check AMR package - some users might use our data sets for testing
+    addrs <- unlist(lapply(ls("package:AMR"), function(x) address(get(x))))
+    res <- ls("package:AMR")[addrs == obj_addr]
+  }
+  if (length(res) == 0) {
+    else_txt
+  } else {
+    res
+  }
+}

R/misc.R

@@ -172,16 +172,19 @@ get_column_abx <- function(x,
   # get_column_abx(septic_patients %>% rename(thisone = AMX), amox = "thisone")
   dots <- list(...)
   if (length(dots) > 0) {
-    dots <- unlist(dots)
     newnames <- suppressWarnings(as.ab(names(dots)))
     if (any(is.na(newnames))) {
       warning("Invalid antibiotic reference(s): ", toString(names(dots)[is.na(newnames)]),
               call. = FALSE, immediate. = TRUE)
     }
+    # turn all NULLs to NAs
+    dots <- unlist(lapply(dots, function(x) if (is.null(x)) NA else x))
     names(dots) <- newnames
     dots <- dots[!is.na(names(dots))]
     # merge, but overwrite automatically determined ones by 'dots'
     x <- c(x[!x %in% dots & !names(x) %in% names(dots)], dots)
+    # delete NAs, this will make eucast_rules(... TMP = NULL) work to prevent TMP from being used
+    x <- x[!is.na(x)]
   }
 
   # sort on name

R/mo.R

@@ -485,18 +485,21 @@ exec_as.mo <- function(x,
     # remove genus as first word
     x <- gsub("^Genus ", "", x)
     # allow characters that resemble others
-    x <- gsub("[iy]+", "[iy]+", x, ignore.case = TRUE)
-    x <- gsub("[sz]+", "[sz]+", x, ignore.case = TRUE)
-    x <- gsub("(c|k|q|qu)+", "(c|k|q|qu)+", x, ignore.case = TRUE)
-    x <- gsub("(ph|f|v)+", "(ph|f|v)+", x, ignore.case = TRUE)
-    x <- gsub("(th|t)+", "(th|t)+", x, ignore.case = TRUE)
-    x <- gsub("a+", "a+", x, ignore.case = TRUE)
-    # allow any ending of -um, -us, -ium, -ius and -a (needs perl for the negative backward lookup):
-    x <- gsub("(um|u\\[sz\\]\\+|\\[iy\\]\\+um|\\[iy\\]\\+u\\[sz\\]\\+|a\\+)(?![a-z[])",
-              "(um|us|ium|ius|a)", x, ignore.case = TRUE, perl = TRUE)
-    x <- gsub("e+", "e+", x, ignore.case = TRUE)
-    x <- gsub("o+", "o+", x, ignore.case = TRUE)
-
+    if (initial_search == FALSE) {
+      x <- tolower(x)
+      x <- gsub("[iy]+", "[iy]+", x)
+      x <- gsub("(c|k|q|qu|s|z|x|ks)+", "(c|k|q|qu|s|z|x|ks)+", x)
+      x <- gsub("(ph|f|v)+", "(ph|f|v)+", x)
+      x <- gsub("(th|t)+", "(th|t)+", x)
+      x <- gsub("a+", "a+", x)
+      x <- gsub("u+", "u+", x)
+      # allow any ending of -um, -us, -ium, -ius and -a (needs perl for the negative backward lookup):
+      x <- gsub("(um|u\\[sz\\]\\+|\\[iy\\]\\+um|\\[iy\\]\\+u\\[sz\\]\\+|a\\+)(?![a-z[])",
+                "(um|us|ium|ius|a)", x, ignore.case = TRUE, perl = TRUE)
+      x <- gsub("e+", "e+", x, ignore.case = TRUE)
+      x <- gsub("o+", "o+", x, ignore.case = TRUE)
+      x <- gsub("(.)\\1+", "\\1+", x)
+    }
     x <- strip_whitespace(x)
 
     x_trimmed <- x
@@ -639,7 +642,7 @@ exec_as.mo <- function(x,
           }
           next
         }
-        if (toupper(x_backup_without_spp[i]) %in% c("EHEC", "EPEC", "EIEC", "STEC", "ATEC")
+        if (toupper(x_backup_without_spp[i]) %in% c("AIEC", "ATEC", "DAEC", "EAEC", "EHEC", "EIEC", "EPEC", "ETEC", "NMEC", "STEC", "UPEC")
             | x_backup_without_spp[i] %like% "O?(26|103|104|104|111|121|145|157)") {
           x[i] <- microorganismsDT[mo == 'B_ESCHR_COL', ..property][[1]][1L]
           if (initial_search == TRUE) {
@@ -1481,3 +1484,13 @@ translate_allow_uncertain <- function(allow_uncertain) {
   }
   allow_uncertain
 }
+
+#' @exportMethod scale_type.mo
+#' @export
+#' @noRd
+scale_type.mo <- function(x) {
+  # fix for:
+  # "Don't know how to automatically pick scale for object of type mo. Defaulting to continuous."
+  # "Error: Discrete value supplied to continuous scale"
+  "discrete"
+}

R/mo_property.R

@@ -238,7 +238,8 @@ mo_kingdom <- function(x, language = get_locale(), ...) {
   x <- as.mo(x, ...)
   kngdm <- mo_validate(x = x, property = "kingdom", ...)
   if (language != "en") {
-    kngdm[x == "UNKNOWN"] <- t(kngdm[x == "UNKNOWN"], language = language)
+    # translate only unknown, so "Bacteria" (the official taxonomic name) would not change
+    kngdm[identical(x, "UNKNOWN")] <- t(kngdm[identical(x, "UNKNOWN")], language = language)
   }
   kngdm
 }

R/zzz.R

@@ -51,6 +51,31 @@
 
 }
 
+
+.onAttach <- function(...) {
+  if (interactive()) {
+    console_width <- options()$width - 1
+    url <- "https://www.surveymonkey.com/r/AMR_for_R"
+    txt <- paste("Thanks for using the AMR package!",
+                 "As researchers, we are interested in how and why you use this package and if there are things you're missing from it.",
+                 "Please fill in our 2-minute survey at:", url)
+
+    # make it honour new lines bases on console width:
+    txt <- unlist(strsplit(txt, " "))
+    txt_new <- ""
+    total_chars <- 0
+    for (i in 1:length(txt)) {
+      total_chars <- total_chars + nchar(txt[i]) + 1
+      if (total_chars > console_width) {
+        txt_new <- paste0(txt_new, "\n")
+        total_chars <- 0
+      }
+      txt_new <- paste0(txt_new, txt[i], " ")
+    }
+    packageStartupMessage(txt_new)
+  }
+}
+
 #' @importFrom data.table as.data.table setkey
 make_DT <- function() {
   microorganismsDT <- as.data.table(AMR::microorganisms)