(v1.6.0.9017) extra system codes

R/aa_helper_functions.R

@@ -129,11 +129,14 @@ check_dataset_integrity <- function() {
     } else {
       plural <- c(" is", "s", "")
     }
-    warning_("The following data set", plural[1],
-             " overwritten by your global environment and prevent", plural[2], 
-             " the AMR package from working correctly: ",
-             vector_and(overwritten, quotes = "'"),
-             ".\nPlease rename your object", plural[3], ".", call = FALSE)
+    if (message_not_thrown_before("dataset_overwritten")) {
+      warning_("The following data set", plural[1],
+               " overwritten by your global environment and prevent", plural[2], 
+               " the AMR package from working correctly: ",
+               vector_and(overwritten, quotes = "'"),
+               ".\nPlease rename your object", plural[3], ".", call = FALSE)
+      remember_thrown_message("dataset_overwritten")
+    }
   }
   # check if other packages did not overwrite our data sets
   valid_microorganisms <- TRUE
@@ -838,13 +841,6 @@ message_not_thrown_before <- function(fn, entire_session = FALSE) {
   is.null(pkg_env[[paste0("thrown_msg.", fn)]]) || !identical(pkg_env[[paste0("thrown_msg.", fn)]], unique_call_id(entire_session))
 }
 
-reset_all_thrown_messages <- function() {
-  # for unit tests, where the environment and highest system call do not change
-  pkg_env_contents <- ls(envir = pkg_env)
-  rm(list = pkg_env_contents[pkg_env_contents %like% "^thrown_msg."],
-     envir = pkg_env)
-}
-
 has_colour <- function() {
   # this is a base R version of crayon::has_color, but disables colours on emacs
   

R/ab.R

@@ -169,8 +169,6 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
       next
     }
     if (identical(x[i], "") |
-        # no short names:
-        nchar(x[i]) <= 2 |
         # prevent "bacteria" from coercing to TMP, since Bacterial is a brand name of it:
         identical(tolower(x[i]), "bacteria")) {
       x_unknown <- c(x_unknown, x_bak[x[i] == x_bak_clean][1])
@@ -238,7 +236,8 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
     
     # exact abbreviation
     abbr_found <- unlist(lapply(AB_lookup$generalised_abbreviations,
-                                function(s) x[i] %in% s))
+                                # require at least 2 characters for abbreviations
+                                function(s) x[i] %in% s & nchar(x[i]) >= 2))
     found <- antibiotics$ab[abbr_found == TRUE]
     if (length(found) > 0) {
       x_new[i] <- note_if_more_than_one_found(found, i, from_text)

R/custom_eucast_rules.R

@@ -223,59 +223,6 @@ print.custom_eucast_rules <- function(x, ...) {
   }
 }
 
-run_custom_eucast_rules <- function(df, rule, info) {
-  n_dots <- length(rule)
-  stop_if(n_dots == 0, "no custom rules set", call = -2)
-  out <- character(length = NROW(df))
-  reasons <- character(length = NROW(df))
-  for (i in seq_len(n_dots)) {
-    qry <- tryCatch(eval(parse(text = rule[[i]]$query), envir = df, enclos = parent.frame()),
-                    error = function(e) { 
-                      pkg_env$err_msg <- e$message
-                      return("error")
-                    })
-    if (identical(qry, "error")) {
-      warning_("in custom_eucast_rules(): rule ", i, 
-               " (`", as.character(rule[[i]]$query), "`) was ignored because of this error message: ",
-               pkg_env$err_msg,
-               call = FALSE, 
-               add_fn = font_red)
-      next
-    }
-    stop_ifnot(is.logical(qry), "in custom_eucast_rules(): rule ", i, " (`", rule[[i]]$query, 
-               "`) must return `TRUE` or `FALSE`, not ", 
-               format_class(class(qry), plural = FALSE), call = FALSE)
-    
-    new_eucasts <- which(qry == TRUE & out == "")
-    
-    if (info == TRUE) {
-      cat(word_wrap("- Custom EUCAST rule ", i, ": `", as.character(rule[[i]]$query),
-                    "` (", length(new_eucasts),  " rows matched)"), "\n", sep = "")
-    }
-    val <- rule[[i]]$value
-    out[new_eucasts] <- val
-    reasons[new_eucasts] <- paste0("matched rule ", gsub("rule", "", names(rule)[i]), ": ", as.character(rule[[i]]$query))
-  }
-  out[out == ""] <- "Negative"
-  reasons[out == "Negative"] <- "no rules matched"
-  
-  if (isTRUE(attributes(rule)$as_factor)) {
-    out <- factor(out, levels = attributes(rule)$values, ordered = TRUE)
-  }
-  
-  columns_nonsusceptible <- as.data.frame(t(df[, is.rsi(df)] == "R"))
-  columns_nonsusceptible <- vapply(FUN.VALUE = character(1), 
-                                   columns_nonsusceptible, 
-                                   function(x) paste0(rownames(columns_nonsusceptible)[which(x)], collapse = " "))
-  columns_nonsusceptible[is.na(out)] <- NA_character_
-  
-  data.frame(row_number = seq_len(NROW(df)),
-             EUCAST = out,
-             reason = reasons,
-             columns_nonsusceptible = columns_nonsusceptible,
-             stringsAsFactors = FALSE)
-}
-
 format_custom_query_rule <- function(query, colours = has_colour()) {
   query <- gsub(" & ", font_black(font_bold(" and ")), query, fixed = TRUE)
   query <- gsub(" | ", font_black(" or "), query, fixed = TRUE)