P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-07-09 06:51:48 +02:00
Code Releases Activity

(v1.3.0.9010) S3 extensions without dependencies

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2020-08-28 21:55:47 +02:00
parent 81af0b001c
commit 74a172ef55
49 changed files with 227 additions and 156 deletions
Download Patch File Download Diff File Expand all files Collapse all files

58
R/aa_helper_functions.R
View File

@ -444,6 +444,9 @@ font_red_bg <- function(..., collapse = " ") {
font_yellow_bg <- function(..., collapse = " ") {
try_colour(..., before = "\033[43m", after = "\033[49m", collapse = collapse)
}
font_na <- function(..., collapse = " ") {
font_red(..., collapse = collapse)
}
font_bold <- function(..., collapse = " ") {
try_colour(..., before = "\033[1m", after = "\033[22m", collapse = collapse)
}
@ -477,6 +480,61 @@ progress_estimated <- function(n = 1, n_min = 0, ...) {
}
}
create_pillar_column <- function(x, ...) {
new_pillar_shaft_simple <- import_fn("new_pillar_shaft_simple", "pillar", error_on_fail = FALSE)
if (!is.null(new_pillar_shaft_simple)) {
new_pillar_shaft_simple(x, ...)
} else {
# does not exist in package 'pillar' anymore
structure(list(x),
class = "pillar_shaft_simple",
...)
}
}
# copied from vctrs::s3_register by their permission
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()
}
# works exactly like round(), but rounds `round2(44.55, 1)` to 44.6 instead of 44.5
# and adds decimal zeroes until `digits` is reached when force_zero = TRUE
round2 <- function(x, digits = 0, force_zero = TRUE) {

18
R/ab.R
View File

@ -467,22 +467,14 @@ is.ab <- function(x) {
inherits(x, "ab")
}
#' @method pillar_shaft ab
#' @export
# will be exported using s3_register() in R/zzz.R
pillar_shaft.ab <- function(x, ...) {
# import from the pillar package, without being dependent on it!
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 <- format(x)
out[is.na(x)] <- style_na(NA)
new_pillar_shaft_simple(out,
align = "left",
min_width = 4)
out <- trimws(format(x))
out[is.na(x)] <- font_na(NA)
create_pillar_column(out, align = "left", min_width = 4)
}
#' @method type_sum ab
#' @export
# will be exported using s3_register() in R/zzz.R
type_sum.ab <- function(x, ...) {
"ab"
}

12
R/disk.R
View File

@ -114,18 +114,14 @@ is.disk <- function(x) {
inherits(x, "disk")
}
#' @method pillar_shaft disk
#' @export
# will be exported using s3_register() in R/zzz.R
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)
out[is.na(x)] <- font_na(NA)
create_pillar_column(out, align = "right", width = 2)
}
#' @method type_sum disk
#' @export
# will be exported using s3_register() in R/zzz.R
type_sum.disk <- function(x, ...) {
"disk"
}

12
R/mic.R
View File

@ -171,18 +171,14 @@ droplevels.mic <- function(x, exclude = ifelse(anyNA(levels(x)), NULL, NA), ...)
x
}
#' @method pillar_shaft mic
#' @export
# will be exported using s3_register() in R/zzz.R
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)
out[is.na(x)] <- font_na(NA)
create_pillar_column(out, align = "right", min_width = 4)
}
#' @method type_sum mic
#' @export
# will be exported using s3_register() in R/zzz.R
type_sum.mic <- function(x, ...) {
"mic"
}

69
R/mo.R
View File

@ -181,7 +181,7 @@ as.mo <- function(x,
x <- parse_and_convert(x)
# replace mo codes used in older package versions
x <- replace_old_mo_codes(x, property = "mo")
# WHONET: xxx = no growth
x[tolower(as.character(paste0(x, ""))) %in% c("", "xxx", "na", "nan")] <- NA_character_
# Laboratory systems: remove entries like "no growth" etc
@ -384,7 +384,7 @@ exec_as.mo <- function(x,
x <- data.frame(fullname = x, stringsAsFactors = FALSE) %>%
left_join_MO_lookup(by = "fullname") %>%
pull(property)
} else if (all(toupper(x) %in% microorganisms.codes$code)) {
# commonly used MO codes
x <- data.frame(code = toupper(x), stringsAsFactors = FALSE) %>%
@ -1526,41 +1526,54 @@ format_uncertainty_as_df <- function(uncertainty_level,
df
}
#' @method pillar_shaft mo
#' @export
# will be exported using s3_register() in R/zzz.R
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)])
out[!is.na(x)] <- gsub("^([A-Z]+_)(.*)", paste0(font_subtle("\\1"), "\\2"), out[!is.na(x)])
# and grey out every _
out[!is.na(x)] <- gsub("_", style_subtle("_"), out[!is.na(x)])
out[!is.na(x)] <- gsub("_", font_subtle("_"), out[!is.na(x)])
# markup NA and UNKNOWN
out[is.na(x)] <- style_na(" NA")
out[x == "UNKNOWN"] <- style_na(" UNKNOWN")
out[is.na(x)] <- font_na(" NA")
out[x == "UNKNOWN"] <- font_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))
create_pillar_column(out,
align = "left",
width = max(nchar(x)) + ifelse(any(x %in% c(NA, "UNKNOWN")), 2, 0))
}
#' @method type_sum mo
#' @export
# will be exported using s3_register() in R/zzz.R
type_sum.mo <- function(x, ...) {
"mo"
}
# will be exported using s3_register() in R/zzz.R
freq.mo <- function(x, ...) {
x_noNA <- as.mo(x[!is.na(x)]) # as.mo() to get the newest mo codes
grams <- mo_gramstain(x_noNA, language = NULL)
digits <- list(...)$digits
if (is.null(digits)) {
digits <- 2
}
freq.default <- import_fn("freq.default", "cleaner", error_on_fail = FALSE)
freq.default(x = x, ...,
.add_header = list(`Gram-negative` = paste0(format(sum(grams == "Gram-negative", na.rm = TRUE),
big.mark = ",",
decimal.mark = "."),
" (", percentage(sum(grams == "Gram-negative", na.rm = TRUE) / length(grams), digits = digits),
")"),
`Gram-positive` = paste0(format(sum(grams == "Gram-positive", na.rm = TRUE),
big.mark = ",",
decimal.mark = "."),
" (", percentage(sum(grams == "Gram-positive", na.rm = TRUE) / length(grams), digits = digits),
")"),
`No. of genera` = n_distinct(mo_genus(x_noNA, language = NULL)),
`No. of species` = n_distinct(paste(mo_genus(x_noNA, language = NULL),
mo_species(x_noNA, language = NULL)))))
}
#' @method print mo
#' @export
#' @noRd
@ -1584,11 +1597,11 @@ summary.mo <- function(object, ...) {
top <- as.data.frame(table(x), responseName = "n", stringsAsFactors = FALSE)
top_3 <- top[order(-top$n), 1][1:3]
value <- c("Class" = "mo",
"<NA>" = length(x[is.na(x)]),
"Unique" = n_distinct(x[!is.na(x)]),
"#1" = top_3[1],
"#2" = top_3[2],
"#3" = top_3[3])
"<NA>" = length(x[is.na(x)]),
"Unique" = n_distinct(x[!is.na(x)]),
"#1" = top_3[1],
"#2" = top_3[2],
"#3" = top_3[3])
class(value) <- c("summaryDefault", "table")
value
}

36
R/rsi.R
View File

@ -670,24 +670,42 @@ exec_as.rsi <- function(method,
class = c("rsi", "ordered", "factor"))
}
#' @method pillar_shaft rsi
#' @export
# 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 == "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)
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 "))
create_pillar_column(out, align = "left", width = 5)
}
#' @method type_sum rsi
#' @export
# will be exported using s3_register() in R/zzz.R
type_sum.rsi <- function(x, ...) {
"rsi"
}
# will be exported using s3_register() in R/zzz.R
freq.rsi <- function(x, ...) {
x_name <- deparse(substitute(x))
x_name <- gsub(".*[$]", "", x_name)
ab <- suppressMessages(suppressWarnings(as.ab(x_name)))
freq.default <- import_fn("freq.default", "cleaner", error_on_fail = FALSE)
digits <- list(...)$digits
if (is.null(digits)) {
digits <- 2
}
if (!is.na(ab)) {
freq.default(x = x, ...,
.add_header = list(Drug = paste0(ab_name(ab, language = NULL), " (", ab, ", ", ab_atc(ab), ")"),
`Drug group` = ab_group(ab, language = NULL),
`%SI` = percentage(susceptibility(x, minimum = 0, as_percent = FALSE), digits = digits)))
} else {
freq.default(x = x, ...,
.add_header = list(`%SI` = percentage(susceptibility(x, minimum = 0, as_percent = FALSE), digits = digits)))
}
}
#' @method print rsi
#' @export
#' @noRd

61
R/zzz.R
View File

@ -29,6 +29,7 @@
envir = asNamespace("AMR"))
# support for tibble headers (type_sum) and tibble columns content (pillar_shaft)
# without the need to depend on other packages
s3_register("pillar::pillar_shaft", "ab")
s3_register("tibble::type_sum", "ab")
s3_register("pillar::pillar_shaft", "mo")
@ -39,9 +40,10 @@
s3_register("tibble::type_sum", "mic")
s3_register("pillar::pillar_shaft", "disk")
s3_register("tibble::type_sum", "disk")
# support for frequency tables
s3_register("cleaner::freq", "mo")
s3_register("cleaner::freq", "rsi")
}
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)))) {
@ -66,9 +68,9 @@ create_MO_lookup <- function() {
MO_lookup$fullname_lower <- tolower(trimws(paste(MO_lookup$genus,
MO_lookup$species,
MO_lookup$subspecies)))
MO_lookup[MO_lookup$genus == "" | grepl("^[(]unknown ", MO_lookup$fullname), "fullname_lower"] <- tolower(trimws(MO_lookup[MO_lookup$genus == "" | grepl("^[(]unknown ", MO_lookup$fullname),
"fullname"]))
MO_lookup$fullname_lower <- gsub("[^.a-z0-9/ \\-]+", "", MO_lookup$fullname_lower)
ind <- MO_lookup$genus == "" | grepl("^[(]unknown ", MO_lookup$fullname)
MO_lookup[ind, "fullname_lower"] <- tolower(MO_lookup[ind, "fullname"])
MO_lookup$fullname_lower <- trimws(gsub("[^.a-z0-9/ \\-]+", "", MO_lookup$fullname_lower))
# add a column with only "e coli" like combinations
MO_lookup$g_species <- gsub("^([a-z])[a-z]+ ([a-z]+) ?.*", "\\1 \\2", MO_lookup$fullname_lower)
@ -79,54 +81,11 @@ create_MO_lookup <- function() {
create_MO.old_lookup <- function() {
MO.old_lookup <- AMR::microorganisms.old
MO.old_lookup$fullname_lower <- gsub("[^.a-z0-9/ \\-]+", "", tolower(trimws(MO.old_lookup$fullname)))
MO.old_lookup$fullname_lower <- trimws(gsub("[^.a-z0-9/ \\-]+", "", tolower(trimws(MO.old_lookup$fullname))))
# add a column with only "e coli" like combinations
MO.old_lookup$g_species <- gsub("^([a-z])[a-z]+ ([a-z]+) ?.*", "\\1 \\2", MO.old_lookup$fullname_lower)
# add a column with only "e coli"-like combinations
MO.old_lookup$g_species <- trimws(gsub("^([a-z])[a-z]+ ([a-z]+) ?.*", "\\1 \\2", MO.old_lookup$fullname_lower))
# 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()
}