edit methodology of rsi

- 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`

.gitignore

@@ -3,3 +3,4 @@
 .RData
 .Ruserdata
 AMR.Rproj
+tests/testthat/Rplots.pdf

.travis.yml

@@ -1,2 +1,27 @@
+# R for travis: see documentation at https://docs.travis-ci.com/user/languages/r
+
+# Setting up R deps
 language: r
+r: 3.2
+r_packages: covr
 cache: packages
+
+# system deps, install xclip for clipboard support
+os:
+  - linux
+  - osx
+before_install:
+  - if [ $TRAVIS_OS_NAME = linux ]; then sudo apt-get -qq update; fi
+  - if [ $TRAVIS_OS_NAME = linux ]; then sudo apt-get install -y xclip; fi
+  - if [ $TRAVIS_OS_NAME = osx ]; then brew install xclip; fi
+
+# postrun
+after_success:
+  - Rscript -e 'covr::codecov()'
+notifications:
+  email:
+    recipients:
+      - m.s.berends@umcg.nl
+      - c.f.luz@umcg.nl
+    on_success: change
+    on_failure: change

DESCRIPTION

@@ -1,18 +1,20 @@
 Package: AMR
-Version: 0.1.1
-Date: 2018-03-13
+Version: 0.2.0
+Date: 2018-05-02
 Title: Antimicrobial Resistance Analysis
 Authors@R: c(
     person(
         given = c("Matthijs", "S."),
         family = "Berends",
         email = "m.s.berends@umcg.nl",
-        role = c("aut", "cre")),
+        role = c("aut", "cre"),
+        comment = c(ORCID = "0000-0001-7620-1800")),
     person(
         given = c("Christian", "F."),
         family = "Luz",
         email = "c.f.luz@umcg.nl",
-        role = c("aut", "ctb")),
+        role = c("aut", "ctb"),
+        comment = c(ORCID = "0000-0001-5809-5995")),
     person(
         given = c("Erwin", "E.A."),
         family = "Hassing",
@@ -22,8 +24,20 @@ Description: Functions to simplify the analysis of Antimicrobial Resistance (AMR
     of microbial isolates, by using new S3 classes and applying EUCAST expert rules
     on antibiograms according to Leclercq (2013)
     <doi:10.1111/j.1469-0691.2011.03703.x>.
-Depends: R (>= 3.0)
-Imports: dplyr (>= 0.7.0), reshape2 (>= 1.4.0), xml2, rvest
+Depends:
+    R (>= 3.0.0)
+Imports:
+    backports,
+    dplyr (>= 0.7.0),
+    data.table (>= 1.10.0),
+    reshape2 (>= 1.4.0),
+    xml2 (>= 1.0.0),
+    knitr (>= 1.0.0),
+    rvest (>= 0.3.2),
+    tibble
+Suggests:
+    testthat (>= 1.0.2),
+    covr (>= 3.0.1)
 URL: https://github.com/msberends/AMR
 BugReports: https://github.com/msberends/AMR/issues
 License: GPL-2 | file LICENSE

NAMESPACE

@@ -7,30 +7,43 @@ S3method(barplot,mic)
 S3method(barplot,rsi)
 S3method(plot,mic)
 S3method(plot,rsi)
+S3method(print,data.table)
 S3method(print,mic)
 S3method(print,rsi)
+S3method(print,tbl)
+S3method(print,tbl_df)
 S3method(summary,mic)
 S3method(summary,rsi)
+export("%like%")
+export(BRMO)
+export(EUCAST_exceptional_phenotypes)
 export(EUCAST_rules)
+export(MDRO)
+export(MRGN)
 export(abname)
-export(anti_join_bactlist)
+export(anti_join_microorganisms)
 export(as.mic)
 export(as.rsi)
 export(atc_property)
 export(first_isolate)
-export(full_join_bactlist)
-export(inner_join_bactlist)
+export(freq)
+export(frequency_tbl)
+export(full_join_microorganisms)
+export(guess_atc)
+export(guess_bactid)
+export(inner_join_microorganisms)
 export(interpretive_reading)
 export(is.mic)
 export(is.rsi)
 export(key_antibiotics)
-export(left_join_bactlist)
+export(left_join_microorganisms)
 export(mo_property)
-export(right_join_bactlist)
+export(n_rsi)
+export(right_join_microorganisms)
 export(rsi)
 export(rsi_df)
 export(rsi_predict)
-export(semi_join_bactlist)
+export(semi_join_microorganisms)
 exportMethods(as.double.mic)
 exportMethods(as.integer.mic)
 exportMethods(as.numeric.mic)
@@ -38,25 +51,33 @@ exportMethods(barplot.mic)
 exportMethods(barplot.rsi)
 exportMethods(plot.mic)
 exportMethods(plot.rsi)
+exportMethods(print.data.table)
 exportMethods(print.mic)
 exportMethods(print.rsi)
+exportMethods(print.tbl)
+exportMethods(print.tbl_df)
 exportMethods(summary.mic)
 exportMethods(summary.rsi)
+importFrom(data.table,data.table)
 importFrom(dplyr,"%>%")
 importFrom(dplyr,all_vars)
 importFrom(dplyr,any_vars)
 importFrom(dplyr,arrange)
 importFrom(dplyr,arrange_at)
 importFrom(dplyr,between)
+importFrom(dplyr,desc)
 importFrom(dplyr,filter)
 importFrom(dplyr,filter_at)
 importFrom(dplyr,group_by)
 importFrom(dplyr,group_by_at)
+importFrom(dplyr,group_size)
+importFrom(dplyr,group_vars)
 importFrom(dplyr,if_else)
 importFrom(dplyr,lag)
 importFrom(dplyr,left_join)
 importFrom(dplyr,mutate)
 importFrom(dplyr,n_distinct)
+importFrom(dplyr,n_groups)
 importFrom(dplyr,progress_estimated)
 importFrom(dplyr,pull)
 importFrom(dplyr,row_number)
@@ -65,6 +86,7 @@ importFrom(dplyr,slice)
 importFrom(dplyr,summarise)
 importFrom(dplyr,tibble)
 importFrom(dplyr,vars)
+importFrom(grDevices,boxplot.stats)
 importFrom(graphics,axis)
 importFrom(graphics,barplot)
 importFrom(graphics,plot)
@@ -72,4 +94,9 @@ importFrom(graphics,text)
 importFrom(reshape2,dcast)
 importFrom(rvest,html_nodes)
 importFrom(rvest,html_table)
+importFrom(stats,fivenum)
+importFrom(stats,quantile)
+importFrom(stats,sd)
+importFrom(utils,object.size)
+importFrom(utils,packageDescription)
 importFrom(xml2,read_html)

NEWS

@@ -1,9 +0,0 @@
-## 0.1.1
-- `EUCAST_rules` applies for amoxicillin even if ampicillin is missing
-- Edited column names to comply with GLIMS, the laboratory information system
-- Added more valid MIC values
-- Renamed 'Daily Defined Dose' to 'Defined Daily Dose'
-- Added barplots for `rsi` and `mic` classes
-
-## 0.1.0
-- First submission to CRAN.

NEWS.md

@@ -0,0 +1,44 @@
+# 0.2.0
+#### New
+* Full support for Windows, Linux and macOS
+* Full support for old R versions, only R-3.0.0 (April 2013) or later is needed (needed packages may have other dependencies)
+* Function `n_rsi` to count cases where antibiotic test results were available, to be used in conjunction with `dplyr::summarise`, see ?rsi
+* Function `guess_bactid` to **determine the ID** of a microorganism based on genus/species or known abbreviations like MRSA
+* Function `guess_atc` to **determine the ATC** of an antibiotic based on name, trade name, or known abbreviations
+* Function `freq` to create **frequency tables**, with additional info in a header
+* Function `MDRO` to **determine Multi Drug Resistant Organisms (MDRO)** with support for country-specific guidelines.
+  * Suggest your own via [https://github.com/msberends/AMR/issues/new](https://github.com/msberends/AMR/issues/new?title=New%20guideline%20for%20MDRO&body=%3C--%20Please%20add%20your%20country%20code,%20guideline%20name,%20version%20and%20source%20below%20and%20remove%20this%20line--%3E)
+  * [Exceptional resistances defined by EUCAST](http://www.eucast.org/expert_rules_and_intrinsic_resistance) are also supported instead of countries alone
+  * Functions `BRMO` and `MRGN` are wrappers for Dutch and German guidelines, respectively
+* New algorithm to determine weighted isolates, can now be `"points"` or `"keyantibiotics"`, see `?first_isolate`
+* New print format for `tibble`s and `data.table`s
+
+#### Changed
+* Fixed `rsi` class for vectors that contain only invalid antimicrobial interpretations
+* Renamed dataset `ablist` to `antibiotics`
+* Renamed dataset `bactlist` to `microorganisms`
+* Added common abbreviations and trade names to the `antibiotics` dataset
+* Added more microorganisms to the `microorganisms` dataset
+* Added analysis examples on help page of dataset `septic_patients`
+* Added support for character vector in `join` functions
+* Added warnings when a join results in more rows after than before the join
+* Altered `%like%` to make it case insensitive
+* For parameters of functions `first_isolate` and `EUCAST_rules` column names are now case-insensitive
+* Functions `as.rsi` and `as.mic` now add the package name and version as attributes
+
+#### Other
+* Expanded `README.md` with more examples
+* Added [ORCID](https://orcid.org) of authors to DESCRIPTION file
+* Added unit testing with the `testthat` package
+* Added build tests for Linux and macOS using Travis CI (https://travis-ci.org/msberends/AMR)
+* Added line coverage checking using CodeCov (https://codecov.io/gh/msberends/AMR/tree/master/R)
+
+# 0.1.1
+* `EUCAST_rules` applies for amoxicillin even if ampicillin is missing
+* Edited column names to comply with GLIMS, the laboratory information system
+* Added more valid MIC values
+* Renamed 'Daily Defined Dose' to 'Defined Daily Dose'
+* Added barplots for `rsi` and `mic` classes
+
+# 0.1.0
+* First submission to CRAN.

R/atc.R

@@ -127,13 +127,13 @@ atc_property <- function(atc_code,
 
 #' Name of an antibiotic
 #'
-#' Convert antibiotic codes (from a laboratory information system like MOLIS or GLIMS) to a (trivial) antibiotic name or ATC code, or vice versa. This uses the data from \code{\link{ablist}}.
+#' Convert antibiotic codes (from a laboratory information system like MOLIS or GLIMS) to a (trivial) antibiotic name or ATC code, or vice versa. This uses the data from \code{\link{antibiotics}}.
 #' @param abcode a code or name, like \code{"AMOX"}, \code{"AMCL"} or \code{"J01CA04"}
-#' @param from,to type to transform from and to. See \code{\link{ablist}} for its column names.
+#' @param from,to type to transform from and to. See \code{\link{antibiotics}} for its column names. WIth \code{from = "guess"} the from will be guessed from \code{"atc"}, \code{"molis"} and \code{"umcg"}.
 #' @param textbetween text to put between multiple returned texts
 #' @param tolower return output as lower case with function \code{\link{tolower}}.
 #' @keywords ab antibiotics
-#' @source \code{\link{ablist}}
+#' @source \code{\link{antibiotics}}
 #' @export
 #' @importFrom dplyr %>% filter select slice
 #' @examples
@@ -154,17 +154,30 @@ atc_property <- function(atc_code,
 #'
 #' abname("J01CR02", from = "atc", to = "umcg")
 #' # "AMCL"
-abname <- function(abcode, from = 'umcg', to = 'official', textbetween = ' + ', tolower = FALSE) {
+abname <- function(abcode, from = c("guess", "atc", "molis", "umcg"), to = 'official', textbetween = ' + ', tolower = FALSE) {
 
-  ablist <- AMR::ablist
-  colnames(ablist) <- colnames(ablist) %>% tolower()
+  antibiotics <- AMR::antibiotics
+
+  from <- from[1]
+  if (from == "guess") {
+    for (i in 1:3) {
+      if (abcode[1] %in% (antibiotics %>% pull(i))) {
+        from <- colnames(antibiotics)[i]
+      }
+    }
+    if (from == "guess") {
+      from <- "umcg"
+    }
+  }
+
+  colnames(antibiotics) <- colnames(antibiotics) %>% tolower()
   from <- from %>% tolower()
   to <- to %>% tolower()
 
-  if (!from %in% colnames(ablist) |
-      !to %in% colnames(ablist)) {
+  if (!from %in% colnames(antibiotics) |
+      !to %in% colnames(antibiotics)) {
     stop(paste0('Invalid `from` or `to`. Choose one of ',
-                colnames(ablist) %>% paste(collapse = ","), '.'), call. = FALSE)
+                colnames(antibiotics) %>% paste(collapse = ","), '.'), call. = FALSE)
   }
 
   abcode <- as.character(abcode)
@@ -172,21 +185,21 @@ abname <- function(abcode, from = 'umcg', to = 'official', textbetween = ' + ',
   for (i in 1:length(abcode)) {
     drug <- abcode[i]
     if (!grepl('+', drug, fixed = TRUE) & !grepl(' en ', drug, fixed = TRUE)) {
-      # bestaat maar uit 1 middel
-      if (any(ablist[, from] == drug)) {
+      # only 1 drug
+      if (drug %in% (antibiotics %>% pull(from))) {
         abcode[i] <-
-          ablist %>%
+          antibiotics %>%
           filter(.[, from] == drug) %>%
           select(to) %>%
           slice(1) %>%
           as.character()
       } else {
-        # niet gevonden
+        # not found
         warning('Code "', drug, '" not found in antibiotics list.', call. = FALSE)
         abcode[i] <- NA
       }
     } else {
-      # meerdere middelen
+      # more than 1 drug
       if (grepl('+', drug, fixed = TRUE)) {
         drug.group <-
           strsplit(drug, '+', fixed = TRUE) %>%
@@ -205,7 +218,7 @@ abname <- function(abcode, from = 'umcg', to = 'official', textbetween = ' + ',
 
       for (j in 1:length(drug.group)) {
         drug.group[j] <-
-          ablist %>%
+          antibiotics %>%
           filter(.[, from] == drug.group[j]) %>%
           select(to) %>%
           slice(1) %>%
@@ -224,3 +237,217 @@ abname <- function(abcode, from = 'umcg', to = 'official', textbetween = ' + ',
 
   abcode
 }
+
+#' Find bacteria ID based on genus/species
+#'
+#' Use this function to determine a valid ID based on a genus (and species). This input could be a full name (like \code{"Staphylococcus aureus"}), an abbreviated name (like \code{"S. aureus"}), or just a genus. You could also use a \code{\link{paste}} of a genus and species column to use the full name as input: \code{x = paste(df$genus, df$species)}, where \code{df} is your dataframe.
+#' @param x character vector to determine \code{bactid}
+#' @export
+#' @importFrom dplyr %>% filter slice pull
+#' @return Character (vector).
+#' @seealso \code{\link{microorganisms}} for the dataframe that is being used to determine ID's.
+#' @examples
+#' # These examples all return "STAAUR", the ID of S. aureus:
+#' guess_bactid("stau")
+#' guess_bactid("STAU")
+#' guess_bactid("staaur")
+#' guess_bactid("S. aureus")
+#' guess_bactid("S aureus")
+#' guess_bactid("Staphylococcus aureus")
+#' guess_bactid("MRSA") # Methicillin-resistant S. aureus
+#' guess_bactid("VISA") # Vancomycin Intermediate S. aureus
+guess_bactid <- function(x) {
+  # remove dots and other non-text in case of "E. coli" except spaces
+  x <- gsub("[^a-zA-Z ]+", "", x)
+  # but spaces before and after should be omitted
+  x <- trimws(x, which = "both")
+  x.bak <- x
+  # replace space by regex sign
+  x <- gsub(" ", ".*", x, fixed = TRUE)
+  # add start and stop
+  x_species <- paste(x, 'species')
+  x <- paste0('^', x, '$')
+
+  for (i in 1:length(x)) {
+    if (tolower(x[i]) == '^e.*coli$') {
+      # avoid detection of Entamoeba coli in case of E. coli
+      x[i] <- 'Escherichia coli'
+    }
+    if (tolower(x[i]) == '^h.*influenzae$') {
+      # avoid detection of Haematobacter influenzae in case of H. influenzae
+      x[i] <- 'Haemophilus influenzae'
+    }
+    if (tolower(x[i]) == '^st.*au$'
+        | tolower(x[i]) == '^stau$'
+        | tolower(x[i]) == '^staaur$') {
+      # avoid detection of Staphylococcus auricularis in case of S. aureus
+      x[i] <- 'Staphylococcus aureus'
+    }
+    if (tolower(x[i]) == '^p.*aer$') {
+      # avoid detection of Pasteurella aerogenes in case of Pseudomonas aeruginosa
+      x[i] <- 'Pseudomonas aeruginosa'
+    }
+
+    # translate known trivial names to genus+species
+    if (toupper(x.bak[i]) == 'MRSA'
+        | toupper(x.bak[i]) == 'VISA'
+        | toupper(x.bak[i]) == 'VRSA') {
+      x[i] <- 'Staphylococcus aureus'
+    }
+    if (toupper(x.bak[i]) == 'MRSE') {
+      x[i] <- 'Staphylococcus epidermidis'
+    }
+    if (toupper(x.bak[i]) == 'VRE') {
+      x[i] <- 'Enterococcus'
+    }
+    if (toupper(x.bak[i]) == 'MRPA') {
+      # multi resistant P. aeruginosa
+      x[i] <- 'Pseudomonas aeruginosa'
+    }
+    if (toupper(x.bak[i]) == 'PISP'
+        | toupper(x.bak[i]) == 'PRSP') {
+      # peni resistant S. pneumoniae
+      x[i] <- 'Streptococcus pneumoniae'
+    }
+    if (toupper(x.bak[i]) == 'VISP'
+        | toupper(x.bak[i]) == 'VRSP') {
+      # vanco resistant S. pneumoniae
+      x[i] <- 'Streptococcus pneumoniae'
+    }
+
+    # let's try the ID's first
+    found <- AMR::microorganisms %>% filter(bactid == x.bak[i])
+
+    if (nrow(found) == 0) {
+      # now try exact match
+      found <- AMR::microorganisms %>% filter(fullname == x[i])
+    }
+    if (nrow(found) == 0) {
+      # try any match
+      found <- AMR::microorganisms %>% filter(fullname %like% x[i])
+    }
+    if (nrow(found) == 0) {
+      # try only genus, with 'species' attached
+      found <- AMR::microorganisms %>% filter(fullname %like% x_species[i])
+    }
+    if (nrow(found) == 0) {
+      # search for GLIMS code
+      if (toupper(x.bak[i]) %in% toupper(AMR::microorganisms.umcg$mocode)) {
+        found <- AMR::microorganisms.umcg %>% filter(toupper(mocode) == toupper(x.bak[i]))
+      }
+    }
+    if (nrow(found) == 0) {
+      # try splitting of characters and then find ID
+      # like esco = E. coli, klpn = K. pneumoniae, stau = S. aureus
+      x_split <- x
+      x_length <- nchar(x.bak[i])
+      x_split[i] <- paste0(x.bak[i] %>% substr(1, x_length / 2) %>% trimws(),
+                     '.* ',
+                     x.bak[i] %>% substr((x_length / 2) + 1, x_length) %>% trimws())
+      found <- AMR::microorganisms %>% filter(fullname %like% paste0('^', x_split[i]))
+    }
+    if (nrow(found) == 0) {
+      # try any match with text before and after original search string
+      # so "negative rods" will be "GNR"
+      if (x.bak[i] %like% "^Gram") {
+        x.bak[i] <- gsub("^Gram", "", x.bak[i], ignore.case = TRUE)
+        # remove leading and trailing spaces again
+        x.bak[i] <- trimws(x.bak[i], which = "both")
+      }
+      found <- AMR::microorganisms %>% filter(fullname %like% x.bak[i])
+    }
+
+    if (nrow(found) != 0) {
+      x[i] <- found %>%
+        slice(1) %>%
+        pull(bactid)
+    } else {
+      x[i] <- ""
+    }
+  }
+  x
+}
+
+#' Find ATC code based on antibiotic property
+#'
+#' Use this function to determine the ATC code of one or more antibiotics. The dataset \code{\link{antibiotics}} will be searched for abbreviations, official names and trade names.
+#' @param x character vector to determine \code{ATC} code
+#' @export
+#' @importFrom dplyr %>% filter slice pull
+#' @details In the ATC classification system, the active substances are classified in a hierarchy with five different levels.  The system has fourteen main anatomical/pharmacological groups or 1st levels.  Each ATC main group is divided into 2nd levels which could be either pharmacological or therapeutic groups.  The 3rd and 4th levels are chemical, pharmacological or therapeutic subgroups and the 5th level is the chemical substance.  The 2nd, 3rd and 4th levels are often used to identify pharmacological subgroups when that is considered more appropriate than therapeutic or chemical subgroups.
+#'   Source: \url{https://www.whocc.no/atc/structure_and_principles/}
+#' @return Character (vector).
+#' @seealso \code{\link{antibiotics}} for the dataframe that is being used to determine ATC's.
+#' @examples
+#' # These examples all return "J01FA01", the ATC code of Erythromycin:
+#' guess_atc("J01FA01")
+#' guess_atc("Erythromycin")
+#' guess_atc("eryt")
+#' guess_atc("ERYT")
+#' guess_atc("ERY")
+#' guess_atc("Erythrocin") # Trade name
+#' guess_atc("Eryzole")    # Trade name
+#' guess_atc("Pediamycin") # Trade name
+guess_atc <- function(x) {
+
+  # use this later to further fill AMR::antibiotics
+
+  # drug <- "Ciprofloxacin"
+  # url <- xml2::read_html(paste0("https://www.ncbi.nlm.nih.gov/pccompound?term=", drug)) %>%
+  #   html_nodes(".rslt") %>%
+  #   .[[1]] %>%
+  #   html_nodes(".title a") %>%
+  #   html_attr("href") %>%
+  #   gsub("/compound/", "/rest/pug_view/data/compound/", ., fixed = TRUE) %>%
+  #   paste0("/XML/?response_type=display")
+  # synonyms <- url %>%
+  #   read_xml() %>%
+  #   xml_contents() %>% .[[6]] %>%
+  #   xml_contents() %>% .[[8]] %>%
+  #   xml_contents() %>% .[[3]] %>%
+  #   xml_contents() %>% .[[3]] %>%
+  #   xml_contents() %>%
+  #   paste() %>%
+  #   .[. %like% "StringValueList"] %>%
+  #   gsub("[</]+StringValueList[>]", "", .)
+
+
+  for (i in 1:length(x)) {
+
+    # first try atc
+    found <- AMR::antibiotics %>% filter(atc == x[i])
+
+    if (nrow(found) == 0) {
+      # try abbreviation of molis and glims
+      found <- AMR::antibiotics %>% filter(molis == x[i] | umcg == x[i])
+    }
+
+    if (nrow(found) == 0) {
+      # try exact official name
+      found <- AMR::antibiotics[which(AMR::antibiotics$official == x[i]),]
+    }
+
+    if (nrow(found) == 0) {
+      # try trade name
+      found <- AMR::antibiotics[which(paste0("(", AMR::antibiotics$trade_name, ")") %like% x[i]),]
+    }
+
+    if (nrow(found) == 0) {
+      # try abbreviation
+      found <- AMR::antibiotics[which(paste0("(", AMR::antibiotics$abbr, ")") %like% x[i]),]
+    }
+    # if (nrow(found) == 0) {
+    #   # loosely try official name
+    #   found <- AMR::antibiotics[which(AMR::antibiotics$official %like% x[i]),]
+    # }
+
+    if (nrow(found) != 0) {
+      x[i] <- found %>%
+        slice(1) %>%
+        pull(atc)
+    } else {
+      x[i] <- NA
+    }
+  }
+  x
+}

R/classes.R

@@ -21,9 +21,10 @@
 #' 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}
+#' @return Ordered factor with new class \code{rsi} and new attributes \code{package} and \code{package.version}
 #' @export
 #' @importFrom dplyr %>%
+#' @importFrom utils packageDescription
 #' @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"))
@@ -40,6 +41,11 @@ as.rsi <- function(x) {
     x.bak <- x
 
     na_before <- x[is.na(x) | x == ''] %>% length()
+    # remove all spaces
+    x <- gsub(' {2,55}', '', x)
+    # disallow more than 3 characters
+    x[nchar(x) > 3] <- NA
+    # remove all invalid characters
     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)
@@ -54,13 +60,15 @@ as.rsi <- function(x) {
         sort()
       list_missing <- paste0('"', list_missing , '"', collapse = ", ")
       warning(na_after - na_before, ' results truncated (',
-              round(((na_after - na_before) / length(x)) / 100),
+              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')
+    attr(x, 'package') <- 'AMR'
+    attr(x, 'package.version') <- packageDescription('AMR')$Version
     x
   }
 }
@@ -84,20 +92,15 @@ print.rsi <- function(x, ...) {
   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)
-  ))
+  cat("Class 'rsi'\n")
+  cat(n, " results (missing: ", n_total - n, ' = ', percent((n_total - n) / n_total, force_zero = TRUE), ')\n', sep = "")
+  if (n > 0) {
+    cat('\n')
+    cat('Sum of S:   ', S, ' (', percent(S / n, force_zero = TRUE), ')\n', sep = "")
+    cat('Sum of IR:  ', IR, ' (', percent(IR / n, force_zero = TRUE), ')\n', sep = "")
+    cat('- Sum of R: ', R, ' (', percent(R / n, force_zero = TRUE), ')\n', sep = "")
+    cat('- Sum of I: ', I, ' (', percent(I / n, force_zero = TRUE), ')\n', sep = "")
+  }
 }
 
 #' @exportMethod summary.rsi
@@ -189,9 +192,10 @@ barplot.rsi <- function(height, ...) {
 #' @rdname as.mic
 #' @param x vector
 #' @param na.rm a logical indicating whether missing values should be removed
-#' @return New class \code{mic}
+#' @return Ordered factor with new class \code{mic} and new attributes \code{package} and \code{package.version}
 #' @export
 #' @importFrom dplyr %>%
+#' @importFrom utils packageDescription
 #' @examples
 #' mic_data <- as.mic(c(">=32", "1.0", "1", "1.00", 8, "<=0.128", "8", "16", "16"))
 #' is.mic(mic_data)
@@ -289,7 +293,7 @@ as.mic <- function(x, na.rm = FALSE) {
         sort()
       list_missing <- paste0('"', list_missing , '"', collapse = ", ")
       warning(na_after - na_before, ' results truncated (',
-              round(((na_after - na_before) / length(x)) / 100),
+              round(((na_after - na_before) / length(x)) * 100),
               '%) that were invalid MICs: ',
               list_missing, call. = FALSE)
     }
@@ -298,6 +302,8 @@ as.mic <- function(x, na.rm = FALSE) {
                 levels = lvls,
                 ordered = TRUE)
     class(x) <- c('mic', 'ordered', 'factor')
+    attr(x, 'package') <- 'AMR'
+    attr(x, 'package.version') <- packageDescription('AMR')$Version
     x
   }
 }
@@ -350,26 +356,19 @@ print.mic <- function(x, ...) {
 
 #' @exportMethod summary.mic
 #' @export
-#' @importFrom dplyr %>% tibble group_by summarise pull
+#' @importFrom dplyr %>%
 #' @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)
+  lst <- c('mic',
+           n_total - n,
+           sort(x)[1] %>% as.character(),
+           sort(x)[n] %>% as.character())
+  names(lst) <- c("Mode", "<NA>", "Min.", "Max.")
+  lst
 }
 
 #' @exportMethod plot.mic

R/data.R

@@ -18,36 +18,226 @@
 
 #' 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:
+#' A dataset containing all antibiotics with a J0 code, with their DDD's. Properties were downloaded from the WHO, see Source.
+#' @format A data.frame with 420 observations and 18 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{abbr}}{Abbreviation as used by many countries, to be used for \code{\link{guess_atc}}}
+#'   \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_nl}}{Trivial name in Dutch, like \code{"Amoxicilline/clavulaanzuur"}}
-#'   \item{\code{oral_ddd}}{Defined Daily Dose (DDD) according to the WHO, oral treatment}
+#'   \item{\code{trade_name}}{Trade name as used by many countries, to be used for \code{\link{guess_atc}}}
+#'   \item{\code{oral_ddd}}{Defined Daily Dose (DDD), oral treatment}
 #'   \item{\code{oral_units}}{Units of \code{ddd_units}}
-#'   \item{\code{iv_ddd}}{Defined Daily Dose (DDD) according to the WHO, parenteral treatment}
+#'   \item{\code{iv_ddd}}{Defined Daily Dose (DDD), 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"}}
+#'   \item{\code{atc_group1}}{ATC group, like \code{"Macrolides, lincosamides and streptogramins"}}
+#'   \item{\code{atc_group2}}{Subgroup of \code{atc_group1}, like \code{"Macrolides"}}
+#'   \item{\code{atc_group1_nl}}{ATC group in Dutch, like \code{"Macroliden, lincosamiden en streptograminen"}}
+#'   \item{\code{atc_group2_nl}}{Subgroup of \code{atc_group1} in Dutch, like \code{"Macroliden"}}
+#'   \item{\code{useful_gramnegative}}{\code{FALSE} if not useful according to EUCAST, \code{NA} otherwise (see Source)}
+#'   \item{\code{useful_grampositive}}{\code{FALSE} if not useful according to EUCAST, \code{NA} otherwise (see Source)}
 #' }
-#' @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"
+#' @source - World Health Organization: \url{https://www.whocc.no/atc_ddd_index/} \cr - EUCAST - Expert rules intrinsic exceptional V3.1 \cr - MOLIS (LIS of Certe): \url{https://www.certe.nl} \cr - GLIMS (LIS of UMCG): \url{https://www.umcg.nl}
+#' @seealso \code{\link{microorganisms}}
+# abbr and trade_name created with:
+# https://hs.unr.edu/Documents/dhs/chs/NVPHTC/antibiotic_refeference_guide.pdf
+# antibiotics %>%
+#   mutate(abbr =
+#            case_when(
+#              official == 'Amikacin' ~ 'Ak|AN|AMI|AMK',
+#              official == 'Amoxicillin' ~ 'AMX|AMOX|AC',
+#              official == 'Amoxicillin and beta-lactamase inhibitor' ~ 'AUG|A/C|XL|AML',
+#              official == 'Ampicillin' ~ 'AM|AMP',
+#              official == 'Ampicillin and beta-lactamase inhibitor' ~ 'A/S|SAM|AMS|AB',
+#              official == 'Azithromycin' ~ 'Azi|AZM|AZ',
+#              official == 'Azlocillin' ~ 'AZ|AZL',
+#              official == 'Aztreonam' ~ 'Azt|ATM|AT|AZM',
+#              official == 'Carbenicillin' ~ 'Cb|BAR',
+#              official == 'Cefaclor' ~ 'Ccl|CEC|Cfr|FAC|CF',
+#              official == 'Cefadroxil' ~ 'CFR|FAD',
+#              official == 'Cefazolin' ~ 'Cfz|CZ|FAZ|KZ',
+#              official == 'Cefdinir' ~ 'Cdn|CDR|DIN|CD|CFD',
+#              official == 'Cefditoren' ~ 'CDN',
+#              official == 'Cefepime' ~ 'Cpe|FEP|PM|CPM',
+#              official == 'Cefixime' ~ 'Cfe|DCFM|FIX|IX',
+#              official == 'Cefoperazone' ~ 'Cfp|CPZ|PER|FOP|CP',
+#              official == 'Cefotaxime' ~ 'Cft|CTX|TAX|FOT|CT',
+#              official == 'Cefotetan' ~ 'Ctn|CTT|CTE|TANS|CN',
+#              official == 'Cefoxitin' ~ 'Cfx|FOX|CX|FX',
+#              official == 'Cefpodoxime' ~ 'Cpd|POD|PX',
+#              official == 'Cefprozil' ~ 'Cpz|CPR|FP',
+#              official == 'Ceftaroline' ~ 'CPT',
+#              official == 'Ceftazidime' ~ 'Caz|TAZ|TZ',
+#              official == 'Ceftibuten' ~ 'CTB|TIB|CB',
+#              official == 'Ceftizoxime' ~ 'Cz|ZOX|CZX|CZ|CTZ|TIZ',
+#              official == 'Ceftriaxone' ~ 'Cax|CRO|CTR|FRX|AXO|TX',
+#              official == 'Cefuroxime' ~ 'Crm|CXM|CFX|ROX|FUR|XM',
+#              official == 'Cephalexin' ~ 'CN|LX|CFL',
+#              official == 'Cephalothin' ~ 'Cf',
+#              official == 'Chloramphenicol' ~ 'C|CHL|CL',
+#              official == 'Ciprofloxacin' ~ 'Cp|CIP|CI',
+#              official == 'Clarithromycin' ~ 'Cla|CLR|CLM|CH',
+#              official == 'Clindamycin' ~ 'Cd|CC|CM|CLI|DA',
+#              official == 'Colistin' ~ 'CL|CS|CT',
+#              official == 'Daptomycin' ~ 'Dap',
+#              official == 'Doxycycline' ~ 'Dox',
+#              official == 'Doripenem' ~ 'DOR|Dor',
+#              official == 'Ertapenem' ~ 'Etp',
+#              official == 'Erythromycin' ~ 'E|ERY|EM',
+#              official == 'Fosfomycin' ~ 'FOS|FF|FO|FM',
+#              official == 'Flucloxacillin' ~ 'CLOX',
+#              official == 'Gentamicin' ~ 'Gm|CN|GEN',
+#              official == 'Imipenem' ~ 'Imp|IPM|IMI|IP',
+#              official == 'Kanamycin' ~ 'K|KAN|HLK|KM',
+#              official == 'Levofloxacin' ~ 'Lvx|LEV|LEVO|LE',
+#              official == 'Linezolid' ~ 'Lzd|LNZ|LZ',
+#              official == 'Lomefloxacin' ~ 'Lmf|LOM',
+#              official == 'Meropenem' ~ 'Mer|MEM|MERO|MRP|MP',
+#              official == 'Metronidazole' ~ 'MNZ',
+#              official == 'Mezlocillin' ~ 'Mz|MEZ',
+#              official == 'Minocycline' ~ 'Min|MI|MN|MNO|MC|MH',
+#              official == 'Moxifloxacin' ~ 'Mox|MXF',
+#              official == 'Mupirocin' ~ 'MUP',
+#              official == 'Nafcillin' ~ 'Naf|NF',
+#              official == 'Nalidixic acid' ~ 'NA|NAL',
+#              official == 'Nitrofurantoin' ~ 'Fd|F/M|FT|NIT|NI|F',
+#              official == 'Norfloxacin' ~ 'Nxn|NOR|NX',
+#              official == 'Ofloxacin' ~ 'Ofl|OFX|OF',
+#              official == 'Oxacillin' ~ 'Ox|OXS|OXA',
+#              official == 'Benzylpenicillin' ~ 'P|PEN|PV',
+#              official == 'Penicillins, combinations with other antibacterials' ~ 'P|PEN|PV',
+#              official == 'Piperacillin' ~ 'Pi|PIP|PP',
+#              official == 'Piperacillin and beta-lactamase inhibitor' ~ 'PT|TZP|PTZ|P/T|PTc',
+#              official == 'Polymyxin B' ~ 'PB',
+#              official == 'Quinupristin/dalfopristin' ~ 'Syn|Q/D|QDA|RP',
+#              official == 'Rifampin' ~ 'Rif|RA|RI|RD',
+#              official == 'Spectinomycin' ~ 'SPT|SPE|SC',
+#              official == 'Streptomycin' ~ 'S|STR',
+#              official == 'Teicoplanin' ~ 'Tei|TEC|TPN|TP|TPL',
+#              official == 'Telavancin' ~ 'TLV',
+#              official == 'Telithromcyin' ~ 'Tel',
+#              official == 'Tetracycline' ~ 'Te|TET|TC',
+#              official == 'Ticarcillin' ~ 'Ti|TIC|TC',
+#              official == 'Ticarcillin and beta-lactamase inhibitor' ~ 'Tim|T/C|TCC|TLc',
+#              official == 'Tigecycline' ~ 'TGC',
+#              official == 'Tobramycin' ~ 'To|NN|TM|TOB',
+#              official == 'Trimethoprim' ~ 'T|TMP|TR|W',
+#              official == 'Sulfamethoxazole and trimethoprim' ~ 'T/S|SXT|SxT|TS|COT',
+#              official == 'Vancomycin' ~ 'Va|VAN',
+#              TRUE ~ NA_character_),
+#
+#          trade_name =
+#            case_when(
+#              official == 'Amikacin' ~ 'Amikin',
+#              official == 'Amoxicillin' ~ 'Amoxil|Dispermox|Larotid|Trimox',
+#              official == 'Amoxicillin and beta-lactamase inhibitor' ~ 'Augmentin',
+#              official == 'Ampicillin' ~ 'Pfizerpen-A|Principen',
+#              official == 'Ampicillin and beta-lactamase inhibitor' ~ 'Unasyn',
+#              official == 'Azithromycin' ~ 'Zithromax',
+#              official == 'Azlocillin' ~ 'Azlin',
+#              official == 'Aztreonam' ~ 'Azactam',
+#              official == 'Carbenicillin' ~ 'Geocillin',
+#              official == 'Cefaclor' ~ 'Ceclor',
+#              official == 'Cefadroxil' ~ 'Duricef',
+#              official == 'Cefazolin' ~ 'Ancef',
+#              official == 'Cefdinir' ~ 'Omnicef',
+#              official == 'Cefditoren' ~ 'Spectracef',
+#              official == 'Cefepime' ~ 'Maxipime',
+#              official == 'Cefixime' ~ 'Suprax',
+#              official == 'Cefoperazone' ~ 'Cefobid',
+#              official == 'Cefotaxime' ~ 'Claforan',
+#              official == 'Cefotetan' ~ 'Cefotan',
+#              official == 'Cefoxitin' ~ 'Mefoxin',
+#              official == 'Cefpodoxime' ~ 'Vantin',
+#              official == 'Cefprozil' ~ 'Cefzil',
+#              official == 'Ceftaroline' ~ 'Teflaro',
+#              official == 'Ceftazidime' ~ 'Fortaz|Tazicef|Tazidime',
+#              official == 'Ceftibuten' ~ 'Cedax',
+#              official == 'Ceftizoxime' ~ 'Cefizox',
+#              official == 'Ceftriaxone' ~ 'Rocephin',
+#              official == 'Cefuroxime' ~ 'Ceftin|Zinacef',
+#              official == 'Cephalexin' ~ 'Keflex|Panixine',
+#              official == 'Cephalothin' ~ 'Keflin',
+#              official == 'Chloramphenicol' ~ 'Chloromycetin',
+#              official == 'Ciprofloxacin' ~ 'Cipro|Ciloxan|Ciproxin',
+#              official == 'Clarithromycin' ~ 'Biaxin',
+#              official == 'Clindamycin' ~ 'Cleocin|Clinda-Derm|Clindagel|Clindesse|Clindets|Evoclin',
+#              official == 'Colistin' ~ 'Coly-Mycin',
+#              official == 'Daptomycin' ~ 'Cubicin',
+#              official == 'Doxycycline' ~ 'Doryx|Monodox|Vibramycin|Atridox|Oracea|Periostat|Vibra-Tabs',
+#              official == 'Doripenem' ~ 'Doribax',
+#              official == 'Ertapenem' ~ 'Invanz',
+#              official == 'Erythromycin' ~ 'Eryc|EryPed|Erythrocin|E-Base|E-Glades|E-Mycin|E.E.S.|Ery-Tab|Eryderm|Erygel|Erythra-derm|Eryzole|Pediamycin',
+#              official == 'Fosfomycin' ~ 'Monurol',
+#              official == 'Flucloxacillin' ~ 'Flopen|Floxapen|Fluclox|Sesamol|Softapen|Staphylex',
+#              official == 'Gentamicin' ~ 'Garamycin|Genoptic',
+#              official == 'Imipenem' ~ 'Primaxin',
+#              official == 'Kanamycin' ~ 'Kantrex',
+#              official == 'Levofloxacin' ~ 'Levaquin|Quixin',
+#              official == 'Linezolid' ~ 'Zyvox',
+#              official == 'Lomefloxacin' ~ 'Maxaquin',
+#              official == 'Meropenem' ~ 'Merrem',
+#              official == 'Metronidazole' ~ 'Flagyl|MetroGel|MetroCream|MetroLotion',
+#              official == 'Mezlocillin' ~ 'Mezlin',
+#              official == 'Minocycline' ~ 'Arestin|Solodyn',
+#              official == 'Moxifloxacin' ~ 'Avelox|Vigamox',
+#              official == 'Mupirocin' ~ 'Bactroban|Centany',
+#              official == 'Nafcillin' ~ 'Unipen',
+#              official == 'Nalidixic acid' ~ 'NegGram',
+#              official == 'Nitrofurantoin' ~ 'Furadantin|Macrobid|Macrodantin',
+#              official == 'Norfloxacin' ~ 'Noroxin',
+#              official == 'Ofloxacin' ~ 'Floxin|Ocuflox|Ophthalmic',
+#              official == 'Oxacillin' ~ 'Bactocill',
+#              official == 'Benzylpenicillin' ~ 'Permapen|Pfizerpen|Veetids',
+#              official == 'Penicillins, combinations with other antibacterials' ~ 'Permapen|Pfizerpen|Veetids',
+#              official == 'Piperacillin' ~ 'Pipracil',
+#              official == 'Piperacillin and beta-lactamase inhibitor' ~ 'Zosyn',
+#              official == 'Polymyxin B' ~ 'Poly-RX',
+#              official == 'Quinupristin/dalfopristin' ~ 'Synercid',
+#              official == 'Rifampin' ~ 'Rifadin|Rifamate|Rimactane',
+#              official == 'Spectinomycin' ~ 'Trobicin',
+#              official == 'Streptomycin' ~ 'Streptomycin Sulfate',
+#              official == 'Teicoplanin' ~ 'Targocid',
+#              official == 'Telavancin' ~ 'Vibativ',
+#              official == 'Telithromcyin' ~ 'Ketek',
+#              official == 'Tetracycline' ~ 'Sumycin|Bristacycline|Tetrex',
+#              official == 'Ticarcillin' ~ 'Ticar',
+#              official == 'Ticarcillin and beta-lactamase inhibitor' ~ 'Timentin',
+#              official == 'Tigecycline' ~ 'Tygacil',
+#              official == 'Tobramycin' ~ 'Tobi|Aktob|Tobre',
+#              official == 'Trimethoprim' ~ 'Primsol|Proloprim',
+#              official == 'Sulfamethoxazole and trimethoprim' ~ 'Bactrim|Septra|Sulfatrim',
+#              official == 'Vancomycin' ~ 'Vancocin|Vancomycin Hydrochloride',
+#              TRUE ~ NA_character_)
+#   )
+# last two columns created with:
+# antibiotics %>%
+#   mutate(useful_gramnegative =
+#            if_else(
+#              atc_group1 %like% '(fusidic|glycopeptide|macrolide|lincosamide|daptomycin|linezolid)' |
+#                atc_group2 %like% '(fusidic|glycopeptide|macrolide|lincosamide|daptomycin|linezolid)' |
+#                official %like% '(fusidic|glycopeptide|macrolide|lincosamide|daptomycin|linezolid)',
+#              FALSE,
+#              NA
+#            ),
+#          useful_grampositive =
+#            if_else(
+#              atc_group1 %like% '(aztreonam|temocillin|polymyxin|colistin|nalidixic)' |
+#                atc_group2 %like% '(aztreonam|temocillin|polymyxin|colistin|nalidixic)' |
+#                official %like% '(aztreonam|temocillin|polymyxin|colistin|nalidixic)',
+#              FALSE,
+#              NA
+#            )
+#   )
+"antibiotics"
 
 #' 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:
+#' A dataset containing 2453 microorganisms. MO codes of the UMCG can be looked up using \code{\link{microorganisms.umcg}}.
+#' @format A data.frame with 2453 observations and 12 variables:
 #' \describe{
 #'   \item{\code{bactid}}{ID of microorganism}
 #'   \item{\code{bactsys}}{Bactsyscode of microorganism}
@@ -56,29 +246,31 @@
 #'   \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 in Dutch, like \code{"Bacterie"} and \code{"Schimmel/gist"}}
-#'   \item{\code{gramstain}}{Gram of microorganism in Dutch, like \code{"Negatieve staven"}}
-#'   \item{\code{aerobic}}{Type aerobe/anaerobe of bacteria}
+#'   \item{\code{type}}{Type of microorganism, like \code{"Bacteria"} and \code{"Fungus/yeast"}}
+#'   \item{\code{gramstain}}{Gram of microorganism, like \code{"Negative rods"}}
+#'   \item{\code{aerobic}}{Logical whether bacteria is aerobic}
+#'   \item{\code{type_nl}}{Type of microorganism in Dutch, like \code{"Bacterie"} and \code{"Schimmel/gist"}}
+#'   \item{\code{gramstain_nl}}{Gram of microorganism in Dutch, like \code{"Negatieve staven"}}
 #' }
 #' @source MOLIS (LIS of Certe) - \url{https://www.certe.nl}
-#' @seealso \code{\link{ablist}} \code{\link{bactlist.umcg}}
-"bactlist"
+#' @seealso \code{\link{guess_bactid}} \code{\link{antibiotics}} \code{\link{microorganisms.umcg}}
+"microorganisms"
 
 #' 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}}.
+#' A dataset containing all bacteria codes of UMCG MMB. These codes can be joined to data with an ID from \code{\link{microorganisms}$bactid} (using \code{\link{left_join_microorganisms}}). GLIMS codes can also be translated to valid \code{bactid}'s with \code{\link{guess_bactid}}.
 #' @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}}}
+#'   \item{\code{bactid}}{Code of microorganism in \code{\link{microorganisms}}}
 #' }
 #' @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"
+#' @seealso \code{\link{guess_bactid}} \code{\link{microorganisms}}
+"microorganisms.umcg"
 
 #' Dataset with 2000 blood culture isolates of septic patients
 #'
-#' An anonymised dataset containing 2000 microbial blood culture isolates with their antibiogram of septic patients found in 5 different hospitals in the Netherlands, between 2001 and 2017. This data.frame can be used to practice AMR analysis e.g. with \code{\link{rsi}} or \code{\link{rsi_predict}}, or it can be used to practice other statistics.
+#' An anonymised dataset containing 2000 microbial blood culture isolates with their antibiogram of septic patients found in 5 different hospitals in the Netherlands, between 2001 and 2017. This data.frame can be used to practice AMR analysis. For examples, press F1.
 #' @format A data.frame with 2000 observations and 47 variables:
 #' \describe{
 #'   \item{\code{date}}{date of receipt at the laboratory}
@@ -89,8 +281,47 @@
 #'   \item{\code{age}}{age of the patient}
 #'   \item{\code{sex}}{sex of the patient}
 #'   \item{\code{patient_id}}{ID of the patient, first 10 characters of an SHA hash containing irretrievable information}
-#'   \item{\code{bactid}}{ID of microorganism, see \code{\link{bactlist}}}
-#'   \item{\code{peni:mupi}}{38 different antibiotics with class \code{rsi} (see \code{\link{as.rsi}}), these column names occur in \code{\link{ablist}} and can be translated with \code{\link{abname}}}
+#'   \item{\code{bactid}}{ID of microorganism, see \code{\link{microorganisms}}}
+#'   \item{\code{peni:mupi}}{38 different antibiotics with class \code{rsi} (see \code{\link{as.rsi}}); these column names occur in \code{\link{antibiotics}} and can be translated with \code{\link{abname}}}
 #' }
 #' @source MOLIS (LIS of Certe) - \url{https://www.certe.nl}
+#' @examples
+#' # ----------- #
+#' # PREPARATION #
+#' # ----------- #
+#'
+#' # Save this example dataset to an object, so we can edit it:
+#' my_data <- septic_patients
+#'
+#' # load the dplyr package to make data science A LOT easier
+#' library(dplyr)
+#'
+#' # Add first isolates to our dataset:
+#' my_data <- my_data %>%
+#'   mutate(first_isolates = first_isolate(my_data, "date", "patient_id", "bactid"))
+#'
+#' # -------- #
+#' # ANALYSIS #
+#' # -------- #
+#'
+#' # 1. Get the amoxicillin resistance percentages
+#' #    of E. coli, divided by hospital:
+#'
+#' my_data %>%
+#'   filter(bactid == "ESCCOL",
+#'          first_isolates == TRUE) %>%
+#'   group_by(hospital_id) %>%
+#'   summarise(n = n(),
+#'             amoxicillin_resistance = rsi(amox))
+#'
+#'
+#' # 2. Get the amoxicillin/clavulanic acid resistance
+#' #    percentages of E. coli, trend over the years:
+#'
+#' my_data %>%
+#'   filter(bactid == guess_bactid("E. coli"),
+#'          first_isolates == TRUE) %>%
+#'   group_by(year = format(date, "%Y")) %>%
+#'   summarise(n = n(),
+#'             amoxclav_resistance = rsi(amcl, minimum = 20))
 "septic_patients"

R/eucast.R

@@ -20,7 +20,7 @@
 #'
 #' 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} - values of this column should be present in \code{bactlist$bactid}, see \code{\link{bactlist}}
+#' @param col_bactid column name of the bacteria ID in \code{tbl} - values of this column should be present in \code{microorganisms$bactid}, see \code{\link{microorganisms}}
 #' @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}
@@ -33,9 +33,10 @@
 #'   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}
+#'   EUCAST Expert Rules Version 3.1 (Intrinsic Resistance and Exceptional Phenotypes Tables): \cr
+#'   \url{http://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/Expert_rules_intrinsic_exceptional_V3.1.pdf}
 #' @examples
+#' a <- EUCAST_rules(septic_patients)
 #' a <- data.frame(bactid = c("STAAUR",  # Staphylococcus aureus
 #'                            "ENCFAE",  # Enterococcus faecalis
 #'                            "ESCCOL",  # Escherichia coli
@@ -52,7 +53,7 @@
 #' b <- EUCAST_rules(a)
 #' b
 EUCAST_rules <- function(tbl,
-                         col_bactcode = 'bactid',
+                         col_bactid = 'bactid',
                          info = TRUE,
                          amcl = 'amcl',
                          amik = 'amik',
@@ -113,94 +114,84 @@ EUCAST_rules <- function(tbl,
                          trsu = 'trsu',
                          vanc = 'vanc') {
 
-  if (!col_bactcode %in% colnames(tbl)) {
-    stop('Column ', col_bactcode, ' not found.')
+  EUCAST_VERSION <- "3.1"
+
+  if (!col_bactid %in% colnames(tbl)) {
+    stop('Column ', col_bactid, ' not found.', call. = FALSE)
   }
 
-  # 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 }
-  }
+  # check columns
+  col.list <- c(amcl, amik, amox, ampi, azit, aztr, cefa, cfra, cfep, cfot,
+                cfox, cfta, cftr, cfur, chlo, cipr, clar, clin, clox, coli,
+                czol, dapt, doxy, erta, eryt, fosf, fusi, gent, imip, kana,
+                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 <- check_available_columns(tbl = tbl, col.list = col.list, info = info)
+  amcl <- col.list[amcl]
+  amik <- col.list[amik]
+  amox <- col.list[amox]
+  ampi <- col.list[ampi]
+  azit <- col.list[azit]
+  aztr <- col.list[aztr]
+  cefa <- col.list[cefa]
+  cfra <- col.list[cfra]
+  cfep <- col.list[cfep]
+  cfot <- col.list[cfot]
+  cfox <- col.list[cfox]
+  cfta <- col.list[cfta]
+  cftr <- col.list[cftr]
+  cfur <- col.list[cfur]
+  chlo <- col.list[chlo]
+  cipr <- col.list[cipr]
+  clar <- col.list[clar]
+  clin <- col.list[clin]
+  clox <- col.list[clox]
+  coli <- col.list[coli]
+  czol <- col.list[czol]
+  dapt <- col.list[dapt]
+  doxy <- col.list[doxy]
+  erta <- col.list[erta]
+  eryt <- col.list[eryt]
+  fosf <- col.list[fosf]
+  fusi <- col.list[fusi]
+  gent <- col.list[gent]
+  imip <- col.list[imip]
+  kana <- col.list[kana]
+  levo <- col.list[levo]
+  linc <- col.list[linc]
+  line <- col.list[line]
+  mero <- col.list[mero]
+  mino <- col.list[mino]
+  moxi <- col.list[moxi]
+  nali <- col.list[nali]
+  neom <- col.list[neom]
+  neti <- col.list[neti]
+  nitr <- col.list[nitr]
+  novo <- col.list[novo]
+  norf <- col.list[norf]
+  oflo <- col.list[oflo]
+  peni <- col.list[peni]
+  pita <- col.list[pita]
+  poly <- col.list[poly]
+  qida <- col.list[qida]
+  rifa <- col.list[rifa]
+  roxi <- col.list[roxi]
+  siso <- col.list[siso]
+  teic <- col.list[teic]
+  tetr <- col.list[tetr]
+  tica <- col.list[tica]
+  tige <- col.list[tige]
+  tobr <- col.list[tobr]
+  trim <- col.list[trim]
+  trsu <- col.list[trsu]
+  vanc <- col.list[vanc]
 
   total <- 0
   total_rows <- integer(0)
 
-  # functie voor uitvoeren
+  # helper function for editing the table
   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
@@ -209,97 +200,99 @@ EUCAST_rules <- function(tbl,
     }
   }
 
-  # 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", ""))
+  # join to microorganisms table
+  joinby <- colnames(AMR::microorganisms)[1]
+  names(joinby) <- col_bactid
+  tbl <- tbl %>% left_join(y = AMR::microorganisms, by = joinby, suffix = c("_tempmicroorganisms", ""))
 
-  # 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)
+  # 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 <- qida # should officially also be pristinamycin and quinupristin/dalfopristin
+  cephalosporins <- 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)
+  aminopenicillins <- c(ampi, amox)
+  ureidopenicillins <- pita # should officially also be azlo and mezlo
+  fluoroquinolones <- c(oflo, cipr, norf, levo, moxi)
 
   if (info == TRUE) {
-    cat('\nApplying rules to',
+    cat(
+      paste0(
+        '\nApplying rules to ',
         tbl[!is.na(tbl$genus),] %>% nrow() %>% format(big.mark = ","),
-        'rows according to "EUCAST Expert Rules Version 3.1"\n\n')
+        ' rows according to "EUCAST Expert Rules Version ', EUCAST_VERSION, '"\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
+  # Intrisiek R for this group
   edit_rsi(to = 'R',
            rows = which(tbl$family == 'Enterobacteriaceae'),
-           cols = c(peni, glycopeptiden, fusi, macroliden, linc, streptogramines, rifa, dapt, line))
+           cols = c(peni, glycopeptides, fusi, macrolides, linc, streptogramins, rifa, dapt, line))
   # Citrobacter
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Citrobacter (koseri|amalonaticus|sedlakii|farmeri|rodentium)'),
-           cols = c(aminopenicillines, tica))
+           cols = c(aminopenicillins, tica))
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Citrobacter (freundii|braakii|murliniae|werkmanii|youngae)'),
-           cols = c(aminopenicillines, amcl, czol, cfox))
+           cols = c(aminopenicillins, amcl, czol, cfox))
   # Enterobacter
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Enterobacter cloacae'),
-           cols = c(aminopenicillines, amcl, czol, cfox))
+           cols = c(aminopenicillins, amcl, czol, cfox))
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Enterobacter aerogenes'),
-           cols = c(aminopenicillines, amcl, czol, cfox))
+           cols = c(aminopenicillins, amcl, czol, cfox))
   # Escherichia
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Escherichia hermanni'),
-           cols = c(aminopenicillines, tica))
+           cols = c(aminopenicillins, tica))
   # Hafnia
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Hafnia alvei'),
-           cols = c(aminopenicillines, amcl, czol, cfox))
+           cols = c(aminopenicillins, amcl, czol, cfox))
   # Klebsiella
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Klebsiella'),
-           cols = c(aminopenicillines, tica))
+           cols = c(aminopenicillins, tica))
   # Morganella / Proteus
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Morganella morganii'),
-           cols = c(aminopenicillines, amcl, czol, tetracyclines, polymyxines, nitr))
+           cols = c(aminopenicillins, amcl, czol, tetracyclines, polymyxins, nitr))
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Proteus mirabilis'),
-           cols = c(tetracyclines, tige, polymyxines, nitr))
+           cols = c(tetracyclines, tige, polymyxins, nitr))
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Proteus penneri'),
-           cols = c(aminopenicillines, czol, cfur, tetracyclines, tige, polymyxines, nitr))
+           cols = c(aminopenicillins, czol, cfur, tetracyclines, tige, polymyxins, nitr))
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Proteus vulgaris'),
-           cols = c(aminopenicillines, czol, cfur, tetracyclines, tige, polymyxines, nitr))
+           cols = c(aminopenicillins, czol, cfur, tetracyclines, tige, polymyxins, nitr))
   # Providencia
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Providencia rettgeri'),
-           cols = c(aminopenicillines, amcl, czol, cfur, tetracyclines, tige, polymyxines, nitr))
+           cols = c(aminopenicillins, amcl, czol, cfur, tetracyclines, tige, polymyxins, nitr))
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Providencia stuartii'),
-           cols = c(aminopenicillines, amcl, czol, cfur, tetracyclines, tige, polymyxines, nitr))
+           cols = c(aminopenicillins, amcl, czol, cfur, tetracyclines, tige, polymyxins, nitr))
   # Raoultella
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Raoultella'),
-           cols = c(aminopenicillines, tica))
+           cols = c(aminopenicillins, tica))
   # Serratia
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Serratia marcescens'),
-           cols = c(aminopenicillines, amcl, czol, cfox, cfur, tetracyclines[tetracyclines != 'mino'], polymyxines, nitr))
+           cols = c(aminopenicillins, amcl, czol, cfox, cfur, tetracyclines[tetracyclines != 'mino'], polymyxins, nitr))
   # Yersinia
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Yersinia enterocolitica'),
-           cols = c(aminopenicillines, amcl, tica, czol, cfox))
+           cols = c(aminopenicillins, amcl, tica, czol, cfox))
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Yersinia pseudotuberculosis'),
            cols = c(poly, coli))
@@ -309,8 +302,7 @@ EUCAST_rules <- function(tbl,
   if (info == TRUE) {
     cat('...Table 2: Intrinsic resistance in non-fermentative Gram-negative bacteria\n')
   }
-  #voortgang <- progress_estimated(8)
-  # Intrisiek R voor groep
+  # Intrisiek R for this group
   edit_rsi(to = 'R',
            rows = which(tbl$genus %in% c('Achromobacter',
                                          'Acinetobacter',
@@ -322,54 +314,53 @@ EUCAST_rules <- function(tbl,
                                          'Ochrobactrum',
                                          'Pseudomonas',
                                          'Stenotrophomonas')),
-           cols = c(peni, cfox, cfur, glycopeptiden, fusi, macroliden, linc, streptogramines, rifa, dapt, line))
+           cols = c(peni, cfox, cfur, glycopeptides, fusi, macrolides, linc, streptogramins, rifa, dapt, line))
   # Acinetobacter
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Acinetobacter (baumannii|pittii|nosocomialis|calcoaceticus)'),
-           cols = c(aminopenicillines, amcl, czol, cfot, cftr, aztr, erta, trim, fosf, tetracyclines[tetracyclines != 'mino']))
+           cols = c(aminopenicillins, 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(aminopenicillines, czol, cfot, cftr, erta))
+           cols = c(aminopenicillins, 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(aminopenicillines, amcl, tica, pita, czol, cfot, cftr, aztr, erta, cipr, chlo, aminoglycosiden, trim, fosf, polymyxines))
+           cols = c(aminopenicillins, amcl, tica, pita, czol, cfot, cftr, aztr, erta, cipr, chlo, aminoglycosides, trim, fosf, polymyxins))
   # Elizabethkingia
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Elizabethkingia meningoseptic(a|um)'),
-           cols = c(aminopenicillines, amcl, tica, czol, cfot, cftr, cfta, cfep, aztr, erta, imip, mero, polymyxines))
+           cols = c(aminopenicillins, amcl, tica, czol, cfot, cftr, cfta, cfep, aztr, erta, imip, mero, polymyxins))
   # Ochrobactrum
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Ochrobactrum anthropi'),
-           cols = c(aminopenicillines, amcl, tica, pita, czol, cfot, cftr, cfta, cfep, aztr, erta))
+           cols = c(aminopenicillins, amcl, tica, pita, czol, cfot, cftr, cfta, cfep, aztr, erta))
   # Pseudomonas
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Pseudomonas aeruginosa'),
-           cols = c(aminopenicillines, amcl, czol, cfot, cftr, erta, chlo, kana, neom, trim, trsu, tetracyclines, tige))
+           cols = c(aminopenicillins, 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(aminopenicillines, amcl, tica, pita, czol, cfot, cftr, cfta, aztr, erta, imip, mero, aminoglycosiden, trim, fosf, tetr))
+           cols = c(aminopenicillins, amcl, tica, pita, czol, cfot, cftr, cfta, aztr, erta, imip, mero, aminoglycosides, 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
+  # Intrisiek R for this group
   edit_rsi(to = 'R',
            rows = which(tbl$genus %in% c('Haemophilus',
                                          'Moraxella',
                                          'Neisseria',
                                          'Campylobacter')),
-           cols = c(glycopeptiden, linc, dapt, line))
+           cols = c(glycopeptides, linc, dapt, line))
   # Haemophilus
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Haemophilus influenzae'),
-           cols = c(fusi, streptogramines))
+           cols = c(fusi, streptogramins))
   # Moraxella
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Moraxella catarrhalis'),
@@ -381,21 +372,20 @@ EUCAST_rules <- function(tbl,
   # Campylobacter
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Campylobacter fetus'),
-           cols = c(fusi, streptogramines, trim, nali))
+           cols = c(fusi, streptogramins, trim, nali))
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Campylobacter (jejuni|coli)'),
-           cols = c(fusi, streptogramines, trim))
+           cols = c(fusi, streptogramins, 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
+  # Intrisiek R for this group
   edit_rsi(to = 'R',
            rows = which(tbl$gramstain %like% 'Positi(e|)(v|f)'),
-           cols = c(aztr, polymyxines, nali))
+           cols = c(aztr, polymyxins, nali))
   # Staphylococcus
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Staphylococcus saprophyticus'),
@@ -412,17 +402,17 @@ EUCAST_rules <- function(tbl,
   # Streptococcus
   edit_rsi(to = 'R',
            rows = which(tbl$genus == 'Streptococcus'),
-           cols = c(fusi, cfta, aminoglycosiden))
+           cols = c(fusi, cfta, aminoglycosides))
   # 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))
+           cols = c(fusi, cfta, cephalosporins[cephalosporins != cfta], aminoglycosides, macrolides, 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))
+           cols = c(fusi, cfta, cephalosporins[cephalosporins != cfta], aminoglycosides, macrolides, 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))
+           cols = c(fusi, cfta, cephalosporins[cephalosporins != cfta], aminoglycosides, macrolides, trim, trsu))
   # Corynebacterium
   edit_rsi(to = 'R',
            rows = which(tbl$genus == 'Corynebacterium'),
@@ -430,7 +420,7 @@ EUCAST_rules <- function(tbl,
   # Listeria
   edit_rsi(to = 'R',
            rows = which(tbl$fullname %like% '^Listeria monocytogenes'),
-           cols = c(cfta, cefalosporines[cefalosporines != cfta]))
+           cols = c(cfta, cephalosporins[cephalosporins != cfta]))
   # overig
   edit_rsi(to = 'R',
            rows = which(tbl$genus %in% c('Leuconostoc', 'Pediococcus')),
@@ -446,34 +436,32 @@ EUCAST_rules <- function(tbl,
   if (info == TRUE) {
     cat('...Table 8: Interpretive rules for B-lactam agents and Gram-positive cocci\n')
   }
-  #voortgang <- progress_estimated(2)
-  # regel 8.3
+  # rule 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))
+             cols = c(aminopenicillins, cephalosporins, carbapenems))
   }
-  # regel 8.6
+  # rule 8.6
   if (!is.na(ampi)) {
     edit_rsi(to = 'R',
              rows = which(tbl$genus == 'Enterococcus'
                           & tbl[, ampi] == 'R'),
-             cols = c(ureidopenicillines, carbapenems))
+             cols = c(ureidopenicillins, carbapenems))
   }
   if (!is.na(amox)) {
     edit_rsi(to = 'R',
              rows = which(tbl$genus == 'Enterococcus'
                           & tbl[, amox] == 'R'),
-             cols = c(ureidopenicillines, carbapenems))
+             cols = c(ureidopenicillins, 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
+  # rule 9.3
   if (!is.na(tica) & !is.na(pita)) {
     edit_rsi(to = 'R',
              rows = which(tbl$family == 'Enterobacteriaceae'
@@ -486,10 +474,9 @@ EUCAST_rules <- function(tbl,
   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
+  # rule 10.2
   if (!is.na(ampi)) {
-    # hiervoor moeten we eerst weten of ze B-lactamase-positief zijn
+    # you should know first if the are B-lactamase positive, so do not run for now
     # edit_rsi(to = 'R',
     #          rows = which(tbl$fullname %like% '^Haemophilus influenza'
     #                       & tbl[, ampi] == 'R'),
@@ -500,7 +487,7 @@ EUCAST_rules <- function(tbl,
   if (info == TRUE) {
     cat('...Table 11: Interpretive rules for macrolides, lincosamides, and streptogramins\n')
   }
-  # regel 11.1
+  # rule 11.1
   if (!is.na(eryt)) {
     if (!is.na(azit)) {
       tbl[, azit] <- tbl[, eryt]
@@ -514,22 +501,21 @@ EUCAST_rules <- function(tbl,
   if (info == TRUE) {
     cat('...Table 12: Interpretive rules for aminoglycosides\n')
   }
-  #voortgang <- progress_estimated(4)
-  # regel 12.2
+  # rule 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
+  # rule 12.3
   if (!is.na(gent)) {
     edit_rsi(to = 'R',
              rows = which(tbl$genus == 'Staphylococcus'
                           & tbl[, gent] == 'R'),
-             cols = aminoglycosiden)
+             cols = aminoglycosides)
   }
-  # regel 12.8
+  # rule 12.8
   if (!is.na(gent) & !is.na(tobr)) {
     edit_rsi(to = 'R',
              rows = which(tbl$family == 'Enterobacteriaceae'
@@ -537,7 +523,7 @@ EUCAST_rules <- function(tbl,
                           & tbl[, tobr] == 'S'),
              cols = gent)
   }
-  # regel 12.9
+  # rule 12.9
   if (!is.na(gent) & !is.na(tobr)) {
     edit_rsi(to = 'R',
              rows = which(tbl$family == 'Enterobacteriaceae'
@@ -551,42 +537,40 @@ EUCAST_rules <- function(tbl,
   if (info == TRUE) {
     cat('...Table 13: Interpretive rules for quinolones\n')
   }
-  #voortgang <- progress_estimated(4)
-  # regel 13.2
+  # rule 13.2
   if (!is.na(moxi)) {
     edit_rsi(to = 'R',
              rows = which(tbl$genus == 'Staphylococcus'
                           & tbl[, moxi] == 'R'),
-             cols = fluorochinolonen)
+             cols = fluoroquinolones)
   }
-  # regel 13.4
+  # rule 13.4
   if (!is.na(moxi)) {
     edit_rsi(to = 'R',
              rows = which(tbl$fullname %like% '^Streptococcus pneumoniae'
                           & tbl[, moxi] == 'R'),
-             cols = fluorochinolonen)
+             cols = fluoroquinolones)
   }
-  # regel 13.5
+  # rule 13.5
   if (!is.na(cipr)) {
     edit_rsi(to = 'R',
              rows = which(tbl$family == 'Enterobacteriaceae'
                           & tbl[, cipr] == 'R'),
-             cols = fluorochinolonen)
+             cols = fluoroquinolones)
   }
-  # regel 13.8
+  # rule 13.8
   if (!is.na(cipr)) {
     edit_rsi(to = 'R',
              rows = which(tbl$fullname %like% '^Neisseria gonorrhoeae'
                           & tbl[, cipr] == 'R'),
-             cols = fluorochinolonen)
+             cols = fluoroquinolones)
   }
 
 
   # Other ----
   if (info == TRUE) {
-    cat('...Other\n')
+    cat('...Non-EUCAST: trim = R where trsu = R and ampi = R where amcl = R\n')
   }
-  #voortgang <- progress_estimated(2)
   if (!is.na(amcl)) {
     edit_rsi(to = 'R',
              rows = which(tbl[, amcl] == 'R'),
@@ -601,17 +585,17 @@ EUCAST_rules <- function(tbl,
     tbl[, amox] <- tbl %>% pull(ampi)
   }
 
-  # Toegevoegde kolommen weer verwijderen
-  bactlist.ncol <- ncol(AMR::bactlist) - 2
+  # Remove added columns again
+  microorganisms.ncol <- ncol(AMR::microorganisms) - 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))
+  tbl <- tbl %>% select(-c((tbl.ncol - microorganisms.ncol):tbl.ncol))
+  # and remove added suffices
+  colnames(tbl) <- gsub("_tempmicroorganisms", "", colnames(tbl))
 
   if (info == TRUE) {
-    cat('\nDone.\nEUCAST Expert rules applied to',
+    cat('Done.\n\nEUCAST Expert rules applied to',
         total_rows %>% unique() %>% length() %>% format(big.mark = ","),
-        'different rows, to a total of',
+        'different rows (isolates); edited a total of',
         total %>% format(big.mark = ","), 'test results.\n\n')
   }
 
@@ -626,14 +610,14 @@ interpretive_reading <- function(...) {
 
 #' Poperties of a microorganism
 #'
-#' @param bactcode ID of a microorganisme, like \code{"STAAUR} and \code{"ESCCOL}
+#' @param bactid 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') {
+#' @seealso \code{\link{microorganisms}}
+mo_property <- function(bactid, property = 'fullname') {
 
-  mocode <- as.character(bactcode)
+  mocode <- as.character(bactid)
 
   for (i in 1:length(mocode)) {
     bug <- mocode[i]
@@ -641,8 +625,8 @@ mo_property <- function(bactcode, property = 'fullname') {
     if (!is.na(bug)) {
       result = tryCatch({
         mocode[i] <-
-          AMR::bactlist %>%
-          filter(bactid == bactcode) %>%
+          AMR::microorganisms %>%
+          filter(bactid == bug) %>%
           select(property) %>%
           unlist() %>%
           as.character()

R/first_isolates.R

@@ -22,29 +22,46 @@
 #' @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_patient_id 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. 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.
+#' @param col_bactid column name of the unique IDs of the microorganisms (should occur in the \code{\link{microorganisms}} dataset)
+#' @param col_testcode column name of the test codes. 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. Supports tidyverse-like quotation.
 #' @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 col_keyantibiotics column name of the key antibiotics to determine first \emph{weighted} isolates, see \code{\link{key_antibiotics}}. Supports tidyverse-like quotation.
 #' @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 testcodes_exclude character vector with test codes that should be excluded (case-insensitive)
 #' @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 points_threshold points until the comparison of key antibiotics will lead to inclusion of an isolate, see Details
+#' @param output_logical return output as \code{logical} (will else be the values \code{0} or \code{1})
+#' @param type type to determine weighed isolates; can be \code{"keyantibiotics"} or \code{"points"}, see Details
+#' @param ignore_I logical to determine whether antibiotic interpretations with \code{"I"} will be ignored when \code{type = "keyantibiotics"}, see Details
+#' @param points_threshold points until the comparison of key antibiotics will lead to inclusion of an isolate when \code{type = "points"}, see Details
 #' @param info print progress
-#' @details \strong{Why this is so important} \cr
+#' @param col_genus (deprecated, use \code{col_bactid} instead) column name of the genus of the microorganisms
+#' @param col_species (deprecated, use \code{col_bactid} instead) column name of the species of the microorganisms
+#' @details \strong{WHY THIS IS SO IMPORTANT} \cr
 #'     To conduct an analysis of antimicrobial resistance, you should only include the first isolate of every patient per episode \href{https://www.ncbi.nlm.nih.gov/pubmed/17304462}{[1]}. 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 it 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 \href{https://en.wikipedia.org/wiki/Selection_bias}{selection bias}.
 #'
-#'     \strong{Using parameter \code{points_threshold}} \cr
-#'     To compare key antibiotics, the difference between antimicrobial interpretations will be measured. A difference from I to S|R (or vice versa) means 0.5 points. A difference from S to R (or vice versa) means 1 point. When the sum of points exceeds \code{points_threshold}, an isolate will be (re)selected as a first weighted isolate.
+#'     \strong{DETERMINING WEIGHTED ISOLATES} \cr
+#'     \strong{1. Using} \code{type = "keyantibiotics"} \strong{and parameter} \code{ignore_I} \cr
+#'     To determine weighted isolates, the difference between key antibiotics will be checked. Any difference from S to R (or vice versa) will (re)select an isolate as a first weighted isolate. With \code{ignore_I = FALSE}, also differences from I to S|R (or vice versa) will lead to this. This is a reliable method and 30-35 times faster than method 2. \cr
+#'     \strong{2. Using} \code{type = "points"} \strong{and parameter} \code{points_threshold} \cr
+#'     To determine weighted isolates, difference between antimicrobial interpretations will be measured with points. A difference from I to S|R (or vice versa) means 0.5 points, a difference from S to R (or vice versa) means 1 point. When the sum of points exceeds \code{points_threshold}, an isolate will be (re)selected as a first weighted isolate. This method is being used by the Infection Prevention department (Dr M. Lokate) of the University Medical Center Groningen (UMCG).
 #' @keywords isolate isolates first
 #' @export
 #' @importFrom dplyr arrange_at lag between row_number filter mutate arrange
 #' @return A vector to add to table, see Examples.
+#' @source Methodology of this function is based on: "M39 Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data, 4th Edition", 2014, Clinical and Laboratory Standards Institute. \url{https://clsi.org/standards/products/microbiology/documents/m39/}.
 #' @examples
+#' # septic_patients is a dataset available in the AMR package
+#' ?septic_patients
+#' my_patients <- septic_patients
+#'
+#' library(dplyr)
+#' my_patients$first_isolate <- my_patients %>%
+#'   first_isolate(col_date = "date",
+#'                 col_patient_id = "patient_id",
+#'                 col_bactid = "bactid")
+#'
 #' \dontrun{
 #'
 #' # set key antibiotics to a new variable
@@ -87,21 +104,29 @@
 first_isolate <- function(tbl,
                           col_date,
                           col_patient_id,
-                          col_genus,
-                          col_species,
+                          col_bactid = NA,
                           col_testcode = NA,
-                          col_specimen,
-                          col_icu,
+                          col_specimen = NA,
+                          col_icu = NA,
                           col_keyantibiotics = NA,
                           episode_days = 365,
                           testcodes_exclude = '',
                           icu_exclude = FALSE,
                           filter_specimen = NA,
                           output_logical = TRUE,
+                          type = "keyantibiotics",
+                          ignore_I = TRUE,
                           points_threshold = 2,
-                          info = TRUE) {
+                          info = TRUE,
+                          col_genus = NA,
+                          col_species = NA) {
 
-  # controleren of kolommen wel bestaan
+  # bactid OR genus+species must be available
+  if (is.na(col_bactid) & (is.na(col_genus) | is.na(col_species))) {
+    stop('`col_bactid or both `col_genus` and `col_species` must be available.')
+  }
+
+  # check if columns exist
   check_columns_existance <- function(column, tblname = tbl) {
     if (NROW(tblname) <= 1 | NCOL(tblname) <= 1) {
       stop('Please check tbl for existance.')
@@ -109,23 +134,30 @@ first_isolate <- function(tbl,
 
     if (!is.na(column)) {
       if (!(column %in% colnames(tblname))) {
-        stop('Column ', column, ' not found.')
+        stop('Column `', column, '` not found.')
       }
     }
   }
 
   check_columns_existance(col_date)
   check_columns_existance(col_patient_id)
+  check_columns_existance(col_bactid)
   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_bactid)) {
+    tbl <- tbl %>% left_join_microorganisms(by = col_bactid)
+    col_genus <- "genus"
+    col_species <- "species"
+  }
+
   if (is.na(col_testcode)) {
     testcodes_exclude <- NA
   }
-  # testcodes verwijderen die ingevuld zijn
+  # remove testcodes
   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')
   }
@@ -137,9 +169,13 @@ first_isolate <- function(tbl,
       mutate(col_icu = tbl %>% pull(col_icu) %>% as.logical())
   }
 
+  if (is.na(col_specimen)) {
+    filter_specimen <- ''
+  }
+
   specgroup.notice <- ''
   weighted.notice <- ''
-  # filteren op materiaalgroep en sleutelantibiotica gebruiken wanneer deze ingevuld zijn
+  # filter on specimen group and keyantibiotics when they are filled in
   if (!is.na(filter_specimen) & filter_specimen != '') {
     check_columns_existance(col_specimen, tbl)
     if (info == TRUE) {
@@ -158,8 +194,7 @@ first_isolate <- function(tbl,
     testcodes_exclude <- ''
   }
 
-  # nieuwe dataframe maken met de oorspronkelijke rij-index, 0-bepaling en juiste sortering
-  #cat('Sorting table...')
+  # create new dataframe with original row index and right sorting
   tbl <- tbl %>%
     mutate(first_isolate_row_index = 1:nrow(tbl),
            eersteisolaatbepaling = 0,
@@ -203,7 +238,7 @@ first_isolate <- function(tbl,
     }
 
   } else {
-    # sorteren op materiaal en alleen die rijen analyseren om tijd te besparen
+    # sort on specimen and only analyse these row to save time
     if (icu_exclude == FALSE) {
       if (info == TRUE) {
         cat('Isolates from ICU will *NOT* be ignored.\n')
@@ -247,7 +282,7 @@ first_isolate <- function(tbl,
     if (info == TRUE) {
       cat('No isolates found.\n')
     }
-    # NA's maken waar genus niet beschikbaar is
+    # NA's where genus is unavailable
     tbl <- tbl %>%
       mutate(real_first_isolate = if_else(genus == '', NA, FALSE))
     if (output_logical == FALSE) {
@@ -263,7 +298,7 @@ first_isolate <- function(tbl,
            genus != '') %>%
     nrow()
 
-  # Analyse van eerste isolaat ----
+  # Analysis of first isolate ----
   all_first <- tbl %>%
     mutate(other_pat_or_mo = if_else(patient_id == lag(patient_id)
                                      & genus == lag(genus)
@@ -277,13 +312,25 @@ first_isolate <- function(tbl,
 
   if (col_keyantibiotics != '') {
     if (info == TRUE) {
-      cat(paste0('Comparing key antibiotics for first weighted isolates (using points threshold of '
-                 , points_threshold, ')...\n'))
+      if (type == 'keyantibiotics') {
+        cat('Comparing key antibiotics for first weighted isolates (')
+        if (ignore_I == FALSE) {
+          cat('NOT ')
+        }
+        cat('ignoring I)...\n')
+      }
+      if (type == 'points') {
+        cat(paste0('Comparing antibiotics for first weighted isolates (using points threshold of '
+                   , points_threshold, ')...\n'))
+      }
     }
+    type_param <- type
     all_first <- all_first %>%
       mutate(key_ab_lag = lag(key_ab)) %>%
       mutate(key_ab_other = !key_antibiotics_equal(x = key_ab,
                                                    y = key_ab_lag,
+                                                   type = type_param,
+                                                   ignore_I = ignore_I,
                                                    points_threshold = points_threshold,
                                                    info = info)) %>%
       mutate(
@@ -312,9 +359,9 @@ first_isolate <- function(tbl,
             FALSE))
   }
 
-  # allereerst isolaat als TRUE
+  # first one as TRUE
   all_first[row.start, 'real_first_isolate'] <- TRUE
-  # geen testen die uitgesloten moeten worden, of ICU
+  # no tests that should be included, or ICU
   if (!is.na(col_testcode)) {
     all_first[which(all_first[, col_testcode] %in% tolower(testcodes_exclude)), 'real_first_isolate'] <- FALSE
   }
@@ -322,7 +369,7 @@ first_isolate <- function(tbl,
     all_first[which(all_first[, col_icu] == TRUE), 'real_first_isolate'] <- FALSE
   }
 
-  # NA's maken waar genus niet beschikbaar is
+  # NA's where genus is unavailable
   all_first <- all_first %>%
     mutate(real_first_isolate = if_else(genus == '', NA, real_first_isolate))
 
@@ -351,20 +398,20 @@ first_isolate <- function(tbl,
 #' 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 col_bactid column of bacteria IDs in \code{tbl}; these should occur in \code{microorganisms$bactid}, see \code{\link{microorganisms}}
 #' @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.
+#' @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, case-insensitive
 #' @export
 #' @importFrom dplyr %>% mutate if_else
 #' @return Character of length 1.
-#' @seealso \code{\link{mo_property}} \code{\link{ablist}}
+#' @seealso \code{\link{mo_property}} \code{\link{antibiotics}}
 #' @examples
 #' \donttest{
 #' #' # set key antibiotics to a new variable
 #' tbl$keyab <- key_antibiotics(tbl)
 #' }
 key_antibiotics <- function(tbl,
-                            col_bactcode = 'bactid',
+                            col_bactid = 'bactid',
                             info = TRUE,
                             amcl = 'amcl',
                             amox = 'amox',
@@ -389,22 +436,37 @@ key_antibiotics <- function(tbl,
 
   keylist <- character(length = nrow(tbl))
 
+  if (!col_bactid %in% colnames(tbl)) {
+    stop('Column ', col_bactid, ' not found.', call. = FALSE)
+  }
+
   # 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)
-    }
-  }
+  col.list <- check_available_columns(tbl = tbl, col.list = col.list, info = info)
+  amox <- col.list[amox]
+  cfot <- col.list[cfot]
+  cfta <- col.list[cfta]
+  cftr <- col.list[cftr]
+  cfur <- col.list[cfur]
+  cipr <- col.list[cipr]
+  clar <- col.list[clar]
+  clin <- col.list[clin]
+  clox <- col.list[clox]
+  doxy <- col.list[doxy]
+  gent <- col.list[gent]
+  line <- col.list[line]
+  mero <- col.list[mero]
+  peni <- col.list[peni]
+  pita <- col.list[pita]
+  rifa <- col.list[rifa]
+  teic <- col.list[teic]
+  trsu <- col.list[trsu]
+  vanc <- col.list[vanc]
 
-  # bactlist aan vastknopen
-  tbl <- tbl %>% left_join_bactlist(col_bactcode)
+  # join microorganisms
+  tbl <- tbl %>% left_join_microorganisms(col_bactid)
 
   tbl$key_ab <- NA_character_
 
@@ -422,7 +484,7 @@ key_antibiotics <- function(tbl,
   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',
+                          if_else(gramstain %like% '^Positive ',
                                   apply(X = tbl[, list_ab],
                                         MARGIN = 1,
                                         FUN = function(x) paste(x, collapse = "")),
@@ -432,7 +494,7 @@ key_antibiotics <- function(tbl,
   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',
+                          if_else(gramstain %like% '^Negative ',
                                   apply(X = tbl[, list_ab],
                                         MARGIN = 1,
                                         FUN = function(x) paste(x, collapse = "")),
@@ -448,9 +510,16 @@ key_antibiotics <- function(tbl,
 
 #' @importFrom dplyr progress_estimated %>%
 #' @noRd
-key_antibiotics_equal <- function(x, y, points_threshold = 2, info = FALSE) {
+key_antibiotics_equal <- function(x,
+                                  y,
+                                  type = c("keyantibiotics", "points"),
+                                  ignore_I = TRUE,
+                                  points_threshold = 2,
+                                  info = FALSE) {
   # x is active row, y is lag
 
+  type <- type[1]
+
   if (length(x) != length(y)) {
     stop('Length of `x` and `y` must be equal.')
   }
@@ -484,17 +553,42 @@ key_antibiotics_equal <- function(x, y, points_threshold = 2, info = FALSE) {
 
     } else {
 
-      # count points for every single character:
-      # - no change is 0 points
-      # - I <-> S|R is 0.5 point
-      # - S|R <-> R|S is 1 point
-      # use the levels of as.rsi (S = 1, I = 2, R = 3)
+      x2 <- strsplit(x[i], "")[[1]]
+      y2 <- strsplit(y[i], "")[[1]]
 
-      x2 <- strsplit(x[i], "")[[1]] %>% as.rsi() %>% as.double()
-      y2 <- strsplit(y[i], "")[[1]] %>% as.rsi() %>% as.double()
+      if (type == 'points') {
+        # count points for every single character:
+        # - no change is 0 points
+        # - I <-> S|R is 0.5 point
+        # - S|R <-> R|S is 1 point
+        # use the levels of as.rsi (S = 1, I = 2, R = 3)
 
-      points <- (x2 - y2) %>% abs() %>% sum(na.rm = TRUE)
-      result[i] <- ((points / 2) >= points_threshold)
+        suppressWarnings(x2 <- x2 %>% as.rsi() %>% as.double())
+        suppressWarnings(y2 <- y2 %>% as.rsi() %>% as.double())
+
+        points <- (x2 - y2) %>% abs() %>% sum(na.rm = TRUE)
+        result[i] <- ((points / 2) >= points_threshold)
+
+      } else if (type == 'keyantibiotics') {
+        # check if key antibiotics are exactly the same
+        # also possible to ignore I, so only S <-> R and S <-> R are counted
+        if (ignore_I == TRUE) {
+          valid_chars <- c('S', 's', 'R', 'r')
+        } else {
+          valid_chars <- c('S', 's', 'I', 'i', 'R', 'r')
+        }
+
+        # remove invalid values (like "-", NA) on both locations
+        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)
+
+      } else {
+        stop('`', type, '` is not a valid value for type, must be "points" or "keyantibiotics". See ?first_isolate.')
+      }
     }
   }
   if (info == TRUE) {

R/freq.R

@@ -0,0 +1,361 @@
+# ==================================================================== #
+# 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.                         #
+# ==================================================================== #
+
+#' Frequency table
+#'
+#' Create a frequency table of a vector of data, a single column or a maximum of 9 columns of a data frame. Supports markdown for reports.
+#' @param x data
+#' @param sort.count Sort on count. Use \code{FALSE} to sort alphabetically on item.
+#' @param nmax number of row to print. Use \code{nmax = 0} or \code{nmax = NA} to print all rows.
+#' @param na.rm a logical value indicating whether NA values should be removed from the frequency table. The header will always print the amount of\code{NA}s.
+#' @param markdown print table in markdown format (this forces \code{nmax = NA})
+#' @param toConsole Print table to the console. Use \code{FALSE} to assign the table to an object.
+#' @param digits how many significant digits are to be used for numeric values (not for the items themselves, that depends on \code{\link{getOption}("digits")})
+#' @param sep a character string to separate the terms when selecting multiple columns
+#' @details For numeric values, the next values will be calculated and shown into the header:
+#' \itemize{
+#'   \item{Mean, using \code{\link[base]{mean}}}
+#'   \item{Standard deviation, using \code{\link[stats]{sd}}}
+#'   \item{Five numbers of Tukey (min, Q1, median, Q3, max), using \code{\link[stats]{fivenum}}}
+#'   \item{Outliers (count and list), using \code{\link{boxplot.stats}}}
+#'   \item{Coefficient of variation (CV), the standard deviation divided by the mean}
+#'   \item{Coefficient of quartile variation (CQV, sometimes called coefficient of dispersion), calculated as \code{(Q3 - Q1) / (Q3 + Q1)} using \code{\link{quantile}} with \code{type = 6} as quantile algorithm to comply with SPSS standards}
+#' }
+#' @importFrom stats fivenum sd quantile
+#' @importFrom grDevices boxplot.stats
+#' @importFrom dplyr %>% select pull n_distinct group_by arrange desc mutate summarise
+#' @keywords summary summarise frequency freq
+#' @rdname freq
+#' @export
+#' @examples
+#' library(dplyr)
+#'
+#' freq(septic_patients$hospital_id)
+#'
+#' septic_patients %>%
+#'   filter(hospital_id == "A") %>%
+#'   select(bactid) %>%
+#'   freq()
+#'
+#' # select multiple columns; they will be pasted together
+#' septic_patients %>%
+#'   left_join_microorganisms %>%
+#'   filter(hospital_id == "A") %>%
+#'   select(genus, species) %>%
+#'   freq()
+#'
+#' # save frequency table to an object
+#' years <- septic_patients %>%
+#'   mutate(year = format(date, "%Y")) %>%
+#'   select(year) %>%
+#'   freq(toConsole = FALSE)
+freq <- function(x,
+                 sort.count = TRUE,
+                 nmax = 15,
+                 na.rm = TRUE,
+                 markdown = FALSE,
+                 toConsole = TRUE,
+                 digits = 2,
+                 sep = " ") {
+
+  mult.columns <- 0
+
+  if (NROW(x) == 0) {
+    cat('\nNo observations.\n')
+    return(invisible())
+  }
+
+  if (!is.null(ncol(x))) {
+    if (ncol(x) == 1 & any(class(x) == 'data.frame')) {
+      x <- x %>% pull(1)
+    } else if (ncol(x) < 10) {
+
+      mult.columns <- ncol(x)
+
+      colnames(x) <- LETTERS[1:ncol(x)]
+      if (ncol(x) == 2) {
+        x$total <- paste(x$A %>% as.character(),
+                          x$B %>% as.character(),
+                          sep = sep)
+      } else if (ncol(x) == 3) {
+        x$total <- paste(x$A %>% as.character(),
+                          x$B %>% as.character(),
+                          x$C %>% as.character(),
+                          sep = sep)
+      } else if (ncol(x) == 4) {
+        x$total <- paste(x$A %>% as.character(),
+                          x$B %>% as.character(),
+                          x$C %>% as.character(),
+                          x$D %>% as.character(),
+                          sep = sep)
+      } else if (ncol(x) == 5) {
+        x$total <- paste(x$A %>% as.character(),
+                          x$B %>% as.character(),
+                          x$C %>% as.character(),
+                          x$D %>% as.character(),
+                          x$E %>% as.character(),
+                          sep = sep)
+      } else if (ncol(x) == 6) {
+        x$total <- paste(x$A %>% as.character(),
+                          x$B %>% as.character(),
+                          x$C %>% as.character(),
+                          x$D %>% as.character(),
+                          x$E %>% as.character(),
+                          x$F %>% as.character(),
+                          sep = sep)
+      } else if (ncol(x) == 7) {
+        x$total <- paste(x$A %>% as.character(),
+                          x$B %>% as.character(),
+                          x$C %>% as.character(),
+                          x$D %>% as.character(),
+                          x$E %>% as.character(),
+                          x$F %>% as.character(),
+                          x$G %>% as.character(),
+                          sep = sep)
+      } else if (ncol(x) == 8) {
+        x$total <- paste(x$A %>% as.character(),
+                          x$B %>% as.character(),
+                          x$C %>% as.character(),
+                          x$D %>% as.character(),
+                          x$E %>% as.character(),
+                          x$F %>% as.character(),
+                          x$G %>% as.character(),
+                          x$H %>% as.character(),
+                          sep = sep)
+      } else if (ncol(x) == 9) {
+        x$total <- paste(x$A %>% as.character(),
+                          x$B %>% as.character(),
+                          x$C %>% as.character(),
+                          x$D %>% as.character(),
+                          x$E %>% as.character(),
+                          x$F %>% as.character(),
+                          x$G %>% as.character(),
+                          x$H %>% as.character(),
+                          x$I %>% as.character(),
+                          sep = sep)
+      }
+
+      x <- x$total
+
+    } else {
+      stop('A maximum of 9 columns can be analysed at the same time.', call. = FALSE)
+    }
+  }
+  if (markdown == TRUE & toConsole == FALSE) {
+    warning('`toConsole = FALSE` will be ignored when `markdown = TRUE`.')
+  }
+
+  if (mult.columns > 1) {
+    NAs <- x[is.na(x) | x == trimws(strrep('NA ', mult.columns))]
+  } else {
+    NAs <- x[is.na(x)]
+  }
+  if (na.rm == TRUE) {
+    x <- x[!x %in% NAs]
+  }
+
+  if (missing(sort.count) & any(class(x) %in% c('double', 'integer', 'numeric', 'raw', 'single', 'factor'))) {
+    # sort on item/level at default when x is numeric or a factor and sort.count is not set
+    sort.count <- FALSE
+  }
+
+  header <- character(0)
+
+  markdown_line <- ''
+  if (markdown == TRUE) {
+    markdown_line <- '\n'
+  }
+  x_align <- 'l'
+
+  if (mult.columns > 0) {
+    header <- header %>% paste0(markdown_line, 'Columns:   ', mult.columns)
+  } else {
+    header <- header %>% paste0(markdown_line, 'Class:     ', class(x) %>% rev() %>% paste(collapse = " > "))
+  }
+
+  if (is.list(x) | is.matrix(x) | is.environment(x) | is.function(x)) {
+    cat(header, "\n")
+    stop('`freq()` does not support lists, matrices, environments or functions.', call. = FALSE)
+  }
+
+  header <- header %>% paste0(markdown_line, '\nLength:    ', (NAs %>% length() + x %>% length()) %>% format(),
+                              ' (of which NA: ', NAs %>% length() %>% format(),
+                              ' = ', (NAs %>% length() / (NAs %>% length() + x %>% length())) %>% percent(force_zero = TRUE), ')')
+  header <- header %>% paste0(markdown_line, '\nUnique:    ', x %>% n_distinct() %>% format())
+
+  header.numbers.done <- FALSE
+  if (any(class(x) %in% c('double', 'integer', 'numeric', 'raw', 'single'))) {
+    # right align number
+    x_align <- 'r'
+    header <- header %>% paste0('\n')
+    header <- header %>% paste(markdown_line, '\nMean:     ', x %>% base::mean(na.rm = TRUE) %>% format(digits = digits))
+    header <- header %>% paste0(markdown_line, '\nStd. dev.: ', x %>% stats::sd(na.rm = TRUE) %>% format(digits = digits),
+                                ' (CV: ', x %>% cv(na.rm = TRUE) %>% format(digits = digits), ')')
+    header <- header %>% paste0(markdown_line, '\nFive-Num:  ', x %>% stats::fivenum(na.rm = TRUE) %>% format(digits = digits) %>% trimws() %>% paste(collapse = '  |  '),
+                                ' (CQV: ', x %>% cqv(na.rm = TRUE) %>% format(digits = digits), ')')
+    outlier_length <- length(boxplot.stats(x)$out)
+    header <- header %>% paste0(markdown_line, '\nOutliers:  ', outlier_length)
+    if (outlier_length > 0) {
+      header <- header %>% paste0(' (unique: ', boxplot.stats(x)$out %>% unique() %>% length(), ')')
+    }
+  }
+
+  formatdates <- "%e %B %Y" # = d mmmm yyyy
+  if (any(class(x) == 'hms')) {
+    x <- x %>% as.POSIXlt()
+    formatdates <- "%H:%M:%S"
+  }
+  if (any(class(x) %in% c('Date', 'POSIXct', 'POSIXlt'))) {
+    header <- header %>% paste0('\n')
+    mindatum <- x %>% min()
+    maxdatum <- x %>% max()
+    header <- header %>% paste0(markdown_line, '\nOldest:    ', mindatum %>% format(formatdates) %>% trimws())
+    header <- header %>% paste0(markdown_line, '\nNewest:    ', maxdatum %>% format(formatdates) %>% trimws(),
+                                ' (+', difftime(maxdatum, mindatum, units = 'auto') %>% as.double() %>% format(), ')')
+  }
+  if (any(class(x) == 'POSIXlt')) {
+    x <- x %>% format(formatdates)
+  }
+
+  if (toConsole == TRUE) {
+    cat(header)
+  }
+
+  if (all(is.na(x))) {
+    cat('\n\nNo observations.\n')
+    return(invisible())
+  }
+  if (n_distinct(x) == length(x)) {
+    warning('All observations are unique.', call. = FALSE)
+  }
+
+  if (nmax == 0 | is.na(nmax)) {
+    nmax <- length(x)
+  }
+  nmax.1 <- min(length(x), nmax + 1)
+
+  # create table with counts and percentages
+  if (any(class(x) == 'factor')) {
+    df <- tibble::tibble(Item = x,
+                         Fctlvl = x %>% as.integer()) %>%
+      group_by(Item, Fctlvl)
+    column_names <- c('Item', 'Count', 'Percent', 'Cum. Count', 'Cum. Percent', '(Factor Level)')
+    column_align <- c('l', 'r', 'r', 'r', 'r', 'r')
+  } else {
+    df <- tibble::tibble(Item = x) %>%
+      group_by(Item)
+    column_names <- c('Item', 'Count', 'Percent', 'Cum. Count', 'Cum. Percent')
+    column_align <- c(x_align, 'r', 'r', 'r', 'r')
+  }
+  df <- df %>%
+    summarise(Count = n(),
+              Percent = (n() / length(x)) %>% percent(force_zero = TRUE))
+
+  if (df$Item %>% paste(collapse = ',') %like% '\033') {
+    df <- df %>%
+      mutate(Item = Item %>%
+               # remove escape char
+               # see https://en.wikipedia.org/wiki/Escape_character#ASCII_escape_character
+               gsub('\033', ' ', ., fixed = TRUE))
+  }
+
+  # sort according to setting
+  if (sort.count == TRUE) {
+    df <- df %>% arrange(desc(Count))
+  } else {
+    if (any(class(x) == 'factor')) {
+      df <- df %>% arrange(Fctlvl)
+    } else {
+      df <- df %>% arrange(Item)
+    }
+  }
+
+  # add cumulative values
+  df$Cum <- cumsum(df$Count)
+  df$CumTot <- (df$Cum / sum(df$Count, na.rm = TRUE)) %>% percent(force_zero = TRUE)
+  df$Cum <- df$Cum %>% format()
+
+  if (any(class(x) == 'factor')) {
+    # put factor last
+    df <- df %>% select(Item, Count, Percent, Cum, CumTot, Fctlvl)
+  }
+
+  if (markdown == TRUE) {
+    tblformat <- 'markdown'
+  } else {
+    tblformat <- 'pandoc'
+  }
+
+  if (toConsole == FALSE) {
+    # assign to object
+    df[, 3] <- df[, 2] / sum(df[, 2], na.rm = TRUE)
+    df[, 4] <- cumsum(df[, 2])
+    df[, 5] <- df[, 4] / sum(df[, 2], na.rm = TRUE)
+    return(df)
+
+  } else {
+
+    # save old NA setting for kable
+    opt.old <- options()$knitr.kable.NA
+    options(knitr.kable.NA = "<NA>")
+
+    Count.rest <- sum(df[nmax.1:nrow(df), 'Count'], na.rm = TRUE)
+    if (any(class(x) %in% c('double', 'integer', 'numeric', 'raw', 'single'))) {
+      df <- df %>% mutate(Item = format(Item))
+    }
+    df <- df %>% mutate(Count = format(Count))
+
+    if (nrow(df) > nmax.1 & markdown == FALSE) {
+      df2 <- df[1:nmax,]
+      print(
+        knitr::kable(df2,
+                     format = tblformat,
+                     col.names = column_names,
+                     align = column_align,
+                     padding = 1)
+      )
+      cat('... and ',
+          format(nrow(df) - nmax),
+          ' more ',
+          paste0('(n = ',
+                 format(Count.rest),
+                 '; ',
+                 (Count.rest / length(x)) %>% percent(force_zero = TRUE),
+                 ')'),
+          '. Use `nmax` to show more rows.\n', sep = '')
+
+    } else {
+      print(
+        knitr::kable(df,
+                     format = tblformat,
+                     col.names = column_names,
+                     align = column_align,
+                     padding = 1)
+      )
+    }
+    cat('\n')
+
+    # reset old kable setting
+    options(knitr.kable.NA = opt.old)
+    return(invisible())
+  }
+}
+
+#' @rdname freq
+#' @export
+frequency_tbl <- freq

R/globals.R

@@ -16,22 +16,34 @@
 # GNU General Public License for more details.                         #
 # ==================================================================== #
 
-globalVariables(c('.',
-                  'abname',
+globalVariables(c('abname',
+                  'atc',
                   'bactid',
                   'cnt',
+                  'Count',
+                  'Cum',
+                  'CumTot',
                   'date_lab',
                   'days_diff',
+                  'Fctlvl',
                   'first_isolate_row_index',
+                  'fullname',
                   'genus',
                   'gramstain',
+                  'Item',
                   'key_ab',
                   'key_ab_lag',
                   'key_ab_other',
                   'mic',
+                  'mocode',
+                  'molis',
                   'n',
                   'other_pat_or_mo',
                   'patient_id',
+                  'Percent',
+                  'quantile',
                   'real_first_isolate',
                   'species',
-                  'y'))
+                  'umcg',
+                  'y',
+                  '.'))

R/join.R

@@ -1,34 +1,42 @@
-#' Join a table with \code{bactlist}
+#' Join a table with \code{microorganisms}
 #'
-#' Join the list of microorganisms \code{\link{bactlist}} easily to an existing table.
+#' Join the dataset \code{\link{microorganisms}} easily to an existing table or character vector.
 #' @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 x existing table to join, also supports character vectors
+#' @param by a variable to join by - could be a column name of \code{x} with values that exist in \code{microorganisms$bactid} (like \code{by = "bacteria_id"}), or another column in \code{\link{microorganisms}} (but then it should be named, like \code{by = c("my_genus_species" = "fullname")})
+#' @param suffix if there are non-joined duplicate variables in \code{x} and \code{y}, these suffixes will be added to the output to disambiguate them. Should be a character vector of length 2.
 #' @param ... other parameters to pass on 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.
+#' @details As opposed to the \code{\link[dplyr]{join}} functions of \code{dplyr}, characters vectors are supported and 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
 #' @examples
+#' left_join_microorganisms("STAAUR")
+#'
+#' library(dplyr)
+#' septic_patients %>% left_join_microorganisms()
+#'
 #' df <- data.frame(date = seq(from = as.Date("2018-01-01"),
 #'                             to = as.Date("2018-01-07"),
 #'                             by = 1),
 #'                  bacteria_id = c("STAAUR", "STAAUR", "STAAUR", "STAAUR",
 #'                                  "ESCCOL", "ESCCOL", "ESCCOL"),
 #'                  stringsAsFactors = FALSE)
-#'                  
 #' colnames(df)
-#' df2 <- left_join_bactlist(df, "bacteria_id")
+#' df2 <- left_join_microorganisms(df, "bacteria_id")
 #' colnames(df2)
-inner_join_bactlist <- function(x, by = 'bactid', ...) {
+inner_join_microorganisms <- function(x, by = 'bactid', suffix = c("2", ""), ...) {
+  if (any(class(x) %in% c('character', 'factor'))) {
+    x <- data.frame(bactid = x, stringsAsFactors = FALSE)
+  }
   # no name set to `by` parameter
   if (is.null(names(by))) {
-    joinby <- colnames(AMR::bactlist)[1]
+    joinby <- colnames(AMR::microorganisms)[1]
     names(joinby) <- by
   } else {
     joinby <- by
   }
-  join <- dplyr::inner_join(x = x, y = AMR::bactlist, by = joinby, suffix = c("2", ""), ...)
+  join <- dplyr::inner_join(x = x, y = AMR::microorganisms, 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')
   }
@@ -37,15 +45,18 @@ inner_join_bactlist <- function(x, by = 'bactid', ...) {
 
 #' @rdname join
 #' @export
-left_join_bactlist <- function(x, by = 'bactid', ...) {
+left_join_microorganisms <- function(x, by = 'bactid', suffix = c("2", ""), ...) {
+  if (any(class(x) %in% c('character', 'factor'))) {
+    x <- data.frame(bactid = x, stringsAsFactors = FALSE)
+  }
   # no name set to `by` parameter
   if (is.null(names(by))) {
-    joinby <- colnames(AMR::bactlist)[1]
+    joinby <- colnames(AMR::microorganisms)[1]
     names(joinby) <- by
   } else {
     joinby <- by
   }
-  join <- dplyr::left_join(x = x, y = AMR::bactlist, by = joinby, suffix = c("2", ""), ...)
+  join <- dplyr::left_join(x = x, y = AMR::microorganisms, 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')
   }
@@ -54,15 +65,18 @@ left_join_bactlist <- function(x, by = 'bactid', ...) {
 
 #' @rdname join
 #' @export
-right_join_bactlist <- function(x, by = 'bactid', ...) {
+right_join_microorganisms <- function(x, by = 'bactid', suffix = c("2", ""), ...) {
+  if (any(class(x) %in% c('character', 'factor'))) {
+    x <- data.frame(bactid = x, stringsAsFactors = FALSE)
+  }
   # no name set to `by` parameter
   if (is.null(names(by))) {
-    joinby <- colnames(AMR::bactlist)[1]
+    joinby <- colnames(AMR::microorganisms)[1]
     names(joinby) <- by
   } else {
     joinby <- by
   }
-  join <- dplyr::right_join(x = x, y = AMR::bactlist, by = joinby, suffix = c("2", ""), ...)
+  join <- dplyr::right_join(x = x, y = AMR::microorganisms, 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')
   }
@@ -71,39 +85,52 @@ right_join_bactlist <- function(x, by = 'bactid', ...) {
 
 #' @rdname join
 #' @export
-full_join_bactlist <- function(x, by = 'bactid', ...) {
+full_join_microorganisms <- function(x, by = 'bactid', suffix = c("2", ""), ...) {
+  if (any(class(x) %in% c('character', 'factor'))) {
+    x <- data.frame(bactid = x, stringsAsFactors = FALSE)
+  }
   # no name set to `by` parameter
   if (is.null(names(by))) {
-    joinby <- colnames(AMR::bactlist)[1]
+    joinby <- colnames(AMR::microorganisms)[1]
     names(joinby) <- by
   } else {
     joinby <- by
   }
-  dplyr::full_join(x = x, y = AMR::bactlist, by = joinby, suffix = c("2", ""), ...)
+  join <- dplyr::full_join(x = x, y = AMR::microorganisms, 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
-semi_join_bactlist <- function(x, by = 'bactid', ...) {
+semi_join_microorganisms <- function(x, by = 'bactid', ...) {
+  if (any(class(x) %in% c('character', 'factor'))) {
+    x <- data.frame(bactid = x, stringsAsFactors = FALSE)
+  }
   # no name set to `by` parameter
   if (is.null(names(by))) {
-    joinby <- colnames(AMR::bactlist)[1]
+    joinby <- colnames(AMR::microorganisms)[1]
     names(joinby) <- by
   } else {
     joinby <- by
   }
-  dplyr::semi_join(x = x, y = AMR::bactlist, by = joinby, ...)
+  dplyr::semi_join(x = x, y = AMR::microorganisms, by = joinby, ...)
 }
 
 #' @rdname join
 #' @export
-anti_join_bactlist <- function(x, by = 'bactid', ...) {
+anti_join_microorganisms <- function(x, by = 'bactid', ...) {
+  if (any(class(x) %in% c('character', 'factor'))) {
+    x <- data.frame(bactid = x, stringsAsFactors = FALSE)
+  }
   # no name set to `by` parameter
   if (is.null(names(by))) {
-    joinby <- colnames(AMR::bactlist)[1]
+    joinby <- colnames(AMR::microorganisms)[1]
     names(joinby) <- by
   } else {
     joinby <- by
   }
-  dplyr::anti_join(x = x, y = AMR::bactlist, by = joinby, ...)
+  dplyr::anti_join(x = x, y = AMR::microorganisms, by = joinby, ...)
 }

R/mdro.R

@@ -0,0 +1,422 @@
+# ==================================================================== #
+# 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 multidrug-resistant organisms (MDRO)
+#'
+#' Determine which isolates are multidrug-resistant organisms (MDRO) according to country-specific guidelines.
+#' @param tbl table with antibiotic columns, like e.g. \code{amox} and \code{amcl}
+#' @param country country code to determine guidelines. EUCAST rules will be used when left empty, see Details. Should be or a code from the \href{https://en.wikipedia.org/wiki/ISO_3166-1_alpha-2#Officially_assigned_code_elements}{list of ISO 3166-1 alpha-2 country codes}. Case-insensitive. Currently supported are \code{de} (Germany) and \code{nl} (the Netherlands).
+#' @param col_bactid column name of the bacteria ID in \code{tbl} - values of this column should be present in \code{microorganisms$bactid}, see \code{\link{microorganisms}}
+#' @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,metr,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. column names of antibiotics
+#' @param ... parameters that are passed on to methods
+#' @details When \code{country} will be left blank, guidelines will be taken from EUCAST Expert Rules Version 3.1 "Intrinsic Resistance and Exceptional Phenotypes Tables" (\url{http://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/Expert_rules_intrinsic_exceptional_V3.1.pdf}).
+#' @return Ordered factor with levels \code{Unknown < Negative < Unconfirmed < Positive}.
+#' @rdname MDRO
+#' @export
+#' @examples
+#' library(dplyr)
+#'
+#' septic_patients %>%
+#'   mutate(EUCAST = MDRO(.),
+#'          BRMO = MDRO(., "nl"))
+MDRO <- function(tbl,
+                 country = NULL,
+                 col_bactid = 'bactid',
+                 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',
+                 metr = 'metr',
+                 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_bactid %in% colnames(tbl)) {
+    stop('Column ', col_bactid, ' not found.', call. = FALSE)
+  }
+
+  # strip whitespaces
+  if (length(country) > 1) {
+    stop('`country` must be a length one character string.', call. = FALSE)
+  }
+
+  if (is.null(country)) {
+    country <- 'EUCAST'
+  }
+  country <- trimws(country)
+  if (country != 'EUCAST' & !country %like% '^[a-z]{2}$') {
+    stop('This is not a valid ISO 3166-1 alpha-2 country code: "', country, '". Please see ?MDRO.', call. = FALSE)
+  }
+
+  # create list and make country code case-independent
+  guideline <- list(country = list(code = tolower(country)))
+
+  if (guideline$country$code == 'eucast') {
+    guideline$country$name <- '(European guidelines)'
+    guideline$name <- 'EUCAST Expert Rules, "Intrinsic Resistance and Exceptional Phenotypes Tables"'
+    guideline$version <- 'Version 3.1'
+    guideline$source <- 'http://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/Expert_rules_intrinsic_exceptional_V3.1.pdf'
+    # support per country:
+  } else if (guideline$country$code == 'de') {
+    guideline$country$name <- 'Germany'
+    guideline$name <- ''
+    guideline$version <- ''
+    guideline$source <- ''
+  } else if (guideline$country$code == 'nl') {
+    guideline$country$name <- 'The Netherlands'
+    guideline$name <- 'WIP-Richtlijn BRMO'
+    guideline$version <- 'Revision of December 2017'
+    guideline$source <- 'https://www.rivm.nl/Documenten_en_publicaties/Professioneel_Praktisch/Richtlijnen/Infectieziekten/WIP_Richtlijnen/WIP_Richtlijnen/Ziekenhuizen/WIP_richtlijn_BRMO_Bijzonder_Resistente_Micro_Organismen_ZKH'
+  # add here more countries like this:
+  # } else if (country$code == 'AA') {
+  #   country$name <- 'country name'
+  } else {
+    stop('This country code is currently unsupported: ', guideline$country$code, call. = FALSE)
+  }
+
+  # Console colours
+  # source: http://www.tldp.org/HOWTO/Bash-Prompt-HOWTO/x329.html
+  ANSI_red <- "\033[31m"
+  ANSI_blue <- "\033[34m"
+  ANSI_reset <- "\033[0m"
+
+  if (info == TRUE) {
+    cat("Determining multidrug-resistant organisms (MDRO), according to:\n",
+        "Guideline: ", ANSI_red, guideline$name, ", ", guideline$version, ANSI_reset, "\n",
+        "Country  : ", ANSI_red, guideline$country$name, ANSI_reset, "\n",
+        "Source   : ", ANSI_blue, guideline$source, ANSI_reset, "\n",
+        "\n", sep = "")
+  }
+
+  # check columns
+  col.list <- c(amcl, amik, amox, ampi, azit, aztr, cefa, cfra, cfep, cfot,
+                cfox, cfta, cftr, cfur, chlo, cipr, clar, clin, clox, coli,
+                czol, dapt, doxy, erta, eryt, fosf, fusi, gent, imip, kana,
+                levo, linc, line, mero, metr, 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 <- check_available_columns(tbl = tbl, col.list = col.list, info = info)
+  amcl <- col.list[amcl]
+  amik <- col.list[amik]
+  amox <- col.list[amox]
+  ampi <- col.list[ampi]
+  azit <- col.list[azit]
+  aztr <- col.list[aztr]
+  cefa <- col.list[cefa]
+  cfra <- col.list[cfra]
+  cfep <- col.list[cfep]
+  cfot <- col.list[cfot]
+  cfox <- col.list[cfox]
+  cfta <- col.list[cfta]
+  cftr <- col.list[cftr]
+  cfur <- col.list[cfur]
+  chlo <- col.list[chlo]
+  cipr <- col.list[cipr]
+  clar <- col.list[clar]
+  clin <- col.list[clin]
+  clox <- col.list[clox]
+  coli <- col.list[coli]
+  czol <- col.list[czol]
+  dapt <- col.list[dapt]
+  doxy <- col.list[doxy]
+  erta <- col.list[erta]
+  eryt <- col.list[eryt]
+  fosf <- col.list[fosf]
+  fusi <- col.list[fusi]
+  gent <- col.list[gent]
+  imip <- col.list[imip]
+  kana <- col.list[kana]
+  levo <- col.list[levo]
+  linc <- col.list[linc]
+  line <- col.list[line]
+  mero <- col.list[mero]
+  metr <- col.list[metr]
+  mino <- col.list[mino]
+  moxi <- col.list[moxi]
+  nali <- col.list[nali]
+  neom <- col.list[neom]
+  neti <- col.list[neti]
+  nitr <- col.list[nitr]
+  novo <- col.list[novo]
+  norf <- col.list[norf]
+  oflo <- col.list[oflo]
+  peni <- col.list[peni]
+  pita <- col.list[pita]
+  poly <- col.list[poly]
+  qida <- col.list[qida]
+  rifa <- col.list[rifa]
+  roxi <- col.list[roxi]
+  siso <- col.list[siso]
+  teic <- col.list[teic]
+  tetr <- col.list[tetr]
+  tica <- col.list[tica]
+  tige <- col.list[tige]
+  tobr <- col.list[tobr]
+  trim <- col.list[trim]
+  trsu <- col.list[trsu]
+  vanc <- col.list[vanc]
+
+  # antibiotic classes
+  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 clin(damycin) is set apart
+  glycopeptides <- c(vanc, teic)
+  streptogramins <- qida # should officially also be pristinamycin and quinupristin/dalfopristin
+  cephalosporins <- c(cfep, cfot, cfox, cfra, cfta, cftr, cfur, czol)
+  cephalosporins_3rd <- c(cfot, cftr, cfta)
+  carbapenems <- c(erta, imip, mero)
+  aminopenicillins <- c(ampi, amox)
+  ureidopenicillins <- pita # should officially also be azlo and mezlo
+  fluoroquinolones <- c(oflo, cipr, norf, levo, moxi)
+
+  # helper function for editing the table
+  trans_tbl <- function(to, rows, cols) {
+    cols <- cols[!is.na(cols)]
+    if (length(rows) > 0 & length(cols) > 0) {
+      col_filter <- which(tbl[, cols] == 'R')
+      rows <- rows[rows %in% col_filter]
+      tbl[rows, 'MDRO'] <<- to
+    }
+  }
+
+  # join microorganisms
+  tbl <- tbl %>% left_join_microorganisms(col_bactid)
+
+  tbl$MDRO <- NA_integer_
+
+  if (guideline$country$code == 'eucast') {
+    # EUCAST ------------------------------------------------------------------
+    # Table 5
+    trans_tbl(4,
+              which(tbl$family == 'Enterobacteriaceae'
+                    | tbl$fullname %like% '^Pseudomonas aeruginosa'
+                    | tbl$genus == 'Acinetobacter'),
+              coli)
+    trans_tbl(4,
+              which(tbl$fullname %like% '^Salmonella Typhi'),
+              c(carbapenems, fluoroquinolones))
+    trans_tbl(4,
+              which(tbl$fullname %like% '^Haemophilus influenzae'),
+              c(cephalosporins_3rd, carbapenems, fluoroquinolones))
+    trans_tbl(4,
+              which(tbl$fullname %like% '^Moraxella catarrhalis'),
+              c(cephalosporins_3rd, fluoroquinolones))
+    trans_tbl(4,
+              which(tbl$fullname %like% '^Neisseria meningitidis'),
+              c(cephalosporins_3rd, fluoroquinolones))
+    trans_tbl(4,
+              which(tbl$fullname %like% '^Neisseria gonorrhoeae'),
+              azit)
+    # Table 6
+    trans_tbl(4,
+              which(tbl$fullname %like% '^Staphylococcus (aureus|epidermidis|coagulase negatief|hominis|haemolyticus|intermedius|pseudointermedius)'),
+              c(vanc, teic, dapt, line, qida, tige))
+    trans_tbl(4,
+              which(tbl$genus == 'Corynebacterium'),
+              c(vanc, teic, dapt, line, qida, tige))
+    trans_tbl(4,
+              which(tbl$fullname %like% '^Streptococcus pneumoniae'),
+              c(carbapenems, vanc, teic, dapt, line, qida, tige, rifa))
+    trans_tbl(4, # Sr. groups A/B/C/G
+              which(tbl$fullname %like% '^Streptococcus (pyogenes|agalactiae|equisimilis|equi|zooepidemicus|dysgalactiae|anginosus)'),
+              c(peni, cephalosporins, vanc, teic, dapt, line, qida, tige))
+    trans_tbl(4,
+              which(tbl$genus == 'Enterococcus'),
+              c(dapt, line, tige, teic))
+    trans_tbl(4,
+              which(tbl$fullname %like% '^Enterococcus faecalis'),
+              c(ampi, amox))
+    # Table 7
+    trans_tbl(4,
+              which(tbl$genus == 'Bacteroides'),
+              metr)
+    trans_tbl(4,
+              which(tbl$fullname %like% '^Clostridium difficile'),
+              c(metr, vanc))
+  }
+
+  if (guideline$country$code == 'de') {
+    # Germany -----------------------------------------------------------------
+    stop("We are still working on German guidelines in this beta version.", call. = FALSE)
+  }
+
+  if (guideline$country$code == 'nl') {
+    # Netherlands -------------------------------------------------------------
+    aminoglycosides <- aminoglycosides[!is.na(aminoglycosides)]
+    fluoroquinolones <- fluoroquinolones[!is.na(fluoroquinolones)]
+    carbapenems <- carbapenems[!is.na(carbapenems)]
+
+    # Table 1
+    tbl[which(
+      tbl$family == 'Enterobacteriaceae'
+      & rowSums(tbl[, aminoglycosides] == 'R', na.rm = TRUE) >= 1
+      & rowSums(tbl[, fluoroquinolones] == 'R', na.rm = TRUE) >= 1
+    ), 'MDRO'] <- 4
+    tbl[which(
+      tbl$family == 'Enterobacteriaceae'
+      & rowSums(tbl[, carbapenems] == 'R', na.rm = TRUE) >= 1
+    ), 'MDRO'] <- 3
+    # rest is negative
+    tbl[which(
+      tbl$family == 'Enterobacteriaceae'
+      & tbl$MDRO == 1
+    ), 'MDRO'] <- 2
+
+    # Table 2
+    tbl[which(
+      tbl$genus == 'Acinetobacter'
+      & rowSums(tbl[, carbapenems] == 'R', na.rm = TRUE) >= 1
+    ), 'MDRO'] <- 3
+    tbl[which(
+      tbl$genus == 'Acinetobacter'
+      & rowSums(tbl[, aminoglycosides] == 'R', na.rm = TRUE) >= 1
+      & rowSums(tbl[, fluoroquinolones] == 'R', na.rm = TRUE) >= 1
+    ), 'MDRO'] <- 4
+    # rest of Acinetobacter is negative
+    tbl[which(
+      tbl$genus == 'Acinetobacter'
+      & tbl$MDRO == 1
+    ), 'MDRO'] <- 2
+
+    tbl[which(
+      tbl$fullname %like% 'Stenotrophomonas maltophilia'
+      & tbl[, trsu] == 'R'
+    ), 'MDRO'] <- 4
+    # rest of Stenotrophomonas is negative
+    tbl[which(
+      tbl$fullname %like% 'Stenotrophomonas maltophilia'
+      & tbl$MDRO == 1
+    ), 'MDRO'] <- 2
+
+    tbl[which(
+      tbl$fullname %like% 'Pseudomonas aeruginosa'
+      & sum(rowSums(tbl[, carbapenems] == 'R', na.rm = TRUE) >= 1,
+           rowSums(tbl[, aminoglycosides] == 'R', na.rm = TRUE) >= 1,
+           rowSums(tbl[, fluoroquinolones] == 'R', na.rm = TRUE) >= 1,
+           tbl[, cfta] == 'R',
+           tbl[, pita] == 'R') >= 3
+    ), 'MDRO'] <- 4
+    # rest of Pseudomonas is negative
+    tbl[which(
+      tbl$fullname %like% 'Pseudomonas aeruginosa'
+      & tbl$MDRO == 1
+    ), 'MDRO'] <- 2
+
+    # Table 3
+    tbl[which(
+      tbl$fullname %like% 'Streptococcus pneumoniae'
+      & tbl[, peni] == 'R'
+    ), 'MDRO'] <- 4
+    tbl[which(
+      tbl$fullname %like% 'Streptococcus pneumoniae'
+      & tbl[, vanc] == 'R'
+    ), 'MDRO'] <- 4
+    # rest of Streptococcus pneumoniae is negative
+    tbl[which(
+      tbl$fullname %like% 'Streptococcus pneumoniae'
+      & tbl$MDRO == 1
+    ), 'MDRO'] <- 2
+
+    tbl[which(
+      tbl$fullname %like% 'Enterococcus faecium'
+      &  rowSums(tbl[, c(peni, vanc)] == 'R', na.rm = TRUE) >= 1
+    ), 'MDRO'] <- 4
+    # rest of Enterococcus faecium is negative
+    tbl[which(
+      tbl$fullname %like% 'Enterococcus faecium'
+      & tbl$MDRO == 1
+    ), 'MDRO'] <- 2
+  }
+
+  factor(x =  tbl$MDRO,
+         levels = c(1:4),
+         labels = c('Unknown', 'Negative', 'Unconfirmed', 'Positive'),
+         ordered = TRUE)
+}
+
+#' @rdname MDRO
+#' @export
+BRMO <- function(tbl, country = "nl", ...) {
+  MDRO(tbl = tbl, country = "nl", ...)
+}
+
+#' @rdname MDRO
+#' @export
+MRGN <- function(tbl, country = "de", ...) {
+  MDRO(tbl = tbl, country = "de", ...)
+}
+
+#' @rdname MDRO
+#' @export
+EUCAST_exceptional_phenotypes <- function(tbl, country = "EUCAST", ...) {
+  MDRO(tbl = tbl, country = "EUCAST", ...)
+}

R/misc.R

@@ -16,34 +16,101 @@
 # GNU General Public License for more details.                         #
 # ==================================================================== #
 
+#' Pattern Matching
+#'
+#' Convenience function to compare a vector with a pattern, like \code{\link[base]{grep}}. It always returns a \code{logical} vector and is always case-insensitive.
+#' @inheritParams base::grep
+#' @return A \code{logical} vector
+#' @name like
+#' @rdname like
+#' @export
+#' @source Inherited from the \href{https://github.com/Rdatatable/data.table/blob/master/R/like.R}{\code{like} function from the \code{data.table} package}, but made it case insensitive at default.
+#' @examples
+#' library(dplyr)
+#' # get unique occurences of bacteria whose name start with 'Ent'
+#' septic_patients %>%
+#'   left_join_microorganisms() %>%
+#'   filter(fullname %like% '^Ent') %>%
+#'   pull(fullname) %>%
+#'   unique()
+"%like%" <- function(x, pattern) {
+  if (length(pattern) > 1) {
+    pattern <- pattern[1]
+    warning('only the first element of argument `pattern` used for `%like%`', call. = FALSE)
+  }
+  if (is.factor(x)) {
+    as.integer(x) %in% base::grep(pattern, levels(x), ignore.case = TRUE)
+  } else {
+    base::grepl(pattern, x, ignore.case = TRUE)
+  }
+}
+
 # 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, force_zero = FALSE, ...) {
+  val <- base::round(x * 100, digits = round)
+  if (force_zero == TRUE & any(val == as.integer(val) & !is.na(val))) {
+    val[val == as.integer(val)] <- paste0(val[val == as.integer(val)], ".", strrep(0, round))
   }
+  pct <- base::paste0(val, "%")
+  pct[pct == "NA%"] <- NA_character_
+  pct
 }
 
-percent <- function(x, round = 1, ...) {
-  base::paste0(base::round(x * 100, digits = round), "%")
+check_available_columns <- function(tbl, col.list, info = TRUE) {
+  # check columns
+  col.list <- col.list[!is.na(col.list)]
+  names(col.list) <- col.list
+  col.list.bak <- col.list
+  # are they available as upper case or lower case then?
+  for (i in 1:length(col.list)) {
+    if (toupper(col.list[i]) %in% colnames(tbl)) {
+      col.list[i] <- toupper(col.list[i])
+    } else if (tolower(col.list[i]) %in% colnames(tbl)) {
+      col.list[i] <- tolower(col.list[i])
+    } else if (!col.list[i] %in% colnames(tbl)) {
+      col.list[i] <- NA
+    }
+  }
+  if (!all(col.list %in% colnames(tbl))) {
+    if (info == TRUE) {
+      warning('These columns do not exist and will be ignored: ',
+              col.list.bak[!(col.list %in% colnames(tbl))] %>% toString(),
+              '.\nTHIS MAY STRONGLY INFLUENCE THE OUTCOME.',
+              immediate. = TRUE,
+              call. = FALSE)
+    }
+  }
+  col.list
 }
 
-quasiquotate <- function(deparsed, parsed) {
-  # when text: remove first and last "
-  if (any(deparsed %like% '^".+"$' | deparsed %like% "^'.+'$")) {
-    deparsed <- deparsed %>% substr(2, nchar(.) - 1)
-  }
-  # apply if needed
-  if (any(!deparsed %like% '[[$:()]'
-      & !deparsed %in% c('""', "''", "", # empty text
-                         ".", ".data", # dplyr references
-                         "TRUE", "FALSE", # logicals
-                         "NA", "NaN", "NULL", # empty values
-                         ls(.GlobalEnv)))) {
-    deparsed
-  } else {
-    parsed
-  }
+# Coefficient of variation (CV)
+cv <- function(x, na.rm = TRUE) {
+  cv.x <- sd(x, na.rm = na.rm) / abs(mean(x, na.rm = na.rm))
+  cv.x
+}
+
+# Coefficient of dispersion, or coefficient of quartile variation (CQV).
+# (Bonett et al., 2006: Confidence interval for a coefficient of quartile variation).
+cqv <- function(x, na.rm = TRUE) {
+  cqv.x <-
+    (quantile(x, 0.75, na.rm = na.rm, type = 6) - quantile(x, 0.25, na.rm = na.rm, type = 6)) /
+    (quantile(x, 0.75, na.rm = na.rm, type = 6) + quantile(x, 0.25, na.rm = na.rm, type = 6))
+  unname(cqv.x)
+}
+
+# show bytes as kB/MB/GB
+# size_humanreadable(123456) # 121 kB
+# size_humanreadable(12345678) # 11.8 MB
+size_humanreadable <- function(bytes, decimals = 1) {
+  bytes <- bytes %>% as.double()
+  # Adapted from:
+  # http://jeffreysambells.com/2012/10/25/human-readable-filesize-php
+  size <- c('B','kB','MB','GB','TB','PB','EB','ZB','YB')
+  factor <- floor((nchar(bytes) - 1) / 3)
+  # added slight improvement; no decimals for B and kB:
+  decimals <- rep(decimals, length(bytes))
+  decimals[size[factor + 1] %in% c('B', 'kB')] <- 0
+
+  out <- paste(sprintf(paste0("%.", decimals, "f"), bytes / (1024 ^ factor)), size[factor + 1])
+  out
 }

R/print.R

@@ -0,0 +1,347 @@
+# ==================================================================== #
+# 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.                         #
+# ==================================================================== #
+
+#' Printing Data Tables and Tibbles
+#'
+#' Print a data table or tibble. It prints: \cr- The \strong{first and last rows} like \code{data.table}s are printed by the \code{data.table} package,\cr- A \strong{header} and \strong{left aligned text} like \code{tibble}s are printed by the \code{tibble} package with info about grouped variables,\cr- \strong{Unchanged values} and \strong{support for row names} like \code{data.frame}s are printed by the \code{base} package.
+#' @inheritParams base::print.data.frame
+#' @param nmax amount of rows to print in total. When the total amount of rows exceeds this limit, the first and last \code{nmax / 2} rows will be printed. Use \code{nmax = NA} to print all rows.
+#' @param header print header with information about data size and tibble grouping
+#' @param print.keys print keys for \code{data.table}
+#' @param na value to print instead of NA
+#' @param width amount of white spaces to keep between columns, must be at least 1
+#' @rdname print
+#' @name print
+#' @importFrom dplyr %>% n_groups group_vars group_size filter pull select
+#' @importFrom data.table data.table
+#' @importFrom utils object.size
+#' @exportMethod print.tbl_df
+#' @export
+#' @examples
+#' # more reliable data view:
+#' library(dplyr)
+#' starwars
+#' print(starwars, width = 3)
+#'
+#' # This is how the tibble package prints since v1.4.0:
+#' # (mind the quite unfamiliar underscores and ending dots)
+#' tibble(now_what = c(1.2345, 2345.67, 321.456)) %>% tibble:::print.tbl_df()
+#'
+#' # This is how this AMR package prints:
+#' # (every number shown as you would expect)
+#' tibble(now_what = c(1.2345, 2345.67, 321.456))
+#'
+#' # also supports info about groups (look at header)
+#' starwars %>% group_by(homeworld, gender)
+print.tbl_df <- function(x,
+                         nmax = 10,
+                         header = TRUE,
+                         row.names = TRUE,
+                         right = FALSE,
+                         width = 1,
+                         na = "<NA>",
+                         ...) {
+  prettyprint_df(x = x,
+                 nmax = nmax,
+                 header = header,
+                 row.names = row.names,
+                 print.keys = FALSE,
+                 right = right,
+                 width = width,
+                 na = na,
+                 ...)
+}
+
+#' @rdname print
+#' @exportMethod print.tbl
+#' @export
+print.tbl <- function(x, ...) {
+  prettyprint_df(x, ...)
+}
+
+#' @rdname print
+#' @exportMethod print.data.table
+#' @export
+print.data.table <- function(x,
+                             print.keys = FALSE,
+                             ...) {
+  prettyprint_df(x = x,
+                 print.keys = print.keys,
+                 ...)
+}
+
+printDT <- data.table:::print.data.table
+prettyprint_df <- function(x,
+                           nmax = 10,
+                           header = TRUE,
+                           row.names = TRUE,
+                           print.keys = FALSE,
+                           right = FALSE,
+                           width = 1,
+                           na = "<NA>",
+                           ...) {
+
+  ansi_reset <- "\u001B[0m"
+  ansi_black <- "\u001B[30m"
+  ansi_red <- "\u001B[31m"
+  ansi_green <- "\u001B[32m"
+  ansi_yellow <- "\u001B[33m"
+  ansi_blue <- "\u001B[34m"
+  ansi_purple <- "\u001B[35m"
+  ansi_cyan <- "\u001B[36m"
+  ansi_white <- "\u001B[37m"
+  ansi_gray <- "\u001B[38;5;246m"
+
+  if (width < 1) {
+    stop('`width` must be at least 1.', call. = FALSE)
+  }
+
+  if (is.na(nmax)) {
+    nmax <- NROW(x)
+  }
+  n <- nmax
+  if (n %% 2 == 1) {
+    # odd number; add 1
+    n <- n + 1
+  }
+
+  width <- width - 1
+
+  if ('tbl_df' %in% class(x)) {
+    type <- 'tibble'
+  } else if ('data.table' %in% class(x)) {
+    type <- 'data.table'
+  } else {
+    type <- 'data.frame'
+  }
+
+  if (header == TRUE) {
+    if (NCOL(x) == 1) {
+      vars <- 'variable'
+    } else {
+      vars <- 'variables'
+    }
+
+    size <- object.size(x) %>% as.double() %>% size_humanreadable()
+
+    cat(paste0("A ", type,": ",
+               format(NROW(x)),
+               " obs. of ",
+               format(NCOL(x)),
+               " ", vars,
+               ansi_gray, " (", size, ")\n", ansi_reset))
+    if ('grouped_df' %in% class(x) & n_groups(x) > 0) {
+      cat(paste0("Grouped by ",
+                 x %>% group_vars() %>% paste0(ansi_red, ., ansi_reset) %>% paste0(collapse = " and "),
+                 ansi_gray,
+                 " (",
+                 x %>% n_groups(),
+                 " groups with sizes between ",
+                 x %>% group_size() %>% min(),
+                 " and ",
+                 x %>% group_size() %>% max(),
+                 ")\n",
+                 ansi_reset))
+    }
+    if (!is.null(attributes(x)$qry)) {
+      cat(paste0(ansi_gray, "This data contains a query. Use qry() to view it.\n", ansi_reset))
+    }
+    cat("\n")
+  }
+
+  # data.table where keys should be printed
+  if (print.keys == TRUE) {
+    printDT(x,
+            class = header,
+            row.names = row.names,
+            print.keys = TRUE,
+            right = right,
+            ...
+    )
+    return(invisible())
+  }
+
+  # tibbles give warning when setting column names
+  x <- x %>% base::as.data.frame(stringsAsFactors = FALSE)
+
+  # extra space of 3 chars, right to row name or number
+  if (NROW(x) > 0) {
+    maxrowchars <- rownames(x) %>% nchar() %>% max() + 3
+    rownames(x) <- paste0(rownames(x), strrep(" ", maxrowchars - nchar(rownames(x))))
+  } else {
+    maxrowchars <- 0
+  }
+
+  x.bak <- x
+
+  if (n + 1 < nrow(x)) {
+    # remove in between part, 1 extra for ~~~~ between first and last part
+    rows_list <- c(1:(n / 2 + 1), (nrow(x) - (n / 2) + 1):nrow(x))
+    x <- as.data.frame(x.bak[rows_list,])
+    colnames(x) <- colnames(x.bak)
+    rownames(x) <- rownames(x.bak)[rows_list]
+    # set inbetweener between parts
+    rownames(x)[n / 2 + 1] <- strrep("~", maxrowchars)
+  }
+
+  if (header == TRUE) {
+    # add 1 row for classes
+    # class will be marked up per column
+    if (NROW(x.bak) > 0) {
+      rownames.x <- rownames(x)
+      x <- x %>% filter(row_number() == 1) %>% rbind(x, stringsAsFactors = FALSE)
+      rownames(x) <- c('*', rownames.x)
+    }
+
+    # select 1st class per column and abbreviate
+    classes <- x.bak %>%
+      sapply(class) %>%
+      lapply(
+        function(c) {
+          # do print all POSIX classes like "POSct/t"
+          if ('POSIXct' %in% c) {
+            paste0('POS',
+                   c %>%
+                     gsub('POSIX', '', .) %>%
+                     paste0(collapse = '/'))
+          } else {
+            if (NCOL(.) > 1) {
+              .[1,]
+            } else {
+              c[[1]]
+            }
+          }
+        }) %>%
+      unlist() %>%
+      gsub("character",  "chr", ., fixed = TRUE) %>%
+      gsub("complex",    "cplx", ., fixed = TRUE) %>%
+      gsub("Date",       "Date", ., fixed = TRUE) %>%
+      gsub("double",     "dbl", ., fixed = TRUE) %>%
+      gsub("expression", "expr", ., fixed = TRUE) %>%
+      gsub("factor",     "fct", ., fixed = TRUE) %>%
+      gsub("IDate",      "IDat", ., fixed = TRUE) %>%
+      gsub("integer",    "int", ., fixed = TRUE) %>%
+      gsub("integer64",  "i64", ., fixed = TRUE) %>%
+      gsub("list",       "list", ., fixed = TRUE) %>%
+      gsub("logical",    "lgl", ., fixed = TRUE) %>%
+      gsub("numeric",    "dbl", ., fixed = TRUE) %>%
+      gsub("ordered",    "ord", ., fixed = TRUE) %>%
+      gsub("percent",    "pct", ., fixed = TRUE) %>%
+      gsub("single",     "sgl", ., fixed = TRUE) %>%
+      paste0("<", ., ">")
+  }
+
+  # markup cols
+  for (i in 1:ncol(x)) {
+    if (all(!class(x[, i]) %in% class(x.bak[, i]))) {
+      class(x[, i]) <- class(x.bak[, i])
+    }
+    try(x[, i] <- format(x %>% pull(i)), silent = TRUE)
+
+    # replace NAs
+    if (nchar(na) < 2) {
+      # make as long as the text "NA"
+      na <- paste0(na, strrep(" ", 2 - nchar(na)))
+    }
+    try(x[, i] <- gsub("^NA$", na, trimws(x[, i], 'both')), silent = TRUE)
+    # place class into 1st row
+    if (header == TRUE) {
+      x[1, i] <- classes[i]
+    }
+    # dashes between two parts when exceeding nmax
+    maxvalchars <- max(colnames(x)[i] %>% nchar(), x[, i] %>% nchar() %>% max())
+    if (n + 1 < nrow(x.bak)) {
+      x[n / 2 + if_else(header == TRUE, 2, 1), i] <- strrep("~", maxvalchars)
+    }
+
+    # align according to `right` parameter, but only factors, logicals text, but not MICs
+    if (any(x.bak %>% pull(i) %>% class() %in% c('factor', 'character', 'logical'))
+        & !("mic" %in% (x.bak %>% pull(i) %>% class()))) {
+      vals <- x %>% pull(i) %>% trimws('both')
+      colname <- colnames(x)[i] %>% trimws('both')
+      if (right == FALSE) {
+        vals <- paste0(vals, strrep(" ", maxvalchars - nchar(vals)))
+        colname <- paste0(colname, strrep(" ", maxvalchars - nchar(colname)))
+      } else {
+        vals <- paste0(strrep(" ", maxvalchars - nchar(vals)), vals)
+        colname <- paste0(strrep(" ", maxvalchars - nchar(colname)), colname)
+      }
+      x[, i] <- vals
+      colnames(x)[i] <- colname
+    }
+
+    # add left padding according to `width` parameter
+    # but not in 1st col when row names are off
+    if (row.names == TRUE | i > 1) {
+      x[, i] <- paste0(strrep(" ", width), x[, i])
+      colnames(x)[i] <- paste0(strrep(" ", width), colnames(x)[i])
+    }
+
+    # strip columns that do not fit (3 chars as margin)
+    width_console <- options()$width
+    width_until_col <- x %>%
+      select(1:i) %>%
+      apply(1, paste, collapse = strrep(" ", width + 1)) %>%
+      nchar() %>%
+      max()
+    width_until_col_before <- x %>%
+      select(1:(max(i, 2) - 1)) %>%
+      apply(1, paste, collapse = strrep(" ", width + 1)) %>%
+      nchar() %>%
+      max()
+    extraspace <- maxrowchars + nchar(rownames(x)[length(rownames(x))])
+    width_until_colnames <- colnames(x)[1:i] %>% paste0(collapse = strrep(" ", width + 1)) %>% nchar() + extraspace
+    width_until_colnames_before <- colnames(x)[1:(max(i, 2) - 1)] %>% paste0(collapse = strrep(" ", width + 1)) %>% nchar() + extraspace
+
+    if (i > 1 &
+        (width_until_col > width_console
+         | width_until_colnames > width_console)) {
+      if (width_until_col_before > width_console
+          | width_until_colnames_before > width_console) {
+        x <- x[, 1:(i - 2)]
+      } else {
+        x <- x[, 1:(i - 1)]
+      }
+      break
+    }
+  }
+
+  # empty table, row name of header should be "*"
+  if (NROW(x.bak) == 0) {
+    rownames(x) <- '* '
+  }
+
+  # and here it is...
+  suppressWarnings(
+    base::print.data.frame(x, row.names = row.names, ...)
+  )
+
+  # print rest of col names when they were stripped
+  if (ncol(x) < ncol(x.bak)) {
+    x.notshown <- x.bak %>% select((ncol(x) + 1):ncol(x.bak))
+    if (ncol(x.notshown) == 1) {
+      cat('...and 1 more column: ')
+    } else {
+      cat('...and', ncol(x.notshown), 'more columns: ')
+    }
+    cat(x.notshown %>%
+          colnames() %>%
+          paste0(' ', ansi_gray, classes[(ncol(x) + 1):ncol(x.bak)], ansi_reset) %>%
+          paste0(collapse = ", "), '\n')
+  }
+}

R/rsi_analysis.R

@@ -16,115 +16,230 @@
 # GNU General Public License for more details.                         #
 # ==================================================================== #
 
-#' Resistance of isolates in data.frame
+#' Resistance of isolates
 #'
-#' \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.
+#' This functions can be used to calculate the (co-)resistance of isolates (i.e. percentage S, SI, I, IR or R [of a vector] of isolates). The functions \code{rsi} and \code{n_rsi} can be used in \code{dplyr}s \code{\link[dplyr]{summarise}} and support grouped variables, see \emph{Examples}.
 #' @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 ab character vector with 1, 2 or 3 antibiotics that occur as column names in \code{tbl}, like \code{ab = c("amox", "amcl")}
+#' @param ab1,ab2 vector of antibiotic interpretations, they will be transformed internally with \code{\link{as.rsi}}
 #' @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 as_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}!
+#' \if{html}{
+#'   \cr \cr
+#'   To calculate the probability (\emph{p}) of susceptibility of one antibiotic, we use this formula:
+#'   \out{<div style="text-align: center">}\figure{mono_therapy.png}\out{</div>}
+#'   To calculate the probability (\emph{p}) of susceptibility of more antibiotics (i.e. combination therapy), we need to check whether one of them has a susceptible result (as numerator) and count all cases where all antibiotics were tested (as denominator). \cr
+#'   For two antibiotics:
+#'   \out{<div style="text-align: center">}\figure{combi_therapy_2.png}\out{</div>}
+#'   \cr
+#'   For three antibiotics:
+#'   \out{<div style="text-align: center">}\figure{combi_therapy_3.png}\out{</div>}
+#' }
 #' @keywords rsi antibiotics isolate isolates
-#' @return Double or, when \code{percent = TRUE}, a character.
+#' @return Double or, when \code{as_percent = TRUE}, a character.
+#' @rdname rsi
 #' @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:
+#'
+#' septic_patients %>%
+#'   group_by(hospital_id) %>%
+#'   summarise(cipro_susceptibility = rsi(cipr, interpretation = "S"),
+#'             n = n_rsi(cipr)) # n_rsi works like n_distinct in dplyr
+#'
+#' septic_patients %>%
+#'   group_by(hospital_id) %>%
+#'   summarise(cipro_S = rsi(cipr, interpretation = "S",
+#'                           as_percent = TRUE, warning = FALSE),
+#'             cipro_n = n_rsi(cipr),
+#'             genta_S = rsi(gent, interpretation = "S",
+#'                           as_percent = TRUE, warning = FALSE),
+#'             genta_n = n_rsi(gent),
+#'             combination_S = rsi(cipr, gent, interpretation = "S",
+#'                                 as_percent = TRUE, warning = FALSE),
+#'             combination_n = n_rsi(cipr, gent))
+#'
+#' # calculate resistance
+#' rsi(septic_patients$amox)
+#' # or susceptibility
+#' rsi(septic_patients$amox, interpretation = "S")
+#'
+#' # calculate co-resistance between amoxicillin/clav acid and gentamicin,
+#' # so we can review that combination therapy does a lot more than mono therapy:
+#' septic_patients %>% rsi_df(ab = "amcl", interpretation = "S") # = 67.8%
+#' septic_patients %>% rsi_df(ab = "gent", interpretation = "S") # = 69.1%
+#' septic_patients %>% rsi_df(ab = c("amcl", "gent"), interpretation = "S") # = 90.6%
+#'
+#' \dontrun{
+#' # calculate current empiric combination therapy of Helicobacter gastritis:
 #' my_table %>%
 #'   filter(first_isolate == TRUE,
 #'          genus == "Helicobacter") %>%
-#'   rsi_df(antibiotics = c("amox", "metr"))
+#'   rsi_df(ab = c("amox", "metr")) # amoxicillin with metronidazole
 #' }
+rsi <- function(ab1,
+                ab2 = NA,
+                interpretation = 'IR',
+                minimum = 30,
+                as_percent = FALSE,
+                info = FALSE,
+                warning = TRUE) {
+  ab1.name <- deparse(substitute(ab1))
+  if (ab1.name %like% '.[$].') {
+    ab1.name <- unlist(strsplit(ab1.name, "$", fixed = TRUE))
+    ab1.name <- ab1.name[length(ab1.name)]
+  }
+  if (!ab1.name %like% '^[a-z]{3,4}$') {
+    ab1.name <- 'rsi1'
+  }
+  if (length(ab1) == 1 & is.character(ab1)) {
+    stop('`ab1` must be a vector of antibiotic interpretations.',
+         '\n  Try rsi(', ab1, ', ...) instead of rsi("', ab1, '", ...)', call. = FALSE)
+  }
+  ab2.name <- deparse(substitute(ab2))
+  if (ab2.name %like% '.[$].') {
+    ab2.name <- unlist(strsplit(ab2.name, "$", fixed = TRUE))
+    ab2.name <- ab2.name[length(ab2.name)]
+  }
+  if (!ab2.name %like% '^[a-z]{3,4}$') {
+    ab2.name <- 'rsi2'
+  }
+  if (length(ab2) == 1 & is.character(ab2)) {
+    stop('`ab2` must be a vector of antibiotic interpretations.',
+         '\n  Try rsi(', ab2, ', ...) instead of rsi("', ab2, '", ...)', call. = FALSE)
+  }
+
+  interpretation <- paste(interpretation, collapse = "")
+
+  ab1 <- as.rsi(ab1)
+  ab2 <- as.rsi(ab2)
+
+  tbl <- tibble(rsi1 = ab1, rsi2 = ab2)
+  colnames(tbl) <- c(ab1.name, ab2.name)
+
+  if (length(ab2) == 1) {
+    r <- rsi_df(tbl = tbl,
+                ab = ab1.name,
+                interpretation = interpretation,
+                minimum = minimum,
+                as_percent = FALSE,
+                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 %in% c('S', 'IS', 'SI')) {
+      warning('`interpretation` not set to S or I/S, albeit analysing a combination therapy.', call. = FALSE)
+    }
+    r <- rsi_df(tbl = tbl,
+                ab = c(ab1.name, ab2.name),
+                interpretation = interpretation,
+                minimum = minimum,
+                as_percent = FALSE,
+                info = info,
+                warning = warning)
+  }
+  if (as_percent == TRUE) {
+    percent(r, force_zero = TRUE)
+  } else {
+    r
+  }
+}
+
+#' @export
+#' @rdname rsi
 rsi_df <- function(tbl,
-                   antibiotics,
+                   ab,
                    interpretation = 'IR',
                    minimum = 30,
-                   percent = FALSE,
+                   as_percent = FALSE,
                    info = TRUE,
                    warning = TRUE) {
 
-  # we willen niet dat tbl$interpretation toevallig ook bestaat, dus:
-  te_testen_uitslag_ab <- interpretation
+  # in case tbl$interpretation already exists:
+  interpretations_to_check <- paste(interpretation, collapse = "")
 
-  # 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)
+  # validate:
+  if (min(grepl('^[a-z]{3,4}$', ab)) == 0 &
+      min(grepl('^rsi[1-2]$', ab)) == 0) {
+    for (i in 1:length(ab)) {
+      ab[i] <- paste0('rsi', i)
     }
   }
-  if (!grepl('^(S|SI|IS|I|IR|RI|R){1}$', te_testen_uitslag_ab)) {
+  if (!grepl('^(S|SI|IS|I|IR|RI|R){1}$', interpretations_to_check)) {
     stop('Invalid `interpretation`; must be "S", "SI", "I", "IR", or "R".')
   }
   if ('is_ic' %in% colnames(tbl)) {
-    if (n_distinct(tbl$is_ic) > 1) {
+    if (n_distinct(tbl$is_ic) > 1 & warning == TRUE) {
       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]]
+  # transform when checking for different results
+  if (interpretations_to_check %in% c('SI', 'IS')) {
+    for (i in 1:length(ab)) {
+      lijst <- tbl[, ab[i]]
       if ('I' %in% lijst) {
-        tbl[which(tbl[antibiotics[i]] == 'I'), ][antibiotics[i]] <- 'S'
+        tbl[which(tbl[ab[i]] == 'I'), ][ab[i]] <- 'S'
       }
     }
-    te_testen_uitslag_ab <- 'S'
+    interpretations_to_check <- 'S'
   }
-  if (te_testen_uitslag_ab %in% c('RI', 'IR')) {
-    for (i in 1:length(antibiotics)) {
-      lijst <- tbl[, antibiotics[i]]
+  if (interpretations_to_check %in% c('RI', 'IR')) {
+    for (i in 1:length(ab)) {
+      lijst <- tbl[, ab[i]]
       if ('I' %in% lijst) {
-        tbl[which(tbl[antibiotics[i]] == 'I'), ][antibiotics[i]] <- 'R'
+        tbl[which(tbl[ab[i]] == 'I'), ][ab[i]] <- 'R'
       }
     }
-    te_testen_uitslag_ab <- 'R'
+    interpretations_to_check <- 'R'
   }
 
-  # breuk samenstellen
-  if (length(antibiotics) == 1) {
+  # get fraction
+  if (length(ab) == 1) {
     numerator <- tbl %>%
-      filter(pull(., antibiotics[1]) == te_testen_uitslag_ab) %>%
+      filter(pull(., ab[1]) == interpretations_to_check) %>%
       nrow()
 
     denominator <- tbl %>%
-      filter(pull(., antibiotics[1]) %in% c("S", "I", "R")) %>%
+      filter(pull(., ab[1]) %in% c("S", "I", "R")) %>%
       nrow()
 
-  } else if (length(antibiotics) == 2) {
+  } else if (length(ab) == 2) {
+    if (interpretations_to_check != 'S') {
+      warning('`interpretation` not set to S or I/S, albeit analysing a combination therapy.', call. = FALSE)
+    }
     numerator <- tbl %>%
-      filter_at(vars(antibiotics[1], antibiotics[2]),
-                any_vars(. == te_testen_uitslag_ab)) %>%
-      filter_at(vars(antibiotics[1], antibiotics[2]),
+      filter_at(vars(ab[1], ab[2]),
+                any_vars(. == interpretations_to_check)) %>%
+      filter_at(vars(ab[1], ab[2]),
                 all_vars(. %in% c("S", "R", "I"))) %>%
       nrow()
 
     denominator <- tbl %>%
-      filter_at(vars(antibiotics[1], antibiotics[2]),
+      filter_at(vars(ab[1], ab[2]),
                 all_vars(. %in% c("S", "R", "I"))) %>%
       nrow()
 
-  } else if (length(antibiotics) == 3) {
+  } else if (length(ab) == 3) {
+    if (interpretations_to_check != 'S') {
+      warning('`interpretation` not set to S or I/S, albeit analysing a combination therapy.', call. = FALSE)
+    }
     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]),
+      filter_at(vars(ab[1], ab[2], ab[3]),
+                any_vars(. == interpretations_to_check)) %>%
+      filter_at(vars(ab[1], ab[2], ab[3]),
                 all_vars(. %in% c("S", "R", "I"))) %>%
       nrow()
 
     denominator <- tbl %>%
-      filter_at(vars(antibiotics[1], antibiotics[2], antibiotics[3]),
+      filter_at(vars(ab[1], ab[2], ab[3]),
                 all_vars(. %in% c("S", "R", "I"))) %>%
       nrow()
 
@@ -132,7 +247,7 @@ rsi_df <- function(tbl,
     stop('Maximum of 3 drugs allowed.')
   }
 
-  # tekstdeel opbouwen
+  # build text part
   if (info == TRUE) {
     cat('n =', denominator)
     info.txt1 <- percent(denominator / nrow(tbl))
@@ -140,23 +255,23 @@ rsi_df <- function(tbl,
       info.txt1 <- 'none'
     }
     info.txt2 <- gsub(',', ' and',
-                      antibiotics %>%
-                        abname(to = 'trivial',
-                               tolower = TRUE) %>%
+                      ab %>%
+                        abname(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
+  # calculate and format
   y <- numerator / denominator
-  if (percent == TRUE) {
-    y <- percent(y)
+  if (as_percent == TRUE) {
+   y <- percent(y, force_zero = TRUE)
   }
+
   if (denominator < minimum) {
     if (warning == TRUE) {
-      warning(paste0('TOO FEW ISOLATES OF ', toString(antibiotics), ' (n = ', denominator, ', n < ', minimum, '); NO RESULT.'))
+      warning(paste0('TOO FEW ISOLATES OF ', toString(ab), ' (n = ', denominator, ', n < ', minimum, '); NO RESULT.'))
     }
     y <- NA
   }
@@ -165,73 +280,29 @@ rsi_df <- function(tbl,
   y
 }
 
-#' Resistance of isolates
-#'
-#' This function can be used in \code{dplyr}s \code{\link[dplyr]{summarise}}, see \emph{Examples}. Calculate the percentage S, SI, I, IR or R of a vector of isolates.
-#' @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(hospital) %>%
-#'   summarise(cipr = rsi(cipr))
-#'   
-#' tbl %>%
-#'   group_by(year, hospital) %>%
-#'   summarise(
-#'     isolates = n(),
-#'     cipro = rsi(cipr %>% as.rsi(), percent = TRUE),
-#'     amoxi = rsi(amox %>% as.rsi(), percent = TRUE))
-#'     
-#' rsi(as.rsi(isolates$amox))
-#'
-#' rsi(as.rsi(isolates$amcl), interpretation = "S")
-#' }
-rsi <- function(ab1, ab2 = NA, interpretation = 'IR', minimum = 30, percent = FALSE, info = FALSE, warning = FALSE) {
-  function_text <- as.character(match.call())
-  # param 1 = functienaam
-  # param 2 = ab1
-  # param 3 = ab2
-  ab1.naam <- function_text[2]
-  if (!grepl('^[a-z]{3,4}$', ab1.naam)) {
-    ab1.naam <- 'rsi1'
-  }
-  ab2.naam <- function_text[3]
-  if (!grepl('^[a-z]{3,4}$', ab2.naam)) {
-    ab2.naam <- 'rsi2'
+#' @rdname rsi
+n_rsi <- function(ab1, ab2 = NA) {
+
+  if (length(ab1) == 1 & is.character(ab1)) {
+    stop('`ab1` must be a vector of antibiotic interpretations.',
+         '\n  Try n_rsi(', ab1, ', ...) instead of n_rsi("', ab1, '", ...)', call. = FALSE)
   }
+  ab1 <- as.rsi(ab1)
 
-  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))
+  if (length(ab2) == 1 & all(is.na(ab2))) {
+    # only 1 antibiotic
+    length(ab1[!is.na(ab1)])
   } else {
-    if (length(ab1) != length(ab2)) {
-      stop('`ab1` (n = ', length(ab1), ') and `ab2` (n = ', length(ab2), ') must be of same length.', call. = FALSE)
+    if (length(ab2) == 1 & is.character(ab2)) {
+      stop('`ab2` must be a vector of antibiotic interpretations.',
+           '\n  Try n_rsi(', ab2, ', ...) instead of n_rsi("', ab2, '", ...)', 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))
+    ab2 <- as.rsi(ab2)
+    tbl <- tibble(ab1, ab2)
+    tbl %>% filter(!is.na(ab1) & !is.na(ab2)) %>% nrow()
   }
+
 }
 
 #' Predict antimicrobial resistance
@@ -270,14 +341,13 @@ rsi <- function(ab1, ab2 = NA, interpretation = 'IR', minimum = 30, percent = FA
 #' library(dplyr)
 #' septic_patients %>%
 #'   # get bacteria properties like genus and species
-#'   left_join_bactlist("bactid") %>% 
+#'   left_join_microorganisms("bactid") %>%
 #'   # calculate first isolates
 #'   mutate(first_isolate =
 #'            first_isolate(.,
 #'                          "date",
 #'                          "patient_id",
-#'                          "genus",
-#'                          "species",
+#'                          "bactid",
 #'                          col_specimen = NA,
 #'                          col_icu = NA)) %>%
 #'   # filter on first E. coli isolates
@@ -285,8 +355,8 @@ rsi <- function(ab1, ab2 = NA, interpretation = 'IR', minimum = 30, percent = FA
 #'          species == "coli",
 #'          first_isolate == TRUE) %>%
 #'   # predict resistance of cefotaxime for next years
-#'   rsi_predict(col_ab = cfot,
-#'               col_date = date,
+#'   rsi_predict(col_ab = "cfot",
+#'               col_date = "date",
 #'               year_max = 2025,
 #'               preserve_measurements = FALSE)
 #'
@@ -300,11 +370,14 @@ rsi_predict <- function(tbl,
                         preserve_measurements = TRUE,
                         info = TRUE) {
 
-  col_ab <- quasiquotate(deparse(substitute(col_ab)), col_ab)
+  if (nrow(tbl) == 0) {
+    stop('This table does not contain any observations.')
+  }
+
   if (!col_ab %in% colnames(tbl)) {
     stop('Column ', col_ab, ' not found.')
   }
-  col_date <- quasiquotate(deparse(substitute(col_date)), col_date)
+
   if (!col_date %in% colnames(tbl)) {
     stop('Column ', col_date, ' not found.')
   }

R/zzz.R

@@ -0,0 +1,3 @@
+.onLoad <- function(libname, pkgname) {
+  backports::import(pkgname)
+}

README.md

@@ -1,35 +1,54 @@
 # `AMR`
-This is an [R package](https://www.r-project.org) to simplify the analysis and prediction of Antimicrobial Resistance (AMR).
+### An [R package](https://www.r-project.org) to simplify the analysis and prediction of Antimicrobial Resistance (AMR).
 
-![logo_uni](man/figures/logo_en.png)![logo_umcg](man/figures/logo_umcg.png)
+[![logo_rug](man/figures/logo_rug.png)](https://www.rug.nl)[![logo_umcg](man/figures/logo_umcg.png)](https://www.umcg.nl)
 
-This R package was created for academic research by PhD students of the Faculty of Medical Sciences of the [University of Groningen](https://www.rug.nl/) and the Medical Microbiology & Infection Prevention department of the University Medical Center Groningen (UMCG). They also maintain this package, see [Authors](#authors).
+This R package was created for academic research by PhD students of the Faculty of Medical Sciences of the [University of Groningen)](https://www.rug.nl) and the Medical Microbiology & Infection Prevention (MMBI) department of the [University Medical Center Groningen (UMCG)](https://www.umcg.nl). See [Authors](#authors).
 
 ## Why this package?
-This R package contains functions to make microbiological, epidemiological data analysis easier. It allows the use of some new S3 classes to work with MIC values and antimicrobial interpretations (i.e. values S, I and R).
+This R package contains functions to make **microbiological, epidemiological data analysis easier**. It allows the use of some new classes to work with MIC values and antimicrobial interpretations (i.e. values S, I and R).
 
-AMR can also be predicted for the forthcoming years with the `rsi_predict` function. For use with the `dplyr` package, the `rsi` function can be used in conjunction with `summarise` to calculate the resistance percentages of different antibiotic columns of a table.
+With `AMR` you can also:
+* Create frequency tables with the `freq` function
+* Conduct AMR analysis with the `rsi` function, that can also be used with the `dplyr` package (e.g. in conjunction with `summarise`) to calculate the resistance percentages (and even co-resistance) of different antibiotic columns of a table
+* Predict antimicrobial resistance for the nextcoming years with the `rsi_predict` function
+* Apply [EUCAST rules to isolates](http://www.eucast.org/expert_rules_and_intrinsic_resistance/) with the `EUCAST_rules` function
+* Identify first isolates of every patient [using guidelines from the CLSI](https://clsi.org/standards/products/microbiology/documents/m39/) (Clinical and Laboratory Standards Institute) with the `first_isolate` function
+* Translate antibiotic codes from the lab (like `"AMOX"`) or the [WHO](https://www.whocc.no/atc_ddd_index/?code=J01CA04&showdescription=no) (like `"J01CA04"`) to trivial names (like `"amoxicillin"`) with the `abname` function
 
-It also contains functions to translate antibiotic codes from the lab (like `"AMOX"`) or the [WHO](https://www.whocc.no/atc_ddd_index/?code=J01CA04&showdescription=no) (like `"J01CA04"`) to trivial names (like `"amoxicillin"`) and vice versa.
+With the `MDRO` function (abbreviation of Multi Drug Resistant Organisms), you can check your isolates for exceptional resistance with country-specific guidelines or EUCAST rules. Currently guidelines for Germany and the Netherlands are supported. Please suggest addition of your own country here: [https://github.com/msberends/AMR/issues/new](https://github.com/msberends/AMR/issues/new?title=New%20guideline%20for%20MDRO&body=%3C--%20Please%20add%20your%20country%20code,%20guideline%20name,%20version%20and%20source%20below%20and%20remove%20this%20line--%3E).
+
+This package contains an example data set `septic_patients`, consisting of 2000 isolates from anonymised septic patients between 2001 and 2017.
 
 ## How to get it?
 This package is available on CRAN and also here on GitHub.
 
-### From CRAN (recommended, latest stable version)
+### From CRAN (recommended)
 [![CRAN_Badge](https://img.shields.io/cran/v/AMR.svg?label=CRAN&colorB=3679BC)](http://cran.r-project.org/package=AMR)
 [![CRAN_Downloads](https://cranlogs.r-pkg.org/badges/grand-total/AMR)](http://cran.r-project.org/package=AMR)
+[![CRAN_Downloads](https://cranlogs.r-pkg.org/badges/AMR)](http://cran.r-project.org/package=AMR)
   
-- RStudio:
+- <img src="http://www.rstudio.com/favicon.ico" alt="RStudio favicon" height="20px"> In [RStudio](http://www.rstudio.com) (recommended):
   - Click on `Tools` and then `Install Packages...`
-  -  Type in `AMR` and press <kbd>Install</kbd>
+  - Type in `AMR` and press <kbd>Install</kbd>
 
-- R console:
+- <img src="https://cran.r-project.org/favicon.ico" alt="R favicon" height="20px"> In R directly:
   - `install.packages("AMR")`
 
+- <img src="https://exploratory.io/favicon.ico" alt="Exploratory favicon" height="20px"> In [Exploratory.io](https://exploratory.io):
+  - (Exploratory.io costs $40/month but the somewhat limited Community Plan is free for students and teachers, [click here to enroll](https://exploratory.io/plan?plan=Community))
+  - Start the software and log in
+  - Click on your username at the right hand side top
+  - Click on `R Packages`
+  - Click on the `Install` tab
+  - Type in `AMR` and press <kbd>Install</kbd>
+  - Once it’s installed it will show up in the `User Packages` section under the `Packages` tab.
+
 ### From GitHub (latest development version)
 [![Travis_Build](https://travis-ci.org/msberends/AMR.svg?branch=master)](https://travis-ci.org/msberends/AMR)
-[![Since_Release](https://img.shields.io/github/commits-since/msberends/AMR/latest.svg?colorB=3679BC)](https://github.com/msberends/AMR/releases)
-[![Last_Commit](https://img.shields.io/github/last-commit/msberends/AMR.svg?colorB=3679BC)](https://github.com/msberends/AMR/commits/master)
+[![Since_Release](https://img.shields.io/github/commits-since/msberends/AMR/latest.svg?colorB=3679BC)](https://github.com/msberends/AMR/commits/master)
+[![Last_Commit](https://img.shields.io/github/last-commit/msberends/AMR.svg)](https://github.com/msberends/AMR/commits/master)
+[![Code_Coverage](https://codecov.io/gh/msberends/AMR/branch/master/graph/badge.svg)](https://codecov.io/gh/msberends/AMR)
 
 ```r
 install.packages("devtools")
@@ -77,6 +96,104 @@ after
 # 5 PSEAER    R    R    -    -    R
 ```
 
+### Frequency tables
+Base R lacks a simple function to create frequency tables. We created such a function that works with almost all data types: `freq` (or `frequency_tbl`).
+```r
+## Factors sort on item by default:
+
+freq(septic_patients$hospital_id)
+# Class:     factor
+# Length:    2000 (of which NA: 0 = 0.0%)
+# Unique:    5
+# 
+# Item    Count   Percent   Cum. Count   Cum. Percent   (Factor Level)
+# -----  ------  --------  -----------  -------------  ---------------
+# A         233     11.7%          233          11.7%                1
+# B         583     29.1%          816          40.8%                2
+# C         221     11.1%         1037          51.8%                3
+# D         650     32.5%         1687          84.4%                4
+# E         313     15.7%         2000         100.0%                5
+
+
+## This can be changed with the `sort.count` parameter:
+
+freq(septic_patients$hospital_id, sort.count = TRUE)
+# Class:     factor
+# Length:    2000 (of which NA: 0 = 0.0%)
+# Unique:    5
+# 
+# Item    Count   Percent   Cum. Count   Cum. Percent   (Factor Level)
+# -----  ------  --------  -----------  -------------  ---------------
+# D         650     32.5%          650          32.5%                4
+# B         583     29.1%         1233          61.7%                2
+# E         313     15.7%         1546          77.3%                5
+# A         233     11.7%         1779          88.9%                1
+# C         221     11.1%         2000         100.0%                3
+
+
+## Other types, like numbers or dates, sort on count by default:
+
+> freq(septic_patients$date)
+# Class:     Date
+# Length:    2000 (of which NA: 0 = 0.0%)
+# Unique:    1662
+# 
+# Oldest:    2 January 2001
+# Newest:    18 October 2017 (+6133)
+# 
+# Item          Count   Percent   Cum. Count   Cum. Percent
+# -----------  ------  --------  -----------  -------------
+# 2008-12-24        5      0.2%            5           0.2%
+# 2010-12-10        4      0.2%            9           0.4%
+# 2011-03-03        4      0.2%           13           0.6%
+# 2013-06-24        4      0.2%           17           0.8%
+# 2017-09-01        4      0.2%           21           1.1%
+# 2002-09-02        3      0.2%           24           1.2%
+# 2003-10-14        3      0.2%           27           1.4%
+# 2004-06-25        3      0.2%           30           1.5%
+# 2004-06-27        3      0.2%           33           1.7%
+# 2004-10-29        3      0.2%           36           1.8%
+# 2005-09-27        3      0.2%           39           2.0%
+# 2006-08-01        3      0.2%           42           2.1%
+# 2006-10-10        3      0.2%           45           2.2%
+# 2007-11-16        3      0.2%           48           2.4%
+# 2008-03-09        3      0.2%           51           2.5%
+# ... and 1647 more (n = 1949; 97.5%). Use `nmax` to show more rows.
+
+
+## For numeric values, some extra descriptive statistics will be calculated:
+
+> freq(runif(n = 10, min = 1, max = 5))
+# Class:     numeric
+# Length:    10 (of which NA: 0 = 0.0%)
+# Unique:    10
+#   
+# Mean:      3
+# Std. dev.: 0.93 (CV: 0.31)
+# Five-Num:  1.1  |  2.3  |  3.1  |  3.8  |  4.0 (CQV: 0.25)
+# Outliers:  0
+# 
+#      Item   Count   Percent   Cum. Count   Cum. Percent
+# ---------  ------  --------  -----------  -------------
+#  1.132033       1     10.0%            1          10.0%
+#  2.226903       1     10.0%            2          20.0%
+#  2.280779       1     10.0%            3          30.0%
+#  2.640898       1     10.0%            4          40.0%
+#  2.913462       1     10.0%            5          50.0%
+#  3.364201       1     10.0%            6          60.0%
+#  3.771975       1     10.0%            7          70.0%
+#  3.802861       1     10.0%            8          80.0%
+#  3.803547       1     10.0%            9          90.0%
+#  3.985691       1     10.0%           10         100.0%
+# 
+# Warning message:
+# All observations are unique. 
+```
+Learn more about this function with:
+```r
+?freq
+```
+
 ### New classes
 This package contains two new S3 classes: `mic` for MIC values (e.g. from Vitek or Phoenix) and `rsi` for antimicrobial drug interpretations (i.e. S, I and R). Both are actually ordered factors under the hood (an MIC of `2` being higher than `<=1` but lower than `>=32`, and for class `rsi` factors are ordered as `S < I < R`). 
 Both classes have extensions for existing generic functions like `print`, `summary` and `plot`.
@@ -116,7 +233,14 @@ A plot of `rsi_data`:
 plot(rsi_data)
 ```
 
-![example](man/figures/rsi_example.png)
+![example1](man/figures/rsi_example.png)
+
+A plot of `mic_data` (defaults to bar plot):
+```r
+plot(mic_data)
+```
+
+![example2](man/figures/mic_example.png)
 
 Other epidemiological functions:
 
@@ -140,11 +264,17 @@ abname("J01CR02", from = "atc", to = "umcg") # "AMCL"
 ### Databases included in package
 Datasets to work with antibiotics and bacteria properties.
 ```r
-# Dataset with ATC antibiotics codes, official names and DDD's (oral and parenteral)
-ablist        # A tibble: 420 x 12
+# Dataset with 2000 random blood culture isolates from anonymised
+# septic patients between 2001 and 2017 in 5 Dutch hospitals
+septic_patients   # A tibble: 4,000 x 47
 
-# Dataset with bacteria codes and properties like gram stain and aerobic/anaerobic
-bactlist      # A tibble: 2,507 x 10
+# Dataset with ATC antibiotics codes, official names, trade names 
+# and DDD's (oral and parenteral)
+antibiotics       # A tibble: 420 x 18
+
+# Dataset with bacteria codes and properties like gram stain and 
+# aerobic/anaerobic
+microorganisms    # A tibble: 2,453 x 12
 ```
 
 
@@ -156,7 +286,9 @@ bactlist      # A tibble: 2,507 x 10
   
 <sup>1</sup> Department of Medical Microbiology, University of Groningen, University Medical Center Groningen, Groningen, the Netherlands
 
-<sup>2</sup> Department of Medical, Market and Innovation (MMI), Certe Medische diagnostiek & advies, Groningen, the Netherlands
+<sup>2</sup> Certe Medical Diagnostics & Advice, Groningen, the Netherlands
+
+[![logo_umcg](man/figures/logo_umcg.png)](https://www.umcg.nl)[![logo_certe](man/figures/logo_certe.png)](https://www.certe.nl)[![logo_eh1h](man/figures/logo_eh1h.png)](http://www.eurhealth-1health.eu)[![logo_interreg](man/figures/logo_interreg.png)](http://www.eurhealth-1health.eu)
 
 ## Copyright
 [![License](https://img.shields.io/github/license/msberends/AMR.svg?colorB=3679BC)](https://github.com/msberends/AMR/blob/master/LICENSE)
@@ -167,6 +299,8 @@ This R package is licensed under the [GNU General Public License (GPL) v2.0](htt
 
 - May be used for private purposes
 
+- May **not** be used for patent purposes
+
 - May be modified, although:
 
   - Modifications **must** be released under the same license when distributing the package

man/EUCAST.Rd

@@ -1,5 +1,5 @@
 % Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/EUCAST.R
+% Please edit documentation in R/eucast.R
 \name{EUCAST_rules}
 \alias{EUCAST_rules}
 \alias{interpretive_reading}
@@ -9,11 +9,11 @@ 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}
+  EUCAST Expert Rules Version 3.1 (Intrinsic Resistance and Exceptional Phenotypes Tables): \cr
+  \url{http://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/Expert_rules_intrinsic_exceptional_V3.1.pdf}
 }
 \usage{
-EUCAST_rules(tbl, col_bactcode = "bactid", info = TRUE, amcl = "amcl",
+EUCAST_rules(tbl, col_bactid = "bactid", 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",
@@ -35,7 +35,7 @@ interpretive_reading(...)
 \arguments{
 \item{tbl}{table with antibiotic columns, like e.g. \code{amox} and \code{amcl}}
 
-\item{col_bactcode}{column name of the bacteria ID in \code{tbl} - values of this column should be present in \code{bactlist$bactid}, see \code{\link{bactlist}}}
+\item{col_bactid}{column name of the bacteria ID in \code{tbl} - values of this column should be present in \code{microorganisms$bactid}, see \code{\link{microorganisms}}}
 
 \item{info}{print progress}
 
@@ -50,6 +50,7 @@ table with edited variables of antibiotics.
 Apply expert rules (like intrinsic resistance), as defined by the European Committee on Antimicrobial Susceptibility Testing (EUCAST, \url{http://eucast.org}), see \emph{Source}.
 }
 \examples{
+a <- EUCAST_rules(septic_patients)
 a <- data.frame(bactid = c("STAAUR",  # Staphylococcus aureus
                            "ENCFAE",  # Enterococcus faecalis
                            "ESCCOL",  # Escherichia coli

man/MDRO.Rd

@@ -0,0 +1,61 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/mdro.R
+\name{MDRO}
+\alias{MDRO}
+\alias{BRMO}
+\alias{MRGN}
+\alias{EUCAST_exceptional_phenotypes}
+\title{Determine multidrug-resistant organisms (MDRO)}
+\usage{
+MDRO(tbl, country = NULL, col_bactid = "bactid", 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", metr = "metr", 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")
+
+BRMO(tbl, country = "nl", ...)
+
+MRGN(tbl, country = "de", ...)
+
+EUCAST_exceptional_phenotypes(tbl, country = "EUCAST", ...)
+}
+\arguments{
+\item{tbl}{table with antibiotic columns, like e.g. \code{amox} and \code{amcl}}
+
+\item{country}{country code to determine guidelines. EUCAST rules will be used when left empty, see Details. Should be or a code from the \href{https://en.wikipedia.org/wiki/ISO_3166-1_alpha-2#Officially_assigned_code_elements}{list of ISO 3166-1 alpha-2 country codes}. Case-insensitive. Currently supported are \code{de} (Germany) and \code{nl} (the Netherlands).}
+
+\item{col_bactid}{column name of the bacteria ID in \code{tbl} - values of this column should be present in \code{microorganisms$bactid}, see \code{\link{microorganisms}}}
+
+\item{info}{print progress}
+
+\item{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, metr, 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. column names of antibiotics}
+
+\item{...}{parameters that are passed on to methods}
+}
+\value{
+Ordered factor with levels \code{Unknown < Negative < Unconfirmed < Positive}.
+}
+\description{
+Determine which isolates are multidrug-resistant organisms (MDRO) according to country-specific guidelines.
+}
+\details{
+When \code{country} will be left blank, guidelines will be taken from EUCAST Expert Rules Version 3.1 "Intrinsic Resistance and Exceptional Phenotypes Tables" (\url{http://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/Expert_rules_intrinsic_exceptional_V3.1.pdf}).
+}
+\examples{
+library(dplyr)
+
+septic_patients \%>\%
+  mutate(EUCAST = MDRO(.),
+         BRMO = MDRO(., "nl"))
+}

man/ablist.Rd

@@ -1,34 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/data.R
-\docType{data}
-\name{ablist}
-\alias{ablist}
-\title{Dataset with 420 antibiotics}
-\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_nl}}{Trivial name in Dutch, like \code{"Amoxicilline/clavulaanzuur"}}
-  \item{\code{oral_ddd}}{Defined Daily Dose (DDD) according to the WHO, oral treatment}
-  \item{\code{oral_units}}{Units of \code{ddd_units}}
-  \item{\code{iv_ddd}}{Defined Daily Dose (DDD) according to the WHO, 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/}
-}
-\usage{
-ablist
-}
-\description{
-A dataset containing all antibiotics with a J0 code, with their DDD's.
-}
-\seealso{
-\code{\link{bactlist}}
-}
-\keyword{datasets}

man/abname.Rd

@@ -4,23 +4,23 @@
 \alias{abname}
 \title{Name of an antibiotic}
 \source{
-\code{\link{ablist}}
+\code{\link{antibiotics}}
 }
 \usage{
-abname(abcode, from = "umcg", to = "official", textbetween = " + ",
-  tolower = FALSE)
+abname(abcode, from = c("guess", "atc", "molis", "umcg"), to = "official",
+  textbetween = " + ", tolower = FALSE)
 }
 \arguments{
 \item{abcode}{a code or name, like \code{"AMOX"}, \code{"AMCL"} or \code{"J01CA04"}}
 
-\item{from, to}{type to transform from and to. See \code{\link{ablist}} for its column names.}
+\item{from, to}{type to transform from and to. See \code{\link{antibiotics}} for its column names. WIth \code{from = "guess"} the from will be guessed from \code{"atc"}, \code{"molis"} and \code{"umcg"}.}
 
 \item{textbetween}{text to put between multiple returned texts}
 
 \item{tolower}{return output as lower case with function \code{\link{tolower}}.}
 }
 \description{
-Convert antibiotic codes (from a laboratory information system like MOLIS or GLIMS) to a (trivial) antibiotic name or ATC code, or vice versa. This uses the data from \code{\link{ablist}}.
+Convert antibiotic codes (from a laboratory information system like MOLIS or GLIMS) to a (trivial) antibiotic name or ATC code, or vice versa. This uses the data from \code{\link{antibiotics}}.
 }
 \examples{
 abname("AMCL")

man/antibiotics.Rd

@@ -0,0 +1,40 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/data.R
+\docType{data}
+\name{antibiotics}
+\alias{antibiotics}
+\title{Dataset with 420 antibiotics}
+\format{A data.frame with 420 observations and 18 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{abbr}}{Abbreviation as used by many countries, to be used for \code{\link{guess_atc}}}
+  \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_nl}}{Trivial name in Dutch, like \code{"Amoxicilline/clavulaanzuur"}}
+  \item{\code{trade_name}}{Trade name as used by many countries, to be used for \code{\link{guess_atc}}}
+  \item{\code{oral_ddd}}{Defined Daily Dose (DDD), oral treatment}
+  \item{\code{oral_units}}{Units of \code{ddd_units}}
+  \item{\code{iv_ddd}}{Defined Daily Dose (DDD), parenteral treatment}
+  \item{\code{iv_units}}{Units of \code{iv_ddd}}
+  \item{\code{atc_group1}}{ATC group, like \code{"Macrolides, lincosamides and streptogramins"}}
+  \item{\code{atc_group2}}{Subgroup of \code{atc_group1}, like \code{"Macrolides"}}
+  \item{\code{atc_group1_nl}}{ATC group in Dutch, like \code{"Macroliden, lincosamiden en streptograminen"}}
+  \item{\code{atc_group2_nl}}{Subgroup of \code{atc_group1} in Dutch, like \code{"Macroliden"}}
+  \item{\code{useful_gramnegative}}{\code{FALSE} if not useful according to EUCAST, \code{NA} otherwise (see Source)}
+  \item{\code{useful_grampositive}}{\code{FALSE} if not useful according to EUCAST, \code{NA} otherwise (see Source)}
+}}
+\source{
+- World Health Organization: \url{https://www.whocc.no/atc_ddd_index/} \cr - EUCAST - Expert rules intrinsic exceptional V3.1 \cr - MOLIS (LIS of Certe): \url{https://www.certe.nl} \cr - GLIMS (LIS of UMCG): \url{https://www.umcg.nl}
+}
+\usage{
+antibiotics
+}
+\description{
+A dataset containing all antibiotics with a J0 code, with their DDD's. Properties were downloaded from the WHO, see Source.
+}
+\seealso{
+\code{\link{microorganisms}}
+}
+\keyword{datasets}

man/as.mic.Rd

@@ -15,7 +15,7 @@ is.mic(x)
 \item{na.rm}{a logical indicating whether missing values should be removed}
 }
 \value{
-New class \code{mic}
+Ordered factor with new class \code{mic} and new attributes \code{package} and \code{package.version}
 }
 \description{
 This transforms a vector to a new class\code{mic}, which is an ordered factor with valid MIC values as levels. Invalid MIC values will be translated as \code{NA} with a warning.

man/as.rsi.Rd

@@ -13,7 +13,7 @@ is.rsi(x)
 \item{x}{vector}
 }
 \value{
-New class \code{rsi}
+Ordered factor with new class \code{rsi} and new attributes \code{package} and \code{package.version}
 }
 \description{
 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.

man/bactlist.Rd

@@ -1,32 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/data.R
-\docType{data}
-\name{bactlist}
-\alias{bactlist}
-\title{Dataset with ~2500 microorganisms}
-\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 in Dutch, like \code{"Bacterie"} and \code{"Schimmel/gist"}}
-  \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}
-}
-\usage{
-bactlist
-}
-\description{
-A dataset containing all microorganisms of MOLIS. MO codes of the UMCG can be looked up using \code{\link{bactlist.umcg}}.
-}
-\seealso{
-\code{\link{ablist}} \code{\link{bactlist.umcg}}
-}
-\keyword{datasets}

man/first_isolate.Rd

@@ -3,12 +3,16 @@
 \name{first_isolate}
 \alias{first_isolate}
 \title{Determine first (weighted) isolates}
+\source{
+Methodology of this function is based on: "M39 Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data, 4th Edition", 2014, Clinical and Laboratory Standards Institute. \url{https://clsi.org/standards/products/microbiology/documents/m39/}.
+}
 \usage{
-first_isolate(tbl, col_date, col_patient_id, 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, points_threshold = 2,
-  info = TRUE)
+first_isolate(tbl, col_date, col_patient_id, col_bactid = NA,
+  col_testcode = NA, col_specimen = NA, col_icu = NA,
+  col_keyantibiotics = NA, episode_days = 365, testcodes_exclude = "",
+  icu_exclude = FALSE, filter_specimen = NA, output_logical = TRUE,
+  type = "keyantibiotics", ignore_I = TRUE, points_threshold = 2,
+  info = TRUE, col_genus = NA, col_species = NA)
 }
 \arguments{
 \item{tbl}{a \code{data.frame} containing isolates.}
@@ -17,31 +21,37 @@ first_isolate(tbl, col_date, col_patient_id, col_genus, col_species,
 
 \item{col_patient_id}{column name of the unique IDs of the patients}
 
-\item{col_genus}{column name of the genus of the microorganisms}
+\item{col_bactid}{column name of the unique IDs of the microorganisms (should occur in the \code{\link{microorganisms}} dataset)}
 
-\item{col_species}{column name of the species of the microorganisms}
-
-\item{col_testcode}{column name of the test codes. 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.}
+\item{col_testcode}{column name of the test codes. 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. Supports tidyverse-like quotation.}
 
 \item{col_specimen}{column name of the specimen type or group}
 
 \item{col_icu}{column name of the logicals (\code{TRUE}/\code{FALSE}) whether a ward or department is an Intensive Care Unit (ICU)}
 
-\item{col_keyantibiotics}{column name of the key antibiotics to determine first \emph{weighted} isolates, see \code{\link{key_antibiotics}}.}
+\item{col_keyantibiotics}{column name of the key antibiotics to determine first \emph{weighted} isolates, see \code{\link{key_antibiotics}}. Supports tidyverse-like quotation.}
 
 \item{episode_days}{episode in days after which a genus/species combination will be determined as 'first isolate' again}
 
-\item{testcodes_exclude}{character vector with test codes that should be excluded (caseINsensitive)}
+\item{testcodes_exclude}{character vector with test codes that should be excluded (case-insensitive)}
 
 \item{icu_exclude}{logical whether ICU isolates should be excluded}
 
 \item{filter_specimen}{specimen group or type that should be excluded}
 
-\item{output_logical}{return output as \code{logical} (will else the values \code{0} or \code{1})}
+\item{output_logical}{return output as \code{logical} (will else be the values \code{0} or \code{1})}
 
-\item{points_threshold}{points until the comparison of key antibiotics will lead to inclusion of an isolate, see Details}
+\item{type}{type to determine weighed isolates; can be \code{"keyantibiotics"} or \code{"points"}, see Details}
+
+\item{ignore_I}{logical to determine whether antibiotic interpretations with \code{"I"} will be ignored when \code{type = "keyantibiotics"}, see Details}
+
+\item{points_threshold}{points until the comparison of key antibiotics will lead to inclusion of an isolate when \code{type = "points"}, see Details}
 
 \item{info}{print progress}
+
+\item{col_genus}{(deprecated, use \code{col_bactid} instead) column name of the genus of the microorganisms}
+
+\item{col_species}{(deprecated, use \code{col_bactid} instead) column name of the species of the microorganisms}
 }
 \value{
 A vector to add to table, see Examples.
@@ -50,13 +60,26 @@ A vector to add to table, see Examples.
 Determine first (weighted) isolates of all microorganisms of every patient per episode and (if needed) per specimen type.
 }
 \details{
-\strong{Why this is so important} \cr
+\strong{WHY THIS IS SO IMPORTANT} \cr
     To conduct an analysis of antimicrobial resistance, you should only include the first isolate of every patient per episode \href{https://www.ncbi.nlm.nih.gov/pubmed/17304462}{[1]}. 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 it 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 \href{https://en.wikipedia.org/wiki/Selection_bias}{selection bias}.
 
-    \strong{Using parameter \code{points_threshold}} \cr
-    To compare key antibiotics, the difference between antimicrobial interpretations will be measured. A difference from I to S|R (or vice versa) means 0.5 points. A difference from S to R (or vice versa) means 1 point. When the sum of points exceeds \code{points_threshold}, an isolate will be (re)selected as a first weighted isolate.
+    \strong{DETERMINING WEIGHTED ISOLATES} \cr
+    \strong{1. Using} \code{type = "keyantibiotics"} \strong{and parameter} \code{ignore_I} \cr
+    To determine weighted isolates, the difference between key antibiotics will be checked. Any difference from S to R (or vice versa) will (re)select an isolate as a first weighted isolate. With \code{ignore_I = FALSE}, also differences from I to S|R (or vice versa) will lead to this. This is a reliable method and 30-35 times faster than method 2. \cr
+    \strong{2. Using} \code{type = "points"} \strong{and parameter} \code{points_threshold} \cr
+    To determine weighted isolates, difference between antimicrobial interpretations will be measured with points. A difference from I to S|R (or vice versa) means 0.5 points, a difference from S to R (or vice versa) means 1 point. When the sum of points exceeds \code{points_threshold}, an isolate will be (re)selected as a first weighted isolate. This method is being used by the Infection Prevention department (Dr M. Lokate) of the University Medical Center Groningen (UMCG).
 }
 \examples{
+# septic_patients is a dataset available in the AMR package
+?septic_patients
+my_patients <- septic_patients
+
+library(dplyr)
+my_patients$first_isolate <- my_patients \%>\%
+  first_isolate(col_date = "date",
+                col_patient_id = "patient_id",
+                col_bactid = "bactid")
+
 \dontrun{
 
 # set key antibiotics to a new variable

man/freq.Rd

@@ -0,0 +1,71 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/freq.R
+\name{freq}
+\alias{freq}
+\alias{frequency_tbl}
+\title{Frequency table}
+\usage{
+freq(x, sort.count = TRUE, nmax = 15, na.rm = TRUE, markdown = FALSE,
+  toConsole = TRUE, digits = 2, sep = " ")
+
+frequency_tbl(x, sort.count = TRUE, nmax = 15, na.rm = TRUE,
+  markdown = FALSE, toConsole = TRUE, digits = 2, sep = " ")
+}
+\arguments{
+\item{x}{data}
+
+\item{sort.count}{Sort on count. Use \code{FALSE} to sort alphabetically on item.}
+
+\item{nmax}{number of row to print. Use \code{nmax = 0} or \code{nmax = NA} to print all rows.}
+
+\item{na.rm}{a logical value indicating whether NA values should be removed from the frequency table. The header will always print the amount of\code{NA}s.}
+
+\item{markdown}{print table in markdown format (this forces \code{nmax = NA})}
+
+\item{toConsole}{Print table to the console. Use \code{FALSE} to assign the table to an object.}
+
+\item{digits}{how many significant digits are to be used for numeric values (not for the items themselves, that depends on \code{\link{getOption}("digits")})}
+
+\item{sep}{a character string to separate the terms when selecting multiple columns}
+}
+\description{
+Create a frequency table of a vector of data, a single column or a maximum of 9 columns of a data frame. Supports markdown for reports.
+}
+\details{
+For numeric values, the next values will be calculated and shown into the header:
+\itemize{
+  \item{Mean, using \code{\link[base]{mean}}}
+  \item{Standard deviation, using \code{\link[stats]{sd}}}
+  \item{Five numbers of Tukey (min, Q1, median, Q3, max), using \code{\link[stats]{fivenum}}}
+  \item{Outliers (count and list), using \code{\link{boxplot.stats}}}
+  \item{Coefficient of variation (CV), the standard deviation divided by the mean}
+  \item{Coefficient of quartile variation (CQV, sometimes called coefficient of dispersion), calculated as \code{(Q3 - Q1) / (Q3 + Q1)} using \code{\link{quantile}} with \code{type = 6} as quantile algorithm to comply with SPSS standards}
+}
+}
+\examples{
+library(dplyr)
+
+freq(septic_patients$hospital_id)
+
+septic_patients \%>\%
+  filter(hospital_id == "A") \%>\%
+  select(bactid) \%>\%
+  freq()
+
+# select multiple columns; they will be pasted together
+septic_patients \%>\%
+  left_join_microorganisms \%>\%
+  filter(hospital_id == "A") \%>\%
+  select(genus, species) \%>\%
+  freq()
+
+# save frequency table to an object
+years <- septic_patients \%>\%
+  mutate(year = format(date, "\%Y")) \%>\%
+  select(year) \%>\%
+  freq(toConsole = FALSE)
+}
+\keyword{freq}
+\keyword{frequency}
+\keyword{summarise}
+\keyword{summary}

man/guess_atc.Rd

@@ -0,0 +1,35 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/atc.R
+\name{guess_atc}
+\alias{guess_atc}
+\title{Find ATC code based on antibiotic property}
+\usage{
+guess_atc(x)
+}
+\arguments{
+\item{x}{character vector to determine \code{ATC} code}
+}
+\value{
+Character (vector).
+}
+\description{
+Use this function to determine the ATC code of one or more antibiotics. The dataset \code{\link{antibiotics}} will be searched for abbreviations, official names and trade names.
+}
+\details{
+In the ATC classification system, the active substances are classified in a hierarchy with five different levels.  The system has fourteen main anatomical/pharmacological groups or 1st levels.  Each ATC main group is divided into 2nd levels which could be either pharmacological or therapeutic groups.  The 3rd and 4th levels are chemical, pharmacological or therapeutic subgroups and the 5th level is the chemical substance.  The 2nd, 3rd and 4th levels are often used to identify pharmacological subgroups when that is considered more appropriate than therapeutic or chemical subgroups.
+  Source: \url{https://www.whocc.no/atc/structure_and_principles/}
+}
+\examples{
+# These examples all return "J01FA01", the ATC code of Erythromycin:
+guess_atc("J01FA01")
+guess_atc("Erythromycin")
+guess_atc("eryt")
+guess_atc("ERYT")
+guess_atc("ERY")
+guess_atc("Erythrocin") # Trade name
+guess_atc("Eryzole")    # Trade name
+guess_atc("Pediamycin") # Trade name
+}
+\seealso{
+\code{\link{antibiotics}} for the dataframe that is being used to determine ATC's.
+}

man/guess_bactid.Rd

@@ -0,0 +1,31 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/atc.R
+\name{guess_bactid}
+\alias{guess_bactid}
+\title{Find bacteria ID based on genus/species}
+\usage{
+guess_bactid(x)
+}
+\arguments{
+\item{x}{character vector to determine \code{bactid}}
+}
+\value{
+Character (vector).
+}
+\description{
+Use this function to determine a valid ID based on a genus (and species). This input could be a full name (like \code{"Staphylococcus aureus"}), an abbreviated name (like \code{"S. aureus"}), or just a genus. You could also use a \code{\link{paste}} of a genus and species column to use the full name as input: \code{x = paste(df$genus, df$species)}, where \code{df} is your dataframe.
+}
+\examples{
+# These examples all return "STAAUR", the ID of S. aureus:
+guess_bactid("stau")
+guess_bactid("STAU")
+guess_bactid("staaur")
+guess_bactid("S. aureus")
+guess_bactid("S aureus")
+guess_bactid("Staphylococcus aureus")
+guess_bactid("MRSA") # Methicillin-resistant S. aureus
+guess_bactid("VISA") # Vancomycin Intermediate S. aureus
+}
+\seealso{
+\code{\link{microorganisms}} for the dataframe that is being used to determine ID's.
+}

man/join.Rd

@@ -2,49 +2,55 @@
 % Please edit documentation in R/join.R
 \name{join}
 \alias{join}
-\alias{inner_join_bactlist}
+\alias{inner_join_microorganisms}
 \alias{inner_join}
-\alias{left_join_bactlist}
-\alias{right_join_bactlist}
-\alias{full_join_bactlist}
-\alias{semi_join_bactlist}
-\alias{anti_join_bactlist}
-\title{Join a table with \code{bactlist}}
+\alias{left_join_microorganisms}
+\alias{right_join_microorganisms}
+\alias{full_join_microorganisms}
+\alias{semi_join_microorganisms}
+\alias{anti_join_microorganisms}
+\title{Join a table with \code{microorganisms}}
 \usage{
-inner_join_bactlist(x, by = "bactid", ...)
+inner_join_microorganisms(x, by = "bactid", suffix = c("2", ""), ...)
 
-left_join_bactlist(x, by = "bactid", ...)
+left_join_microorganisms(x, by = "bactid", suffix = c("2", ""), ...)
 
-right_join_bactlist(x, by = "bactid", ...)
+right_join_microorganisms(x, by = "bactid", suffix = c("2", ""), ...)
 
-full_join_bactlist(x, by = "bactid", ...)
+full_join_microorganisms(x, by = "bactid", suffix = c("2", ""), ...)
 
-semi_join_bactlist(x, by = "bactid", ...)
+semi_join_microorganisms(x, by = "bactid", ...)
 
-anti_join_bactlist(x, by = "bactid", ...)
+anti_join_microorganisms(x, by = "bactid", ...)
 }
 \arguments{
-\item{x}{existing table to join}
+\item{x}{existing table to join, also supports character vectors}
 
-\item{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")})}
+\item{by}{a variable to join by - could be a column name of \code{x} with values that exist in \code{microorganisms$bactid} (like \code{by = "bacteria_id"}), or another column in \code{\link{microorganisms}} (but then it should be named, like \code{by = c("my_genus_species" = "fullname")})}
+
+\item{suffix}{if there are non-joined duplicate variables in \code{x} and \code{y}, these suffixes will be added to the output to disambiguate them. Should be a character vector of length 2.}
 
 \item{...}{other parameters to pass on to \code{dplyr::\link[dplyr]{join}}.}
 }
 \description{
-Join the list of microorganisms \code{\link{bactlist}} easily to an existing table.
+Join the dataset \code{\link{microorganisms}} easily to an existing table or character vector.
 }
 \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.
+As opposed to the \code{\link[dplyr]{join}} functions of \code{dplyr}, characters vectors are supported and 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.
 }
 \examples{
+left_join_microorganisms("STAAUR")
+
+library(dplyr)
+septic_patients \%>\% left_join_microorganisms()
+
 df <- data.frame(date = seq(from = as.Date("2018-01-01"),
                             to = as.Date("2018-01-07"),
                             by = 1),
                  bacteria_id = c("STAAUR", "STAAUR", "STAAUR", "STAAUR",
                                  "ESCCOL", "ESCCOL", "ESCCOL"),
                  stringsAsFactors = FALSE)
-                 
 colnames(df)
-df2 <- left_join_bactlist(df, "bacteria_id")
+df2 <- left_join_microorganisms(df, "bacteria_id")
 colnames(df2)
 }

man/key_antibiotics.Rd

@@ -4,7 +4,7 @@
 \alias{key_antibiotics}
 \title{Key antibiotics based on bacteria ID}
 \usage{
-key_antibiotics(tbl, col_bactcode = "bactid", info = TRUE, amcl = "amcl",
+key_antibiotics(tbl, col_bactid = "bactid", 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",
@@ -14,11 +14,11 @@ key_antibiotics(tbl, col_bactcode = "bactid", info = TRUE, amcl = "amcl",
 \arguments{
 \item{tbl}{table with antibiotics coloms, like \code{amox} and \code{amcl}.}
 
-\item{col_bactcode}{column of bacteria IDs in \code{tbl}; these should occur in \code{bactlist$bactid}, see \code{\link{bactlist}}}
+\item{col_bactid}{column of bacteria IDs in \code{tbl}; these should occur in \code{microorganisms$bactid}, see \code{\link{microorganisms}}}
 
 \item{info}{print warnings}
 
-\item{amcl, amox, cfot, cfta, cftr, cfur, cipr, clar, clin, clox, doxy, gent, line, mero, peni, pita, rifa, teic, trsu, vanc}{column names of antibiotics.}
+\item{amcl, amox, cfot, cfta, cftr, cfur, cipr, clar, clin, clox, doxy, gent, line, mero, peni, pita, rifa, teic, trsu, vanc}{column names of antibiotics, case-insensitive}
 }
 \value{
 Character of length 1.
@@ -33,5 +33,5 @@ tbl$keyab <- key_antibiotics(tbl)
 }
 }
 \seealso{
-\code{\link{mo_property}} \code{\link{ablist}}
+\code{\link{mo_property}} \code{\link{antibiotics}}
 }

man/like.Rd

@@ -0,0 +1,40 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/misc.R
+\name{like}
+\alias{like}
+\alias{\%like\%}
+\title{Pattern Matching}
+\source{
+Inherited from the \href{https://github.com/Rdatatable/data.table/blob/master/R/like.R}{\code{like} function from the \code{data.table} package}, but made it case insensitive at default.
+}
+\usage{
+x \%like\% pattern
+}
+\arguments{
+\item{x}{a character vector where matches are sought, or an
+    object which can be coerced by \code{as.character} to a character
+    vector.  \link{Long vectors} are supported.}
+
+\item{pattern}{character string containing a \link{regular expression}
+    (or character string for \code{fixed = TRUE}) to be matched
+    in the given character vector.  Coerced by
+    \code{\link{as.character}} to a character string if possible.  If a
+    character vector of length 2 or more is supplied, the first element
+    is used with a warning.  Missing values are allowed except for
+    \code{regexpr} and \code{gregexpr}.}
+}
+\value{
+A \code{logical} vector
+}
+\description{
+Convenience function to compare a vector with a pattern, like \code{\link[base]{grep}}. It always returns a \code{logical} vector and is always case-insensitive.
+}
+\examples{
+library(dplyr)
+# get unique occurences of bacteria whose name start with 'Ent'
+septic_patients \%>\%
+  left_join_microorganisms() \%>\%
+  filter(fullname \%like\% '^Ent') \%>\%
+  pull(fullname) \%>\%
+  unique()
+}

man/microorganisms.Rd

@@ -0,0 +1,34 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/data.R
+\docType{data}
+\name{microorganisms}
+\alias{microorganisms}
+\title{Dataset with ~2500 microorganisms}
+\format{A data.frame with 2453 observations and 12 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{"Bacteria"} and \code{"Fungus/yeast"}}
+  \item{\code{gramstain}}{Gram of microorganism, like \code{"Negative rods"}}
+  \item{\code{aerobic}}{Logical whether bacteria is aerobic}
+  \item{\code{type_nl}}{Type of microorganism in Dutch, like \code{"Bacterie"} and \code{"Schimmel/gist"}}
+  \item{\code{gramstain_nl}}{Gram of microorganism in Dutch, like \code{"Negatieve staven"}}
+}}
+\source{
+MOLIS (LIS of Certe) - \url{https://www.certe.nl}
+}
+\usage{
+microorganisms
+}
+\description{
+A dataset containing 2453 microorganisms. MO codes of the UMCG can be looked up using \code{\link{microorganisms.umcg}}.
+}
+\seealso{
+\code{\link{guess_bactid}} \code{\link{antibiotics}} \code{\link{microorganisms.umcg}}
+}
+\keyword{datasets}

man/microorganisms.umcg.Rd

@@ -1,24 +1,24 @@
 % Generated by roxygen2: do not edit by hand
 % Please edit documentation in R/data.R
 \docType{data}
-\name{bactlist.umcg}
-\alias{bactlist.umcg}
+\name{microorganisms.umcg}
+\alias{microorganisms.umcg}
 \title{Translation table for UMCG with ~1100 microorganisms}
 \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}}}
+  \item{\code{bactid}}{Code of microorganism in \code{\link{microorganisms}}}
 }}
 \source{
 MOLIS (LIS of Certe) - \url{https://www.certe.nl} \cr \cr GLIMS (LIS of UMCG) - \url{https://www.umcg.nl}
 }
 \usage{
-bactlist.umcg
+microorganisms.umcg
 }
 \description{
-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}}.
+A dataset containing all bacteria codes of UMCG MMB. These codes can be joined to data with an ID from \code{\link{microorganisms}$bactid} (using \code{\link{left_join_microorganisms}}). GLIMS codes can also be translated to valid \code{bactid}'s with \code{\link{guess_bactid}}.
 }
 \seealso{
-\code{\link{bactlist}}
+\code{\link{guess_bactid}} \code{\link{microorganisms}}
 }
 \keyword{datasets}

man/mo_property.Rd

@@ -1,13 +1,13 @@
 % Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/EUCAST.R
+% Please edit documentation in R/eucast.R
 \name{mo_property}
 \alias{mo_property}
 \title{Poperties of a microorganism}
 \usage{
-mo_property(bactcode, property = "fullname")
+mo_property(bactid, property = "fullname")
 }
 \arguments{
-\item{bactcode}{ID of a microorganisme, like \code{"STAAUR} and \code{"ESCCOL}}
+\item{bactid}{ID of a microorganisme, like \code{"STAAUR} and \code{"ESCCOL}}
 
 \item{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}}
 }
@@ -15,5 +15,5 @@ mo_property(bactcode, property = "fullname")
 Poperties of a microorganism
 }
 \seealso{
-\code{\link{bactlist}}
+\code{\link{microorganisms}}
 }

man/print.Rd

@@ -0,0 +1,57 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/print.R
+\name{print}
+\alias{print}
+\alias{print.tbl_df}
+\alias{print.tbl}
+\alias{print.data.table}
+\title{Printing Data Tables and Tibbles}
+\usage{
+\method{print}{tbl_df}(x, nmax = 10, header = TRUE, row.names = TRUE,
+  right = FALSE, width = 1, na = "<NA>", ...)
+
+\method{print}{tbl}(x, ...)
+
+\method{print}{data.table}(x, print.keys = FALSE, ...)
+}
+\arguments{
+\item{x}{object of class \code{data.frame}.}
+
+\item{nmax}{amount of rows to print in total. When the total amount of rows exceeds this limit, the first and last \code{nmax / 2} rows will be printed. Use \code{nmax = NA} to print all rows.}
+
+\item{header}{print header with information about data size and tibble grouping}
+
+\item{row.names}{logical (or character vector), indicating whether (or
+    what) row names should be printed.}
+
+\item{right}{logical, indicating whether or not strings should be
+    right-aligned.  The default is right-alignment.}
+
+\item{width}{amount of white spaces to keep between columns, must be at least 1}
+
+\item{na}{value to print instead of NA}
+
+\item{...}{optional arguments to \code{print} or \code{plot} methods.}
+
+\item{print.keys}{print keys for \code{data.table}}
+}
+\description{
+Print a data table or tibble. It prints: \cr- The \strong{first and last rows} like \code{data.table}s are printed by the \code{data.table} package,\cr- A \strong{header} and \strong{left aligned text} like \code{tibble}s are printed by the \code{tibble} package with info about grouped variables,\cr- \strong{Unchanged values} and \strong{support for row names} like \code{data.frame}s are printed by the \code{base} package.
+}
+\examples{
+# more reliable data view:
+library(dplyr)
+starwars
+print(starwars, width = 3)
+
+# This is how the tibble package prints since v1.4.0:
+# (mind the quite unfamiliar underscores and ending dots)
+tibble(now_what = c(1.2345, 2345.67, 321.456)) \%>\% tibble:::print.tbl_df()
+
+# This is how this AMR package prints:
+# (every number shown as you would expect)
+tibble(now_what = c(1.2345, 2345.67, 321.456))
+
+# also supports info about groups (look at header)
+starwars \%>\% group_by(homeworld, gender)
+}

man/rsi.Rd

@@ -2,49 +2,92 @@
 % Please edit documentation in R/rsi_analysis.R
 \name{rsi}
 \alias{rsi}
+\alias{rsi_df}
+\alias{n_rsi}
 \title{Resistance of isolates}
 \usage{
-rsi(ab1, ab2 = NA, interpretation = "IR", minimum = 30, percent = FALSE,
-  info = FALSE, warning = FALSE)
+rsi(ab1, ab2 = NA, interpretation = "IR", minimum = 30,
+  as_percent = FALSE, info = FALSE, warning = TRUE)
+
+rsi_df(tbl, ab, interpretation = "IR", minimum = 30, as_percent = FALSE,
+  info = TRUE, warning = TRUE)
+
+n_rsi(ab1, ab2 = NA)
 }
 \arguments{
-\item{ab1, ab2}{list with interpretations of an antibiotic}
+\item{ab1, ab2}{vector of antibiotic interpretations, they will be transformed internally with \code{\link{as.rsi}}}
 
 \item{interpretation}{antimicrobial interpretation of which the portion must be calculated. Valid values are \code{"S"}, \code{"SI"}, \code{"I"}, \code{"IR"} or \code{"R"}.}
 
 \item{minimum}{minimal amount of available isolates. Any number lower than \code{minimum} will return \code{NA} with a warning (when \code{warning = TRUE}).}
 
-\item{percent}{return output as percent (text), will else (at default) be a double}
+\item{as_percent}{return output as percent (text), will else (at default) be a double}
 
 \item{info}{calculate the amount of available isolates and print it, like \code{n = 423}}
 
 \item{warning}{show a warning when the available amount of isolates is below \code{minimum}}
+
+\item{tbl}{\code{data.frame} containing columns with antibiotic interpretations.}
+
+\item{ab}{character vector with 1, 2 or 3 antibiotics that occur as column names in \code{tbl}, like \code{ab = c("amox", "amcl")}}
 }
 \value{
-Double or, when \code{percent = TRUE}, a character.
+Double or, when \code{as_percent = TRUE}, a character.
 }
 \description{
-This function can be used in \code{dplyr}s \code{\link[dplyr]{summarise}}, see \emph{Examples}. Calculate the percentage S, SI, I, IR or R of a vector of isolates.
+This functions can be used to calculate the (co-)resistance of isolates (i.e. percentage S, SI, I, IR or R [of a vector] of isolates). The functions \code{rsi} and \code{n_rsi} can be used in \code{dplyr}s \code{\link[dplyr]{summarise}} and support grouped variables, see \emph{Examples}.
 }
 \details{
-This function uses the \code{\link{rsi_df}} function internally.
+Remember that you should filter your table to let it contain \strong{only first isolates}!
+\if{html}{
+  \cr \cr
+  To calculate the probability (\emph{p}) of susceptibility of one antibiotic, we use this formula:
+  \out{<div style="text-align: center">}\figure{mono_therapy.png}\out{</div>}
+  To calculate the probability (\emph{p}) of susceptibility of more antibiotics (i.e. combination therapy), we need to check whether one of them has a susceptible result (as numerator) and count all cases where all antibiotics were tested (as denominator). \cr
+  For two antibiotics:
+  \out{<div style="text-align: center">}\figure{combi_therapy_2.png}\out{</div>}
+  \cr
+  For three antibiotics:
+  \out{<div style="text-align: center">}\figure{combi_therapy_3.png}\out{</div>}
+}
 }
 \examples{
+library(dplyr)
+
+septic_patients \%>\%
+  group_by(hospital_id) \%>\%
+  summarise(cipro_susceptibility = rsi(cipr, interpretation = "S"),
+            n = n_rsi(cipr)) # n_rsi works like n_distinct in dplyr
+
+septic_patients \%>\%
+  group_by(hospital_id) \%>\%
+  summarise(cipro_S = rsi(cipr, interpretation = "S",
+                          as_percent = TRUE, warning = FALSE),
+            cipro_n = n_rsi(cipr),
+            genta_S = rsi(gent, interpretation = "S",
+                          as_percent = TRUE, warning = FALSE),
+            genta_n = n_rsi(gent),
+            combination_S = rsi(cipr, gent, interpretation = "S",
+                                as_percent = TRUE, warning = FALSE),
+            combination_n = n_rsi(cipr, gent))
+
+# calculate resistance
+rsi(septic_patients$amox)
+# or susceptibility
+rsi(septic_patients$amox, interpretation = "S")
+
+# calculate co-resistance between amoxicillin/clav acid and gentamicin,
+# so we can review that combination therapy does a lot more than mono therapy:
+septic_patients \%>\% rsi_df(ab = "amcl", interpretation = "S") # = 67.8\%
+septic_patients \%>\% rsi_df(ab = "gent", interpretation = "S") # = 69.1\%
+septic_patients \%>\% rsi_df(ab = c("amcl", "gent"), interpretation = "S") # = 90.6\%
+
 \dontrun{
-tbl \%>\%
-  group_by(hospital) \%>\%
-  summarise(cipr = rsi(cipr))
-  
-tbl \%>\%
-  group_by(year, hospital) \%>\%
-  summarise(
-    isolates = n(),
-    cipro = rsi(cipr \%>\% as.rsi(), percent = TRUE),
-    amoxi = rsi(amox \%>\% as.rsi(), percent = TRUE))
-    
-rsi(as.rsi(isolates$amox))
-
-rsi(as.rsi(isolates$amcl), interpretation = "S")
+# calculate current empiric combination therapy of Helicobacter gastritis:
+my_table \%>\%
+  filter(first_isolate == TRUE,
+         genus == "Helicobacter") \%>\%
+  rsi_df(ab = c("amox", "metr")) # amoxicillin with metronidazole
 }
 }
 \keyword{antibiotics}

man/rsi_df.Rd

@@ -1,54 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/rsi_analysis.R
-\name{rsi_df}
-\alias{rsi_df}
-\title{Resistance of isolates in data.frame}
-\usage{
-rsi_df(tbl, antibiotics, interpretation = "IR", minimum = 30,
-  percent = FALSE, info = TRUE, warning = TRUE)
-}
-\arguments{
-\item{tbl}{\code{data.frame} containing columns with antibiotic interpretations.}
-
-\item{antibiotics}{character vector with 1, 2 or 3 antibiotics that occur as column names in \code{tbl}, like \code{antibiotics = c("amox", "amcl")}}
-
-\item{interpretation}{antimicrobial interpretation of which the portion must be calculated. Valid values are \code{"S"}, \code{"SI"}, \code{"I"}, \code{"IR"} or \code{"R"}.}
-
-\item{minimum}{minimal amount of available isolates. Any number lower than \code{minimum} will return \code{NA} with a warning (when \code{warning = TRUE}).}
-
-\item{percent}{return output as percent (text), will else (at default) be a double}
-
-\item{info}{calculate the amount of available isolates and print it, like \code{n = 423}}
-
-\item{warning}{show a warning when the available amount of isolates is below \code{minimum}}
-}
-\value{
-Double or, when \code{percent = TRUE}, a character.
-}
-\description{
-\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.
-}
-\details{
-Remember that you should filter your table to let it contain \strong{only first isolates}!
-}
-\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"))
-}
-}
-\seealso{
-\code{\link{rsi}} for the function that can be used with \code{\link[dplyr]{summarise}} directly.
-}
-\keyword{antibiotics}
-\keyword{isolate}
-\keyword{isolates}
-\keyword{rsi}

man/rsi_predict.Rd

@@ -53,14 +53,13 @@ tbl \%>\%
 library(dplyr)
 septic_patients \%>\%
   # get bacteria properties like genus and species
-  left_join_bactlist("bactid") \%>\% 
+  left_join_microorganisms("bactid") \%>\%
   # calculate first isolates
   mutate(first_isolate =
            first_isolate(.,
                          "date",
                          "patient_id",
-                         "genus",
-                         "species",
+                         "bactid",
                          col_specimen = NA,
                          col_icu = NA)) \%>\%
   # filter on first E. coli isolates
@@ -68,8 +67,8 @@ septic_patients \%>\%
          species == "coli",
          first_isolate == TRUE) \%>\%
   # predict resistance of cefotaxime for next years
-  rsi_predict(col_ab = cfot,
-              col_date = date,
+  rsi_predict(col_ab = "cfot",
+              col_date = "date",
               year_max = 2025,
               preserve_measurements = FALSE)
 

man/septic_patients.Rd

@@ -14,8 +14,8 @@
   \item{\code{age}}{age of the patient}
   \item{\code{sex}}{sex of the patient}
   \item{\code{patient_id}}{ID of the patient, first 10 characters of an SHA hash containing irretrievable information}
-  \item{\code{bactid}}{ID of microorganism, see \code{\link{bactlist}}}
-  \item{\code{peni:mupi}}{38 different antibiotics with class \code{rsi} (see \code{\link{as.rsi}}), these column names occur in \code{\link{ablist}} and can be translated with \code{\link{abname}}}
+  \item{\code{bactid}}{ID of microorganism, see \code{\link{microorganisms}}}
+  \item{\code{peni:mupi}}{38 different antibiotics with class \code{rsi} (see \code{\link{as.rsi}}); these column names occur in \code{\link{antibiotics}} and can be translated with \code{\link{abname}}}
 }}
 \source{
 MOLIS (LIS of Certe) - \url{https://www.certe.nl}
@@ -24,6 +24,46 @@ MOLIS (LIS of Certe) - \url{https://www.certe.nl}
 septic_patients
 }
 \description{
-An anonymised dataset containing 2000 microbial blood culture isolates with their antibiogram of septic patients found in 5 different hospitals in the Netherlands, between 2001 and 2017. This data.frame can be used to practice AMR analysis e.g. with \code{\link{rsi}} or \code{\link{rsi_predict}}, or it can be used to practice other statistics.
+An anonymised dataset containing 2000 microbial blood culture isolates with their antibiogram of septic patients found in 5 different hospitals in the Netherlands, between 2001 and 2017. This data.frame can be used to practice AMR analysis. For examples, press F1.
+}
+\examples{
+# ----------- #
+# PREPARATION #
+# ----------- #
+
+# Save this example dataset to an object, so we can edit it:
+my_data <- septic_patients
+
+# load the dplyr package to make data science A LOT easier
+library(dplyr)
+
+# Add first isolates to our dataset:
+my_data <- my_data \%>\%
+  mutate(first_isolates = first_isolate(my_data, "date", "patient_id", "bactid"))
+
+# -------- #
+# ANALYSIS #
+# -------- #
+
+# 1. Get the amoxicillin resistance percentages
+#    of E. coli, divided by hospital:
+
+my_data \%>\%
+  filter(bactid == "ESCCOL",
+         first_isolates == TRUE) \%>\%
+  group_by(hospital_id) \%>\%
+  summarise(n = n(),
+            amoxicillin_resistance = rsi(amox))
+
+
+# 2. Get the amoxicillin/clavulanic acid resistance
+#    percentages of E. coli, trend over the years:
+
+my_data \%>\%
+  filter(bactid == guess_bactid("E. coli"),
+         first_isolates == TRUE) \%>\%
+  group_by(year = format(date, "\%Y")) \%>\%
+  summarise(n = n(),
+            amoxclav_resistance = rsi(amcl, minimum = 20))
 }
 \keyword{datasets}

tests/testthat.R

@@ -0,0 +1,4 @@
+library(testthat)
+library(AMR)
+
+test_check("AMR")

tests/testthat/test-atc.R

@@ -0,0 +1,44 @@
+context("atc.R")
+
+
+test_that("atc_property works", {
+  expect_equal(tolower(atc_property("J01CA04", property = "Name")), "amoxicillin")
+  expect_equivalent(atc_property("J01CA04", "DDD"), 1)
+})
+
+test_that("abname works", {
+  expect_equal(abname("AMOX"), "Amoxicillin")
+  expect_equal(abname(c("AMOX", "GENT")), c("Amoxicillin", "Gentamicin"))
+  expect_equal(abname(c("AMOX+GENT")), "Amoxicillin + gentamicin")
+  expect_equal(abname("AMOX", from = 'umcg'), "Amoxicillin")
+  expect_equal(abname("amox", from = 'molis'), "Amoxicillin")
+  expect_equal(abname("J01CA04", from = 'atc'), "Amoxicillin")
+})
+
+test_that("guess_bactid works", {
+  expect_identical(guess_bactid(c("E. coli", "H. influenzae")), c("ESCCOL", "HAEINF"))
+  expect_equal(guess_bactid("Escherichia coli"), "ESCCOL")
+  expect_equal(guess_bactid("Negative rods"), "GNR")
+  expect_equal(guess_bactid(c("stau",
+                              "STAU",
+                              "staaur",
+                              "S. aureus",
+                              "S aureus",
+                              "Staphylococcus aureus",
+                              "MRSA",
+                              "VISA")),
+               rep("STAAUR", 8))
+})
+
+test_that("guess_atc works", {
+  expect_equal(guess_atc(c("J01FA01",
+                           "Erythromycin",
+                           "eryt",
+                           "ERYT",
+                           "ERY",
+                           "Erythrocin",
+                           "Eryzole",
+                           "Pediamycin")),
+               rep("J01FA01", 8))
+
+})

tests/testthat/test-classes.R

@@ -0,0 +1,43 @@
+context("classes.R")
+
+test_that("rsi works", {
+  expect_true(as.rsi("S") < as.rsi("I"))
+  expect_true(as.rsi("I") < as.rsi("R"))
+  expect_true(as.rsi("R") > as.rsi("S"))
+  expect_true(is.rsi(as.rsi("S")))
+
+  # print plots, should not raise errors
+  barplot(as.rsi(c("S", "I", "R")))
+  plot(as.rsi(c("S", "I", "R")))
+  print(as.rsi(c("S", "I", "R")))
+
+  expect_equal(suppressWarnings(as.logical(as.rsi("INVALID VALUE"))), NA)
+
+  expect_equal(summary(as.rsi(c("S", "R"))), c("Mode" = 'rsi',
+                                               "<NA>" = "0",
+                                               "Sum S" = "1",
+                                               "Sum IR" = "1",
+                                               "Sum R" = "1",
+                                               "Sum I" = "0"))
+})
+
+test_that("mic works", {
+  expect_true(as.mic(8) == as.mic("8"))
+  expect_true(as.mic("1") > as.mic("<=0.0625"))
+  expect_true(as.mic("1") < as.mic(">=32"))
+  expect_true(is.mic(as.mic(8)))
+
+  expect_equal(as.double(as.mic(">=32")), 32)
+  expect_equal(as.integer(as.mic(">=32")), 32)
+  expect_equal(suppressWarnings(as.logical(as.mic("INVALID VALUE"))), NA)
+
+  # print plots, should not raise errors
+  barplot(as.mic(c(1, 2, 4, 8)))
+  plot(as.mic(c(1, 2, 4, 8)))
+  print(as.mic(c(1, 2, 4, 8)))
+
+  expect_equal(summary(as.mic(c(2, 8))), c("Mode" = 'mic',
+                                           "<NA>" = "0",
+                                           "Min." = "2",
+                                           "Max." = "8"))
+})

tests/testthat/test-eucast.R

@@ -0,0 +1,33 @@
+context("eucast.R")
+
+test_that("EUCAST rules work", {
+  a <- EUCAST_rules(septic_patients)
+
+  a <- data.frame(bactid = c("KLEPNE",  # Klebsiella pneumoniae
+                             "PSEAER",  # Pseudomonas aeruginosa
+                             "ENTAER"), # Enterobacter aerogenes
+                  amox = "-",           # Amoxicillin
+                  stringsAsFactors = FALSE)
+  b <- data.frame(bactid = c("KLEPNE",  # Klebsiella pneumoniae
+                             "PSEAER",  # Pseudomonas aeruginosa
+                             "ENTAER"), # Enterobacter aerogenes
+                  amox = "R",           # Amoxicillin
+                  stringsAsFactors = FALSE)
+  expect_equal(EUCAST_rules(a, info = FALSE), b)
+  expect_equal(suppressWarnings(interpretive_reading(a, info = TRUE)), b)
+
+  a <- data.frame(bactid = c("STAAUR",  # Staphylococcus aureus
+                             "STCGRA"), # Streptococcus pyognenes (Lancefield Group A)
+                  coli = "-",           # Colistin
+                  stringsAsFactors = FALSE)
+  b <- data.frame(bactid = c("STAAUR",  # Staphylococcus aureus
+                             "STCGRA"), # Streptococcus pyognenes (Lancefield Group A)
+                  coli = "R",           # Colistin
+                  stringsAsFactors = FALSE)
+  expect_equal(EUCAST_rules(a, info = FALSE), b)
+})
+
+test_that("MO properties work", {
+  expect_equal(mo_property("ESCCOL"), "Escherichia coli")
+  expect_equal(mo_property("STAAUR"), "Staphylococcus aureus")
+})

tests/testthat/test-first_isolates.R

@@ -0,0 +1,53 @@
+context("first_isolates.R")
+
+test_that("keyantibiotics work", {
+  expect_equal(length(key_antibiotics(septic_patients, info = FALSE)), nrow(septic_patients))
+  expect_true(key_antibiotics_equal("SSS", "SSS"))
+  expect_true(key_antibiotics_equal("SSS", "SIS", ignore_I = TRUE))
+  expect_false(key_antibiotics_equal("SSS", "SIS", ignore_I = FALSE))
+})
+
+test_that("first isolates work", {
+  # septic_patients contains 1960 out of 2000 first isolates
+  #septic_ptns <- septic_patients
+  expect_equal(sum(first_isolate(tbl = septic_patients,
+                                 col_date = "date",
+                                 col_patient_id = "patient_id",
+                                 col_bactid = "bactid",
+                                 info = FALSE)), 1960)
+
+  # septic_patients contains 1962 out of 2000 first *weighted* isolates
+  expect_equal(
+    suppressWarnings(sum(
+      first_isolate(tbl = septic_patients %>% mutate(keyab = key_antibiotics(.)),
+                    col_date = "date",
+                    col_patient_id = "patient_id",
+                    col_bactid = "bactid",
+                    col_keyantibiotics = "keyab",
+                    type = "keyantibiotics",
+                    info = TRUE))),
+    1962)
+
+  # septic_patients contains 1733 out of 2000 first non-ICU isolates
+  expect_equal(
+    sum(
+      first_isolate(septic_patients, col_bactid = "bactid", col_date = "date", col_patient_id = "patient_id", col_icu = "ward_icu", info = TRUE, icu_exclude = TRUE)),
+    1733
+  )
+
+  # set 1500 random observations to be of specimen type 'Urine'
+  random_rows <- sample(x = 1:2000, size = 1500, replace = FALSE)
+  expect_lt(sum(
+    first_isolate(tbl = mutate(septic_patients,
+                               specimen = if_else(row_number() %in% random_rows,
+                                                  "Urine",
+                                                  "Unknown")),
+                  col_date = "date",
+                  col_patient_id = "patient_id",
+                  col_bactid = "bactid",
+                  col_specimen = "specimen",
+                  filter_specimen = "Urine",
+                  info = TRUE)),
+    1501)
+
+})

tests/testthat/test-freq.R

@@ -0,0 +1,26 @@
+context("freq.R")
+
+test_that("frequency table works", {
+  expect_equal(nrow(freq(c(1, 1, 2, 2, 3, 3, 4, 4, 5, 5), toConsole = FALSE)), 5)
+  expect_equal(nrow(frequency_tbl(c(1, 1, 2, 2, 3, 3, 4, 4, 5, 5), toConsole = FALSE)), 5)
+
+  # date column of septic_patients should contain 1662 unique dates
+  expect_equal(nrow(freq(septic_patients$date, toConsole = FALSE)), 1662)
+  expect_equal(nrow(freq(septic_patients$date, toConsole = FALSE)),
+               length(unique(septic_patients$date)))
+
+  expect_output(freq(septic_patients$age))
+  expect_output(freq(septic_patients$date))
+  expect_output(freq(septic_patients$hospital_id))
+
+  library(dplyr)
+  expect_output(septic_patients %>% select(1:2) %>% freq())
+  expect_output(septic_patients %>% select(1:3) %>% freq())
+  expect_output(septic_patients %>% select(1:4) %>% freq())
+  expect_output(septic_patients %>% select(1:5) %>% freq())
+  expect_output(septic_patients %>% select(1:6) %>% freq())
+  expect_output(septic_patients %>% select(1:7) %>% freq())
+  expect_output(septic_patients %>% select(1:8) %>% freq())
+  expect_output(septic_patients %>% select(1:9) %>% freq())
+})
+

tests/testthat/test-joins.R

@@ -0,0 +1,27 @@
+context("joins.R")
+
+test_that("joins work", {
+  unjoined <- septic_patients
+  inner <- septic_patients %>% inner_join_microorganisms()
+  left <- septic_patients %>% left_join_microorganisms()
+  semi <- septic_patients %>% semi_join_microorganisms()
+  anti <- septic_patients %>% anti_join_microorganisms()
+  suppressWarnings(right <- septic_patients %>% right_join_microorganisms())
+  suppressWarnings(full <- septic_patients %>% full_join_microorganisms())
+
+  expect_true(ncol(unjoined) < ncol(inner))
+  expect_true(nrow(unjoined) == nrow(inner))
+
+  expect_true(ncol(unjoined) < ncol(left))
+  expect_true(nrow(unjoined) == nrow(left))
+
+  expect_true(ncol(semi) == ncol(semi))
+  expect_true(nrow(semi) == nrow(semi))
+
+  expect_true(nrow(anti) == 0)
+
+  expect_true(nrow(unjoined) < nrow(right))
+  expect_true(nrow(unjoined) < nrow(full))
+
+  expect_equal(nrow(left_join_microorganisms("ESCCOL")), 1)
+})

tests/testthat/test-mdro.R

@@ -0,0 +1,20 @@
+context("mdro.R")
+
+
+test_that("MDRO works", {
+  library(dplyr)
+
+  outcome <- MDRO(septic_patients, "EUCAST", info = FALSE)
+  # check class
+  expect_equal(outcome %>% class(), c('ordered', 'factor'))
+
+  outcome <- MDRO(septic_patients, "nl", info = FALSE)
+  # check class
+  expect_equal(outcome %>% class(), c('ordered', 'factor'))
+
+  # septic_patients should have these finding using Dutch guidelines
+  expect_equal(outcome %>% freq(toConsole = FALSE) %>% pull(Count), c(3, 21))
+
+  expect_equal(BRMO(septic_patients, info = FALSE), MDRO(septic_patients, "nl", info = FALSE))
+
+})

tests/testthat/test-misc.R

@@ -0,0 +1,27 @@
+context("misc.R")
+
+test_that("`like` works", {
+  expect_true(suppressWarnings("test" %like% c("^t", "^s")))
+  expect_true("test" %like% "test")
+  expect_true("test" %like% "TEST")
+  expect_true(as.factor("test") %like% "TEST")
+})
+
+test_that("percentages works", {
+  expect_equal(percent(0.25), "25%")
+  expect_equal(percent(0.5), "50%")
+  expect_equal(percent(0.500, force_zero = TRUE), "50.0%")
+  expect_equal(percent(0.1234), "12.3%")
+})
+
+test_that("size format works", {
+  expect_equal(size_humanreadable(123456), "121 kB")
+})
+
+test_that("functions missing in older R versions work", {
+  expect_equal(strrep("A", 5), "AAAAA")
+  expect_equal(strrep(c("A", "B"), c(5, 2)), c("AAAAA", "BB"))
+  expect_equal(trimws(" test "), "test")
+  expect_equal(trimws(" test ", "l"), "test ")
+  expect_equal(trimws(" test ", "r"), " test")
+})

tests/testthat/test-print.R

@@ -0,0 +1,11 @@
+context("print.R")
+
+
+test_that("tibble printing works", {
+  library(dplyr)
+  library(data.table)
+  expect_output(print(starwars))
+  expect_output(print(starwars %>% group_by(homeworld, gender)))
+  expect_output(print(starwars %>% as.data.table(), print.keys = TRUE))
+  expect_output(print(septic_patients))
+})

tests/testthat/test-rsi_analysis.R

@@ -0,0 +1,88 @@
+context("rsi_analysis.R")
+
+test_that("rsi works", {
+  # amox resistance in `septic_patients` should be around 53.86%
+  expect_equal(rsi(septic_patients$amox), 0.5386, tolerance = 0.0001)
+  expect_equal(rsi(septic_patients$amox), 0.5386, tolerance = 0.0001)
+  expect_equal(rsi_df(septic_patients,
+                      ab = "amox",
+                      info = FALSE),
+               0.5386,
+               tolerance = 0.0001)
+  # pita+genta susceptibility around 98.09%
+  expect_equal(rsi(septic_patients$pita,
+                   septic_patients$gent,
+                   interpretation = "S",
+                   info = TRUE),
+               0.9809,
+               tolerance = 0.0001)
+  expect_equal(rsi_df(septic_patients,
+                      ab = c("pita", "gent"),
+                      interpretation = "S",
+                      info = FALSE),
+               0.9809,
+               tolerance = 0.0001)
+  # mero+pita+genta susceptibility around 98.58%
+  expect_equal(rsi_df(septic_patients,
+                      ab = c("mero", "pita", "gent"),
+                      interpretation = "IS",
+                      info = FALSE),
+               0.9858,
+               tolerance = 0.0001)
+
+  # count of cases
+  expect_equal(septic_patients %>%
+                 group_by(hospital_id) %>%
+                 summarise(cipro_S = rsi(cipr, interpretation = "S",
+                                         as_percent = TRUE, warning = FALSE),
+                           cipro_n = n_rsi(cipr),
+                           genta_S = rsi(gent, interpretation = "S",
+                                         as_percent = TRUE, warning = FALSE),
+                           genta_n = n_rsi(gent),
+                           combination_S = rsi(cipr, gent, interpretation = "S",
+                                               as_percent = TRUE, warning = FALSE),
+                           combination_n = n_rsi(cipr, gent)) %>%
+                 pull(combination_n),
+               c(138, 474, 170, 464, 183))
+})
+
+test_that("prediction of rsi works", {
+  amox_R <- septic_patients %>%
+    filter(bactid == "ESCCOL") %>%
+    rsi_predict(col_ab = "amox",
+                col_date = "date",
+                info = FALSE) %>%
+    pull("probR")
+  # amox resistance will decrease using dataset `septic_patients`
+  expect_true(amox_R[2] > amox_R[20])
+
+  expect_output(rsi_predict(tbl = filter(septic_patients, bactid == "ESCCOL"),
+                            model = "binomial",
+                            col_ab = "amox",
+                            col_date = "date",
+                            info = TRUE))
+  expect_output(rsi_predict(tbl = filter(septic_patients, bactid == "ESCCOL"),
+                            model = "loglin",
+                            col_ab = "amox",
+                            col_date = "date",
+                            info = TRUE))
+  expect_output(rsi_predict(tbl = filter(septic_patients, bactid == "ESCCOL"),
+                            model = "lin",
+                            col_ab = "amox",
+                            col_date = "date",
+                            info = TRUE))
+
+  expect_error(rsi_predict(tbl = filter(septic_patients, bactid == "ESCCOL"),
+                           model = "INVALID MODEL",
+                           col_ab = "amox",
+                           col_date = "date",
+                           info = FALSE))
+  expect_error(rsi_predict(tbl = filter(septic_patients, bactid == "ESCCOL"),
+                           col_ab = "NOT EXISTING COLUMN",
+                           col_date = "date",
+                           info = FALSE))
+  expect_error(rsi_predict(tbl = filter(septic_patients, bactid == "ESCCOL"),
+                           col_ab = "amox",
+                           col_date = "NOT EXISTING COLUMN",
+                           info = FALSE))
+})