P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2024-12-25 07:26:12 +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$
^data-raw$
R/aa_test.R$
^\.lintr$

1
.gitignore vendored
View File

@ -22,4 +22,3 @@ packrat/lib*/
packrat/src/
data-raw/taxon.tab
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",
quiet = TRUE,
install_pkgdown = FALSE) {
install_pkgdown = FALSE,
install_lintr = FALSE) {
# update existing
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) {
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)

10
.gitlab-ci.yml
View File

@ -26,6 +26,7 @@ stages:
- build
- test
- deploy
- lint
image: rocker/r-base
@ -131,3 +132,12 @@ pages:
artifacts:
paths:
- 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
Version: 0.7.1.9101
Date: 2019-10-09
Version: 0.7.1.9102
Date: 2019-10-11
Title: Antimicrobial Resistance Analysis
Authors@R: c(
person(role = c("aut", "cre"),
@ -48,6 +48,7 @@ Suggests:
covr (>= 3.0.1),
curl,
readxl,
rmarkdown,
rstudioapi,
rvest (>= 0.3.2),
testthat (>= 1.0.2),

1
NAMESPACE
View File

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

5
NEWS.md
View File

@ -1,5 +1,5 @@
# AMR 0.7.1.9101
<small>Last updated: 09-Oct-2019</small>
# AMR 0.7.1.9102
<small>Last updated: 11-Oct-2019</small>
### 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`:
@ -126,6 +126,7 @@
#### 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
* Cleaned the coding style of every single syntax line in this package with the help of the `lintr` package
# AMR 0.7.1

26
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)
# remove part between brackets if that's followed by another string
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
x_bak_clean <- trimws(gsub(" +", " ", x_bak_clean, ignore.case = TRUE))
# 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_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])) {
next
}
@ -108,28 +106,28 @@ as.ab <- function(x, ...) {
}
# exact AB code
found <- AMR::antibiotics[which(AMR::antibiotics$ab == toupper(x[i])),]$ab
found <- AMR::antibiotics[which(AMR::antibiotics$ab == toupper(x[i])), ]$ab
if (length(found) > 0) {
x_new[i] <- found[1L]
next
}
# exact ATC code
found <- AMR::antibiotics[which(AMR::antibiotics$atc == toupper(x[i])),]$ab
found <- AMR::antibiotics[which(AMR::antibiotics$atc == toupper(x[i])), ]$ab
if (length(found) > 0) {
x_new[i] <- found[1L]
next
}
# exact CID code
found <- AMR::antibiotics[which(AMR::antibiotics$cid == x[i]),]$ab
found <- AMR::antibiotics[which(AMR::antibiotics$cid == x[i]), ]$ab
if (length(found) > 0) {
x_new[i] <- found[1L]
next
}
# exact name
found <- AMR::antibiotics[which(toupper(AMR::antibiotics$name) == toupper(x[i])),]$ab
found <- AMR::antibiotics[which(toupper(AMR::antibiotics$name) == toupper(x[i])), ]$ab
if (length(found) > 0) {
x_new[i] <- found[1L]
next
@ -163,7 +161,7 @@ as.ab <- function(x, ...) {
# first >=4 characters of name
if (nchar(x[i]) >= 4) {
found <- AMR::antibiotics[which(toupper(AMR::antibiotics$name) %like% paste0("^", x[i])),]$ab
found <- AMR::antibiotics[which(toupper(AMR::antibiotics$name) %like% paste0("^", x[i])), ]$ab
if (length(found) > 0) {
x_new[i] <- found[1L]
next
@ -193,7 +191,7 @@ as.ab <- function(x, ...) {
x_spelling <- gsub("(.)\\1+", "\\1+", x_spelling)
# try if name starts with it
found <- AMR::antibiotics[which(AMR::antibiotics$name %like% paste0("^", x_spelling)),]$ab
found <- AMR::antibiotics[which(AMR::antibiotics$name %like% paste0("^", x_spelling)), ]$ab
if (length(found) > 0) {
x_new[i] <- found[1L]
next
@ -233,7 +231,7 @@ as.ab <- function(x, ...) {
# transform back from other languages and try again
x_translated <- paste(lapply(strsplit(x[i], "[^a-zA-Z0-9 ]"),
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),
translations_file[which(tolower(translations_file$replacement) == tolower(y[i]) &
!isFALSE(translations_file$fixed)), "pattern"],
@ -252,7 +250,7 @@ as.ab <- function(x, ...) {
# now also try to coerce brandname combinations like "Amoxy/clavulanic acid"
x_translated <- paste(lapply(strsplit(x_translated, "[^a-zA-Z0-9 ]"),
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[i] <- ifelse(!is.na(y_name),
y_name,
@ -278,14 +276,14 @@ as.ab <- function(x, ...) {
x_unknown <- x_unknown[!x_unknown %in% x_unknown_ATCs]
if (length(x_unknown_ATCs) > 0) {
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)
}
if (length(x_unknown) > 0) {
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)
}
@ -319,7 +317,7 @@ print.ab <- function(x, ...) {
#' @exportMethod as.data.frame.ab
#' @export
#' @noRd
as.data.frame.ab <- function (x, ...) {
as.data.frame.ab <- function(x, ...) {
# same as as.data.frame.character but with removed stringsAsFactors
nm <- paste(deparse(substitute(x), width.cutoff = 500L),
collapse = " ")

2
R/ab_property.R
View File

@ -165,7 +165,7 @@ ab_info <- function(x, language = get_locale(), ...) {
#' @rdname ab_property
#' @export
ab_property <- function(x, property = 'name', language = get_locale(), ...) {
ab_property <- function(x, property = "name", language = get_locale(), ...) {
if (length(property) != 1L) {
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
y <- x
labs <- split_at
for (i in 1:length(split_at)) {
for (i in seq_len(length(split_at))) {
y[x >= split_at[i]] <- i
# create labels
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}
#' @name AMR
#' @rdname AMR
# # prevent NOTE on R >= 3.6
#' @importFrom microbenchmark microbenchmark
#' @importFrom knitr kable
NULL

39
R/atc_online.R
View File

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

6
R/availability.R
View File

@ -44,7 +44,9 @@
#' select_if(is.rsi) %>%
#' availability()
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)]))
R <- base::sapply(tbl, function(x) base::ifelse(is.rsi(x), portion_R(x, minimum = 0), NA))
R_print <- character(length(R))
@ -83,7 +85,7 @@ availability <- function(tbl, width = NULL) {
resistant = R_print,
visual_resistance = vis_resistance)
if (length(R[is.na(R)]) == ncol(tbl)) {
df[,1:3]
df[, 1:3]
} else {
df
}

12
R/bug_drug_combinations.R
View File

@ -31,7 +31,7 @@
#' @param ... arguments passed on to \code{FUN}
#' @inheritParams rsi_df
#' @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 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.
@ -46,7 +46,7 @@
#' \donttest{
#' x <- bug_drug_combinations(example_isolates)
#' x
#' format(x)
#' format(x, translate_ab = "name (atc)")
#'
#' # Use FUN to change to transformation of microorganism codes
#' x <- bug_drug_combinations(example_isolates,
@ -76,7 +76,9 @@ bug_drug_combinations <- function(x,
x <- x %>%
as.data.frame(stringsAsFactors = FALSE) %>%
mutate(mo = x %>% pull(col_mo) %>% FUN(...)) %>%
mutate(mo = x %>%
pull(col_mo) %>%
FUN(...)) %>%
group_by(mo) %>%
select_if(is.rsi) %>%
gather("ab", "value", -mo) %>%
@ -112,7 +114,7 @@ format.bug_drug_combinations <- function(x,
if (remove_intrinsic_resistant == TRUE) {
x <- x %>% filter(R != total)
}
if (combine_IR == FALSE | combine_SI == TRUE) {
if (combine_SI == TRUE | combine_IR == FALSE) {
x$isolates <- x$R
} else {
x$isolates <- x$R + x$I
@ -121,7 +123,7 @@ format.bug_drug_combinations <- function(x,
give_ab_name <- function(ab, format, language) {
format <- tolower(format)
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("cid", ab_cid(ab[i]), ab_txt[i])
ab_txt[i] <- gsub("group", ab_group(ab[i], language = language), ab_txt[i])

2
R/count.R
View File

@ -154,7 +154,7 @@ count_all <- function(..., only_all_tested = FALSE) {
#' @rdname count
#' @export
n_rsi<- count_all
n_rsi <- count_all
#' @rdname count
#' @export

4
R/data.R
View File

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

10
R/disk.R
View File

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

172
R/eucast_rules.R
View File

@ -233,8 +233,15 @@ eucast_rules <- function(x,
warned <- FALSE
txt_error <- function() { cat("", bgRed(white(" ERROR ")), "\n\n") }
txt_warning <- function() { if (warned == FALSE) { cat("", bgYellow(black(" WARNING "))) }; warned <<- TRUE }
txt_error <- function() {
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) {
if (warned == FALSE) {
if (no_added + no_changed == 0) {
@ -337,69 +344,69 @@ eucast_rules <- function(x,
verbose = verbose,
...)
AMC <- cols_ab['AMC']
AMK <- cols_ab['AMK']
AMP <- cols_ab['AMP']
AMX <- cols_ab['AMX']
ATM <- cols_ab['ATM']
AZL <- cols_ab['AZL']
AZM <- cols_ab['AZM']
CAZ <- cols_ab['CAZ']
CED <- cols_ab['CED']
CHL <- cols_ab['CHL']
CIP <- cols_ab['CIP']
CLI <- cols_ab['CLI']
CLR <- cols_ab['CLR']
COL <- cols_ab['COL']
CRO <- cols_ab['CRO']
CTX <- cols_ab['CTX']
CXM <- cols_ab['CXM']
CZO <- cols_ab['CZO']
DAP <- cols_ab['DAP']
DOX <- cols_ab['DOX']
ERY <- cols_ab['ERY']
ETP <- cols_ab['ETP']
FEP <- cols_ab['FEP']
FLC <- cols_ab['FLC']
FOS <- cols_ab['FOS']
FOX <- cols_ab['FOX']
FUS <- cols_ab['FUS']
GEN <- cols_ab['GEN']
IPM <- cols_ab['IPM']
KAN <- cols_ab['KAN']
LIN <- cols_ab['LIN']
LNZ <- cols_ab['LNZ']
LVX <- cols_ab['LVX']
MEM <- cols_ab['MEM']
MEZ <- cols_ab['MEZ']
MFX <- cols_ab['MFX']
MNO <- cols_ab['MNO']
NAL <- cols_ab['NAL']
NEO <- cols_ab['NEO']
NET <- cols_ab['NET']
NIT <- cols_ab['NIT']
NOR <- cols_ab['NOR']
NOV <- cols_ab['NOV']
OFX <- cols_ab['OFX']
OXA <- cols_ab['OXA']
PEN <- cols_ab['PEN']
PIP <- cols_ab['PIP']
PLB <- cols_ab['PLB']
PRI <- cols_ab['PRI']
QDA <- cols_ab['QDA']
RID <- cols_ab['RID']
RIF <- cols_ab['RIF']
RXT <- cols_ab['RXT']
SIS <- cols_ab['SIS']
SXT <- cols_ab['SXT']
TCY <- cols_ab['TCY']
TEC <- cols_ab['TEC']
TGC <- cols_ab['TGC']
TIC <- cols_ab['TIC']
TMP <- cols_ab['TMP']
TOB <- cols_ab['TOB']
TZP <- cols_ab['TZP']
VAN <- cols_ab['VAN']
AMC <- cols_ab["AMC"]
AMK <- cols_ab["AMK"]
AMP <- cols_ab["AMP"]
AMX <- cols_ab["AMX"]
ATM <- cols_ab["ATM"]
AZL <- cols_ab["AZL"]
AZM <- cols_ab["AZM"]
CAZ <- cols_ab["CAZ"]
CED <- cols_ab["CED"]
CHL <- cols_ab["CHL"]
CIP <- cols_ab["CIP"]
CLI <- cols_ab["CLI"]
CLR <- cols_ab["CLR"]
COL <- cols_ab["COL"]
CRO <- cols_ab["CRO"]
CTX <- cols_ab["CTX"]
CXM <- cols_ab["CXM"]
CZO <- cols_ab["CZO"]
DAP <- cols_ab["DAP"]
DOX <- cols_ab["DOX"]
ERY <- cols_ab["ERY"]
ETP <- cols_ab["ETP"]
FEP <- cols_ab["FEP"]
FLC <- cols_ab["FLC"]
FOS <- cols_ab["FOS"]
FOX <- cols_ab["FOX"]
FUS <- cols_ab["FUS"]
GEN <- cols_ab["GEN"]
IPM <- cols_ab["IPM"]
KAN <- cols_ab["KAN"]
LIN <- cols_ab["LIN"]
LNZ <- cols_ab["LNZ"]
LVX <- cols_ab["LVX"]
MEM <- cols_ab["MEM"]
MEZ <- cols_ab["MEZ"]
MFX <- cols_ab["MFX"]
MNO <- cols_ab["MNO"]
NAL <- cols_ab["NAL"]
NEO <- cols_ab["NEO"]
NET <- cols_ab["NET"]
NIT <- cols_ab["NIT"]
NOR <- cols_ab["NOR"]
NOV <- cols_ab["NOV"]
OFX <- cols_ab["OFX"]
OXA <- cols_ab["OXA"]
PEN <- cols_ab["PEN"]
PIP <- cols_ab["PIP"]
PLB <- cols_ab["PLB"]
PRI <- cols_ab["PRI"]
QDA <- cols_ab["QDA"]
RID <- cols_ab["RID"]
RIF <- cols_ab["RIF"]
RXT <- cols_ab["RXT"]
SIS <- cols_ab["SIS"]
SXT <- cols_ab["SXT"]
TCY <- cols_ab["TCY"]
TEC <- cols_ab["TEC"]
TGC <- cols_ab["TGC"]
TIC <- cols_ab["TIC"]
TMP <- cols_ab["TMP"]
TOB <- cols_ab["TOB"]
TZP <- cols_ab["TZP"]
VAN <- cols_ab["VAN"]
ab_missing <- function(ab) {
all(ab %in% c(NULL, NA))
@ -425,11 +432,11 @@ eucast_rules <- function(x,
# insert into original table
x_original[rows, cols] <<- to,
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 <<- x %>% mutate_at(vars(cols), ~factor(x = as.character(.), levels = c(to, levels(.))))
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()
warned <<- FALSE
} else {
@ -442,8 +449,8 @@ eucast_rules <- function(x,
txt_error()
stop(paste0("In row(s) ", paste(rows[1:min(length(rows), 10)], collapse = ","),
ifelse(length(rows) > 10, "...", ""),
' while writing value "', to,
'" to column(s) `', paste(cols, collapse = "`, `"),
" while writing value '", to,
"' to column(s) `", paste(cols, collapse = "`, `"),
"`:\n", e$message),
call. = FALSE)
}
@ -453,17 +460,17 @@ eucast_rules <- function(x,
x[rows, cols] <<- x_original[rows, cols],
error = function(e) {
stop(paste0("In row(s) ", paste(rows[1:min(length(rows), 10)], collapse = ","),
'... while writing value "', to,
'" to column(s) `', paste(cols, collapse = "`, `"),
"... while writing value '", to,
"' to column(s) `", paste(cols, collapse = "`, `"),
"`:\n", e$message), call. = FALSE)
}
)
# before_df might not be a data.frame, but a tibble or data.table instead
old <- as.data.frame(before_df, stringsAsFactors = FALSE)[rows,]
old <- as.data.frame(before_df, stringsAsFactors = FALSE)[rows, ]
track_changes <- list(added = 0,
changed = 0)
for (i in 1:length(cols)) {
for (i in seq_len(length(cols))) {
verbose_new <- data.frame(row = rows,
col = cols[i],
mo_fullname = x[rows, "fullname"],
@ -530,6 +537,7 @@ eucast_rules <- function(x,
AMP <- AMX
}
# nolint start
# antibiotic classes
aminoglycosides <- c(TOB, GEN, KAN, NEO, NET, SIS)
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)
all_betalactams <- c(aminopenicillins, cephalosporins, carbapenems, ureidopenicillins, AMC, OXA, FLC, PEN)
fluoroquinolones <- c(OFX, CIP, NOR, LVX, MFX)
# nolint end
# Help function to get available antibiotic column names ------------------
get_antibiotic_columns <- function(x, df) {
x <- trimws(unlist(strsplit(x, ",", fixed = TRUE)))
y <- character(0)
for (i in 1:length(x)) {
for (i in seq_len(length(x))) {
if (is.function(get(x[i]))) {
stop("Column ", x[i], " is also a function. Please create an issue on github.com/msberends/AMR/issues.")
}
@ -562,7 +571,7 @@ eucast_rules <- function(x,
strsplit(",") %>%
unlist() %>%
trimws() %>%
sapply(function(x) if(x %in% AMR::antibiotics$ab) ab_name(x, language = NULL, tolower = TRUE) else x) %>%
sapply(function(x) if (x %in% AMR::antibiotics$ab) ab_name(x, language = NULL, tolower = TRUE) else x) %>%
sort() %>%
paste(collapse = ", ")
}
@ -598,14 +607,13 @@ eucast_rules <- function(x,
eucast_rules_df <- eucast_rules_file # internal data file
no_added <- 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_current <- eucast_rules_df[i, "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_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])) {
rule_text <- paste0("always report as '", eucast_rules_df[i, 7], "': ", get_antibiotic_names(eucast_rules_df[i, 6]))
} else {
@ -620,7 +628,6 @@ eucast_rules <- function(x,
}
if (i == nrow(eucast_rules_df)) {
rule_next <- ""
rule_group_next <- ""
}
# 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") {
mo_value <- paste0("^", eucast_rules_df[i, 3], "$")
} else if (like_is_one_of == "one_of") {
# "Clostridium, Actinomyces, ..." -> "^(Clostridium|Actinomyces|...)$"
# so 'Clostridium, Actinomyces, ...' will turn into '^(Clostridium|Actinomyces|...)$'
mo_value <- paste0("^(",
paste(trimws(unlist(strsplit(eucast_rules_df[i, 3], ",", fixed = TRUE))),
collapse = "|"),
@ -774,10 +781,10 @@ eucast_rules <- function(x,
arrange(row, rule_group, rule_name, col)
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)),
'out of', formatnr(nrow(x_original)),
'rows, making a total of', formatnr(nrow(verbose_info)), 'edits\n')))
"out of", formatnr(nrow(x_original)),
"rows, making a total of", formatnr(nrow(verbose_info)), "edits\n")))
n_added <- 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
}
}

154
R/first_isolate.R
View File

@ -124,39 +124,11 @@
#' # set key antibiotics to a new variable
#' x$keyab <- key_antibiotics(x)
#'
#' x$first_isolate <-
#' first_isolate(x)
#' x$first_isolate <- first_isolate(x)
#'
#' x$first_isolate_weighed <-
#' first_isolate(x,
#' col_keyantibiotics = 'keyab')
#' x$first_isolate_weighed <- first_isolate(x, col_keyantibiotics = 'keyab')
#'
#' x$first_blood_isolate <-
#' 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')
#' x$first_blood_isolate <- first_isolate(x, specimen_group = "Blood")
#' }
first_isolate <- function(x,
col_date = NULL,
@ -185,11 +157,11 @@ first_isolate <- function(x,
if (length(dots) != 0) {
# backwards compatibility with old parameters
dots.names <- dots %>% names()
if ('filter_specimen' %in% dots.names) {
specimen_group <- dots[which(dots.names == 'filter_specimen')]
if ("filter_specimen" %in% dots.names) {
specimen_group <- dots[which(dots.names == "filter_specimen")]
}
if ('tbl' %in% dots.names) {
x <- dots[which(dots.names == 'tbl')]
if ("tbl" %in% dots.names) {
x <- dots[which(dots.names == "tbl")]
}
}
@ -216,11 +188,11 @@ first_isolate <- function(x,
# -- 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
x <- x %>% mutate(patient_id = paste(`First name`, `Last name`, Sex))
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 {
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_columns_existance <- function(column, tblname = x) {
if (NROW(tblname) <= 1 | NCOL(tblname) <= 1) {
stop('Please check tbl for existance.')
stop("Please check tbl for existance.")
}
if (!is.null(column)) {
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
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_genus_species = paste(mo_genus(newvar_mo), mo_species(newvar_mo)),
newvar_date = x %>% pull(col_date),
@ -278,7 +250,7 @@ first_isolate <- function(x,
}
# remove testcodes
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)) {
@ -296,7 +268,7 @@ first_isolate <- function(x,
if (!is.null(specimen_group)) {
check_columns_existance(col_specimen, x)
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)) {
@ -304,7 +276,7 @@ first_isolate <- function(x,
}
if (is.null(testcodes_exclude)) {
testcodes_exclude <- ''
testcodes_exclude <- ""
}
# arrange data to the right sorting
@ -312,7 +284,7 @@ first_isolate <- function(x,
# not filtering on specimen
if (icu_exclude == FALSE) {
if (info == TRUE & !is.null(col_icu)) {
cat('[Criterion] Included isolates from ICU.\n')
message(blue("[Criterion] Included isolates from ICU"))
}
x <- x %>%
arrange(newvar_patient_id,
@ -322,7 +294,7 @@ first_isolate <- function(x,
row.end <- nrow(x)
} else {
if (info == TRUE) {
cat('[Criterion] Excluded isolates from ICU.\n')
message(blue("[Criterion] Excluded isolates from ICU"))
}
x <- x %>%
arrange_at(c(col_icu,
@ -342,7 +314,7 @@ first_isolate <- function(x,
# filtering on specimen and only analyse these row to save time
if (icu_exclude == FALSE) {
if (info == TRUE & !is.null(col_icu)) {
cat('[Criterion] Included isolates from ICU.\n')
message(blue("[Criterion] Included isolates from ICU.\n"))
}
x <- x %>%
arrange_at(c(col_specimen,
@ -357,7 +329,7 @@ first_isolate <- function(x,
)
} else {
if (info == TRUE) {
cat('[Criterion] Excluded isolates from ICU.\n')
message(blue("[Criterion] Excluded isolates from ICU"))
}
x <- x %>%
arrange_at(c(col_icu,
@ -366,12 +338,14 @@ first_isolate <- function(x,
"newvar_genus_species",
"newvar_date"))
suppressWarnings(
row.start <- which(x %>% pull(col_specimen) == specimen_group
& x %>% pull(col_icu) == FALSE) %>% min(na.rm = TRUE)
row.start <- min(which(x %>% pull(col_specimen) == specimen_group
& x %>% pull(col_icu) == FALSE),
na.rm = TRUE)
)
suppressWarnings(
row.end <- which(x %>% pull(col_specimen) == specimen_group
& x %>% pull(col_icu) == FALSE) %>% max(na.rm = TRUE)
row.end <- max(which(x %>% pull(col_specimen) == specimen_group &
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
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
# x %>%
# filter(
# row_number() %>% between(row.start,
# row.end),
# newvar_genus != "",
# newvar_species != "") %>%
# nrow()
# )
scope.size <- row.end - row.start + 1
identify_new_year = function(x, episode_days) {
identify_new_year <- function(x, episode_days) {
# I asked on StackOverflow:
# https://stackoverflow.com/questions/42122245/filter-one-row-every-year
if (length(x) == 1) {
@ -434,20 +398,18 @@ first_isolate <- function(x,
episode_days = episode_days)) %>%
ungroup()
weighted.notice <- ''
weighted.notice <- ""
if (!is.null(col_keyantibiotics)) {
weighted.notice <- 'weighted '
weighted.notice <- "weighted "
if (info == TRUE) {
if (type == 'keyantibiotics') {
cat('[Criterion] Inclusion based on key antibiotics, ')
if (ignore_I == FALSE) {
cat('not ')
}
cat('ignoring I.\n')
if (type == "keyantibiotics") {
message(blue(paste0("[Criterion] Inclusion based on key antibiotics, ",
ifelse(ignore_I == FALSE, "not ", ""),
"ignoring I")))
}
if (type == 'points') {
cat(paste0('[Criterion] Inclusion based on key antibiotics, using points threshold of '
, points_threshold, '.\n'))
if (type == "points") {
message(blue(paste0("[Criterion] Inclusion based on key antibiotics, using points threshold of "
, points_threshold)))
}
}
type_param <- type
@ -473,24 +435,24 @@ first_isolate <- function(x,
# no key antibiotics
all_first <- all_first %>%
mutate(
real_first_isolate =
if_else(
newvar_row_index_sorted %>% between(row.start, row.end)
& newvar_genus_species != ""
& (other_pat_or_mo | more_than_episode_ago),
TRUE,
FALSE))
real_first_isolate =
if_else(
newvar_row_index_sorted %>% between(row.start, row.end)
& newvar_genus_species != ""
& (other_pat_or_mo | more_than_episode_ago),
TRUE,
FALSE))
}
# 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
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) {
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")
@ -498,26 +460,20 @@ first_isolate <- function(x,
# handle empty microorganisms
if (any(all_first$newvar_mo == "UNKNOWN", na.rm = TRUE) & info == TRUE) {
if (include_unknown == TRUE) {
message(blue(paste0("NOTE: Included ", 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), '`).')))
} 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), '`).')))
}
message(blue(paste0("NOTE: ", ifelse(include_unknown == TRUE, "Included ", "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
if (any(is.na(all_first$newvar_mo)) & info == TRUE) {
message(blue(paste0("NOTE: Excluded ", format(sum(is.na(all_first$newvar_mo)),
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
all_first <- all_first %>%
@ -580,5 +536,5 @@ filter_first_weighted_isolate <- function(x,
col_mo = col_mo,
col_keyantibiotics = "keyab",
...))
x[which(tbl_keyab$firsts == TRUE),]
x[which(tbl_keyab$firsts == TRUE), ]
}

73
R/g.test.R
View File

@ -107,10 +107,10 @@
#' # Meaning: there are significantly more left-billed birds.
#'
g.test <- function(x,
y = NULL,
# correct = TRUE,
p = rep(1/length(x), length(x)),
rescale.p = FALSE) {
y = NULL,
# correct = TRUE,
p = rep(1 / length(x), length(x)),
rescale.p = FALSE) {
DNAME <- deparse(substitute(x))
if (is.data.frame(x))
x <- as.matrix(x)
@ -144,11 +144,8 @@ g.test <- function(x,
stop("all entries of 'x' must be nonnegative and finite")
if ((n <- sum(x)) == 0)
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)) {
METHOD <- "G-test of independence"
nr <- as.integer(nrow(x))
@ -157,34 +154,18 @@ g.test <- function(x,
stop("invalid nrow(x) or ncol(x)", domain = NA)
# add fisher.test suggestion
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)
sc <- colSums(x)
E <- outer(sr, sc, "*")/n
v <- function(r, c, n) c * r * (n - r) * (n - c)/n^3
E <- outer(sr, sc, "*") / n
v <- function(r, c, n) c * r * (n - r) * (n - c) / n ^ 3
V <- outer(sr, sc, v, n)
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
PARAMETER <- (nr - 1L) * (nc - 1L)
PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE)
# }
STATISTIC <- 2 * sum(x * log(x / E)) # sum((abs(x - E) - YATES)^2/E) for chisq.test
PARAMETER <- (nr - 1L) * (nc - 1L)
PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE)
}
else {
if (length(dim(x)) > 2L)
@ -197,7 +178,7 @@ g.test <- function(x,
stop("probabilities must be non-negative.")
if (abs(sum(p) - 1) > sqrt(.Machine$double.eps)) {
if (rescale.p)
p <- p/sum(p)
p <- p / sum(p)
else stop("probabilities must sum to 1.")
}
METHOD <- "G-test of goodness-of-fit (likelihood ratio test)"
@ -205,22 +186,10 @@ g.test <- function(x,
V <- n * p * (1 - p)
STATISTIC <- 2 * sum(x * log(x / E)) # sum((x - E)^2/E) for chisq.test
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
PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE)
# }
PARAMETER <- length(x) - 1
PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE)
}
names(STATISTIC) <- "X-squared"
names(PARAMETER) <- "df"
@ -229,6 +198,6 @@ g.test <- function(x,
structure(list(statistic = STATISTIC, parameter = PARAMETER,
p.value = PVAL, method = METHOD, data.name = DNAME,
observed = x, expected = E, residuals = (x - E)/sqrt(E),
stdres = (x - E)/sqrt(V)), class = "htest")
observed = x, expected = E, residuals = (x - E) / sqrt(E),
stdres = (x - E) / sqrt(V)), class = "htest")
}

12
R/ggplot_rsi.R
View File

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

15
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"))))) {
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 {
# sort colnames on length - longest first
cols <- colnames(x[, x %>% colnames() %>% nchar() %>% order() %>% rev()])
@ -128,7 +125,7 @@ get_column_abx <- function(x,
# only check columns that are a valid AB code, ATC code, name, abbreviation or synonym,
# or already have the rsi class (as.rsi)
# and that have no more than 50% invalid values
vectr_antibiotics <- unique(toupper(unlist(AMR::antibiotics[,c("ab", "atc", "name", "abbreviations", "synonyms")])))
vectr_antibiotics <- unique(toupper(unlist(AMR::antibiotics[, c("ab", "atc", "name", "abbreviations", "synonyms")])))
vectr_antibiotics <- vectr_antibiotics[!is.na(vectr_antibiotics) & nchar(vectr_antibiotics) >= 3]
x_columns <- sapply(colnames(x), function(col, df = x_bak) {
if (toupper(col) %in% vectr_antibiotics |
@ -144,12 +141,12 @@ get_column_abx <- function(x,
df_trans <- data.frame(colnames = colnames(x),
abcode = suppressWarnings(as.ab(colnames(x))))
df_trans <- df_trans[!is.na(df_trans$abcode),]
df_trans <- df_trans[!is.na(df_trans$abcode), ]
x <- as.character(df_trans$colnames)
names(x) <- df_trans$abcode
# 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(...)
if (length(dots) > 0) {
newnames <- suppressWarnings(as.ab(names(dots)))
@ -173,12 +170,12 @@ get_column_abx <- function(x,
x <- x[!names(x) %in% names(duplicates)]
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],
"` (", ab_name(names(x)[i], tolower = TRUE), ").")))
}
} 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])]),
"` (", ab_name(names(x[names(which(x == duplicates))[i]]), tolower = TRUE),
"), 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, ")")) %>%
arrange(missing_names) %>%
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 = ", ")))
}
}

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, ...)
)
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
}
@ -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, ...)
)
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
}
@ -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, ...)
)
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
}
@ -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, ...)
)
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
}

30
R/key_antibiotics.R
View File

@ -118,7 +118,7 @@ key_antibiotics <- function(x,
names(col.list) <- col.list
col.list.bak <- col.list
# 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]))) {
col.list[i] <- NA
} 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 (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(),
'.\nTHIS MAY STRONGLY INFLUENCE THE OUTCOME.',
".\nTHIS MAY STRONGLY INFLUENCE THE OUTCOME.",
immediate. = TRUE,
call. = FALSE)
}
@ -164,7 +164,7 @@ key_antibiotics <- function(x,
universal <- c(universal_1, universal_2, universal_3,
universal_4, universal_5, universal_6)
gram_positive = c(universal,
gram_positive <- c(universal,
GramPos_1, GramPos_2, GramPos_3,
GramPos_4, GramPos_5, GramPos_6)
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)
}
gram_negative = c(universal,
gram_negative <- c(universal,
GramNeg_1, GramNeg_2, GramNeg_3,
GramNeg_4, GramNeg_5, GramNeg_6)
gram_negative <- gram_negative[!is.null(gram_negative)]
@ -211,8 +211,8 @@ key_antibiotics <- function(x,
# format
key_abs <- x %>%
pull(key_ab) %>%
gsub('(NA|NULL)', '.', .) %>%
gsub('[^SIR]', '.', ., ignore.case = TRUE) %>%
gsub("(NA|NULL)", ".", .) %>%
gsub("[^SIR]", ".", ., ignore.case = TRUE) %>%
toupper()
if (n_distinct(key_abs) == 1) {
@ -239,7 +239,7 @@ key_antibiotics_equal <- function(y,
type <- type[1]
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
@ -251,17 +251,17 @@ key_antibiotics_equal <- function(y,
p <- dplyr::progress_estimated(length(x))
}
for (i in 1:length(x)) {
for (i in seq_len(length(x))) {
if (info_needed == TRUE) {
p$tick()$print()
}
if (is.na(x[i])) {
x[i] <- ''
x[i] <- ""
}
if (is.na(y[i])) {
y[i] <- ''
y[i] <- ""
}
if (x[i] == y[i]) {
@ -277,7 +277,7 @@ key_antibiotics_equal <- function(y,
x_split <- strsplit(x[i], "")[[1]]
y_split <- strsplit(y[i], "")[[1]]
if (type == 'keyantibiotics') {
if (type == "keyantibiotics") {
if (ignore_I == TRUE) {
x_split[x_split == "I"] <- "."
@ -289,7 +289,7 @@ key_antibiotics_equal <- function(y,
result[i] <- all(x_split == y_split)
} else if (type == 'points') {
} else if (type == "points") {
# count points for every single character:
# - no change is 0 points
# - I <-> S|R is 0.5 point
@ -303,12 +303,12 @@ key_antibiotics_equal <- function(y,
result[i] <- points >= points_threshold
} 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) {
cat('\n')
cat("\n")
}
result
}

6
R/kurtosis.R
View File

@ -37,7 +37,7 @@ kurtosis <- function(x, na.rm = FALSE) {
#' @exportMethod kurtosis.default
#' @rdname kurtosis
#' @export
kurtosis.default <- function (x, na.rm = FALSE) {
kurtosis.default <- function(x, na.rm = FALSE) {
x <- as.vector(x)
if (na.rm == TRUE) {
x <- x[!is.na(x)]
@ -50,13 +50,13 @@ kurtosis.default <- function (x, na.rm = FALSE) {
#' @exportMethod kurtosis.matrix
#' @rdname kurtosis
#' @export
kurtosis.matrix <- function (x, na.rm = FALSE) {
kurtosis.matrix <- function(x, na.rm = FALSE) {
base::apply(x, 2, kurtosis.default, na.rm = na.rm)
}
#' @exportMethod kurtosis.data.frame
#' @rdname kurtosis
#' @export
kurtosis.data.frame <- function (x, na.rm = FALSE) {
kurtosis.data.frame <- function(x, na.rm = FALSE) {
base::sapply(x, kurtosis.default, na.rm = na.rm)
}

2
R/like.R
View File

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

4
R/mdro.R
View File

@ -272,7 +272,7 @@ mdro <- function(x,
row_filter <- which(x[, cols] == "R")
} else if (any_all == "all") {
row_filter <- x %>%
mutate(index = 1:nrow(.)) %>%
mutate(index = seq_len(nrow(.))) %>%
filter_at(vars(cols), all_vars(. == "R")) %>%
pull((index))
}
@ -452,7 +452,7 @@ mdro <- function(x,
& !ab_missing(GEN) & !ab_missing(TOB)
& !ab_missing(CIP)
& !ab_missing(CAZ)
& !ab_missing(TZP) ) {
& !ab_missing(TZP)) {
x$psae <- 0
x[which(x[, MEM] == "R" | x[, IPM] == "R"), "psae"] <- 1 + x[which(x[, MEM] == "R" | x[, IPM] == "R"), "psae"]
x[which(x[, GEN] == "R" & x[, TOB] == "R"), "psae"] <- 1 + x[which(x[, GEN] == "R" & x[, TOB] == "R"), "psae"]

62
R/mic.R
View File

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

4
R/misc.R
View File

@ -67,7 +67,7 @@ search_type_in_df <- function(x, type) {
call. = FALSE)
}
} else {
for (i in 1:ncol(x)) {
for (i in seq_len(ncol(x))) {
if (any(class(x %>% pull(i)) %in% c("Date", "POSIXct"))) {
found <- colnames(x)[i]
break
@ -141,7 +141,7 @@ getdecimalplaces <- function(x, minimum = 0, maximum = 3) {
if (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),
function(y) ifelse(length(y) == 2, nchar(y[2]), 0))), na.rm = TRUE)
max(min(max_places,

194
R/mo.R
View File

@ -197,7 +197,7 @@ as.mo <- function(x, Becker = FALSE, Lancefield = FALSE, allow_uncertain = TRUE,
& isFALSE(Becker)
& isFALSE(Lancefield)
& !is.null(reference_df)
& all(x %in% reference_df[,1][[1]])) {
& all(x %in% reference_df[, 1][[1]])) {
# has valid own reference_df
# (data.table not faster here)
@ -308,13 +308,13 @@ exec_as.mo <- function(x,
# support tidyverse selection like: df %>% select(colA, colB)
# paste these columns together
x_vector <- vector("character", NROW(x))
for (i in 1:NROW(x)) {
x_vector[i] <- paste(pull(x[i,], 1), pull(x[i,], 2), sep = " ")
for (i in seq_len(NROW(x))) {
x_vector[i] <- paste(pull(x[i, ], 1), pull(x[i, ], 2), sep = " ")
}
x <- x_vector
} else {
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
@ -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
# this will allow "Pasteurella damatis" to be correctly read as "Pasteurella dagmatis".
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 <- strip_whitespace(x, dyslexia_mode)
@ -558,11 +558,11 @@ exec_as.mo <- function(x,
x_withspaces <- gsub("[ .]+", ".* ", x)
x <- gsub("[ .]+", ".*", x)
# add start en stop regex
x <- paste0('^', x, '$')
x <- paste0("^", x, "$")
x_withspaces_start_only <- paste0('^', x_withspaces)
x_withspaces_end_only <- paste0(x_withspaces, '$')
x_withspaces_start_end <- paste0('^', x_withspaces, '$')
x_withspaces_start_only <- paste0("^", x_withspaces)
x_withspaces_end_only <- paste0(x_withspaces, "$")
x_withspaces_start_end <- paste0("^", x_withspaces, "$")
if (isTRUE(debug)) {
cat(paste0('x "', x, '"\n'))
@ -579,7 +579,7 @@ exec_as.mo <- function(x,
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()
@ -681,23 +681,6 @@ exec_as.mo <- function(x,
# check for very small input, but ignore the O antigens of E. coli
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)") {
# 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
x[i] <- microorganismsDT[mo == "UNKNOWN", ..property][[1]]
if (initial_search == TRUE) {
@ -715,17 +698,17 @@ exec_as.mo <- function(x,
# translate known trivial abbreviations to genus + species ----
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[i] <- microorganismsDT[mo == 'B_STPHY_AURS', ..property][[1]][1L]
x[i] <- microorganismsDT[mo == "B_STPHY_AURS", ..property][[1]][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
}
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[i] <- microorganismsDT[mo == 'B_STPHY_EPDR', ..property][[1]][1L]
x[i] <- microorganismsDT[mo == "B_STPHY_EPDR", ..property][[1]][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)
}
@ -733,8 +716,8 @@ exec_as.mo <- function(x,
}
if (toupper(x_backup_without_spp[i]) == "VRE"
| x_backup_without_spp[i] %like_case% " vre "
| x_backup_without_spp[i] %like_case% '(enterococci|enterokok|enterococo)[a-z]*?$') {
x[i] <- microorganismsDT[mo == 'B_ENTRC', ..property][[1]][1L]
| x_backup_without_spp[i] %like_case% "(enterococci|enterokok|enterococo)[a-z]*?$") {
x[i] <- microorganismsDT[mo == "B_ENTRC", ..property][[1]][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)
}
@ -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")
# 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[i] <- microorganismsDT[mo == 'B_ESCHR_COLI', ..property][[1]][1L]
x[i] <- microorganismsDT[mo == "B_ESCHR_COLI", ..property][[1]][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
}
if (toupper(x_backup_without_spp[i]) == 'MRPA'
if (toupper(x_backup_without_spp[i]) == "MRPA"
| x_backup_without_spp[i] %like_case% " mrpa ") {
# 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) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
next
}
if (toupper(x_backup_without_spp[i]) == 'CRSM') {
if (toupper(x_backup_without_spp[i]) == "CRSM") {
# 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) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
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) ") {
# 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) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
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)
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) {
@ -795,7 +778,7 @@ exec_as.mo <- function(x,
}
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"
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) {
@ -803,7 +786,7 @@ exec_as.mo <- function(x,
}
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"
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) {
@ -811,79 +794,79 @@ exec_as.mo <- function(x,
}
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
x[i] <- microorganismsDT[mo == 'B_STRPT_HAEM', ..property][[1]][1L]
x[i] <- microorganismsDT[mo == "B_STRPT_HAEM", ..property][[1]][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
}
# CoNS/CoPS in different languages (support for German, Dutch, Spanish, Portuguese) ----
if (x_backup_without_spp[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]?$') {
if (x_backup_without_spp[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]?$") {
# 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) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
next
}
if (x_backup_without_spp[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]?$') {
if (x_backup_without_spp[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]?$") {
# 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) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
next
}
# streptococcal groups: milleri and viridans
if (x_trimmed[i] %like_case% 'strepto.* milleri'
| x_backup_without_spp[i] %like_case% 'strepto.* milleri'
| x_backup_without_spp[i] %like_case% 'mgs[^a-z]?$') {
if (x_trimmed[i] %like_case% "strepto.* milleri"
| x_backup_without_spp[i] %like_case% "strepto.* milleri"
| x_backup_without_spp[i] %like_case% "mgs[^a-z]?$") {
# 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) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
next
}
if (x_trimmed[i] %like_case% 'strepto.* viridans'
| x_backup_without_spp[i] %like_case% 'strepto.* viridans'
| x_backup_without_spp[i] %like_case% 'vgs[^a-z]?$') {
if (x_trimmed[i] %like_case% "strepto.* viridans"
| x_backup_without_spp[i] %like_case% "strepto.* viridans"
| x_backup_without_spp[i] %like_case% "vgs[^a-z]?$") {
# 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) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
next
}
if (x_backup_without_spp[i] %like_case% 'gram[ -]?neg.*'
| x_backup_without_spp[i] %like_case% 'negatie?[vf]'
| x_trimmed[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_trimmed[i] %like_case% "gram[ -]?neg.*") {
# 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) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
next
}
if (x_backup_without_spp[i] %like_case% 'gram[ -]?pos.*'
| x_backup_without_spp[i] %like_case% 'positie?[vf]'
| x_trimmed[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_trimmed[i] %like_case% "gram[ -]?pos.*") {
# 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) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
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
x[i] <- microorganismsDT[mo == 'B_MYCBC', ..property][[1]][1L]
x[i] <- microorganismsDT[mo == "B_MYCBC", ..property][[1]][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)
}
@ -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 group") {
# 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) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
next
} 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
x[i] <- microorganismsDT[mo == 'B_SLMNL_ENTR', ..property][[1]][1L]
x[i] <- microorganismsDT[mo == "B_SLMNL_ENTR", ..property][[1]][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)
}
@ -915,7 +898,7 @@ exec_as.mo <- function(x,
# trivial names known to the field:
if ("meningococcus" %like_case% x_trimmed[i]) {
# 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) {
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]) {
# 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) {
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]) {
# 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) {
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_split <- paste0("^",
g.x_backup_without_spp %>% substr(1, x_length / 2),
'.* ',
".* ",
g.x_backup_without_spp %>% substr((x_length / 2) + 1, x_length))
found <- data_to_check[fullname_lower %like_case% x_split, ..property][[1]]
if (length(found) > 0) {
@ -1050,12 +1033,12 @@ exec_as.mo <- function(x,
# look for old taxonomic names ----
# wait until prevalence == 2 to run the old taxonomic results on both prevalence == 1 and prevalence == 2
found <- data.old_to_check[fullname_lower == tolower(a.x_backup)
| fullname_lower %like_case% d.x_withspaces_start_end,]
| fullname_lower %like_case% d.x_withspaces_start_end, ]
if (NROW(found) > 0) {
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:
# mo_ref("Chlamydia psittaci") = "Page, 1968" (with warning)
# mo_ref("Chlamydophila psittaci") = "Everett et al., 1999"
# mo_ref() of "Chlamydia psittaci" will be "Page, 1968" (with warning)
# mo_ref() of "Chlamydophila psittaci" will be "Everett et al., 1999"
if (property == "ref") {
x[i] <- found[1, ref]
} else {
@ -1067,9 +1050,7 @@ exec_as.mo <- function(x,
ref_old = found[1, ref],
ref_new = microorganismsDT[col_id == found[1, col_id_new], ref],
mo = microorganismsDT[col_id == found[1, col_id_new], mo])
# if (initial_search == TRUE) {
# set_mo_history(a.x_backup, get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
# }
# no set history on renames
return(x[i])
}
@ -1119,9 +1100,7 @@ exec_as.mo <- function(x,
format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup,
result_mo = microorganismsDT[col_id == found[1, col_id_new], mo]))
# if (initial_search == TRUE) {
# set_mo_history(a.x_backup, get_mo_code(x, property), 1, force = force_mo_history, disable = disable_mo_history)
# }
# no set history on renames
return(x)
}
@ -1243,11 +1222,11 @@ exec_as.mo <- function(x,
}
x_strip <- a.x_backup %>% strsplit(" ") %>% unlist()
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_half <- substr(lastword, 1, as.integer(nchar(lastword) / 2))
# 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 (isTRUE(debug)) {
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")
}
if (length(x_strip) > 1) {
for (i in 1:(length(x_strip) - 1)) {
x_strip_collapsed <- paste(x_strip[1:(length(x_strip) - i)], collapse = " ")
for (i in seq_len(length(x_strip) - 1)) {
x_strip_collapsed <- paste(x_strip[seq_len(length(x_strip) - i)], collapse = " ")
if (nchar(x_strip_collapsed) >= 6) {
if (isTRUE(debug)) {
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")
}
if (length(x_strip) > 1) {
for (i in 1:(length(x_strip) - 1)) {
x_strip_collapsed <- paste(x_strip[1:(length(x_strip) - i)], collapse = " ")
for (i in seq_len(length(x_strip) - 1)) {
x_strip_collapsed <- paste(x_strip[seq_len(length(x_strip) - i)], collapse = " ")
if (isTRUE(debug)) {
message("Running '", x_strip_collapsed, "'")
}
@ -1579,7 +1558,7 @@ exec_as.mo <- function(x,
" (covering ", percentage(total_failures / total_n),
") could not be coerced and ", plural[3], " considered 'unknown'")
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).")
warning(red(msg),
@ -1639,35 +1618,35 @@ exec_as.mo <- function(x,
immediate. = TRUE)
}
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% CoNS] <- microorganismsDT[mo == "B_STPHY_CONS", ..property][[1]][1L]
x[x %in% CoPS] <- microorganismsDT[mo == "B_STPHY_COPS", ..property][[1]][1L]
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 ----
if (Lancefield == TRUE | Lancefield == "all") {
# 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
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
S_groupC <- microorganismsDT %>% filter(genus == "Streptococcus",
species %in% c("equisimilis", "equi",
"zooepidemicus", "dysgalactiae")) %>%
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") {
# 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
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
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
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 ----------------------------------------------------------------
@ -1886,7 +1865,7 @@ print.mo_uncertainties <- function(x, ...) {
", 3 = ", red("very uncertain"), ")\n"))
msg <- ""
for (i in 1:nrow(x)) {
for (i in seq_len(nrow(x))) {
if (x[i, "uncertainty"] == 1) {
colour1 <- green
colour2 <- function(...) bgGreen(white(...))
@ -1929,7 +1908,7 @@ print.mo_renamed <- function(x, ...) {
if (NROW(x) == 0) {
return(invisible())
}
for (i in 1:nrow(x)) {
for (i in seq_len(nrow(x))) {
message(blue(paste0("NOTE: ",
italic(x$old_name[i]), ifelse(x$old_ref[i] %in% c("", NA), "",
paste0(" (", gsub("et al.", italic("et al."), x$old_ref[i]), ")")),
@ -1955,15 +1934,10 @@ unregex <- function(x) {
}
get_mo_code <- function(x, property) {
# don't use right now
# return(NULL)
if (property == "mo") {
unique(x)
} else {
microorganismsDT[get(property) == x, "mo"][[1]]
# which is ~2.5 times faster than:
# AMR::microorganisms[base::which(AMR::microorganisms[, property] %in% x),]$mo
}
}

8
R/mo_history.R
View File

@ -43,11 +43,11 @@ set_mo_history <- function(x, mo, uncertainty_level, force = FALSE, disable = FA
}
x <- toupper(df$x)
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
if (NROW(mo_hist[base::which(mo_hist$x == x[i] &
mo_hist$uncertainty_level >= uncertainty_level &
mo_hist$package_version == utils::packageVersion("AMR")),]) == 0) {
mo_hist$package_version == utils::packageVersion("AMR")), ]) == 0) {
# # Not using the file system:
# tryCatch(options(mo_remembered_results = rbind(mo_hist,
# data.frame(
@ -73,7 +73,9 @@ set_mo_history <- function(x, mo, uncertainty_level, force = FALSE, disable = FA
stringsAsFactors = FALSE)),
row.names = FALSE,
file = mo_history_file()),
error = function(e) { warning_new_write <- FALSE; base::invisible()})
error = function(e) {
warning_new_write <- FALSE; base::invisible()
})
}
}
}

6
R/mo_property.R
View File

@ -158,8 +158,8 @@ mo_shortname <- function(x, language = get_locale(), ...) {
shortnames <- paste0(substr(mo_genus(x.mo, language = NULL), 1, 1), ". ", replace_empty(mo_species(x.mo, language = NULL)))
# exceptions for Staphylococci
shortnames[shortnames == "S. coagulase-negative" ] <- "CoNS"
shortnames[shortnames == "S. coagulase-positive" ] <- "CoPS"
shortnames[shortnames == "S. coagulase-negative"] <- "CoNS"
shortnames[shortnames == "S. coagulase-positive"] <- "CoPS"
# exceptions for Streptococci: Streptococcus Group A -> GAS
shortnames[shortnames %like% "S. group [ABCDFGHK]"] <- paste0("G", gsub("S. group ([ABCDFGHK])", "\\1", shortnames[shortnames %like% "S. group [ABCDFGHK]"]), "S")
@ -384,7 +384,7 @@ mo_url <- function(x, open = FALSE, ...) {
#' @rdname mo_property
#' @importFrom data.table data.table as.data.table setkey
#' @export
mo_property <- function(x, property = 'fullname', language = get_locale(), ...) {
mo_property <- function(x, property = "fullname", language = get_locale(), ...) {
if (length(property) != 1L) {
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!
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) {
stop("`path` must be a character of length 1.")
@ -119,17 +119,17 @@ set_mo_source <- function(path) {
stop("File not found: ", path)
}
if (path %like% '[.]rds$') {
if (path %like% "[.]rds$") {
df <- readRDS(path)
} else if (path %like% '[.]xlsx?$') {
} else if (path %like% "[.]xlsx?$") {
# is Excel file (old or new)
if (!"readxl" %in% utils::installed.packages()) {
stop("Install the 'readxl' package first.")
}
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)
} else {
@ -196,7 +196,7 @@ get_mo_source <- function() {
# set updated source
set_mo_source(getOption("mo_source"))
}
file_location <- path.expand('~/mo_source.rds')
file_location <- path.expand("~/mo_source.rds")
readRDS(file_location)
}
}

5
R/read.4d.R
View File

@ -154,7 +154,7 @@ read.4D <- function(file,
if (info == TRUE) {
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])) {
attr(data_4D[, i], "label") <- colnames.bak[i]
}
@ -163,7 +163,7 @@ read.4D <- function(file,
if (info == TRUE) {
message("OK\nSetting query as label to data.frame... ", appendLF = FALSE)
}
qry <- readLines(con <- file(file, open="r"))[1]
qry <- readLines(con <- file(file, open = "r"))[1]
close(con)
attr(data_4D, "label") <- qry
@ -173,4 +173,3 @@ read.4D <- function(file,
data_4D
}

46
R/resistance_predict.R
View File

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

71
R/rsi.R
View File

@ -100,20 +100,17 @@ as.rsi.default <- function(x, ...) {
if (is.rsi(x)) {
x
} else if (identical(levels(x), c("S", "I", "R"))) {
structure(x, class = c('rsi', 'ordered', 'factor'))
structure(x, class = c("rsi", "ordered", "factor"))
} 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.bak <- x
na_before <- x[is.na(x) | x == ''] %>% length()
na_before <- x[is.na(x) | x == ""] %>% length()
# remove all spaces
x <- gsub(' +', '', x)
x <- gsub(" +", "", x)
# 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'
x <- gsub("([(].*[)])", "", x)
x <- gsub("(high|low)", "", x, ignore.case = TRUE)
@ -122,29 +119,29 @@ as.rsi.default <- function(x, ...) {
# set to capitals
x <- toupper(x)
# 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
x <- gsub('^S+$', 'S', x)
x <- gsub('^I+$', 'I', x)
x <- gsub('^R+$', 'R', x)
x[!x %in% c('S', 'I', 'R')] <- NA
na_after <- x[is.na(x) | x == ''] %>% length()
x <- gsub("^S+$", "S", x)
x <- gsub("^I+$", "I", x)
x <- gsub("^R+$", "R", x)
x[!x %in% c("S", "I", "R")] <- NA
na_after <- x[is.na(x) | x == ""] %>% length()
if (!isFALSE(list(...)$warn)) { # so as.rsi(..., warn = FALSE) will never throw a warning
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() %>%
sort()
list_missing <- paste0('"', list_missing , '"', collapse = ", ")
warning(na_after - na_before, ' results truncated (',
list_missing <- paste0('"', list_missing, '"', collapse = ", ")
warning(na_after - na_before, " results truncated (",
round(((na_after - na_before) / length(x)) * 100),
'%) that were invalid antimicrobial interpretations: ',
"%) that were invalid antimicrobial interpretations: ",
list_missing, call. = FALSE)
}
}
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_lancefield <- paste(mo_lancefield, ab)
for (i in 1:length(x)) {
for (i in seq_len(length(x))) {
get_record <- trans %>%
filter(lookup %in% c(lookup_mo[i],
lookup_genus[i],
@ -236,7 +233,7 @@ exec_as.rsi <- function(method, x, mo, ab, guideline) {
lookup_lancefield[i])) %>%
# be as specific as possible (i.e. prefer species over genus):
arrange(desc(nchar(mo))) %>%
.[1L,]
.[1L, ]
if (NROW(get_record) > 0) {
if (method == "mic") {
@ -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),
class = c('rsi', 'ordered', 'factor'))
class = c("rsi", "ordered", "factor"))
}
#' @rdname as.rsi
@ -280,7 +277,7 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", ...) {
# transform all MICs
ab_cols <- colnames(x)[sapply(x, is.mic)]
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])))) {
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
@ -297,7 +294,7 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", ...) {
# transform all disks
ab_cols <- colnames(x)[sapply(x, is.disk)]
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])))) {
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
@ -319,14 +316,14 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", ...) {
#' @export
is.rsi <- function(x) {
identical(class(x),
c('rsi', 'ordered', 'factor'))
c("rsi", "ordered", "factor"))
}
#' @rdname as.rsi
#' @export
is.rsi.eligible <- function(x, threshold = 0.05) {
if (NCOL(x) > 1) {
stop('`x` must be a one-dimensional vector.')
stop("`x` must be a one-dimensional vector.")
}
if (any(c("logical",
"numeric",
@ -363,9 +360,9 @@ print.rsi <- function(x, ...) {
#' @exportMethod droplevels.rsi
#' @export
#' @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, ...)
class(x) <- c('rsi', 'ordered', 'factor')
class(x) <- c("rsi", "ordered", "factor")
x
}
@ -375,7 +372,7 @@ droplevels.rsi <- function(x, exclude = if(anyNA(levels(x))) NULL else NA, ...)
summary.rsi <- function(object, ...) {
x <- object
c(
"Class" = 'rsi',
"Class" = "rsi",
"<NA>" = sum(is.na(x)),
"Sum S" = sum(x == "S", 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,
lwd = 2,
ylim = NULL,
ylab = 'Percentage',
xlab = 'Antimicrobial Interpretation',
main = paste('Susceptibility Analysis of', deparse(substitute(x))),
ylab = "Percentage",
xlab = "Antimicrobial Interpretation",
main = paste("Susceptibility Analysis of", deparse(substitute(x))),
axes = FALSE,
...) {
suppressWarnings(
@ -416,7 +413,7 @@ plot.rsi <- function(x,
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)
@ -436,7 +433,7 @@ plot.rsi <- function(x,
text(x = data$x,
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
#' @noRd
barplot.rsi <- function(height,
col = c('green3', 'orange2', 'red3'),
xlab = ifelse(beside, 'Antimicrobial Interpretation', ''),
main = paste('Susceptibility Analysis of', deparse(substitute(height))),
ylab = 'Frequency',
col = c("green3", "orange2", "red3"),
xlab = ifelse(beside, "Antimicrobial Interpretation", ""),
main = paste("Susceptibility Analysis of", deparse(substitute(height))),
ylab = "Frequency",
beside = TRUE,
axes = beside,
...) {

22
R/rsi_calc.R
View File

@ -50,13 +50,13 @@ rsi_calc <- function(...,
data_vars <- dots2vars(...)
if (!is.numeric(minimum)) {
stop('`minimum` must be numeric', call. = FALSE)
stop("`minimum` must be numeric", call. = FALSE)
}
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)) {
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
@ -67,8 +67,7 @@ rsi_calc <- function(...,
ndots <- length(dots)
if ("data.frame" %in% class(dots_df)) {
# data.frame passed with other columns, like:
# example_isolates %>% portion_S(amcl, gent)
# data.frame passed with other columns, like: example_isolates %>% portion_S(amcl, gent)
dots <- as.character(dots)
dots <- dots[dots != "."]
if (length(dots) == 0 | all(dots == "df")) {
@ -79,13 +78,10 @@ rsi_calc <- function(...,
x <- dots_df[, dots]
}
} else if (ndots == 1) {
# only 1 variable passed (can also be data.frame), like:
# portion_S(example_isolates$amcl)
# example_isolates$amcl %>% portion_S()
# only 1 variable passed (can also be data.frame), like: portion_S(example_isolates$amcl) and example_isolates$amcl %>% portion_S()
x <- dots_df
} else {
# multiple variables passed without pipe, like:
# portion_S(example_isolates$amcl, example_isolates$gent)
# multiple variables passed without pipe, like: portion_S(example_isolates$amcl, example_isolates$gent)
x <- NULL
try(x <- as.data.frame(dots), silent = TRUE)
if (is.null(x)) {
@ -105,7 +101,7 @@ rsi_calc <- function(...,
if (is.data.frame(x)) {
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
if (!is.rsi(x %>% pull(i))) {
rsi_integrity_check <- c(rsi_integrity_check, x %>% pull(i) %>% as.character())
@ -129,7 +125,9 @@ rsi_calc <- function(...,
} else {
# THE NUMBER OF ISOLATES WHERE *ANY* ABx IS S/I/R
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()
denominator <- x %>% filter(!other_values_filter) %>% nrow()
}

8
R/skewness.R
View File

@ -38,25 +38,25 @@ skewness <- function(x, na.rm = FALSE) {
#' @exportMethod skewness.default
#' @rdname skewness
#' @export
skewness.default <- function (x, na.rm = FALSE) {
skewness.default <- function(x, na.rm = FALSE) {
x <- as.vector(x)
if (na.rm == TRUE) {
x <- x[!is.na(x)]
}
n <- length(x)
(base::sum((x - base::mean(x))^3) / n) / (base::sum((x - base::mean(x))^2) / n)^(3/2)
(base::sum((x - base::mean(x))^3) / n) / (base::sum((x - base::mean(x)) ^ 2) / n) ^ (3 / 2)
}
#' @exportMethod skewness.matrix
#' @rdname skewness
#' @export
skewness.matrix <- function (x, na.rm = FALSE) {
skewness.matrix <- function(x, na.rm = FALSE) {
base::apply(x, 2, skewness.default, na.rm = na.rm)
}
#' @exportMethod skewness.data.frame
#' @rdname skewness
#' @export
skewness.data.frame <- function (x, na.rm = FALSE) {
skewness.data.frame <- function(x, na.rm = FALSE) {
base::sapply(x, skewness.default, na.rm = na.rm)
}

2
R/translate.R
View File

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

35
R/zzz.R
View File

@ -42,42 +42,9 @@
value = make_trans_tbl(),
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"))
}
.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)
# }
}
# maybe add survey later: "https://www.surveymonkey.com/r/AMR_for_R"
#' @importFrom data.table as.data.table setkey
make_DT <- function() {

2
docs/404.html
View File

@ -84,7 +84,7 @@
</button>
<span class="navbar-brand">
<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>
</div>

2
docs/LICENSE-text.html
View File

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

2
docs/articles/index.html
View File

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

2
docs/authors.html
View File

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

2
docs/index.html
View File

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

44
docs/news/index.html
View File

@ -84,7 +84,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">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>
</div>
@ -231,11 +231,11 @@
</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">
<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>
<p><small>Last updated: 08-Oct-2019</small></p>
<p><small>Last updated: 11-Oct-2019</small></p>
<div id="breaking" class="section level3">
<h3 class="hasAnchor">
<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>
<ul>
<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>
<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-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-4" data-line-number="4"><span class="co">#&gt; ab mo 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-6" data-line-number="6"><span class="co">#&gt; 2 AMC E. coli 332 74 61 467</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-8" data-line-number="8"><span class="co">#&gt; 4 AMC P. aeruginosa 0 0 30 30</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-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">4</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 A. baumannii AMC 0 0 3 3</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 A. baumannii AMP 0 0 3 3</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; </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-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-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-15" data-line-number="15"><span class="co">#&gt; ab mo 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-17" data-line-number="17"><span class="co">#&gt; 2 AMC Gram-positive 873 2 272 1147</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-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-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 Gram-negative AMC 469 89 174 732</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 Gram-negative AMP 227 0 405 632</span></a>
<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>
<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>
<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>
<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>
@ -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>
<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>Cleaned the coding style of every single syntax line in this package with the help of the <code>lintr</code> package</li>
</ul>
</div>
</div>
@ -1290,7 +1292,7 @@ Using <code><a href="../reference/as.mo.html">as.mo(..., allow_uncertain = 3)</a
<div id="tocnav">
<h2>Contents</h2>
<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-0">0.7.0</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_sha: ~
articles:

4
docs/reference/bug_drug_combinations.html
View File

@ -85,7 +85,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">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>
</div>
@ -327,7 +327,7 @@
<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='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='no'>x</span> <span class='kw'>&lt;-</span> <span class='fu'>bug_drug_combinations</span>(<span class='no'>example_isolates</span>,

89
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="76x76" href="../apple-touch-icon-76x76.png" />
<link rel="apple-touch-icon" type="image/png" sizes="60x60" href="../apple-touch-icon-60x60.png" />
<!-- jquery -->
<script src="https://cdnjs.cloudflare.com/ajax/libs/jquery/3.3.1/jquery.min.js" integrity="sha256-FgpCb/KJQlLNfOu91ta32o/NMZxltwRo8QtmkMRdAu8=" crossorigin="anonymous"></script>
<!-- Bootstrap -->
<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>
<!-- 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 -->
<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 -->
<script src="https://cdnjs.cloudflare.com/ajax/libs/sticky-kit/1.1.3/sticky-kit.min.js" integrity="sha256-c4Rlo1ZozqTPE2RLuvbusY3+SU1pQaJC0TjuhygMipw=" crossorigin="anonymous"></script>
<!-- headroom.js -->
<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 -->
<link href="../pkgdown.css" rel="stylesheet">
@ -45,15 +49,15 @@
<link href="../extra.css" rel="stylesheet">
<script src="../extra.js"></script>
<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:image" content="https://msberends.gitlab.io/AMR/logo.png" />
<meta name="twitter:card" content="summary" />
<!-- 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/config/TeX-AMS-MML_HTMLorMML.js" integrity="sha256-84DKXVJXs0/F8OTMzX4UR909+jtl4G7SPypPavF+GfA=" crossorigin="anonymous"></script>
@ -64,6 +68,7 @@
<![endif]-->
</head>
<body>
@ -80,7 +85,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">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>
</div>
@ -189,7 +194,6 @@
</a>
</li>
</ul>
<ul class="nav navbar-nav navbar-right">
<li>
<a href="https://gitlab.com/msberends/AMR">
@ -207,7 +211,7 @@
</li>
</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">
<input type="search" class="form-control" name="search-input" id="search-input" placeholder="Search..." aria-label="Search for..." autocomplete="off">
</div>
@ -218,6 +222,7 @@
</div><!--/.navbar -->
</header>
<div class="row">
@ -229,9 +234,7 @@
</div>
<div class="ref-description">
<p>Determine first (weighted) isolates of all microorganisms of every patient per episode and (if needed) per specimen type.</p>
</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>,
@ -328,11 +331,9 @@
<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>
<h2 class="hasAnchor" id="value"><a class="anchor" href="#value"></a>Value</h2>
<p>Logical vector</p>
<h2 class="hasAnchor" id="details"><a class="anchor" href="#details"></a>Details</h2>
<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>
<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 />
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 />
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>
<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>
<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>
<pre class="examples"><span class='co'># NOT RUN {</span>
<span class='co'># `example_isolates` is a dataset available in the AMR package.</span>
<pre class="examples"><span class='co'># `example_isolates` is a dataset available in the AMR package.</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='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>,
@ -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'># }</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='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='fu'>first_isolate</span>(<span class='no'>x</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='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='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='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='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>
<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>)
}</pre>
</div>
<div class="col-md-3 hidden-xs hidden-sm" id="sidebar">
<h2>Contents</h2>
<ul class="nav nav-pills nav-stacked">
<li><a href="#arguments">Arguments</a></li>
<li><a href="#source">Source</a></li>
<li><a href="#value">Value</a></li>
<li><a href="#details">Details</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="#see-also">See also</a></li>
<li><a href="#examples">Examples</a></li>
</ul>
</div>
</div>
<footer>
<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>
</div>
<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>
</footer>
</div>
@ -504,6 +471,8 @@ To conduct an analysis of antimicrobial resistance, you should only include the
</script>
</body>
</html>

2
docs/reference/index.html
View File

@ -84,7 +84,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">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>
</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{
x <- bug_drug_combinations(example_isolates)
x
format(x)
format(x, translate_ab = "name (atc)")
# Use FUN to change to transformation of microorganism codes
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
x$keyab <- key_antibiotics(x)
x$first_isolate <-
first_isolate(x)
x$first_isolate <- first_isolate(x)
x$first_isolate_weighed <-
first_isolate(x,
col_keyantibiotics = 'keyab')
x$first_isolate_weighed <- first_isolate(x, col_keyantibiotics = 'keyab')
x$first_blood_isolate <-
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')
x$first_blood_isolate <- first_isolate(x, specimen_group = "Blood")
}
}
\seealso{

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

@ -37,13 +37,13 @@ test_that("ab_property works", {
expect_identical(ab_name("Fluclox"), "Flucloxacillin")
expect_identical(ab_name("fluklox"), "Flucloxacillin")
expect_identical(ab_name("floxapen"), "Flucloxacillin")
expect_identical(ab_name(21319) , "Flucloxacillin")
expect_identical(ab_name(21319), "Flucloxacillin")
expect_identical(ab_name("J01CF05"), "Flucloxacillin")
expect_identical(ab_ddd("AMX", "oral"), 1)
expect_identical(ab_ddd("AMX", "oral", units = TRUE) , "g")
expect_identical(ab_ddd("AMX", "oral", units = TRUE), "g")
expect_identical(ab_ddd("AMX", "iv"), 1)
expect_identical(ab_ddd("AMX", "iv", units = TRUE) , "g")
expect_identical(ab_ddd("AMX", "iv", units = TRUE), "g")
expect_identical(ab_name(x = c("AMC", "PLB")), c("Amoxicillin/clavulanic acid", "Polymyxin B"))
expect_identical(ab_name(x = c("AMC", "PLB"), tolower = TRUE),

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

@ -85,6 +85,6 @@ test_that("counts work", {
expect_error(count_S("test", as_percent = "test"))
expect_error(count_df(c("A", "B", "C")))
expect_error(count_df(example_isolates[,"date"]))
expect_error(count_df(example_isolates[, "date"]))
})

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)
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"))
#print(paste("testing data set", datasets[i]))
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),
1317)
# first *weighted* isolates
# first weighted isolates
expect_equal(
suppressWarnings(
sum(
first_isolate(x = example_isolates %>% mutate(keyab = key_antibiotics(.)),
# let syntax determine these automatically:
# col_date = "date",
# col_patient_id = "patient_id",
# col_mo = "mo",
# col_keyantibiotics = "keyab",
# let syntax determine arguments automatically
type = "keyantibiotics",
info = TRUE),
na.rm = TRUE)),
@ -145,7 +141,7 @@ test_that("first isolates work", {
filter_specimen = "something_unexisting")))
# printing of exclusion message
expect_output(example_isolates %>%
expect_message(example_isolates %>%
first_isolate(col_date = "date",
col_mo = "mo",
col_patient_id = "patient_id",

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

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

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

@ -60,7 +60,7 @@ test_that("G-test works", {
y = c(780, 1560, 780),
rescale.p = TRUE))
expect_error(g.test(matrix(data = c(-1, -2, -3 , -4), ncol = 2, byrow = TRUE)))
expect_error(g.test(matrix(data = c(-1, -2, -3, -4), ncol = 2, byrow = TRUE)))
expect_error(g.test(matrix(data = c(0, 0, 0, 0), ncol = 2, byrow = TRUE)))
})

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", "es"), "Staphylococcus coagulasa negativo (SCN)")
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)")
})

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

@ -30,35 +30,26 @@ test_that("ggplot_rsi works", {
# data should be equal
expect_equal(
(example_isolates %>% select(AMC, CIP) %>% ggplot_rsi())$data %>%
summarise_all(portion_IR) %>% as.double(),
example_isolates %>% select(AMC, CIP) %>%
summarise_all(portion_IR) %>% as.double()
(example_isolates %>% select(AMC, CIP) %>% ggplot_rsi())$data %>% 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 = "antibiotic", facet = "interpretation"))
expect_equal(
(example_isolates %>% select(AMC, CIP) %>% ggplot_rsi(x = "interpretation", facet = "antibiotic"))$data %>%
summarise_all(portion_IR) %>% as.double(),
example_isolates %>% select(AMC, CIP) %>%
summarise_all(portion_IR) %>% as.double()
(example_isolates %>% select(AMC, CIP) %>% ggplot_rsi(x = "interpretation", facet = "antibiotic"))$data %>% summarise_all(portion_IR) %>% as.double(),
example_isolates %>% select(AMC, CIP) %>% summarise_all(portion_IR) %>% as.double()
)
expect_equal(
(example_isolates %>% select(AMC, CIP) %>% ggplot_rsi(x = "antibiotic", facet = "interpretation"))$data %>%
summarise_all(portion_IR) %>% as.double(),
example_isolates %>% select(AMC, CIP) %>%
summarise_all(portion_IR) %>% as.double()
(example_isolates %>% select(AMC, CIP) %>% ggplot_rsi(x = "antibiotic", facet = "interpretation"))$data %>% summarise_all(portion_IR) %>% as.double(),
example_isolates %>% select(AMC, CIP) %>% summarise_all(portion_IR) %>% as.double()
)
expect_equal(
(example_isolates %>% select(AMC, CIP) %>% ggplot_rsi(x = "antibiotic",
facet = "interpretation"))$data %>%
summarise_all(count_IR) %>% as.double(),
example_isolates %>% select(AMC, CIP) %>%
summarise_all(count_IR) %>% as.double()
(example_isolates %>% select(AMC, CIP) %>% ggplot_rsi(x = "antibiotic", facet = "interpretation"))$data %>% summarise_all(count_IR) %>% as.double(),
example_isolates %>% select(AMC, CIP) %>% summarise_all(count_IR) %>% as.double()
)
# 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 <- eucast_exceptional_phenotypes(example_isolates, info = TRUE)
# check class
expect_equal(outcome %>% class(), c('ordered', 'factor'))
expect_equal(outcome %>% class(), c("ordered", "factor"))
outcome <- mdro(example_isolates, "nl", info = TRUE)
# 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
expect_equal(outcome %>% freq() %>% pull(count),

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

@ -94,7 +94,7 @@ test_that("as.mo works", {
rep("B_STPHY_AURS", 9))
expect_identical(
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))
# unprevalent MO
expect_identical(
@ -114,13 +114,13 @@ test_that("as.mo works", {
c("UNKNOWN", NA_character_, "B_STNTR_MLTP", "B_KLBSL_PNMN_RHNS", "B_ESCHR_COLI"))
# check for Becker classification
expect_identical(as.character(as.mo("S. epidermidis", Becker = FALSE)), "B_STPHY_EPDR")
expect_identical(as.character(as.mo("S. epidermidis", Becker = TRUE)), "B_STPHY_CONS")
expect_identical(as.character(as.mo("STAEPI", Becker = TRUE)), "B_STPHY_CONS")
expect_identical(as.character(as.mo("S. intermedius", Becker = FALSE)), "B_STPHY_INTR")
expect_identical(as.character(as.mo("Sta intermedius",Becker = FALSE)), "B_STPHY_INTR")
expect_identical(as.character(as.mo("Sta intermedius",Becker = TRUE)), "B_STPHY_COPS")
expect_identical(as.character(as.mo("STAINT", Becker = TRUE)), "B_STPHY_COPS")
expect_identical(as.character(as.mo("S. epidermidis", Becker = FALSE)), "B_STPHY_EPDR")
expect_identical(as.character(as.mo("S. epidermidis", Becker = TRUE)), "B_STPHY_CONS")
expect_identical(as.character(as.mo("STAEPI", Becker = TRUE)), "B_STPHY_CONS")
expect_identical(as.character(as.mo("S. intermedius", Becker = FALSE)), "B_STPHY_INTR")
expect_identical(as.character(as.mo("Sta intermedius", Becker = FALSE)), "B_STPHY_INTR")
expect_identical(as.character(as.mo("Sta intermedius", Becker = TRUE)), "B_STPHY_COPS")
expect_identical(as.character(as.mo("STAINT", Becker = TRUE)), "B_STPHY_COPS")
# aureus must only be influenced if Becker = "all"
expect_identical(as.character(as.mo("STAAUR", Becker = FALSE)), "B_STPHY_AURS")
expect_identical(as.character(as.mo("STAAUR", Becker = TRUE)), "B_STPHY_AURS")
@ -150,7 +150,7 @@ test_that("as.mo works", {
# select with one column
expect_identical(
example_isolates[1:10,] %>%
example_isolates[1:10, ] %>%
left_join_microorganisms() %>%
select(genus) %>%
as.mo() %>%
@ -160,9 +160,9 @@ test_that("as.mo works", {
# select with two columns
expect_identical(
example_isolates[1:10,] %>%
example_isolates[1:10, ] %>%
pull(mo),
example_isolates[1:10,] %>%
example_isolates[1:10, ] %>%
left_join_microorganisms() %>%
select(genus, species) %>%
as.mo())
@ -260,10 +260,6 @@ test_that("as.mo works", {
expect_null(mo_failures())
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))
# 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", 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
MOs <- AMR::microorganisms

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

@ -117,5 +117,5 @@ test_that("portions works", {
)
expect_error(portion_df(c("A", "B", "C")))
expect_error(portion_df(example_isolates[,"date"]))
expect_error(portion_df(example_isolates[, "date"]))
})