1
0
mirror of https://github.com/msberends/AMR.git synced 2024-12-25 18:46:11 +01:00
This commit is contained in:
dr. M.S. (Matthijs) Berends 2022-10-31 13:25:41 +01:00
parent 796b972f8a
commit d20caae54b
7 changed files with 53 additions and 41 deletions

View File

@ -1,5 +1,5 @@
Package: AMR Package: AMR
Version: 1.8.2.9040 Version: 1.8.2.9041
Date: 2022-10-31 Date: 2022-10-31
Title: Antimicrobial Resistance Data Analysis Title: Antimicrobial Resistance Data Analysis
Description: Functions to simplify and standardise antimicrobial resistance (AMR) Description: Functions to simplify and standardise antimicrobial resistance (AMR)

View File

@ -1,4 +1,4 @@
# AMR 1.8.2.9040 # AMR 1.8.2.9041
This version will eventually become v2.0! We're happy to reach a new major milestone soon! This version will eventually become v2.0! We're happy to reach a new major milestone soon!

View File

@ -1130,7 +1130,7 @@ font_grey <- function(..., collapse = " ") {
try_colour(..., before = "\033[38;5;249m", after = "\033[39m", collapse = collapse) try_colour(..., before = "\033[38;5;249m", after = "\033[39m", collapse = collapse)
} }
font_grey_bg <- function(..., collapse = " ") { font_grey_bg <- function(..., collapse = " ") {
if (tryCatch(import_fn("getThemeInfo", "rstudioapi", error_on_fail = FALSE)()$dark, error = function(e) FALSE)) { if (is_dark()) {
# similar to HTML #444444 # similar to HTML #444444
try_colour(..., before = "\033[48;5;238m", after = "\033[49m", collapse = collapse) try_colour(..., before = "\033[48;5;238m", after = "\033[49m", collapse = collapse)
} else { } else {
@ -1360,20 +1360,11 @@ percentage <- function(x, digits = NULL, ...) {
) )
} }
time_start_tracking <- function() {
AMR_env$time_start <- round(as.double(Sys.time()) * 1000)
}
time_track <- function(name = NULL) {
paste("(until now:", trimws(round(as.double(Sys.time()) * 1000) - AMR_env$time_start), "ms)")
}
trimws2 <- function(..., whitespace = "[\u0009\u000A\u000B\u000C\u000D\u0020\u0085\u00A0\u1680\u180E\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u200C\u200D\u2028\u2029\u202F\u205F\u2060\u3000\uFEFF]") { trimws2 <- function(..., whitespace = "[\u0009\u000A\u000B\u000C\u000D\u0020\u0085\u00A0\u1680\u180E\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u200C\u200D\u2028\u2029\u202F\u205F\u2060\u3000\uFEFF]") {
# this is even faster than trimws() itself which sets " \t\n\r". # this is even faster than trimws() itself which sets " \t\n\r".
trimws(..., whitespace = whitespace) trimws(..., whitespace = whitespace)
} }
# Faster data.table implementations ---- # Faster data.table implementations ----
match <- function(x, table, ...) { match <- function(x, table, ...) {

3
R/ab.R
View File

@ -498,6 +498,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
data.frame( data.frame(
x = x, x = x,
ab = x_new, ab = x_new,
x_bak = x_bak[match(x, x_bak_clean)],
stringsAsFactors = FALSE stringsAsFactors = FALSE
), ),
stringsAsFactors = FALSE stringsAsFactors = FALSE
@ -513,7 +514,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
} }
x_unknown <- x_unknown[!x_unknown %in% x_unknown_ATCs] x_unknown <- x_unknown[!x_unknown %in% x_unknown_ATCs]
x_unknown <- c(x_unknown, x_unknown <- c(x_unknown,
AMR_env$ab_previously_coerced$x[which(AMR_env$ab_previously_coerced$x %in% x & is.na(AMR_env$ab_previously_coerced$ab))]) AMR_env$ab_previously_coerced$x_bak[which(AMR_env$ab_previously_coerced$x %in% x & is.na(AMR_env$ab_previously_coerced$ab))])
if (length(x_unknown) > 0 && fast_mode == FALSE) { if (length(x_unknown) > 0 && fast_mode == FALSE) {
warning_( warning_(
"in `as.ab()`: these values could not be coerced to a valid antimicrobial ID: ", "in `as.ab()`: these values could not be coerced to a valid antimicrobial ID: ",

67
R/rsi.R
View File

@ -629,7 +629,7 @@ as.rsi.data.frame <- function(x,
} }
x[, ab_cols[i]] <- as.rsi.default(x = as.character(x[, ab_cols[i], drop = TRUE])) x[, ab_cols[i]] <- as.rsi.default(x = as.character(x[, ab_cols[i], drop = TRUE]))
if (show_message == TRUE) { if (show_message == TRUE) {
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE) message_(" OK.", add_fn = list(font_green), as_note = FALSE)
} }
} }
} }
@ -790,6 +790,7 @@ as_rsi_method <- function(method_short,
} }
rise_warning <- FALSE rise_warning <- FALSE
rise_note <- FALSE
method_param <- toupper(method) method_param <- toupper(method)
genera <- mo_genus(mo, language = NULL) genera <- mo_genus(mo, language = NULL)
@ -828,7 +829,7 @@ as_rsi_method <- function(method_short,
} }
if (nrow(trans) == 0) { if (nrow(trans) == 0) {
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE) message_(" OK.", add_fn = list(font_green), as_note = FALSE)
load_mo_uncertainties(metadata_mo) load_mo_uncertainties(metadata_mo)
return(set_clean_class(factor(new_rsi, levels = c("S", "I", "R"), ordered = TRUE), return(set_clean_class(factor(new_rsi, levels = c("S", "I", "R"), ordered = TRUE),
new_class = c("rsi", "ordered", "factor") new_class = c("rsi", "ordered", "factor")
@ -875,14 +876,18 @@ as_rsi_method <- function(method_short,
)) ))
if (NROW(get_record) == 0) { if (NROW(get_record) == 0) {
warning_( if (mo_rank(mo[i]) %in% c("kingdom", "phylum", "class", "order")) {
"No ", method_param, " breakpoints available for ", mo_formatted <- suppressMessages(suppressWarnings(mo_shortname(mo[i], language = NULL, keep_synonyms = FALSE)))
font_italic(suppressMessages(suppressWarnings(mo_shortname(mo[i], language = NULL, keep_synonyms = FALSE)))), } else {
paste0(" / "), mo_formatted <- font_italic(suppressMessages(suppressWarnings(mo_shortname(mo[i], language = NULL, keep_synonyms = FALSE))))
}
message_(font_green(font_bold(" NOTE.\n")),
font_black("No ", method_param, " breakpoints available for ", mo_formatted,
" / ",
suppressMessages(suppressWarnings(ab_name(ab_param, language = NULL, tolower = TRUE))), suppressMessages(suppressWarnings(ab_name(ab_param, language = NULL, tolower = TRUE))),
" (", ab_param, ")" " (", ab_param, ")", collapse = NULL)
) )
rise_warning <- TRUE rise_note <- TRUE
next next
} }
@ -905,13 +910,19 @@ as_rsi_method <- function(method_short,
rise_warning <- TRUE rise_warning <- TRUE
} else if (nrow(records_same_mo) > 1 && length(unique(records_same_mo$site)) > 1 && is.na(uti[i]) && all(c(TRUE, FALSE) %in% records_same_mo$uti, na.rm = TRUE) && message_not_thrown_before("as.rsi", "siteUTI", records_same_mo$mo[1], ab_param)) { } else if (nrow(records_same_mo) > 1 && length(unique(records_same_mo$site)) > 1 && is.na(uti[i]) && all(c(TRUE, FALSE) %in% records_same_mo$uti, na.rm = TRUE) && message_not_thrown_before("as.rsi", "siteUTI", records_same_mo$mo[1], ab_param)) {
# uti not set and both UTI and non-UTI breakpoints available, so throw warning # uti not set and both UTI and non-UTI breakpoints available, so throw warning
warning_("in `as.rsi()`: breakpoints for UTI ", font_underline("and"), " non-UTI available for ", if (mo_rank(mo[i]) %in% c("kingdom", "phylum", "class", "order")) {
font_italic(suppressMessages(suppressWarnings(mo_shortname(records_same_mo$mo[1], language = NULL, keep_synonyms = FALSE)))), mo_formatted <- suppressMessages(suppressWarnings(mo_shortname(mo[i], language = NULL, keep_synonyms = FALSE)))
} else {
mo_formatted <- font_italic(suppressMessages(suppressWarnings(mo_shortname(mo[i], language = NULL, keep_synonyms = FALSE))))
}
message_(font_green(font_bold(" NOTE.\n")),
font_black("Breakpoints for UTI ", font_underline("and"), " non-UTI available for ", mo_formatted,
" / ", " / ",
suppressMessages(suppressWarnings(ab_name(ab_param, language = NULL, tolower = TRUE))), suppressMessages(suppressWarnings(ab_name(ab_param, language = NULL, tolower = TRUE))),
" (", ab_param, ") - assuming non-UTI. Use argument `uti` to set which isolates are from urine. See ?as.rsi.", " (", ab_param, ") - assuming non-UTI. Use argument `uti` to set which isolates are from urine. See ?as.rsi.", collapse = NULL),
call = FALSE as_note = FALSE
) )
rise_note <- TRUE
get_record <- get_record %pm>% get_record <- get_record %pm>%
pm_filter(uti == FALSE) pm_filter(uti == FALSE)
rise_warning <- TRUE rise_warning <- TRUE
@ -923,14 +934,19 @@ as_rsi_method <- function(method_short,
} else { } else {
site <- paste0("body site '", get_record[1L, "site", drop = FALSE], "'") site <- paste0("body site '", get_record[1L, "site", drop = FALSE], "'")
} }
warning_("in `as.rsi()`: breakpoints available for ", if (mo_rank(mo[i]) %in% c("kingdom", "phylum", "class", "order")) {
font_italic(suppressMessages(suppressWarnings(mo_shortname(records_same_mo$mo[1], language = NULL, keep_synonyms = FALSE)))), mo_formatted <- suppressMessages(suppressWarnings(mo_shortname(mo[i], language = NULL, keep_synonyms = FALSE)))
paste0(" / "), } else {
mo_formatted <- font_italic(suppressMessages(suppressWarnings(mo_shortname(mo[i], language = NULL, keep_synonyms = FALSE))))
}
message_(font_green(font_bold(" NOTE.\n")),
font_black("Breakpoints available for ", mo_formatted,
" / ",
suppressMessages(suppressWarnings(ab_name(records_same_mo$ab[1], language = NULL, tolower = TRUE))), suppressMessages(suppressWarnings(ab_name(records_same_mo$ab[1], language = NULL, tolower = TRUE))),
paste0(" - assuming ", site), paste0(" - assuming ", site), collapse = NULL),
call = FALSE as_note = FALSE
) )
rise_warning <- TRUE rise_note <- TRUE
} }
if (NROW(get_record) > 0) { if (NROW(get_record) > 0) {
@ -1002,13 +1018,16 @@ as_rsi_method <- function(method_short,
by = "x_mo" by = "x_mo"
) %pm>% ) %pm>%
pm_pull(new_rsi) pm_pull(new_rsi)
if (isTRUE(rise_warning)) { if (!isTRUE(rise_note)) {
message_("WARNING.", add_fn = list(font_yellow, font_bold), as_note = FALSE) # notes already a have green "NOTE" text by this point
} else { if (isTRUE(rise_warning)) {
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE) message_(" WARNING.", add_fn = list(font_yellow, font_bold), as_note = FALSE)
} else {
message_(" OK.", add_fn = list(font_green), as_note = FALSE)
}
} }
load_mo_uncertainties(metadata_mo) load_mo_uncertainties(metadata_mo)
set_clean_class(factor(new_rsi, levels = c("S", "I", "R"), ordered = TRUE), set_clean_class(factor(new_rsi, levels = c("S", "I", "R"), ordered = TRUE),

View File

@ -28,7 +28,7 @@
# ==================================================================== # # ==================================================================== #
# extra tests for {vctrs} pkg support # extra tests for {vctrs} pkg support
if (pkg_is_available("dplyr", also_load = FALSE)) { if (AMR:::pkg_is_available("dplyr", also_load = FALSE)) {
test <- dplyr::tibble(ab = as.ab("CIP"), test <- dplyr::tibble(ab = as.ab("CIP"),
mo = as.mo("Escherichia coli"), mo = as.mo("Escherichia coli"),
mic = as.mic(2), mic = as.mic(2),

View File

@ -30,10 +30,11 @@
# we use {tinytest} instead of {testthat} because it does not rely on recent R versions - we want to test on R >= 3.0. # we use {tinytest} instead of {testthat} because it does not rely on recent R versions - we want to test on R >= 3.0.
# Run them in RStudio using: # Run them in RStudio using:
# rstudioapi::jobRunScript("tests/tinytest.R", name = "Tinytest Unit Tests", workingDir = getwd(), exportEnv = "tinytest_results") # rstudioapi::jobRunScript("tests/tinytest.R", name = "AMR Unit Tests", workingDir = getwd(), exportEnv = "tinytest_results")
# test only on GitHub Actions and at home - not on CRAN as tests are lengthy # test only on GitHub Actions and at using RStudio jobs - not on CRAN as tests are lengthy
if (identical(Sys.getenv("R_RUN_TINYTEST"), "true")) { if (tryCatch(isTRUE(AMR:::import_fn("isJob", "rstudioapi")()), error = function(e) FALSE) ||
identical(Sys.getenv("R_RUN_TINYTEST"), "true")) {
# env var 'R_LIBS_USER' got overwritten during 'R CMD check' in GitHub Actions, so: # env var 'R_LIBS_USER' got overwritten during 'R CMD check' in GitHub Actions, so:
.libPaths(c(Sys.getenv("R_LIBS_USER_GH_ACTIONS"), .libPaths())) .libPaths(c(Sys.getenv("R_LIBS_USER_GH_ACTIONS"), .libPaths()))
if (AMR:::pkg_is_available("tinytest", also_load = TRUE)) { if (AMR:::pkg_is_available("tinytest", also_load = TRUE)) {