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

reftbl in plots, speedup for as.sir() and mo_validate

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2023-07-10 16:43:46 +02:00
parent 70c601ca11
commit a4e2e25e3f
14 changed files with 128 additions and 65 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
R/aa_globals.R
View File

@ -60,19 +60,19 @@ EUCAST_VERSION_EXPERT_RULES <- list(
version_txt = "v3.3",
year = 2021,
title = "'EUCAST Expert Rules' and 'EUCAST Intrinsic Resistance and Unusual Phenotypes'",
url = "https://www.eucast.org/expert_rules_and_expected_phenotypes/"
url = "https://www.eucast.org/expert_rules_and_expected_phenotypes"
),
"3.2" = list(
version_txt = "v3.2",
year = 2020,
title = "'EUCAST Expert Rules' and 'EUCAST Intrinsic Resistance and Unusual Phenotypes'",
url = "https://www.eucast.org/expert_rules_and_expected_phenotypes/"
url = "https://www.eucast.org/expert_rules_and_expected_phenotypes"
),
"3.1" = list(
version_txt = "v3.1",
year = 2016,
title = "'EUCAST Expert Rules, Intrinsic Resistance and Exceptional Phenotypes'",
url = "https://www.eucast.org/expert_rules_and_expected_phenotypes/"
url = "https://www.eucast.org/expert_rules_and_expected_phenotypes"
)
)
# EUCAST_VERSION_RESISTANTPHENOTYPES <- list(
@ -80,7 +80,7 @@ EUCAST_VERSION_EXPERT_RULES <- list(
# version_txt = "v1.2",
# year = 2023,
# title = "'Expected Resistant Phenotypes'",
# url = "https://www.eucast.org/expert_rules_and_expected_phenotypes/"
# url = "https://www.eucast.org/expert_rules_and_expected_phenotypes"
# )
# )

12
R/aa_helper_functions.R
View File

@ -1237,7 +1237,7 @@ font_grey_bg <- function(..., collapse = " ") {
}
font_red_bg <- function(..., collapse = " ") {
# this is #ed553b (picked to be colourblind-safe with other SIR colours)
try_colour(font_black(..., collapse = collapse), before = "\033[48;5;203m", after = "\033[49m", collapse = collapse)
try_colour(font_black(..., collapse = collapse, adapt = FALSE), before = "\033[48;5;203m", after = "\033[49m", collapse = collapse)
}
font_orange_bg <- function(..., collapse = " ") {
# this is #f6d55c (picked to be colourblind-safe with other SIR colours)
@ -1533,19 +1533,17 @@ readRDS_AMR <- function(file, refhook = NULL) {
# Faster data.table implementations ----
match <- function(x, table, ...) {
chmatch <- import_fn("chmatch", "data.table", error_on_fail = FALSE)
if (!is.null(chmatch) && is.character(x) && is.character(table)) {
if (!is.null(AMR_env$chmatch) && inherits(x, "character") && inherits(table, "character")) {
# data.table::chmatch() is much faster than base::match() for character
chmatch(x, table, ...)
AMR_env$chmatch(x, table, ...)
} else {
base::match(x, table, ...)
}
}
`%in%` <- function(x, table) {
chin <- import_fn("%chin%", "data.table", error_on_fail = FALSE)
if (!is.null(chin) && is.character(x) && is.character(table)) {
if (!is.null(AMR_env$chin) && inherits(x, "character") && inherits(table, "character")) {
# data.table::`%chin%`() is much faster than base::`%in%`() for character
chin(x, table)
AMR_env$chin(x, table)
} else {
base::`%in%`(x, table)
}

6
R/mo.R
View File

@ -628,6 +628,12 @@ pillar_shaft.mo <- function(x, ...) {
)
}
# add the names to the bugs as mouse-over!
if (tryCatch(isTRUE(getExportedValue("ansi_has_hyperlink_support", ns = asNamespace("cli"))()), error = function(e) FALSE)) {
out[!x %in% c("UNKNOWN", NA)] <- font_url(url = mo_name(x[!x %in% c("UNKNOWN", NA)], language = NULL, keep_synonyms = TRUE),
txt = out[!x %in% c("UNKNOWN", NA)])
}
# make it always fit exactly
max_char <- max(nchar(x))
if (is.na(max_char)) {

48
R/mo_property.R
View File

@ -913,26 +913,36 @@ mo_validate <- function(x, property, language, keep_synonyms = keep_synonyms, ..
Lancefield <- FALSE
}
has_Becker_or_Lancefield <- Becker %in% c(TRUE, "all") || Lancefield %in% c(TRUE, "all")
# get microorganisms data set, but remove synonyms if keep_synonyms is FALSE
mo_data_check <- AMR_env$MO_lookup[which(AMR_env$MO_lookup$status %in% if (isTRUE(keep_synonyms)) c("synonym", "accepted") else "accepted"), , drop = FALSE]
if (all(x %in% c(mo_data_check$mo, NA)) && !has_Becker_or_Lancefield) {
# do nothing, just don't run the other if-else's
} else if (all(x %in% c(unlist(mo_data_check[[property]]), NA)) && !has_Becker_or_Lancefield) {
# no need to do anything, just return it
return(x)
if (isFALSE(has_Becker_or_Lancefield) && isTRUE(keep_synonyms) && all(x %in% c(AMR_env$MO_lookup$mo, NA))) {
# fastest way to get properties
if (property == "snomed") {
x <- lapply(x, function(y) unlist(AMR_env$MO_lookup$snomed[match(y, AMR_env$MO_lookup$mo)]))
} else {
x <- AMR_env$MO_lookup[[property]][match(x, AMR_env$MO_lookup$mo)]
}
} else {
# we need to get MO codes now
x <- replace_old_mo_codes(x, property = property)
x <- as.mo(x, language = language, keep_synonyms = keep_synonyms, ...)
}
# get property reeaaally fast using match()
if (property == "snomed") {
x <- lapply(x, function(y) unlist(AMR_env$MO_lookup$snomed[match(y, AMR_env$MO_lookup$mo)]))
} else {
x <- AMR_env$MO_lookup[[property]][match(x, AMR_env$MO_lookup$mo)]
# get microorganisms data set, but remove synonyms if keep_synonyms is FALSE
mo_data_check <- AMR_env$MO_lookup[which(AMR_env$MO_lookup$status %in% if (isTRUE(keep_synonyms)) c("synonym", "accepted") else "accepted"), , drop = FALSE]
if (all(x %in% c(mo_data_check$mo, NA)) && !has_Becker_or_Lancefield) {
# do nothing, just don't run the other if-else's
} else if (all(x %in% c(unlist(mo_data_check[[property]]), NA)) && !has_Becker_or_Lancefield) {
# no need to do anything, just return it
return(x)
} else {
# we need to get MO codes now
x <- replace_old_mo_codes(x, property = property)
x <- as.mo(x, language = language, keep_synonyms = keep_synonyms, ...)
}
# get property reeaaally fast using match()
if (property == "snomed") {
x <- lapply(x, function(y) unlist(AMR_env$MO_lookup$snomed[match(y, AMR_env$MO_lookup$mo)]))
} else {
x <- AMR_env$MO_lookup[[property]][match(x, AMR_env$MO_lookup$mo)]
}
}
if (property == "mo") {

49
R/plot.R
View File

@ -40,6 +40,7 @@
#' @param colours_SIR colours to use for filling in the bars, must be a vector of three values (in the order S, I and R). The default colours are colour-blind friendly.
#' @param language language to be used to translate 'Susceptible', 'Increased exposure'/'Intermediate' and 'Resistant' - the default is system language (see [get_AMR_locale()]) and can be overwritten by setting the [package option][AMR-options] [`AMR_locale`][AMR-options], e.g. `options(AMR_locale = "de")`, see [translate]. Use `language = NULL` or `language = ""` to prevent translation.
#' @param expand a [logical] to indicate whether the range on the x axis should be expanded between the lowest and highest value. For MIC values, intermediate values will be factors of 2 starting from the highest MIC value. For disk diameters, the whole diameter range will be filled.
#' @inheritParams as.sir
#' @details
#' The interpretation of "I" will be named "Increased exposure" for all EUCAST guidelines since 2019, and will be named "Intermediate" in all other cases.
#'
@ -93,6 +94,8 @@ plot.mic <- function(x,
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(),
expand = TRUE,
include_PKPD = getOption("AMR_include_PKPD", TRUE),
breakpoint_type = getOption("AMR_breakpoint_type", "human"),
...) {
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
@ -123,7 +126,9 @@ plot.mic <- function(x,
colours_SIR = colours_SIR,
fn = as.mic,
language = language,
type = "MIC",
method = "MIC",
include_PKPD = include_PKPD,
breakpoint_type = breakpoint_type,
...
)
barplot(x,
@ -224,6 +229,8 @@ autoplot.mic <- function(object,
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(),
expand = TRUE,
include_PKPD = getOption("AMR_include_PKPD", TRUE),
breakpoint_type = getOption("AMR_breakpoint_type", "human"),
...) {
stop_ifnot_installed("ggplot2")
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
@ -256,7 +263,9 @@ autoplot.mic <- function(object,
colours_SIR = colours_SIR,
fn = as.mic,
language = language,
type = "MIC",
method = "MIC",
include_PKPD = include_PKPD,
breakpoint_type = breakpoint_type,
...
)
df <- as.data.frame(x, stringsAsFactors = TRUE)
@ -327,6 +336,8 @@ plot.disk <- function(x,
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(),
expand = TRUE,
include_PKPD = getOption("AMR_include_PKPD", TRUE),
breakpoint_type = getOption("AMR_breakpoint_type", "human"),
...) {
meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(ylab, allow_class = "character", has_length = 1)
@ -357,7 +368,9 @@ plot.disk <- function(x,
colours_SIR = colours_SIR,
fn = as.disk,
language = language,
type = "disk",
method = "disk",
include_PKPD = include_PKPD,
breakpoint_type = breakpoint_type,
...
)
@ -458,6 +471,8 @@ autoplot.disk <- function(object,
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(),
expand = TRUE,
include_PKPD = getOption("AMR_include_PKPD", TRUE),
breakpoint_type = getOption("AMR_breakpoint_type", "human"),
...) {
stop_ifnot_installed("ggplot2")
meet_criteria(title, allow_class = "character", allow_NULL = TRUE)
@ -490,7 +505,9 @@ autoplot.disk <- function(object,
colours_SIR = colours_SIR,
fn = as.disk,
language = language,
type = "disk",
method = "disk",
include_PKPD = include_PKPD,
breakpoint_type = breakpoint_type,
...
)
df <- as.data.frame(x, stringsAsFactors = TRUE)
@ -744,7 +761,7 @@ plot_name_of_I <- function(guideline) {
}
}
plot_colours_subtitle_guideline <- function(x, mo, ab, guideline, colours_SIR, fn, language, type, ...) {
plot_colours_subtitle_guideline <- function(x, mo, ab, guideline, colours_SIR, fn, language, method, breakpoint_type, include_PKPD, ...) {
guideline <- get_guideline(guideline, AMR::clinical_breakpoints)
if (!is.null(mo) && !is.null(ab)) {
# interpret and give colour based on MIC values
@ -752,30 +769,36 @@ plot_colours_subtitle_guideline <- function(x, mo, ab, guideline, colours_SIR, f
moname <- mo_name(mo, language = language)
ab <- as.ab(ab)
abname <- ab_name(ab, language = language)
# store previous interpretations to backup
sir_history <- AMR_env$sir_interpretation_history
# and clear previous interpretations
AMR_env$sir_interpretation_history <- AMR_env$sir_interpretation_history[0, , drop = FALSE]
sir <- suppressWarnings(suppressMessages(as.sir(fn(names(x)), mo = mo, ab = ab, guideline = guideline, include_screening = FALSE, include_PKPD = TRUE, ...)))
sir <- suppressWarnings(suppressMessages(as.sir(fn(names(x)), mo = mo, ab = ab, guideline = guideline, include_screening = FALSE, include_PKPD = include_PKPD, breakpoint_type = breakpoint_type, ...)))
guideline_txt <- guideline
if (all(is.na(sir))) {
sir_screening <- suppressWarnings(suppressMessages(as.sir(fn(names(x)), mo = mo, ab = ab, guideline = guideline, include_screening = TRUE, include_PKPD = TRUE, ...)))
sir_screening <- suppressWarnings(suppressMessages(as.sir(fn(names(x)), mo = mo, ab = ab, guideline = guideline, include_screening = TRUE, include_PKPD = include_PKPD, breakpoint_type = breakpoint_type, ...)))
if (!all(is.na(sir_screening))) {
message_(
"Only ", guideline, " ", type, " interpretations found for ",
"Only ", guideline, " ", method, " interpretations found for ",
ab_name(ab, language = NULL, tolower = TRUE), " in ", italicise(moname), " for screening"
)
sir <- sir_screening
guideline_txt <- paste0("(Screen, ", guideline_txt, ")")
} else {
message_(
"No ", guideline, " ", type, " interpretations found for ",
"No ", guideline, " ", method, " interpretations found for ",
ab_name(ab, language = NULL, tolower = TRUE), " in ", italicise(moname)
)
guideline_txt <- ""
guideline_txt <- paste0("(", guideline_txt, ")")
}
} else {
if (isTRUE(list(...)$uti)) {
guideline_txt <- paste("UTIs,", guideline_txt)
}
guideline_txt <- paste0("(", guideline_txt, ")")
ref_tbl <- paste0('"', unique(AMR_env$sir_interpretation_history$ref_table), '"', collapse = "/")
guideline_txt <- paste0("(", guideline_txt, ": ", ref_tbl, ")")
}
cols <- character(length = length(sir))
cols[is.na(sir)] <- "#BEBEBE"
@ -787,5 +810,9 @@ plot_colours_subtitle_guideline <- function(x, mo, ab, guideline, colours_SIR, f
cols <- "#BEBEBE"
sub <- NULL
}
# restore previous interpretations to backup
AMR_env$sir_interpretation_history <- sir_history
list(cols = cols, count = as.double(x), sub = sub, guideline = guideline)
}

39
R/sir.R
View File

@ -793,7 +793,7 @@ as_sir_method <- function(method_short,
mo.bak <- mo
}
# be sure to take current taxonomy, as the 'clinical_breakpoints' data set only contains current taxonomy
mo <- suppressWarnings(suppressMessages(as.mo(mo, keep_synonyms = FALSE, inf0 = FALSE)))
mo <- suppressWarnings(suppressMessages(as.mo(mo, keep_synonyms = FALSE, info = FALSE)))
guideline_coerced <- get_guideline(guideline, reference_data)
if (is.na(ab)) {
message_("Returning NAs for unknown antibiotic: '", font_bold(ab.bak),
@ -846,12 +846,13 @@ as_sir_method <- function(method_short,
message_(intro_txt, appendLF = FALSE, as_note = FALSE)
msg_note <- function(messages) {
messages <- unique(messages)
for (i in seq_len(length(messages))) {
messages[i] <- word_wrap(extra_indent = 5, messages[i])
}
message(
font_yellow_bg(paste0(" NOTE", ifelse(length(messages) > 1, "S", ""), " \n")),
paste0(" ", font_black(AMR_env$bullet_icon), " ", font_black(messages, collapse = NULL), collapse = "\n")
paste0(" ", font_black(AMR_env$bullet_icon), " ", font_black(messages, collapse = NULL), collapse = "\n")
)
}
@ -879,7 +880,6 @@ as_sir_method <- function(method_short,
rise_note <- FALSE
method_coerced <- toupper(method)
ab_coerced <- ab
mo_coerced <- mo
if (identical(reference_data, AMR::clinical_breakpoints)) {
breakpoints <- reference_data %pm>%
@ -928,7 +928,7 @@ as_sir_method <- function(method_short,
p <- progress_ticker(n = nrow(df_unique), n_min = 10, title = font_blue(intro_txt), only_bar_percent = TRUE)
has_progress_bar <- !is.null(import_fn("progress_bar", "progress", error_on_fail = FALSE)) && nrow(df_unique) >= 10
on.exit(close(p))
# run the rules
for (i in seq_len(nrow(df_unique))) {
p$tick()
@ -943,21 +943,23 @@ as_sir_method <- function(method_short,
values <- df[rows, "values", drop = TRUE]
new_sir <- rep(NA_sir_, length(rows))
# find different mo properties
mo_current_genus <- as.mo(mo_genus(mo_current, language = NULL))
mo_current_family <- as.mo(mo_family(mo_current, language = NULL))
mo_current_order <- as.mo(mo_order(mo_current, language = NULL))
mo_current_class <- as.mo(mo_class(mo_current, language = NULL))
# find different mo properties, as fast as possible
mo_current_genus <- AMR_env$MO_lookup$mo[match(AMR_env$MO_lookup$genus[match(mo_current, AMR_env$MO_lookup$mo)], AMR_env$MO_lookup$genus)]
mo_current_family <- AMR_env$MO_lookup$mo[match(AMR_env$MO_lookup$family[match(mo_current, AMR_env$MO_lookup$mo)], AMR_env$MO_lookup$family)]
mo_current_order <- AMR_env$MO_lookup$mo[match(AMR_env$MO_lookup$order[match(mo_current, AMR_env$MO_lookup$mo)], AMR_env$MO_lookup$order)]
mo_current_class <- AMR_env$MO_lookup$mo[match(AMR_env$MO_lookup$class[match(mo_current, AMR_env$MO_lookup$mo)], AMR_env$MO_lookup$class)]
mo_current_rank <- AMR_env$MO_lookup$rank[match(mo_current, AMR_env$MO_lookup$mo)]
mo_current_name <- AMR_env$MO_lookup$fullname[match(mo_current, AMR_env$MO_lookup$mo)]
if (mo_current %in% AMR::microorganisms.groups$mo) {
# get the species group
mo_current_species_group <- AMR::microorganisms.groups$mo_group[match(mo_current, AMR::microorganisms.groups$mo)]
} else {
mo_current_species_group <- mo_current
}
mo_current_other <- as.mo("UNKNOWN")
mo_current_other <- structure("UNKNOWN", class = c("mo", "character"))
# formatted for notes
mo_formatted <- suppressMessages(suppressWarnings(mo_fullname(mo_current, language = NULL, keep_synonyms = FALSE)))
if (!mo_rank(mo_current) %in% c("kingdom", "phylum", "class", "order")) {
mo_formatted <- mo_current_name
if (!mo_current_rank %in% c("kingdom", "phylum", "class", "order")) {
mo_formatted <- font_italic(mo_formatted)
}
ab_formatted <- paste0(
@ -1106,8 +1108,7 @@ as_sir_method <- function(method_short,
sir_interpretation_history <- function(clean = FALSE) {
meet_criteria(clean, allow_class = "logical", has_length = 1)
out.bak <- AMR_env$sir_interpretation_history
out <- out.bak
out <- AMR_env$sir_interpretation_history
if (NROW(out) == 0) {
message_("No results to return. Run `as.sir()` on MIC values or disk diffusion zones first to see a 'logbook' data set here.")
return(invisible(NULL))
@ -1118,10 +1119,8 @@ sir_interpretation_history <- function(clean = FALSE) {
# keep stored for next use
if (isTRUE(clean)) {
AMR_env$sir_interpretation_history <- AMR_env$sir_interpretation_history[0, , drop = FALSE]
} else {
AMR_env$sir_interpretation_history <- out.bak
}
# sort descending on time
out <- out[order(out$datetime, decreasing = TRUE), , drop = FALSE]
@ -1141,7 +1140,11 @@ pillar_shaft.sir <- function(x, ...) {
out[is.na(x)] <- font_grey(" NA")
out[x == "S"] <- font_green_bg(" S ")
out[x == "I"] <- font_orange_bg(" I ")
out[x == "R"] <- font_red_bg(" R ")
if (is_dark()) {
out[x == "R"] <- font_red_bg(" R ")
} else {
out[x == "R"] <- font_rose_bg(" R ")
}
}
create_pillar_column(out, align = "left", width = 5)
}

2
R/zzz.R
View File

@ -73,6 +73,8 @@ AMR_env$sir_interpretation_history <- data.frame(
AMR_env$custom_ab_codes <- character(0)
AMR_env$custom_mo_codes <- character(0)
AMR_env$is_dark_theme <- NULL
AMR_env$chmatch <- import_fn("chmatch", "data.table", error_on_fail = FALSE)
AMR_env$chin <- import_fn("%chin%", "data.table", error_on_fail = FALSE)
# determine info icon for messages
if (pkg_is_available("cli")) {