P281424
/
AMR
mirror of https://github.com/msberends/AMR.git
1
0
Fork 0
Code Releases Activity

cleanup

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
DESCRIPTION
View File

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

2
NEWS.md
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!

11
R/aa_helper_functions.R
View File

@ -1130,7 +1130,7 @@ font_grey <- function(..., collapse = " ") {
try_colour(..., before = "\033[38;5;249m", after = "\033[39m", collapse = 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
try_colour(..., before = "\033[48;5;238m", after = "\033[49m", collapse = collapse)
} 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]") {
# this is even faster than trimws() itself which sets " \t\n\r".
trimws(..., whitespace = whitespace)
}
# Faster data.table implementations ----
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(
x = x,
ab = x_new,
x_bak = x_bak[match(x, x_bak_clean)],
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 <- 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) {
warning_(
"in `as.ab()`: these values could not be coerced to a valid antimicrobial ID: ",

59
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]))
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_note <- FALSE
method_param <- toupper(method)
genera <- mo_genus(mo, language = NULL)
@ -828,7 +829,7 @@ as_rsi_method <- function(method_short,
}
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)
return(set_clean_class(factor(new_rsi, levels = c("S", "I", "R"), ordered = TRUE),
new_class = c("rsi", "ordered", "factor")
@ -875,14 +876,18 @@ as_rsi_method <- function(method_short,
))
if (NROW(get_record) == 0) {
warning_(
"No ", method_param, " breakpoints available for ",
font_italic(suppressMessages(suppressWarnings(mo_shortname(mo[i], language = NULL, keep_synonyms = FALSE)))),
paste0(" / "),
if (mo_rank(mo[i]) %in% c("kingdom", "phylum", "class", "order")) {
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("No ", method_param, " breakpoints available for ", mo_formatted,
" / ",
suppressMessages(suppressWarnings(ab_name(ab_param, language = NULL, tolower = TRUE))),
" (", ab_param, ")"
" (", ab_param, ")", collapse = NULL)
)
rise_warning <- TRUE
rise_note <- TRUE
next
}
@ -905,13 +910,19 @@ as_rsi_method <- function(method_short,
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)) {
# 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 ",
font_italic(suppressMessages(suppressWarnings(mo_shortname(records_same_mo$mo[1], language = NULL, keep_synonyms = FALSE)))),
if (mo_rank(mo[i]) %in% c("kingdom", "phylum", "class", "order")) {
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))),
" (", ab_param, ") - assuming non-UTI. Use argument `uti` to set which isolates are from urine. See ?as.rsi.",
call = FALSE
" (", ab_param, ") - assuming non-UTI. Use argument `uti` to set which isolates are from urine. See ?as.rsi.", collapse = NULL),
as_note = FALSE
)
rise_note <- TRUE
get_record <- get_record %pm>%
pm_filter(uti == FALSE)
rise_warning <- TRUE
@ -923,14 +934,19 @@ as_rsi_method <- function(method_short,
} else {
site <- paste0("body site '", get_record[1L, "site", drop = FALSE], "'")
}
warning_("in `as.rsi()`: breakpoints available for ",
font_italic(suppressMessages(suppressWarnings(mo_shortname(records_same_mo$mo[1], language = NULL, keep_synonyms = FALSE)))),
paste0(" / "),
if (mo_rank(mo[i]) %in% c("kingdom", "phylum", "class", "order")) {
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 available for ", mo_formatted,
" / ",
suppressMessages(suppressWarnings(ab_name(records_same_mo$ab[1], language = NULL, tolower = TRUE))),
paste0(" - assuming ", site),
call = FALSE
paste0(" - assuming ", site), collapse = NULL),
as_note = FALSE
)
rise_warning <- TRUE
rise_note <- TRUE
}
if (NROW(get_record) > 0) {
@ -1003,10 +1019,13 @@ as_rsi_method <- function(method_short,
) %pm>%
pm_pull(new_rsi)
if (!isTRUE(rise_note)) {
# notes already a have green "NOTE" text by this point
if (isTRUE(rise_warning)) {
message_("WARNING.", add_fn = list(font_yellow, 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, font_bold), as_note = FALSE)
message_(" OK.", add_fn = list(font_green), as_note = FALSE)
}
}
load_mo_uncertainties(metadata_mo)

2
inst/tinytest/test-vctrs.R
View File

@ -28,7 +28,7 @@
# ==================================================================== #
# 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"),
mo = as.mo("Escherichia coli"),
mic = as.mic(2),

7
tests/tinytest.R
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.
# 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
if (identical(Sys.getenv("R_RUN_TINYTEST"), "true")) {
# test only on GitHub Actions and at using RStudio jobs - not on CRAN as tests are lengthy
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:
.libPaths(c(Sys.getenv("R_LIBS_USER_GH_ACTIONS"), .libPaths()))
if (AMR:::pkg_is_available("tinytest", also_load = TRUE)) {