diff --git a/DESCRIPTION b/DESCRIPTION index cc76b85b..cc5f8d5e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -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) diff --git a/NEWS.md b/NEWS.md index a0e4a06f..01284cf7 100755 --- a/NEWS.md +++ b/NEWS.md @@ -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! diff --git a/R/aa_helper_functions.R b/R/aa_helper_functions.R index 675b5814..4c5217b6 100755 --- a/R/aa_helper_functions.R +++ b/R/aa_helper_functions.R @@ -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, ...) { diff --git a/R/ab.R b/R/ab.R index ab3bc7c1..4ecf4c15 100755 --- a/R/ab.R +++ b/R/ab.R @@ -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: ", diff --git a/R/rsi.R b/R/rsi.R index 59bacdf3..81b0e7e6 100755 --- a/R/rsi.R +++ b/R/rsi.R @@ -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) { @@ -1002,13 +1018,16 @@ as_rsi_method <- function(method_short, by = "x_mo" ) %pm>% pm_pull(new_rsi) - - if (isTRUE(rise_warning)) { - 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) + + 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) + } else { + message_(" OK.", add_fn = list(font_green), as_note = FALSE) + } } - + load_mo_uncertainties(metadata_mo) set_clean_class(factor(new_rsi, levels = c("S", "I", "R"), ordered = TRUE), diff --git a/inst/tinytest/test-vctrs.R b/inst/tinytest/test-vctrs.R index d9e2dc80..d9d88051 100755 --- a/inst/tinytest/test-vctrs.R +++ b/inst/tinytest/test-vctrs.R @@ -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), diff --git a/tests/tinytest.R b/tests/tinytest.R index d7936a22..7b373745 100644 --- a/tests/tinytest.R +++ b/tests/tinytest.R @@ -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)) {