mirror of
https://github.com/msberends/AMR.git
synced 2025-07-10 07:41:57 +02:00
(v2.1.1.9095) Python support
This commit is contained in:
@ -822,7 +822,6 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
|
||||
is_positive = NULL,
|
||||
is_positive_or_zero = NULL,
|
||||
is_finite = NULL,
|
||||
contains_column_class = NULL,
|
||||
allow_NULL = FALSE,
|
||||
allow_NA = FALSE,
|
||||
ignore.case = FALSE,
|
||||
@ -851,6 +850,11 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
|
||||
stop_if(allow_NA == FALSE, "argument `", obj_name, "` must not be NA", call = call_depth)
|
||||
return(invisible())
|
||||
}
|
||||
|
||||
if (identical(class(object), "list") && !"list" %in% allow_class) {
|
||||
# coming from Python, possibly - turn lists (not data.frame) to the underlying data type
|
||||
object <- unlist(object)
|
||||
}
|
||||
|
||||
if (!is.null(allow_class) && !(suppressWarnings(all(is.na(object))) && allow_NA == TRUE)) {
|
||||
stop_ifnot(inherits(object, allow_class), "argument `", obj_name,
|
||||
@ -937,21 +941,6 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
|
||||
call = call_depth
|
||||
)
|
||||
}
|
||||
if (!is.null(contains_column_class)) {
|
||||
stop_ifnot(
|
||||
any(vapply(
|
||||
FUN.VALUE = logical(1),
|
||||
object,
|
||||
function(col, columns_class = contains_column_class) {
|
||||
inherits(col, columns_class)
|
||||
}
|
||||
), na.rm = TRUE),
|
||||
"the data provided in argument `", obj_name,
|
||||
"` must contain at least one column of class '", contains_column_class[1L], "'. ",
|
||||
"See `?as.", contains_column_class[1L], "`.",
|
||||
call = call_depth
|
||||
)
|
||||
}
|
||||
if (!is.null(allow_arguments_from) && !is.null(names(object))) {
|
||||
args_given <- names(object)
|
||||
if (is.function(allow_arguments_from)) {
|
||||
@ -973,6 +962,20 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
|
||||
return(invisible())
|
||||
}
|
||||
|
||||
ascertain_sir_classes <- function(x, obj_name) {
|
||||
sirs <- vapply(FUN.VALUE = logical(1), x, is.sir)
|
||||
if (!any(sirs, na.rm = TRUE)) {
|
||||
warning_("the data provided in argument `", obj_name,
|
||||
"` should contain at least one column of class 'sir'. Eligible SIR column were now guessed. ",
|
||||
"See `?as.sir`.")
|
||||
sirs_eligible <- is_sir_eligible(x)
|
||||
for (col in colnames(x)[sirs_eligible]) {
|
||||
x[[col]] <- as.sir(x[[col]])
|
||||
}
|
||||
}
|
||||
x
|
||||
}
|
||||
|
||||
get_current_data <- function(arg_name, call) {
|
||||
valid_df <- function(x) {
|
||||
!is.null(x) && is.data.frame(x)
|
||||
|
@ -313,7 +313,8 @@ antibiogram <- function(x,
|
||||
combine_SI = TRUE,
|
||||
sep = " + ",
|
||||
info = interactive()) {
|
||||
meet_criteria(x, allow_class = "data.frame", contains_column_class = c("sir", "rsi"))
|
||||
meet_criteria(x, allow_class = "data.frame")
|
||||
x <- ascertain_sir_classes(x, "x")
|
||||
meet_criteria(mo_transform, allow_class = "character", has_length = 1, is_in = c("name", "shortname", "gramstain", colnames(AMR::microorganisms)), allow_NULL = TRUE)
|
||||
meet_criteria(ab_transform, allow_class = "character", has_length = 1, is_in = colnames(AMR::antibiotics), allow_NULL = TRUE)
|
||||
meet_criteria(syndromic_group, allow_class = "character", allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
@ -71,7 +71,8 @@ bug_drug_combinations <- function(x,
|
||||
col_mo = NULL,
|
||||
FUN = mo_shortname,
|
||||
...) {
|
||||
meet_criteria(x, allow_class = "data.frame", contains_column_class = c("sir", "rsi"))
|
||||
meet_criteria(x, allow_class = "data.frame")
|
||||
x <- ascertain_sir_classes(x, "x")
|
||||
meet_criteria(col_mo, allow_class = "character", is_in = colnames(x), has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(FUN, allow_class = "function", has_length = 1)
|
||||
|
||||
|
8
R/disk.R
8
R/disk.R
@ -29,13 +29,13 @@
|
||||
|
||||
#' Transform Input to Disk Diffusion Diameters
|
||||
#'
|
||||
#' This transforms a vector to a new class [`disk`], which is a disk diffusion growth zone size (around an antibiotic disk) in millimetres between 6 and 50.
|
||||
#' This transforms a vector to a new class [`disk`], which is a disk diffusion growth zone size (around an antibiotic disk) in millimetres between 0 and 50.
|
||||
#' @rdname as.disk
|
||||
#' @param x vector
|
||||
#' @param na.rm a [logical] indicating whether missing values should be removed
|
||||
#' @details Interpret disk values as SIR values with [as.sir()]. It supports guidelines from EUCAST and CLSI.
|
||||
#'
|
||||
#' Disk diffusion growth zone sizes must be between 6 and 50 millimetres. Values higher than 50 but lower than 100 will be maximised to 50. All others input values outside the 6-50 range will return `NA`.
|
||||
#' Disk diffusion growth zone sizes must be between 0 and 50 millimetres. Values higher than 50 but lower than 100 will be maximised to 50. All others input values outside the 0-50 range will return `NA`.
|
||||
#' @return An [integer] with additional class [`disk`]
|
||||
#' @aliases disk
|
||||
#' @export
|
||||
@ -108,8 +108,8 @@ as.disk <- function(x, na.rm = FALSE) {
|
||||
# round up and make it an integer
|
||||
x <- as.integer(ceiling(clean_double2(x)))
|
||||
|
||||
# disks can never be less than 6 mm (size of smallest disk) or more than 50 mm
|
||||
x[x < 6 | x > 99] <- NA_integer_
|
||||
# disks can never be less than 0 mm or more than 50 mm
|
||||
x[x < 0 | x > 99] <- NA_integer_
|
||||
x[x > 50] <- 50L
|
||||
na_after <- length(x[is.na(x)])
|
||||
|
||||
|
@ -193,7 +193,8 @@ ggplot_sir <- function(data,
|
||||
y.title = "Proportion",
|
||||
...) {
|
||||
stop_ifnot_installed("ggplot2")
|
||||
meet_criteria(data, allow_class = "data.frame", contains_column_class = c("sir", "rsi"))
|
||||
meet_criteria(data, allow_class = "data.frame")
|
||||
data <- ascertain_sir_classes(data, "data")
|
||||
meet_criteria(position, allow_class = "character", has_length = 1, is_in = c("fill", "stack", "dodge"), allow_NULL = TRUE)
|
||||
meet_criteria(x, allow_class = "character", has_length = 1)
|
||||
meet_criteria(fill, allow_class = "character", has_length = 1)
|
||||
|
@ -292,14 +292,14 @@ sir_confidence_interval <- function(...,
|
||||
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
|
||||
)
|
||||
|
||||
# this applies the Clopper-Pearson method
|
||||
if (x == 0) {
|
||||
out <- c(NA_real_, NA_real_)
|
||||
out <- c(0, 0)
|
||||
} else {
|
||||
# this applies the Clopper-Pearson method
|
||||
out <- stats::binom.test(x = x, n = n, conf.level = confidence_level)$conf.int
|
||||
}
|
||||
out <- set_clean_class(out, "numeric")
|
||||
|
||||
|
||||
if (side %in% c("left", "l", "lower", "lowest", "less", "min")) {
|
||||
out <- out[1]
|
||||
} else if (side %in% c("right", "r", "higher", "highest", "greater", "g", "max")) {
|
||||
@ -312,7 +312,7 @@ sir_confidence_interval <- function(...,
|
||||
if (is.numeric(out)) {
|
||||
out <- round(out, digits = 3)
|
||||
}
|
||||
out[is.na(out)] <- "??"
|
||||
# out[is.na(out)] <- 0
|
||||
out <- paste(out, collapse = ifelse(isTRUE(collapse), "-", collapse))
|
||||
}
|
||||
|
||||
|
6
R/sir.R
6
R/sir.R
@ -1263,7 +1263,7 @@ as_sir_method <- function(method_short,
|
||||
if (breakpoint_type == "animal" && !host_current %in% breakpoints_current$host) {
|
||||
if (guideline_coerced %like% "CLSI") {
|
||||
# VET09 says that staph/strep/enterococcus BP can be extrapolated to all Gr+ cocci except for intrinsic resistance, so take all Gr+ cocci:
|
||||
all_gram_pos_genera <- c("B_STPHY", "B_STRPT", "B_ENTRC", "B_PPTST", "B_AERCC", "B_MCRCCC", "B_TRPRL")
|
||||
all_gram_pos_genera <- c("B_STPHY", "B_STRPT", "B_PPTST", "B_AERCC", "B_MCRCCC", "B_TRPRL")
|
||||
|
||||
# HUMAN SUBSTITUTES
|
||||
if (ab_current == "AZM" && mo_current_genus %in% all_gram_pos_genera && host_current %in% c("dogs", "cats", "horse")) {
|
||||
@ -1310,9 +1310,9 @@ as_sir_method <- function(method_short,
|
||||
# vancomycin can take human breakpoints in these hosts
|
||||
breakpoints_current <- breakpoints_current %pm>% subset(host == "human")
|
||||
notes_current <- c(notes_current, paste0("Using ", font_bold("human"), " breakpoints for ", ab_formatted, " based on CLSI VET09."))
|
||||
|
||||
|
||||
} else if (host_current %in% c("dogs", "cats") && (mo_current_genus %in% c("B_AMYCS", "B_NOCRD", "B_CMPYL", "B_CRYNB", "B_ENTRC", "B_MYCBC", "B_PSDMN", "B_AERMN") | mo_current_class == "B_[CLS]_BTPRTBCT" | mo_current == "B_LISTR_MNCY")) {
|
||||
# human breakpoints if no canine/feline
|
||||
# dog breakpoints if no canine/feline
|
||||
breakpoints_current <- breakpoints_current %pm>% subset(host == "human")
|
||||
notes_current <- c(notes_current, paste0("Using ", font_bold("human"), " breakpoints for ", mo_formatted, " based on CLSI VET09."))
|
||||
|
||||
|
@ -223,7 +223,8 @@ sir_calc_df <- function(type, # "proportion", "count" or "both"
|
||||
combine_SI = TRUE,
|
||||
confidence_level = 0.95) {
|
||||
meet_criteria(type, is_in = c("proportion", "count", "both"), has_length = 1)
|
||||
meet_criteria(data, allow_class = "data.frame", contains_column_class = "sir")
|
||||
meet_criteria(data, allow_class = "data.frame")
|
||||
data <- ascertain_sir_classes(data, "data")
|
||||
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE)
|
||||
language <- validate_language(language)
|
||||
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_positive_or_zero = TRUE, is_finite = TRUE)
|
||||
|
Reference in New Issue
Block a user