mirror of
https://github.com/msberends/AMR.git
synced 2024-12-24 04:06:12 +01:00
(v1.4.0.9052) replaced all sapply's with type-safe vapply's
This commit is contained in:
parent
ccf13dd6c0
commit
526f8afb08
2
.github/workflows/lintr.yaml
vendored
2
.github/workflows/lintr.yaml
vendored
@ -66,5 +66,5 @@ jobs:
|
||||
shell: Rscript {0}
|
||||
|
||||
- name: Lint
|
||||
run: lintr::lint_package(linters = lintr::with_defaults(line_length_linter = NULL, trailing_whitespace_linter = NULL, object_name_linter = NULL, cyclocomp_linter = NULL, object_usage_linter = NULL, object_length_linter = lintr::object_length_linter(length = 50L)), exclusions = list("R/aa_helper_pm_functions.R"))
|
||||
run: lintr::lint_package(linters = lintr::with_defaults(line_length_linter = NULL, trailing_whitespace_linter = NULL, object_name_linter = NULL, cyclocomp_linter = NULL, object_length_linter = lintr::object_length_linter(length = 50L)), exclusions = list("R/aa_helper_pm_functions.R"))
|
||||
shell: Rscript {0}
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
Package: AMR
|
||||
Version: 1.4.0.9051
|
||||
Date: 2020-12-27
|
||||
Version: 1.4.0.9052
|
||||
Date: 2020-12-28
|
||||
Title: Antimicrobial Resistance Analysis
|
||||
Authors@R: c(
|
||||
person(role = c("aut", "cre"),
|
||||
|
||||
6
NEWS.md
6
NEWS.md
@ -1,5 +1,5 @@
|
||||
# AMR 1.4.0.9051
|
||||
## <small>Last updated: 27 December 2020</small>
|
||||
# AMR 1.4.0.9052
|
||||
## <small>Last updated: 28 December 2020</small>
|
||||
|
||||
### New
|
||||
* Functions `get_episode()` and `is_new_episode()` to determine (patient) episodes which are not necessarily based on microorganisms. The `get_episode()` function returns the index number of the episode per group, while the `is_new_episode()` function returns values `TRUE`/`FALSE` to indicate whether an item in a vector is the start of a new episode. They also support `dplyr`s grouping (i.e. using `group_by()`):
|
||||
@ -53,6 +53,8 @@
|
||||
* All messages and warnings thrown by this package now break sentences on whole words
|
||||
* More extensive unit tests
|
||||
* Internal calls to `options()` were all removed in favour of a new internal environment `pkg_env`
|
||||
* Improved internal type setting (among other things: replaced all `sapply()` calls with `vapply()`)
|
||||
* Added CodeFactor as a continuous code review to this package: <https://www.codefactor.io/repository/github/msberends/amr/>
|
||||
* Added Dr. Rogier Schade as contributor
|
||||
|
||||
# AMR 1.4.0
|
||||
|
||||
@ -119,8 +119,8 @@ search_type_in_df <- function(x, type, info = TRUE) {
|
||||
|
||||
# -- mo
|
||||
if (type == "mo") {
|
||||
if (any(sapply(x, is.mo))) {
|
||||
found <- sort(colnames(x)[sapply(x, is.mo)])[1]
|
||||
if (any(vapply(FUN.VALUE = logical(1), x, is.mo))) {
|
||||
found <- sort(colnames(x)[vapply(FUN.VALUE = logical(1), x, is.mo)])[1]
|
||||
} else if ("mo" %in% colnames(x) &
|
||||
suppressWarnings(
|
||||
all(x$mo %in% c(NA,
|
||||
@ -152,8 +152,8 @@ search_type_in_df <- function(x, type, info = TRUE) {
|
||||
"`, but this column contains no valid dates. Transform its values to valid dates first.")),
|
||||
call. = FALSE)
|
||||
}
|
||||
} else if (any(sapply(x, function(x) inherits(x, c("Date", "POSIXct"))))) {
|
||||
found <- sort(colnames(x)[sapply(x, function(x) inherits(x, c("Date", "POSIXct")))])[1]
|
||||
} else if (any(vapply(FUN.VALUE = logical(1), x, function(x) inherits(x, c("Date", "POSIXct"))))) {
|
||||
found <- sort(colnames(x)[vapply(FUN.VALUE = logical(1), x, function(x) inherits(x, c("Date", "POSIXct")))])[1]
|
||||
}
|
||||
}
|
||||
# -- patient id
|
||||
@ -202,7 +202,7 @@ search_type_in_df <- function(x, type, info = TRUE) {
|
||||
}
|
||||
|
||||
is_possibly_regex <- function(x) {
|
||||
tryCatch(sapply(strsplit(x, ""),
|
||||
tryCatch(vapply(FUN.VALUE = character(1), strsplit(x, ""),
|
||||
function(y) any(y %in% c("$", "(", ")", "*", "+", "-", ".", "?", "[", "]", "^", "{", "|", "}", "\\"), na.rm = TRUE)),
|
||||
error = function(e) rep(TRUE, length(x)))
|
||||
}
|
||||
@ -210,7 +210,7 @@ is_possibly_regex <- function(x) {
|
||||
stop_ifnot_installed <- function(package) {
|
||||
# no "utils::installed.packages()" since it requires non-staged install since R 3.6.0
|
||||
# https://developer.r-project.org/Blog/public/2019/02/14/staged-install/index.html
|
||||
sapply(package, function(pkg)
|
||||
vapply(FUN.VALUE = character(1), package, function(pkg)
|
||||
tryCatch(get(".packageName", envir = asNamespace(pkg)),
|
||||
error = function(e) {
|
||||
if (package == "rstudioapi") {
|
||||
@ -260,7 +260,8 @@ word_wrap <- function(...,
|
||||
|
||||
if (msg %like% "\n") {
|
||||
# run word_wraps() over every line here, bind them and return again
|
||||
return(paste0(sapply(trimws(unlist(strsplit(msg, "\n")), which = "right"),
|
||||
return(paste0(vapply(FUN.VALUE = character(1),
|
||||
trimws(unlist(strsplit(msg, "\n")), which = "right"),
|
||||
word_wrap,
|
||||
add_fn = add_fn,
|
||||
as_note = FALSE,
|
||||
@ -512,7 +513,11 @@ meet_criteria <- function(object,
|
||||
call = call_depth)
|
||||
}
|
||||
if (!is.null(contains_column_class)) {
|
||||
stop_ifnot(any(sapply(object, function(col, columns_class = contains_column_class) inherits(col, columns_class)), na.rm = TRUE),
|
||||
stop_ifnot(any(vapply(FUN.VALUE = logical(1),
|
||||
object,
|
||||
function(col, columns_class = contains_column_class) {
|
||||
inherits(col, columns_class)
|
||||
}), na.rm = TRUE),
|
||||
"the data provided in argument `", obj_name,
|
||||
"` must contain at least one column of class <", contains_column_class, ">. ",
|
||||
"See ?as.", contains_column_class, ".",
|
||||
|
||||
@ -163,14 +163,24 @@ ab_selector <- function(ab_class, function_name) {
|
||||
meet_criteria(function_name, allow_class = "character", has_length = 1, .call_depth = 1)
|
||||
|
||||
for (i in seq_len(length(sys.frames()))) {
|
||||
# dplyr?
|
||||
if (".data" %in% names(sys.frames()[[i]])) {
|
||||
vars_df <- sys.frames()[[i]]$`.data`
|
||||
if (is.data.frame(vars_df)) {
|
||||
break
|
||||
}
|
||||
}
|
||||
# then try base R - an element `x` will be in the system call stack
|
||||
vars_df <- tryCatch(sys.frames()[[i]]$x, error = function(e) NULL)
|
||||
if (!is.null(vars_df) && is.data.frame(vars_df)) {
|
||||
# when using e.g. example_isolates[, carbapenems()] or example_isolates %>% select(carbapenems())
|
||||
break
|
||||
} else if (!is.null(vars_df) && is.list(vars_df)) {
|
||||
# when using e.g. example_isolates %>% filter(across(carbapenems(), ~. == "R"))
|
||||
vars_df <- as.data.frame(vars_df, stringsAsFactors = FALSE)
|
||||
break
|
||||
vars_df <- tryCatch(as.data.frame(vars_df, stringsAsFactors = FALSE), error = function(e) NULL)
|
||||
if (!is.null(vars_df)) {
|
||||
break
|
||||
}
|
||||
}
|
||||
}
|
||||
stop_ifnot(is.data.frame(vars_df), "this function must be used inside dplyr selection verbs or within a data.frame call.", call = -2)
|
||||
@ -199,7 +209,7 @@ ab_selector <- function(ab_class, function_name) {
|
||||
message_("No antimicrobial agents of class ", ab_group, " found", examples, ".")
|
||||
} else {
|
||||
message_("Selecting ", ab_group, ": ",
|
||||
paste(paste0("'", font_bold(agents, collapse = NULL),
|
||||
paste(paste0("column '", font_bold(agents, collapse = NULL),
|
||||
"' (", ab_name(names(agents), tolower = TRUE, language = NULL), ")"),
|
||||
collapse = ", "),
|
||||
as_note = FALSE,
|
||||
|
||||
@ -115,7 +115,7 @@ ab_from_text <- function(text,
|
||||
translate_ab <- get_translate_ab(translate_ab)
|
||||
|
||||
if (isTRUE(thorough_search) |
|
||||
(isTRUE(is.null(thorough_search)) & max(sapply(text_split_all, length), na.rm = TRUE) <= 3)) {
|
||||
(isTRUE(is.null(thorough_search)) & max(vapply(FUN.VALUE = double(1), text_split_all, length), na.rm = TRUE) <= 3)) {
|
||||
text_split_all <- text_split_all[nchar(text_split_all) >= 4 & grepl("[a-z]+", text_split_all)]
|
||||
result <- lapply(text_split_all, function(text_split) {
|
||||
progress$tick()
|
||||
@ -203,7 +203,7 @@ ab_from_text <- function(text,
|
||||
|
||||
# collapse text if needed
|
||||
if (!is.null(collapse)) {
|
||||
result <- sapply(result, function(x) {
|
||||
result <- vapply(FUN.VALUE = character(1), result, function(x) {
|
||||
if (length(x) == 1 & all(is.na(x))) {
|
||||
NA_character_
|
||||
} else {
|
||||
|
||||
@ -46,11 +46,11 @@ availability <- function(tbl, width = NULL) {
|
||||
meet_criteria(tbl, allow_class = "data.frame")
|
||||
meet_criteria(width, allow_class = "numeric", allow_NULL = TRUE)
|
||||
|
||||
x <- sapply(tbl, function(x) {
|
||||
x <- vapply(FUN.VALUE = double(1), tbl, function(x) {
|
||||
1 - sum(is.na(x)) / length(x)
|
||||
})
|
||||
n <- sapply(tbl, function(x) length(x[!is.na(x)]))
|
||||
R <- sapply(tbl, function(x) ifelse(is.rsi(x), resistance(x, minimum = 0), NA))
|
||||
n <- vapply(FUN.VALUE = double(1), tbl, function(x) length(x[!is.na(x)]))
|
||||
R <- vapply(FUN.VALUE = double(1), tbl, function(x) ifelse(is.rsi(x), resistance(x, minimum = 0), NA_real_))
|
||||
R_print <- character(length(R))
|
||||
R_print[!is.na(R)] <- percentage(R[!is.na(R)])
|
||||
R_print[is.na(R)] <- ""
|
||||
|
||||
@ -75,7 +75,7 @@ bug_drug_combinations <- function(x,
|
||||
x_class <- class(x)
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||
x[, col_mo] <- FUN(x[, col_mo, drop = TRUE], ...)
|
||||
x <- x[, c(col_mo, names(which(sapply(x, is.rsi)))), drop = FALSE]
|
||||
x <- x[, c(col_mo, names(which(vapply(FUN.VALUE = logical(1), x, is.rsi)))), drop = FALSE]
|
||||
|
||||
unique_mo <- sort(unique(x[, col_mo, drop = TRUE]))
|
||||
|
||||
@ -89,7 +89,7 @@ bug_drug_combinations <- function(x,
|
||||
|
||||
for (i in seq_len(length(unique_mo))) {
|
||||
# filter on MO group and only select R/SI columns
|
||||
x_mo_filter <- x[which(x[, col_mo, drop = TRUE] == unique_mo[i]), names(which(sapply(x, is.rsi))), drop = FALSE]
|
||||
x_mo_filter <- x[which(x[, col_mo, drop = TRUE] == unique_mo[i]), names(which(vapply(FUN.VALUE = logical(1), x, is.rsi))), drop = FALSE]
|
||||
# turn and merge everything
|
||||
pivot <- lapply(x_mo_filter, function(x) {
|
||||
m <- as.matrix(table(x))
|
||||
@ -165,7 +165,7 @@ 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(lapply(.data, function(x) ifelse(is.na(x), "", x)),
|
||||
stringsAsFactors = FALSE)
|
||||
colnames(.data) <- cols
|
||||
.data
|
||||
@ -235,7 +235,7 @@ format.bug_drug_combinations <- function(x,
|
||||
}
|
||||
|
||||
if (remove_intrinsic_resistant == TRUE) {
|
||||
y <- y[, !sapply(y, function(col) all(col %like% "100", na.rm = TRUE) & !any(is.na(col))), drop = FALSE]
|
||||
y <- y[, !vapply(FUN.VALUE = logical(1), y, function(col) all(col %like% "100", na.rm = TRUE) & !any(is.na(col))), drop = FALSE]
|
||||
}
|
||||
|
||||
rownames(y) <- NULL
|
||||
|
||||
4
R/data.R
4
R/data.R
@ -178,7 +178,7 @@ catalogue_of_life <- list(
|
||||
#' - `gender`\cr gender of the patient
|
||||
#' - `patient_id`\cr ID of the patient
|
||||
#' - `mo`\cr ID of microorganism created with [as.mo()], see also [microorganisms]
|
||||
#' - `PEN:RIF`\cr `r sum(sapply(example_isolates, is.rsi))` different antibiotics with class [`rsi`] (see [as.rsi()]); these column names occur in the [antibiotics] data set and can be translated with [ab_name()]
|
||||
#' - `PEN:RIF`\cr `r sum(vapply(FUN.VALUE = logical(1), example_isolates, is.rsi))` different antibiotics with class [`rsi`] (see [as.rsi()]); these column names occur in the [antibiotics] data set and can be translated with [ab_name()]
|
||||
#' @inheritSection AMR Reference data publicly available
|
||||
#' @inheritSection AMR Read more on our website!
|
||||
"example_isolates"
|
||||
@ -225,7 +225,7 @@ catalogue_of_life <- list(
|
||||
#' - `Inducible clindamycin resistance`\cr Clindamycin can be induced?
|
||||
#' - `Comment`\cr Other comments
|
||||
#' - `Date of data entry`\cr Date this data was entered in WHONET
|
||||
#' - `AMP_ND10:CIP_EE`\cr `r sum(sapply(WHONET, is.rsi))` different antibiotics. You can lookup the abbreviations in the [antibiotics] data set, or use e.g. [`ab_name("AMP")`][ab_name()] to get the official name immediately. Before analysis, you should transform this to a valid antibiotic class, using [as.rsi()].
|
||||
#' - `AMP_ND10:CIP_EE`\cr `r sum(vapply(FUN.VALUE = logical(1), WHONET, is.rsi))` different antibiotics. You can lookup the abbreviations in the [antibiotics] data set, or use e.g. [`ab_name("AMP")`][ab_name()] to get the official name immediately. Before analysis, you should transform this to a valid antibiotic class, using [as.rsi()].
|
||||
#' @inheritSection AMR Reference data publicly available
|
||||
#' @inheritSection AMR Read more on our website!
|
||||
"WHONET"
|
||||
|
||||
4
R/disk.R
4
R/disk.R
@ -69,13 +69,13 @@ as.disk <- function(x, na.rm = FALSE) {
|
||||
|
||||
na_before <- length(x[is.na(x)])
|
||||
|
||||
# heavily based on the function from our cleaner package:
|
||||
# heavily based on cleaner::clean_double():
|
||||
clean_double2 <- function(x, remove = "[^0-9.,-]", fixed = FALSE) {
|
||||
x <- gsub(",", ".", x)
|
||||
# remove ending dot/comma
|
||||
x <- gsub("[,.]$", "", x)
|
||||
# only keep last dot/comma
|
||||
reverse <- function(x) sapply(lapply(strsplit(x, NULL), rev), paste, collapse = "")
|
||||
reverse <- function(x) vapply(FUN.VALUE = character(1), lapply(strsplit(x, NULL), rev), paste, collapse = "")
|
||||
x <- sub("{{dot}}", ".",
|
||||
gsub(".", "",
|
||||
reverse(sub(".", "}}tod{{",
|
||||
|
||||
@ -64,7 +64,8 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
|
||||
#' @param verbose a [logical] to turn Verbose mode on and off (default is off). In Verbose mode, the function does not apply rules to the data, but instead returns a data set in logbook form with extensive info about which rows and columns would be effected and in which way. Using Verbose mode takes a lot more time.
|
||||
#' @param version_breakpoints the version number to use for the EUCAST Clinical Breakpoints guideline. Currently supported: `r paste0(names(EUCAST_VERSION_BREAKPOINTS), collapse = ", ")`.
|
||||
#' @param version_expertrules the version number to use for the EUCAST Expert Rules and Intrinsic Resistance guideline. Currently supported: `r paste0(names(EUCAST_VERSION_EXPERT_RULES), collapse = ", ")`.
|
||||
#' @param ampc_cephalosporin_resistance a character value that should be applied for AmpC de-repressed cephalosporin-resistant mutants, defaults to `NA`. Currently only works when `version_expertrules` is `3.2`; '*EUCAST Expert Rules v3.2 on Enterobacterales*' states that susceptible (S) results of cefotaxime, ceftriaxone and ceftazidime should be reported with a note, or results should be suppressed (emptied) for these agents. A value of `NA` for this argument will remove results for these agents, while e.g. a value of `"R"` will make the results for these agents resistant. Use `NULL` to not alter the results for AmpC de-repressed cephalosporin-resistant mutants. \cr For *EUCAST Expert Rules* v3.2, this rule applies to: *`r gsub("|", "*, *", gsub("[)(^)]", "", eucast_rules_file[which(eucast_rules_file$reference.version == 3.2 & eucast_rules_file$reference.rule %like% "ampc"), "this_value"][1]), fixed = TRUE)`*.
|
||||
#' @param ampc_cephalosporin_resistance a character value that should be applied for AmpC de-repressed cephalosporin-resistant mutants, defaults to `NA`. Currently only works when `version_expertrules` is `3.2`; '*EUCAST Expert Rules v3.2 on Enterobacterales*' states that susceptible (S) results of cefotaxime, ceftriaxone and ceftazidime should be reported with a note, or results should be suppressed (emptied) for these agents. A value of `NA` for this argument will remove results for these agents, while e.g. a value of `"R"` will make the results for these agents resistant. Use `NULL` to not alter the results for AmpC de-repressed cephalosporin-resistant mutants. \cr For *EUCAST Expert Rules* v3.2, this rule applies to: *`r gsub("[)(^]", "", gsub("|", ", ", eucast_rules_file[which(eucast_rules_file$reference.version == 3.2 & eucast_rules_file$reference.rule %like% "ampc"), "this_value"][1], fixed = TRUE))`*.
|
||||
#'
|
||||
#' @param ... column name of an antibiotic, please see section *Antibiotics* below
|
||||
#' @inheritParams first_isolate
|
||||
#' @details
|
||||
@ -537,7 +538,7 @@ eucast_rules <- function(x,
|
||||
strsplit(",") %pm>%
|
||||
unlist() %pm>%
|
||||
trimws() %pm>%
|
||||
sapply(function(x) if (x %in% antibiotics$ab) ab_name(x, language = NULL, tolower = TRUE) else x) %pm>%
|
||||
vapply(FUN.VALUE = character(1), function(x) if (x %in% antibiotics$ab) ab_name(x, language = NULL, tolower = TRUE) else x) %pm>%
|
||||
sort() %pm>%
|
||||
paste(collapse = ", ")
|
||||
x <- gsub("_", " ", x, fixed = TRUE)
|
||||
@ -600,13 +601,14 @@ eucast_rules <- function(x,
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE) # no tibbles, data.tables, etc.
|
||||
rownames(x) <- NULL # will later be restored with old_attributes
|
||||
# create unique row IDs - combination of the MO and all ABx columns (so they will only run once per unique combination)
|
||||
x$`.rowid` <- sapply(as.list(as.data.frame(t(x[, c(col_mo, cols_ab), drop = FALSE]),
|
||||
x$`.rowid` <- vapply(FUN.VALUE = character(1),
|
||||
as.list(as.data.frame(t(x[, c(col_mo, cols_ab), drop = FALSE]),
|
||||
stringsAsFactors = FALSE)),
|
||||
function(x) {
|
||||
x[is.na(x)] <- "."
|
||||
paste0(x, collapse = "")
|
||||
})
|
||||
|
||||
|
||||
# save original table, with the new .rowid column
|
||||
x.bak <- x
|
||||
# keep only unique rows for MO and ABx
|
||||
@ -1093,18 +1095,18 @@ edit_rsi <- function(x,
|
||||
|
||||
if (length(rows) > 0 & length(cols) > 0) {
|
||||
new_edits <- x
|
||||
if (any(!sapply(x[, cols, drop = FALSE], is.rsi), na.rm = TRUE)) {
|
||||
track_changes$rsi_warn <- cols[!sapply(x[, cols, drop = FALSE], is.rsi)]
|
||||
if (any(!vapply(FUN.VALUE = logical(1), x[, cols, drop = FALSE], is.rsi), na.rm = TRUE)) {
|
||||
track_changes$rsi_warn <- cols[!vapply(FUN.VALUE = logical(1), x[, cols, drop = FALSE], is.rsi)]
|
||||
}
|
||||
tryCatch(
|
||||
# insert into original table
|
||||
new_edits[rows, cols] <- to,
|
||||
warning = function(w) {
|
||||
if (w$message %like% "invalid factor level") {
|
||||
xyz <- sapply(cols, function(col) {
|
||||
xyz <- vapply(FUN.VALUE = logical(1), cols, function(col) {
|
||||
new_edits[, col] <<- factor(x = as.character(pm_pull(new_edits, col)),
|
||||
levels = unique(c(to, levels(pm_pull(new_edits, col)))))
|
||||
invisible()
|
||||
TRUE
|
||||
})
|
||||
suppressWarnings(new_edits[rows, cols] <<- to)
|
||||
warning_('Value "', to, '" added to the factor levels of column(s) `', paste(cols, collapse = "`, `"), "` because this value was not an existing factor level. A better way is to use as.rsi() on beforehand on antimicrobial columns to guarantee the right structure.", call = FALSE)
|
||||
|
||||
@ -165,7 +165,7 @@ filter_ab_class <- function(x,
|
||||
collapse = scope_txt),
|
||||
operator, toString(result), as_note = 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 <- vapply(FUN.VALUE = logical(1), x_transposed, function(y) scope_fn(y %in% result, na.rm = TRUE))
|
||||
x <- x[which(filtered), , drop = FALSE]
|
||||
class(x) <- x_class
|
||||
x
|
||||
|
||||
@ -306,7 +306,6 @@ pca_calculations <- function(pca_model,
|
||||
d <- pca_model$svd
|
||||
u <- predict(pca_model)$x / nobs.factor
|
||||
v <- pca_model$scaling
|
||||
d.total <- sum(d ^ 2)
|
||||
} else {
|
||||
stop("Expected an object of class prcomp, princomp, PCA, or lda")
|
||||
}
|
||||
|
||||
@ -139,13 +139,13 @@ get_column_abx <- function(x,
|
||||
}
|
||||
x_bak <- x
|
||||
# only check columns that are a valid AB code, ATC code, name, abbreviation or synonym,
|
||||
# or already have the rsi class (as.rsi)
|
||||
# and that have no more than 50% invalid values
|
||||
# or already have the <rsi> class (as.rsi)
|
||||
# and that they have no more than 50% invalid values
|
||||
vectr_antibiotics <- unique(toupper(unlist(antibiotics[, c("ab", "atc", "name", "abbreviations", "synonyms")])))
|
||||
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, stringsAsFactors = FALSE)[, col, drop = TRUE]) |
|
||||
x_columns <- vapply(FUN.VALUE = character(1), colnames(x), function(col, df = x_bak) {
|
||||
if (toupper(col) %in% vectr_antibiotics ||
|
||||
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)
|
||||
|
||||
@ -71,5 +71,5 @@ kurtosis.matrix <- function(x, na.rm = FALSE, excess = FALSE) {
|
||||
kurtosis.data.frame <- function(x, na.rm = FALSE, excess = FALSE) {
|
||||
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(excess, allow_class = "logical", has_length = 1)
|
||||
sapply(x, kurtosis.default, na.rm = na.rm, excess = excess)
|
||||
vapply(FUN.VALUE = double(1), x, kurtosis.default, na.rm = na.rm, excess = excess)
|
||||
}
|
||||
|
||||
2
R/like.R
2
R/like.R
@ -102,7 +102,7 @@ like <- function(x, pattern, ignore.case = TRUE) {
|
||||
res[i] <- grepl(pattern[i], x[i], ignore.case = FALSE, fixed = fixed)
|
||||
}
|
||||
}
|
||||
res <- sapply(pattern, function(pttrn) grepl(pttrn, x, ignore.case = FALSE, fixed = fixed))
|
||||
res <- vapply(FUN.VALUE = logical(1), pattern, function(pttrn) grepl(pttrn, x, ignore.case = FALSE, fixed = fixed))
|
||||
res2 <- as.logical(rowSums(res))
|
||||
# get only first item of every hit in pattern
|
||||
res2[duplicated(res)] <- FALSE
|
||||
|
||||
49
R/mdro.R
49
R/mdro.R
@ -193,28 +193,28 @@ mdro <- function(x,
|
||||
guideline$name <- "Multidrug-resistant, extensively drug-resistant and pandrug-resistant bacteria: an international expert proposal for interim standard definitions for acquired resistance."
|
||||
guideline$author <- "Magiorakos AP, Srinivasan A, Carey RB, ..., Vatopoulos A, Weber JT, Monnet DL"
|
||||
guideline$version <- NA
|
||||
guideline$source <- "Clinical Microbiology and Infection 18:3, 2012. DOI: 10.1111/j.1469-0691.2011.03570.x"
|
||||
guideline$source_url <- "Clinical Microbiology and Infection 18:3, 2012. DOI: 10.1111/j.1469-0691.2011.03570.x"
|
||||
guideline$type <- "MDRs/XDRs/PDRs"
|
||||
|
||||
} else if (guideline$code == "eucast3.1") {
|
||||
guideline$name <- "EUCAST Expert Rules, \"Intrinsic Resistance and Exceptional Phenotypes Tables\""
|
||||
guideline$author <- "EUCAST (European Committee on Antimicrobial Susceptibility Testing)"
|
||||
guideline$version <- "3.1, 2016"
|
||||
guideline$source <- "https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/Expert_rules_intrinsic_exceptional_V3.1.pdf"
|
||||
guideline$source_url <- "https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/Expert_rules_intrinsic_exceptional_V3.1.pdf"
|
||||
guideline$type <- "EUCAST Exceptional Phenotypes"
|
||||
|
||||
} else if (guideline$code == "eucast3.2") {
|
||||
guideline$name <- "EUCAST Expert Rules, \"Intrinsic Resistance and Unusual Phenotypes\""
|
||||
guideline$author <- "EUCAST (European Committee on Antimicrobial Susceptibility Testing)"
|
||||
guideline$version <- "3.2, 2020"
|
||||
guideline$source <- "https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/2020/Intrinsic_Resistance_and_Unusual_Phenotypes_Tables_v3.2_20200225.pdf"
|
||||
guideline$source_url <- "https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/2020/Intrinsic_Resistance_and_Unusual_Phenotypes_Tables_v3.2_20200225.pdf"
|
||||
guideline$type <- "EUCAST Unusual Phenotypes"
|
||||
|
||||
} else if (guideline$code == "tb") {
|
||||
guideline$name <- "Companion handbook to the WHO guidelines for the programmatic management of drug-resistant tuberculosis"
|
||||
guideline$author <- "WHO (World Health Organization)"
|
||||
guideline$version <- "WHO/HTM/TB/2014.11, 2014"
|
||||
guideline$source <- "https://www.who.int/tb/publications/pmdt_companionhandbook/en/"
|
||||
guideline$source_url <- "https://www.who.int/tb/publications/pmdt_companionhandbook/en/"
|
||||
guideline$type <- "MDR-TB's"
|
||||
|
||||
# support per country:
|
||||
@ -222,14 +222,14 @@ mdro <- function(x,
|
||||
guideline$name <- "Cross-border comparison of the Dutch and German guidelines on multidrug-resistant Gram-negative microorganisms"
|
||||
guideline$author <- "M\u00fcller J, Voss A, K\u00f6ck R, ..., Kern WV, Wendt C, Friedrich AW"
|
||||
guideline$version <- NA
|
||||
guideline$source <- "Antimicrobial Resistance and Infection Control 4:7, 2015. DOI: 10.1186/s13756-015-0047-6"
|
||||
guideline$source_url <- "Antimicrobial Resistance and Infection Control 4:7, 2015. DOI: 10.1186/s13756-015-0047-6"
|
||||
guideline$type <- "MRGNs"
|
||||
|
||||
} else if (guideline$code == "brmo") {
|
||||
guideline$name <- "WIP-Richtlijn Bijzonder Resistente Micro-organismen (BRMO)"
|
||||
guideline$author <- "RIVM (Rijksinstituut voor de Volksgezondheid)"
|
||||
guideline$version <- "Revision as of December 2017"
|
||||
guideline$source <- "https://www.rivm.nl/Documenten_en_publicaties/Professioneel_Praktisch/Richtlijnen/Infectieziekten/WIP_Richtlijnen/WIP_Richtlijnen/Ziekenhuizen/WIP_richtlijn_BRMO_Bijzonder_Resistente_Micro_Organismen_ZKH"
|
||||
guideline$source_url <- "https://www.rivm.nl/Documenten_en_publicaties/Professioneel_Praktisch/Richtlijnen/Infectieziekten/WIP_Richtlijnen/WIP_Richtlijnen/Ziekenhuizen/WIP_richtlijn_BRMO_Bijzonder_Resistente_Micro_Organismen_ZKH"
|
||||
guideline$type <- "BRMOs"
|
||||
} else {
|
||||
stop("This guideline is currently unsupported: ", guideline$code, call. = FALSE)
|
||||
@ -413,6 +413,7 @@ mdro <- function(x,
|
||||
...)
|
||||
}
|
||||
|
||||
# nolint start
|
||||
AMC <- cols_ab["AMC"]
|
||||
AMK <- cols_ab["AMK"]
|
||||
AMP <- cols_ab["AMP"]
|
||||
@ -555,6 +556,7 @@ mdro <- function(x,
|
||||
abx_tb <- c(CAP, ETH, GAT, INH, PZA, RIF, RIB, RFP)
|
||||
abx_tb <- abx_tb[!is.na(abx_tb)]
|
||||
stop_if(guideline$code == "tb" & length(abx_tb) == 0, "no antimycobacterials found in data set")
|
||||
# nolint end
|
||||
|
||||
if (combine_SI == TRUE) {
|
||||
search_result <- "R"
|
||||
@ -574,8 +576,8 @@ mdro <- function(x,
|
||||
ifelse(!is.na(guideline$version),
|
||||
paste0(word_wrap(paste0(font_bold("Version: "), guideline$version), extra_indent = 11, as_note = FALSE), "\n"),
|
||||
""),
|
||||
word_wrap(paste0(font_bold("Source: "), guideline$source), extra_indent = 11, as_note = FALSE), "\n",
|
||||
"\n", sep = "")
|
||||
paste0(font_bold("Source: "), guideline$source_url),
|
||||
"\n\n", sep = "")
|
||||
}
|
||||
|
||||
ab_missing <- function(ab) {
|
||||
@ -585,9 +587,8 @@ mdro <- function(x,
|
||||
x[!is.na(x)]
|
||||
}
|
||||
|
||||
verbose_df <- NULL
|
||||
|
||||
# antibiotic classes
|
||||
# nolint start
|
||||
aminoglycosides <- c(TOB, GEN)
|
||||
cephalosporins <- c(CDZ, CAC, CEC, CFR, RID, MAN, CTZ, CZD, CZO, CDR, DIT, FEP, CAT, CFM, CMX, CMZ, DIZ, CID, CFP, CSL, CND, CTX, CTT, CTF, FOX, CPM, CPO, CPD, CPR, CRD, CFS, CPT, CAZ, CCV, CTL, CTB, CZX, BPR, CFM1, CEI, CRO, CXM, LEX, CEP, HAP, CED, LTM, LOR)
|
||||
cephalosporins_1st <- c(CAC, CFR, RID, CTZ, CZD, CZO, CRD, CTL, LEX, CEP, HAP, CED)
|
||||
@ -595,6 +596,7 @@ mdro <- function(x,
|
||||
cephalosporins_3rd <- c(CDZ, CDR, DIT, CAT, CFM, CMX, DIZ, CFP, CSL, CTX, CPM, CPD, CFS, CAZ, CCV, CTB, CZX, CRO, LTM)
|
||||
carbapenems <- c(DOR, ETP, IPM, MEM, MEV)
|
||||
fluoroquinolones <- c(CIP, ENX, FLE, GAT, GEM, GRX, LVX, LOM, MFX, NOR, OFX, PAZ, PEF, PRU, RFL, SPX, TMX, TVA)
|
||||
# nolint end
|
||||
|
||||
# helper function for editing the table
|
||||
trans_tbl <- function(to, rows, cols, any_all) {
|
||||
@ -604,9 +606,10 @@ mdro <- function(x,
|
||||
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"] <<- vapply(FUN.VALUE = character(1),
|
||||
rows,
|
||||
function(row, group_vct = cols) {
|
||||
cols_nonsus <- sapply(x[row, group_vct, drop = FALSE],
|
||||
cols_nonsus <- vapply(FUN.VALUE = logical(1), x[row, group_vct, drop = FALSE],
|
||||
function(y) y %in% search_result)
|
||||
paste(sort(c(unlist(strsplit(x[row, "columns_nonsusceptible", drop = TRUE], ", ")),
|
||||
names(cols_nonsus)[cols_nonsus])),
|
||||
@ -620,7 +623,7 @@ mdro <- function(x,
|
||||
}
|
||||
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 <- vapply(FUN.VALUE = logical(1), 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]
|
||||
x[rows, "MDRO"] <<- to
|
||||
@ -638,21 +641,27 @@ mdro <- function(x,
|
||||
function(col) as.rsi(col)),
|
||||
stringsAsFactors = FALSE)
|
||||
x[rows, "classes_in_guideline"] <<- length(lst)
|
||||
x[rows, "classes_available"] <<- sapply(rows,
|
||||
x[rows, "classes_available"] <<- vapply(FUN.VALUE = double(1),
|
||||
rows,
|
||||
function(row, group_tbl = lst) {
|
||||
sum(sapply(group_tbl, function(group) any(unlist(x[row, group[!is.na(group)], drop = TRUE]) %in% c("S", "I", "R"))))
|
||||
sum(vapply(FUN.VALUE = logical(1),
|
||||
group_tbl,
|
||||
function(group) any(unlist(x[row, group[!is.na(group)], drop = TRUE]) %in% c("S", "I", "R"))))
|
||||
})
|
||||
|
||||
if (verbose == TRUE) {
|
||||
x[rows, "columns_nonsusceptible"] <<- sapply(rows,
|
||||
x[rows, "columns_nonsusceptible"] <<- vapply(FUN.VALUE = character(1),
|
||||
rows,
|
||||
function(row, group_vct = lst_vector) {
|
||||
cols_nonsus <- sapply(x[row, group_vct, drop = FALSE], function(y) y %in% search_result)
|
||||
cols_nonsus <- vapply(FUN.VALUE = logical(1), x[row, group_vct, drop = FALSE], function(y) y %in% search_result)
|
||||
paste(sort(names(cols_nonsus)[cols_nonsus]), collapse = ", ")
|
||||
})
|
||||
}
|
||||
x[rows, "classes_affected"] <<- sapply(rows,
|
||||
x[rows, "classes_affected"] <<- vapply(FUN.VALUE = double(1),
|
||||
rows,
|
||||
function(row, group_tbl = lst) {
|
||||
sum(sapply(group_tbl,
|
||||
sum(vapply(FUN.VALUE = logical(1),
|
||||
group_tbl,
|
||||
function(group) {
|
||||
any(unlist(x[row, group[!is.na(group)], drop = TRUE]) %in% search_result, na.rm = TRUE)
|
||||
}),
|
||||
@ -661,7 +670,7 @@ mdro <- function(x,
|
||||
# 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]),
|
||||
stringsAsFactors = FALSE))
|
||||
row_filter <- sapply(x_transposed, function(y) all(y %in% search_result, na.rm = TRUE))
|
||||
row_filter <- vapply(FUN.VALUE = logical(1), x_transposed, function(y) all(y %in% search_result, na.rm = TRUE))
|
||||
x[which(row_filter), "classes_affected"] <<- 999
|
||||
}
|
||||
|
||||
|
||||
12
R/mic.R
12
R/mic.R
@ -107,14 +107,14 @@ as.mic <- function(x, na.rm = FALSE) {
|
||||
|
||||
# these are allowed MIC values and will become factor levels
|
||||
ops <- c("<", "<=", "", ">=", ">")
|
||||
lvls <- c(c(t(sapply(ops, function(x) paste0(x, "0.00", 1:9)))),
|
||||
unique(c(t(sapply(ops, function(x) paste0(x, sort(as.double(paste0("0.0",
|
||||
lvls <- c(c(t(vapply(FUN.VALUE = character(9), ops, function(x) paste0(x, "0.00", 1:9)))),
|
||||
unique(c(t(vapply(FUN.VALUE = character(104), ops, function(x) paste0(x, sort(as.double(paste0("0.0",
|
||||
sort(c(1:99, 125, 128, 256, 512, 625)))))))))),
|
||||
unique(c(t(sapply(ops, function(x) paste0(x, sort(as.double(paste0("0.",
|
||||
unique(c(t(vapply(FUN.VALUE = character(103), ops, function(x) paste0(x, sort(as.double(paste0("0.",
|
||||
c(1:99, 125, 128, 256, 512))))))))),
|
||||
c(t(sapply(ops, function(x) paste0(x, sort(c(1:9, 1.5)))))),
|
||||
c(t(sapply(ops, function(x) paste0(x, c(10:98)[9:98 %% 2 == TRUE])))),
|
||||
c(t(sapply(ops, function(x) paste0(x, sort(c(2 ^ c(7:10), 80 * c(2:12))))))))
|
||||
c(t(vapply(FUN.VALUE = character(10), ops, function(x) paste0(x, sort(c(1:9, 1.5)))))),
|
||||
c(t(vapply(FUN.VALUE = character(45), ops, function(x) paste0(x, c(10:98)[9:98 %% 2 == TRUE])))),
|
||||
c(t(vapply(FUN.VALUE = character(15), ops, function(x) paste0(x, sort(c(2 ^ c(7:10), 80 * c(2:12))))))))
|
||||
|
||||
na_before <- x[is.na(x) | x == ""] %pm>% length()
|
||||
x[!x %in% lvls] <- NA
|
||||
|
||||
10
R/pca.R
10
R/pca.R
@ -97,7 +97,7 @@ pca <- function(x,
|
||||
}
|
||||
|
||||
x <- as.data.frame(new_list, stringsAsFactors = FALSE)
|
||||
if (any(sapply(x, function(y) !is.numeric(y)))) {
|
||||
if (any(vapply(FUN.VALUE = logical(1), x, function(y) !is.numeric(y)))) {
|
||||
warning_("Be sure to first calculate the resistance (or susceptibility) of variables with antimicrobial test results, since PCA works with numeric variables only. Please see Examples in ?pca.")
|
||||
}
|
||||
|
||||
@ -106,21 +106,21 @@ pca <- function(x,
|
||||
error = function(e) warning("column names could not be set"))
|
||||
|
||||
# keep only numeric columns
|
||||
x <- x[, sapply(x, function(y) is.numeric(y))]
|
||||
x <- x[, vapply(FUN.VALUE = logical(1), x, function(y) is.numeric(y))]
|
||||
# bind the data set with the non-numeric columns
|
||||
x <- cbind(x.bak[, sapply(x.bak, function(y) !is.numeric(y) & !all(is.na(y))), drop = FALSE], x)
|
||||
x <- cbind(x.bak[, vapply(FUN.VALUE = logical(1), x.bak, function(y) !is.numeric(y) & !all(is.na(y))), drop = FALSE], x)
|
||||
}
|
||||
|
||||
x <- pm_ungroup(x) # would otherwise select the grouping vars
|
||||
x <- x[rowSums(is.na(x)) == 0, ] # remove columns containing NAs
|
||||
|
||||
pca_data <- x[, which(sapply(x, function(x) is.numeric(x)))]
|
||||
pca_data <- x[, which(vapply(FUN.VALUE = logical(1), x, function(x) is.numeric(x)))]
|
||||
|
||||
message_("Columns selected for PCA: ", paste0(font_bold(colnames(pca_data)), collapse = "/"),
|
||||
". Total observations available: ", nrow(pca_data), ".")
|
||||
|
||||
pca_model <- prcomp(pca_data, retx = retx, center = center, scale. = scale., tol = tol, rank. = rank.)
|
||||
attr(pca_model, "non_numeric_cols") <- x[, sapply(x, function(y) !is.numeric(y) & !all(is.na(y))), drop = FALSE]
|
||||
attr(pca_model, "non_numeric_cols") <- x[, vapply(FUN.VALUE = logical(1), x, function(y) !is.numeric(y) & !all(is.na(y))), drop = FALSE]
|
||||
class(pca_model) <- c("pca", class(pca_model))
|
||||
pca_model
|
||||
}
|
||||
|
||||
@ -192,7 +192,9 @@ resistance_predict <- function(x,
|
||||
rownames(df) <- NULL
|
||||
|
||||
df <- subset(df, sum(df$R + df$S, na.rm = TRUE) >= minimum)
|
||||
# nolint start
|
||||
df_matrix <- as.matrix(df[, c("R", "S"), drop = FALSE])
|
||||
# nolint end
|
||||
|
||||
stop_if(NROW(df) == 0, "there are no observations")
|
||||
|
||||
|
||||
23
R/rsi.R
23
R/rsi.R
@ -544,7 +544,7 @@ as.rsi.data.frame <- function(x,
|
||||
sel <- sel[sel != col_mo]
|
||||
}
|
||||
|
||||
ab_cols <- colnames(x)[sapply(x, function(y) {
|
||||
ab_cols <- colnames(x)[vapply(FUN.VALUE = logical(1), x, function(y) {
|
||||
i <<- i + 1
|
||||
check <- is.mic(y) | is.disk(y)
|
||||
ab <- colnames(x)[i]
|
||||
@ -571,11 +571,11 @@ as.rsi.data.frame <- function(x,
|
||||
"no columns with MIC values, disk zones or antibiotic column names found in this data set. Use as.mic() or as.disk() to transform antimicrobial columns.")
|
||||
# set type per column
|
||||
types <- character(length(ab_cols))
|
||||
types[sapply(x.bak[, ab_cols, drop = FALSE], is.disk)] <- "disk"
|
||||
types[sapply(x.bak[, ab_cols, drop = FALSE], is.mic)] <- "mic"
|
||||
types[types == "" & sapply(x[, ab_cols, drop = FALSE], all_valid_disks)] <- "disk"
|
||||
types[types == "" & sapply(x[, ab_cols, drop = FALSE], all_valid_mics)] <- "mic"
|
||||
types[types == "" & !sapply(x.bak[, ab_cols, drop = FALSE], is.rsi)] <- "rsi"
|
||||
types[vapply(FUN.VALUE = logical(1), x.bak[, ab_cols, drop = FALSE], is.disk)] <- "disk"
|
||||
types[vapply(FUN.VALUE = logical(1), x.bak[, ab_cols, drop = FALSE], is.mic)] <- "mic"
|
||||
types[types == "" & vapply(FUN.VALUE = logical(1), x[, ab_cols, drop = FALSE], all_valid_disks)] <- "disk"
|
||||
types[types == "" & vapply(FUN.VALUE = logical(1), x[, ab_cols, drop = FALSE], all_valid_mics)] <- "mic"
|
||||
types[types == "" & !vapply(FUN.VALUE = logical(1), x.bak[, ab_cols, drop = FALSE], is.rsi)] <- "rsi"
|
||||
if (any(types %in% c("mic", "disk"), na.rm = TRUE)) {
|
||||
# now we need an mo column
|
||||
stop_if(is.null(col_mo), "`col_mo` must be set")
|
||||
@ -861,7 +861,8 @@ freq.rsi <- function(x, ...) {
|
||||
x_name <- gsub(".*[$]", "", x_name)
|
||||
if (x_name %in% c("x", ".")) {
|
||||
# try again going through system calls
|
||||
x_name <- stats::na.omit(sapply(sys.calls(),
|
||||
x_name <- stats::na.omit(vapply(FUN.VALUE = character(1),
|
||||
sys.calls(),
|
||||
function(call) {
|
||||
call_txt <- as.character(call)
|
||||
ifelse(call_txt[1] %like% "freq$", call_txt[length(call_txt)], character(0))
|
||||
@ -906,8 +907,8 @@ get_skimmers.rsi <- function(column) {
|
||||
if (is.null(vars) | is.null(i)) {
|
||||
NA_character_
|
||||
} else {
|
||||
lengths <- sapply(vars, length)
|
||||
when_starts_rsi <- which(names(sapply(vars, length)) == "rsi")
|
||||
lengths <- vapply(FUN.VALUE = double(1), vars, length)
|
||||
when_starts_rsi <- which(names(vapply(FUN.VALUE = double(1), vars, length)) == "rsi")
|
||||
offset <- sum(lengths[c(1:when_starts_rsi - 1)])
|
||||
var <- vars$rsi[i - offset]
|
||||
if (!isFALSE(var == "data")) {
|
||||
@ -1115,8 +1116,8 @@ unique.rsi <- function(x, incomparables = FALSE, ...) {
|
||||
|
||||
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 "))
|
||||
class_rsi <- vapply(FUN.VALUE = character(1), rsi_translation, function(x) paste0("<", class(x), ">", collapse = " and "))
|
||||
class_ref <- vapply(FUN.VALUE = character(1), 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)
|
||||
}
|
||||
|
||||
10
R/rsi_calc.R
10
R/rsi_calc.R
@ -129,12 +129,12 @@ rsi_calc <- function(...,
|
||||
MARGIN = 1,
|
||||
FUN = min)
|
||||
numerator <- sum(as.integer(y) %in% as.integer(ab_result), na.rm = TRUE)
|
||||
denominator <- sum(sapply(x_transposed, function(y) !(any(is.na(y)))))
|
||||
denominator <- sum(vapply(FUN.VALUE = logical(1), x_transposed, function(y) !(any(is.na(y)))))
|
||||
} else {
|
||||
# may contain NAs in any column
|
||||
other_values <- setdiff(c(NA, levels(ab_result)), ab_result)
|
||||
numerator <- sum(sapply(x_transposed, function(y) any(y %in% ab_result, na.rm = TRUE)))
|
||||
denominator <- sum(sapply(x_transposed, function(y) !(all(y %in% other_values) & any(is.na(y)))))
|
||||
numerator <- sum(vapply(FUN.VALUE = logical(1), x_transposed, function(y) any(y %in% ab_result, na.rm = TRUE)))
|
||||
denominator <- sum(vapply(FUN.VALUE = logical(1), x_transposed, function(y) !(all(y %in% other_values) & any(is.na(y)))))
|
||||
}
|
||||
} else {
|
||||
# x is not a data.frame
|
||||
@ -207,10 +207,10 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
|
||||
if (inherits(data, "grouped_df")) {
|
||||
data_has_groups <- TRUE
|
||||
groups <- setdiff(names(attributes(data)$groups), ".rows")
|
||||
data <- data[, c(groups, colnames(data)[sapply(data, is.rsi)]), drop = FALSE]
|
||||
data <- data[, c(groups, colnames(data)[vapply(FUN.VALUE = logical(1), data, is.rsi)]), drop = FALSE]
|
||||
} else {
|
||||
data_has_groups <- FALSE
|
||||
data <- data[, colnames(data)[sapply(data, is.rsi)], drop = FALSE]
|
||||
data <- data[, colnames(data)[vapply(FUN.VALUE = logical(1), data, is.rsi)], drop = FALSE]
|
||||
}
|
||||
|
||||
data <- as.data.frame(data, stringsAsFactors = FALSE)
|
||||
|
||||
@ -66,5 +66,5 @@ skewness.matrix <- function(x, na.rm = FALSE) {
|
||||
#' @export
|
||||
skewness.data.frame <- function(x, na.rm = FALSE) {
|
||||
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
|
||||
sapply(x, skewness.default, na.rm = na.rm)
|
||||
vapply(FUN.VALUE = double(1), x, skewness.default, na.rm = na.rm)
|
||||
}
|
||||
|
||||
BIN
R/sysdata.rda
BIN
R/sysdata.rda
Binary file not shown.
@ -300,6 +300,6 @@ genus_species is Moraxella catarrhalis NAL S fluoroquinolones S Expert Rules on
|
||||
genus_species is Moraxella catarrhalis NAL R fluoroquinolones R Expert Rules on Moraxella catarrhalis Expert Rules 3.2
|
||||
genus is Campylobacter ERY S CLR, AZM S Expert Rules on Campylobacter Expert Rules 3.2
|
||||
genus_species is Campylobacter ERY R CLR, AZM R Expert Rules on Campylobacter Expert Rules 3.2
|
||||
fullname like ^(Enterobacter|Klebsiella aerogenes|Citrobacter freundii|Hafnia alvei|Serratia|Morganella morganii|Providencia) CTX S CTX, CRO, CAZ Expert Rules on Enterobacterales (AmpC de-repressed cephalosporins) Expert Rules 3.2 This is rule 3 and 4 of EUCAST Expert Rules v3.2 on Enterobacterales, result will be set with the 'ampc_derepressed_cephalosporins' argument
|
||||
fullname like ^(Enterobacter|Klebsiella aerogenes|Citrobacter freundii|Hafnia alvei|Serratia|Morganella morganii|Providencia) CRO S CTX, CRO, CAZ Expert Rules on Enterobacterales (AmpC de-repressed cephalosporins) Expert Rules 3.2 This is rule 3 and 4 of EUCAST Expert Rules v3.2 on Enterobacterales, result will be set with the 'ampc_derepressed_cephalosporins' argument
|
||||
fullname like ^(Enterobacter|Klebsiella aerogenes|Citrobacter freundii|Hafnia alvei|Serratia|Morganella morganii|Providencia) CAZ S CTX, CRO, CAZ Expert Rules on Enterobacterales (AmpC de-repressed cephalosporins) Expert Rules 3.2 This is rule 3 and 4 of EUCAST Expert Rules v3.2 on Enterobacterales, result will be set with the 'ampc_derepressed_cephalosporins' argument
|
||||
fullname like ^(Enterobacter|Klebsiella aerogenes|Citrobacter (braakii|freundii|gillenii|murliniae|rodenticum|sedlakii|werkmanii|youngae)|Hafnia alvei|Serratia|Morganella morganii|Providencia) CTX S CTX, CRO, CAZ Expert Rules on Enterobacterales (AmpC de-repressed cephalosporins) Expert Rules 3.2 This is rule 3 and 4 of EUCAST Expert Rules v3.2 on Enterobacterales, result will be set with the 'ampc_derepressed_cephalosporins' argument
|
||||
fullname like ^(Enterobacter|Klebsiella aerogenes|Citrobacter (braakii|freundii|gillenii|murliniae|rodenticum|sedlakii|werkmanii|youngae)|Hafnia alvei|Serratia|Morganella morganii|Providencia) CRO S CTX, CRO, CAZ Expert Rules on Enterobacterales (AmpC de-repressed cephalosporins) Expert Rules 3.2 This is rule 3 and 4 of EUCAST Expert Rules v3.2 on Enterobacterales, result will be set with the 'ampc_derepressed_cephalosporins' argument
|
||||
fullname like ^(Enterobacter|Klebsiella aerogenes|Citrobacter (braakii|freundii|gillenii|murliniae|rodenticum|sedlakii|werkmanii|youngae)|Hafnia alvei|Serratia|Morganella morganii|Providencia) CAZ S CTX, CRO, CAZ Expert Rules on Enterobacterales (AmpC de-repressed cephalosporins) Expert Rules 3.2 This is rule 3 and 4 of EUCAST Expert Rules v3.2 on Enterobacterales, result will be set with the 'ampc_derepressed_cephalosporins' argument
|
||||
|
||||
|
Can't render this file because it contains an unexpected character in line 6 and column 96.
|
@ -81,7 +81,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<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.9051</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9052</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
|
||||
@ -81,7 +81,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<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.9051</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9052</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
|
||||
@ -81,7 +81,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<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.9051</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9052</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
|
||||
@ -81,7 +81,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<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.9051</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9052</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
|
||||
@ -43,7 +43,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<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.9051</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9052</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
@ -337,7 +337,7 @@ Since you are one of our users, we would like to know how you use the package an
|
||||
<div id="latest-released-version" class="section level4">
|
||||
<h4 class="hasAnchor">
|
||||
<a href="#latest-released-version" class="anchor"></a>Latest released version</h4>
|
||||
<p><img src="https://www.r-pkg.org/badges/version-ago/AMR"><img src="https://cranlogs.r-pkg.org/badges/grand-total/AMR"></p>
|
||||
<p><a href="https://cran.r-project.org/package=AMR"><img src="https://www.r-pkg.org/badges/version-ago/AMR" alt="CRAN"></a> <a href="https://cran.r-project.org/package=AMR"><img src="https://cranlogs.r-pkg.org/badges/grand-total/AMR" alt="CRANlogs"></a></p>
|
||||
<p>This package is available <a href="https://cran.r-project.org/package=AMR">here on the official R network (CRAN)</a>, which has a peer-reviewed submission process. Install this package in R from CRAN by using the command:</p>
|
||||
<div class="sourceCode" id="cb2"><pre class="downlit sourceCode r">
|
||||
<code class="sourceCode R"><span class="fu"><a href="https://rdrr.io/r/utils/install.packages.html">install.packages</a></span><span class="op">(</span><span class="st">"AMR"</span><span class="op">)</span></code></pre></div>
|
||||
@ -347,6 +347,7 @@ Since you are one of our users, we would like to know how you use the package an
|
||||
<div id="latest-development-version" class="section level4">
|
||||
<h4 class="hasAnchor">
|
||||
<a href="#latest-development-version" class="anchor"></a>Latest development version</h4>
|
||||
<p><img src="https://github.com/msberends/AMR/workflows/R-code-check/badge.svg?branch=master" alt="R-code-check"><a href="https://www.codefactor.io/repository/github/msberends/amr"><img src="https://www.codefactor.io/repository/github/msberends/amr/badge" alt="CodeFactor"></a> <a href="https://codecov.io/gh/msberends/AMR?branch=master"><img src="https://codecov.io/gh/msberends/AMR/branch/master/graph/badge.svg" alt="Codecov"></a></p>
|
||||
<p>The latest and unpublished development version can be installed from GitHub using:</p>
|
||||
<div class="sourceCode" id="cb3"><pre class="downlit sourceCode r">
|
||||
<code class="sourceCode R"><span class="fu"><a href="https://rdrr.io/r/utils/install.packages.html">install.packages</a></span><span class="op">(</span><span class="st">"remotes"</span><span class="op">)</span>
|
||||
|
||||
@ -81,7 +81,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<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.9051</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9052</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
@ -236,13 +236,13 @@
|
||||
<small>Source: <a href='https://github.com/msberends/AMR/blob/master/NEWS.md'><code>NEWS.md</code></a></small>
|
||||
</div>
|
||||
|
||||
<div id="amr-1409051" class="section level1">
|
||||
<h1 class="page-header" data-toc-text="1.4.0.9051">
|
||||
<a href="#amr-1409051" class="anchor"></a>AMR 1.4.0.9051<small> Unreleased </small>
|
||||
<div id="amr-1409052" class="section level1">
|
||||
<h1 class="page-header" data-toc-text="1.4.0.9052">
|
||||
<a href="#amr-1409052" class="anchor"></a>AMR 1.4.0.9052<small> Unreleased </small>
|
||||
</h1>
|
||||
<div id="last-updated-27-december-2020" class="section level2">
|
||||
<div id="last-updated-28-december-2020" class="section level2">
|
||||
<h2 class="hasAnchor">
|
||||
<a href="#last-updated-27-december-2020" class="anchor"></a><small>Last updated: 27 December 2020</small>
|
||||
<a href="#last-updated-28-december-2020" class="anchor"></a><small>Last updated: 28 December 2020</small>
|
||||
</h2>
|
||||
<div id="new" class="section level3">
|
||||
<h3 class="hasAnchor">
|
||||
@ -317,6 +317,9 @@
|
||||
<li>More extensive unit tests</li>
|
||||
<li>Internal calls to <code><a href="https://rdrr.io/r/base/options.html">options()</a></code> were all removed in favour of a new internal environment <code>pkg_env</code>
|
||||
</li>
|
||||
<li>Improved internal type setting (among other things: replaced all <code><a href="https://rdrr.io/r/base/lapply.html">sapply()</a></code> calls with <code><a href="https://rdrr.io/r/base/lapply.html">vapply()</a></code>)</li>
|
||||
<li>Added CodeFactor as a continuous code review to this package: <a href="https://www.codefactor.io/repository/github/msberends/amr/" class="uri">https://www.codefactor.io/repository/github/msberends/amr/</a>
|
||||
</li>
|
||||
<li>Added Dr. Rogier Schade as contributor</li>
|
||||
</ul>
|
||||
</div>
|
||||
|
||||
@ -12,7 +12,7 @@ articles:
|
||||
datasets: datasets.html
|
||||
resistance_predict: resistance_predict.html
|
||||
welcome_to_AMR: welcome_to_AMR.html
|
||||
last_built: 2020-12-27T22:17Z
|
||||
last_built: 2020-12-28T21:24Z
|
||||
urls:
|
||||
reference: https://msberends.github.io/AMR//reference
|
||||
article: https://msberends.github.io/AMR//articles
|
||||
|
||||
@ -83,7 +83,7 @@ To improve the interpretation of the antibiogram before EUCAST rules are applied
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<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.9050</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9052</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
@ -289,7 +289,7 @@ To improve the interpretation of the antibiogram before EUCAST rules are applied
|
||||
</tr>
|
||||
<tr>
|
||||
<th>ampc_cephalosporin_resistance</th>
|
||||
<td><p>a character value that should be applied for AmpC de-repressed cephalosporin-resistant mutants, defaults to <code>NA</code>. Currently only works when <code>version_expertrules</code> is <code>3.2</code>; '<em>EUCAST Expert Rules v3.2 on Enterobacterales</em>' states that susceptible (S) results of cefotaxime, ceftriaxone and ceftazidime should be reported with a note, or results should be suppressed (emptied) for these agents. A value of <code>NA</code> for this argument will remove results for these agents, while e.g. a value of <code>"R"</code> will make the results for these agents resistant. Use <code>NULL</code> to not alter the results for AmpC de-repressed cephalosporin-resistant mutants. <br /> For <em>EUCAST Expert Rules</em> v3.2, this rule applies to: <em>Enterobacter</em>, <em>Klebsiella aerogenes</em>, <em>Citrobacter freundii</em>, <em>Hafnia alvei</em>, <em>Serratia</em>, <em>Morganella morganii</em>, <em>Providencia</em>.</p></td>
|
||||
<td><p>a character value that should be applied for AmpC de-repressed cephalosporin-resistant mutants, defaults to <code>NA</code>. Currently only works when <code>version_expertrules</code> is <code>3.2</code>; '<em>EUCAST Expert Rules v3.2 on Enterobacterales</em>' states that susceptible (S) results of cefotaxime, ceftriaxone and ceftazidime should be reported with a note, or results should be suppressed (emptied) for these agents. A value of <code>NA</code> for this argument will remove results for these agents, while e.g. a value of <code>"R"</code> will make the results for these agents resistant. Use <code>NULL</code> to not alter the results for AmpC de-repressed cephalosporin-resistant mutants. <br /> For <em>EUCAST Expert Rules</em> v3.2, this rule applies to: <em>Enterobacter, Klebsiella aerogenes, Citrobacter freundii, Hafnia alvei, Serratia, Morganella morganii, Providencia</em>.</p></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<th>...</th>
|
||||
|
||||
@ -81,7 +81,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<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.9051</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9052</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
|
||||
@ -81,7 +81,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<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.9051</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9052</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
|
||||
8
index.md
8
index.md
@ -88,8 +88,8 @@ This package can be used for:
|
||||
### Get this package
|
||||
|
||||
#### Latest released version
|
||||
<img src="https://www.r-pkg.org/badges/version-ago/AMR" />
|
||||
<img src="https://cranlogs.r-pkg.org/badges/grand-total/AMR" />
|
||||
[](https://cran.r-project.org/package=AMR)
|
||||
[](https://cran.r-project.org/package=AMR)
|
||||
|
||||
This package is available [here on the official R network (CRAN)](https://cran.r-project.org/package=AMR), which has a peer-reviewed submission process. Install this package in R from CRAN by using the command:
|
||||
|
||||
@ -102,8 +102,12 @@ It will be downloaded and installed automatically. For RStudio, click on the men
|
||||
**Note:** Not all functions on this website may be available in this latest release. To use all functions and data sets mentioned on this website, install the latest development version.
|
||||
|
||||
#### Latest development version
|
||||
|
||||
[](https://www.codefactor.io/repository/github/msberends/amr)
|
||||
[](https://codecov.io/gh/msberends/AMR?branch=master)
|
||||
|
||||
The latest and unpublished development version can be installed from GitHub using:
|
||||
|
||||
```r
|
||||
install.packages("remotes")
|
||||
remotes::install_github("msberends/AMR")
|
||||
|
||||
@ -42,7 +42,7 @@ eucast_rules(
|
||||
|
||||
\item{version_expertrules}{the version number to use for the EUCAST Expert Rules and Intrinsic Resistance guideline. Currently supported: 3.1, 3.2.}
|
||||
|
||||
\item{ampc_cephalosporin_resistance}{a character value that should be applied for AmpC de-repressed cephalosporin-resistant mutants, defaults to \code{NA}. Currently only works when \code{version_expertrules} is \code{3.2}; '\emph{EUCAST Expert Rules v3.2 on Enterobacterales}' states that susceptible (S) results of cefotaxime, ceftriaxone and ceftazidime should be reported with a note, or results should be suppressed (emptied) for these agents. A value of \code{NA} for this argument will remove results for these agents, while e.g. a value of \code{"R"} will make the results for these agents resistant. Use \code{NULL} to not alter the results for AmpC de-repressed cephalosporin-resistant mutants. \cr For \emph{EUCAST Expert Rules} v3.2, this rule applies to: \emph{Enterobacter}, \emph{Klebsiella aerogenes}, \emph{Citrobacter freundii}, \emph{Hafnia alvei}, \emph{Serratia}, \emph{Morganella morganii}, \emph{Providencia}.}
|
||||
\item{ampc_cephalosporin_resistance}{a character value that should be applied for AmpC de-repressed cephalosporin-resistant mutants, defaults to \code{NA}. Currently only works when \code{version_expertrules} is \code{3.2}; '\emph{EUCAST Expert Rules v3.2 on Enterobacterales}' states that susceptible (S) results of cefotaxime, ceftriaxone and ceftazidime should be reported with a note, or results should be suppressed (emptied) for these agents. A value of \code{NA} for this argument will remove results for these agents, while e.g. a value of \code{"R"} will make the results for these agents resistant. Use \code{NULL} to not alter the results for AmpC de-repressed cephalosporin-resistant mutants. \cr For \emph{EUCAST Expert Rules} v3.2, this rule applies to: \emph{Enterobacter, Klebsiella aerogenes, Citrobacter freundii, Hafnia alvei, Serratia, Morganella morganii, Providencia}.}
|
||||
|
||||
\item{...}{column name of an antibiotic, please see section \emph{Antibiotics} below}
|
||||
}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user