diff --git a/DESCRIPTION b/DESCRIPTION index fbdb612a..a8bdfcdc 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: AMR -Version: 1.4.0.9016 -Date: 2020-11-10 +Version: 1.4.0.9017 +Date: 2020-11-11 Title: Antimicrobial Resistance Analysis Authors@R: c( person(role = c("aut", "cre"), diff --git a/NEWS.md b/NEWS.md index f17103b0..3de30742 100755 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,5 @@ -# AMR 1.4.0.9016 -## Last updated: 10 November 2020 +# AMR 1.4.0.9017 +## Last updated: 11 November 2020 ### 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: @@ -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. ### 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. * 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 diff --git a/R/ab_class_selectors.R b/R/ab_class_selectors.R index 54be0406..6c831854 100644 --- a/R/ab_class_selectors.R +++ b/R/ab_class_selectors.R @@ -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) diff --git a/R/availability.R b/R/availability.R index 7381665e..8c39cc94 100644 --- a/R/availability.R +++ b/R/availability.R @@ -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 { diff --git a/R/bug_drug_combinations.R b/R/bug_drug_combinations.R index d8ee159e..792aeb85 100644 --- a/R/bug_drug_combinations.R +++ b/R/bug_drug_combinations.R @@ -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 } diff --git a/R/eucast_rules.R b/R/eucast_rules.R index 3dd375e9..2328d2c8 100755 --- a/R/eucast_rules.R +++ b/R/eucast_rules.R @@ -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>% diff --git a/R/filter_ab_class.R b/R/filter_ab_class.R index 46c9e1bf..4f6c2795 100644 --- a/R/filter_ab_class.R +++ b/R/filter_ab_class.R @@ -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 diff --git a/R/ggplot_pca.R b/R/ggplot_pca.R index 7f640453..1854cbd4 100755 --- a/R/ggplot_pca.R +++ b/R/ggplot_pca.R @@ -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)) diff --git a/R/guess_ab_col.R b/R/guess_ab_col.R index 8d00d569..30380c6c 100755 --- a/R/guess_ab_col.R +++ b/R/guess_ab_col.R @@ -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))) { diff --git a/R/mdro.R b/R/mdro.R index 37fce4c4..ca5f79ed 100755 --- a/R/mdro.R +++ b/R/mdro.R @@ -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) } } diff --git a/R/mo.R b/R/mo.R index 44fac861..fa34ba98 100755 --- a/R/mo.R +++ b/R/mo.R @@ -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) } diff --git a/R/resistance_predict.R b/R/resistance_predict.R index 39d90bfa..3d33eb00 100755 --- a/R/resistance_predict.R +++ b/R/resistance_predict.R @@ -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 diff --git a/R/rsi.R b/R/rsi.R index 3299f9d4..190e74d5 100755 --- a/R/rsi.R +++ b/R/rsi.R @@ -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) + } + } +} diff --git a/R/rsi_calc.R b/R/rsi_calc.R index e3d60256..e2dc5ba2 100755 --- a/R/rsi_calc.R +++ b/R/rsi_calc.R @@ -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 diff --git a/docs/404.html b/docs/404.html index 53cdaf62..821aae93 100644 --- a/docs/404.html +++ b/docs/404.html @@ -81,7 +81,7 @@ AMR (for R) - 1.4.0.9016 + 1.4.0.9017 diff --git a/docs/LICENSE-text.html b/docs/LICENSE-text.html index bcdc6cff..eda3eed9 100644 --- a/docs/LICENSE-text.html +++ b/docs/LICENSE-text.html @@ -81,7 +81,7 @@ AMR (for R) - 1.4.0.9016 + 1.4.0.9017 diff --git a/docs/articles/index.html b/docs/articles/index.html index 44824168..92312efb 100644 --- a/docs/articles/index.html +++ b/docs/articles/index.html @@ -81,7 +81,7 @@ AMR (for R) - 1.4.0.9016 + 1.4.0.9017 diff --git a/docs/authors.html b/docs/authors.html index 00cd68c3..e4129903 100644 --- a/docs/authors.html +++ b/docs/authors.html @@ -81,7 +81,7 @@ AMR (for R) - 1.4.0.9016 + 1.4.0.9017 diff --git a/docs/index.html b/docs/index.html index d5102462..0cd46e1e 100644 --- a/docs/index.html +++ b/docs/index.html @@ -43,7 +43,7 @@ AMR (for R) - 1.4.0.9016 + 1.4.0.9017 diff --git a/docs/news/index.html b/docs/news/index.html index 3b66c2fb..65adace5 100644 --- a/docs/news/index.html +++ b/docs/news/index.html @@ -81,7 +81,7 @@ AMR (for R) - 1.4.0.9016 + 1.4.0.9017 @@ -236,13 +236,13 @@ Source: NEWS.md -
-

-AMR 1.4.0.9016 Unreleased +
+

+AMR 1.4.0.9017 Unreleased

-
+

-Last updated: 10 November 2020 +Last updated: 11 November 2020

@@ -252,7 +252,7 @@

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:

 example_isolates %>%
-  filter(is_gram_positive())
+  filter(is_gram_positive())
 #> NOTE: Using column `mo` as input for 'x'

  • 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.

    • @@ -262,6 +262,7 @@

    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 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 for the source code to preserve it.
    • Better determination of disk zones and MIC values when running as.rsi() on a data.frame
      • diff --git a/docs/pkgdown.yml b/docs/pkgdown.yml index 58640be2..b27f64e8 100644 --- a/docs/pkgdown.yml +++ b/docs/pkgdown.yml @@ -12,7 +12,7 @@ articles: datasets: datasets.html resistance_predict: resistance_predict.html welcome_to_AMR: welcome_to_AMR.html -last_built: 2020-11-10T18:58Z +last_built: 2020-11-11T15:44Z urls: reference: https://msberends.github.io/AMR//reference article: https://msberends.github.io/AMR//articles diff --git a/docs/reference/as.rsi.html b/docs/reference/as.rsi.html index 5dcbf2fc..154b4ec9 100644 --- a/docs/reference/as.rsi.html +++ b/docs/reference/as.rsi.html @@ -82,7 +82,7 @@ AMR (for R) - 1.4.0.9008 + 1.4.0.9017
    @@ -257,6 +257,7 @@ uti = FALSE, conserve_capped_values = FALSE, add_intrinsic_resistance = FALSE, + reference_data = AMR::rsi_translation, ... ) @@ -268,6 +269,7 @@ guideline = "EUCAST", uti = FALSE, add_intrinsic_resistance = FALSE, + reference_data = AMR::rsi_translation, ... ) @@ -279,7 +281,8 @@ guideline = "EUCAST", uti = NULL, conserve_capped_values = FALSE, - add_intrinsic_resistance = FALSE + add_intrinsic_resistance = FALSE, + reference_data = rsi_translation )

    Arguments

    @@ -322,6 +325,10 @@

    (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 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").

    + + 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().

    + col_mo

    column name of the IDs of the microorganisms (see as.mo()), defaults to the first column of class mo. Values will be coerced using as.mo().

    @@ -358,7 +365,7 @@ list(version_txt = "v3.2", year = 2020, title = "EUCAST Expert Rules / EUCAST In

    For interpreting MIC values as well as disk diffusion diameters, supported guidelines to be used as input for the 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 "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

    diff --git a/docs/reference/index.html b/docs/reference/index.html index 23c81bd6..7a25ff29 100644 --- a/docs/reference/index.html +++ b/docs/reference/index.html @@ -81,7 +81,7 @@ AMR (for R) - 1.4.0.9016 + 1.4.0.9017
    diff --git a/docs/survey.html b/docs/survey.html index b1d9ec63..9a753eff 100644 --- a/docs/survey.html +++ b/docs/survey.html @@ -81,7 +81,7 @@ AMR (for R) - 1.4.0.9016 + 1.4.0.9017
    diff --git a/man/as.rsi.Rd b/man/as.rsi.Rd index 80cb649a..b5038e3e 100755 --- a/man/as.rsi.Rd +++ b/man/as.rsi.Rd @@ -24,6 +24,7 @@ is.rsi.eligible(x, threshold = 0.05) uti = FALSE, conserve_capped_values = FALSE, add_intrinsic_resistance = FALSE, + reference_data = AMR::rsi_translation, ... ) @@ -34,6 +35,7 @@ is.rsi.eligible(x, threshold = 0.05) guideline = "EUCAST", uti = FALSE, add_intrinsic_resistance = FALSE, + reference_data = AMR::rsi_translation, ... ) @@ -44,7 +46,8 @@ is.rsi.eligible(x, threshold = 0.05) guideline = "EUCAST", uti = NULL, conserve_capped_values = FALSE, - add_intrinsic_resistance = FALSE + add_intrinsic_resistance = FALSE, + reference_data = rsi_translation ) } \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") 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()}}.} } \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". -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}{ diff --git a/tests/testthat/test-eucast_rules.R b/tests/testthat/test-eucast_rules.R index f661f77c..d3ff0868 100755 --- a/tests/testthat/test-eucast_rules.R +++ b/tests/testthat/test-eucast_rules.R @@ -90,12 +90,12 @@ test_that("EUCAST rules work", { "R") # Azithromycin and Clarythromycin must be equal to Erythromycin - a <- as.rsi(eucast_rules(data.frame(mo = example_isolates$mo, - ERY = example_isolates$ERY, - AZM = as.rsi("R"), - CLR = factor("R"), - stringsAsFactors = FALSE), - version_expertrules = 3.1)$CLR) + a <- suppressWarnings(as.rsi(eucast_rules(data.frame(mo = example_isolates$mo, + ERY = example_isolates$ERY, + AZM = as.rsi("R"), + CLR = factor("R"), + stringsAsFactors = FALSE), + version_expertrules = 3.1)$CLR)) b <- example_isolates$ERY expect_identical(a[!is.na(b)], b[!is.na(b)])