2018-04-18 12:24:54 +02:00
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Analysis #
# #
2019-01-02 23:24:07 +01:00
# SOURCE #
# https://gitlab.com/msberends/AMR #
2018-04-18 12:24:54 +02:00
# #
# LICENCE #
2019-01-02 23:24:07 +01:00
# (c) 2019 Berends MS (m.s.berends@umcg.nl), Luz CF (c.f.luz@umcg.nl) #
2018-04-18 12:24:54 +02:00
# #
2019-01-02 23:24:07 +01:00
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
# GNU General Public License version 2.0 (GNU GPL-2), as published by #
# the Free Software Foundation. #
# #
# This R package was created for academic research and was publicly #
# released in the hope that it will be useful, but it comes WITHOUT #
# ANY WARRANTY OR LIABILITY. #
# Visit our website for more info: https://msberends.gitab.io/AMR. #
2018-04-18 12:24:54 +02:00
# ==================================================================== #
#' Determine multidrug-resistant organisms (MDRO)
#'
#' Determine which isolates are multidrug-resistant organisms (MDRO) according to country-specific guidelines.
#' @param tbl table with antibiotic columns, like e.g. \code{amox} and \code{amcl}
2018-04-25 15:33:58 +02:00
#' @param country country code to determine guidelines. EUCAST rules will be used when left empty, see Details. Should be or a code from the \href{https://en.wikipedia.org/wiki/ISO_3166-1_alpha-2#Officially_assigned_code_elements}{list of ISO 3166-1 alpha-2 country codes}. Case-insensitive. Currently supported are \code{de} (Germany) and \code{nl} (the Netherlands).
2018-04-18 12:24:54 +02:00
#' @param info print progress
2018-11-16 20:50:50 +01:00
#' @inheritParams eucast_rules
2018-12-07 12:04:55 +01:00
#' @param metr column name of an antibiotic, see Antibiotics
2018-04-25 15:33:58 +02:00
#' @param ... parameters that are passed on to methods
2018-11-16 20:50:50 +01:00
#' @inheritSection eucast_rules Antibiotics
2018-04-25 15:33:58 +02:00
#' @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}).
2018-11-16 20:50:50 +01:00
#' @return Ordered factor with levels \code{Negative < Positive, unconfirmed < Positive}.
#' @rdname mdro
2018-10-23 11:15:05 +02:00
#' @importFrom dplyr %>%
2018-12-22 22:39:34 +01:00
#' @importFrom crayon red blue bold
2018-04-18 12:24:54 +02:00
#' @export
2019-01-02 23:24:07 +01:00
#' @inheritSection AMR Read more on our website!
2018-04-25 15:33:58 +02:00
#' @examples
#' library(dplyr)
#'
#' septic_patients %>%
2018-11-16 20:50:50 +01:00
#' mutate(EUCAST = mdro(.),
#' BRMO = brmo(.))
mdro <- function ( tbl ,
2018-04-25 15:33:58 +02:00
country = NULL ,
2018-10-23 11:15:05 +02:00
col_mo = NULL ,
2018-04-18 12:24:54 +02:00
info = TRUE ,
2019-01-11 20:37:23 +01:00
amcl = guess_ab_col ( ) ,
amik = guess_ab_col ( ) ,
amox = guess_ab_col ( ) ,
ampi = guess_ab_col ( ) ,
azit = guess_ab_col ( ) ,
aztr = guess_ab_col ( ) ,
cefa = guess_ab_col ( ) ,
cfra = guess_ab_col ( ) ,
cfep = guess_ab_col ( ) ,
cfot = guess_ab_col ( ) ,
cfox = guess_ab_col ( ) ,
cfta = guess_ab_col ( ) ,
cftr = guess_ab_col ( ) ,
cfur = guess_ab_col ( ) ,
chlo = guess_ab_col ( ) ,
cipr = guess_ab_col ( ) ,
clar = guess_ab_col ( ) ,
clin = guess_ab_col ( ) ,
clox = guess_ab_col ( ) ,
coli = guess_ab_col ( ) ,
czol = guess_ab_col ( ) ,
dapt = guess_ab_col ( ) ,
doxy = guess_ab_col ( ) ,
erta = guess_ab_col ( ) ,
eryt = guess_ab_col ( ) ,
fosf = guess_ab_col ( ) ,
fusi = guess_ab_col ( ) ,
gent = guess_ab_col ( ) ,
imip = guess_ab_col ( ) ,
kana = guess_ab_col ( ) ,
levo = guess_ab_col ( ) ,
linc = guess_ab_col ( ) ,
line = guess_ab_col ( ) ,
mero = guess_ab_col ( ) ,
metr = guess_ab_col ( ) ,
mino = guess_ab_col ( ) ,
moxi = guess_ab_col ( ) ,
nali = guess_ab_col ( ) ,
neom = guess_ab_col ( ) ,
neti = guess_ab_col ( ) ,
nitr = guess_ab_col ( ) ,
novo = guess_ab_col ( ) ,
norf = guess_ab_col ( ) ,
oflo = guess_ab_col ( ) ,
peni = guess_ab_col ( ) ,
pipe = guess_ab_col ( ) ,
pita = guess_ab_col ( ) ,
poly = guess_ab_col ( ) ,
qida = guess_ab_col ( ) ,
rifa = guess_ab_col ( ) ,
roxi = guess_ab_col ( ) ,
siso = guess_ab_col ( ) ,
teic = guess_ab_col ( ) ,
tetr = guess_ab_col ( ) ,
tica = guess_ab_col ( ) ,
tige = guess_ab_col ( ) ,
tobr = guess_ab_col ( ) ,
trim = guess_ab_col ( ) ,
trsu = guess_ab_col ( ) ,
vanc = guess_ab_col ( ) ) {
2018-04-25 15:33:58 +02:00
2018-10-23 11:15:05 +02:00
if ( ! is.data.frame ( tbl ) ) {
stop ( " `tbl` must be a data frame." , call. = FALSE )
}
# try to find columns based on type
# -- mo
2019-01-15 12:45:24 +01:00
if ( is.null ( col_mo ) ) {
col_mo <- search_type_in_df ( tbl = tbl , type = " mo" )
2018-12-22 22:39:34 +01:00
}
if ( is.null ( col_mo ) ) {
stop ( " `col_mo` must be set." , call. = FALSE )
2018-04-25 15:33:58 +02:00
}
2018-04-18 12:24:54 +02:00
# strip whitespaces
if ( length ( country ) > 1 ) {
stop ( ' `country` must be a length one character string.' , call. = FALSE )
}
2018-04-25 15:33:58 +02:00
if ( is.null ( country ) ) {
country <- ' EUCAST'
}
country <- trimws ( country )
2018-11-16 20:50:50 +01:00
if ( tolower ( country ) != ' eucast' & ! country %like% ' ^[a-z]{2}$' ) {
stop ( ' This is not a valid ISO 3166-1 alpha-2 country code: "' , country , ' ". Please see ?mdro.' , call. = FALSE )
2018-04-18 12:24:54 +02:00
}
# create list and make country code case-independent
guideline <- list ( country = list ( code = tolower ( country ) ) )
2018-04-25 15:33:58 +02:00
if ( guideline $ country $ code == ' eucast' ) {
guideline $ country $ name <- ' (European guidelines)'
guideline $ name <- ' EUCAST Expert Rules, "Intrinsic Resistance and Exceptional Phenotypes Tables"'
guideline $ version <- ' Version 3.1'
guideline $ source <- ' http://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/Expert_rules_intrinsic_exceptional_V3.1.pdf'
# support per country:
} else if ( guideline $ country $ code == ' de' ) {
2018-04-18 12:24:54 +02:00
guideline $ country $ name <- ' Germany'
guideline $ name <- ' '
guideline $ version <- ' '
guideline $ source <- ' '
} else if ( guideline $ country $ code == ' nl' ) {
guideline $ country $ name <- ' The Netherlands'
guideline $ name <- ' WIP-Richtlijn BRMO'
2019-03-18 14:29:41 +01:00
guideline $ version <- ' Revision as of December 2017'
2018-04-18 12:24:54 +02:00
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'
2018-11-16 20:50:50 +01:00
# add here more countries like this:
# } else if (country$code == 'xx') {
# country$name <- 'country name'
2018-04-18 12:24:54 +02:00
} else {
stop ( ' This country code is currently unsupported: ' , guideline $ country $ code , call. = FALSE )
}
if ( info == TRUE ) {
2018-04-25 15:33:58 +02:00
cat ( " Determining multidrug-resistant organisms (MDRO), according to:\n" ,
2018-10-23 11:15:05 +02:00
" Guideline: " , red ( paste0 ( guideline $ name , " , " , guideline $ version , " \n" ) ) ,
" Country : " , red ( paste0 ( guideline $ country $ name , " \n" ) ) ,
" Source : " , blue ( paste0 ( guideline $ source , " \n" ) ) ,
2018-04-18 12:24:54 +02:00
" \n" , sep = " " )
}
2018-04-25 15:33:58 +02:00
# check columns
2019-01-11 20:37:23 +01:00
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 ) }
2018-04-25 15:33:58 +02:00
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 ,
2019-01-03 23:56:19 +01:00
levo , linc , line , mero , metr , mino , moxi , nali , neom , neti ,
nitr , novo , norf , oflo , peni , pipe , pita , poly , qida , rifa ,
roxi , siso , teic , tetr , tica , tige , tobr , trim , trsu , vanc )
if ( length ( col.list ) < 60 ) {
warning ( ' Some columns do not exist -- THIS MAY STRONGLY INFLUENCE THE OUTCOME.' ,
immediate. = TRUE ,
call. = FALSE )
}
2018-04-25 15:33:58 +02:00
col.list <- check_available_columns ( tbl = tbl , col.list = col.list , info = info )
amcl <- col.list [amcl ]
amik <- col.list [amik ]
amox <- col.list [amox ]
ampi <- col.list [ampi ]
azit <- col.list [azit ]
aztr <- col.list [aztr ]
cefa <- col.list [cefa ]
cfra <- col.list [cfra ]
cfep <- col.list [cfep ]
cfot <- col.list [cfot ]
cfox <- col.list [cfox ]
cfta <- col.list [cfta ]
cftr <- col.list [cftr ]
cfur <- col.list [cfur ]
chlo <- col.list [chlo ]
cipr <- col.list [cipr ]
clar <- col.list [clar ]
clin <- col.list [clin ]
clox <- col.list [clox ]
coli <- col.list [coli ]
czol <- col.list [czol ]
dapt <- col.list [dapt ]
doxy <- col.list [doxy ]
erta <- col.list [erta ]
eryt <- col.list [eryt ]
fosf <- col.list [fosf ]
fusi <- col.list [fusi ]
gent <- col.list [gent ]
imip <- col.list [imip ]
kana <- col.list [kana ]
levo <- col.list [levo ]
linc <- col.list [linc ]
line <- col.list [line ]
mero <- col.list [mero ]
metr <- col.list [metr ]
mino <- col.list [mino ]
moxi <- col.list [moxi ]
nali <- col.list [nali ]
neom <- col.list [neom ]
neti <- col.list [neti ]
nitr <- col.list [nitr ]
novo <- col.list [novo ]
norf <- col.list [norf ]
oflo <- col.list [oflo ]
peni <- col.list [peni ]
2019-01-03 23:56:19 +01:00
pipe <- col.list [pipe ]
2018-04-25 15:33:58 +02:00
pita <- col.list [pita ]
poly <- col.list [poly ]
qida <- col.list [qida ]
rifa <- col.list [rifa ]
roxi <- col.list [roxi ]
siso <- col.list [siso ]
teic <- col.list [teic ]
tetr <- col.list [tetr ]
tica <- col.list [tica ]
tige <- col.list [tige ]
tobr <- col.list [tobr ]
trim <- col.list [trim ]
trsu <- col.list [trsu ]
vanc <- col.list [vanc ]
# antibiotic classes
2018-10-23 11:15:05 +02:00
aminoglycosides <- c ( tobr , gent ) # can also be kana but that one is often intrinsic R
2018-04-25 15:33:58 +02:00
cephalosporins <- c ( cfep , cfot , cfox , cfra , cfta , cftr , cfur , czol )
cephalosporins_3rd <- c ( cfot , cftr , cfta )
carbapenems <- c ( erta , imip , mero )
2018-10-23 11:15:05 +02:00
fluoroquinolones <- c ( oflo , cipr , levo , moxi )
2018-04-25 15:33:58 +02:00
# helper function for editing the table
2018-11-16 20:50:50 +01:00
trans_tbl <- function ( to , rows , cols , any_all ) {
2018-04-25 15:33:58 +02:00
cols <- cols [ ! is.na ( cols ) ]
if ( length ( rows ) > 0 & length ( cols ) > 0 ) {
2018-11-16 20:50:50 +01:00
if ( any_all == " any" ) {
col_filter <- which ( tbl [ , cols ] == ' R' )
} else if ( any_all == " all" ) {
col_filter <- tbl %>%
mutate ( index = 1 : nrow ( .) ) %>%
filter_at ( vars ( cols ) , all_vars ( . == " R" ) ) %>%
pull ( ( index ) )
}
2018-04-25 15:33:58 +02:00
rows <- rows [rows %in% col_filter ]
tbl [rows , ' MDRO' ] <<- to
}
}
2018-10-23 11:15:05 +02:00
tbl <- tbl %>%
2018-12-22 22:39:34 +01:00
mutate_at ( vars ( col_mo ) , as.mo ) %>%
2018-10-23 11:15:05 +02:00
# join to microorganisms data set
left_join_microorganisms ( by = col_mo ) %>%
# add unconfirmed to where genus is available
mutate ( MDRO = ifelse ( ! is.na ( genus ) , 1 , NA_integer_ ) )
2018-04-25 15:33:58 +02:00
if ( guideline $ country $ code == ' eucast' ) {
# EUCAST ------------------------------------------------------------------
# Table 5
2018-11-16 20:50:50 +01:00
trans_tbl ( 3 ,
2018-04-25 15:33:58 +02:00
which ( tbl $ family == ' Enterobacteriaceae'
| tbl $ fullname %like% ' ^Pseudomonas aeruginosa'
| tbl $ genus == ' Acinetobacter' ) ,
2018-11-16 20:50:50 +01:00
coli ,
" all" )
trans_tbl ( 3 ,
2018-04-25 15:33:58 +02:00
which ( tbl $ fullname %like% ' ^Salmonella Typhi' ) ,
2018-11-16 20:50:50 +01:00
c ( carbapenems , fluoroquinolones ) ,
" any" )
trans_tbl ( 3 ,
2018-04-25 15:33:58 +02:00
which ( tbl $ fullname %like% ' ^Haemophilus influenzae' ) ,
2018-11-16 20:50:50 +01:00
c ( cephalosporins_3rd , carbapenems , fluoroquinolones ) ,
" any" )
trans_tbl ( 3 ,
2018-04-25 15:33:58 +02:00
which ( tbl $ fullname %like% ' ^Moraxella catarrhalis' ) ,
2018-11-16 20:50:50 +01:00
c ( cephalosporins_3rd , fluoroquinolones ) ,
" any" )
trans_tbl ( 3 ,
2018-04-25 15:33:58 +02:00
which ( tbl $ fullname %like% ' ^Neisseria meningitidis' ) ,
2018-11-16 20:50:50 +01:00
c ( cephalosporins_3rd , fluoroquinolones ) ,
" any" )
trans_tbl ( 3 ,
2018-04-25 15:33:58 +02:00
which ( tbl $ fullname %like% ' ^Neisseria gonorrhoeae' ) ,
2018-11-16 20:50:50 +01:00
azit ,
" any" )
2018-04-25 15:33:58 +02:00
# Table 6
2018-11-16 20:50:50 +01:00
trans_tbl ( 3 ,
2018-04-25 15:33:58 +02:00
which ( tbl $ fullname %like% ' ^Staphylococcus (aureus|epidermidis|coagulase negatief|hominis|haemolyticus|intermedius|pseudointermedius)' ) ,
2018-11-16 20:50:50 +01:00
c ( vanc , teic , dapt , line , qida , tige ) ,
" any" )
trans_tbl ( 3 ,
2018-04-25 15:33:58 +02:00
which ( tbl $ genus == ' Corynebacterium' ) ,
2018-11-16 20:50:50 +01:00
c ( vanc , teic , dapt , line , qida , tige ) ,
" any" )
trans_tbl ( 3 ,
2018-04-25 15:33:58 +02:00
which ( tbl $ fullname %like% ' ^Streptococcus pneumoniae' ) ,
2018-11-16 20:50:50 +01:00
c ( carbapenems , vanc , teic , dapt , line , qida , tige , rifa ) ,
" any" )
trans_tbl ( 3 , # Sr. groups A/B/C/G
2018-04-25 15:33:58 +02:00
which ( tbl $ fullname %like% ' ^Streptococcus (pyogenes|agalactiae|equisimilis|equi|zooepidemicus|dysgalactiae|anginosus)' ) ,
2018-11-16 20:50:50 +01:00
c ( peni , cephalosporins , vanc , teic , dapt , line , qida , tige ) ,
" any" )
trans_tbl ( 3 ,
2018-04-25 15:33:58 +02:00
which ( tbl $ genus == ' Enterococcus' ) ,
2018-11-16 20:50:50 +01:00
c ( dapt , line , tige , teic ) ,
" any" )
trans_tbl ( 3 ,
2018-04-25 15:33:58 +02:00
which ( tbl $ fullname %like% ' ^Enterococcus faecalis' ) ,
2018-11-16 20:50:50 +01:00
c ( ampi , amox ) ,
" any" )
2018-04-25 15:33:58 +02:00
# Table 7
2018-11-16 20:50:50 +01:00
trans_tbl ( 3 ,
2018-04-25 15:33:58 +02:00
which ( tbl $ genus == ' Bacteroides' ) ,
2018-11-16 20:50:50 +01:00
metr ,
" any" )
trans_tbl ( 3 ,
2018-04-25 15:33:58 +02:00
which ( tbl $ fullname %like% ' ^Clostridium difficile' ) ,
2018-11-16 20:50:50 +01:00
c ( metr , vanc ) ,
" any" )
2018-04-25 15:33:58 +02:00
}
2018-04-18 12:24:54 +02:00
2018-04-19 14:10:57 +02:00
if ( guideline $ country $ code == ' de' ) {
2018-04-25 15:33:58 +02:00
# Germany -----------------------------------------------------------------
2018-04-19 14:10:57 +02:00
stop ( " We are still working on German guidelines in this beta version." , call. = FALSE )
}
2018-04-18 12:24:54 +02:00
if ( guideline $ country $ code == ' nl' ) {
2018-04-25 15:33:58 +02:00
# Netherlands -------------------------------------------------------------
aminoglycosides <- aminoglycosides [ ! is.na ( aminoglycosides ) ]
fluoroquinolones <- fluoroquinolones [ ! is.na ( fluoroquinolones ) ]
carbapenems <- carbapenems [ ! is.na ( carbapenems ) ]
2018-04-18 12:24:54 +02:00
# Table 1
2018-11-16 20:50:50 +01:00
trans_tbl ( 3 ,
which ( tbl $ family == ' Enterobacteriaceae' ) ,
c ( aminoglycosides , fluoroquinolones ) ,
" all" )
trans_tbl ( 2 ,
which ( tbl $ family == ' Enterobacteriaceae' ) ,
c ( carbapenems ) ,
" any" )
2018-04-18 12:24:54 +02:00
# Table 2
2018-11-16 20:50:50 +01:00
trans_tbl ( 2 ,
which ( tbl $ genus == ' Acinetobacter' ) ,
c ( carbapenems ) ,
" any" )
trans_tbl ( 3 ,
which ( tbl $ genus == ' Acinetobacter' ) ,
c ( aminoglycosides , fluoroquinolones ) ,
" all" )
2018-04-18 12:24:54 +02:00
2018-11-16 20:50:50 +01:00
trans_tbl ( 3 ,
which ( tbl $ fullname %like% ' ^Stenotrophomonas maltophilia' ) ,
trsu ,
" all" )
2018-04-18 12:24:54 +02:00
2018-11-16 20:50:50 +01:00
if ( ! is.na ( mero ) & ! is.na ( imip )
& ! is.na ( gent ) & ! is.na ( tobr )
& ! is.na ( cipr )
& ! is.na ( cfta )
& ! is.na ( pita ) ) {
tbl <- tbl %>% mutate (
psae = 0 ,
psae = ifelse ( mero == " R" | imip == " R" , psae + 1 , psae ) ,
psae = ifelse ( gent == " R" & tobr == " R" , psae + 1 , psae ) ,
psae = ifelse ( cipr == " R" , psae + 1 , psae ) ,
psae = ifelse ( cfta == " R" , psae + 1 , psae ) ,
psae = ifelse ( pita == " R" , psae + 1 , psae ) ,
psae = ifelse ( is.na ( psae ) , 0 , psae )
)
} else {
tbl $ psae <- 0
}
2018-04-18 12:24:54 +02:00
tbl [which (
tbl $ fullname %like% ' Pseudomonas aeruginosa'
2018-10-23 11:15:05 +02:00
& tbl $ psae >= 3
2018-11-16 20:50:50 +01:00
) , ' MDRO' ] <- 3
2018-04-18 12:24:54 +02:00
# Table 3
2018-11-16 20:50:50 +01:00
trans_tbl ( 3 ,
which ( tbl $ fullname %like% ' Streptococcus pneumoniae' ) ,
peni ,
" all" )
trans_tbl ( 3 ,
which ( tbl $ fullname %like% ' Streptococcus pneumoniae' ) ,
vanc ,
" all" )
trans_tbl ( 3 ,
which ( tbl $ fullname %like% ' Enterococcus faecium' ) ,
c ( peni , vanc ) ,
" all" )
2018-04-18 12:24:54 +02:00
}
factor ( x = tbl $ MDRO ,
2018-11-16 20:50:50 +01:00
levels = 1 : 3 ,
labels = c ( ' Negative' , ' Positive, unconfirmed' , ' Positive' ) ,
2018-04-18 12:24:54 +02:00
ordered = TRUE )
}
2018-11-16 20:50:50 +01:00
#' @rdname mdro
2018-04-18 12:24:54 +02:00
#' @export
2018-11-16 20:50:50 +01:00
brmo <- function ( ... , country = " nl" ) {
mdro ( ... , country = " nl" )
2018-04-18 12:24:54 +02:00
}
2018-11-16 20:50:50 +01:00
#' @rdname mdro
2018-04-18 12:24:54 +02:00
#' @export
2018-11-16 20:50:50 +01:00
mrgn <- function ( tbl , country = " de" , ... ) {
mdro ( tbl = tbl , country = " de" , ... )
2018-04-25 15:33:58 +02:00
}
2018-11-16 20:50:50 +01:00
#' @rdname mdro
2018-04-25 15:33:58 +02:00
#' @export
2018-11-16 20:50:50 +01:00
eucast_exceptional_phenotypes <- function ( tbl , country = " EUCAST" , ... ) {
mdro ( tbl = tbl , country = " EUCAST" , ... )
2018-04-18 12:24:54 +02:00
}