(v1.4.0.9021) more robust class setting

R/aa_helper_functions.R

@@ -670,7 +670,7 @@ progress_ticker <- function(n = 1, n_min = 0, ...) {
     pb$kill <- function() {
       invisible()
     }
-    structure(pb, class = "txtProgressBar")
+    set_clean_class(pb, new_class = "txtProgressBar")
   } else if (n >= n_min) {
     pb <- utils::txtProgressBar(max = n, style = 3)
     pb$tick <- function() {
@@ -680,6 +680,21 @@ progress_ticker <- function(n = 1, n_min = 0, ...) {
   }
 }
 
+set_clean_class <- function(x, new_class) {
+  if (is.null(x)) {
+    x <- NA_character_
+  }
+  if (is.factor(x)) {
+    lvls <- levels(x)
+    attributes(x) <- NULL
+    levels(x) <- lvls
+  } else {
+    attributes(x) <- NULL
+  }
+  class(x) <- new_class
+  x
+}
+
 create_pillar_column <- function(x, ...) {
   new_pillar_shaft_simple <- import_fn("new_pillar_shaft_simple", "pillar", error_on_fail = FALSE)
   if (!is.null(new_pillar_shaft_simple)) {

R/ab.R

@@ -97,8 +97,8 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = TRUE, ...) {
   
   if (all(toupper(x) %in% antibiotics$ab)) {
     # valid AB code, but not yet right class
-    return(structure(.Data = toupper(x),
-                     class = c("ab", "character")))
+    return(set_clean_class(toupper(x),
+                           new_class = c("ab", "character")))
   }
   
   x_bak <- x
@@ -455,8 +455,8 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = TRUE, ...) {
     x_result <- NA_character_
   }
   
-  structure(.Data = x_result,
-            class = c("ab", "character"))
+  set_clean_class(x_result,
+                  new_class = c("ab", "character"))
 }
 
 #' @rdname as.ab

R/ab_property.R

@@ -263,7 +263,7 @@ ab_validate <- function(x, property, ...) {
      pm_pull(property)
   }
   if (property == "ab") {
-    return(structure(x, class = property))
+    return(set_clean_class(x, new_class = c("ab", "character")))
   } else if (property == "cid") {
     return(as.integer(x))
   } else if (property %like% "ddd") {

R/age.R

@@ -139,13 +139,14 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
 #'
 #' \donttest{
 #' # resistance of ciprofloxacin per age group
-#' library(dplyr)
-#' example_isolates %>%
-#'   filter_first_isolate() %>%
-#'   filter(mo == as.mo("E. coli")) %>%
-#'   group_by(age_group = age_groups(age)) %>%
-#'   select(age_group, CIP) %>%
-#'   ggplot_rsi(x = "age_group", minimum = 0)
+#' if (require("dplyr")) {
+#'   example_isolates %>%
+#'     filter_first_isolate() %>%
+#'     filter(mo == as.mo("E. coli")) %>%
+#'     group_by(age_group = age_groups(age)) %>%
+#'     select(age_group, CIP) %>%
+#'     ggplot_rsi(x = "age_group", minimum = 0)
+#' }
 #' }
 age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
   meet_criteria(x, allow_class = c("numeric", "integer"))

R/bug_drug_combinations.R

@@ -106,7 +106,8 @@ bug_drug_combinations <- function(x,
     out <- rbind(out, out_group, stringsAsFactors = FALSE)
   }
   
-  structure(.Data = out, class = c("bug_drug_combinations", x_class))
+  set_clean_class(out,
+                  new_class = c("bug_drug_combinations", x_class))
 }
 
 #' @method format bug_drug_combinations
@@ -245,7 +246,8 @@ format.bug_drug_combinations <- function(x,
 #' @export
 print.bug_drug_combinations <- function(x, ...) {
   x_class <- class(x)
-  print(structure(x, class = x_class[x_class != "bug_drug_combinations"]),
+  print(set_clean_class(x, 
+                        new_class = x_class[x_class != "bug_drug_combinations"]),
         ...)
   message_("Use 'format()' on this result to get a publishable/printable format.", as_note = FALSE)
 }

R/catalogue_of_life.R

@@ -107,8 +107,8 @@ catalogue_of_life_version <- function() {
                   n_total_species = nrow(microorganisms),
                   n_total_synonyms = nrow(microorganisms.old)))
   
-  structure(.Data = lst,
-            class = c("catalogue_of_life_version", "list"))
+  set_clean_class(lst,
+                  new_class = c("catalogue_of_life_version", "list"))
 }
 
 #' @method print catalogue_of_life_version

R/disk.R

@@ -39,7 +39,6 @@
 #' @examples
 #' \donttest{
 #' # transform existing disk zones to the `disk` class
-#' library(dplyr)
 #' df <- data.frame(microorganism = "E. coli",
 #'                  AMP = 20,
 #'                  CIP = 14,
@@ -107,8 +106,8 @@ as.disk <- function(x, na.rm = FALSE) {
                list_missing, call = FALSE)
     }
   }
-  structure(as.integer(x),
-            class = c("disk", "integer"))
+  set_clean_class(as.integer(x),
+                  new_class = c("disk", "integer"))
 }
 
 all_valid_disks <- function(x) {

R/mic.R

@@ -131,8 +131,8 @@ as.mic <- function(x, na.rm = FALSE) {
                list_missing, call = FALSE)
     }
     
-    structure(.Data = factor(x, levels = lvls, ordered = TRUE),
-              class =  c("mic", "ordered", "factor"))
+    set_clean_class(factor(x, levels = lvls, ordered = TRUE),
+                    new_class =  c("mic", "ordered", "factor"))
   }
 }
 

R/mo.R

@@ -175,7 +175,7 @@ as.mo <- function(x,
                & isFALSE(Lancefield), error = function(e) FALSE)) {
     # don't look into valid MO codes, just return them
     # is.mo() won't work - MO codes might change between package versions
-    return(to_class_mo(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)
@@ -228,12 +228,8 @@ as.mo <- function(x,
                      ...)
   }
 
-  to_class_mo(y)
-}
-
-to_class_mo <- function(x) {
-  structure(.Data = x,
-            class = c("mo", "character"))
+  set_clean_class(y,
+                  new_class = c("mo", "character"))
 }
 
 #' @rdname as.mo
@@ -399,7 +395,8 @@ exec_as.mo <- function(x,
   # all empty
   if (all(identical(trimws(x_input), "") | is.na(x_input) | length(x) == 0)) {
     if (property == "mo") {
-      return(to_class_mo(rep(NA_character_, length(x_input))))
+      return(set_clean_class(rep(NA_character_, length(x_input)),
+                             new_class = c("mo", "character")))
     } else {
       return(rep(NA_character_, length(x_input)))
     }
@@ -1499,7 +1496,7 @@ exec_as.mo <- function(x,
   x <- df_found$found[match(df_input$input, df_found$input)]
 
   if (property == "mo") {
-    x <- to_class_mo(x)
+    x <- set_clean_class(x, new_class = c("mo", "character"))
   }
 
   if (length(mo_renamed()) > 0) {
@@ -1740,8 +1737,9 @@ mo_uncertainties <- function() {
   if (is.null(getOption("mo_uncertainties"))) {
     return(NULL)
   }
-  structure(.Data = as.data.frame(getOption("mo_uncertainties"), stringsAsFactors = FALSE),
-            class = c("mo_uncertainties", "data.frame"))
+  set_clean_class(as.data.frame(getOption("mo_uncertainties"), 
+                                stringsAsFactors = FALSE),
+                  new_class = c("mo_uncertainties", "data.frame"))
 }
 
 #' @method print mo_uncertainties
@@ -1814,8 +1812,9 @@ mo_renamed <- function() {
   } else {
     items <- pm_distinct(items, old_name, .keep_all = TRUE)
   }
-  structure(.Data = items,
-            class = c("mo_renamed", "data.frame"))
+  set_clean_class(as.data.frame(items,
+                                stringsAsFactors = FALSE),
+                  new_class = c("mo_renamed", "data.frame"))
 }
 
 #' @method print mo_renamed

R/rsi.R

@@ -223,17 +223,15 @@ is.rsi.eligible <- function(x, threshold = 0.05) {
 #' @export
 as.rsi.default <- function(x, ...) {
   if (is.rsi(x)) {
-    x
-  } else if (all(is.na(x)) || identical(levels(x), c("S", "I", "R"))) {
-    structure(.Data = factor(x, levels = c("S", "I", "R"), ordered = TRUE),
-              class =  c("rsi", "ordered", "factor"))
-  } else if (inherits(x, "integer") & all(x %in% c(1:3, NA))) {
+    return(x)
+  }
+  
+  if (inherits(x, "integer") & all(x %in% c(1:3, NA))) {
     x[x == 1] <- "S"
     x[x == 2] <- "I"
     x[x == 3] <- "R"
-    structure(.Data = factor(x, levels = c("S", "I", "R"), ordered = TRUE),
-              class =  c("rsi", "ordered", "factor"))
-  } else {
+    
+  } else if (!all(is.na(x)) && !identical(levels(x), c("S", "I", "R"))) {
     
     if (!any(x %like% "(R|S|I)", na.rm = TRUE)) {
       # check if they are actually MICs or disks now that the antibiotic name is valid
@@ -280,10 +278,10 @@ as.rsi.default <- function(x, ...) {
                  list_missing, call = FALSE)
       }
     }
-    
-    structure(.Data = factor(x, levels = c("S", "I", "R"), ordered = TRUE),
-              class =  c("rsi", "ordered", "factor"))
   }
+  
+  set_clean_class(factor(x, levels = c("S", "I", "R"), ordered = TRUE),
+                  new_class =  c("rsi", "ordered", "factor"))
 }
 
 #' @rdname as.rsi
@@ -804,8 +802,8 @@ exec_as.rsi <- function(method,
   
   load_mo_failures_uncertainties_renamed(metadata_mo)
   
-  structure(.Data = factor(new_rsi, levels = c("S", "I", "R"), ordered = TRUE),
-            class =  c("rsi", "ordered", "factor"))
+  set_clean_class(factor(new_rsi, levels = c("S", "I", "R"), ordered = TRUE),
+                  new_class =  c("rsi", "ordered", "factor"))
 }
 
 # will be exported using s3_register() in R/zzz.R