mirror of
https://github.com/msberends/AMR.git
synced 2025-07-08 16:42:10 +02:00
(v1.3.0.9007) tibble printing
This commit is contained in:
16
R/disk.R
16
R/disk.R
@ -114,6 +114,22 @@ is.disk <- function(x) {
|
||||
inherits(x, "disk")
|
||||
}
|
||||
|
||||
#' @method pillar_shaft disk
|
||||
#' @export
|
||||
pillar_shaft.disk <- function(x, ...) {
|
||||
style_na <- import_fn("style_na", "pillar", error_on_fail = FALSE)
|
||||
new_pillar_shaft_simple <- import_fn("new_pillar_shaft_simple", "pillar", error_on_fail = FALSE)
|
||||
out <- trimws(format(x))
|
||||
out[is.na(x)] <- style_na(NA)
|
||||
new_pillar_shaft_simple(out, align = "right", min_width = 3)
|
||||
}
|
||||
|
||||
#' @method type_sum disk
|
||||
#' @export
|
||||
type_sum.disk <- function(x, ...) {
|
||||
"disk"
|
||||
}
|
||||
|
||||
#' @method print disk
|
||||
#' @export
|
||||
#' @noRd
|
||||
|
@ -350,6 +350,9 @@ eucast_rules <- function(x,
|
||||
verbose = verbose,
|
||||
...)
|
||||
|
||||
# data preparation ----
|
||||
message(font_blue("NOTE: Preparing data..."), appendLF = FALSE)
|
||||
|
||||
AMC <- cols_ab["AMC"]
|
||||
AMK <- cols_ab["AMK"]
|
||||
AMP <- cols_ab["AMP"]
|
||||
@ -429,7 +432,7 @@ eucast_rules <- function(x,
|
||||
rule_name = character(0),
|
||||
stringsAsFactors = FALSE)
|
||||
|
||||
# helper function for editing the table
|
||||
# helper function for editing the table ----
|
||||
edit_rsi <- function(to, rule, rows, cols) {
|
||||
cols <- unique(cols[!is.na(cols) & !is.null(cols)])
|
||||
if (length(rows) > 0 & length(cols) > 0) {
|
||||
@ -508,10 +511,21 @@ eucast_rules <- function(x,
|
||||
changed = 0))
|
||||
}
|
||||
|
||||
# save original table
|
||||
|
||||
old_cols <- colnames(x)
|
||||
old_attributes <- attributes(x)
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE) # no tibbles, data.tables, etc.
|
||||
# create unique row IDs - combination of the MO and all ABx columns (so they will only run once per unique combination)
|
||||
x$`.rowid` <- sapply(as.list(as.data.frame(t(x[, c(col_mo, cols_ab), drop = FALSE]))), function(x) {
|
||||
x[is.na(x)] <- "."
|
||||
paste0(x, collapse = "")
|
||||
})
|
||||
|
||||
# save original table, with the new .rowid column
|
||||
x_original.bak <- x
|
||||
# keep only unique rows for MO and ABx
|
||||
x <- x %>% distinct(`.rowid`, .keep_all = TRUE)
|
||||
x_original <- x
|
||||
x_original_attr <- attributes(x)
|
||||
x_original <- as.data.frame(x_original, stringsAsFactors = FALSE) # no tibbles, data.tables, etc.
|
||||
|
||||
# join to microorganisms data set
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||
@ -520,6 +534,7 @@ eucast_rules <- function(x,
|
||||
left_join_microorganisms(by = col_mo, suffix = c("_oldcols", ""))
|
||||
x$gramstain <- mo_gramstain(x[, col_mo, drop = TRUE], language = NULL)
|
||||
x$genus_species <- paste(x$genus, x$species)
|
||||
message(font_blue("OK."))
|
||||
|
||||
if (ab_missing(AMP) & !ab_missing(AMX)) {
|
||||
# ampicillin column is missing, but amoxicillin is available
|
||||
@ -528,7 +543,7 @@ eucast_rules <- function(x,
|
||||
}
|
||||
|
||||
# nolint start
|
||||
# antibiotic classes
|
||||
# antibiotic classes ----
|
||||
aminoglycosides <- c(TOB, GEN, KAN, NEO, NET, SIS)
|
||||
tetracyclines <- c(DOX, MNO, TCY) # since EUCAST v3.1 tigecycline (TGC) is set apart
|
||||
polymyxins <- c(PLB, COL)
|
||||
@ -544,7 +559,7 @@ eucast_rules <- function(x,
|
||||
fluoroquinolones <- c(OFX, CIP, NOR, LVX, MFX)
|
||||
# nolint end
|
||||
|
||||
# Help function to get available antibiotic column names ------------------
|
||||
# help function to get available antibiotic column names ------------------
|
||||
get_antibiotic_columns <- function(x, df) {
|
||||
x <- trimws(unlist(strsplit(x, ",", fixed = TRUE)))
|
||||
y <- character(0)
|
||||
@ -923,7 +938,12 @@ eucast_rules <- function(x,
|
||||
verbose_info
|
||||
} else {
|
||||
# reset original attributes
|
||||
attributes(x_original) <- x_original_attr
|
||||
x_original
|
||||
x_original <- x_original[, c(col_mo, cols_ab, ".rowid"), drop = FALSE]
|
||||
x_original.bak <- x_original.bak[, setdiff(colnames(x_original.bak), c(col_mo, cols_ab)), drop = FALSE]
|
||||
x_original.bak <- x_original.bak %>%
|
||||
left_join(x_original, by = ".rowid")
|
||||
x_original.bak <- x_original.bak[, old_cols, drop = FALSE]
|
||||
attributes(x_original.bak) <- old_attributes
|
||||
x_original.bak
|
||||
}
|
||||
}
|
||||
|
16
R/mic.R
16
R/mic.R
@ -171,6 +171,22 @@ droplevels.mic <- function(x, exclude = ifelse(anyNA(levels(x)), NULL, NA), ...)
|
||||
x
|
||||
}
|
||||
|
||||
#' @method pillar_shaft mic
|
||||
#' @export
|
||||
pillar_shaft.mic <- function(x, ...) {
|
||||
style_na <- import_fn("style_na", "pillar", error_on_fail = FALSE)
|
||||
new_pillar_shaft_simple <- import_fn("new_pillar_shaft_simple", "pillar", error_on_fail = FALSE)
|
||||
out <- trimws(format(x))
|
||||
out[is.na(x)] <- style_na(NA)
|
||||
new_pillar_shaft_simple(out, align = "right", min_width = 4)
|
||||
}
|
||||
|
||||
#' @method type_sum mic
|
||||
#' @export
|
||||
type_sum.mic <- function(x, ...) {
|
||||
"mic"
|
||||
}
|
||||
|
||||
#' @method print mic
|
||||
#' @export
|
||||
#' @noRd
|
||||
|
49
R/mo.R
49
R/mo.R
@ -159,7 +159,8 @@
|
||||
#' select(microorganism_name) %>%
|
||||
#' as.mo()
|
||||
#'
|
||||
#' # and can even contain 2 columns, which is convenient for genus/species combinations:
|
||||
#' # and can even contain 2 columns, which is convenient
|
||||
#' # for genus/species combinations:
|
||||
#' df$mo <- df %>%
|
||||
#' select(genus, species) %>%
|
||||
#' as.mo()
|
||||
@ -459,13 +460,15 @@ exec_as.mo <- function(x,
|
||||
x <- gsub("(th|ht|t)+", "(th|ht|t)+", x)
|
||||
x <- gsub("a+", "a+", x)
|
||||
x <- gsub("u+", "u+", x)
|
||||
# allow any ending of -um, -us, -ium, -icum, -ius, -icus, -ica and -a (needs perl for the negative backward lookup):
|
||||
# allow any ending of -um, -us, -ium, -icum, -ius, -icus, -ica, -ia and -a (needs perl for the negative backward lookup):
|
||||
x <- gsub("(u\\+\\(c\\|k\\|q\\|qu\\+\\|s\\|z\\|x\\|ks\\)\\+)(?![a-z])",
|
||||
"(u[s|m]|[iy][ck]?u[ms]|[iy]?[ck]?a)", x, perl = TRUE)
|
||||
x <- gsub("(\\[iy\\]\\+\\(c\\|k\\|q\\|qu\\+\\|s\\|z\\|x\\|ks\\)\\+a\\+)(?![a-z])",
|
||||
"(u[s|m]|[iy][ck]?u[ms]|[iy]?[ck]?a)", x, perl = TRUE)
|
||||
x <- gsub("(\\[iy\\]\\+u\\+m)(?![a-z])",
|
||||
"(u[s|m]|[iy][ck]?u[ms]|[iy]?[ck]?a)", x, perl = TRUE)
|
||||
x <- gsub("(\\[iy\\]\\+a\\+)(?![a-z])",
|
||||
"([iy]*a+|[iy]+a*)", x, perl = TRUE)
|
||||
x <- gsub("e+", "e+", x)
|
||||
x <- gsub("o+", "o+", x)
|
||||
x <- gsub("(.)\\1+", "\\1+", x)
|
||||
@ -636,7 +639,7 @@ exec_as.mo <- function(x,
|
||||
}
|
||||
|
||||
# translate known trivial abbreviations to genus + species ----
|
||||
if (toupper(x_backup_without_spp[i]) %in% c("MRSA", "MSSA", "VISA", "VRSA")
|
||||
if (toupper(x_backup_without_spp[i]) %in% c("MRSA", "MSSA", "VISA", "VRSA", "BORSA")
|
||||
| x_backup_without_spp[i] %like_case% " (mrsa|mssa|visa|vrsa) ") {
|
||||
x[i] <- lookup(fullname == "Staphylococcus aureus")
|
||||
next
|
||||
@ -1523,12 +1526,50 @@ format_uncertainty_as_df <- function(uncertainty_level,
|
||||
df
|
||||
}
|
||||
|
||||
#' @method pillar_shaft mo
|
||||
#' @export
|
||||
pillar_shaft.mo <- function(x, ...) {
|
||||
# import from the pillar package, without being dependent on it!
|
||||
style_na <- import_fn("style_na", "pillar", error_on_fail = FALSE)
|
||||
style_subtle <- import_fn("style_subtle", "pillar", error_on_fail = FALSE)
|
||||
new_pillar_shaft_simple <- import_fn("new_pillar_shaft_simple", "pillar", error_on_fail = FALSE)
|
||||
if (is.null(style_na) | is.null(style_subtle) | is.null(new_pillar_shaft_simple)) {
|
||||
return(x)
|
||||
}
|
||||
|
||||
out <- format(x)
|
||||
# grey out the kingdom (part until first "_")
|
||||
out[!is.na(x)] <- gsub("^([A-Z]+_)(.*)", paste0(style_subtle("\\1"), "\\2"), out[!is.na(x)])
|
||||
# and grey out every _
|
||||
out[!is.na(x)] <- gsub("_", style_subtle("_"), out[!is.na(x)])
|
||||
|
||||
# markup NA and UNKNOWN
|
||||
out[is.na(x)] <- style_na(" NA")
|
||||
out[x == "UNKNOWN"] <- style_na(" UNKNOWN")
|
||||
|
||||
# make it always fit exactly
|
||||
new_pillar_shaft_simple(out,
|
||||
align = "left",
|
||||
width = max(nchar(x)) + ifelse(length(x[x %in% c(NA, "UNKNOWN")]) > 0,
|
||||
2,
|
||||
0))
|
||||
}
|
||||
|
||||
#' @method type_sum mo
|
||||
#' @export
|
||||
type_sum.mo <- function(x, ...) {
|
||||
"mo"
|
||||
}
|
||||
|
||||
#' @method print mo
|
||||
#' @export
|
||||
#' @noRd
|
||||
print.mo <- function(x, ...) {
|
||||
print.mo <- function(x, print.shortnames = FALSE, ...) {
|
||||
cat("Class <mo>\n")
|
||||
x_names <- names(x)
|
||||
if (is.null(x_names) & print.shortnames == TRUE) {
|
||||
x_names <- tryCatch(mo_shortname(x, ...), error = function(e) NULL)
|
||||
}
|
||||
x <- as.character(x)
|
||||
names(x) <- x_names
|
||||
print.default(x, quote = FALSE)
|
||||
|
@ -161,13 +161,18 @@ mo_shortname <- function(x, language = get_locale(), ...) {
|
||||
}
|
||||
|
||||
# get first char of genus and complete species in English
|
||||
shortnames <- paste0(substr(mo_genus(x.mo, language = NULL), 1, 1), ". ", replace_empty(mo_species(x.mo, language = NULL)))
|
||||
genera <- mo_genus(x.mo, language = NULL)
|
||||
shortnames <- paste0(substr(genera, 1, 1), ". ", replace_empty(mo_species(x.mo, language = NULL)))
|
||||
|
||||
# exceptions for where no species is known
|
||||
shortnames[shortnames %like% ".[.] spp[.]"] <- genera[shortnames %like% ".[.] spp[.]"]
|
||||
# exceptions for Staphylococci
|
||||
shortnames[shortnames == "S. coagulase-negative"] <- "CoNS"
|
||||
shortnames[shortnames == "S. coagulase-positive"] <- "CoPS"
|
||||
# exceptions for Streptococci: Streptococcus Group A -> GAS
|
||||
shortnames[shortnames %like% "S. group [ABCDFGHK]"] <- paste0("G", gsub("S. group ([ABCDFGHK])", "\\1", shortnames[shortnames %like% "S. group [ABCDFGHK]"]), "S")
|
||||
# unknown species etc.
|
||||
shortnames[shortnames %like% "unknown"] <- paste0("(", trimws(gsub("[^a-zA-Z -]", "", shortnames[shortnames %like% "unknown"])), ")")
|
||||
|
||||
load_mo_failures_uncertainties_renamed(metadata)
|
||||
translate_AMR(shortnames, language = language, only_unknown = FALSE)
|
||||
|
18
R/rsi.R
18
R/rsi.R
@ -670,6 +670,24 @@ exec_as.rsi <- function(method,
|
||||
class = c("rsi", "ordered", "factor"))
|
||||
}
|
||||
|
||||
#' @method pillar_shaft rsi
|
||||
#' @export
|
||||
pillar_shaft.rsi <- function(x, ...) {
|
||||
out <- trimws(format(x))
|
||||
out[is.na(x)] <- font_grey(" NA")
|
||||
out[x == "S"] <- font_green_bg(font_white(" S "))
|
||||
out[x == "I"] <- font_yellow_bg(font_black(" I "))
|
||||
out[x == "R"] <- font_red_bg(font_white(" R "))
|
||||
new_pillar_shaft_simple <- import_fn("new_pillar_shaft_simple", "pillar", error_on_fail = FALSE)
|
||||
new_pillar_shaft_simple(out, align = "left", width = 3)
|
||||
}
|
||||
|
||||
#' @method type_sum rsi
|
||||
#' @export
|
||||
type_sum.rsi <- function(x, ...) {
|
||||
"rsi"
|
||||
}
|
||||
|
||||
#' @method print rsi
|
||||
#' @export
|
||||
#' @noRd
|
||||
|
55
R/zzz.R
55
R/zzz.R
@ -27,7 +27,19 @@
|
||||
assign(x = "MO.old_lookup",
|
||||
value = create_MO.old_lookup(),
|
||||
envir = asNamespace("AMR"))
|
||||
|
||||
# support for tibble headers (type_sum) and tibble columns content (pillar_shaft)
|
||||
s3_register("pillar::pillar_shaft", "mo")
|
||||
s3_register("tibble::type_sum", "mo")
|
||||
s3_register("pillar::pillar_shaft", "rsi")
|
||||
s3_register("tibble::type_sum", "rsi")
|
||||
s3_register("pillar::pillar_shaft", "mic")
|
||||
s3_register("tibble::type_sum", "mic")
|
||||
s3_register("pillar::pillar_shaft", "disk")
|
||||
s3_register("tibble::type_sum", "disk")
|
||||
}
|
||||
pillar_shaft <- import_fn("pillar_shaft", "pillar", error_on_fail = FALSE)
|
||||
type_sum <- import_fn("type_sum", "tibble", error_on_fail = FALSE)
|
||||
|
||||
.onAttach <- function(...) {
|
||||
if (!interactive() || stats::runif(1) > 0.1 || isTRUE(as.logical(Sys.getenv("AMR_silentstart", FALSE)))) {
|
||||
@ -73,3 +85,46 @@ create_MO.old_lookup <- function() {
|
||||
# so arrange data on prevalence first, then full name
|
||||
MO.old_lookup[order(MO.old_lookup$prevalence, MO.old_lookup$fullname_lower), ]
|
||||
}
|
||||
|
||||
# copied from vctrs::s3_register
|
||||
s3_register <- function (generic, class, method = NULL) {
|
||||
stopifnot(is.character(generic), length(generic) == 1)
|
||||
stopifnot(is.character(class), length(class) == 1)
|
||||
pieces <- strsplit(generic, "::")[[1]]
|
||||
stopifnot(length(pieces) == 2)
|
||||
package <- pieces[[1]]
|
||||
generic <- pieces[[2]]
|
||||
caller <- parent.frame()
|
||||
get_method_env <- function() {
|
||||
top <- topenv(caller)
|
||||
if (isNamespace(top)) {
|
||||
asNamespace(environmentName(top))
|
||||
}
|
||||
else {
|
||||
caller
|
||||
}
|
||||
}
|
||||
get_method <- function(method, env) {
|
||||
if (is.null(method)) {
|
||||
get(paste0(generic, ".", class), envir = get_method_env())
|
||||
}
|
||||
else {
|
||||
method
|
||||
}
|
||||
}
|
||||
method_fn <- get_method(method)
|
||||
stopifnot(is.function(method_fn))
|
||||
setHook(packageEvent(package, "onLoad"), function(...) {
|
||||
ns <- asNamespace(package)
|
||||
method_fn <- get_method(method)
|
||||
registerS3method(generic, class, method_fn, envir = ns)
|
||||
})
|
||||
if (!isNamespaceLoaded(package)) {
|
||||
return(invisible())
|
||||
}
|
||||
envir <- asNamespace(package)
|
||||
if (exists(generic, envir)) {
|
||||
registerS3method(generic, class, method_fn, envir = envir)
|
||||
}
|
||||
invisible()
|
||||
}
|
||||
|
Reference in New Issue
Block a user