(v1.5.0.9022) mo properties speed improvement

R/aa_helper_functions.R

@@ -112,7 +112,7 @@ check_dataset_integrity <- function() {
     require("AMR")
   })
   stop_if(!valid_microorganisms | !valid_antibiotics,
-          "the data set `microorganisms` or `antibiotics` was overwritten in your environment because another package with the same object names was loaded _after_ the AMR package, preventing the AMR package from working correctly. Please load the AMR package last.")
+          "the data set `microorganisms` or `antibiotics` was overwritten in your environment because another package with the same object name(s) was loaded _after_ the AMR package, preventing the AMR package from working correctly. Please load the AMR package last.")
   invisible(TRUE)
 }
 
@@ -538,7 +538,7 @@ meet_criteria <- function(object,
   if (!is.null(pkg_env$meet_criteria_error_txt)) {
     error_txt <- pkg_env$meet_criteria_error_txt
     pkg_env$meet_criteria_error_txt <- NULL
-    stop(error_txt, call. = FALSE)
+    stop(error_txt, call. = FALSE) # don't use stop_() here, pkg may not be loaded yet
   }
   pkg_env$meet_criteria_error_txt <- NULL
 
@@ -867,7 +867,13 @@ font_grey <- function(..., collapse = " ") {
   try_colour(..., before = "\033[38;5;249m", after = "\033[39m", collapse = collapse)
 }
 font_grey_bg <- function(..., collapse = " ") {
-  try_colour(..., before = "\033[48;5;254m", after = "\033[49m", collapse = collapse)
+  if (tryCatch(rstudioapi::getThemeInfo()$dark == TRUE, error = function(e) FALSE)) {
+    # similar to HTML #444444
+    try_colour(..., before = "\033[48;5;238m", after = "\033[49m", collapse = collapse)  
+  } else {
+    # similar to HTML #eeeeee
+    try_colour(..., before = "\033[48;5;254m", after = "\033[49m", collapse = collapse)
+  }
 }
 font_green_bg <- function(..., collapse = " ") {
   try_colour(..., before = "\033[42m", after = "\033[49m", collapse = collapse)

R/mo.R

@@ -178,13 +178,6 @@ as.mo <- function(x,
     return(set_clean_class(x, new_class = c("mo", "character")))
   }
 
-  if (tryCatch(all(x == "" | gsub(".*(unknown ).*", "unknown name", tolower(x), perl = TRUE) %in% MO_lookup$fullname_lower, na.rm = TRUE)
-               & isFALSE(Becker)
-               & isFALSE(Lancefield), error = function(e) FALSE)) {
-    # to improve speed, special case for taxonomically correct full names (case-insensitive)
-    return(MO_lookup[match(gsub(".*(unknown ).*", "unknown name", tolower(x), perl = TRUE), MO_lookup$fullname_lower), "mo", drop = TRUE])
-  }
-
   # start off with replaced language-specific non-ASCII characters with ASCII characters
   x <- parse_and_convert(x)
   # replace mo codes used in older package versions
@@ -198,6 +191,13 @@ as.mo <- function(x,
   x[trimws2(x) %like% translate_AMR("no .*growth", language = language)] <- NA_character_
   x[trimws2(x) %like% paste0("^(", translate_AMR("no|not", language = language), ") [a-z]+")] <- "UNKNOWN"
   uncertainty_level <- translate_allow_uncertain(allow_uncertain)
+  
+  if (tryCatch(all(x == "" | gsub(".*(unknown ).*", "unknown name", tolower(x), perl = TRUE) %in% MO_lookup$fullname_lower, na.rm = TRUE)
+               & isFALSE(Becker)
+               & isFALSE(Lancefield), error = function(e) FALSE)) {
+    # to improve speed, special case for taxonomically correct full names (case-insensitive)
+    return(MO_lookup[match(gsub(".*(unknown ).*", "unknown name", tolower(x), perl = TRUE), MO_lookup$fullname_lower), "mo", drop = TRUE])
+  }
 
   if (!is.null(reference_df)
       && check_validity_mo_source(reference_df)
@@ -481,11 +481,11 @@ exec_as.mo <- function(x,
     
     # Fill in fullnames and MO codes at once
     known_names <- tolower(x_backup) %in% MO_lookup$fullname_lower
-    x[known_names] <- MO_lookup[match(tolower(x_backup)[known_names], MO_lookup$fullname), property, drop = TRUE]
+    x[known_names] <- MO_lookup[match(tolower(x_backup)[known_names], MO_lookup$fullname_lower), property, drop = TRUE]
     known_codes <- toupper(x_backup) %in% MO_lookup$mo
     x[known_codes] <- MO_lookup[match(toupper(x_backup)[known_codes], MO_lookup$mo), property, drop = TRUE]
     already_known <- known_names | known_codes
-    
+
     # now only continue where the right taxonomic output is not already known
     if (any(!already_known)) {
       x_known <- x[already_known]
@@ -984,7 +984,6 @@ exec_as.mo <- function(x,
                               g.x_backup_without_spp %pm>% substr(1, x_length / 2),
                               ".* ",
                               g.x_backup_without_spp %pm>% substr((x_length / 2) + 1, x_length))
-            print(x_split)
             found <- lookup(fullname_lower %like_case% x_split,
                             haystack = data_to_check)
             if (!is.na(found)) {
@@ -1977,13 +1976,13 @@ parse_and_convert <- function(x) {
       if (NCOL(x) > 2) {
         stop("a maximum of two columns is allowed", call. = FALSE)
       } else if (NCOL(x) == 2) {
-        # support Tidyverse selection like: df %pm>% select(colA, colB)
+        # support Tidyverse selection like: df %>% select(colA, colB)
         # paste these columns together
         x <- as.data.frame(x, stringsAsFactors = FALSE)
         colnames(x) <- c("A", "B")
         x <- paste(x$A, x$B)
       } else {
-        # support Tidyverse selection like: df %pm>% select(colA)
+        # support Tidyverse selection like: df %>% select(colA)
         x <- as.data.frame(x, stringsAsFactors = FALSE)[[1]]
       }
     }
@@ -1991,6 +1990,8 @@ parse_and_convert <- function(x) {
     parsed <- iconv(x, to = "UTF-8")
     parsed[is.na(parsed) & !is.na(x)] <- iconv(x[is.na(parsed) & !is.na(x)], from = "Latin1", to = "ASCII//TRANSLIT")
     parsed <- gsub('"', "", parsed, fixed = TRUE)
+    parsed <- gsub(" +", " ", parsed, perl = TRUE)
+    parsed <- trimws(parsed)
   }, error = function(e) stop(e$message, call. = FALSE)) # this will also be thrown when running `as.mo(no_existing_object)`
   parsed
 }

R/mo_property.R

@@ -694,22 +694,22 @@ mo_property <- function(x, property = "fullname", language = get_locale(), ...)
 
 mo_validate <- function(x, property, language, ...) {
   check_dataset_integrity()
-  
-  if (tryCatch(all(x[!is.na(x)] %in% MO_lookup$mo) & length(list(...)) == 0, error = function(e) FALSE)) {
-    # special case for mo_* functions where class is already <mo>
-    return(MO_lookup[match(x, MO_lookup$mo), property, drop = TRUE])
-  }
-  
   dots <- list(...)
   Becker <- dots$Becker
-  if (is.null(Becker)) {
+  if (is.null(Becker) | property %in% c("kingdom", "phylum", "class", "order", "family", "genus")) {
     Becker <- FALSE
   }
   Lancefield <- dots$Lancefield
-  if (is.null(Lancefield)) {
+  if (is.null(Lancefield) | property %in% c("kingdom", "phylum", "class", "order", "family", "genus")) {
     Lancefield <- FALSE
   }
+  has_Becker_or_Lancefield <- Becker %in% c(TRUE, "all") | Lancefield %in% c(TRUE, "all")
   
+  if (tryCatch(all(x[!is.na(x)] %in% MO_lookup$mo) & !has_Becker_or_Lancefield, error = function(e) FALSE)) {
+    # special case for mo_* functions where class is already <mo>
+    return(MO_lookup[match(x, MO_lookup$mo), property, drop = TRUE])
+  }
+
   # try to catch an error when inputting an invalid argument
   # so the 'call.' can be set to FALSE
   tryCatch(x[1L] %in% MO_lookup[1, property, drop = TRUE],
@@ -722,8 +722,13 @@ mo_validate <- function(x, property, language, ...) {
     # because it's already a valid MO
     x <- exec_as.mo(x, property = property, initial_search = FALSE, language = language, ...)
   } else if (!all(x %in% MO_lookup[, property, drop = TRUE])
-             | Becker %in% c(TRUE, "all")
-             | Lancefield %in% c(TRUE, "all")) {
+             | has_Becker_or_Lancefield) {
+    accepted_args <- names(as.list(args("as.mo")))
+    accepted_args <- accepted_args[!accepted_args %in% c("", "...", "x", "property")]
+    stop_if(!all(names(dots) %in% names(as.list(args("as.mo")))),
+            "invalid argument(s): ", vector_and(names(dots)[!names(dots) %in% names(as.list(args("as.mo")))], quotes = "'"),
+            ".\nAccepted arguments are ", vector_and(accepted_args, quotes = "'"), ".",
+            call = FALSE)
     x <- exec_as.mo(x, property = property, language = language, ...)
   }