P281424
/
AMR
mirror of https://github.com/msberends/AMR.git
1
0
Fork 0
Code Releases Activity

update dependencies

This commit is contained in:
dr. M.S. (Matthijs) Berends 2018-04-02 16:05:09 +02:00
parent cee64ef050
commit 07bdd61241
15 changed files with 172 additions and 221 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
DESCRIPTION
View File

@ -24,10 +24,17 @@ Description: Functions to simplify the analysis of Antimicrobial Resistance (AMR
of microbial isolates, by using new S3 classes and applying EUCAST expert rules of microbial isolates, by using new S3 classes and applying EUCAST expert rules
on antibiograms according to Leclercq (2013) on antibiograms according to Leclercq (2013)
<doi:10.1111/j.1469-0691.2011.03703.x>. <doi:10.1111/j.1469-0691.2011.03703.x>.
Depends: R (>= 3.0) Depends:
Imports: dplyr (>= 0.7.0), reshape2 (>= 1.4.0), xml2, rvest R (>= 3.2.0)
Suggests: testthat Imports:
URL: https://cran.r-project.org/package=AMR dplyr (>= 0.7.0),
reshape2 (>= 1.4.0),
xml2 (>= 1.0.0),
rvest (>= 0.3.2)
Suggests:
testthat (>= 2.0.0),
covr (>= 3.0.1)
URL: https://github.com/msberends/AMR
BugReports: https://github.com/msberends/AMR/issues BugReports: https://github.com/msberends/AMR/issues
License: GPL-2 | file LICENSE License: GPL-2 | file LICENSE
Encoding: UTF-8 Encoding: UTF-8

25
NEWS
View File

@ -1,14 +1,19 @@
## 0.1.2 ## 0.1.2
- NEW: Function `guess_bactid` to determine the ID of a microorganism based on genus/species - Added full support for Windows, Linux and macOS; this package now works everywhere :)
- NEW: Functions `clipboard_import` and `clipboard_export` as helper functions to quickly copy and paste from/to software like Excel and SPSS - New function `guess_bactid` to determine the ID of a microorganism based on genus/species
- NEW: New algorithm to determine weighted isolates, can now be `"points"` or `"keyantibiotics"`, see `?first_isolate` - New functions `clipboard_import` and `clipboard_export` as helper functions to quickly copy and paste from/to software like Excel and SPSS
- EDIT: Renamed dataset `ablist` to `antibiotics` - New algorithm to determine weighted isolates, can now be `"points"` or `"keyantibiotics"`, see `?first_isolate`
- EDIT: Renamed dataset `bactlist` to `microorganisms` - Renamed dataset `ablist` to `antibiotics`
- EDIT: Added support for character vector in join functions - Renamed dataset `bactlist` to `microorganisms`
- EDIT: Altered `%like%` to make it case insensitive - Added analysis examples on help page of dataset `septic_patients`
- EDIT: Functions `first_isolate`, `EUCAST_rules` and `rsi_predict` supports tidyverse-like evaluation of parameters (no need to quote columns them anymore) - Added support for character vector in join functions
- EDIT: For functions `first_isolate`, `EUCAST_rules` the antibiotic column names are case-insensitive - Added warnings when applying a join results in more rows after than before the join
- EDIT: Functions `as.rsi` and `as.mic` now add the package name and version as attribute - Altered `%like%` to make it case insensitive
- For parameters of functions `first_isolate`, `EUCAST_rules` the column names are now case-insensitive
- Functions `as.rsi` and `as.mic` now add the package name and version as attribute
- Expanded README.md
- Added unit testing with Travis CI (https://travis-ci.org/msberends/AMR)
- Added code coverage checking with Codecov (https://codecov.io/gh/msberends/AMR/tree/master/R)
## 0.1.1 ## 0.1.1
- `EUCAST_rules` applies for amoxicillin even if ampicillin is missing - `EUCAST_rules` applies for amoxicillin even if ampicillin is missing

122
R/EUCAST.R
View File

@ -48,7 +48,7 @@
#' cfur = "-", # Cefuroxime #' cfur = "-", # Cefuroxime
#' stringsAsFactors = FALSE) #' stringsAsFactors = FALSE)
#' a #' a
#' #'
#' b <- EUCAST_rules(a) #' b <- EUCAST_rules(a)
#' b #' b
EUCAST_rules <- function(tbl, EUCAST_rules <- function(tbl,
@ -114,71 +114,11 @@ EUCAST_rules <- function(tbl,
vanc = 'vanc') { vanc = 'vanc') {
EUCAST_VERSION <- "3.1" EUCAST_VERSION <- "3.1"
# support using columns as objects; the tidyverse way
amcl <- quasiquotate(deparse(substitute(amcl)), amcl)
amik <- quasiquotate(deparse(substitute(amik)), amik)
amox <- quasiquotate(deparse(substitute(amox)), amox)
ampi <- quasiquotate(deparse(substitute(ampi)), ampi)
azit <- quasiquotate(deparse(substitute(azit)), azit)
aztr <- quasiquotate(deparse(substitute(aztr)), aztr)
cefa <- quasiquotate(deparse(substitute(cefa)), cefa)
cfra <- quasiquotate(deparse(substitute(cfra)), cfra)
cfep <- quasiquotate(deparse(substitute(cfep)), cfep)
cfot <- quasiquotate(deparse(substitute(cfot)), cfot)
cfox <- quasiquotate(deparse(substitute(cfox)), cfox)
cfta <- quasiquotate(deparse(substitute(cfta)), cfta)
cftr <- quasiquotate(deparse(substitute(cftr)), cftr)
cfur <- quasiquotate(deparse(substitute(cfur)), cfur)
chlo <- quasiquotate(deparse(substitute(chlo)), chlo)
cipr <- quasiquotate(deparse(substitute(cipr)), cipr)
clar <- quasiquotate(deparse(substitute(clar)), clar)
clin <- quasiquotate(deparse(substitute(clin)), clin)
clox <- quasiquotate(deparse(substitute(clox)), clox)
coli <- quasiquotate(deparse(substitute(coli)), coli)
czol <- quasiquotate(deparse(substitute(czol)), czol)
dapt <- quasiquotate(deparse(substitute(dapt)), dapt)
doxy <- quasiquotate(deparse(substitute(doxy)), doxy)
erta <- quasiquotate(deparse(substitute(erta)), erta)
eryt <- quasiquotate(deparse(substitute(eryt)), eryt)
fosf <- quasiquotate(deparse(substitute(fosf)), fosf)
fusi <- quasiquotate(deparse(substitute(fusi)), fusi)
gent <- quasiquotate(deparse(substitute(gent)), gent)
imip <- quasiquotate(deparse(substitute(imip)), imip)
kana <- quasiquotate(deparse(substitute(kana)), kana)
levo <- quasiquotate(deparse(substitute(levo)), levo)
linc <- quasiquotate(deparse(substitute(linc)), linc)
line <- quasiquotate(deparse(substitute(line)), line)
mero <- quasiquotate(deparse(substitute(mero)), mero)
mino <- quasiquotate(deparse(substitute(mino)), mino)
moxi <- quasiquotate(deparse(substitute(moxi)), moxi)
nali <- quasiquotate(deparse(substitute(nali)), nali)
neom <- quasiquotate(deparse(substitute(neom)), neom)
neti <- quasiquotate(deparse(substitute(neti)), neti)
nitr <- quasiquotate(deparse(substitute(nitr)), nitr)
novo <- quasiquotate(deparse(substitute(novo)), novo)
norf <- quasiquotate(deparse(substitute(norf)), norf)
oflo <- quasiquotate(deparse(substitute(oflo)), oflo)
peni <- quasiquotate(deparse(substitute(peni)), peni)
pita <- quasiquotate(deparse(substitute(pita)), pita)
poly <- quasiquotate(deparse(substitute(poly)), poly)
qida <- quasiquotate(deparse(substitute(qida)), qida)
rifa <- quasiquotate(deparse(substitute(rifa)), rifa)
roxi <- quasiquotate(deparse(substitute(roxi)), roxi)
siso <- quasiquotate(deparse(substitute(siso)), siso)
teic <- quasiquotate(deparse(substitute(teic)), teic)
tetr <- quasiquotate(deparse(substitute(tetr)), tetr)
tica <- quasiquotate(deparse(substitute(tica)), tica)
tige <- quasiquotate(deparse(substitute(tige)), tige)
tobr <- quasiquotate(deparse(substitute(tobr)), tobr)
trim <- quasiquotate(deparse(substitute(trim)), trim)
trsu <- quasiquotate(deparse(substitute(trsu)), trsu)
vanc <- quasiquotate(deparse(substitute(vanc)), vanc)
if (!col_bactid %in% colnames(tbl)) { if (!col_bactid %in% colnames(tbl)) {
stop('Column ', col_bactid, ' not found.') stop('Column ', col_bactid, ' not found.')
} }
# check columns # check columns
col.list <- c(amcl, amik, amox, ampi, azit, aztr, cefa, cfra, cfep, cfot, col.list <- c(amcl, amik, amox, ampi, azit, aztr, cefa, cfra, cfep, cfot,
cfox, cfta, cftr, cfur, chlo, cipr, clar, clin, clox, coli, cfox, cfta, cftr, cfur, chlo, cipr, clar, clin, clox, coli,
@ -209,7 +149,7 @@ EUCAST_rules <- function(tbl,
call. = FALSE) call. = FALSE)
} }
} }
amcl <- col.list[1] amcl <- col.list[1]
amik <- col.list[2] amik <- col.list[2]
amox <- col.list[3] amox <- col.list[3]
@ -268,10 +208,10 @@ EUCAST_rules <- function(tbl,
trim <- col.list[56] trim <- col.list[56]
trsu <- col.list[57] trsu <- col.list[57]
vanc <- col.list[58] vanc <- col.list[58]
total <- 0 total <- 0
total_rows <- integer(0) total_rows <- integer(0)
# helper function for editing the table # helper function for editing the table
edit_rsi <- function(to, rows, cols) { edit_rsi <- function(to, rows, cols) {
cols <- cols[!is.na(cols)] cols <- cols[!is.na(cols)]
@ -281,12 +221,12 @@ EUCAST_rules <- function(tbl,
total_rows <<- c(total_rows, rows) total_rows <<- c(total_rows, rows)
} }
} }
# join to microorganisms table # join to microorganisms table
joinby <- colnames(AMR::microorganisms)[1] joinby <- colnames(AMR::microorganisms)[1]
names(joinby) <- col_bactid names(joinby) <- col_bactid
tbl <- tbl %>% left_join(y = AMR::microorganisms, by = joinby, suffix = c("_tempmicroorganisms", "")) tbl <- tbl %>% left_join(y = AMR::microorganisms, by = joinby, suffix = c("_tempmicroorganisms", ""))
# antibiotic classes # antibiotic classes
aminoglycosides <- c(tobr, gent, kana, neom, neti, siso) aminoglycosides <- c(tobr, gent, kana, neom, neti, siso)
tetracyclines <- c(doxy, mino, tetr) # since EUCAST v3.1 tige(cycline) is set apart tetracyclines <- c(doxy, mino, tetr) # since EUCAST v3.1 tige(cycline) is set apart
@ -299,7 +239,7 @@ EUCAST_rules <- function(tbl,
aminopenicillins <- c(ampi, amox) aminopenicillins <- c(ampi, amox)
ureidopenicillins <- pita # should officially also be azlo and mezlo ureidopenicillins <- pita # should officially also be azlo and mezlo
fluoroquinolones <- c(oflo, cipr, norf, levo, moxi) fluoroquinolones <- c(oflo, cipr, norf, levo, moxi)
if (info == TRUE) { if (info == TRUE) {
cat( cat(
paste0( paste0(
@ -308,7 +248,7 @@ EUCAST_rules <- function(tbl,
' rows according to "EUCAST Expert Rules Version ', EUCAST_VERSION, '"\n') ' rows according to "EUCAST Expert Rules Version ', EUCAST_VERSION, '"\n')
) )
} }
# Table 1: Intrinsic resistance in Enterobacteriaceae ---- # Table 1: Intrinsic resistance in Enterobacteriaceae ----
if (info == TRUE) { if (info == TRUE) {
cat('...Table 1: Intrinsic resistance in Enterobacteriaceae\n') cat('...Table 1: Intrinsic resistance in Enterobacteriaceae\n')
@ -378,8 +318,8 @@ EUCAST_rules <- function(tbl,
edit_rsi(to = 'R', edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Yersinia pseudotuberculosis'), rows = which(tbl$fullname %like% '^Yersinia pseudotuberculosis'),
cols = c(poly, coli)) cols = c(poly, coli))
# Table 2: Intrinsic resistance in non-fermentative Gram-negative bacteria ---- # Table 2: Intrinsic resistance in non-fermentative Gram-negative bacteria ----
if (info == TRUE) { if (info == TRUE) {
cat('...Table 2: Intrinsic resistance in non-fermentative Gram-negative bacteria\n') cat('...Table 2: Intrinsic resistance in non-fermentative Gram-negative bacteria\n')
@ -426,8 +366,8 @@ EUCAST_rules <- function(tbl,
edit_rsi(to = 'R', edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Stenotrophomonas maltophilia'), rows = which(tbl$fullname %like% '^Stenotrophomonas maltophilia'),
cols = c(aminopenicillins, amcl, tica, pita, czol, cfot, cftr, cfta, aztr, erta, imip, mero, aminoglycosides, trim, fosf, tetr)) cols = c(aminopenicillins, amcl, tica, pita, czol, cfot, cftr, cfta, aztr, erta, imip, mero, aminoglycosides, trim, fosf, tetr))
# Table 3: Intrinsic resistance in other Gram-negative bacteria ---- # Table 3: Intrinsic resistance in other Gram-negative bacteria ----
if (info == TRUE) { if (info == TRUE) {
cat('...Table 3: Intrinsic resistance in other Gram-negative bacteria\n') cat('...Table 3: Intrinsic resistance in other Gram-negative bacteria\n')
@ -458,8 +398,8 @@ EUCAST_rules <- function(tbl,
edit_rsi(to = 'R', edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Campylobacter (jejuni|coli)'), rows = which(tbl$fullname %like% '^Campylobacter (jejuni|coli)'),
cols = c(fusi, streptogramins, trim)) cols = c(fusi, streptogramins, trim))
# Table 4: Intrinsic resistance in Gram-positive bacteria ---- # Table 4: Intrinsic resistance in Gram-positive bacteria ----
if (info == TRUE) { if (info == TRUE) {
cat('...Table 4: Intrinsic resistance in Gram-positive bacteria\n') cat('...Table 4: Intrinsic resistance in Gram-positive bacteria\n')
@ -513,7 +453,7 @@ EUCAST_rules <- function(tbl,
edit_rsi(to = 'R', edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Clostridium (ramosum|innocuum)'), rows = which(tbl$fullname %like% '^Clostridium (ramosum|innocuum)'),
cols = vanc) cols = vanc)
# Table 8: Interpretive rules for B-lactam agents and Gram-positive cocci ---- # Table 8: Interpretive rules for B-lactam agents and Gram-positive cocci ----
if (info == TRUE) { if (info == TRUE) {
cat('...Table 8: Interpretive rules for B-lactam agents and Gram-positive cocci\n') cat('...Table 8: Interpretive rules for B-lactam agents and Gram-positive cocci\n')
@ -538,7 +478,7 @@ EUCAST_rules <- function(tbl,
& tbl[, amox] == 'R'), & tbl[, amox] == 'R'),
cols = c(ureidopenicillins, carbapenems)) cols = c(ureidopenicillins, carbapenems))
} }
# Table 9: Interpretive rules for B-lactam agents and Gram-negative rods ---- # Table 9: Interpretive rules for B-lactam agents and Gram-negative rods ----
if (info == TRUE) { if (info == TRUE) {
cat('...Table 9: Interpretive rules for B-lactam agents and Gram-negative rods\n') cat('...Table 9: Interpretive rules for B-lactam agents and Gram-negative rods\n')
@ -551,7 +491,7 @@ EUCAST_rules <- function(tbl,
& tbl[, pita] == 'S'), & tbl[, pita] == 'S'),
cols = pita) cols = pita)
} }
# Table 10: Interpretive rules for B-lactam agents and other Gram-negative bacteria ---- # Table 10: Interpretive rules for B-lactam agents and other Gram-negative bacteria ----
if (info == TRUE) { if (info == TRUE) {
cat('...Table 10: Interpretive rules for B-lactam agents and other Gram-negative bacteria\n') cat('...Table 10: Interpretive rules for B-lactam agents and other Gram-negative bacteria\n')
@ -564,7 +504,7 @@ EUCAST_rules <- function(tbl,
# & tbl[, ampi] == 'R'), # & tbl[, ampi] == 'R'),
# cols = c(ampi, amox, amcl, pita, cfur)) # cols = c(ampi, amox, amcl, pita, cfur))
} }
# Table 11: Interpretive rules for macrolides, lincosamides, and streptogramins ---- # Table 11: Interpretive rules for macrolides, lincosamides, and streptogramins ----
if (info == TRUE) { if (info == TRUE) {
cat('...Table 11: Interpretive rules for macrolides, lincosamides, and streptogramins\n') cat('...Table 11: Interpretive rules for macrolides, lincosamides, and streptogramins\n')
@ -578,7 +518,7 @@ EUCAST_rules <- function(tbl,
tbl[, clar] <- tbl[, eryt] tbl[, clar] <- tbl[, eryt]
} }
} }
# Table 12: Interpretive rules for aminoglycosides ---- # Table 12: Interpretive rules for aminoglycosides ----
if (info == TRUE) { if (info == TRUE) {
cat('...Table 12: Interpretive rules for aminoglycosides\n') cat('...Table 12: Interpretive rules for aminoglycosides\n')
@ -613,8 +553,8 @@ EUCAST_rules <- function(tbl,
& tbl[, gent] == 'R'), & tbl[, gent] == 'R'),
cols = tobr) cols = tobr)
} }
# Table 13: Interpretive rules for quinolones ---- # Table 13: Interpretive rules for quinolones ----
if (info == TRUE) { if (info == TRUE) {
cat('...Table 13: Interpretive rules for quinolones\n') cat('...Table 13: Interpretive rules for quinolones\n')
@ -647,8 +587,8 @@ EUCAST_rules <- function(tbl,
& tbl[, cipr] == 'R'), & tbl[, cipr] == 'R'),
cols = fluoroquinolones) cols = fluoroquinolones)
} }
# Other ---- # Other ----
if (info == TRUE) { if (info == TRUE) {
cat('...Non-EUCAST: trim = R where trsu = R and ampi = R where amcl = R\n') cat('...Non-EUCAST: trim = R where trsu = R and ampi = R where amcl = R\n')
@ -666,21 +606,21 @@ EUCAST_rules <- function(tbl,
if (!is.na(ampi) & !is.na(amox)) { if (!is.na(ampi) & !is.na(amox)) {
tbl[, amox] <- tbl %>% pull(ampi) tbl[, amox] <- tbl %>% pull(ampi)
} }
# Remove added columns again # Remove added columns again
microorganisms.ncol <- ncol(AMR::microorganisms) - 2 microorganisms.ncol <- ncol(AMR::microorganisms) - 2
tbl.ncol <- ncol(tbl) tbl.ncol <- ncol(tbl)
tbl <- tbl %>% select(-c((tbl.ncol - microorganisms.ncol):tbl.ncol)) tbl <- tbl %>% select(-c((tbl.ncol - microorganisms.ncol):tbl.ncol))
# and remove added suffices # and remove added suffices
colnames(tbl) <- gsub("_tempmicroorganisms", "", colnames(tbl)) colnames(tbl) <- gsub("_tempmicroorganisms", "", colnames(tbl))
if (info == TRUE) { if (info == TRUE) {
cat('Done.\n\nEUCAST Expert rules applied to', cat('Done.\n\nEUCAST Expert rules applied to',
total_rows %>% unique() %>% length() %>% format(big.mark = ","), total_rows %>% unique() %>% length() %>% format(big.mark = ","),
'different rows (isolates); edited a total of', 'different rows (isolates); edited a total of',
total %>% format(big.mark = ","), 'test results.\n\n') total %>% format(big.mark = ","), 'test results.\n\n')
} }
tbl tbl
} }
@ -698,12 +638,12 @@ interpretive_reading <- function(...) {
#' @importFrom dplyr %>% filter select #' @importFrom dplyr %>% filter select
#' @seealso \code{\link{microorganisms}} #' @seealso \code{\link{microorganisms}}
mo_property <- function(bactid, property = 'fullname') { mo_property <- function(bactid, property = 'fullname') {
mocode <- as.character(bactid) mocode <- as.character(bactid)
for (i in 1:length(mocode)) { for (i in 1:length(mocode)) {
bug <- mocode[i] bug <- mocode[i]
if (!is.na(bug)) { if (!is.na(bug)) {
result = tryCatch({ result = tryCatch({
mocode[i] <- mocode[i] <-
@ -720,7 +660,7 @@ mo_property <- function(bactid, property = 'fullname') {
} }
}) })
} }
} }
mocode mocode
} }

37
R/classes.R
View File

@ -29,18 +29,23 @@
#' rsi_data <- as.rsi(c(rep("S", 474), rep("I", 36), rep("R", 370))) #' rsi_data <- as.rsi(c(rep("S", 474), rep("I", 36), rep("R", 370)))
#' rsi_data <- as.rsi(c(rep("S", 474), rep("I", 36), rep("R", 370), "A", "B", "C")) #' rsi_data <- as.rsi(c(rep("S", 474), rep("I", 36), rep("R", 370), "A", "B", "C"))
#' is.rsi(rsi_data) #' is.rsi(rsi_data)
#' #'
#' plot(rsi_data) # for percentages #' plot(rsi_data) # for percentages
#' barplot(rsi_data) # for frequencies #' barplot(rsi_data) # for frequencies
as.rsi <- function(x) { as.rsi <- function(x) {
if (is.rsi(x)) { if (is.rsi(x)) {
x x
} else { } else {
x <- x %>% unlist() x <- x %>% unlist()
x.bak <- x x.bak <- x
na_before <- x[is.na(x) | x == ''] %>% length() na_before <- x[is.na(x) | x == ''] %>% length()
# remove all spaces
x <- gsub(' {2,55}', '', x)
# disallow more than 3 characters
x[nchar(x) > 3] <- NA
# remove all invalid characters
x <- gsub('[^RSI]+', '', x %>% toupper()) x <- gsub('[^RSI]+', '', x %>% toupper())
# needed for UMCG in cases of "S;S" but also "S;I"; the latter will be NA: # needed for UMCG in cases of "S;S" but also "S;I"; the latter will be NA:
x <- gsub('^S+$', 'S', x) x <- gsub('^S+$', 'S', x)
@ -48,7 +53,7 @@ as.rsi <- function(x) {
x <- gsub('^R+$', 'R', x) x <- gsub('^R+$', 'R', x)
x[!x %in% c('S', 'I', 'R')] <- NA x[!x %in% c('S', 'I', 'R')] <- NA
na_after <- x[is.na(x) | x == ''] %>% length() na_after <- x[is.na(x) | x == ''] %>% length()
if (na_before != na_after) { if (na_before != na_after) {
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ''] %>% list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ''] %>%
unique() %>% unique() %>%
@ -59,7 +64,7 @@ as.rsi <- function(x) {
'%) that were invalid antimicrobial interpretations: ', '%) that were invalid antimicrobial interpretations: ',
list_missing, call. = FALSE) list_missing, call. = FALSE)
} }
x <- x %>% toupper() %>% factor(levels = c("S", "I", "R"), ordered = TRUE) x <- x %>% toupper() %>% factor(levels = c("S", "I", "R"), ordered = TRUE)
class(x) <- c('rsi', 'ordered', 'factor') class(x) <- c('rsi', 'ordered', 'factor')
attr(x, 'package') <- 'AMR' attr(x, 'package') <- 'AMR'
@ -128,7 +133,7 @@ summary.rsi <- function(object, ...) {
#' @noRd #' @noRd
plot.rsi <- function(x, ...) { plot.rsi <- function(x, ...) {
x_name <- deparse(substitute(x)) x_name <- deparse(substitute(x))
data <- data.frame(x = x, data <- data.frame(x = x,
y = 1, y = 1,
stringsAsFactors = TRUE) %>% stringsAsFactors = TRUE) %>%
@ -137,7 +142,7 @@ plot.rsi <- function(x, ...) {
filter(!is.na(x)) %>% filter(!is.na(x)) %>%
mutate(s = round((n / sum(n)) * 100, 1)) mutate(s = round((n / sum(n)) * 100, 1))
data$x <- factor(data$x, levels = c('S', 'I', 'R'), ordered = TRUE) data$x <- factor(data$x, levels = c('S', 'I', 'R'), ordered = TRUE)
ymax <- if_else(max(data$s) > 95, 105, 100) ymax <- if_else(max(data$s) > 95, 105, 100)
plot(x = data$x, plot(x = data$x,
@ -154,7 +159,7 @@ plot.rsi <- function(x, ...) {
axis(side = 1, at = 1:n_distinct(data$x), labels = levels(data$x), lwd = 0) axis(side = 1, at = 1:n_distinct(data$x), labels = levels(data$x), lwd = 0)
# y axis, 0-100% # y axis, 0-100%
axis(side = 2, at = seq(0, 100, 5)) axis(side = 2, at = seq(0, 100, 5))
text(x = data$x, text(x = data$x,
y = data$s + 4, y = data$s + 4,
labels = paste0(data$s, '% (n = ', data$n, ')')) labels = paste0(data$s, '% (n = ', data$n, ')'))
@ -169,7 +174,7 @@ plot.rsi <- function(x, ...) {
barplot.rsi <- function(height, ...) { barplot.rsi <- function(height, ...) {
x <- height x <- height
x_name <- deparse(substitute(height)) x_name <- deparse(substitute(height))
data <- data.frame(rsi = x, cnt = 1) %>% data <- data.frame(rsi = x, cnt = 1) %>%
group_by(rsi) %>% group_by(rsi) %>%
summarise(cnt = sum(cnt)) %>% summarise(cnt = sum(cnt)) %>%
@ -199,7 +204,7 @@ barplot.rsi <- function(height, ...) {
#' @examples #' @examples
#' mic_data <- as.mic(c(">=32", "1.0", "1", "1.00", 8, "<=0.128", "8", "16", "16")) #' mic_data <- as.mic(c(">=32", "1.0", "1", "1.00", 8, "<=0.128", "8", "16", "16"))
#' is.mic(mic_data) #' is.mic(mic_data)
#' #'
#' plot(mic_data) #' plot(mic_data)
#' barplot(mic_data) #' barplot(mic_data)
as.mic <- function(x, na.rm = FALSE) { as.mic <- function(x, na.rm = FALSE) {
@ -211,7 +216,7 @@ as.mic <- function(x, na.rm = FALSE) {
x <- x[!is.na(x)] x <- x[!is.na(x)]
} }
x.bak <- x x.bak <- x
# comma to dot # comma to dot
x <- gsub(',', '.', x, fixed = TRUE) x <- gsub(',', '.', x, fixed = TRUE)
# starting dots must start with 0 # starting dots must start with 0
@ -224,7 +229,7 @@ as.mic <- function(x, na.rm = FALSE) {
x <- gsub('[^0-9]$', '', x) x <- gsub('[^0-9]$', '', x)
# remove last zeroes # remove last zeroes
x <- gsub('[.]?0+$', '', x) x <- gsub('[.]?0+$', '', x)
lvls <- c("<0.002", "<=0.002", "0.002", ">=0.002", ">0.002", lvls <- c("<0.002", "<=0.002", "0.002", ">=0.002", ">0.002",
"<0.003", "<=0.003", "0.003", ">=0.003", ">0.003", "<0.003", "<=0.003", "0.003", ">=0.003", ">0.003",
"<0.004", "<=0.004", "0.004", ">=0.004", ">0.004", "<0.004", "<=0.004", "0.004", ">=0.004", ">0.004",
@ -282,11 +287,11 @@ as.mic <- function(x, na.rm = FALSE) {
"<512", "<=512", "512", ">=512", ">512", "<512", "<=512", "512", ">=512", ">512",
"<1024", "<=1024", "1024", ">=1024", ">1024") "<1024", "<=1024", "1024", ">=1024", ">1024")
x <- x %>% as.character() x <- x %>% as.character()
na_before <- x[is.na(x) | x == ''] %>% length() na_before <- x[is.na(x) | x == ''] %>% length()
x[!x %in% lvls] <- NA x[!x %in% lvls] <- NA
na_after <- x[is.na(x) | x == ''] %>% length() na_after <- x[is.na(x) | x == ''] %>% length()
if (na_before != na_after) { if (na_before != na_after) {
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ''] %>% list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ''] %>%
unique() %>% unique() %>%
@ -297,7 +302,7 @@ as.mic <- function(x, na.rm = FALSE) {
'%) that were invalid MICs: ', '%) that were invalid MICs: ',
list_missing, call. = FALSE) list_missing, call. = FALSE)
} }
x <- factor(x = x, x <- factor(x = x,
levels = lvls, levels = lvls,
ordered = TRUE) ordered = TRUE)
@ -407,7 +412,7 @@ create_barplot_mic <- function(x, x_name, ...) {
barplot(table(droplevels(x)), barplot(table(droplevels(x)),
ylab = 'Frequency', ylab = 'Frequency',
xlab = 'MIC value', xlab = 'MIC value',
main = paste('MIC values of', x_name), main = paste('MIC values of', x_name),
axes = FALSE, axes = FALSE,
...) ...)
axis(2, seq(0, max(data$cnt))) axis(2, seq(0, max(data$cnt)))

19
R/misc.R
View File

@ -31,22 +31,3 @@
percent <- function(x, round = 1, ...) { percent <- function(x, round = 1, ...) {
base::paste0(base::round(x * 100, digits = round), "%") base::paste0(base::round(x * 100, digits = round), "%")
} }
# No export, no Rd
quasiquotate <- function(deparsed, parsed) {
# when text: remove first and last "
if (any(deparsed %like% '^".+"$' | deparsed %like% "^'.+'$")) {
deparsed <- deparsed %>% substr(2, nchar(.) - 1)
}
# apply if needed
if (any(!deparsed %like% '[[$:()]'
& !deparsed %in% c('""', "''", "", # empty text
".", ".data", # dplyr references
"TRUE", "FALSE", # logicals
"NA", "NaN", "NULL", # empty values
ls(.GlobalEnv)))) {
deparsed
} else {
parsed
}
}

93
R/rsi_analysis.R
View File

@ -41,7 +41,7 @@
#' library(dplyr) #' library(dplyr)
#' # calculate current empiric therapy of Helicobacter gastritis: #' # calculate current empiric therapy of Helicobacter gastritis:
#' my_table %>% #' my_table %>%
#' filter(first_isolate == TRUE, #' filter(first_isolate == TRUE,
#' genus == "Helicobacter") %>% #' genus == "Helicobacter") %>%
#' rsi_df(ab = c("amox", "metr")) #' rsi_df(ab = c("amox", "metr"))
#' } #' }
@ -55,7 +55,7 @@ rsi_df <- function(tbl,
# in case tbl$interpretation already exists: # in case tbl$interpretation already exists:
interpretations_to_check <- paste(interpretation, collapse = "") interpretations_to_check <- paste(interpretation, collapse = "")
# validate: # validate:
if (min(grepl('^[a-z]{3,4}$', ab)) == 0 & if (min(grepl('^[a-z]{3,4}$', ab)) == 0 &
min(grepl('^rsi[1-2]$', ab)) == 0) { min(grepl('^rsi[1-2]$', ab)) == 0) {
@ -71,7 +71,7 @@ rsi_df <- function(tbl,
warning('Dataset contains isolates from the Intensive Care. Exclude them from proper epidemiological analysis.') warning('Dataset contains isolates from the Intensive Care. Exclude them from proper epidemiological analysis.')
} }
} }
# transform when checking for different results # transform when checking for different results
if (interpretations_to_check %in% c('SI', 'IS')) { if (interpretations_to_check %in% c('SI', 'IS')) {
for (i in 1:length(ab)) { for (i in 1:length(ab)) {
@ -101,7 +101,7 @@ rsi_df <- function(tbl,
denominator <- tbl %>% denominator <- tbl %>%
filter(pull(., ab[1]) %in% c("S", "I", "R")) %>% filter(pull(., ab[1]) %in% c("S", "I", "R")) %>%
nrow() nrow()
} else if (length(ab) == 2) { } else if (length(ab) == 2) {
numerator <- tbl %>% numerator <- tbl %>%
filter_at(vars(ab[1], ab[2]), filter_at(vars(ab[1], ab[2]),
@ -109,12 +109,12 @@ rsi_df <- function(tbl,
filter_at(vars(ab[1], ab[2]), filter_at(vars(ab[1], ab[2]),
all_vars(. %in% c("S", "R", "I"))) %>% all_vars(. %in% c("S", "R", "I"))) %>%
nrow() nrow()
denominator <- tbl %>% denominator <- tbl %>%
filter_at(vars(ab[1], ab[2]), filter_at(vars(ab[1], ab[2]),
all_vars(. %in% c("S", "R", "I"))) %>% all_vars(. %in% c("S", "R", "I"))) %>%
nrow() nrow()
} else if (length(ab) == 3) { } else if (length(ab) == 3) {
numerator <- tbl %>% numerator <- tbl %>%
filter_at(vars(ab[1], ab[2], ab[3]), filter_at(vars(ab[1], ab[2], ab[3]),
@ -122,16 +122,16 @@ rsi_df <- function(tbl,
filter_at(vars(ab[1], ab[2], ab[3]), filter_at(vars(ab[1], ab[2], ab[3]),
all_vars(. %in% c("S", "R", "I"))) %>% all_vars(. %in% c("S", "R", "I"))) %>%
nrow() nrow()
denominator <- tbl %>% denominator <- tbl %>%
filter_at(vars(ab[1], ab[2], ab[3]), filter_at(vars(ab[1], ab[2], ab[3]),
all_vars(. %in% c("S", "R", "I"))) %>% all_vars(. %in% c("S", "R", "I"))) %>%
nrow() nrow()
} else { } else {
stop('Maximum of 3 drugs allowed.') stop('Maximum of 3 drugs allowed.')
} }
# build text part # build text part
if (info == TRUE) { if (info == TRUE) {
cat('n =', denominator) cat('n =', denominator)
@ -147,7 +147,7 @@ rsi_df <- function(tbl,
info.txt2 <- gsub('rsi1', 'this drug', info.txt2, fixed = TRUE) info.txt2 <- gsub('rsi1', 'this drug', info.txt2, fixed = TRUE)
cat(paste0(' (of ', nrow(tbl), ' in total; ', info.txt1, ' tested on ', info.txt2, ')\n')) cat(paste0(' (of ', nrow(tbl), ' in total; ', info.txt1, ' tested on ', info.txt2, ')\n'))
} }
# calculate and format # calculate and format
y <- numerator / denominator y <- numerator / denominator
if (percent == TRUE) { if (percent == TRUE) {
@ -159,7 +159,7 @@ rsi_df <- function(tbl,
} }
y <- NA y <- NA
} }
# output # output
y y
} }
@ -178,14 +178,14 @@ rsi_df <- function(tbl,
#' tbl %>% #' tbl %>%
#' group_by(hospital) %>% #' group_by(hospital) %>%
#' summarise(cipr = rsi(cipr)) #' summarise(cipr = rsi(cipr))
#' #'
#' tbl %>% #' tbl %>%
#' group_by(year, hospital) %>% #' group_by(year, hospital) %>%
#' summarise( #' summarise(
#' isolates = n(), #' isolates = n(),
#' cipro = rsi(cipr %>% as.rsi(), percent = TRUE), #' cipro = rsi(cipr %>% as.rsi(), percent = TRUE),
#' amoxi = rsi(amox %>% as.rsi(), percent = TRUE)) #' amoxi = rsi(amox %>% as.rsi(), percent = TRUE))
#' #'
#' rsi(as.rsi(isolates$amox)) #' rsi(as.rsi(isolates$amox))
#' #'
#' rsi(as.rsi(isolates$amcl), interpretation = "S") #' rsi(as.rsi(isolates$amcl), interpretation = "S")
@ -207,12 +207,12 @@ rsi <- function(ab1, ab2 = NA, interpretation = 'IR', minimum = 30, percent = FA
if (!ab2.name %like% '^[a-z]{3,4}$') { if (!ab2.name %like% '^[a-z]{3,4}$') {
ab2.name <- 'rsi2' ab2.name <- 'rsi2'
} }
interpretation <- paste(interpretation, collapse = "") interpretation <- paste(interpretation, collapse = "")
tbl <- tibble(rsi1 = ab1, rsi2 = ab2) tbl <- tibble(rsi1 = ab1, rsi2 = ab2)
colnames(tbl) <- c(ab1.name, ab2.name) colnames(tbl) <- c(ab1.name, ab2.name)
if (length(ab2) == 1) { if (length(ab2) == 1) {
return(rsi_df(tbl = tbl, return(rsi_df(tbl = tbl,
ab = ab1.name, ab = ab1.name,
@ -260,7 +260,7 @@ rsi <- function(ab1, ab2 = NA, interpretation = 'IR', minimum = 30, percent = FA
#' # use it directly: #' # use it directly:
#' rsi_predict(tbl = tbl[which(first_isolate == TRUE & genus == "Haemophilus"),], #' rsi_predict(tbl = tbl[which(first_isolate == TRUE & genus == "Haemophilus"),],
#' col_ab = "amcl", col_date = "date") #' col_ab = "amcl", col_date = "date")
#' #'
#' # or with dplyr so you can actually read it: #' # or with dplyr so you can actually read it:
#' library(dplyr) #' library(dplyr)
#' tbl %>% #' tbl %>%
@ -274,22 +274,22 @@ rsi <- function(ab1, ab2 = NA, interpretation = 'IR', minimum = 30, percent = FA
#' library(dplyr) #' library(dplyr)
#' septic_patients %>% #' septic_patients %>%
#' # get bacteria properties like genus and species #' # get bacteria properties like genus and species
#' left_join_microorganisms("bactid") %>% #' left_join_microorganisms("bactid") %>%
#' # calculate first isolates #' # calculate first isolates
#' mutate(first_isolate = #' mutate(first_isolate =
#' first_isolate(., #' first_isolate(.,
#' "date", #' "date",
#' "patient_id", #' "patient_id",
#' "bactid", #' "bactid",
#' col_specimen = NA, #' col_specimen = NA,
#' col_icu = NA)) %>% #' col_icu = NA)) %>%
#' # filter on first E. coli isolates #' # filter on first E. coli isolates
#' filter(genus == "Escherichia", #' filter(genus == "Escherichia",
#' species == "coli", #' species == "coli",
#' first_isolate == TRUE) %>% #' first_isolate == TRUE) %>%
#' # predict resistance of cefotaxime for next years #' # predict resistance of cefotaxime for next years
#' rsi_predict(col_ab = cfot, #' rsi_predict(col_ab = "cfot",
#' col_date = date, #' col_date = "date",
#' year_max = 2025, #' year_max = 2025,
#' preserve_measurements = FALSE) #' preserve_measurements = FALSE)
#' #'
@ -302,16 +302,15 @@ rsi_predict <- function(tbl,
I_as_R = TRUE, I_as_R = TRUE,
preserve_measurements = TRUE, preserve_measurements = TRUE,
info = TRUE) { info = TRUE) {
if (nrow(tbl) == 0) { if (nrow(tbl) == 0) {
stop('This table does not contain any observations.') stop('This table does not contain any observations.')
} }
col_ab <- quasiquotate(deparse(substitute(col_ab)), col_ab)
if (!col_ab %in% colnames(tbl)) { if (!col_ab %in% colnames(tbl)) {
stop('Column ', col_ab, ' not found.') stop('Column ', col_ab, ' not found.')
} }
col_date <- quasiquotate(deparse(substitute(col_date)), col_date)
if (!col_date %in% colnames(tbl)) { if (!col_date %in% colnames(tbl)) {
stop('Column ', col_date, ' not found.') stop('Column ', col_date, ' not found.')
} }
@ -327,7 +326,7 @@ rsi_predict <- function(tbl,
if (!all(tbl %>% pull(col_ab) %>% as.rsi() %in% c(NA, 'S', 'I', 'R'))) { if (!all(tbl %>% pull(col_ab) %>% as.rsi() %in% c(NA, 'S', 'I', 'R'))) {
stop('Column ', col_ab, ' must contain antimicrobial interpretations (S, I, R).') stop('Column ', col_ab, ' must contain antimicrobial interpretations (S, I, R).')
} }
year <- function(x) { year <- function(x) {
if (all(grepl('^[0-9]{4}$', x))) { if (all(grepl('^[0-9]{4}$', x))) {
x x
@ -335,9 +334,9 @@ rsi_predict <- function(tbl,
as.integer(format(as.Date(x), '%Y')) as.integer(format(as.Date(x), '%Y'))
} }
} }
years_predict <- seq(from = min(year(tbl %>% pull(col_date))), to = year_max, by = year_every) years_predict <- seq(from = min(year(tbl %>% pull(col_date))), to = year_max, by = year_every)
df <- tbl %>% df <- tbl %>%
mutate(year = year(tbl %>% pull(col_date))) %>% mutate(year = year(tbl %>% pull(col_date))) %>%
group_by_at(c('year', col_ab)) %>% group_by_at(c('year', col_ab)) %>%
@ -345,7 +344,7 @@ rsi_predict <- function(tbl,
colnames(df) <- c('year', 'antibiotic', 'count') colnames(df) <- c('year', 'antibiotic', 'count')
df <- df %>% df <- df %>%
reshape2::dcast(year ~ antibiotic, value.var = 'count') reshape2::dcast(year ~ antibiotic, value.var = 'count')
if (model %in% c('binomial', 'binom', 'logit')) { if (model %in% c('binomial', 'binom', 'logit')) {
logitmodel <- with(df, glm(cbind(R, S) ~ year, family = binomial)) logitmodel <- with(df, glm(cbind(R, S) ~ year, family = binomial))
if (info == TRUE) { if (info == TRUE) {
@ -353,11 +352,11 @@ rsi_predict <- function(tbl,
cat('\n------------------------------------------------------------\n') cat('\n------------------------------------------------------------\n')
print(summary(logitmodel)) print(summary(logitmodel))
} }
predictmodel <- stats::predict(logitmodel, newdata = with(df, list(year = years_predict)), type = "response", se.fit = TRUE) predictmodel <- stats::predict(logitmodel, newdata = with(df, list(year = years_predict)), type = "response", se.fit = TRUE)
prediction <- predictmodel$fit prediction <- predictmodel$fit
se <- predictmodel$se.fit se <- predictmodel$se.fit
} else if (model == 'loglin') { } else if (model == 'loglin') {
loglinmodel <- with(df, glm(R ~ year, family = poisson)) loglinmodel <- with(df, glm(R ~ year, family = poisson))
if (info == TRUE) { if (info == TRUE) {
@ -365,11 +364,11 @@ rsi_predict <- function(tbl,
cat('\n--------------------------------------------------------------\n') cat('\n--------------------------------------------------------------\n')
print(summary(loglinmodel)) print(summary(loglinmodel))
} }
predictmodel <- stats::predict(loglinmodel, newdata = with(df, list(year = years_predict)), type = "response", se.fit = TRUE) predictmodel <- stats::predict(loglinmodel, newdata = with(df, list(year = years_predict)), type = "response", se.fit = TRUE)
prediction <- predictmodel$fit prediction <- predictmodel$fit
se <- predictmodel$se.fit se <- predictmodel$se.fit
} else if (model %in% c('lin', 'linear')) { } else if (model %in% c('lin', 'linear')) {
linmodel <- with(df, lm((R / (R + S)) ~ year)) linmodel <- with(df, lm((R / (R + S)) ~ year))
if (info == TRUE) { if (info == TRUE) {
@ -377,36 +376,36 @@ rsi_predict <- function(tbl,
cat('\n-----------------------\n') cat('\n-----------------------\n')
print(summary(linmodel)) print(summary(linmodel))
} }
predictmodel <- stats::predict(linmodel, newdata = with(df, list(year = years_predict)), se.fit = TRUE) predictmodel <- stats::predict(linmodel, newdata = with(df, list(year = years_predict)), se.fit = TRUE)
prediction <- predictmodel$fit prediction <- predictmodel$fit
se <- predictmodel$se.fit se <- predictmodel$se.fit
} else { } else {
stop('No valid model selected.') stop('No valid model selected.')
} }
# prepare the output dataframe # prepare the output dataframe
prediction <- data.frame(year = years_predict, probR = prediction, stringsAsFactors = FALSE) prediction <- data.frame(year = years_predict, probR = prediction, stringsAsFactors = FALSE)
prediction$se_min <- prediction$probR - se prediction$se_min <- prediction$probR - se
prediction$se_max <- prediction$probR + se prediction$se_max <- prediction$probR + se
if (model == 'loglin') { if (model == 'loglin') {
prediction$probR <- prediction$probR %>% prediction$probR <- prediction$probR %>%
format(scientific = FALSE) %>% format(scientific = FALSE) %>%
as.integer() as.integer()
prediction$se_min <- prediction$se_min %>% as.integer() prediction$se_min <- prediction$se_min %>% as.integer()
prediction$se_max <- prediction$se_max %>% as.integer() prediction$se_max <- prediction$se_max %>% as.integer()
colnames(prediction) <- c('year', 'amountR', 'se_max', 'se_min') colnames(prediction) <- c('year', 'amountR', 'se_max', 'se_min')
} else { } else {
prediction$se_max[which(prediction$se_max > 1)] <- 1 prediction$se_max[which(prediction$se_max > 1)] <- 1
} }
prediction$se_min[which(prediction$se_min < 0)] <- 0 prediction$se_min[which(prediction$se_min < 0)] <- 0
total <- prediction total <- prediction
if (preserve_measurements == TRUE) { if (preserve_measurements == TRUE) {
# geschatte data vervangen door gemeten data # geschatte data vervangen door gemeten data
if (I_as_R == TRUE) { if (I_as_R == TRUE) {
@ -424,10 +423,10 @@ rsi_predict <- function(tbl,
stringsAsFactors = FALSE) stringsAsFactors = FALSE)
colnames(measurements) <- colnames(prediction) colnames(measurements) <- colnames(prediction)
prediction <- prediction %>% filter(!year %in% df$year) prediction <- prediction %>% filter(!year %in% df$year)
total <- rbind(measurements, prediction) total <- rbind(measurements, prediction)
} }
total total
} }

2
README.md
View File

@ -30,7 +30,7 @@ This package is available on CRAN and also here on GitHub.
- `install.packages("AMR")` - `install.packages("AMR")`
- <img src="https://exploratory.io/favicon.ico" alt="Exploratory favicon" height="20px"> In [Exploratory.io](https://exploratory.io): - <img src="https://exploratory.io/favicon.ico" alt="Exploratory favicon" height="20px"> In [Exploratory.io](https://exploratory.io):
- (Exploratory.io costs $40/month but is free for students and teachers; if you have an `@umcg.nl` or `@rug.nl` email address, [click here to enroll](https://exploratory.io/plan?plan=Community)) - (Exploratory.io costs $40/month, but is free for students and teachers; if you have an `@umcg.nl` or `@rug.nl` email address, [click here to enroll](https://exploratory.io/plan?plan=Community))
- Start the software and log in - Start the software and log in
- Click on your username at the right hand side top - Click on your username at the right hand side top
- Click on `R Packages` - Click on `R Packages`

4
man/rsi.Rd
View File

@ -34,14 +34,14 @@ This function uses the \code{\link{rsi_df}} function internally.
tbl \%>\% tbl \%>\%
group_by(hospital) \%>\% group_by(hospital) \%>\%
summarise(cipr = rsi(cipr)) summarise(cipr = rsi(cipr))
tbl \%>\% tbl \%>\%
group_by(year, hospital) \%>\% group_by(year, hospital) \%>\%
summarise( summarise(
isolates = n(), isolates = n(),
cipro = rsi(cipr \%>\% as.rsi(), percent = TRUE), cipro = rsi(cipr \%>\% as.rsi(), percent = TRUE),
amoxi = rsi(amox \%>\% as.rsi(), percent = TRUE)) amoxi = rsi(amox \%>\% as.rsi(), percent = TRUE))
rsi(as.rsi(isolates$amox)) rsi(as.rsi(isolates$amox))
rsi(as.rsi(isolates$amcl), interpretation = "S") rsi(as.rsi(isolates$amcl), interpretation = "S")

2
man/rsi_df.Rd
View File

@ -40,7 +40,7 @@ rsi_df(tbl_with_bloodcultures, c('amcl', 'gent'), interpretation = 'IR')
library(dplyr) library(dplyr)
# calculate current empiric therapy of Helicobacter gastritis: # calculate current empiric therapy of Helicobacter gastritis:
my_table \%>\% my_table \%>\%
filter(first_isolate == TRUE, filter(first_isolate == TRUE,
genus == "Helicobacter") \%>\% genus == "Helicobacter") \%>\%
rsi_df(ab = c("amox", "metr")) rsi_df(ab = c("amox", "metr"))
} }

16
man/rsi_predict.Rd
View File

@ -39,7 +39,7 @@ Create a prediction model to predict antimicrobial resistance for the next years
# use it directly: # use it directly:
rsi_predict(tbl = tbl[which(first_isolate == TRUE & genus == "Haemophilus"),], rsi_predict(tbl = tbl[which(first_isolate == TRUE & genus == "Haemophilus"),],
col_ab = "amcl", col_date = "date") col_ab = "amcl", col_date = "date")
# or with dplyr so you can actually read it: # or with dplyr so you can actually read it:
library(dplyr) library(dplyr)
tbl \%>\% tbl \%>\%
@ -53,22 +53,22 @@ tbl \%>\%
library(dplyr) library(dplyr)
septic_patients \%>\% septic_patients \%>\%
# get bacteria properties like genus and species # get bacteria properties like genus and species
left_join_microorganisms("bactid") \%>\% left_join_microorganisms("bactid") \%>\%
# calculate first isolates # calculate first isolates
mutate(first_isolate = mutate(first_isolate =
first_isolate(., first_isolate(.,
"date", "date",
"patient_id", "patient_id",
"bactid", "bactid",
col_specimen = NA, col_specimen = NA,
col_icu = NA)) \%>\% col_icu = NA)) \%>\%
# filter on first E. coli isolates # filter on first E. coli isolates
filter(genus == "Escherichia", filter(genus == "Escherichia",
species == "coli", species == "coli",
first_isolate == TRUE) \%>\% first_isolate == TRUE) \%>\%
# predict resistance of cefotaxime for next years # predict resistance of cefotaxime for next years
rsi_predict(col_ab = cfot, rsi_predict(col_ab = "cfot",
col_date = date, col_date = "date",
year_max = 2025, year_max = 2025,
preserve_measurements = FALSE) preserve_measurements = FALSE)

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

@ -9,6 +9,7 @@ test_that("atc_property works", {
test_that("abname works", { test_that("abname works", {
expect_equal(abname("AMOX"), "Amoxicillin") expect_equal(abname("AMOX"), "Amoxicillin")
expect_equal(abname(c("AMOX", "GENT")), c("Amoxicillin", "Gentamicin")) expect_equal(abname(c("AMOX", "GENT")), c("Amoxicillin", "Gentamicin"))
expect_equal(abname(c("AMOX+GENT")), "Amoxicillin + gentamicin")
expect_equal(abname("AMOX", from = 'umcg'), "Amoxicillin") expect_equal(abname("AMOX", from = 'umcg'), "Amoxicillin")
expect_equal(abname("amox", from = 'molis'), "Amoxicillin") expect_equal(abname("amox", from = 'molis'), "Amoxicillin")
expect_equal(abname("J01CA04", from = 'atc'), "Amoxicillin") expect_equal(abname("J01CA04", from = 'atc'), "Amoxicillin")

22
tests/testthat/test-classes.R
View File

@ -5,11 +5,14 @@ test_that("rsi works", {
expect_true(as.rsi("I") < as.rsi("R")) expect_true(as.rsi("I") < as.rsi("R"))
expect_true(as.rsi("R") > as.rsi("S")) expect_true(as.rsi("R") > as.rsi("S"))
expect_true(is.rsi(as.rsi("S"))) expect_true(is.rsi(as.rsi("S")))
# print plots, should not raise errors
barplot(as.rsi(c("S", "I", "R")))
plot(as.rsi(c("S", "I", "R")))
print(as.rsi(c("S", "I", "R")))
expect_equal(suppressWarnings(as.logical(as.rsi("INVALID VALUE"))), NA) expect_equal(suppressWarnings(as.logical(as.rsi("INVALID VALUE"))), NA)
expect_equal(class(barplot(as.rsi(c("S", "I", "R")))), "numeric")
expect_equal(summary(as.rsi(c("S", "R"))), c("Mode" = 'rsi', expect_equal(summary(as.rsi(c("S", "R"))), c("Mode" = 'rsi',
"<NA>" = "0", "<NA>" = "0",
"Sum S" = "1", "Sum S" = "1",
@ -23,13 +26,16 @@ test_that("mic works", {
expect_true(as.mic("1") > as.mic("<=0.0625")) expect_true(as.mic("1") > as.mic("<=0.0625"))
expect_true(as.mic("1") < as.mic(">=32")) expect_true(as.mic("1") < as.mic(">=32"))
expect_true(is.mic(as.mic(8))) expect_true(is.mic(as.mic(8)))
expect_equal(as.double(as.mic(">=32")), 32) expect_equal(as.double(as.mic(">=32")), 32)
expect_equal(as.integer(as.mic(">=32")), 32) expect_equal(as.integer(as.mic(">=32")), 32)
expect_equal(suppressWarnings(as.logical(as.mic("INVALID VALUE"))), NA) expect_equal(suppressWarnings(as.logical(as.mic("INVALID VALUE"))), NA)
expect_equal(class(plot(as.mic(c(1, 2, 4, 8)))), "numeric") # print plots, should not raise errors
barplot(as.mic(c(1, 2, 4, 8)))
plot(as.mic(c(1, 2, 4, 8)))
print(as.mic(c(1, 2, 4, 8)))
expect_equal(summary(as.mic(c(2, 8))), c("Mode" = 'mic', expect_equal(summary(as.mic(c(2, 8))), c("Mode" = 'mic',
"<NA>" = "0", "<NA>" = "0",
"Min." = "2", "Min." = "2",

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

@ -12,8 +12,8 @@ test_that("EUCAST rules work", {
amox = "R", # Amoxicillin amox = "R", # Amoxicillin
stringsAsFactors = FALSE) stringsAsFactors = FALSE)
expect_equal(EUCAST_rules(a, info = FALSE), b) expect_equal(EUCAST_rules(a, info = FALSE), b)
expect_equal(interpretive_reading(a, info = FALSE), b) expect_equal(suppressWarnings(interpretive_reading(a, info = TRUE)), b)
a <- data.frame(bactid = c("STAAUR", # Staphylococcus aureus a <- data.frame(bactid = c("STAAUR", # Staphylococcus aureus
"STCGRA"), # Streptococcus pyognenes (Lancefield Group A) "STCGRA"), # Streptococcus pyognenes (Lancefield Group A)
coli = "-", # Colistin coli = "-", # Colistin

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

@ -7,7 +7,6 @@ test_that("keyantibiotics work", {
expect_false(key_antibiotics_equal("SSS", "SIS", ignore_I = FALSE)) expect_false(key_antibiotics_equal("SSS", "SIS", ignore_I = FALSE))
}) })
test_that("guess_bactid works", { test_that("guess_bactid works", {
expect_equal(guess_bactid("E. coli"), "ESCCOL") expect_equal(guess_bactid("E. coli"), "ESCCOL")
expect_equal(guess_bactid("Escherichia coli"), "ESCCOL") expect_equal(guess_bactid("Escherichia coli"), "ESCCOL")
@ -15,9 +14,23 @@ test_that("guess_bactid works", {
test_that("first isolates work", { test_that("first isolates work", {
# septic_patients contains 1960 out of 2000 first isolates # septic_patients contains 1960 out of 2000 first isolates
expect_equal(sum(first_isolate(septic_patients, septic_ptns <- septic_patients
"date", expect_equal(sum(first_isolate(tbl = septic_ptns,
"patient_id", col_date = "date",
"bactid", col_patient_id = "patient_id",
info = FALSE)), 1960) col_bactid = "bactid",
info = FALSE)), 1960)
# septic_patients contains 1962 out of 2000 first weighted isolates
septic_ptns$keyab <- suppressWarnings(key_antibiotics(septic_ptns))
expect_equal(
suppressWarnings(sum(
first_isolate(tbl = septic_ptns,
col_date = "date",
col_patient_id = "patient_id",
col_bactid = "bactid",
col_keyantibiotics = "keyab",
type = "keyantibiotics",
info = TRUE))),
1962)
}) })

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

@ -12,9 +12,3 @@ test_that("percentages works", {
expect_equal(percent(0.5), "50%") expect_equal(percent(0.5), "50%")
expect_equal(percent(0.1234), "12.3%") expect_equal(percent(0.1234), "12.3%")
}) })
test_that("quasiquotation works", {
expect_equal(quasiquotate(deparse(substitute("test")), "test"), "test")
expect_equal(quasiquotate(deparse(substitute('test')), "'test'"), "test")
expect_equal(quasiquotate(deparse(substitute(test)), test), "test")
})