mirror of
https://github.com/msberends/AMR.git
synced 2025-07-09 21:42:01 +02:00
first commit
This commit is contained in:
637
R/EUCAST.R
Normal file
637
R/EUCAST.R
Normal 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
121
R/atc.R
Normal 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
356
R/classes.R
Normal 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
77
R/data.R
Normal 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
507
R/first_isolates.R
Normal 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
37
R/globals.R
Normal 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
98
R/join.R
Normal 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
31
R/misc.R
Normal 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
386
R/rsi_analysis.R
Normal 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
|
||||
|
||||
}
|
||||
Reference in New Issue
Block a user