P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-07-08 16:42:10 +02:00
Code Releases Activity

(v1.5.0.9015) unit test fix, grouped first isolates

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2021-02-04 16:48:16 +01:00
parent 2eca8c3f01
commit 8fda473e49
44 changed files with 239 additions and 168 deletions
Download Patch File Download Diff File Expand all files Collapse all files

29
R/aa_helper_functions.R
View File

@ -85,7 +85,7 @@ check_dataset_integrity <- function() {
warning_(ifelse(length(overwritten) == 1,
"The following data set is overwritten by your global environment and prevents the AMR package from working correctly: ",
"The following data sets are overwritten by your global environment and prevent the AMR package from working correctly: "),
paste0("'", overwritten, "'", collapse = ", "),
vector_and(overwritten, quotes = "'"),
".\nPlease rename your object(s).", call = FALSE)
}
# check if other packages did not overwrite our data sets
@ -442,29 +442,38 @@ create_ab_documentation <- function(ab) {
out
}
vector_or <- function(v, quotes = TRUE, reverse = FALSE, last_sep = " or ") {
vector_or <- function(v, quotes = TRUE, reverse = FALSE, sort = TRUE, last_sep = " or ") {
# makes unique and sorts, and this also removed NAs
v <- sort(unique(v))
if (length(v) == 1) {
return(paste0(ifelse(quotes, '"', ""), v, ifelse(quotes, '"', "")))
v <- unique(v)
if (isTRUE(sort)) {
v <- sort(v)
}
if (reverse == TRUE) {
if (isTRUE(reverse)) {
v <- rev(v)
}
if (identical(v, c("I", "R", "S"))) {
# class <rsi> should be sorted like this
v <- c("R", "S", "I")
}
if (isTRUE(quotes)) {
quotes <- '"'
} else if (isFALSE(quotes)) {
quotes <- ""
} else {
quotes <- quotes[1L]
}
if (length(v) == 1) {
return(paste0(quotes, v, quotes))
}
if (identical(v, c("I", "R", "S"))) {
# class <rsi> should be sorted like this
v <- c("R", "S", "I")
}
# all commas except for last item, so will become '"val1", "val2", "val3" or "val4"'
paste0(paste0(quotes, v[seq_len(length(v) - 1)], quotes, collapse = ", "),
last_sep, paste0(quotes, v[length(v)], quotes))
}
vector_and <- function(v, quotes = TRUE, reverse = FALSE, sort = TRUE) {
vector_or(v = v, quotes = quotes, reverse = reverse, sort = sort, last_sep = " and ")
}
format_class <- function(class, plural) {
class.bak <- class
class[class == "numeric"] <- "number"

7
R/ab.R
View File

@ -134,7 +134,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = TRUE, ...) {
}
if (length(abnames) > 1) {
message_("More than one result was found for item ", index, ": ",
paste0(abnames, collapse = ", "))
vector_and(abnames, quotes = FALSE))
}
}
found[1L]
@ -454,14 +454,13 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = TRUE, ...) {
x_unknown <- x_unknown[!x_unknown %in% x_unknown_ATCs]
if (length(x_unknown_ATCs) > 0) {
warning_("These ATC codes are not (yet) in the antibiotics data set: ",
paste('"', sort(unique(x_unknown_ATCs)), '"', sep = "", collapse = ", "),
".",
vector_and(x_unknown_ATCs), ".",
call = FALSE)
}
if (length(x_unknown) > 0 & fast_mode == FALSE) {
warning_("These values could not be coerced to a valid antimicrobial ID: ",
paste('"', sort(unique(x_unknown)), '"', sep = "", collapse = ", "),
vector_and(x_unknown), ".",
".",
call = FALSE)
}

6
R/ab_class_selectors.R
View File

@ -82,13 +82,13 @@
#' }
ab_class <- function(ab_class,
only_rsi_columns = NULL) {
ab_selector(ab_class, function_name = "ab_class")
ab_selector(ab_class, function_name = "ab_class", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
aminoglycosides <- function(only_rsi_columns = NULL) {
ab_selector("aminoglycoside", function_name = "aminoglycosides")
ab_selector("aminoglycoside", function_name = "aminoglycosides", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
@ -217,7 +217,7 @@ ab_selector <- function(ab_class,
need_name <- tolower(gsub("[^a-zA-Z]", "", agents)) != tolower(gsub("[^a-zA-Z]", "", agents_names))
agents_formatted[need_name] <- paste0(agents_formatted[need_name],
" (", agents_names[need_name], ")")
message_("Selecting ", ab_group, ": ", paste(agents_formatted, collapse = ", "),
message_("Selecting ", ab_group, ": ", vector_and(agents_formatted, quotes = FALSE),
as_note = FALSE,
extra_indent = 4)
}

2
R/ab_from_text.R
View File

@ -29,7 +29,7 @@
#' @inheritSection lifecycle Maturing Lifecycle
#' @param text text to analyse
#' @param type type of property to search for, either `"drug"`, `"dose"` or `"administration"`, see *Examples*
#' @param collapse character to pass on to `paste(..., collapse = ...)` to only return one character per element of `text`, see *Examples*
#' @param collapse character to pass on to `paste(, collapse = ...)` to only return one character per element of `text`, see *Examples*
#' @param translate_ab if `type = "drug"`: a column name of the [antibiotics] data set to translate the antibiotic abbreviations to, using [ab_property()]. Defaults to `FALSE`. Using `TRUE` is equal to using "name".
#' @param thorough_search logical to indicate whether the input must be extensively searched for misspelling and other faulty input values. Setting this to `TRUE` will take considerably more time than when using `FALSE`. At default, it will turn `TRUE` when all input elements contain a maximum of three words.
#' @param ... arguments passed on to [as.ab()]

2
R/ab_property.R
View File

@ -225,7 +225,7 @@ ab_url <- function(x, open = FALSE, ...) {
NAs <- ab_name(ab, tolower = TRUE, language = NULL)[!is.na(ab) & is.na(ab_atc(ab))]
if (length(NAs) > 0) {
warning_("No ATC code available for ", paste0(NAs, collapse = ", "), ".")
warning_("No ATC code available for ", vector_and(NAs, quotes = FALSE), ".")
}
if (open == TRUE) {

4
R/disk.R
View File

@ -98,8 +98,8 @@ as.disk <- function(x, na.rm = FALSE) {
if (na_before != na_after) {
list_missing <- x.bak[is.na(x) & !is.na(x.bak)] %pm>%
unique() %pm>%
sort()
list_missing <- paste0('"', list_missing, '"', collapse = ", ")
sort() %pm>%
vector_and(quotes = TRUE)
warning_(na_after - na_before, " results truncated (",
round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid disk zones: ",

23
R/eucast_rules.R
View File

@ -57,7 +57,8 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
" (", lst[[v]]$year, ")"))
}
}
paste0(txt, collapse = ", ")
vector_and(txt, quotes = FALSE)
}
#' Apply EUCAST Rules
@ -73,7 +74,7 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
#' @param verbose a [logical] to turn Verbose mode on and off (default is off). In Verbose mode, the function does not apply rules to the data, but instead returns a data set in logbook form with extensive info about which rows and columns would be effected and in which way. Using Verbose mode takes a lot more time.
#' @param version_breakpoints the version number to use for the EUCAST Clinical Breakpoints guideline. Can be either `r vector_or(names(EUCAST_VERSION_BREAKPOINTS), reverse = TRUE)`.
#' @param version_expertrules the version number to use for the EUCAST Expert Rules and Intrinsic Resistance guideline. Can be either `r vector_or(names(EUCAST_VERSION_EXPERT_RULES), reverse = TRUE)`.
#' @param ampc_cephalosporin_resistance a character value that should be applied for AmpC de-repressed cephalosporin-resistant mutants, defaults to `NA`. Currently only works when `version_expertrules` is `3.2`; '*EUCAST Expert Rules v3.2 on Enterobacterales*' states that results of cefotaxime, ceftriaxone and ceftazidime should be reported with a note, or results should be suppressed (emptied) for these agents. A value of `NA` for this argument will remove results for these agents, while e.g. a value of `"R"` will make the results for these agents resistant. Use `NULL` to not alter the results for AmpC de-repressed cephalosporin-resistant mutants. \cr For *EUCAST Expert Rules* v3.2, this rule applies to: `r vector_or(gsub("[^a-zA-Z ]+", "", unlist(strsplit(eucast_rules_file[which(eucast_rules_file$reference.version == 3.2 & eucast_rules_file$reference.rule %like% "ampc"), "this_value"][1], "|", fixed = TRUE))), quotes = "*", last_sep = " and ")`.
#' @param ampc_cephalosporin_resistance a character value that should be applied for AmpC de-repressed cephalosporin-resistant mutants, defaults to `NA`. Currently only works when `version_expertrules` is `3.2`; '*EUCAST Expert Rules v3.2 on Enterobacterales*' states that results of cefotaxime, ceftriaxone and ceftazidime should be reported with a note, or results should be suppressed (emptied) for these agents. A value of `NA` for this argument will remove results for these agents, while e.g. a value of `"R"` will make the results for these agents resistant. Use `NULL` to not alter the results for AmpC de-repressed cephalosporin-resistant mutants. \cr For *EUCAST Expert Rules* v3.2, this rule applies to: `r vector_and(gsub("[^a-zA-Z ]+", "", unlist(strsplit(eucast_rules_file[which(eucast_rules_file$reference.version == 3.2 & eucast_rules_file$reference.rule %like% "ampc"), "this_value"][1], "|", fixed = TRUE))), quotes = "*")`.
#' @param ... column name of an antibiotic, see section *Antibiotics* below
#' @param ab any (vector of) text that can be coerced to a valid antibiotic code with [as.ab()]
#' @param administration route of administration, either `r vector_or(dosage$administration)`
@ -282,6 +283,16 @@ eucast_rules <- function(x,
only_rsi_columns = only_rsi_columns,
...)
if (only_rsi_columns == TRUE && !paste0(sys.calls()[1], collapse = "") %like% "only_rsi_columns") {
cols_rsi_eligible <- colnames(x[, is.rsi.eligible(x), drop = FALSE])
if (length(cols_rsi_eligible) > 0) {
message_("These columns might be eligible for EUCAST rules, but are ignored since `only_rsi_columns` is `TRUE`: ",
vector_and(cols_rsi_eligible, quotes = TRUE, sort = FALSE),
as_note = TRUE, add_fn = font_red)
}
}
AMC <- cols_ab["AMC"]
AMK <- cols_ab["AMK"]
AMP <- cols_ab["AMP"]
@ -737,12 +748,8 @@ eucast_rules <- function(x,
} else {
if (info == TRUE) {
message_("\n\nSkipping inheritance rules defined by this package, such as setting trimethoprim (TMP) = R where trimethoprim/sulfamethoxazole (SXT) = R.",
as_note = FALSE,
add_fn = font_red)
message_("Use eucast_rules(..., rules = \"all\") to also apply those rules.",
as_note = FALSE,
add_fn = font_red)
cat("\n")
message_("Skipping inheritance rules defined by this package, such as setting trimethoprim (TMP) = R where trimethoprim/sulfamethoxazole (SXT) = R. Use `eucast_rules(..., rules = \"all\")` to also apply those rules.")
}
}

52
R/first_isolate.R
View File

@ -100,24 +100,27 @@
#' # See ?example_isolates.
#'
#' # basic filtering on first isolates
#' example_isolates[first_isolate(example_isolates), ]
#' example_isolates[first_isolate(), ]
#'
#' # filtering based on isolates ----------------------------------------------
#' \donttest{
#' # get all first Gram-negatives
#' example_isolates[which(first_isolate() & mo_is_gram_negative()), ]
#'
#' if (require("dplyr")) {
#' # filter on first isolates:
#' # filter on first isolates using dplyr:
#' example_isolates %>%
#' mutate(first_isolate = first_isolate(.)) %>%
#' filter(first_isolate == TRUE)
#' filter(first_isolate())
#'
#' # short-hand versions:
#' example_isolates %>%
#' filter(first_isolate())
#' example_isolates %>%
#' filter_first_isolate()
#'
#' example_isolates %>%
#' filter_first_weighted_isolate()
#'
#' # grouped determination of first isolates (also prints group names):
#' example_isolates %>%
#' group_by(hospital_id) %>%
#' mutate(first = first_isolate())
#'
#' # now let's see if first isolates matter:
#' A <- example_isolates %>%
@ -194,6 +197,14 @@ first_isolate <- function(x,
}
}
# fix for using a grouped df as input (a dot as first argument)
# such as example_isolates %>% group_by(hospital_id) %>% mutate(first_isolate = first_isolate(.))
if (inherits(x, "grouped_df")) {
# get_current_data() contains dplyr::cur_data_all()
x <- tryCatch(get_current_data(arg_name = "x", 0),
error = function(e) x)
}
# remove data.table, grouping from tibbles, etc.
x <- as.data.frame(x, stringsAsFactors = FALSE)
@ -427,12 +438,33 @@ first_isolate <- function(x,
decimal.mark <- getOption("OutDec")
big.mark <- ifelse(decimal.mark != ",", ",", ".")
if (info == TRUE) {
# print group name if used in dplyr::group_by()
cur_group <- import_fn("cur_group", "dplyr", error_on_fail = FALSE)
if (!is.null(cur_group)) {
group_df <- tryCatch(cur_group(), error = function(e) data.frame())
if (NCOL(group_df) > 0) {
# transform factors to characters
group <- vapply(FUN.VALUE = character(1), group_df, function(x) {
if (is.numeric(x)) {
format(x)
} else if (is.logical(x)) {
as.character(x)
} else {
paste0('"', x, '"')
}
})
cat("\nGroup: ", paste0(names(group), " = ", group, collapse = ", "), "\n", sep = "")
}
}
}
# handle empty microorganisms
if (any(x$newvar_mo == "UNKNOWN", na.rm = TRUE) & info == TRUE) {
message_(ifelse(include_unknown == TRUE, "Included ", "Excluded "),
format(sum(x$newvar_mo == "UNKNOWN", na.rm = TRUE),
decimal.mark = decimal.mark, big.mark = big.mark),
" isolates with a microbial ID 'UNKNOWN' (column '", font_bold(col_mo), "')")
" isolates with a microbial ID 'UNKNOWN' (in column '", font_bold(col_mo), "')")
}
x[which(x$newvar_mo == "UNKNOWN"), "newvar_first_isolate"] <- include_unknown
@ -440,7 +472,7 @@ first_isolate <- function(x,
if (any(is.na(x$newvar_mo)) & info == TRUE) {
message_("Excluded ", format(sum(is.na(x$newvar_mo), na.rm = TRUE),
decimal.mark = decimal.mark, big.mark = big.mark),
" isolates with a microbial ID 'NA' (column '", font_bold(col_mo), "')")
" isolates with a microbial ID 'NA' (in column '", font_bold(col_mo), "')")
}
x[which(is.na(x$newvar_mo)), "newvar_first_isolate"] <- FALSE

9
R/guess_ab_col.R
View File

@ -67,6 +67,7 @@ guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE, only_r
meet_criteria(x, allow_class = "data.frame", allow_NULL = TRUE)
meet_criteria(search_string, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(verbose, allow_class = "logical", has_length = 1)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
if (is.null(x) & is.null(search_string)) {
return(as.name("guess_ab_col"))
@ -225,9 +226,9 @@ get_column_abx <- function(x,
if (info == TRUE & !all(soft_dependencies %in% names(x))) {
# missing a soft dependency may lower the reliability
missing <- soft_dependencies[!soft_dependencies %in% names(x)]
missing_msg <- paste(paste0(ab_name(missing, tolower = TRUE, language = NULL),
" (", font_bold(missing, collapse = NULL), ")"),
collapse = ", ")
missing_msg <- vector_and(paste0(ab_name(missing, tolower = TRUE, language = NULL),
" (", font_bold(missing, collapse = NULL), ")"),
quotes = FALSE)
message_("Reliability would be improved if these antimicrobial results would be available too: ",
missing_msg)
}
@ -243,7 +244,7 @@ generate_warning_abs_missing <- function(missing, any = FALSE) {
any_txt <- c("", "are")
}
warning_(paste0("Introducing NAs since", any_txt[1], " these antimicrobials ", any_txt[2], " required: ",
paste(missing, collapse = ", ")),
vector_and(missing, quotes = FALSE)),
immediate = TRUE,
call = FALSE)
}

9
R/mdro.R
View File

@ -497,6 +497,15 @@ mdro <- function(x,
...)
}
if (only_rsi_columns == TRUE) {
cols_rsi_eligible <- colnames(x[, is.rsi.eligible(x), drop = FALSE])
if (length(cols_rsi_eligible) > 0) {
message_("These columns might be eligible for determining ", guideline$type, ", but are ignored since `only_rsi_columns` is `TRUE`: ",
vector_and(cols_rsi_eligible, quotes = TRUE, sort = FALSE),
as_note = TRUE, add_fn = font_red)
}
}
# nolint start
AMC <- cols_ab["AMC"]
AMK <- cols_ab["AMK"]

4
R/mic.R
View File

@ -123,8 +123,8 @@ as.mic <- function(x, na.rm = FALSE) {
if (na_before != na_after) {
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ""] %pm>%
unique() %pm>%
sort()
list_missing <- paste0('"', list_missing, '"', collapse = ", ")
sort() %pm>%
vector_and(quotes = TRUE)
warning_(na_after - na_before, " results truncated (",
round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid MICs: ",

12
R/mo.R
View File

@ -1418,7 +1418,7 @@ exec_as.mo <- function(x,
" (covering ", percentage(total_failures / total_n),
") could not be coerced and ", plural[3], " considered 'unknown'")
if (pm_n_distinct(failures) <= 10) {
msg <- paste0(msg, ": ", paste('"', unique(failures), '"', sep = "", collapse = ", "))
msg <- paste0(msg, ": ", vector_and(failures, quotes = TRUE))
}
msg <- paste0(msg,
".\nUse mo_failures() to review ", plural[2], ". Edit the `allow_uncertain` argument if needed (see ?as.mo).\n",
@ -1450,7 +1450,7 @@ exec_as.mo <- function(x,
# - Becker et al. 2014, PMID 25278577
# - Becker et al. 2019, PMID 30872103
# - Becker et al. 2020, PMID 32056452
post_Becker <- character(0) # 2020-10-20 currently all are mentioned in above papers (otherwise uncomment below)
post_Becker <- character(0) # 2020-10-20 currently all are mentioned in above papers (otherwise uncomment the section below)
# nolint start
# if (any(x %in% MO_lookup[which(MO_lookup$species %in% post_Becker), property])) {
@ -1796,7 +1796,6 @@ print.mo_uncertainties <- function(x, ...) {
return(NULL)
}
message_("Matching scores are based on human pathogenic prevalence and the resemblance between the input and the full taxonomic name. See ?mo_matching_score.", as_note = FALSE)
cat("\n")
msg <- ""
for (i in seq_len(nrow(x))) {
@ -1807,7 +1806,7 @@ print.mo_uncertainties <- function(x, ...) {
candidates <- candidates[order(1 - scores)]
scores_formatted <- trimws(formatC(round(scores, 3), format = "f", digits = 3))
n_candidates <- length(candidates)
candidates <- paste0(candidates, " (", scores_formatted[order(1 - scores)], ")", collapse = ", ")
candidates <- vector_and(paste0(candidates, " (", scores_formatted[order(1 - scores)], ")"), quotes = FALSE)
# align with input after arrow
candidates <- paste0("\n",
strwrap(paste0("Also matched",
@ -1987,9 +1986,8 @@ replace_ignore_pattern <- function(x, ignore_pattern) {
ignore_cases <- x %like% ignore_pattern
if (sum(ignore_cases) > 0) {
message_("The following input was ignored by `ignore_pattern = \"", ignore_pattern, "\"`: ",
paste0("'", sort(unique(x[x %like% ignore_pattern])), "'", collapse = ", "),
collapse = ", ")
x[x %like% ignore_pattern] <- NA_character_
vector_and(x[ignore_cases], quotes = TRUE))
x[ignore_cases] <- NA_character_
}
}
x

2
R/mo_property.R
View File

@ -28,7 +28,7 @@
#' Use these functions to return a specific property of a microorganism based on the latest accepted taxonomy. All input values will be evaluated internally with [as.mo()], which makes it possible to use microbial abbreviations, codes and names as input. See *Examples*.
#' @inheritSection lifecycle Stable Lifecycle
#' @param x any character (vector) that can be coerced to a valid microorganism code with [as.mo()]. Can be left blank for auto-guessing the column containing microorganism codes if used in a data set, see *Examples*.
#' @param property one of the column names of the [microorganisms] data set: `r paste0('"``', colnames(microorganisms), '\``"', collapse = ", ")`, or must be `"shortname"`
#' @param property one of the column names of the [microorganisms] data set: `r vector_or(colnames(microorganisms), sort = FALSE, quotes = TRUE)`, or must be `"shortname"`
#' @param language language of the returned text, defaults to system language (see [get_locale()]) and can be overwritten by setting the option `AMR_locale`, e.g. `options(AMR_locale = "de")`, see [translate]. Also used to translate text like "no growth". Use `language = NULL` or `language = ""` to prevent translation.
#' @param ... other arguments passed on to [as.mo()], such as 'allow_uncertain' and 'ignore_pattern'
#' @param ab any (vector of) text that can be coerced to a valid antibiotic code with [as.ab()]

4
R/mo_source.R
View File

@ -283,9 +283,9 @@ check_validity_mo_source <- function(x, refer_to_name = "`reference_df`", stop_o
} else {
plural <- ""
}
stop_("Value", plural, " ", paste0("'", invalid[, 1, drop = TRUE], "'", collapse = ", "),
stop_("Value", plural, " ", vector_and(invalid[, 1, drop = TRUE], quotes = TRUE),
" found in ", tolower(refer_to_name),
", but with invalid microorganism code", plural, " ", paste0("'", invalid$mo, "'", collapse = ", "),
", but with invalid microorganism code", plural, " ", vector_and(invalid$mo, quotes = TRUE),
call = FALSE)
} else {
return(FALSE)

4
R/pca.R
View File

@ -117,9 +117,7 @@ pca <- function(x,
pca_data <- x[, which(vapply(FUN.VALUE = logical(1), x, function(x) is.numeric(x)))]
message_("Columns selected for PCA: ", vector_or(font_bold(colnames(pca_data), collapse = NULL),
quotes = "'",
last_sep = " and "),
message_("Columns selected for PCA: ", vector_and(font_bold(colnames(pca_data), collapse = NULL), quotes = TRUE),
". Total observations available: ", nrow(pca_data), ".")
if (as.double(R.Version()$major) + (as.double(R.Version()$minor) / 10) < 3.4) {

19
R/rsi.R
View File

@ -65,7 +65,7 @@
#'
#' ## Supported Guidelines
#'
#' For interpreting MIC values as well as disk diffusion diameters, supported guidelines to be used as input for the `guideline` argument are: `r paste0('"', sort(unique(AMR::rsi_translation$guideline)), '"', collapse = ", ")`.
#' For interpreting MIC values as well as disk diffusion diameters, supported guidelines to be used as input for the `guideline` argument are: `r vector_and(AMR::rsi_translation$guideline, quotes = TRUE, reverse = TRUE)`.
#'
#' Simply using `"CLSI"` or `"EUCAST"` as input will automatically select the latest version of that guideline. You can set your own data set using the `reference_data` argument. The `guideline` argument will then be ignored.
#'
@ -79,9 +79,9 @@
#'
#' ## Other
#'
#' The function [is.rsi()] detects if the input contains class `<rsi>`. If the input is a data.frame, it returns a vector in which all columns are checked for this class.
#' The function [is.rsi()] detects if the input contains class `<rsi>`. If the input is a data.frame, it iterates over all columns and returns a logical vector.
#'
#' The function [is.rsi.eligible()] returns `TRUE` when a columns contains at most 5% invalid antimicrobial interpretations (not S and/or I and/or R), and `FALSE` otherwise. The threshold of 5% can be set with the `threshold` argument.
#' The function [is.rsi.eligible()] returns `TRUE` when a columns contains at most 5% invalid antimicrobial interpretations (not S and/or I and/or R), and `FALSE` otherwise. The threshold of 5% can be set with the `threshold` argument. If the input is a data.frame, it iterates over all columns and returns a logical vector.
#' @section Interpretation of R and S/I:
#' In 2019, the European Committee on Antimicrobial Susceptibility Testing (EUCAST) has decided to change the definitions of susceptibility testing categories R and S/I as shown below (<https://www.eucast.org/newsiandr/>).
#'
@ -203,6 +203,10 @@ is.rsi <- function(x) {
is.rsi.eligible <- function(x, threshold = 0.05) {
meet_criteria(threshold, allow_class = "numeric", has_length = 1)
if (inherits(x, "data.frame")) {
return(unname(vapply(FUN.VALUE = logical(1), x, is.rsi.eligible)))
}
stop_if(NCOL(x) > 1, "`x` must be a one-dimensional vector.")
if (any(c("numeric",
"integer",
@ -294,8 +298,8 @@ as.rsi.default <- function(x, ...) {
if (na_before != na_after) {
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ""] %pm>%
unique() %pm>%
sort()
list_missing <- paste0('"', list_missing, '"', collapse = ", ")
sort() %pm>%
vector_and(quotes = TRUE)
warning_(na_after - na_before, " results truncated (",
round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid antimicrobial interpretations: ",
@ -551,7 +555,7 @@ as.rsi.data.frame <- function(x,
plural <- c("", "s", "a ")
}
message_("Assuming value", plural[1], " ",
paste(paste0('"', values, '"'), collapse = ", "),
vector_and(values, quotes = TRUE),
" in column '", font_bold(col_specimen),
"' reflect", plural[2], " ", plural[3], "urinary tract infection", plural[1],
".\n Use `as.rsi(uti = FALSE)` to prevent this.")
@ -682,10 +686,9 @@ get_guideline <- function(guideline, reference_data) {
stop_ifnot(guideline_param %in% reference_data$guideline,
"invalid guideline: '", guideline,
"'.\nValid guidelines are: ", paste0("'", unique(reference_data$guideline), "'", collapse = ", "), call = FALSE)
"'.\nValid guidelines are: ", vector_and(reference_data$guideline, quotes = TRUE, reverse = TRUE), call = FALSE)
guideline_param
}
exec_as.rsi <- function(method,

4
R/rsi_calc.R
View File

@ -27,7 +27,7 @@ dots2vars <- function(...) {
# this function is to give more informative output about
# variable names in count_* and proportion_* functions
dots <- substitute(list(...))
paste(as.character(dots)[2:length(dots)], collapse = ", ")
vector_and(as.character(dots)[2:length(dots)], quotes = FALSE)
}
rsi_calc <- function(...,
@ -78,7 +78,7 @@ rsi_calc <- function(...,
dots <- c(dots[dots %in% colnames(dots_df)],
eval(parse(text = dots[!dots %in% colnames(dots_df)]), envir = dots_df, enclos = globalenv()))
dots_not_exist <- dots[!dots %in% colnames(dots_df)]
stop_if(length(dots_not_exist) > 0, "column(s) not found: ", paste0("'", dots_not_exist, "'", collapse = ", "), call = -2)
stop_if(length(dots_not_exist) > 0, "column(s) not found: ", vector_and(dots_not_exist, quotes = TRUE), call = -2)
x <- dots_df[, dots, drop = FALSE]
}
} else if (ndots == 1) {

10
R/translate.R
View File

@ -29,7 +29,7 @@
#' @inheritSection lifecycle Stable Lifecycle
#' @details Strings will be translated to foreign languages if they are defined in a local translation file. Additions to this file can be suggested at our repository. The file can be found here: <https://github.com/msberends/AMR/blob/master/data-raw/translations.tsv>. This file will be read by all functions where a translated output can be desired, like all [`mo_*`][mo_property()] functions (such as [mo_name()], [mo_gramstain()], [mo_type()], etc.) and [`ab_*`][ab_property()] functions (such as [ab_name()], [ab_group()], etc.).
#'
#' Currently supported languages are: `r paste(sort(gsub(";.*", "", ISOcodes::ISO_639_2[which(ISOcodes::ISO_639_2$Alpha_2 %in% LANGUAGES_SUPPORTED), "Name"])), collapse = ", ")`. Please note that currently not all these languages have translations available for all antimicrobial agents and colloquial microorganism names.
#' Currently supported languages are: `r vector_and(gsub(";.*", "", ISOcodes::ISO_639_2[which(ISOcodes::ISO_639_2$Alpha_2 %in% LANGUAGES_SUPPORTED), "Name"]), quotes = FALSE)`. Please note that currently not all these languages have translations available for all antimicrobial agents and colloquial microorganism names.
#'
#' Please suggest your own translations [by creating a new issue on our repository](https://github.com/msberends/AMR/issues/new?title=Translations).
#'
@ -83,8 +83,8 @@ get_locale <- function() {
if (lang %in% LANGUAGES_SUPPORTED) {
return(lang)
} else {
stop_("unsupported language set as option 'AMR_locale': '", lang, "' - use one of: ",
paste0("'", LANGUAGES_SUPPORTED, "'", collapse = ", "))
stop_("unsupported language set as option 'AMR_locale': \"", lang, "\" - use either ",
vector_or(LANGUAGES_SUPPORTED, quotes = TRUE))
}
} else {
# we now support the LANGUAGE system variable - return it if set
@ -138,8 +138,8 @@ translate_AMR <- function(from, language = get_locale(), only_unknown = FALSE) {
from_unique_translated <- from_unique
stop_ifnot(language %in% LANGUAGES_SUPPORTED,
"unsupported language: '", language, "' - use one of: ",
paste0("'", LANGUAGES_SUPPORTED, "'", collapse = ", "),
"unsupported language: \"", language, "\" - use either ",
vector_or(LANGUAGES_SUPPORTED, quotes = TRUE),
call = FALSE)
df_trans <- subset(df_trans, lang == language)