mirror of
https://github.com/msberends/AMR.git
synced 2025-07-08 12:31:58 +02:00
cfta streptococci, codecov.yml
This commit is contained in:
154
R/mdro.R
154
R/mdro.R
@ -27,9 +27,10 @@
|
||||
#' @param info print progress
|
||||
#' @inheritParams eucast_rules
|
||||
#' @param metr column name of an antibiotic, see Antibiotics
|
||||
#' @param verbose print additional info: missing antibiotic columns per parameter
|
||||
#' @param ... parameters that are passed on to methods
|
||||
#' @inheritSection eucast_rules Antibiotics
|
||||
#' @details When \code{country} will be left blank, guidelines will be taken from EUCAST Expert Rules Version 3.1 "Intrinsic Resistance and Exceptional Phenotypes Tables" (\url{http://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/Expert_rules_intrinsic_exceptional_V3.1.pdf}).
|
||||
#' @details When \code{country} will be left blank, guidelines will be taken from EUCAST Expert Rules Version 3.1 "Intrinsic Resistance and Exceptional Phenotypes Tables" (\href{http://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/Expert_rules_intrinsic_exceptional_V3.1.pdf}{link}).
|
||||
#' @return Ordered factor with levels \code{Negative < Positive, unconfirmed < Positive}.
|
||||
#' @rdname mdro
|
||||
#' @importFrom dplyr %>%
|
||||
@ -105,7 +106,8 @@ mdro <- function(tbl,
|
||||
tobr = guess_ab_col(),
|
||||
trim = guess_ab_col(),
|
||||
trsu = guess_ab_col(),
|
||||
vanc = guess_ab_col()) {
|
||||
vanc = guess_ab_col(),
|
||||
verbose = FALSE) {
|
||||
|
||||
if (!is.data.frame(tbl)) {
|
||||
stop("`tbl` must be a data frame.", call. = FALSE)
|
||||
@ -152,9 +154,9 @@ mdro <- function(tbl,
|
||||
guideline$name <- 'WIP-Richtlijn BRMO'
|
||||
guideline$version <- 'Revision as of December 2017'
|
||||
guideline$source <- 'https://www.rivm.nl/Documenten_en_publicaties/Professioneel_Praktisch/Richtlijnen/Infectieziekten/WIP_Richtlijnen/WIP_Richtlijnen/Ziekenhuizen/WIP_richtlijn_BRMO_Bijzonder_Resistente_Micro_Organismen_ZKH'
|
||||
# add here more countries like this:
|
||||
# } else if (country$code == 'xx') {
|
||||
# country$name <- 'country name'
|
||||
# add here more countries like this:
|
||||
# } else if (country$code == 'xx') {
|
||||
# country$name <- 'country name'
|
||||
} else {
|
||||
stop('This country code is currently unsupported: ', guideline$country$code, call. = FALSE)
|
||||
}
|
||||
@ -168,66 +170,66 @@ mdro <- function(tbl,
|
||||
}
|
||||
|
||||
# check columns
|
||||
if (identical(amcl, as.name("guess_ab_col"))) { amcl <- guess_ab_col(tbl, "amcl", verbose = info) }
|
||||
if (identical(amik, as.name("guess_ab_col"))) { amik <- guess_ab_col(tbl, "amik", verbose = info) }
|
||||
if (identical(amox, as.name("guess_ab_col"))) { amox <- guess_ab_col(tbl, "amox", verbose = info) }
|
||||
if (identical(ampi, as.name("guess_ab_col"))) { ampi <- guess_ab_col(tbl, "ampi", verbose = info) }
|
||||
if (identical(azit, as.name("guess_ab_col"))) { azit <- guess_ab_col(tbl, "azit", verbose = info) }
|
||||
if (identical(aztr, as.name("guess_ab_col"))) { aztr <- guess_ab_col(tbl, "aztr", verbose = info) }
|
||||
if (identical(cefa, as.name("guess_ab_col"))) { cefa <- guess_ab_col(tbl, "cefa", verbose = info) }
|
||||
if (identical(cfra, as.name("guess_ab_col"))) { cfra <- guess_ab_col(tbl, "cfra", verbose = info) }
|
||||
if (identical(cfep, as.name("guess_ab_col"))) { cfep <- guess_ab_col(tbl, "cfep", verbose = info) }
|
||||
if (identical(cfot, as.name("guess_ab_col"))) { cfot <- guess_ab_col(tbl, "cfot", verbose = info) }
|
||||
if (identical(cfox, as.name("guess_ab_col"))) { cfox <- guess_ab_col(tbl, "cfox", verbose = info) }
|
||||
if (identical(cfta, as.name("guess_ab_col"))) { cfta <- guess_ab_col(tbl, "cfta", verbose = info) }
|
||||
if (identical(cftr, as.name("guess_ab_col"))) { cftr <- guess_ab_col(tbl, "cftr", verbose = info) }
|
||||
if (identical(cfur, as.name("guess_ab_col"))) { cfur <- guess_ab_col(tbl, "cfur", verbose = info) }
|
||||
if (identical(chlo, as.name("guess_ab_col"))) { chlo <- guess_ab_col(tbl, "chlo", verbose = info) }
|
||||
if (identical(cipr, as.name("guess_ab_col"))) { cipr <- guess_ab_col(tbl, "cipr", verbose = info) }
|
||||
if (identical(clar, as.name("guess_ab_col"))) { clar <- guess_ab_col(tbl, "clar", verbose = info) }
|
||||
if (identical(clin, as.name("guess_ab_col"))) { clin <- guess_ab_col(tbl, "clin", verbose = info) }
|
||||
if (identical(clox, as.name("guess_ab_col"))) { clox <- guess_ab_col(tbl, "clox", verbose = info) }
|
||||
if (identical(coli, as.name("guess_ab_col"))) { coli <- guess_ab_col(tbl, "coli", verbose = info) }
|
||||
if (identical(czol, as.name("guess_ab_col"))) { czol <- guess_ab_col(tbl, "czol", verbose = info) }
|
||||
if (identical(dapt, as.name("guess_ab_col"))) { dapt <- guess_ab_col(tbl, "dapt", verbose = info) }
|
||||
if (identical(doxy, as.name("guess_ab_col"))) { doxy <- guess_ab_col(tbl, "doxy", verbose = info) }
|
||||
if (identical(erta, as.name("guess_ab_col"))) { erta <- guess_ab_col(tbl, "erta", verbose = info) }
|
||||
if (identical(eryt, as.name("guess_ab_col"))) { eryt <- guess_ab_col(tbl, "eryt", verbose = info) }
|
||||
if (identical(fosf, as.name("guess_ab_col"))) { fosf <- guess_ab_col(tbl, "fosf", verbose = info) }
|
||||
if (identical(fusi, as.name("guess_ab_col"))) { fusi <- guess_ab_col(tbl, "fusi", verbose = info) }
|
||||
if (identical(gent, as.name("guess_ab_col"))) { gent <- guess_ab_col(tbl, "gent", verbose = info) }
|
||||
if (identical(imip, as.name("guess_ab_col"))) { imip <- guess_ab_col(tbl, "imip", verbose = info) }
|
||||
if (identical(kana, as.name("guess_ab_col"))) { kana <- guess_ab_col(tbl, "kana", verbose = info) }
|
||||
if (identical(levo, as.name("guess_ab_col"))) { levo <- guess_ab_col(tbl, "levo", verbose = info) }
|
||||
if (identical(linc, as.name("guess_ab_col"))) { linc <- guess_ab_col(tbl, "linc", verbose = info) }
|
||||
if (identical(line, as.name("guess_ab_col"))) { line <- guess_ab_col(tbl, "line", verbose = info) }
|
||||
if (identical(mero, as.name("guess_ab_col"))) { mero <- guess_ab_col(tbl, "mero", verbose = info) }
|
||||
if (identical(metr, as.name("guess_ab_col"))) { metr <- guess_ab_col(tbl, "metr", verbose = info) }
|
||||
if (identical(mino, as.name("guess_ab_col"))) { mino <- guess_ab_col(tbl, "mino", verbose = info) }
|
||||
if (identical(moxi, as.name("guess_ab_col"))) { moxi <- guess_ab_col(tbl, "moxi", verbose = info) }
|
||||
if (identical(nali, as.name("guess_ab_col"))) { nali <- guess_ab_col(tbl, "nali", verbose = info) }
|
||||
if (identical(neom, as.name("guess_ab_col"))) { neom <- guess_ab_col(tbl, "neom", verbose = info) }
|
||||
if (identical(neti, as.name("guess_ab_col"))) { neti <- guess_ab_col(tbl, "neti", verbose = info) }
|
||||
if (identical(nitr, as.name("guess_ab_col"))) { nitr <- guess_ab_col(tbl, "nitr", verbose = info) }
|
||||
if (identical(novo, as.name("guess_ab_col"))) { novo <- guess_ab_col(tbl, "novo", verbose = info) }
|
||||
if (identical(norf, as.name("guess_ab_col"))) { norf <- guess_ab_col(tbl, "norf", verbose = info) }
|
||||
if (identical(oflo, as.name("guess_ab_col"))) { oflo <- guess_ab_col(tbl, "oflo", verbose = info) }
|
||||
if (identical(peni, as.name("guess_ab_col"))) { peni <- guess_ab_col(tbl, "peni", verbose = info) }
|
||||
if (identical(pipe, as.name("guess_ab_col"))) { pipe <- guess_ab_col(tbl, "pipe", verbose = info) }
|
||||
if (identical(pita, as.name("guess_ab_col"))) { pita <- guess_ab_col(tbl, "pita", verbose = info) }
|
||||
if (identical(poly, as.name("guess_ab_col"))) { poly <- guess_ab_col(tbl, "poly", verbose = info) }
|
||||
if (identical(qida, as.name("guess_ab_col"))) { qida <- guess_ab_col(tbl, "qida", verbose = info) }
|
||||
if (identical(rifa, as.name("guess_ab_col"))) { rifa <- guess_ab_col(tbl, "rifa", verbose = info) }
|
||||
if (identical(roxi, as.name("guess_ab_col"))) { roxi <- guess_ab_col(tbl, "roxi", verbose = info) }
|
||||
if (identical(siso, as.name("guess_ab_col"))) { siso <- guess_ab_col(tbl, "siso", verbose = info) }
|
||||
if (identical(teic, as.name("guess_ab_col"))) { teic <- guess_ab_col(tbl, "teic", verbose = info) }
|
||||
if (identical(tetr, as.name("guess_ab_col"))) { tetr <- guess_ab_col(tbl, "tetr", verbose = info) }
|
||||
if (identical(tica, as.name("guess_ab_col"))) { tica <- guess_ab_col(tbl, "tica", verbose = info) }
|
||||
if (identical(tige, as.name("guess_ab_col"))) { tige <- guess_ab_col(tbl, "tige", verbose = info) }
|
||||
if (identical(tobr, as.name("guess_ab_col"))) { tobr <- guess_ab_col(tbl, "tobr", verbose = info) }
|
||||
if (identical(trim, as.name("guess_ab_col"))) { trim <- guess_ab_col(tbl, "trim", verbose = info) }
|
||||
if (identical(trsu, as.name("guess_ab_col"))) { trsu <- guess_ab_col(tbl, "trsu", verbose = info) }
|
||||
if (identical(vanc, as.name("guess_ab_col"))) { vanc <- guess_ab_col(tbl, "vanc", verbose = info) }
|
||||
if (identical(amcl, as.name("guess_ab_col"))) { amcl <- guess_ab_col(tbl, "amcl", verbose = verbose) }
|
||||
if (identical(amik, as.name("guess_ab_col"))) { amik <- guess_ab_col(tbl, "amik", verbose = verbose) }
|
||||
if (identical(amox, as.name("guess_ab_col"))) { amox <- guess_ab_col(tbl, "amox", verbose = verbose) }
|
||||
if (identical(ampi, as.name("guess_ab_col"))) { ampi <- guess_ab_col(tbl, "ampi", verbose = verbose) }
|
||||
if (identical(azit, as.name("guess_ab_col"))) { azit <- guess_ab_col(tbl, "azit", verbose = verbose) }
|
||||
if (identical(aztr, as.name("guess_ab_col"))) { aztr <- guess_ab_col(tbl, "aztr", verbose = verbose) }
|
||||
if (identical(cefa, as.name("guess_ab_col"))) { cefa <- guess_ab_col(tbl, "cefa", verbose = verbose) }
|
||||
if (identical(cfra, as.name("guess_ab_col"))) { cfra <- guess_ab_col(tbl, "cfra", verbose = verbose) }
|
||||
if (identical(cfep, as.name("guess_ab_col"))) { cfep <- guess_ab_col(tbl, "cfep", verbose = verbose) }
|
||||
if (identical(cfot, as.name("guess_ab_col"))) { cfot <- guess_ab_col(tbl, "cfot", verbose = verbose) }
|
||||
if (identical(cfox, as.name("guess_ab_col"))) { cfox <- guess_ab_col(tbl, "cfox", verbose = verbose) }
|
||||
if (identical(cfta, as.name("guess_ab_col"))) { cfta <- guess_ab_col(tbl, "cfta", verbose = verbose) }
|
||||
if (identical(cftr, as.name("guess_ab_col"))) { cftr <- guess_ab_col(tbl, "cftr", verbose = verbose) }
|
||||
if (identical(cfur, as.name("guess_ab_col"))) { cfur <- guess_ab_col(tbl, "cfur", verbose = verbose) }
|
||||
if (identical(chlo, as.name("guess_ab_col"))) { chlo <- guess_ab_col(tbl, "chlo", verbose = verbose) }
|
||||
if (identical(cipr, as.name("guess_ab_col"))) { cipr <- guess_ab_col(tbl, "cipr", verbose = verbose) }
|
||||
if (identical(clar, as.name("guess_ab_col"))) { clar <- guess_ab_col(tbl, "clar", verbose = verbose) }
|
||||
if (identical(clin, as.name("guess_ab_col"))) { clin <- guess_ab_col(tbl, "clin", verbose = verbose) }
|
||||
if (identical(clox, as.name("guess_ab_col"))) { clox <- guess_ab_col(tbl, "clox", verbose = verbose) }
|
||||
if (identical(coli, as.name("guess_ab_col"))) { coli <- guess_ab_col(tbl, "coli", verbose = verbose) }
|
||||
if (identical(czol, as.name("guess_ab_col"))) { czol <- guess_ab_col(tbl, "czol", verbose = verbose) }
|
||||
if (identical(dapt, as.name("guess_ab_col"))) { dapt <- guess_ab_col(tbl, "dapt", verbose = verbose) }
|
||||
if (identical(doxy, as.name("guess_ab_col"))) { doxy <- guess_ab_col(tbl, "doxy", verbose = verbose) }
|
||||
if (identical(erta, as.name("guess_ab_col"))) { erta <- guess_ab_col(tbl, "erta", verbose = verbose) }
|
||||
if (identical(eryt, as.name("guess_ab_col"))) { eryt <- guess_ab_col(tbl, "eryt", verbose = verbose) }
|
||||
if (identical(fosf, as.name("guess_ab_col"))) { fosf <- guess_ab_col(tbl, "fosf", verbose = verbose) }
|
||||
if (identical(fusi, as.name("guess_ab_col"))) { fusi <- guess_ab_col(tbl, "fusi", verbose = verbose) }
|
||||
if (identical(gent, as.name("guess_ab_col"))) { gent <- guess_ab_col(tbl, "gent", verbose = verbose) }
|
||||
if (identical(imip, as.name("guess_ab_col"))) { imip <- guess_ab_col(tbl, "imip", verbose = verbose) }
|
||||
if (identical(kana, as.name("guess_ab_col"))) { kana <- guess_ab_col(tbl, "kana", verbose = verbose) }
|
||||
if (identical(levo, as.name("guess_ab_col"))) { levo <- guess_ab_col(tbl, "levo", verbose = verbose) }
|
||||
if (identical(linc, as.name("guess_ab_col"))) { linc <- guess_ab_col(tbl, "linc", verbose = verbose) }
|
||||
if (identical(line, as.name("guess_ab_col"))) { line <- guess_ab_col(tbl, "line", verbose = verbose) }
|
||||
if (identical(mero, as.name("guess_ab_col"))) { mero <- guess_ab_col(tbl, "mero", verbose = verbose) }
|
||||
if (identical(metr, as.name("guess_ab_col"))) { metr <- guess_ab_col(tbl, "metr", verbose = verbose) }
|
||||
if (identical(mino, as.name("guess_ab_col"))) { mino <- guess_ab_col(tbl, "mino", verbose = verbose) }
|
||||
if (identical(moxi, as.name("guess_ab_col"))) { moxi <- guess_ab_col(tbl, "moxi", verbose = verbose) }
|
||||
if (identical(nali, as.name("guess_ab_col"))) { nali <- guess_ab_col(tbl, "nali", verbose = verbose) }
|
||||
if (identical(neom, as.name("guess_ab_col"))) { neom <- guess_ab_col(tbl, "neom", verbose = verbose) }
|
||||
if (identical(neti, as.name("guess_ab_col"))) { neti <- guess_ab_col(tbl, "neti", verbose = verbose) }
|
||||
if (identical(nitr, as.name("guess_ab_col"))) { nitr <- guess_ab_col(tbl, "nitr", verbose = verbose) }
|
||||
if (identical(novo, as.name("guess_ab_col"))) { novo <- guess_ab_col(tbl, "novo", verbose = verbose) }
|
||||
if (identical(norf, as.name("guess_ab_col"))) { norf <- guess_ab_col(tbl, "norf", verbose = verbose) }
|
||||
if (identical(oflo, as.name("guess_ab_col"))) { oflo <- guess_ab_col(tbl, "oflo", verbose = verbose) }
|
||||
if (identical(peni, as.name("guess_ab_col"))) { peni <- guess_ab_col(tbl, "peni", verbose = verbose) }
|
||||
if (identical(pipe, as.name("guess_ab_col"))) { pipe <- guess_ab_col(tbl, "pipe", verbose = verbose) }
|
||||
if (identical(pita, as.name("guess_ab_col"))) { pita <- guess_ab_col(tbl, "pita", verbose = verbose) }
|
||||
if (identical(poly, as.name("guess_ab_col"))) { poly <- guess_ab_col(tbl, "poly", verbose = verbose) }
|
||||
if (identical(qida, as.name("guess_ab_col"))) { qida <- guess_ab_col(tbl, "qida", verbose = verbose) }
|
||||
if (identical(rifa, as.name("guess_ab_col"))) { rifa <- guess_ab_col(tbl, "rifa", verbose = verbose) }
|
||||
if (identical(roxi, as.name("guess_ab_col"))) { roxi <- guess_ab_col(tbl, "roxi", verbose = verbose) }
|
||||
if (identical(siso, as.name("guess_ab_col"))) { siso <- guess_ab_col(tbl, "siso", verbose = verbose) }
|
||||
if (identical(teic, as.name("guess_ab_col"))) { teic <- guess_ab_col(tbl, "teic", verbose = verbose) }
|
||||
if (identical(tetr, as.name("guess_ab_col"))) { tetr <- guess_ab_col(tbl, "tetr", verbose = verbose) }
|
||||
if (identical(tica, as.name("guess_ab_col"))) { tica <- guess_ab_col(tbl, "tica", verbose = verbose) }
|
||||
if (identical(tige, as.name("guess_ab_col"))) { tige <- guess_ab_col(tbl, "tige", verbose = verbose) }
|
||||
if (identical(tobr, as.name("guess_ab_col"))) { tobr <- guess_ab_col(tbl, "tobr", verbose = verbose) }
|
||||
if (identical(trim, as.name("guess_ab_col"))) { trim <- guess_ab_col(tbl, "trim", verbose = verbose) }
|
||||
if (identical(trsu, as.name("guess_ab_col"))) { trsu <- guess_ab_col(tbl, "trsu", verbose = verbose) }
|
||||
if (identical(vanc, as.name("guess_ab_col"))) { vanc <- guess_ab_col(tbl, "vanc", verbose = verbose) }
|
||||
col.list <- c(amcl, amik, amox, ampi, azit, aztr, cefa, cfra, cfep, cfot,
|
||||
cfox, cfta, cftr, cfur, chlo, cipr, clar, clin, clox, coli,
|
||||
czol, dapt, doxy, erta, eryt, fosf, fusi, gent, imip, kana,
|
||||
@ -301,6 +303,10 @@ mdro <- function(tbl,
|
||||
trsu <- col.list[trsu]
|
||||
vanc <- col.list[vanc]
|
||||
|
||||
ab_missing <- function(ab) {
|
||||
isTRUE(ab %in% c(NULL, NA)) | length(ab) == 0
|
||||
}
|
||||
|
||||
# antibiotic classes
|
||||
aminoglycosides <- c(tobr, gent) # can also be kana but that one is often intrinsic R
|
||||
cephalosporins <- c(cfep, cfot, cfox, cfra, cfta, cftr, cfur, czol)
|
||||
@ -310,7 +316,7 @@ mdro <- function(tbl,
|
||||
|
||||
# helper function for editing the table
|
||||
trans_tbl <- function(to, rows, cols, any_all) {
|
||||
cols <- cols[!is.na(cols)]
|
||||
cols <- cols[!ab_missing(cols)]
|
||||
if (length(rows) > 0 & length(cols) > 0) {
|
||||
if (any_all == "any") {
|
||||
col_filter <- which(tbl[, cols] == 'R')
|
||||
@ -404,9 +410,9 @@ mdro <- function(tbl,
|
||||
|
||||
if (guideline$country$code == 'nl') {
|
||||
# Netherlands -------------------------------------------------------------
|
||||
aminoglycosides <- aminoglycosides[!is.na(aminoglycosides)]
|
||||
fluoroquinolones <- fluoroquinolones[!is.na(fluoroquinolones)]
|
||||
carbapenems <- carbapenems[!is.na(carbapenems)]
|
||||
aminoglycosides <- aminoglycosides[!ab_missing(aminoglycosides)]
|
||||
fluoroquinolones <- fluoroquinolones[!ab_missing(fluoroquinolones)]
|
||||
carbapenems <- carbapenems[!ab_missing(carbapenems)]
|
||||
|
||||
# Table 1
|
||||
trans_tbl(3,
|
||||
@ -434,11 +440,11 @@ mdro <- function(tbl,
|
||||
trsu,
|
||||
"all")
|
||||
|
||||
if (!is.na(mero) & !is.na(imip)
|
||||
& !is.na(gent) & !is.na(tobr)
|
||||
& !is.na(cipr)
|
||||
& !is.na(cfta)
|
||||
& !is.na(pita) ) {
|
||||
if (!ab_missing(mero) & !ab_missing(imip)
|
||||
& !ab_missing(gent) & !ab_missing(tobr)
|
||||
& !ab_missing(cipr)
|
||||
& !ab_missing(cfta)
|
||||
& !ab_missing(pita) ) {
|
||||
tbl <- tbl %>% mutate(
|
||||
psae = 0,
|
||||
psae = ifelse(mero == "R" | imip == "R", psae + 1, psae),
|
||||
|
||||
Reference in New Issue
Block a user