(v1.5.0.9013) updated tibble printing colours

R/aa_helper_functions.R

@@ -802,13 +802,13 @@ font_green_bg <- function(..., collapse = " ") {
   try_colour(..., before = "\033[42m", after = "\033[49m", collapse = collapse)
 }
 font_rsi_R_bg <- function(..., collapse = " ") {
-  try_colour(..., before = "\033[48;5;202m", after = "\033[49m", collapse = collapse)
+  try_colour(..., before = "\033[48;5;210m", after = "\033[49m", collapse = collapse)
 }
 font_rsi_S_bg <- function(..., collapse = " ") {
-  try_colour(..., before = "\033[48;5;76m", after = "\033[49m", collapse = collapse)
+  try_colour(..., before = "\033[48;5;113m", after = "\033[49m", collapse = collapse)
 }
 font_rsi_I_bg <- function(..., collapse = " ") {
-  try_colour(..., before = "\033[48;5;148m", after = "\033[49m", collapse = collapse)
+  try_colour(..., before = "\033[48;5;185m", after = "\033[49m", collapse = collapse)
 }
 font_red_bg <- function(..., collapse = " ") {
   try_colour(..., before = "\033[41m", after = "\033[49m", collapse = collapse)

R/ab_class_selectors.R

@@ -25,7 +25,7 @@
 
 #' Antibiotic Class Selectors
 #' 
-#' These functions help to select the columns of antibiotics that are of a specific antibiotic class, without the need to define the columns or antibiotic abbreviations.
+#' These functions help to select the columns of antibiotics that are of a specific antibiotic class, without the need to define the columns or antibiotic abbreviations. \strong{\Sexpr{ifelse(as.double(R.Version()$major) + (as.double(R.Version()$minor) / 10) < 3.2, paste0("NOTE: THESE FUNCTIONS DO NOT WORK ON YOUR CURRENT R VERSION. These functions require R version 3.2 or later - you have ", R.version.string, "."), "")}}
 #' @inheritSection lifecycle Stable Lifecycle
 #' @inheritParams filter_ab_class 
 #' @details \strong{\Sexpr{ifelse(as.double(R.Version()$major) + (as.double(R.Version()$minor) / 10) < 3.2, paste0("NOTE: THESE FUNCTIONS DO NOT WORK ON YOUR CURRENT R VERSION. These functions require R version 3.2 or later - you have ", R.version.string, "."), "")}}

R/mo.R

@@ -2018,7 +2018,7 @@ repair_reference_df <- function(reference_df) {
 }
 
 strip_words <- function(text, n, side = "right") {
-  out <- lapply(strsplit(x, " "), function(x) {
+  out <- lapply(strsplit(text, " "), function(x) {
     if (side %like% "^r" & length(x) > n) {
       x[seq_len(length(x) - n)]
     } else if (side %like% "^l" & length(x) > n) {

R/pca.R

@@ -47,7 +47,7 @@
 #'   # calculate the resistance per group first 
 #'   resistance_data <- example_isolates %>% 
 #'     group_by(order = mo_order(mo),       # group on anything, like order
-#'              genus = mo_genus(mo)) %>%   #  and genus as we do here
+#'              genus = mo_genus(mo)) %>%   #   and genus as we do here;
 #'     summarise_if(is.rsi, resistance)     # then get resistance of all drugs
 #'     
 #'   # now conduct PCA for certain antimicrobial agents
@@ -99,7 +99,7 @@ pca <- function(x,
     
     x <- as.data.frame(new_list, stringsAsFactors = FALSE)
     if (any(vapply(FUN.VALUE = logical(1), x, function(y) !is.numeric(y)))) {
-      warning_("Be sure to first calculate the resistance (or susceptibility) of variables with antimicrobial test results, since PCA works with numeric variables only. See Examples in ?pca.")
+      warning_("Be sure to first calculate the resistance (or susceptibility) of variables with antimicrobial test results, since PCA works with numeric variables only. See Examples in ?pca.", call = FALSE)
     }
     
     # set column names
@@ -117,11 +117,51 @@ pca <- function(x,
   
   pca_data <- x[, which(vapply(FUN.VALUE = logical(1), x, function(x) is.numeric(x)))]
   
-  message_("Columns selected for PCA: ", paste0(font_bold(colnames(pca_data)), collapse = "/"),
+  message_("Columns selected for PCA: ", vector_or(font_bold(colnames(pca_data), collapse = NULL),
+                                                   quotes = "'",
+                                                   last_sep = " and "),
            ". Total observations available: ", nrow(pca_data), ".")
   
-  pca_model <- prcomp(pca_data, retx = retx, center = center, scale. = scale., tol = tol, rank. = rank.)
-  attr(pca_model, "non_numeric_cols") <- x[, vapply(FUN.VALUE = logical(1), x, function(y) !is.numeric(y) & !all(is.na(y))), drop = FALSE]
+  if (as.double(R.Version()$major) + (as.double(R.Version()$minor) / 10) < 3.4) {
+    # stats::prcomp prior to 3.4.0 does not have the 'rank.' argument
+    pca_model <- prcomp(pca_data, retx = retx, center = center, scale. = scale., tol = tol)
+  } else {
+    pca_model <- prcomp(pca_data, retx = retx, center = center, scale. = scale., tol = tol, rank. = rank.)
+  }
+  groups <- x[, vapply(FUN.VALUE = logical(1), x, function(y) !is.numeric(y) & !all(is.na(y))), drop = FALSE]
+  rownames(groups) <- NULL
+  attr(pca_model, "non_numeric_cols") <- groups
   class(pca_model) <- c("pca", class(pca_model))
   pca_model
 }
+
+#' @method print pca
+#' @export
+#' @noRd
+print.pca <- function(x, ...) {
+  a <- attributes(x)$non_numeric_cols
+  if (!is.null(a)) {
+    print_pca_group(a)
+    class(x) <- class(x)[class(x) != "pca"]
+  }
+  print(x, ...)
+}
+
+#' @method summary pca
+#' @export
+#' @noRd
+summary.pca <- function(object, ...) {
+  a <- attributes(object)$non_numeric_cols
+  if (!is.null(a)) {
+    print_pca_group(a)
+    class(object) <- class(object)[class(object) != "pca"]
+  }
+  summary(object, ...)
+}
+
+print_pca_group <- function(a) {
+  grps <- sort(unique(a[, 1, drop = TRUE]))
+  cat("Groups (n=", length(grps), ", named as '", colnames(a)[1], "'):\n", sep = "")
+  print(grps)
+  cat("\n")
+}

R/rsi.R

@@ -848,10 +848,14 @@ exec_as.rsi <- function(method,
 # will be exported using s3_register() in R/zzz.R
 pillar_shaft.rsi <- function(x, ...) {
   out <- trimws(format(x))
-  out[is.na(x)] <- font_grey(" NA")
-  out[x == "R"] <- font_rsi_R_bg(font_black("  R  "))
-  out[x == "S"] <- font_rsi_S_bg(font_black("  S  "))
-  out[x == "I"] <- font_rsi_I_bg(font_black("  I  "))
+  if (has_colour()) {
+    # colours will anyway not work when has_colour() == FALSE,
+    # but then the indentation should also not be applied
+    out[is.na(x)] <- font_grey(" NA")
+    out[x == "R"] <- font_rsi_R_bg(font_black("  R  "))
+    out[x == "S"] <- font_rsi_S_bg(font_black("  S  "))
+    out[x == "I"] <- font_rsi_I_bg(font_black("  I  "))
+  }
   create_pillar_column(out, align = "left", width = 5)
 }