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:
@ -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)
|
||||
|
@ -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
2
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) {
|
||||
|
50
R/pca.R
50
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")
|
||||
}
|
||||
|
12
R/rsi.R
12
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)
|
||||
}
|
||||
|
||||
|
Reference in New Issue
Block a user