P281424
/
AMR
mirror of https://github.com/msberends/AMR.git
1
0
Fork 0
Code Releases Activity
AMR/R/eucast_rules.R

832 lines
44 KiB
R
Raw Normal View History

first commit
2018-02-21 11:52:31 +01:00
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Analysis #
# #
big website update, licence txt update
2019-01-02 23:24:07 +01:00
# SOURCE #
# https://gitlab.com/msberends/AMR #
first commit
2018-02-21 11:52:31 +01:00
# #
# LICENCE #
big website update, licence txt update
2019-01-02 23:24:07 +01:00
# (c) 2019 Berends MS (m.s.berends@umcg.nl), Luz CF (c.f.luz@umcg.nl) #
first commit
2018-02-21 11:52:31 +01:00
# #
big website update, licence txt update
2019-01-02 23:24:07 +01:00
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
# GNU General Public License version 2.0 (GNU GPL-2), as published by #
# the Free Software Foundation. #
# #
# This R package was created for academic research and was publicly #
# released in the hope that it will be useful, but it comes WITHOUT #
# ANY WARRANTY OR LIABILITY. #
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
# Visit our website for more info: https://msberends.gitlab.io/AMR. #
first commit
2018-02-21 11:52:31 +01:00
# ==================================================================== #
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
# global variables
EUCAST_RULES_FILE_LOCATION <- system.file("eucast/eucast_rules.tsv", package = "AMR")
EUCAST_VERSION_BREAKPOINTS <- "9.0, 2019"
EUCAST_VERSION_EXPERT_RULES <- "3.1, 2016"
new EUCAST rules: clinical breakpoints
2018-10-17 17:32:34 +02:00
#' EUCAST rules
first commit
2018-02-21 11:52:31 +01:00
#'
new EUCAST rules: clinical breakpoints
2018-10-17 17:32:34 +02:00
#' Apply susceptibility rules as defined by the European Committee on Antimicrobial Susceptibility Testing (EUCAST, \url{http://eucast.org}), see \emph{Source}. This includes (1) expert rules, (2) intrinsic resistance and (3) inferred resistance as defined in their breakpoint tables.
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
#' @param x data with antibiotic columns, like e.g. \code{amox} and \code{amcl}
first commit
2018-02-21 11:52:31 +01:00
#' @param info print progress
param rules for EUCAST
2018-10-18 12:10:10 +02:00
#' @param rules a character vector that specifies which rules should be applied - one or more of \code{c("breakpoints", "expert", "other", "all")}
mo codes for WHONET
2019-02-08 16:06:54 +01:00
#' @param verbose a logical to indicate whether extensive info should be returned as a \code{data.frame} with info about which rows and columns are effected. It runs all EUCAST rules, but will not be applied to an output - only an informative \code{data.frame} with changes will be returned as output.
AI improvements
2018-12-07 12:04:55 +01:00
#' @param amcl,amik,amox,ampi,azit,azlo,aztr,cefa,cfep,cfot,cfox,cfra,cfta,cftr,cfur,chlo,cipr,clar,clin,clox,coli,czol,dapt,doxy,erta,eryt,fosf,fusi,gent,imip,kana,levo,linc,line,mero,mezl,mino,moxi,nali,neom,neti,nitr,norf,novo,oflo,oxac,peni,pipe,pita,poly,pris,qida,rifa,roxi,siso,teic,tetr,tica,tige,tobr,trim,trsu,vanc column name of an antibiotic, see Antibiotics
MDRO update
2018-11-16 20:50:50 +01:00
#' @param ... parameters that are passed on to \code{eucast_rules}
test syntax fix
2018-11-01 20:50:10 +01:00
#' @inheritParams first_isolate
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
#' @details
cfta streptococci, codecov.yml
2019-04-09 14:59:17 +02:00
#' \strong{NOTE:} This function does not translate MIC values to RSI values. It only applies (1) inferred susceptibility and resistance based on results of other antibiotics and (2) intrinsic resistance based on taxonomic properties of a microorganism.
#'
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
#' The file used for applying all EUCAST rules can be retrieved with \code{\link{eucast_rules_file}()}. It returns an easily readable data set containing all rules. The original TSV file (tab separated file) that is being read by this function can be found when running this command: \cr
#' \code{AMR::EUCAST_RULES_FILE_LOCATION} (without brackets).
#'
#' In the source code it is located under \href{https://gitlab.com/msberends/AMR/blob/master/inst/eucast/eucast_rules.tsv}{\code{./inst/eucast/eucast_rules.tsv}}.
#'
#' \strong{Note:} When ampicillin (J01CA01) is not available but amoxicillin (J01CA04) is, the latter will be used for all rules where there is a dependency on ampicillin. These drugs are interchangeable when it comes to expression of antimicrobial resistance.
replaced bactid by mo
2018-08-31 13:36:19 +02:00
#' @section Antibiotics:
guess_ab_col, benchmarks
2019-01-11 20:37:23 +01:00
#' To define antibiotics column names, leave as it is to determine it automatically with \code{\link{guess_ab_col}} or input a text (case-insensitive) or use \code{NULL} to skip a column (e.g. \code{tica = NULL}). Non-existing columns will anyway be skipped with a warning.
AI improvements
2018-12-07 12:04:55 +01:00
#'
param rules for EUCAST
2018-10-18 12:10:10 +02:00
#' Abbrevations of the column containing antibiotics in the form: \strong{abbreviation}: generic name (\emph{ATC code})
improvement for forecasting resistance
2018-07-26 16:30:42 +02:00
#'
EUCAST update, as.mo bugfix for empty vlaues
2019-01-08 16:23:45 +01:00
#' \strong{amcl}: amoxicillin+clavulanic acid (\href{https://www.whocc.no/atc_ddd_index/?code=J01CR02}{J01CR02}),
#' \strong{amik}: amikacin (\href{https://www.whocc.no/atc_ddd_index/?code=J01GB06}{J01GB06}),
#' \strong{amox}: amoxicillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01CA04}{J01CA04}),
#' \strong{ampi}: ampicillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01CA01}{J01CA01}),
#' \strong{azit}: azithromycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01FA10}{J01FA10}),
#' \strong{azlo}: azlocillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01CA09}{J01CA09}),
#' \strong{aztr}: aztreonam (\href{https://www.whocc.no/atc_ddd_index/?code=J01DF01}{J01DF01}),
#' \strong{cefa}: cefaloridine (\href{https://www.whocc.no/atc_ddd_index/?code=J01DB02}{J01DB02}),
#' \strong{cfep}: cefepime (\href{https://www.whocc.no/atc_ddd_index/?code=J01DE01}{J01DE01}),
#' \strong{cfot}: cefotaxime (\href{https://www.whocc.no/atc_ddd_index/?code=J01DD01}{J01DD01}),
#' \strong{cfox}: cefoxitin (\href{https://www.whocc.no/atc_ddd_index/?code=J01DC01}{J01DC01}),
#' \strong{cfra}: cefradine (\href{https://www.whocc.no/atc_ddd_index/?code=J01DB09}{J01DB09}),
#' \strong{cfta}: ceftazidime (\href{https://www.whocc.no/atc_ddd_index/?code=J01DD02}{J01DD02}),
#' \strong{cftr}: ceftriaxone (\href{https://www.whocc.no/atc_ddd_index/?code=J01DD04}{J01DD04}),
#' \strong{cfur}: cefuroxime (\href{https://www.whocc.no/atc_ddd_index/?code=J01DC02}{J01DC02}),
#' \strong{chlo}: chloramphenicol (\href{https://www.whocc.no/atc_ddd_index/?code=J01BA01}{J01BA01}),
#' \strong{cipr}: ciprofloxacin (\href{https://www.whocc.no/atc_ddd_index/?code=J01MA02}{J01MA02}),
#' \strong{clar}: clarithromycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01FA09}{J01FA09}),
#' \strong{clin}: clindamycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01FF01}{J01FF01}),
#' \strong{clox}: flucloxacillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01CF05}{J01CF05}),
#' \strong{coli}: colistin (\href{https://www.whocc.no/atc_ddd_index/?code=J01XB01}{J01XB01}),
#' \strong{czol}: cefazolin (\href{https://www.whocc.no/atc_ddd_index/?code=J01DB04}{J01DB04}),
#' \strong{dapt}: daptomycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01XX09}{J01XX09}),
#' \strong{doxy}: doxycycline (\href{https://www.whocc.no/atc_ddd_index/?code=J01AA02}{J01AA02}),
#' \strong{erta}: ertapenem (\href{https://www.whocc.no/atc_ddd_index/?code=J01DH03}{J01DH03}),
#' \strong{eryt}: erythromycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01FA01}{J01FA01}),
#' \strong{fosf}: fosfomycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01XX01}{J01XX01}),
#' \strong{fusi}: fusidic acid (\href{https://www.whocc.no/atc_ddd_index/?code=J01XC01}{J01XC01}),
#' \strong{gent}: gentamicin (\href{https://www.whocc.no/atc_ddd_index/?code=J01GB03}{J01GB03}),
#' \strong{imip}: imipenem (\href{https://www.whocc.no/atc_ddd_index/?code=J01DH51}{J01DH51}),
#' \strong{kana}: kanamycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01GB04}{J01GB04}),
#' \strong{levo}: levofloxacin (\href{https://www.whocc.no/atc_ddd_index/?code=J01MA12}{J01MA12}),
#' \strong{linc}: lincomycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01FF02}{J01FF02}),
#' \strong{line}: linezolid (\href{https://www.whocc.no/atc_ddd_index/?code=J01XX08}{J01XX08}),
#' \strong{mero}: meropenem (\href{https://www.whocc.no/atc_ddd_index/?code=J01DH02}{J01DH02}),
#' \strong{mezl}: mezlocillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01CA10}{J01CA10}),
#' \strong{mino}: minocycline (\href{https://www.whocc.no/atc_ddd_index/?code=J01AA08}{J01AA08}),
#' \strong{moxi}: moxifloxacin (\href{https://www.whocc.no/atc_ddd_index/?code=J01MA14}{J01MA14}),
#' \strong{nali}: nalidixic acid (\href{https://www.whocc.no/atc_ddd_index/?code=J01MB02}{J01MB02}),
#' \strong{neom}: neomycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01GB05}{J01GB05}),
#' \strong{neti}: netilmicin (\href{https://www.whocc.no/atc_ddd_index/?code=J01GB07}{J01GB07}),
#' \strong{nitr}: nitrofurantoin (\href{https://www.whocc.no/atc_ddd_index/?code=J01XE01}{J01XE01}),
#' \strong{norf}: norfloxacin (\href{https://www.whocc.no/atc_ddd_index/?code=J01MA06}{J01MA06}),
#' \strong{novo}: novobiocin (an ATCvet code: \href{https://www.whocc.no/atc_ddd_index/?code=QJ01XX95}{QJ01XX95}),
#' \strong{oflo}: ofloxacin (\href{https://www.whocc.no/atc_ddd_index/?code=J01MA01}{J01MA01}),
#' \strong{peni}: (benzyl)penicillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01CE01}{J01CE01}),
#' \strong{pipe}: piperacillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01CA12}{J01CA12}),
#' \strong{pita}: piperacillin+tazobactam (\href{https://www.whocc.no/atc_ddd_index/?code=J01CR05}{J01CR05}),
#' \strong{poly}: polymyxin B (\href{https://www.whocc.no/atc_ddd_index/?code=J01XB02}{J01XB02}),
#' \strong{pris}: pristinamycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01FG01}{J01FG01}),
#' \strong{qida}: quinupristin/dalfopristin (\href{https://www.whocc.no/atc_ddd_index/?code=J01FG02}{J01FG02}),
#' \strong{rifa}: rifampicin (\href{https://www.whocc.no/atc_ddd_index/?code=J04AB02}{J04AB02}),
#' \strong{roxi}: roxithromycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01FA06}{J01FA06}),
#' \strong{siso}: sisomicin (\href{https://www.whocc.no/atc_ddd_index/?code=J01GB08}{J01GB08}),
#' \strong{teic}: teicoplanin (\href{https://www.whocc.no/atc_ddd_index/?code=J01XA02}{J01XA02}),
#' \strong{tetr}: tetracycline (\href{https://www.whocc.no/atc_ddd_index/?code=J01AA07}{J01AA07}),
#' \strong{tica}: ticarcillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01CA13}{J01CA13}),
#' \strong{tige}: tigecycline (\href{https://www.whocc.no/atc_ddd_index/?code=J01AA12}{J01AA12}),
#' \strong{tobr}: tobramycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01GB01}{J01GB01}),
#' \strong{trim}: trimethoprim (\href{https://www.whocc.no/atc_ddd_index/?code=J01EA01}{J01EA01}),
#' \strong{trsu}: sulfamethoxazole and trimethoprim (\href{https://www.whocc.no/atc_ddd_index/?code=J01EE01}{J01EE01}),
#' \strong{vanc}: vancomycin (\href{https://www.whocc.no/atc_ddd_index/?code=J01XA01}{J01XA01}).
improvement for forecasting resistance
2018-07-26 16:30:42 +02:00
#' @keywords interpretive eucast reading resistance
MDRO update
2018-11-16 20:50:50 +01:00
#' @rdname eucast_rules
first commit
2018-02-21 11:52:31 +01:00
#' @export
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
#' @importFrom dplyr %>% select pull mutate_at vars group_by summarise n
freq: fix na.rm in groups
2018-11-08 16:10:03 +01:00
#' @importFrom crayon bold bgGreen bgYellow bgRed black green blue italic strip_style
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
#' @return The input of \code{tbl_}, possibly with edited values of antibiotics. Or, if \code{verbose = TRUE}, a \code{data.frame} with all original and new values of the affected bug-drug combinations.
first commit
2018-02-21 11:52:31 +01:00
#' @source
new EUCAST rules: clinical breakpoints
2018-10-17 17:32:34 +02:00
#' \itemize{
#' \item{
#' EUCAST Expert Rules. Version 2.0, 2012. \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}
#' }
#' \item{
#' EUCAST Expert Rules, Intrinsic Resistance and Exceptional Phenotypes Tables. Version 3.1, 2016. \cr
#' \url{http://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/Expert_rules_intrinsic_exceptional_V3.1.pdf}
#' }
#' \item{
EUCAST update, as.mo bugfix for empty vlaues
2019-01-08 16:23:45 +01:00
#' EUCAST Breakpoint tables for interpretation of MICs and zone diameters. Version 9.0, 2019. \cr
#' \url{http://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Breakpoint_tables/v_9.0_Breakpoint_Tables.xlsx}
new EUCAST rules: clinical breakpoints
2018-10-17 17:32:34 +02:00
#' }
#' }
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
#'
#' For editing the reference file (which is available with \code{\link{eucast_rules_file}}), these values can all be used for target antibiotics: aminoglycosides, tetracyclines, polymyxins, macrolides, glycopeptides, streptogramins, cephalosporins, cephalosporins_without_cfta, carbapenems, aminopenicillins, ureidopenicillins, fluoroquinolones, all_betalactams, and all separate four letter codes like amcl. They can be separated by comma: \code{"amcl, fluoroquinolones"}. The mo_property can be any column name from the \code{\link{microorganisms}} data set, or \code{genus_species} or \code{gramstain}. This file contains references to the 'Burkholderia cepacia complex'. The species in this group can be found in: LiPuma JJ, 2015 (PMID 16217180).
big website update, licence txt update
2019-01-02 23:24:07 +01:00
#' @inheritSection AMR Read more on our website!
first commit
2018-02-21 11:52:31 +01:00
#' @examples
MDRO update
2018-11-16 20:50:50 +01:00
#' a <- eucast_rules(septic_patients)
CRAN fixes for release 0.4.0 https://cran.r-project.org/web/checks/check_results_AMR.html
2018-10-09 13:53:33 +02:00
#'
#' a <- data.frame(mo = c("Staphylococcus aureus",
#' "Enterococcus faecalis",
#' "Escherichia coli",
#' "Klebsiella pneumoniae",
#' "Pseudomonas aeruginosa"),
replaced bactid by mo
2018-08-31 13:36:19 +02:00
#' vanc = "-", # Vancomycin
#' amox = "-", # Amoxicillin
#' coli = "-", # Colistin
#' cfta = "-", # Ceftazidime
#' cfur = "-", # Cefuroxime
param rules for EUCAST
2018-10-18 12:10:10 +02:00
#' peni = "S", # Benzylpenicillin
#' cfox = "S", # Cefoxitin
add NEWS
2018-02-22 21:37:10 +01:00
#' stringsAsFactors = FALSE)
param rules for EUCAST
2018-10-18 12:10:10 +02:00
#'
add NEWS
2018-02-22 21:37:10 +01:00
#' a
param rules for EUCAST
2018-10-18 12:10:10 +02:00
#' # mo vanc amox coli cfta cfur peni cfox
#' # 1 Staphylococcus aureus - - - - - S S
#' # 2 Enterococcus faecalis - - - - - S S
#' # 3 Escherichia coli - - - - - S S
#' # 4 Klebsiella pneumoniae - - - - - S S
#' # 5 Pseudomonas aeruginosa - - - - - S S
#'
mo codes for WHONET
2019-02-08 16:06:54 +01:00
#'
#' # apply EUCAST rules: 18 results are forced as R or S
#' b <- eucast_rules(a)
update dependencies
2018-04-02 16:05:09 +02:00
#'
add NEWS
2018-02-22 21:37:10 +01:00
#' b
param rules for EUCAST
2018-10-18 12:10:10 +02:00
#' # mo vanc amox coli cfta cfur peni cfox
#' # 1 Staphylococcus aureus - S R R S S S
#' # 2 Enterococcus faecalis - - R R R S R
#' # 3 Escherichia coli R - - - - R S
#' # 4 Klebsiella pneumoniae R R - - - R S
#' # 5 Pseudomonas aeruginosa R R - - R R R
mo codes for WHONET
2019-02-08 16:06:54 +01:00
#'
#'
#' # do not apply EUCAST rules, but rather get a a data.frame
#' # with 18 rows, containing all details about the transformations:
#' c <- eucast_rules(a, verbose = TRUE)
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
eucast_rules <- function(x,
eucast update
2018-11-01 20:23:33 +01:00
col_mo = NULL,
first commit
2018-02-21 11:52:31 +01:00
info = TRUE,
param rules for EUCAST
2018-10-18 12:10:10 +02:00
rules = c("breakpoints", "expert", "other", "all"),
eucast update
2018-11-01 20:23:33 +01:00
verbose = FALSE,
guess_ab_col, benchmarks
2019-01-11 20:37:23 +01:00
amcl = guess_ab_col(),
amik = guess_ab_col(),
amox = guess_ab_col(),
ampi = guess_ab_col(),
azit = guess_ab_col(),
azlo = guess_ab_col(),
aztr = guess_ab_col(),
cefa = guess_ab_col(),
cfep = guess_ab_col(),
cfot = guess_ab_col(),
cfox = guess_ab_col(),
cfra = guess_ab_col(),
cfta = guess_ab_col(),
cftr = guess_ab_col(),
cfur = guess_ab_col(),
chlo = guess_ab_col(),
cipr = guess_ab_col(),
clar = guess_ab_col(),
clin = guess_ab_col(),
clox = guess_ab_col(),
coli = guess_ab_col(),
czol = guess_ab_col(),
dapt = guess_ab_col(),
doxy = guess_ab_col(),
erta = guess_ab_col(),
eryt = guess_ab_col(),
fosf = guess_ab_col(),
fusi = guess_ab_col(),
gent = guess_ab_col(),
imip = guess_ab_col(),
kana = guess_ab_col(),
levo = guess_ab_col(),
linc = guess_ab_col(),
line = guess_ab_col(),
mero = guess_ab_col(),
mezl = guess_ab_col(),
mino = guess_ab_col(),
moxi = guess_ab_col(),
nali = guess_ab_col(),
neom = guess_ab_col(),
neti = guess_ab_col(),
nitr = guess_ab_col(),
norf = guess_ab_col(),
novo = guess_ab_col(),
oflo = guess_ab_col(),
oxac = guess_ab_col(),
peni = guess_ab_col(),
pipe = guess_ab_col(),
pita = guess_ab_col(),
poly = guess_ab_col(),
pris = guess_ab_col(),
qida = guess_ab_col(),
rifa = guess_ab_col(),
roxi = guess_ab_col(),
siso = guess_ab_col(),
teic = guess_ab_col(),
tetr = guess_ab_col(),
tica = guess_ab_col(),
tige = guess_ab_col(),
tobr = guess_ab_col(),
trim = guess_ab_col(),
trsu = guess_ab_col(),
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
vanc = guess_ab_col(),
...) {
- For functions `first_isolate`, `EUCAST_rules` the antibiotic column names are case-insensitive - Functions `first_isolate`, `EUCAST_rules` and `rsi_predict` supports tidyverse-like evaluation of parameters (no need to quote columns them anymore) - Functions `clipboard_import` and `clipboard_export` as helper functions to quickly copy and paste from/to software like Excel and SPSS - Renamed dataset `bactlist` to `microorganisms`
2018-03-23 14:46:02 +01:00
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
# support old `tbl` parameter
if ("tbl" %in% names(list(...))) {
x <- list(...)$tbl
}
tbl_ <- x
if (!is.data.frame(tbl_)) {
stop("`tbl_` must be a data frame.", call. = FALSE)
eucast update
2018-11-01 20:23:33 +01:00
}
# try to find columns based on type
# -- mo
resistance predict
2019-01-15 12:45:24 +01:00
if (is.null(col_mo)) {
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
col_mo <- search_type_in_df(tbl = tbl_, type = "mo")
dplyr 0.8.0 support, fixes #7
2018-12-22 22:39:34 +01:00
}
if (is.null(col_mo)) {
stop("`col_mo` must be set.", call. = FALSE)
first commit
2018-02-21 11:52:31 +01:00
}
update dependencies
2018-04-02 16:05:09 +02:00
param rules for EUCAST
2018-10-18 12:10:10 +02:00
if (!all(rules %in% c("breakpoints", "expert", "other", "all"))) {
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
stop("`rules` must be one or more of: 'breakpoints', 'expert', 'other', 'all'.")
param rules for EUCAST
2018-10-18 12:10:10 +02:00
}
eucast update
2018-11-01 20:23:33 +01:00
if (is.null(col_mo)) {
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
stop("`col_mo` must be set")
eucast update
2018-11-01 20:23:33 +01:00
}
new EUCAST rules: clinical breakpoints
2018-10-17 17:32:34 +02:00
warned <- FALSE
txt_error <- function() { cat("", bgRed(black(" ERROR ")), "\n") }
txt_warning <- function() { if (warned == FALSE) { cat("", bgYellow(black(" WARNING ")), "\n") }; warned <<- TRUE }
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
txt_ok <- function(no_of_changes) {
new EUCAST rules: clinical breakpoints
2018-10-17 17:32:34 +02:00
if (warned == FALSE) {
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
if (no_of_changes > 0) {
if (no_of_changes == 1) {
cat(blue(" (1 new change)\n"))
new EUCAST rules: clinical breakpoints
2018-10-17 17:32:34 +02:00
} else {
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
cat(blue(paste0(" (", no_of_changes, " new changes)\n")))
new EUCAST rules: clinical breakpoints
2018-10-17 17:32:34 +02:00
}
} else {
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
cat(green(" (no new changes)\n"))
new EUCAST rules: clinical breakpoints
2018-10-17 17:32:34 +02:00
}
warned <<- FALSE
}
}
- For functions `first_isolate`, `EUCAST_rules` the antibiotic column names are case-insensitive - Functions `first_isolate`, `EUCAST_rules` and `rsi_predict` supports tidyverse-like evaluation of parameters (no need to quote columns them anymore) - Functions `clipboard_import` and `clipboard_export` as helper functions to quickly copy and paste from/to software like Excel and SPSS - Renamed dataset `bactlist` to `microorganisms`
2018-03-23 14:46:02 +01:00
# check columns
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
if (identical(amcl, as.name("guess_ab_col"))) { amcl <- guess_ab_col(tbl_, "amcl", verbose = verbose) }
if (identical(amik, as.name("guess_ab_col"))) { amik <- guess_ab_col(tbl_, "amik", verbose = verbose) }
if (identical(amox, as.name("guess_ab_col"))) { amox <- guess_ab_col(tbl_, "amox", verbose = verbose) }
if (identical(ampi, as.name("guess_ab_col"))) { ampi <- guess_ab_col(tbl_, "ampi", verbose = verbose) }
if (identical(azit, as.name("guess_ab_col"))) { azit <- guess_ab_col(tbl_, "azit", verbose = verbose) }
if (identical(azlo, as.name("guess_ab_col"))) { azlo <- guess_ab_col(tbl_, "azlo", verbose = verbose) }
if (identical(aztr, as.name("guess_ab_col"))) { aztr <- guess_ab_col(tbl_, "aztr", verbose = verbose) }
if (identical(cefa, as.name("guess_ab_col"))) { cefa <- guess_ab_col(tbl_, "cefa", verbose = verbose) }
if (identical(cfep, as.name("guess_ab_col"))) { cfep <- guess_ab_col(tbl_, "cfep", verbose = verbose) }
if (identical(cfot, as.name("guess_ab_col"))) { cfot <- guess_ab_col(tbl_, "cfot", verbose = verbose) }
if (identical(cfox, as.name("guess_ab_col"))) { cfox <- guess_ab_col(tbl_, "cfox", verbose = verbose) }
if (identical(cfra, as.name("guess_ab_col"))) { cfra <- guess_ab_col(tbl_, "cfra", verbose = verbose) }
if (identical(cfta, as.name("guess_ab_col"))) { cfta <- guess_ab_col(tbl_, "cfta", verbose = verbose) }
if (identical(cftr, as.name("guess_ab_col"))) { cftr <- guess_ab_col(tbl_, "cftr", verbose = verbose) }
if (identical(cfur, as.name("guess_ab_col"))) { cfur <- guess_ab_col(tbl_, "cfur", verbose = verbose) }
if (identical(chlo, as.name("guess_ab_col"))) { chlo <- guess_ab_col(tbl_, "chlo", verbose = verbose) }
if (identical(cipr, as.name("guess_ab_col"))) { cipr <- guess_ab_col(tbl_, "cipr", verbose = verbose) }
if (identical(clar, as.name("guess_ab_col"))) { clar <- guess_ab_col(tbl_, "clar", verbose = verbose) }
if (identical(clin, as.name("guess_ab_col"))) { clin <- guess_ab_col(tbl_, "clin", verbose = verbose) }
if (identical(clox, as.name("guess_ab_col"))) { clox <- guess_ab_col(tbl_, "clox", verbose = verbose) }
if (identical(coli, as.name("guess_ab_col"))) { coli <- guess_ab_col(tbl_, "coli", verbose = verbose) }
if (identical(czol, as.name("guess_ab_col"))) { czol <- guess_ab_col(tbl_, "czol", verbose = verbose) }
if (identical(dapt, as.name("guess_ab_col"))) { dapt <- guess_ab_col(tbl_, "dapt", verbose = verbose) }
if (identical(doxy, as.name("guess_ab_col"))) { doxy <- guess_ab_col(tbl_, "doxy", verbose = verbose) }
if (identical(erta, as.name("guess_ab_col"))) { erta <- guess_ab_col(tbl_, "erta", verbose = verbose) }
if (identical(eryt, as.name("guess_ab_col"))) { eryt <- guess_ab_col(tbl_, "eryt", verbose = verbose) }
if (identical(fosf, as.name("guess_ab_col"))) { fosf <- guess_ab_col(tbl_, "fosf", verbose = verbose) }
if (identical(fusi, as.name("guess_ab_col"))) { fusi <- guess_ab_col(tbl_, "fusi", verbose = verbose) }
if (identical(gent, as.name("guess_ab_col"))) { gent <- guess_ab_col(tbl_, "gent", verbose = verbose) }
if (identical(imip, as.name("guess_ab_col"))) { imip <- guess_ab_col(tbl_, "imip", verbose = verbose) }
if (identical(kana, as.name("guess_ab_col"))) { kana <- guess_ab_col(tbl_, "kana", verbose = verbose) }
if (identical(levo, as.name("guess_ab_col"))) { levo <- guess_ab_col(tbl_, "levo", verbose = verbose) }
if (identical(linc, as.name("guess_ab_col"))) { linc <- guess_ab_col(tbl_, "linc", verbose = verbose) }
if (identical(line, as.name("guess_ab_col"))) { line <- guess_ab_col(tbl_, "line", verbose = verbose) }
if (identical(mero, as.name("guess_ab_col"))) { mero <- guess_ab_col(tbl_, "mero", verbose = verbose) }
if (identical(mezl, as.name("guess_ab_col"))) { mezl <- guess_ab_col(tbl_, "mezl", verbose = verbose) }
if (identical(mino, as.name("guess_ab_col"))) { mino <- guess_ab_col(tbl_, "mino", verbose = verbose) }
if (identical(moxi, as.name("guess_ab_col"))) { moxi <- guess_ab_col(tbl_, "moxi", verbose = verbose) }
if (identical(nali, as.name("guess_ab_col"))) { nali <- guess_ab_col(tbl_, "nali", verbose = verbose) }
if (identical(neom, as.name("guess_ab_col"))) { neom <- guess_ab_col(tbl_, "neom", verbose = verbose) }
if (identical(neti, as.name("guess_ab_col"))) { neti <- guess_ab_col(tbl_, "neti", verbose = verbose) }
if (identical(nitr, as.name("guess_ab_col"))) { nitr <- guess_ab_col(tbl_, "nitr", verbose = verbose) }
if (identical(norf, as.name("guess_ab_col"))) { norf <- guess_ab_col(tbl_, "norf", verbose = verbose) }
if (identical(novo, as.name("guess_ab_col"))) { novo <- guess_ab_col(tbl_, "novo", verbose = verbose) }
if (identical(oflo, as.name("guess_ab_col"))) { oflo <- guess_ab_col(tbl_, "oflo", verbose = verbose) }
if (identical(oxac, as.name("guess_ab_col"))) { oxac <- guess_ab_col(tbl_, "oxac", verbose = verbose) }
if (identical(peni, as.name("guess_ab_col"))) { peni <- guess_ab_col(tbl_, "peni", verbose = verbose) }
if (identical(pipe, as.name("guess_ab_col"))) { pipe <- guess_ab_col(tbl_, "pipe", verbose = verbose) }
if (identical(pita, as.name("guess_ab_col"))) { pita <- guess_ab_col(tbl_, "pita", verbose = verbose) }
if (identical(poly, as.name("guess_ab_col"))) { poly <- guess_ab_col(tbl_, "poly", verbose = verbose) }
if (identical(pris, as.name("guess_ab_col"))) { pris <- guess_ab_col(tbl_, "pris", verbose = verbose) }
if (identical(qida, as.name("guess_ab_col"))) { qida <- guess_ab_col(tbl_, "qida", verbose = verbose) }
if (identical(rifa, as.name("guess_ab_col"))) { rifa <- guess_ab_col(tbl_, "rifa", verbose = verbose) }
if (identical(roxi, as.name("guess_ab_col"))) { roxi <- guess_ab_col(tbl_, "roxi", verbose = verbose) }
if (identical(siso, as.name("guess_ab_col"))) { siso <- guess_ab_col(tbl_, "siso", verbose = verbose) }
if (identical(teic, as.name("guess_ab_col"))) { teic <- guess_ab_col(tbl_, "teic", verbose = verbose) }
if (identical(tetr, as.name("guess_ab_col"))) { tetr <- guess_ab_col(tbl_, "tetr", verbose = verbose) }
if (identical(tica, as.name("guess_ab_col"))) { tica <- guess_ab_col(tbl_, "tica", verbose = verbose) }
if (identical(tige, as.name("guess_ab_col"))) { tige <- guess_ab_col(tbl_, "tige", verbose = verbose) }
if (identical(tobr, as.name("guess_ab_col"))) { tobr <- guess_ab_col(tbl_, "tobr", verbose = verbose) }
if (identical(trim, as.name("guess_ab_col"))) { trim <- guess_ab_col(tbl_, "trim", verbose = verbose) }
if (identical(trsu, as.name("guess_ab_col"))) { trsu <- guess_ab_col(tbl_, "trsu", verbose = verbose) }
if (identical(vanc, as.name("guess_ab_col"))) { vanc <- guess_ab_col(tbl_, "vanc", verbose = verbose) }
improvement for forecasting resistance
2018-07-26 16:30:42 +02:00
col.list <- c(amcl, amik, amox, ampi, azit, azlo, aztr, cefa, cfra, cfep, cfot,
- For functions `first_isolate`, `EUCAST_rules` the antibiotic column names are case-insensitive - Functions `first_isolate`, `EUCAST_rules` and `rsi_predict` supports tidyverse-like evaluation of parameters (no need to quote columns them anymore) - Functions `clipboard_import` and `clipboard_export` as helper functions to quickly copy and paste from/to software like Excel and SPSS - Renamed dataset `bactlist` to `microorganisms`
2018-03-23 14:46:02 +01:00
cfox, cfta, cftr, cfur, chlo, cipr, clar, clin, clox, coli,
czol, dapt, doxy, erta, eryt, fosf, fusi, gent, imip, kana,
improvement for forecasting resistance
2018-07-26 16:30:42 +02:00
levo, linc, line, mero, mezl, mino, moxi, nali, neom, neti, nitr,
eucast updates
2018-11-01 17:06:08 +01:00
novo, norf, oflo, oxac, peni, pipe, pita, poly, pris, qida, rifa,
roxi, siso, teic, tetr, tica, tige, tobr, trim, trsu, vanc)
guess_ab
2019-01-03 23:56:19 +01:00
if (length(col.list) < 63) {
warning('Some columns do not exist -- THIS MAY STRONGLY INFLUENCE THE OUTCOME.',
immediate. = TRUE,
call. = FALSE)
}
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
col.list <- check_available_columns(tbl = tbl_, col.list = col.list, info = info)
EUCAST rules for MDRO
2018-04-25 15:33:58 +02:00
amcl <- col.list[amcl]
amik <- col.list[amik]
amox <- col.list[amox]
ampi <- col.list[ampi]
azit <- col.list[azit]
improvement for forecasting resistance
2018-07-26 16:30:42 +02:00
azlo <- col.list[azlo]
EUCAST rules for MDRO
2018-04-25 15:33:58 +02:00
aztr <- col.list[aztr]
cefa <- col.list[cefa]
cfep <- col.list[cfep]
cfot <- col.list[cfot]
cfox <- col.list[cfox]
improvement for forecasting resistance
2018-07-26 16:30:42 +02:00
cfra <- col.list[cfra]
EUCAST rules for MDRO
2018-04-25 15:33:58 +02:00
cfta <- col.list[cfta]
cftr <- col.list[cftr]
cfur <- col.list[cfur]
chlo <- col.list[chlo]
cipr <- col.list[cipr]
clar <- col.list[clar]
clin <- col.list[clin]
clox <- col.list[clox]
coli <- col.list[coli]
czol <- col.list[czol]
dapt <- col.list[dapt]
doxy <- col.list[doxy]
erta <- col.list[erta]
eryt <- col.list[eryt]
fosf <- col.list[fosf]
fusi <- col.list[fusi]
gent <- col.list[gent]
imip <- col.list[imip]
kana <- col.list[kana]
levo <- col.list[levo]
linc <- col.list[linc]
line <- col.list[line]
mero <- col.list[mero]
improvement for forecasting resistance
2018-07-26 16:30:42 +02:00
mezl <- col.list[mezl]
EUCAST rules for MDRO
2018-04-25 15:33:58 +02:00
mino <- col.list[mino]
moxi <- col.list[moxi]
nali <- col.list[nali]
neom <- col.list[neom]
neti <- col.list[neti]
nitr <- col.list[nitr]
norf <- col.list[norf]
improvement for forecasting resistance
2018-07-26 16:30:42 +02:00
novo <- col.list[novo]
EUCAST rules for MDRO
2018-04-25 15:33:58 +02:00
oflo <- col.list[oflo]
new EUCAST rules: clinical breakpoints
2018-10-17 17:32:34 +02:00
oxac <- col.list[oxac]
EUCAST rules for MDRO
2018-04-25 15:33:58 +02:00
peni <- col.list[peni]
eucast updates
2018-11-01 17:06:08 +01:00
pipe <- col.list[pipe]
EUCAST rules for MDRO
2018-04-25 15:33:58 +02:00
pita <- col.list[pita]
poly <- col.list[poly]
improvement for forecasting resistance
2018-07-26 16:30:42 +02:00
pris <- col.list[pris]
EUCAST rules for MDRO
2018-04-25 15:33:58 +02:00
qida <- col.list[qida]
rifa <- col.list[rifa]
roxi <- col.list[roxi]
siso <- col.list[siso]
teic <- col.list[teic]
tetr <- col.list[tetr]
tica <- col.list[tica]
tige <- col.list[tige]
tobr <- col.list[tobr]
trim <- col.list[trim]
trsu <- col.list[trsu]
vanc <- col.list[vanc]
update dependencies
2018-04-02 16:05:09 +02:00
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
ab_missing <- function(ab) {
all(ab %in% c(NULL, NA))
}
mo codes for WHONET
2019-02-08 16:06:54 +01:00
verbose_info <- data.frame(row = integer(0),
col = character(0),
mo_fullname = character(0),
old = character(0),
new = character(0),
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
rule = character(0),
mo codes for WHONET
2019-02-08 16:06:54 +01:00
rule_group = character(0),
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
rule_name = character(0),
new verbose
2018-10-19 00:17:03 +02:00
stringsAsFactors = FALSE)
update dependencies
2018-04-02 16:05:09 +02:00
- For functions `first_isolate`, `EUCAST_rules` the antibiotic column names are case-insensitive - Functions `first_isolate`, `EUCAST_rules` and `rsi_predict` supports tidyverse-like evaluation of parameters (no need to quote columns them anymore) - Functions `clipboard_import` and `clipboard_export` as helper functions to quickly copy and paste from/to software like Excel and SPSS - Renamed dataset `bactlist` to `microorganisms`
2018-03-23 14:46:02 +01:00
# helper function for editing the table
new EUCAST rules: clinical breakpoints
2018-10-17 17:32:34 +02:00
edit_rsi <- function(to, rule, rows, cols) {
guess_ab
2019-01-03 23:56:19 +01:00
cols <- unique(cols[!is.na(cols) & !is.null(cols)])
first commit
2018-02-21 11:52:31 +01:00
if (length(rows) > 0 & length(cols) > 0) {
mo codes for WHONET
2019-02-08 16:06:54 +01:00
before_df <- tbl_original
new EUCAST rules: clinical breakpoints
2018-10-17 17:32:34 +02:00
before <- as.character(unlist(as.list(tbl_original[rows, cols])))
mo codes for WHONET
2019-02-08 16:06:54 +01:00
new EUCAST rules: clinical breakpoints
2018-10-17 17:32:34 +02:00
tryCatch(
# insert into original table
tbl_original[rows, cols] <<- to,
warning = function(w) {
if (w$message %like% 'invalid factor level') {
warning('Value "', to, '" could not be applied to column(s) `', paste(cols, collapse = '`, `'), '` because this value is not an existing factor level.', call. = FALSE)
} else {
warning(w$message, call. = FALSE)
}
txt_warning()
},
error = function(e) {
txt_error()
stop(e, call. = FALSE)
}
)
self-learning off
2019-04-06 09:38:23 +02:00
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
tbl_[rows, cols] <<- tbl_original[rows, cols]
mo codes for WHONET
2019-02-08 16:06:54 +01:00
new EUCAST rules: clinical breakpoints
2018-10-17 17:32:34 +02:00
after <- as.character(unlist(as.list(tbl_original[rows, cols])))
mo codes for WHONET
2019-02-08 16:06:54 +01:00
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
# before_df might not be a data.frame, but a tibble of data.table instead
old <- as.data.frame(before_df, stringsAsFactors = FALSE)[rows,]
no_of_changes_this_run <- 0
for (i in 1:length(cols)) {
verbose_new <- data.frame(row = rows,
col = cols[i],
mo_fullname = tbl_[rows, "fullname"],
old = as.character(old[, cols[i]]),
new = as.character(tbl_[rows, cols[i]]),
rule = strip_style(rule[1]),
rule_group = strip_style(rule[2]),
rule_name = strip_style(rule[3]),
stringsAsFactors = FALSE)
colnames(verbose_new) <- c("row", "col", "mo_fullname", "old", "new", "rule", "rule_group", "rule_name")
verbose_new <- verbose_new %>% filter(old != new | is.na(old))
verbose_info <<- rbind(verbose_info, verbose_new)
no_of_changes_this_run <- no_of_changes_this_run + nrow(verbose_new)
new EUCAST rules: clinical breakpoints
2018-10-17 17:32:34 +02:00
}
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
# return number of (new) changes
return(no_of_changes_this_run)
new EUCAST rules: clinical breakpoints
2018-10-17 17:32:34 +02:00
}
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
# return number of (new) changes: none.
return(0)
first commit
2018-02-21 11:52:31 +01:00
}
update dependencies
2018-04-02 16:05:09 +02:00
param rules for EUCAST
2018-10-18 12:10:10 +02:00
# save original table
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
tbl_original <- tbl_
param rules for EUCAST
2018-10-18 12:10:10 +02:00
# join to microorganisms data set
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
suppressWarnings(
tbl_ <- tbl_ %>%
mutate_at(vars(col_mo), as.mo) %>%
left_join_microorganisms(by = col_mo, suffix = c("_oldcols", "")) %>%
mutate(gramstain = mo_gramstain(pull(., col_mo), language = "en"),
genus_species = paste(genus, species)) %>%
as.data.frame(stringsAsFactors = FALSE)
)
new EUCAST rules: clinical breakpoints
2018-10-17 17:32:34 +02:00
if (info == TRUE) {
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
cat(paste0(
"\nRules by the ", bold("European Committee on Antimicrobial Susceptibility Testing (EUCAST)"),
"\n", blue("http://eucast.org/"), "\n"))
new EUCAST rules: clinical breakpoints
2018-10-17 17:32:34 +02:00
}
eucast rules fix, 1st isolate fix, website update
2018-12-31 01:48:53 +01:00
# since ampicillin ^= amoxicillin, get the first from the latter (not in original EUCAST table)
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
if (!ab_missing(ampi) & !ab_missing(amox)) {
better verbose in EUCAST
2018-10-19 00:57:10 +02:00
if (verbose == TRUE) {
mo codes for WHONET
2019-02-08 16:06:54 +01:00
cat("\n VERBOSE: transforming",
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
length(which(tbl_[, amox] == "S" & !tbl_[, ampi] %in% c("S", "I", "R"))),
mo codes for WHONET
2019-02-08 16:06:54 +01:00
"empty ampicillin fields to 'S' based on amoxicillin. ")
cat("\n VERBOSE: transforming",
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
length(which(tbl_[, amox] == "I" & !tbl_[, ampi] %in% c("S", "I", "R"))),
mo codes for WHONET
2019-02-08 16:06:54 +01:00
"empty ampicillin fields to 'I' based on amoxicillin. ")
cat("\n VERBOSE: transforming",
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
length(which(tbl_[, amox] == "R" & !tbl_[, ampi] %in% c("S", "I", "R"))),
mo codes for WHONET
2019-02-08 16:06:54 +01:00
"empty ampicillin fields to 'R' based on amoxicillin. \n")
better verbose in EUCAST
2018-10-19 00:57:10 +02:00
}
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
tbl_[which(tbl_[, amox] == "S" & !tbl_[, ampi] %in% c("S", "I", "R")), ampi] <- "S"
tbl_[which(tbl_[, amox] == "I" & !tbl_[, ampi] %in% c("S", "I", "R")), ampi] <- "I"
tbl_[which(tbl_[, amox] == "R" & !tbl_[, ampi] %in% c("S", "I", "R")), ampi] <- "R"
} else if (ab_missing(ampi) & !ab_missing(amox)) {
eucast rules fix, 1st isolate fix, website update
2018-12-31 01:48:53 +01:00
# ampicillin column is missing, but amoxicillin is available
message(blue(paste0("NOTE: Using column `", bold(amox), "` as input for ampicillin (J01CA01) since many EUCAST rules depend on it.")))
ampi <- amox
new EUCAST rules: clinical breakpoints
2018-10-17 17:32:34 +02:00
}
eucast rules fix, 1st isolate fix, website update
2018-12-31 01:48:53 +01:00
# antibiotic classes
aminoglycosides <- c(tobr, gent, kana, neom, neti, siso)
tetracyclines <- c(doxy, mino, tetr) # since EUCAST v3.1 tige(cycline) is set apart
polymyxins <- c(poly, coli)
macrolides <- c(eryt, azit, roxi, clar) # since EUCAST v3.1 clinda is set apart
glycopeptides <- c(vanc, teic)
streptogramins <- c(qida, pris) # should officially also be quinupristin/dalfopristin
cephalosporins <- c(cfep, cfot, cfox, cfra, cfta, cftr, cfur, czol)
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
cephalosporins_without_cfta <- cephalosporins[cephalosporins != ifelse(is.null(cfta), "", cfta)]
eucast rules fix, 1st isolate fix, website update
2018-12-31 01:48:53 +01:00
carbapenems <- c(erta, imip, mero)
aminopenicillins <- c(ampi, amox)
ureidopenicillins <- c(pipe, pita, azlo, mezl)
fluoroquinolones <- c(oflo, cipr, norf, levo, moxi)
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
all_betalactams <- c(aminopenicillins, ureidopenicillins, cephalosporins, carbapenems, amcl, oxac, clox, peni)
param rules for EUCAST
2018-10-18 12:10:10 +02:00
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
# Help function to get available antibiotic column names ------------------
get_antibiotic_columns <- function(x, df) {
x <- trimws(unlist(strsplit(x, ",", fixed = TRUE)))
y <- character(0)
for (i in 1:length(x)) {
y <- c(y, tryCatch(get(x[i]), error = function(e) ""))
param rules for EUCAST
2018-10-18 12:10:10 +02:00
}
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
y[y != "" & y %in% colnames(df)]
}
param rules for EUCAST
2018-10-18 12:10:10 +02:00
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
eucast_rules_df <- eucast_rules_file()
no_of_changes <- 0
for (i in 1:nrow(eucast_rules_df)) {
rule_previous <- eucast_rules_df[max(1, i - 1), "reference.rule"]
rule_current <- eucast_rules_df[i, "reference.rule"]
rule_next <- eucast_rules_df[min(nrow(eucast_rules_df), i + 1), "reference.rule"]
rule_group_previous <- eucast_rules_df[max(1, i - 1), "reference.rule_group"]
rule_group_current <- eucast_rules_df[i, "reference.rule_group"]
rule_group_next <- eucast_rules_df[min(nrow(eucast_rules_df), i + 1), "reference.rule_group"]
if (is.na(eucast_rules_df[i, 4])) {
rule_text <- paste(eucast_rules_df[i, 6], "=", eucast_rules_df[i, 7])
} else {
rule_text <- paste("if", eucast_rules_df[i, 4], "=", eucast_rules_df[i, 5],
"then", eucast_rules_df[i, 6], "=", eucast_rules_df[i, 7])
param rules for EUCAST
2018-10-18 12:10:10 +02:00
}
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
if (i == 1) {
rule_previous <- ""
rule_group_previous <- ""
param rules for EUCAST
2018-10-18 12:10:10 +02:00
}
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
if (i == nrow(eucast_rules_df)) {
rule_next <- ""
rule_group_next <- ""
param rules for EUCAST
2018-10-18 12:10:10 +02:00
}
update dependencies
2018-04-02 16:05:09 +02:00
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
# don't apply rules if user doesn't want to apply them
if (rule_group_current %like% "breakpoint" & !any(c("all", "breakpoints") %in% rules)) {
next
param rules for EUCAST
2018-10-18 12:10:10 +02:00
}
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
if (rule_group_current %like% "expert" & !any(c("all", "expert") %in% rules)) {
next
param rules for EUCAST
2018-10-18 12:10:10 +02:00
}
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
if (rule_group_current %like% "other" & !any(c("all", "other") %in% rules)) {
next
param rules for EUCAST
2018-10-18 12:10:10 +02:00
}
update dependencies
2018-04-02 16:05:09 +02:00
param rules for EUCAST
2018-10-18 12:10:10 +02:00
if (info == TRUE) {
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
# Print rule (group) ------------------------------------------------------
if (rule_group_current != rule_group_previous) {
# is new rule group, one of Breakpoints, Expert Rules and Other
cat(bold(
case_when(
rule_group_current %like% "breakpoint" ~
paste0("\nEUCAST Clinical Breakpoints (v", EUCAST_VERSION_BREAKPOINTS, ")\n"),
rule_group_current %like% "expert" ~
paste0("\nEUCAST Expert Rules, Intrinsic Resistance and Exceptional Phenotypes (v", EUCAST_VERSION_EXPERT_RULES, ")\n"),
TRUE ~
"\nOther rules\n"
)
))
}
# Print rule -------------------------------------------------------------
if (rule_current != rule_previous) {
# is new rule within group, print its name
if (rule_current %in% c(AMR::microorganisms$family,
AMR::microorganisms$fullname)) {
cat(italic(rule_current))
} else {
cat(rule_current)
}
warned <- FALSE
}
param rules for EUCAST
2018-10-18 12:10:10 +02:00
}
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
# Get rule from file ------------------------------------------------------
col_mo_property <- eucast_rules_df[i, 1]
like_is_one_of <- eucast_rules_df[i, 2]
param rules for EUCAST
2018-10-18 12:10:10 +02:00
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
# be sure to comprise all coagulase-negative/-positive Staphylococci when they are mentioned
if (eucast_rules_df[i, 3] %like% "coagulase-") {
suppressWarnings(
all_staph <- AMR::microorganisms %>%
filter(genus == "Staphylococcus") %>%
mutate(CNS_CPS = mo_fullname(mo, Becker = "all"))
)
if (eucast_rules_df[i, 3] %like% "coagulase-") {
eucast_rules_df[i, 3] <- paste0("^(",
paste0(all_staph %>%
filter(CNS_CPS %like% "coagulase-negative") %>%
pull(fullname),
collapse = "|"),
")$")
} else {
eucast_rules_df[i, 3] <- paste0("^(",
paste0(all_staph %>%
filter(CNS_CPS %like% "coagulase-positive") %>%
pull(fullname),
collapse = "|"),
")$")
}
like_is_one_of <- "like"
}
if (like_is_one_of == "is") {
mo_value <- paste0("^", eucast_rules_df[i, 3], "$")
} else if (like_is_one_of == "one_of") {
# "Clostridium, Actinomyces, ..." -> "^(Clostridium|Actinomyces|...)$"
mo_value <- paste0("^(",
paste(trimws(unlist(strsplit(eucast_rules_df[i, 3], ",", fixed = TRUE))),
collapse = "|"),
")$")
} else if (like_is_one_of == "like") {
mo_value <- eucast_rules_df[i, 3]
} else {
stop("invalid like_is_one_of", call. = FALSE)
param rules for EUCAST
2018-10-18 12:10:10 +02:00
}
new EUCAST rules: clinical breakpoints
2018-10-17 17:32:34 +02:00
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
source_antibiotics <- eucast_rules_df[i, 4]
source_value <- trimws(unlist(strsplit(eucast_rules_df[i, 5], ",", fixed = TRUE)))
target_antibiotics <- eucast_rules_df[i, 6]
target_value <- eucast_rules_df[i, 7]
param rules for EUCAST
2018-10-18 12:10:10 +02:00
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
if (is.na(source_antibiotics)) {
rows <- tryCatch(which(tbl_[, col_mo_property] %like% mo_value),
error = function(e) integer(0))
} else {
source_antibiotics <- get_antibiotic_columns(source_antibiotics, tbl_)
if (length(source_value) == 1 & length(source_antibiotics) > 1) {
source_value <- rep(source_value, length(source_antibiotics))
}
if (length(source_antibiotics) == 0) {
rows <- integer(0)
} else if (length(source_antibiotics) == 1) {
rows <- tryCatch(which(tbl_[, col_mo_property] %like% mo_value
& tbl_[, source_antibiotics[1L]] == source_value[1L]),
error = function(e) integer(0))
} else if (length(source_antibiotics) == 2) {
rows <- tryCatch(which(tbl_[, col_mo_property] %like% mo_value
& tbl_[, source_antibiotics[1L]] == source_value[1L]
& tbl_[, source_antibiotics[2L]] == source_value[2L]),
error = function(e) integer(0))
} else if (length(source_antibiotics) == 3) {
rows <- tryCatch(which(tbl_[, col_mo_property] %like% mo_value
& tbl_[, source_antibiotics[1L]] == source_value[1L]
& tbl_[, source_antibiotics[2L]] == source_value[2L]
& tbl_[, source_antibiotics[3L]] == source_value[3L]),
error = function(e) integer(0))
} else {
stop("only 3 antibiotics supported for source_antibiotics ", call. = FALSE)
}
param rules for EUCAST
2018-10-18 12:10:10 +02:00
}
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
cols <- get_antibiotic_columns(target_antibiotics, tbl_)
param rules for EUCAST
2018-10-18 12:10:10 +02:00
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
# Apply rule on data ------------------------------------------------------
# this will return the unique number of changes
no_of_changes <- no_of_changes + edit_rsi(to = target_value,
rule = c(rule_text, rule_group_current, rule_current),
rows = rows,
cols = cols)
param rules for EUCAST
2018-10-18 12:10:10 +02:00
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
# Print number of new changes ---------------------------------------------
if (info == TRUE & rule_next != rule_current) {
# print only on last one of rules in this group
txt_ok(no_of_changes = no_of_changes)
no_of_changes <- 0
eucast updates
2018-11-01 17:06:08 +01:00
}
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
}
update dependencies
2018-04-02 16:05:09 +02:00
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
# Print overview ----------------------------------------------------------
first commit
2018-02-21 11:52:31 +01:00
if (info == TRUE) {
better verbose in EUCAST
2018-10-19 00:57:10 +02:00
if (verbose == TRUE) {
wouldve <- "would have "
} else {
wouldve <- ""
}
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
verbose_info <- verbose_info %>%
arrange(row, rule_group, rule_name, col)
dplyr 0.8.0 support, fixes #7
2018-12-22 22:39:34 +01:00
decimal.mark <- getOption("OutDec")
big.mark <- ifelse(decimal.mark != ",", ",", ".")
mo codes for WHONET
2019-02-08 16:06:54 +01:00
formatnr <- function(x) {
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
trimws(format(x, big.mark = big.mark, decimal.mark = decimal.mark))
}
cat(paste0("\n", silver(strrep("-", options()$width - 1)), "\n"))
cat(bold(paste('EUCAST rules', paste0(wouldve, 'affected'),
formatnr(n_distinct(verbose_info$row)),
'out of', formatnr(nrow(tbl_original)),
'rows, making a total of', formatnr(nrow(verbose_info)), 'edits\n')))
# print added values ----
if (verbose_info %>% filter(is.na(old)) %>% nrow() == 0) {
colour <- cat # is function
} else {
colour <- blue # is function
mo codes for WHONET
2019-02-08 16:06:54 +01:00
}
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
cat(colour(paste0("=> ", wouldve, "added ",
bold(formatnr(verbose_info %>%
filter(is.na(old)) %>%
nrow()), "test results"),
mo codes for WHONET
2019-02-08 16:06:54 +01:00
"\n")))
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
if (verbose_info %>% filter(is.na(old)) %>% nrow() > 0) {
verbose_info %>%
filter(is.na(old)) %>%
# sort it well: S < I < R
mutate(new = as.rsi(new)) %>%
group_by(new) %>%
summarise(n = n()) %>%
mutate(plural = ifelse(n > 1, "s", ""),
txt = paste0(formatnr(n), " test result", plural, " added as ", new)) %>%
pull(txt) %>%
paste(" -", ., collapse = "\n") %>%
cat()
}
# print changed values ----
if (verbose_info %>% filter(!is.na(old)) %>% nrow() == 0) {
colour <- cat # is function
} else {
colour <- blue # is function
}
cat(colour(paste0("\n=> ", wouldve, "changed ",
bold(formatnr(verbose_info %>%
filter(!is.na(old)) %>%
nrow()), "test results"),
mo codes for WHONET
2019-02-08 16:06:54 +01:00
"\n")))
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
if (verbose_info %>% filter(!is.na(old)) %>% nrow() > 0) {
verbose_info %>%
filter(!is.na(old)) %>%
# sort it well: S < I < R
mutate(old = as.rsi(old),
new = as.rsi(new)) %>%
group_by(old, new) %>%
summarise(n = n()) %>%
mutate(plural = ifelse(n > 1, "s", ""),
txt = paste0(formatnr(n), " test result", plural, " changed from ", old, " to ", new)) %>%
pull(txt) %>%
paste(" -", ., collapse = "\n") %>%
cat()
cat("\n")
}
cat(paste0(silver(strrep("-", options()$width - 1)), "\n"))
if (verbose == FALSE & nrow(verbose_info) > 0) {
cat(paste("\nUse", bold("verbose = TRUE"), "to get a data.frame with all specified edits instead.\n"))
v0.6.1
2019-03-28 21:33:28 +01:00
}
new EUCAST rules: clinical breakpoints
2018-10-17 17:32:34 +02:00
}
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
# Return data set ---------------------------------------------------------
new verbose
2018-10-19 00:17:03 +02:00
if (verbose == TRUE) {
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
verbose_info
} else {
tbl_original
first commit
2018-02-21 11:52:31 +01:00
}
}
MDRO update
2018-11-16 20:50:50 +01:00
#' @rdname eucast_rules
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
#' @importFrom dplyr %>% arrange
MDRO update
2018-11-16 20:50:50 +01:00
#' @export
new EUCAST rules algorithm
2019-04-05 18:47:39 +02:00
eucast_rules_file <- function() {
utils::read.delim(file = EUCAST_RULES_FILE_LOCATION,
sep = "\t",
stringsAsFactors = FALSE,
header = TRUE,
strip.white = TRUE,
na = c(NA, "", NULL)) %>%
arrange(reference.rule_group,
reference.rule)
MDRO update
2018-11-16 20:50:50 +01:00
}