(v1.7.1.9010) fix for count_* and proportion_*

R/ab_class_selectors.R

@@ -266,12 +266,13 @@ ab_selector <- function(function_name,
   meet_criteria(function_name, allow_class = "character", has_length = 1, allow_NULL = TRUE, .call_depth = 1)
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1, .call_depth = 1)
   meet_criteria(ab_class, allow_class = "character", has_length = 1, allow_NULL = TRUE, .call_depth = 1)
-
+  
   # get_current_data() has to run each time, for cases where e.g., filter() and select() are used in same call
+  # but it only takes a couple of milliseconds
   vars_df <- get_current_data(arg_name = NA, call = -3)
   # to improve speed, get_column_abx() will only run once when e.g. in a select or group call
   ab_in_data <- get_column_abx(vars_df, info = FALSE, only_rsi_columns = only_rsi_columns, sort = FALSE)
-  
+
   if (length(ab_in_data) == 0) {
     message_("No antimicrobial agents found in the data.")
     return(NULL)
@@ -312,7 +313,7 @@ ab_selector <- function(function_name,
                       paste0("\"", ab_class, "\""),
                       ""),
                ")` using ",
-               ifelse(length(agents) == 1, "column: ", "columns: "),
+               ifelse(length(agents) == 1, "column ", "columns "),
                vector_and(agents_formatted, quotes = FALSE, sort = FALSE))
     }
     remember_thrown_message(paste0(function_name, ".", paste(pkg_env$get_column_abx.out, collapse = "|")))

R/mo_property.R

@@ -222,9 +222,12 @@ mo_shortname <- function(x, language = get_locale(), ...) {
   
   shortnames[is.na(x.mo)] <- NA_character_
   load_mo_failures_uncertainties_renamed(metadata)
-  translate_AMR(shortnames, language = language, only_unknown = FALSE, only_affect_mo_names = TRUE)
+  out <- translate_AMR(shortnames, language = language, only_unknown = FALSE, only_affect_mo_names = TRUE)
+  set_clean_class(out, new_class = c("taxonomic_name", "character"))
 }
 
+
+
 #' @rdname mo_property
 #' @export
 mo_subspecies <- function(x, language = get_locale(), ...) {
@@ -723,20 +726,24 @@ mo_validate <- function(x, property, language, ...) {
   
   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],
-           error = function(e) stop(e$message, call. = FALSE))
+    x <- MO_lookup[match(x, MO_lookup$mo), property, drop = TRUE]
 
-  if (!all(x[!is.na(x)] %in% MO_lookup[, property, drop = TRUE]) | has_Becker_or_Lancefield) {
-    x <- exec_as.mo(x, property = property, language = language, ...)
+  } else {
+    # 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],
+             error = function(e) stop(e$message, call. = FALSE))
+    
+    if (!all(x[!is.na(x)] %in% MO_lookup[, property, drop = TRUE]) | has_Becker_or_Lancefield) {
+      x <- exec_as.mo(x, property = property, language = language, ...)
+    }
   }
   
   if (property == "mo") {
     return(set_clean_class(x, new_class = c("mo", "character")))
+  } else if (property %in% c("fullname", "genus", "family")) {
+    # shortname is considered in mo_shortname()
+    return(set_clean_class(x, new_class = c("taxonomic_name", "character")))
   } else if (property == "snomed") {
     return(as.double(eval(parse(text = x))))
   } else {
@@ -762,3 +769,87 @@ find_mo_col <- function(fn) {
     stop_("argument `x` is missing and no column with info about microorganisms could be found.", call = -2)
   }
 }
+
+#' @method print taxonomic_name
+#' @export
+#' @noRd
+print.taxonomic_name <- function(x, ...) {
+  print(unclass(x), ...)
+}
+
+#' @method as.data.frame taxonomic_name
+#' @export
+#' @noRd
+as.data.frame.taxonomic_name <- function(x, ...) {
+  nm <- deparse1(substitute(x))
+  if (!"nm" %in% names(list(...))) {
+    as.data.frame.vector(x, ..., nm = nm)
+  } else {
+    as.data.frame.vector(x, ...)
+  }
+}
+
+# will be exported using s3_register() in R/zzz.R
+type_sum.taxonomic_name <- function(x, ...) {
+  "chr"
+}
+
+# will be exported using s3_register() in R/zzz.R
+pillar_shaft.taxonomic_name <- function(x, ...) {
+  out <- format(x)
+  hits <- tolower(x) %in% MO_lookup$fullname_lower | tolower(gsub("[^a-zA-Z ]", "", x)) %in% c(MO_lookup$g_species)
+  # grey out the kingdom (part until first "_")
+  out[hits] <- font_italic(x[hits], collapse = NULL)
+  out[is.na(x)] <- font_na(out[is.na(x)], collapse = NULL)
+  create_pillar_column(out, align = "left")
+}
+
+#' @method [ taxonomic_name
+#' @export
+#' @noRd
+"[.taxonomic_name" <- function(x, ...) {
+  y <- NextMethod()
+  attributes(y) <- attributes(x)
+  y
+}
+#' @method [[ taxonomic_name
+#' @export
+#' @noRd
+"[[.taxonomic_name" <- function(x, ...) {
+  y <- NextMethod()
+  attributes(y) <- attributes(x)
+  y
+}
+#' @method [<- taxonomic_name
+#' @export
+#' @noRd
+"[<-.taxonomic_name" <- function(i, j, ..., value) {
+  value <- set_clean_class(value, c("taxonomic_name", "character"))
+  y <- NextMethod()
+  attributes(y) <- attributes(i)
+  y
+}
+#' @method [[<- taxonomic_name
+#' @export
+#' @noRd
+"[[<-.taxonomic_name" <- function(i, j, ..., value) {
+  value <- set_clean_class(value, c("taxonomic_name", "character"))
+  y <- NextMethod()
+  attributes(y) <- attributes(i)
+  y
+}
+#' @method c taxonomic_name
+#' @export
+#' @noRd
+c.taxonomic_name <- function(...) {
+  set_clean_class(unlist(lapply(list(...), as.character)), c("taxonomic_name", "character"))
+}
+
+#' @method unique taxonomic_name
+#' @export
+#' @noRd
+unique.taxonomic_name <- function(x, incomparables = FALSE, ...) {
+  y <- NextMethod()
+  attributes(y) <- attributes(x)
+  y
+}

R/rsi_calc.R

@@ -27,12 +27,7 @@ dots2vars <- function(...) {
   # this function is to give more informative output about 
   # variable names in count_* and proportion_* functions
   dots <- substitute(list(...))
-  agents <- as.character(dots)[2:length(dots)]
-  agents_formatted <- paste0("'", font_bold(agents, collapse = NULL), "'")
-  agents_names <- ab_name(agents, tolower = TRUE, language = NULL)
-  need_name <- generalise_antibiotic_name(agents) != agents_names
-  agents_formatted[need_name] <- paste0(agents_formatted[need_name], " (", agents_names[need_name], ")")
-  vector_and(agents_formatted, quotes = FALSE)
+  as.character(dots)[2:length(dots)]
 }
 
 rsi_calc <- function(...,

R/zzz.R

@@ -48,11 +48,13 @@ if (utf8_supported && !is_latex) {
   s3_register("pillar::pillar_shaft", "rsi")
   s3_register("pillar::pillar_shaft", "mic")
   s3_register("pillar::pillar_shaft", "disk")
+  s3_register("pillar::pillar_shaft", "taxonomic_name")
   s3_register("tibble::type_sum", "ab")
   s3_register("tibble::type_sum", "mo")
   s3_register("tibble::type_sum", "rsi")
   s3_register("tibble::type_sum", "mic")
   s3_register("tibble::type_sum", "disk")
+  s3_register("tibble::type_sum", "taxonomic_name")
   # Support for frequency tables from the cleaner package
   s3_register("cleaner::freq", "mo")
   s3_register("cleaner::freq", "rsi")