mirror of
https://github.com/msberends/AMR.git
synced 2025-07-13 00:32:34 +02:00
(v2.1.1.9049) new 2024 breakpoints, add AMO, set NI instead of N
This commit is contained in:
@ -743,9 +743,9 @@ vector_or <- function(v, quotes = TRUE, reverse = FALSE, sort = TRUE, initial_ca
|
||||
# class 'sir' should be sorted like this
|
||||
v <- c("S", "I", "R")
|
||||
}
|
||||
if (identical(v, c("I", "N", "R", "S", "SDD"))) {
|
||||
if (identical(v, c("I", "NI", "R", "S", "SDD"))) {
|
||||
# class 'sir' should be sorted like this
|
||||
v <- c("S", "SDD", "I", "R", "N")
|
||||
v <- c("S", "SDD", "I", "R", "NI")
|
||||
}
|
||||
# oxford comma
|
||||
if (last_sep %in% c(" or ", " and ") && length(v) > 2) {
|
||||
@ -1342,6 +1342,10 @@ progress_ticker <- function(n = 1, n_min = 0, print = TRUE, clear = TRUE, title
|
||||
if (!is.null(progress_bar)) {
|
||||
# so we use progress::progress_bar
|
||||
# a close()-method was also added, see below for that
|
||||
title <- trimws2(title)
|
||||
if (title != "") {
|
||||
title <- paste0(title, " ")
|
||||
}
|
||||
pb <- progress_bar$new(
|
||||
format = paste0(title,
|
||||
ifelse(only_bar_percent == TRUE, "[:bar] :percent", "[:bar] :percent (:current/:total,:eta)")),
|
||||
@ -1538,14 +1542,14 @@ add_MO_lookup_to_AMR_env <- function() {
|
||||
MO_lookup[which(is.na(MO_lookup$kingdom_index)), "kingdom_index"] <- 3
|
||||
|
||||
# the fullname lowercase, important for the internal algorithms in as.mo()
|
||||
MO_lookup$fullname_lower <- tolower(trimws(paste(
|
||||
MO_lookup$fullname_lower <- tolower(trimws2(paste(
|
||||
MO_lookup$genus,
|
||||
MO_lookup$species,
|
||||
MO_lookup$subspecies
|
||||
)))
|
||||
ind <- MO_lookup$genus == "" | grepl("^[(]unknown ", MO_lookup$fullname, perl = TRUE)
|
||||
MO_lookup[ind, "fullname_lower"] <- tolower(MO_lookup[ind, "fullname", drop = TRUE])
|
||||
MO_lookup$fullname_lower <- trimws(gsub("[^.a-z0-9/ \\-]+", "", MO_lookup$fullname_lower, perl = TRUE))
|
||||
MO_lookup$fullname_lower <- trimws2(gsub("[^.a-z0-9/ \\-]+", "", MO_lookup$fullname_lower, perl = TRUE))
|
||||
# special for Salmonella - they have cities as subspecies but not the species (enterica) in the fullname:
|
||||
MO_lookup$fullname_lower[which(MO_lookup$subspecies %like_case% "^[A-Z]")] <- gsub(" enterica ", " ", MO_lookup$fullname_lower[which(MO_lookup$subspecies %like_case% "^[A-Z]")], fixed = TRUE)
|
||||
|
||||
|
||||
1
R/ab.R
1
R/ab.R
@ -525,6 +525,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
x_unknown,
|
||||
AMR_env$ab_previously_coerced$x_bak[which(AMR_env$ab_previously_coerced$x %in% x & is.na(AMR_env$ab_previously_coerced$ab))]
|
||||
)
|
||||
x_unknown <- x_unknown[!x_unknown %in% c("", NA)]
|
||||
if (length(x_unknown) > 0 && fast_mode == FALSE) {
|
||||
warning_(
|
||||
"in `as.ab()`: these values could not be coerced to a valid antimicrobial ID: ",
|
||||
|
||||
@ -690,10 +690,10 @@ c.ab_selector <- function(...) {
|
||||
|
||||
all_any_ab_selector <- function(type, ..., na.rm = TRUE) {
|
||||
cols_ab <- c(...)
|
||||
result <- cols_ab[toupper(cols_ab) %in% c("S", "SDD", "I", "R", "N")]
|
||||
result <- cols_ab[toupper(cols_ab) %in% c("S", "SDD", "I", "R", "NI")]
|
||||
if (length(result) == 0) {
|
||||
message_("Filtering ", type, " of columns ", vector_and(font_bold(cols_ab, collapse = NULL), quotes = "'"), ' to contain value "S", "I" or "R"')
|
||||
result <- c("S", "SDD", "I", "R", "N")
|
||||
result <- c("S", "SDD", "I", "R", "NI")
|
||||
}
|
||||
cols_ab <- cols_ab[!cols_ab %in% result]
|
||||
df <- get_current_data(arg_name = NA, call = -3)
|
||||
@ -802,7 +802,7 @@ any.ab_selector_any_all <- function(..., na.rm = FALSE) {
|
||||
}
|
||||
}
|
||||
# this is `!=`, so turn around the values
|
||||
sir <- c("S", "SDD", "I", "R", "N")
|
||||
sir <- c("S", "SDD", "I", "R", "NI")
|
||||
e2 <- sir[sir != e2]
|
||||
structure(all_any_ab_selector(type = type, e1, e2),
|
||||
class = c("ab_selector_any_all", "logical")
|
||||
|
||||
@ -352,7 +352,7 @@ antibiogram <- function(x,
|
||||
} else {
|
||||
S_values <- "S"
|
||||
}
|
||||
other_values <- setdiff(c("S", "SDD", "I", "R", "N"), S_values)
|
||||
other_values <- setdiff(c("S", "SDD", "I", "R", "NI"), S_values)
|
||||
x_transposed <- as.list(as.data.frame(t(x[, abx, drop = FALSE]), stringsAsFactors = FALSE))
|
||||
if (isTRUE(only_all_tested)) {
|
||||
x[new_colname] <- as.sir(vapply(FUN.VALUE = character(1), x_transposed, function(x) ifelse(anyNA(x), NA_character_, ifelse(any(x %in% S_values), "S", "R")), USE.NAMES = FALSE))
|
||||
|
||||
@ -124,7 +124,7 @@ bug_drug_combinations <- function(x,
|
||||
# turn and merge everything
|
||||
pivot <- lapply(x_mo_filter, function(x) {
|
||||
m <- as.matrix(table(as.sir(x)))
|
||||
data.frame(S = m["S", ], SDD = m["SDD", ], I = m["I", ], R = m["R", ], N = m["N", ], stringsAsFactors = FALSE)
|
||||
data.frame(S = m["S", ], SDD = m["SDD", ], I = m["I", ], R = m["R", ], NI = m["NI", ], stringsAsFactors = FALSE)
|
||||
})
|
||||
merged <- do.call(rbind_AMR, pivot)
|
||||
out_group <- data.frame(
|
||||
@ -134,8 +134,8 @@ bug_drug_combinations <- function(x,
|
||||
SDD = merged$SDD,
|
||||
I = merged$I,
|
||||
R = merged$R,
|
||||
N = merged$N,
|
||||
total = merged$S + merged$SDD + merged$I + merged$R + merged$N,
|
||||
NI = merged$NI,
|
||||
total = merged$S + merged$SDD + merged$I + merged$R + merged$NI,
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
if (data_has_groups) {
|
||||
@ -210,13 +210,13 @@ format.bug_drug_combinations <- function(x,
|
||||
SDD = vapply(FUN.VALUE = double(1), idx, function(i) sum(x$SDD[i], na.rm = TRUE)),
|
||||
I = vapply(FUN.VALUE = double(1), idx, function(i) sum(x$I[i], na.rm = TRUE)),
|
||||
R = vapply(FUN.VALUE = double(1), idx, function(i) sum(x$R[i], na.rm = TRUE)),
|
||||
N = vapply(FUN.VALUE = double(1), idx, function(i) sum(x$R[i], na.rm = TRUE)),
|
||||
NI = vapply(FUN.VALUE = double(1), idx, function(i) sum(x$NI[i], na.rm = TRUE)),
|
||||
total = vapply(FUN.VALUE = double(1), idx, function(i) {
|
||||
sum(x$S[i], na.rm = TRUE) +
|
||||
sum(x$SDD[i], na.rm = TRUE) +
|
||||
sum(x$I[i], na.rm = TRUE) +
|
||||
sum(x$R[i], na.rm = TRUE) +
|
||||
sum(x$N[i], na.rm = TRUE)
|
||||
sum(x$NI[i], na.rm = TRUE)
|
||||
}),
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
|
||||
@ -225,7 +225,7 @@ count_R <- function(..., only_all_tested = FALSE) {
|
||||
count_all <- function(..., only_all_tested = FALSE) {
|
||||
tryCatch(
|
||||
sir_calc(...,
|
||||
ab_result = c("S", "SDD", "I", "R", "N"),
|
||||
ab_result = c("S", "SDD", "I", "R", "NI"),
|
||||
only_all_tested = only_all_tested,
|
||||
only_count = TRUE
|
||||
),
|
||||
|
||||
@ -204,8 +204,8 @@ custom_eucast_rules <- function(...) {
|
||||
result_value <- as.character(result)[[3]]
|
||||
result_value[result_value == "NA"] <- NA
|
||||
stop_ifnot(
|
||||
result_value %in% c("S", "SDD", "I", "R", "N", NA),
|
||||
"the resulting value of rule ", i, " must be either \"S\", \"SDD\", \"I\", \"R\", \"N\" or NA"
|
||||
result_value %in% c("S", "SDD", "I", "R", "NI", NA),
|
||||
"the resulting value of rule ", i, " must be either \"S\", \"SDD\", \"I\", \"R\", \"NI\" or NA"
|
||||
)
|
||||
result_value <- as.sir(result_value)
|
||||
|
||||
|
||||
@ -236,7 +236,7 @@ first_isolate <- function(x = NULL,
|
||||
FUN.VALUE = logical(1),
|
||||
X = x,
|
||||
# check only first 10,000 rows
|
||||
FUN = function(x) any(as.character(x[1:10000]) %in% c("S", "SDD", "I", "R", "N"), na.rm = TRUE),
|
||||
FUN = function(x) any(as.character(x[1:10000]) %in% c("S", "SDD", "I", "R", "NI"), na.rm = TRUE),
|
||||
USE.NAMES = FALSE
|
||||
))
|
||||
if (method == "phenotype-based" && !any_col_contains_sir) {
|
||||
|
||||
@ -283,7 +283,7 @@ generate_antimcrobials_string <- function(df) {
|
||||
function(x) {
|
||||
x <- toupper(as.character(x))
|
||||
x[x == "SDD"] <- "I"
|
||||
# ignore "N" here, no use for determining first isolates
|
||||
# ignore "NI" here, no use for determining first isolates
|
||||
x[!x %in% c("S", "I", "R")] <- "."
|
||||
paste(x)
|
||||
}
|
||||
|
||||
4
R/mo.R
4
R/mo.R
@ -285,7 +285,9 @@ as.mo <- function(x,
|
||||
# do a pre-match on first character (and if it contains a space, first chars of first two terms)
|
||||
if (length(x_parts) %in% c(2, 3)) {
|
||||
# for genus + species + subspecies
|
||||
if (nchar(gsub("[^a-z]", "", x_parts[1], perl = TRUE)) <= 3) {
|
||||
if (paste(x_parts[1:2], collapse = " ") %in% AMR_env$MO_lookup$fullname_lower) {
|
||||
filtr <- which(AMR_env$MO_lookup$fullname_lower %like% paste(x_parts[1:2], collapse = " "))
|
||||
} else if (nchar(gsub("[^a-z]", "", x_parts[1], perl = TRUE)) <= 3) {
|
||||
filtr <- which(AMR_env$MO_lookup$full_first == substr(x_parts[1], 1, 1) &
|
||||
(AMR_env$MO_lookup$species_first == substr(x_parts[2], 1, 1) |
|
||||
AMR_env$MO_lookup$subspecies_first == substr(x_parts[2], 1, 1) |
|
||||
|
||||
18
R/plot.R
18
R/plot.R
@ -659,12 +659,12 @@ plot.sir <- function(x,
|
||||
if (!"R" %in% data$x) {
|
||||
data <- rbind_AMR(data, data.frame(x = "R", n = 0, s = 0, stringsAsFactors = FALSE))
|
||||
}
|
||||
if (!"N" %in% data$x) {
|
||||
data <- rbind_AMR(data, data.frame(x = "N", n = 0, s = 0, stringsAsFactors = FALSE))
|
||||
if (!"NI" %in% data$x) {
|
||||
data <- rbind_AMR(data, data.frame(x = "NI", n = 0, s = 0, stringsAsFactors = FALSE))
|
||||
}
|
||||
|
||||
data <- data[!(data$n == 0 & data$x %in% c("SDD", "I", "N")), , drop = FALSE]
|
||||
data$x <- factor(data$x, levels = intersect(unique(data$x), c("S", "SDD", "I", "R", "N")), ordered = TRUE)
|
||||
data <- data[!(data$n == 0 & data$x %in% c("SDD", "I", "NI")), , drop = FALSE]
|
||||
data$x <- factor(data$x, levels = intersect(unique(data$x), c("S", "SDD", "I", "R", "NI")), ordered = TRUE)
|
||||
|
||||
ymax <- pm_if_else(max(data$s) > 95, 105, 100)
|
||||
|
||||
@ -719,8 +719,8 @@ barplot.sir <- function(height,
|
||||
|
||||
x <- table(height)
|
||||
# remove missing I, SDD, and N
|
||||
colours_SIR <- colours_SIR[!(names(x) %in% c("SDD", "I", "N") & x == 0)]
|
||||
x <- x[!(names(x) %in% c("SDD", "I", "N") & x == 0)]
|
||||
colours_SIR <- colours_SIR[!(names(x) %in% c("SDD", "I", "NI") & x == 0)]
|
||||
x <- x[!(names(x) %in% c("SDD", "I", "NI") & x == 0)]
|
||||
# plot it
|
||||
barplot(x,
|
||||
col = colours_SIR,
|
||||
@ -761,7 +761,7 @@ autoplot.sir <- function(object,
|
||||
|
||||
df <- as.data.frame(table(object), stringsAsFactors = TRUE)
|
||||
colnames(df) <- c("x", "n")
|
||||
df <- df[!(df$n == 0 & df$x %in% c("SDD", "I", "N")), , drop = FALSE]
|
||||
df <- df[!(df$n == 0 & df$x %in% c("SDD", "I", "NI")), , drop = FALSE]
|
||||
ggplot2::ggplot(df) +
|
||||
ggplot2::geom_col(ggplot2::aes(x = x, y = n, fill = x)) +
|
||||
# limits = force is needed because of a ggplot2 >= 3.3.4 bug (#4511)
|
||||
@ -771,7 +771,7 @@ autoplot.sir <- function(object,
|
||||
"SDD" = colours_SIR[2],
|
||||
"I" = colours_SIR[2],
|
||||
"R" = colours_SIR[3],
|
||||
"N" = "#888888"
|
||||
"NI" = "#888888"
|
||||
),
|
||||
limits = force
|
||||
) +
|
||||
@ -891,7 +891,7 @@ plot_colours_subtitle_guideline <- function(x, mo, ab, guideline, colours_SIR, f
|
||||
cols[sir == "SDD"] <- colours_SIR[2]
|
||||
cols[sir == "I"] <- colours_SIR[2]
|
||||
cols[sir == "R"] <- colours_SIR[3]
|
||||
cols[sir == "N"] <- "#888888"
|
||||
cols[sir == "NI"] <- "#888888"
|
||||
sub <- bquote(.(abname) ~ "-" ~ italic(.(moname)) ~ .(guideline_txt))
|
||||
} else {
|
||||
cols <- "#BEBEBE"
|
||||
|
||||
@ -267,7 +267,7 @@ sir_confidence_interval <- function(...,
|
||||
confidence_level = 0.95,
|
||||
side = "both",
|
||||
collapse = FALSE) {
|
||||
meet_criteria(ab_result, allow_class = c("character", "sir"), has_length = c(1:5), is_in = c("S", "SDD", "I", "R", "N"))
|
||||
meet_criteria(ab_result, allow_class = c("character", "sir"), has_length = c(1:5), is_in = c("S", "SDD", "I", "R", "NI"))
|
||||
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_positive_or_zero = TRUE, is_finite = TRUE)
|
||||
meet_criteria(as_percent, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(only_all_tested, allow_class = "logical", has_length = 1)
|
||||
@ -285,7 +285,7 @@ sir_confidence_interval <- function(...,
|
||||
)
|
||||
n <- tryCatch(
|
||||
sir_calc(...,
|
||||
ab_result = c("S", "SDD", "I", "R", "N"),
|
||||
ab_result = c("S", "SDD", "I", "R", "NI"),
|
||||
only_all_tested = only_all_tested,
|
||||
only_count = TRUE
|
||||
),
|
||||
|
||||
42
R/sir.R
42
R/sir.R
@ -29,7 +29,7 @@
|
||||
|
||||
#' Translate MIC and Disk Diffusion to SIR, or Clean Existing SIR Data
|
||||
#'
|
||||
#' @description Clean up existing SIR values, or interpret minimum inhibitory concentration (MIC) values and disk diffusion diameters according to EUCAST or CLSI. [as.sir()] transforms the input to a new class [`sir`], which is an ordered [factor] containing the levels `S`, `SDD`, `I`, `R`, `N`.
|
||||
#' @description Clean up existing SIR values, or interpret minimum inhibitory concentration (MIC) values and disk diffusion diameters according to EUCAST or CLSI. [as.sir()] transforms the input to a new class [`sir`], which is an ordered [factor] containing the levels `S`, `SDD`, `I`, `R`, `NI`.
|
||||
#'
|
||||
#' These breakpoints are currently implemented:
|
||||
#' - For **clinical microbiology**: EUCAST `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "human")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "EUCAST" & type == "human")$guideline)))` and CLSI `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "human")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, guideline %like% "CLSI" & type == "human")$guideline)))`;
|
||||
@ -60,7 +60,7 @@
|
||||
#'
|
||||
#' The [as.sir()] function can work in four ways:
|
||||
#'
|
||||
#' 1. For **cleaning raw / untransformed data**. The data will be cleaned to only contain valid values, namely: **S** for susceptible, **I** for intermediate or 'susceptible, increased exposure', **R** for resistant, **N** for non-interpretable, and **SDD** for susceptible dose-dependent. Each of these can be set using a [regular expression][base::regex]. Furthermore, [as.sir()] will try its best to clean with some intelligence. For example, mixed values with SIR interpretations and MIC values such as `"<0.25; S"` will be coerced to `"S"`. Combined interpretations for multiple test methods (as seen in laboratory records) such as `"S; S"` will be coerced to `"S"`, but a value like `"S; I"` will return `NA` with a warning that the input is invalid.
|
||||
#' 1. For **cleaning raw / untransformed data**. The data will be cleaned to only contain valid values, namely: **S** for susceptible, **I** for intermediate or 'susceptible, increased exposure', **R** for resistant, **NI** for non-interpretable, and **SDD** for susceptible dose-dependent. Each of these can be set using a [regular expression][base::regex]. Furthermore, [as.sir()] will try its best to clean with some intelligence. For example, mixed values with SIR interpretations and MIC values such as `"<0.25; S"` will be coerced to `"S"`. Combined interpretations for multiple test methods (as seen in laboratory records) such as `"S; S"` will be coerced to `"S"`, but a value like `"S; I"` will return `NA` with a warning that the input is invalid.
|
||||
#'
|
||||
#' 2. For **interpreting minimum inhibitory concentration (MIC) values** according to EUCAST or CLSI. You must clean your MIC values first using [as.mic()], that also gives your columns the new data class [`mic`]. Also, be sure to have a column with microorganism names or codes. It will be found automatically, but can be set manually using the `mo` argument.
|
||||
#' * Using `dplyr`, SIR interpretation can be done very easily with either:
|
||||
@ -126,7 +126,7 @@
|
||||
#'
|
||||
#' The base R function [as.double()] can be used to retrieve quantitative values from a `sir` object: `"S"` = 1, `"I"`/`"SDD"` = 2, `"R"` = 3. All other values are rendered `NA` . **Note:** Do not use `as.integer()`, since that (because of how R works internally) will return the factor level indices, and not these aforementioned quantitative values.
|
||||
#'
|
||||
#' The function [is_sir_eligible()] returns `TRUE` when a column contains at most 5% invalid antimicrobial interpretations (not S and/or I and/or R and/or N and/or SDD), 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.
|
||||
#' The function [is_sir_eligible()] returns `TRUE` when a column contains at most 5% invalid antimicrobial interpretations (not S and/or I and/or R and/or NI and/or SDD), 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 SIR:
|
||||
#' In 2019, the European Committee on Antimicrobial Susceptibility Testing (EUCAST) has decided to change the definitions of susceptibility testing categories S, I, and R as shown below (<https://www.eucast.org/newsiandr>):
|
||||
#'
|
||||
@ -220,7 +220,7 @@
|
||||
#'
|
||||
#' # For CLEANING existing SIR values ------------------------------------
|
||||
#'
|
||||
#' as.sir(c("S", "SDD", "I", "R", "N", "A", "B", "C"))
|
||||
#' as.sir(c("S", "SDD", "I", "R", "NI", "A", "B", "C"))
|
||||
#' as.sir("<= 0.002; S") # will return "S"
|
||||
#' sir_data <- as.sir(c(rep("S", 474), rep("I", 36), rep("R", 370)))
|
||||
#' is.sir(sir_data)
|
||||
@ -228,9 +228,9 @@
|
||||
#' barplot(sir_data) # for frequencies
|
||||
#'
|
||||
#' # as common in R, you can use as.integer() to return factor indices:
|
||||
#' as.integer(as.sir(c("S", "SDD", "I", "R", "N", NA)))
|
||||
#' as.integer(as.sir(c("S", "SDD", "I", "R", "NI", NA)))
|
||||
#' # but for computational use, as.double() will return 1 for S, 2 for I/SDD, and 3 for R:
|
||||
#' as.double(as.sir(c("S", "SDD", "I", "R", "N", NA)))
|
||||
#' as.double(as.sir(c("S", "SDD", "I", "R", "NI", NA)))
|
||||
#'
|
||||
#' # the dplyr way
|
||||
#' if (require("dplyr")) {
|
||||
@ -255,7 +255,7 @@ as.sir <- function(x, ...) {
|
||||
|
||||
as_sir_structure <- function(x) {
|
||||
structure(factor(as.character(unlist(unname(x))),
|
||||
levels = c("S", "SDD", "I", "R", "N"),
|
||||
levels = c("S", "SDD", "I", "R", "NI"),
|
||||
ordered = TRUE),
|
||||
class = c("sir", "ordered", "factor"))
|
||||
}
|
||||
@ -302,9 +302,9 @@ is_sir_eligible <- function(x, threshold = 0.05) {
|
||||
%in% class(x))) {
|
||||
# no transformation needed
|
||||
return(FALSE)
|
||||
} else if (all(x %in% c("S", "SDD", "I", "R", "N", NA)) & !all(is.na(x))) {
|
||||
} else if (all(x %in% c("S", "SDD", "I", "R", "NI", NA)) & !all(is.na(x))) {
|
||||
return(TRUE)
|
||||
} else if (!any(c("S", "SDD", "I", "R", "N") %in% x, na.rm = TRUE) & !all(is.na(x))) {
|
||||
} else if (!any(c("S", "SDD", "I", "R", "NI") %in% x, na.rm = TRUE) & !all(is.na(x))) {
|
||||
return(FALSE)
|
||||
} else {
|
||||
x <- x[!is.na(x) & !is.null(x) & !x %in% c("", "-", "NULL")]
|
||||
@ -334,13 +334,13 @@ is_sir_eligible <- function(x, threshold = 0.05) {
|
||||
|
||||
#' @rdname as.sir
|
||||
#' @export
|
||||
#' @param S,I,R,N,SDD a case-independent [regular expression][base::regex] to translate input to this result. This regular expression will be run *after* all non-letters and whitespaces are removed from the input.
|
||||
#' @param S,I,R,NI,SDD a case-independent [regular expression][base::regex] to translate input to this result. This regular expression will be run *after* all non-letters and whitespaces are removed from the input.
|
||||
# extra param: warn (logical, to never throw a warning)
|
||||
as.sir.default <- function(x,
|
||||
S = "^(S|U)+$",
|
||||
I = "^(I)+$",
|
||||
R = "^(R)+$",
|
||||
N = "^(N|V)+$",
|
||||
NI = "^(N|NI|V)+$",
|
||||
SDD = "^(SDD|D|H)+$",
|
||||
...) {
|
||||
if (inherits(x, "sir")) {
|
||||
@ -366,13 +366,13 @@ as.sir.default <- function(x,
|
||||
x[x.bak == "1"] <- "S"
|
||||
x[x.bak == "2"] <- "I"
|
||||
x[x.bak == "3"] <- "R"
|
||||
} else if (inherits(x.bak, "character") && all(x %in% c("1", "2", "3", "4", "5", "S", "SDD", "I", "R", "N", NA_character_))) {
|
||||
} else if (inherits(x.bak, "character") && all(x %in% c("1", "2", "3", "4", "5", "S", "SDD", "I", "R", "NI", NA_character_))) {
|
||||
x[x.bak == "1"] <- "S"
|
||||
x[x.bak == "2"] <- "SDD"
|
||||
x[x.bak == "3"] <- "I"
|
||||
x[x.bak == "4"] <- "R"
|
||||
x[x.bak == "5"] <- "N"
|
||||
} else if (!all(is.na(x)) && !identical(levels(x), c("S", "SDD", "I", "R", "N")) && !all(x %in% c("S", "SDD", "I", "R", "N", NA))) {
|
||||
x[x.bak == "5"] <- "NI"
|
||||
} else if (!all(is.na(x)) && !identical(levels(x), c("S", "SDD", "I", "R", "NI")) && !all(x %in% c("S", "SDD", "I", "R", "NI", NA))) {
|
||||
if (all(x %unlike% "(S|I|R)", na.rm = TRUE)) {
|
||||
# check if they are actually MICs or disks
|
||||
if (all_valid_mics(x)) {
|
||||
@ -408,7 +408,7 @@ as.sir.default <- function(x,
|
||||
# replace all English textual input
|
||||
x[x %like% "([^a-z]|^)res(is(tant)?)?"] <- "R"
|
||||
x[x %like% "([^a-z]|^)sus(cep(tible)?)?"] <- "S"
|
||||
x[x %like% "not|non"] <- "N"
|
||||
x[x %like% "not|non"] <- "NI"
|
||||
x[x %like% "([^a-z]|^)int(er(mediate)?)?|incr.*exp"] <- "I"
|
||||
x[x %like% "dose"] <- "SDD"
|
||||
x <- gsub("[^A-Z]+", "", x, perl = TRUE)
|
||||
@ -416,9 +416,9 @@ as.sir.default <- function(x,
|
||||
x[x %like% S] <- "S"
|
||||
x[x %like% I] <- "I"
|
||||
x[x %like% R] <- "R"
|
||||
x[x %like% N] <- "N"
|
||||
x[x %like% NI] <- "NI"
|
||||
x[x %like% SDD] <- "SDD"
|
||||
x[!x %in% c("S", "SDD", "I", "R", "N")] <- NA_character_
|
||||
x[!x %in% c("S", "SDD", "I", "R", "NI")] <- NA_character_
|
||||
na_after <- length(x[is.na(x) | x == ""])
|
||||
|
||||
if (!isFALSE(list(...)$warn)) { # so as.sir(..., warn = FALSE) will never throw a warning
|
||||
@ -711,7 +711,7 @@ as.sir.data.frame <- function(x,
|
||||
show_message <- FALSE
|
||||
ab <- ab_cols[i]
|
||||
ab_coerced <- suppressWarnings(as.ab(ab))
|
||||
if (!all(x[, ab_cols[i], drop = TRUE] %in% c("S", "SDD", "I", "R", "N", NA), na.rm = TRUE)) {
|
||||
if (!all(x[, ab_cols[i], drop = TRUE] %in% c("S", "SDD", "I", "R", "NI", NA), na.rm = TRUE)) {
|
||||
show_message <- TRUE
|
||||
# only print message if values are not already clean
|
||||
message_("Cleaning values in column '", font_bold(ab), "' (",
|
||||
@ -1313,7 +1313,7 @@ pillar_shaft.sir <- function(x, ...) {
|
||||
# colours will anyway not work when has_colour() == FALSE,
|
||||
# but then the indentation should also not be applied
|
||||
out[is.na(x)] <- font_grey(" NA")
|
||||
out[x == "N"] <- font_grey_bg(" N ")
|
||||
out[x == "NI"] <- font_grey_bg(" NI ")
|
||||
out[x == "S"] <- font_green_bg(" S ")
|
||||
out[x == "I"] <- font_orange_bg(" I ")
|
||||
out[x == "SDD"] <- font_orange_bg(" SDD ")
|
||||
@ -1445,7 +1445,7 @@ summary.sir <- function(object, ...) {
|
||||
SDD <- sum(x == "SDD", na.rm = TRUE)
|
||||
I <- sum(x == "I", na.rm = TRUE)
|
||||
R <- sum(x == "R", na.rm = TRUE)
|
||||
N <- sum(x == "N", na.rm = TRUE)
|
||||
NI <- sum(x == "NI", na.rm = TRUE)
|
||||
pad <- function(x) {
|
||||
if (is.na(x)) {
|
||||
return("??")
|
||||
@ -1464,7 +1464,7 @@ summary.sir <- function(object, ...) {
|
||||
"%SDD" = paste0(pad(percentage(SDD / n, digits = 1)), " (n=", SDD, ")"),
|
||||
"%I" = paste0(pad(percentage(I / n, digits = 1)), " (n=", I, ")"),
|
||||
"%R" = paste0(pad(percentage(R / n, digits = 1)), " (n=", R, ")"),
|
||||
"%N" = paste0(pad(percentage(N / n, digits = 1)), " (n=", N, ")")
|
||||
"%NI" = paste0(pad(percentage(NI / n, digits = 1)), " (n=", NI, ")")
|
||||
)
|
||||
class(value) <- c("summaryDefault", "table")
|
||||
value
|
||||
|
||||
@ -278,9 +278,9 @@ sir_calc_df <- function(type, # "proportion", "count" or "both"
|
||||
for (i in seq_len(ncol(.data))) {
|
||||
values <- .data[, i, drop = TRUE]
|
||||
if (isTRUE(combine_SI)) {
|
||||
values <- factor(values, levels = c("SI", "R", "N"), ordered = TRUE)
|
||||
values <- factor(values, levels = c("SI", "R", "NI"), ordered = TRUE)
|
||||
} else {
|
||||
values <- factor(values, levels = c("S", "SDD", "I", "R", "N"), ordered = TRUE)
|
||||
values <- factor(values, levels = c("S", "SDD", "I", "R", "NI"), ordered = TRUE)
|
||||
}
|
||||
col_results <- as.data.frame(as.matrix(table(values)), stringsAsFactors = FALSE)
|
||||
col_results$interpretation <- rownames(col_results)
|
||||
|
||||
BIN
R/sysdata.rda
BIN
R/sysdata.rda
Binary file not shown.
Reference in New Issue
Block a user