1
0
mirror of https://github.com/msberends/AMR.git synced 2025-07-09 11:01:57 +02:00

first commit

This commit is contained in:
2018-02-21 11:52:31 +01:00
commit 62304dc23f
34 changed files with 3459 additions and 0 deletions

637
R/EUCAST.R Normal file
View File

@ -0,0 +1,637 @@
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Analysis #
# #
# AUTHORS #
# Berends MS (m.s.berends@umcg.nl), Luz CF (c.f.luz@umcg.nl) #
# #
# LICENCE #
# This program is free software; you can redistribute it and/or modify #
# it under the terms of the GNU General Public License version 2.0, #
# as published by the Free Software Foundation. #
# #
# This program is distributed in the hope that it will be useful, #
# but WITHOUT ANY WARRANTY; without even the implied warranty of #
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the #
# GNU General Public License for more details. #
# ==================================================================== #
#' EUCAST expert rules
#'
#' Apply expert rules (like intrinsic resistance), as defined by the European Committee on Antimicrobial Susceptibility Testing (EUCAST, \url{http://eucast.org}), see \emph{Source}.
#' @param tbl table with antibiotic columns, like e.g. \code{amox} and \code{amcl}
#' @param col_bactcode column name of the bacteria ID in \code{tbl} - should also be present in \code{bactlist$bactid}, see \code{\link{bactlist}}.
#' @param info print progress
#' @param 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,levo,linc,line,mero,mino,moxi,nali,neom,neti,nitr,novo,norf,oflo,peni,pita,poly,qida,rifa,roxi,siso,teic,tetr,tica,tige,tobr,trim,trsu,vanc column names of antibiotics. Use \code{NA} to skip a column, like \code{tica = NA}. Non-existing column will be skipped.
#' @param ... parameters that are passed on to \code{EUCAST_rules}
#' @name EUCAST
#' @rdname EUCAST
#' @export
#' @importFrom dplyr %>% left_join select
#' @source
#' EUCAST Expert Rules Version 2.0: \cr
#' Leclercq et al. \strong{EUCAST expert rules in antimicrobial susceptibility testing.} \emph{Clin Microbiol Infect.} 2013;19(2):141-60. \cr
#' \url{https://doi.org/10.1111/j.1469-0691.2011.03703.x} \cr
#' \cr
#' EUCAST Expert Rules Version 3.1: \cr
#' \url{http://www.eucast.org/expert_rules_and_intrinsic_resistance}
#' @examples
#' \dontrun{
#' tbl <- interpretive_reading(tbl)
#' }
EUCAST_rules <- function(tbl,
col_bactcode = 'bacteriecode',
info = TRUE,
amcl = 'amcl',
amik = 'amik',
amox = 'amox',
ampi = 'ampi',
azit = 'azit',
aztr = 'aztr',
cefa = 'cefa',
cfra = 'cfra',
cfep = 'cfep',
cfot = 'cfot',
cfox = 'cfox',
cfta = 'cfta',
cftr = 'cftr',
cfur = 'cfur',
chlo = 'chlo',
cipr = 'cipr',
clar = 'clar',
clin = 'clin',
clox = 'clox',
coli = 'coli',
czol = 'czol',
dapt = 'dapt',
doxy = 'doxy',
erta = 'erta',
eryt = 'eryt',
fosf = 'fosf',
fusi = 'fusi',
gent = 'gent',
imip = 'imip',
kana = 'kana',
levo = 'levo',
linc = 'linc',
line = 'line',
mero = 'mero',
mino = 'mino',
moxi = 'moxi',
nali = 'nali',
neom = 'neom',
neti = 'neti',
nitr = 'nitr',
novo = 'novo',
norf = 'norf',
oflo = 'oflo',
peni = 'peni',
pita = 'pita',
poly = 'poly',
qida = 'qida',
rifa = 'rifa',
roxi = 'roxi',
siso = 'siso',
teic = 'teic',
tetr = 'tetr',
tica = 'tica',
tige = 'tige',
tobr = 'tobr',
trim = 'trim',
trsu = 'trsu',
vanc = 'vanc') {
if (!col_bactcode %in% colnames(tbl)) {
stop('Column ', col_bactcode, ' not found.')
}
# kolommen controleren
col.list <- c(amcl, amik, amox, ampi, azit, aztr, cefa, cfra, cfep,
cfot, cfox, cfta, cftr, cfur, cipr, clar, clin, clox, coli, czol,
dapt, doxy, erta, eryt, fusi, gent, imip, kana, levo, linc, line,
mero, mino, moxi, nali, neom, neti, nitr, novo, norf, oflo, peni,
pita, poly, qida, rifa, roxi, siso, teic, tetr, tica, tige, tobr,
trim, trsu, vanc)
col.list <- col.list[!is.na(col.list)]
if (!all(col.list %in% colnames(tbl))) {
if (info == TRUE) {
cat('\n')
}
if (info == TRUE) {
warning('These columns do not exist and will be ignored:\n',
col.list[!(col.list %in% colnames(tbl))] %>% toString(),
immediate. = TRUE,
call. = FALSE)
}
if (!amcl %in% colnames(tbl)) { amcl <- NA }
if (!amik %in% colnames(tbl)) { amik <- NA }
if (!amox %in% colnames(tbl)) { amox <- NA }
if (!ampi %in% colnames(tbl)) { ampi <- NA }
if (!azit %in% colnames(tbl)) { azit <- NA }
if (!aztr %in% colnames(tbl)) { aztr <- NA }
if (!cefa %in% colnames(tbl)) { cefa <- NA }
if (!cfra %in% colnames(tbl)) { cfra <- NA }
if (!cfep %in% colnames(tbl)) { cfep <- NA }
if (!cfot %in% colnames(tbl)) { cfot <- NA }
if (!cfox %in% colnames(tbl)) { cfox <- NA }
if (!cfta %in% colnames(tbl)) { cfta <- NA }
if (!cftr %in% colnames(tbl)) { cftr <- NA }
if (!cfur %in% colnames(tbl)) { cfur <- NA }
if (!chlo %in% colnames(tbl)) { chlo <- NA }
if (!cipr %in% colnames(tbl)) { cipr <- NA }
if (!clar %in% colnames(tbl)) { clar <- NA }
if (!clin %in% colnames(tbl)) { clin <- NA }
if (!clox %in% colnames(tbl)) { clox <- NA }
if (!coli %in% colnames(tbl)) { coli <- NA }
if (!czol %in% colnames(tbl)) { czol <- NA }
if (!dapt %in% colnames(tbl)) { dapt <- NA }
if (!doxy %in% colnames(tbl)) { doxy <- NA }
if (!erta %in% colnames(tbl)) { erta <- NA }
if (!eryt %in% colnames(tbl)) { eryt <- NA }
if (!fosf %in% colnames(tbl)) { fosf <- NA }
if (!fusi %in% colnames(tbl)) { fusi <- NA }
if (!gent %in% colnames(tbl)) { gent <- NA }
if (!imip %in% colnames(tbl)) { imip <- NA }
if (!kana %in% colnames(tbl)) { kana <- NA }
if (!levo %in% colnames(tbl)) { levo <- NA }
if (!linc %in% colnames(tbl)) { linc <- NA }
if (!line %in% colnames(tbl)) { line <- NA }
if (!mero %in% colnames(tbl)) { mero <- NA }
if (!mino %in% colnames(tbl)) { mino <- NA }
if (!moxi %in% colnames(tbl)) { moxi <- NA }
if (!nali %in% colnames(tbl)) { nali <- NA }
if (!neom %in% colnames(tbl)) { neom <- NA }
if (!neti %in% colnames(tbl)) { neti <- NA }
if (!nitr %in% colnames(tbl)) { nitr <- NA }
if (!novo %in% colnames(tbl)) { novo <- NA }
if (!norf %in% colnames(tbl)) { norf <- NA }
if (!oflo %in% colnames(tbl)) { oflo <- NA }
if (!peni %in% colnames(tbl)) { peni <- NA }
if (!pita %in% colnames(tbl)) { pita <- NA }
if (!poly %in% colnames(tbl)) { poly <- NA }
if (!qida %in% colnames(tbl)) { qida <- NA }
if (!rifa %in% colnames(tbl)) { rifa <- NA }
if (!roxi %in% colnames(tbl)) { roxi <- NA }
if (!siso %in% colnames(tbl)) { siso <- NA }
if (!teic %in% colnames(tbl)) { teic <- NA }
if (!tetr %in% colnames(tbl)) { tetr <- NA }
if (!tica %in% colnames(tbl)) { tica <- NA }
if (!tige %in% colnames(tbl)) { tige <- NA }
if (!tobr %in% colnames(tbl)) { tobr <- NA }
if (!trim %in% colnames(tbl)) { trim <- NA }
if (!trsu %in% colnames(tbl)) { trsu <- NA }
if (!vanc %in% colnames(tbl)) { vanc <- NA }
}
total <- 0
# functie voor uitvoeren
edit_rsi <- function(to, rows, cols) {
#voortgang$tick()$print()
cols <- cols[!is.na(cols)]
if (length(rows) > 0 & length(cols) > 0) {
tbl[rows, cols] <<- to
total <<- total + (length(rows) * length(cols))
}
}
# bactlist aan vastknopen (bestaande kolommen krijgen extra suffix)
joinby <- colnames(AMR::bactlist)[1]
names(joinby) <- col_bactcode
tbl <- tbl %>% left_join(y = AMR::bactlist, by = joinby, suffix = c("_tempbactlist", ""))
# antibioticagroepen
aminoglycosiden <- c(tobr, gent, kana, neom, neti, siso)
tetracyclines <- c(doxy, mino, tetr) # sinds EUCAST v3.1 is tige(cycline) apart
polymyxines <- c(poly, coli)
macroliden <- c(eryt, azit, roxi, clar) # sinds EUCAST v3.1 is clinda apart
glycopeptiden <- c(vanc, teic)
streptogramines <- qida # eigenlijk pristinamycine en quinupristine/dalfopristine
cefalosporines <- c(cfep, cfot, cfox, cfra, cfta, cftr, cfur, czol)
carbapenems <- c(erta, imip, mero)
aminopenicillines <- c(ampi, amox)
ureidopenicillines <- pita # eigenlijk ook azlo en mezlo
fluorochinolonen <- c(oflo, cipr, norf, levo, moxi)
if (info == TRUE) {
cat('\nApplying EUCAST expert rules on',
tbl[!is.na(tbl$genus),] %>% nrow(),
'isolates according to "EUCAST Expert Rules Version 3.1"\n\n')
}
# Table 1: Intrinsic resistance in Enterobacteriaceae ----
if (info == TRUE) {
cat('...Table 1: Intrinsic resistance in Enterobacteriaceae\n')
}
#voortgang <- progress_estimated(17)
# Intrisiek R voor groep
edit_rsi(to = 'R',
rows = which(tbl$family == 'Enterobacteriaceae'),
cols = c(peni, glycopeptiden, fusi, macroliden, linc, streptogramines, rifa, dapt, line))
# Citrobacter
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Citrobacter (koseri|amalonaticus|sedlakii|farmeri|rodentium)'),
cols = c(ampi, tica))
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Citrobacter (freundii|braakii|murliniae|werkmanii|youngae)'),
cols = c(ampi, amcl, czol, cfox))
# Enterobacter
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Enterobacter cloacae'),
cols = c(ampi, amcl, czol, cfox))
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Enterobacter aerogenes'),
cols = c(ampi, amcl, czol, cfox))
# Escherichia
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Escherichia hermanni'),
cols = c(ampi, tica))
# Hafnia
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Hafnia alvei'),
cols = c(ampi, amcl, czol, cfox))
# Klebsiella
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Klebsiella'),
cols = c(ampi, tica))
# Morganella / Proteus
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Morganella morganii'),
cols = c(ampi, amcl, czol, tetracyclines, polymyxines, nitr))
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Proteus mirabilis'),
cols = c(tetracyclines, tige, polymyxines, nitr))
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Proteus penneri'),
cols = c(ampi, czol, cfur, tetracyclines, tige, polymyxines, nitr))
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Proteus vulgaris'),
cols = c(ampi, czol, cfur, tetracyclines, tige, polymyxines, nitr))
# Providencia
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Providencia rettgeri'),
cols = c(ampi, amcl, czol, cfur, tetracyclines, tige, polymyxines, nitr))
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Providencia stuartii'),
cols = c(ampi, amcl, czol, cfur, tetracyclines, tige, polymyxines, nitr))
# Raoultella
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Raoultella'),
cols = c(ampi, tica))
# Serratia
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Serratia marcescens'),
cols = c(ampi, amcl, czol, cfox, cfur, tetracyclines[tetracyclines != 'mino'], polymyxines, nitr))
# Yersinia
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Yersinia enterocolitica'),
cols = c(ampi, amcl, tica, czol, cfox))
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Yersinia pseudotuberculosis'),
cols = c(poly, coli))
# Table 2: Intrinsic resistance in non-fermentative Gram-negative bacteria ----
if (info == TRUE) {
cat('...Table 2: Intrinsic resistance in non-fermentative Gram-negative bacteria\n')
}
#voortgang <- progress_estimated(8)
# Intrisiek R voor groep
edit_rsi(to = 'R',
rows = which(tbl$genus %in% c('Achromobacter',
'Acinetobacter',
'Alcaligenes',
'Bordatella',
'Burkholderia',
'Elizabethkingia',
'Flavobacterium',
'Ochrobactrum',
'Pseudomonas',
'Stenotrophomonas')),
cols = c(peni, cfox, cfur, glycopeptiden, fusi, macroliden, linc, streptogramines, rifa, dapt, line))
# Acinetobacter
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Acinetobacter (baumannii|pittii|nosocomialis|calcoaceticus)'),
cols = c(ampi, amcl, czol, cfot, cftr, aztr, erta, trim, fosf, tetracyclines[tetracyclines != 'mino']))
# Achromobacter
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Achromobacter (xylosoxydans|xylosoxidans)'),
cols = c(ampi, czol, cfot, cftr, erta))
# Burkholderia
edit_rsi(to = 'R',
# onder 'Burkholderia cepacia complex' vallen deze species allemaal: PMID 16217180.
rows = which(tbl$fullname %like% '^Burkholderia (cepacia|multivorans|cenocepacia|stabilis|vietnamiensis|dolosa|ambifaria|anthina|pyrrocinia|ubonensis)'),
cols = c(ampi, amcl, tica, pita, czol, cfot, cftr, aztr, erta, cipr, chlo, aminoglycosiden, trim, fosf, polymyxines))
# Elizabethkingia
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Elizabethkingia meningoseptic(a|um)'),
cols = c(ampi, amcl, tica, czol, cfot, cftr, cfta, cfep, aztr, erta, imip, mero, polymyxines))
# Ochrobactrum
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Ochrobactrum anthropi'),
cols = c(ampi, amcl, tica, pita, czol, cfot, cftr, cfta, cfep, aztr, erta))
# Pseudomonas
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Pseudomonas aeruginosa'),
cols = c(ampi, amcl, czol, cfot, cftr, erta, chlo, kana, neom, trim, trsu, tetracyclines, tige))
# Stenotrophomonas
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Stenotrophomonas maltophilia'),
cols = c(ampi, amcl, tica, pita, czol, cfot, cftr, cfta, aztr, erta, imip, mero, aminoglycosiden, trim, fosf, tetr))
# Table 3: Intrinsic resistance in other Gram-negative bacteria ----
if (info == TRUE) {
cat('...Table 3: Intrinsic resistance in other Gram-negative bacteria\n')
}
#voortgang <- progress_estimated(7)
# Intrisiek R voor groep
edit_rsi(to = 'R',
rows = which(tbl$genus %in% c('Haemophilus',
'Moraxella',
'Neisseria',
'Campylobacter')),
cols = c(glycopeptiden, linc, dapt, line))
# Haemophilus
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Haemophilus influenzae'),
cols = c(fusi, streptogramines))
# Moraxella
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Moraxella catarrhalis'),
cols = trim)
# Neisseria
edit_rsi(to = 'R',
rows = which(tbl$genus == 'Neisseria'),
cols = trim)
# Campylobacter
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Campylobacter fetus'),
cols = c(fusi, streptogramines, trim, nali))
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Campylobacter (jejuni|coli)'),
cols = c(fusi, streptogramines, trim))
# Table 4: Intrinsic resistance in Gram-positive bacteria ----
if (info == TRUE) {
cat('...Table 4: Intrinsic resistance in Gram-positive bacteria\n')
}
#voortgang <- progress_estimated(14)
# Intrisiek R voor groep
edit_rsi(to = 'R',
rows = which(tbl$gramstain %like% 'Positi(e|)(v|f)'),
cols = c(aztr, polymyxines, nali))
# Staphylococcus
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Staphylococcus saprophyticus'),
cols = c(fusi, cfta, fosf, novo))
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Staphylococcus (cohnii|xylosus)'),
cols = c(cfta, novo))
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Staphylococcus capitis'),
cols = c(cfta, fosf))
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Staphylococcus (aureus|epidermidis|coagulase negatief|hominis|haemolyticus|intermedius|pseudointermedius)'),
cols = cfta)
# Streptococcus
edit_rsi(to = 'R',
rows = which(tbl$genus == 'Streptococcus'),
cols = c(fusi, cfta, aminoglycosiden))
# Enterococcus
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Enterococcus faecalis'),
cols = c(fusi, cfta, cefalosporines[cefalosporines != cfta], aminoglycosiden, macroliden, clin, qida, trim, trsu))
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Enterococcus (gallinarum|casseliflavus)'),
cols = c(fusi, cfta, cefalosporines[cefalosporines != cfta], aminoglycosiden, macroliden, clin, qida, vanc, trim, trsu))
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Enterococcus faecium'),
cols = c(fusi, cfta, cefalosporines[cefalosporines != cfta], aminoglycosiden, macroliden, trim, trsu))
# Corynebacterium
edit_rsi(to = 'R',
rows = which(tbl$genus == 'Corynebacterium'),
cols = fosf)
# Listeria
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Listeria monocytogenes'),
cols = c(cfta, cefalosporines[cefalosporines != cfta]))
# overig
edit_rsi(to = 'R',
rows = which(tbl$genus %in% c('Leuconostoc', 'Pediococcus')),
cols = c(vanc, teic))
edit_rsi(to = 'R',
rows = which(tbl$genus == 'Lactobacillus'),
cols = c(vanc, teic))
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Clostridium (ramosum|innocuum)'),
cols = vanc)
# Table 8: Interpretive rules for B-lactam agents and Gram-positive cocci ----
if (info == TRUE) {
cat('...Table 8: Interpretive rules for B-lactam agents and Gram-positive cocci\n')
}
#voortgang <- progress_estimated(2)
# regel 8.3
if (!is.na(peni)) {
edit_rsi(to = 'S',
rows = which(tbl$fullname %like% '^Streptococcus (pyogenes|agalactiae|dysgalactiae|groep A|groep B|groep C|groep G)'
& tbl[, peni] == 'S'),
cols = c(aminopenicillines, cefalosporines, carbapenems))
}
# regel 8.6
if (!is.na(ampi)) {
edit_rsi(to = 'R',
rows = which(tbl$genus == 'Enterococcus'
& tbl[, ampi] == 'R'),
cols = c(ureidopenicillines, carbapenems))
}
# Table 9: Interpretive rules for B-lactam agents and Gram-negative rods ----
if (info == TRUE) {
cat('...Table 9: Interpretive rules for B-lactam agents and Gram-negative rods\n')
}
#voortgang <- progress_estimated(1)
# regel 9.3
if (!is.na(tica) & !is.na(pita)) {
edit_rsi(to = 'R',
rows = which(tbl$family == 'Enterobacteriaceae'
& tbl[, tica] == 'R'
& tbl[, pita] == 'S'),
cols = pita)
}
# Table 10: Interpretive rules for B-lactam agents and other Gram-negative bacteria ----
if (info == TRUE) {
cat('...Table 10: Interpretive rules for B-lactam agents and other Gram-negative bacteria\n')
}
#voortgang <- progress_estimated(1)
# regel 10.2
if (!is.na(ampi)) {
# hiervoor moeten we eerst weten of ze B-lactamase-positief zijn
# edit_rsi(to = 'R',
# rows = which(tbl$fullname %like% '^Haemophilus influenza'
# & tbl[, ampi] == 'R'),
# cols = c(ampi, amox, amcl, pita, cfur))
}
# Table 11: Interpretive rules for macrolides, lincosamides, and streptogramins ----
if (info == TRUE) {
cat('...Table 11: Interpretive rules for macrolides, lincosamides, and streptogramins\n')
}
# regel 11.1
if (!is.na(eryt)) {
if (!is.na(azit)) {
tbl[, azit] <- tbl[, eryt]
}
if (!is.na(clar)) {
tbl[, clar] <- tbl[, eryt]
}
}
# Table 12: Interpretive rules for aminoglycosides ----
if (info == TRUE) {
cat('...Table 12: Interpretive rules for aminoglycosides\n')
}
#voortgang <- progress_estimated(4)
# regel 12.2
if (!is.na(tobr)) {
edit_rsi(to = 'R',
rows = which(tbl$genus == 'Staphylococcus'
& tbl[, tobr] == 'R'),
cols = c(kana, amik))
}
# regel 12.3
if (!is.na(gent)) {
edit_rsi(to = 'R',
rows = which(tbl$genus == 'Staphylococcus'
& tbl[, gent] == 'R'),
cols = aminoglycosiden)
}
# regel 12.8
if (!is.na(gent) & !is.na(tobr)) {
edit_rsi(to = 'R',
rows = which(tbl$family == 'Enterobacteriaceae'
& tbl[, gent] == 'I'
& tbl[, tobr] == 'S'),
cols = gent)
}
# regel 12.9
if (!is.na(gent) & !is.na(tobr)) {
edit_rsi(to = 'R',
rows = which(tbl$family == 'Enterobacteriaceae'
& tbl[, tobr] == 'I'
& tbl[, gent] == 'R'),
cols = tobr)
}
# Table 13: Interpretive rules for quinolones ----
if (info == TRUE) {
cat('...Table 13: Interpretive rules for quinolones\n')
}
#voortgang <- progress_estimated(4)
# regel 13.2
if (!is.na(moxi)) {
edit_rsi(to = 'R',
rows = which(tbl$genus == 'Staphylococcus'
& tbl[, moxi] == 'R'),
cols = fluorochinolonen)
}
# regel 13.4
if (!is.na(moxi)) {
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Streptococcus pneumoniae'
& tbl[, moxi] == 'R'),
cols = fluorochinolonen)
}
# regel 13.5
if (!is.na(cipr)) {
edit_rsi(to = 'R',
rows = which(tbl$family == 'Enterobacteriaceae'
& tbl[, cipr] == 'R'),
cols = fluorochinolonen)
}
# regel 13.8
if (!is.na(cipr)) {
edit_rsi(to = 'R',
rows = which(tbl$fullname %like% '^Neisseria gonorrhoeae'
& tbl[, cipr] == 'R'),
cols = fluorochinolonen)
}
# Other ----
if (info == TRUE) {
cat('...Other\n')
}
#voortgang <- progress_estimated(2)
if (!is.na(amcl)) {
edit_rsi(to = 'R',
rows = which(tbl[, amcl] == 'R'),
cols = ampi)
}
if (!is.na(trsu)) {
edit_rsi(to = 'R',
rows = which(tbl[, trsu] == 'R'),
cols = trim)
}
if (!is.na(ampi) & !is.na(amox)) {
tbl[, amox] <- tbl[, ampi]
}
# Toegevoegde kolommen weer verwijderen
bactlist.ncol <- ncol(AMR::bactlist) - 2
tbl.ncol <- ncol(tbl)
tbl <- tbl %>% select(-c((tbl.ncol - bactlist.ncol):tbl.ncol))
# en eventueel toegevoegde suffix aan bestaande kolommen weer verwijderen
colnames(tbl) <- gsub("_tempbactlist", "", colnames(tbl))
if (info == TRUE) {
cat('\nDone.\nExpert rules applied to', total, 'test results.\n')
}
tbl
}
#' @rdname EUCAST
#' @export
interpretive_reading <- function(...) {
EUCAST_rules(...)
}
#' Poperties of a microorganism
#'
#' @param bactcode ID of a microorganisme, like \code{"STAAUR} and \code{"ESCCOL}
#' @param property One of the values \code{bactid}, \code{bactsys}, \code{family}, \code{genus}, \code{species}, \code{subspecies}, \code{fullname}, \code{type}, \code{gramstain}, \code{aerobic}
#' @export
#' @importFrom dplyr %>% filter select
#' @seealso \code{\link{bactlist}}
mo_property <- function(bactcode, property = 'fullname') {
mocode <- as.character(bactcode)
for (i in 1:length(mocode)) {
bug <- mocode[i]
if (!is.na(bug)) {
result = tryCatch({
mocode[i] <-
AMR::bactlist %>%
filter(bactid == bactcode) %>%
select(property) %>%
unlist() %>%
as.character()
}, error = function(error_condition) {
warning('Code ', bug, ' not found in bacteria list.')
}, finally = {
if (mocode[i] == bug & !property %in% c('bactid', 'bactsys')) {
mocode[i] <- NA
}
})
}
}
mocode
}

121
R/atc.R Normal file
View File

@ -0,0 +1,121 @@
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Analysis #
# #
# AUTHORS #
# Berends MS (m.s.berends@umcg.nl), Luz CF (c.f.luz@umcg.nl) #
# #
# LICENCE #
# This program is free software; you can redistribute it and/or modify #
# it under the terms of the GNU General Public License version 2.0, #
# as published by the Free Software Foundation. #
# #
# This program is distributed in the hope that it will be useful, #
# but WITHOUT ANY WARRANTY; without even the implied warranty of #
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the #
# GNU General Public License for more details. #
# ==================================================================== #
#' Properties of an ATC code
#'
#' Gets data from the WHO to determine properties of an ATC of e.g. an antibiotic.
#' @param atc_code a character or character vector with ATC code(s) of antibiotic(s)
#' @param property property of an ATC code. Valid values are \code{"ATC code"}, \code{"Name"}, \code{"DDD"}, \code{"U"} (\code{"unit"}), \code{"Adm.R"} en \code{"Note"}.
#' @param administration type of administration, see \emph{Details}
#' @param url url of website of the WHO. The sign \code{\%s} can be used as a placeholder for ATC codes.
#' @details
#' Abbreviations for the property \code{"Adm.R"} (parameter \code{administration}):
#' \itemize{
#' \item{\code{"Implant"}}{ = Implant}
#' \item{\code{"Inhal"}}{ = Inhalation}
#' \item{\code{"Instill"}}{ = Instillation}
#' \item{\code{"N"}}{ = nasal}
#' \item{\code{"O"}}{ = oral}
#' \item{\code{"P"}}{ = parenteral}
#' \item{\code{"R"}}{ = rectal}
#' \item{\code{"SL"}}{ = sublingual/buccal}
#' \item{\code{"TD"}}{ = transdermal}
#' \item{\code{"V"}}{ = vaginal}
#' }
#'
#' Abbreviations for the property \code{"U"} (unit):
#' \itemize{
#' \item{\code{"g"}}{ = gram}
#' \item{\code{"mg"}}{ = milligram}
#' \item{\code{"mcg"}}{ = microgram}
#' \item{\code{"U"}}{ = unit}
#' \item{\code{"TU"}}{ = thousand units}
#' \item{\code{"MU"}}{ = million units}
#' \item{\code{"mmol"}}{ = millimole}
#' \item{\code{"ml"}}{ = milliliter (e.g. eyedrops)}
#' }
#' @export
#' @importFrom dplyr %>% progress_estimated
#' @importFrom xml2 read_html
#' @importFrom rvest html_nodes html_table
#' @source \url{https://www.whocc.no/atc_ddd_alterations__cumulative/ddd_alterations/abbrevations/}
atc_property <- function(atc_code,
property,
administration = 'O',
url = 'https://www.whocc.no/atc_ddd_index/?code=%s&showdescription=no') {
# property <- property %>% tolower()
#
if (property %like% 'unit') {
property <- 'U'
}
# validation of properties
valid_properties.bak <- c("ATC code", "Name", "DDD", "U", "Adm.R", "Note")
valid_properties <- valid_properties.bak #%>% tolower()
if (!property %in% valid_properties) {
stop('Invalid `property`, use one of ', paste(valid_properties, collapse = ", "), '.')
}
returnvalue <- rep(NA_character_, length(atc_code))
if (property == 'DDD') {
returnvalue <- rep(NA_real_, length(atc_code))
}
progress <- progress_estimated(n = length(atc_code))
for (i in 1:length(atc_code)) {
progress$tick()$print()
atc_url <- sub('%s', atc_code[i], url, fixed = TRUE)
tbl <- xml2::read_html(atc_url) %>%
rvest::html_nodes('table') %>%
rvest::html_table(header = TRUE)
if (length(tbl) == 0) {
warning('ATC not found: ', atc_code[i], '. Please check ', atc_url, '.', call. = FALSE)
returnvalue[i] <- NA
next
}
tbl <- tbl[[1]]
if (property == 'Name') {
returnvalue[i] <- tbl[1, 2]
} else {
names(returnvalue)[i] <- tbl[1, 2] %>% as.character()
if (!'Adm.R' %in% colnames(tbl) | is.na(tbl[1, 'Adm.R'])) {
returnvalue[i] <- NA
next
} else {
for (j in 1:nrow(tbl)) {
if (tbl[j, 'Adm.R'] == administration) {
returnvalue[i] <- tbl[j, property]
}
}
}
}
}
cat('\n')
returnvalue
}

356
R/classes.R Normal file
View File

@ -0,0 +1,356 @@
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Analysis #
# #
# AUTHORS #
# Berends MS (m.s.berends@umcg.nl), Luz CF (c.f.luz@umcg.nl) #
# #
# LICENCE #
# This program is free software; you can redistribute it and/or modify #
# it under the terms of the GNU General Public License version 2.0, #
# as published by the Free Software Foundation. #
# #
# This program is distributed in the hope that it will be useful, #
# but WITHOUT ANY WARRANTY; without even the implied warranty of #
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the #
# GNU General Public License for more details. #
# ==================================================================== #
#' Class 'rsi'
#'
#' This transforms a vector to a new class \code{rsi}, which is an ordered factor with levels \code{S < I < R}. Invalid antimicrobial interpretations will be translated as \code{NA} with a warning.
#' @rdname as.rsi
#' @param x vector
#' @return New class \code{rsi}
#' @export
#' @importFrom dplyr %>%
#' @examples
#' 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"))
as.rsi <- function(x) {
if (is.rsi(x)) {
x
} else {
x <- x %>% unlist()
x.bak <- x
na_before <- x[is.na(x) | x == ''] %>% length()
x <- gsub('[^RSI]+', '', x %>% toupper())
# needed for UMCG in cases of "S;S" but also "S;I"; the latter will be NA:
x <- gsub('^S+$', 'S', x)
x <- gsub('^I+$', 'I', x)
x <- gsub('^R+$', 'R', x)
x[!x %in% c('S', 'I', 'R')] <- NA
na_after <- x[is.na(x) | x == ''] %>% length()
if (na_before != na_after) {
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ''] %>%
unique() %>%
sort()
list_missing <- paste0('"', list_missing , '"', collapse = ", ")
warning(na_after - na_before, ' results truncated (',
round(((na_after - na_before) / length(x)) / 100),
'%) that were invalid antimicrobial interpretations: ',
list_missing, call. = FALSE)
}
x <- x %>% toupper() %>% factor(levels = c("S", "I", "R"), ordered = TRUE)
class(x) <- c('rsi', 'ordered', 'factor')
x
}
}
#' @rdname as.rsi
#' @export
#' @importFrom dplyr %>%
is.rsi <- function(x) {
class(x) %>% identical(c('rsi', 'ordered', 'factor'))
}
#' @exportMethod print.rsi
#' @export
#' @importFrom dplyr %>%
#' @noRd
print.rsi <- function(x, ...) {
n_total <- x %>% length()
x <- x[!is.na(x)]
n <- x %>% length()
S <- x[x == 'S'] %>% length()
I <- x[x == 'I'] %>% length()
R <- x[x == 'R'] %>% length()
IR <- x[x %in% c('I', 'R')] %>% length()
cat("Class 'rsi': ", n, " isolates\n", sep = '')
cat('\n')
cat('<NA>: ', n_total - n, '\n')
cat('Sum of S: ', S, '\n')
cat('Sum of IR: ', IR, '\n')
cat('- Sum of R:', R, '\n')
cat('- Sum of I:', I, '\n')
cat('\n')
print(c(
`%S` = round((S / n) * 100, 1),
`%IR` = round((IR / n) * 100, 1),
`%I` = round((I / n) * 100, 1),
`%R` = round((R / n) * 100, 1)
))
}
#' @exportMethod summary.rsi
#' @export
#' @importFrom dplyr %>%
#' @noRd
summary.rsi <- function(object, ...) {
x <- object
n_total <- x %>% length()
x <- x[!is.na(x)]
n <- x %>% length()
S <- x[x == 'S'] %>% length()
I <- x[x == 'I'] %>% length()
R <- x[x == 'R'] %>% length()
IR <- x[x %in% c('I', 'R')] %>% length()
lst <- c('rsi', n_total - n, S, IR, R, I)
names(lst) <- c("Mode", "<NA>", "Sum S", "Sum IR", "Sum R", "Sum I")
lst
}
#' @exportMethod plot.rsi
#' @export
#' @importFrom dplyr %>% group_by summarise filter mutate if_else
#' @importFrom graphics plot text
#' @noRd
plot.rsi <- function(x, ...) {
x_name <- deparse(substitute(x))
data <- data.frame(x = x,
y = 1,
stringsAsFactors = TRUE) %>%
group_by(x) %>%
summarise(n = sum(y)) %>%
filter(!is.na(x)) %>%
mutate(s = round((n / sum(n)) * 100, 1))
data$x <- factor(data$x, levels = c('S', 'I', 'R'), ordered = TRUE)
ymax <- if_else(max(data$s) > 95, 105, 100)
plot(x = data$x,
y = data$s,
lwd = 2,
col = c('green', 'orange', 'red'),
ylim = c(0, ymax),
ylab = 'Percentage',
xlab = 'Antimicrobial Interpretation',
main = paste('Susceptibilty Analysis of', x_name),
...)
text(x = data$x,
y = data$s + 5,
labels = paste0(data$s, '% (n = ', data$n, ')'))
}
#' Class 'mic'
#'
#' This transforms a vector to a new class\code{mic}, which is an ordered factor valid MIC values as levels. Invalid MIC values will be translated as \code{NA} with a warning.
#' @rdname as.mic
#' @param x vector
#' @param na.rm a logical indicating whether missing values should be removed
#' @return New class \code{mic}
#' @export
#' @importFrom dplyr %>%
as.mic <- function(x, na.rm = FALSE) {
if (is.mic(x)) {
x
} else {
x <- x %>% unlist()
if (na.rm == TRUE) {
x <- x[!is.na(x)]
}
x.bak <- x
# comma to dot
x <- gsub(',', '.', x, fixed = TRUE)
# starting dots must start with 0
x <- gsub('^[.]', '0.', x)
# <=0.2560.512 should be 0.512
x <- gsub('.*[.].*[.]', '0.', x)
# remove ending .0
x <- gsub('[.]0$', '', x)
# remove all after last digit
x <- gsub('[^0-9]$', '', x)
# remove last zeroes
x <- gsub('[.]?0+$', '', x)
lvls <- c("<0.002", "<=0.002", "0.002", ">=0.002", ">0.002",
"<0.003", "<=0.003", "0.003", ">=0.003", ">0.003",
"<0.004", "<=0.004", "0.004", ">=0.004", ">0.004",
"<0.006", "<=0.006", "0.006", ">=0.006", ">0.006",
"<0.008", "<=0.008", "0.008", ">=0.008", ">0.008",
"<0.012", "<=0.012", "0.012", ">=0.012", ">0.012",
"<0.016", "<=0.016", "0.016", ">=0.016", ">0.016",
"<0.023", "<=0.023", "0.023", ">=0.023", ">0.023",
"<0.03", "<=0.03", "0.03", ">=0.03", ">0.03",
"<0.032", "<=0.032", "0.032", ">=0.032", ">0.032",
"<0.047", "<=0.047", "0.047", ">=0.047", ">0.047",
"<0.05", "<=0.05", "0.05", ">=0.05", ">0.05",
"<0.06", "<=0.06", "0.06", ">=0.06", ">0.06",
"<0.0625", "<=0.0625", "0.0625", ">=0.0625", ">0.0625",
"<0.064", "<=0.064", "0.064", ">=0.064", ">0.064",
"<0.09", "<=0.09", "0.09", ">=0.09", ">0.09",
"<0.094", "<=0.094", "0.094", ">=0.094", ">0.094",
"<0.12", "<=0.12", "0.12", ">=0.12", ">0.12",
"<0.125", "<=0.125", "0.125", ">=0.125", ">0.125",
"<0.128", "<=0.128", "0.128", ">=0.128", ">0.128",
"<0.19", "<=0.19", "0.19", ">=0.19", ">0.19",
"<0.25", "<=0.25", "0.25", ">=0.25", ">0.25",
"<0.256", "<=0.256", "0.256", ">=0.256", ">0.256",
"<0.38", "<=0.38", "0.38", ">=0.38", ">0.38",
"<0.5", "<=0.5", "0.5", ">=0.5", ">0.5",
"<0.512", "<=0.512", "0.512", ">=0.512", ">0.512",
"<0.75", "<=0.75", "0.75", ">=0.75", ">0.75",
"<1", "<=1", "1", ">=1", ">1",
"<1.5", "<=1.5", "1.5", ">=1.5", ">1.5",
"<2", "<=2", "2", ">=2", ">2",
"<3", "<=3", "3", ">=3", ">3",
"<4", "<=4", "4", ">=4", ">4",
"<6", "<=6", "6", ">=6", ">6",
"<8", "<=8", "8", ">=8", ">8",
"<10", "<=10", "10", ">=10", ">10",
"<12", "<=12", "12", ">=12", ">12",
"<16", "<=16", "16", ">=16", ">16",
"<20", "<=20", "20", ">=20", ">20",
"<24", "<=24", "24", ">=24", ">24",
"<32", "<=32", "32", ">=32", ">32",
"<40", "<=40", "40", ">=40", ">40",
"<48", "<=48", "48", ">=48", ">48",
"<64", "<=64", "64", ">=64", ">64",
"<80", "<=80", "80", ">=80", ">80",
"<96", "<=96", "96", ">=96", ">96",
"<128", "<=128", "128", ">=128", ">128",
"<160", "<=160", "160", ">=160", ">160",
"<256", "<=256", "256", ">=256", ">256",
"<320", "<=320", "320", ">=320", ">320",
"<512", "<=512", "512", ">=512", ">512",
"<1024", "<=1024", "1024", ">=1024", ">1024")
x <- x %>% as.character()
na_before <- x[is.na(x) | x == ''] %>% length()
x[!x %in% lvls] <- NA
na_after <- x[is.na(x) | x == ''] %>% length()
if (na_before != na_after) {
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ''] %>%
unique() %>%
sort()
list_missing <- paste0('"', list_missing , '"', collapse = ", ")
warning(na_after - na_before, ' results truncated (',
round(((na_after - na_before) / length(x)) / 100),
'%) that were invalid MICs: ',
list_missing, call. = FALSE)
}
x <- factor(x = x,
levels = lvls,
ordered = TRUE)
class(x) <- c('mic', 'ordered', 'factor')
x
}
}
#' @rdname as.mic
#' @export
#' @importFrom dplyr %>%
is.mic <- function(x) {
class(x) %>% identical(c('mic', 'ordered', 'factor'))
}
#' @exportMethod as.double.mic
#' @export
#' @importFrom dplyr %>%
#' @noRd
as.double.mic <- function(x, ...) {
as.double(gsub('(<=)|(>=)', '', as.character(x)))
}
#' @exportMethod as.integer.mic
#' @export
#' @importFrom dplyr %>%
#' @noRd
as.integer.mic <- function(x, ...) {
as.integer(gsub('(<=)|(>=)', '', as.character(x)))
}
#' @exportMethod as.numeric.mic
#' @export
#' @importFrom dplyr %>%
#' @noRd
as.numeric.mic <- function(x, ...) {
as.numeric(gsub('(<=)|(>=)', '', as.character(x)))
}
#' @exportMethod print.mic
#' @export
#' @importFrom dplyr %>% tibble group_by summarise pull
#' @noRd
print.mic <- function(x, ...) {
n_total <- x %>% length()
x <- x[!is.na(x)]
n <- x %>% length()
cat("Class 'mic': ", n, " isolates\n", sep = '')
cat('\n')
cat('<NA> ', n_total - n, '\n')
cat('\n')
tbl <- tibble(x = x, y = 1) %>% group_by(x) %>% summarise(y = sum(y))
cnt <- tbl %>% pull(y)
names(cnt) <- tbl %>% pull(x)
print(cnt)
}
#' @exportMethod summary.mic
#' @export
#' @importFrom dplyr %>% tibble group_by summarise pull
#' @noRd
summary.mic <- function(object, ...) {
x <- object
n_total <- x %>% length()
x <- x[!is.na(x)]
n <- x %>% length()
return(c("Mode" = 'mic',
"NA" = n_total - n,
"Min." = sort(x)[1] %>% as.character(),
"Max." = sort(x)[n] %>% as.character()
))
cat("Class 'mic': ", n, " isolates\n", sep = '')
cat('\n')
cat('<NA> ', n_total - n, '\n')
cat('\n')
tbl <- tibble(x = x, y = 1) %>% group_by(x) %>% summarise(y = sum(y))
cnt <- tbl %>% pull(y)
names(cnt) <- tbl %>% pull(x)
print(cnt)
}
#' @exportMethod plot.mic
#' @export
#' @importFrom dplyr %>% group_by summarise
#' @importFrom graphics plot text
#' @noRd
plot.mic <- function(x, ...) {
x_name <- deparse(substitute(x))
data <- data.frame(mic = x, cnt = 1) %>%
group_by(mic) %>%
summarise(cnt = sum(cnt)) %>%
droplevels()
plot(x = data$mic,
y = data$cnt,
lwd = 2,
ylim = c(-0.5, max(5, max(data$cnt))),
ylab = 'Frequency',
xlab = 'MIC value',
main = paste('MIC values of', x_name),
...)
text(x = data$mic,
y = -0.5,
labels = paste('n =', data$cnt))
}

77
R/data.R Normal file
View File

@ -0,0 +1,77 @@
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Analysis #
# #
# AUTHORS #
# Berends MS (m.s.berends@umcg.nl), Luz CF (c.f.luz@umcg.nl) #
# #
# LICENCE #
# This program is free software; you can redistribute it and/or modify #
# it under the terms of the GNU General Public License version 2.0, #
# as published by the Free Software Foundation. #
# #
# This program is distributed in the hope that it will be useful, #
# but WITHOUT ANY WARRANTY; without even the implied warranty of #
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the #
# GNU General Public License for more details. #
# ==================================================================== #
#' Dataset with 420 antibiotics
#'
#' A dataset containing all antibiotics with a J0 code, with their DDD's.
#' @format A data.frame with 420 observations and 12 variables:
#' \describe{
#' \item{\code{atc}}{ATC code, like \code{J01CR02}}
#' \item{\code{molis}}{MOLIS code, like \code{amcl}}
#' \item{\code{umcg}}{UMCG code, like \code{AMCL}}
#' \item{\code{official}}{Official name by the WHO, like \code{"amoxicillin and enzyme inhibitor"}}
#' \item{\code{official_nl}}{Official name in the Netherlands, like \code{"Amoxicilline met enzymremmer"}}
#' \item{\code{trivial}}{Trivial name in Dutch, like \code{"Amoxicilline/clavulaanzuur"}}
#' \item{\code{oral_ddd}}{Daily Defined Dose (DDD) according to the WHO, oral treatment}
#' \item{\code{oral_units}}{Units of \code{ddd_units}}
#' \item{\code{iv_ddd}}{Daily Defined Dose (DDD) according to the WHO, bij parenteral treatment}
#' \item{\code{iv_units}}{Units of \code{iv_ddd}}
#' \item{\code{atc_group1}}{ATC group in Dutch, like \code{"Macroliden, lincosamiden en streptograminen"}}
#' \item{\code{atc_group2}}{Subgroup of \code{atc_group1} in Dutch, like \code{"Macroliden"}}
#' }
#' @source MOLIS (LIS of Certe) - \url{https://www.certe.nl} \cr \cr GLIMS (LIS of UMCG) - \url{https://www.umcg.nl} \cr \cr World Health Organization - \url{https://www.whocc.no/atc_ddd_index/}
#' @seealso \code{\link{bactlist}}
# todo:
# ablist <- ablist %>% mutate(useful_gramnegative = if_else(atc_group2 == 'Tetracyclines', FALSE, TRUE))
# ablist <- ablist %>% mutate(useful_gramnegative = if_else(atc_group2 %like% 'Glycopept', FALSE, useful_gramnegative))
# Tbl1 Enterobacteriaceae are also intrinsically resistant to benzylpenicillin, glycopeptides, fusidic acid, macrolides (with some exceptions1), lincosamides, streptogramins, rifampicin, daptomycin and linezolid.
# Tbl2 Non-fermentative Gram-negative bacteria are also generally intrinsically resistant to benzylpenicillin, first and second generation cephalosporins, glycopeptides, fusidic acid, macrolides, lincosamides, streptogramins, rifampicin, daptomycin and linezolid
# Tbl3 Gram-negative bacteria other than Enterobacteriaceae and non-fermentative Gram-negative bacteria listed are also intrinsically resistant to glycopeptides, lincosamides, daptomycin and linezolid.
"ablist"
#' Dataset with ~2500 microorganisms
#'
#' A dataset containing all microorganisms of MOLIS. MO codes of the UMCG can be looked up using \code{\link{bactlist.umcg}}.
#' @format A data.frame with 2507 observations and 10 variables:
#' \describe{
#' \item{\code{bactid}}{ID of microorganism}
#' \item{\code{bactsys}}{Bactsyscode of microorganism}
#' \item{\code{family}}{Family name of microorganism}
#' \item{\code{genus}}{Genus name of microorganism, like \code{"Echerichia"}}
#' \item{\code{species}}{Species name of microorganism, like \code{"coli"}}
#' \item{\code{subspecies}}{Subspecies name of bio-/serovar of microorganism, like \code{"EHEC"}}
#' \item{\code{fullname}}{Full name, like \code{"Echerichia coli (EHEC)"}}
#' \item{\code{type}}{Type of microorganism, like \code{"Bacterie"} en \code{"Schimmel/gist"} (these are Dutch)}
#' \item{\code{gramstain}}{Gram of microorganism in Dutch, like \code{"Negatieve staven"}}
#' \item{\code{aerobic}}{Type aerobe/anaerobe of bacteria}
#' }
#' @source MOLIS (LIS of Certe) - \url{https://www.certe.nl}
#' @seealso \code{\link{ablist}} \code{\link{bactlist.umcg}}
"bactlist"
#' Translation table for UMCG with ~1100 microorganisms
#'
#' A dataset containing all bacteria codes of UMCG MMB. These codes can be joined to data with an ID from \code{\link{bactlist}$bactid}, using \code{\link{left_join_bactlist}}.
#' @format A data.frame with 1090 observations and 2 variables:
#' \describe{
#' \item{\code{mocode}}{Code of microorganism according to UMCG MMB}
#' \item{\code{bactid}}{Code of microorganism in \code{\link{bactlist}}}
#' }
#' @source MOLIS (LIS of Certe) - \url{https://www.certe.nl} \cr \cr GLIMS (LIS of UMCG) - \url{https://www.umcg.nl}
#' @seealso \code{\link{bactlist}}
"bactlist.umcg"

507
R/first_isolates.R Normal file
View File

@ -0,0 +1,507 @@
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Analysis #
# #
# AUTHORS #
# Berends MS (m.s.berends@umcg.nl), Luz CF (c.f.luz@umcg.nl) #
# #
# LICENCE #
# This program is free software; you can redistribute it and/or modify #
# it under the terms of the GNU General Public License version 2.0, #
# as published by the Free Software Foundation. #
# #
# This program is distributed in the hope that it will be useful, #
# but WITHOUT ANY WARRANTY; without even the implied warranty of #
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the #
# GNU General Public License for more details. #
# ==================================================================== #
#' Determine first (weighted) isolates
#'
#' Determine first (weighted) isolates of all microorganisms of every patient per episode and (if needed) per specimen type.
#' @param tbl a \code{data.frame} containing isolates.
#' @param col_date column name of the result date (or date that is was received on the lab)
#' @param col_patid column name of the unique IDs of the patients
#' @param col_genus column name of the genus of the microorganisms
#' @param col_species column name of the species of the microorganisms
#' @param col_testcode column name of the test codes, see Details
#' @param col_specimen column name of the specimen type or group
#' @param col_icu column name of the logicals (\code{TRUE}/\code{FALSE}) whether a ward or department is an Intensive Care Unit (ICU)
#' @param col_keyantibiotics column name of the key antibiotics to determine first \emph{weighted} isolates, see \code{\link{key_antibiotics}}.
#' @param episode_days episode in days after which a genus/species combination will be determined as 'first isolate' again
#' @param testcodes_exclude character vector with test codes that should be excluded (caseINsensitive)
#' @param icu_exclude logical whether ICU isolates should be excluded
#' @param filter_specimen specimen group or type that should be excluded
#' @param output_logical return output as \code{logical} (will else the values \code{0} or \code{1})
#' @param ignore_I ignore \code{"I"} as antimicrobial interpretation of key antibiotics (with \code{FALSE}, changes in antibiograms from S to I and I to R will be interpreted as difference)
#' @param info print progress
# @param ... parameters to pass through to \code{first_isolate}.
#' @rdname first_isolate
#' @details To conduct an analysis of antimicrobial resistance, you should only include the first isolate of every patient per episode. If you would not do this, you could easily get an overestimate or underestimate of the resistance of an antibiotic. Imagine that a patient was admitted with an MRSA and that is was found in 5 different blood cultures the following week. The resistance percentage of oxacillin of all \emph{S. aureus} isolates would be overestimated, because you included this MRSA more than once. It would be selection bias.
#'
#' Use \code{col_testcode = NA} to \strong{not} exclude certain test codes (like test codes for screening). In that case \code{testcodes_exclude} will be ignored.
#' @keywords isolate isolates first
#' @importFrom dplyr arrange_at lag between row_number filter mutate arrange
#' @return A vector to add to table, see Examples.
#' @examples
#' \dontrun{
#'
#' tbl$keyab <- key_antibiotics(tbl)
#'
#' tbl$first_isolate <-
#' first_isolate(tbl)
#'
#' tbl$first_isolate_weighed <-
#' first_isolate(tbl,
#' col_keyantibiotics = 'keyab')
#'
#' tbl$first_blood_isolate <-
#' first_isolate(tbl,
#' filter_specimen = 'Blood')
#'
#' tbl$first_blood_isolate_weighed <-
#' first_isolate(tbl,
#' filter_specimen = 'Blood',
#' col_keyantibiotics = 'keyab')
#'
#' tbl$first_urine_isolate <-
#' first_isolate(tbl,
#' filter_specimen = 'Urine')
#'
#' tbl$first_urine_isolate_weighed <-
#' first_isolate(tbl,
#' filter_specimen = 'Urine',
#' col_keyantibiotics = 'keyab')
#'
#' tbl$first_resp_isolate <-
#' first_isolate(tbl,
#' filter_specimen = 'Respiratory')
#'
#' tbl$first_resp_isolate_weighed <-
#' first_isolate(tbl,
#' filter_specimen = 'Respiratory',
#' col_keyantibiotics = 'keyab')
#' }
first_isolate <- function(tbl,
col_date,
col_patid,
col_genus,
col_species,
col_testcode = NA,
col_specimen,
col_icu,
col_keyantibiotics = NA,
episode_days = 365,
testcodes_exclude = '',
icu_exclude = FALSE,
filter_specimen = NA,
output_logical = TRUE,
ignore_I = TRUE,
info = TRUE) {
# controleren of kolommen wel bestaan
check_columns_existance <- function(column, tblname = tbl) {
if (NROW(tblname) <= 1 | NCOL(tblname) <= 1) {
stop('Please check tbl for existance.')
}
if (!is.na(column)) {
if (!(column %in% colnames(tblname))) {
stop('Column ', column, ' not found.')
}
}
}
check_columns_existance(col_date)
check_columns_existance(col_patid)
check_columns_existance(col_genus)
check_columns_existance(col_species)
check_columns_existance(col_testcode)
check_columns_existance(col_icu)
check_columns_existance(col_keyantibiotics)
if (is.na(col_testcode)) {
testcodes_exclude <- NA
}
# testcodes verwijderen die ingevuld zijn
if (!is.na(testcodes_exclude[1]) & testcodes_exclude[1] != '' & info == TRUE) {
cat('Isolates from these test codes will be ignored:\n', toString(testcodes_exclude), '\n')
}
if (is.na(col_icu)) {
icu_exclude <- FALSE
} else {
tbl <- tbl %>%
mutate(col_icu = tbl %>% pull(col_icu) %>% as.logical())
}
specgroup.notice <- ''
weighted.notice <- ''
# filteren op materiaalgroep en sleutelantibiotica gebruiken wanneer deze ingevuld zijn
if (!is.na(filter_specimen) & filter_specimen != '') {
check_columns_existance(col_specimen, tbl)
if (info == TRUE) {
cat('Isolates other than of specimen group \'', filter_specimen, '\' will be ignored. ', sep = '')
}
} else {
filter_specimen <- ''
}
if (col_keyantibiotics %in% c(NA, '')) {
col_keyantibiotics <- ''
} else {
tbl <- tbl %>% mutate(key_ab = tbl %>% pull(col_keyantibiotics))
}
if (is.na(testcodes_exclude[1])) {
testcodes_exclude <- ''
}
# nieuwe dataframe maken met de oorspronkelijke rij-index, 0-bepaling en juiste sortering
#cat('Sorting table...')
tbl <- tbl %>%
mutate(first_isolate_row_index = 1:nrow(tbl),
eersteisolaatbepaling = 0,
date_lab = tbl %>% pull(col_date),
species = if_else(is.na(species), '', species),
genus = if_else(is.na(genus), '', genus))
if (filter_specimen == '') {
if (icu_exclude == FALSE) {
if (info == TRUE) {
cat('Isolates from ICU will *NOT* be ignored.\n')
}
tbl <- tbl %>%
arrange_at(c(col_patid,
col_genus,
col_species,
col_date))
row.start <- 1
row.end <- nrow(tbl)
} else {
if (info == TRUE) {
cat('Isolates from ICU will be ignored.\n')
}
tbl <- tbl %>%
arrange_at(c(col_icu,
col_patid,
col_genus,
col_species,
col_date))
suppressWarnings(
row.start <- which(tbl %>% pull(col_icu) == FALSE) %>% min(na.rm = TRUE)
)
suppressWarnings(
row.end <- which(tbl %>% pull(col_icu) == FALSE) %>% max(na.rm = TRUE)
)
}
} else {
# sorteren op materiaal en alleen die rijen analyseren om tijd te besparen
if (icu_exclude == FALSE) {
if (info == TRUE) {
cat('Isolates from ICU will *NOT* be ignored.\n')
}
tbl <- tbl %>%
arrange_at(c(col_specimen,
col_patid,
col_genus,
col_species,
col_date))
suppressWarnings(
row.start <- which(tbl %>% pull(col_specimen) == filter_specimen) %>% min(na.rm = TRUE)
)
suppressWarnings(
row.end <- which(tbl %>% pull(col_specimen) == filter_specimen) %>% max(na.rm = TRUE)
)
} else {
if (info == TRUE) {
cat('Isolates from ICU will be ignored.\n')
}
tbl <- tbl %>%
arrange_at(c(col_icu,
col_specimen,
col_patid,
col_genus,
col_species,
col_date))
suppressWarnings(
row.start <- which(tbl %>% pull(col_specimen) == filter_specimen
& tbl %>% pull(col_icu) == FALSE) %>% min(na.rm = TRUE)
)
suppressWarnings(
row.end <- which(tbl %>% pull(col_specimen) == filter_specimen
& tbl %>% pull(col_icu) == FALSE) %>% max(na.rm = TRUE)
)
}
}
if (abs(row.start) == Inf | abs(row.end) == Inf) {
if (info == TRUE) {
cat('No isolates found.\n')
}
# NA's maken waar genus niet beschikbaar is
tbl <- tbl %>%
mutate(real_first_isolate = if_else(genus == '', NA, FALSE))
if (output_logical == FALSE) {
tbl$real_first_isolate <- tbl %>% pull(real_first_isolate) %>% as.integer()
}
return(tbl %>% pull(real_first_isolate))
}
scope.size <- tbl %>%
filter(row_number() %>%
between(row.start,
row.end),
genus != '') %>%
nrow()
# Analyse van eerste isolaat ----
all_first <- tbl %>%
mutate(other_pat_or_mo = if_else(patient_id == lag(patient_id)
& genus == lag(genus)
& species == lag(species),
FALSE,
TRUE),
days_diff = 0) %>%
mutate(days_diff = if_else(other_pat_or_mo == FALSE,
(date_lab - lag(date_lab)) + lag(days_diff),
0))
if (col_keyantibiotics != '') {
# dit duurt 2 min bij 120.000 isolaten
if (info == TRUE) {
cat('Comparing key antibiotics for first weighted isolates')
if (ignore_I == TRUE) {
cat(' (ignoring I)')
}
cat('...\n')
}
all_first <- all_first %>%
mutate(key_ab_lag = lag(key_ab)) %>%
mutate(key_ab_other = !key_antibiotics_equal(key_ab,
key_ab_lag,
ignore_I = ignore_I,
info = info)) %>%
mutate(
real_first_isolate =
if_else(
between(row_number(), row.start, row.end)
& genus != ''
& (other_pat_or_mo
| days_diff >= episode_days
| key_ab_other),
TRUE,
FALSE))
if (info == TRUE) {
cat('\n')
}
} else {
all_first <- all_first %>%
mutate(
real_first_isolate =
if_else(
between(row_number(), row.start, row.end)
& genus != ''
& (other_pat_or_mo
| days_diff >= episode_days),
TRUE,
FALSE))
}
# allereerst isolaat als TRUE
all_first[row.start, 'real_first_isolate'] <- TRUE
# geen testen die uitgesloten moeten worden, of ICU
if (!is.na(col_testcode)) {
all_first[which(all_first[, col_testcode] %in% tolower(testcodes_exclude)), 'real_first_isolate'] <- FALSE
}
if (icu_exclude == TRUE) {
all_first[which(all_first[, col_icu] == TRUE), 'real_first_isolate'] <- FALSE
}
# NA's maken waar genus niet beschikbaar is
all_first <- all_first %>%
mutate(real_first_isolate = if_else(genus == '', NA, real_first_isolate))
all_first <- all_first %>%
arrange(first_isolate_row_index) %>%
pull(real_first_isolate)
if (info == TRUE) {
cat(paste0('\nFound ',
all_first %>% sum(na.rm = TRUE),
' first ', weighted.notice, 'isolates (',
(all_first %>% sum(na.rm = TRUE) / scope.size) %>% percent(),
' of isolates in scope [where genus was not empty] and ',
(all_first %>% sum(na.rm = TRUE) / tbl %>% nrow()) %>% percent(),
' of total)\n'))
}
if (output_logical == FALSE) {
all_first <- all_first %>% as.integer()
}
all_first
}
#' Key antibiotics based on bacteria ID
#'
#' @param tbl table with antibiotics coloms, like \code{amox} and \code{amcl}.
#' @param col_bactcode column of bacteria IDs in \code{tbl}; these should occur in \code{bactlist$bactid}, see \code{\link{bactlist}}
#' @param info print warnings
#' @param amcl,amox,cfot,cfta,cftr,cfur,cipr,clar,clin,clox,doxy,gent,line,mero,peni,pita,rifa,teic,trsu,vanc column names of antibiotics.
#' @export
#' @importFrom dplyr %>% mutate if_else
#' @seealso \code{\link{mo_property}} \code{\link{ablist}}
key_antibiotics <- function(tbl,
col_bactcode = 'bacteriecode',
info = TRUE,
amcl = 'amcl',
amox = 'amox',
cfot = 'cfot',
cfta = 'cfta',
cftr = 'cftr',
cfur = 'cfur',
cipr = 'cipr',
clar = 'clar',
clin = 'clin',
clox = 'clox',
doxy = 'doxy',
gent = 'gent',
line = 'line',
mero = 'mero',
peni = 'peni',
pita = 'pita',
rifa = 'rifa',
teic = 'teic',
trsu = 'trsu',
vanc = 'vanc') {
keylist <- character(length = nrow(tbl))
# check columns
col.list <- c(amox, cfot, cfta, cftr, cfur, cipr, clar,
clin, clox, doxy, gent, line, mero, peni,
pita, rifa, teic, trsu, vanc)
col.list <- col.list[!is.na(col.list)]
if (!all(col.list %in% colnames(tbl))) {
if (info == TRUE) {
warning('These columns do not exist and will be ignored:\n',
col.list[!(col.list %in% colnames(tbl))] %>% toString(),
immediate. = TRUE,
call. = FALSE)
}
}
# bactlist aan vastknopen
tbl <- tbl %>% left_join_bactlist(col_bactcode)
tbl$key_ab <- NA_character_
# Staphylococcus
list_ab <- c(clox, trsu, teic, vanc, doxy, line, clar, rifa)
list_ab <- list_ab[list_ab %in% colnames(tbl)]
tbl <- tbl %>% mutate(key_ab =
if_else(genus == 'Staphylococcus',
apply(X = tbl[, list_ab],
MARGIN = 1,
FUN = function(x) paste(x, collapse = "")),
key_ab))
# Rest of Gram +
list_ab <- c(peni, amox, teic, vanc, clin, line, clar, trsu)
list_ab <- list_ab[list_ab %in% colnames(tbl)]
tbl <- tbl %>% mutate(key_ab =
if_else(gramstain %like% '^Positi[e]?ve',
apply(X = tbl[, list_ab],
MARGIN = 1,
FUN = function(x) paste(x, collapse = "")),
key_ab))
# Gram -
list_ab <- c(amox, amcl, pita, cfur, cfot, cfta, cftr, mero, cipr, trsu, gent)
list_ab <- list_ab[list_ab %in% colnames(tbl)]
tbl <- tbl %>% mutate(key_ab =
if_else(gramstain %like% '^Negati[e]?ve',
apply(X = tbl[, list_ab],
MARGIN = 1,
FUN = function(x) paste(x, collapse = "")),
key_ab))
# format
tbl <- tbl %>%
mutate(key_ab = gsub('(NA|NULL)', '-', key_ab) %>% toupper())
tbl$key_ab
}
#' Compare key antibiotics
#'
#' Check whether two text values with key antibiotics match. Supports vectors.
#' @param x,y tekst (or multiple text vectors) with antimicrobial interpretations
#' @param ignore_I ignore \code{"I"} as antimicrobial interpretation of key antibiotics (with \code{FALSE}, changes in antibiograms from S to I and I to R will be interpreted as difference)
#' @param info print progress
#' @return logical
#' @export
#' @seealso \code{\link{key_antibiotics}}
key_antibiotics_equal <- function(x, y, ignore_I = TRUE, info = FALSE) {
if (length(x) != length(y)) {
stop('Length of `x` and `y` must be equal.')
}
result <- logical(length(x))
if (info == TRUE) {
voortgang <- dplyr::progress_estimated(length(x))
}
for (i in 1:length(x)) {
if (info == TRUE) {
voortgang$tick()$print()
}
if (is.na(x[i])) {
x[i] <- ''
}
if (is.na(y[i])) {
y[i] <- ''
}
if (nchar(x[i]) != nchar(y[i])) {
result[i] <- FALSE
} else if (x[i] == '' & y[i] == '') {
result[i] <- TRUE
} else {
x2 <- strsplit(x[i], "")[[1]]
y2 <- strsplit(y[i], "")[[1]]
if (ignore_I == TRUE) {
valid_chars <- c('S', 's', 'R', 'r')
} else {
valid_chars <- c('S', 's', 'I', 'i', 'R', 'r')
}
# Ongeldige waarden (zoals "-", NA) op beide locaties verwijderen
x2[which(!x2 %in% valid_chars)] <- '?'
x2[which(!y2 %in% valid_chars)] <- '?'
y2[which(!x2 %in% valid_chars)] <- '?'
y2[which(!y2 %in% valid_chars)] <- '?'
result[i] <- all(x2 == y2)
}
}
if (info == TRUE) {
cat('\n')
}
result
}

37
R/globals.R Normal file
View File

@ -0,0 +1,37 @@
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Analysis #
# #
# AUTHORS #
# Berends MS (m.s.berends@umcg.nl), Luz CF (c.f.luz@umcg.nl) #
# #
# LICENCE #
# This program is free software; you can redistribute it and/or modify #
# it under the terms of the GNU General Public License version 2.0, #
# as published by the Free Software Foundation. #
# #
# This program is distributed in the hope that it will be useful, #
# but WITHOUT ANY WARRANTY; without even the implied warranty of #
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the #
# GNU General Public License for more details. #
# ==================================================================== #
globalVariables(c('.',
'abname',
'bactid',
'cnt',
'date_lab',
'days_diff',
'first_isolate_row_index',
'genus',
'gramstain',
'key_ab',
'key_ab_lag',
'key_ab_other',
'mic',
'n',
'other_pat_or_mo',
'patient_id',
'real_first_isolate',
'species',
'y'))

98
R/join.R Normal file
View File

@ -0,0 +1,98 @@
#' Join van tabel en \code{bactlist}
#'
#' Join the list of microorganisms \code{\link{bactlist}} easily to an existing table.
#' @rdname join
#' @name join
#' @aliases join inner_join
#' @param x existing table to join
#' @param by a variable to join by - could be a column name of \code{x} with values that exist in \code{bactlist$bactid} (like \code{by = "bacteria_id"}), or another column in \code{\link{bactlist}} (but then it should be named, like \code{by = c("my_genus_species" = "fullname")})
#' @param ... other parameters to pass trhough to \code{dplyr::\link[dplyr]{join}}.
#' @details As opposed to the \code{\link[dplyr]{join}} functions of \code{dplyr}, at default existing columns will get a suffix \code{"2"} and the newly joined columns will not get a suffix. See \code{\link[dplyr]{join}} for more information.
#' @export
inner_join_bactlist <- function(x, by = 'bactid', ...) {
# no name set to `by` parameter
if (is.null(names(by))) {
joinby <- colnames(AMR::bactlist)[1]
names(joinby) <- by
} else {
joinby <- by
}
join <- dplyr::inner_join(x = x, y = AMR::bactlist, by = joinby, suffix = c("2", ""), ...)
if (nrow(join) > nrow(x)) {
warning('the newly joined tbl contains ', nrow(join) - nrow(x), ' rows more that its original')
}
join
}
#' @rdname join
#' @export
left_join_bactlist <- function(x, by = 'bacteriecode', ...) {
# no name set to `by` parameter
if (is.null(names(by))) {
joinby <- colnames(AMR::bactlist)[1]
names(joinby) <- by
} else {
joinby <- by
}
join <- dplyr::left_join(x = x, y = AMR::bactlist, by = joinby, suffix = c("2", ""), ...)
if (nrow(join) > nrow(x)) {
warning('the newly joined tbl contains ', nrow(join) - nrow(x), ' rows more that its original')
}
join
}
#' @rdname join
#' @export
right_join_bactlist <- function(x, by = 'bacteriecode', ...) {
# no name set to `by` parameter
if (is.null(names(by))) {
joinby <- colnames(AMR::bactlist)[1]
names(joinby) <- by
} else {
joinby <- by
}
join <- dplyr::right_join(x = x, y = AMR::bactlist, by = joinby, suffix = c("2", ""), ...)
if (nrow(join) > nrow(x)) {
warning('the newly joined tbl contains ', nrow(join) - nrow(x), ' rows more that its original')
}
join
}
#' @rdname join
#' @export
full_join_bactlist <- function(x, by = 'bacteriecode', ...) {
# no name set to `by` parameter
if (is.null(names(by))) {
joinby <- colnames(AMR::bactlist)[1]
names(joinby) <- by
} else {
joinby <- by
}
dplyr::full_join(x = x, y = AMR::bactlist, by = joinby, suffix = c("2", ""), ...)
}
#' @rdname join
#' @export
semi_join_bactlist <- function(x, by = 'bacteriecode', ...) {
# no name set to `by` parameter
if (is.null(names(by))) {
joinby <- colnames(AMR::bactlist)[1]
names(joinby) <- by
} else {
joinby <- by
}
dplyr::semi_join(x = x, y = AMR::bactlist, by = joinby, ...)
}
#' @rdname join
#' @export
anti_join_bactlist <- function(x, by = 'bacteriecode', ...) {
# no name set to `by` parameter
if (is.null(names(by))) {
joinby <- colnames(AMR::bactlist)[1]
names(joinby) <- by
} else {
joinby <- by
}
dplyr::anti_join(x = x, y = AMR::bactlist, by = joinby, ...)
}

31
R/misc.R Normal file
View File

@ -0,0 +1,31 @@
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Analysis #
# #
# AUTHORS #
# Berends MS (m.s.berends@umcg.nl), Luz CF (c.f.luz@umcg.nl) #
# #
# LICENCE #
# This program is free software; you can redistribute it and/or modify #
# it under the terms of the GNU General Public License version 2.0, #
# as published by the Free Software Foundation. #
# #
# This program is distributed in the hope that it will be useful, #
# but WITHOUT ANY WARRANTY; without even the implied warranty of #
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the #
# GNU General Public License for more details. #
# ==================================================================== #
# No export, no Rd
"%like%" <- function(vector, pattern) {
# Source: https://github.com/Rdatatable/data.table/blob/master/R/like.R
if (is.factor(vector)) {
as.integer(vector) %in% grep(pattern, levels(vector))
} else {
grepl(pattern, vector)
}
}
percent <- function(x, round = 1, ...) {
base::paste0(base::round(x * 100, digits = round), "%")
}

386
R/rsi_analysis.R Normal file
View File

@ -0,0 +1,386 @@
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Analysis #
# #
# AUTHORS #
# Berends MS (m.s.berends@umcg.nl), Luz CF (c.f.luz@umcg.nl) #
# #
# LICENCE #
# This program is free software; you can redistribute it and/or modify #
# it under the terms of the GNU General Public License version 2.0, #
# as published by the Free Software Foundation. #
# #
# This program is distributed in the hope that it will be useful, #
# but WITHOUT ANY WARRANTY; without even the implied warranty of #
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the #
# GNU General Public License for more details. #
# ==================================================================== #
#' Resistance of isolates in data.frame
#'
#' \strong{NOTE: use \code{\link{rsi}} in dplyr functions like \code{\link[dplyr]{summarise}}.} \cr Calculate the percentage of S, SI, I, IR or R of a \code{data.frame} containing isolates.
#' @param tbl \code{data.frame} containing columns with antibiotic interpretations.
#' @param antibiotics character vector with 1, 2 or 3 antibiotics that occur as column names in \code{tbl}, like \code{antibiotics = c("amox", "amcl")}
#' @param interpretation antimicrobial interpretation of which the portion must be calculated. Valid values are \code{"S"}, \code{"SI"}, \code{"I"}, \code{"IR"} or \code{"R"}.
#' @param minimum minimal amount of available isolates. Any number lower than \code{minimum} will return \code{NA} with a warning (when \code{warning = TRUE}).
#' @param percent return output as percent (text), will else (at default) be a double
#' @param info calculate the amount of available isolates and print it, like \code{n = 423}
#' @param warning show a warning when the available amount of isolates is below \code{minimum}
#' @details Remember that you should filter your table to let it contain \strong{only first isolates}!
#' @keywords rsi antibiotics isolate isolates
#' @return Double or, when \code{percent = TRUE}, a character.
#' @export
#' @importFrom dplyr %>% n_distinct filter filter_at pull vars all_vars any_vars
#' @seealso \code{\link{rsi}} for the function that can be used with \code{\link[dplyr]{summarise}} directly.
#' @examples
#' \dontrun{
#' rsi_df(tbl_with_bloodcultures, 'amcl')
#'
#' rsi_df(tbl_with_bloodcultures, c('amcl', 'gent'), interpretation = 'IR')
#'
#' library(dplyr)
#' # calculate current empiric therapy of Helicobacter gastritis:
#' my_table %>%
#' filter(first_isolate == TRUE,
#' genus == "Helicobacter") %>%
#' rsi_df(antibiotics = c("amox", "metr"))
#' }
rsi_df <- function(tbl,
antibiotics,
interpretation = 'IR',
minimum = 30,
percent = FALSE,
info = TRUE,
warning = TRUE) {
# we willen niet dat tbl$interpretation toevallig ook bestaat, dus:
te_testen_uitslag_ab <- interpretation
# validatie:
if (min(grepl('^[a-z]{3,4}$', antibiotics)) == 0 &
min(grepl('^rsi[1-2]$', antibiotics)) == 0) {
for (i in 1:length(antibiotics)) {
antibiotics[i] <- paste0('rsi', i)
}
}
if (!grepl('^(S|SI|IS|I|IR|RI|R){1}$', te_testen_uitslag_ab)) {
stop('Invalid `interpretation`; must be "S", "SI", "I", "IR", or "R".')
}
if ('is_ic' %in% colnames(tbl)) {
if (n_distinct(tbl$is_ic) > 1) {
warning('Dataset contains isolates from the Intensive Care. Exclude them from proper epidemiological analysis.')
}
}
# transformeren wanneer gezocht wordt op verschillende uitslagen
if (te_testen_uitslag_ab %in% c('SI', 'IS')) {
for (i in 1:length(antibiotics)) {
lijst <- tbl[, antibiotics[i]]
if ('I' %in% lijst) {
tbl[which(tbl[antibiotics[i]] == 'I'), ][antibiotics[i]] <- 'S'
}
}
te_testen_uitslag_ab <- 'S'
}
if (te_testen_uitslag_ab %in% c('RI', 'IR')) {
for (i in 1:length(antibiotics)) {
lijst <- tbl[, antibiotics[i]]
if ('I' %in% lijst) {
tbl[which(tbl[antibiotics[i]] == 'I'), ][antibiotics[i]] <- 'R'
}
}
te_testen_uitslag_ab <- 'R'
}
# breuk samenstellen
if (length(antibiotics) == 1) {
numerator <- tbl %>%
filter(pull(., antibiotics[1]) == te_testen_uitslag_ab) %>%
nrow()
denominator <- tbl %>%
filter(pull(., antibiotics[1]) %in% c("S", "I", "R")) %>%
nrow()
} else if (length(antibiotics) == 2) {
numerator <- tbl %>%
filter_at(vars(antibiotics[1], antibiotics[2]),
any_vars(. == te_testen_uitslag_ab)) %>%
filter_at(vars(antibiotics[1], antibiotics[2]),
all_vars(. %in% c("S", "R", "I"))) %>%
nrow()
denominator <- tbl %>%
filter_at(vars(antibiotics[1], antibiotics[2]),
all_vars(. %in% c("S", "R", "I"))) %>%
nrow()
} else if (length(antibiotics) == 3) {
numerator <- tbl %>%
filter_at(vars(antibiotics[1], antibiotics[2], antibiotics[3]),
any_vars(. == te_testen_uitslag_ab)) %>%
filter_at(vars(antibiotics[1], antibiotics[2], antibiotics[3]),
all_vars(. %in% c("S", "R", "I"))) %>%
nrow()
denominator <- tbl %>%
filter_at(vars(antibiotics[1], antibiotics[2], antibiotics[3]),
all_vars(. %in% c("S", "R", "I"))) %>%
nrow()
} else {
stop('Maximum of 3 drugs allowed.')
}
# tekstdeel opbouwen
if (info == TRUE) {
cat('n =', denominator)
info.txt1 <- percent(denominator / nrow(tbl))
if (denominator == 0) {
info.txt1 <- 'none'
}
info.txt2 <- gsub(',', ' and',
antibiotics %>%
abname(to = 'trivial',
tolower = TRUE) %>%
toString(), fixed = TRUE)
info.txt2 <- gsub('rsi1 and rsi2', 'these two drugs', 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'))
}
# rekenen en opmaken
y <- numerator / denominator
if (percent == TRUE) {
y <- percent(y)
}
if (denominator < minimum) {
if (warning == TRUE) {
warning(paste0('TOO FEW ISOLATES OF ', toString(antibiotics), ' (n = ', denominator, ', n < ', minimum, '); NO RESULT.'))
}
y <- NA
}
# output
y
}
#' Resistance of isolates
#'
#' This function can be used in \code{\link[dplyr]{summarise}}, see \emph{Examples}. CaBerekent het percentage S, SI, I, IR of R van een lijst isolaten.
#' @param ab1,ab2 list with interpretations of an antibiotic
#' @inheritParams rsi_df
#' @details This function uses the \code{\link{rsi_df}} function internally.
#' @keywords rsi antibiotics isolate isolates
#' @return Double or, when \code{percent = TRUE}, a character.
#' @export
#' @examples
#' \dontrun{
#' tbl %>%
#' group_by(year, hospital) %>%
#' summarise(
#' isolates = n(),
#' cipro = rsi(cipr, percent = TRUE),
#' amoxi = rsi(amox, percent = TRUE)
#' )
#'
#' tbl %>%
#' group_by(hospital) %>%
#' summarise(cipr = rsi(cipr))
#'
#' rsi(isolates$amox)
#'
#' rsi(isolates$amcl, interpretation = "S")
#' }
rsi <- function(ab1, ab2 = NA, interpretation = 'IR', minimum = 30, percent = FALSE, info = FALSE, warning = FALSE) {
functietekst <- as.character(match.call())
# param 1 = functienaam
# param 2 = ab1
# param 3 = ab2
ab1.naam <- functietekst[2]
if (!grepl('^[a-z]{3,4}$', ab1.naam)) {
ab1.naam <- 'rsi1'
}
ab2.naam <- functietekst[3]
if (!grepl('^[a-z]{3,4}$', ab2.naam)) {
ab2.naam <- 'rsi2'
}
tbl <- tibble(rsi1 = ab1, rsi2 = ab2)
colnames(tbl) <- c(ab1.naam, ab2.naam)
if (length(ab2) == 1) {
return(rsi_df(tbl = tbl,
antibiotics = ab1.naam,
interpretation = interpretation,
minimum = minimum,
percent = percent,
info = info,
warning = warning))
} else {
if (length(ab1) != length(ab2)) {
stop('`ab1` (n = ', length(ab1), ') and `ab2` (n = ', length(ab2), ') must be of same length.', call. = FALSE)
}
if (interpretation != 'S') {
warning('`interpretation` is not set to S, albeit analysing a combination therapy.')
}
return(rsi_df(tbl = tbl,
antibiotics = c(ab1.naam, ab2.naam),
interpretation = interpretation,
minimum = minimum,
percent = percent,
info = info,
warning = warning))
}
}
#' Predict antimicrobial resistance
#'
#' Create a prediction model to predict antimicrobial resistance for the next years on statistical solid ground. Standard errors (SE) will be returned as columns \code{se_min} and \code{se_max}.
#' @param tbl table that contains columns \code{col_ab} and \code{col_date}
#' @param col_ab column name of \code{tbl} with antimicrobial interpretations (\code{R}, \code{I} and \code{S})
#' @param col_date column name of the date, will be used to calculate years
#' @param year_max highest year to use in the prediction model, deafults to 15 years after today
#' @param year_every unit of sequence between lowest year found in the data and \code{year_max}
#' @param model the statistical model of choice. Valid values are \code{"binomial"} (or \code{"binom"} or \code{"logit"}) or \code{"loglin"} or \code{"linear"} (or \code{"lin"}).
#' @param I_as_R treat \code{I} as \code{R}
#' @param preserve_measurements overwrite predictions of years that are actually available in the data, with the original data. The standard errors of those years will be \code{NA}.
#' @param info print textual analysis with the name and \code{\link{summary}} of the model.
#' @return \code{data.frame} with columns \code{year}, \code{probR}, \code{se_min} and \code{se_max}.
#' @seealso \code{\link{lm}} \cr \code{\link{glm}}
#' @export
#' @importFrom dplyr %>% pull mutate group_by_at summarise filter
#' @importFrom reshape2 dcast
#' @examples
#' \dontrun{
#' # use it directly:
#' rsi_predict(tbl[which(first_isolate == TRUE & genus == "Haemophilus"),], "amcl")
#'
#' # or with dplyr so you can actually read it:
#' tbl %>%
#' filter(first_isolate == TRUE,
#' genus == "Haemophilus") %>%
#' rsi_predict("amcl")
#'
#' tbl %>%
#' filter(first_isolate_weighted == TRUE,
#' genus == "Haemophilus") %>%
#' rsi_predict(col_ab = "amcl",
#' year_max = 2050,
#' year_every = 5)
#'
#' }
rsi_predict <- function(tbl,
col_ab,
col_date = 'ontvangstdatum',
year_max = as.integer(format(as.Date(Sys.Date()), '%Y')) + 15,
year_every = 1,
model = 'binomial',
I_as_R = TRUE,
preserve_measurements = TRUE,
info = TRUE) {
if (I_as_R == TRUE) {
tbl[, col_ab] <- gsub('I', 'R', tbl %>% pull(col_ab))
}
year <- function(x) {
as.integer(format(as.Date(x), '%Y'))
}
years_predict <- seq(from = min(year(tbl %>% pull(col_date))), to = year_max, by = year_every)
df <- tbl %>%
mutate(year = year(tbl %>% pull(col_date))) %>%
group_by_at(c('year', col_ab)) %>%
summarise(n())
colnames(df) <- c('year', 'antibiotic', 'count')
df <- df %>%
reshape2::dcast(year ~ antibiotic, value.var = 'count')
if (model %in% c('binomial', 'binom', 'logit')) {
logitmodel <- with(df, glm(cbind(R, S) ~ year, family = binomial))
if (info == TRUE) {
cat('\nLogistic regression model (logit) with binomial distribution')
cat('\n------------------------------------------------------------\n')
print(summary(logitmodel))
}
predictmodel <- stats::predict(logitmodel, newdata = with(df, list(year = years_predict)), type = "response", se.fit = TRUE)
prediction <- predictmodel$fit
se <- predictmodel$se.fit
} else if (model == 'loglin') {
loglinmodel <- with(df, glm(R ~ year, family = poisson))
if (info == TRUE) {
cat('\nLog-linear regression model (loglin) with poisson distribution')
cat('\n--------------------------------------------------------------\n')
print(summary(loglinmodel))
}
predictmodel <- stats::predict(loglinmodel, newdata = with(df, list(year = years_predict)), type = "response", se.fit = TRUE)
prediction <- predictmodel$fit
se <- predictmodel$se.fit
} else if (model %in% c('lin', 'linear')) {
linmodel <- with(df, lm((R / (R + S)) ~ year))
if (info == TRUE) {
cat('\nLinear regression model')
cat('\n-----------------------\n')
print(summary(linmodel))
}
predictmodel <- stats::predict(linmodel, newdata = with(df, list(year = years_predict)), se.fit = TRUE)
prediction <- predictmodel$fit
se <- predictmodel$se.fit
} else {
stop('No valid model selected.')
}
# prepare the output dataframe
prediction <- data.frame(year = years_predict, probR = prediction, stringsAsFactors = FALSE)
prediction$se_min <- prediction$probR - se
prediction$se_max <- prediction$probR + se
if (model == 'loglin') {
prediction$probR <- prediction$probR %>%
format(scientific = FALSE) %>%
as.integer()
prediction$se_min <- prediction$se_min %>% as.integer()
prediction$se_max <- prediction$se_max %>% as.integer()
colnames(prediction) <- c('year', 'amountR', 'se_max', 'se_min')
} else {
prediction$se_max[which(prediction$se_max > 1)] <- 1
}
prediction$se_min[which(prediction$se_min < 0)] <- 0
total <- prediction
if (preserve_measurements == TRUE) {
# geschatte data vervangen door gemeten data
if (I_as_R == TRUE) {
if (!'I' %in% colnames(df)) {
df$I <- 0
}
df$probR <- df$R / rowSums(df[, c('R', 'S', 'I')])
} else {
df$probR <- df$R / rowSums(df[, c('R', 'S')])
}
measurements <- data.frame(year = df$year,
probR = df$probR,
se_min = NA,
se_max = NA,
stringsAsFactors = FALSE)
colnames(measurements) <- colnames(prediction)
prediction <- prediction %>% filter(!year %in% df$year)
total <- rbind(measurements, prediction)
}
total
}