Browse Source

(v1.4.0.9001) is_gram_positive(), is_gram_negative(), parameter hardening

new-mo-algorithm
parent
commit
4e9ccb4435
  1. 4
      .github/workflows/check.yaml
  2. 4
      DESCRIPTION
  3. 2
      NAMESPACE
  4. 11
      NEWS.md
  5. 83
      R/aa_helper_functions.R
  6. 3
      R/ab.R
  7. 7
      R/ab_class_selectors.R
  8. 9
      R/ab_from_text.R
  9. 33
      R/ab_property.R
  10. 39
      R/age.R
  11. 19
      R/atc_online.R
  12. 4
      R/availability.R
  13. 22
      R/bug_drug_combinations.R
  14. 1
      R/count.R
  15. 16
      R/deprecated.R
  16. 6
      R/disk.R
  17. 15
      R/eucast_rules.R
  18. 27
      R/filter_ab_class.R
  19. 46
      R/first_isolate.R
  20. 48
      R/ggplot_pca.R
  21. 57
      R/ggplot_rsi.R
  22. 18
      R/guess_ab_col.R
  23. 40
      R/join_microorganisms.R
  24. 45
      R/key_antibiotics.R
  25. 8
      R/kurtosis.R
  26. 14
      R/like.R
  27. 24
      R/mdro.R
  28. 16
      R/mic.R
  29. 25
      R/mo.R
  30. 3
      R/mo_matching_score.R
  31. 93
      R/mo_property.R
  32. 8
      R/mo_source.R
  33. 48
      R/p_symbol.R
  34. 9
      R/pca.R
  35. 1
      R/proportion.R
  36. 22
      R/resistance_predict.R
  37. 50
      R/rsi.R
  38. 23
      R/rsi_calc.R
  39. 1
      R/rsi_df.R
  40. 4
      R/skewness.R
  41. 16
      R/translate.R
  42. 2
      docs/404.html
  43. 2
      docs/LICENSE-text.html
  44. 2
      docs/articles/index.html
  45. 2
      docs/authors.html
  46. 2
      docs/index.html
  47. 177
      docs/news/index.html
  48. 2
      docs/pkgdown.yml
  49. 20
      docs/reference/AMR-deprecated.html
  50. 13
      docs/reference/age.html
  51. 13
      docs/reference/age_groups.html
  52. 4
      docs/reference/antibiotic_class_selectors.html
  53. 4
      docs/reference/as.rsi.html
  54. 6
      docs/reference/bug_drug_combinations.html
  55. 83
      docs/reference/ggplot_pca.html
  56. 4
      docs/reference/guess_ab_col.html
  57. 8
      docs/reference/index.html
  58. 16
      docs/reference/key_antibiotics.html
  59. 10
      docs/reference/mo_property.html
  60. 2
      docs/reference/plot.html
  61. 6
      docs/sitemap.xml
  62. 2
      docs/survey.html
  63. 24
      man/AMR-deprecated.Rd
  64. 9
      man/age.Rd
  65. 11
      man/age_groups.Rd
  66. 2
      man/antibiotic_class_selectors.Rd
  67. 2
      man/as.rsi.Rd
  68. 4
      man/bug_drug_combinations.Rd
  69. 5
      man/ggplot_pca.Rd
  70. 2
      man/guess_ab_col.Rd
  71. 14
      man/key_antibiotics.Rd
  72. 10
      man/mo_property.Rd
  73. 33
      man/p_symbol.Rd
  74. 3
      tests/testthat/test-_deprecated.R
  75. 5
      tests/testthat/test-mo_property.R
  76. 32
      tests/testthat/test-p_symbol.R

4
.github/workflows/check.yaml

@ -58,8 +58,8 @@ jobs: @@ -58,8 +58,8 @@ jobs:
- {os: ubuntu-16.04, r: '4.0', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
- {os: ubuntu-16.04, r: '3.6', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
- {os: ubuntu-16.04, r: '3.5', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
- {os: ubuntu-16.04, r: '3.4', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
- {os: ubuntu-16.04, r: '3.3', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
# - {os: ubuntu-16.04, r: '3.4', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
# - {os: ubuntu-16.04, r: '3.3', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
env:
R_REMOTES_NO_ERRORS_FROM_WARNINGS: true

4
DESCRIPTION

@ -1,6 +1,6 @@ @@ -1,6 +1,6 @@
Package: AMR
Version: 1.4.0.9000
Date: 2020-10-15
Version: 1.4.0.9001
Date: 2020-10-19
Title: Antimicrobial Resistance Analysis
Authors@R: c(
person(role = c("aut", "cre"),

2
NAMESPACE

@ -150,6 +150,8 @@ export(is.mic) @@ -150,6 +150,8 @@ export(is.mic)
export(is.mo)
export(is.rsi)
export(is.rsi.eligible)
export(is_gram_negative)
export(is_gram_positive)
export(key_antibiotics)
export(key_antibiotics_equal)
export(kurtosis)

11
NEWS.md

@ -1,5 +1,12 @@ @@ -1,5 +1,12 @@
# AMR 1.4.0.9000
## <small>Last updated: 15 October 2020</small>
# AMR 1.4.0.9001
## <small>Last updated: 19 October 2020</small>
### New
* Functions `is_gram_negative()` and `is_gram_positive()` as wrappers around `mo_gramstain()`. They always return `TRUE` or `FALSE`, thus always return `FALSE` for species outside the taxonomic kingdom of Bacteria.
### Changed
* For all function parameters in the code, it is now defined what the exact type of user input should be (inspired by the [`typed`](https://github.com/moodymudskipper/typed) package). If the user input for a certain function does not meet the requirements for a specific parameter (such as the class or length), an informative error will be thrown. This makes the package more robust and the use of it more reproducible and reliable. In total, more than 400 arguments were defined.
* Deprecated function `p_symbol()` that not really fits the scope of this package. It will be removed in a future version. See [here](https://github.com/msberends/AMR/blob/v1.4.0/R/p_symbol.R) for the source code to preserve it.
### Other
* More extensive unit tests

83
R/aa_helper_functions.R

@ -329,6 +329,89 @@ create_ab_documentation <- function(ab) { @@ -329,6 +329,89 @@ create_ab_documentation <- function(ab) {
out
}
# a check for every single argument in all functions
meet_criteria <- function(object,
allow_class = NULL,
has_length = NULL,
looks_like = NULL,
is_in = NULL,
contains_column_class = NULL,
allow_NULL = FALSE,
allow_NA = FALSE,
ignore.case = FALSE,
.call_depth = 0) { # depth in calling
obj_name <- deparse(substitute(object))
call_depth <- -2 - abs(.call_depth)
if (is.null(object)) {
stop_if(allow_NULL == FALSE, "argument `", obj_name, "` must not be NULL", call = call_depth)
return(invisible())
}
if (is.null(dim(object)) && length(object) == 1 && is.na(object)) {
stop_if(allow_NA == FALSE, "argument `", obj_name, "` must not be NA", call = call_depth)
return(invisible())
}
vector_or <- function(v, quotes) {
if (length(v) == 1) {
return(paste0(ifelse(quotes, '"', ""), v, ifelse(quotes, '"', "")))
}
# all commas except for last item, so will become '"val1", "val2", "val3" or "val4"'
paste0(paste0(ifelse(quotes, '"', ""), v[seq_len(length(v) - 1)], ifelse(quotes, '"', ""), collapse = ", "),
" or ", paste0(ifelse(quotes, '"', ""), v[length(v)], ifelse(quotes, '"', "")))
}
if (!is.null(allow_class)) {
stop_ifnot(inherits(object, allow_class), "argument `", obj_name,
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
"be of class ", vector_or(allow_class, quotes = TRUE),
", not \"", paste(class(object), collapse = "/"), "\"",
call = call_depth)
# check data.frames for data
if (inherits(object, "data.frame")) {
stop_if(any(dim(object) == 0),
"the data provided in argument `", obj_name,
"` must contain rows and columns (current dimensions: ",
paste(dim(object), collapse = " x "), ")",
call = call_depth)
}
}
if (!is.null(has_length)) {
stop_ifnot(length(object) %in% has_length, "argument `", obj_name,
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
"be of length ", vector_or(has_length, quotes = FALSE),
", not ", length(object),
call = call_depth)
}
if (!is.null(looks_like)) {
stop_ifnot(object %like% looks_like, "argument `", obj_name,
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
"resemble the regular expression \"", looks_like, "\"",
call = call_depth)
}
if (!is.null(is_in)) {
if (ignore.case == TRUE) {
object <- tolower(object)
is_in <- tolower(is_in)
}
stop_ifnot(all(object %in% is_in, na.rm = TRUE), "argument `", obj_name,
"` must be ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1, "one of: ", ""),
vector_or(is_in, quotes = TRUE),
", not ", paste0("\"", object, "\"", collapse = "/"), "",
call = call_depth)
}
if (!is.null(contains_column_class)) {
stop_ifnot(any(sapply(object, function(col, columns_class = contains_column_class) inherits(col, columns_class)), na.rm = TRUE),
"the data provided in argument `", obj_name,
"` must contain at least one column of class <", contains_column_class, ">. ",
"See ?as.", contains_column_class, ".",
call = call_depth)
}
return(invisible())
}
has_colour <- function() {
# this is a base R version of crayon::has_color
enabled <- getOption("crayon.enabled")

3
R/ab.R

@ -82,6 +82,9 @@ @@ -82,6 +82,9 @@
#' ab_name("J01FA01") # "Erythromycin"
#' ab_name("eryt") # "Erythromycin"
as.ab <- function(x, flag_multiple_results = TRUE, info = TRUE, ...) {
meet_criteria(x, allow_class = c("character", "numeric", "integer"), allow_NA = TRUE)
meet_criteria(flag_multiple_results, allow_class = "logical", has_length = 1)
meet_criteria(info, allow_class = "logical", has_length = 1)
check_dataset_integrity()

7
R/ab_class_selectors.R

@ -54,7 +54,7 @@ @@ -54,7 +54,7 @@
#'
#' # get bug/drug combinations for only macrolides in Gram-positives:
#' example_isolates %>%
#' filter(mo_gramstain(mo) %like% "pos") %>%
#' filter(mo %>% is_gram_positive()) %>%
#' select(mo, macrolides()) %>%
#' bug_drug_combinations() %>%
#' format()
@ -148,9 +148,12 @@ tetracyclines <- function() { @@ -148,9 +148,12 @@ tetracyclines <- function() {
}
ab_selector <- function(ab_class, function_name) {
meet_criteria(ab_class, allow_class = "character", has_length = 1, .call_depth = 1)
meet_criteria(function_name, allow_class = "character", has_length = 1, .call_depth = 1)
peek_vars_tidyselect <- import_fn("peek_vars", "tidyselect")
vars_vct <- peek_vars_tidyselect(fn = function_name)
vars_df <- data.frame(as.list(vars_vct))[0, , drop = FALSE]
vars_df <- data.frame(as.list(vars_vct))[1, , drop = FALSE]
colnames(vars_df) <- vars_vct
ab_in_data <- get_column_abx(vars_df, info = FALSE)

9
R/ab_from_text.R

@ -92,12 +92,17 @@ ab_from_text <- function(text, @@ -92,12 +92,17 @@ ab_from_text <- function(text,
translate_ab = FALSE,
thorough_search = NULL,
...) {
if (missing(type)) {
type <- type[1L]
}
meet_criteria(text)
meet_criteria(type, allow_class = "character", has_length = 1)
meet_criteria(collapse, has_length = 1, allow_NULL = TRUE)
meet_criteria(translate_ab, allow_NULL = FALSE) # get_translate_ab() will be more informative about what's allowed
meet_criteria(thorough_search, allow_class = "logical", has_length = 1, allow_NULL = TRUE)
type <- tolower(trimws(type))
stop_if(length(type) != 1, "`type` must be of length 1")
text <- tolower(as.character(text))
text_split_all <- strsplit(text, "[ ;.,:\\|]")

33
R/ab_property.R

@ -89,6 +89,10 @@ @@ -89,6 +89,10 @@
#' ab_atc("cephthriaxone")
#' ab_atc("seephthriaaksone")
ab_name <- function(x, language = get_locale(), tolower = FALSE, ...) {
meet_criteria(x, allow_class = c("character", "numeric", "integer"))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(tolower, allow_class = "logical", has_length = 1)
x <- translate_AMR(ab_validate(x = x, property = "name", ...), language = language)
if (tolower == TRUE) {
# use perl to only transform the first character
@ -102,18 +106,21 @@ ab_name <- function(x, language = get_locale(), tolower = FALSE, ...) { @@ -102,18 +106,21 @@ ab_name <- function(x, language = get_locale(), tolower = FALSE, ...) {
#' @aliases ATC
#' @export
ab_atc <- function(x, ...) {
meet_criteria(x, allow_class = c("character", "numeric", "integer"))
ab_validate(x = x, property = "atc", ...)
}
#' @rdname ab_property
#' @export
ab_cid <- function(x, ...) {
meet_criteria(x, allow_class = c("character", "numeric", "integer"))
ab_validate(x = x, property = "cid", ...)
}
#' @rdname ab_property
#' @export
ab_synonyms <- function(x, ...) {
meet_criteria(x, allow_class = c("character", "numeric", "integer"))
syns <- ab_validate(x = x, property = "synonyms", ...)
names(syns) <- x
if (length(syns) == 1) {
@ -126,30 +133,38 @@ ab_synonyms <- function(x, ...) { @@ -126,30 +133,38 @@ ab_synonyms <- function(x, ...) {
#' @rdname ab_property
#' @export
ab_tradenames <- function(x, ...) {
meet_criteria(x, allow_class = c("character", "numeric", "integer"))
ab_synonyms(x, ...)
}
#' @rdname ab_property
#' @export
ab_group <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_class = c("character", "numeric", "integer"))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
translate_AMR(ab_validate(x = x, property = "group", ...), language = language)
}
#' @rdname ab_property
#' @export
ab_atc_group1 <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_class = c("character", "numeric", "integer"))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
translate_AMR(ab_validate(x = x, property = "atc_group1", ...), language = language)
}
#' @rdname ab_property
#' @export
ab_atc_group2 <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_class = c("character", "numeric", "integer"))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
translate_AMR(ab_validate(x = x, property = "atc_group2", ...), language = language)
}
#' @rdname ab_property
#' @export
ab_loinc <- function(x, ...) {
meet_criteria(x, allow_class = c("character", "numeric", "integer"))
loincs <- ab_validate(x = x, property = "loinc", ...)
names(loincs) <- x
if (length(loincs) == 1) {
@ -162,7 +177,10 @@ ab_loinc <- function(x, ...) { @@ -162,7 +177,10 @@ ab_loinc <- function(x, ...) {
#' @rdname ab_property
#' @export
ab_ddd <- function(x, administration = "oral", units = FALSE, ...) {
stop_ifnot(administration %in% c("oral", "iv"), "`administration` must be 'oral' or 'iv'")
meet_criteria(x, allow_class = c("character", "numeric", "integer"))
meet_criteria(administration, is_in = c("oral", "iv"), has_length = 1)
meet_criteria(units, allow_class = "logical", has_length = 1)
ddd_prop <- administration
if (units == TRUE) {
ddd_prop <- paste0(ddd_prop, "_units")
@ -175,6 +193,9 @@ ab_ddd <- function(x, administration = "oral", units = FALSE, ...) { @@ -175,6 +193,9 @@ ab_ddd <- function(x, administration = "oral", units = FALSE, ...) {
#' @rdname ab_property
#' @export
ab_info <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_class = c("character", "numeric", "integer"))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
x <- as.ab(x, ...)
list(ab = as.character(x),
atc = ab_atc(x),
@ -194,6 +215,9 @@ ab_info <- function(x, language = get_locale(), ...) { @@ -194,6 +215,9 @@ ab_info <- function(x, language = get_locale(), ...) {
#' @rdname ab_property
#' @export
ab_url <- function(x, open = FALSE, ...) {
meet_criteria(x, allow_class = c("character", "numeric", "integer"))
meet_criteria(open, allow_class = "logical", has_length = 1)
ab <- as.ab(x = x, ... = ...)
u <- paste0("https://www.whocc.no/atc_ddd_index/?code=", ab_atc(ab), "&showdescription=no")
u[is.na(ab_atc(ab))] <- NA_character_
@ -218,10 +242,9 @@ ab_url <- function(x, open = FALSE, ...) { @@ -218,10 +242,9 @@ ab_url <- function(x, open = FALSE, ...) {
#' @rdname ab_property
#' @export
ab_property <- function(x, property = "name", language = get_locale(), ...) {
stop_if(length(property) != 1L, "'property' must be of length 1.")
stop_ifnot(property %in% colnames(antibiotics),
"invalid property: '", property, "' - use a column name of the `antibiotics` data set")
meet_criteria(x, allow_class = c("character", "numeric", "integer"))
meet_criteria(property, is_in = colnames(antibiotics), has_length = 1)
meet_criteria(language, is_in = c(LANGUAGES_SUPPORTED, ""), has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
translate_AMR(ab_validate(x = x, property = property, ...), language = language)
}

39
R/age.R

@ -28,9 +28,11 @@ @@ -28,9 +28,11 @@
#' Calculates age in years based on a reference date, which is the sytem date at default.
#' @inheritSection lifecycle Stable lifecycle
#' @param x date(s), will be coerced with [as.POSIXlt()]
#' @param reference reference date(s) (defaults to today), will be coerced with [as.POSIXlt()] and cannot be lower than `x`
#' @param reference reference date(s) (defaults to today), will be coerced with [as.POSIXlt()]
#' @param exact a logical to indicate whether age calculation should be exact, i.e. with decimals. It divides the number of days of [year-to-date](https://en.wikipedia.org/wiki/Year-to-date) (YTD) of `x` by the number of days in the year of `reference` (either 365 or 366).
#' @param na.rm a logical to indicate whether missing values should be removed
#' @param ... parameters passed on to [as.POSIXlt()], such as `origin`
#' @details Ages below 0 will be returned as `NA` with a warning. Ages above 120 will only give a warning.
#' @return An [integer] (no decimals) if `exact = FALSE`, a [double] (with decimals) otherwise
#' @seealso To split ages into groups, use the [age_groups()] function.
#' @inheritSection AMR Read more on our website!
@ -44,13 +46,18 @@ @@ -44,13 +46,18 @@
#' df$age_exact <- age(df$birth_date, exact = TRUE)
#'
#' df
age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE) {
age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
meet_criteria(x, allow_class = c("character", "Date", "POSIXt"))
meet_criteria(reference, allow_class = c("character", "Date", "POSIXt"))
meet_criteria(exact, allow_class = "logical", has_length = 1)
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
if (length(x) != length(reference)) {
stop_if(length(reference) != 1, "`x` and `reference` must be of same length, or `reference` must be of length 1.")
reference <- rep(reference, length(x))
}
x <- as.POSIXlt(x)
reference <- as.POSIXlt(reference)
x <- as.POSIXlt(x, ...)
reference <- as.POSIXlt(reference, ...)
# from https://stackoverflow.com/a/25450756/4575331
years_gap <- reference$year - x$year
@ -98,13 +105,13 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE) { @@ -98,13 +105,13 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE) {
#' @param na.rm a [logical] to indicate whether missing values should be removed
#' @details To split ages, the input for the `split_at` parameter can be:
#'
#' * A numeric vector. A vector of e.g. `c(10, 20)` will split on 0-9, 10-19 and 20+. A value of only `50` will split on 0-49 and 50+.
#' * A numeric vector. A value of e.g. `c(10, 20)` will split `x` on 0-9, 10-19 and 20+. A value of only `50` will split `x` on 0-49 and 50+.
#' The default is to split on young children (0-11), youth (12-24), young adults (25-54), middle-aged adults (55-74) and elderly (75+).
#' * A character:
#' - `"children"` or `"kids"`, equivalent of: `c(0, 1, 2, 4, 6, 13, 18)`. This will split on 0, 1, 2-3, 4-5, 6-12, 13-17 and 18+.
#' - `"elderly"` or `"seniors"`, equivalent of: `c(65, 75, 85)`. This will split on 0-64, 65-74, 75-84, 85+.
#' - `"fives"`, equivalent of: `1:20 * 5`. This will split on 0-4, 5-9, 10-14, ..., 90-94, 95-99, 100+.
#' - `"tens"`, equivalent of: `1:10 * 10`. This will split on 0-9, 10-19, 20-29, ..., 80-89, 90-99, 100+.
#' - `"fives"`, equivalent of: `1:20 * 5`. This will split on 0-4, 5-9, ..., 95-99, 100+.
#' - `"tens"`, equivalent of: `1:10 * 10`. This will split on 0-9, 10-19, ..., 90-99, 100+.
#' @return Ordered [factor]
#' @seealso To determine ages, based on one or more reference dates, use the [age()] function.
#' @export
@ -127,12 +134,11 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE) { @@ -127,12 +134,11 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE) {
#' age_groups(ages, split_at = "fives")
#'
#' # split specifically for children
#' age_groups(ages, "children")
#' # same:
#' age_groups(ages, c(1, 2, 4, 6, 13, 17))
#' age_groups(ages, "children")
#'
#' \donttest{
#' # resistance of ciprofloxacine per age group
#' # resistance of ciprofloxacin per age group
#' library(dplyr)
#' example_isolates %>%
#' filter_first_isolate() %>%
@ -142,7 +148,10 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE) { @@ -142,7 +148,10 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE) {
#' ggplot_rsi(x = "age_group", minimum = 0)
#' }
age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
stop_ifnot(is.numeric(x), "`x` must be numeric, not ", paste0(class(x), collapse = "/"))
meet_criteria(x, allow_class = c("numeric", "integer"))
meet_criteria(split_at, allow_class = c("numeric", "integer", "character"))
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
if (any(x < 0, na.rm = TRUE)) {
x[x < 0] <- NA
warning("NAs introduced for ages below 0.")
@ -169,17 +178,17 @@ age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) { @@ -169,17 +178,17 @@ age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
# turn input values to 'split_at' indices
y <- x
labs <- split_at
lbls <- split_at
for (i in seq_len(length(split_at))) {
y[x >= split_at[i]] <- i
# create labels
labs[i - 1] <- paste0(unique(c(split_at[i - 1], split_at[i] - 1)), collapse = "-")
lbls[i - 1] <- paste0(unique(c(split_at[i - 1], split_at[i] - 1)), collapse = "-")
}
# last category
labs[length(labs)] <- paste0(split_at[length(split_at)], "+")
lbls[length(lbls)] <- paste0(split_at[length(split_at)], "+")
agegroups <- factor(labs[y], levels = labs, ordered = TRUE)
agegroups <- factor(lbls[y], levels = lbls, ordered = TRUE)
if (isTRUE(na.rm)) {
agegroups <- agegroups[!is.na(agegroups)]

19
R/atc_online.R

@ -78,6 +78,11 @@ atc_online_property <- function(atc_code, @@ -78,6 +78,11 @@ atc_online_property <- function(atc_code,
administration = "O",
url = "https://www.whocc.no/atc_ddd_index/?code=%s&showdescription=no",
url_vet = "https://www.whocc.no/atcvet/atcvet_index/?code=%s&showdescription=no") {
meet_criteria(atc_code, allow_class = "character")
meet_criteria(property, allow_class = "character", has_length = 1, is_in = c("ATC", "Name", "DDD", "U", "Adm.R", "Note", "groups"), ignore.case = TRUE)
meet_criteria(administration, allow_class = "character", has_length = 1)
meet_criteria(url, allow_class = "character", has_length = 1, looks_like = "https?://")
meet_criteria(url_vet, allow_class = "character", has_length = 1, looks_like = "https?://")
has_internet <- import_fn("has_internet", "curl")
html_attr <- import_fn("html_attr", "rvest")
@ -99,24 +104,12 @@ atc_online_property <- function(atc_code, @@ -99,24 +104,12 @@ atc_online_property <- function(atc_code,
return(rep(NA, length(atc_code)))
}
stop_if(length(property) != 1L, "`property` must be of length 1")
stop_if(length(administration) != 1L, "`administration` must be of length 1")
# also allow unit as property
if (property %like% "unit") {
property <- "U"
}
# validation of properties
valid_properties <- c("ATC", "Name", "DDD", "U", "Adm.R", "Note", "groups")
valid_properties.bak <- valid_properties
property <- tolower(property)
valid_properties <- tolower(valid_properties)
stop_ifnot(property %in% valid_properties,
"Invalid `property`, use one of ", paste(valid_properties.bak, collapse = ", "))
if (property == "ddd") {
returnvalue <- rep(NA_real_, length(atc_code))
} else if (property == "groups") {
@ -199,11 +192,13 @@ atc_online_property <- function(atc_code, @@ -199,11 +192,13 @@ atc_online_property <- function(atc_code,
#' @rdname atc_online
#' @export
atc_online_groups <- function(atc_code, ...) {
meet_criteria(atc_code, allow_class = "character")
atc_online_property(atc_code = atc_code, property = "groups", ...)
}
#' @rdname atc_online
#' @export
atc_online_ddd <- function(atc_code, ...) {
meet_criteria(atc_code, allow_class = "character")
atc_online_property(atc_code = atc_code, property = "ddd", ...)
}

4
R/availability.R

@ -43,7 +43,9 @@ @@ -43,7 +43,9 @@
#' availability()
#' }
availability <- function(tbl, width = NULL) {
stop_ifnot(is.data.frame(tbl), "`tbl` must be a data.frame")
meet_criteria(tbl, allow_class = "data.frame")
meet_criteria(width, allow_class = "numeric", allow_NULL = TRUE)
x <- sapply(tbl, function(x) {
1 - sum(is.na(x)) / length(x)
})

22
R/bug_drug_combinations.R

@ -31,8 +31,8 @@ @@ -31,8 +31,8 @@
#' @param combine_IR logical to indicate whether values R and I should be summed
#' @param add_ab_group logical to indicate where the group of the antimicrobials must be included as a first column
#' @param remove_intrinsic_resistant logical to indicate that rows and columns with 100% resistance for all tested antimicrobials must be removed from the table
#' @param FUN the function to call on the `mo` column to transform the microorganism IDs, defaults to [mo_shortname()]
#' @param translate_ab a character of length 1 containing column names of the [antibiotics] data set
#' @param FUN function to call on the `mo` column to transform the microorganism IDs, defaults to [mo_shortname()]
#' @param translate_ab character of length 1 containing column names of the [antibiotics] data set
#' @param ... arguments passed on to `FUN`
#' @inheritParams rsi_df
#' @inheritParams base::formatC
@ -61,9 +61,10 @@ bug_drug_combinations <- function(x, @@ -61,9 +61,10 @@ bug_drug_combinations <- function(x,
col_mo = NULL,
FUN = mo_shortname,
...) {
stop_ifnot(is.data.frame(x), "`x` must be a data frame")
stop_ifnot(any(sapply(x, is.rsi), na.rm = TRUE), "No columns with class <rsi> found. See ?as.rsi.")
meet_criteria(x, allow_class = "data.frame", contains_column_class = "rsi")
meet_criteria(col_mo, allow_class = "character", is_in = colnames(x), has_length = 1, allow_NULL = TRUE)
meet_criteria(FUN, allow_class = "function", has_length = 1)
# try to find columns based on type
# -- mo
if (is.null(col_mo)) {
@ -121,6 +122,17 @@ format.bug_drug_combinations <- function(x, @@ -121,6 +122,17 @@ format.bug_drug_combinations <- function(x,
decimal.mark = getOption("OutDec"),
big.mark = ifelse(decimal.mark == ",", ".", ","),
...) {
meet_criteria(x, allow_class = "data.frame")
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
meet_criteria(combine_IR, allow_class = "logical", has_length = 1)
meet_criteria(add_ab_group, allow_class = "logical", has_length = 1)
meet_criteria(remove_intrinsic_resistant, allow_class = "logical", has_length = 1)
meet_criteria(decimal.mark, allow_class = "character", has_length = 1)
meet_criteria(big.mark, allow_class = "character", has_length = 1)
x <- as.data.frame(x, stringsAsFactors = FALSE)
x <- subset(x, total >= minimum)

1
R/count.R

@ -189,7 +189,6 @@ count_df <- function(data, @@ -189,7 +189,6 @@ count_df <- function(data,
language = get_locale(),
combine_SI = TRUE,
combine_IR = FALSE) {
rsi_calc_df(type = "count",
data = data,
translate_ab = translate_ab,

16
R/deprecated.R

@ -30,4 +30,18 @@ @@ -30,4 +30,18 @@
#' @inheritSection AMR Read more on our website!
#' @keywords internal
#' @name AMR-deprecated
# @export
#' @export
p_symbol <- function(p, emptychar = " ") {
.Deprecated(package = "AMR")
p <- as.double(p)
s <- rep(NA_character_, length(p))
s[p <= 1] <- emptychar
s[p <= 0.100] <- "."
s[p <= 0.050] <- "*"
s[p <= 0.010] <- "**"
s[p <= 0.001] <- "***"
s
}

6
R/disk.R

@ -58,6 +58,9 @@ @@ -58,6 +58,9 @@
#' as.rsi(df)
#' }
as.disk <- function(x, na.rm = FALSE) {
meet_criteria(x, allow_class = c("disk", "character", "numeric", "integer"), allow_NA = TRUE)
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
if (!is.disk(x)) {
x <- x %pm>% unlist()
if (na.rm == TRUE) {
@ -109,6 +112,9 @@ as.disk <- function(x, na.rm = FALSE) { @@ -109,6 +112,9 @@ as.disk <- function(x, na.rm = FALSE) {
}
all_valid_disks <- function(x) {
if (!inherits(x, c("disk", "character", "numeric", "integer"))) {
return(FALSE)
}
x_disk <- suppressWarnings(as.disk(x[!is.na(x)]))
!any(is.na(x_disk)) & !all(is.na(x))
}

15
R/eucast_rules.R

@ -134,6 +134,13 @@ eucast_rules <- function(x, @@ -134,6 +134,13 @@ eucast_rules <- function(x,
version_breakpoints = 10.0,
version_expertrules = 3.2,
...) {
meet_criteria(x, allow_class = "data.frame")
meet_criteria(col_mo, allow_class = "character", has_length = 1, is_in = colnames(x), allow_NULL = TRUE)
meet_criteria(info, allow_class = "logical", has_length = 1)
meet_criteria(rules, allow_class = "character", has_length = c(1, 2, 3, 4), is_in = c("breakpoints", "expert", "other", "all"))
meet_criteria(verbose, allow_class = "logical", has_length = 1)
meet_criteria(version_breakpoints, allow_class = "numeric", has_length = 1)
meet_criteria(version_expertrules, allow_class = "numeric", has_length = 1)
x_deparsed <- deparse(substitute(x))
if (length(x_deparsed) > 1 || !all(x_deparsed %like% "[a-z]+")) {
@ -172,18 +179,12 @@ eucast_rules <- function(x, @@ -172,18 +179,12 @@ eucast_rules <- function(x,
}
}
stop_ifnot(is.data.frame(x), "`x` must be a data frame")
# try to find columns based on type
# -- mo
if (is.null(col_mo)) {
col_mo <- search_type_in_df(x = x, type = "mo", info = info)
}
stop_if(is.null(col_mo), "`col_mo` must be set")
stop_ifnot(col_mo %in% colnames(x), "column '", col_mo, "' (`col_mo`) not found")
stop_ifnot(all(rules %in% c("breakpoints", "expert", "other", "all")),
'`rules` must be one or more of: "breakpoints", "expert", "other", "all".')
decimal.mark <- getOption("OutDec")
big.mark <- ifelse(decimal.mark != ",", ",", ".")
@ -576,7 +577,7 @@ eucast_rules <- function(x, @@ -576,7 +577,7 @@ eucast_rules <- function(x,
# big speed gain! only analyse unique rows:
pm_distinct(`.rowid`, .keep_all = TRUE) %pm>%
as.data.frame(stringsAsFactors = FALSE)
x[, col_mo] <- as.mo(x[, col_mo, drop = TRUE])
x[, col_mo] <- as.mo(as.character(x[, col_mo, drop = TRUE]))
x <- x %pm>%
left_join_microorganisms(by = col_mo, suffix = c("_oldcols", ""))
x$gramstain <- mo_gramstain(x[, col_mo, drop = TRUE], language = NULL)

27
R/filter_ab_class.R

@ -80,16 +80,22 @@ filter_ab_class <- function(x, @@ -80,16 +80,22 @@ filter_ab_class <- function(x,
result = NULL,
scope = "any",
...) {
.call_depth <- list(...)$`.call_depth`
if (is.null(.call_depth)) {
.call_depth <- 0
}
meet_criteria(x, allow_class = "data.frame", .call_depth = .call_depth)
meet_criteria(ab_class, allow_class = "character", has_length = 1, .call_depth = .call_depth)
meet_criteria(result, allow_class = "character", has_length = c(1, 2, 3), allow_NULL = TRUE, .call_depth = .call_depth)
meet_criteria(scope, allow_class = "character", has_length = 1, is_in = c("all", "any"), .call_depth = .call_depth)
check_dataset_integrity()
stop_ifnot(is.data.frame(x), "`x` must be a data frame")
# save to return later
x_class <- class(x)
x.bak <- x
x <- as.data.frame(x, stringsAsFactors = FALSE)
scope <- scope[1L]
if (is.null(result)) {
result <- c("S", "I", "R")
}
@ -174,6 +180,7 @@ filter_aminoglycosides <- function(x, @@ -174,6 +180,7 @@ filter_aminoglycosides <- function(x,
ab_class = "aminoglycoside",
result = result,
scope = scope,
.call_depth = 1,
...)
}
@ -187,6 +194,7 @@ filter_carbapenems <- function(x, @@ -187,6 +194,7 @@ filter_carbapenems <- function(x,
ab_class = "carbapenem",
result = result,
scope = scope,
.call_depth = 1,
...)
}
@ -200,6 +208,7 @@ filter_cephalosporins <- function(x, @@ -200,6 +208,7 @@ filter_cephalosporins <- function(x,
ab_class = "cephalosporin",
result = result,
scope = scope,
.call_depth = 1,
...)
}
@ -213,6 +222,7 @@ filter_1st_cephalosporins <- function(x, @@ -213,6 +222,7 @@ filter_1st_cephalosporins <- function(x,
ab_class = "cephalosporins (1st gen.)",
result = result,
scope = scope,
.call_depth = 1,
...)
}
@ -226,6 +236,7 @@ filter_2nd_cephalosporins <- function(x, @@ -226,6 +236,7 @@ filter_2nd_cephalosporins <- function(x,
ab_class = "cephalosporins (2nd gen.)",
result = result,
scope = scope,
.call_depth = 1,
...)
}
@ -239,6 +250,7 @@ filter_3rd_cephalosporins <- function(x, @@ -239,6 +250,7 @@ filter_3rd_cephalosporins <- function(x,
ab_class = "cephalosporins (3rd gen.)",
result = result,
scope = scope,
.call_depth = 1,
...)
}
@ -252,6 +264,7 @@ filter_4th_cephalosporins <- function(x, @@ -252,6 +264,7 @@ filter_4th_cephalosporins <- function(x,
ab_class = "cephalosporins (4th gen.)",
result = result,
scope = scope,
.call_depth = 1,
...)
}
@ -265,6 +278,7 @@ filter_5th_cephalosporins <- function(x, @@ -265,6 +278,7 @@ filter_5th_cephalosporins <- function(x,
ab_class = "cephalosporins (5th gen.)",
result = result,
scope = scope,
.call_depth = 1,
...)
}
@ -278,6 +292,7 @@ filter_fluoroquinolones <- function(x, @@ -278,6 +292,7 @@ filter_fluoroquinolones <- function(x,
ab_class = "fluoroquinolone",
result = result,
scope = scope,
.call_depth = 1,
...)
}
@ -291,6 +306,7 @@ filter_glycopeptides <- function(x, @@ -291,6 +306,7 @@ filter_glycopeptides <- function(x,
ab_class = "glycopeptide",
result = result,
scope = scope,
.call_depth = 1,
...)
}
@ -304,6 +320,7 @@ filter_macrolides <- function(x, @@ -304,6 +320,7 @@ filter_macrolides <- function(x,
ab_class = "macrolide",
result = result,
scope = scope,
.call_depth = 1,
...)
}
@ -317,6 +334,7 @@ filter_penicillins <- function(x, @@ -317,6 +334,7 @@ filter_penicillins <- function(x,
ab_class = "penicillin",
result = result,
scope = scope,
.call_depth = 1,
...)
}
@ -330,6 +348,7 @@ filter_tetracyclines <- function(x, @@ -330,6 +348,7 @@ filter_tetracyclines <- function(x,
ab_class = "tetracycline",
result = result,
scope = scope,
.call_depth = 1,
...)
}

46
R/first_isolate.R

@ -139,6 +139,23 @@ first_isolate <- function(x, @@ -139,6 +139,23 @@ first_isolate <- function(x,
info = interactive(),
include_unknown = FALSE,
...) {
meet_criteria(x, allow_class = "data.frame")
meet_criteria(col_date, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
meet_criteria(col_patient_id, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
meet_criteria(col_mo, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
meet_criteria(col_testcode, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
meet_criteria(col_specimen, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
meet_criteria(col_icu, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
meet_criteria(col_keyantibiotics, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
meet_criteria(episode_days, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(testcodes_exclude, allow_class = "character", allow_NULL = TRUE)
meet_criteria(icu_exclude, allow_class = "logical", has_length = 1)
meet_criteria(specimen_group, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(type, allow_class = "character", has_length = 1)
meet_criteria(ignore_I, allow_class = "logical", has_length = 1)
meet_criteria(points_threshold, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(info, allow_class = "logical", has_length = 1)
meet_criteria(include_unknown, allow_class = "logical", has_length = 1)
dots <- unlist(list(...))
if (length(dots) != 0) {
@ -352,20 +369,20 @@ first_isolate <- function(x, @@ -352,20 +369,20 @@ first_isolate <- function(x,
info = info)
# with key antibiotics
x$newvar_first_isolate <- pm_if_else(x$newvar_row_index_sorted >= row.start &
x$newvar_row_index_sorted <= row.end &
x$newvar_genus_species != "" &
(x$other_pat_or_mo | x$more_than_episode_ago | x$other_key_ab),
TRUE,
FALSE)
x$newvar_row_index_sorted <= row.end &
x$newvar_genus_species != "" &
(x$other_pat_or_mo | x$more_than_episode_ago | x$other_key_ab),
TRUE,
FALSE)
} else {
# no key antibiotics
x$newvar_first_isolate <- pm_if_else(x$newvar_row_index_sorted >= row.start &
x$newvar_row_index_sorted <= row.end &
x$newvar_genus_species != "" &
(x$other_pat_or_mo | x$more_than_episode_ago),
TRUE,
FALSE)
x$newvar_row_index_sorted <= row.end &
x$newvar_genus_species != "" &
(x$other_pat_or_mo | x$more_than_episode_ago),
TRUE,
FALSE)
}
# first one as TRUE
@ -442,6 +459,10 @@ filter_first_isolate <- function(x, @@ -442,6 +459,10 @@ filter_first_isolate <- function(x,
col_patient_id = NULL,
col_mo = NULL,
...) {
meet_criteria(x, allow_class = "data.frame")
meet_criteria(col_date, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
meet_criteria(col_patient_id, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
meet_criteria(col_mo, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
subset(x, first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
@ -457,6 +478,11 @@ filter_first_weighted_isolate <- function(x, @@ -457,6 +478,11 @@ filter_first_weighted_isolate <- function(x,
col_mo = NULL,
col_keyantibiotics = NULL,
...) {
meet_criteria(x, allow_class = "data.frame")
meet_criteria(col_date, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
meet_criteria(col_patient_id, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
meet_criteria(col_mo, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
meet_criteria(col_keyantibiotics, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
y <- x
if (is.null(col_keyantibiotics)) {
# first try to look for it

48
R/ggplot_pca.R

@ -53,9 +53,10 @@ @@ -53,9 +53,10 @@
#' As per their GPL-2 licence that demands documentation of code changes, the changes made based on the source code were:
#' 1. Rewritten code to remove the dependency on packages `plyr`, `scales` and `grid`
#' 2. Parametrised more options, like arrow and ellipse settings
#' 3. Added total amount of explained variance as a caption in the plot
#' 4. Cleaned all syntax based on the `lintr` package and added integrity checks
#' 5. Updated documentation
#' 3. Hardened all input possibilities by defining the exact type of user input for every parameter
#' 4. Added total amount of explained variance as a caption in the plot
#' 5. Cleaned all syntax based on the `lintr` package, fixed grammatical errors and added integrity checks
#' 6. Updated documentation
#' @details The colours for labels and points can be changed by adding another scale layer for colour, like `scale_colour_viridis_d()` or `scale_colour_brewer()`.
#' @rdname ggplot_pca
#' @export
@ -85,7 +86,7 @@ @@ -85,7 +86,7 @@
#' }
ggplot_pca <- function(x,
choices = 1:2,
scale = TRUE,
scale = 1,
pc.biplot = TRUE,
labels = NULL,
labels_textsize = 3,
@ -107,22 +108,27 @@ ggplot_pca <- function(x, @@ -107,22 +108,27 @@ ggplot_pca <- function(x,
...) {
stop_ifnot_installed("ggplot2")
stop_ifnot(length(choices) == 2, "`choices` must be of length 2")
stop_ifnot(is.logical(arrows), "`arrows` must be TRUE or FALSE")
stop_ifnot(is.logical(arrows_textangled), "`arrows_textangled` must be TRUE or FALSE")
stop_ifnot(is.logical(ellipse), "`ellipse` must be TRUE or FALSE")
stop_ifnot(is.logical(pc.biplot), "`pc.biplot` must be TRUE or FALSE")
stop_ifnot(is.logical(scale), "`scale` must be TRUE or FALSE")
stop_ifnot(is.numeric(arrows_alpha), "`arrows_alpha` must be numeric")
stop_ifnot(is.numeric(arrows_size), "`arrows_size` must be numeric")
stop_ifnot(is.numeric(arrows_textsize), "`arrows_textsize` must be numeric")
stop_ifnot(is.numeric(base_textsize), "`base_textsize` must be numeric")
stop_ifnot(is.numeric(choices), "`choices` must be numeric")
stop_ifnot(is.numeric(ellipse_alpha), "`ellipse_alpha` must be numeric")
stop_ifnot(is.numeric(ellipse_prob), "`ellipse_prob` must be numeric")
stop_ifnot(is.numeric(ellipse_size), "`ellipse_size` must be numeric")
stop_ifnot(is.numeric(labels_text_placement), "`labels_text_placement` must be numeric")
stop_ifnot(is.numeric(labels_textsize), "`labels_textsize` must be numeric")
meet_criteria(x, allow_class = c("prcomp", "princomp", "PCA", "lda"))
meet_criteria(choices, allow_class = c("numeric", "integer"), has_length = 2)
meet_criteria(scale, allow_class = c("numeric", "integer", "logical"), has_length = 1)
meet_criteria(pc.biplot, allow_class = "logical", has_length = 1)
meet_criteria(labels, allow_class = "character", allow_NULL = TRUE)
meet_criteria(labels_textsize, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(labels_text_placement, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(groups, allow_class = "character", allow_NULL = TRUE)
meet_criteria(ellipse, allow_class = "logical", has_length = 1)
meet_criteria(ellipse_prob, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(ellipse_size, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(ellipse_alpha, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(points_size, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(points_alpha, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(arrows, allow_class = "logical", has_length = 1)
meet_criteria(arrows_colour, allow_class = "character", has_length = 1)
meet_criteria(arrows_size, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(arrows_textsize, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(arrows_textangled, allow_class = "logical", has_length = 1)
meet_criteria(arrows_alpha, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(base_textsize, allow_class = c("numeric", "integer"), has_length = 1)
calculations <- pca_calculations(pca_model = x,
groups = groups,
@ -302,7 +308,7 @@ pca_calculations <- function(pca_model, @@ -302,7 +308,7 @@ pca_calculations <- function(pca_model,
v <- pca_model$scaling
d.total <- sum(d ^ 2)
} else {
stop("Expected a object of class prcomp, princomp, PCA, or lda")
stop("Expected an object of class prcomp, princomp, PCA, or lda")
}
# Scores

57
R/ggplot_rsi.R

@ -171,10 +171,29 @@ ggplot_rsi <- function(data, @@ -171,10 +171,29 @@ ggplot_rsi <- function(data,
...) {
stop_ifnot_installed("ggplot2")
x <- x[1]
facet <- facet[1]
meet_criteria(data, allow_class = "data.frame", contains_column_class = "rsi")
meet_criteria(position, allow_class = "character", has_length = 1, is_in = c("fill", "stack", "dodge"), allow_NULL = TRUE)
meet_criteria(x, allow_class = "character", has_length = 1)
meet_criteria(fill, allow_class = "character", has_length = 1)
meet_criteria(facet, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(breaks, allow_class = c("numeric", "integer"))
meet_criteria(limits, allow_class = c("numeric", "integer"), has_length = 2, allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
meet_criteria(combine_IR, allow_class = "logical", has_length = 1)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(nrow, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE)
meet_criteria(colours, allow_class = "character")
meet_criteria(datalabels, allow_class = "logical", has_length = 1)
meet_criteria(datalabels.size, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(datalabels.colour, allow_class = "character", has_length = 1)
meet_criteria(title, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(subtitle, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(caption, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(x.title, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(y.title, allow_class = "character", has_length = 1, allow_NULL = TRUE)
# we work with aes_string later on
x_deparse <- deparse(substitute(x))
if (x_deparse != "x") {
@ -256,7 +275,15 @@ geom_rsi <- function(position = NULL, @@ -256,7 +275,15 @@ geom_rsi <- function(position = NULL,
...) {
stop_ifnot_installed("ggplot2")
stop_if(is.data.frame(position), "`position` is invalid. Did you accidentally use '%pm>%' instead of '+'?")
stop_if(is.data.frame(position), "`position` is invalid. Did you accidentally use '%>%' instead of '+'?")
meet_criteria(position, allow_class = "character", has_length = 1, is_in = c("fill", "stack", "dodge"), allow_NULL = TRUE)
meet_criteria(x, allow_class = "character", has_length = 1)
meet_criteria(fill, allow_class = "character", has_length = 1)
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
meet_criteria(combine_IR, allow_class = "logical", has_length = 1)
y <- "value"
if (missing(position) | is.null(position)) {
@ -300,10 +327,10 @@ geom_rsi <- function(position = NULL, @@ -300,10 +327,10 @@ geom_rsi <- function(position = NULL,
#' @rdname ggplot_rsi
#' @export
facet_rsi <- function(facet = c("interpretation", "antibiotic"), nrow = NULL) {
stop_ifnot_installed("ggplot2")
facet <- facet[1]
stop_ifnot_installed("ggplot2")
meet_criteria(facet, allow_class = "character", has_length = 1)
meet_criteria(nrow, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE)
# we work with aes_string later on
facet_deparse <- deparse(substitute(facet))
@ -327,6 +354,8 @@ facet_rsi <- function(facet = c("interpretation", "antibiotic"), nrow = NULL) { @@ -327,6 +354,8 @@ facet_rsi <- function(facet = c("interpretation", "antibiotic"), nrow = NULL) {
#' @export
scale_y_percent <- function(breaks = seq(0, 1, 0.1), limits = NULL) {
stop_ifnot_installed("ggplot2")
meet_criteria(breaks, allow_class = c("numeric", "integer"))
meet_criteria(limits, allow_class = c("numeric", "integer"), has_length = 2, allow_NULL = TRUE, allow_NA = TRUE)
if (all(breaks[breaks != 0] > 1)) {
breaks <- breaks / 100
@ -344,6 +373,8 @@ scale_rsi_colours <- function(colours = c(S = "#61a8ff", @@ -344,6 +373,8 @@ scale_rsi_colours <- function(colours = c(S = "#61a8ff",
IR = "#ff6961",
R = "#ff6961")) {
stop_ifnot_installed("ggplot2")
meet_criteria(colours, allow_class = "character")
# previous colour: palette = "RdYlGn"
# previous colours: values = c("#b22222", "#ae9c20", "#7cfc00")
@ -383,6 +414,16 @@ labels_rsi_count <- function(position = NULL, @@ -383,6 +414,16 @@ labels_rsi_count <- function(position = NULL,
datalabels.size = 3,
datalabels.colour = "gray15") {
stop_ifnot_installed("ggplot2")
meet_criteria(position, allow_class = "character", has_length = 1, is_in = c("fill", "stack", "dodge"), allow_NULL = TRUE)
meet_criteria(x, allow_class = "character", has_length = 1)
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
meet_criteria(combine_IR, allow_class = "logical", has_length = 1)
meet_criteria(datalabels.size, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(datalabels.colour, allow_class = "character", has_length = 1)
if (is.null(position)) {
position <- "fill"
}

18
R/guess_ab_col.R

@ -30,7 +30,7 @@ @@ -30,7 +30,7 @@
#' @param x a [data.frame]
#' @param search_string a text to search `x` for, will be checked with [as.ab()] if this value is not a column in `x`
#' @param verbose a logical to indicate whether additional info should be printed
#' @details You can look for an antibiotic (trade) name or abbreviation and it will search `x` and the [antibiotics] data set for any column containing a name or code of that antibiotic. **Longer columns names take precendence over shorter column names.**
#' @details You can look for an antibiotic (trade) name or abbreviation and it will search `x` and the [antibiotics] data set for any column containing a name or code of that antibiotic. **Longer columns names take precedence over shorter column names.**
#' @return A column name of `x`, or `NULL` when no result is found.
#' @export
#' @inheritSection AMR Read more on our website!
@ -63,16 +63,13 @@ @@ -63,16 +63,13 @@
#' guess_ab_col(df, "ampicillin")
#' # [1] "AMP_ED20"
guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE) {
meet_criteria(x, allow_class = "data.frame", allow_NULL = TRUE)
meet_criteria(search_string, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(verbose, allow_class = "logical", has_length = 1)
if (is.null(x) & is.null(search_string)) {
return(as.name("guess_ab_col"))
}
stop_ifnot(is.data.frame(x), "`x` must be a data.frame")
if (length(search_string) > 1) {
warning("argument 'search_string' has length > 1 and only the first element will be used")
search_string <- search_string[1]
}
search_string <- as.character(search_string)
if (search_string %in% colnames(x)) {
ab_result <- search_string
@ -116,6 +113,11 @@ get_column_abx <- function(x, @@ -116,6 +113,11 @@ get_column_abx <- function(x,
verbose = FALSE,
info = TRUE,
...) {
meet_criteria(x, allow_class = "data.frame")
meet_criteria(soft_dependencies, allow_class = "character", allow_NULL = TRUE)
meet_criteria(hard_dependencies, allow_class = "character", allow_NULL = TRUE)
meet_criteria(verbose, allow_class = "logical", has_length = 1)
meet_criteria(info, allow_class = "logical", has_length = 1)
if (info == TRUE) {
message(font_blue("NOTE: Auto-guessing columns suitable for analysis"), appendLF = FALSE)

40
R/join_microorganisms.R

@ -61,8 +61,12 @@ @@ -61,8 +61,12 @@
#' }
#' }
inner_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
meet_criteria(x, allow_class = c("data.frame", "character"))
meet_criteria(by, allow_class = "character", allow_NULL = TRUE)
meet_criteria(suffix, allow_class = "character", has_length = 2)
check_dataset_integrity()
check_groups_before_join(x, "inner_join_microorganisms")
x <- check_groups_before_join(x, "inner_join_microorganisms")
checked <- joins_check_df(x, by)
x_class <- get_prejoined_class(x)
x <- checked$x
@ -88,8 +92,12 @@ inner_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) { @@ -88,8 +92,12 @@ inner_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
#' @rdname join
#' @export
left_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
meet_criteria(x, allow_class = c("data.frame", "character"))
meet_criteria(by, allow_class = "character", allow_NULL = TRUE)
meet_criteria(suffix, allow_class = "character", has_length = 2)
check_dataset_integrity()
check_groups_before_join(x, "left_join_microorganisms")
x <- check_groups_before_join(x, "left_join_microorganisms")
checked <- joins_check_df(x, by)
x_class <- get_prejoined_class(x)
x <- checked$x
@ -115,8 +123,12 @@ left_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) { @@ -115,8 +123,12 @@ left_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
#' @rdname join
#' @export