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

(v0.8.0.9012) mdro improvement

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends 2019-11-05 11:28:52 +01:00
parent fe606e287b
commit 5345d2759a
12 changed files with 73 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
DESCRIPTION
View File

@ -1,6 +1,6 @@
Package: AMR Package: AMR
Version: 0.8.0.9011 Version: 0.8.0.9012
Date: 2019-11-04 Date: 2019-11-05
Title: Antimicrobial Resistance Analysis Title: Antimicrobial Resistance Analysis
Authors@R: c( Authors@R: c(
person(role = c("aut", "cre"), person(role = c("aut", "cre"),

6
NEWS.md
View File

@ -1,10 +1,10 @@
# AMR 0.8.0.9011 # AMR 0.8.0.9012
<small>Last updated: 04-Nov-2019</small> <small>Last updated: 05-Nov-2019</small>
### New ### New
* Support for a new MDRO guideline: Magiorakos AP, Srinivasan A *et al.* "Multidrug-resistant, extensively drug-resistant and pandrug-resistant bacteria: an international expert proposal for interim standard definitions for acquired resistance." Clinical Microbiology and Infection (2012). * Support for a new MDRO guideline: Magiorakos AP, Srinivasan A *et al.* "Multidrug-resistant, extensively drug-resistant and pandrug-resistant bacteria: an international expert proposal for interim standard definitions for acquired resistance." Clinical Microbiology and Infection (2012).
* This is now the new default guideline for the `mdro()` function * This is now the new default guideline for the `mdro()` function
* The new Verbose mode (`mdro(...., verbose = TRUE)`) returns an informative data set where the reason for MDRO determination is given for every isolate * The new Verbose mode (`mdro(...., verbose = TRUE)`) returns an informative data set where the reason for MDRO determination is given for every isolate, and an list of the resistant antimicrobial agents
### Changes ### Changes
* When running `as.rsi()` over a data set, it will now print the guideline that will be used if it is not specified by the user * When running `as.rsi()` over a data set, it will now print the guideline that will be used if it is not specified by the user

75
R/mdro.R
View File

@ -48,7 +48,7 @@
#' \item{Everything else:\cr Ordered factor with levels \code{Negative < Positive, unconfirmed < Positive}. The value \code{"Positive, unconfirmed"} means that, according to the guideline, it is not entirely sure if the isolate is multi-drug resistant and this should be confirmed with additional (e.g. molecular) tests} #' \item{Everything else:\cr Ordered factor with levels \code{Negative < Positive, unconfirmed < Positive}. The value \code{"Positive, unconfirmed"} means that, according to the guideline, it is not entirely sure if the isolate is multi-drug resistant and this should be confirmed with additional (e.g. molecular) tests}
#' } #' }
#' @rdname mdro #' @rdname mdro
#' @importFrom dplyr %>% filter_at vars all_vars pull #' @importFrom dplyr %>% filter_at vars all_vars pull mutate_at
#' @importFrom crayon blue bold italic #' @importFrom crayon blue bold italic
#' @importFrom cleaner percentage #' @importFrom cleaner percentage
#' @export #' @export
@ -439,6 +439,15 @@ mdro <- function(x,
cols <- cols[!ab_missing(cols)] cols <- cols[!ab_missing(cols)]
cols <- cols[!is.na(cols)] cols <- cols[!is.na(cols)]
if (length(rows) > 0 & length(cols) > 0) { if (length(rows) > 0 & length(cols) > 0) {
#print(cols)
x <<- x %>% mutate_at(vars(cols), as.rsi)
x[rows, "columns_nonsusceptible"] <<- sapply(rows,
function(row, group_vct = cols) {
cols_nonsus <- sapply(x[row, group_vct, drop = FALSE], function(y) y == "R")
paste(sort(c(unlist(strsplit(x[row, "columns_nonsusceptible", drop = TRUE], ", ")),
names(cols_nonsus)[cols_nonsus])),
collapse = ", ")
})
if (any_all == "any") { if (any_all == "any") {
row_filter <- which(x[, cols] == "R") row_filter <- which(x[, cols] == "R")
} else if (any_all == "all") { } else if (any_all == "all") {
@ -449,8 +458,7 @@ mdro <- function(x,
} }
rows <- rows[rows %in% row_filter] rows <- rows[rows %in% row_filter]
x[rows, "MDRO"] <<- to x[rows, "MDRO"] <<- to
x[rows, "reason"] <<- paste0(any_all, " of these ", ifelse(any_all == "any", "is", "are"), " R: ", x[rows, "reason"] <<- paste0(any_all, " of the required antibiotics ", ifelse(any_all == "any", "is", "are"), " R")
paste(cols, collapse = ", "))
} }
} }
trans_tbl2 <- function(txt, rows, lst) { trans_tbl2 <- function(txt, rows, lst) {
@ -460,16 +468,20 @@ mdro <- function(x,
if (length(rows) > 0) { if (length(rows) > 0) {
# function specific for the CMI paper of 2012 (Magiorakos et al.) # function specific for the CMI paper of 2012 (Magiorakos et al.)
lst_vector <- unlist(lst)[!is.na(unlist(lst))] lst_vector <- unlist(lst)[!is.na(unlist(lst))]
x <<- x %>% mutate_at(vars(lst_vector), as.rsi)
x[rows, "classes_in_guideline"] <<- length(lst) x[rows, "classes_in_guideline"] <<- length(lst)
x[rows, "classes_available"] <<- sapply(rows, x[rows, "classes_available"] <<- sapply(rows,
function(row, group_tbl = lst) { function(row, group_tbl = lst) {
sum(sapply(group_tbl, function(group) !all(is.na(group)))) sum(sapply(group_tbl, function(group) any(unlist(x[row, group[!is.na(group)], drop = TRUE]) %in% c("S", "I", "R"))))
}) })
# now the hard part - using two sapply()s for super fast results:
# [1] run through all `rows` with sapply() if (verbose == TRUE) {
# [2] within each row, run through all antibiotic classes with another sapply() x[rows, "columns_nonsusceptible"] <<- sapply(rows,
# [3] determine for each antibiotic group in that row if at least 1 drug is R of I function(row, group_vct = lst_vector) {
# [4] sum the number of TRUEs of this determination cols_nonsus <- sapply(x[row, group_vct, drop = FALSE], function(y) y %in% c("I", "R"))
paste(sort(names(cols_nonsus)[cols_nonsus]), collapse = ", ")
})
}
x[rows, "classes_affected"] <<- sapply(rows, x[rows, "classes_affected"] <<- sapply(rows,
function(row, group_tbl = lst) { function(row, group_tbl = lst) {
sum(sapply(group_tbl, sum(sapply(group_tbl,
@ -479,7 +491,7 @@ mdro <- function(x,
}), }),
na.rm = TRUE) na.rm = TRUE)
}) })
x[filter_at(x[rows,], x[filter_at(x[rows, ],
vars(lst_vector), vars(lst_vector),
all_vars(. %in% c("R", "I")))$row_number, "classes_affected"] <<- 999 all_vars(. %in% c("R", "I")))$row_number, "classes_affected"] <<- 999
} }
@ -496,7 +508,8 @@ mdro <- function(x,
# add unavailable to where genus is available # add unavailable to where genus is available
mutate(MDRO = ifelse(!is.na(genus), 1, NA_integer_), mutate(MDRO = ifelse(!is.na(genus), 1, NA_integer_),
row_number = seq_len(nrow(.)), row_number = seq_len(nrow(.)),
reason = paste0("not covered by ", toupper(guideline$code), " guideline")) %>% reason = paste0("not covered by ", toupper(guideline$code), " guideline"),
columns_nonsusceptible = "") %>%
# transform to data.frame so subsetting is possible with x[y, z] (might not be the case with tibble/data.table/...) # transform to data.frame so subsetting is possible with x[y, z] (might not be the case with tibble/data.table/...)
as.data.frame(stringsAsFactors = FALSE) as.data.frame(stringsAsFactors = FALSE)
@ -690,29 +703,30 @@ mdro <- function(x,
x[which(x$classes_affected >= 3), "reason"] <- paste0("at least 3 classes contain R or I: ", x$classes_affected[which(x$classes_affected >= 3)], x[which(x$classes_affected >= 3), "reason"] <- paste0("at least 3 classes contain R or I: ", x$classes_affected[which(x$classes_affected >= 3)],
" out of ", x$classes_available[which(x$classes_affected >= 3)], " available classes") " out of ", x$classes_available[which(x$classes_affected >= 3)], " available classes")
} }
# XDR (=3): all but <=2 classes affected # XDR (=3): all but <=2 classes affected
x[which((x$classes_in_guideline - x$classes_affected) <= 2), "MDRO"] <- 3 x[which((x$classes_in_guideline - x$classes_affected) <= 2), "MDRO"] <- 3
if (verbose == TRUE) { if (verbose == TRUE) {
x[which((x$classes_in_guideline - x$classes_affected) <= 2), "reason"] <- paste0("less than 3 classes remain susceptible (", x$classes_in_guideline[which((x$classes_in_guideline - x$classes_affected) <= 2)] - x$classes_affected[which((x$classes_in_guideline - x$classes_affected) <= 2)], x[which(x$MDRO == 3), "reason"] <- paste0("less than 3 classes remain susceptible (", x$classes_in_guideline[which((x$classes_in_guideline - x$classes_affected) <= 2)] - x$classes_affected[which(x$MDRO == 3)],
" out of ", x$classes_in_guideline[which((x$classes_in_guideline - x$classes_affected) <= 2)], " classes)") " out of ", x$classes_in_guideline[which(x$MDRO == 3)], " classes)")
} }
# PDR (=4): all agents are R # PDR (=4): all agents are R
x[which(x$classes_affected == 999 & x$classes_in_guideline == x$classes_available), "MDRO"] <- 4 x[which(x$classes_affected == 999 & x$classes_in_guideline == x$classes_available), "MDRO"] <- 4
if (verbose == TRUE) { if (verbose == TRUE) {
x[which(x$classes_affected == 999 & x$classes_in_guideline == x$classes_available), "reason"] <- paste("all antibiotics in all", x$classes_in_guideline[which(x$classes_affected == 999 & x$classes_in_guideline == x$classes_available)], "classes were tested R or I") x[which(x$MDRO == 4), "reason"] <- paste("all antibiotics in all", x$classes_in_guideline[which(x$MDRO == 4)], "classes were tested R or I")
} }
# not enough classes available # not enough classes available
x[which(x$classes_available < base::floor(x$classes_in_guideline * pct_required_classes)), "MDRO"] <- -1 x[which(x$MDRO %in% c(1, 3) & x$classes_available < base::floor(x$classes_in_guideline * pct_required_classes)), "MDRO"] <- -1
if (verbose == TRUE) { if (verbose == TRUE) {
x[which(x$classes_available < base::floor(x$classes_in_guideline * pct_required_classes)), "reason"] <- paste0("not enough classes available: ", x$classes_available[which(x$classes_available < base::floor(x$classes_in_guideline * pct_required_classes))], x[which(x$MDRO == -1), "reason"] <- paste0("not enough classes available: ", x$classes_available[which(x$MDRO == -1)],
" instead of ", (base::floor(x$classes_in_guideline * pct_required_classes))[which(x$classes_available < base::floor(x$classes_in_guideline * pct_required_classes))], " of required ", (base::floor(x$classes_in_guideline * pct_required_classes))[which(x$MDRO == -1)],
" (~", percentage(pct_required_classes), " of ", x$classes_in_guideline[which(x$classes_available < base::floor(x$classes_in_guideline * pct_required_classes))], ")") " (~", percentage(pct_required_classes), " of ", x$classes_in_guideline[which(x$MDRO == -1)], ")")
}
# some more info on negative results
if (verbose == TRUE) {
x[which(x$MDRO == 1 & !is.na(x$classes_affected)), "reason"] <- paste0(x$classes_affected[which(x$MDRO == 1 & !is.na(x$classes_affected))], " of ", x$classes_available[which(x$MDRO == 1 & !is.na(x$classes_affected))], " available classes contain R or I (3 required for MDR)")
} }
# add antibiotic names of resistant ones to verbose output
} }
if (guideline$code == "eucast") { if (guideline$code == "eucast") {
@ -973,6 +987,15 @@ mdro <- function(x,
" tested isolates (", percentage(sum(x$MDRO %in% c(2:5), na.rm = TRUE) / sum(!is.na(x$MDRO))), ")\n"))) " tested isolates (", percentage(sum(x$MDRO %in% c(2:5), na.rm = TRUE) / sum(!is.na(x$MDRO))), ")\n")))
} }
# some more info on negative results
if (verbose == TRUE ) {
if (guideline$code == "cmi2012") {
x[which(x$MDRO == 1 & !is.na(x$classes_affected)), "reason"] <- paste0(x$classes_affected[which(x$MDRO == 1 & !is.na(x$classes_affected))], " of ", x$classes_available[which(x$MDRO == 1 & !is.na(x$classes_affected))], " available classes contain R or I (3 required for MDR)")
} else {
x[which(x$MDRO == 1), "reason"] <- "too few antibiotics are R"
}
}
# Results ---- # Results ----
if (guideline$code == "cmi2012") { if (guideline$code == "cmi2012") {
if (any(x$MDRO == -1, na.rm = TRUE)) { if (any(x$MDRO == -1, na.rm = TRUE)) {
@ -1008,7 +1031,9 @@ mdro <- function(x,
x[, c("row_number", x[, c("row_number",
col_mo, col_mo,
"MDRO", "MDRO",
"reason")] "reason",
"columns_nonsusceptible")]
#x
} else { } else {
x$MDRO x$MDRO
} }

6
R/rsi.R
View File

@ -99,6 +99,12 @@ as.rsi.default <- function(x, ...) {
x x
} else if (identical(levels(x), c("S", "I", "R"))) { } else if (identical(levels(x), c("S", "I", "R"))) {
structure(x, class = c("rsi", "ordered", "factor")) structure(x, class = c("rsi", "ordered", "factor"))
} else if (identical(class(x), "integer") & all(x %in% c(1:3, NA))) {
x[x == 1] <- "S"
x[x == 2] <- "I"
x[x == 3] <- "R"
structure(.Data = factor(x, levels = c("S", "I", "R"), ordered = TRUE),
class = c("rsi", "ordered", "factor"))
} else { } else {
x <- x %>% unlist() x <- x %>% unlist()

2
docs/404.html
View File

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

2
docs/LICENSE-text.html
View File

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

2
docs/articles/index.html
View File

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

2
docs/authors.html
View File

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

2
docs/index.html
View File

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

10
docs/news/index.html
View File

@ -84,7 +84,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a> <a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">0.8.0.9011</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">0.8.0.9012</span>
</span> </span>
</div> </div>
@ -231,11 +231,11 @@
</div> </div>
<div id="amr-0-8-0-9011" class="section level1"> <div id="amr-0-8-0-9012" class="section level1">
<h1 class="page-header"> <h1 class="page-header">
<a href="#amr-0-8-0-9011" class="anchor"></a>AMR 0.8.0.9011<small> Unreleased </small> <a href="#amr-0-8-0-9012" class="anchor"></a>AMR 0.8.0.9012<small> Unreleased </small>
</h1> </h1>
<p><small>Last updated: 04-Nov-2019</small></p> <p><small>Last updated: 05-Nov-2019</small></p>
<div id="new" class="section level3"> <div id="new" class="section level3">
<h3 class="hasAnchor"> <h3 class="hasAnchor">
<a href="#new" class="anchor"></a>New</h3> <a href="#new" class="anchor"></a>New</h3>
@ -1333,7 +1333,7 @@ Using <code><a href="../reference/as.mo.html">as.mo(..., allow_uncertain = 3)</a
<div id="tocnav"> <div id="tocnav">
<h2>Contents</h2> <h2>Contents</h2>
<ul class="nav nav-pills nav-stacked"> <ul class="nav nav-pills nav-stacked">
<li><a href="#amr-0-8-0-9011">0.8.0.9011</a></li> <li><a href="#amr-0-8-0-9012">0.8.0.9012</a></li>
<li><a href="#amr-0-8-0">0.8.0</a></li> <li><a href="#amr-0-8-0">0.8.0</a></li>
<li><a href="#amr-0-7-1">0.7.1</a></li> <li><a href="#amr-0-7-1">0.7.1</a></li>
<li><a href="#amr-0-7-0">0.7.0</a></li> <li><a href="#amr-0-7-0">0.7.0</a></li>

2
docs/reference/index.html
View File

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

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

@ -32,7 +32,7 @@ test_that("mdro works", {
expect_error(mdro(example_isolates, guideline = c("BRMO", "MRGN"), info = TRUE)) expect_error(mdro(example_isolates, guideline = c("BRMO", "MRGN"), info = TRUE))
expect_error(mdro(example_isolates, col_mo = "invalid", info = TRUE)) expect_error(mdro(example_isolates, col_mo = "invalid", info = TRUE))
outcome <- mdro(example_isolates) outcome <- suppressWarnings(mdro(example_isolates))
outcome <- eucast_exceptional_phenotypes(example_isolates, info = TRUE) outcome <- eucast_exceptional_phenotypes(example_isolates, info = TRUE)
# check class # check class
expect_equal(outcome %>% class(), c("ordered", "factor")) expect_equal(outcome %>% class(), c("ordered", "factor"))