P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2024-12-25 19:26:13 +01:00
Code Releases Activity

(v0.7.1.9102) lintr

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends 2019-10-11 17:21:02 +02:00
parent 59af355a89
commit 00cdb498a0
65 changed files with 620 additions and 812 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.Rbuildignore
View File

@ -22,3 +22,4 @@
^public$ ^public$
^data-raw$ ^data-raw$
R/aa_test.R$ R/aa_test.R$
^\.lintr$

1
.gitignore vendored
View File

@ -22,4 +22,3 @@ packrat/lib*/
packrat/src/ packrat/src/
data-raw/taxon.tab data-raw/taxon.tab
data-raw/DSMZ_bactnames.xlsx data-raw/DSMZ_bactnames.xlsx
R/aa_test.R

6
.gitlab-ci.R
View File

@ -29,7 +29,8 @@ install_if_needed <- function(pkg, repos, quiet) {
gl_update_pkg_all <- function(repos = "https://cran.rstudio.com", gl_update_pkg_all <- function(repos = "https://cran.rstudio.com",
quiet = TRUE, quiet = TRUE,
install_pkgdown = FALSE) { install_pkgdown = FALSE,
install_lintr = FALSE) {
# update existing # update existing
update.packages(ask = FALSE, repos = repos, quiet = quiet) update.packages(ask = FALSE, repos = repos, quiet = quiet)
@ -37,6 +38,9 @@ gl_update_pkg_all <- function(repos = "https://cran.rstudio.com",
if (install_pkgdown == TRUE) { if (install_pkgdown == TRUE) {
install_if_needed(pkg = "pkgdown", repos = repos, quiet = quiet) install_if_needed(pkg = "pkgdown", repos = repos, quiet = quiet)
} }
if (install_lintr == TRUE) {
install_if_needed(pkg = "lintr", repos = repos, quiet = quiet)
}
devtools::install_dev_deps(repos = repos, quiet = quiet, upgrade = TRUE) devtools::install_dev_deps(repos = repos, quiet = quiet, upgrade = TRUE)

10
.gitlab-ci.yml
View File

@ -26,6 +26,7 @@ stages:
- build - build
- test - test
- deploy - deploy
- lint
image: rocker/r-base image: rocker/r-base
@ -131,3 +132,12 @@ pages:
artifacts: artifacts:
paths: paths:
- public - public
lintr:
stage: lint
when: on_success
script:
# install missing and outdated packages
- Rscript -e 'source(".gitlab-ci.R"); gl_update_pkg_all(repos = "https://cran.rstudio.com", quiet = TRUE, install_pkgdown = FALSE, install_lintr = TRUE)'
# check all syntax with lintr
- Rscript -e 'lintr::lint_package()'

2
.lintr Normal file
View File

@ -0,0 +1,2 @@
linters: with_defaults(line_length_linter = NULL, trailing_whitespace_linter = NULL, object_name_linter = NULL, cyclocomp_linter = NULL, object_usage_linter = NULL, object_length_linter(length = 50L))
exclusions: list("R/mo_history.R", "tests/testthat/test-mo_history.R")

5
DESCRIPTION
View File

@ -1,6 +1,6 @@
Package: AMR Package: AMR
Version: 0.7.1.9101 Version: 0.7.1.9102
Date: 2019-10-09 Date: 2019-10-11
Title: Antimicrobial Resistance Analysis Title: Antimicrobial Resistance Analysis
Authors@R: c( Authors@R: c(
person(role = c("aut", "cre"), person(role = c("aut", "cre"),
@ -48,6 +48,7 @@ Suggests:
covr (>= 3.0.1), covr (>= 3.0.1),
curl, curl,
readxl, readxl,
rmarkdown,
rstudioapi, rstudioapi,
rvest (>= 0.3.2), rvest (>= 0.3.2),
testthat (>= 1.0.2), testthat (>= 1.0.2),

1
NAMESPACE
View File

@ -300,6 +300,7 @@ importFrom(graphics,par)
importFrom(graphics,plot) importFrom(graphics,plot)
importFrom(graphics,points) importFrom(graphics,points)
importFrom(graphics,text) importFrom(graphics,text)
importFrom(knitr,kable)
importFrom(microbenchmark,microbenchmark) importFrom(microbenchmark,microbenchmark)
importFrom(pillar,pillar_shaft) importFrom(pillar,pillar_shaft)
importFrom(pillar,type_sum) importFrom(pillar,type_sum)

5
NEWS.md
View File

@ -1,5 +1,5 @@
# AMR 0.7.1.9101 # AMR 0.7.1.9102
<small>Last updated: 09-Oct-2019</small> <small>Last updated: 11-Oct-2019</small>
### Breaking ### Breaking
* Determination of first isolates now **excludes** all 'unknown' microorganisms at default, i.e. microbial code `"UNKNOWN"`. They can be included with the new parameter `include_unknown`: * Determination of first isolates now **excludes** all 'unknown' microorganisms at default, i.e. microbial code `"UNKNOWN"`. They can be included with the new parameter `include_unknown`:
@ -126,6 +126,7 @@
#### Other #### Other
* Added Prof. Dr. Casper Albers as doctoral advisor and added Dr. Judith Fonville, Eric Hazenberg, Dr. Bart Meijer, Dr. Dennis Souverein and Annick Lenglet as contributors * Added Prof. Dr. Casper Albers as doctoral advisor and added Dr. Judith Fonville, Eric Hazenberg, Dr. Bart Meijer, Dr. Dennis Souverein and Annick Lenglet as contributors
* Cleaned the coding style of every single syntax line in this package with the help of the `lintr` package
# AMR 0.7.1 # AMR 0.7.1

12
R/ab.R
View File

@ -79,8 +79,6 @@ as.ab <- function(x, ...) {
x_bak_clean <- gsub("_[A-Z]{2}[0-9_]{0,3}$", "", x_bak_clean, ignore.case = TRUE) x_bak_clean <- gsub("_[A-Z]{2}[0-9_]{0,3}$", "", x_bak_clean, ignore.case = TRUE)
# remove part between brackets if that's followed by another string # remove part between brackets if that's followed by another string
x_bak_clean <- gsub("(.*)+ [(].*[)]", "\\1", x_bak_clean) x_bak_clean <- gsub("(.*)+ [(].*[)]", "\\1", x_bak_clean)
# keep only a-Z, 0-9, space, slash and dash
# x_bak_clean <- gsub("[^A-Z0-9 /-]", "", x_bak_clean, ignore.case = TRUE)
# keep only max 1 space # keep only max 1 space
x_bak_clean <- trimws(gsub(" +", " ", x_bak_clean, ignore.case = TRUE)) x_bak_clean <- trimws(gsub(" +", " ", x_bak_clean, ignore.case = TRUE))
# non-character, space or number should be a slash # non-character, space or number should be a slash
@ -93,7 +91,7 @@ as.ab <- function(x, ...) {
x_new <- rep(NA_character_, length(x)) x_new <- rep(NA_character_, length(x))
x_unknown <- character(0) x_unknown <- character(0)
for (i in 1:length(x)) { for (i in seq_len(length(x))) {
if (is.na(x[i]) | is.null(x[i])) { if (is.na(x[i]) | is.null(x[i])) {
next next
} }
@ -233,7 +231,7 @@ as.ab <- function(x, ...) {
# transform back from other languages and try again # transform back from other languages and try again
x_translated <- paste(lapply(strsplit(x[i], "[^a-zA-Z0-9 ]"), x_translated <- paste(lapply(strsplit(x[i], "[^a-zA-Z0-9 ]"),
function(y) { function(y) {
for (i in 1:length(y)) { for (i in seq_len(length(y))) {
y[i] <- ifelse(tolower(y[i]) %in% tolower(translations_file$replacement), y[i] <- ifelse(tolower(y[i]) %in% tolower(translations_file$replacement),
translations_file[which(tolower(translations_file$replacement) == tolower(y[i]) & translations_file[which(tolower(translations_file$replacement) == tolower(y[i]) &
!isFALSE(translations_file$fixed)), "pattern"], !isFALSE(translations_file$fixed)), "pattern"],
@ -252,7 +250,7 @@ as.ab <- function(x, ...) {
# now also try to coerce brandname combinations like "Amoxy/clavulanic acid" # now also try to coerce brandname combinations like "Amoxy/clavulanic acid"
x_translated <- paste(lapply(strsplit(x_translated, "[^a-zA-Z0-9 ]"), x_translated <- paste(lapply(strsplit(x_translated, "[^a-zA-Z0-9 ]"),
function(y) { function(y) {
for (i in 1:length(y)) { for (i in seq_len(length(y))) {
y_name <- suppressWarnings(ab_name(y[i], language = NULL, initial_search = FALSE, initial_search2 = FALSE)) y_name <- suppressWarnings(ab_name(y[i], language = NULL, initial_search = FALSE, initial_search2 = FALSE))
y[i] <- ifelse(!is.na(y_name), y[i] <- ifelse(!is.na(y_name),
y_name, y_name,
@ -278,14 +276,14 @@ as.ab <- function(x, ...) {
x_unknown <- x_unknown[!x_unknown %in% x_unknown_ATCs] x_unknown <- x_unknown[!x_unknown %in% x_unknown_ATCs]
if (length(x_unknown_ATCs) > 0) { if (length(x_unknown_ATCs) > 0) {
warning("These ATC codes are not (yet) in the antibiotics data set: ", warning("These ATC codes are not (yet) in the antibiotics data set: ",
paste('"', sort(unique(x_unknown_ATCs)), '"', sep = "", collapse = ', '), paste('"', sort(unique(x_unknown_ATCs)), '"', sep = "", collapse = ", "),
".", ".",
call. = FALSE) call. = FALSE)
} }
if (length(x_unknown) > 0) { if (length(x_unknown) > 0) {
warning("These values could not be coerced to a valid antimicrobial ID: ", warning("These values could not be coerced to a valid antimicrobial ID: ",
paste('"', sort(unique(x_unknown)), '"', sep = "", collapse = ', '), paste('"', sort(unique(x_unknown)), '"', sep = "", collapse = ", "),
".", ".",
call. = FALSE) call. = FALSE)
} }

2
R/ab_property.R
View File

@ -165,7 +165,7 @@ ab_info <- function(x, language = get_locale(), ...) {
#' @rdname ab_property #' @rdname ab_property
#' @export #' @export
ab_property <- function(x, property = 'name', language = get_locale(), ...) { ab_property <- function(x, property = "name", language = get_locale(), ...) {
if (length(property) != 1L) { if (length(property) != 1L) {
stop("'property' must be of length 1.") stop("'property' must be of length 1.")
} }

2
R/age.R
View File

@ -175,7 +175,7 @@ age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
# turn input values to 'split_at' indices # turn input values to 'split_at' indices
y <- x y <- x
labs <- split_at labs <- split_at
for (i in 1:length(split_at)) { for (i in seq_len(length(split_at))) {
y[x >= split_at[i]] <- i y[x >= split_at[i]] <- i
# create labels # create labels
labs[i - 1] <- paste0(unique(c(split_at[i - 1], split_at[i] - 1)), collapse = "-") labs[i - 1] <- paste0(unique(c(split_at[i - 1], split_at[i] - 1)), collapse = "-")

2
R/amr.R
View File

@ -65,6 +65,6 @@
#' \url{https://gitlab.com/msberends/AMR/issues} #' \url{https://gitlab.com/msberends/AMR/issues}
#' @name AMR #' @name AMR
#' @rdname AMR #' @rdname AMR
# # prevent NOTE on R >= 3.6
#' @importFrom microbenchmark microbenchmark #' @importFrom microbenchmark microbenchmark
#' @importFrom knitr kable
NULL NULL

39
R/atc_online.R
View File

@ -73,8 +73,8 @@
#' } #' }
atc_online_property <- function(atc_code, atc_online_property <- function(atc_code,
property, property,
administration = 'O', administration = "O",
url = 'https://www.whocc.no/atc_ddd_index/?code=%s&showdescription=no') { url = "https://www.whocc.no/atc_ddd_index/?code=%s&showdescription=no") {
if (!all(c("curl", "rvest", "xml2") %in% rownames(utils::installed.packages()))) { if (!all(c("curl", "rvest", "xml2") %in% rownames(utils::installed.packages()))) {
stop("Packages 'xml2', 'rvest' and 'curl' are required for this function") stop("Packages 'xml2', 'rvest' and 'curl' are required for this function")
@ -90,15 +90,15 @@ atc_online_property <- function(atc_code,
} }
if (length(property) != 1L) { if (length(property) != 1L) {
stop('`property` must be of length 1', call. = FALSE) stop("`property` must be of length 1", call. = FALSE)
} }
if (length(administration) != 1L) { if (length(administration) != 1L) {
stop('`administration` must be of length 1', call. = FALSE) stop("`administration` must be of length 1", call. = FALSE)
} }
# also allow unit as property # also allow unit as property
if (property %like% 'unit') { if (property %like% "unit") {
property <- 'U' property <- "U"
} }
# validation of properties # validation of properties
@ -109,12 +109,12 @@ atc_online_property <- function(atc_code,
valid_properties <- tolower(valid_properties) valid_properties <- tolower(valid_properties)
if (!property %in% valid_properties) { if (!property %in% valid_properties) {
stop('Invalid `property`, use one of ', paste(valid_properties.bak, collapse = ", "), '.') stop("Invalid `property`, use one of ", paste(valid_properties.bak, collapse = ", "), ".")
} }
if (property == 'ddd') { if (property == "ddd") {
returnvalue <- rep(NA_real_, length(atc_code)) returnvalue <- rep(NA_real_, length(atc_code))
} else if (property == 'groups') { } else if (property == "groups") {
returnvalue <- list() returnvalue <- list()
} else { } else {
returnvalue <- rep(NA_character_, length(atc_code)) returnvalue <- rep(NA_character_, length(atc_code))
@ -122,11 +122,11 @@ atc_online_property <- function(atc_code,
progress <- progress_estimated(n = length(atc_code)) progress <- progress_estimated(n = length(atc_code))
for (i in 1:length(atc_code)) { for (i in seq_len(length(atc_code))) {
progress$tick()$print() progress$tick()$print()
atc_url <- sub('%s', atc_code[i], url, fixed = TRUE) atc_url <- sub("%s", atc_code[i], url, fixed = TRUE)
if (property == "groups") { if (property == "groups") {
tbl <- xml2::read_html(atc_url) %>% tbl <- xml2::read_html(atc_url) %>%
@ -141,34 +141,34 @@ atc_online_property <- function(atc_code,
# select only text items where URL like "code=" # select only text items where URL like "code="
texts <- texts[grepl("?code=", tolower(hrefs), fixed = TRUE)] texts <- texts[grepl("?code=", tolower(hrefs), fixed = TRUE)]
# last one is antibiotics, skip it # last one is antibiotics, skip it
texts <- texts[1:length(texts) - 1] texts <- texts[seq_len(length(texts)) - 1]
returnvalue <- c(list(texts), returnvalue) returnvalue <- c(list(texts), returnvalue)
} else { } else {
tbl <- xml2::read_html(atc_url) %>% tbl <- xml2::read_html(atc_url) %>%
rvest::html_nodes('table') %>% rvest::html_nodes("table") %>%
rvest::html_table(header = TRUE) %>% rvest::html_table(header = TRUE) %>%
as.data.frame(stringsAsFactors = FALSE) as.data.frame(stringsAsFactors = FALSE)
# case insensitive column names # case insensitive column names
colnames(tbl) <- tolower(colnames(tbl)) %>% gsub('^atc.*', 'atc', .) colnames(tbl) <- tolower(colnames(tbl)) %>% gsub("^atc.*", "atc", .)
if (length(tbl) == 0) { if (length(tbl) == 0) {
warning('ATC not found: ', atc_code[i], '. Please check ', atc_url, '.', call. = FALSE) warning("ATC not found: ", atc_code[i], ". Please check ", atc_url, ".", call. = FALSE)
returnvalue[i] <- NA returnvalue[i] <- NA
next next
} }
if (property %in% c('atc', 'name')) { if (property %in% c("atc", "name")) {
# ATC and name are only in first row # ATC and name are only in first row
returnvalue[i] <- tbl[1, property] returnvalue[i] <- tbl[1, property]
} else { } else {
if (!'adm.r' %in% colnames(tbl) | is.na(tbl[1, 'adm.r'])) { if (!"adm.r" %in% colnames(tbl) | is.na(tbl[1, "adm.r"])) {
returnvalue[i] <- NA returnvalue[i] <- NA
next next
} else { } else {
for (j in 1:nrow(tbl)) { for (j in seq_len(length(tbl))) {
if (tbl[j, 'adm.r'] == administration) { if (tbl[j, "adm.r"] == administration) {
returnvalue[i] <- tbl[j, property] returnvalue[i] <- tbl[j, property]
} }
} }
@ -195,4 +195,3 @@ atc_online_groups <- function(atc_code, ...) {
atc_online_ddd <- function(atc_code, ...) { atc_online_ddd <- function(atc_code, ...) {
atc_online_property(atc_code = atc_code, property = "ddd", ...) atc_online_property(atc_code = atc_code, property = "ddd", ...)
} }

4
R/availability.R
View File

@ -44,7 +44,9 @@
#' select_if(is.rsi) %>% #' select_if(is.rsi) %>%
#' availability() #' availability()
availability <- function(tbl, width = NULL) { availability <- function(tbl, width = NULL) {
x <- base::sapply(tbl, function(x) { 1 - base::sum(base::is.na(x)) / base::length(x) }) x <- base::sapply(tbl, function(x) {
1 - base::sum(base::is.na(x)) / base::length(x)
})
n <- base::sapply(tbl, function(x) base::length(x[!base::is.na(x)])) n <- base::sapply(tbl, function(x) base::length(x[!base::is.na(x)]))
R <- base::sapply(tbl, function(x) base::ifelse(is.rsi(x), portion_R(x, minimum = 0), NA)) R <- base::sapply(tbl, function(x) base::ifelse(is.rsi(x), portion_R(x, minimum = 0), NA))
R_print <- character(length(R)) R_print <- character(length(R))

12
R/bug_drug_combinations.R
View File

@ -31,7 +31,7 @@
#' @param ... arguments passed on to \code{FUN} #' @param ... arguments passed on to \code{FUN}
#' @inheritParams rsi_df #' @inheritParams rsi_df
#' @inheritParams base::formatC #' @inheritParams base::formatC
#' @importFrom dplyr %>% rename group_by select mutate filter pull #' @importFrom dplyr %>% rename group_by select mutate filter summarise ungroup
#' @importFrom tidyr spread #' @importFrom tidyr spread
# @importFrom clean freq percentage # @importFrom clean freq percentage
#' @details The function \code{format} calculates the resistance per bug-drug combination. Use \code{combine_IR = FALSE} (default) to test R vs. S+I and \code{combine_IR = TRUE} to test R+I vs. S. #' @details The function \code{format} calculates the resistance per bug-drug combination. Use \code{combine_IR = FALSE} (default) to test R vs. S+I and \code{combine_IR = TRUE} to test R+I vs. S.
@ -46,7 +46,7 @@
#' \donttest{ #' \donttest{
#' x <- bug_drug_combinations(example_isolates) #' x <- bug_drug_combinations(example_isolates)
#' x #' x
#' format(x) #' format(x, translate_ab = "name (atc)")
#' #'
#' # Use FUN to change to transformation of microorganism codes #' # Use FUN to change to transformation of microorganism codes
#' x <- bug_drug_combinations(example_isolates, #' x <- bug_drug_combinations(example_isolates,
@ -76,7 +76,9 @@ bug_drug_combinations <- function(x,
x <- x %>% x <- x %>%
as.data.frame(stringsAsFactors = FALSE) %>% as.data.frame(stringsAsFactors = FALSE) %>%
mutate(mo = x %>% pull(col_mo) %>% FUN(...)) %>% mutate(mo = x %>%
pull(col_mo) %>%
FUN(...)) %>%
group_by(mo) %>% group_by(mo) %>%
select_if(is.rsi) %>% select_if(is.rsi) %>%
gather("ab", "value", -mo) %>% gather("ab", "value", -mo) %>%
@ -112,7 +114,7 @@ format.bug_drug_combinations <- function(x,
if (remove_intrinsic_resistant == TRUE) { if (remove_intrinsic_resistant == TRUE) {
x <- x %>% filter(R != total) x <- x %>% filter(R != total)
} }
if (combine_IR == FALSE | combine_SI == TRUE) { if (combine_SI == TRUE | combine_IR == FALSE) {
x$isolates <- x$R x$isolates <- x$R
} else { } else {
x$isolates <- x$R + x$I x$isolates <- x$R + x$I
@ -121,7 +123,7 @@ format.bug_drug_combinations <- function(x,
give_ab_name <- function(ab, format, language) { give_ab_name <- function(ab, format, language) {
format <- tolower(format) format <- tolower(format)
ab_txt <- rep(format, length(ab)) ab_txt <- rep(format, length(ab))
for (i in 1:length(ab_txt)) { for (i in seq_len(length(ab_txt))) {
ab_txt[i] <- gsub("ab", ab[i], ab_txt[i]) ab_txt[i] <- gsub("ab", ab[i], ab_txt[i])
ab_txt[i] <- gsub("cid", ab_cid(ab[i]), ab_txt[i]) ab_txt[i] <- gsub("cid", ab_cid(ab[i]), ab_txt[i])
ab_txt[i] <- gsub("group", ab_group(ab[i], language = language), ab_txt[i]) ab_txt[i] <- gsub("group", ab_group(ab[i], language = language), ab_txt[i])

4
R/data.R
View File

@ -203,10 +203,10 @@ dataset_UTF8_to_ASCII <- function(df) {
iconv(vect, from = "UTF-8", to = "ASCII//TRANSLIT") iconv(vect, from = "UTF-8", to = "ASCII//TRANSLIT")
} }
df <- as.data.frame(df, stringsAsFactors = FALSE) df <- as.data.frame(df, stringsAsFactors = FALSE)
for (i in 1:NCOL(df)) { for (i in seq_len(NCOL(df))) {
col <- df[, i] col <- df[, i]
if (is.list(col)) { if (is.list(col)) {
for (j in 1:length(col)) { for (j in seq_len(length(col))) {
col[[j]] <- trans(col[[j]]) col[[j]] <- trans(col[[j]])
} }
df[, i] <- list(col) df[, i] <- list(col)

8
R/disk.R
View File

@ -65,13 +65,13 @@ as.disk <- function(x, na.rm = FALSE) {
unique() %>% unique() %>%
sort() sort()
list_missing <- paste0('"', list_missing, '"', collapse = ", ") list_missing <- paste0('"', list_missing, '"', collapse = ", ")
warning(na_after - na_before, ' results truncated (', warning(na_after - na_before, " results truncated (",
round(((na_after - na_before) / length(x)) * 100), round(((na_after - na_before) / length(x)) * 100),
'%) that were invalid disk zones: ', "%) that were invalid disk zones: ",
list_missing, call. = FALSE) list_missing, call. = FALSE)
} }
class(x) <- c('disk', 'integer') class(x) <- c("disk", "integer")
x x
} }
} }
@ -80,7 +80,7 @@ as.disk <- function(x, na.rm = FALSE) {
#' @export #' @export
#' @importFrom dplyr %>% #' @importFrom dplyr %>%
is.disk <- function(x) { is.disk <- function(x) {
class(x) %>% identical(c('disk', 'integer')) class(x) %>% identical(c("disk", "integer"))
} }
#' @exportMethod print.disk #' @exportMethod print.disk

168
R/eucast_rules.R
View File

@ -233,8 +233,15 @@ eucast_rules <- function(x,
warned <- FALSE warned <- FALSE
txt_error <- function() { cat("", bgRed(white(" ERROR ")), "\n\n") } txt_error <- function() {
txt_warning <- function() { if (warned == FALSE) { cat("", bgYellow(black(" WARNING "))) }; warned <<- TRUE } cat("", bgRed(white(" ERROR ")), "\n\n")
}
txt_warning <- function() {
if (warned == FALSE) {
cat("", bgYellow(black(" WARNING ")))
}
warned <<- TRUE
}
txt_ok <- function(no_added, no_changed) { txt_ok <- function(no_added, no_changed) {
if (warned == FALSE) { if (warned == FALSE) {
if (no_added + no_changed == 0) { if (no_added + no_changed == 0) {
@ -337,69 +344,69 @@ eucast_rules <- function(x,
verbose = verbose, verbose = verbose,
...) ...)
AMC <- cols_ab['AMC'] AMC <- cols_ab["AMC"]
AMK <- cols_ab['AMK'] AMK <- cols_ab["AMK"]
AMP <- cols_ab['AMP'] AMP <- cols_ab["AMP"]
AMX <- cols_ab['AMX'] AMX <- cols_ab["AMX"]
ATM <- cols_ab['ATM'] ATM <- cols_ab["ATM"]
AZL <- cols_ab['AZL'] AZL <- cols_ab["AZL"]
AZM <- cols_ab['AZM'] AZM <- cols_ab["AZM"]
CAZ <- cols_ab['CAZ'] CAZ <- cols_ab["CAZ"]
CED <- cols_ab['CED'] CED <- cols_ab["CED"]
CHL <- cols_ab['CHL'] CHL <- cols_ab["CHL"]
CIP <- cols_ab['CIP'] CIP <- cols_ab["CIP"]
CLI <- cols_ab['CLI'] CLI <- cols_ab["CLI"]
CLR <- cols_ab['CLR'] CLR <- cols_ab["CLR"]
COL <- cols_ab['COL'] COL <- cols_ab["COL"]
CRO <- cols_ab['CRO'] CRO <- cols_ab["CRO"]
CTX <- cols_ab['CTX'] CTX <- cols_ab["CTX"]
CXM <- cols_ab['CXM'] CXM <- cols_ab["CXM"]
CZO <- cols_ab['CZO'] CZO <- cols_ab["CZO"]
DAP <- cols_ab['DAP'] DAP <- cols_ab["DAP"]
DOX <- cols_ab['DOX'] DOX <- cols_ab["DOX"]
ERY <- cols_ab['ERY'] ERY <- cols_ab["ERY"]
ETP <- cols_ab['ETP'] ETP <- cols_ab["ETP"]
FEP <- cols_ab['FEP'] FEP <- cols_ab["FEP"]
FLC <- cols_ab['FLC'] FLC <- cols_ab["FLC"]
FOS <- cols_ab['FOS'] FOS <- cols_ab["FOS"]
FOX <- cols_ab['FOX'] FOX <- cols_ab["FOX"]
FUS <- cols_ab['FUS'] FUS <- cols_ab["FUS"]
GEN <- cols_ab['GEN'] GEN <- cols_ab["GEN"]
IPM <- cols_ab['IPM'] IPM <- cols_ab["IPM"]
KAN <- cols_ab['KAN'] KAN <- cols_ab["KAN"]
LIN <- cols_ab['LIN'] LIN <- cols_ab["LIN"]
LNZ <- cols_ab['LNZ'] LNZ <- cols_ab["LNZ"]
LVX <- cols_ab['LVX'] LVX <- cols_ab["LVX"]
MEM <- cols_ab['MEM'] MEM <- cols_ab["MEM"]
MEZ <- cols_ab['MEZ'] MEZ <- cols_ab["MEZ"]
MFX <- cols_ab['MFX'] MFX <- cols_ab["MFX"]
MNO <- cols_ab['MNO'] MNO <- cols_ab["MNO"]
NAL <- cols_ab['NAL'] NAL <- cols_ab["NAL"]
NEO <- cols_ab['NEO'] NEO <- cols_ab["NEO"]
NET <- cols_ab['NET'] NET <- cols_ab["NET"]
NIT <- cols_ab['NIT'] NIT <- cols_ab["NIT"]
NOR <- cols_ab['NOR'] NOR <- cols_ab["NOR"]
NOV <- cols_ab['NOV'] NOV <- cols_ab["NOV"]
OFX <- cols_ab['OFX'] OFX <- cols_ab["OFX"]
OXA <- cols_ab['OXA'] OXA <- cols_ab["OXA"]
PEN <- cols_ab['PEN'] PEN <- cols_ab["PEN"]
PIP <- cols_ab['PIP'] PIP <- cols_ab["PIP"]
PLB <- cols_ab['PLB'] PLB <- cols_ab["PLB"]
PRI <- cols_ab['PRI'] PRI <- cols_ab["PRI"]
QDA <- cols_ab['QDA'] QDA <- cols_ab["QDA"]
RID <- cols_ab['RID'] RID <- cols_ab["RID"]
RIF <- cols_ab['RIF'] RIF <- cols_ab["RIF"]
RXT <- cols_ab['RXT'] RXT <- cols_ab["RXT"]
SIS <- cols_ab['SIS'] SIS <- cols_ab["SIS"]
SXT <- cols_ab['SXT'] SXT <- cols_ab["SXT"]
TCY <- cols_ab['TCY'] TCY <- cols_ab["TCY"]
TEC <- cols_ab['TEC'] TEC <- cols_ab["TEC"]
TGC <- cols_ab['TGC'] TGC <- cols_ab["TGC"]
TIC <- cols_ab['TIC'] TIC <- cols_ab["TIC"]
TMP <- cols_ab['TMP'] TMP <- cols_ab["TMP"]
TOB <- cols_ab['TOB'] TOB <- cols_ab["TOB"]
TZP <- cols_ab['TZP'] TZP <- cols_ab["TZP"]
VAN <- cols_ab['VAN'] VAN <- cols_ab["VAN"]
ab_missing <- function(ab) { ab_missing <- function(ab) {
all(ab %in% c(NULL, NA)) all(ab %in% c(NULL, NA))
@ -425,11 +432,11 @@ eucast_rules <- function(x,
# insert into original table # insert into original table
x_original[rows, cols] <<- to, x_original[rows, cols] <<- to,
warning = function(w) { warning = function(w) {
if (w$message %like% 'invalid factor level') { if (w$message %like% "invalid factor level") {
x_original <<- x_original %>% mutate_at(vars(cols), ~factor(x = as.character(.), levels = c(to, levels(.)))) x_original <<- x_original %>% mutate_at(vars(cols), ~factor(x = as.character(.), levels = c(to, levels(.))))
x <<- x %>% mutate_at(vars(cols), ~factor(x = as.character(.), levels = c(to, levels(.)))) x <<- x %>% mutate_at(vars(cols), ~factor(x = as.character(.), levels = c(to, levels(.))))
x_original[rows, cols] <<- to x_original[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.\nA better way is to use as.rsi() on beforehand on antimicrobial columns to guarantee the right structure.', call. = FALSE) warning('Value "', to, '" added to the factor levels of column(s) `', paste(cols, collapse = "`, `"), "` because this value was not an existing factor level.\nA better way is to use as.rsi() on beforehand on antimicrobial columns to guarantee the right structure.", call. = FALSE)
txt_warning() txt_warning()
warned <<- FALSE warned <<- FALSE
} else { } else {
@ -442,8 +449,8 @@ eucast_rules <- function(x,
txt_error() txt_error()
stop(paste0("In row(s) ", paste(rows[1:min(length(rows), 10)], collapse = ","), stop(paste0("In row(s) ", paste(rows[1:min(length(rows), 10)], collapse = ","),
ifelse(length(rows) > 10, "...", ""), ifelse(length(rows) > 10, "...", ""),
' while writing value "', to, " while writing value '", to,
'" to column(s) `', paste(cols, collapse = "`, `"), "' to column(s) `", paste(cols, collapse = "`, `"),
"`:\n", e$message), "`:\n", e$message),
call. = FALSE) call. = FALSE)
} }
@ -453,8 +460,8 @@ eucast_rules <- function(x,
x[rows, cols] <<- x_original[rows, cols], x[rows, cols] <<- x_original[rows, cols],
error = function(e) { error = function(e) {
stop(paste0("In row(s) ", paste(rows[1:min(length(rows), 10)], collapse = ","), stop(paste0("In row(s) ", paste(rows[1:min(length(rows), 10)], collapse = ","),
'... while writing value "', to, "... while writing value '", to,
'" to column(s) `', paste(cols, collapse = "`, `"), "' to column(s) `", paste(cols, collapse = "`, `"),
"`:\n", e$message), call. = FALSE) "`:\n", e$message), call. = FALSE)
} }
) )
@ -463,7 +470,7 @@ eucast_rules <- function(x,
old <- as.data.frame(before_df, stringsAsFactors = FALSE)[rows, ] old <- as.data.frame(before_df, stringsAsFactors = FALSE)[rows, ]
track_changes <- list(added = 0, track_changes <- list(added = 0,
changed = 0) changed = 0)
for (i in 1:length(cols)) { for (i in seq_len(length(cols))) {
verbose_new <- data.frame(row = rows, verbose_new <- data.frame(row = rows,
col = cols[i], col = cols[i],
mo_fullname = x[rows, "fullname"], mo_fullname = x[rows, "fullname"],
@ -530,6 +537,7 @@ eucast_rules <- function(x,
AMP <- AMX AMP <- AMX
} }
# nolint start
# antibiotic classes # antibiotic classes
aminoglycosides <- c(TOB, GEN, KAN, NEO, NET, SIS) aminoglycosides <- c(TOB, GEN, KAN, NEO, NET, SIS)
tetracyclines <- c(DOX, MNO, TCY) # since EUCAST v3.1 tigecycline (TGC) is set apart tetracyclines <- c(DOX, MNO, TCY) # since EUCAST v3.1 tigecycline (TGC) is set apart
@ -544,12 +552,13 @@ eucast_rules <- function(x,
ureidopenicillins <- c(PIP, TZP, AZL, MEZ) ureidopenicillins <- c(PIP, TZP, AZL, MEZ)
all_betalactams <- c(aminopenicillins, cephalosporins, carbapenems, ureidopenicillins, AMC, OXA, FLC, PEN) all_betalactams <- c(aminopenicillins, cephalosporins, carbapenems, ureidopenicillins, AMC, OXA, FLC, PEN)
fluoroquinolones <- c(OFX, CIP, NOR, LVX, MFX) fluoroquinolones <- c(OFX, CIP, NOR, LVX, MFX)
# nolint end
# Help function to get available antibiotic column names ------------------ # Help function to get available antibiotic column names ------------------
get_antibiotic_columns <- function(x, df) { get_antibiotic_columns <- function(x, df) {
x <- trimws(unlist(strsplit(x, ",", fixed = TRUE))) x <- trimws(unlist(strsplit(x, ",", fixed = TRUE)))
y <- character(0) y <- character(0)
for (i in 1:length(x)) { for (i in seq_len(length(x))) {
if (is.function(get(x[i]))) { if (is.function(get(x[i]))) {
stop("Column ", x[i], " is also a function. Please create an issue on github.com/msberends/AMR/issues.") stop("Column ", x[i], " is also a function. Please create an issue on github.com/msberends/AMR/issues.")
} }
@ -598,14 +607,13 @@ eucast_rules <- function(x,
eucast_rules_df <- eucast_rules_file # internal data file eucast_rules_df <- eucast_rules_file # internal data file
no_added <- 0 no_added <- 0
no_changed <- 0 no_changed <- 0
for (i in 1:nrow(eucast_rules_df)) { for (i in seq_len(nrow(eucast_rules_df))) {
rule_previous <- eucast_rules_df[max(1, i - 1), "reference.rule"] rule_previous <- eucast_rules_df[max(1, i - 1), "reference.rule"]
rule_current <- eucast_rules_df[i, "reference.rule"] rule_current <- eucast_rules_df[i, "reference.rule"]
rule_next <- eucast_rules_df[min(nrow(eucast_rules_df), i + 1), "reference.rule"] rule_next <- eucast_rules_df[min(nrow(eucast_rules_df), i + 1), "reference.rule"]
rule_group_previous <- eucast_rules_df[max(1, i - 1), "reference.rule_group"] rule_group_previous <- eucast_rules_df[max(1, i - 1), "reference.rule_group"]
rule_group_current <- eucast_rules_df[i, "reference.rule_group"] rule_group_current <- eucast_rules_df[i, "reference.rule_group"]
rule_group_next <- eucast_rules_df[min(nrow(eucast_rules_df), i + 1), "reference.rule_group"]
if (is.na(eucast_rules_df[i, 4])) { if (is.na(eucast_rules_df[i, 4])) {
rule_text <- paste0("always report as '", eucast_rules_df[i, 7], "': ", get_antibiotic_names(eucast_rules_df[i, 6])) rule_text <- paste0("always report as '", eucast_rules_df[i, 7], "': ", get_antibiotic_names(eucast_rules_df[i, 6]))
} else { } else {
@ -620,7 +628,6 @@ eucast_rules <- function(x,
} }
if (i == nrow(eucast_rules_df)) { if (i == nrow(eucast_rules_df)) {
rule_next <- "" rule_next <- ""
rule_group_next <- ""
} }
# don't apply rules if user doesn't want to apply them # don't apply rules if user doesn't want to apply them
@ -695,7 +702,7 @@ eucast_rules <- function(x,
if (like_is_one_of == "is") { if (like_is_one_of == "is") {
mo_value <- paste0("^", eucast_rules_df[i, 3], "$") mo_value <- paste0("^", eucast_rules_df[i, 3], "$")
} else if (like_is_one_of == "one_of") { } else if (like_is_one_of == "one_of") {
# "Clostridium, Actinomyces, ..." -> "^(Clostridium|Actinomyces|...)$" # so 'Clostridium, Actinomyces, ...' will turn into '^(Clostridium|Actinomyces|...)$'
mo_value <- paste0("^(", mo_value <- paste0("^(",
paste(trimws(unlist(strsplit(eucast_rules_df[i, 3], ",", fixed = TRUE))), paste(trimws(unlist(strsplit(eucast_rules_df[i, 3], ",", fixed = TRUE))),
collapse = "|"), collapse = "|"),
@ -774,10 +781,10 @@ eucast_rules <- function(x,
arrange(row, rule_group, rule_name, col) arrange(row, rule_group, rule_name, col)
cat(paste0("\n", grey(strrep("-", options()$width - 1)), "\n")) cat(paste0("\n", grey(strrep("-", options()$width - 1)), "\n"))
cat(bold(paste('EUCAST rules', paste0(wouldve, 'affected'), cat(bold(paste("EUCAST rules", paste0(wouldve, "affected"),
formatnr(n_distinct(verbose_info$row)), formatnr(n_distinct(verbose_info$row)),
'out of', formatnr(nrow(x_original)), "out of", formatnr(nrow(x_original)),
'rows, making a total of', formatnr(nrow(verbose_info)), 'edits\n'))) "rows, making a total of", formatnr(nrow(verbose_info)), "edits\n")))
n_added <- verbose_info %>% filter(is.na(old)) %>% nrow() n_added <- verbose_info %>% filter(is.na(old)) %>% nrow()
n_changed <- verbose_info %>% filter(!is.na(old)) %>% nrow() n_changed <- verbose_info %>% filter(!is.na(old)) %>% nrow()
@ -847,4 +854,3 @@ eucast_rules <- function(x,
x_original x_original
} }
} }

134
R/first_isolate.R
View File

@ -124,39 +124,11 @@
#' # set key antibiotics to a new variable #' # set key antibiotics to a new variable
#' x$keyab <- key_antibiotics(x) #' x$keyab <- key_antibiotics(x)
#' #'
#' x$first_isolate <- #' x$first_isolate <- first_isolate(x)
#' first_isolate(x)
#' #'
#' x$first_isolate_weighed <- #' x$first_isolate_weighed <- first_isolate(x, col_keyantibiotics = 'keyab')
#' first_isolate(x,
#' col_keyantibiotics = 'keyab')
#' #'
#' x$first_blood_isolate <- #' x$first_blood_isolate <- first_isolate(x, specimen_group = "Blood")
#' first_isolate(x,
#' specimen_group = 'Blood')
#'
#' x$first_blood_isolate_weighed <-
#' first_isolate(x,
#' specimen_group = 'Blood',
#' col_keyantibiotics = 'keyab')
#'
#' x$first_urine_isolate <-
#' first_isolate(x,
#' specimen_group = 'Urine')
#'
#' x$first_urine_isolate_weighed <-
#' first_isolate(x,
#' specimen_group = 'Urine',
#' col_keyantibiotics = 'keyab')
#'
#' x$first_resp_isolate <-
#' first_isolate(x,
#' specimen_group = 'Respiratory')
#'
#' x$first_resp_isolate_weighed <-
#' first_isolate(x,
#' specimen_group = 'Respiratory',
#' col_keyantibiotics = 'keyab')
#' } #' }
first_isolate <- function(x, first_isolate <- function(x,
col_date = NULL, col_date = NULL,
@ -185,11 +157,11 @@ first_isolate <- function(x,
if (length(dots) != 0) { if (length(dots) != 0) {
# backwards compatibility with old parameters # backwards compatibility with old parameters
dots.names <- dots %>% names() dots.names <- dots %>% names()
if ('filter_specimen' %in% dots.names) { if ("filter_specimen" %in% dots.names) {
specimen_group <- dots[which(dots.names == 'filter_specimen')] specimen_group <- dots[which(dots.names == "filter_specimen")]
} }
if ('tbl' %in% dots.names) { if ("tbl" %in% dots.names) {
x <- dots[which(dots.names == 'tbl')] x <- dots[which(dots.names == "tbl")]
} }
} }
@ -216,11 +188,11 @@ first_isolate <- function(x,
# -- patient id # -- patient id
if (is.null(col_patient_id)) { if (is.null(col_patient_id)) {
if (all(c("First name", "Last name", "Sex", "Identification number") %in% colnames(x))) { if (all(c("First name", "Last name", "Sex") %in% colnames(x))) {
# WHONET support # WHONET support
x <- x %>% mutate(patient_id = paste(`First name`, `Last name`, Sex)) x <- x %>% mutate(patient_id = paste(`First name`, `Last name`, Sex))
col_patient_id <- "patient_id" col_patient_id <- "patient_id"
message(blue(paste0("NOTE: Using combined columns `", bold("First name"), "`, `", bold("Last name"), "` and `", bold("Sex"), "` as input for `col_patient_id`."))) message(blue(paste0("NOTE: Using combined columns `", bold("First name"), "`, `", bold("Last name"), "` and `", bold("Sex"), "` as input for `col_patient_id`")))
} else { } else {
col_patient_id <- search_type_in_df(x = x, type = "patient_id") col_patient_id <- search_type_in_df(x = x, type = "patient_id")
} }
@ -248,12 +220,12 @@ first_isolate <- function(x,
# check if columns exist # check if columns exist
check_columns_existance <- function(column, tblname = x) { check_columns_existance <- function(column, tblname = x) {
if (NROW(tblname) <= 1 | NCOL(tblname) <= 1) { if (NROW(tblname) <= 1 | NCOL(tblname) <= 1) {
stop('Please check tbl for existance.') stop("Please check tbl for existance.")
} }
if (!is.null(column)) { if (!is.null(column)) {
if (!(column %in% colnames(tblname))) { if (!(column %in% colnames(tblname))) {
stop('Column `', column, '` not found.') stop("Column `", column, "` not found.")
} }
} }
} }
@ -267,7 +239,7 @@ first_isolate <- function(x,
# create new dataframe with original row index # create new dataframe with original row index
x <- x %>% x <- x %>%
mutate(newvar_row_index = 1:nrow(x), mutate(newvar_row_index = seq_len(nrow(x)),
newvar_mo = x %>% pull(col_mo) %>% as.mo(), newvar_mo = x %>% pull(col_mo) %>% as.mo(),
newvar_genus_species = paste(mo_genus(newvar_mo), mo_species(newvar_mo)), newvar_genus_species = paste(mo_genus(newvar_mo), mo_species(newvar_mo)),
newvar_date = x %>% pull(col_date), newvar_date = x %>% pull(col_date),
@ -278,7 +250,7 @@ first_isolate <- function(x,
} }
# remove testcodes # remove testcodes
if (!is.null(testcodes_exclude) & info == TRUE) { if (!is.null(testcodes_exclude) & info == TRUE) {
cat('[Criterion] Excluded test codes:\n', toString(testcodes_exclude), '\n') message(blue(paste0("[Criterion] Excluded test codes: ", toString(testcodes_exclude))))
} }
if (is.null(col_icu)) { if (is.null(col_icu)) {
@ -296,7 +268,7 @@ first_isolate <- function(x,
if (!is.null(specimen_group)) { if (!is.null(specimen_group)) {
check_columns_existance(col_specimen, x) check_columns_existance(col_specimen, x)
if (info == TRUE) { if (info == TRUE) {
cat('[Criterion] Excluded other than specimen group \'', specimen_group, '\'\n', sep = '') message(blue(paste0("[Criterion] Excluded other than specimen group '", specimen_group, "'")))
} }
} }
if (!is.null(col_keyantibiotics)) { if (!is.null(col_keyantibiotics)) {
@ -304,7 +276,7 @@ first_isolate <- function(x,
} }
if (is.null(testcodes_exclude)) { if (is.null(testcodes_exclude)) {
testcodes_exclude <- '' testcodes_exclude <- ""
} }
# arrange data to the right sorting # arrange data to the right sorting
@ -312,7 +284,7 @@ first_isolate <- function(x,
# not filtering on specimen # not filtering on specimen
if (icu_exclude == FALSE) { if (icu_exclude == FALSE) {
if (info == TRUE & !is.null(col_icu)) { if (info == TRUE & !is.null(col_icu)) {
cat('[Criterion] Included isolates from ICU.\n') message(blue("[Criterion] Included isolates from ICU"))
} }
x <- x %>% x <- x %>%
arrange(newvar_patient_id, arrange(newvar_patient_id,
@ -322,7 +294,7 @@ first_isolate <- function(x,
row.end <- nrow(x) row.end <- nrow(x)
} else { } else {
if (info == TRUE) { if (info == TRUE) {
cat('[Criterion] Excluded isolates from ICU.\n') message(blue("[Criterion] Excluded isolates from ICU"))
} }
x <- x %>% x <- x %>%
arrange_at(c(col_icu, arrange_at(c(col_icu,
@ -342,7 +314,7 @@ first_isolate <- function(x,
# filtering on specimen and only analyse these row to save time # filtering on specimen and only analyse these row to save time
if (icu_exclude == FALSE) { if (icu_exclude == FALSE) {
if (info == TRUE & !is.null(col_icu)) { if (info == TRUE & !is.null(col_icu)) {
cat('[Criterion] Included isolates from ICU.\n') message(blue("[Criterion] Included isolates from ICU.\n"))
} }
x <- x %>% x <- x %>%
arrange_at(c(col_specimen, arrange_at(c(col_specimen,
@ -357,7 +329,7 @@ first_isolate <- function(x,
) )
} else { } else {
if (info == TRUE) { if (info == TRUE) {
cat('[Criterion] Excluded isolates from ICU.\n') message(blue("[Criterion] Excluded isolates from ICU"))
} }
x <- x %>% x <- x %>%
arrange_at(c(col_icu, arrange_at(c(col_icu,
@ -366,12 +338,14 @@ first_isolate <- function(x,
"newvar_genus_species", "newvar_genus_species",
"newvar_date")) "newvar_date"))
suppressWarnings( suppressWarnings(
row.start <- which(x %>% pull(col_specimen) == specimen_group row.start <- min(which(x %>% pull(col_specimen) == specimen_group
& x %>% pull(col_icu) == FALSE) %>% min(na.rm = TRUE) & x %>% pull(col_icu) == FALSE),
na.rm = TRUE)
) )
suppressWarnings( suppressWarnings(
row.end <- which(x %>% pull(col_specimen) == specimen_group row.end <- max(which(x %>% pull(col_specimen) == specimen_group &
& x %>% pull(col_icu) == FALSE) %>% max(na.rm = TRUE) x %>% pull(col_icu) == FALSE),
na.rm = TRUE)
) )
} }
@ -386,21 +360,11 @@ first_isolate <- function(x,
} }
# did find some isolates - add new index numbers of rows # did find some isolates - add new index numbers of rows
x <- x %>% mutate(newvar_row_index_sorted = 1:nrow(.)) x <- x %>% mutate(newvar_row_index_sorted = seq_len(nrow(.)))
# suppress warnings because dplyr wants us to use library(dplyr) when using filter(row_number())
#suppressWarnings(
scope.size <- row.end - row.start + 1 scope.size <- row.end - row.start + 1
# x %>%
# filter(
# row_number() %>% between(row.start,
# row.end),
# newvar_genus != "",
# newvar_species != "") %>%
# nrow()
# )
identify_new_year = function(x, episode_days) { identify_new_year <- function(x, episode_days) {
# I asked on StackOverflow: # I asked on StackOverflow:
# https://stackoverflow.com/questions/42122245/filter-one-row-every-year # https://stackoverflow.com/questions/42122245/filter-one-row-every-year
if (length(x) == 1) { if (length(x) == 1) {
@ -434,20 +398,18 @@ first_isolate <- function(x,
episode_days = episode_days)) %>% episode_days = episode_days)) %>%
ungroup() ungroup()
weighted.notice <- '' weighted.notice <- ""
if (!is.null(col_keyantibiotics)) { if (!is.null(col_keyantibiotics)) {
weighted.notice <- 'weighted ' weighted.notice <- "weighted "
if (info == TRUE) { if (info == TRUE) {
if (type == 'keyantibiotics') { if (type == "keyantibiotics") {
cat('[Criterion] Inclusion based on key antibiotics, ') message(blue(paste0("[Criterion] Inclusion based on key antibiotics, ",
if (ignore_I == FALSE) { ifelse(ignore_I == FALSE, "not ", ""),
cat('not ') "ignoring I")))
} }
cat('ignoring I.\n') if (type == "points") {
} message(blue(paste0("[Criterion] Inclusion based on key antibiotics, using points threshold of "
if (type == 'points') { , points_threshold)))
cat(paste0('[Criterion] Inclusion based on key antibiotics, using points threshold of '
, points_threshold, '.\n'))
} }
} }
type_param <- type type_param <- type
@ -484,13 +446,13 @@ first_isolate <- function(x,
} }
# first one as TRUE # first one as TRUE
all_first[row.start, 'real_first_isolate'] <- TRUE all_first[row.start, "real_first_isolate"] <- TRUE
# no tests that should be included, or ICU # no tests that should be included, or ICU
if (!is.null(col_testcode)) { if (!is.null(col_testcode)) {
all_first[which(all_first[, col_testcode] %in% tolower(testcodes_exclude)), 'real_first_isolate'] <- FALSE all_first[which(all_first[, col_testcode] %in% tolower(testcodes_exclude)), "real_first_isolate"] <- FALSE
} }
if (icu_exclude == TRUE) { if (icu_exclude == TRUE) {
all_first[which(all_first[, col_icu] == TRUE), 'real_first_isolate'] <- FALSE all_first[which(all_first[, col_icu] == TRUE), "real_first_isolate"] <- FALSE
} }
decimal.mark <- getOption("OutDec") decimal.mark <- getOption("OutDec")
@ -498,26 +460,20 @@ first_isolate <- function(x,
# handle empty microorganisms # handle empty microorganisms
if (any(all_first$newvar_mo == "UNKNOWN", na.rm = TRUE) & info == TRUE) { if (any(all_first$newvar_mo == "UNKNOWN", na.rm = TRUE) & info == TRUE) {
if (include_unknown == TRUE) { message(blue(paste0("NOTE: ", ifelse(include_unknown == TRUE, "Included ", "Excluded "),
message(blue(paste0("NOTE: Included ", format(sum(all_first$newvar_mo == "UNKNOWN"), format(sum(all_first$newvar_mo == "UNKNOWN"),
decimal.mark = decimal.mark, big.mark = big.mark), decimal.mark = decimal.mark, big.mark = big.mark),
' isolates with a microbial ID "UNKNOWN" (column `', bold(col_mo), '`).'))) " isolates with a microbial ID 'UNKNOWN' (column `", bold(col_mo), "`)")))
} else {
message(blue(paste0("NOTE: Excluded ", format(sum(all_first$newvar_mo == "UNKNOWN"),
decimal.mark = decimal.mark, big.mark = big.mark),
' isolates with a microbial ID "UNKNOWN" (column `', bold(col_mo), '`).')))
} }
} all_first[which(all_first$newvar_mo == "UNKNOWN"), "real_first_isolate"] <- include_unknown
all_first[which(all_first$newvar_mo == "UNKNOWN"), 'real_first_isolate'] <- include_unknown
# exclude all NAs # exclude all NAs
if (any(is.na(all_first$newvar_mo)) & info == TRUE) { if (any(is.na(all_first$newvar_mo)) & info == TRUE) {
message(blue(paste0("NOTE: Excluded ", format(sum(is.na(all_first$newvar_mo)), message(blue(paste0("NOTE: Excluded ", format(sum(is.na(all_first$newvar_mo)),
decimal.mark = decimal.mark, big.mark = big.mark), decimal.mark = decimal.mark, big.mark = big.mark),
' isolates with a microbial ID "NA" (column `', bold(col_mo), '`).'))) " isolates with a microbial ID 'NA' (column `", bold(col_mo), "`)")))
} }
all_first[which(is.na(all_first$newvar_mo)), 'real_first_isolate'] <- FALSE all_first[which(is.na(all_first$newvar_mo)), "real_first_isolate"] <- FALSE
# arrange back according to original sorting again # arrange back according to original sorting again
all_first <- all_first %>% all_first <- all_first %>%

45
R/g.test.R
View File

@ -144,11 +144,8 @@ g.test <- function(x,
stop("all entries of 'x' must be nonnegative and finite") stop("all entries of 'x' must be nonnegative and finite")
if ((n <- sum(x)) == 0) if ((n <- sum(x)) == 0)
stop("at least one entry of 'x' must be positive") stop("at least one entry of 'x' must be positive")
# if (simulate.p.value) {
# setMETH <- function() METHOD <<- paste(METHOD, "with simulated p-value\n\t (based on",
# B, "replicates)")
# almost.1 <- 1 - 64 * .Machine$double.eps
# }
if (is.matrix(x)) { if (is.matrix(x)) {
METHOD <- "G-test of independence" METHOD <- "G-test of independence"
nr <- as.integer(nrow(x)) nr <- as.integer(nrow(x))
@ -157,34 +154,18 @@ g.test <- function(x,
stop("invalid nrow(x) or ncol(x)", domain = NA) stop("invalid nrow(x) or ncol(x)", domain = NA)
# add fisher.test suggestion # add fisher.test suggestion
if (nr == 2 && nc == 2) if (nr == 2 && nc == 2)
warning("`fisher.test()` is always more reliable for 2x2 tables and although must slower, often only takes seconds.") warning("`fisher.test()` is always more reliable for 2x2 tables and although much slower, often only takes seconds.")
sr <- rowSums(x) sr <- rowSums(x)
sc <- colSums(x) sc <- colSums(x)
E <- outer(sr, sc, "*") / n E <- outer(sr, sc, "*") / n
v <- function(r, c, n) c * r * (n - r) * (n - c) / n ^ 3 v <- function(r, c, n) c * r * (n - r) * (n - c) / n ^ 3
V <- outer(sr, sc, v, n) V <- outer(sr, sc, v, n)
dimnames(E) <- dimnames(x) dimnames(E) <- dimnames(x)
# if (simulate.p.value && all(sr > 0) && all(sc > 0)) {
# setMETH()
# tmp <- .Call(chisq_sim, sr, sc, B, E, PACKAGE = "stats")
# STATISTIC <- 2 * sum(x * log(x / E)) # sum(sort((x - E)^2/E, decreasing = TRUE)) for chisq.test
# PARAMETER <- NA
# PVAL <- (1 + sum(tmp >= almost.1 * STATISTIC))/(B +
# 1)
# }
# else {
# if (simulate.p.value)
# warning("cannot compute simulated p-value with zero marginals")
# if (correct && nrow(x) == 2L && ncol(x) == 2L) {
# YATES <- min(0.5, abs(x - E))
# if (YATES > 0)
# METHOD <- paste(METHOD, "with Yates' continuity correction")
# }
# else YATES <- 0
STATISTIC <- 2 * sum(x * log(x / E)) # sum((abs(x - E) - YATES)^2/E) for chisq.test STATISTIC <- 2 * sum(x * log(x / E)) # sum((abs(x - E) - YATES)^2/E) for chisq.test
PARAMETER <- (nr - 1L) * (nc - 1L) PARAMETER <- (nr - 1L) * (nc - 1L)
PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE) PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE)
# }
} }
else { else {
if (length(dim(x)) > 2L) if (length(dim(x)) > 2L)
@ -205,22 +186,10 @@ g.test <- function(x,
V <- n * p * (1 - p) V <- n * p * (1 - p)
STATISTIC <- 2 * sum(x * log(x / E)) # sum((x - E)^2/E) for chisq.test STATISTIC <- 2 * sum(x * log(x / E)) # sum((x - E)^2/E) for chisq.test
names(E) <- names(x) names(E) <- names(x)
# if (simulate.p.value) {
# setMETH()
# nx <- length(x)
# sm <- matrix(sample.int(nx, B * n, TRUE, prob = p),
# nrow = n)
# ss <- apply(sm, 2L, function(x, E, k) {
# sum((table(factor(x, levels = 1L:k)) - E)^2/E)
# }, E = E, k = nx)
# PARAMETER <- NA
# PVAL <- (1 + sum(ss >= almost.1 * STATISTIC))/(B +
# 1)
# }
# else {
PARAMETER <- length(x) - 1 PARAMETER <- length(x) - 1
PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE) PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE)
# }
} }
names(STATISTIC) <- "X-squared" names(STATISTIC) <- "X-squared"
names(PARAMETER) <- "df" names(PARAMETER) <- "df"

12
R/ggplot_rsi.R
View File

@ -292,9 +292,9 @@ geom_rsi <- function(position = NULL,
x <- substr(x, 2, nchar(x) - 1) x <- substr(x, 2, nchar(x) - 1)
} }
if (tolower(x) %in% tolower(c('ab', 'abx', 'antibiotics'))) { if (tolower(x) %in% tolower(c("ab", "abx", "antibiotics"))) {
x <- "antibiotic" x <- "antibiotic"
} else if (tolower(x) %in% tolower(c('SIR', 'RSI', 'interpretations', 'result'))) { } else if (tolower(x) %in% tolower(c("SIR", "RSI", "interpretations", "result"))) {
x <- "interpretation" x <- "interpretation"
} }
@ -327,9 +327,9 @@ facet_rsi <- function(facet = c("interpretation", "antibiotic"), nrow = NULL) {
facet <- substr(facet, 2, nchar(facet) - 1) facet <- substr(facet, 2, nchar(facet) - 1)
} }
if (tolower(facet) %in% tolower(c('SIR', 'RSI', 'interpretations', 'result'))) { if (tolower(facet) %in% tolower(c("SIR", "RSI", "interpretations", "result"))) {
facet <- "interpretation" facet <- "interpretation"
} else if (tolower(facet) %in% tolower(c('ab', 'abx', 'antibiotics'))) { } else if (tolower(facet) %in% tolower(c("ab", "abx", "antibiotics"))) {
facet <- "antibiotic" facet <- "antibiotic"
} }
@ -358,8 +358,8 @@ scale_rsi_colours <- function(colours = c(S = "#61a8ff",
IR = "#ff6961", IR = "#ff6961",
R = "#ff6961")) { R = "#ff6961")) {
stopifnot_installed_package("ggplot2") stopifnot_installed_package("ggplot2")
#ggplot2::scale_fill_brewer(palette = "RdYlGn") # previous colour: palette = "RdYlGn"
#ggplot2::scale_fill_manual(values = c("#b22222", "#ae9c20", "#7cfc00")) # previous colours: values = c("#b22222", "#ae9c20", "#7cfc00")
if (!identical(colours, FALSE)) { if (!identical(colours, FALSE)) {
original_cols <- c(S = "#61a8ff", original_cols <- c(S = "#61a8ff",

11
R/guess_ab_col.R
View File

@ -83,9 +83,6 @@ guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE) {
} else if (any(tolower(colnames(x)) %in% tolower(unlist(ab_property(search_string.ab, "abbreviations"))))) { } else if (any(tolower(colnames(x)) %in% tolower(unlist(ab_property(search_string.ab, "abbreviations"))))) {
ab_result <- colnames(x)[tolower(colnames(x)) %in% tolower(unlist(ab_property(search_string.ab, "abbreviations")))][1L] ab_result <- colnames(x)[tolower(colnames(x)) %in% tolower(unlist(ab_property(search_string.ab, "abbreviations")))][1L]
# } else if (any(tolower(colnames(x)) %in% tolower(ab_tradenames(search_string.ab)))) {
# ab_result <- colnames(x)[tolower(colnames(x)) %in% tolower(ab_tradenames(search_string.ab))][1L]
} else { } else {
# sort colnames on length - longest first # sort colnames on length - longest first
cols <- colnames(x[, x %>% colnames() %>% nchar() %>% order() %>% rev()]) cols <- colnames(x[, x %>% colnames() %>% nchar() %>% order() %>% rev()])
@ -149,7 +146,7 @@ get_column_abx <- function(x,
names(x) <- df_trans$abcode names(x) <- df_trans$abcode
# add from self-defined dots (...): # add from self-defined dots (...):
# get_column_abx(example_isolates %>% rename(thisone = AMX), amox = "thisone") # such as get_column_abx(example_isolates %>% rename(thisone = AMX), amox = "thisone")
dots <- list(...) dots <- list(...)
if (length(dots) > 0) { if (length(dots) > 0) {
newnames <- suppressWarnings(as.ab(names(dots))) newnames <- suppressWarnings(as.ab(names(dots)))
@ -173,12 +170,12 @@ get_column_abx <- function(x,
x <- x[!names(x) %in% names(duplicates)] x <- x[!names(x) %in% names(duplicates)]
if (verbose == TRUE) { if (verbose == TRUE) {
for (i in 1:length(x)) { for (i in seq_len(length(x))) {
message(blue(paste0("NOTE: Using column `", bold(x[i]), "` as input for `", names(x)[i], message(blue(paste0("NOTE: Using column `", bold(x[i]), "` as input for `", names(x)[i],
"` (", ab_name(names(x)[i], tolower = TRUE), ")."))) "` (", ab_name(names(x)[i], tolower = TRUE), ").")))
} }
} else if (length(duplicates) > 0) { } else if (length(duplicates) > 0) {
for (i in 1:length(duplicates)) { for (i in seq_len(length(duplicates))) {
warning(red(paste0("Using column `", bold(duplicates[i]), "` as input for `", names(x[which(x == duplicates[i])]), warning(red(paste0("Using column `", bold(duplicates[i]), "` as input for `", names(x[which(x == duplicates[i])]),
"` (", ab_name(names(x[names(which(x == duplicates))[i]]), tolower = TRUE), "` (", ab_name(names(x[names(which(x == duplicates))[i]]), tolower = TRUE),
"), although it was matched for multiple antibiotics or columns.")), call. = FALSE) "), although it was matched for multiple antibiotics or columns.")), call. = FALSE)
@ -203,7 +200,7 @@ get_column_abx <- function(x,
mutate(txt = paste0(bold(missing), " (", missing_names, ")")) %>% mutate(txt = paste0(bold(missing), " (", missing_names, ")")) %>%
arrange(missing_names) %>% arrange(missing_names) %>%
pull(txt) pull(txt)
message(blue('NOTE: Reliability might be improved if these antimicrobial results would be available too:', message(blue("NOTE: Reliability might be improved if these antimicrobial results would be available too:",
paste(missing_txt, collapse = ", "))) paste(missing_txt, collapse = ", ")))
} }
} }

8
R/join_microorganisms.R
View File

@ -56,7 +56,7 @@ inner_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
dplyr::inner_join(x = x, y = AMR::microorganisms, by = by, suffix = suffix, ...) dplyr::inner_join(x = x, y = AMR::microorganisms, by = by, suffix = suffix, ...)
) )
if (nrow(join) > nrow(x)) { if (nrow(join) > nrow(x)) {
warning('The newly joined tbl contains ', nrow(join) - nrow(x), ' rows more that its original.') warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
} }
join join
} }
@ -71,7 +71,7 @@ left_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
dplyr::left_join(x = x, y = AMR::microorganisms, by = by, suffix = suffix, ...) dplyr::left_join(x = x, y = AMR::microorganisms, by = by, suffix = suffix, ...)
) )
if (nrow(join) > nrow(x)) { if (nrow(join) > nrow(x)) {
warning('The newly joined tbl contains ', nrow(join) - nrow(x), ' rows more that its original.') warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
} }
join join
} }
@ -86,7 +86,7 @@ right_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
dplyr::right_join(x = x, y = AMR::microorganisms, by = by, suffix = suffix, ...) dplyr::right_join(x = x, y = AMR::microorganisms, by = by, suffix = suffix, ...)
) )
if (nrow(join) > nrow(x)) { if (nrow(join) > nrow(x)) {
warning('The newly joined tbl contains ', nrow(join) - nrow(x), ' rows more that its original.') warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
} }
join join
} }
@ -101,7 +101,7 @@ full_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
dplyr::full_join(x = x, y = AMR::microorganisms, by = by, suffix = suffix, ...) dplyr::full_join(x = x, y = AMR::microorganisms, by = by, suffix = suffix, ...)
) )
if (nrow(join) > nrow(x)) { if (nrow(join) > nrow(x)) {
warning('The newly joined tbl contains ', nrow(join) - nrow(x), ' rows more that its original.') warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
} }
join join
} }

30
R/key_antibiotics.R
View File

@ -118,7 +118,7 @@ key_antibiotics <- function(x,
names(col.list) <- col.list names(col.list) <- col.list
col.list.bak <- col.list col.list.bak <- col.list
# are they available as upper case or lower case then? # are they available as upper case or lower case then?
for (i in 1:length(col.list)) { for (i in seq_len(length(col.list))) {
if (is.null(col.list[i]) | isTRUE(is.na(col.list[i]))) { if (is.null(col.list[i]) | isTRUE(is.na(col.list[i]))) {
col.list[i] <- NA col.list[i] <- NA
} else if (toupper(col.list[i]) %in% colnames(x)) { } else if (toupper(col.list[i]) %in% colnames(x)) {
@ -131,9 +131,9 @@ key_antibiotics <- function(x,
} }
if (!all(col.list %in% colnames(x))) { if (!all(col.list %in% colnames(x))) {
if (info == TRUE) { if (info == TRUE) {
warning('Some columns do not exist and will be ignored: ', warning("Some columns do not exist and will be ignored: ",
col.list.bak[!(col.list %in% colnames(x))] %>% toString(), col.list.bak[!(col.list %in% colnames(x))] %>% toString(),
'.\nTHIS MAY STRONGLY INFLUENCE THE OUTCOME.', ".\nTHIS MAY STRONGLY INFLUENCE THE OUTCOME.",
immediate. = TRUE, immediate. = TRUE,
call. = FALSE) call. = FALSE)
} }
@ -164,7 +164,7 @@ key_antibiotics <- function(x,
universal <- c(universal_1, universal_2, universal_3, universal <- c(universal_1, universal_2, universal_3,
universal_4, universal_5, universal_6) universal_4, universal_5, universal_6)
gram_positive = c(universal, gram_positive <- c(universal,
GramPos_1, GramPos_2, GramPos_3, GramPos_1, GramPos_2, GramPos_3,
GramPos_4, GramPos_5, GramPos_6) GramPos_4, GramPos_5, GramPos_6)
gram_positive <- gram_positive[!is.null(gram_positive)] gram_positive <- gram_positive[!is.null(gram_positive)]
@ -173,7 +173,7 @@ key_antibiotics <- function(x,
warning("only using ", length(gram_positive), " different antibiotics as key antibiotics for Gram-positives. See ?key_antibiotics.", call. = FALSE) warning("only using ", length(gram_positive), " different antibiotics as key antibiotics for Gram-positives. See ?key_antibiotics.", call. = FALSE)
} }
gram_negative = c(universal, gram_negative <- c(universal,
GramNeg_1, GramNeg_2, GramNeg_3, GramNeg_1, GramNeg_2, GramNeg_3,
GramNeg_4, GramNeg_5, GramNeg_6) GramNeg_4, GramNeg_5, GramNeg_6)
gram_negative <- gram_negative[!is.null(gram_negative)] gram_negative <- gram_negative[!is.null(gram_negative)]
@ -211,8 +211,8 @@ key_antibiotics <- function(x,
# format # format
key_abs <- x %>% key_abs <- x %>%
pull(key_ab) %>% pull(key_ab) %>%
gsub('(NA|NULL)', '.', .) %>% gsub("(NA|NULL)", ".", .) %>%
gsub('[^SIR]', '.', ., ignore.case = TRUE) %>% gsub("[^SIR]", ".", ., ignore.case = TRUE) %>%
toupper() toupper()
if (n_distinct(key_abs) == 1) { if (n_distinct(key_abs) == 1) {
@ -239,7 +239,7 @@ key_antibiotics_equal <- function(y,
type <- type[1] type <- type[1]
if (length(x) != length(y)) { if (length(x) != length(y)) {
stop('Length of `x` and `y` must be equal.') stop("Length of `x` and `y` must be equal.")
} }
# only show progress bar on points or when at least 5000 isolates # only show progress bar on points or when at least 5000 isolates
@ -251,17 +251,17 @@ key_antibiotics_equal <- function(y,
p <- dplyr::progress_estimated(length(x)) p <- dplyr::progress_estimated(length(x))
} }
for (i in 1:length(x)) { for (i in seq_len(length(x))) {
if (info_needed == TRUE) { if (info_needed == TRUE) {
p$tick()$print() p$tick()$print()
} }
if (is.na(x[i])) { if (is.na(x[i])) {
x[i] <- '' x[i] <- ""
} }
if (is.na(y[i])) { if (is.na(y[i])) {
y[i] <- '' y[i] <- ""
} }
if (x[i] == y[i]) { if (x[i] == y[i]) {
@ -277,7 +277,7 @@ key_antibiotics_equal <- function(y,
x_split <- strsplit(x[i], "")[[1]] x_split <- strsplit(x[i], "")[[1]]
y_split <- strsplit(y[i], "")[[1]] y_split <- strsplit(y[i], "")[[1]]
if (type == 'keyantibiotics') { if (type == "keyantibiotics") {
if (ignore_I == TRUE) { if (ignore_I == TRUE) {
x_split[x_split == "I"] <- "." x_split[x_split == "I"] <- "."
@ -289,7 +289,7 @@ key_antibiotics_equal <- function(y,
result[i] <- all(x_split == y_split) result[i] <- all(x_split == y_split)
} else if (type == 'points') { } else if (type == "points") {
# count points for every single character: # count points for every single character:
# - no change is 0 points # - no change is 0 points
# - I <-> S|R is 0.5 point # - I <-> S|R is 0.5 point
@ -303,12 +303,12 @@ key_antibiotics_equal <- function(y,
result[i] <- points >= points_threshold result[i] <- points >= points_threshold
} else { } else {
stop('`', type, '` is not a valid value for type, must be "points" or "keyantibiotics". See ?key_antibiotics') stop("`", type, '` is not a valid value for type, must be "points" or "keyantibiotics". See ?key_antibiotics')
} }
} }
} }
if (info_needed == TRUE) { if (info_needed == TRUE) {
cat('\n') cat("\n")
} }
result result
} }

2
R/like.R
View File

@ -69,7 +69,7 @@ like <- function(x, pattern, ignore.case = TRUE) {
} else { } else {
# x and pattern are of same length, so items with each other # x and pattern are of same length, so items with each other
res <- vector(length = length(pattern)) res <- vector(length = length(pattern))
for (i in 1:length(res)) { for (i in seq_len(length(res))) {
if (is.factor(x[i])) { if (is.factor(x[i])) {
res[i] <- as.integer(x[i]) %in% base::grep(pattern[i], levels(x[i]), ignore.case = ignore.case) res[i] <- as.integer(x[i]) %in% base::grep(pattern[i], levels(x[i]), ignore.case = ignore.case)
} else { } else {

2
R/mdro.R
View File

@ -272,7 +272,7 @@ mdro <- function(x,
row_filter <- which(x[, cols] == "R") row_filter <- which(x[, cols] == "R")
} else if (any_all == "all") { } else if (any_all == "all") {
row_filter <- x %>% row_filter <- x %>%
mutate(index = 1:nrow(.)) %>% mutate(index = seq_len(nrow(.))) %>%
filter_at(vars(cols), all_vars(. == "R")) %>% filter_at(vars(cols), all_vars(. == "R")) %>%
pull((index)) pull((index))
} }

60
R/mic.R
View File

@ -65,29 +65,29 @@ as.mic <- function(x, na.rm = FALSE) {
x.bak <- x x.bak <- x
# comma to period # comma to period
x <- gsub(',', '.', x, fixed = TRUE) x <- gsub(",", ".", x, fixed = TRUE)
# remove space between operator and number ("<= 0.002" -> "<=0.002") # remove space between operator and number ("<= 0.002" -> "<=0.002")
x <- gsub('(<|=|>) +', '\\1', x) x <- gsub("(<|=|>) +", "\\1", x)
# transform => to >= and =< to <= # transform => to >= and =< to <=
x <- gsub('=>', '>=', x, fixed = TRUE) x <- gsub("=>", ">=", x, fixed = TRUE)
x <- gsub('=<', '<=', x, fixed = TRUE) x <- gsub("=<", "<=", x, fixed = TRUE)
# starting dots must start with 0 # starting dots must start with 0
x <- gsub('^[.]+', '0.', x) x <- gsub("^[.]+", "0.", x)
# <=0.2560.512 should be 0.512 # <=0.2560.512 should be 0.512
x <- gsub('.*[.].*[.]', '0.', x) x <- gsub(".*[.].*[.]", "0.", x)
# remove ending .0 # remove ending .0
x <- gsub('[.]+0$', '', x) x <- gsub("[.]+0$", "", x)
# remove all after last digit # remove all after last digit
x <- gsub('[^0-9]+$', '', x) x <- gsub("[^0-9]+$", "", x)
# keep only one zero before dot # keep only one zero before dot
x <- gsub("0+[.]", "0.", x) x <- gsub("0+[.]", "0.", x)
# starting 00 is probably 0.0 if there's no dot yet # starting 00 is probably 0.0 if there's no dot yet
x[!x %like% "[.]"] <- gsub("^00", "0.0", x[!x %like% "[.]"]) x[!x %like% "[.]"] <- gsub("^00", "0.0", x[!x %like% "[.]"])
# remove last zeroes # remove last zeroes
x <- gsub('([.].?)0+$', '\\1', x) x <- gsub("([.].?)0+$", "\\1", x)
x <- gsub('(.*[.])0+$', '\\10', x) x <- gsub("(.*[.])0+$", "\\10", x)
# remove ending .0 again # remove ending .0 again
x[x %like% "[.]"] <- gsub('0+$', '', x[x %like% "[.]"]) x[x %like% "[.]"] <- gsub("0+$", "", x[x %like% "[.]"])
# force to be character # force to be character
x <- as.character(x) x <- as.character(x)
# trim it # trim it
@ -190,23 +190,23 @@ as.mic <- function(x, na.rm = FALSE) {
"<1024", "<=1024", "1024", ">=1024", ">1024", "<1024", "<=1024", "1024", ">=1024", ">1024",
"1025") "1025")
na_before <- x[is.na(x) | x == ''] %>% length() na_before <- x[is.na(x) | x == ""] %>% length()
x[!x %in% lvls] <- NA x[!x %in% lvls] <- NA
na_after <- x[is.na(x) | x == ''] %>% length() na_after <- x[is.na(x) | x == ""] %>% length()
if (na_before != na_after) { if (na_before != na_after) {
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ''] %>% list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ""] %>%
unique() %>% unique() %>%
sort() sort()
list_missing <- paste0('"', list_missing, '"', collapse = ", ") list_missing <- paste0('"', list_missing, '"', collapse = ", ")
warning(na_after - na_before, ' results truncated (', warning(na_after - na_before, " results truncated (",
round(((na_after - na_before) / length(x)) * 100), round(((na_after - na_before) / length(x)) * 100),
'%) that were invalid MICs: ', "%) that were invalid MICs: ",
list_missing, call. = FALSE) list_missing, call. = FALSE)
} }
structure(.Data = factor(x, levels = lvls, ordered = TRUE), structure(.Data = factor(x, levels = lvls, ordered = TRUE),
class = c('mic', 'ordered', 'factor')) class = c("mic", "ordered", "factor"))
} }
} }
@ -214,36 +214,36 @@ as.mic <- function(x, na.rm = FALSE) {
#' @export #' @export
#' @importFrom dplyr %>% #' @importFrom dplyr %>%
is.mic <- function(x) { is.mic <- function(x) {
class(x) %>% identical(c('mic', 'ordered', 'factor')) class(x) %>% identical(c("mic", "ordered", "factor"))
} }
#' @exportMethod as.double.mic #' @exportMethod as.double.mic
#' @export #' @export
#' @noRd #' @noRd
as.double.mic <- function(x, ...) { as.double.mic <- function(x, ...) {
as.double(gsub('(<|=|>)+', '', as.character(x))) as.double(gsub("(<|=|>)+", "", as.character(x)))
} }
#' @exportMethod as.integer.mic #' @exportMethod as.integer.mic
#' @export #' @export
#' @noRd #' @noRd
as.integer.mic <- function(x, ...) { as.integer.mic <- function(x, ...) {
as.integer(gsub('(<|=|>)+', '', as.character(x))) as.integer(gsub("(<|=|>)+", "", as.character(x)))
} }
#' @exportMethod as.numeric.mic #' @exportMethod as.numeric.mic
#' @export #' @export
#' @noRd #' @noRd
as.numeric.mic <- function(x, ...) { as.numeric.mic <- function(x, ...) {
as.numeric(gsub('(<|=|>)+', '', as.character(x))) as.numeric(gsub("(<|=|>)+", "", as.character(x)))
} }
#' @exportMethod droplevels.mic #' @exportMethod droplevels.mic
#' @export #' @export
#' @noRd #' @noRd
droplevels.mic <- function(x, exclude = if(anyNA(levels(x))) NULL else NA, ...) { droplevels.mic <- function(x, exclude = ifelse(anyNA(levels(x)), NULL, NA), ...) {
x <- droplevels.factor(x, exclude = exclude, ...) x <- droplevels.factor(x, exclude = exclude, ...)
class(x) <- c('mic', 'ordered', 'factor') class(x) <- c("mic", "ordered", "factor")
x x
} }
@ -266,7 +266,7 @@ summary.mic <- function(object, ...) {
x <- x[!is.na(x)] x <- x[!is.na(x)]
n <- x %>% length() n <- x %>% length()
c( c(
"Class" = 'mic', "Class" = "mic",
"<NA>" = n_total - n, "<NA>" = n_total - n,
"Min." = sort(x)[1] %>% as.character(), "Min." = sort(x)[1] %>% as.character(),
"Max." = sort(x)[n] %>% as.character() "Max." = sort(x)[n] %>% as.character()
@ -278,9 +278,9 @@ summary.mic <- function(object, ...) {
#' @importFrom graphics barplot axis par #' @importFrom graphics barplot axis par
#' @noRd #' @noRd
plot.mic <- function(x, plot.mic <- function(x,
main = paste('MIC values of', deparse(substitute(x))), main = paste("MIC values of", deparse(substitute(x))),
ylab = 'Frequency', ylab = "Frequency",
xlab = 'MIC value', xlab = "MIC value",
axes = FALSE, axes = FALSE,
...) { ...) {
barplot(table(droplevels.factor(x)), barplot(table(droplevels.factor(x)),
@ -297,9 +297,9 @@ plot.mic <- function(x,
#' @importFrom graphics barplot axis #' @importFrom graphics barplot axis
#' @noRd #' @noRd
barplot.mic <- function(height, barplot.mic <- function(height,
main = paste('MIC values of', deparse(substitute(height))), main = paste("MIC values of", deparse(substitute(height))),
ylab = 'Frequency', ylab = "Frequency",
xlab = 'MIC value', xlab = "MIC value",
axes = FALSE, axes = FALSE,
...) { ...) {
barplot(table(droplevels.factor(height)), barplot(table(droplevels.factor(height)),

4
R/misc.R
View File

@ -67,7 +67,7 @@ search_type_in_df <- function(x, type) {
call. = FALSE) call. = FALSE)
} }
} else { } else {
for (i in 1:ncol(x)) { for (i in seq_len(ncol(x))) {
if (any(class(x %>% pull(i)) %in% c("Date", "POSIXct"))) { if (any(class(x %>% pull(i)) %in% c("Date", "POSIXct"))) {
found <- colnames(x)[i] found <- colnames(x)[i]
break break
@ -141,7 +141,7 @@ getdecimalplaces <- function(x, minimum = 0, maximum = 3) {
if (minimum > maximum) { if (minimum > maximum) {
minimum <- maximum minimum <- maximum
} }
max_places <- max(unlist(lapply(strsplit(sub('0+$', '', max_places <- max(unlist(lapply(strsplit(sub("0+$", "",
as.character(x * 100)), ".", fixed = TRUE), as.character(x * 100)), ".", fixed = TRUE),
function(y) ifelse(length(y) == 2, nchar(y[2]), 0))), na.rm = TRUE) function(y) ifelse(length(y) == 2, nchar(y[2]), 0))), na.rm = TRUE)
max(min(max_places, max(min(max_places,

188
R/mo.R
View File

@ -308,13 +308,13 @@ exec_as.mo <- function(x,
# support tidyverse selection like: df %>% select(colA, colB) # support tidyverse selection like: df %>% select(colA, colB)
# paste these columns together # paste these columns together
x_vector <- vector("character", NROW(x)) x_vector <- vector("character", NROW(x))
for (i in 1:NROW(x)) { for (i in seq_len(NROW(x))) {
x_vector[i] <- paste(pull(x[i, ], 1), pull(x[i, ], 2), sep = " ") x_vector[i] <- paste(pull(x[i, ], 1), pull(x[i, ], 2), sep = " ")
} }
x <- x_vector x <- x_vector
} else { } else {
if (NCOL(x) > 2) { if (NCOL(x) > 2) {
stop('`x` can be 2 columns at most', call. = FALSE) stop("`x` can be 2 columns at most", call. = FALSE)
} }
x[is.null(x)] <- NA x[is.null(x)] <- NA
@ -544,7 +544,7 @@ exec_as.mo <- function(x,
# if the input is longer than 10 characters, allow any constant between all characters, as some might have forgotten a character # if the input is longer than 10 characters, allow any constant between all characters, as some might have forgotten a character
# this will allow "Pasteurella damatis" to be correctly read as "Pasteurella dagmatis". # this will allow "Pasteurella damatis" to be correctly read as "Pasteurella dagmatis".
constants <- paste(letters[!letters %in% c("a", "e", "i", "o", "u")], collapse = "") constants <- paste(letters[!letters %in% c("a", "e", "i", "o", "u")], collapse = "")
#x[nchar(x_backup_without_spp) > 10] <- gsub("([a-z])([a-z])", paste0("\\1[", constants, "]?\\2"), x[nchar(x_backup_without_spp) > 10])
x[nchar(x_backup_without_spp) > 10] <- gsub("[+]", paste0("+[", constants, "]?"), x[nchar(x_backup_without_spp) > 10]) x[nchar(x_backup_without_spp) > 10] <- gsub("[+]", paste0("+[", constants, "]?"), x[nchar(x_backup_without_spp) > 10])
} }
x <- strip_whitespace(x, dyslexia_mode) x <- strip_whitespace(x, dyslexia_mode)
@ -558,11 +558,11 @@ exec_as.mo <- function(x,
x_withspaces <- gsub("[ .]+", ".* ", x) x_withspaces <- gsub("[ .]+", ".* ", x)
x <- gsub("[ .]+", ".*", x) x <- gsub("[ .]+", ".*", x)
# add start en stop regex # add start en stop regex
x <- paste0('^', x, '$') x <- paste0("^", x, "$")
x_withspaces_start_only <- paste0('^', x_withspaces) x_withspaces_start_only <- paste0("^", x_withspaces)
x_withspaces_end_only <- paste0(x_withspaces, '$') x_withspaces_end_only <- paste0(x_withspaces, "$")
x_withspaces_start_end <- paste0('^', x_withspaces, '$') x_withspaces_start_end <- paste0("^", x_withspaces, "$")
if (isTRUE(debug)) { if (isTRUE(debug)) {
cat(paste0('x "', x, '"\n')) cat(paste0('x "', x, '"\n'))
@ -579,7 +579,7 @@ exec_as.mo <- function(x,
progress <- progress_estimated(n = length(x), min_time = 3) progress <- progress_estimated(n = length(x), min_time = 3)
for (i in 1:length(x)) { for (i in seq_len(length(x))) {
progress$tick()$print() progress$tick()$print()
@ -681,23 +681,6 @@ exec_as.mo <- function(x,
# check for very small input, but ignore the O antigens of E. coli # check for very small input, but ignore the O antigens of E. coli
if (nchar(gsub("[^a-zA-Z]", "", x_trimmed[i])) < 3 if (nchar(gsub("[^a-zA-Z]", "", x_trimmed[i])) < 3
& !x_backup_without_spp[i] %like_case% "[Oo]?(26|103|104|104|111|121|145|157)") { & !x_backup_without_spp[i] %like_case% "[Oo]?(26|103|104|104|111|121|145|157)") {
# check if search term was like "A. species", then return first genus found with ^A
# if (x_backup[i] %like% "[a-z]+ species" | x_backup[i] %like% "[a-z] spp[.]?") {
# # get mo code of first hit
# found <- microorganismsDT[fullname %like% x_withspaces_start_only[i], mo]
# if (length(found) > 0) {
# mo_code <- found[1L] %>% strsplit("_") %>% unlist() %>% .[1:2] %>% paste(collapse = "_")
# found <- microorganismsDT[mo == mo_code, ..property][[1]]
# # return first genus that begins with x_trimmed, e.g. when "E. spp."
# if (length(found) > 0) {
# x[i] <- found[1L]
# if (initial_search == TRUE) {
# set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
# }
# next
# }
# }
# }
# fewer than 3 chars and not looked for species, add as failure # fewer than 3 chars and not looked for species, add as failure
x[i] <- microorganismsDT[mo == "UNKNOWN", ..property][[1]] x[i] <- microorganismsDT[mo == "UNKNOWN", ..property][[1]]
if (initial_search == TRUE) { if (initial_search == TRUE) {
@ -715,17 +698,17 @@ exec_as.mo <- function(x,
# translate known trivial abbreviations to genus + species ---- # translate known trivial abbreviations to genus + species ----
if (!is.na(x_trimmed[i])) { if (!is.na(x_trimmed[i])) {
if (toupper(x_backup_without_spp[i]) %in% c('MRSA', 'MSSA', 'VISA', 'VRSA') if (toupper(x_backup_without_spp[i]) %in% c("MRSA", "MSSA", "VISA", "VRSA")
| x_backup_without_spp[i] %like_case% " (mrsa|mssa|visa|vrsa) ") { | x_backup_without_spp[i] %like_case% " (mrsa|mssa|visa|vrsa) ") {
x[i] <- microorganismsDT[mo == 'B_STPHY_AURS', ..property][[1]][1L] x[i] <- microorganismsDT[mo == "B_STPHY_AURS", ..property][[1]][1L]
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
} }
next next
} }
if (toupper(x_backup_without_spp[i]) %in% c('MRSE', 'MSSE') if (toupper(x_backup_without_spp[i]) %in% c("MRSE", "MSSE")
| x_backup_without_spp[i] %like_case% " (mrse|msse) ") { | x_backup_without_spp[i] %like_case% " (mrse|msse) ") {
x[i] <- microorganismsDT[mo == 'B_STPHY_EPDR', ..property][[1]][1L] x[i] <- microorganismsDT[mo == "B_STPHY_EPDR", ..property][[1]][1L]
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
} }
@ -733,8 +716,8 @@ exec_as.mo <- function(x,
} }
if (toupper(x_backup_without_spp[i]) == "VRE" if (toupper(x_backup_without_spp[i]) == "VRE"
| x_backup_without_spp[i] %like_case% " vre " | x_backup_without_spp[i] %like_case% " vre "
| x_backup_without_spp[i] %like_case% '(enterococci|enterokok|enterococo)[a-z]*?$') { | x_backup_without_spp[i] %like_case% "(enterococci|enterokok|enterococo)[a-z]*?$") {
x[i] <- microorganismsDT[mo == 'B_ENTRC', ..property][[1]][1L] x[i] <- microorganismsDT[mo == "B_ENTRC", ..property][[1]][1L]
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
} }
@ -755,39 +738,39 @@ exec_as.mo <- function(x,
if (toupper(x_backup_without_spp[i]) %in% c("AIEC", "ATEC", "DAEC", "EAEC", "EHEC", "EIEC", "EPEC", "ETEC", "NMEC", "STEC", "UPEC") if (toupper(x_backup_without_spp[i]) %in% c("AIEC", "ATEC", "DAEC", "EAEC", "EHEC", "EIEC", "EPEC", "ETEC", "NMEC", "STEC", "UPEC")
# also support O-antigens of E. coli: O26, O103, O104, O111, O121, O145, O157 # also support O-antigens of E. coli: O26, O103, O104, O111, O121, O145, O157
| x_backup_without_spp[i] %like_case% "o?(26|103|104|111|121|145|157)") { | x_backup_without_spp[i] %like_case% "o?(26|103|104|111|121|145|157)") {
x[i] <- microorganismsDT[mo == 'B_ESCHR_COLI', ..property][[1]][1L] x[i] <- microorganismsDT[mo == "B_ESCHR_COLI", ..property][[1]][1L]
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
} }
next next
} }
if (toupper(x_backup_without_spp[i]) == 'MRPA' if (toupper(x_backup_without_spp[i]) == "MRPA"
| x_backup_without_spp[i] %like_case% " mrpa ") { | x_backup_without_spp[i] %like_case% " mrpa ") {
# multi resistant P. aeruginosa # multi resistant P. aeruginosa
x[i] <- microorganismsDT[mo == 'B_PSDMN_ARGN', ..property][[1]][1L] x[i] <- microorganismsDT[mo == "B_PSDMN_ARGN", ..property][[1]][1L]
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
} }
next next
} }
if (toupper(x_backup_without_spp[i]) == 'CRSM') { if (toupper(x_backup_without_spp[i]) == "CRSM") {
# co-trim resistant S. maltophilia # co-trim resistant S. maltophilia
x[i] <- microorganismsDT[mo == 'B_STNTR_MLTP', ..property][[1]][1L] x[i] <- microorganismsDT[mo == "B_STNTR_MLTP", ..property][[1]][1L]
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
} }
next next
} }
if (toupper(x_backup_without_spp[i]) %in% c('PISP', 'PRSP', 'VISP', 'VRSP') if (toupper(x_backup_without_spp[i]) %in% c("PISP", "PRSP", "VISP", "VRSP")
| x_backup_without_spp[i] %like_case% " (pisp|prsp|visp|vrsp) ") { | x_backup_without_spp[i] %like_case% " (pisp|prsp|visp|vrsp) ") {
# peni I, peni R, vanco I, vanco R: S. pneumoniae # peni I, peni R, vanco I, vanco R: S. pneumoniae
x[i] <- microorganismsDT[mo == 'B_STRPT_PNMN', ..property][[1]][1L] x[i] <- microorganismsDT[mo == "B_STRPT_PNMN", ..property][[1]][1L]
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
} }
next next
} }
if (x_backup_without_spp[i] %like_case% '^g[abcdfghk]s$') { if (x_backup_without_spp[i] %like_case% "^g[abcdfghk]s$") {
# Streptococci, like GBS = Group B Streptococci (B_STRPT_GRPB) # Streptococci, like GBS = Group B Streptococci (B_STRPT_GRPB)
x[i] <- microorganismsDT[mo == toupper(gsub("g([abcdfghk])s", "B_STRPT_GRP\\1", x_backup_without_spp[i])), ..property][[1]][1L] x[i] <- microorganismsDT[mo == toupper(gsub("g([abcdfghk])s", "B_STRPT_GRP\\1", x_backup_without_spp[i])), ..property][[1]][1L]
if (initial_search == TRUE) { if (initial_search == TRUE) {
@ -795,7 +778,7 @@ exec_as.mo <- function(x,
} }
next next
} }
if (x_backup_without_spp[i] %like_case% '(streptococ|streptokok).* [abcdfghk]$') { if (x_backup_without_spp[i] %like_case% "(streptococ|streptokok).* [abcdfghk]$") {
# Streptococci in different languages, like "estreptococos grupo B" # Streptococci in different languages, like "estreptococos grupo B"
x[i] <- microorganismsDT[mo == toupper(gsub(".*(streptococ|streptokok|estreptococ).* ([abcdfghk])$", "B_STRPT_GRP\\2", x_backup_without_spp[i])), ..property][[1]][1L] x[i] <- microorganismsDT[mo == toupper(gsub(".*(streptococ|streptokok|estreptococ).* ([abcdfghk])$", "B_STRPT_GRP\\2", x_backup_without_spp[i])), ..property][[1]][1L]
if (initial_search == TRUE) { if (initial_search == TRUE) {
@ -803,7 +786,7 @@ exec_as.mo <- function(x,
} }
next next
} }
if (x_backup_without_spp[i] %like_case% 'group [abcdfghk] (streptococ|streptokok|estreptococ)') { if (x_backup_without_spp[i] %like_case% "group [abcdfghk] (streptococ|streptokok|estreptococ)") {
# Streptococci in different languages, like "Group A Streptococci" # Streptococci in different languages, like "Group A Streptococci"
x[i] <- microorganismsDT[mo == toupper(gsub(".*group ([abcdfghk]) (streptococ|streptokok|estreptococ).*", "B_STRPT_GRP\\1", x_backup_without_spp[i])), ..property][[1]][1L] x[i] <- microorganismsDT[mo == toupper(gsub(".*group ([abcdfghk]) (streptococ|streptokok|estreptococ).*", "B_STRPT_GRP\\1", x_backup_without_spp[i])), ..property][[1]][1L]
if (initial_search == TRUE) { if (initial_search == TRUE) {
@ -811,79 +794,79 @@ exec_as.mo <- function(x,
} }
next next
} }
if (x_backup_without_spp[i] %like_case% 'haemoly.*strept') { if (x_backup_without_spp[i] %like_case% "haemoly.*strept") {
# Haemolytic streptococci in different languages # Haemolytic streptococci in different languages
x[i] <- microorganismsDT[mo == 'B_STRPT_HAEM', ..property][[1]][1L] x[i] <- microorganismsDT[mo == "B_STRPT_HAEM", ..property][[1]][1L]
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
} }
next next
} }
# CoNS/CoPS in different languages (support for German, Dutch, Spanish, Portuguese) ---- # CoNS/CoPS in different languages (support for German, Dutch, Spanish, Portuguese) ----
if (x_backup_without_spp[i] %like_case% '[ck]oagulas[ea] negatie?[vf]' if (x_backup_without_spp[i] %like_case% "[ck]oagulas[ea] negatie?[vf]"
| x_trimmed[i] %like_case% '[ck]oagulas[ea] negatie?[vf]' | x_trimmed[i] %like_case% "[ck]oagulas[ea] negatie?[vf]"
| x_backup_without_spp[i] %like_case% '[ck]o?ns[^a-z]?$') { | x_backup_without_spp[i] %like_case% "[ck]o?ns[^a-z]?$") {
# coerce S. coagulase negative # coerce S. coagulase negative
x[i] <- microorganismsDT[mo == 'B_STPHY_CONS', ..property][[1]][1L] x[i] <- microorganismsDT[mo == "B_STPHY_CONS", ..property][[1]][1L]
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
} }
next next
} }
if (x_backup_without_spp[i] %like_case% '[ck]oagulas[ea] positie?[vf]' if (x_backup_without_spp[i] %like_case% "[ck]oagulas[ea] positie?[vf]"
| x_trimmed[i] %like_case% '[ck]oagulas[ea] positie?[vf]' | x_trimmed[i] %like_case% "[ck]oagulas[ea] positie?[vf]"
| x_backup_without_spp[i] %like_case% '[ck]o?ps[^a-z]?$') { | x_backup_without_spp[i] %like_case% "[ck]o?ps[^a-z]?$") {
# coerce S. coagulase positive # coerce S. coagulase positive
x[i] <- microorganismsDT[mo == 'B_STPHY_COPS', ..property][[1]][1L] x[i] <- microorganismsDT[mo == "B_STPHY_COPS", ..property][[1]][1L]
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
} }
next next
} }
# streptococcal groups: milleri and viridans # streptococcal groups: milleri and viridans
if (x_trimmed[i] %like_case% 'strepto.* milleri' if (x_trimmed[i] %like_case% "strepto.* milleri"
| x_backup_without_spp[i] %like_case% 'strepto.* milleri' | x_backup_without_spp[i] %like_case% "strepto.* milleri"
| x_backup_without_spp[i] %like_case% 'mgs[^a-z]?$') { | x_backup_without_spp[i] %like_case% "mgs[^a-z]?$") {
# Milleri Group Streptococcus (MGS) # Milleri Group Streptococcus (MGS)
x[i] <- microorganismsDT[mo == 'B_STRPT_MILL', ..property][[1]][1L] x[i] <- microorganismsDT[mo == "B_STRPT_MILL", ..property][[1]][1L]
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
} }
next next
} }
if (x_trimmed[i] %like_case% 'strepto.* viridans' if (x_trimmed[i] %like_case% "strepto.* viridans"
| x_backup_without_spp[i] %like_case% 'strepto.* viridans' | x_backup_without_spp[i] %like_case% "strepto.* viridans"
| x_backup_without_spp[i] %like_case% 'vgs[^a-z]?$') { | x_backup_without_spp[i] %like_case% "vgs[^a-z]?$") {
# Viridans Group Streptococcus (VGS) # Viridans Group Streptococcus (VGS)
x[i] <- microorganismsDT[mo == 'B_STRPT_VIRI', ..property][[1]][1L] x[i] <- microorganismsDT[mo == "B_STRPT_VIRI", ..property][[1]][1L]
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
} }
next next
} }
if (x_backup_without_spp[i] %like_case% 'gram[ -]?neg.*' if (x_backup_without_spp[i] %like_case% "gram[ -]?neg.*"
| x_backup_without_spp[i] %like_case% 'negatie?[vf]' | x_backup_without_spp[i] %like_case% "negatie?[vf]"
| x_trimmed[i] %like_case% 'gram[ -]?neg.*') { | x_trimmed[i] %like_case% "gram[ -]?neg.*") {
# coerce Gram negatives # coerce Gram negatives
x[i] <- microorganismsDT[mo == 'B_GRAMN', ..property][[1]][1L] x[i] <- microorganismsDT[mo == "B_GRAMN", ..property][[1]][1L]
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
} }
next next
} }
if (x_backup_without_spp[i] %like_case% 'gram[ -]?pos.*' if (x_backup_without_spp[i] %like_case% "gram[ -]?pos.*"
| x_backup_without_spp[i] %like_case% 'positie?[vf]' | x_backup_without_spp[i] %like_case% "positie?[vf]"
| x_trimmed[i] %like_case% 'gram[ -]?pos.*') { | x_trimmed[i] %like_case% "gram[ -]?pos.*") {
# coerce Gram positives # coerce Gram positives
x[i] <- microorganismsDT[mo == 'B_GRAMP', ..property][[1]][1L] x[i] <- microorganismsDT[mo == "B_GRAMP", ..property][[1]][1L]
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
} }
next next
} }
if (x_backup_without_spp[i] %like_case% 'mycoba[ck]teri.[nm]?$') { if (x_backup_without_spp[i] %like_case% "mycoba[ck]teri.[nm]?$") {
# coerce Gram positives # coerce Gram positives
x[i] <- microorganismsDT[mo == 'B_MYCBC', ..property][[1]][1L] x[i] <- microorganismsDT[mo == "B_MYCBC", ..property][[1]][1L]
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
} }
@ -893,14 +876,14 @@ exec_as.mo <- function(x,
if (x_backup_without_spp[i] %like_case% "salmonella [a-z]+ ?.*") { if (x_backup_without_spp[i] %like_case% "salmonella [a-z]+ ?.*") {
if (x_backup_without_spp[i] %like_case% "salmonella group") { if (x_backup_without_spp[i] %like_case% "salmonella group") {
# Salmonella Group A to Z, just return S. species for now # Salmonella Group A to Z, just return S. species for now
x[i] <- microorganismsDT[mo == 'B_SLMNL', ..property][[1]][1L] x[i] <- microorganismsDT[mo == "B_SLMNL", ..property][[1]][1L]
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
} }
next next
} else if (grepl("[sS]almonella [A-Z][a-z]+ ?.*", x_backup[i], ignore.case = FALSE)) { } else if (grepl("[sS]almonella [A-Z][a-z]+ ?.*", x_backup[i], ignore.case = FALSE)) {
# Salmonella with capital letter species like "Salmonella Goettingen" - they're all S. enterica # Salmonella with capital letter species like "Salmonella Goettingen" - they're all S. enterica
x[i] <- microorganismsDT[mo == 'B_SLMNL_ENTR', ..property][[1]][1L] x[i] <- microorganismsDT[mo == "B_SLMNL_ENTR", ..property][[1]][1L]
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
} }
@ -915,7 +898,7 @@ exec_as.mo <- function(x,
# trivial names known to the field: # trivial names known to the field:
if ("meningococcus" %like_case% x_trimmed[i]) { if ("meningococcus" %like_case% x_trimmed[i]) {
# coerce Neisseria meningitidis # coerce Neisseria meningitidis
x[i] <- microorganismsDT[mo == 'B_NESSR_MNNG', ..property][[1]][1L] x[i] <- microorganismsDT[mo == "B_NESSR_MNNG", ..property][[1]][1L]
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
} }
@ -923,7 +906,7 @@ exec_as.mo <- function(x,
} }
if ("gonococcus" %like_case% x_trimmed[i]) { if ("gonococcus" %like_case% x_trimmed[i]) {
# coerce Neisseria gonorrhoeae # coerce Neisseria gonorrhoeae
x[i] <- microorganismsDT[mo == 'B_NESSR_GNRR', ..property][[1]][1L] x[i] <- microorganismsDT[mo == "B_NESSR_GNRR", ..property][[1]][1L]
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
} }
@ -931,7 +914,7 @@ exec_as.mo <- function(x,
} }
if ("pneumococcus" %like_case% x_trimmed[i]) { if ("pneumococcus" %like_case% x_trimmed[i]) {
# coerce Streptococcus penumoniae # coerce Streptococcus penumoniae
x[i] <- microorganismsDT[mo == 'B_STRPT_PNMN', ..property][[1]][1L] x[i] <- microorganismsDT[mo == "B_STRPT_PNMN", ..property][[1]][1L]
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
} }
@ -1030,7 +1013,7 @@ exec_as.mo <- function(x,
x_length <- nchar(g.x_backup_without_spp) x_length <- nchar(g.x_backup_without_spp)
x_split <- paste0("^", x_split <- paste0("^",
g.x_backup_without_spp %>% substr(1, x_length / 2), g.x_backup_without_spp %>% substr(1, x_length / 2),
'.* ', ".* ",
g.x_backup_without_spp %>% substr((x_length / 2) + 1, x_length)) g.x_backup_without_spp %>% substr((x_length / 2) + 1, x_length))
found <- data_to_check[fullname_lower %like_case% x_split, ..property][[1]] found <- data_to_check[fullname_lower %like_case% x_split, ..property][[1]]
if (length(found) > 0) { if (length(found) > 0) {
@ -1054,8 +1037,8 @@ exec_as.mo <- function(x,
if (NROW(found) > 0) { if (NROW(found) > 0) {
col_id_new <- found[1, col_id_new] col_id_new <- found[1, col_id_new]
# when property is "ref" (which is the case in mo_ref, mo_authors and mo_year), return the old value, so: # when property is "ref" (which is the case in mo_ref, mo_authors and mo_year), return the old value, so:
# mo_ref("Chlamydia psittaci") = "Page, 1968" (with warning) # mo_ref() of "Chlamydia psittaci" will be "Page, 1968" (with warning)
# mo_ref("Chlamydophila psittaci") = "Everett et al., 1999" # mo_ref() of "Chlamydophila psittaci" will be "Everett et al., 1999"
if (property == "ref") { if (property == "ref") {
x[i] <- found[1, ref] x[i] <- found[1, ref]
} else { } else {
@ -1067,9 +1050,7 @@ exec_as.mo <- function(x,
ref_old = found[1, ref], ref_old = found[1, ref],
ref_new = microorganismsDT[col_id == found[1, col_id_new], ref], ref_new = microorganismsDT[col_id == found[1, col_id_new], ref],
mo = microorganismsDT[col_id == found[1, col_id_new], mo]) mo = microorganismsDT[col_id == found[1, col_id_new], mo])
# if (initial_search == TRUE) { # no set history on renames
# set_mo_history(a.x_backup, get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
# }
return(x[i]) return(x[i])
} }
@ -1119,9 +1100,7 @@ exec_as.mo <- function(x,
format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level, format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup, input = a.x_backup,
result_mo = microorganismsDT[col_id == found[1, col_id_new], mo])) result_mo = microorganismsDT[col_id == found[1, col_id_new], mo]))
# if (initial_search == TRUE) { # no set history on renames
# set_mo_history(a.x_backup, get_mo_code(x, property), 1, force = force_mo_history, disable = disable_mo_history)
# }
return(x) return(x)
} }
@ -1243,11 +1222,11 @@ exec_as.mo <- function(x,
} }
x_strip <- a.x_backup %>% strsplit(" ") %>% unlist() x_strip <- a.x_backup %>% strsplit(" ") %>% unlist()
if (length(x_strip) > 1) { if (length(x_strip) > 1) {
for (i in 1:(length(x_strip) - 1)) { for (i in seq_len(length(x_strip) - 1)) {
lastword <- x_strip[length(x_strip) - i + 1] lastword <- x_strip[length(x_strip) - i + 1]
lastword_half <- substr(lastword, 1, as.integer(nchar(lastword) / 2)) lastword_half <- substr(lastword, 1, as.integer(nchar(lastword) / 2))
# remove last half of the second term # remove last half of the second term
x_strip_collapsed <- paste(c(x_strip[1:(length(x_strip) - i)], lastword_half), collapse = " ") x_strip_collapsed <- paste(c(x_strip[seq_len(length(x_strip) - i)], lastword_half), collapse = " ")
if (nchar(x_strip_collapsed) >= 4 & nchar(lastword_half) > 2) { if (nchar(x_strip_collapsed) >= 4 & nchar(lastword_half) > 2) {
if (isTRUE(debug)) { if (isTRUE(debug)) {
message("Running '", x_strip_collapsed, "'") message("Running '", x_strip_collapsed, "'")
@ -1278,8 +1257,8 @@ exec_as.mo <- function(x,
cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (7) try to strip off one element from end and check the remains\n") cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (7) try to strip off one element from end and check the remains\n")
} }
if (length(x_strip) > 1) { if (length(x_strip) > 1) {
for (i in 1:(length(x_strip) - 1)) { for (i in seq_len(length(x_strip) - 1)) {
x_strip_collapsed <- paste(x_strip[1:(length(x_strip) - i)], collapse = " ") x_strip_collapsed <- paste(x_strip[seq_len(length(x_strip) - i)], collapse = " ")
if (nchar(x_strip_collapsed) >= 6) { if (nchar(x_strip_collapsed) >= 6) {
if (isTRUE(debug)) { if (isTRUE(debug)) {
message("Running '", x_strip_collapsed, "'") message("Running '", x_strip_collapsed, "'")
@ -1412,8 +1391,8 @@ exec_as.mo <- function(x,
cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (11) try to strip off one element from end and check the remains (any text size)\n") cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (11) try to strip off one element from end and check the remains (any text size)\n")
} }
if (length(x_strip) > 1) { if (length(x_strip) > 1) {
for (i in 1:(length(x_strip) - 1)) { for (i in seq_len(length(x_strip) - 1)) {
x_strip_collapsed <- paste(x_strip[1:(length(x_strip) - i)], collapse = " ") x_strip_collapsed <- paste(x_strip[seq_len(length(x_strip) - i)], collapse = " ")
if (isTRUE(debug)) { if (isTRUE(debug)) {
message("Running '", x_strip_collapsed, "'") message("Running '", x_strip_collapsed, "'")
} }
@ -1579,7 +1558,7 @@ exec_as.mo <- function(x,
" (covering ", percentage(total_failures / total_n), " (covering ", percentage(total_failures / total_n),
") could not be coerced and ", plural[3], " considered 'unknown'") ") could not be coerced and ", plural[3], " considered 'unknown'")
if (n_distinct(failures) <= 10) { if (n_distinct(failures) <= 10) {
msg <- paste0(msg, ": ", paste('"', unique(failures), '"', sep = "", collapse = ', ')) msg <- paste0(msg, ": ", paste('"', unique(failures), '"', sep = "", collapse = ", "))
} }
msg <- paste0(msg, ". Use mo_failures() to review ", plural[2], ". Edit the `allow_uncertain` parameter if needed (see ?as.mo).") msg <- paste0(msg, ". Use mo_failures() to review ", plural[2], ". Edit the `allow_uncertain` parameter if needed (see ?as.mo).")
warning(red(msg), warning(red(msg),
@ -1639,35 +1618,35 @@ exec_as.mo <- function(x,
immediate. = TRUE) immediate. = TRUE)
} }
x[x %in% CoNS] <- microorganismsDT[mo == 'B_STPHY_CONS', ..property][[1]][1L] x[x %in% CoNS] <- microorganismsDT[mo == "B_STPHY_CONS", ..property][[1]][1L]
x[x %in% CoPS] <- microorganismsDT[mo == 'B_STPHY_COPS', ..property][[1]][1L] x[x %in% CoPS] <- microorganismsDT[mo == "B_STPHY_COPS", ..property][[1]][1L]
if (Becker == "all") { if (Becker == "all") {
x[x %in% microorganismsDT[mo %like_case% '^B_STPHY_AURS', ..property][[1]]] <- microorganismsDT[mo == 'B_STPHY_COPS', ..property][[1]][1L] x[x %in% microorganismsDT[mo %like_case% "^B_STPHY_AURS", ..property][[1]]] <- microorganismsDT[mo == "B_STPHY_COPS", ..property][[1]][1L]
} }
} }
# Lancefield ---- # Lancefield ----
if (Lancefield == TRUE | Lancefield == "all") { if (Lancefield == TRUE | Lancefield == "all") {
# group A - S. pyogenes # group A - S. pyogenes
x[x == microorganismsDT[mo == 'B_STRPT_PYGN', ..property][[1]][1L]] <- microorganismsDT[mo == 'B_STRPT_GRPA', ..property][[1]][1L] x[x == microorganismsDT[mo == "B_STRPT_PYGN", ..property][[1]][1L]] <- microorganismsDT[mo == "B_STRPT_GRPA", ..property][[1]][1L]
# group B - S. agalactiae # group B - S. agalactiae
x[x == microorganismsDT[mo == 'B_STRPT_AGLC', ..property][[1]][1L]] <- microorganismsDT[mo == 'B_STRPT_GRPB', ..property][[1]][1L] x[x == microorganismsDT[mo == "B_STRPT_AGLC", ..property][[1]][1L]] <- microorganismsDT[mo == "B_STRPT_GRPB", ..property][[1]][1L]
# group C # group C
S_groupC <- microorganismsDT %>% filter(genus == "Streptococcus", S_groupC <- microorganismsDT %>% filter(genus == "Streptococcus",
species %in% c("equisimilis", "equi", species %in% c("equisimilis", "equi",
"zooepidemicus", "dysgalactiae")) %>% "zooepidemicus", "dysgalactiae")) %>%
pull(property) pull(property)
x[x %in% S_groupC] <- microorganismsDT[mo == 'B_STRPT_GRPC', ..property][[1]][1L] x[x %in% S_groupC] <- microorganismsDT[mo == "B_STRPT_GRPC", ..property][[1]][1L]
if (Lancefield == "all") { if (Lancefield == "all") {
# all Enterococci # all Enterococci
x[x %like% "^(Enterococcus|B_ENTRC)"] <- microorganismsDT[mo == 'B_STRPT_GRPD', ..property][[1]][1L] x[x %like% "^(Enterococcus|B_ENTRC)"] <- microorganismsDT[mo == "B_STRPT_GRPD", ..property][[1]][1L]
} }
# group F - S. anginosus # group F - S. anginosus
x[x == microorganismsDT[mo == 'B_STRPT_ANGN', ..property][[1]][1L]] <- microorganismsDT[mo == 'B_STRPT_GRPF', ..property][[1]][1L] x[x == microorganismsDT[mo == "B_STRPT_ANGN", ..property][[1]][1L]] <- microorganismsDT[mo == "B_STRPT_GRPF", ..property][[1]][1L]
# group H - S. sanguinis # group H - S. sanguinis
x[x == microorganismsDT[mo == 'B_STRPT_SNGN', ..property][[1]][1L]] <- microorganismsDT[mo == 'B_STRPT_GRPH', ..property][[1]][1L] x[x == microorganismsDT[mo == "B_STRPT_SNGN", ..property][[1]][1L]] <- microorganismsDT[mo == "B_STRPT_GRPH", ..property][[1]][1L]
# group K - S. salivarius # group K - S. salivarius
x[x == microorganismsDT[mo == 'B_STRPT_SLVR', ..property][[1]][1L]] <- microorganismsDT[mo == 'B_STRPT_GRPK', ..property][[1]][1L] x[x == microorganismsDT[mo == "B_STRPT_SLVR", ..property][[1]][1L]] <- microorganismsDT[mo == "B_STRPT_GRPK", ..property][[1]][1L]
} }
# Wrap up ---------------------------------------------------------------- # Wrap up ----------------------------------------------------------------
@ -1886,7 +1865,7 @@ print.mo_uncertainties <- function(x, ...) {
", 3 = ", red("very uncertain"), ")\n")) ", 3 = ", red("very uncertain"), ")\n"))
msg <- "" msg <- ""
for (i in 1:nrow(x)) { for (i in seq_len(nrow(x))) {
if (x[i, "uncertainty"] == 1) { if (x[i, "uncertainty"] == 1) {
colour1 <- green colour1 <- green
colour2 <- function(...) bgGreen(white(...)) colour2 <- function(...) bgGreen(white(...))
@ -1929,7 +1908,7 @@ print.mo_renamed <- function(x, ...) {
if (NROW(x) == 0) { if (NROW(x) == 0) {
return(invisible()) return(invisible())
} }
for (i in 1:nrow(x)) { for (i in seq_len(nrow(x))) {
message(blue(paste0("NOTE: ", message(blue(paste0("NOTE: ",
italic(x$old_name[i]), ifelse(x$old_ref[i] %in% c("", NA), "", italic(x$old_name[i]), ifelse(x$old_ref[i] %in% c("", NA), "",
paste0(" (", gsub("et al.", italic("et al."), x$old_ref[i]), ")")), paste0(" (", gsub("et al.", italic("et al."), x$old_ref[i]), ")")),
@ -1955,15 +1934,10 @@ unregex <- function(x) {
} }
get_mo_code <- function(x, property) { get_mo_code <- function(x, property) {
# don't use right now
# return(NULL)
if (property == "mo") { if (property == "mo") {
unique(x) unique(x)
} else { } else {
microorganismsDT[get(property) == x, "mo"][[1]] microorganismsDT[get(property) == x, "mo"][[1]]
# which is ~2.5 times faster than:
# AMR::microorganisms[base::which(AMR::microorganisms[, property] %in% x),]$mo
} }
} }

6
R/mo_history.R
View File

@ -43,7 +43,7 @@ set_mo_history <- function(x, mo, uncertainty_level, force = FALSE, disable = FA
} }
x <- toupper(df$x) x <- toupper(df$x)
mo <- df$mo mo <- df$mo
for (i in 1:length(x)) { for (i in seq_len(length(x))) {
# save package version too, as both the as.mo() algorithm and the reference data set may change # save package version too, as both the as.mo() algorithm and the reference data set may change
if (NROW(mo_hist[base::which(mo_hist$x == x[i] & if (NROW(mo_hist[base::which(mo_hist$x == x[i] &
mo_hist$uncertainty_level >= uncertainty_level & mo_hist$uncertainty_level >= uncertainty_level &
@ -73,7 +73,9 @@ set_mo_history <- function(x, mo, uncertainty_level, force = FALSE, disable = FA
stringsAsFactors = FALSE)), stringsAsFactors = FALSE)),
row.names = FALSE, row.names = FALSE,
file = mo_history_file()), file = mo_history_file()),
error = function(e) { warning_new_write <- FALSE; base::invisible()}) error = function(e) {
warning_new_write <- FALSE; base::invisible()
})
} }
} }
} }

2
R/mo_property.R
View File

@ -384,7 +384,7 @@ mo_url <- function(x, open = FALSE, ...) {
#' @rdname mo_property #' @rdname mo_property
#' @importFrom data.table data.table as.data.table setkey #' @importFrom data.table data.table as.data.table setkey
#' @export #' @export
mo_property <- function(x, property = 'fullname', language = get_locale(), ...) { mo_property <- function(x, property = "fullname", language = get_locale(), ...) {
if (length(property) != 1L) { if (length(property) != 1L) {
stop("'property' must be of length 1.") stop("'property' must be of length 1.")
} }

10
R/mo_source.R
View File

@ -99,7 +99,7 @@
#' @inheritSection AMR Read more on our website! #' @inheritSection AMR Read more on our website!
set_mo_source <- function(path) { set_mo_source <- function(path) {
file_location <- path.expand('~/mo_source.rds') file_location <- path.expand("~/mo_source.rds")
if (!is.character(path) | length(path) > 1) { if (!is.character(path) | length(path) > 1) {
stop("`path` must be a character of length 1.") stop("`path` must be a character of length 1.")
@ -119,17 +119,17 @@ set_mo_source <- function(path) {
stop("File not found: ", path) stop("File not found: ", path)
} }
if (path %like% '[.]rds$') { if (path %like% "[.]rds$") {
df <- readRDS(path) df <- readRDS(path)
} else if (path %like% '[.]xlsx?$') { } else if (path %like% "[.]xlsx?$") {
# is Excel file (old or new) # is Excel file (old or new)
if (!"readxl" %in% utils::installed.packages()) { if (!"readxl" %in% utils::installed.packages()) {
stop("Install the 'readxl' package first.") stop("Install the 'readxl' package first.")
} }
df <- readxl::read_excel(path) df <- readxl::read_excel(path)
} else if (path %like% '[.]tsv$') { } else if (path %like% "[.]tsv$") {
df <- utils::read.table(header = TRUE, sep = "\t", stringsAsFactors = FALSE) df <- utils::read.table(header = TRUE, sep = "\t", stringsAsFactors = FALSE)
} else { } else {
@ -196,7 +196,7 @@ get_mo_source <- function() {
# set updated source # set updated source
set_mo_source(getOption("mo_source")) set_mo_source(getOption("mo_source"))
} }
file_location <- path.expand('~/mo_source.rds') file_location <- path.expand("~/mo_source.rds")
readRDS(file_location) readRDS(file_location)
} }
} }

3
R/read.4d.R
View File

@ -154,7 +154,7 @@ read.4D <- function(file,
if (info == TRUE) { if (info == TRUE) {
message("OK\nSetting original column names as label... ", appendLF = FALSE) message("OK\nSetting original column names as label... ", appendLF = FALSE)
} }
for (i in 1:ncol(data_4D)) { for (i in seq_len(ncol(data_4D))) {
if (!is.na(colnames.bak[i])) { if (!is.na(colnames.bak[i])) {
attr(data_4D[, i], "label") <- colnames.bak[i] attr(data_4D[, i], "label") <- colnames.bak[i]
} }
@ -173,4 +173,3 @@ read.4D <- function(file,
data_4D data_4D
} }

46
R/resistance_predict.R
View File

@ -120,7 +120,7 @@ resistance_predict <- function(x,
...) { ...) {
if (nrow(x) == 0) { if (nrow(x) == 0) {
stop('This table does not contain any observations.') stop("This table does not contain any observations.")
} }
if (is.null(model)) { if (is.null(model)) {
@ -128,17 +128,17 @@ resistance_predict <- function(x,
} }
if (!col_ab %in% colnames(x)) { if (!col_ab %in% colnames(x)) {
stop('Column ', col_ab, ' not found.') stop("Column ", col_ab, " not found.")
} }
dots <- unlist(list(...)) dots <- unlist(list(...))
if (length(dots) != 0) { if (length(dots) != 0) {
# backwards compatibility with old parameters # backwards compatibility with old parameters
dots.names <- dots %>% names() dots.names <- dots %>% names()
if ('tbl' %in% dots.names) { if ("tbl" %in% dots.names) {
x <- dots[which(dots.names == 'tbl')] x <- dots[which(dots.names == "tbl")]
} }
if ('I_as_R' %in% dots.names) { if ("I_as_R" %in% dots.names) {
warning("`I_as_R is deprecated - use I_as_S instead.", call. = FALSE) warning("`I_as_R is deprecated - use I_as_S instead.", call. = FALSE)
} }
} }
@ -152,7 +152,7 @@ resistance_predict <- function(x,
} }
if (!col_date %in% colnames(x)) { if (!col_date %in% colnames(x)) {
stop('Column ', col_date, ' not found.') stop("Column ", col_date, " not found.")
} }
if (n_groups(x) > 1) { if (n_groups(x) > 1) {
@ -161,10 +161,10 @@ resistance_predict <- function(x,
} }
year <- function(x) { year <- function(x) {
if (all(grepl('^[0-9]{4}$', x))) { if (all(grepl("^[0-9]{4}$", x))) {
x x
} else { } else {
as.integer(format(as.Date(x), '%Y')) as.integer(format(as.Date(x), "%Y"))
} }
} }
@ -181,8 +181,8 @@ resistance_predict <- function(x,
} }
df <- df %>% df <- df %>%
filter_at(col_ab, all_vars(!is.na(.))) %>% filter_at(col_ab, all_vars(!is.na(.))) %>%
mutate(year = pull(., col_date) %>% year()) %>% mutate(year = year(pull(., col_date))) %>%
group_by_at(c('year', col_ab)) %>% group_by_at(c("year", col_ab)) %>%
summarise(n()) summarise(n())
if (df %>% pull(col_ab) %>% n_distinct(na.rm = TRUE) < 2) { if (df %>% pull(col_ab) %>% n_distinct(na.rm = TRUE) < 2) {
@ -191,7 +191,7 @@ resistance_predict <- function(x,
call. = FALSE) call. = FALSE)
} }
colnames(df) <- c('year', 'antibiotic', 'observations') colnames(df) <- c("year", "antibiotic", "observations")
df <- df %>% df <- df %>%
filter(!is.na(antibiotic)) %>% filter(!is.na(antibiotic)) %>%
tidyr::spread(antibiotic, observations, fill = 0) %>% tidyr::spread(antibiotic, observations, fill = 0) %>%
@ -202,7 +202,7 @@ resistance_predict <- function(x,
as.matrix() as.matrix()
if (NROW(df) == 0) { if (NROW(df) == 0) {
stop('There are no observations.') stop("There are no observations.")
} }
year_lowest <- min(df$year) year_lowest <- min(df$year)
@ -217,12 +217,12 @@ resistance_predict <- function(x,
years <- list(year = seq(from = year_min, to = year_max, by = year_every)) years <- list(year = seq(from = year_min, to = year_max, by = year_every))
if (model %in% c('binomial', 'binom', 'logit')) { if (model %in% c("binomial", "binom", "logit")) {
model <- "binomial" model <- "binomial"
model_lm <- with(df, glm(df_matrix ~ year, family = binomial)) model_lm <- with(df, glm(df_matrix ~ year, family = binomial))
if (info == TRUE) { if (info == TRUE) {
cat('\nLogistic regression model (logit) with binomial distribution') cat("\nLogistic regression model (logit) with binomial distribution")
cat('\n------------------------------------------------------------\n') cat("\n------------------------------------------------------------\n")
print(summary(model_lm)) print(summary(model_lm))
} }
@ -230,12 +230,12 @@ resistance_predict <- function(x,
prediction <- predictmodel$fit prediction <- predictmodel$fit
se <- predictmodel$se.fit se <- predictmodel$se.fit
} else if (model %in% c('loglin', 'poisson')) { } else if (model %in% c("loglin", "poisson")) {
model <- "poisson" model <- "poisson"
model_lm <- with(df, glm(R ~ year, family = poisson)) model_lm <- with(df, glm(R ~ year, family = poisson))
if (info == TRUE) { if (info == TRUE) {
cat('\nLog-linear regression model (loglin) with poisson distribution') cat("\nLog-linear regression model (loglin) with poisson distribution")
cat('\n--------------------------------------------------------------\n') cat("\n--------------------------------------------------------------\n")
print(summary(model_lm)) print(summary(model_lm))
} }
@ -243,12 +243,12 @@ resistance_predict <- function(x,
prediction <- predictmodel$fit prediction <- predictmodel$fit
se <- predictmodel$se.fit se <- predictmodel$se.fit
} else if (model %in% c('lin', 'linear')) { } else if (model %in% c("lin", "linear")) {
model <- "linear" model <- "linear"
model_lm <- with(df, lm((R / (R + S)) ~ year)) model_lm <- with(df, lm((R / (R + S)) ~ year))
if (info == TRUE) { if (info == TRUE) {
cat('\nLinear regression model') cat("\nLinear regression model")
cat('\n-----------------------\n') cat("\n-----------------------\n")
print(summary(model_lm)) print(summary(model_lm))
} }
@ -257,7 +257,7 @@ resistance_predict <- function(x,
se <- predictmodel$se.fit se <- predictmodel$se.fit
} else { } else {
stop('No valid model selected. See ?resistance_predict.') stop("No valid model selected. See ?resistance_predict.")
} }
# prepare the output dataframe # prepare the output dataframe
@ -268,7 +268,7 @@ resistance_predict <- function(x,
mutate(se_min = value - se, mutate(se_min = value - se,
se_max = value + se) se_max = value + se)
if (model == 'poisson') { if (model == "poisson") {
df_prediction <- df_prediction %>% df_prediction <- df_prediction %>%
mutate(value = value %>% mutate(value = value %>%
format(scientific = FALSE) %>% format(scientific = FALSE) %>%

65
R/rsi.R
View File

@ -100,20 +100,17 @@ as.rsi.default <- function(x, ...) {
if (is.rsi(x)) { if (is.rsi(x)) {
x x
} else if (identical(levels(x), c("S", "I", "R"))) { } else if (identical(levels(x), c("S", "I", "R"))) {
structure(x, class = c('rsi', 'ordered', 'factor')) structure(x, class = c("rsi", "ordered", "factor"))
} else { } else {
# if (input_resembles_mic(x) > 0.5) {
# warning("`as.rsi` is intended to clean antimicrobial interpretations - not to interpret MIC values.", call. = FALSE)
# }
x <- x %>% unlist() x <- x %>% unlist()
x.bak <- x x.bak <- x
na_before <- x[is.na(x) | x == ''] %>% length() na_before <- x[is.na(x) | x == ""] %>% length()
# remove all spaces # remove all spaces
x <- gsub(' +', '', x) x <- gsub(" +", "", x)
# remove all MIC-like values: numbers, operators and periods # remove all MIC-like values: numbers, operators and periods
x <- gsub('[0-9.,;:<=>]+', '', x) x <- gsub("[0-9.,;:<=>]+", "", x)
# remove everything between brackets, and 'high' and 'low' # remove everything between brackets, and 'high' and 'low'
x <- gsub("([(].*[)])", "", x) x <- gsub("([(].*[)])", "", x)
x <- gsub("(high|low)", "", x, ignore.case = TRUE) x <- gsub("(high|low)", "", x, ignore.case = TRUE)
@ -122,29 +119,29 @@ as.rsi.default <- function(x, ...) {
# set to capitals # set to capitals
x <- toupper(x) x <- toupper(x)
# remove all invalid characters # remove all invalid characters
x <- gsub('[^RSI]+', '', x) x <- gsub("[^RSI]+", "", x)
# in cases of "S;S" keep S, but in case of "S;I" make it NA # in cases of "S;S" keep S, but in case of "S;I" make it NA
x <- gsub('^S+$', 'S', x) x <- gsub("^S+$", "S", x)
x <- gsub('^I+$', 'I', x) x <- gsub("^I+$", "I", x)
x <- gsub('^R+$', 'R', x) x <- gsub("^R+$", "R", x)
x[!x %in% c('S', 'I', 'R')] <- NA x[!x %in% c("S", "I", "R")] <- NA
na_after <- x[is.na(x) | x == ''] %>% length() na_after <- x[is.na(x) | x == ""] %>% length()
if (!isFALSE(list(...)$warn)) { # so as.rsi(..., warn = FALSE) will never throw a warning if (!isFALSE(list(...)$warn)) { # so as.rsi(..., warn = FALSE) will never throw a warning
if (na_before != na_after) { if (na_before != na_after) {
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ''] %>% list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ""] %>%
unique() %>% unique() %>%
sort() sort()
list_missing <- paste0('"', list_missing, '"', collapse = ", ") list_missing <- paste0('"', list_missing, '"', collapse = ", ")
warning(na_after - na_before, ' results truncated (', warning(na_after - na_before, " results truncated (",
round(((na_after - na_before) / length(x)) * 100), round(((na_after - na_before) / length(x)) * 100),
'%) that were invalid antimicrobial interpretations: ', "%) that were invalid antimicrobial interpretations: ",
list_missing, call. = FALSE) list_missing, call. = FALSE)
} }
} }
structure(.Data = factor(x, levels = c("S", "I", "R"), ordered = TRUE), structure(.Data = factor(x, levels = c("S", "I", "R"), ordered = TRUE),
class = c('rsi', 'ordered', 'factor')) class = c("rsi", "ordered", "factor"))
} }
} }
@ -226,7 +223,7 @@ exec_as.rsi <- function(method, x, mo, ab, guideline) {
lookup_becker <- paste(mo_becker, ab) lookup_becker <- paste(mo_becker, ab)
lookup_lancefield <- paste(mo_lancefield, ab) lookup_lancefield <- paste(mo_lancefield, ab)
for (i in 1:length(x)) { for (i in seq_len(length(x))) {
get_record <- trans %>% get_record <- trans %>%
filter(lookup %in% c(lookup_mo[i], filter(lookup %in% c(lookup_mo[i],
lookup_genus[i], lookup_genus[i],
@ -254,7 +251,7 @@ exec_as.rsi <- function(method, x, mo, ab, guideline) {
} }
} }
structure(.Data = factor(new_rsi, levels = c("S", "I", "R"), ordered = TRUE), structure(.Data = factor(new_rsi, levels = c("S", "I", "R"), ordered = TRUE),
class = c('rsi', 'ordered', 'factor')) class = c("rsi", "ordered", "factor"))
} }
#' @rdname as.rsi #' @rdname as.rsi
@ -280,7 +277,7 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", ...) {
# transform all MICs # transform all MICs
ab_cols <- colnames(x)[sapply(x, is.mic)] ab_cols <- colnames(x)[sapply(x, is.mic)]
if (length(ab_cols) > 0) { if (length(ab_cols) > 0) {
for (i in 1:length(ab_cols)) { for (i in seq_len(length(ab_cols))) {
if (is.na(suppressWarnings(as.ab(ab_cols[i])))) { if (is.na(suppressWarnings(as.ab(ab_cols[i])))) {
message(red(paste0("Unknown drug: `", bold(ab_cols[i]), "`. Rename this column to a drug name or code, and check the output with as.ab()."))) message(red(paste0("Unknown drug: `", bold(ab_cols[i]), "`. Rename this column to a drug name or code, and check the output with as.ab().")))
next next
@ -297,7 +294,7 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", ...) {
# transform all disks # transform all disks
ab_cols <- colnames(x)[sapply(x, is.disk)] ab_cols <- colnames(x)[sapply(x, is.disk)]
if (length(ab_cols) > 0) { if (length(ab_cols) > 0) {
for (i in 1:length(ab_cols)) { for (i in seq_len(length(ab_cols))) {
if (is.na(suppressWarnings(as.ab(ab_cols[i])))) { if (is.na(suppressWarnings(as.ab(ab_cols[i])))) {
message(red(paste0("Unknown drug: `", bold(ab_cols[i]), "`. Rename this column to a drug name or code, and check the output with as.ab()."))) message(red(paste0("Unknown drug: `", bold(ab_cols[i]), "`. Rename this column to a drug name or code, and check the output with as.ab().")))
next next
@ -319,14 +316,14 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", ...) {
#' @export #' @export
is.rsi <- function(x) { is.rsi <- function(x) {
identical(class(x), identical(class(x),
c('rsi', 'ordered', 'factor')) c("rsi", "ordered", "factor"))
} }
#' @rdname as.rsi #' @rdname as.rsi
#' @export #' @export
is.rsi.eligible <- function(x, threshold = 0.05) { is.rsi.eligible <- function(x, threshold = 0.05) {
if (NCOL(x) > 1) { if (NCOL(x) > 1) {
stop('`x` must be a one-dimensional vector.') stop("`x` must be a one-dimensional vector.")
} }
if (any(c("logical", if (any(c("logical",
"numeric", "numeric",
@ -365,7 +362,7 @@ print.rsi <- function(x, ...) {
#' @noRd #' @noRd
droplevels.rsi <- function(x, exclude = if (anyNA(levels(x))) NULL else NA, ...) { droplevels.rsi <- function(x, exclude = if (anyNA(levels(x))) NULL else NA, ...) {
x <- droplevels.factor(x, exclude = exclude, ...) x <- droplevels.factor(x, exclude = exclude, ...)
class(x) <- c('rsi', 'ordered', 'factor') class(x) <- c("rsi", "ordered", "factor")
x x
} }
@ -375,7 +372,7 @@ droplevels.rsi <- function(x, exclude = if(anyNA(levels(x))) NULL else NA, ...)
summary.rsi <- function(object, ...) { summary.rsi <- function(object, ...) {
x <- object x <- object
c( c(
"Class" = 'rsi', "Class" = "rsi",
"<NA>" = sum(is.na(x)), "<NA>" = sum(is.na(x)),
"Sum S" = sum(x == "S", na.rm = TRUE), "Sum S" = sum(x == "S", na.rm = TRUE),
"Sum IR" = sum(x %in% c("I", "R"), na.rm = TRUE), "Sum IR" = sum(x %in% c("I", "R"), na.rm = TRUE),
@ -392,9 +389,9 @@ summary.rsi <- function(object, ...) {
plot.rsi <- function(x, plot.rsi <- function(x,
lwd = 2, lwd = 2,
ylim = NULL, ylim = NULL,
ylab = 'Percentage', ylab = "Percentage",
xlab = 'Antimicrobial Interpretation', xlab = "Antimicrobial Interpretation",
main = paste('Susceptibility Analysis of', deparse(substitute(x))), main = paste("Susceptibility Analysis of", deparse(substitute(x))),
axes = FALSE, axes = FALSE,
...) { ...) {
suppressWarnings( suppressWarnings(
@ -416,7 +413,7 @@ plot.rsi <- function(x,
data <- rbind(data, data.frame(x = "R", n = 0, s = 0)) data <- rbind(data, data.frame(x = "R", n = 0, s = 0))
} }
data$x <- factor(data$x, levels = c('S', 'I', 'R'), ordered = TRUE) data$x <- factor(data$x, levels = c("S", "I", "R"), ordered = TRUE)
ymax <- if_else(max(data$s) > 95, 105, 100) ymax <- if_else(max(data$s) > 95, 105, 100)
@ -436,7 +433,7 @@ plot.rsi <- function(x,
text(x = data$x, text(x = data$x,
y = data$s + 4, y = data$s + 4,
labels = paste0(data$s, '% (n = ', data$n, ')')) labels = paste0(data$s, "% (n = ", data$n, ")"))
} }
@ -446,10 +443,10 @@ plot.rsi <- function(x,
#' @importFrom graphics barplot axis par #' @importFrom graphics barplot axis par
#' @noRd #' @noRd
barplot.rsi <- function(height, barplot.rsi <- function(height,
col = c('green3', 'orange2', 'red3'), col = c("green3", "orange2", "red3"),
xlab = ifelse(beside, 'Antimicrobial Interpretation', ''), xlab = ifelse(beside, "Antimicrobial Interpretation", ""),
main = paste('Susceptibility Analysis of', deparse(substitute(height))), main = paste("Susceptibility Analysis of", deparse(substitute(height))),
ylab = 'Frequency', ylab = "Frequency",
beside = TRUE, beside = TRUE,
axes = beside, axes = beside,
...) { ...) {

22
R/rsi_calc.R
View File

@ -50,13 +50,13 @@ rsi_calc <- function(...,
data_vars <- dots2vars(...) data_vars <- dots2vars(...)
if (!is.numeric(minimum)) { if (!is.numeric(minimum)) {
stop('`minimum` must be numeric', call. = FALSE) stop("`minimum` must be numeric", call. = FALSE)
} }
if (!is.logical(as_percent)) { if (!is.logical(as_percent)) {
stop('`as_percent` must be logical', call. = FALSE) stop("`as_percent` must be logical", call. = FALSE)
} }
if (!is.logical(only_all_tested)) { if (!is.logical(only_all_tested)) {
stop('`only_all_tested` must be logical', call. = FALSE) stop("`only_all_tested` must be logical", call. = FALSE)
} }
dots_df <- ...elt(1) # it needs this evaluation dots_df <- ...elt(1) # it needs this evaluation
@ -67,8 +67,7 @@ rsi_calc <- function(...,
ndots <- length(dots) ndots <- length(dots)
if ("data.frame" %in% class(dots_df)) { if ("data.frame" %in% class(dots_df)) {
# data.frame passed with other columns, like: # data.frame passed with other columns, like: example_isolates %>% portion_S(amcl, gent)
# example_isolates %>% portion_S(amcl, gent)
dots <- as.character(dots) dots <- as.character(dots)
dots <- dots[dots != "."] dots <- dots[dots != "."]
if (length(dots) == 0 | all(dots == "df")) { if (length(dots) == 0 | all(dots == "df")) {
@ -79,13 +78,10 @@ rsi_calc <- function(...,
x <- dots_df[, dots] x <- dots_df[, dots]
} }
} else if (ndots == 1) { } else if (ndots == 1) {
# only 1 variable passed (can also be data.frame), like: # only 1 variable passed (can also be data.frame), like: portion_S(example_isolates$amcl) and example_isolates$amcl %>% portion_S()
# portion_S(example_isolates$amcl)
# example_isolates$amcl %>% portion_S()
x <- dots_df x <- dots_df
} else { } else {
# multiple variables passed without pipe, like: # multiple variables passed without pipe, like: portion_S(example_isolates$amcl, example_isolates$gent)
# portion_S(example_isolates$amcl, example_isolates$gent)
x <- NULL x <- NULL
try(x <- as.data.frame(dots), silent = TRUE) try(x <- as.data.frame(dots), silent = TRUE)
if (is.null(x)) { if (is.null(x)) {
@ -105,7 +101,7 @@ rsi_calc <- function(...,
if (is.data.frame(x)) { if (is.data.frame(x)) {
rsi_integrity_check <- character(0) rsi_integrity_check <- character(0)
for (i in 1:ncol(x)) { for (i in seq_len(ncol(x))) {
# check integrity of columns: force rsi class # check integrity of columns: force rsi class
if (!is.rsi(x %>% pull(i))) { if (!is.rsi(x %>% pull(i))) {
rsi_integrity_check <- c(rsi_integrity_check, x %>% pull(i) %>% as.character()) rsi_integrity_check <- c(rsi_integrity_check, x %>% pull(i) %>% as.character())
@ -129,7 +125,9 @@ rsi_calc <- function(...,
} else { } else {
# THE NUMBER OF ISOLATES WHERE *ANY* ABx IS S/I/R # THE NUMBER OF ISOLATES WHERE *ANY* ABx IS S/I/R
other_values <- base::setdiff(c(NA, levels(ab_result)), ab_result) other_values <- base::setdiff(c(NA, levels(ab_result)), ab_result)
other_values_filter <- base::apply(x, 1, function(y) { base::all(y %in% other_values) & base::any(is.na(y)) }) other_values_filter <- base::apply(x, 1, function(y) {
base::all(y %in% other_values) & base::any(is.na(y))
})
numerator <- x %>% filter_all(any_vars(. %in% ab_result)) %>% nrow() numerator <- x %>% filter_all(any_vars(. %in% ab_result)) %>% nrow()
denominator <- x %>% filter(!other_values_filter) %>% nrow() denominator <- x %>% filter(!other_values_filter) %>% nrow()
} }

2
R/translate.R
View File

@ -134,7 +134,7 @@ translate_AMR <- function(from, language = get_locale(), only_unknown = FALSE) {
return(from) return(from)
} }
for (i in 1:nrow(df_trans)) { for (i in seq_len(nrow(df_trans))) {
from <- gsub(x = from, from <- gsub(x = from,
pattern = df_trans$pattern[i], pattern = df_trans$pattern[i],
replacement = df_trans$replacement[i], replacement = df_trans$replacement[i],

35
R/zzz.R
View File

@ -42,42 +42,9 @@
value = make_trans_tbl(), value = make_trans_tbl(),
envir = asNamespace("AMR")) envir = asNamespace("AMR"))
# assign(x = "mo_history",
# value = data.frame(x = character(0),
# mo = character(0),
# uncertainty_level = integer(0),
# package_v = character(0),
# stringsAsFactors = FALSE),
# envir = asNamespace("AMR"))
} }
# maybe add survey later: "https://www.surveymonkey.com/r/AMR_for_R"
.onAttach <- function(...) {
# if (interactive() & !isFALSE(getOption("AMR_survey"))) {
# options(AMR_survey = FALSE)
# console_width <- options()$width - 1
# url <- "https://www.surveymonkey.com/r/AMR_for_R"
# txt <- paste0("Thanks for using the AMR package! ",
# "As researchers, we are interested in how and why you use this package and if there are things you're missing from it. ",
# "Please fill in our 2-minute survey at: ", url, ". ",
# "This message can be turned off with: options(AMR_survey = FALSE)")
#
# # make it honour new lines bases on console width:
# txt <- unlist(strsplit(txt, " "))
# txt_new <- ""
# total_chars <- 0
# for (i in 1:length(txt)) {
# total_chars <- total_chars + nchar(txt[i]) + 1
# if (total_chars > console_width) {
# txt_new <- paste0(txt_new, "\n")
# total_chars <- 0
# }
# txt_new <- paste0(txt_new, txt[i], " ")
# }
# # packageStartupMessage(txt_new)
# }
}
#' @importFrom data.table as.data.table setkey #' @importFrom data.table as.data.table setkey
make_DT <- function() { make_DT <- function() {

2
docs/404.html
View File

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

2
docs/LICENSE-text.html
View File

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

2
docs/articles/index.html
View File

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

2
docs/authors.html
View File

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

2
docs/index.html
View File

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

44
docs/news/index.html
View File

@ -84,7 +84,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a> <a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">0.7.1.9100</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">0.7.1.9102</span>
</span> </span>
</div> </div>
@ -231,11 +231,11 @@
</div> </div>
<div id="amr-0-7-1-9100" class="section level1"> <div id="amr-0-7-1-9102" class="section level1">
<h1 class="page-header"> <h1 class="page-header">
<a href="#amr-0-7-1-9100" class="anchor"></a>AMR 0.7.1.9100<small> Unreleased </small> <a href="#amr-0-7-1-9102" class="anchor"></a>AMR 0.7.1.9102<small> Unreleased </small>
</h1> </h1>
<p><small>Last updated: 08-Oct-2019</small></p> <p><small>Last updated: 11-Oct-2019</small></p>
<div id="breaking" class="section level3"> <div id="breaking" class="section level3">
<h3 class="hasAnchor"> <h3 class="hasAnchor">
<a href="#breaking" class="anchor"></a>Breaking</h3> <a href="#breaking" class="anchor"></a>Breaking</h3>
@ -267,31 +267,32 @@ This is important, because a value like <code>"testvalue"</code> could never be
<a href="#new" class="anchor"></a>New</h3> <a href="#new" class="anchor"></a>New</h3>
<ul> <ul>
<li> <li>
<p>Function <code><a href="../reference/bug_drug_combinations.html">bug_drug_combinations()</a></code> to quickly get a <code>data.frame</code> with the antimicrobial resistance of any bug-drug combination in a data set. The columns with microorganism codes is guessed automatically and its input is transformed with <code><a href="../reference/mo_property.html">mo_shortname()</a></code> at default:</p> <p>Function <code><a href="../reference/bug_drug_combinations.html">bug_drug_combinations()</a></code> to quickly get a <code>data.frame</code> with the results of all bug-drug combinations in a data set. The column containing microorganism codes is guessed automatically and its input is transformed with <code><a href="../reference/mo_property.html">mo_shortname()</a></code> at default:</p>
<div class="sourceCode" id="cb3"><pre class="sourceCode r"><code class="sourceCode r"><a class="sourceLine" id="cb3-1" data-line-number="1">x &lt;-<span class="st"> </span><span class="kw"><a href="../reference/bug_drug_combinations.html">bug_drug_combinations</a></span>(example_isolates)</a> <div class="sourceCode" id="cb3"><pre class="sourceCode r"><code class="sourceCode r"><a class="sourceLine" id="cb3-1" data-line-number="1">x &lt;-<span class="st"> </span><span class="kw"><a href="../reference/bug_drug_combinations.html">bug_drug_combinations</a></span>(example_isolates)</a>
<a class="sourceLine" id="cb3-2" data-line-number="2"><span class="co"># </span><span class="al">NOTE</span><span class="co">: Using column `mo` as input for `col_mo`.</span></a> <a class="sourceLine" id="cb3-2" data-line-number="2"><span class="co">#&gt; </span><span class="al">NOTE</span><span class="co">: Using column `mo` as input for `col_mo`.</span></a>
<a class="sourceLine" id="cb3-3" data-line-number="3">x[<span class="dv">1</span><span class="op">:</span><span class="dv">5</span>, ]</a> <a class="sourceLine" id="cb3-3" data-line-number="3">x[<span class="dv">1</span><span class="op">:</span><span class="dv">4</span>, ]</a>
<a class="sourceLine" id="cb3-4" data-line-number="4"><span class="co">#&gt; ab mo S I R total</span></a> <a class="sourceLine" id="cb3-4" data-line-number="4"><span class="co">#&gt; mo ab S I R total</span></a>
<a class="sourceLine" id="cb3-5" data-line-number="5"><span class="co">#&gt; 1 AMC CoNS 178 0 132 310</span></a> <a class="sourceLine" id="cb3-5" data-line-number="5"><span class="co">#&gt; 1 A. baumannii AMC 0 0 3 3</span></a>
<a class="sourceLine" id="cb3-6" data-line-number="6"><span class="co">#&gt; 2 AMC E. coli 332 74 61 467</span></a> <a class="sourceLine" id="cb3-6" data-line-number="6"><span class="co">#&gt; 2 A. baumannii AMK 0 0 0 0</span></a>
<a class="sourceLine" id="cb3-7" data-line-number="7"><span class="co">#&gt; 3 AMC K. pneumoniae 49 3 6 58</span></a> <a class="sourceLine" id="cb3-7" data-line-number="7"><span class="co">#&gt; 3 A. baumannii AMP 0 0 3 3</span></a>
<a class="sourceLine" id="cb3-8" data-line-number="8"><span class="co">#&gt; 4 AMC P. aeruginosa 0 0 30 30</span></a> <a class="sourceLine" id="cb3-8" data-line-number="8"><span class="co">#&gt; 4 A. baumannii AMX 0 0 3 3</span></a>
<a class="sourceLine" id="cb3-9" data-line-number="9"><span class="co">#&gt; 5 AMC P. mirabilis 28 7 1 36</span></a> <a class="sourceLine" id="cb3-9" data-line-number="9"><span class="co">#&gt; </span><span class="al">NOTE</span><span class="co">: Use 'format()' on this result to get a publicable/printable format.</span></a>
<a class="sourceLine" id="cb3-10" data-line-number="10"></a> <a class="sourceLine" id="cb3-10" data-line-number="10"></a>
<a class="sourceLine" id="cb3-11" data-line-number="11"><span class="co"># change the transformation with the FUN argument to anything you like:</span></a> <a class="sourceLine" id="cb3-11" data-line-number="11"><span class="co"># change the transformation with the FUN argument to anything you like:</span></a>
<a class="sourceLine" id="cb3-12" data-line-number="12">x &lt;-<span class="st"> </span><span class="kw"><a href="../reference/bug_drug_combinations.html">bug_drug_combinations</a></span>(example_isolates, <span class="dt">FUN =</span> mo_gramstain)</a> <a class="sourceLine" id="cb3-12" data-line-number="12">x &lt;-<span class="st"> </span><span class="kw"><a href="../reference/bug_drug_combinations.html">bug_drug_combinations</a></span>(example_isolates, <span class="dt">FUN =</span> mo_gramstain)</a>
<a class="sourceLine" id="cb3-13" data-line-number="13"><span class="co"># </span><span class="al">NOTE</span><span class="co">: Using column `mo` as input for `col_mo`.</span></a> <a class="sourceLine" id="cb3-13" data-line-number="13"><span class="co">#&gt; </span><span class="al">NOTE</span><span class="co">: Using column `mo` as input for `col_mo`.</span></a>
<a class="sourceLine" id="cb3-14" data-line-number="14">x[<span class="dv">1</span><span class="op">:</span><span class="dv">4</span>, ]</a> <a class="sourceLine" id="cb3-14" data-line-number="14">x[<span class="dv">1</span><span class="op">:</span><span class="dv">4</span>, ]</a>
<a class="sourceLine" id="cb3-15" data-line-number="15"><span class="co">#&gt; ab mo S I R total</span></a> <a class="sourceLine" id="cb3-15" data-line-number="15"><span class="co">#&gt; mo ab S I R total</span></a>
<a class="sourceLine" id="cb3-16" data-line-number="16"><span class="co">#&gt; 1 AMC Gram-negative 469 89 174 732</span></a> <a class="sourceLine" id="cb3-16" data-line-number="16"><span class="co">#&gt; 1 Gram-negative AMC 469 89 174 732</span></a>
<a class="sourceLine" id="cb3-17" data-line-number="17"><span class="co">#&gt; 2 AMC Gram-positive 873 2 272 1147</span></a> <a class="sourceLine" id="cb3-17" data-line-number="17"><span class="co">#&gt; 2 Gram-negative AMK 251 0 2 253</span></a>
<a class="sourceLine" id="cb3-18" data-line-number="18"><span class="co">#&gt; 3 AMK Gram-negative 251 0 2 253</span></a> <a class="sourceLine" id="cb3-18" data-line-number="18"><span class="co">#&gt; 3 Gram-negative AMP 227 0 405 632</span></a>
<a class="sourceLine" id="cb3-19" data-line-number="19"><span class="co">#&gt; 4 AMK Gram-positive 0 0 100 100</span></a></code></pre></div> <a class="sourceLine" id="cb3-19" data-line-number="19"><span class="co">#&gt; 4 Gram-negative AMX 227 0 405 632</span></a>
<a class="sourceLine" id="cb3-20" data-line-number="20"><span class="co">#&gt; </span><span class="al">NOTE</span><span class="co">: Use 'format()' on this result to get a publicable/printable format.</span></a></code></pre></div>
<p>You can format this to a printable format, ready for reporting or exporting to e.g. Excel with the base R <code><a href="https://rdrr.io/r/base/format.html">format()</a></code> function:</p> <p>You can format this to a printable format, ready for reporting or exporting to e.g. Excel with the base R <code><a href="https://rdrr.io/r/base/format.html">format()</a></code> function:</p>
<div class="sourceCode" id="cb4"><pre class="sourceCode r"><code class="sourceCode r"><a class="sourceLine" id="cb4-1" data-line-number="1"><span class="kw"><a href="https://rdrr.io/r/base/format.html">format</a></span>(x, <span class="dt">combine_IR =</span> <span class="ot">FALSE</span>)</a></code></pre></div> <div class="sourceCode" id="cb4"><pre class="sourceCode r"><code class="sourceCode r"><a class="sourceLine" id="cb4-1" data-line-number="1"><span class="kw"><a href="https://rdrr.io/r/base/format.html">format</a></span>(x, <span class="dt">combine_IR =</span> <span class="ot">FALSE</span>)</a></code></pre></div>
</li> </li>
<li> <li>
<p>Additional way to calculate co-resistance, i.e. when using multiple antimicrobials as input for <code>portion_*</code> functions or <code>count_*</code> functions. This can be used to determine the empiric susceptibily of a combination therapy. A new parameter <code>only_all_tested</code> (<strong>which defaults to <code>FALSE</code></strong>) replaces the old <code>also_single_tested</code> and can be used to select one of the two methods to count isolates and calculate portions. The difference can be seen in this example table (which is also on the <code>portion</code> and <code>count</code> help pages), where the %SI is being determined:</p> <p>Additional way to calculate co-resistance, i.e. when using multiple antimicrobials as input for <code>portion_*</code> functions or <code>count_*</code> functions. This can be used to determine the empiric susceptibility of a combination therapy. A new parameter <code>only_all_tested</code> (<strong>which defaults to <code>FALSE</code></strong>) replaces the old <code>also_single_tested</code> and can be used to select one of the two methods to count isolates and calculate portions. The difference can be seen in this example table (which is also on the <code>portion</code> and <code>count</code> help pages), where the %SI is being determined:</p>
<div class="sourceCode" id="cb5"><pre class="sourceCode r"><code class="sourceCode r"><a class="sourceLine" id="cb5-1" data-line-number="1"><span class="co"># --------------------------------------------------------------------</span></a> <div class="sourceCode" id="cb5"><pre class="sourceCode r"><code class="sourceCode r"><a class="sourceLine" id="cb5-1" data-line-number="1"><span class="co"># --------------------------------------------------------------------</span></a>
<a class="sourceLine" id="cb5-2" data-line-number="2"><span class="co"># only_all_tested = FALSE only_all_tested = TRUE</span></a> <a class="sourceLine" id="cb5-2" data-line-number="2"><span class="co"># only_all_tested = FALSE only_all_tested = TRUE</span></a>
<a class="sourceLine" id="cb5-3" data-line-number="3"><span class="co"># ----------------------- -----------------------</span></a> <a class="sourceLine" id="cb5-3" data-line-number="3"><span class="co"># ----------------------- -----------------------</span></a>
@ -377,6 +378,7 @@ Since this is a major change, usage of the old <code>also_single_tested</code> w
<a href="#other" class="anchor"></a>Other</h4> <a href="#other" class="anchor"></a>Other</h4>
<ul> <ul>
<li>Added Prof. Dr. Casper Albers as doctoral advisor and added Dr. Judith Fonville, Eric Hazenberg, Dr. Bart Meijer, Dr. Dennis Souverein and Annick Lenglet as contributors</li> <li>Added Prof. Dr. Casper Albers as doctoral advisor and added Dr. Judith Fonville, Eric Hazenberg, Dr. Bart Meijer, Dr. Dennis Souverein and Annick Lenglet as contributors</li>
<li>Cleaned the coding style of every single syntax line in this package with the help of the <code>lintr</code> package</li>
</ul> </ul>
</div> </div>
</div> </div>
@ -1290,7 +1292,7 @@ Using <code><a href="../reference/as.mo.html">as.mo(..., allow_uncertain = 3)</a
<div id="tocnav"> <div id="tocnav">
<h2>Contents</h2> <h2>Contents</h2>
<ul class="nav nav-pills nav-stacked"> <ul class="nav nav-pills nav-stacked">
<li><a href="#amr-0-7-1-9100">0.7.1.9100</a></li> <li><a href="#amr-0-7-1-9102">0.7.1.9102</a></li>
<li><a href="#amr-0-7-1">0.7.1</a></li> <li><a href="#amr-0-7-1">0.7.1</a></li>
<li><a href="#amr-0-7-0">0.7.0</a></li> <li><a href="#amr-0-7-0">0.7.0</a></li>
<li><a href="#amr-0-6-1">0.6.1</a></li> <li><a href="#amr-0-6-1">0.6.1</a></li>

2
docs/pkgdown.yml
View File

@ -1,4 +1,4 @@
pandoc: [] pandoc: 2.3.1
pkgdown: 1.4.1 pkgdown: 1.4.1
pkgdown_sha: ~ pkgdown_sha: ~
articles: articles:

4
docs/reference/bug_drug_combinations.html
View File

@ -85,7 +85,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a> <a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">0.7.1.9100</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">0.7.1.9102</span>
</span> </span>
</div> </div>
@ -327,7 +327,7 @@
<pre class="examples"><span class='co'># \donttest{</span> <pre class="examples"><span class='co'># \donttest{</span>
<span class='no'>x</span> <span class='kw'>&lt;-</span> <span class='fu'>bug_drug_combinations</span>(<span class='no'>example_isolates</span>) <span class='no'>x</span> <span class='kw'>&lt;-</span> <span class='fu'>bug_drug_combinations</span>(<span class='no'>example_isolates</span>)
<span class='no'>x</span> <span class='no'>x</span>
<span class='fu'><a href='https://rdrr.io/r/base/format.html'>format</a></span>(<span class='no'>x</span>) <span class='fu'><a href='https://rdrr.io/r/base/format.html'>format</a></span>(<span class='no'>x</span>, <span class='kw'>translate_ab</span> <span class='kw'>=</span> <span class='st'>"name (atc)"</span>)
<span class='co'># Use FUN to change to transformation of microorganism codes</span> <span class='co'># Use FUN to change to transformation of microorganism codes</span>
<span class='no'>x</span> <span class='kw'>&lt;-</span> <span class='fu'>bug_drug_combinations</span>(<span class='no'>example_isolates</span>, <span class='no'>x</span> <span class='kw'>&lt;-</span> <span class='fu'>bug_drug_combinations</span>(<span class='no'>example_isolates</span>,

87
docs/reference/first_isolate.html
View File

@ -15,21 +15,25 @@
<link rel="apple-touch-icon" type="image/png" sizes="120x120" href="../apple-touch-icon-120x120.png" /> <link rel="apple-touch-icon" type="image/png" sizes="120x120" href="../apple-touch-icon-120x120.png" />
<link rel="apple-touch-icon" type="image/png" sizes="76x76" href="../apple-touch-icon-76x76.png" /> <link rel="apple-touch-icon" type="image/png" sizes="76x76" href="../apple-touch-icon-76x76.png" />
<link rel="apple-touch-icon" type="image/png" sizes="60x60" href="../apple-touch-icon-60x60.png" /> <link rel="apple-touch-icon" type="image/png" sizes="60x60" href="../apple-touch-icon-60x60.png" />
<!-- jquery --> <!-- jquery -->
<script src="https://cdnjs.cloudflare.com/ajax/libs/jquery/3.3.1/jquery.min.js" integrity="sha256-FgpCb/KJQlLNfOu91ta32o/NMZxltwRo8QtmkMRdAu8=" crossorigin="anonymous"></script> <script src="https://cdnjs.cloudflare.com/ajax/libs/jquery/3.3.1/jquery.min.js" integrity="sha256-FgpCb/KJQlLNfOu91ta32o/NMZxltwRo8QtmkMRdAu8=" crossorigin="anonymous"></script>
<!-- Bootstrap --> <!-- Bootstrap -->
<link href="https://cdnjs.cloudflare.com/ajax/libs/bootswatch/3.3.7/flatly/bootstrap.min.css" rel="stylesheet" crossorigin="anonymous" /> <link href="https://cdnjs.cloudflare.com/ajax/libs/bootswatch/3.3.7/flatly/bootstrap.min.css" rel="stylesheet" crossorigin="anonymous" />
<script src="https://cdnjs.cloudflare.com/ajax/libs/twitter-bootstrap/3.3.7/js/bootstrap.min.js" integrity="sha256-U5ZEeKfGNOja007MMD3YBI0A3OSZOQbeG6z2f2Y0hu8=" crossorigin="anonymous"></script> <script src="https://cdnjs.cloudflare.com/ajax/libs/twitter-bootstrap/3.3.7/js/bootstrap.min.js" integrity="sha256-U5ZEeKfGNOja007MMD3YBI0A3OSZOQbeG6z2f2Y0hu8=" crossorigin="anonymous"></script>
<!-- Font Awesome icons --> <!-- Font Awesome icons -->
<link rel="stylesheet" href="https://cdnjs.cloudflare.com/ajax/libs/font-awesome/4.7.0/css/font-awesome.min.css" integrity="sha256-eZrrJcwDc/3uDhsdt61sL2oOBY362qM3lon1gyExkL0=" crossorigin="anonymous" /> <link rel="stylesheet" href="https://cdnjs.cloudflare.com/ajax/libs/font-awesome/5.7.1/css/all.min.css" integrity="sha256-nAmazAk6vS34Xqo0BSrTb+abbtFlgsFK7NKSi6o7Y78=" crossorigin="anonymous" />
<link rel="stylesheet" href="https://cdnjs.cloudflare.com/ajax/libs/font-awesome/5.7.1/css/v4-shims.min.css" integrity="sha256-6qHlizsOWFskGlwVOKuns+D1nB6ssZrHQrNj1wGplHc=" crossorigin="anonymous" />
<!-- clipboard.js --> <!-- clipboard.js -->
<script src="https://cdnjs.cloudflare.com/ajax/libs/clipboard.js/2.0.4/clipboard.min.js" integrity="sha256-FiZwavyI2V6+EXO1U+xzLG3IKldpiTFf3153ea9zikQ=" crossorigin="anonymous"></script> <script src="https://cdnjs.cloudflare.com/ajax/libs/clipboard.js/2.0.4/clipboard.min.js" integrity="sha256-FiZwavyI2V6+EXO1U+xzLG3IKldpiTFf3153ea9zikQ=" crossorigin="anonymous"></script>
<!-- sticky kit --> <!-- headroom.js -->
<script src="https://cdnjs.cloudflare.com/ajax/libs/sticky-kit/1.1.3/sticky-kit.min.js" integrity="sha256-c4Rlo1ZozqTPE2RLuvbusY3+SU1pQaJC0TjuhygMipw=" crossorigin="anonymous"></script> <script src="https://cdnjs.cloudflare.com/ajax/libs/headroom/0.9.4/headroom.min.js" integrity="sha256-DJFC1kqIhelURkuza0AvYal5RxMtpzLjFhsnVIeuk+U=" crossorigin="anonymous"></script>
<script src="https://cdnjs.cloudflare.com/ajax/libs/headroom/0.9.4/jQuery.headroom.min.js" integrity="sha256-ZX/yNShbjqsohH1k95liqY9Gd8uOiE1S4vZc+9KQ1K4=" crossorigin="anonymous"></script>
<!-- pkgdown --> <!-- pkgdown -->
<link href="../pkgdown.css" rel="stylesheet"> <link href="../pkgdown.css" rel="stylesheet">
@ -45,15 +49,15 @@
<link href="../extra.css" rel="stylesheet"> <link href="../extra.css" rel="stylesheet">
<script src="../extra.js"></script> <script src="../extra.js"></script>
<meta property="og:title" content="Determine first (weighted) isolates — first_isolate" /> <meta property="og:title" content="Determine first (weighted) isolates — first_isolate" />
<meta property="og:description" content="Determine first (weighted) isolates of all microorganisms of every patient per episode and (if needed) per specimen type." /> <meta property="og:description" content="Determine first (weighted) isolates of all microorganisms of every patient per episode and (if needed) per specimen type." />
<meta property="og:image" content="https://msberends.gitlab.io/AMR/logo.png" /> <meta property="og:image" content="https://msberends.gitlab.io/AMR/logo.png" />
<meta name="twitter:card" content="summary" /> <meta name="twitter:card" content="summary" />
<!-- mathjax --> <!-- mathjax -->
<script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js" integrity="sha256-nvJJv9wWKEm88qvoQl9ekL2J+k/RWIsaSScxxlsrv8k=" crossorigin="anonymous"></script> <script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js" integrity="sha256-nvJJv9wWKEm88qvoQl9ekL2J+k/RWIsaSScxxlsrv8k=" crossorigin="anonymous"></script>
<script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/config/TeX-AMS-MML_HTMLorMML.js" integrity="sha256-84DKXVJXs0/F8OTMzX4UR909+jtl4G7SPypPavF+GfA=" crossorigin="anonymous"></script> <script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/config/TeX-AMS-MML_HTMLorMML.js" integrity="sha256-84DKXVJXs0/F8OTMzX4UR909+jtl4G7SPypPavF+GfA=" crossorigin="anonymous"></script>
@ -64,6 +68,7 @@
<![endif]--> <![endif]-->
</head> </head>
<body> <body>
@ -80,7 +85,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a> <a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">0.7.1.9067</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">0.7.1.9102</span>
</span> </span>
</div> </div>
@ -189,7 +194,6 @@
</a> </a>
</li> </li>
</ul> </ul>
<ul class="nav navbar-nav navbar-right"> <ul class="nav navbar-nav navbar-right">
<li> <li>
<a href="https://gitlab.com/msberends/AMR"> <a href="https://gitlab.com/msberends/AMR">
@ -207,7 +211,7 @@
</li> </li>
</ul> </ul>
<form class="navbar-form navbar-right" role="search"> <form class="navbar-form navbar-right hidden-xs hidden-sm" role="search">
<div class="form-group"> <div class="form-group">
<input type="search" class="form-control" name="search-input" id="search-input" placeholder="Search..." aria-label="Search for..." autocomplete="off"> <input type="search" class="form-control" name="search-input" id="search-input" placeholder="Search..." aria-label="Search for..." autocomplete="off">
</div> </div>
@ -218,6 +222,7 @@
</div><!--/.navbar --> </div><!--/.navbar -->
</header> </header>
<div class="row"> <div class="row">
@ -229,9 +234,7 @@
</div> </div>
<div class="ref-description"> <div class="ref-description">
<p>Determine first (weighted) isolates of all microorganisms of every patient per episode and (if needed) per specimen type.</p> <p>Determine first (weighted) isolates of all microorganisms of every patient per episode and (if needed) per specimen type.</p>
</div> </div>
<pre class="usage"><span class='fu'>first_isolate</span>(<span class='no'>x</span>, <span class='kw'>col_date</span> <span class='kw'>=</span> <span class='kw'>NULL</span>, <span class='kw'>col_patient_id</span> <span class='kw'>=</span> <span class='kw'>NULL</span>, <pre class="usage"><span class='fu'>first_isolate</span>(<span class='no'>x</span>, <span class='kw'>col_date</span> <span class='kw'>=</span> <span class='kw'>NULL</span>, <span class='kw'>col_patient_id</span> <span class='kw'>=</span> <span class='kw'>NULL</span>,
@ -328,11 +331,9 @@
<h2 class="hasAnchor" id="source"><a class="anchor" href="#source"></a>Source</h2> <h2 class="hasAnchor" id="source"><a class="anchor" href="#source"></a>Source</h2>
<p>Methodology of this function is based on: <strong>M39 Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data, 4th Edition</strong>, 2014, <em>Clinical and Laboratory Standards Institute (CLSI)</em>. <a href='https://clsi.org/standards/products/microbiology/documents/m39/'>https://clsi.org/standards/products/microbiology/documents/m39/</a>.</p> <p>Methodology of this function is based on: <strong>M39 Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data, 4th Edition</strong>, 2014, <em>Clinical and Laboratory Standards Institute (CLSI)</em>. <a href='https://clsi.org/standards/products/microbiology/documents/m39/'>https://clsi.org/standards/products/microbiology/documents/m39/</a>.</p>
<h2 class="hasAnchor" id="value"><a class="anchor" href="#value"></a>Value</h2> <h2 class="hasAnchor" id="value"><a class="anchor" href="#value"></a>Value</h2>
<p>Logical vector</p> <p>Logical vector</p>
<h2 class="hasAnchor" id="details"><a class="anchor" href="#details"></a>Details</h2> <h2 class="hasAnchor" id="details"><a class="anchor" href="#details"></a>Details</h2>
<p><strong>WHY THIS IS SO IMPORTANT</strong> <br /> <p><strong>WHY THIS IS SO IMPORTANT</strong> <br />
@ -355,28 +356,26 @@ To conduct an analysis of antimicrobial resistance, you should only include the
<h2 class="hasAnchor" id="key-antibiotics"><a class="anchor" href="#key-antibiotics"></a>Key antibiotics</h2> <h2 class="hasAnchor" id="key-antibiotics"><a class="anchor" href="#key-antibiotics"></a>Key antibiotics</h2>
<p>There are two ways to determine whether isolates can be included as first <em>weighted</em> isolates which will give generally the same results: <br /></p> <p>There are two ways to determine whether isolates can be included as first <em>weighted</em> isolates which will give generally the same results: <br /></p>
<p><strong>1. Using</strong> <code>type = "keyantibiotics"</code> <strong>and parameter</strong> <code>ignore_I</code> <br /> <p><strong>1. Using</strong> <code>type = "keyantibiotics"</code> <strong>and parameter</strong> <code>ignore_I</code> <br />
Any difference from S to R (or vice versa) will (re)select an isolate as a first weighted isolate. With <code>ignore_I = FALSE</code>, also differences from I to S|R (or vice versa) will lead to this. This is a reliable method and 30-35 times faster than method 2. Read more about this in the <code><a href='key_antibiotics.html'>key_antibiotics</a></code> function. <br /></p> Any difference from S to R (or vice versa) will (re)select an isolate as a first weighted isolate. With <code>ignore_I = FALSE</code>, also differences from I to S|R (or vice versa) will lead to this. This is a reliable method and 30-35 times faster than method 2. Read more about this in the <code><a href='key_antibiotics.html'>key_antibiotics</a></code> function. <br /></p>
<p><strong>2. Using</strong> <code>type = "points"</code> <strong>and parameter</strong> <code>points_threshold</code> <br /> <p><strong>2. Using</strong> <code>type = "points"</code> <strong>and parameter</strong> <code>points_threshold</code> <br />
A difference from I to S|R (or vice versa) means 0.5 points, a difference from S to R (or vice versa) means 1 point. When the sum of points exceeds <code>points_threshold</code>, which default to <code>2</code>, an isolate will be (re)selected as a first weighted isolate.</p> A difference from I to S|R (or vice versa) means 0.5 points, a difference from S to R (or vice versa) means 1 point. When the sum of points exceeds <code>points_threshold</code>, which default to <code>2</code>, an isolate will be (re)selected as a first weighted isolate.</p>
<h2 class="hasAnchor" id="read-more-on-our-website-"><a class="anchor" href="#read-more-on-our-website-"></a>Read more on our website!</h2> <h2 class="hasAnchor" id="read-more-on-our-website-"><a class="anchor" href="#read-more-on-our-website-"></a>Read more on our website!</h2>
<p>On our website <a href='https://msberends.gitlab.io/AMR'>https://msberends.gitlab.io/AMR</a> you can find <a href='https://msberends.gitlab.io/AMR/articles/AMR.html'>a tutorial</a> about how to conduct AMR analysis, the <a href='https://msberends.gitlab.io/AMR/reference'>complete documentation of all functions</a> (which reads a lot easier than here in R) and <a href='https://msberends.gitlab.io/AMR/articles/WHONET.html'>an example analysis using WHONET data</a>.</p>
<p>On our website <a href='https://msberends.gitlab.io/AMR'>https://msberends.gitlab.io/AMR</a> you can find <a href='https://msberends.gitlab.io/AMR/articles/AMR.html'>a tutorial</a> about how to conduct AMR analysis, the <a href='https://msberends.gitlab.io/AMR/reference'>complete documentation of all functions</a> (which reads a lot easier than here in R) and <a href='https://msberends.gitlab.io/AMR/articles/WHONET.html'>an example analysis using WHONET data</a>.</p>
<h2 class="hasAnchor" id="see-also"><a class="anchor" href="#see-also"></a>See also</h2> <h2 class="hasAnchor" id="see-also"><a class="anchor" href="#see-also"></a>See also</h2>
<div class='dont-index'><p><code><a href='key_antibiotics.html'>key_antibiotics</a></code></p></div> <div class='dont-index'><p><code><a href='key_antibiotics.html'>key_antibiotics</a></code></p></div>
<h2 class="hasAnchor" id="examples"><a class="anchor" href="#examples"></a>Examples</h2> <h2 class="hasAnchor" id="examples"><a class="anchor" href="#examples"></a>Examples</h2>
<pre class="examples"><span class='co'># NOT RUN {</span> <pre class="examples"><span class='co'># `example_isolates` is a dataset available in the AMR package.</span>
<span class='co'># `example_isolates` is a dataset available in the AMR package.</span>
<span class='co'># See ?example_isolates.</span> <span class='co'># See ?example_isolates.</span>
<span class='fu'><a href='https://www.rdocumentation.org/packages/base/topics/library'>library</a></span>(<span class='no'>dplyr</span>) <span class='fu'><a href='https://rdrr.io/r/base/library.html'>library</a></span>(<span class='no'>dplyr</span>)
<span class='co'># Filter on first isolates:</span> <span class='co'># Filter on first isolates:</span>
<span class='no'>example_isolates</span> <span class='kw'>%&gt;%</span> <span class='no'>example_isolates</span> <span class='kw'>%&gt;%</span>
<span class='fu'><a href='https://dplyr.tidyverse.org/reference/mutate.html'>mutate</a></span>(<span class='kw'>first_isolate</span> <span class='kw'>=</span> <span class='fu'>first_isolate</span>(<span class='no'>.</span>, <span class='fu'><a href='https://dplyr.tidyverse.org/reference/mutate.html'>mutate</a></span>(<span class='kw'>first_isolate</span> <span class='kw'>=</span> <span class='fu'>first_isolate</span>(<span class='no'>.</span>,
@ -412,76 +411,44 @@ To conduct an analysis of antimicrobial resistance, you should only include the
<span class='co'>## OTHER EXAMPLES:</span> <span class='co'>## OTHER EXAMPLES:</span>
<span class='co'># }</span><span class='co'># NOT RUN {</span> <span class='kw'>if</span> (<span class='fl'>FALSE</span>) {
<span class='co'># set key antibiotics to a new variable</span> <span class='co'># set key antibiotics to a new variable</span>
<span class='no'>x</span>$<span class='no'>keyab</span> <span class='kw'>&lt;-</span> <span class='fu'><a href='key_antibiotics.html'>key_antibiotics</a></span>(<span class='no'>x</span>) <span class='no'>x</span>$<span class='no'>keyab</span> <span class='kw'>&lt;-</span> <span class='fu'><a href='key_antibiotics.html'>key_antibiotics</a></span>(<span class='no'>x</span>)
<span class='no'>x</span>$<span class='no'>first_isolate</span> <span class='kw'>&lt;-</span> <span class='no'>x</span>$<span class='no'>first_isolate</span> <span class='kw'>&lt;-</span> <span class='fu'>first_isolate</span>(<span class='no'>x</span>)
<span class='fu'>first_isolate</span>(<span class='no'>x</span>)
<span class='no'>x</span>$<span class='no'>first_isolate_weighed</span> <span class='kw'>&lt;-</span> <span class='no'>x</span>$<span class='no'>first_isolate_weighed</span> <span class='kw'>&lt;-</span> <span class='fu'>first_isolate</span>(<span class='no'>x</span>, <span class='kw'>col_keyantibiotics</span> <span class='kw'>=</span> <span class='st'>'keyab'</span>)
<span class='fu'>first_isolate</span>(<span class='no'>x</span>,
<span class='kw'>col_keyantibiotics</span> <span class='kw'>=</span> <span class='st'>'keyab'</span>)
<span class='no'>x</span>$<span class='no'>first_blood_isolate</span> <span class='kw'>&lt;-</span> <span class='no'>x</span>$<span class='no'>first_blood_isolate</span> <span class='kw'>&lt;-</span> <span class='fu'>first_isolate</span>(<span class='no'>x</span>, <span class='kw'>specimen_group</span> <span class='kw'>=</span> <span class='st'>"Blood"</span>)
<span class='fu'>first_isolate</span>(<span class='no'>x</span>, }</pre>
<span class='kw'>specimen_group</span> <span class='kw'>=</span> <span class='st'>'Blood'</span>)
<span class='no'>x</span>$<span class='no'>first_blood_isolate_weighed</span> <span class='kw'>&lt;-</span>
<span class='fu'>first_isolate</span>(<span class='no'>x</span>,
<span class='kw'>specimen_group</span> <span class='kw'>=</span> <span class='st'>'Blood'</span>,
<span class='kw'>col_keyantibiotics</span> <span class='kw'>=</span> <span class='st'>'keyab'</span>)
<span class='no'>x</span>$<span class='no'>first_urine_isolate</span> <span class='kw'>&lt;-</span>
<span class='fu'>first_isolate</span>(<span class='no'>x</span>,
<span class='kw'>specimen_group</span> <span class='kw'>=</span> <span class='st'>'Urine'</span>)
<span class='no'>x</span>$<span class='no'>first_urine_isolate_weighed</span> <span class='kw'>&lt;-</span>
<span class='fu'>first_isolate</span>(<span class='no'>x</span>,
<span class='kw'>specimen_group</span> <span class='kw'>=</span> <span class='st'>'Urine'</span>,
<span class='kw'>col_keyantibiotics</span> <span class='kw'>=</span> <span class='st'>'keyab'</span>)
<span class='no'>x</span>$<span class='no'>first_resp_isolate</span> <span class='kw'>&lt;-</span>
<span class='fu'>first_isolate</span>(<span class='no'>x</span>,
<span class='kw'>specimen_group</span> <span class='kw'>=</span> <span class='st'>'Respiratory'</span>)
<span class='no'>x</span>$<span class='no'>first_resp_isolate_weighed</span> <span class='kw'>&lt;-</span>
<span class='fu'>first_isolate</span>(<span class='no'>x</span>,
<span class='kw'>specimen_group</span> <span class='kw'>=</span> <span class='st'>'Respiratory'</span>,
<span class='kw'>col_keyantibiotics</span> <span class='kw'>=</span> <span class='st'>'keyab'</span>)
<span class='co'># }</span></pre>
</div> </div>
<div class="col-md-3 hidden-xs hidden-sm" id="sidebar"> <div class="col-md-3 hidden-xs hidden-sm" id="sidebar">
<h2>Contents</h2> <h2>Contents</h2>
<ul class="nav nav-pills nav-stacked"> <ul class="nav nav-pills nav-stacked">
<li><a href="#arguments">Arguments</a></li> <li><a href="#arguments">Arguments</a></li>
<li><a href="#source">Source</a></li> <li><a href="#source">Source</a></li>
<li><a href="#value">Value</a></li> <li><a href="#value">Value</a></li>
<li><a href="#details">Details</a></li> <li><a href="#details">Details</a></li>
<li><a href="#key-antibiotics">Key antibiotics</a></li> <li><a href="#key-antibiotics">Key antibiotics</a></li>
<li><a href="#read-more-on-our-website-">Read more on our website!</a></li> <li><a href="#read-more-on-our-website-">Read more on our website!</a></li>
<li><a href="#see-also">See also</a></li> <li><a href="#see-also">See also</a></li>
<li><a href="#examples">Examples</a></li> <li><a href="#examples">Examples</a></li>
</ul> </ul>
</div> </div>
</div> </div>
<footer> <footer>
<div class="copyright"> <div class="copyright">
<p>Developed by <a href='https://www.rug.nl/staff/m.s.berends/'>Matthijs S. Berends</a>, <a href='https://www.rug.nl/staff/c.f.luz/'>Christian F. Luz</a>, <a href='https://www.rug.nl/staff/a.w.friedrich/'>Alex W. Friedrich</a>, <a href='https://www.rug.nl/staff/b.sinha/'>Bhanu N. M. Sinha</a>, <a href='https://www.rug.nl/staff/c.j.albers/'>Casper J. Albers</a>, <a href='https://www.rug.nl/staff/c.glasner/'>Corinna Glasner</a>.</p> <p>Developed by <a href='https://www.rug.nl/staff/m.s.berends/'>Matthijs S. Berends</a>, <a href='https://www.rug.nl/staff/c.f.luz/'>Christian F. Luz</a>, <a href='https://www.rug.nl/staff/a.w.friedrich/'>Alex W. Friedrich</a>, <a href='https://www.rug.nl/staff/b.sinha/'>Bhanu N. M. Sinha</a>, <a href='https://www.rug.nl/staff/c.j.albers/'>Casper J. Albers</a>, <a href='https://www.rug.nl/staff/c.glasner/'>Corinna Glasner</a>.</p>
</div> </div>
<div class="pkgdown"> <div class="pkgdown">
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.3.0.</p> <p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.4.1.</p>
</div> </div>
</footer> </footer>
</div> </div>
@ -504,6 +471,8 @@ To conduct an analysis of antimicrobial resistance, you should only include the
</script> </script>
</body> </body>
</html> </html>

2
docs/reference/index.html
View File

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

2
man/bug_drug_combinations.Rd
View File

@ -67,7 +67,7 @@ On our website \url{https://msberends.gitlab.io/AMR} you can find \href{https://
\donttest{ \donttest{
x <- bug_drug_combinations(example_isolates) x <- bug_drug_combinations(example_isolates)
x x
format(x) format(x, translate_ab = "name (atc)")
# Use FUN to change to transformation of microorganism codes # Use FUN to change to transformation of microorganism codes
x <- bug_drug_combinations(example_isolates, x <- bug_drug_combinations(example_isolates,

34
man/first_isolate.Rd
View File

@ -150,39 +150,11 @@ B <- example_isolates \%>\%
# set key antibiotics to a new variable # set key antibiotics to a new variable
x$keyab <- key_antibiotics(x) x$keyab <- key_antibiotics(x)
x$first_isolate <- x$first_isolate <- first_isolate(x)
first_isolate(x)
x$first_isolate_weighed <- x$first_isolate_weighed <- first_isolate(x, col_keyantibiotics = 'keyab')
first_isolate(x,
col_keyantibiotics = 'keyab')
x$first_blood_isolate <- x$first_blood_isolate <- first_isolate(x, specimen_group = "Blood")
first_isolate(x,
specimen_group = 'Blood')
x$first_blood_isolate_weighed <-
first_isolate(x,
specimen_group = 'Blood',
col_keyantibiotics = 'keyab')
x$first_urine_isolate <-
first_isolate(x,
specimen_group = 'Urine')
x$first_urine_isolate_weighed <-
first_isolate(x,
specimen_group = 'Urine',
col_keyantibiotics = 'keyab')
x$first_resp_isolate <-
first_isolate(x,
specimen_group = 'Respiratory')
x$first_resp_isolate_weighed <-
first_isolate(x,
specimen_group = 'Respiratory',
col_keyantibiotics = 'keyab')
} }
} }
\seealso{ \seealso{

3
tests/testthat/test-data.R
View File

@ -41,9 +41,8 @@ test_that("data sets are valid", {
# there should be no diacritics (i.e. non ASCII) characters in the datasets (CRAN policy) # there should be no diacritics (i.e. non ASCII) characters in the datasets (CRAN policy)
datasets <- data(package = "AMR", envir = asNamespace("AMR"))$results[, "Item"] datasets <- data(package = "AMR", envir = asNamespace("AMR"))$results[, "Item"]
for (i in 1:length(datasets)) { for (i in seq_len(length(datasets))) {
dataset <- get(datasets[i], envir = asNamespace("AMR")) dataset <- get(datasets[i], envir = asNamespace("AMR"))
#print(paste("testing data set", datasets[i]))
expect_identical(dataset_UTF8_to_ASCII(dataset), dataset) expect_identical(dataset_UTF8_to_ASCII(dataset), dataset)
} }
}) })

10
tests/testthat/test-first_isolate.R
View File

@ -33,16 +33,12 @@ test_that("first isolates work", {
na.rm = TRUE), na.rm = TRUE),
1317) 1317)
# first *weighted* isolates # first weighted isolates
expect_equal( expect_equal(
suppressWarnings( suppressWarnings(
sum( sum(
first_isolate(x = example_isolates %>% mutate(keyab = key_antibiotics(.)), first_isolate(x = example_isolates %>% mutate(keyab = key_antibiotics(.)),
# let syntax determine these automatically: # let syntax determine arguments automatically
# col_date = "date",
# col_patient_id = "patient_id",
# col_mo = "mo",
# col_keyantibiotics = "keyab",
type = "keyantibiotics", type = "keyantibiotics",
info = TRUE), info = TRUE),
na.rm = TRUE)), na.rm = TRUE)),
@ -145,7 +141,7 @@ test_that("first isolates work", {
filter_specimen = "something_unexisting"))) filter_specimen = "something_unexisting")))
# printing of exclusion message # printing of exclusion message
expect_output(example_isolates %>% expect_message(example_isolates %>%
first_isolate(col_date = "date", first_isolate(col_date = "date",
col_mo = "mo", col_mo = "mo",
col_patient_id = "patient_id", col_patient_id = "patient_id",

1
tests/testthat/test-freq.R
View File

@ -34,4 +34,3 @@ test_that("frequency table works", {
library(dplyr) library(dplyr)
expect_true(is.freq(example_isolates %>% freq(AMX))) expect_true(is.freq(example_isolates %>% freq(AMX)))
}) })

1
tests/testthat/test-get_locale.R
View File

@ -30,7 +30,6 @@ test_that("get_locale works", {
expect_identical(mo_fullname("CoNS", "nl"), "Coagulase-negatieve Staphylococcus (CNS)") expect_identical(mo_fullname("CoNS", "nl"), "Coagulase-negatieve Staphylococcus (CNS)")
expect_identical(mo_fullname("CoNS", "es"), "Staphylococcus coagulasa negativo (SCN)") expect_identical(mo_fullname("CoNS", "es"), "Staphylococcus coagulasa negativo (SCN)")
expect_identical(mo_fullname("CoNS", "it"), "Staphylococcus negativo coagulasi (CoNS)") expect_identical(mo_fullname("CoNS", "it"), "Staphylococcus negativo coagulasi (CoNS)")
# expect_identical(mo_fullname("CoNS", "fr"), "Staphylococcus \u00e0 coagulase n\u00e9gative (CoNS)")
expect_identical(mo_fullname("CoNS", "pt"), "Staphylococcus coagulase negativo (CoNS)") expect_identical(mo_fullname("CoNS", "pt"), "Staphylococcus coagulase negativo (CoNS)")
}) })

25
tests/testthat/test-ggplot_rsi.R
View File

@ -30,35 +30,26 @@ test_that("ggplot_rsi works", {
# data should be equal # data should be equal
expect_equal( expect_equal(
(example_isolates %>% select(AMC, CIP) %>% ggplot_rsi())$data %>% (example_isolates %>% select(AMC, CIP) %>% ggplot_rsi())$data %>% summarise_all(portion_IR) %>% as.double(),
summarise_all(portion_IR) %>% as.double(), example_isolates %>% select(AMC, CIP) %>% summarise_all(portion_IR) %>% as.double()
example_isolates %>% select(AMC, CIP) %>%
summarise_all(portion_IR) %>% as.double()
) )
print(example_isolates %>% select(AMC, CIP) %>% ggplot_rsi(x = "interpretation", facet = "antibiotic")) print(example_isolates %>% select(AMC, CIP) %>% ggplot_rsi(x = "interpretation", facet = "antibiotic"))
print(example_isolates %>% select(AMC, CIP) %>% ggplot_rsi(x = "antibiotic", facet = "interpretation")) print(example_isolates %>% select(AMC, CIP) %>% ggplot_rsi(x = "antibiotic", facet = "interpretation"))
expect_equal( expect_equal(
(example_isolates %>% select(AMC, CIP) %>% ggplot_rsi(x = "interpretation", facet = "antibiotic"))$data %>% (example_isolates %>% select(AMC, CIP) %>% ggplot_rsi(x = "interpretation", facet = "antibiotic"))$data %>% summarise_all(portion_IR) %>% as.double(),
summarise_all(portion_IR) %>% as.double(), example_isolates %>% select(AMC, CIP) %>% summarise_all(portion_IR) %>% as.double()
example_isolates %>% select(AMC, CIP) %>%
summarise_all(portion_IR) %>% as.double()
) )
expect_equal( expect_equal(
(example_isolates %>% select(AMC, CIP) %>% ggplot_rsi(x = "antibiotic", facet = "interpretation"))$data %>% (example_isolates %>% select(AMC, CIP) %>% ggplot_rsi(x = "antibiotic", facet = "interpretation"))$data %>% summarise_all(portion_IR) %>% as.double(),
summarise_all(portion_IR) %>% as.double(), example_isolates %>% select(AMC, CIP) %>% summarise_all(portion_IR) %>% as.double()
example_isolates %>% select(AMC, CIP) %>%
summarise_all(portion_IR) %>% as.double()
) )
expect_equal( expect_equal(
(example_isolates %>% select(AMC, CIP) %>% ggplot_rsi(x = "antibiotic", (example_isolates %>% select(AMC, CIP) %>% ggplot_rsi(x = "antibiotic", facet = "interpretation"))$data %>% summarise_all(count_IR) %>% as.double(),
facet = "interpretation"))$data %>% example_isolates %>% select(AMC, CIP) %>% summarise_all(count_IR) %>% as.double()
summarise_all(count_IR) %>% as.double(),
example_isolates %>% select(AMC, CIP) %>%
summarise_all(count_IR) %>% as.double()
) )
# support for scale_type ab and mo # support for scale_type ab and mo

4
tests/testthat/test-mdro.R
View File

@ -32,11 +32,11 @@ test_that("mdro works", {
outcome <- mdro(example_isolates) outcome <- mdro(example_isolates)
outcome <- eucast_exceptional_phenotypes(example_isolates, info = TRUE) outcome <- eucast_exceptional_phenotypes(example_isolates, info = TRUE)
# check class # check class
expect_equal(outcome %>% class(), c('ordered', 'factor')) expect_equal(outcome %>% class(), c("ordered", "factor"))
outcome <- mdro(example_isolates, "nl", info = TRUE) outcome <- mdro(example_isolates, "nl", info = TRUE)
# check class # check class
expect_equal(outcome %>% class(), c('ordered', 'factor')) expect_equal(outcome %>% class(), c("ordered", "factor"))
# example_isolates should have these finding using Dutch guidelines # example_isolates should have these finding using Dutch guidelines
expect_equal(outcome %>% freq() %>% pull(count), expect_equal(outcome %>% freq() %>% pull(count),

6
tests/testthat/test-mo.R
View File

@ -94,7 +94,7 @@ test_that("as.mo works", {
rep("B_STPHY_AURS", 9)) rep("B_STPHY_AURS", 9))
expect_identical( expect_identical(
as.character( as.character(
as.mo(c('EHEC', 'EPEC', 'EIEC', 'STEC', 'ATEC', 'UPEC'))), as.mo(c("EHEC", "EPEC", "EIEC", "STEC", "ATEC", "UPEC"))),
rep("B_ESCHR_COLI", 6)) rep("B_ESCHR_COLI", 6))
# unprevalent MO # unprevalent MO
expect_identical( expect_identical(
@ -260,10 +260,6 @@ test_that("as.mo works", {
expect_null(mo_failures()) expect_null(mo_failures())
expect_true(example_isolates %>% pull(mo) %>% is.mo()) expect_true(example_isolates %>% pull(mo) %>% is.mo())
# expect_equal(get_mo_code("test", "mo"), "test")
# expect_equal(length(get_mo_code("Escherichia", "genus")),
# nrow(AMR::microorganisms[base::which(AMR::microorganisms[, "genus"] %in% "Escherichia"),]))
expect_error(translate_allow_uncertain(5)) expect_error(translate_allow_uncertain(5))
# very old MO codes (<= v0.5.0) # very old MO codes (<= v0.5.0)

2
tests/testthat/test-mo_property.R
View File

@ -57,7 +57,7 @@ test_that("mo_property works", {
expect_equal(mo_shortname("Streptococcus agalactiae"), "S. agalactiae") expect_equal(mo_shortname("Streptococcus agalactiae"), "S. agalactiae")
expect_equal(mo_shortname("Streptococcus agalactiae", Lancefield = TRUE), "GBS") expect_equal(mo_shortname("Streptococcus agalactiae", Lancefield = TRUE), "GBS")
#expect_true(mo_url("Escherichia coli") %like% "www.catalogueoflife.org") expect_true(mo_url("Escherichia coli") %like% "www.catalogueoflife.org")
# test integrity # test integrity
MOs <- AMR::microorganisms MOs <- AMR::microorganisms