P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2024-12-25 18:06:12 +01: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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
DESCRIPTION
View File

@ -1,6 +1,6 @@
Package: AMR Package: AMR
Version: 1.4.0.9016 Version: 1.4.0.9017
Date: 2020-11-10 Date: 2020-11-11
Title: Antimicrobial Resistance Analysis Title: Antimicrobial Resistance Analysis
Authors@R: c( Authors@R: c(
person(role = c("aut", "cre"), person(role = c("aut", "cre"),

5
NEWS.md
View File

@ -1,5 +1,5 @@
# AMR 1.4.0.9016 # AMR 1.4.0.9017
## <small>Last updated: 10 November 2020</small> ## <small>Last updated: 11 November 2020</small>
### New ### New
* Functions `is_gram_negative()` and `is_gram_positive()` as wrappers around `mo_gramstain()`. They always return `TRUE` or `FALSE` (except when the input is `NA` or the MO code is `UNKNOWN`), thus always return `FALSE` for species outside the taxonomic kingdom of Bacteria. If you have the `dplyr` package installed, they can even determine the column with microorganisms themselves inside `dplyr` functions: * Functions `is_gram_negative()` and `is_gram_positive()` as wrappers around `mo_gramstain()`. They always return `TRUE` or `FALSE` (except when the input is `NA` or the MO code is `UNKNOWN`), thus always return `FALSE` for species outside the taxonomic kingdom of Bacteria. If you have the `dplyr` package installed, they can even determine the column with microorganisms themselves inside `dplyr` functions:
@ -11,6 +11,7 @@
* Functions `%not_like%` and `%not_like_case%` as wrappers around `%like%` and `%like_case%`. The RStudio addin to insert the text " %like% " as provided in this package now iterates over all like variants. So if you have defined the keyboard shortcut Ctrl/Cmd + L to this addin, it will first insert ` %like% ` and by pressing it again it will be replaced with ` %not_like% `, etc. * Functions `%not_like%` and `%not_like_case%` as wrappers around `%like%` and `%like_case%`. The RStudio addin to insert the text " %like% " as provided in this package now iterates over all like variants. So if you have defined the keyboard shortcut Ctrl/Cmd + L to this addin, it will first insert ` %like% ` and by pressing it again it will be replaced with ` %not_like% `, etc.
### Changed ### Changed
* Reference data used for `as.rsi()` can now be set by the user, using the `reference_data` parameter.
* For all function parameters in the code, it is now defined what the exact type of user input should be (inspired by the [`typed`](https://github.com/moodymudskipper/typed) package). If the user input for a certain function does not meet the requirements for a specific parameter (such as the class or length), an informative error will be thrown. This makes the package more robust and the use of it more reproducible and reliable. In total, more than 400 arguments were defined. * For all function parameters in the code, it is now defined what the exact type of user input should be (inspired by the [`typed`](https://github.com/moodymudskipper/typed) package). If the user input for a certain function does not meet the requirements for a specific parameter (such as the class or length), an informative error will be thrown. This makes the package more robust and the use of it more reproducible and reliable. In total, more than 400 arguments were defined.
* Deprecated function `p_symbol()` that not really fits the scope of this package. It will be removed in a future version. See [here](https://github.com/msberends/AMR/blob/v1.4.0/R/p_symbol.R) for the source code to preserve it. * Deprecated function `p_symbol()` that not really fits the scope of this package. It will be removed in a future version. See [here](https://github.com/msberends/AMR/blob/v1.4.0/R/p_symbol.R) for the source code to preserve it.
* Better determination of disk zones and MIC values when running `as.rsi()` on a data.frame * Better determination of disk zones and MIC values when running `as.rsi()` on a data.frame

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") peek_vars_tidyselect <- import_fn("peek_vars", "tidyselect")
vars_vct <- peek_vars_tidyselect(fn = function_name) 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 colnames(vars_df) <- vars_vct
ab_in_data <- get_column_abx(vars_df, info = FALSE) 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), available = percentage(x),
visual_availabilty = paste0("|", x_chars, x_chars_empty, "|"), visual_availabilty = paste0("|", x_chars, x_chars_empty, "|"),
resistant = R_print, resistant = R_print,
visual_resistance = vis_resistance) visual_resistance = vis_resistance,
stringsAsFactors = FALSE)
if (length(R[is.na(R)]) == ncol(tbl)) { if (length(R[is.na(R)]) == ncol(tbl)) {
df[, 1:3] df[, 1:3]
} else { } 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])) unique_mo <- sort(unique(x[, col_mo, drop = TRUE]))
out <- data.frame( out <- data.frame(mo = character(0),
mo = character(0), ab = character(0),
ab = character(0), S = integer(0),
S = integer(0), I = integer(0),
I = integer(0), R = integer(0),
R = integer(0), total = integer(0),
total = integer(0)) stringsAsFactors = FALSE)
for (i in seq_len(length(unique_mo))) { for (i in seq_len(length(unique_mo))) {
# filter on MO group and only select R/SI columns # filter on MO group and only select R/SI columns
@ -101,8 +101,9 @@ bug_drug_combinations <- function(x,
S = merged$S, S = merged$S,
I = merged$I, I = merged$I,
R = merged$R, R = merged$R,
total = merged$S + merged$I + merged$R) total = merged$S + merged$I + merged$R,
out <- rbind(out, out_group) stringsAsFactors = FALSE)
out <- rbind(out, out_group, stringsAsFactors = FALSE)
} }
structure(.Data = out, class = c("bug_drug_combinations", x_class)) structure(.Data = out, class = c("bug_drug_combinations", x_class))
@ -163,7 +164,8 @@ format.bug_drug_combinations <- function(x,
remove_NAs <- function(.data) { remove_NAs <- function(.data) {
cols <- colnames(.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 colnames(.data) <- cols
.data .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$gramstain <- mo_gramstain(x[, col_mo, drop = TRUE], language = NULL)
x$genus_species <- paste(x$genus, x$species) x$genus_species <- paste(x$genus, x$species)
if (info == TRUE & NROW(x) > 10000) { 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)) { if (any(x$genus == "Staphylococcus", na.rm = TRUE)) {
@ -1088,7 +1088,9 @@ edit_rsi <- function(x,
"rule", "rule_group", "rule_name", "rule_source") "rule", "rule_group", "rule_name", "rule_source")
verbose_new <- verbose_new %pm>% pm_filter(old != new | is.na(old)) verbose_new <- verbose_new %pm>% pm_filter(old != new | is.na(old))
# save changes to data set 'verbose_info' # 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 # count adds and changes
track_changes$added <- track_changes$added + verbose_new %pm>% track_changes$added <- track_changes$added + verbose_new %pm>%
pm_filter(is.na(old)) %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), ")"), "` (", ab_name(names(agents), tolower = TRUE, language = NULL), ")"),
collapse = scope_txt), collapse = scope_txt),
operator, toString(result), as_note = FALSE) 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)) filtered <- sapply(x_transposed, function(y) scope_fn(y %in% result, na.rm = TRUE))
x <- x[which(filtered), , drop = FALSE] x <- x[which(filtered), , drop = FALSE]
class(x) <- x_class class(x) <- x_class

9
R/ggplot_pca.R
View File

@ -314,11 +314,13 @@ pca_calculations <- function(pca_model,
# Scores # Scores
choices <- pmin(choices, ncol(u)) choices <- pmin(choices, ncol(u))
obs.scale <- 1 - as.integer(scale) 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 # Directions
v <- sweep(v, 2, d ^ as.integer(scale), FUN = "*") 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.u) <- c("xvar", "yvar")
names(df.v) <- names(df.u) names(df.v) <- names(df.u)
@ -356,7 +358,8 @@ pca_calculations <- function(pca_model,
if (nrow(x) <= 2) { if (nrow(x) <= 2) {
return(data.frame(X1 = numeric(0), return(data.frame(X1 = numeric(0),
X2 = numeric(0), X2 = numeric(0),
groups = character(0))) groups = character(0),
stringsAsFactors = FALSE))
} }
sigma <- var(cbind(x$xvar, x$yvar)) sigma <- var(cbind(x$xvar, x$yvar))
mu <- c(mean(x$xvar), mean(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] vectr_antibiotics <- vectr_antibiotics[!is.na(vectr_antibiotics) & nchar(vectr_antibiotics) >= 3]
x_columns <- sapply(colnames(x), function(col, df = x_bak) { x_columns <- sapply(colnames(x), function(col, df = x_bak) {
if (toupper(col) %in% vectr_antibiotics | if (toupper(col) %in% vectr_antibiotics |
is.rsi(as.data.frame(df)[, col, drop = TRUE]) | is.rsi(as.data.frame(df, stringsAsFactors = FALSE)[, col, drop = TRUE]) |
is.rsi.eligible(as.data.frame(df)[, col, drop = TRUE], threshold = 0.5)) { is.rsi.eligible(as.data.frame(df, stringsAsFactors = FALSE)[, col, drop = TRUE],
threshold = 0.5)) {
return(col) return(col)
} else { } else {
return(NA_character_) 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 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), 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] df_trans <- df_trans[!is.na(df_trans$abcode), , drop = FALSE]
x <- as.character(df_trans$colnames) x <- as.character(df_trans$colnames)
names(x) <- df_trans$abcode names(x) <- df_trans$abcode
@ -197,7 +199,7 @@ get_column_abx <- function(x,
# succeeded with auto-guessing # succeeded with auto-guessing
if (info == TRUE) { 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))) { 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[!ab_missing(cols)]
cols <- cols[!is.na(cols)] cols <- cols[!is.na(cols)]
if (length(rows) > 0 & length(cols) > 0) { 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, x[rows, "columns_nonsusceptible"] <<- sapply(rows,
function(row, group_vct = cols) { function(row, group_vct = cols) {
cols_nonsus <- sapply(x[row, group_vct, drop = FALSE], cols_nonsus <- sapply(x[row, group_vct, drop = FALSE],
@ -589,7 +591,8 @@ mdro <- function(x,
} else if (any_all == "all") { } else if (any_all == "all") {
search_function <- 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 <- sapply(x_transposed, function(y) search_function(y %in% search_result, na.rm = TRUE))
row_filter <- x[which(row_filter), "row_number", drop = TRUE] row_filter <- x[which(row_filter), "row_number", drop = TRUE]
rows <- rows[rows %in% row_filter] rows <- rows[rows %in% row_filter]
@ -604,7 +607,9 @@ mdro <- function(x,
if (length(rows) > 0) { if (length(rows) > 0) {
# function specific for the CMI paper of 2012 (Magiorakos et al.) # function specific for the CMI paper of 2012 (Magiorakos et al.)
lst_vector <- unlist(lst)[!is.na(unlist(lst))] 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_in_guideline"] <<- length(lst)
x[rows, "classes_available"] <<- sapply(rows, x[rows, "classes_available"] <<- sapply(rows,
function(row, group_tbl = lst) { function(row, group_tbl = lst) {
@ -627,13 +632,14 @@ mdro <- function(x,
na.rm = TRUE) na.rm = TRUE)
}) })
# for PDR; all agents are R (or I if combine_SI = FALSE) # 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)) row_filter <- sapply(x_transposed, function(y) all(y %in% search_result, na.rm = TRUE))
x[which(row_filter), "classes_affected"] <<- 999 x[which(row_filter), "classes_affected"] <<- 999
} }
if (info == TRUE) { 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, format_uncertainty_as_df(uncertainty_level = uncertainty,
input = input, input = input,
result_mo = res_df[1, "mo", drop = TRUE], 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)))] res[seq_len(min(n, length(res)))]
} }
@ -819,7 +820,8 @@ exec_as.mo <- function(x,
uncertainties <- rbind(uncertainties, uncertainties <- rbind(uncertainties,
format_uncertainty_as_df(uncertainty_level = 1, format_uncertainty_as_df(uncertainty_level = 1,
input = x_backup[i], 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 next
} }
} }
@ -1022,7 +1024,8 @@ exec_as.mo <- function(x,
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level, format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup, 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) return(x)
} }
@ -1043,7 +1046,8 @@ exec_as.mo <- function(x,
if (!empty_result(found)) { if (!empty_result(found)) {
found_result <- found found_result <- found
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
attr(found, which = "uncertainties", exact = TRUE)) attr(found, which = "uncertainties", exact = TRUE),
stringsAsFactors = FALSE)
found <- lookup(mo == found) found <- lookup(mo == found)
return(found) return(found)
} }
@ -1071,7 +1075,8 @@ exec_as.mo <- function(x,
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level, format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup, input = a.x_backup,
result_mo = found_result)) result_mo = found_result),
stringsAsFactors = FALSE)
return(found) return(found)
} }
} }
@ -1095,7 +1100,8 @@ exec_as.mo <- function(x,
if (!empty_result(found) & nchar(g.x_backup_without_spp) >= 6) { if (!empty_result(found) & nchar(g.x_backup_without_spp) >= 6) {
found_result <- found found_result <- found
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
attr(found, which = "uncertainties", exact = TRUE)) attr(found, which = "uncertainties", exact = TRUE),
stringsAsFactors = FALSE)
found <- lookup(mo == found) found <- lookup(mo == found)
return(found) return(found)
} }
@ -1118,7 +1124,8 @@ exec_as.mo <- function(x,
if (!empty_result(found) & nchar(g.x_backup_without_spp) >= 6) { if (!empty_result(found) & nchar(g.x_backup_without_spp) >= 6) {
found_result <- found found_result <- found
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
attr(found, which = "uncertainties", exact = TRUE)) attr(found, which = "uncertainties", exact = TRUE),
stringsAsFactors = FALSE)
found <- lookup(mo == found) found <- lookup(mo == found)
return(found) return(found)
} }
@ -1147,7 +1154,8 @@ exec_as.mo <- function(x,
if (!empty_result(found)) { if (!empty_result(found)) {
found_result <- found found_result <- found
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
attr(found, which = "uncertainties", exact = TRUE)) attr(found, which = "uncertainties", exact = TRUE),
stringsAsFactors = FALSE)
found <- lookup(mo == found) found <- lookup(mo == found)
return(found) return(found)
} }
@ -1175,7 +1183,8 @@ exec_as.mo <- function(x,
if (!empty_result(found)) { if (!empty_result(found)) {
found_result <- found found_result <- found
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
attr(found, which = "uncertainties", exact = TRUE)) attr(found, which = "uncertainties", exact = TRUE),
stringsAsFactors = FALSE)
found <- lookup(mo == found) found <- lookup(mo == found)
return(found) return(found)
} }
@ -1193,7 +1202,8 @@ exec_as.mo <- function(x,
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level, format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup, input = a.x_backup,
result_mo = found_result)) result_mo = found_result),
stringsAsFactors = FALSE)
return(found) return(found)
} }
if (b.x_trimmed %like_case% "(fungus|fungi)" & !b.x_trimmed %like_case% "fungiphrya") { 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, uncertainties <<- rbind(uncertainties,
format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level, format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup, input = a.x_backup,
result_mo = found_result)) result_mo = found_result),
stringsAsFactors = FALSE)
return(found) return(found)
} }
# (9) try to strip off one element from start and check the remains (only allow >= 2-part name outcome) ---- # (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) # uncertainty level 2 only if searched part contains a space (otherwise it will be found with lvl 3)
if (x_strip_collapsed %like_case% " ") { if (x_strip_collapsed %like_case% " ") {
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
attr(found, which = "uncertainties", exact = TRUE)) attr(found, which = "uncertainties", exact = TRUE),
stringsAsFactors = FALSE)
found <- lookup(mo == found) found <- lookup(mo == found)
return(found) return(found)
} }
@ -1261,7 +1273,8 @@ exec_as.mo <- function(x,
if (!empty_result(found)) { if (!empty_result(found)) {
found_result <- found found_result <- found
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
attr(found, which = "uncertainties", exact = TRUE)) attr(found, which = "uncertainties", exact = TRUE),
stringsAsFactors = FALSE)
found <- lookup(mo == found) found <- lookup(mo == found)
return(found) return(found)
} }
@ -1287,7 +1300,8 @@ exec_as.mo <- function(x,
if (!empty_result(found)) { if (!empty_result(found)) {
found_result <- found found_result <- found
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
attr(found, which = "uncertainties", exact = TRUE)) attr(found, which = "uncertainties", exact = TRUE),
stringsAsFactors = FALSE)
found <- lookup(mo == found) found <- lookup(mo == found)
return(found) return(found)
} }
@ -1305,7 +1319,8 @@ exec_as.mo <- function(x,
if (!is.na(found) & nchar(g.x_backup_without_spp) >= 6) { if (!is.na(found) & nchar(g.x_backup_without_spp) >= 6) {
found_result <- lookup(mo == found) found_result <- lookup(mo == found)
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
attr(found, which = "uncertainties", exact = TRUE)) attr(found, which = "uncertainties", exact = TRUE),
stringsAsFactors = FALSE)
found <- lookup(mo == found) found <- lookup(mo == found)
return(found) return(found)
} }
@ -1498,7 +1513,8 @@ exec_as.mo <- function(x,
format_uncertainty_as_df(uncertainty_level = actual_uncertainty, format_uncertainty_as_df(uncertainty_level = actual_uncertainty,
input = actual_input, input = actual_input,
result_mo = x, 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 # 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) x <- structure(x, uncertainties = uncertainties)
@ -1520,7 +1536,9 @@ was_renamed <- function(name_old, name_new, ref_old = "", ref_new = "", mo = "")
stringsAsFactors = FALSE) stringsAsFactors = FALSE)
already_set <- getOption("mo_renamed") already_set <- getOption("mo_renamed")
if (!is.null(already_set)) { if (!is.null(already_set)) {
options(mo_renamed = rbind(already_set, newly_set)) options(mo_renamed = rbind(already_set,
newly_set,
stringsAsFactors = FALSE))
} else { } else {
options(mo_renamed = newly_set) options(mo_renamed = newly_set)
} }
@ -1791,7 +1809,7 @@ print.mo_uncertainties <- function(x, ...) {
mo_renamed <- function() { mo_renamed <- function() {
items <- getOption("mo_renamed", default = NULL) items <- getOption("mo_renamed", default = NULL)
if (is.null(items)) { if (is.null(items)) {
items <- data.frame() items <- data.frame(stringsAsFactors = FALSE)
} else { } else {
items <- pm_distinct(items, old_name, .keep_all = TRUE) 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 # remove rows with NAs
df <- subset(df, !is.na(df[, col_ab, drop = TRUE])) df <- subset(df, !is.na(df[, col_ab, drop = TRUE]))
df$year <- year(df[, col_date, 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)) df$year <- as.integer(rownames(df))
rownames(df) <- NULL 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 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 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 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 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. #' @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 #' @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 = ", ")`. #' 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 #' ## After interpretation
#' #'
@ -294,6 +295,7 @@ as.rsi.mic <- function(x,
uti = FALSE, uti = FALSE,
conserve_capped_values = FALSE, conserve_capped_values = FALSE,
add_intrinsic_resistance = FALSE, add_intrinsic_resistance = FALSE,
reference_data = AMR::rsi_translation,
...) { ...) {
meet_criteria(x) meet_criteria(x)
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE) 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(uti, allow_class = "logical", has_length = c(1, length(x)))
meet_criteria(conserve_capped_values, allow_class = "logical", has_length = 1) meet_criteria(conserve_capped_values, allow_class = "logical", has_length = 1)
meet_criteria(add_intrinsic_resistance, 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() # for dplyr's across()
cur_column_dplyr <- import_fn("cur_column", "dplyr", error_on_fail = FALSE) 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)) { if (is.null(mo)) {
stop_('No information was supplied about the microorganisms (missing parameter "mo"). See ?as.rsi.\n\n', 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", "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",
"`data %>% mutate_at(vars(...), as.rsi, mo = .$x)`, where x is your column with microorganisms.\n\n",
"To tranform all MIC values in a data set, use `data %>% as.rsi()` or data %>% mutate_if(is.mic, as.rsi).", call = FALSE) "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") { if (length(ab) == 1 && ab %like% "as.mic") {
@ -338,7 +341,7 @@ as.rsi.mic <- function(x,
ab_coerced <- suppressWarnings(as.ab(ab)) ab_coerced <- suppressWarnings(as.ab(ab))
mo_coerced <- suppressWarnings(as.mo(mo)) mo_coerced <- suppressWarnings(as.mo(mo))
guideline_coerced <- get_guideline(guideline) guideline_coerced <- get_guideline(guideline, reference_data)
if (is.na(ab_coerced)) { if (is.na(ab_coerced)) {
message_("Returning NAs for unknown drug: `", font_bold(ab), 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().", "`. 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, guideline = guideline_coerced,
uti = uti, uti = uti,
conserve_capped_values = conserve_capped_values, 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 result
} }
@ -379,6 +383,7 @@ as.rsi.disk <- function(x,
guideline = "EUCAST", guideline = "EUCAST",
uti = FALSE, uti = FALSE,
add_intrinsic_resistance = FALSE, add_intrinsic_resistance = FALSE,
reference_data = AMR::rsi_translation,
...) { ...) {
meet_criteria(x) meet_criteria(x)
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE) 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(guideline, allow_class = "character", has_length = 1)
meet_criteria(uti, allow_class = "logical", has_length = c(1, length(x))) 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(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() # for dplyr's across()
cur_column_dplyr <- import_fn("cur_column", "dplyr", error_on_fail = FALSE) 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)) { if (is.null(mo)) {
stop_('No information was supplied about the microorganisms (missing parameter "mo"). See ?as.rsi.\n\n', 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", "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",
"`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 `data %>% as.rsi()` or data %>% mutate_if(is.disk, as.rsi).", call = FALSE) "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") { if (length(ab) == 1 && ab %like% "as.disk") {
@ -422,7 +428,7 @@ as.rsi.disk <- function(x,
ab_coerced <- suppressWarnings(as.ab(ab)) ab_coerced <- suppressWarnings(as.ab(ab))
mo_coerced <- suppressWarnings(as.mo(mo)) mo_coerced <- suppressWarnings(as.mo(mo))
guideline_coerced <- get_guideline(guideline) guideline_coerced <- get_guideline(guideline, reference_data)
if (is.na(ab_coerced)) { if (is.na(ab_coerced)) {
message_("Returning NAs for unknown drug: `", font_bold(ab), 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().", "`. 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, guideline = guideline_coerced,
uti = uti, uti = uti,
conserve_capped_values = FALSE, 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 result
} }
@ -461,13 +468,15 @@ as.rsi.data.frame <- function(x,
guideline = "EUCAST", guideline = "EUCAST",
uti = NULL, uti = NULL,
conserve_capped_values = FALSE, 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(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(col_mo, allow_class = "character", is_in = colnames(x), allow_NULL = TRUE)
meet_criteria(guideline, allow_class = "character", has_length = 1) meet_criteria(guideline, allow_class = "character", has_length = 1)
meet_criteria(uti, allow_class = c("logical", "character"), allow_NULL = TRUE) meet_criteria(uti, allow_class = c("logical", "character"), allow_NULL = TRUE)
meet_criteria(conserve_capped_values, allow_class = "logical", has_length = 1) meet_criteria(conserve_capped_values, allow_class = "logical", has_length = 1)
meet_criteria(add_intrinsic_resistance, 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))) { for (i in seq_len(ncol(x))) {
# don't keep factors # don't keep factors
@ -574,18 +583,28 @@ as.rsi.data.frame <- function(x,
for (i in seq_len(length(ab_cols))) { for (i in seq_len(length(ab_cols))) {
if (types[i] == "mic") { if (types[i] == "mic") {
x[, ab_cols[i]] <- as.rsi.mic(x = x %pm>% pm_pull(ab_cols[i]), x[, ab_cols[i]] <- as.rsi(x = x %pm>%
mo = x_mo, pm_pull(ab_cols[i]) %pm>%
ab = ab_cols[i], as.character() %pm>%
guideline = guideline, as.mic(),
uti = uti, mo = x_mo,
conserve_capped_values = conserve_capped_values) 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") { } else if (types[i] == "disk") {
x[, ab_cols[i]] <- as.rsi.disk(x = x %pm>% pm_pull(ab_cols[i]), x[, ab_cols[i]] <- as.rsi(x = x %pm>%
mo = x_mo, pm_pull(ab_cols[i]) %pm>%
ab = ab_cols[i], as.character() %pm>%
guideline = guideline, as.disk(),
uti = uti) 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") { } else if (types[i] == "rsi") {
ab <- ab_cols[i] ab <- ab_cols[i]
ab_coerced <- suppressWarnings(as.ab(ab)) ab_coerced <- suppressWarnings(as.ab(ab))
@ -595,26 +614,26 @@ as.rsi.data.frame <- function(x,
appendLF = FALSE, appendLF = FALSE,
as_note = FALSE) as_note = FALSE)
x[, ab_cols[i]] <- as.rsi.default(x = x %pm>% pm_pull(ab_cols[i])) 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 x
} }
get_guideline <- function(guideline) { get_guideline <- function(guideline, reference_data) {
guideline_param <- toupper(guideline) guideline_param <- toupper(guideline)
if (guideline_param %in% c("CLSI", "EUCAST")) { 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% " ") { if (!guideline_param %like% " ") {
# like 'EUCAST2020', should be 'EUCAST 2020' # like 'EUCAST2020', should be 'EUCAST 2020'
guideline_param <- gsub("([a-z]+)([0-9]+)", "\\1 \\2", guideline_param, ignore.case = TRUE) 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, "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 guideline_param
@ -631,7 +650,7 @@ exec_as.rsi <- function(method,
metadata_mo <- get_mo_failures_uncertainties_renamed() 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) df <- unique(data.frame(x, mo), stringsAsFactors = FALSE)
x <- df$x x <- df$x
mo <- df$mo mo <- df$mo
@ -661,14 +680,14 @@ exec_as.rsi <- function(method,
} }
mo_other <- as.mo(rep("UNKNOWN", length(mo))) mo_other <- as.mo(rep("UNKNOWN", length(mo)))
guideline_coerced <- get_guideline(guideline) guideline_coerced <- get_guideline(guideline, reference_data)
if (guideline_coerced != guideline) { if (guideline_coerced != guideline) {
message_("Using guideline ", font_bold(guideline_coerced), " as input for `guideline`.") message_("Using guideline ", font_bold(guideline_coerced), " as input for `guideline`.")
} }
new_rsi <- rep(NA_character_, length(x)) new_rsi <- rep(NA_character_, length(x))
ab_param <- ab ab_param <- ab
trans <- rsi_translation %pm>% trans <- reference_data %pm>%
subset(guideline == guideline_coerced & method == method_param & ab == ab_param) subset(guideline == guideline_coerced & method == method_param & ab == ab_param)
trans$lookup <- paste(trans$mo, trans$ab) 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)) { if (all(trans$uti == TRUE, na.rm = TRUE) & all(uti == FALSE)) {
message_("WARNING.", add_fn = list(font_red, font_bold), as_note = 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 warned <- TRUE
} }
@ -757,11 +776,13 @@ exec_as.rsi <- function(method,
} }
new_rsi <- x_bak %pm>% 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) pm_pull(new_rsi)
if (warned == FALSE) { 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) 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) data$s <- round((data$n / sum(data$n)) * 100, 1)
if (!"S" %in% data$x) { 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) { 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) { 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() # don't use as.rsi() here, it will confuse plot()
@ -1037,3 +1061,17 @@ unique.rsi <- function(x, incomparables = FALSE, ...) {
attributes(y) <- attributes(x) attributes(y) <- attributes(x)
y 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) 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) { if (only_all_tested == TRUE) {
# no NAs in any column # no NAs in any column
y <- apply(X = as.data.frame(lapply(x, as.integer), stringsAsFactors = FALSE), 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 { } else {
values <- factor(values, levels = c("S", "I", "R"), ordered = TRUE) 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$interpretation <- rownames(col_results)
col_results$isolates <- col_results[, 1, drop = TRUE] col_results$isolates <- col_results[, 1, drop = TRUE]
if (NROW(col_results) > 0 && sum(col_results$isolates, na.rm = TRUE) > 0) { 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_new <- cbind(group_values, out_new)
} }
out <- rbind(out, out_new) out <- rbind(out, out_new, stringsAsFactors = FALSE)
} }
} }
out out

2
docs/404.html
View File

@ -81,7 +81,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="https://msberends.github.io/AMR//index.html">AMR (for R)</a> <a class="navbar-link" href="https://msberends.github.io/AMR//index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9016</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9017</span>
</span> </span>
</div> </div>

2
docs/LICENSE-text.html
View File

@ -81,7 +81,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="index.html">AMR (for R)</a> <a class="navbar-link" href="index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9016</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9017</span>
</span> </span>
</div> </div>

2
docs/articles/index.html
View File

@ -81,7 +81,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a> <a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9016</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9017</span>
</span> </span>
</div> </div>

2
docs/authors.html
View File

@ -81,7 +81,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="index.html">AMR (for R)</a> <a class="navbar-link" href="index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9016</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9017</span>
</span> </span>
</div> </div>

2
docs/index.html
View File

@ -43,7 +43,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="index.html">AMR (for R)</a> <a class="navbar-link" href="index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9016</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9017</span>
</span> </span>
</div> </div>

15
docs/news/index.html
View File

@ -81,7 +81,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a> <a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9016</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9017</span>
</span> </span>
</div> </div>
@ -236,13 +236,13 @@
<small>Source: <a href='https://github.com/msberends/AMR/blob/master/NEWS.md'><code>NEWS.md</code></a></small> <small>Source: <a href='https://github.com/msberends/AMR/blob/master/NEWS.md'><code>NEWS.md</code></a></small>
</div> </div>
<div id="amr-1409016" class="section level1"> <div id="amr-1409017" class="section level1">
<h1 class="page-header" data-toc-text="1.4.0.9016"> <h1 class="page-header" data-toc-text="1.4.0.9017">
<a href="#amr-1409016" class="anchor"></a>AMR 1.4.0.9016<small> Unreleased </small> <a href="#amr-1409017" class="anchor"></a>AMR 1.4.0.9017<small> Unreleased </small>
</h1> </h1>
<div id="last-updated-10-november-2020" class="section level2"> <div id="last-updated-11-november-2020" class="section level2">
<h2 class="hasAnchor"> <h2 class="hasAnchor">
<a href="#last-updated-10-november-2020" class="anchor"></a><small>Last updated: 10 November 2020</small> <a href="#last-updated-11-november-2020" class="anchor"></a><small>Last updated: 11 November 2020</small>
</h2> </h2>
<div id="new" class="section level3"> <div id="new" class="section level3">
<h3 class="hasAnchor"> <h3 class="hasAnchor">
@ -252,7 +252,7 @@
<p>Functions <code><a href="../reference/mo_property.html">is_gram_negative()</a></code> and <code><a href="../reference/mo_property.html">is_gram_positive()</a></code> as wrappers around <code><a href="../reference/mo_property.html">mo_gramstain()</a></code>. They always return <code>TRUE</code> or <code>FALSE</code> (except when the input is <code>NA</code> or the MO code is <code>UNKNOWN</code>), thus always return <code>FALSE</code> for species outside the taxonomic kingdom of Bacteria. If you have the <code>dplyr</code> package installed, they can even determine the column with microorganisms themselves inside <code>dplyr</code> functions:</p> <p>Functions <code><a href="../reference/mo_property.html">is_gram_negative()</a></code> and <code><a href="../reference/mo_property.html">is_gram_positive()</a></code> as wrappers around <code><a href="../reference/mo_property.html">mo_gramstain()</a></code>. They always return <code>TRUE</code> or <code>FALSE</code> (except when the input is <code>NA</code> or the MO code is <code>UNKNOWN</code>), thus always return <code>FALSE</code> for species outside the taxonomic kingdom of Bacteria. If you have the <code>dplyr</code> package installed, they can even determine the column with microorganisms themselves inside <code>dplyr</code> functions:</p>
<div class="sourceCode" id="cb1"><pre class="downlit"> <div class="sourceCode" id="cb1"><pre class="downlit">
<span class="va">example_isolates</span> <span class="op">%&gt;%</span> <span class="va">example_isolates</span> <span class="op">%&gt;%</span>
<span class="fu"><a href="https://rdrr.io/r/stats/filter.html">filter</a></span><span class="op">(</span><span class="fu"><a href="../reference/mo_property.html">is_gram_positive</a></span><span class="op">(</span><span class="op">)</span><span class="op">)</span> <span class="fu"><a href="https://dplyr.tidyverse.org/reference/filter.html">filter</a></span><span class="op">(</span><span class="fu"><a href="../reference/mo_property.html">is_gram_positive</a></span><span class="op">(</span><span class="op">)</span><span class="op">)</span>
<span class="co">#&gt; NOTE: Using column `mo` as input for 'x'</span></pre></div> <span class="co">#&gt; NOTE: Using column `mo` as input for 'x'</span></pre></div>
</li> </li>
<li><p>Functions <code><a href="../reference/like.html">%not_like%</a></code> and <code><a href="../reference/like.html">%not_like_case%</a></code> as wrappers around <code><a href="../reference/like.html">%like%</a></code> and <code><a href="../reference/like.html">%like_case%</a></code>. The RStudio addin to insert the text " %like% " as provided in this package now iterates over all like variants. So if you have defined the keyboard shortcut Ctrl/Cmd + L to this addin, it will first insert <code><a href="../reference/like.html">%like%</a></code> and by pressing it again it will be replaced with <code><a href="../reference/like.html">%not_like%</a></code>, etc.</p></li> <li><p>Functions <code><a href="../reference/like.html">%not_like%</a></code> and <code><a href="../reference/like.html">%not_like_case%</a></code> as wrappers around <code><a href="../reference/like.html">%like%</a></code> and <code><a href="../reference/like.html">%like_case%</a></code>. The RStudio addin to insert the text " %like% " as provided in this package now iterates over all like variants. So if you have defined the keyboard shortcut Ctrl/Cmd + L to this addin, it will first insert <code><a href="../reference/like.html">%like%</a></code> and by pressing it again it will be replaced with <code><a href="../reference/like.html">%not_like%</a></code>, etc.</p></li>
@ -262,6 +262,7 @@
<h3 class="hasAnchor"> <h3 class="hasAnchor">
<a href="#changed" class="anchor"></a>Changed</h3> <a href="#changed" class="anchor"></a>Changed</h3>
<ul> <ul>
<li>Reference data used for <code><a href="../reference/as.rsi.html">as.rsi()</a></code> can now be set by the user, using the <code>reference_data</code> parameter.</li>
<li>For all function parameters in the code, it is now defined what the exact type of user input should be (inspired by the <a href="https://github.com/moodymudskipper/typed"><code>typed</code></a> package). If the user input for a certain function does not meet the requirements for a specific parameter (such as the class or length), an informative error will be thrown. This makes the package more robust and the use of it more reproducible and reliable. In total, more than 400 arguments were defined.</li> <li>For all function parameters in the code, it is now defined what the exact type of user input should be (inspired by the <a href="https://github.com/moodymudskipper/typed"><code>typed</code></a> package). If the user input for a certain function does not meet the requirements for a specific parameter (such as the class or length), an informative error will be thrown. This makes the package more robust and the use of it more reproducible and reliable. In total, more than 400 arguments were defined.</li>
<li>Deprecated function <code><a href="../reference/AMR-deprecated.html">p_symbol()</a></code> that not really fits the scope of this package. It will be removed in a future version. See <a href="https://github.com/msberends/AMR/blob/v1.4.0/R/p_symbol.R">here</a> for the source code to preserve it.</li> <li>Deprecated function <code><a href="../reference/AMR-deprecated.html">p_symbol()</a></code> that not really fits the scope of this package. It will be removed in a future version. See <a href="https://github.com/msberends/AMR/blob/v1.4.0/R/p_symbol.R">here</a> for the source code to preserve it.</li>
<li>Better determination of disk zones and MIC values when running <code><a href="../reference/as.rsi.html">as.rsi()</a></code> on a data.frame</li> <li>Better determination of disk zones and MIC values when running <code><a href="../reference/as.rsi.html">as.rsi()</a></code> on a data.frame</li>

2
docs/pkgdown.yml
View File

@ -12,7 +12,7 @@ articles:
datasets: datasets.html datasets: datasets.html
resistance_predict: resistance_predict.html resistance_predict: resistance_predict.html
welcome_to_AMR: welcome_to_AMR.html welcome_to_AMR: welcome_to_AMR.html
last_built: 2020-11-10T18:58Z last_built: 2020-11-11T15:44Z
urls: urls:
reference: https://msberends.github.io/AMR//reference reference: https://msberends.github.io/AMR//reference
article: https://msberends.github.io/AMR//articles article: https://msberends.github.io/AMR//articles

13
docs/reference/as.rsi.html
View File

@ -82,7 +82,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a> <a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9008</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9017</span>
</span> </span>
</div> </div>
@ -257,6 +257,7 @@
uti <span class='op'>=</span> <span class='cn'>FALSE</span>, uti <span class='op'>=</span> <span class='cn'>FALSE</span>,
conserve_capped_values <span class='op'>=</span> <span class='cn'>FALSE</span>, conserve_capped_values <span class='op'>=</span> <span class='cn'>FALSE</span>,
add_intrinsic_resistance <span class='op'>=</span> <span class='cn'>FALSE</span>, add_intrinsic_resistance <span class='op'>=</span> <span class='cn'>FALSE</span>,
reference_data <span class='op'>=</span> <span class='fu'>AMR</span><span class='fu'>::</span><span class='va'><a href='rsi_translation.html'>rsi_translation</a></span>,
<span class='va'>...</span> <span class='va'>...</span>
<span class='op'>)</span> <span class='op'>)</span>
@ -268,6 +269,7 @@
guideline <span class='op'>=</span> <span class='st'>"EUCAST"</span>, guideline <span class='op'>=</span> <span class='st'>"EUCAST"</span>,
uti <span class='op'>=</span> <span class='cn'>FALSE</span>, uti <span class='op'>=</span> <span class='cn'>FALSE</span>,
add_intrinsic_resistance <span class='op'>=</span> <span class='cn'>FALSE</span>, add_intrinsic_resistance <span class='op'>=</span> <span class='cn'>FALSE</span>,
reference_data <span class='op'>=</span> <span class='fu'>AMR</span><span class='fu'>::</span><span class='va'><a href='rsi_translation.html'>rsi_translation</a></span>,
<span class='va'>...</span> <span class='va'>...</span>
<span class='op'>)</span> <span class='op'>)</span>
@ -279,7 +281,8 @@
guideline <span class='op'>=</span> <span class='st'>"EUCAST"</span>, guideline <span class='op'>=</span> <span class='st'>"EUCAST"</span>,
uti <span class='op'>=</span> <span class='cn'>NULL</span>, uti <span class='op'>=</span> <span class='cn'>NULL</span>,
conserve_capped_values <span class='op'>=</span> <span class='cn'>FALSE</span>, conserve_capped_values <span class='op'>=</span> <span class='cn'>FALSE</span>,
add_intrinsic_resistance <span class='op'>=</span> <span class='cn'>FALSE</span> add_intrinsic_resistance <span class='op'>=</span> <span class='cn'>FALSE</span>,
reference_data <span class='op'>=</span> <span class='va'>rsi_translation</span>
<span class='op'>)</span></pre> <span class='op'>)</span></pre>
<h2 class="hasAnchor" id="arguments"><a class="anchor" href="#arguments"></a>Arguments</h2> <h2 class="hasAnchor" id="arguments"><a class="anchor" href="#arguments"></a>Arguments</h2>
@ -322,6 +325,10 @@
<td><p><em>(only useful when using a EUCAST guideline)</em> 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 <em>Klebsiella</em> species. Determination is based on the <a href='intrinsic_resistant.html'>intrinsic_resistant</a> data set, that itself is based on 'EUCAST Expert Rules, Intrinsic Resistance and Exceptional Phenotypes', version list(version_txt = "v3.1", year = 2016, title = "EUCAST Expert Rules, Intrinsic Resistance and Exceptional Phenotypes") <td><p><em>(only useful when using a EUCAST guideline)</em> 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 <em>Klebsiella</em> species. Determination is based on the <a href='intrinsic_resistant.html'>intrinsic_resistant</a> data set, that itself is based on 'EUCAST Expert Rules, Intrinsic Resistance and Exceptional Phenotypes', version list(version_txt = "v3.1", year = 2016, title = "EUCAST Expert Rules, Intrinsic Resistance and Exceptional Phenotypes")
list(version_txt = "v3.2", year = 2020, title = "EUCAST Expert Rules / EUCAST Intrinsic Resistance and Unusual Phenotypes").</p></td> list(version_txt = "v3.2", year = 2020, title = "EUCAST Expert Rules / EUCAST Intrinsic Resistance and Unusual Phenotypes").</p></td>
</tr> </tr>
<tr>
<th>reference_data</th>
<td><p>a <a href='https://rdrr.io/r/base/data.frame.html'>data.frame</a> to be used for interpretation, which defaults to the <a href='rsi_translation.html'>rsi_translation</a> 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 <a href='rsi_translation.html'>rsi_translation</a> 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 <code>as.rsi()</code>.</p></td>
</tr>
<tr> <tr>
<th>col_mo</th> <th>col_mo</th>
<td><p>column name of the IDs of the microorganisms (see <code><a href='as.mo.html'>as.mo()</a></code>), defaults to the first column of class <code><a href='as.mo.html'>mo</a></code>. Values will be coerced using <code><a href='as.mo.html'>as.mo()</a></code>.</p></td> <td><p>column name of the IDs of the microorganisms (see <code><a href='as.mo.html'>as.mo()</a></code>), defaults to the first column of class <code><a href='as.mo.html'>mo</a></code>. Values will be coerced using <code><a href='as.mo.html'>as.mo()</a></code>.</p></td>
@ -358,7 +365,7 @@ list(version_txt = "v3.2", year = 2020, title = "EUCAST Expert Rules / EUCAST In
<p>For interpreting MIC values as well as disk diffusion diameters, supported guidelines to be used as input for the <code>guideline</code> parameter are: "CLSI 2010", "CLSI 2011", "CLSI 2012", "CLSI 2013", "CLSI 2014", "CLSI 2015", "CLSI 2016", "CLSI 2017", "CLSI 2018", "CLSI 2019", "EUCAST 2011", "EUCAST 2012", "EUCAST 2013", "EUCAST 2014", "EUCAST 2015", "EUCAST 2016", "EUCAST 2017", "EUCAST 2018", "EUCAST 2019", "EUCAST 2020".</p> <p>For interpreting MIC values as well as disk diffusion diameters, supported guidelines to be used as input for the <code>guideline</code> parameter are: "CLSI 2010", "CLSI 2011", "CLSI 2012", "CLSI 2013", "CLSI 2014", "CLSI 2015", "CLSI 2016", "CLSI 2017", "CLSI 2018", "CLSI 2019", "EUCAST 2011", "EUCAST 2012", "EUCAST 2013", "EUCAST 2014", "EUCAST 2015", "EUCAST 2016", "EUCAST 2017", "EUCAST 2018", "EUCAST 2019", "EUCAST 2020".</p>
<p>Simply using <code>"CLSI"</code> or <code>"EUCAST"</code> as input will automatically select the latest version of that guideline.</p> <p>Simply using <code>"CLSI"</code> or <code>"EUCAST"</code> as input will automatically select the latest version of that guideline. You can set your own data set using the <code>reference_data</code> parameter.</p>
<h3 class='hasAnchor' id='arguments'><a class='anchor' href='#arguments'></a>After interpretation</h3> <h3 class='hasAnchor' id='arguments'><a class='anchor' href='#arguments'></a>After interpretation</h3>

2
docs/reference/index.html
View File

@ -81,7 +81,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a> <a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9016</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9017</span>
</span> </span>
</div> </div>

2
docs/survey.html
View File

@ -81,7 +81,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="index.html">AMR (for R)</a> <a class="navbar-link" href="index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9016</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9017</span>
</span> </span>
</div> </div>

9
man/as.rsi.Rd
View File

@ -24,6 +24,7 @@ is.rsi.eligible(x, threshold = 0.05)
uti = FALSE, uti = FALSE,
conserve_capped_values = FALSE, conserve_capped_values = FALSE,
add_intrinsic_resistance = FALSE, add_intrinsic_resistance = FALSE,
reference_data = AMR::rsi_translation,
... ...
) )
@ -34,6 +35,7 @@ is.rsi.eligible(x, threshold = 0.05)
guideline = "EUCAST", guideline = "EUCAST",
uti = FALSE, uti = FALSE,
add_intrinsic_resistance = FALSE, add_intrinsic_resistance = FALSE,
reference_data = AMR::rsi_translation,
... ...
) )
@ -44,7 +46,8 @@ is.rsi.eligible(x, threshold = 0.05)
guideline = "EUCAST", guideline = "EUCAST",
uti = NULL, uti = NULL,
conserve_capped_values = FALSE, conserve_capped_values = FALSE,
add_intrinsic_resistance = FALSE add_intrinsic_resistance = FALSE,
reference_data = rsi_translation
) )
} }
\arguments{ \arguments{
@ -67,6 +70,8 @@ is.rsi.eligible(x, threshold = 0.05)
\item{add_intrinsic_resistance}{\emph{(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 \emph{Klebsiella} species. Determination is based on the \link{intrinsic_resistant} data set, that itself is based on 'EUCAST Expert Rules, Intrinsic Resistance and Exceptional Phenotypes', version list(version_txt = "v3.1", year = 2016, title = "EUCAST Expert Rules, Intrinsic Resistance and Exceptional Phenotypes") \item{add_intrinsic_resistance}{\emph{(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 \emph{Klebsiella} species. Determination is based on the \link{intrinsic_resistant} data set, that itself is based on 'EUCAST Expert Rules, Intrinsic Resistance and Exceptional Phenotypes', version list(version_txt = "v3.1", year = 2016, title = "EUCAST Expert Rules, Intrinsic Resistance and Exceptional Phenotypes")
list(version_txt = "v3.2", year = 2020, title = "EUCAST Expert Rules / EUCAST Intrinsic Resistance and Unusual Phenotypes").} list(version_txt = "v3.2", year = 2020, title = "EUCAST Expert Rules / EUCAST Intrinsic Resistance and Unusual Phenotypes").}
\item{reference_data}{a \link{data.frame} to be used for interpretation, which defaults to the \link{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 \link{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 \code{\link[=as.rsi]{as.rsi()}}.}
\item{col_mo}{column name of the IDs of the microorganisms (see \code{\link[=as.mo]{as.mo()}}), defaults to the first column of class \code{\link{mo}}. Values will be coerced using \code{\link[=as.mo]{as.mo()}}.} \item{col_mo}{column name of the IDs of the microorganisms (see \code{\link[=as.mo]{as.mo()}}), defaults to the first column of class \code{\link{mo}}. Values will be coerced using \code{\link[=as.mo]{as.mo()}}.}
} }
\value{ \value{
@ -102,7 +107,7 @@ your_data \%>\% mutate(across(where(is.disk), as.rsi)) # since dplyr 1.0.0
For interpreting MIC values as well as disk diffusion diameters, supported guidelines to be used as input for the \code{guideline} parameter are: "CLSI 2010", "CLSI 2011", "CLSI 2012", "CLSI 2013", "CLSI 2014", "CLSI 2015", "CLSI 2016", "CLSI 2017", "CLSI 2018", "CLSI 2019", "EUCAST 2011", "EUCAST 2012", "EUCAST 2013", "EUCAST 2014", "EUCAST 2015", "EUCAST 2016", "EUCAST 2017", "EUCAST 2018", "EUCAST 2019", "EUCAST 2020". For interpreting MIC values as well as disk diffusion diameters, supported guidelines to be used as input for the \code{guideline} parameter are: "CLSI 2010", "CLSI 2011", "CLSI 2012", "CLSI 2013", "CLSI 2014", "CLSI 2015", "CLSI 2016", "CLSI 2017", "CLSI 2018", "CLSI 2019", "EUCAST 2011", "EUCAST 2012", "EUCAST 2013", "EUCAST 2014", "EUCAST 2015", "EUCAST 2016", "EUCAST 2017", "EUCAST 2018", "EUCAST 2019", "EUCAST 2020".
Simply using \code{"CLSI"} or \code{"EUCAST"} as input will automatically select the latest version of that guideline. Simply using \code{"CLSI"} or \code{"EUCAST"} as input will automatically select the latest version of that guideline. You can set your own data set using the \code{reference_data} parameter.
} }
\subsection{After interpretation}{ \subsection{After interpretation}{

12
tests/testthat/test-eucast_rules.R
View File

@ -90,12 +90,12 @@ test_that("EUCAST rules work", {
"R") "R")
# Azithromycin and Clarythromycin must be equal to Erythromycin # Azithromycin and Clarythromycin must be equal to Erythromycin
a <- as.rsi(eucast_rules(data.frame(mo = example_isolates$mo, a <- suppressWarnings(as.rsi(eucast_rules(data.frame(mo = example_isolates$mo,
ERY = example_isolates$ERY, ERY = example_isolates$ERY,
AZM = as.rsi("R"), AZM = as.rsi("R"),
CLR = factor("R"), CLR = factor("R"),
stringsAsFactors = FALSE), stringsAsFactors = FALSE),
version_expertrules = 3.1)$CLR) version_expertrules = 3.1)$CLR))
b <- example_isolates$ERY b <- example_isolates$ERY
expect_identical(a[!is.na(b)], expect_identical(a[!is.na(b)],
b[!is.na(b)]) b[!is.na(b)])