1
0
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:
2020-08-26 11:33:54 +02:00
parent c8c8bb4e3a
commit 5e45fdcf2a
64 changed files with 266 additions and 77 deletions

View File

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

View File

@ -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
View File

@ -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
View File

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

View File

@ -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
View File

@ -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
View File

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