P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-07-11 15:41:57 +02:00
Code Releases Activity

(v2.1.1.9049) new 2024 breakpoints, add AMO, set NI instead of N

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2024-06-14 22:39:01 +02:00
parent de17de1be9
commit 9bf7584d58
57 changed files with 4375 additions and 135 deletions
Download Patch File Download Diff File Expand all files Collapse all files

12
R/aa_helper_functions.R
View File

@ -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
View File

@ -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: ",

6
R/ab_selectors.R
View File

@ -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")

2
R/antibiogram.R
View File

@ -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))

10
R/bug_drug_combinations.R
View File

@ -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
)

2
R/count.R
View File

@ -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
),

4
R/custom_eucast_rules.R
View File

@ -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)

2
R/first_isolate.R
View File

@ -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) {

2
R/key_antimicrobials.R
View File

@ -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
View File

@ -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
View File

@ -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"

4
R/proportion.R
View File

@ -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
View File

@ -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

4
R/sir_calc.R
View File

@ -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
View File

Binary file not shown.