P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-10-31 08:48:16 +01:00
Code Releases Activity

dplyr 0.8.0 support, fixes #7

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2018-12-22 22:39:34 +01:00
parent b937662a97
commit 0b8084871d
29 changed files with 555 additions and 479 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
DESCRIPTION
View File

@@ -1,6 +1,6 @@
Package: AMR Package: AMR
Version: 0.5.0.9005 Version: 0.5.0.9007
Date: 2018-12-15 Date: 2018-12-22
Title: Antimicrobial Resistance Analysis Title: Antimicrobial Resistance Analysis
Authors@R: c( Authors@R: c(
person( person(

12
NAMESPACE
View File

@@ -1,7 +1,6 @@
# Generated by roxygen2: do not edit by hand # Generated by roxygen2: do not edit by hand
S3method(as.data.frame,atc) S3method(as.data.frame,atc)
S3method(as.data.frame,bactid)
S3method(as.data.frame,frequency_tbl) S3method(as.data.frame,frequency_tbl)
S3method(as.data.frame,mo) S3method(as.data.frame,mo)
S3method(as.double,mic) S3method(as.double,mic)
@@ -21,13 +20,11 @@ S3method(plot,frequency_tbl)
S3method(plot,mic) S3method(plot,mic)
S3method(plot,rsi) S3method(plot,rsi)
S3method(print,atc) S3method(print,atc)
S3method(print,bactid)
S3method(print,frequency_tbl) S3method(print,frequency_tbl)
S3method(print,mic) S3method(print,mic)
S3method(print,mo) S3method(print,mo)
S3method(print,rsi) S3method(print,rsi)
S3method(pull,atc) S3method(pull,atc)
S3method(pull,bactid)
S3method(pull,mo) S3method(pull,mo)
S3method(skewness,data.frame) S3method(skewness,data.frame)
S3method(skewness,default) S3method(skewness,default)
@@ -50,7 +47,6 @@ export(age)
export(age_groups) export(age_groups)
export(anti_join_microorganisms) export(anti_join_microorganisms)
export(as.atc) export(as.atc)
export(as.bactid)
export(as.mic) export(as.mic)
export(as.mo) export(as.mo)
export(as.rsi) export(as.rsi)
@@ -68,6 +64,8 @@ export(count_df)
export(eucast_exceptional_phenotypes) export(eucast_exceptional_phenotypes)
export(eucast_rules) export(eucast_rules)
export(facet_rsi) export(facet_rsi)
export(filter_first_isolate)
export(filter_first_weighted_isolate)
export(first_isolate) export(first_isolate)
export(freq) export(freq)
export(frequency_tbl) export(frequency_tbl)
@@ -77,12 +75,10 @@ export(geom_rsi)
export(get_locale) export(get_locale)
export(ggplot_rsi) export(ggplot_rsi)
export(guess_atc) export(guess_atc)
export(guess_bactid)
export(guess_mo) export(guess_mo)
export(inner_join_microorganisms) export(inner_join_microorganisms)
export(interpretive_reading) export(interpretive_reading)
export(is.atc) export(is.atc)
export(is.bactid)
export(is.mic) export(is.mic)
export(is.mo) export(is.mo)
export(is.rsi) export(is.rsi)
@@ -137,7 +133,6 @@ export(skewness)
export(theme_rsi) export(theme_rsi)
export(top_freq) export(top_freq)
exportMethods(as.data.frame.atc) exportMethods(as.data.frame.atc)
exportMethods(as.data.frame.bactid)
exportMethods(as.data.frame.frequency_tbl) exportMethods(as.data.frame.frequency_tbl)
exportMethods(as.data.frame.mo) exportMethods(as.data.frame.mo)
exportMethods(as.double.mic) exportMethods(as.double.mic)
@@ -158,13 +153,11 @@ exportMethods(plot.frequency_tbl)
exportMethods(plot.mic) exportMethods(plot.mic)
exportMethods(plot.rsi) exportMethods(plot.rsi)
exportMethods(print.atc) exportMethods(print.atc)
exportMethods(print.bactid)
exportMethods(print.frequency_tbl) exportMethods(print.frequency_tbl)
exportMethods(print.mic) exportMethods(print.mic)
exportMethods(print.mo) exportMethods(print.mo)
exportMethods(print.rsi) exportMethods(print.rsi)
exportMethods(pull.atc) exportMethods(pull.atc)
exportMethods(pull.bactid)
exportMethods(pull.mo) exportMethods(pull.mo)
exportMethods(skewness) exportMethods(skewness)
exportMethods(skewness.data.frame) exportMethods(skewness.data.frame)
@@ -214,6 +207,7 @@ importFrom(dplyr,left_join)
importFrom(dplyr,mutate) importFrom(dplyr,mutate)
importFrom(dplyr,mutate_all) importFrom(dplyr,mutate_all)
importFrom(dplyr,mutate_at) importFrom(dplyr,mutate_at)
importFrom(dplyr,n)
importFrom(dplyr,n_distinct) importFrom(dplyr,n_distinct)
importFrom(dplyr,progress_estimated) importFrom(dplyr,progress_estimated)
importFrom(dplyr,pull) importFrom(dplyr,pull)

23
NEWS.md
View File

@@ -1,10 +1,25 @@
# 0.5.0.90xx (latest development version) # 0.5.0.90xx (latest development version)
#### New #### New
* **BREAKING**: removed deprecated functions, parameters and references to 'bactid'. Use `as.mo` to identify an MO code.
* Support for `dplyr` version 0.8.0
* Function `mo_failures` to review values that could not be coerced to a valid MO code, using `as.mo`. This latter function will now only show a maximum of 25 uncoerced values. * Function `mo_failures` to review values that could not be coerced to a valid MO code, using `as.mo`. This latter function will now only show a maximum of 25 uncoerced values.
* Function `mo_renamed` to get a list of all returned values from `as.mo` that have had taxonomic renaming * Function `mo_renamed` to get a list of all returned values from `as.mo` that have had taxonomic renaming
* Function `age` to calculate the (patients) age in years * Function `age` to calculate the (patients) age in years
* Function `age_groups` to split ages into custom or predefined groups (like children or elderly). This allows for easier demographic antimicrobial resistance analysis (per age group). * Function `age_groups` to split ages into custom or predefined groups (like children or elderly). This allows for easier demographic antimicrobial resistance analysis per age group.
* Functions `filter_first_isolate` and `filter_first_weighted_isolate()` to shorten and fasten filtering on data sets with antimicrobial results, e.g.:
```r
septic_patients %>% filter_first_isolate()
# or
filter_first_isolate(septic_patients)
```
is the same as:
```r
septic_patients %>%
mutate(only_firsts = first_isolate(septic_patients, ...)) %>%
filter(only_firsts == TRUE) %>%
select(-only_firsts)
```
#### Changed #### Changed
* Improvements for `as.mo`: * Improvements for `as.mo`:
@@ -18,6 +33,8 @@
* Function `first_isolate`: * Function `first_isolate`:
* Will now use a column named like "patid" for the patient ID (parameter `col_patientid`), when this parameter was left blank * Will now use a column named like "patid" for the patient ID (parameter `col_patientid`), when this parameter was left blank
* Will now use a column named like "key(...)ab" or "key(...)antibiotics" for the key antibiotics (parameter `col_keyantibiotics`), when this parameter was left blank * Will now use a column named like "key(...)ab" or "key(...)antibiotics" for the key antibiotics (parameter `col_keyantibiotics`), when this parameter was left blank
* Removed parameter `output_logical`, the function will now always return a logical value
* Renamed parameter `filter_specimen` to `specimen_group`, although using `filter_specimen` will still work
* A note to the manual pages of the `portion` functions, that low counts can influence the outcome and that the `portion` functions may camouflage this, since they only return the portion (albeit being dependent on the `minimum` parameter) * A note to the manual pages of the `portion` functions, that low counts can influence the outcome and that the `portion` functions may camouflage this, since they only return the portion (albeit being dependent on the `minimum` parameter)
* Function `mo_taxonomy` now contains the kingdom too * Function `mo_taxonomy` now contains the kingdom too
* Function `first_isolate` will now use a column named like "patid" for the patient ID, when this parameter was left blank * Function `first_isolate` will now use a column named like "patid" for the patient ID, when this parameter was left blank
@@ -29,7 +46,11 @@
* Now honours the `decimal.mark` setting, which just like `format` defaults to `getOption("OutDec")` * Now honours the `decimal.mark` setting, which just like `format` defaults to `getOption("OutDec")`
* The new `big.mark` parameter will at default be `","` when `decimal.mark = "."` and `"."` otherwise * The new `big.mark` parameter will at default be `","` when `decimal.mark = "."` and `"."` otherwise
* Fix for header text where all observations are `NA` * Fix for header text where all observations are `NA`
* New parameter `droplevels` to exclude empty factor levels when input is a factor
* Factor levels will be in header when present
* Function `scale_y_percent` now has the `limits` parameter * Function `scale_y_percent` now has the `limits` parameter
* Automatic parameter filling for `mdro`, `key_antibiotics` and `eucast_rules`
* Updated examples for resistance prediction (`resistance_predict` function)
#### Other #### Other
* Updated licence text to emphasise GPL 2.0 and that this is an R package. * Updated licence text to emphasise GPL 2.0 and that this is an R package.

32
R/age.R
View File

@@ -19,28 +19,28 @@
#' Age in years of individuals #' Age in years of individuals
#' #'
#' Calculates age in years based on a reference date, which is the sytem time at default. #' Calculates age in years based on a reference date, which is the sytem time at default.
#' @param x date(s) - will be coerced with \code{\link{as.POSIXlt}} #' @param x date(s), will be coerced with \code{\link{as.POSIXlt}}
#' @param y reference date(s) - defaults to \code{\link{Sys.Date}} - will be coerced with \code{\link{as.POSIXlt}} #' @param reference reference date(s) (defaults to today), will be coerced with \code{\link{as.POSIXlt}}
#' @return Integer (no decimals) #' @return Integer (no decimals)
#' @seealso age_groups #' @seealso \code{\link{age_groups}} to splits age into groups
#' @importFrom dplyr if_else #' @importFrom dplyr if_else
#' @export #' @export
age <- function(x, y = Sys.Date()) { age <- function(x, reference = Sys.Date()) {
if (length(x) != length(y)) { if (length(x) != length(reference)) {
if (length(y) == 1) { if (length(reference) == 1) {
y <- rep(y, length(x)) reference <- rep(reference, length(x))
} else { } else {
stop("`x` and `y` must be of same length, or `y` must be of length 1.") stop("`x` and `reference` must be of same length, or `reference` must be of length 1.")
} }
} }
x <- base::as.POSIXlt(x) x <- base::as.POSIXlt(x)
y <- base::as.POSIXlt(y) reference <- base::as.POSIXlt(reference)
if (any(y < x)) { if (any(reference < x)) {
stop("`y` cannot be lower (older) than `x`.") stop("`reference` cannot be lower (older) than `x`.")
} }
years_gap <- y$year - x$year years_gap <- reference$year - x$year
# from https://stackoverflow.com/a/25450756/4575331 # from https://stackoverflow.com/a/25450756/4575331
ages <- if_else(y$mon < x$mon | (y$mon == x$mon & y$mday < x$mday), ages <- if_else(reference$mon < x$mon | (reference$mon == x$mon & reference$mday < x$mday),
as.integer(years_gap - 1), as.integer(years_gap - 1),
as.integer(years_gap)) as.integer(years_gap))
if (any(ages > 120)) { if (any(ages > 120)) {
@@ -51,9 +51,9 @@ age <- function(x, y = Sys.Date()) {
#' Split ages into age groups #' Split ages into age groups
#' #'
#' Splits ages into groups defined by the \code{split} parameter. #' Split ages into age groups defined by the \code{split} parameter. This allows for easier demographic (antimicrobial resistance) analysis.
#' @param x age, e.g. calculated with \code{\link{age}} #' @param x age, e.g. calculated with \code{\link{age}}
#' @param split_at values to split \code{x}, defaults to 0-11, 12-24, 26-54, 55-74 and 75+. See Details. #' @param split_at values to split \code{x} at, defaults to age groups 0-11, 12-24, 26-54, 55-74 and 75+. See Details.
#' @details To split ages, the input can be: #' @details To split ages, the input can be:
#' \itemize{ #' \itemize{
#' \item{A numeric vector. A vector of \code{c(10, 20)} will split on 0-9, 10-19 and 20+. A value of only \code{50} will split on 0-49 and 50+. #' \item{A numeric vector. A vector of \code{c(10, 20)} will split on 0-9, 10-19 and 20+. A value of only \code{50} will split on 0-49 and 50+.
@@ -68,7 +68,7 @@ age <- function(x, y = Sys.Date()) {
#' } #' }
#' @keywords age_group age #' @keywords age_group age
#' @return Ordered \code{\link{factor}} #' @return Ordered \code{\link{factor}}
#' @seealso age #' @seealso \code{\link{age}} to determine ages based on one or more reference dates
#' @export #' @export
#' @examples #' @examples
#' ages <- c(3, 8, 16, 54, 31, 76, 101, 43, 21) #' ages <- c(3, 8, 16, 54, 31, 76, 101, 43, 21)

51
R/deprecated.R
View File

@@ -23,57 +23,6 @@
#' @keywords internal #' @keywords internal
#' @name AMR-deprecated #' @name AMR-deprecated
#' @rdname AMR-deprecated #' @rdname AMR-deprecated
as.bactid <- function(...) {
.Deprecated("as.mo", package = "AMR")
as.mo(...)
}
#' @rdname AMR-deprecated
#' @export
is.bactid <- function(...) {
.Deprecated(new = "is.mo", package = "AMR")
is.mo(...)
}
#' @rdname AMR-deprecated
#' @export
guess_bactid <- function(...) {
.Deprecated(new = "guess_mo", package = "AMR")
guess_mo(...)
}
#' @exportMethod print.bactid
#' @export
#' @noRd
print.bactid <- function(x, ...) {
cat("Class 'bactid'\n")
print.default(as.character(x), quote = FALSE)
}
#' @exportMethod as.data.frame.bactid
#' @export
#' @noRd
as.data.frame.bactid <- function (x, ...) {
# same as as.data.frame.character but with removed stringsAsFactors
nm <- paste(deparse(substitute(x), width.cutoff = 500L),
collapse = " ")
if (!"nm" %in% names(list(...))) {
as.data.frame.vector(x, ..., nm = nm)
} else {
as.data.frame.vector(x, ...)
}
}
#' @exportMethod pull.bactid
#' @export
#' @importFrom dplyr pull
#' @noRd
pull.bactid <- function(.data, ...) {
pull(as.data.frame(.data), ...)
}
#' @rdname AMR-deprecated
#' @export
ratio <- function(x, ratio) { ratio <- function(x, ratio) {
.Deprecated(package = "AMR") .Deprecated(package = "AMR")

24
R/eucast_rules.R
View File

@@ -24,7 +24,6 @@
#' @param rules a character vector that specifies which rules should be applied - one or more of \code{c("breakpoints", "expert", "other", "all")} #' @param rules a character vector that specifies which rules should be applied - one or more of \code{c("breakpoints", "expert", "other", "all")}
#' @param verbose a logical to indicate whether extensive info should be returned as a \code{data.frame} with info about which rows and columns are effected #' @param verbose a logical to indicate whether extensive info should be returned as a \code{data.frame} with info about which rows and columns are effected
#' @param amcl,amik,amox,ampi,azit,azlo,aztr,cefa,cfep,cfot,cfox,cfra,cfta,cftr,cfur,chlo,cipr,clar,clin,clox,coli,czol,dapt,doxy,erta,eryt,fosf,fusi,gent,imip,kana,levo,linc,line,mero,mezl,mino,moxi,nali,neom,neti,nitr,norf,novo,oflo,oxac,peni,pipe,pita,poly,pris,qida,rifa,roxi,siso,teic,tetr,tica,tige,tobr,trim,trsu,vanc column name of an antibiotic, see Antibiotics #' @param amcl,amik,amox,ampi,azit,azlo,aztr,cefa,cfep,cfot,cfox,cfra,cfta,cftr,cfur,chlo,cipr,clar,clin,clox,coli,czol,dapt,doxy,erta,eryt,fosf,fusi,gent,imip,kana,levo,linc,line,mero,mezl,mino,moxi,nali,neom,neti,nitr,norf,novo,oflo,oxac,peni,pipe,pita,poly,pris,qida,rifa,roxi,siso,teic,tetr,tica,tige,tobr,trim,trsu,vanc column name of an antibiotic, see Antibiotics
#' @param col_bactid deprecated, use \code{col_mo} instead.
#' @param ... parameters that are passed on to \code{eucast_rules} #' @param ... parameters that are passed on to \code{eucast_rules}
#' @inheritParams first_isolate #' @inheritParams first_isolate
#' @section Antibiotics: #' @section Antibiotics:
@@ -217,8 +216,7 @@ eucast_rules <- function(tbl,
tobr = 'tobr', tobr = 'tobr',
trim = 'trim', trim = 'trim',
trsu = 'trsu', trsu = 'trsu',
vanc = 'vanc', vanc = 'vanc') {
col_bactid = NULL) {
EUCAST_VERSION_BREAKPOINTS <- "8.1, 2018" EUCAST_VERSION_BREAKPOINTS <- "8.1, 2018"
EUCAST_VERSION_EXPERT_RULES <- "3.1, 2016" EUCAST_VERSION_EXPERT_RULES <- "3.1, 2016"
@@ -229,12 +227,12 @@ eucast_rules <- function(tbl,
# try to find columns based on type # try to find columns based on type
# -- mo # -- mo
if (!is.null(col_bactid)) { if (is.null(col_mo) & "mo" %in% lapply(tbl, class)) {
col_mo <- col_bactid col_mo <- colnames(tbl)[lapply(tbl, class) == "mo"][1]
warning("Use of `col_bactid` is deprecated. Use `col_mo` instead.") message(blue(paste0("NOTE: Using column `", bold(col_mo), "` as input for `col_mo`.")))
} else if (is.null(col_mo) & "mo" %in% lapply(tbl, class)) { }
col_mo <- colnames(tbl)[lapply(tbl, class) == "mo"] if (is.null(col_mo)) {
message("NOTE: Using column `", col_mo, "` as input for `col_mo`.") stop("`col_mo` must be set.", call. = FALSE)
} }
if (!all(rules %in% c("breakpoints", "expert", "other", "all"))) { if (!all(rules %in% c("breakpoints", "expert", "other", "all"))) {
@@ -1731,12 +1729,14 @@ eucast_rules <- function(tbl,
} else { } else {
colour <- blue colour <- blue
} }
decimal.mark <- getOption("OutDec")
big.mark <- ifelse(decimal.mark != ",", ",", ".")
cat(bold(paste('\n=> EUCAST rules', paste0(wouldve, 'affected'), cat(bold(paste('\n=> EUCAST rules', paste0(wouldve, 'affected'),
amount_affected_rows %>% length() %>% format(big.mark = ","), amount_affected_rows %>% length() %>% format(big.mark = big.mark, decimal.mark = decimal.mark),
'out of', nrow(tbl_original) %>% format(big.mark = ","), 'out of', nrow(tbl_original) %>% format(big.mark = big.mark, decimal.mark = decimal.mark),
'rows ->', 'rows ->',
colour(paste0(wouldve, 'changed'), colour(paste0(wouldve, 'changed'),
amount_changed %>% format(big.mark = ","), 'test results.\n\n')))) amount_changed %>% format(big.mark = big.mark, decimal.mark = decimal.mark), 'test results.\n\n'))))
} }
if (verbose == TRUE) { if (verbose == TRUE) {

209
R/first_isolate.R
View File

@@ -29,18 +29,32 @@
#' @param col_keyantibiotics column name of the key antibiotics to determine first \emph{weighted} isolates, see \code{\link{key_antibiotics}}. Defaults to the first column that starts with 'key' followed by 'ab' or 'antibiotics' (case insensitive). Use \code{col_keyantibiotics = FALSE} to prevent this. #' @param col_keyantibiotics column name of the key antibiotics to determine first \emph{weighted} isolates, see \code{\link{key_antibiotics}}. Defaults to the first column that starts with 'key' followed by 'ab' or 'antibiotics' (case insensitive). Use \code{col_keyantibiotics = FALSE} to prevent this.
#' @param episode_days episode in days after which a genus/species combination will be determined as 'first isolate' again #' @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 (case-insensitive) #' @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 icu_exclude logical whether ICU isolates should be excluded (rows with value \code{TRUE} in column \code{col_icu})
#' @param filter_specimen specimen group or type that should be excluded #' @param specimen_group value in column \code{col_specimen} to filter on
#' @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 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 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 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 #' @param info print progress
#' @param col_bactid (deprecated, use \code{col_mo} instead) #' @param ... parameters passed on to the \code{first_isolate} function
#' @param col_genus (deprecated, use \code{col_mo} instead) column name of the genus of the microorganisms
#' @param col_species (deprecated, use \code{col_mo} instead) column name of the species of the microorganisms
#' @details \strong{WHY THIS IS SO IMPORTANT} \cr #' @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}. #' 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}.
#'
#' The function \code{filter_first_isolate} is essentially equal to:
#' \preformatted{
#' tbl \%>\%
#' mutate(only_firsts = first_isolate(tbl, ...)) \%>\%
#' filter(only_firsts == TRUE) \%>\%
#' select(-only_firsts)
#' }
#' The function \code{filter_first_weighted_isolate} is essentially equal to:
#' \preformatted{
#' tbl \%>\%
#' mutate(keyab = key_antibiotics(.)) \%>\%
#' mutate(only_weighted_firsts = first_isolate(tbl,
#' col_keyantibiotics = "keyab", ...)) \%>\%
#' filter(only_weighted_firsts == TRUE) \%>\%
#' select(-only_weighted_firsts)
#' }
#' @section Key antibiotics: #' @section Key antibiotics:
#' There are two ways to determine whether isolates can be included as first \emph{weighted} isolates which will give generally the same results: \cr #' There are two ways to determine whether isolates can be included as first \emph{weighted} isolates which will give generally the same results: \cr
#' #'
@@ -49,31 +63,42 @@
#' #'
#' \strong{2. Using} \code{type = "points"} \strong{and parameter} \code{points_threshold} \cr #' \strong{2. Using} \code{type = "points"} \strong{and parameter} \code{points_threshold} \cr
#' 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. #' 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.
#' @rdname first_isolate
#' @keywords isolate isolates first #' @keywords isolate isolates first
#' @seealso \code{\link{key_antibiotics}} #' @seealso \code{\link{key_antibiotics}}
#' @export #' @export
#' @importFrom dplyr arrange_at lag between row_number filter mutate arrange #' @importFrom dplyr arrange_at lag between row_number filter mutate arrange
#' @return A vector to add to table, see Examples. #' @importFrom crayon blue bold silver
#' @return Logical vector
#' @source Methodology of this function is based on: \strong{M39 Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data, 4th Edition}, 2014, \emph{Clinical and Laboratory Standards Institute (CLSI)}. \url{https://clsi.org/standards/products/microbiology/documents/m39/}. #' @source Methodology of this function is based on: \strong{M39 Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data, 4th Edition}, 2014, \emph{Clinical and Laboratory Standards Institute (CLSI)}. \url{https://clsi.org/standards/products/microbiology/documents/m39/}.
#' @examples #' @examples
#' # septic_patients is a dataset available in the AMR package. It is true, genuine data. #' # septic_patients is a dataset available in the AMR package. It is true, genuine data.
#' ?septic_patients #' ?septic_patients
#' #'
#' library(dplyr) #' library(dplyr)
#' my_patients <- septic_patients %>% #' # Filter on first isolates:
#' septic_patients %>%
#' mutate(first_isolate = first_isolate(., #' mutate(first_isolate = first_isolate(.,
#' col_date = "date", #' col_date = "date",
#' col_patient_id = "patient_id", #' col_patient_id = "patient_id",
#' col_mo = "mo")) #' col_mo = "mo")) %>%
#' filter(first_isolate == TRUE)
#'
#' # Which can be shortened to:
#' septic_patients %>%
#' filter_first_isolate()
#' # or for first weighted isolates:
#' septic_patients %>%
#' filter_first_weighted_isolate()
#' #'
#' # Now let's see if first isolates matter: #' # Now let's see if first isolates matter:
#' A <- my_patients %>% #' A <- septic_patients %>%
#' group_by(hospital_id) %>% #' group_by(hospital_id) %>%
#' summarise(count = n_rsi(gent), # gentamicin availability #' summarise(count = n_rsi(gent), # gentamicin availability
#' resistance = portion_IR(gent)) # gentamicin resistance #' resistance = portion_IR(gent)) # gentamicin resistance
#' #'
#' B <- my_patients %>% #' B <- septic_patients %>%
#' filter(first_isolate == TRUE) %>% # the 1st isolate filter #' filter_first_weighted_isolate() %>% # the 1st isolate filter
#' group_by(hospital_id) %>% #' group_by(hospital_id) %>%
#' summarise(count = n_rsi(gent), # gentamicin availability #' summarise(count = n_rsi(gent), # gentamicin availability
#' resistance = portion_IR(gent)) # gentamicin resistance #' resistance = portion_IR(gent)) # gentamicin resistance
@@ -83,6 +108,7 @@
#' # Gentamicin resitance in hospital D appears to be 5.4% higher than #' # Gentamicin resitance in hospital D appears to be 5.4% higher than
#' # when you (erroneously) would have used all isolates! #' # when you (erroneously) would have used all isolates!
#' #'
#'
#' ## OTHER EXAMPLES: #' ## OTHER EXAMPLES:
#' #'
#' \dontrun{ #' \dontrun{
@@ -99,29 +125,29 @@
#' #'
#' tbl$first_blood_isolate <- #' tbl$first_blood_isolate <-
#' first_isolate(tbl, #' first_isolate(tbl,
#' filter_specimen = 'Blood') #' specimen_group = 'Blood')
#' #'
#' tbl$first_blood_isolate_weighed <- #' tbl$first_blood_isolate_weighed <-
#' first_isolate(tbl, #' first_isolate(tbl,
#' filter_specimen = 'Blood', #' specimen_group = 'Blood',
#' col_keyantibiotics = 'keyab') #' col_keyantibiotics = 'keyab')
#' #'
#' tbl$first_urine_isolate <- #' tbl$first_urine_isolate <-
#' first_isolate(tbl, #' first_isolate(tbl,
#' filter_specimen = 'Urine') #' specimen_group = 'Urine')
#' #'
#' tbl$first_urine_isolate_weighed <- #' tbl$first_urine_isolate_weighed <-
#' first_isolate(tbl, #' first_isolate(tbl,
#' filter_specimen = 'Urine', #' specimen_group = 'Urine',
#' col_keyantibiotics = 'keyab') #' col_keyantibiotics = 'keyab')
#' #'
#' tbl$first_resp_isolate <- #' tbl$first_resp_isolate <-
#' first_isolate(tbl, #' first_isolate(tbl,
#' filter_specimen = 'Respiratory') #' specimen_group = 'Respiratory')
#' #'
#' tbl$first_resp_isolate_weighed <- #' tbl$first_resp_isolate_weighed <-
#' first_isolate(tbl, #' first_isolate(tbl,
#' filter_specimen = 'Respiratory', #' specimen_group = 'Respiratory',
#' col_keyantibiotics = 'keyab') #' col_keyantibiotics = 'keyab')
#' } #' }
first_isolate <- function(tbl, first_isolate <- function(tbl,
@@ -135,28 +161,34 @@ first_isolate <- function(tbl,
episode_days = 365, episode_days = 365,
testcodes_exclude = NULL, testcodes_exclude = NULL,
icu_exclude = FALSE, icu_exclude = FALSE,
filter_specimen = NULL, specimen_group = NULL,
output_logical = TRUE,
type = "keyantibiotics", type = "keyantibiotics",
ignore_I = TRUE, ignore_I = TRUE,
points_threshold = 2, points_threshold = 2,
info = TRUE, info = TRUE,
col_bactid = NULL, ...) {
col_genus = NULL,
col_species = NULL) {
if (!is.data.frame(tbl)) { if (!is.data.frame(tbl)) {
stop("`tbl` must be a data frame.", call. = FALSE) stop("`tbl` must be a data.frame.", call. = FALSE)
}
dots <- unlist(list(...))
if (length(dots) != 0) {
# backwards compatibility with old parameters
dots.names <- dots %>% names()
if ('filter_specimen' %in% dots.names) {
specimen_group <- dots[which(dots.names == 'filter_specimen')]
}
} }
# try to find columns based on type # try to find columns based on type
# -- mo # -- mo
if (!is.null(col_bactid)) { if (is.null(col_mo) & "mo" %in% lapply(tbl, class)) {
col_mo <- col_bactid
warning("Use of `col_bactid` is deprecated. Use `col_mo` instead.")
} else if (is.null(col_mo) & "mo" %in% lapply(tbl, class)) {
col_mo <- colnames(tbl)[lapply(tbl, class) == "mo"][1] col_mo <- colnames(tbl)[lapply(tbl, class) == "mo"][1]
message("NOTE: Using column `", col_mo, "` as input for `col_mo`.") message(blue(paste0("NOTE: Using column `", bold(col_mo), "` as input for `col_mo`.")))
}
if (is.null(col_mo)) {
stop("`col_mo` must be set.", call. = FALSE)
} }
# -- date # -- date
@@ -164,7 +196,7 @@ first_isolate <- function(tbl,
for (i in 1:ncol(tbl)) { for (i in 1:ncol(tbl)) {
if ("Date" %in% class(tbl %>% pull(i)) | "POSIXct" %in% class(tbl %>% pull(i))) { if ("Date" %in% class(tbl %>% pull(i)) | "POSIXct" %in% class(tbl %>% pull(i))) {
col_date <- colnames(tbl)[i] col_date <- colnames(tbl)[i]
message("NOTE: Using column `", col_date, "` as input for `col_date`.") message(blue(paste0("NOTE: Using column `", bold(col_date), "` as input for `col_date`.")))
break break
} }
} }
@@ -178,7 +210,7 @@ first_isolate <- function(tbl,
# -- patient id # -- patient id
if (is.null(col_patient_id) & any(colnames(tbl) %like% "^(patient|patid)")) { if (is.null(col_patient_id) & any(colnames(tbl) %like% "^(patient|patid)")) {
col_patient_id <- colnames(tbl)[colnames(tbl) %like% "^(patient|patid)"][1] col_patient_id <- colnames(tbl)[colnames(tbl) %like% "^(patient|patid)"][1]
message("NOTE: Using column `", col_patient_id, "` as input for `col_patient_id`.") message(blue(paste0("NOTE: Using column `", bold(col_patient_id), "` as input for `col_patient_id`.")))
} }
if (is.null(col_patient_id)) { if (is.null(col_patient_id)) {
stop("`col_patient_id` must be set.", call. = FALSE) stop("`col_patient_id` must be set.", call. = FALSE)
@@ -187,18 +219,12 @@ first_isolate <- function(tbl,
# -- key antibiotics # -- key antibiotics
if (is.null(col_keyantibiotics) & any(colnames(tbl) %like% "^key.*(ab|antibiotics)")) { if (is.null(col_keyantibiotics) & any(colnames(tbl) %like% "^key.*(ab|antibiotics)")) {
col_keyantibiotics <- colnames(tbl)[colnames(tbl) %like% "^key.*(ab|antibiotics)"][1] col_keyantibiotics <- colnames(tbl)[colnames(tbl) %like% "^key.*(ab|antibiotics)"][1]
message("NOTE: Using column `", col_keyantibiotics, "` as input for `col_keyantibiotics`. Use col_keyantibiotics = FALSE to prevent this.") message(blue(paste0("NOTE: Using column `", bold(col_keyantibiotics), "` as input for `col_keyantibiotics`. Use ", bold("col_keyantibiotics = FALSE"), " to prevent this.")))
} }
if (isFALSE(col_keyantibiotics)) { if (isFALSE(col_keyantibiotics)) {
col_keyantibiotics <- NULL col_keyantibiotics <- NULL
} }
# col_mo OR col_genus+col_species must be available
if (is.null(col_mo) & (is.null(col_genus) | is.null(col_species))) {
stop("`col_mo` or both `col_genus` and `col_species` must be set.", call. = FALSE)
}
# check if columns exist # check if columns exist
check_columns_existance <- function(column, tblname = tbl) { check_columns_existance <- function(column, tblname = tbl) {
if (NROW(tblname) <= 1 | NCOL(tblname) <= 1) { if (NROW(tblname) <= 1 | NCOL(tblname) <= 1) {
@@ -215,27 +241,23 @@ first_isolate <- function(tbl,
check_columns_existance(col_date) check_columns_existance(col_date)
check_columns_existance(col_patient_id) check_columns_existance(col_patient_id)
check_columns_existance(col_mo) check_columns_existance(col_mo)
check_columns_existance(col_genus)
check_columns_existance(col_species)
check_columns_existance(col_testcode) check_columns_existance(col_testcode)
check_columns_existance(col_icu) check_columns_existance(col_icu)
check_columns_existance(col_keyantibiotics) check_columns_existance(col_keyantibiotics)
if (!is.null(col_mo)) {
# join to microorganisms data set # join to microorganisms data set
tbl <- tbl %>% tbl <- tbl %>%
mutate_at(vars(col_mo), as.mo) %>% mutate_at(vars(col_mo), as.mo) %>%
left_join_microorganisms(by = col_mo) left_join_microorganisms(by = col_mo)
col_genus <- "genus" col_genus <- "genus"
col_species <- "species" col_species <- "species"
}
if (is.null(col_testcode)) { if (is.null(col_testcode)) {
testcodes_exclude <- NULL testcodes_exclude <- NULL
} }
# remove testcodes # remove testcodes
if (!is.null(testcodes_exclude) & info == TRUE) { if (!is.null(testcodes_exclude) & info == TRUE) {
cat('[Criteria] Excluded test codes:\n', toString(testcodes_exclude), '\n') cat('[Criterion] Excluded test codes:\n', toString(testcodes_exclude), '\n')
} }
if (is.null(col_icu)) { if (is.null(col_icu)) {
@@ -246,14 +268,14 @@ first_isolate <- function(tbl,
} }
if (is.null(col_specimen)) { if (is.null(col_specimen)) {
filter_specimen <- NULL specimen_group <- NULL
} }
# filter on specimen group and keyantibiotics when they are filled in # filter on specimen group and keyantibiotics when they are filled in
if (!is.null(filter_specimen)) { if (!is.null(specimen_group)) {
check_columns_existance(col_specimen, tbl) check_columns_existance(col_specimen, tbl)
if (info == TRUE) { if (info == TRUE) {
cat('[Criteria] Excluded other than specimen group \'', filter_specimen, '\'\n', sep = '') cat('[Criterion] Excluded other than specimen group \'', specimen_group, '\'\n', sep = '')
} }
} }
if (!is.null(col_keyantibiotics)) { if (!is.null(col_keyantibiotics)) {
@@ -274,11 +296,11 @@ first_isolate <- function(tbl,
mutate(species = if_else(is.na(species) | species == "(no MO)", "", species), mutate(species = if_else(is.na(species) | species == "(no MO)", "", species),
genus = if_else(is.na(genus) | genus == "(no MO)", "", genus)) genus = if_else(is.na(genus) | genus == "(no MO)", "", genus))
if (is.null(filter_specimen)) { if (is.null(specimen_group)) {
# not filtering on specimen # not filtering on specimen
if (icu_exclude == FALSE) { if (icu_exclude == FALSE) {
if (info == TRUE & !is.null(col_icu)) { if (info == TRUE & !is.null(col_icu)) {
cat('[Criteria] Included isolates from ICU.\n') cat('[Criterion] Included isolates from ICU.\n')
} }
tbl <- tbl %>% tbl <- tbl %>%
arrange_at(c(col_patient_id, arrange_at(c(col_patient_id,
@@ -289,7 +311,7 @@ first_isolate <- function(tbl,
row.end <- nrow(tbl) row.end <- nrow(tbl)
} else { } else {
if (info == TRUE) { if (info == TRUE) {
cat('[Criteria] Excluded isolates from ICU.\n') cat('[Criterion] Excluded isolates from ICU.\n')
} }
tbl <- tbl %>% tbl <- tbl %>%
arrange_at(c(col_icu, arrange_at(c(col_icu,
@@ -310,7 +332,7 @@ first_isolate <- function(tbl,
# filtering on specimen and only analyse these row to save time # filtering on specimen and only analyse these row to save time
if (icu_exclude == FALSE) { if (icu_exclude == FALSE) {
if (info == TRUE & !is.null(col_icu)) { if (info == TRUE & !is.null(col_icu)) {
cat('[Criteria] Included isolates from ICU.\n') cat('[Criterion] Included isolates from ICU.\n')
} }
tbl <- tbl %>% tbl <- tbl %>%
arrange_at(c(col_specimen, arrange_at(c(col_specimen,
@@ -319,14 +341,14 @@ first_isolate <- function(tbl,
col_species, col_species,
col_date)) col_date))
suppressWarnings( suppressWarnings(
row.start <- which(tbl %>% pull(col_specimen) == filter_specimen) %>% min(na.rm = TRUE) row.start <- which(tbl %>% pull(col_specimen) == specimen_group) %>% min(na.rm = TRUE)
) )
suppressWarnings( suppressWarnings(
row.end <- which(tbl %>% pull(col_specimen) == filter_specimen) %>% max(na.rm = TRUE) row.end <- which(tbl %>% pull(col_specimen) == specimen_group) %>% max(na.rm = TRUE)
) )
} else { } else {
if (info == TRUE) { if (info == TRUE) {
cat('[Criteria] Excluded isolates from ICU.\n') cat('[Criterion] Excluded isolates from ICU.\n')
} }
tbl <- tbl %>% tbl <- tbl %>%
arrange_at(c(col_icu, arrange_at(c(col_icu,
@@ -336,11 +358,11 @@ first_isolate <- function(tbl,
col_species, col_species,
col_date)) col_date))
suppressWarnings( suppressWarnings(
row.start <- which(tbl %>% pull(col_specimen) == filter_specimen row.start <- which(tbl %>% pull(col_specimen) == specimen_group
& tbl %>% pull(col_icu) == FALSE) %>% min(na.rm = TRUE) & tbl %>% pull(col_icu) == FALSE) %>% min(na.rm = TRUE)
) )
suppressWarnings( suppressWarnings(
row.end <- which(tbl %>% pull(col_specimen) == filter_specimen row.end <- which(tbl %>% pull(col_specimen) == specimen_group
& tbl %>% pull(col_icu) == FALSE) %>% max(na.rm = TRUE) & tbl %>% pull(col_icu) == FALSE) %>% max(na.rm = TRUE)
) )
} }
@@ -352,12 +374,10 @@ first_isolate <- function(tbl,
message('No isolates found.') message('No isolates found.')
} }
# NAs where genus is unavailable # NAs where genus is unavailable
tbl <- tbl %>% return(tbl %>%
mutate(real_first_isolate = if_else(genus == '', NA, FALSE)) mutate(real_first_isolate = if_else(genus == '', NA, FALSE)) %>%
if (output_logical == FALSE) { pull(real_first_isolate)
tbl$real_first_isolate <- tbl %>% pull(real_first_isolate) %>% as.integer() )
}
return(tbl %>% pull(real_first_isolate))
} }
# suppress warnings because dplyr want us to use library(dplyr) when using filter(row_number()) # suppress warnings because dplyr want us to use library(dplyr) when using filter(row_number())
@@ -388,14 +408,14 @@ first_isolate <- function(tbl,
weighted.notice <- 'weighted ' weighted.notice <- 'weighted '
if (info == TRUE) { if (info == TRUE) {
if (type == 'keyantibiotics') { if (type == 'keyantibiotics') {
cat('[Criteria] Inclusion based on key antibiotics, ') cat('[Criterion] Inclusion based on key antibiotics, ')
if (ignore_I == FALSE) { if (ignore_I == FALSE) {
cat('not ') cat('not ')
} }
cat('ignoring I.\n') cat('ignoring I.\n')
} }
if (type == 'points') { if (type == 'points') {
cat(paste0('[Criteria] Inclusion based on key antibiotics, using points threshold of ' cat(paste0('[Criterion] Inclusion based on key antibiotics, using points threshold of '
, points_threshold, '.\n')) , points_threshold, '.\n'))
} }
} }
@@ -458,19 +478,62 @@ first_isolate <- function(tbl,
pull(real_first_isolate) pull(real_first_isolate)
if (info == TRUE) { if (info == TRUE) {
message(paste0('Found ', decimal.mark <- getOption("OutDec")
all_first %>% sum(na.rm = TRUE), big.mark <- ifelse(decimal.mark != ",", ",", ".")
' first ', weighted.notice, 'isolates (', n_found <- base::sum(all_first, na.rm = TRUE)
(all_first %>% sum(na.rm = TRUE) / scope.size) %>% percent(), p_found_total <- percent(n_found / nrow(tbl), force_zero = TRUE)
' of isolates in scope [where genus was not empty] and ', p_found_scope <- percent(n_found / scope.size, force_zero = TRUE)
(all_first %>% sum(na.rm = TRUE) / tbl %>% nrow()) %>% percent(), # mark up number of found
' of total)')) n_found <- base::format(n_found, big.mark = big.mark, decimal.mark = decimal.mark)
if (p_found_total != p_found_scope) {
msg_txt <- paste0("=> Found ",
bold(paste0(n_found, " first ", weighted.notice, "isolates")),
" (", p_found_scope, " within scope and ", p_found_total, " of total)")
} else {
msg_txt <- paste0("=> Found ",
bold(paste0(n_found, " first ", weighted.notice, "isolates")),
" (", p_found_total, " of total)")
} }
base::message(msg_txt)
if (output_logical == FALSE) {
all_first <- all_first %>% as.integer()
} }
all_first all_first
} }
#' @rdname first_isolate
#' @importFrom dplyr filter
#' @export
filter_first_isolate <- function(tbl,
col_date = NULL,
col_patient_id = NULL,
col_mo = NULL,
...) {
filter(tbl, first_isolate(tbl = tbl,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
...))
}
#' @rdname first_isolate
#' @importFrom dplyr %>% mutate filter
#' @export
filter_first_weighted_isolate <- function(tbl,
col_date = NULL,
col_patient_id = NULL,
col_mo = NULL,
col_keyantibiotics = NULL,
...) {
tbl_keyab <- tbl %>%
mutate(keyab = suppressMessages(key_antibiotics(.,
col_mo = col_mo,
...))) %>%
mutate(firsts = first_isolate(.,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
col_keyantibiotics = "keyab",
...))
tbl[which(tbl_keyab$firsts == TRUE),]
}

230
R/freq.R
View File

@@ -31,6 +31,7 @@
#' @param header a logical value indicating whether an informative header should be printed #' @param header a logical value indicating whether an informative header should be printed
#' @param title text to show above frequency table, at default to tries to coerce from the variables passed to \code{x} #' @param title text to show above frequency table, at default to tries to coerce from the variables passed to \code{x}
#' @param na a character string to should be used to show empty (\code{NA}) values (only useful when \code{na.rm = FALSE}) #' @param na a character string to should be used to show empty (\code{NA}) values (only useful when \code{na.rm = FALSE})
#' @param droplevels a logical value indicating whether in factors empty levels should be dropped
#' @param sep a character string to separate the terms when selecting multiple columns #' @param sep a character string to separate the terms when selecting multiple columns
#' @inheritParams base::format #' @inheritParams base::format
#' @param f a frequency table #' @param f a frequency table
@@ -56,11 +57,12 @@
#' \item{Median, using \code{\link[stats]{median}}, with percentage since oldest} #' \item{Median, using \code{\link[stats]{median}}, with percentage since oldest}
#' } #' }
#' #'
#' In factors, all factor levels that are not existing in the input data will be dropped.
#' #'
#' The function \code{top_freq} uses \code{\link[dplyr]{top_n}} internally and will include more than \code{n} rows if there are ties. #' The function \code{top_freq} uses \code{\link[dplyr]{top_n}} internally and will include more than \code{n} rows if there are ties.
#' @importFrom stats fivenum sd mad #' @importFrom stats fivenum sd mad
#' @importFrom grDevices boxplot.stats #' @importFrom grDevices boxplot.stats
#' @importFrom dplyr %>% arrange arrange_at desc filter_at funs group_by mutate mutate_at n_distinct pull select summarise tibble ungroup vars all_vars #' @importFrom dplyr %>% arrange arrange_at desc filter_at funs group_by mutate mutate_at n n_distinct pull select summarise tibble ungroup vars all_vars
#' @importFrom utils browseVignettes #' @importFrom utils browseVignettes
#' @importFrom hms is.hms #' @importFrom hms is.hms
#' @importFrom crayon red green silver #' @importFrom crayon red green silver
@@ -183,6 +185,7 @@ frequency_tbl <- function(x,
header = !markdown, header = !markdown,
title = NULL, title = NULL,
na = "<NA>", na = "<NA>",
droplevels = TRUE,
sep = " ", sep = " ",
decimal.mark = getOption("OutDec"), decimal.mark = getOption("OutDec"),
big.mark = ifelse(decimal.mark != ",", ",", ".")) { big.mark = ifelse(decimal.mark != ",", ",", ".")) {
@@ -190,23 +193,23 @@ frequency_tbl <- function(x,
mult.columns <- 0 mult.columns <- 0
x.group = character(0) x.group = character(0)
df <- NULL df <- NULL
# x_haslevels <- !is.null(levels(x))
x.name <- NULL x.name <- NULL
cols <- NULL cols <- NULL
if (any(class(x) == 'list')) { if (any(class(x) == "list")) {
cols <- names(x) cols <- names(x)
x <- as.data.frame(x, stringsAsFactors = FALSE) x <- as.data.frame(x, stringsAsFactors = FALSE)
x.name <- "a list" x.name <- "a list"
} else if (any(class(x) == 'matrix')) { } else if (any(class(x) == "matrix")) {
x <- as.data.frame(x, stringsAsFactors = FALSE) x <- as.data.frame(x, stringsAsFactors = FALSE)
x.name <- "a matrix" x.name <- "a matrix"
cols <- colnames(x) cols <- colnames(x)
if (all(cols %like% 'V[0-9]')) { if (all(cols %like% "V[0-9]")) {
cols <- NULL cols <- NULL
} }
} }
if (any(class(x) == 'data.frame')) { if (any(class(x) == "data.frame")) {
x.group <- group_vars(x) x.group <- group_vars(x)
if (length(x.group) > 1) { if (length(x.group) > 1) {
x.group <- x.group[1L] x.group <- x.group[1L]
@@ -225,13 +228,18 @@ frequency_tbl <- function(x,
if (ndots < 10) { if (ndots < 10) {
cols <- as.character(dots) cols <- as.character(dots)
if (!all(cols %in% colnames(x))) { if (!all(cols %in% colnames(x))) {
stop("one or more columns not found: `", paste(cols, collapse = "`, `"), '`', call. = FALSE) stop("one or more columns not found: `", paste(cols, collapse = "`, `"), "`", call. = FALSE)
} }
if (length(x.group) > 0) { if (length(x.group) > 0) {
x.group_cols <- c(x.group, cols) x.group_cols <- c(x.group, cols)
# if (droplevels == TRUE) {
# x <- x %>% mutate_at(vars(x.group_cols), droplevels)
# }
suppressWarnings(
df <- x %>% df <- x %>%
group_by_at(vars(x.group_cols)) %>% group_by_at(vars(x.group_cols)) %>%
summarise(count = n()) summarise(count = n())
)
if (na.rm == TRUE) { if (na.rm == TRUE) {
df <- df %>% filter_at(vars(cols), all_vars(!is.na(.))) df <- df %>% filter_at(vars(cols), all_vars(!is.na(.)))
} }
@@ -250,16 +258,21 @@ frequency_tbl <- function(x,
mutate_at(vars(x.group), funs(ifelse(lag(.) == ., "", .))) mutate_at(vars(x.group), funs(ifelse(lag(.) == ., "", .)))
df[1, 1] <- df.topleft df[1, 1] <- df.topleft
colnames(df)[1:2] <- c("group", "item") colnames(df)[1:2] <- c("group", "item")
if (!is.null(levels(df$item)) & droplevels == TRUE) {
# is factor
df <- df %>% filter(count != 0)
}
} }
if (length(cols) > 0) { if (length(cols) > 0) {
x <- x[, cols] x <- x[, cols]
} }
} else if (ndots >= 10) { } else if (ndots >= 10) {
stop('A maximum of 9 columns can be analysed at the same time.', call. = FALSE) stop("A maximum of 9 columns can be analysed at the same time.", call. = FALSE)
} else { } else {
cols <- NULL cols <- NULL
} }
} else if (any(class(x) == 'table')) { } else if (any(class(x) == "table")) {
x <- as.data.frame(x, stringsAsFactors = FALSE) x <- as.data.frame(x, stringsAsFactors = FALSE)
# now this DF contains 3 columns: the 2 vars and a Freq column # now this DF contains 3 columns: the 2 vars and a Freq column
# paste the first 2 cols and repeat them Freq times: # paste the first 2 cols and repeat them Freq times:
@@ -274,18 +287,18 @@ frequency_tbl <- function(x,
} }
if (!is.null(ncol(x))) { if (!is.null(ncol(x))) {
if (ncol(x) == 1 & any(class(x) == 'data.frame')) { if (ncol(x) == 1 & any(class(x) == "data.frame")) {
x <- x %>% pull(1) x <- x %>% pull(1)
} else if (ncol(x) < 10) { } else if (ncol(x) < 10) {
mult.columns <- ncol(x) mult.columns <- ncol(x)
x <- do.call(paste, c(x[colnames(x)], sep = sep)) x <- do.call(paste, c(x[colnames(x)], sep = sep))
} else { } else {
stop('A maximum of 9 columns can be analysed at the same time.', call. = FALSE) stop("A maximum of 9 columns can be analysed at the same time.", call. = FALSE)
} }
} }
if (mult.columns > 1) { if (mult.columns > 1) {
NAs <- x[is.na(x) | x == trimws(strrep('NA ', mult.columns))] NAs <- x[is.na(x) | x == trimws(strrep("NA ", mult.columns))]
} else { } else {
NAs <- x[is.na(x)] NAs <- x[is.na(x)]
} }
@@ -296,91 +309,109 @@ frequency_tbl <- function(x,
class(x) <- x_class class(x) <- x_class
} }
# if (sort.count == FALSE & 'factor' %in% class(x)) {
# warning("Sorting a factor sorts on factor level, not necessarily alphabetically.", call. = FALSE)
# }
header_txt <- character(0) header_txt <- character(0)
markdown_line <- '' markdown_line <- ""
if (markdown == TRUE) { if (markdown == TRUE) {
markdown_line <- '\n' markdown_line <- "\n"
} }
x_align <- 'l' x_align <- "l"
if (mult.columns > 0) { if (mult.columns > 0) {
header_txt <- header_txt %>% paste0(markdown_line, 'Columns: ', mult.columns) header_txt <- header_txt %>% paste0(markdown_line, "Columns: ", mult.columns)
} else { } else {
header_txt <- header_txt %>% paste0(markdown_line, 'Class: ', class(x) %>% rev() %>% paste(collapse = " > ")) header_txt <- header_txt %>% paste0(markdown_line, "Class: ", class(x) %>% rev() %>% paste(collapse = " > "))
if (!mode(x) %in% class(x)) { if (!mode(x) %in% class(x)) {
header_txt <- header_txt %>% paste0(silver(paste0(" (", mode(x), ")"))) header_txt <- header_txt %>% paste0(silver(paste0(" (", mode(x), ")")))
} }
} }
if ((length(NAs) + length(x) > 0) > 0) { if ((length(NAs) + length(x) > 0) > 0) {
na_txt <- paste0(NAs %>% length() %>% format(decimal.mark = decimal.mark, big.mark = big.mark), ' = ', na_txt <- paste0(NAs %>% length() %>% format(decimal.mark = decimal.mark, big.mark = big.mark), " = ",
(NAs %>% length() / (NAs %>% length() + x %>% length())) %>% percent(force_zero = TRUE, round = digits, decimal.mark = decimal.mark) %>% (NAs %>% length() / (NAs %>% length() + x %>% length())) %>% percent(force_zero = TRUE, round = digits, decimal.mark = decimal.mark) %>%
sub('NaN', '0', ., fixed = TRUE)) sub("NaN", "0", ., fixed = TRUE))
if (!na_txt %like% "^0 =") { if (!na_txt %like% "^0 =") {
na_txt <- red(na_txt) na_txt <- red(na_txt)
} else { } else {
na_txt <- green(na_txt) na_txt <- green(na_txt)
} }
na_txt <- paste0('(of which NA: ', na_txt, ')') na_txt <- paste0("(of which NA: ", na_txt, ")")
} else { } else {
na_txt <- "" na_txt <- ""
} }
header_txt <- header_txt %>% paste0(markdown_line, '\nLength: ', (NAs %>% length() + x %>% length()) %>% format(decimal.mark = decimal.mark, big.mark = big.mark), if (!is.null(levels(x))) {
' ', na_txt) n_levels <- x %>% levels() %>% length()
header_txt <- header_txt %>% paste0(markdown_line, '\nUnique: ', x %>% n_distinct() %>% format(decimal.mark = decimal.mark, big.mark = big.mark)) n_levels_empty <- n_levels - x %>% droplevels() %>% levels() %>% length()
n_levels_list <- levels(x)
if (n_levels > 5) {
n_levels_list <- c(n_levels_list[1:5], "...")
}
if (is.ordered(x)) {
n_levels_list <- paste0(levels(x), collapse = " < ")
} else {
n_levels_list <- paste0(levels(x), collapse = ", ")
}
header_txt <- header_txt %>% paste0(markdown_line, "\nLevels: ", n_levels_list)
# drop levels of non-existing factor values,
# since dplyr >= 0.8.0 does not do this anymore in group_by
if (droplevels == TRUE) {
x <- droplevels(x)
}
}
header_txt <- header_txt %>% paste0(markdown_line, "\nLength: ", (NAs %>% length() + x %>% length()) %>% format(decimal.mark = decimal.mark, big.mark = big.mark),
" ", na_txt)
header_txt <- header_txt %>% paste0(markdown_line, "\nUnique: ", x %>% n_distinct() %>% format(decimal.mark = decimal.mark, big.mark = big.mark))
if (NROW(x) > 0 & any(class(x) == "character")) { if (NROW(x) > 0 & any(class(x) == "character")) {
header_txt <- header_txt %>% paste0('\n') header_txt <- header_txt %>% paste0("\n")
header_txt <- header_txt %>% paste0(markdown_line, '\nShortest: ', x %>% base::nchar() %>% base::min(na.rm = TRUE) %>% format(decimal.mark = decimal.mark, big.mark = big.mark)) header_txt <- header_txt %>% paste0(markdown_line, "\nShortest: ", x %>% base::nchar() %>% base::min(na.rm = TRUE) %>% format(decimal.mark = decimal.mark, big.mark = big.mark))
header_txt <- header_txt %>% paste0(markdown_line, '\nLongest: ', x %>% base::nchar() %>% base::max(na.rm = TRUE) %>% format(decimal.mark = decimal.mark, big.mark = big.mark)) header_txt <- header_txt %>% paste0(markdown_line, "\nLongest: ", x %>% base::nchar() %>% base::max(na.rm = TRUE) %>% format(decimal.mark = decimal.mark, big.mark = big.mark))
} }
if (NROW(x) > 0 & any(class(x) == "mo")) { if (NROW(x) > 0 & any(class(x) == "mo")) {
header_txt <- header_txt %>% paste0('\n') header_txt <- header_txt %>% paste0("\n")
header_txt <- header_txt %>% paste0(markdown_line, '\nFamilies: ', x %>% mo_family() %>% n_distinct() %>% format(decimal.mark = decimal.mark, big.mark = big.mark)) header_txt <- header_txt %>% paste0(markdown_line, "\nFamilies: ", x %>% mo_family() %>% n_distinct() %>% format(decimal.mark = decimal.mark, big.mark = big.mark))
header_txt <- header_txt %>% paste0(markdown_line, '\nGenera: ', x %>% mo_genus() %>% n_distinct() %>% format(decimal.mark = decimal.mark, big.mark = big.mark)) header_txt <- header_txt %>% paste0(markdown_line, "\nGenera: ", x %>% mo_genus() %>% n_distinct() %>% format(decimal.mark = decimal.mark, big.mark = big.mark))
header_txt <- header_txt %>% paste0(markdown_line, '\nSpecies: ', x %>% mo_species() %>% n_distinct() %>% format(decimal.mark = decimal.mark, big.mark = big.mark)) header_txt <- header_txt %>% paste0(markdown_line, "\nSpecies: ", x %>% mo_species() %>% n_distinct() %>% format(decimal.mark = decimal.mark, big.mark = big.mark))
} }
if (NROW(x) > 0 & any(class(x) == "difftime") & !is.hms(x)) { if (NROW(x) > 0 & any(class(x) == "difftime") & !is.hms(x)) {
header_txt <- header_txt %>% paste0('\n') header_txt <- header_txt %>% paste0("\n")
header_txt <- header_txt %>% paste(markdown_line, '\nUnits: ', attributes(x)$units) header_txt <- header_txt %>% paste(markdown_line, "\nUnits: ", attributes(x)$units)
x <- as.double(x) x <- as.double(x)
# after this, the numeric header_txt continues # after this, the numeric header_txt continues
} }
if (NROW(x) > 0 & any(class(x) %in% c('double', 'integer', 'numeric', 'raw', 'single'))) { if (NROW(x) > 0 & any(class(x) %in% c("double", "integer", "numeric", "raw", "single"))) {
# right align number # right align number
Tukey_five <- stats::fivenum(x, na.rm = TRUE) Tukey_five <- stats::fivenum(x, na.rm = TRUE)
x_align <- 'r' x_align <- "r"
header_txt <- header_txt %>% paste0('\n') header_txt <- header_txt %>% paste0("\n")
header_txt <- header_txt %>% paste(markdown_line, '\nMean: ', x %>% base::mean(na.rm = TRUE) %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark)) header_txt <- header_txt %>% paste(markdown_line, "\nMean: ", x %>% base::mean(na.rm = TRUE) %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark))
header_txt <- header_txt %>% paste0(markdown_line, '\nStd. dev.: ', x %>% stats::sd(na.rm = TRUE) %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark), header_txt <- header_txt %>% paste0(markdown_line, "\nStd. dev.: ", x %>% stats::sd(na.rm = TRUE) %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark),
' (CV: ', x %>% cv(na.rm = TRUE) %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark), " (CV: ", x %>% cv(na.rm = TRUE) %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark),
', MAD: ', x %>% stats::mad(na.rm = TRUE) %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark), ')') ", MAD: ", x %>% stats::mad(na.rm = TRUE) %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark), ")")
header_txt <- header_txt %>% paste0(markdown_line, '\nFive-Num: ', Tukey_five %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark) %>% trimws() %>% paste(collapse = ' | '), header_txt <- header_txt %>% paste0(markdown_line, "\nFive-Num: ", Tukey_five %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark) %>% trimws() %>% paste(collapse = " | "),
' (IQR: ', (Tukey_five[4] - Tukey_five[2]) %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark), " (IQR: ", (Tukey_five[4] - Tukey_five[2]) %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark),
', CQV: ', x %>% cqv(na.rm = TRUE) %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark), ')') ", CQV: ", x %>% cqv(na.rm = TRUE) %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark), ")")
outlier_length <- length(boxplot.stats(x)$out) outlier_length <- length(boxplot.stats(x)$out)
header_txt <- header_txt %>% paste0(markdown_line, '\nOutliers: ', outlier_length) header_txt <- header_txt %>% paste0(markdown_line, "\nOutliers: ", outlier_length)
if (outlier_length > 0) { if (outlier_length > 0) {
header_txt <- header_txt %>% paste0(' (unique count: ', boxplot.stats(x)$out %>% n_distinct(), ')') header_txt <- header_txt %>% paste0(" (unique count: ", boxplot.stats(x)$out %>% n_distinct(), ")")
} }
} }
if (NROW(x) > 0 & any(class(x) == "rsi")) { if (NROW(x) > 0 & any(class(x) == "rsi")) {
header_txt <- header_txt %>% paste0('\n') header_txt <- header_txt %>% paste0("\n")
cnt_S <- sum(x == "S", na.rm = TRUE) cnt_S <- sum(x == "S", na.rm = TRUE)
cnt_IR <- sum(x %in% c("I", "R"), na.rm = TRUE) cnt_IR <- sum(x %in% c("I", "R"), na.rm = TRUE)
header_txt <- header_txt %>% paste(markdown_line, '\n%IR: ', header_txt <- header_txt %>% paste(markdown_line, "\n%IR: ",
(cnt_IR / sum(!is.na(x), na.rm = TRUE)) %>% percent(force_zero = TRUE, round = digits, decimal.mark = decimal.mark), (cnt_IR / sum(!is.na(x), na.rm = TRUE)) %>% percent(force_zero = TRUE, round = digits, decimal.mark = decimal.mark),
paste0('(ratio S : IR = 1.0 : ', (cnt_IR / cnt_S) %>% format(digits = 1, nsmall = 1, decimal.mark = decimal.mark, big.mark = big.mark), ")")) paste0("(ratio S : IR = 1.0 : ", (cnt_IR / cnt_S) %>% format(digits = 1, nsmall = 1, decimal.mark = decimal.mark, big.mark = big.mark), ")"))
if (NROW(x) < 30) { if (NROW(x) < 30) {
header_txt <- header_txt %>% paste(markdown_line, red('\nToo few isolates for reliable resistance interpretation.')) header_txt <- header_txt %>% paste(markdown_line, red("\nToo few isolates for reliable resistance interpretation."))
} }
} }
@@ -389,29 +420,29 @@ frequency_tbl <- function(x,
x <- x %>% as.POSIXlt() x <- x %>% as.POSIXlt()
formatdates <- "%H:%M:%S" formatdates <- "%H:%M:%S"
} }
if (NROW(x) > 0 & any(class(x) %in% c('Date', 'POSIXct', 'POSIXlt'))) { if (NROW(x) > 0 & any(class(x) %in% c("Date", "POSIXct", "POSIXlt"))) {
header_txt <- header_txt %>% paste0('\n') header_txt <- header_txt %>% paste0("\n")
mindate <- x %>% min(na.rm = TRUE) mindate <- x %>% min(na.rm = TRUE)
maxdate <- x %>% max(na.rm = TRUE) maxdate <- x %>% max(na.rm = TRUE)
maxdate_days <- difftime(maxdate, mindate, units = 'auto') %>% as.double() maxdate_days <- difftime(maxdate, mindate, units = "auto") %>% as.double()
mediandate <- x %>% median(na.rm = TRUE) mediandate <- x %>% median(na.rm = TRUE)
median_days <- difftime(mediandate, mindate, units = 'auto') %>% as.double() median_days <- difftime(mediandate, mindate, units = "auto") %>% as.double()
if (formatdates == "%H:%M:%S") { if (formatdates == "%H:%M:%S") {
# hms # hms
header_txt <- header_txt %>% paste0(markdown_line, '\nEarliest: ', mindate %>% format(formatdates) %>% trimws()) header_txt <- header_txt %>% paste0(markdown_line, "\nEarliest: ", mindate %>% format(formatdates) %>% trimws())
header_txt <- header_txt %>% paste0(markdown_line, '\nLatest: ', maxdate %>% format(formatdates) %>% trimws(), header_txt <- header_txt %>% paste0(markdown_line, "\nLatest: ", maxdate %>% format(formatdates) %>% trimws(),
' (+', difftime(maxdate, mindate, units = 'mins') %>% as.double() %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark), ' min.)') " (+", difftime(maxdate, mindate, units = "mins") %>% as.double() %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark), " min.)")
} else { } else {
# other date formats # other date formats
header_txt <- header_txt %>% paste0(markdown_line, '\nOldest: ', mindate %>% format(formatdates) %>% trimws()) header_txt <- header_txt %>% paste0(markdown_line, "\nOldest: ", mindate %>% format(formatdates) %>% trimws())
header_txt <- header_txt %>% paste0(markdown_line, '\nNewest: ', maxdate %>% format(formatdates) %>% trimws(), header_txt <- header_txt %>% paste0(markdown_line, "\nNewest: ", maxdate %>% format(formatdates) %>% trimws(),
' (+', difftime(maxdate, mindate, units = 'auto') %>% as.double() %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark), ')') " (+", difftime(maxdate, mindate, units = "auto") %>% as.double() %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark), ")")
} }
header_txt <- header_txt %>% paste0(markdown_line, '\nMedian: ', mediandate %>% format(formatdates) %>% trimws(), header_txt <- header_txt %>% paste0(markdown_line, "\nMedian: ", mediandate %>% format(formatdates) %>% trimws(),
' (~', percent(median_days / maxdate_days, round = 0, decimal.mark = decimal.mark), ')') " (~", percent(median_days / maxdate_days, round = 0, decimal.mark = decimal.mark), ")")
} }
if (any(class(x) == 'POSIXlt')) { if (any(class(x) == "POSIXlt")) {
x <- x %>% format(formatdates) x <- x %>% format(formatdates)
} }
@@ -427,9 +458,9 @@ frequency_tbl <- function(x,
nmax <- length(x) nmax <- length(x)
} }
column_names <- c('Item', 'Count', 'Percent', 'Cum. Count', 'Cum. Percent') column_names <- c("Item", "Count", "Percent", "Cum. Count", "Cum. Percent")
column_names_df <- c('item', 'count', 'percent', 'cum_count', 'cum_percent') column_names_df <- c("item", "count", "percent", "cum_count", "cum_percent")
column_align <- c(x_align, 'r', 'r', 'r', 'r') column_align <- c(x_align, "r", "r", "r", "r")
if (is.null(df)) { if (is.null(df)) {
# create table with counts and percentages # create table with counts and percentages
@@ -449,10 +480,10 @@ frequency_tbl <- function(x,
column_align <- c("l", column_align) column_align <- c("l", column_align)
} }
if (df$item %>% paste(collapse = ',') %like% '\033') { if (df$item %>% paste(collapse = ",") %like% "\033") {
# remove escape char # remove escape char
# see https://en.wikipedia.org/wiki/Escape_character#ASCII_escape_character # see https://en.wikipedia.org/wiki/Escape_character#ASCII_escape_character
df <- df %>% mutate(item = item %>% gsub('\033', ' ', ., fixed = TRUE)) df <- df %>% mutate(item = item %>% gsub("\033", " ", ., fixed = TRUE))
} }
if (quote == TRUE) { if (quote == TRUE) {
@@ -475,9 +506,9 @@ frequency_tbl <- function(x,
} }
if (markdown == TRUE) { if (markdown == TRUE) {
tbl_format <- 'markdown' tbl_format <- "markdown"
} else { } else {
tbl_format <- 'pandoc' tbl_format <- "pandoc"
} }
if (!is.null(title)) { if (!is.null(title)) {
@@ -485,7 +516,7 @@ frequency_tbl <- function(x,
} }
structure(.Data = df, structure(.Data = df,
class = c('frequency_tbl', class(df)), class = c("frequency_tbl", class(df)),
opt = list(title = title, opt = list(title = title,
data = x.name, data = x.name,
vars = cols, vars = cols,
@@ -511,11 +542,11 @@ freq <- frequency_tbl
#' @export #' @export
#' @importFrom dplyr top_n pull #' @importFrom dplyr top_n pull
top_freq <- function(f, n) { top_freq <- function(f, n) {
if (!'frequency_tbl' %in% class(f)) { if (!"frequency_tbl" %in% class(f)) {
stop('top_freq can only be applied to frequency tables', call. = FALSE) stop("top_freq can only be applied to frequency tables", call. = FALSE)
} }
if (!is.numeric(n) | length(n) != 1L) { if (!is.numeric(n) | length(n) != 1L) {
stop('For top_freq, `nmax` must be a number of length 1', call. = FALSE) stop("For top_freq, `nmax` must be a number of length 1", call. = FALSE)
} }
top <- f %>% top_n(n, count) top <- f %>% top_n(n, count)
vect <- top %>% pull(item) vect <- top %>% pull(item)
@@ -562,10 +593,10 @@ diff.frequency_tbl <- function(x, y, ...) {
diff.percent = percent( diff.percent = percent(
diff / count.x, diff / count.x,
force_zero = TRUE)) %>% force_zero = TRUE)) %>%
mutate(diff = ifelse(diff %like% '^-', mutate(diff = ifelse(diff %like% "^-",
diff, diff,
paste0("+", diff)), paste0("+", diff)),
diff.percent = ifelse(diff.percent %like% '^-', diff.percent = ifelse(diff.percent %like% "^-",
diff.percent, diff.percent,
paste0("+", diff.percent))) paste0("+", diff.percent)))
@@ -590,7 +621,7 @@ print.frequency_tbl <- function(x, nmax = getOption("max.print.freq", default =
big.mark = ifelse(decimal.mark != ",", ",", "."), big.mark = ifelse(decimal.mark != ",", ",", "."),
...) { ...) {
opt <- attr(x, 'opt') opt <- attr(x, "opt")
if (length(opt$vars) == 0) { if (length(opt$vars) == 0) {
opt$vars <- NULL opt$vars <- NULL
@@ -666,7 +697,7 @@ print.frequency_tbl <- function(x, nmax = getOption("max.print.freq", default =
} }
if (NROW(x) == 0) { if (NROW(x) == 0) {
cat('\n\nNo observations.\n') cat("\n\nNo observations.\n")
return(invisible()) return(invisible())
} }
@@ -680,7 +711,7 @@ print.frequency_tbl <- function(x, nmax = getOption("max.print.freq", default =
if (nrow(x) > opt$nmax & opt$tbl_format != "markdown") { if (nrow(x) > opt$nmax & opt$tbl_format != "markdown") {
x.rows <- nrow(x) x.rows <- nrow(x)
x.unprinted <- base::sum(x[(opt$nmax + 1):nrow(x), 'count'], na.rm = TRUE) x.unprinted <- base::sum(x[(opt$nmax + 1):nrow(x), "count"], na.rm = TRUE)
x.printed <- base::sum(x$count) - x.unprinted x.printed <- base::sum(x$count) - x.unprinted
if (opt$nmax.set == TRUE) { if (opt$nmax.set == TRUE) {
@@ -692,18 +723,18 @@ print.frequency_tbl <- function(x, nmax = getOption("max.print.freq", default =
x <- x[1:nmax,] x <- x[1:nmax,]
if (opt$nmax.set == TRUE) { if (opt$nmax.set == TRUE) {
footer <- paste('[ reached `nmax = ', opt$nmax, '`', sep = '') footer <- paste("[ reached `nmax = ", opt$nmax, "`", sep = "")
} else { } else {
footer <- '[ reached getOption("max.print.freq")' footer <- '[ reached getOption("max.print.freq")'
} }
footer <- paste(footer, footer <- paste(footer,
' -- omitted ', " -- omitted ",
format(x.rows - opt$nmax, big.mark = opt$big.mark), format(x.rows - opt$nmax, big.mark = opt$big.mark),
' entries, n = ', " entries, n = ",
format(x.unprinted, big.mark = opt$big.mark), format(x.unprinted, big.mark = opt$big.mark),
' (', " (",
(x.unprinted / (x.unprinted + x.printed)) %>% percent(force_zero = TRUE, decimal.mark = opt$decimal.mark), (x.unprinted / (x.unprinted + x.printed)) %>% percent(force_zero = TRUE, decimal.mark = opt$decimal.mark),
') ]\n', sep = '') ") ]\n", sep = "")
if (opt$tbl_format == "pandoc") { if (opt$tbl_format == "pandoc") {
footer <- silver(footer) # only silver in regular printing footer <- silver(footer) # only silver in regular printing
} }
@@ -712,7 +743,7 @@ print.frequency_tbl <- function(x, nmax = getOption("max.print.freq", default =
} }
if ("item" %in% colnames(x)) { if ("item" %in% colnames(x)) {
if (any(class(x$item) %in% c('double', 'integer', 'numeric', 'raw', 'single'))) { if (any(class(x$item) %in% c("double", "integer", "numeric", "raw", "single"))) {
x$item <- format(x$item, decimal.mark = opt$decimal.mark, big.mark = opt$big.mark) x$item <- format(x$item, decimal.mark = opt$decimal.mark, big.mark = opt$big.mark)
} }
} else { } else {
@@ -720,7 +751,7 @@ print.frequency_tbl <- function(x, nmax = getOption("max.print.freq", default =
} }
if ("count" %in% colnames(x)) { if ("count" %in% colnames(x)) {
if (all(x$count == 1)) { if (all(x$count == 1)) {
warning('All observations are unique.', call. = FALSE) warning("All observations are unique.", call. = FALSE)
} }
x$count <- format(x$count, decimal.mark = opt$decimal.mark, big.mark = opt$big.mark) x$count <- format(x$count, decimal.mark = opt$decimal.mark, big.mark = opt$big.mark)
} else { } else {
@@ -762,7 +793,7 @@ print.frequency_tbl <- function(x, nmax = getOption("max.print.freq", default =
if (opt$tbl_format == "markdown") { if (opt$tbl_format == "markdown") {
cat("\n\n") cat("\n\n")
} else { } else {
cat('\n') cat("\n")
} }
# reset old kable setting # reset old kable setting
@@ -775,8 +806,8 @@ print.frequency_tbl <- function(x, nmax = getOption("max.print.freq", default =
#' @exportMethod as.data.frame.frequency_tbl #' @exportMethod as.data.frame.frequency_tbl
#' @export #' @export
as.data.frame.frequency_tbl <- function(x, ...) { as.data.frame.frequency_tbl <- function(x, ...) {
attr(x, 'package') <- NULL attr(x, "package") <- NULL
attr(x, 'opt') <- NULL attr(x, "opt") <- NULL
as.data.frame.data.frame(x, ...) as.data.frame.data.frame(x, ...)
} }
@@ -785,8 +816,8 @@ as.data.frame.frequency_tbl <- function(x, ...) {
#' @export #' @export
#' @importFrom dplyr as_tibble #' @importFrom dplyr as_tibble
as_tibble.frequency_tbl <- function(x, validate = TRUE, ..., rownames = NA) { as_tibble.frequency_tbl <- function(x, validate = TRUE, ..., rownames = NA) {
attr(x, 'package') <- NULL attr(x, "package") <- NULL
attr(x, 'opt') <- NULL attr(x, "opt") <- NULL
as_tibble(x = as.data.frame(x), validate = validate, ..., rownames = rownames) as_tibble(x = as.data.frame(x), validate = validate, ..., rownames = rownames)
} }
@@ -794,10 +825,10 @@ as_tibble.frequency_tbl <- function(x, validate = TRUE, ..., rownames = NA) {
#' @exportMethod hist.frequency_tbl #' @exportMethod hist.frequency_tbl
#' @export #' @export
#' @importFrom graphics hist #' @importFrom graphics hist
hist.frequency_tbl <- function(x, breaks = "Sturges", main = NULL, ...) { hist.frequency_tbl <- function(x, breaks = "Sturges", main = NULL, xlab = NULL, ...) {
opt <- attr(x, 'opt') opt <- attr(x, "opt")
if (!class(x$item) %in% c("numeric", "double", "integer", "Date")) { if (!class(x$item) %in% c("numeric", "double", "integer", "Date")) {
stop("'x' must be numeric or Date.", call. = FALSE) stop("`x` must be numeric or Date.", call. = FALSE)
} }
if (!is.null(opt$vars)) { if (!is.null(opt$vars)) {
title <- opt$vars title <- opt$vars
@@ -814,14 +845,17 @@ hist.frequency_tbl <- function(x, breaks = "Sturges", main = NULL, ...) {
if (is.null(main)) { if (is.null(main)) {
main <- paste("Histogram of", title) main <- paste("Histogram of", title)
} }
hist(x, main = main, xlab = title, ...) if (is.null(xlab)) {
xlab <- title
}
hist(x, main = main, xlab = xlab, breaks = breaks, ...)
} }
#' @noRd #' @noRd
#' @exportMethod plot.frequency_tbl #' @exportMethod plot.frequency_tbl
#' @export #' @export
plot.frequency_tbl <- function(x, y, ...) { plot.frequency_tbl <- function(x, y, ...) {
opt <- attr(x, 'opt') opt <- attr(x, "opt")
if (!is.null(opt$vars)) { if (!is.null(opt$vars)) {
title <- opt$vars title <- opt$vars
} else { } else {
@@ -841,7 +875,7 @@ as.vector.frequency_tbl <- function(x, mode = "any") {
#' @exportMethod format.frequency_tbl #' @exportMethod format.frequency_tbl
#' @export #' @export
format.frequency_tbl <- function(x, digits = 1, ...) { format.frequency_tbl <- function(x, digits = 1, ...) {
opt <- attr(x, 'opt') opt <- attr(x, "opt")
if (opt$nmax.set == TRUE) { if (opt$nmax.set == TRUE) {
nmax <- opt$nmax nmax <- opt$nmax
} else { } else {

42
R/key_antibiotics.R
View File

@@ -26,6 +26,7 @@
#' @param GramPos_1,GramPos_2,GramPos_3,GramPos_4,GramPos_5,GramPos_6 column names of antibiotics for \strong{Gram positives}, case-insensitive #' @param GramPos_1,GramPos_2,GramPos_3,GramPos_4,GramPos_5,GramPos_6 column names of antibiotics for \strong{Gram positives}, case-insensitive
#' @param GramNeg_1,GramNeg_2,GramNeg_3,GramNeg_4,GramNeg_5,GramNeg_6 column names of antibiotics for \strong{Gram negatives}, case-insensitive #' @param GramNeg_1,GramNeg_2,GramNeg_3,GramNeg_4,GramNeg_5,GramNeg_6 column names of antibiotics for \strong{Gram negatives}, case-insensitive
#' @param warnings give warning about missing antibiotic columns, they will anyway be ignored #' @param warnings give warning about missing antibiotic columns, they will anyway be ignored
#' @param ... other parameters passed on to function
#' @details The function \code{key_antibiotics} returns a character vector with 12 antibiotic results for every isolate. These isolates can then be compared using \code{key_antibiotics_equal}, to check if two isolates have generally the same antibiogram. Missing and invalid values are replaced with a dot (\code{"."}). The \code{\link{first_isolate}} function only uses this function on the same microbial species from the same patient. Using this, an MRSA will be included after a susceptible \emph{S. aureus} (MSSA) found within the same episode (see \code{episode} parameter of \code{\link{first_isolate}}). Without key antibiotic comparison it wouldn't. #' @details The function \code{key_antibiotics} returns a character vector with 12 antibiotic results for every isolate. These isolates can then be compared using \code{key_antibiotics_equal}, to check if two isolates have generally the same antibiogram. Missing and invalid values are replaced with a dot (\code{"."}). The \code{\link{first_isolate}} function only uses this function on the same microbial species from the same patient. Using this, an MRSA will be included after a susceptible \emph{S. aureus} (MSSA) found within the same episode (see \code{episode} parameter of \code{\link{first_isolate}}). Without key antibiotic comparison it wouldn't.
#' #'
#' At default, the antibiotics that are used for \strong{Gram positive bacteria} are (colum names): \cr #' At default, the antibiotics that are used for \strong{Gram positive bacteria} are (colum names): \cr
@@ -40,22 +41,21 @@
#' @rdname key_antibiotics #' @rdname key_antibiotics
#' @export #' @export
#' @importFrom dplyr %>% mutate if_else #' @importFrom dplyr %>% mutate if_else
#' @importFrom crayon blue bold
#' @seealso \code{\link{first_isolate}} #' @seealso \code{\link{first_isolate}}
#' @examples #' @examples
#' # septic_patients is a dataset available in the AMR package #' # septic_patients is a dataset available in the AMR package
#' ?septic_patients #' ?septic_patients
#' my_patients <- septic_patients
#'
#' library(dplyr) #' library(dplyr)
#' # set key antibiotics to a new variable #' # set key antibiotics to a new variable
#' my_patients <- my_patients %>% #' my_patients <- septic_patients %>%
#' mutate(keyab = key_antibiotics(.)) %>% #' mutate(keyab = key_antibiotics(.)) %>%
#' mutate( #' mutate(
#' # now calculate first isolates #' # now calculate first isolates
#' first_regular = first_isolate(., "date", "patient_id", "mo"), #' first_regular = first_isolate(., col_keyantibiotics = FALSE),
#' # and first WEIGHTED isolates #' # and first WEIGHTED isolates
#' first_weighted = first_isolate(., "date", "patient_id", "mo", #' first_weighted = first_isolate(., col_keyantibiotics = "keyab")
#' col_keyantibiotics = "keyab")
#' ) #' )
#' #'
#' # Check the difference, in this data set it results in 7% more isolates: #' # Check the difference, in this data set it results in 7% more isolates:
@@ -68,12 +68,12 @@
#' strainB <- "SSSIRSSSRSSS" #' strainB <- "SSSIRSSSRSSS"
#' #'
#' key_antibiotics_equal(strainA, strainB) #' key_antibiotics_equal(strainA, strainB)
#' # TRUE, because I is ignored (as are missing values) #' # TRUE, because I is ignored (as well as missing values)
#' #'
#' key_antibiotics_equal(strainA, strainB, ignore_I = FALSE) #' key_antibiotics_equal(strainA, strainB, ignore_I = FALSE)
#' # FALSE, because I is not ignored and so the 4th value differs #' # FALSE, because I is not ignored and so the 4th value differs
key_antibiotics <- function(tbl, key_antibiotics <- function(tbl,
col_mo = "mo", col_mo = NULL,
universal_1 = "amox", universal_1 = "amox",
universal_2 = "amcl", universal_2 = "amcl",
universal_3 = "cfur", universal_3 = "cfur",
@@ -93,14 +93,16 @@ key_antibiotics <- function(tbl,
GramNeg_5 = "cfta", GramNeg_5 = "cfta",
GramNeg_6 = "mero", GramNeg_6 = "mero",
warnings = TRUE, warnings = TRUE,
col_bactid = "bactid") { ...) {
if (col_bactid %in% colnames(tbl)) { # try to find columns based on type
col_mo <- col_bactid # -- mo
warning("Use of `col_bactid` is deprecated. Use `col_mo` instead.") if (is.null(col_mo) & "mo" %in% lapply(tbl, class)) {
col_mo <- colnames(tbl)[lapply(tbl, class) == "mo"][1]
message(blue(paste0("NOTE: Using column `", bold(col_mo), "` as input for `col_mo`.")))
} }
if (!col_mo %in% colnames(tbl)) { if (is.null(col_mo)) {
stop('Column ', col_mo, ' not found.', call. = FALSE) stop("`col_mo` must be set.", call. = FALSE)
} }
# check columns # check columns
@@ -140,13 +142,11 @@ key_antibiotics <- function(tbl,
GramNeg_4, GramNeg_5, GramNeg_6) GramNeg_4, GramNeg_5, GramNeg_6)
gram_negative <- gram_negative[!is.na(gram_negative)] gram_negative <- gram_negative[!is.na(gram_negative)]
if (!tbl %>% pull(col_mo) %>% is.mo()) { # join to microorganisms data set
tbl[, col_mo] <- as.mo(tbl[, col_mo]) tbl <- tbl %>%
} mutate_at(vars(col_mo), as.mo) %>%
# join microorganisms left_join_microorganisms(by = col_mo) %>%
tbl <- tbl %>% left_join_microorganisms(col_mo) mutate(key_ab = NA_character_)
tbl$key_ab <- NA_character_
# Gram + # Gram +
tbl <- tbl %>% mutate(key_ab = tbl <- tbl %>% mutate(key_ab =

22
R/mdro.R
View File

@@ -30,7 +30,7 @@
#' @return Ordered factor with levels \code{Negative < Positive, unconfirmed < Positive}. #' @return Ordered factor with levels \code{Negative < Positive, unconfirmed < Positive}.
#' @rdname mdro #' @rdname mdro
#' @importFrom dplyr %>% #' @importFrom dplyr %>%
#' @importFrom crayon red blue #' @importFrom crayon red blue bold
#' @export #' @export
#' @examples #' @examples
#' library(dplyr) #' library(dplyr)
@@ -101,8 +101,7 @@ mdro <- function(tbl,
tobr = 'tobr', tobr = 'tobr',
trim = 'trim', trim = 'trim',
trsu = 'trsu', trsu = 'trsu',
vanc = 'vanc', vanc = 'vanc') {
col_bactid = NULL) {
if (!is.data.frame(tbl)) { if (!is.data.frame(tbl)) {
stop("`tbl` must be a data frame.", call. = FALSE) stop("`tbl` must be a data frame.", call. = FALSE)
@@ -110,14 +109,12 @@ mdro <- function(tbl,
# try to find columns based on type # try to find columns based on type
# -- mo # -- mo
if (!is.null(col_bactid)) { if (is.null(col_mo) & "mo" %in% lapply(tbl, class)) {
col_mo <- col_bactid
warning("Use of `col_bactid` is deprecated. Use `col_mo` instead.")
} else if (is.null(col_mo) & "mo" %in% lapply(tbl, class)) {
col_mo <- colnames(tbl)[lapply(tbl, class) == "mo"][1] col_mo <- colnames(tbl)[lapply(tbl, class) == "mo"][1]
message("NOTE: Using column `", col_mo, "` as input for `col_mo`.") message(blue(paste0("NOTE: Using column `", bold(col_mo), "` as input for `col_mo`.")))
} else if (!col_mo %in% colnames(tbl)) { }
stop('Column ', col_mo, ' not found.', call. = FALSE) if (is.null(col_mo)) {
stop("`col_mo` must be set.", call. = FALSE)
} }
# strip whitespaces # strip whitespaces
@@ -259,11 +256,8 @@ mdro <- function(tbl,
} }
} }
if (!tbl %>% pull(col_mo) %>% is.mo()) {
tbl[, col_mo] <- as.mo(tbl[, col_mo])
}
tbl <- tbl %>% tbl <- tbl %>%
mutate_at(vars(col_mo), as.mo) %>%
# join to microorganisms data set # join to microorganisms data set
left_join_microorganisms(by = col_mo) %>% left_join_microorganisms(by = col_mo) %>%
# add unconfirmed to where genus is available # add unconfirmed to where genus is available

10
R/misc.R
View File

@@ -26,15 +26,19 @@ addin_insert_like <- function() {
rstudioapi::insertText(" %like% ") rstudioapi::insertText(" %like% ")
} }
# No export, no Rd
# works exactly like round(), but rounds `round(0.55, 1)` as 0.6
round2 <- function(x, digits = 0) {
# https://stackoverflow.com/a/12688836/4575331
(trunc((abs(x) * 10 ^ digits) + 0.5) / 10 ^ digits) * sign(x)
}
# No export, no Rd # No export, no Rd
percent <- function(x, round = 1, force_zero = FALSE, decimal.mark = getOption("OutDec"), ...) { percent <- function(x, round = 1, force_zero = FALSE, decimal.mark = getOption("OutDec"), ...) {
decimal.mark.options <- getOption("OutDec") decimal.mark.options <- getOption("OutDec")
options(OutDec = ".") options(OutDec = ".")
# https://stackoverflow.com/a/12688836/4575331
round2 <- function(x, n) (trunc((abs(x) * 10 ^ n) + 0.5) / 10 ^ n) * sign(x)
val <- round2(x, round + 2) # round up 0.5 val <- round2(x, round + 2) # round up 0.5
val <- round(x = val * 100, digits = round) # remove floating point error val <- round(x = val * 100, digits = round) # remove floating point error

4
R/mo.R
View File

@@ -154,9 +154,7 @@ as.mo <- function(x, Becker = FALSE, Lancefield = FALSE, allow_uncertain = TRUE,
#' @rdname as.mo #' @rdname as.mo
#' @export #' @export
is.mo <- function(x) { is.mo <- function(x) {
# bactid for older releases identical(class(x), "mo")
# remove when is.bactid will be removed
identical(class(x), "mo") | identical(class(x), "bactid")
} }
#' @rdname as.mo #' @rdname as.mo

11
R/resistance_predict.R
View File

@@ -44,7 +44,7 @@
#' @rdname resistance_predict #' @rdname resistance_predict
#' @export #' @export
#' @importFrom stats predict glm lm #' @importFrom stats predict glm lm
#' @importFrom dplyr %>% pull mutate group_by_at summarise filter n_distinct arrange case_when #' @importFrom dplyr %>% pull mutate mutate_at n group_by_at summarise filter filter_at all_vars n_distinct arrange case_when
# @importFrom tidyr spread # @importFrom tidyr spread
#' @examples #' @examples
#' \dontrun{ #' \dontrun{
@@ -83,7 +83,7 @@
#' if (!require(ggplot2)) { #' if (!require(ggplot2)) {
#' #'
#' data <- septic_patients %>% #' data <- septic_patients %>%
#' filter(mo == "ESCCOL") %>% #' filter(mo == as.mo("E. coli")) %>%
#' resistance_predict(col_ab = "amox", #' resistance_predict(col_ab = "amox",
#' col_date = "date", #' col_date = "date",
#' info = FALSE, #' info = FALSE,
@@ -137,9 +137,10 @@ resistance_predict <- function(tbl,
tbl[, col_ab] <- gsub('I', 'R', tbl %>% pull(col_ab)) tbl[, col_ab] <- gsub('I', 'R', tbl %>% pull(col_ab))
} }
if (!tbl %>% pull(col_ab) %>% is.rsi()) { tbl <- tbl %>%
tbl[, col_ab] <- tbl %>% pull(col_ab) %>% as.rsi() mutate_at(col_ab, as.rsi) %>%
} filter_at(col_ab, all_vars(!is.na(.)))
tbl[, col_ab] <- droplevels(tbl[, col_ab])
year <- function(x) { year <- function(x) {
if (all(grepl('^[0-9]{4}$', x))) { if (all(grepl('^[0-9]{4}$', x))) {

2
R/rsi_calc.R
View File

@@ -73,7 +73,7 @@ rsi_calc <- function(...,
print_warning <- FALSE print_warning <- FALSE
type_trans <- as.integer(as.rsi(type)) type_trans <- as.integer(as.rsi(type))
type_others <- setdiff(1:3, type_trans) type_others <- base::setdiff(1:3, type_trans)
if (is.data.frame(x)) { if (is.data.frame(x)) {
rsi_integrity_check <- character(0) rsi_integrity_check <- character(0)

9
man/AMR-deprecated.Rd
View File

@@ -2,18 +2,9 @@
% Please edit documentation in R/deprecated.R % Please edit documentation in R/deprecated.R
\name{AMR-deprecated} \name{AMR-deprecated}
\alias{AMR-deprecated} \alias{AMR-deprecated}
\alias{as.bactid}
\alias{is.bactid}
\alias{guess_bactid}
\alias{ratio} \alias{ratio}
\title{Deprecated functions} \title{Deprecated functions}
\usage{ \usage{
as.bactid(...)
is.bactid(...)
guess_bactid(...)
ratio(x, ratio) ratio(x, ratio)
} }
\description{ \description{

8
man/age.Rd
View File

@@ -4,12 +4,12 @@
\alias{age} \alias{age}
\title{Age in years of individuals} \title{Age in years of individuals}
\usage{ \usage{
age(x, y = Sys.Date()) age(x, reference = Sys.Date())
} }
\arguments{ \arguments{
\item{x}{date(s) - will be coerced with \code{\link{as.POSIXlt}}} \item{x}{date(s), will be coerced with \code{\link{as.POSIXlt}}}
\item{y}{reference date(s) - defaults to \code{\link{Sys.Date}} - will be coerced with \code{\link{as.POSIXlt}}} \item{reference}{reference date(s) (defaults to today), will be coerced with \code{\link{as.POSIXlt}}}
} }
\value{ \value{
Integer (no decimals) Integer (no decimals)
@@ -18,5 +18,5 @@ Integer (no decimals)
Calculates age in years based on a reference date, which is the sytem time at default. Calculates age in years based on a reference date, which is the sytem time at default.
} }
\seealso{ \seealso{
age_groups \code{\link{age_groups}} to splits age into groups
} }

6
man/age_groups.Rd
View File

@@ -9,13 +9,13 @@ age_groups(x, split_at = c(12, 25, 55, 75))
\arguments{ \arguments{
\item{x}{age, e.g. calculated with \code{\link{age}}} \item{x}{age, e.g. calculated with \code{\link{age}}}
\item{split_at}{values to split \code{x}, defaults to 0-11, 12-24, 26-54, 55-74 and 75+. See Details.} \item{split_at}{values to split \code{x} at, defaults to age groups 0-11, 12-24, 26-54, 55-74 and 75+. See Details.}
} }
\value{ \value{
Ordered \code{\link{factor}} Ordered \code{\link{factor}}
} }
\description{ \description{
Splits ages into groups defined by the \code{split} parameter. Split ages into age groups defined by the \code{split} parameter. This allows for easier demographic (antimicrobial resistance) analysis.
} }
\details{ \details{
To split ages, the input can be: To split ages, the input can be:
@@ -65,7 +65,7 @@ septic_patients \%>\%
ggplot_rsi(x = "age_group") ggplot_rsi(x = "age_group")
} }
\seealso{ \seealso{
age \code{\link{age}} to determine ages based on one or more reference dates
} }
\keyword{age} \keyword{age}
\keyword{age_group} \keyword{age_group}

4
man/eucast_rules.Rd
View File

@@ -40,7 +40,7 @@ eucast_rules(tbl, col_mo = NULL, info = TRUE,
pita = "pita", poly = "poly", pris = "pris", qida = "qida", pita = "pita", poly = "poly", pris = "pris", qida = "qida",
rifa = "rifa", roxi = "roxi", siso = "siso", teic = "teic", rifa = "rifa", roxi = "roxi", siso = "siso", teic = "teic",
tetr = "tetr", tica = "tica", tige = "tige", tobr = "tobr", tetr = "tetr", tica = "tica", tige = "tige", tobr = "tobr",
trim = "trim", trsu = "trsu", vanc = "vanc", col_bactid = NULL) trim = "trim", trsu = "trsu", vanc = "vanc")
EUCAST_rules(...) EUCAST_rules(...)
@@ -59,8 +59,6 @@ interpretive_reading(...)
\item{amcl, amik, amox, ampi, azit, azlo, aztr, cefa, cfep, cfot, cfox, cfra, cfta, cftr, cfur, chlo, cipr, clar, clin, clox, coli, czol, dapt, doxy, erta, eryt, fosf, fusi, gent, imip, kana, levo, linc, line, mero, mezl, mino, moxi, nali, neom, neti, nitr, norf, novo, oflo, oxac, peni, pipe, pita, poly, pris, qida, rifa, roxi, siso, teic, tetr, tica, tige, tobr, trim, trsu, vanc}{column name of an antibiotic, see Antibiotics} \item{amcl, amik, amox, ampi, azit, azlo, aztr, cefa, cfep, cfot, cfox, cfra, cfta, cftr, cfur, chlo, cipr, clar, clin, clox, coli, czol, dapt, doxy, erta, eryt, fosf, fusi, gent, imip, kana, levo, linc, line, mero, mezl, mino, moxi, nali, neom, neti, nitr, norf, novo, oflo, oxac, peni, pipe, pita, poly, pris, qida, rifa, roxi, siso, teic, tetr, tica, tige, tobr, trim, trsu, vanc}{column name of an antibiotic, see Antibiotics}
\item{col_bactid}{deprecated, use \code{col_mo} instead.}
\item{...}{parameters that are passed on to \code{eucast_rules}} \item{...}{parameters that are passed on to \code{eucast_rules}}
} }
\value{ \value{

78
man/first_isolate.Rd
View File

@@ -2,6 +2,8 @@
% Please edit documentation in R/first_isolate.R % Please edit documentation in R/first_isolate.R
\name{first_isolate} \name{first_isolate}
\alias{first_isolate} \alias{first_isolate}
\alias{filter_first_isolate}
\alias{filter_first_weighted_isolate}
\title{Determine first (weighted) isolates} \title{Determine first (weighted) isolates}
\source{ \source{
Methodology of this function is based on: \strong{M39 Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data, 4th Edition}, 2014, \emph{Clinical and Laboratory Standards Institute (CLSI)}. \url{https://clsi.org/standards/products/microbiology/documents/m39/}. Methodology of this function is based on: \strong{M39 Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data, 4th Edition}, 2014, \emph{Clinical and Laboratory Standards Institute (CLSI)}. \url{https://clsi.org/standards/products/microbiology/documents/m39/}.
@@ -11,10 +13,15 @@ first_isolate(tbl, col_date = NULL, col_patient_id = NULL,
col_mo = NULL, col_testcode = NULL, col_specimen = NULL, col_mo = NULL, col_testcode = NULL, col_specimen = NULL,
col_icu = NULL, col_keyantibiotics = NULL, episode_days = 365, col_icu = NULL, col_keyantibiotics = NULL, episode_days = 365,
testcodes_exclude = NULL, icu_exclude = FALSE, testcodes_exclude = NULL, icu_exclude = FALSE,
filter_specimen = NULL, output_logical = TRUE, specimen_group = NULL, type = "keyantibiotics", ignore_I = TRUE,
type = "keyantibiotics", ignore_I = TRUE, points_threshold = 2, points_threshold = 2, info = TRUE, ...)
info = TRUE, col_bactid = NULL, col_genus = NULL,
col_species = NULL) filter_first_isolate(tbl, col_date = NULL, col_patient_id = NULL,
col_mo = NULL, ...)
filter_first_weighted_isolate(tbl, col_date = NULL,
col_patient_id = NULL, col_mo = NULL, col_keyantibiotics = NULL,
...)
} }
\arguments{ \arguments{
\item{tbl}{a \code{data.frame} containing isolates.} \item{tbl}{a \code{data.frame} containing isolates.}
@@ -37,11 +44,9 @@ first_isolate(tbl, col_date = NULL, col_patient_id = NULL,
\item{testcodes_exclude}{character vector with test codes that should be excluded (case-insensitive)} \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{icu_exclude}{logical whether ICU isolates should be excluded (rows with value \code{TRUE} in column \code{col_icu})}
\item{filter_specimen}{specimen group or type that should be excluded} \item{specimen_group}{value in column \code{col_specimen} to filter on}
\item{output_logical}{return output as \code{logical} (will else be the values \code{0} or \code{1})}
\item{type}{type to determine weighed isolates; can be \code{"keyantibiotics"} or \code{"points"}, see Details} \item{type}{type to determine weighed isolates; can be \code{"keyantibiotics"} or \code{"points"}, see Details}
@@ -51,14 +56,10 @@ first_isolate(tbl, col_date = NULL, col_patient_id = NULL,
\item{info}{print progress} \item{info}{print progress}
\item{col_bactid}{(deprecated, use \code{col_mo} instead)} \item{...}{parameters passed on to the \code{first_isolate} function}
\item{col_genus}{(deprecated, use \code{col_mo} instead) column name of the genus of the microorganisms}
\item{col_species}{(deprecated, use \code{col_mo} instead) column name of the species of the microorganisms}
} }
\value{ \value{
A vector to add to table, see Examples. Logical vector
} }
\description{ \description{
Determine first (weighted) isolates of all microorganisms of every patient per episode and (if needed) per specimen type. Determine first (weighted) isolates of all microorganisms of every patient per episode and (if needed) per specimen type.
@@ -66,6 +67,23 @@ Determine first (weighted) isolates of all microorganisms of every patient per e
\details{ \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}. 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}.
The function \code{filter_first_isolate} is essentially equal to:
\preformatted{
tbl \%>\%
mutate(only_firsts = first_isolate(tbl, ...)) \%>\%
filter(only_firsts == TRUE) \%>\%
select(-only_firsts)
}
The function \code{filter_first_weighted_isolate} is essentially equal to:
\preformatted{
tbl \%>\%
mutate(keyab = key_antibiotics(.)) \%>\%
mutate(only_weighted_firsts = first_isolate(tbl,
col_keyantibiotics = "keyab", ...)) \%>\%
filter(only_weighted_firsts == TRUE) \%>\%
select(-only_weighted_firsts)
}
} }
\section{Key antibiotics}{ \section{Key antibiotics}{
@@ -83,20 +101,29 @@ Determine first (weighted) isolates of all microorganisms of every patient per e
?septic_patients ?septic_patients
library(dplyr) library(dplyr)
my_patients <- septic_patients \%>\% # Filter on first isolates:
septic_patients \%>\%
mutate(first_isolate = first_isolate(., mutate(first_isolate = first_isolate(.,
col_date = "date", col_date = "date",
col_patient_id = "patient_id", col_patient_id = "patient_id",
col_mo = "mo")) col_mo = "mo")) \%>\%
filter(first_isolate == TRUE)
# Which can be shortened to:
septic_patients \%>\%
filter_first_isolate()
# or for first weighted isolates:
septic_patients \%>\%
filter_first_weighted_isolate()
# Now let's see if first isolates matter: # Now let's see if first isolates matter:
A <- my_patients \%>\% A <- septic_patients \%>\%
group_by(hospital_id) \%>\% group_by(hospital_id) \%>\%
summarise(count = n_rsi(gent), # gentamicin availability summarise(count = n_rsi(gent), # gentamicin availability
resistance = portion_IR(gent)) # gentamicin resistance resistance = portion_IR(gent)) # gentamicin resistance
B <- my_patients \%>\% B <- septic_patients \%>\%
filter(first_isolate == TRUE) \%>\% # the 1st isolate filter filter_first_weighted_isolate() \%>\% # the 1st isolate filter
group_by(hospital_id) \%>\% group_by(hospital_id) \%>\%
summarise(count = n_rsi(gent), # gentamicin availability summarise(count = n_rsi(gent), # gentamicin availability
resistance = portion_IR(gent)) # gentamicin resistance resistance = portion_IR(gent)) # gentamicin resistance
@@ -106,6 +133,7 @@ B <- my_patients \%>\%
# Gentamicin resitance in hospital D appears to be 5.4\% higher than # Gentamicin resitance in hospital D appears to be 5.4\% higher than
# when you (erroneously) would have used all isolates! # when you (erroneously) would have used all isolates!
## OTHER EXAMPLES: ## OTHER EXAMPLES:
\dontrun{ \dontrun{
@@ -122,29 +150,29 @@ tbl$first_isolate_weighed <-
tbl$first_blood_isolate <- tbl$first_blood_isolate <-
first_isolate(tbl, first_isolate(tbl,
filter_specimen = 'Blood') specimen_group = 'Blood')
tbl$first_blood_isolate_weighed <- tbl$first_blood_isolate_weighed <-
first_isolate(tbl, first_isolate(tbl,
filter_specimen = 'Blood', specimen_group = 'Blood',
col_keyantibiotics = 'keyab') col_keyantibiotics = 'keyab')
tbl$first_urine_isolate <- tbl$first_urine_isolate <-
first_isolate(tbl, first_isolate(tbl,
filter_specimen = 'Urine') specimen_group = 'Urine')
tbl$first_urine_isolate_weighed <- tbl$first_urine_isolate_weighed <-
first_isolate(tbl, first_isolate(tbl,
filter_specimen = 'Urine', specimen_group = 'Urine',
col_keyantibiotics = 'keyab') col_keyantibiotics = 'keyab')
tbl$first_resp_isolate <- tbl$first_resp_isolate <-
first_isolate(tbl, first_isolate(tbl,
filter_specimen = 'Respiratory') specimen_group = 'Respiratory')
tbl$first_resp_isolate_weighed <- tbl$first_resp_isolate_weighed <-
first_isolate(tbl, first_isolate(tbl,
filter_specimen = 'Respiratory', specimen_group = 'Respiratory',
col_keyantibiotics = 'keyab') col_keyantibiotics = 'keyab')
} }
} }

14
man/freq.Rd
View File

@@ -10,15 +10,16 @@
frequency_tbl(x, ..., sort.count = TRUE, frequency_tbl(x, ..., sort.count = TRUE,
nmax = getOption("max.print.freq"), na.rm = TRUE, row.names = TRUE, nmax = getOption("max.print.freq"), na.rm = TRUE, row.names = TRUE,
markdown = !interactive(), digits = 2, quote = FALSE, markdown = !interactive(), digits = 2, quote = FALSE,
header = !markdown, title = NULL, na = "<NA>", sep = " ", header = !markdown, title = NULL, na = "<NA>", droplevels = TRUE,
decimal.mark = getOption("OutDec"), big.mark = ifelse(decimal.mark != sep = " ", decimal.mark = getOption("OutDec"),
",", ",", ".")) big.mark = ifelse(decimal.mark != ",", ",", "."))
freq(x, ..., sort.count = TRUE, nmax = getOption("max.print.freq"), freq(x, ..., sort.count = TRUE, nmax = getOption("max.print.freq"),
na.rm = TRUE, row.names = TRUE, markdown = !interactive(), na.rm = TRUE, row.names = TRUE, markdown = !interactive(),
digits = 2, quote = FALSE, header = !markdown, title = NULL, digits = 2, quote = FALSE, header = !markdown, title = NULL,
na = "<NA>", sep = " ", decimal.mark = getOption("OutDec"), na = "<NA>", droplevels = TRUE, sep = " ",
big.mark = ifelse(decimal.mark != ",", ",", ".")) decimal.mark = getOption("OutDec"), big.mark = ifelse(decimal.mark !=
",", ",", "."))
top_freq(f, n) top_freq(f, n)
@@ -52,6 +53,8 @@ top_freq(f, n)
\item{na}{a character string to should be used to show empty (\code{NA}) values (only useful when \code{na.rm = FALSE})} \item{na}{a character string to should be used to show empty (\code{NA}) values (only useful when \code{na.rm = FALSE})}
\item{droplevels}{a logical value indicating whether in factors empty levels should be dropped}
\item{sep}{a character string to separate the terms when selecting multiple columns} \item{sep}{a character string to separate the terms when selecting multiple columns}
\item{decimal.mark}{% \item{decimal.mark}{%
@@ -94,6 +97,7 @@ For dates and times of any class, these additional values will be calculated wit
\item{Median, using \code{\link[stats]{median}}, with percentage since oldest} \item{Median, using \code{\link[stats]{median}}, with percentage since oldest}
} }
In factors, all factor levels that are not existing in the input data will be dropped.
The function \code{top_freq} uses \code{\link[dplyr]{top_n}} internally and will include more than \code{n} rows if there are ties. The function \code{top_freq} uses \code{\link[dplyr]{top_n}} internally and will include more than \code{n} rows if there are ties.
} }

18
man/key_antibiotics.Rd
View File

@@ -5,14 +5,13 @@
\alias{key_antibiotics_equal} \alias{key_antibiotics_equal}
\title{Key antibiotics for first \emph{weighted} isolates} \title{Key antibiotics for first \emph{weighted} isolates}
\usage{ \usage{
key_antibiotics(tbl, col_mo = "mo", universal_1 = "amox", key_antibiotics(tbl, col_mo = NULL, universal_1 = "amox",
universal_2 = "amcl", universal_3 = "cfur", universal_4 = "pita", universal_2 = "amcl", universal_3 = "cfur", universal_4 = "pita",
universal_5 = "cipr", universal_6 = "trsu", GramPos_1 = "vanc", universal_5 = "cipr", universal_6 = "trsu", GramPos_1 = "vanc",
GramPos_2 = "teic", GramPos_3 = "tetr", GramPos_4 = "eryt", GramPos_2 = "teic", GramPos_3 = "tetr", GramPos_4 = "eryt",
GramPos_5 = "oxac", GramPos_6 = "rifa", GramNeg_1 = "gent", GramPos_5 = "oxac", GramPos_6 = "rifa", GramNeg_1 = "gent",
GramNeg_2 = "tobr", GramNeg_3 = "coli", GramNeg_4 = "cfot", GramNeg_2 = "tobr", GramNeg_3 = "coli", GramNeg_4 = "cfot",
GramNeg_5 = "cfta", GramNeg_6 = "mero", warnings = TRUE, GramNeg_5 = "cfta", GramNeg_6 = "mero", warnings = TRUE, ...)
col_bactid = "bactid")
key_antibiotics_equal(x, y, type = c("keyantibiotics", "points"), key_antibiotics_equal(x, y, type = c("keyantibiotics", "points"),
ignore_I = TRUE, points_threshold = 2, info = FALSE) ignore_I = TRUE, points_threshold = 2, info = FALSE)
@@ -30,7 +29,7 @@ key_antibiotics_equal(x, y, type = c("keyantibiotics", "points"),
\item{warnings}{give warning about missing antibiotic columns, they will anyway be ignored} \item{warnings}{give warning about missing antibiotic columns, they will anyway be ignored}
\item{col_bactid}{(deprecated, use \code{col_mo} instead)} \item{...}{other parameters passed on to function}
\item{x, y}{characters to compare} \item{x, y}{characters to compare}
@@ -71,18 +70,15 @@ The function \code{key_antibiotics} returns a character vector with 12 antibioti
\examples{ \examples{
# septic_patients is a dataset available in the AMR package # septic_patients is a dataset available in the AMR package
?septic_patients ?septic_patients
my_patients <- septic_patients
library(dplyr) library(dplyr)
# set key antibiotics to a new variable # set key antibiotics to a new variable
my_patients <- my_patients \%>\% my_patients <- septic_patients \%>\%
mutate(keyab = key_antibiotics(.)) \%>\% mutate(keyab = key_antibiotics(.)) \%>\%
mutate( mutate(
# now calculate first isolates # now calculate first isolates
first_regular = first_isolate(., "date", "patient_id", "mo"), first_regular = first_isolate(., col_keyantibiotics = FALSE),
# and first WEIGHTED isolates # and first WEIGHTED isolates
first_weighted = first_isolate(., "date", "patient_id", "mo", first_weighted = first_isolate(., col_keyantibiotics = "keyab")
col_keyantibiotics = "keyab")
) )
# Check the difference, in this data set it results in 7\% more isolates: # Check the difference, in this data set it results in 7\% more isolates:
@@ -95,7 +91,7 @@ strainA <- "SSSRR.S.R..S"
strainB <- "SSSIRSSSRSSS" strainB <- "SSSIRSSSRSSS"
key_antibiotics_equal(strainA, strainB) key_antibiotics_equal(strainA, strainB)
# TRUE, because I is ignored (as are missing values) # TRUE, because I is ignored (as well as missing values)
key_antibiotics_equal(strainA, strainB, ignore_I = FALSE) key_antibiotics_equal(strainA, strainB, ignore_I = FALSE)
# FALSE, because I is not ignored and so the 4th value differs # FALSE, because I is not ignored and so the 4th value differs

5
man/mdro.Rd
View File

@@ -22,8 +22,7 @@ mdro(tbl, country = NULL, col_mo = NULL, info = TRUE,
peni = "peni", pipe = "pipe", pita = "pita", poly = "poly", peni = "peni", pipe = "pipe", pita = "pita", poly = "poly",
qida = "qida", rifa = "rifa", roxi = "roxi", siso = "siso", qida = "qida", rifa = "rifa", roxi = "roxi", siso = "siso",
teic = "teic", tetr = "tetr", tica = "tica", tige = "tige", teic = "teic", tetr = "tetr", tica = "tica", tige = "tige",
tobr = "tobr", trim = "trim", trsu = "trsu", vanc = "vanc", tobr = "tobr", trim = "trim", trsu = "trsu", vanc = "vanc")
col_bactid = NULL)
brmo(..., country = "nl") brmo(..., country = "nl")
@@ -160,8 +159,6 @@ eucast_exceptional_phenotypes(tbl, country = "EUCAST", ...)
\item{vanc}{column name of an antibiotic, see Antibiotics} \item{vanc}{column name of an antibiotic, see Antibiotics}
\item{col_bactid}{deprecated, use \code{col_mo} instead.}
\item{...}{parameters that are passed on to methods} \item{...}{parameters that are passed on to methods}
} }
\value{ \value{

2
man/resistance_predict.Rd
View File

@@ -89,7 +89,7 @@ septic_patients \%>\%
if (!require(ggplot2)) { if (!require(ggplot2)) {
data <- septic_patients \%>\% data <- septic_patients \%>\%
filter(mo == "ESCCOL") \%>\% filter(mo == as.mo("E. coli")) \%>\%
resistance_predict(col_ab = "amox", resistance_predict(col_ab = "amox",
col_date = "date", col_date = "date",
info = FALSE, info = FALSE,

8
tests/testthat/test-age.R
View File

@@ -20,17 +20,17 @@ context("age.R")
test_that("age works", { test_that("age works", {
expect_equal(age(x = c("1980-01-01", "1985-01-01", "1990-01-01"), expect_equal(age(x = c("1980-01-01", "1985-01-01", "1990-01-01"),
y = "2019-01-01"), reference = "2019-01-01"),
c(39, 34, 29)) c(39, 34, 29))
expect_error(age(x = c("1980-01-01", "1985-01-01", "1990-01-01"), expect_error(age(x = c("1980-01-01", "1985-01-01", "1990-01-01"),
y = c("2019-01-01", "2019-01-01"))) reference = c("2019-01-01", "2019-01-01")))
expect_error(age(x = c("1980-01-01", "1985-01-01", "1990-01-01"), expect_error(age(x = c("1980-01-01", "1985-01-01", "1990-01-01"),
y = "1975-01-01")) reference = "1975-01-01"))
expect_warning(age(x = c("1800-01-01", "1805-01-01", "1810-01-01"), expect_warning(age(x = c("1800-01-01", "1805-01-01", "1810-01-01"),
y = "2019-01-01")) reference = "2019-01-01"))
}) })
test_that("age_groups works", { test_that("age_groups works", {

14
tests/testthat/test-deprecated.R
View File

@@ -20,11 +20,6 @@ context("deprecated.R")
test_that("deprecated functions work", { test_that("deprecated functions work", {
expect_identical(is.mo(as.mo("esco")), suppressWarnings(is.bactid(as.bactid("esco"))))
expect_warning(identical(is.mo(as.mo("esco")), is.bactid(as.bactid("esco"))))
expect_identical(as.mo("esco"), suppressWarnings(guess_bactid("esco")))
expect_error(suppressWarnings(ratio("A"))) expect_error(suppressWarnings(ratio("A")))
expect_error(suppressWarnings(ratio(1, ratio = "abc"))) expect_error(suppressWarnings(ratio(1, ratio = "abc")))
expect_error(suppressWarnings(ratio(c(1, 2), ratio = c(1, 2, 3)))) expect_error(suppressWarnings(ratio(c(1, 2), ratio = c(1, 2, 3))))
@@ -32,13 +27,4 @@ test_that("deprecated functions work", {
expect_identical(suppressWarnings(ratio(c(772, 1611, 737), ratio = "1:2:1")), c(780, 1560, 780)) expect_identical(suppressWarnings(ratio(c(772, 1611, 737), ratio = "1:2:1")), c(780, 1560, 780))
expect_identical(suppressWarnings(ratio(c(1752, 1895), ratio = c(1, 1))), c(1823.5, 1823.5)) expect_identical(suppressWarnings(ratio(c(1752, 1895), ratio = c(1, 1))), c(1823.5, 1823.5))
old_mo <- "ESCCOL"
class(old_mo) <- "bactid"
df_oldmo <- data.frame(test = old_mo)
# print
expect_output(print(old_mo))
# test pull
library(dplyr)
expect_identical(df_oldmo %>% pull(test), old_mo)
}) })

11
tests/testthat/test-first_isolate.R
View File

@@ -19,7 +19,7 @@
context("first_isolate.R") context("first_isolate.R")
test_that("first isolates work", { test_that("first isolates work", {
# septic_patients contains 1331 out of 2000 first isolates # septic_patients contains 1315 out of 2000 first isolates
expect_equal( expect_equal(
sum( sum(
first_isolate(tbl = septic_patients, first_isolate(tbl = septic_patients,
@@ -139,8 +139,7 @@ test_that("first isolates work", {
mutate(first = first_isolate(., "date", "patient_id", mutate(first = first_isolate(., "date", "patient_id",
col_mo = "mo", col_mo = "mo",
col_specimen = "specimen", col_specimen = "specimen",
filter_specimen = "something_unexisting", filter_specimen = "something_unexisting")))
output_logical = FALSE)))
# printing of exclusion message # printing of exclusion message
expect_output(septic_patients %>% expect_output(septic_patients %>%
@@ -158,11 +157,9 @@ test_that("first isolates work", {
# look for columns itself # look for columns itself
expect_message(first_isolate(septic_patients)) expect_message(first_isolate(septic_patients))
expect_message(first_isolate(septic_patients %>% expect_error(first_isolate(septic_patients %>%
mutate(mo = as.character(mo)) %>% mutate(mo = as.character(mo)) %>%
left_join_microorganisms(), left_join_microorganisms()))
col_genus = "genus",
col_species = "species"))
# if mo is not an mo class, result should be the same # if mo is not an mo class, result should be the same
expect_identical(septic_patients %>% expect_identical(septic_patients %>%

4
tests/testthat/test-mdro.R
View File

@@ -21,8 +21,8 @@ context("mdro.R")
test_that("mdro works", { test_that("mdro works", {
library(dplyr) library(dplyr)
expect_error(suppressWarnings(mdro(septic_patients, "invalid", col_bactid = "mo", info = TRUE))) expect_error(suppressWarnings(mdro(septic_patients, "invalid", col_mo = "mo", info = TRUE)))
expect_error(suppressWarnings(mdro(septic_patients, "fr", col_bactid = "mo", info = TRUE))) expect_error(suppressWarnings(mdro(septic_patients, "fr", info = TRUE)))
expect_error(suppressWarnings(mdro(septic_patients, country = c("de", "nl"), info = TRUE))) expect_error(suppressWarnings(mdro(septic_patients, country = c("de", "nl"), info = TRUE)))
expect_error(suppressWarnings(mdro(septic_patients, col_mo = "invalid", info = TRUE))) expect_error(suppressWarnings(mdro(septic_patients, col_mo = "invalid", info = TRUE)))

50
tests/testthat/test-portion.R
View File

@@ -147,53 +147,3 @@ test_that("old rsi works", {
}) })
test_that("prediction of rsi works", {
amox_R <- septic_patients %>%
filter(mo == "B_ESCHR_COL") %>%
rsi_predict(col_ab = "amox",
col_date = "date",
minimum = 10,
info = TRUE) %>%
pull("value")
# amox resistance will increase according to data set `septic_patients`
expect_true(amox_R[3] < amox_R[20])
expect_output(rsi_predict(tbl = filter(septic_patients, mo == "B_ESCHR_COL"),
model = "binomial",
col_ab = "amox",
col_date = "date",
info = TRUE))
expect_output(rsi_predict(tbl = filter(septic_patients, mo == "B_ESCHR_COL"),
model = "loglin",
col_ab = "amox",
col_date = "date",
info = TRUE))
expect_output(rsi_predict(tbl = filter(septic_patients, mo == "B_ESCHR_COL"),
model = "lin",
col_ab = "amox",
col_date = "date",
info = TRUE))
expect_error(rsi_predict(tbl = filter(septic_patients, mo == "B_ESCHR_COL"),
model = "INVALID MODEL",
col_ab = "amox",
col_date = "date",
info = TRUE))
expect_error(rsi_predict(tbl = filter(septic_patients, mo == "B_ESCHR_COL"),
col_ab = "NOT EXISTING COLUMN",
col_date = "date",
info = TRUE))
expect_error(rsi_predict(tbl = filter(septic_patients, mo == "B_ESCHR_COL"),
col_ab = "amox",
col_date = "NOT EXISTING COLUMN",
info = TRUE))
# almost all E. coli are mero S in the Netherlands :)
expect_error(resistance_predict(tbl = filter(septic_patients, mo == "B_ESCHR_COL"),
col_ab = "mero",
col_date = "date",
info = TRUE))
expect_error(portion_df(c("A", "B", "C")))
expect_error(portion_df(septic_patients[,"date"]))
})

71
tests/testthat/test-resistance_predict.R Normal file
View File

@@ -0,0 +1,71 @@
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Analysis #
# #
# AUTHORS #
# Berends MS (m.s.berends@umcg.nl), Luz CF (c.f.luz@umcg.nl) #
# #
# LICENCE #
# This package 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 R package 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 version 2.0 for more details. #
# ==================================================================== #
context("portion.R")
test_that("prediction of rsi works", {
amox_R <- septic_patients %>%
filter(mo == "B_ESCHR_COL") %>%
rsi_predict(col_ab = "amox",
col_date = "date",
minimum = 10,
info = TRUE) %>%
pull("value")
# amox resistance will increase according to data set `septic_patients`
expect_true(amox_R[3] < amox_R[20])
library(dplyr)
expect_output(rsi_predict(tbl = filter(septic_patients, mo == "B_ESCHR_COL"),
model = "binomial",
col_ab = "amox",
col_date = "date",
info = TRUE))
expect_output(rsi_predict(tbl = filter(septic_patients, mo == "B_ESCHR_COL"),
model = "loglin",
col_ab = "amox",
col_date = "date",
info = TRUE))
expect_output(rsi_predict(tbl = filter(septic_patients, mo == "B_ESCHR_COL"),
model = "lin",
col_ab = "amox",
col_date = "date",
info = TRUE))
expect_error(rsi_predict(tbl = filter(septic_patients, mo == "B_ESCHR_COL"),
model = "INVALID MODEL",
col_ab = "amox",
col_date = "date",
info = TRUE))
expect_error(rsi_predict(tbl = filter(septic_patients, mo == "B_ESCHR_COL"),
col_ab = "NOT EXISTING COLUMN",
col_date = "date",
info = TRUE))
expect_error(rsi_predict(tbl = filter(septic_patients, mo == "B_ESCHR_COL"),
col_ab = "amox",
col_date = "NOT EXISTING COLUMN",
info = TRUE))
# almost all E. coli are mero S in the Netherlands :)
expect_error(resistance_predict(tbl = filter(septic_patients, mo == "B_ESCHR_COL"),
col_ab = "mero",
col_date = "date",
info = TRUE))
expect_error(portion_df(c("A", "B", "C")))
expect_error(portion_df(septic_patients[,"date"]))
})