P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-07-09 02:03:04 +02:00
Code Releases Activity

(v1.4.0.9017) stringsAsFactors definitions

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2020-11-11 16:49:27 +01:00
parent 68ac39aa7f
commit 01d9522434
26 changed files with 201 additions and 114 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
R/ab_class_selectors.R
View File

@ -153,7 +153,7 @@ ab_selector <- function(ab_class, function_name) {
peek_vars_tidyselect <- import_fn("peek_vars", "tidyselect")
vars_vct <- peek_vars_tidyselect(fn = function_name)
vars_df <- data.frame(as.list(vars_vct))[1, , drop = FALSE]
vars_df <- data.frame(as.list(vars_vct), stringsAsFactors = FALSE)[1, , drop = FALSE]
colnames(vars_df) <- vars_vct
ab_in_data <- get_column_abx(vars_df, info = FALSE)

3
R/availability.R
View File

@ -85,7 +85,8 @@ availability <- function(tbl, width = NULL) {
available = percentage(x),
visual_availabilty = paste0("|", x_chars, x_chars_empty, "|"),
resistant = R_print,
visual_resistance = vis_resistance)
visual_resistance = vis_resistance,
stringsAsFactors = FALSE)
if (length(R[is.na(R)]) == ncol(tbl)) {
df[, 1:3]
} else {

22
R/bug_drug_combinations.R
View File

@ -79,13 +79,13 @@ bug_drug_combinations <- function(x,
unique_mo <- sort(unique(x[, col_mo, drop = TRUE]))
out <- data.frame(
mo = character(0),
ab = character(0),
S = integer(0),
I = integer(0),
R = integer(0),
total = integer(0))
out <- data.frame(mo = character(0),
ab = character(0),
S = integer(0),
I = integer(0),
R = integer(0),
total = integer(0),
stringsAsFactors = FALSE)
for (i in seq_len(length(unique_mo))) {
# filter on MO group and only select R/SI columns
@ -101,8 +101,9 @@ bug_drug_combinations <- function(x,
S = merged$S,
I = merged$I,
R = merged$R,
total = merged$S + merged$I + merged$R)
out <- rbind(out, out_group)
total = merged$S + merged$I + merged$R,
stringsAsFactors = FALSE)
out <- rbind(out, out_group, stringsAsFactors = FALSE)
}
structure(.Data = out, class = c("bug_drug_combinations", x_class))
@ -163,7 +164,8 @@ format.bug_drug_combinations <- function(x,
remove_NAs <- function(.data) {
cols <- colnames(.data)
.data <- as.data.frame(sapply(.data, function(x) ifelse(is.na(x), "", x), simplify = FALSE))
.data <- as.data.frame(sapply(.data, function(x) ifelse(is.na(x), "", x), simplify = FALSE),
stringsAsFactors = FALSE)
colnames(.data) <- cols
.data
}

6
R/eucast_rules.R
View File

@ -585,7 +585,7 @@ eucast_rules <- function(x,
x$gramstain <- mo_gramstain(x[, col_mo, drop = TRUE], language = NULL)
x$genus_species <- paste(x$genus, x$species)
if (info == TRUE & NROW(x) > 10000) {
message_("OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
}
if (any(x$genus == "Staphylococcus", na.rm = TRUE)) {
@ -1088,7 +1088,9 @@ edit_rsi <- function(x,
"rule", "rule_group", "rule_name", "rule_source")
verbose_new <- verbose_new %pm>% pm_filter(old != new | is.na(old))
# save changes to data set 'verbose_info'
track_changes$verbose_info <- rbind(track_changes$verbose_info, verbose_new)
track_changes$verbose_info <- rbind(track_changes$verbose_info,
verbose_new,
stringsAsFactors = FALSE)
# count adds and changes
track_changes$added <- track_changes$added + verbose_new %pm>%
pm_filter(is.na(old)) %pm>%

2
R/filter_ab_class.R
View File

@ -163,7 +163,7 @@ filter_ab_class <- function(x,
"` (", ab_name(names(agents), tolower = TRUE, language = NULL), ")"),
collapse = scope_txt),
operator, toString(result), as_note = FALSE)
x_transposed <- as.list(as.data.frame(t(x[, agents, drop = FALSE])))
x_transposed <- as.list(as.data.frame(t(x[, agents, drop = FALSE]), stringsAsFactors = FALSE))
filtered <- sapply(x_transposed, function(y) scope_fn(y %in% result, na.rm = TRUE))
x <- x[which(filtered), , drop = FALSE]
class(x) <- x_class

9
R/ggplot_pca.R
View File

@ -314,11 +314,13 @@ pca_calculations <- function(pca_model,
# Scores
choices <- pmin(choices, ncol(u))
obs.scale <- 1 - as.integer(scale)
df.u <- as.data.frame(sweep(u[, choices], 2, d[choices] ^ obs.scale, FUN = "*"))
df.u <- as.data.frame(sweep(u[, choices], 2, d[choices] ^ obs.scale, FUN = "*"),
stringsAsFactors = FALSE)
# Directions
v <- sweep(v, 2, d ^ as.integer(scale), FUN = "*")
df.v <- as.data.frame(v[, choices])
df.v <- as.data.frame(v[, choices],
stringsAsFactors = FALSE)
names(df.u) <- c("xvar", "yvar")
names(df.v) <- names(df.u)
@ -356,7 +358,8 @@ pca_calculations <- function(pca_model,
if (nrow(x) <= 2) {
return(data.frame(X1 = numeric(0),
X2 = numeric(0),
groups = character(0)))
groups = character(0),
stringsAsFactors = FALSE))
}
sigma <- var(cbind(x$xvar, x$yvar))
mu <- c(mean(x$xvar), mean(x$yvar))

10
R/guess_ab_col.R
View File

@ -145,8 +145,9 @@ get_column_abx <- function(x,
vectr_antibiotics <- vectr_antibiotics[!is.na(vectr_antibiotics) & nchar(vectr_antibiotics) >= 3]
x_columns <- sapply(colnames(x), function(col, df = x_bak) {
if (toupper(col) %in% vectr_antibiotics |
is.rsi(as.data.frame(df)[, col, drop = TRUE]) |
is.rsi.eligible(as.data.frame(df)[, col, drop = TRUE], threshold = 0.5)) {
is.rsi(as.data.frame(df, stringsAsFactors = FALSE)[, col, drop = TRUE]) |
is.rsi.eligible(as.data.frame(df, stringsAsFactors = FALSE)[, col, drop = TRUE],
threshold = 0.5)) {
return(col)
} else {
return(NA_character_)
@ -156,7 +157,8 @@ get_column_abx <- function(x,
x <- x[, x_columns, drop = FALSE] # without drop = TRUE, x will become a vector when x_columns is length 1
df_trans <- data.frame(colnames = colnames(x),
abcode = suppressWarnings(as.ab(colnames(x), info = FALSE)))
abcode = suppressWarnings(as.ab(colnames(x), info = FALSE)),
stringsAsFactors = FALSE)
df_trans <- df_trans[!is.na(df_trans$abcode), , drop = FALSE]
x <- as.character(df_trans$colnames)
names(x) <- df_trans$abcode
@ -197,7 +199,7 @@ get_column_abx <- function(x,
# succeeded with auto-guessing
if (info == TRUE) {
message_("OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
}
for (i in seq_len(length(x))) {

16
R/mdro.R
View File

@ -574,7 +574,9 @@ mdro <- function(x,
cols <- cols[!ab_missing(cols)]
cols <- cols[!is.na(cols)]
if (length(rows) > 0 & length(cols) > 0) {
x[, cols] <- as.data.frame(lapply(x[, cols, drop = FALSE], function(col) as.rsi(col)))
x[, cols] <- as.data.frame(lapply(x[, cols, drop = FALSE],
function(col) as.rsi(col)),
stringsAsFactors = FALSE)
x[rows, "columns_nonsusceptible"] <<- sapply(rows,
function(row, group_vct = cols) {
cols_nonsus <- sapply(x[row, group_vct, drop = FALSE],
@ -589,7 +591,8 @@ mdro <- function(x,
} else if (any_all == "all") {
search_function <- all
}
x_transposed <- as.list(as.data.frame(t(x[, cols, drop = FALSE])))
x_transposed <- as.list(as.data.frame(t(x[, cols, drop = FALSE]),
stringsAsFactors = FALSE))
row_filter <- sapply(x_transposed, function(y) search_function(y %in% search_result, na.rm = TRUE))
row_filter <- x[which(row_filter), "row_number", drop = TRUE]
rows <- rows[rows %in% row_filter]
@ -604,7 +607,9 @@ mdro <- function(x,
if (length(rows) > 0) {
# function specific for the CMI paper of 2012 (Magiorakos et al.)
lst_vector <- unlist(lst)[!is.na(unlist(lst))]
x[, lst_vector] <- as.data.frame(lapply(x[, lst_vector, drop = FALSE], function(col) as.rsi(col)))
x[, lst_vector] <- as.data.frame(lapply(x[, lst_vector, drop = FALSE],
function(col) as.rsi(col)),
stringsAsFactors = FALSE)
x[rows, "classes_in_guideline"] <<- length(lst)
x[rows, "classes_available"] <<- sapply(rows,
function(row, group_tbl = lst) {
@ -627,13 +632,14 @@ mdro <- function(x,
na.rm = TRUE)
})
# for PDR; all agents are R (or I if combine_SI = FALSE)
x_transposed <- as.list(as.data.frame(t(x[rows, lst_vector, drop = FALSE])))
x_transposed <- as.list(as.data.frame(t(x[rows, lst_vector, drop = FALSE]),
stringsAsFactors = FALSE))
row_filter <- sapply(x_transposed, function(y) all(y %in% search_result, na.rm = TRUE))
x[which(row_filter), "classes_affected"] <<- 999
}
if (info == TRUE) {
message_(" OK", as_note = FALSE)
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
}
}

54
R/mo.R
View File

@ -324,7 +324,8 @@ exec_as.mo <- function(x,
format_uncertainty_as_df(uncertainty_level = uncertainty,
input = input,
result_mo = res_df[1, "mo", drop = TRUE],
candidates = as.character(res_df[, "fullname", drop = TRUE])))
candidates = as.character(res_df[, "fullname", drop = TRUE])),
stringsAsFactors = FALSE)
}
res[seq_len(min(n, length(res)))]
}
@ -819,7 +820,8 @@ exec_as.mo <- function(x,
uncertainties <- rbind(uncertainties,
format_uncertainty_as_df(uncertainty_level = 1,
input = x_backup[i],
result_mo = lookup(fullname == "Salmonella enterica", "mo", uncertainty = -1)))
result_mo = lookup(fullname == "Salmonella enterica", "mo", uncertainty = -1)),
stringsAsFactors = FALSE)
next
}
}
@ -1022,7 +1024,8 @@ exec_as.mo <- function(x,
uncertainties <<- rbind(uncertainties,
format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup,
result_mo = lookup(fullname == found["fullname_new"], "mo", haystack = MO_lookup)))
result_mo = lookup(fullname == found["fullname_new"], "mo", haystack = MO_lookup)),
stringsAsFactors = FALSE)
return(x)
}
@ -1043,7 +1046,8 @@ exec_as.mo <- function(x,
if (!empty_result(found)) {
found_result <- found
uncertainties <<- rbind(uncertainties,
attr(found, which = "uncertainties", exact = TRUE))
attr(found, which = "uncertainties", exact = TRUE),
stringsAsFactors = FALSE)
found <- lookup(mo == found)
return(found)
}
@ -1071,7 +1075,8 @@ exec_as.mo <- function(x,
uncertainties <<- rbind(uncertainties,
format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup,
result_mo = found_result))
result_mo = found_result),
stringsAsFactors = FALSE)
return(found)
}
}
@ -1095,7 +1100,8 @@ exec_as.mo <- function(x,
if (!empty_result(found) & nchar(g.x_backup_without_spp) >= 6) {
found_result <- found
uncertainties <<- rbind(uncertainties,
attr(found, which = "uncertainties", exact = TRUE))
attr(found, which = "uncertainties", exact = TRUE),
stringsAsFactors = FALSE)
found <- lookup(mo == found)
return(found)
}
@ -1118,7 +1124,8 @@ exec_as.mo <- function(x,
if (!empty_result(found) & nchar(g.x_backup_without_spp) >= 6) {
found_result <- found
uncertainties <<- rbind(uncertainties,
attr(found, which = "uncertainties", exact = TRUE))
attr(found, which = "uncertainties", exact = TRUE),
stringsAsFactors = FALSE)
found <- lookup(mo == found)
return(found)
}
@ -1147,7 +1154,8 @@ exec_as.mo <- function(x,
if (!empty_result(found)) {
found_result <- found
uncertainties <<- rbind(uncertainties,
attr(found, which = "uncertainties", exact = TRUE))
attr(found, which = "uncertainties", exact = TRUE),
stringsAsFactors = FALSE)
found <- lookup(mo == found)
return(found)
}
@ -1175,7 +1183,8 @@ exec_as.mo <- function(x,
if (!empty_result(found)) {
found_result <- found
uncertainties <<- rbind(uncertainties,
attr(found, which = "uncertainties", exact = TRUE))
attr(found, which = "uncertainties", exact = TRUE),
stringsAsFactors = FALSE)
found <- lookup(mo == found)
return(found)
}
@ -1193,7 +1202,8 @@ exec_as.mo <- function(x,
uncertainties <<- rbind(uncertainties,
format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup,
result_mo = found_result))
result_mo = found_result),
stringsAsFactors = FALSE)
return(found)
}
if (b.x_trimmed %like_case% "(fungus|fungi)" & !b.x_trimmed %like_case% "fungiphrya") {
@ -1203,7 +1213,8 @@ exec_as.mo <- function(x,
uncertainties <<- rbind(uncertainties,
format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup,
result_mo = found_result))
result_mo = found_result),
stringsAsFactors = FALSE)
return(found)
}
# (9) try to strip off one element from start and check the remains (only allow >= 2-part name outcome) ----
@ -1228,7 +1239,8 @@ exec_as.mo <- function(x,
# uncertainty level 2 only if searched part contains a space (otherwise it will be found with lvl 3)
if (x_strip_collapsed %like_case% " ") {
uncertainties <<- rbind(uncertainties,
attr(found, which = "uncertainties", exact = TRUE))
attr(found, which = "uncertainties", exact = TRUE),
stringsAsFactors = FALSE)
found <- lookup(mo == found)
return(found)
}
@ -1261,7 +1273,8 @@ exec_as.mo <- function(x,
if (!empty_result(found)) {
found_result <- found
uncertainties <<- rbind(uncertainties,
attr(found, which = "uncertainties", exact = TRUE))
attr(found, which = "uncertainties", exact = TRUE),
stringsAsFactors = FALSE)
found <- lookup(mo == found)
return(found)
}
@ -1287,7 +1300,8 @@ exec_as.mo <- function(x,
if (!empty_result(found)) {
found_result <- found
uncertainties <<- rbind(uncertainties,
attr(found, which = "uncertainties", exact = TRUE))
attr(found, which = "uncertainties", exact = TRUE),
stringsAsFactors = FALSE)
found <- lookup(mo == found)
return(found)
}
@ -1305,7 +1319,8 @@ exec_as.mo <- function(x,
if (!is.na(found) & nchar(g.x_backup_without_spp) >= 6) {
found_result <- lookup(mo == found)
uncertainties <<- rbind(uncertainties,
attr(found, which = "uncertainties", exact = TRUE))
attr(found, which = "uncertainties", exact = TRUE),
stringsAsFactors = FALSE)
found <- lookup(mo == found)
return(found)
}
@ -1498,7 +1513,8 @@ exec_as.mo <- function(x,
format_uncertainty_as_df(uncertainty_level = actual_uncertainty,
input = actual_input,
result_mo = x,
candidates = ""))
candidates = ""),
stringsAsFactors = FALSE)
}
# this will save the uncertain items as attribute, so they can be bound to `uncertainties` in the uncertain_fn() function
x <- structure(x, uncertainties = uncertainties)
@ -1520,7 +1536,9 @@ was_renamed <- function(name_old, name_new, ref_old = "", ref_new = "", mo = "")
stringsAsFactors = FALSE)
already_set <- getOption("mo_renamed")
if (!is.null(already_set)) {
options(mo_renamed = rbind(already_set, newly_set))
options(mo_renamed = rbind(already_set,
newly_set,
stringsAsFactors = FALSE))
} else {
options(mo_renamed = newly_set)
}
@ -1791,7 +1809,7 @@ print.mo_uncertainties <- function(x, ...) {
mo_renamed <- function() {
items <- getOption("mo_renamed", default = NULL)
if (is.null(items)) {
items <- data.frame()
items <- data.frame(stringsAsFactors = FALSE)
} else {
items <- pm_distinct(items, old_name, .keep_all = TRUE)
}

3
R/resistance_predict.R
View File

@ -186,7 +186,8 @@ resistance_predict <- function(x,
# remove rows with NAs
df <- subset(df, !is.na(df[, col_ab, drop = TRUE]))
df$year <- year(df[, col_date, drop = TRUE])
df <- as.data.frame(rbind(table(df[, c("year", col_ab)])), stringsAsFactors = FALSE)
df <- as.data.frame(rbind(table(df[, c("year", col_ab)])),
stringsAsFactors = FALSE)
df$year <- as.integer(rownames(df))
rownames(df) <- NULL

108
R/rsi.R
View File

@ -36,6 +36,7 @@
#' @param guideline defaults to the latest included EUCAST guideline, see Details for all options
#' @param conserve_capped_values a logical to indicate that MIC values starting with `">"` (but not `">="`) must always return "R" , and that MIC values starting with `"<"` (but not `"<="`) must always return "S"
#' @param add_intrinsic_resistance *(only useful when using a EUCAST guideline)* a logical to indicate whether intrinsic antibiotic resistance must also be considered for applicable bug-drug combinations, meaning that e.g. ampicillin will always return "R" in *Klebsiella* species. Determination is based on the [intrinsic_resistant] data set, that itself is based on 'EUCAST Expert Rules, Intrinsic Resistance and Exceptional Phenotypes', version `r EUCAST_VERSION_EXPERT_RULES`.
#' @param reference_data a [data.frame] to be used for interpretation, which defaults to the [rsi_translation] data set. Changing this parameter allows for using own interpretation guidelines. This parameter must contain a data set that is equal in structure to the [rsi_translation] data set (same column names and column types). Please note that the 'guideline' column in this data set must contain values set in the 'guideline' parameter of [as.rsi()].
#' @param threshold maximum fraction of invalid antimicrobial interpretations of `x`, please see *Examples*
#' @param ... for using on a [data.frame]: names of columns to apply [as.rsi()] on (supports tidy selection like `AMX:VAN`). Otherwise: parameters passed on to methods.
#' @details
@ -66,7 +67,7 @@
#'
#' For interpreting MIC values as well as disk diffusion diameters, supported guidelines to be used as input for the `guideline` parameter are: `r paste0('"', sort(unique(AMR::rsi_translation$guideline)), '"', collapse = ", ")`.
#'
#' Simply using `"CLSI"` or `"EUCAST"` as input will automatically select the latest version of that guideline.
#' Simply using `"CLSI"` or `"EUCAST"` as input will automatically select the latest version of that guideline. You can set your own data set using the `reference_data` parameter.
#'
#' ## After interpretation
#'
@ -294,6 +295,7 @@ as.rsi.mic <- function(x,
uti = FALSE,
conserve_capped_values = FALSE,
add_intrinsic_resistance = FALSE,
reference_data = AMR::rsi_translation,
...) {
meet_criteria(x)
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
@ -302,6 +304,8 @@ as.rsi.mic <- function(x,
meet_criteria(uti, allow_class = "logical", has_length = c(1, length(x)))
meet_criteria(conserve_capped_values, allow_class = "logical", has_length = 1)
meet_criteria(add_intrinsic_resistance, allow_class = "logical", has_length = 1)
meet_criteria(reference_data, allow_class = "data.frame")
check_reference_data(reference_data)
# for dplyr's across()
cur_column_dplyr <- import_fn("cur_column", "dplyr", error_on_fail = FALSE)
@ -328,8 +332,7 @@ as.rsi.mic <- function(x,
}
if (is.null(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 transform certain columns with e.g. mutate_at(), use `data %>% mutate_at(vars(...), as.rsi, mo = .$x)`, where x is your column with microorganisms.\n",
"To tranform all MIC values in a data set, use `data %>% as.rsi()` or data %>% mutate_if(is.mic, as.rsi).", call = FALSE)
}
if (length(ab) == 1 && ab %like% "as.mic") {
@ -338,7 +341,7 @@ as.rsi.mic <- function(x,
ab_coerced <- suppressWarnings(as.ab(ab))
mo_coerced <- suppressWarnings(as.mo(mo))
guideline_coerced <- get_guideline(guideline)
guideline_coerced <- get_guideline(guideline, reference_data)
if (is.na(ab_coerced)) {
message_("Returning NAs for unknown drug: `", font_bold(ab),
"`. Rename this column to a drug name or code, and check the output with as.ab().",
@ -367,7 +370,8 @@ as.rsi.mic <- function(x,
guideline = guideline_coerced,
uti = uti,
conserve_capped_values = conserve_capped_values,
add_intrinsic_resistance = add_intrinsic_resistance) # exec_as.rsi will return message_(" OK.")
add_intrinsic_resistance = add_intrinsic_resistance,
reference_data = reference_data) # exec_as.rsi will return message 'OK'
result
}
@ -379,6 +383,7 @@ as.rsi.disk <- function(x,
guideline = "EUCAST",
uti = FALSE,
add_intrinsic_resistance = FALSE,
reference_data = AMR::rsi_translation,
...) {
meet_criteria(x)
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
@ -386,6 +391,8 @@ as.rsi.disk <- function(x,
meet_criteria(guideline, allow_class = "character", has_length = 1)
meet_criteria(uti, allow_class = "logical", has_length = c(1, length(x)))
meet_criteria(add_intrinsic_resistance, allow_class = "logical", has_length = 1)
meet_criteria(reference_data, allow_class = "data.frame")
check_reference_data(reference_data)
# for dplyr's across()
cur_column_dplyr <- import_fn("cur_column", "dplyr", error_on_fail = FALSE)
@ -412,8 +419,7 @@ as.rsi.disk <- function(x,
}
if (is.null(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 transform certain columns with e.g. mutate_at(), use `data %>% mutate_at(vars(...), as.rsi, mo = .$x)`, where x is your column with microorganisms.\n",
"To tranform all disk diffusion zones in a data set, use `data %>% as.rsi()` or data %>% mutate_if(is.disk, as.rsi).", call = FALSE)
}
if (length(ab) == 1 && ab %like% "as.disk") {
@ -422,7 +428,7 @@ as.rsi.disk <- function(x,
ab_coerced <- suppressWarnings(as.ab(ab))
mo_coerced <- suppressWarnings(as.mo(mo))
guideline_coerced <- get_guideline(guideline)
guideline_coerced <- get_guideline(guideline, reference_data)
if (is.na(ab_coerced)) {
message_("Returning NAs for unknown drug: `", font_bold(ab),
"`. Rename this column to a drug name or code, and check the output with as.ab().",
@ -449,7 +455,8 @@ as.rsi.disk <- function(x,
guideline = guideline_coerced,
uti = uti,
conserve_capped_values = FALSE,
add_intrinsic_resistance = add_intrinsic_resistance) # exec_as.rsi will return message_(" OK.")
add_intrinsic_resistance = add_intrinsic_resistance,
reference_data = reference_data) # exec_as.rsi will return message 'OK'
result
}
@ -461,13 +468,15 @@ as.rsi.data.frame <- function(x,
guideline = "EUCAST",
uti = NULL,
conserve_capped_values = FALSE,
add_intrinsic_resistance = FALSE) {
add_intrinsic_resistance = FALSE,
reference_data = rsi_translation) {
meet_criteria(x, allow_class = "data.frame") # will also check for dimensions > 0
meet_criteria(col_mo, allow_class = "character", is_in = colnames(x), allow_NULL = TRUE)
meet_criteria(guideline, allow_class = "character", has_length = 1)
meet_criteria(uti, allow_class = c("logical", "character"), allow_NULL = TRUE)
meet_criteria(conserve_capped_values, allow_class = "logical", has_length = 1)
meet_criteria(add_intrinsic_resistance, allow_class = "logical", has_length = 1)
meet_criteria(reference_data, allow_class = "data.frame")
for (i in seq_len(ncol(x))) {
# don't keep factors
@ -574,18 +583,28 @@ as.rsi.data.frame <- function(x,
for (i in seq_len(length(ab_cols))) {
if (types[i] == "mic") {
x[, ab_cols[i]] <- as.rsi.mic(x = x %pm>% pm_pull(ab_cols[i]),
mo = x_mo,
ab = ab_cols[i],
guideline = guideline,
uti = uti,
conserve_capped_values = conserve_capped_values)
x[, ab_cols[i]] <- as.rsi(x = x %pm>%
pm_pull(ab_cols[i]) %pm>%
as.character() %pm>%
as.mic(),
mo = x_mo,
ab = ab_cols[i],
guideline = guideline,
uti = uti,
conserve_capped_values = conserve_capped_values,
add_intrinsic_resistance = add_intrinsic_resistance,
reference_data = reference_data)
} else if (types[i] == "disk") {
x[, ab_cols[i]] <- as.rsi.disk(x = x %pm>% pm_pull(ab_cols[i]),
mo = x_mo,
ab = ab_cols[i],
guideline = guideline,
uti = uti)
x[, ab_cols[i]] <- as.rsi(x = x %pm>%
pm_pull(ab_cols[i]) %pm>%
as.character() %pm>%
as.disk(),
mo = x_mo,
ab = ab_cols[i],
guideline = guideline,
uti = uti,
add_intrinsic_resistance = add_intrinsic_resistance,
reference_data = reference_data)
} else if (types[i] == "rsi") {
ab <- ab_cols[i]
ab_coerced <- suppressWarnings(as.ab(ab))
@ -595,26 +614,26 @@ as.rsi.data.frame <- function(x,
appendLF = FALSE,
as_note = FALSE)
x[, ab_cols[i]] <- as.rsi.default(x = x %pm>% pm_pull(ab_cols[i]))
message_("OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
}
}
x
}
get_guideline <- function(guideline) {
get_guideline <- function(guideline, reference_data) {
guideline_param <- toupper(guideline)
if (guideline_param %in% c("CLSI", "EUCAST")) {
guideline_param <- rev(sort(subset(rsi_translation, guideline %like% guideline_param)$guideline))[1L]
guideline_param <- rev(sort(subset(reference_data, guideline %like% guideline_param)$guideline))[1L]
}
if (!guideline_param %like% " ") {
# like 'EUCAST2020', should be 'EUCAST 2020'
guideline_param <- gsub("([a-z]+)([0-9]+)", "\\1 \\2", guideline_param, ignore.case = TRUE)
}
stop_ifnot(guideline_param %in% rsi_translation$guideline,
stop_ifnot(guideline_param %in% reference_data$guideline,
"invalid guideline: '", guideline,
"'.\nValid guidelines are: ", paste0("'", unique(rsi_translation$guideline), "'", collapse = ", "), call = FALSE)
"'.\nValid guidelines are: ", paste0("'", unique(reference_data$guideline), "'", collapse = ", "), call = FALSE)
guideline_param
@ -631,7 +650,7 @@ exec_as.rsi <- function(method,
metadata_mo <- get_mo_failures_uncertainties_renamed()
x_bak <- data.frame(x_mo = paste0(x, mo))
x_bak <- data.frame(x_mo = paste0(x, mo), stringsAsFactors = FALSE)
df <- unique(data.frame(x, mo), stringsAsFactors = FALSE)
x <- df$x
mo <- df$mo
@ -661,14 +680,14 @@ exec_as.rsi <- function(method,
}
mo_other <- as.mo(rep("UNKNOWN", length(mo)))
guideline_coerced <- get_guideline(guideline)
guideline_coerced <- get_guideline(guideline, reference_data)
if (guideline_coerced != guideline) {
message_("Using guideline ", font_bold(guideline_coerced), " as input for `guideline`.")
}
new_rsi <- rep(NA_character_, length(x))
ab_param <- ab
trans <- rsi_translation %pm>%
trans <- reference_data %pm>%
subset(guideline == guideline_coerced & method == method_param & ab == ab_param)
trans$lookup <- paste(trans$mo, trans$ab)
@ -682,7 +701,7 @@ exec_as.rsi <- function(method,
if (all(trans$uti == TRUE, na.rm = TRUE) & all(uti == FALSE)) {
message_("WARNING.", add_fn = list(font_red, font_bold), as_note = FALSE)
warning_("Interpretation of ", font_bold(ab_name(ab, tolower = TRUE)), " for some microorganisms is only available for (uncomplicated) urinary tract infections (UTI).\n Use parameter 'uti' to set which isolates are from urine. See ?as.rsi.", call = FALSE)
warning_("Interpretation of ", font_bold(ab_name(ab, tolower = TRUE)), " for some microorganisms is only available for (uncomplicated) urinary tract infections (UTI). Use parameter 'uti' to set which isolates are from urine. See ?as.rsi.", call = FALSE)
warned <- TRUE
}
@ -757,11 +776,13 @@ exec_as.rsi <- function(method,
}
new_rsi <- x_bak %pm>%
pm_left_join(data.frame(x_mo = paste0(df$x, df$mo), new_rsi), by = "x_mo") %pm>%
pm_left_join(data.frame(x_mo = paste0(df$x, df$mo), new_rsi,
stringsAsFactors = FALSE),
by = "x_mo") %pm>%
pm_pull(new_rsi)
if (warned == FALSE) {
message_("OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
}
load_mo_failures_uncertainties_renamed(metadata_mo)
@ -928,13 +949,16 @@ plot.rsi <- function(x,
data$s <- round((data$n / sum(data$n)) * 100, 1)
if (!"S" %in% data$x) {
data <- rbind(data, data.frame(x = "S", n = 0, s = 0))
data <- rbind(data, data.frame(x = "S", n = 0, s = 0, stringsAsFactors = FALSE),
stringsAsFactors = FALSE)
}
if (!"I" %in% data$x) {
data <- rbind(data, data.frame(x = "I", n = 0, s = 0))
data <- rbind(data, data.frame(x = "I", n = 0, s = 0, stringsAsFactors = FALSE),
stringsAsFactors = FALSE)
}
if (!"R" %in% data$x) {
data <- rbind(data, data.frame(x = "R", n = 0, s = 0))
data <- rbind(data, data.frame(x = "R", n = 0, s = 0, stringsAsFactors = FALSE),
stringsAsFactors = FALSE)
}
# don't use as.rsi() here, it will confuse plot()
@ -1037,3 +1061,17 @@ unique.rsi <- function(x, incomparables = FALSE, ...) {
attributes(y) <- attributes(x)
y
}
check_reference_data <- function(reference_data) {
if (!identical(reference_data, AMR::rsi_translation)) {
class_rsi <- sapply(rsi_translation, function(x) paste0("<", class(x), ">", collapse = " and "))
class_ref <- sapply(reference_data, function(x) paste0("<", class(x), ">", collapse = " and "))
if (!all(names(class_rsi) == names(class_ref))) {
stop_("'reference_data' must have the same column names as the 'rsi_translation' data set.", call = -2)
}
if (!all(class_rsi == class_ref)) {
class_rsi[class_rsi != class_ref][1]
stop_("'reference_data' must be the same structure as the 'rsi_translation' data set. Column '", names(class_ref[class_rsi != class_ref][1]), "' is of class ", class_ref[class_rsi != class_ref][1], ", but should be of class ", class_rsi[class_rsi != class_ref][1], ".", call = -2)
}
}
}

6
R/rsi_calc.R
View File

@ -118,7 +118,7 @@ rsi_calc <- function(...,
rsi_integrity_check <- as.rsi(rsi_integrity_check)
}
x_transposed <- as.list(as.data.frame(t(x)))
x_transposed <- as.list(as.data.frame(t(x), stringsAsFactors = FALSE))
if (only_all_tested == TRUE) {
# no NAs in any column
y <- apply(X = as.data.frame(lapply(x, as.integer), stringsAsFactors = FALSE),
@ -240,7 +240,7 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
} else {
values <- factor(values, levels = c("S", "I", "R"), ordered = TRUE)
}
col_results <- as.data.frame(as.matrix(table(values)))
col_results <- as.data.frame(as.matrix(table(values)), stringsAsFactors = FALSE)
col_results$interpretation <- rownames(col_results)
col_results$isolates <- col_results[, 1, drop = TRUE]
if (NROW(col_results) > 0 && sum(col_results$isolates, na.rm = TRUE) > 0) {
@ -265,7 +265,7 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
}
out_new <- cbind(group_values, out_new)
}
out <- rbind(out, out_new)
out <- rbind(out, out_new, stringsAsFactors = FALSE)
}
}
out