mirror of
https://github.com/msberends/AMR.git
synced 2025-07-11 03:42:01 +02:00
(v1.2.0.9011) mo_domain(), improved error handling
This commit is contained in:
@ -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)
|
||||
|
||||
@ -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
16
R/age.R
@ -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
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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)
|
||||
})
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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 != ",", ",", ".")
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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)
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
@ -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,
|
||||
|
||||
@ -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"
|
||||
}
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
27
R/mdro.R
27
R/mdro.R
@ -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
12
R/mo.R
@ -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
|
||||
|
||||
@ -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)
|
||||
}
|
||||
|
||||
@ -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)
|
||||
|
||||
5
R/pca.R
5
R/pca.R
@ -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
|
||||
|
||||
@ -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
58
R/rsi.R
@ -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, ")")
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
41
R/rsi_calc.R
41
R/rsi_calc.R
@ -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"
|
||||
}
|
||||
|
||||
@ -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
10
R/zzz.R
@ -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
|
||||
|
||||
Reference in New Issue
Block a user