1
0
mirror of https://github.com/msberends/AMR.git synced 2025-07-09 17:02:03 +02:00

(v1.2.0.9011) mo_domain(), improved error handling

This commit is contained in:
2020-06-22 11:18:40 +02:00
parent e88d7853f5
commit 93a158aebd
49 changed files with 523 additions and 590 deletions

View File

@ -179,7 +179,7 @@ search_type_in_df <- function(x, type) {
found
}
stopifnot_installed_package <- function(package) {
stop_ifnot_installed <- function(package) {
# no "utils::installed.packages()" since it requires non-staged install since R 3.6.0
# https://developer.r-project.org/Blog/public/2019/02/14/staged-install/index.html
sapply(package, function(pkg)
@ -197,16 +197,41 @@ stopifnot_installed_package <- function(package) {
}
import_fn <- function(name, pkg) {
stopifnot_installed_package(pkg)
stop_ifnot_installed(pkg)
get(name, envir = asNamespace(pkg))
}
stopifnot_msg <- function(expr, msg) {
if (!isTRUE(expr)) {
stop_if <- function(expr, ..., call = TRUE) {
msg <- paste0(c(...), collapse = "")
if (!isFALSE(call)) {
if (isTRUE(call)) {
call <- as.character(sys.call(-1)[1])
} else {
# so you can go back more than 1 call, as used in rsi_calc(), that now throws a reference to e.g. n_rsi()
call <- as.character(sys.call(call)[1])
}
msg <- paste0("in ", call, "(): ", msg)
}
if (isTRUE(expr)) {
stop(msg, call. = FALSE)
}
}
stop_ifnot <- function(expr, ..., call = TRUE) {
msg <- paste0(c(...), collapse = "")
if (!isFALSE(call)) {
if (isTRUE(call)) {
call <- as.character(sys.call(-1)[1])
} else {
# so you can go back more than 1 call, as used in rsi_calc(), that now throws a reference to e.g. n_rsi()
call <- as.character(sys.call(call)[1])
}
msg <- paste0("in ", call, "(): ", msg)
}
if (!isTRUE(expr)) {
stop(msg, call. = FALSE)
}
}
"%or%" <- function(x, y) {
if (is.null(x) | is.null(y)) {
@ -396,7 +421,7 @@ progress_estimated <- function(n = 1, n_min = 0, ...) {
}
}
# works exactly like round(), but rounds `round(44.55, 1)` as 44.6 instead of 44.5
# works exactly like round(), but rounds `round2(44.55, 1)` to 44.6 instead of 44.5
# and adds decimal zeroes until `digits` is reached when force_zero = TRUE
round2 <- function(x, digits = 0, force_zero = TRUE) {
x <- as.double(x)

View File

@ -157,9 +157,7 @@ ab_loinc <- function(x, ...) {
#' @rdname ab_property
#' @export
ab_ddd <- function(x, administration = "oral", units = FALSE, ...) {
if (!administration %in% c("oral", "iv")) {
stop("`administration` must be 'oral' or 'iv'", call. = FALSE)
}
stop_ifnot(administration %in% c("oral", "iv"), "`administration` must be 'oral' or 'iv'")
ddd_prop <- administration
if (units == TRUE) {
ddd_prop <- paste0(ddd_prop, "_units")
@ -215,12 +213,9 @@ ab_url <- function(x, open = FALSE, ...) {
#' @rdname ab_property
#' @export
ab_property <- function(x, property = "name", language = get_locale(), ...) {
if (length(property) != 1L) {
stop("'property' must be of length 1.")
}
if (!property %in% colnames(antibiotics)) {
stop("invalid property: '", property, "' - use a column name of the `antibiotics` data set")
}
stop_if(length(property) != 1L, "'property' must be of length 1.")
stop_ifnot(property %in% colnames(antibiotics),
"invalid property: '", property, "' - use a column name of the `antibiotics` data set")
translate_AMR(ab_validate(x = x, property = property, ...), language = language)
}

16
R/age.R
View File

@ -42,11 +42,8 @@
#' df
age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE) {
if (length(x) != length(reference)) {
if (length(reference) == 1) {
reference <- rep(reference, length(x))
} else {
stop("`x` and `reference` must be of same length, or `reference` must be of length 1.")
}
stop_if(length(reference) != 1, "`x` and `reference` must be of same length, or `reference` must be of length 1.")
reference <- rep(reference, length(x))
}
x <- as.POSIXlt(x)
reference <- as.POSIXlt(reference)
@ -141,9 +138,7 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE) {
#' ggplot_rsi(x = "age_group")
#' }
age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
if (!is.numeric(x)) {
stop("`x` and must be numeric, not a ", paste0(class(x), collapse = "/"), ".")
}
stop_ifnot(is.numeric(x), "`x` must be numeric, not ", paste0(class(x), collapse = "/"))
if (any(x < 0, na.rm = TRUE)) {
x[x < 0] <- NA
warning("NAs introduced for ages below 0.")
@ -166,10 +161,7 @@ age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
split_at <- c(0, split_at)
}
split_at <- split_at[!is.na(split_at)]
if (length(split_at) == 1) {
# only 0 is available
stop("invalid value for `split_at`.")
}
stop_if(length(split_at) == 1, "invalid value for `split_at`") # only 0 is available
# turn input values to 'split_at' indices
y <- x

View File

@ -96,12 +96,8 @@ atc_online_property <- function(atc_code,
return(rep(NA, length(atc_code)))
}
if (length(property) != 1L) {
stop("`property` must be of length 1", call. = FALSE)
}
if (length(administration) != 1L) {
stop("`administration` must be of length 1", call. = FALSE)
}
stop_if(length(property) != 1L, "`property` must be of length 1")
stop_if(length(administration) != 1L, "`administration` must be of length 1")
# also allow unit as property
if (property %like% "unit") {
@ -115,9 +111,8 @@ atc_online_property <- function(atc_code,
property <- tolower(property)
valid_properties <- tolower(valid_properties)
if (!property %in% valid_properties) {
stop("Invalid `property`, use one of ", paste(valid_properties.bak, collapse = ", "), ".")
}
stop_ifnot(property %in% valid_properties,
"Invalid `property`, use one of ", paste(valid_properties.bak, collapse = ", "))
if (property == "ddd") {
returnvalue <- rep(NA_real_, length(atc_code))

View File

@ -46,6 +46,7 @@
#' availability()
#' }
availability <- function(tbl, width = NULL) {
stop_ifnot(is.data.frame(tbl), "`tbl` must be a data.frame")
x <- base::sapply(tbl, function(x) {
1 - base::sum(base::is.na(x)) / base::length(x)
})

View File

@ -59,21 +59,15 @@ bug_drug_combinations <- function(x,
col_mo = NULL,
FUN = mo_shortname,
...) {
if (!is.data.frame(x)) {
stop("`x` must be a data frame.", call. = FALSE)
}
if (!any(sapply(x, is.rsi), na.rm = TRUE)) {
stop("No columns with class <rsi> found. See ?as.rsi.", call. = FALSE)
}
stop_ifnot(is.data.frame(x), "`x` must be a data frame")
stop_ifnot(any(sapply(x, is.rsi), na.rm = TRUE), "No columns with class <rsi> found. See ?as.rsi.")
# try to find columns based on type
# -- mo
if (is.null(col_mo)) {
col_mo <- search_type_in_df(x = x, type = "mo")
}
if (is.null(col_mo)) {
stop("`col_mo` must be set.", call. = FALSE)
}
stop_if(is.null(col_mo), "`col_mo` must be set")
x_class <- class(x)
x <- as.data.frame(x, stringsAsFactors = FALSE)

View File

@ -217,26 +217,17 @@ eucast_rules <- function(x,
}
}
if (!is.data.frame(x)) {
stop("`x` must be a data frame.", call. = FALSE)
}
stop_ifnot(is.data.frame(x), "`x` must be a data frame")
# try to find columns based on type
# -- mo
if (is.null(col_mo)) {
col_mo <- search_type_in_df(x = x, type = "mo")
}
if (is.null(col_mo)) {
stop("`col_mo` must be set.", call. = FALSE)
}
stop_if(is.null(col_mo), "`col_mo` must be set")
if (!all(rules %in% c("breakpoints", "expert", "other", "all"))) {
stop('`rules` must be one or more of: "breakpoints", "expert", "other", "all".')
}
if (is.null(col_mo)) {
stop("`col_mo` must be set")
}
stop_ifnot(all(rules %in% c("breakpoints", "expert", "other", "all")),
'`rules` must be one or more of: "breakpoints", "expert", "other", "all".')
decimal.mark <- getOption("OutDec")
big.mark <- ifelse(decimal.mark != ",", ",", ".")

View File

@ -71,10 +71,7 @@ filter_ab_class <- function(x,
...) {
check_dataset_integrity()
if (!is.data.frame(x)) {
stop("`x` must be a data frame.", call. = FALSE)
}
stop_ifnot(is.data.frame(x), "`x` must be a data frame")
# save to return later
x_class <- class(x)
@ -88,12 +85,8 @@ filter_ab_class <- function(x,
# make result = "SI" works too:
result <- unlist(strsplit(result, ""))
if (!all(result %in% c("S", "I", "R"))) {
stop("`result` must be one or more of: S, I, R", call. = FALSE)
}
if (!all(scope %in% c("any", "all"))) {
stop("`scope` must be one of: any, all", call. = FALSE)
}
stop_ifnot(all(result %in% c("S", "I", "R")), "`result` must be one or more of: S, I, R")
stop_ifnot(all(scope %in% c("any", "all")), "`scope` must be one of: any, all")
# get all columns in data with names that resemble antibiotics
ab_in_data <- suppressMessages(get_column_abx(x))

View File

@ -156,9 +156,9 @@ first_isolate <- function(x,
}
}
if (!is.data.frame(x)) {
stop("`x` must be a data.frame.", call. = FALSE)
}
stop_ifnot(is.data.frame(x), "`x` must be a data.frame")
stop_if(any(dim(x) == 0), "`x` must contain rows and columns")
# remove data.table, grouping from tibbles, etc.
x <- as.data.frame(x, stringsAsFactors = FALSE)
@ -166,17 +166,13 @@ first_isolate <- function(x,
# -- mo
if (is.null(col_mo)) {
col_mo <- search_type_in_df(x = x, type = "mo")
if (is.null(col_mo)) {
stop("`col_mo` must be set.", call. = FALSE)
}
stop_if(is.null(col_mo), "`col_mo` must be set")
}
# -- date
if (is.null(col_date)) {
col_date <- search_type_in_df(x = x, type = "date")
if (is.null(col_date)) {
stop("`col_date` must be set.", call. = FALSE)
}
stop_if(is.null(col_date), "`col_date` must be set")
}
# convert to Date
dates <- as.Date(x[, col_date, drop = TRUE])
@ -193,9 +189,7 @@ first_isolate <- function(x,
} else {
col_patient_id <- search_type_in_df(x = x, type = "patient_id")
}
if (is.null(col_patient_id)) {
stop("`col_patient_id` must be set.", call. = FALSE)
}
stop_if(is.null(col_patient_id), "`col_patient_id` must be set")
}
# -- key antibiotics
@ -216,14 +210,9 @@ first_isolate <- function(x,
# check if columns exist
check_columns_existance <- function(column, tblname = x) {
if (NROW(tblname) <= 1 | NCOL(tblname) <= 1) {
stop("Please check tbl for existance.")
}
if (!is.null(column)) {
if (!(column %in% colnames(tblname))) {
stop("Column `", column, "` not found.")
}
stop_ifnot(column %in% colnames(tblname),
"Column `", column, "` not found.", call = FALSE)
}
}

View File

@ -95,22 +95,22 @@ ggplot_pca <- function(x,
base_textsize = 10,
...) {
stopifnot_installed_package("ggplot2")
stopifnot_msg(length(choices) == 2, "`choices` must be of length 2")
stopifnot_msg(is.logical(scale), "`scale` must be TRUE or FALSE")
stopifnot_msg(is.logical(pc.biplot), "`pc.biplot` must be TRUE or FALSE")
stopifnot_msg(is.numeric(choices), "`choices` must be numeric")
stopifnot_msg(is.numeric(labels_textsize), "`labels_textsize` must be numeric")
stopifnot_msg(is.numeric(labels_text_placement), "`labels_text_placement` must be numeric")
stopifnot_msg(is.logical(ellipse), "`ellipse` must be TRUE or FALSE")
stopifnot_msg(is.numeric(ellipse_prob), "`ellipse_prob` must be numeric")
stopifnot_msg(is.numeric(ellipse_size), "`ellipse_size` must be numeric")
stopifnot_msg(is.numeric(ellipse_alpha), "`ellipse_alpha` must be numeric")
stopifnot_msg(is.logical(arrows), "`arrows` must be TRUE or FALSE")
stopifnot_msg(is.numeric(arrows_size), "`arrows_size` must be numeric")
stopifnot_msg(is.numeric(arrows_textsize), "`arrows_textsize` must be numeric")
stopifnot_msg(is.numeric(arrows_alpha), "`arrows_alpha` must be numeric")
stopifnot_msg(is.numeric(base_textsize), "`base_textsize` must be numeric")
stop_ifnot_installed("ggplot2")
stop_ifnot(length(choices) == 2, "`choices` must be of length 2")
stop_ifnot(is.logical(scale), "`scale` must be TRUE or FALSE")
stop_ifnot(is.logical(pc.biplot), "`pc.biplot` must be TRUE or FALSE")
stop_ifnot(is.numeric(choices), "`choices` must be numeric")
stop_ifnot(is.numeric(labels_textsize), "`labels_textsize` must be numeric")
stop_ifnot(is.numeric(labels_text_placement), "`labels_text_placement` must be numeric")
stop_ifnot(is.logical(ellipse), "`ellipse` must be TRUE or FALSE")
stop_ifnot(is.numeric(ellipse_prob), "`ellipse_prob` must be numeric")
stop_ifnot(is.numeric(ellipse_size), "`ellipse_size` must be numeric")
stop_ifnot(is.numeric(ellipse_alpha), "`ellipse_alpha` must be numeric")
stop_ifnot(is.logical(arrows), "`arrows` must be TRUE or FALSE")
stop_ifnot(is.numeric(arrows_size), "`arrows_size` must be numeric")
stop_ifnot(is.numeric(arrows_textsize), "`arrows_textsize` must be numeric")
stop_ifnot(is.numeric(arrows_alpha), "`arrows_alpha` must be numeric")
stop_ifnot(is.numeric(base_textsize), "`base_textsize` must be numeric")
calculations <- pca_calculations(pca_model = x,
groups = groups,

View File

@ -164,7 +164,7 @@ ggplot_rsi <- function(data,
y.title = "Proportion",
...) {
stopifnot_installed_package("ggplot2")
stop_ifnot_installed("ggplot2")
x <- x[1]
facet <- facet[1]
@ -245,11 +245,8 @@ geom_rsi <- function(position = NULL,
combine_IR = FALSE,
...) {
stopifnot_installed_package("ggplot2")
if (is.data.frame(position)) {
stop("`position` is invalid. Did you accidentally use '%>%' instead of '+'?", call. = FALSE)
}
stop_ifnot_installed("ggplot2")
stop_if(is.data.frame(position), "`position` is invalid. Did you accidentally use '%>%' instead of '+'?")
y <- "value"
if (missing(position) | is.null(position)) {
@ -293,7 +290,7 @@ geom_rsi <- function(position = NULL,
#' @export
facet_rsi <- function(facet = c("interpretation", "antibiotic"), nrow = NULL) {
stopifnot_installed_package("ggplot2")
stop_ifnot_installed("ggplot2")
facet <- facet[1]
@ -318,7 +315,7 @@ facet_rsi <- function(facet = c("interpretation", "antibiotic"), nrow = NULL) {
#' @rdname ggplot_rsi
#' @export
scale_y_percent <- function(breaks = seq(0, 1, 0.1), limits = NULL) {
stopifnot_installed_package("ggplot2")
stop_ifnot_installed("ggplot2")
if (all(breaks[breaks != 0] > 1)) {
breaks <- breaks / 100
@ -335,7 +332,7 @@ scale_rsi_colours <- function(colours = c(S = "#61a8ff",
I = "#61f7ff",
IR = "#ff6961",
R = "#ff6961")) {
stopifnot_installed_package("ggplot2")
stop_ifnot_installed("ggplot2")
# previous colour: palette = "RdYlGn"
# previous colours: values = c("#b22222", "#ae9c20", "#7cfc00")
@ -353,7 +350,7 @@ scale_rsi_colours <- function(colours = c(S = "#61a8ff",
#' @rdname ggplot_rsi
#' @export
theme_rsi <- function() {
stopifnot_installed_package("ggplot2")
stop_ifnot_installed("ggplot2")
ggplot2::theme_minimal(base_size = 10) +
ggplot2::theme(panel.grid.major.x = ggplot2::element_blank(),
panel.grid.minor = ggplot2::element_blank(),
@ -372,7 +369,7 @@ labels_rsi_count <- function(position = NULL,
combine_IR = FALSE,
datalabels.size = 3,
datalabels.colour = "gray15") {
stopifnot_installed_package("ggplot2")
stop_ifnot_installed("ggplot2")
if (is.null(position)) {
position <- "fill"
}

View File

@ -62,9 +62,7 @@ guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE) {
if (is.null(x) & is.null(search_string)) {
return(as.name("guess_ab_col"))
}
if (!is.data.frame(x)) {
stop("`x` must be a data.frame")
}
stop_ifnot(is.data.frame(x), "`x` must be a data.frame")
if (length(search_string) > 1) {
warning("argument 'search_string' has length > 1 and only the first element will be used")

View File

@ -175,7 +175,7 @@ joins_check_df <- function(x, by) {
by <- "mo"
x[, "mo"] <- as.mo(x[, "mo"])
} else {
stop("Cannot join - no column found with name or class <mo>.", call. = FALSE)
stop("Cannot join - no column found with name 'mo' or with class <mo>.", call. = FALSE)
}
}
message('Joining, by = "', by, '"') # message same as dplyr::join functions

View File

@ -136,9 +136,7 @@ key_antibiotics <- function(x,
if (is.null(col_mo)) {
col_mo <- search_type_in_df(x = x, type = "mo")
}
if (is.null(col_mo)) {
stop("`col_mo` must be set.", call. = FALSE)
}
stop_if(is.null(col_mo), "`col_mo` must be set")
# check columns
col.list <- c(universal_1, universal_2, universal_3, universal_4, universal_5, universal_6,
@ -260,9 +258,7 @@ key_antibiotics_equal <- function(y,
type <- type[1]
if (length(x) != length(y)) {
stop("Length of `x` and `y` must be equal.")
}
stop_ifnot(length(x) == length(y), "length of `x` and `y` must be equal")
# only show progress bar on points or when at least 5000 isolates
info_needed <- info == TRUE & (type == "points" | length(x) > 5000)

View File

@ -106,15 +106,13 @@ mdro <- function(x,
}
}
if (!is.data.frame(x)) {
stop("`x` must be a data frame.", call. = FALSE)
}
stop_ifnot(is.data.frame(x), "`x` must be a data.frame")
stop_if(any(dim(x) == 0), "`x` must contain rows and columns")
# force regular data.frame, not a tibble or data.table
x <- as.data.frame(x, stringsAsFactors = FALSE)
if (!is.numeric(pct_required_classes)) {
stop("`pct_required_classes` must be numeric.", call. = FALSE)
}
stop_ifnot(is.numeric(pct_required_classes), "`pct_required_classes` must be numeric")
if (pct_required_classes > 1) {
# allow pct_required_classes = 75 -> pct_required_classes = 0.75
pct_required_classes <- pct_required_classes / 100
@ -124,9 +122,7 @@ mdro <- function(x,
warning("Using `country` is deprecated, use `guideline` instead. Please see ?mdro.", call. = FALSE)
guideline <- list(...)$country
}
if (length(guideline) > 1) {
stop("`guideline` must be a length one character string.", call. = FALSE)
}
stop_ifnot(length(guideline) == 1, "`guideline` must be of length 1")
if (is.null(guideline)) {
# default to the paper by Magiorakos et al. (2012)
@ -138,9 +134,8 @@ mdro <- function(x,
if (tolower(guideline) == "de") {
guideline <- "MRGN"
}
if (!tolower(guideline) %in% c("brmo", "mrgn", "eucast", "tb", "cmi2012")) {
stop("invalid guideline: ", guideline, call. = FALSE)
}
stop_ifnot(tolower(guideline) %in% c("brmo", "mrgn", "eucast", "tb", "cmi2012"),
"invalid guideline: ", guideline)
guideline <- list(code = tolower(guideline))
# try to find columns based on type
@ -154,9 +149,7 @@ mdro <- function(x,
x$mo <- as.mo("Mycobacterium tuberculosis")
col_mo <- "mo"
}
if (is.null(col_mo)) {
stop("`col_mo` must be set.", call. = FALSE)
}
stop_if(is.null(col_mo), "`col_mo` must be set")
if (guideline$code == "cmi2012") {
guideline$name <- "Multidrug-resistant, extensively drug-resistant and pandrug-resistant bacteria: an international expert proposal for interim standard definitions for acquired resistance."
@ -417,9 +410,7 @@ mdro <- function(x,
RFP <- cols_ab["RFP"]
abx_tb <- c(CAP, ETH, GAT, INH, PZA, RIF, RIB, RFP)
abx_tb <- abx_tb[!is.na(abx_tb)]
if (guideline$code == "tb" & length(abx_tb) == 0) {
stop("No antimycobacterials found in data set.", call. = FALSE)
}
stop_if(guideline$code == "tb" & length(abx_tb) == 0, "no antimycobacterials found in data set")
if (combine_SI == TRUE) {
search_result <- "R"

12
R/mo.R
View File

@ -350,9 +350,8 @@ exec_as.mo <- function(x,
# defined df to check for
if (!is.null(reference_df)) {
if (!mo_source_isvalid(reference_df)) {
stop("`reference_df` must contain a column `mo` with values from the 'microorganisms' data set.", call. = FALSE)
}
mo_source_isvalid(reference_df)
reference_df <- reference_df %>% filter(!is.na(mo))
# keep only first two columns, second must be mo
if (colnames(reference_df)[1] == "mo") {
@ -1760,9 +1759,8 @@ translate_allow_uncertain <- function(allow_uncertain) {
allow_uncertain[tolower(allow_uncertain) == "none"] <- 0
allow_uncertain[tolower(allow_uncertain) == "all"] <- 3
allow_uncertain <- as.integer(allow_uncertain)
if (!allow_uncertain %in% c(0:3)) {
stop('`allow_uncertain` must be a number between 0 (or "none") and 3 (or "all"), or TRUE (= 2) or FALSE (= 0).', call. = FALSE)
}
stop_ifnot(allow_uncertain %in% c(0:3),
'`allow_uncertain` must be a number between 0 (or "none") and 3 (or "all"), or TRUE (= 2) or FALSE (= 0)', call = FALSE)
}
allow_uncertain
}
@ -1803,7 +1801,7 @@ parse_and_convert <- function(x) {
tryCatch({
if (!is.null(dim(x))) {
if (NCOL(x) > 2) {
stop("A maximum of two columns is allowed.", call. = FALSE)
stop("a maximum of two columns is allowed", call. = FALSE)
} else if (NCOL(x) == 2) {
# support Tidyverse selection like: df %>% select(colA, colB)
# paste these columns together

View File

@ -28,14 +28,16 @@
#' @param language language of the returned text, defaults to system language (see [get_locale()]) and can also be set with `getOption("AMR_locale")`. Use `language = NULL` or `language = ""` to prevent translation.
#' @param ... other parameters passed on to [as.mo()]
#' @param open browse the URL using [utils::browseURL()]
#' @details All functions will return the most recently known taxonomic property according to the Catalogue of Life, except for [mo_ref()], [mo_authors()] and [mo_year()]. This leads to the following results:
#' - `mo_name("Chlamydia psittaci")` will return `"Chlamydophila psittaci"` (with a warning about the renaming)
#' - `mo_ref("Chlamydia psittaci")` will return `"Page, 1968"` (with a warning about the renaming)
#' - `mo_ref("Chlamydophila psittaci")` will return `"Everett et al., 1999"` (without a warning)
#' @details All functions will return the most recently known taxonomic property according to the Catalogue of Life, except for [mo_ref()], [mo_authors()] and [mo_year()]. Please refer to this example, knowing that *Escherichia blattae* was renamed to *Shimwellia blattae* in 2010:
#' - `mo_name("Escherichia blattae")` will return `"Shimwellia blattae"` (with a message about the renaming)
#' - `mo_ref("Escherichia blattae")` will return `"Burgess et al., 1973"` (with a message about the renaming)
#' - `mo_ref("Shimwellia blattae")` will return `"Priest et al., 2010"` (without a message)
#'
#' The short name - [mo_shortname()] - almost always returns the first character of the genus and the full species, like *"E. coli"*. Exceptions are abbreviations of staphylococci and beta-haemolytic streptococci, like *"CoNS"* (Coagulase-Negative Staphylococci) and *"GBS"* (Group B Streptococci).
#' The short name - [mo_shortname()] - almost always returns the first character of the genus and the full species, like `"E. coli"`. Exceptions are abbreviations of staphylococci (like *"CoNS"*, Coagulase-Negative Staphylococci) and beta-haemolytic streptococci (like *"GBS"*, Group B Streptococci). Please bear in mind that e.g. *E. coli* could mean *Escherichia coli* (kingdom of Bacteria) as well as *Entamoeba coli* (kingdom of Protozoa). Returning to the full name will be done using [as.mo()] internally, giving priority to bacteria and human pathogens, i.e. `"E. coli"` will be considered *Escherichia coli*. In other words, `mo_fullname(mo_shortname("Entamoeba coli"))` returns `"Escherichia coli"`.
#'
#' Since the top-level of the taxonomy is sometimes referred to as 'kingdom' and sometimes as 'domain', the functions [mo_kingdom()] and [mo_domain()] return the exact same results.
#'
#' The Gram stain - [mo_gramstain()] - will be determined on the taxonomic kingdom and phylum. According to Cavalier-Smith (2002) who defined subkingdoms Negibacteria and Posibacteria, only these phyla are Posibacteria: Actinobacteria, Chloroflexi, Firmicutes and Tenericutes. These bacteria are considered Gram-positive - all other bacteria are considered Gram-negative. Species outside the kingdom of Bacteria will return a value `NA`.
#' The Gram stain - [mo_gramstain()] - will be determined based on the taxonomic kingdom and phylum. According to Cavalier-Smith (2002, [PMID 11837318](https://pubmed.ncbi.nlm.nih.gov/11837318)), who defined subkingdoms Negibacteria and Posibacteria, only these phyla are Posibacteria: Actinobacteria, Chloroflexi, Firmicutes and Tenericutes. These bacteria are considered Gram-positive - all other bacteria are considered Gram-negative. Species outside the kingdom of Bacteria will return a value `NA`.
#'
#' All output will be [translate]d where possible.
#'
@ -218,6 +220,10 @@ mo_kingdom <- function(x, language = get_locale(), ...) {
translate_AMR(mo_validate(x = x, property = "kingdom", ...), language = language, only_unknown = TRUE)
}
#' @rdname mo_property
#' @export
mo_domain <- mo_kingdom
#' @rdname mo_property
#' @export
mo_type <- function(x, language = get_locale(), ...) {
@ -391,12 +397,9 @@ mo_url <- function(x, open = FALSE, ...) {
#' @rdname mo_property
#' @export
mo_property <- function(x, property = "fullname", language = get_locale(), ...) {
if (length(property) != 1L) {
stop("'property' must be of length 1.")
}
if (!property %in% colnames(microorganisms)) {
stop("invalid property: '", property, "' - use a column name of the `microorganisms` data set")
}
stop_ifnot(length(property) == 1L, "'property' must be of length 1")
stop_ifnot(property %in% colnames(microorganisms),
"invalid property: '", property, "' - use a column name of the `microorganisms` data set")
translate_AMR(mo_validate(x = x, property = property, ...), language = language, only_unknown = TRUE)
}

View File

@ -112,9 +112,7 @@ set_mo_source <- function(path) {
file_location <- path.expand("~/mo_source.rds")
if (length(path) > 1) {
stop("`path` must be of length 1.")
}
stop_ifnot(length(path) == 1, "`path` must be of length 1")
if (is.null(path) || path %in% c(FALSE, "")) {
options(mo_source = NULL)
@ -126,9 +124,8 @@ set_mo_source <- function(path) {
return(invisible())
}
if (!file.exists(path)) {
stop("File not found: ", path)
}
stop_ifnot(file.exists(path),
"file not found: ", path)
if (path %like% "[.]rds$") {
df <- readRDS(path)
@ -231,21 +228,21 @@ mo_source_isvalid <- function(x, refer_to_name = "`reference_df`", stop_on_error
}
if (is.null(x)) {
if (stop_on_error == TRUE) {
stop(refer_to_name, " cannot be NULL.", call. = FALSE)
stop(refer_to_name, " cannot be NULL", call. = FALSE)
} else {
return(FALSE)
}
}
if (!is.data.frame(x)) {
if (stop_on_error == TRUE) {
stop(refer_to_name, " must be a data.frame.", call. = FALSE)
stop(refer_to_name, " must be a data.frame", call. = FALSE)
} else {
return(FALSE)
}
}
if (!"mo" %in% colnames(x)) {
if (stop_on_error == TRUE) {
stop(refer_to_name, " must contain a column 'mo'.", call. = FALSE)
stop(refer_to_name, " must contain a column 'mo'", call. = FALSE)
} else {
return(FALSE)
}
@ -260,7 +257,7 @@ mo_source_isvalid <- function(x, refer_to_name = "`reference_df`", stop_on_error
}
stop("Value", plural, " ", paste0("'", invalid[, 1, drop = TRUE], "'", collapse = ", "),
" found in ", tolower(refer_to_name),
", but with invalid microorganism code", plural, " ", paste0("'", invalid$mo, "'", collapse = ", "), ".",
", but with invalid microorganism code", plural, " ", paste0("'", invalid$mo, "'", collapse = ", "),
call. = FALSE)
} else {
return(FALSE)

View File

@ -61,9 +61,8 @@ pca <- function(x,
tol = NULL,
rank. = NULL) {
if (!is.data.frame(x)) {
stop("this function only takes a data.frame as input")
}
stop_ifnot(is.data.frame(x), "`x` must be a data.frame")
stop_if(any(dim(x) == 0), "`x` must contain rows and columns")
# unset data.table, tibble, etc.
# also removes groups made by dplyr::group_by

View File

@ -123,18 +123,12 @@ resistance_predict <- function(x,
info = interactive(),
...) {
if (nrow(x) == 0) {
stop("This table does not contain any observations.")
}
stop_ifnot(is.data.frame(x), "`x` must be a data.frame")
stop_if(any(dim(x) == 0), "`x` must contain rows and columns")
stop_if(is.null(model), 'choose a regression model with the `model` parameter, e.g. resistance_predict(..., model = "binomial")')
stop_ifnot(col_ab %in% colnames(x),
"column `", col_ab, "` not found")
if (is.null(model)) {
stop('Choose a regression model with the `model` parameter, e.g. resistance_predict(..., model = "binomial").')
}
if (!col_ab %in% colnames(x)) {
stop("Column ", col_ab, " not found.")
}
dots <- unlist(list(...))
if (length(dots) != 0) {
# backwards compatibility with old parameters
@ -150,16 +144,12 @@ resistance_predict <- function(x,
# -- date
if (is.null(col_date)) {
col_date <- search_type_in_df(x = x, type = "date")
stop_if(is.null(col_date), "`col_date` must be set")
}
if (is.null(col_date)) {
stop("`col_date` must be set.", call. = FALSE)
}
stop_ifnot(col_date %in% colnames(x),
"column `", col_date, "` not found")
if (!col_date %in% colnames(x)) {
stop("Column ", col_date, " not found.")
}
# no grouped tibbles, mutate will throw errors
# no grouped tibbles
x <- as.data.frame(x, stringsAsFactors = FALSE)
year <- function(x) {
@ -192,10 +182,8 @@ resistance_predict <- function(x,
df <- subset(df, sum(df$R + df$S, na.rm = TRUE) >= minimum)
df_matrix <- as.matrix(df[, c("R", "S"), drop = FALSE])
if (NROW(df) == 0) {
stop("There are no observations.")
}
stop_if(NROW(df) == 0, "there are no observations")
year_lowest <- min(df$year)
if (is.null(year_min)) {
year_min <- year_lowest
@ -248,7 +236,7 @@ resistance_predict <- function(x,
se <- predictmodel$se.fit
} else {
stop("No valid model selected. See ?resistance_predict.")
stop("no valid model selected. See ?resistance_predict.")
}
# prepare the output dataframe
@ -355,12 +343,9 @@ ggplot_rsi_predict <- function(x,
main = paste("Resistance Prediction of", x_name),
ribbon = TRUE,
...) {
stopifnot_installed_package("ggplot2")
if (!"resistance_predict" %in% class(x)) {
stop("`x` must be a resistance prediction model created with resistance_predict().")
}
stop_ifnot_installed("ggplot2")
stop_ifnot(inherits(x, "resistance_predict"), "`x` must be a resistance prediction model created with resistance_predict()")
x_name <- paste0(ab_name(attributes(x)$ab), " (", attributes(x)$ab, ")")

58
R/rsi.R
View File

@ -209,12 +209,11 @@ as.rsi.default <- function(x, ...) {
#' @rdname as.rsi
#' @export
as.rsi.mic <- function(x, mo, ab = deparse(substitute(x)), guideline = "EUCAST", uti = FALSE, ...) {
if (missing(mo)) {
stop('No information was supplied about the microorganisms (missing parameter "mo"). See ?as.rsi.\n\n',
"To transform certain columns with e.g. mutate_at(), use\n",
"`data %>% mutate_at(vars(...), as.rsi, mo = .$x)`, where x is your column with microorganisms.\n\n",
"To tranform all MIC variables in a data set, use `as.rsi(data)` or `data %>% as.rsi()`.", call. = FALSE)
}
stop_if(missing(mo),
'No information was supplied about the microorganisms (missing parameter "mo"). See ?as.rsi.\n\n',
"To transform certain columns with e.g. mutate_at(), use\n",
"`data %>% mutate_at(vars(...), as.rsi, mo = .$x)`, where x is your column with microorganisms.\n\n",
"To tranform all MIC variables in a data set, use `as.rsi(data)` or `data %>% as.rsi()`.", call = FALSE)
ab_coerced <- suppressWarnings(as.ab(ab))
mo_coerced <- suppressWarnings(as.mo(mo))
@ -246,12 +245,11 @@ as.rsi.mic <- function(x, mo, ab = deparse(substitute(x)), guideline = "EUCAST",
#' @rdname as.rsi
#' @export
as.rsi.disk <- function(x, mo, ab = deparse(substitute(x)), guideline = "EUCAST", uti = FALSE, ...) {
if (missing(mo)) {
stop('No information was supplied about the microorganisms (missing parameter "mo"). See ?as.rsi.\n\n',
"To transform certain columns with e.g. mutate_at(), use\n",
"`data %>% mutate_at(vars(...), as.rsi, mo = .$x)`, where x is your column with microorganisms.\n\n",
"To tranform all disk diffusion zones in a data set, use `as.rsi(data)` or `data %>% as.rsi()`.", call. = FALSE)
}
stop_if(missing(mo),
'No information was supplied about the microorganisms (missing parameter "mo"). See ?as.rsi.\n\n',
"To transform certain columns with e.g. mutate_at(), use\n",
"`data %>% mutate_at(vars(...), as.rsi, mo = .$x)`, where x is your column with microorganisms.\n\n",
"To tranform all disk diffusion zones in a data set, use `as.rsi(data)` or `data %>% as.rsi()`.", call = FALSE)
ab_coerced <- suppressWarnings(as.ab(ab))
mo_coerced <- suppressWarnings(as.mo(mo))
@ -287,10 +285,9 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", uti = NULL
# -- mo
if (is.null(col_mo)) {
col_mo <- search_type_in_df(x = x, type = "mo")
stop_if(is.null(col_mo), "`col_mo` must be set")
}
if (is.null(col_mo)) {
stop("`col_mo` must be set.", call. = FALSE)
}
# -- UTIs
col_uti <- uti
if (is.null(col_uti)) {
@ -353,9 +350,8 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", uti = NULL
}
})]
if (length(ab_cols) == 0) {
stop("No columns with MIC values or disk zones found in this data set. Use as.mic() or as.disk() to transform antimicrobial columns.", call. = FALSE)
}
stop_if(length(ab_cols) == 0,
"no columns with MIC values or disk zones found in this data set. Use as.mic() or as.disk() to transform antimicrobial columns.")
# set type per column
types <- character(length(ab_cols))
@ -393,11 +389,9 @@ get_guideline <- function(guideline) {
guideline_param <- gsub("([a-z]+)([0-9]+)", "\\1 \\2", guideline_param, ignore.case = TRUE)
}
if (!guideline_param %in% rsi_translation$guideline) {
stop(paste0("invalid guideline: '", guideline,
"'.\nValid guidelines are: ", paste0("'", unique(rsi_translation$guideline), "'", collapse = ", "), "."),
call. = FALSE)
}
stop_ifnot(guideline_param %in% rsi_translation$guideline,
"invalid guideline: '", guideline,
"'.\nValid guidelines are: ", paste0("'", unique(rsi_translation$guideline), "'", collapse = ", "), call = FALSE)
guideline_param
@ -503,9 +497,8 @@ is.rsi <- function(x) {
#' @rdname as.rsi
#' @export
is.rsi.eligible <- function(x, threshold = 0.05) {
if (NCOL(x) > 1) {
stop("`x` must be a one-dimensional vector.")
}
stop_if(NCOL(x) > 1, "`x` must be a one-dimensional vector.")
if (any(c("logical",
"numeric",
"integer",
@ -551,13 +544,16 @@ droplevels.rsi <- function(x, exclude = if (anyNA(levels(x))) NULL else NA, ...)
#' @noRd
summary.rsi <- function(object, ...) {
x <- object
n <- sum(!is.na(x))
S <- sum(x == "S", na.rm = TRUE)
I <- sum(x == "I", na.rm = TRUE)
R <- sum(x == "R", na.rm = TRUE)
c(
"Class" = "rsi",
"<NA>" = sum(is.na(x)),
"Sum S" = sum(x == "S", na.rm = TRUE),
"Sum IR" = sum(x %in% c("I", "R"), na.rm = TRUE),
"-Sum R" = sum(x == "R", na.rm = TRUE),
"-Sum I" = sum(x == "I", na.rm = TRUE)
"%R" = paste0(percentage(R / n), " (n=", R, ")"),
"%SI" = paste0(percentage((S + I) / n), " (n=", S + I, ")"),
"- %S" = paste0(percentage(S / n), " (n=", S, ")"),
"- %I" = paste0(percentage(I / n), " (n=", I, ")")
)
}

View File

@ -33,23 +33,19 @@ rsi_calc <- function(...,
only_all_tested = FALSE,
only_count = FALSE) {
stop_ifnot(is.numeric(minimum), "`minimum` must be numeric", call = -2)
stop_ifnot(is.logical(as_percent), "`as_percent` must be logical", call = -2)
stop_ifnot(is.logical(only_all_tested), "`only_all_tested` must be logical", call = -2)
data_vars <- dots2vars(...)
if (!is.numeric(minimum)) {
stop("`minimum` must be numeric", call. = FALSE)
}
if (!is.logical(as_percent)) {
stop("`as_percent` must be logical", call. = FALSE)
}
if (!is.logical(only_all_tested)) {
stop("`only_all_tested` must be logical", call. = FALSE)
}
dots_df <- switch(1, ...)
dots <- base::eval(base::substitute(base::alist(...)))
if ("also_single_tested" %in% names(dots)) {
stop("`also_single_tested` was replaced by `only_all_tested`. Please read Details in the help page (`?proportion`) as this may have a considerable impact on your analysis.", call. = FALSE)
}
stop_if(length(dots) == 0, "no variables selected", call = -2)
stop_if("also_single_tested" %in% names(dots),
"`also_single_tested` was replaced by `only_all_tested`.\n",
"Please read Details in the help page (`?proportion`) as this may have a considerable impact on your analysis.", call = -2)
ndots <- length(dots)
if ("data.frame" %in% class(dots_df)) {
@ -164,22 +160,15 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
combine_SI_missing = FALSE) {
check_dataset_integrity()
if (!"data.frame" %in% class(data)) {
stop(paste0("`", type, "_df` must be called on a data.frame"), call. = FALSE)
}
stop_ifnot(is.data.frame(data), "`data` must be a data.frame", call = -2)
stop_if(any(dim(data) == 0), "`data` must contain rows and columns", call = -2)
stop_ifnot(any(sapply(data, is.rsi), na.rm = TRUE), "no columns with class <rsi> found. See ?as.rsi.", call = -2)
stop_if(isTRUE(combine_SI) & isTRUE(combine_IR), "either `combine_SI` or `combine_IR` can be TRUE, not both", call = -2)
if (isTRUE(combine_IR) & isTRUE(combine_SI_missing)) {
combine_SI <- FALSE
}
if (isTRUE(combine_SI) & isTRUE(combine_IR)) {
stop("either `combine_SI` or `combine_IR` can be TRUE, not both", call. = FALSE)
}
if (!any(sapply(data, is.rsi), na.rm = TRUE)) {
stop("No columns with class <rsi> found. See ?as.rsi.", call. = FALSE)
}
if (as.character(translate_ab) %in% c("TRUE", "official")) {
translate_ab <- "name"
}

View File

@ -108,11 +108,10 @@ translate_AMR <- function(from, language = get_locale(), only_unknown = FALSE) {
df_trans <- translations_file # internal data file
if (!language %in% df_trans$lang) {
stop("Unsupported language: '", language, "' - use one of: ",
paste0("'", sort(unique(df_trans$lang)), "'", collapse = ", "),
call. = FALSE)
}
stop_ifnot(language %in% df_trans$lang,
"unsupported language: '", language, "' - use one of: ",
paste0("'", sort(unique(df_trans$lang)), "'", collapse = ", "),
call = FALSE)
df_trans <- df_trans %>% subset(lang == language)
if (only_unknown == TRUE) {

10
R/zzz.R
View File

@ -23,11 +23,11 @@
assign(x = "MO_lookup",
value = create_MO_lookup(),
envir = asNamespace("AMR"))
assign(x = "MO.old_lookup",
value = create_MO.old_lookup(),
envir = asNamespace("AMR"))
assign(x = "mo_codes_v0.5.0",
value = make_trans_tbl(),
envir = asNamespace("AMR"))
@ -47,10 +47,10 @@ create_MO_lookup <- function() {
# use this paste instead of `fullname` to
# work with Viridans Group Streptococci, etc.
MO_lookup$fullname_lower <- tolower(trimws(paste(MO_lookup$genus,
MO_lookup$species,
MO_lookup$subspecies)))
MO_lookup$species,
MO_lookup$subspecies)))
MO_lookup[MO_lookup$genus == "" | grepl("^[(]unknown ", MO_lookup$fullname), "fullname_lower"] <- tolower(trimws(MO_lookup[MO_lookup$genus == "" | grepl("^[(]unknown ", MO_lookup$fullname),
"fullname"]))
"fullname"]))
MO_lookup$fullname_lower <- gsub("[^.a-z0-9/ \\-]+", "", MO_lookup$fullname_lower)
# add a column with only "e coli" like combinations