Browse Source

(v1.4.0.9052) replaced all sapply's with type-safe vapply's

main
parent
commit
526f8afb08
  1. 2
      .github/workflows/lintr.yaml
  2. 4
      DESCRIPTION
  3. 6
      NEWS.md
  4. 21
      R/aa_helper_functions.R
  5. 16
      R/ab_class_selectors.R
  6. 4
      R/ab_from_text.R
  7. 6
      R/availability.R
  8. 8
      R/bug_drug_combinations.R
  9. 4
      R/data.R
  10. 4
      R/disk.R
  11. 18
      R/eucast_rules.R
  12. 2
      R/filter_ab_class.R
  13. 1
      R/ggplot_pca.R
  14. 10
      R/guess_ab_col.R
  15. 2
      R/kurtosis.R
  16. 2
      R/like.R
  17. 49
      R/mdro.R
  18. 12
      R/mic.R
  19. 10
      R/pca.R
  20. 2
      R/resistance_predict.R
  21. 23
      R/rsi.R
  22. 10
      R/rsi_calc.R
  23. 2
      R/skewness.R
  24. BIN
      R/sysdata.rda
  25. 6
      data-raw/eucast_rules.tsv
  26. 2
      docs/404.html
  27. 2
      docs/LICENSE-text.html
  28. 2
      docs/articles/index.html
  29. 2
      docs/authors.html
  30. 5
      docs/index.html
  31. 15
      docs/news/index.html
  32. 2
      docs/pkgdown.yml
  33. 4
      docs/reference/eucast_rules.html
  34. 2
      docs/reference/index.html
  35. 2
      docs/survey.html
  36. 8
      index.md
  37. 2
      man/eucast_rules.Rd

2
.github/workflows/lintr.yaml

@ -66,5 +66,5 @@ jobs: @@ -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}

4
DESCRIPTION

@ -1,6 +1,6 @@ @@ -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

@ -1,5 +1,5 @@ @@ -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 @@ @@ -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

21
R/aa_helper_functions.R

@ -119,8 +119,8 @@ search_type_in_df <- function(x, type, info = TRUE) { @@ -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) { @@ -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) { @@ -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) { @@ -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(..., @@ -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, @@ -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, ".",

16
R/ab_class_selectors.R

@ -163,14 +163,24 @@ ab_selector <- function(ab_class, function_name) { @@ -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) { @@ -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,

4
R/ab_from_text.R

@ -115,7 +115,7 @@ ab_from_text <- function(text, @@ -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, @@ -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 {

6
R/availability.R

@ -46,11 +46,11 @@ availability <- function(tbl, width = NULL) { @@ -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)] <- ""

8
R/bug_drug_combinations.R

@ -75,7 +75,7 @@ bug_drug_combinations <- function(x, @@ -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, @@ -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, @@ -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, @@ -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

@ -178,7 +178,7 @@ catalogue_of_life <- list( @@ -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( @@ -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

@ -69,13 +69,13 @@ as.disk <- function(x, na.rm = FALSE) { @@ -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{{",

18
R/eucast_rules.R

@ -64,7 +64,8 @@ format_eucast_version_nr <- function(version, markdown = TRUE) { @@ -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, @@ -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, @@ -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, @@ -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)

2
R/filter_ab_class.R

@ -165,7 +165,7 @@ filter_ab_class <- function(x, @@ -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

1
R/ggplot_pca.R

@ -306,7 +306,6 @@ pca_calculations <- function(pca_model, @@ -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")
}

10
R/guess_ab_col.R

@ -139,13 +139,13 @@ get_column_abx <- function(x, @@ -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)

2
R/kurtosis.R

@ -71,5 +71,5 @@ kurtosis.matrix <- function(x, na.rm = FALSE, excess = FALSE) { @@ -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

@ -102,7 +102,7 @@ like <- function(x, pattern, ignore.case = TRUE) { @@ -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

@ -193,28 +193,28 @@ mdro <- function(x, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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

@ -107,14 +107,14 @@ as.mic <- function(x, na.rm = FALSE) { @@ -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

@ -97,7 +97,7 @@ pca <- function(x, @@ -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, @@ -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
}

2
R/resistance_predict.R

@ -192,7 +192,9 @@ resistance_predict <- function(x, @@ -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

@ -544,7 +544,7 @@ as.rsi.data.frame <- function(x, @@ -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, @@ -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, ...) { @@ -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) { @@ -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, ...) { @@ -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

@ -129,12 +129,12 @@ rsi_calc <- function(..., @@ -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" @@ -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)

2
R/skewness.R

@ -66,5 +66,5 @@ skewness.matrix <- function(x, na.rm = 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

Binary file not shown.

6
data-raw/eucast_rules.tsv

@ -300,6 +300,6 @@ genus_species is Moraxella catarrhalis NAL S fluoroquinolones S Expert Rules on @@ -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.

2
docs/404.html

@ -81,7 +81,7 @@ @@ -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>

2
docs/LICENSE-text.html

@ -81,7 +81,7 @@ @@ -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>

2
docs/articles/index.html

@ -81,7 +81,7 @@ @@ -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>

2
docs/authors.html

@ -81,7 +81,7 @@ @@ -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>

5
docs/index.html

@ -43,7 +43,7 @@ @@ -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 @@ -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 @@ -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>

15
docs/news/index.html

@ -81,7 +81,7 @@ @@ -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 @@ @@ -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 @@ @@ -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>

2
docs/pkgdown.yml

@ -12,7 +12,7 @@ articles: @@ -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

4
docs/reference/eucast_rules.html

@ -83,7 +83,7 @@ To improve the interpretation of the antibiogram before EUCAST rules are applied @@ -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 @@ -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>

2
docs/reference/index.html

@ -81,7 +81,7 @@ @@ -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>

2
docs/survey.html

@ -81,7 +81,7 @@ @@ -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

@ -88,8 +88,8 @@ This package can be used for: @@ -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" />
[![CRAN](https://www.r-pkg.org/badges/version-ago/AMR)](https://cran.r-project.org/package=AMR)
[![CRANlogs](https://cranlogs.r-pkg.org/badges/grand-total/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 @@ -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
![R-code-check](https://github.com/msberends/AMR/workflows/R-code-check/badge.svg?branch=master)
[![CodeFactor](https://www.codefactor.io/repository/github/msberends/amr/badge)](https://www.codefactor.io/repository/github/msberends/amr)
[![Codecov](https://codecov.io/gh/msberends/AMR/branch/master/graph/badge.svg)](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")

2
man/eucast_rules.Rd

@ -42,7 +42,7 @@ eucast_rules( @@ -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…
Cancel
Save