1
0
mirror of https://github.com/msberends/AMR.git synced 2025-07-09 13:42:04 +02:00

(v1.5.0.9013) updated tibble printing colours

This commit is contained in:
2021-01-28 16:09:30 +01:00
parent 331c1f6508
commit 20d638c193
39 changed files with 162 additions and 108 deletions

View File

@ -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)

View File

@ -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, "."), "")}}

2
R/mo.R
View File

@ -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) {

50
R/pca.R
View File

@ -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")
}

12
R/rsi.R
View File

@ -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)
}