Browse Source

(v1.4.0.9041) updates based on review

main
parent
commit
81af41da3a
  1. 6
      DESCRIPTION
  2. 11
      NEWS.md
  3. 25
      R/aa_helper_functions.R
  4. 46
      R/aa_helper_pm_functions.R
  5. 7
      R/ab.R
  6. 2
      R/ab_from_text.R
  7. 4
      R/amr.R
  8. 4
      R/catalogue_of_life.R
  9. 4
      R/data.R
  10. 11
      R/disk.R
  11. 2
      R/first_isolate.R
  12. 4
      R/g.test.R
  13. 3
      R/globals.R
  14. 2
      R/join_microorganisms.R
  15. 10
      R/mic.R
  16. 107
      R/mo.R
  17. 2
      R/mo_property.R
  18. 108
      R/mo_source.R
  19. 4
      R/proportion.R
  20. 2
      R/resistance_predict.R
  21. 46
      R/rsi.R
  22. 6
      R/rsi_calc.R
  23. 4
      R/translate.R
  24. 1
      R/zzz.R
  25. 4
      data-raw/reproduction_of_poorman.R
  26. 2
      docs/404.html
  27. 2
      docs/LICENSE-text.html
  28. 40
      docs/articles/datasets.html
  29. 12
      docs/articles/datasets_files/header-attrs-2.6/header-attrs.js
  30. 2
      docs/articles/index.html
  31. 2
      docs/authors.html
  32. 2
      docs/index.html
  33. 19
      docs/news/index.html
  34. 2
      docs/pkgdown.yml
  35. 6
      docs/reference/AMR.html
  36. 40
      docs/reference/ab_from_text.html
  37. 44
      docs/reference/antibiotics.html
  38. 45
      docs/reference/as.ab.html
  39. 44
      docs/reference/as.mo.html
  40. 40
      docs/reference/bug_drug_combinations.html
  41. 42
      docs/reference/catalogue_of_life.html
  42. 42
      docs/reference/count.html
  43. 40
      docs/reference/first_isolate.html
  44. 40
      docs/reference/g.test.html
  45. 42
      docs/reference/ggplot_rsi.html
  46. 2
      docs/reference/index.html
  47. 40
      docs/reference/join.html
  48. 40
      docs/reference/mo_property.html
  49. 76
      docs/reference/mo_source.html
  50. 2
      docs/reference/plot.html
  51. 42
      docs/reference/proportion.html
  52. 40
      docs/reference/resistance_predict.html
  53. 40
      docs/reference/translate.html
  54. 2
      docs/survey.html
  55. 4
      man/AMR.Rd
  56. 2
      man/ab_from_text.Rd
  57. 4
      man/antibiotics.Rd
  58. 8
      man/as.ab.Rd
  59. 4
      man/as.mo.Rd
  60. 2
      man/bug_drug_combinations.Rd
  61. 4
      man/catalogue_of_life.Rd
  62. 4
      man/count.Rd
  63. 2
      man/first_isolate.Rd
  64. 2
      man/g.test.Rd
  65. 4
      man/ggplot_rsi.Rd
  66. 2
      man/join.Rd
  67. 2
      man/mo_property.Rd
  68. 36
      man/mo_source.Rd
  69. 4
      man/proportion.Rd
  70. 2
      man/resistance_predict.Rd
  71. 2
      man/translate.Rd
  72. 14
      tests/testthat/test-rsi.R
  73. 5
      tests/testthat/test-zzz.R
  74. 13
      vignettes/datasets.Rmd

6
DESCRIPTION

@ -1,6 +1,6 @@ @@ -1,6 +1,6 @@
Package: AMR
Version: 1.4.0.9040
Date: 2020-12-16
Version: 1.4.0.9041
Date: 2020-12-17
Title: Antimicrobial Resistance Analysis
Authors@R: c(
person(role = c("aut", "cre"),
@ -47,6 +47,7 @@ Suggests: @@ -47,6 +47,7 @@ Suggests:
ggplot2,
knitr,
microbenchmark,
pillar,
readxl,
rmarkdown,
rstudioapi,
@ -54,6 +55,7 @@ Suggests: @@ -54,6 +55,7 @@ Suggests:
skimr,
testthat,
tidyr,
tidyselect,
xml2
VignetteBuilder: knitr,rmarkdown
URL: https://msberends.github.io/AMR/, https://github.com/msberends/AMR

11
NEWS.md

@ -1,5 +1,7 @@ @@ -1,5 +1,7 @@
# AMR 1.4.0.9040
## <small>Last updated: 16 December 2020</small>
# AMR 1.4.0.9041
## <small>Last updated: 17 December 2020</small>
Note: some changes in this version were suggested by anonymous reviewers from the journal we submitted our manuscript about this package to. We are those reviewers very grateful for going through our code so thoroughly!
### New
* Function `is_new_episode()` to determine patient episodes which are not necessarily based on microorganisms. It also supports grouped variables with e.g. `mutate()`, `filter()` and `summarise()` of the `dplyr` package:
@ -26,6 +28,7 @@ @@ -26,6 +28,7 @@
as_tibble()
```
* 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.
* Fix for `set_mo_source()`, that previously would not remember the file location of the original file
* 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.
* Better determination of disk zones and MIC values when running `as.rsi()` on a data.frame
* Updated coagulase-negative staphylococci determination with Becker *et al.* 2020 (PMID 32056452), meaning that the species *S. argensis*, *S. caeli*, *S. debuckii*, *S. edaphicus* and *S. pseudoxylosus* are now all considered CoNS
@ -40,14 +43,16 @@ @@ -40,14 +43,16 @@
* Fix for plotting MIC values with `plot()`
* Added `plot()` generic to class `<disk>`
* LA-MRSA and CA-MRSA are now recognised as an abbreviation for *Staphylococcus aureus*, meaning that e.g. `mo_genus("LA-MRSA")` will return `"Staphylococcus"` and `mo_is_gram_positive("LA-MRSA")` will return `TRUE`.
* Fix for using `as.rsi()` on a `data.frame` that only contains one column for antibiotic interpretations
### Other
* All messages and warnings thrown by this package now break sentences on whole words
* More extensive unit tests
* Internal calls to `options()` were all removed in favour of a new internal environment `mo_env`
# AMR 1.4.0
Note: some changes in this version were suggested by anonymous reviewers from the journal we submitted our manuscipt about this package to. We are those reviewers very grateful for going through our code so thoroughly!
Note: some changes in this version were suggested by anonymous reviewers from the journal we submitted our manuscript about this package to. We are those reviewers very grateful for going through our code so thoroughly!
### New
* Support for 'EUCAST Expert Rules' / 'EUCAST Intrinsic Resistance and Unusual Phenotypes' version 3.2 of May 2020. With this addition to the previously implemented version 3.1 of 2016, the `eucast_rules()` function can now correct for more than 180 different antibiotics and the `mdro()` function can determine multidrug resistance based on more than 150 different antibiotics. All previously implemented versions of the EUCAST rules are now maintained and kept available in this package. The `eucast_rules()` function consequently gained the parameters `version_breakpoints` (at the moment defaults to v10.0, 2020) and `version_expertrules` (at the moment defaults to v3.2, 2020). The `example_isolates` data set now also reflects the change from v3.1 to v3.2. The `mdro()` function now accepts `guideline == "EUCAST3.1"` and `guideline == "EUCAST3.2"`.

25
R/aa_helper_functions.R

@ -101,6 +101,8 @@ check_dataset_integrity <- function() { @@ -101,6 +101,8 @@ check_dataset_integrity <- function() {
# package not yet loaded
require("AMR")
})
stop_if(!check_microorganisms | !check_antibiotics,
"the data set `microorganisms` or `antibiotics` was overwritten in your environment because another package with the same object names was loaded _after_ the AMR package, preventing the AMR package from working correctly. Please load the AMR package last.")
invisible(TRUE)
}
@ -224,10 +226,11 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) { @@ -224,10 +226,11 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) {
stop_ifnot_installed(pkg)
}
tryCatch(
get(name, envir = asNamespace(pkg)),
# don't use get() to avoid fetching non-API functions
getExportedValue(name = name, ns = asNamespace(pkg)),
error = function(e) {
if (isTRUE(error_on_fail)) {
stop_("function ", name, "() not found in package '", pkg,
stop_("function ", name, "() is not an exported object from package '", pkg,
"'. Please create an issue at https://github.com/msberends/AMR/issues. Many thanks!",
call = FALSE)
} else {
@ -239,7 +242,7 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) { @@ -239,7 +242,7 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) {
# this alternative wrapper to the message(), warning() and stop() functions:
# - wraps text to never break lines within words
# - ignores formatted text while wrapping
# - adds indentation dependent on the type of message (like NOTE)
# - adds indentation dependent on the type of message (such as NOTE)
# - can add additional formatting functions like blue or bold text
word_wrap <- function(...,
add_fn = list(),
@ -690,6 +693,17 @@ set_clean_class <- function(x, new_class) { @@ -690,6 +693,17 @@ set_clean_class <- function(x, new_class) {
x
}
formatted_filesize <- function(...) {
size_kb <- file.size(...) / 1024
if (size_kb < 1) {
paste(round(size_kb, 1), "kB")
} else if (size_kb < 100) {
paste(round(size_kb, 0), "kB")
} else {
paste(round(size_kb / 1024, 1), "MB")
}
}
create_pillar_column <- function(x, ...) {
new_pillar_shaft_simple <- import_fn("new_pillar_shaft_simple", "pillar", error_on_fail = FALSE)
if (!is.null(new_pillar_shaft_simple)) {
@ -817,7 +831,7 @@ percentage <- function(x, digits = NULL, ...) { @@ -817,7 +831,7 @@ percentage <- function(x, digits = NULL, ...) {
}
# prevent dependency on package 'backports'
# these functions were not available in previous versions of R (last checked: R 4.0.2)
# these functions were not available in previous versions of R (last checked: R 4.0.3)
# see here for the full list: https://github.com/r-lib/backports
strrep <- function(x, times) {
x <- as.character(x)
@ -861,3 +875,6 @@ str2lang <- function(s) { @@ -861,3 +875,6 @@ str2lang <- function(s) {
isNamespaceLoaded <- function(pkg) {
pkg %in% loadedNamespaces()
}
lengths = function(x, use.names = TRUE) {
vapply(x, length, FUN.VALUE = NA_integer_, USE.NAMES = use.names)
}

46
R/aa_helper_pm_functions.R

@ -388,29 +388,29 @@ pm_group_size <- function(x) { @@ -388,29 +388,29 @@ pm_group_size <- function(x) {
pm_n_groups <- function(x) {
nrow(pm_group_data(x))
}
pm_group_split <- function(.data, ..., .keep = TRUE) {
dots_len <- ...length() > 0L
if (pm_has_groups(.data) && isTRUE(dots_len)) {
warning("... is ignored in pm_group_split(<grouped_df>), please use pm_group_by(..., .add = TRUE) %pm>% pm_group_split()")
}
if (!pm_has_groups(.data) && isTRUE(dots_len)) {
.data <- pm_group_by(.data, ...)
}
if (!pm_has_groups(.data) && isFALSE(dots_len)) {
return(list(.data))
}
pm_context$setup(.data)
on.exit(pm_context$clean(), add = TRUE)
pm_groups <- pm_get_groups(.data)
attr(pm_context$.data, "pm_groups") <- NULL
res <- pm_split_into_groups(pm_context$.data, pm_groups)
names(res) <- NULL
if (isFALSE(.keep)) {
res <- lapply(res, function(x) x[, !colnames(x) %in% pm_groups])
}
any_empty <- unlist(lapply(res, function(x) !(nrow(x) == 0L)))
res[any_empty]
}
# pm_group_split <- function(.data, ..., .keep = TRUE) {
# dots_len <- ...length() > 0L
# if (pm_has_groups(.data) && isTRUE(dots_len)) {
# warning("... is ignored in pm_group_split(<grouped_df>), please use pm_group_by(..., .add = TRUE) %pm>% pm_group_split()")
# }
# if (!pm_has_groups(.data) && isTRUE(dots_len)) {
# .data <- pm_group_by(.data, ...)
# }
# if (!pm_has_groups(.data) && isFALSE(dots_len)) {
# return(list(.data))
# }
# pm_context$setup(.data)
# on.exit(pm_context$clean(), add = TRUE)
# pm_groups <- pm_get_groups(.data)
# attr(pm_context$.data, "pm_groups") <- NULL
# res <- pm_split_into_groups(pm_context$.data, pm_groups)
# names(res) <- NULL
# if (isFALSE(.keep)) {
# res <- lapply(res, function(x) x[, !colnames(x) %in% pm_groups])
# }
# any_empty <- unlist(lapply(res, function(x) !(nrow(x) == 0L)))
# res[any_empty]
# }
pm_group_keys <- function(.data) {
pm_groups <- pm_get_groups(.data)

7
R/ab.R

@ -37,13 +37,14 @@ @@ -37,13 +37,14 @@
#'
#' All these properties will be searched for the user input. The [as.ab()] can correct for different forms of misspelling:
#'
#' * Wrong spelling of drug names (like "tobramicin" or "gentamycin"), which corrects for most audible similarities such as f/ph, x/ks, c/z/s, t/th, etc.
#' * Wrong spelling of drug names (such as "tobramicin" or "gentamycin"), which corrects for most audible similarities such as f/ph, x/ks, c/z/s, t/th, etc.
#' * Too few or too many vowels or consonants
#' * Switching two characters (like "mreopenem", often the case in clinical data, when doctors typed too fast)
#' * Switching two characters (such as "mreopenem", often the case in clinical data, when doctors typed too fast)
#' * Digitalised paper records, leaving artefacts like 0/o/O (zero and O's), B/8, n/r, etc.
#'
#' Use the [ab_property()] functions to get properties based on the returned antibiotic ID, see Examples.
#' Use the [`ab_*`][ab_property()] functions to get properties based on the returned antibiotic ID, see Examples.
#'
#' Note: the [as.ab()] and [`ab_*`][ab_property()] functions may use very long regular expression to match brand names of antimicrobial agents. This may fail on some systems.
#' @section Source:
#' World Health Organization (WHO) Collaborating Centre for Drug Statistics Methodology: \url{https://www.whocc.no/atc_ddd_index/}
#'

2
R/ab_from_text.R

@ -46,7 +46,7 @@ @@ -46,7 +46,7 @@
#' Without using `collapse`, this function will return a [list]. This can be convenient to use e.g. inside a `mutate()`):\cr
#' `df %>% mutate(abx = ab_from_text(clinical_text))`
#'
#' The returned AB codes can be transformed to official names, groups, etc. with all [ab_property()] functions like [ab_name()] and [ab_group()], or by using the `translate_ab` parameter.
#' The returned AB codes can be transformed to official names, groups, etc. with all [`ab_*`][ab_property()] functions such as [ab_name()] and [ab_group()], or by using the `translate_ab` parameter.
#'
#' With using `collapse`, this function will return a [character]:\cr
#' `df %>% mutate(abx = ab_from_text(clinical_text, collapse = "|"))`

4
R/amr.R

@ -42,8 +42,8 @@ @@ -42,8 +42,8 @@
#' - Determining multi-drug resistance (MDR) / multi-drug resistant organisms (MDRO)
#' - Calculating (empirical) susceptibility of both mono therapy and combination therapies
#' - Predicting future antimicrobial resistance using regression models
#' - Getting properties for any microorganism (like Gram stain, species, genus or family)
#' - Getting properties for any antibiotic (like name, code of EARS-Net/ATC/LOINC/PubChem, defined daily dose or trade name)
#' - Getting properties for any microorganism (such as Gram stain, species, genus or family)
#' - Getting properties for any antibiotic (such as name, code of EARS-Net/ATC/LOINC/PubChem, defined daily dose or trade name)
#' - Plotting antimicrobial resistance
#' - Applying EUCAST expert rules
#' - Getting SNOMED codes of a microorganism, or getting properties of a microorganism based on a SNOMED code

4
R/catalogue_of_life.R

@ -50,8 +50,8 @@ format_included_data_number <- function(data) { @@ -50,8 +50,8 @@ format_included_data_number <- function(data) {
#' @section Included taxa:
#' Included are:
#' - All `r format_included_data_number(microorganisms[which(microorganisms$kingdom %in% c("Archeae", "Bacteria", "Chromista", "Protozoa")), ])` (sub)species from the kingdoms of Archaea, Bacteria, Chromista and Protozoa
#' - All `r format_included_data_number(microorganisms[which(microorganisms$kingdom == "Fungi" & microorganisms$order %in% c("Eurotiales", "Microascales", "Mucorales", "Onygenales", "Pneumocystales", "Saccharomycetales", "Schizosaccharomycetales", "Tremellales")), ])` (sub)species from these orders of the kingdom of Fungi: Eurotiales, Microascales, Mucorales, Onygenales, Pneumocystales, Saccharomycetales, Schizosaccharomycetales and Tremellales, as well as `r format_included_data_number(microorganisms[which(microorganisms$kingdom == "Fungi" & !microorganisms$order %in% c("Eurotiales", "Microascales", "Mucorales", "Onygenales", "Pneumocystales", "Saccharomycetales", "Schizosaccharomycetales", "Tremellales")), ])` other fungal (sub)species. The kingdom of Fungi is a very large taxon with almost 300,000 different (sub)species, of which most are not microbial (but rather macroscopic, like mushrooms). Because of this, not all fungi fit the scope of this package and including everything would tremendously slow down our algorithms too. By only including the aforementioned taxonomic orders, the most relevant fungi are covered (like all species of *Aspergillus*, *Candida*, *Cryptococcus*, *Histplasma*, *Pneumocystis*, *Saccharomyces* and *Trichophyton*).
#' - All `r format_included_data_number(microorganisms[which(microorganisms$kingdom == "Animalia"), ])` (sub)species from `r format_included_data_number(microorganisms[which(microorganisms$kingdom == "Animalia"), "genus"])` other relevant genera from the kingdom of Animalia (like *Strongyloides* and *Taenia*)
#' - All `r format_included_data_number(microorganisms[which(microorganisms$kingdom == "Fungi" & microorganisms$order %in% c("Eurotiales", "Microascales", "Mucorales", "Onygenales", "Pneumocystales", "Saccharomycetales", "Schizosaccharomycetales", "Tremellales")), ])` (sub)species from these orders of the kingdom of Fungi: Eurotiales, Microascales, Mucorales, Onygenales, Pneumocystales, Saccharomycetales, Schizosaccharomycetales and Tremellales, as well as `r format_included_data_number(microorganisms[which(microorganisms$kingdom == "Fungi" & !microorganisms$order %in% c("Eurotiales", "Microascales", "Mucorales", "Onygenales", "Pneumocystales", "Saccharomycetales", "Schizosaccharomycetales", "Tremellales")), ])` other fungal (sub)species. The kingdom of Fungi is a very large taxon with almost 300,000 different (sub)species, of which most are not microbial (but rather macroscopic, like mushrooms). Because of this, not all fungi fit the scope of this package and including everything would tremendously slow down our algorithms too. By only including the aforementioned taxonomic orders, the most relevant fungi are covered (such as all species of *Aspergillus*, *Candida*, *Cryptococcus*, *Histplasma*, *Pneumocystis*, *Saccharomyces* and *Trichophyton*).
#' - All `r format_included_data_number(microorganisms[which(microorganisms$kingdom == "Animalia"), ])` (sub)species from `r format_included_data_number(microorganisms[which(microorganisms$kingdom == "Animalia"), "genus"])` other relevant genera from the kingdom of Animalia (such as *Strongyloides* and *Taenia*)
#' - All `r format_included_data_number(microorganisms.old)` previously accepted names of all included (sub)species (these were taxonomically renamed)
#' - The complete taxonomic tree of all included (sub)species: from kingdom to subspecies
#' - The responsible author(s) and year of scientific publication

4
R/data.R

@ -25,10 +25,10 @@ @@ -25,10 +25,10 @@
#' Data sets with `r format(nrow(antibiotics) + nrow(antivirals), big.mark = ",")` antimicrobials
#'
#' Two data sets containing all antibiotics/antimycotics and antivirals. Use [as.ab()] or one of the [ab_property()] functions to retrieve values from the [antibiotics] data set. Three identifiers are included in this data set: an antibiotic ID (`ab`, primarily used in this package) as defined by WHONET/EARS-Net, an ATC code (`atc`) as defined by the WHO, and a Compound ID (`cid`) as found in PubChem. Other properties in this data set are derived from one or more of these codes.
#' Two data sets containing all antibiotics/antimycotics and antivirals. Use [as.ab()] or one of the [`ab_*`][ab_property()] functions to retrieve values from the [antibiotics] data set. Three identifiers are included in this data set: an antibiotic ID (`ab`, primarily used in this package) as defined by WHONET/EARS-Net, an ATC code (`atc`) as defined by the WHO, and a Compound ID (`cid`) as found in PubChem. Other properties in this data set are derived from one or more of these codes.
#' @format
#' ### For the [antibiotics] data set: a [data.frame] with `r nrow(antibiotics)` observations and `r ncol(antibiotics)` variables:
#' - `ab`\cr Antibiotic ID as used in this package (like `AMC`), using the official EARS-Net (European Antimicrobial Resistance Surveillance Network) codes where available
#' - `ab`\cr Antibiotic ID as used in this package (such as `AMC`), using the official EARS-Net (European Antimicrobial Resistance Surveillance Network) codes where available
#' - `atc`\cr ATC code (Anatomical Therapeutic Chemical) as defined by the WHOCC, like `J01CR02`
#' - `cid`\cr Compound ID as found in PubChem
#' - `name`\cr Official name as used by WHONET/EARS-Net or the WHO

11
R/disk.R

@ -114,8 +114,9 @@ all_valid_disks <- function(x) { @@ -114,8 +114,9 @@ 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))
x_disk <- tryCatch(suppressWarnings(as.disk(x[!is.na(x)])),
error = function(e) NA)
!any(is.na(x_disk)) && !all(is.na(x))
}
#' @rdname as.disk
@ -223,14 +224,12 @@ unique.disk <- function(x, incomparables = FALSE, ...) { @@ -223,14 +224,12 @@ unique.disk <- function(x, incomparables = FALSE, ...) {
# will be exported using s3_register() in R/zzz.R
get_skimmers.disk <- function(column) {
sfl <- import_fn("sfl", "skimr", error_on_fail = FALSE)
inline_hist <- import_fn("inline_hist", "skimr", error_on_fail = FALSE)
sfl(
skimr::sfl(
skim_type = "disk",
min = ~min(as.double(.), na.rm = TRUE),
max = ~max(as.double(.), na.rm = TRUE),
median = ~stats::median(as.double(.), na.rm = TRUE),
n_unique = ~pm_n_distinct(., na.rm = TRUE),
hist = ~inline_hist(stats::na.omit(as.double(.)))
hist = ~skimr::inline_hist(stats::na.omit(as.double(.)))
)
}

2
R/first_isolate.R

@ -31,7 +31,7 @@ @@ -31,7 +31,7 @@
#' @param col_date column name of the result date (or date that is was received on the lab), defaults to the first column with a date class
#' @param col_patient_id column name of the unique IDs of the patients, defaults to the first column that starts with 'patient' or 'patid' (case insensitive)
#' @param col_mo column name of the IDs of the microorganisms (see [as.mo()]), defaults to the first column of class [`mo`]. Values will be coerced using [as.mo()].
#' @param col_testcode column name of the test codes. Use `col_testcode = NULL` to **not** exclude certain test codes (like test codes for screening). In that case `testcodes_exclude` will be ignored.
#' @param col_testcode column name of the test codes. Use `col_testcode = NULL` to **not** exclude certain test codes (such as test codes for screening). In that case `testcodes_exclude` will be ignored.
#' @param col_specimen column name of the specimen type or group
#' @param col_icu column name of the logicals (`TRUE`/`FALSE`) whether a ward or department is an Intensive Care Unit (ICU)
#' @param col_keyantibiotics column name of the key antibiotics to determine first *weighted* isolates, see [key_antibiotics()]. Defaults to the first column that starts with 'key' followed by 'ab' or 'antibiotics' (case insensitive). Use `col_keyantibiotics = FALSE` to prevent this.

4
R/g.test.R

@ -34,7 +34,7 @@ @@ -34,7 +34,7 @@
#'
#' The p-value is computed from the asymptotic chi-squared distribution of the test statistic.
#'
#' In the contingency table case simulation is done by random sampling from the set of all contingency tables with given marginals, and works only if the marginals are strictly positive. Note that this is not the usual sampling situation assumed for a chi-squared test (like the *G*-test) but rather that for Fisher's exact test.
#' In the contingency table case simulation is done by random sampling from the set of all contingency tables with given marginals, and works only if the marginals are strictly positive. Note that this is not the usual sampling situation assumed for a chi-squared test (such as the *G*-test) but rather that for Fisher's exact test.
#'
#' In the goodness-of-fit case simulation is done by random sampling from the discrete distribution specified by `p`, each sample being of size `n = sum(x)`. This simulation is done in \R and may be slow.
#'
@ -144,7 +144,7 @@ g.test <- function(x, @@ -144,7 +144,7 @@ g.test <- function(x,
DNAME <- paste(paste(DNAME, collapse = "\n"), "and",
paste(DNAME2, collapse = "\n"))
}
if (any(x < 0) || anyNA(x))
if (any(x < 0) || any(is.na((x)))) # this last one was anyNA, but only introduced in R 3.1.0
stop("all entries of 'x' must be nonnegative and finite")
if ((n <- sum(x)) == 0)
stop("at least one entry of 'x' must be positive")

3
R/globals.R

@ -23,8 +23,7 @@ @@ -23,8 +23,7 @@
# how to conduct AMR analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
globalVariables(c("...length", # for pm_group_split() on R 3.3
".rowid",
globalVariables(c(".rowid",
"ab",
"ab_txt",
"angle",

2
R/join_microorganisms.R

@ -31,7 +31,7 @@ @@ -31,7 +31,7 @@
#' @name join
#' @aliases join inner_join
#' @param x existing table to join, or character vector
#' @param by a variable to join by - if left empty will search for a column with class [`mo`] (created with [as.mo()]) or will be `"mo"` if that column name exists in `x`, could otherwise be a column name of `x` with values that exist in `microorganisms$mo` (like `by = "bacteria_id"`), or another column in [microorganisms] (but then it should be named, like `by = c("bacteria_id" = "fullname")`)
#' @param by a variable to join by - if left empty will search for a column with class [`mo`] (created with [as.mo()]) or will be `"mo"` if that column name exists in `x`, could otherwise be a column name of `x` with values that exist in `microorganisms$mo` (such as `by = "bacteria_id"`), or another column in [microorganisms] (but then it should be named, like `by = c("bacteria_id" = "fullname")`)
#' @param suffix if there are non-joined duplicate variables in `x` and `y`, these suffixes will be added to the output to disambiguate them. Should be a character vector of length 2.
#' @param ... ignored
#' @details **Note:** As opposed to the `join()` functions of `dplyr`, [character] vectors are supported and at default existing columns will get a suffix `"2"` and the newly joined columns will not get a suffix.

10
R/mic.R

@ -142,7 +142,7 @@ all_valid_mics <- function(x) { @@ -142,7 +142,7 @@ all_valid_mics <- function(x) {
}
x_mic <- tryCatch(suppressWarnings(as.mic(x[!is.na(x)])),
error = function(e) NA)
!any(is.na(x_mic)) & !all(is.na(x))
!any(is.na(x_mic)) && !all(is.na(x))
}
#' @rdname as.mic
@ -175,7 +175,7 @@ as.numeric.mic <- function(x, ...) { @@ -175,7 +175,7 @@ as.numeric.mic <- function(x, ...) {
#' @method droplevels mic
#' @export
#' @noRd
droplevels.mic <- function(x, exclude = ifelse(anyNA(levels(x)), NULL, NA), ...) {
droplevels.mic <- function(x, exclude = if (any(is.na(levels(x)))) NULL else NA, ...) {
x <- droplevels.factor(x, exclude = exclude, ...)
class(x) <- c("mic", "ordered", "factor")
x
@ -323,14 +323,12 @@ unique.mic <- function(x, incomparables = FALSE, ...) { @@ -323,14 +323,12 @@ unique.mic <- function(x, incomparables = FALSE, ...) {
# will be exported using s3_register() in R/zzz.R
get_skimmers.mic <- function(column) {
sfl <- import_fn("sfl", "skimr", error_on_fail = FALSE)
inline_hist <- import_fn("inline_hist", "skimr", error_on_fail = FALSE)
sfl(
skimr::sfl(
skim_type = "mic",
min = ~as.character(sort(stats::na.omit(.))[1]),
max = ~as.character(sort(stats::na.omit(.))[length(stats::na.omit(.))]),
median = ~as.character(stats::na.omit(.)[as.double(stats::na.omit(.)) == median(as.double(stats::na.omit(.)))])[1],
n_unique = ~pm_n_distinct(., na.rm = TRUE),
hist_log2 = ~inline_hist(log2(as.double(stats::na.omit(.))))
hist_log2 = ~skimr::inline_hist(log2(as.double(stats::na.omit(.))))
)
}

107
R/mo.R

@ -25,7 +25,7 @@ @@ -25,7 +25,7 @@
#' Transform input to a microorganism ID
#'
#' Use this function to determine a valid microorganism ID ([`mo`]). Determination is done using intelligent rules and the complete taxonomic kingdoms Bacteria, Chromista, Protozoa, Archaea and most microbial species from the kingdom Fungi (see Source). The input can be almost anything: a full name (like `"Staphylococcus aureus"`), an abbreviated name (like `"S. aureus"`), an abbreviation known in the field (like `"MRSA"`), or just a genus. Please see *Examples*.
#' Use this function to determine a valid microorganism ID ([`mo`]). Determination is done using intelligent rules and the complete taxonomic kingdoms Bacteria, Chromista, Protozoa, Archaea and most microbial species from the kingdom Fungi (see Source). The input can be almost anything: a full name (like `"Staphylococcus aureus"`), an abbreviated name (such as `"S. aureus"`), an abbreviation known in the field (such as `"MRSA"`), or just a genus. Please see *Examples*.
#' @inheritSection lifecycle Stable lifecycle
#' @param x a character vector or a [data.frame] with one or two columns
#' @param Becker a logical to indicate whether staphylococci should be categorised into coagulase-negative staphylococci ("CoNS") and coagulase-positive staphylococci ("CoPS") instead of their own species, according to Karsten Becker *et al.* (1,2,3).
@ -111,7 +111,7 @@ @@ -111,7 +111,7 @@
#' @return A [character] [vector] with additional class [`mo`]
#' @seealso [microorganisms] for the [data.frame] that is being used to determine ID's.
#'
#' The [mo_property()] functions (like [mo_genus()], [mo_gramstain()]) to get properties based on the returned code.
#' The [`mo_*`][mo_property()] functions (such as [mo_genus()], [mo_gramstain()]) to get properties based on the returned code.
#' @inheritSection AMR Reference data publicly available
#' @inheritSection AMR Read more on our website!
#' @examples
@ -199,10 +199,10 @@ as.mo <- function(x, @@ -199,10 +199,10 @@ as.mo <- function(x,
x[trimws2(x) %like% paste0("^(", translate_AMR("no|not", language = language), ") [a-z]+")] <- "UNKNOWN"
uncertainty_level <- translate_allow_uncertain(allow_uncertain)
if (mo_source_isvalid(reference_df)
if (!is.null(reference_df)
&& mo_source_isvalid(reference_df)
&& isFALSE(Becker)
&& isFALSE(Lancefield)
&& !is.null(reference_df)
&& all(x %in% unlist(reference_df), na.rm = TRUE)) {
reference_df <- repair_reference_df(reference_df)
@ -358,11 +358,11 @@ exec_as.mo <- function(x, @@ -358,11 +358,11 @@ exec_as.mo <- function(x,
x[trimws2(x) %like% paste0("^(", translate_AMR("no|not", language = language), ") [a-z]+")] <- "UNKNOWN"
if (initial_search == TRUE) {
options(mo_failures = NULL)
options(mo_uncertainties = NULL)
options(mo_renamed = NULL)
mo_env$mo_failures <- NULL
mo_env$mo_uncertainties <- NULL
mo_env$mo_renamed <- NULL
}
options(mo_renamed_last_run = NULL)
mo_env$mo_renamed_last_run <- NULL
failures <- character(0)
uncertainty_level <- translate_allow_uncertain(allow_uncertain)
@ -595,7 +595,7 @@ exec_as.mo <- function(x, @@ -595,7 +595,7 @@ exec_as.mo <- function(x,
} else {
x[i] <- lookup(fullname == found["fullname_new"], haystack = MO_lookup)
}
options(mo_renamed_last_run = found["fullname"])
mo_env$mo_renamed_last_run <- found["fullname"]
was_renamed(name_old = found["fullname"],
name_new = lookup(fullname == found["fullname_new"], "fullname", haystack = MO_lookup),
ref_old = found["ref"],
@ -970,7 +970,7 @@ exec_as.mo <- function(x, @@ -970,7 +970,7 @@ exec_as.mo <- function(x,
} else {
x[i] <- lookup(fullname == found["fullname_new"], haystack = MO_lookup)
}
options(mo_renamed_last_run = found["fullname"])
mo_env$mo_renamed_last_run <- found["fullname"]
was_renamed(name_old = found["fullname"],
name_new = lookup(fullname == found["fullname_new"], "fullname", haystack = MO_lookup),
ref_old = found["ref"],
@ -1022,7 +1022,7 @@ exec_as.mo <- function(x, @@ -1022,7 +1022,7 @@ exec_as.mo <- function(x,
ref_old = found["ref"],
ref_new = lookup(fullname == found["fullname_new"], "ref", haystack = MO_lookup),
mo = lookup(fullname == found["fullname_new"], "mo", haystack = MO_lookup))
options(mo_renamed_last_run = found["fullname"])
mo_env$mo_renamed_last_run <- found["fullname"]
uncertainties <<- rbind(uncertainties,
format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup,
@ -1393,7 +1393,7 @@ exec_as.mo <- function(x, @@ -1393,7 +1393,7 @@ exec_as.mo <- function(x,
# handling failures ----
failures <- failures[!failures %in% c(NA, NULL, NaN)]
if (length(failures) > 0 & initial_search == TRUE) {
options(mo_failures = sort(unique(failures)))
mo_env$mo_failures <- sort(unique(failures))
plural <- c("value", "it", "was")
if (pm_n_distinct(failures) > 1) {
plural <- c("values", "them", "were")
@ -1420,7 +1420,7 @@ exec_as.mo <- function(x, @@ -1420,7 +1420,7 @@ exec_as.mo <- function(x,
# handling uncertainties ----
if (NROW(uncertainties) > 0 & initial_search == TRUE) {
uncertainties <- as.list(pm_distinct(uncertainties, input, .keep_all = TRUE))
options(mo_uncertainties = uncertainties)
mo_env$mo_uncertainties <- uncertainties
plural <- c("", "it", "was")
if (length(uncertainties$input) > 1) {
@ -1540,13 +1540,13 @@ was_renamed <- function(name_old, name_new, ref_old = "", ref_new = "", mo = "") @@ -1540,13 +1540,13 @@ was_renamed <- function(name_old, name_new, ref_old = "", ref_new = "", mo = "")
new_ref = ref_new,
mo = mo,
stringsAsFactors = FALSE)
already_set <- getOption("mo_renamed")
already_set <- mo_env$mo_renamed
if (!is.null(already_set)) {
options(mo_renamed = rbind(already_set,
mo_env$mo_renamed = rbind(already_set,
newly_set,
stringsAsFactors = FALSE))
stringsAsFactors = FALSE)
} else {
options(mo_renamed = newly_set)
mo_env$mo_renamed <- newly_set
}
}
@ -1554,9 +1554,9 @@ format_uncertainty_as_df <- function(uncertainty_level, @@ -1554,9 +1554,9 @@ format_uncertainty_as_df <- function(uncertainty_level,
input,
result_mo,
candidates = NULL) {
if (!is.null(getOption("mo_renamed_last_run", default = NULL))) {
fullname <- getOption("mo_renamed_last_run")
options(mo_renamed_last_run = NULL)
if (!is.null(mo_env$mo_renamed_last_run)) {
fullname <- mo_env$mo_renamed_last_run
mo_env$mo_renamed_last_run <- NULL
renamed_to <- MO_lookup[match(result_mo, MO_lookup$mo), "fullname", drop = TRUE][1]
} else {
fullname <- MO_lookup[match(result_mo, MO_lookup$mo), "fullname", drop = TRUE][1]
@ -1603,27 +1603,32 @@ freq.mo <- function(x, ...) { @@ -1603,27 +1603,32 @@ freq.mo <- function(x, ...) {
if (is.null(digits)) {
digits <- 2
}
freq.default <- import_fn("freq.default", "cleaner", error_on_fail = FALSE)
freq.default(x = x, ...,
.add_header = list(`Gram-negative` = paste0(format(sum(grams == "Gram-negative", na.rm = TRUE),
big.mark = ",",
decimal.mark = "."),
" (", percentage(sum(grams == "Gram-negative", na.rm = TRUE) / length(grams), digits = digits),
")"),
`Gram-positive` = paste0(format(sum(grams == "Gram-positive", na.rm = TRUE),
big.mark = ",",
decimal.mark = "."),
" (", percentage(sum(grams == "Gram-positive", na.rm = TRUE) / length(grams), digits = digits),
")"),
`Nr. of genera` = pm_n_distinct(mo_genus(x_noNA, language = NULL)),
`Nr. of species` = pm_n_distinct(paste(mo_genus(x_noNA, language = NULL),
mo_species(x_noNA, language = NULL)))))
cleaner::freq.default(
x = x,
...,
.add_header = list(
`Gram-negative` = paste0(
format(sum(grams == "Gram-negative", na.rm = TRUE),
big.mark = ",",
decimal.mark = "."),
" (", percentage(sum(grams == "Gram-negative", na.rm = TRUE) / length(grams),
digits = digits),
")"),
`Gram-positive` = paste0(
format(sum(grams == "Gram-positive", na.rm = TRUE),
big.mark = ",",
decimal.mark = "."),
" (", percentage(sum(grams == "Gram-positive", na.rm = TRUE) / length(grams),
digits = digits),
")"),
`Nr. of genera` = pm_n_distinct(mo_genus(x_noNA, language = NULL)),
`Nr. of species` = pm_n_distinct(paste(mo_genus(x_noNA, language = NULL),
mo_species(x_noNA, language = NULL)))))
}
# will be exported using s3_register() in R/zzz.R
get_skimmers.mo <- function(column) {
sfl <- import_fn("sfl", "skimr", error_on_fail = FALSE)
sfl(
skimr::sfl(
skim_type = "mo",
unique_total = ~pm_n_distinct(., na.rm = TRUE),
gram_negative = ~sum(mo_is_gram_negative(stats::na.omit(.))),
@ -1736,16 +1741,16 @@ unique.mo <- function(x, incomparables = FALSE, ...) { @@ -1736,16 +1741,16 @@ unique.mo <- function(x, incomparables = FALSE, ...) {
#' @rdname as.mo
#' @export
mo_failures <- function() {
getOption("mo_failures")
mo_env$mo_failures
}
#' @rdname as.mo
#' @export
mo_uncertainties <- function() {
if (is.null(getOption("mo_uncertainties"))) {
if (is.null(mo_env$mo_uncertainties)) {
return(NULL)
}
set_clean_class(as.data.frame(getOption("mo_uncertainties"),
set_clean_class(as.data.frame(mo_env$mo_uncertainties,
stringsAsFactors = FALSE),
new_class = c("mo_uncertainties", "data.frame"))
}
@ -1814,7 +1819,7 @@ print.mo_uncertainties <- function(x, ...) { @@ -1814,7 +1819,7 @@ print.mo_uncertainties <- function(x, ...) {
#' @rdname as.mo
#' @export
mo_renamed <- function() {
items <- getOption("mo_renamed", default = NULL)
items <- mo_env$mo_renamed
if (is.null(items)) {
items <- data.frame(stringsAsFactors = FALSE)
} else {
@ -1878,20 +1883,20 @@ translate_allow_uncertain <- function(allow_uncertain) { @@ -1878,20 +1883,20 @@ translate_allow_uncertain <- function(allow_uncertain) {
}
get_mo_failures_uncertainties_renamed <- function() {
remember <- list(failures = getOption("mo_failures"),
uncertainties = getOption("mo_uncertainties"),
renamed = getOption("mo_renamed"))
remember <- list(failures = mo_env$mo_failures,
uncertainties = mo_env$mo_uncertainties,
renamed = mo_env$mo_renamed)
# empty them, otherwise mo_shortname("Chlamydophila psittaci") will give 3 notes
options("mo_failures" = NULL)
options("mo_uncertainties" = NULL)
options("mo_renamed" = NULL)
mo_env$mo_failures <- NULL
mo_env$mo_uncertainties <- NULL
mo_env$mo_renamed <- NULL
remember
}
load_mo_failures_uncertainties_renamed <- function(metadata) {
options("mo_failures" = metadata$failures)
options("mo_uncertainties" = metadata$uncertainties)
options("mo_renamed" = metadata$renamed)
mo_env$mo_failures <- metadata$failures
mo_env$mo_uncertainties <- metadata$uncertainties
mo_env$mo_renamed <- metadata$renamed
}
trimws2 <- function(x) {
@ -1978,3 +1983,5 @@ repair_reference_df <- function(reference_df) { @@ -1978,3 +1983,5 @@ repair_reference_df <- function(reference_df) {
reference_df[, "mo"] <- as.mo(reference_df[, "mo", drop = TRUE])
reference_df
}
mo_env <- new.env(hash = FALSE)

2
R/mo_property.R

@ -38,7 +38,7 @@ @@ -38,7 +38,7 @@
#' - `mo_ref("Escherichia blattae")` will return `"Burgess et al., 1973"` (with a message about the renaming)
#' - `mo_ref("Shimwellia blattae")` will return `"Priest et al., 2010"` (without a message)
#'
#' The short name - [mo_shortname()] - almost always returns the first character of the genus and the full species, like `"E. coli"`. Exceptions are abbreviations of staphylococci (like *"CoNS"*, Coagulase-Negative Staphylococci) and beta-haemolytic streptococci (like *"GBS"*, Group B Streptococci). Please bear in mind that e.g. *E. coli* could mean *Escherichia coli* (kingdom of Bacteria) as well as *Entamoeba coli* (kingdom of Protozoa). Returning to the full name will be done using [as.mo()] internally, giving priority to bacteria and human pathogens, i.e. `"E. coli"` will be considered *Escherichia coli*. In other words, `mo_fullname(mo_shortname("Entamoeba coli"))` returns `"Escherichia coli"`.
#' The short name - [mo_shortname()] - almost always returns the first character of the genus and the full species, like `"E. coli"`. Exceptions are abbreviations of staphylococci (such as *"CoNS"*, Coagulase-Negative Staphylococci) and beta-haemolytic streptococci (such as *"GBS"*, Group B Streptococci). Please bear in mind that e.g. *E. coli* could mean *Escherichia coli* (kingdom of Bacteria) as well as *Entamoeba coli* (kingdom of Protozoa). Returning to the full name will be done using [as.mo()] internally, giving priority to bacteria and human pathogens, i.e. `"E. coli"` will be considered *Escherichia coli*. In other words, `mo_fullname(mo_shortname("Entamoeba coli"))` returns `"Escherichia coli"`.
#'
#' Since the top-level of the taxonomy is sometimes referred to as 'kingdom' and sometimes as 'domain', the functions [mo_kingdom()] and [mo_domain()] return the exact same results.
#'

108
R/mo_source.R

@ -30,16 +30,17 @@ @@ -30,16 +30,17 @@
#' This is **the fastest way** to have your organisation (or analysis) specific codes picked up and translated by this package.
#' @inheritSection lifecycle Stable lifecycle
#' @param path location of your reference file, see Details. Can be `""`, `NULL` or `FALSE` to delete the reference file.
#' @param destination destination of the compressed data file, default to the user's home directory.
#' @rdname mo_source
#' @name mo_source
#' @aliases set_mo_source get_mo_source
#' @details The reference file can be a text file separated with commas (CSV) or tabs or pipes, an Excel file (either 'xls' or 'xlsx' format) or an R object file (extension '.rds'). To use an Excel file, you will need to have the `readxl` package installed.
#'
#' [set_mo_source()] will check the file for validity: it must be a [data.frame], must have a column named `"mo"` which contains values from [`microorganisms$mo`][microorganisms] and must have a reference column with your own defined values. If all tests pass, [set_mo_source()] will read the file into R and will ask to export it to `"~/.mo_source.rds"`. The CRAN policy disallows packages to write to the file system, although '*exceptions may be allowed in interactive sessions if the package obtains confirmation from the user*'. For this reason, this function only works in interactive sessions so that the user can **specifically confirm and allow** that this file will be created.
#' [set_mo_source()] will check the file for validity: it must be a [data.frame], must have a column named `"mo"` which contains values from [`microorganisms$mo`][microorganisms] and must have a reference column with your own defined values. If all tests pass, [set_mo_source()] will read the file into R and will ask to export it to `"~/mo_source.rds"`. The CRAN policy disallows packages to write to the file system, although '*exceptions may be allowed in interactive sessions if the package obtains confirmation from the user*'. For this reason, this function only works in interactive sessions so that the user can **specifically confirm and allow** that this file will be created. The destination of this file can be set with the `destination` parameter and defaults to the user's home directory. It can also be set as an \R option, using `options(AMR_mo_source = "my/location/file.rds)`.
#'
#' The created compressed data file `"~/.mo_source.rds"` will be used at default for MO determination (function [as.mo()] and consequently all `mo_*` functions like [mo_genus()] and [mo_gramstain()]). The location of the original file will be saved as an R option with `options(mo_source = path)`. Its timestamp will be saved with `options(mo_source_datetime = ...)`.
#' The created compressed data file `"mo_source.rds"` will be used at default for MO determination (function [as.mo()] and consequently all `mo_*` functions like [mo_genus()] and [mo_gramstain()]). The location and timestamp of the original file will be saved as an attribute to the compressed data file.
#'
#' The function [get_mo_source()] will return the data set by reading `"~/.mo_source.rds"` with [readRDS()]. If the original file has changed (by checking the aforementioned options `mo_source` and `mo_source_datetime`), it will call [set_mo_source()] to update the data file automatically if used in an interactive session.
#' The function [get_mo_source()] will return the data set by reading `"mo_source.rds"` with [readRDS()]. If the original file has changed (by checking the location and timestamp of the original file), it will call [set_mo_source()] to update the data file automatically if used in an interactive session.
#'
#' Reading an Excel file (`.xlsx`) with only one row has a size of 8-9 kB. The compressed file created with [set_mo_source()] will then have a size of 0.1 kB and can be read by [get_mo_source()] in only a couple of microseconds (millionths of a second).
#'
@ -60,16 +61,18 @@ @@ -60,16 +61,18 @@
#'
#' ```
#' set_mo_source("home/me/ourcodes.xlsx")
#' #> NOTE: Created mo_source file '~/.mo_source.rds' from 'home/me/ourcodes.xlsx'
#' #> (columns "Organisation XYZ" and "mo")
#' #> NOTE: Created mo_source file '/Users/me/mo_source.rds' (0.3 kB) from
#' #> '/Users/me/Documents/ourcodes.xlsx' (9 kB), columns
#' #> "Organisation XYZ" and "mo"
#' ```
#'
#' It has now created a file `"~/.mo_source.rds"` with the contents of our Excel file. Only the first column with foreign values and the 'mo' column will be kept when creating the RDS file.
#' It has now created a file `"~/mo_source.rds"` with the contents of our Excel file. Only the first column with foreign values and the 'mo' column will be kept when creating the RDS file.
#'
#' And now we can use it in our functions:
#'
#' ```
#' as.mo("lab_mo_ecoli")
#' #> Class <mo>
#' #> [1] B_ESCHR_COLI
#'
#' mo_genus("lab_mo_kpneumoniae")
@ -77,6 +80,9 @@ @@ -77,6 +80,9 @@
#'
#' # other input values still work too
#' as.mo(c("Escherichia coli", "E. coli", "lab_mo_ecoli"))
#' #> NOTE: Translation to one microorganism was guessed with uncertainty.
#' #> Use mo_uncertainties() to review it.
#' #> Class <mo>
#' #> [1] B_ESCHR_COLI B_ESCHR_COLI B_ESCHR_COLI
#' ```
#'
@ -96,8 +102,10 @@ @@ -96,8 +102,10 @@
#'
#' ```
#' as.mo("lab_mo_ecoli")
#' #> NOTE: Updated mo_source file '~/.mo_source.rds' from 'home/me/ourcodes.xlsx'
#' #> (columns "Organisation XYZ" and "mo")
#' #> NOTE: Updated mo_source file '/Users/me/mo_source.rds' (0.3 kB) from
#' #> '/Users/me/Documents/ourcodes.xlsx' (9 kB), columns
#' #> "Organisation XYZ" and "mo"
#' #> Class <mo>
#' #> [1] B_ESCHR_COLI
#'
#' mo_genus("lab_Staph_aureus")
@ -108,25 +116,26 @@ @@ -108,25 +116,26 @@
#'
#' ```
#' set_mo_source(NULL)
#' # Removed mo_source file '~/.mo_source.rds'.
#' #> Removed mo_source file '/Users/me/mo_source.rds'
#' ```
#'
#' If the original Excel file is moved or deleted, the mo_source file will be removed upon the next use of [as.mo()]. If the mo_source file is manually deleted (i.e. without using [set_mo_source()]), the references to the mo_source file will be removed upon the next use of [as.mo()].
#' If the original Excel file is moved or deleted, the mo_source file will be removed upon the next use of [as.mo()].
#' @export
#' @inheritSection AMR Read more on our website!
set_mo_source <- function(path) {
meet_criteria(path, allow_class = "character", has_length = 1)
set_mo_source <- function(path, destination = getOption("AMR_mo_source", "~/mo_source.rds")) {
meet_criteria(path, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(destination, allow_class = "character", has_length = 1)
stop_ifnot(destination %like% "[.]rds$", "the `destination` must be a file location with file extension .rds")
file_location <- path.expand("~/mo_source.rds")
mo_source_destination <- path.expand(destination)
stop_ifnot(interactive(), "This function can only be used in interactive mode, since it must ask for the user's permission to write a file to their home folder.")
if (is.null(path) || path %in% c(FALSE, "")) {
options(mo_source = NULL)
options(mo_source_timestamp = NULL)
if (file.exists(file_location)) {
unlink(file_location)
message_("Removed mo_source file '", font_bold(file_location), "'",
mo_env$mo_source <- NULL
if (file.exists(mo_source_destination)) {
unlink(mo_source_destination)
message_("Removed mo_source file '", font_bold(mo_source_destination), "'",
add_fn = font_red,
as_note = FALSE)
}
@ -178,16 +187,19 @@ set_mo_source <- function(path) { @@ -178,16 +187,19 @@ set_mo_source <- function(path) {
}
df <- as.data.frame(df, stringAsFactors = FALSE)
df[, "mo"] <- set_clean_class(df[, "mo", drop = TRUE], c("mo", "character"))
# success
if (file.exists(file_location)) {
if (file.exists(mo_source_destination)) {
action <- "Updated"
} else {
action <- "Created"
# only ask when file is created, not when it is updated
txt <- paste0("This will write create the new file '",
file_location,
"', for which your permission is needed.\n\nDo you agree that this file will be created? ")
txt <- paste0(word_wrap(paste0("This will write create the new file '",
mo_source_destination,
"', for which your permission is needed.")),
"\n\n",
word_wrap("Do you agree that this file will be created?"))
if ("rsasdtudioapi" %in% rownames(utils::installed.packages())) {
showQuestion <- import_fn("showQuestion", "rstudioapi")
q_continue <- showQuestion("Create new file in home directory", txt)
@ -198,42 +210,38 @@ set_mo_source <- function(path) { @@ -198,42 +210,38 @@ set_mo_source <- function(path) {
return(invisible())
}
}
saveRDS(df, file_location)
options(mo_source = path)
options(mo_source_timestamp = as.character(file.info(path)$mtime))
message_(action, " mo_source file '", font_bold(file_location), "'",
" from '", font_bold(path), "'",
'(columns "', colnames(df)[1], '" and "', colnames(df)[2], '")')
attr(df, "mo_source_location") <- path
attr(df, "mo_source_timestamp") <- file.mtime(path)
saveRDS(df, mo_source_destination)
mo_env$mo_source <- df
message_(action, " mo_source file '", font_bold(mo_source_destination),
"' (", formatted_filesize(mo_source_destination),
") from '", font_bold(path),
"' (", formatted_filesize(path),
'), columns "', colnames(df)[1], '" and "', colnames(df)[2], '"')
}
#' @rdname mo_source
#' @export
get_mo_source <- function() {
if (is.null(getOption("mo_source", NULL))) {
get_mo_source <- function(destination = getOption("AMR_mo_source", "~/mo_source.rds")) {
if (!file.exists(path.expand(destination))) {
if (interactive()) {
# source file might have been deleted, update reference
set_mo_source("")
}
return(NULL)
}
if (!file.exists(path.expand("~/mo_source.rds"))) {
options(mo_source = NULL)
options(mo_source_timestamp = NULL)
message_("Removed references to deleted mo_source file (see ?mo_source)")
return(NULL)
if (is.null(mo_env$mo_source)) {
mo_env$mo_source <- readRDS(path.expand(destination))
}
old_time <- as.POSIXct(getOption("mo_source_timestamp"))
new_time <- as.POSIXct(as.character(file.info(getOption("mo_source", ""))$mtime))
if (is.na(new_time)) {
# source file was deleted, remove reference too
set_mo_source("")
return(NULL)
}
if (interactive() && new_time != old_time) {
# set updated source
set_mo_source(getOption("mo_source"))
old_time <- attributes(mo_env$mo_source)$mo_source_timestamp
new_time <- file.mtime(attributes(mo_env$mo_source)$mo_source_location)
if (interactive() && !identical(old_time, new_time)) {
# source file was updated, also update reference
set_mo_source(attributes(mo_env$mo_source)$mo_source_location)
}
file_location <- path.expand("~/mo_source.rds")
readRDS(file_location)
mo_env$mo_source
}
mo_source_isvalid <- function(x, refer_to_name = "`reference_df`", stop_on_error = TRUE) {
@ -242,7 +250,7 @@ mo_source_isvalid <- function(x, refer_to_name = "`reference_df`", stop_on_error @@ -242,7 +250,7 @@ mo_source_isvalid <- function(x, refer_to_name = "`reference_df`", stop_on_error
if (paste(deparse(substitute(x)), collapse = "") == "get_mo_source()") {
return(TRUE)
}
if (identical(x, get_mo_source())) {
if (is.null(mo_env$mo_source) && (identical(x, get_mo_source()))) {
return(TRUE)
}
if (is.null(x)) {

4
R/proportion.R

@ -34,9 +34,9 @@ @@ -34,9 +34,9 @@
#' @param as_percent a logical to indicate whether the output must be returned as a hundred fold with % sign (a character). A value of `0.123456` will then be returned as `"12.3%"`.
#' @param only_all_tested (for combination therapies, i.e. using more than one variable for `...`): a logical to indicate that isolates must be tested for all antibiotics, see section *Combination therapy* below
#' @param data a [data.frame] containing columns with class [`rsi`] (see [as.rsi()])
#' @param translate_ab a column name of the [antibiotics] data set to translate the antibiotic abbreviations to, using [ab_property()]. Use a value
#' @param translate_ab a column name of the [antibiotics] data set to translate the antibiotic abbreviations to, using [ab_property()]
#' @inheritParams ab_property
#' @param combine_SI a logical to indicate whether all values of S and I must be merged into one, so the output only consists of S+I vs. R (susceptible vs. resistant). This used to be the parameter `combine_IR`, but this now follows the redefinition by EUCAST about the interpretion of I (increased exposure) in 2019, see section 'Interpretation of S, I and R' below. Default is `TRUE`.
#' @param combine_SI a logical to indicate whether all values of S and I must be merged into one, so the output only consists of S+I vs. R (susceptible vs. resistant). This used to be the parameter `combine_IR`, but this now follows the redefinition by EUCAST about the interpretation of I (increased exposure) in 2019, see section 'Interpretation of S, I and R' below. Default is `TRUE`.
#' @param combine_IR a logical to indicate whether all values of I and R must be merged into one, so the output only consists of S vs. I+R (susceptible vs. non-susceptible). This is outdated, see parameter `combine_SI`.
#' @inheritSection as.rsi Interpretation of R and S/I
#' @details

2
R/resistance_predict.R

@ -34,7 +34,7 @@ @@ -34,7 +34,7 @@
#' @param year_every unit of sequence between lowest year found in the data and `year_max`
#' @param minimum minimal amount of available isolates per year to include. Years containing less observations will be estimated by the model.
#' @param model the statistical model of choice. This could be a generalised linear regression model with binomial distribution (i.e. using `glm(..., family = binomial)``, assuming that a period of zero resistance was followed by a period of increasing resistance leading slowly to more and more resistance. See Details for all valid options.
#' @param I_as_S a logical to indicate whether values `I` should be treated as `S` (will otherwise be treated as `R`). The default, `TRUE`, follows the redefinition by EUCAST about the interpretion of I (increased exposure) in 2019, see section *Interpretation of S, I and R* below.
#' @param I_as_S a logical to indicate whether values `"I"` should be treated as `"S"` (will otherwise be treated as `"R"`). The default, `TRUE`, follows the redefinition by EUCAST about the interpretation of I (increased exposure) in 2019, see section *Interpretation of S, I and R* below.
#' @param preserve_measurements a logical to indicate whether predictions of years that are actually available in the data should be overwritten by the original data. The standard errors of those years will be `NA`.
#' @param info a logical to indicate whether textual analysis should be printed with the name and [summary()] of the statistical model.
#' @param main title of the plot

46
R/rsi.R

@ -481,7 +481,7 @@ as.rsi.data.frame <- function(x, @@ -481,7 +481,7 @@ as.rsi.data.frame <- function(x,
meet_criteria(conserve_capped_values, allow_class = "logical", has_length = 1)
meet_criteria(add_intrinsic_resistance, allow_class = "logical", has_length = 1)
meet_criteria(reference_data, allow_class = "data.frame")
for (i in seq_len(ncol(x))) {
# don't keep factors
if (is.factor(x[, i, drop = TRUE])) {
@ -494,7 +494,7 @@ as.rsi.data.frame <- function(x, @@ -494,7 +494,7 @@ as.rsi.data.frame <- function(x,
if (is.null(col_mo)) {
col_mo <- search_type_in_df(x = x, type = "mo", info = FALSE)
}
# -- UTIs
col_uti <- uti
if (is.null(col_uti)) {
@ -535,12 +535,13 @@ as.rsi.data.frame <- function(x, @@ -535,12 +535,13 @@ as.rsi.data.frame <- function(x,
uti <- FALSE
}
}
i <- 0
sel <- colnames(pm_select(x, ...))
if (!is.null(col_mo)) {
sel <- sel[sel != col_mo]
}
ab_cols <- colnames(x)[sapply(x, function(y) {
i <<- i + 1
check <- is.mic(y) | is.disk(y)
@ -563,17 +564,16 @@ as.rsi.data.frame <- function(x, @@ -563,17 +564,16 @@ as.rsi.data.frame <- function(x,
return(FALSE)
}
})]
stop_if(length(ab_cols) == 0,
"no columns with MIC values, disk zones or antibiotic column names found in this data set. Use as.mic() or as.disk() to transform antimicrobial columns.")
# set type per column
types <- character(length(ab_cols))
types[sapply(x[, ab_cols], is.disk)] <- "disk"
types[types == "" & sapply(x[, ab_cols], all_valid_disks)] <- "disk"
types[sapply(x[, ab_cols], is.mic)] <- "mic"
types[types == "" & sapply(x[, ab_cols], all_valid_mics)] <- "mic"
types[types == "" & !sapply(x[, ab_cols], is.rsi)] <- "rsi"
types[sapply(x[, ab_cols, drop = FALSE], is.disk)] <- "disk"
types[types == "" & sapply(x[, ab_cols, drop = FALSE], all_valid_disks)] <- "disk"
types[sapply(x[, ab_cols, drop = FALSE], is.mic)] <- "mic"
types[types == "" & sapply(x[, ab_cols, drop = FALSE], all_valid_mics)] <- "mic"
types[types == "" & !sapply(x[, ab_cols, drop = FALSE], is.rsi)] <- "rsi"
if (any(types %in% c("mic", "disk"), na.rm = TRUE)) {
# now we need an mo column
stop_if(is.null(col_mo), "`col_mo` must be set")
@ -582,9 +582,9 @@ as.rsi.data.frame <- function(x, @@ -582,9 +582,9 @@ as.rsi.data.frame <- function(x,
col_mo <- search_type_in_df(x = x, type = "mo")
}
}
x_mo <- as.mo(x %pm>% pm_pull(col_mo))
for (i in seq_len(length(ab_cols))) {
if (types[i] == "mic") {
x[, ab_cols[i]] <- as.rsi(x = x %pm>%
@ -845,19 +845,22 @@ freq.rsi <- function(x, ...) { @@ -845,19 +845,22 @@ freq.rsi <- function(x, ...) {
}))[1L]
}
ab <- suppressMessages(suppressWarnings(as.ab(x_name)))
freq.default <- import_fn("freq.default", "cleaner", error_on_fail = FALSE)
digits <- list(...)$digits
if (is.null(digits)) {
digits <- 2
}
if (!is.na(ab)) {
freq.default(x = x, ...,
.add_header = list(Drug = paste0(ab_name(ab, language = NULL), " (", ab, ", ", ab_atc(ab), ")"),
`Drug group` = ab_group(ab, language = NULL),
`%SI` = percentage(susceptibility(x, minimum = 0, as_percent = FALSE), digits = digits)))
cleaner::freq.default(x = x, ...,
.add_header = list(
Drug = paste0(ab_name(ab, language = NULL), " (", ab, ", ", ab_atc(ab), ")"),
`Drug group` = ab_group(ab, language = NULL),
`%SI` = percentage(susceptibility(x, minimum = 0, as_percent = FALSE),
digits = digits)))
} else {
freq.default(x = x, ...,
.add_header = list(`%SI` = percentage(susceptibility(x, minimum = 0, as_percent = FALSE), digits = digits)))
cleaner::freq.default(x = x, ...,
.add_header = list(
`%SI` = percentage(susceptibility(x, minimum = 0, as_percent = FALSE),
digits = digits)))
}
}
@ -892,8 +895,7 @@ get_skimmers.rsi <- function(column) { @@ -892,8 +895,7 @@ get_skimmers.rsi <- function(column) {
}
}
sfl <- import_fn("sfl", "skimr", error_on_fail = FALSE)
sfl(
skimr::sfl(
skim_type = "rsi",
ab_name = name_call,
count_R = count_R,
@ -916,7 +918,7 @@ print.rsi <- function(x, ...) { @@ -916,7 +918,7 @@ print.rsi <- function(x, ...) {
#' @method droplevels rsi
#' @export
#' @noRd
droplevels.rsi <- function(x, exclude = if (anyNA(levels(x))) NULL else NA, ...) {
droplevels.rsi <- function(x, exclude = if (any(is.na(levels(x)))) NULL else NA, ...) {
x <- droplevels.factor(x, exclude = exclude, ...)
class(x) <- c("rsi", "ordered", "factor")
x

6
R/rsi_calc.R

@ -96,7 +96,11 @@ rsi_calc <- function(..., @@ -96,7 +96,11 @@ rsi_calc <- function(...,
if (is.null(x)) {
warning_("argument is NULL (check if columns exist): returning NA", call = FALSE)
return(NA)
if (as_percent == TRUE) {
return(NA_character_)
} else {
return(NA_real_)
}
}
print_warning <- FALSE

4
R/translate.R

@ -27,7 +27,7 @@ @@ -27,7 +27,7 @@
#'
#' For language-dependent output of AMR functions, like [mo_name()], [mo_gramstain()], [mo_type()] and [ab_name()].
#' @inheritSection lifecycle Stable lifecycle
#' @details Strings will be translated to foreign languages if they are defined in a local translation file. Additions to this file can be suggested at our repository. The file can be found here: <https://github.com/msberends/AMR/blob/master/data-raw/translations.tsv>. This file will be read by all functions where a translated output can be desired, like all [mo_property()] functions ([mo_name()], [mo_gramstain()], [mo_type()], etc.) and [ab_property()] functions ([ab_name()], [ab_group()] etc.).
#' @details Strings will be translated to foreign languages if they are defined in a local translation file. Additions to this file can be suggested at our repository. The file can be found here: <https://github.com/msberends/AMR/blob/master/data-raw/translations.tsv>. This file will be read by all functions where a translated output can be desired, like all [`mo_*`][mo_property()] functions (such as [mo_name()], [mo_gramstain()], [mo_type()], etc.) and [`ab_*`][ab_property()] functions (such as [ab_name()], [ab_group()], etc.).
#'
#' Currently supported languages are: `r paste(sort(gsub(";.*", "", ISOcodes::ISO_639_2[which(ISOcodes::ISO_639_2$Alpha_2 %in% LANGUAGES_SUPPORTED), "Name"])), collapse = ", ")`. Please note that currently not all these languages have translations available for all antimicrobial agents and colloquial microorganism names.
#'
@ -96,7 +96,7 @@ get_locale <- function() { @@ -96,7 +96,7 @@ get_locale <- function() {
}
}
coerce_language_setting(Sys.getlocale())
coerce_language_setting(Sys.getlocale("LC_COLLATE"))
}
coerce_language_setting <- function(lang) {

1
R/zzz.R

@ -24,6 +24,7 @@ @@ -24,6 +24,7 @@
# ==================================================================== #
.onLoad <- function(libname, pkgname) {
assign(x = "AB_lookup",
value = create_AB_lookup(),
envir = asNamespace("AMR"))

4
data-raw/reproduction_of_poorman.R

@ -75,3 +75,7 @@ contents <- gsub("pm_distinct <- function(.data, ..., .keep_all = FALSE)", "pm_d @@ -75,3 +75,7 @@ contents <- gsub("pm_distinct <- function(.data, ..., .keep_all = FALSE)", "pm_d
contents <- contents[!grepl("summarize", contents)]
writeLines(contents, "R/aa_helper_pm_functions.R")
# after this, comment out:
# pm_left_join() since we use a faster version
# pm_group_split() since we don't use it and it relies on R 3.5.0 for the use of ...length(), which is hard to support with C++ code

2
docs/404.html

@ -81,7 +81,7 @@ @@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="https://msberends.github.io/AMR//index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9040</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9041</span>
</span>
</div>

2
docs/LICENSE-text.html

@ -81,7 +81,7 @@ @@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9040</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9041</span>
</span>
</div>

40
docs/articles/datasets.html

@ -39,7 +39,7 @@ @@ -39,7 +39,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9032</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9041</span>
</span>
</div>
@ -47,14 +47,14 @@ @@ -47,14 +47,14 @@
<ul class="nav navbar-nav">
<li>
<a href="../index.html">
<span class="fa fa-home"></span>
<span class="fas fa-home"></span>
Home
</a>
</li>
<li class="dropdown">
<a href="#" class="dropdown-toggle" data-toggle="dropdown" role="button" aria-expanded="false">
<span class="fa fa-question-circle"></span>
<span class="fas fa-question-circle"></span>
How to
@ -63,77 +63,77 @@ @@ -63,77 +63,77 @@
<ul class="dropdown-menu" role="menu">
<li>
<a href="../articles/AMR.html">
<span class="fa fa-directions"></span>
<span class="fas fa-directions"></span>
Conduct AMR analysis
</a>
</li>
<li>
<a href="../articles/resistance_predict.html">
<span class="fa fa-dice"></span>
<span class="fas fa-dice"></span>
Predict antimicrobial resistance
</a>
</li>
<li>
<a href="../articles/datasets.html">
<span class="fa fa-database"></span>
<span class="fas fa-database"></span>
Data sets for download / own use
</a>
</li>
<li>
<a href="../articles/PCA.html">