Browse Source

(v1.4.0.9008) like variations

main
parent
commit
760d69a3e0
  1. 4
      DESCRIPTION
  2. 2
      NAMESPACE
  3. 8
      NEWS.md
  4. 171
      R/aa_helper_functions.R
  5. 13
      R/like.R
  6. 349
      R/mo.R
  7. 118
      R/mo_property.R
  8. 2
      docs/404.html
  9. 2
      docs/LICENSE-text.html
  10. 54
      docs/articles/PCA.html
  11. 4
      docs/articles/PCA_files/anchor-sections-1.0/anchor-sections.css
  12. 33
      docs/articles/PCA_files/anchor-sections-1.0/anchor-sections.js
  13. BIN
      docs/articles/PCA_files/figure-html/unnamed-chunk-5-1.png
  14. BIN
      docs/articles/PCA_files/figure-html/unnamed-chunk-6-1.png
  15. BIN
      docs/articles/PCA_files/figure-html/unnamed-chunk-7-1.png
  16. 80
      docs/articles/SPSS.html
  17. 4
      docs/articles/SPSS_files/anchor-sections-1.0/anchor-sections.css
  18. 33
      docs/articles/SPSS_files/anchor-sections-1.0/anchor-sections.js
  19. 47
      docs/articles/WHONET.html
  20. 4
      docs/articles/WHONET_files/anchor-sections-1.0/anchor-sections.css
  21. 33
      docs/articles/WHONET_files/anchor-sections-1.0/anchor-sections.js
  22. BIN
      docs/articles/WHONET_files/figure-html/unnamed-chunk-7-1.png
  23. 95
      docs/articles/benchmarks.html
  24. 4
      docs/articles/benchmarks_files/anchor-sections-1.0/anchor-sections.css
  25. 33
      docs/articles/benchmarks_files/anchor-sections-1.0/anchor-sections.js
  26. BIN
      docs/articles/benchmarks_files/figure-html/unnamed-chunk-4-1.png
  27. 2
      docs/articles/index.html
  28. 61
      docs/articles/resistance_predict.html
  29. 4
      docs/articles/resistance_predict_files/anchor-sections-1.0/anchor-sections.css
  30. 33
      docs/articles/resistance_predict_files/anchor-sections-1.0/anchor-sections.js
  31. BIN
      docs/articles/resistance_predict_files/figure-html/unnamed-chunk-4-1.png
  32. BIN
      docs/articles/resistance_predict_files/figure-html/unnamed-chunk-5-1.png
  33. BIN
      docs/articles/resistance_predict_files/figure-html/unnamed-chunk-5-2.png
  34. BIN
      docs/articles/resistance_predict_files/figure-html/unnamed-chunk-6-1.png
  35. BIN
      docs/articles/resistance_predict_files/figure-html/unnamed-chunk-7-1.png
  36. 7
      docs/articles/welcome_to_AMR.html
  37. 4
      docs/articles/welcome_to_AMR_files/anchor-sections-1.0/anchor-sections.css
  38. 33
      docs/articles/welcome_to_AMR_files/anchor-sections-1.0/anchor-sections.js
  39. 2
      docs/authors.html
  40. 2
      docs/index.html
  41. 56
      docs/news/index.html
  42. 4
      docs/pkgdown.yml
  43. 2
      docs/reference/AMR-deprecated.html
  44. 2
      docs/reference/age.html
  45. 2
      docs/reference/age_groups.html
  46. 2
      docs/reference/antibiotic_class_selectors.html
  47. 2
      docs/reference/as.mo.html
  48. 2
      docs/reference/as.rsi.html
  49. 2
      docs/reference/bug_drug_combinations.html
  50. 68
      docs/reference/filter_ab_class.html
  51. 2
      docs/reference/ggplot_pca.html
  52. 2
      docs/reference/ggplot_rsi.html
  53. 2
      docs/reference/guess_ab_col.html
  54. 6
      docs/reference/index.html
  55. 2
      docs/reference/key_antibiotics.html
  56. 4
      docs/reference/lifecycle.html
  57. 17
      docs/reference/like.html
  58. 8
      docs/reference/mo_property.html
  59. 46
      docs/reference/pca.html
  60. 2
      docs/survey.html
  61. 2
      inst/rstudio/addins.dcf
  62. 12
      man/like.Rd
  63. 6
      man/mo_property.Rd
  64. 7
      tests/testthat/test-like.R

4
DESCRIPTION

@ -1,6 +1,6 @@ @@ -1,6 +1,6 @@
Package: AMR
Version: 1.4.0.9007
Date: 2020-10-21
Version: 1.4.0.9008
Date: 2020-10-26
Title: Antimicrobial Resistance Analysis
Authors@R: c(
person(role = c("aut", "cre"),

2
NAMESPACE

@ -65,6 +65,8 @@ S3method(unique,mo) @@ -65,6 +65,8 @@ S3method(unique,mo)
S3method(unique,rsi)
export("%like%")
export("%like_case%")
export("%not_like%")
export("%not_like_case%")
export(ab_atc)
export(ab_atc_group1)
export(ab_atc_group2)

8
NEWS.md

@ -1,17 +1,19 @@ @@ -1,17 +1,19 @@
# AMR 1.4.0.9007
## <small>Last updated: 21 October 2020</small>
# AMR 1.4.0.9008
## <small>Last updated: 26 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.
* Functions `%not_like%` and `%like_perl%` as wrappers around `%like%`.
* Functions `%not_like%` and `%not_like_case%` as wrappers around `%like%` and `%like_case%`. The RStudio addin to insert the text " %like% " as provided in this package now iterates over all like variants. So if you have defined the keyboard shortcut Ctrl/Cmd + L to this addin, it will first insert ` %like% ` and by pressing it again it will be replaced with ` %not_like% `, etc.
### 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.
* Better determination of disk zones and MIC values when running `as.rsi()` on a data.frame
* Updated coagulase-negative staphylococci 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
* Fix for using parameter `reference_df` in `as.mo()` and `mo_*()` functions that contain old microbial codes (from previous package versions)
### Other
* All messages thrown by this package now have correct line breaks
* More extensive unit tests
# AMR 1.4.0

171
R/aa_helper_functions.R

@ -9,7 +9,7 @@ @@ -9,7 +9,7 @@
# (c) 2018-2020 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@ -37,18 +37,18 @@ pm_left_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) { @@ -37,18 +37,18 @@ pm_left_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
if (length(by) == 1) {
by <- rep(by, 2)
}
int_x <- colnames(x) %in% colnames(y) & colnames(x) != by[1]
int_y <- colnames(y) %in% colnames(x) & colnames(y) != by[2]
colnames(x)[int_x] <- paste0(colnames(x)[int_x], suffix[1L])
colnames(y)[int_y] <- paste0(colnames(y)[int_y], suffix[2L])
merged <- cbind(x,
y[match(x[, by[1], drop = TRUE],
y[, by[2], drop = TRUE]),
colnames(y)[!colnames(y) %in% colnames(x) & !colnames(y) == by[2]],
drop = FALSE])
rownames(merged) <- NULL
merged
}
@ -71,7 +71,42 @@ addin_insert_in <- function() { @@ -71,7 +71,42 @@ addin_insert_in <- function() {
# No export, no Rd
addin_insert_like <- function() {
import_fn("insertText", "rstudioapi")(" %like% ")
stop_ifnot_installed("rstudioapi")
# we want Ctrl/Cmd + L to iterate over %like%, %not_like% and %like_case%, so determine context first
getSourceEditorContext <- import_fn("getSourceEditorContext", "rstudioapi")
insertText <- import_fn("insertText", "rstudioapi")
modifyRange <- import_fn("insertText", "rstudioapi")
document_range <- import_fn("document_range", "rstudioapi")
document_position <- import_fn("document_position", "rstudioapi")
# setSelectionRanges <- import_fn("setSelectionRanges", "rstudioapi")
context <- getSourceEditorContext()
current_row <- context$selection[[1]]$range$end[1]
current_col <- context$selection[[1]]$range$end[2]
current_row_txt <- context$contents[current_row]
pos_preceded_by <- function(txt) {
substr(current_row_txt, current_col - nchar(txt), current_col) == txt
}
replace_pos <- function(old, with) {
modifyRange(document_range(document_position(current_row, current_col - nchar(old)),
document_position(current_row, current_col)),
text = with,
id = context$id)
}
if (pos_preceded_by(" %like% ")) {
replace_pos(" %like% ", with = " %not_like% ")
} else if (pos_preceded_by(" %not_like% ")) {
replace_pos(" %not_like% ", with = " %like_case% ")
} else if (pos_preceded_by(" %like_case% ")) {
replace_pos(" %like_case% ", with = " %not_like_case% ")
} else if (pos_preceded_by(" %not_like_case% ")) {
replace_pos(" %not_like_case% ", with = " %like% ")
} else {
insertText(" %like% ")
}
}
check_dataset_integrity <- function() {
@ -88,13 +123,13 @@ check_dataset_integrity <- function() { @@ -88,13 +123,13 @@ check_dataset_integrity <- function() {
# check if other packages did not overwrite our data sets
tryCatch({
check_microorganisms <- all(c("mo", "fullname", "kingdom", "phylum",
"class", "order", "family", "genus",
"class", "order", "family", "genus",
"species", "subspecies", "rank",
"species_id", "source", "ref", "prevalence") %in% colnames(microorganisms),
na.rm = TRUE)
check_antibiotics <- all(c("ab", "atc", "cid", "name", "group",
check_antibiotics <- all(c("ab", "atc", "cid", "name", "group",
"atc_group1", "atc_group2", "abbreviations",
"synonyms", "oral_ddd", "oral_units",
"synonyms", "oral_ddd", "oral_units",
"iv_ddd", "iv_units", "loinc") %in% colnames(antibiotics),
na.rm = TRUE)
}, error = function(e) {
@ -107,10 +142,10 @@ check_dataset_integrity <- function() { @@ -107,10 +142,10 @@ check_dataset_integrity <- function() {
search_type_in_df <- function(x, type, info = TRUE) {
# try to find columns based on type
found <- NULL
x <- as.data.frame(x, stringsAsFactors = FALSE)
colnames(x) <- trimws(colnames(x))
# -- mo
if (type == "mo") {
if (any(sapply(x, is.mo))) {
@ -128,7 +163,7 @@ search_type_in_df <- function(x, type, info = TRUE) { @@ -128,7 +163,7 @@ search_type_in_df <- function(x, type, info = TRUE) {
} else if (any(colnames(x) %like% "species")) {
found <- sort(colnames(x)[colnames(x) %like% "species"])[1]
}
}
# -- key antibiotics
if (type == "keyantibiotics") {
@ -180,7 +215,7 @@ search_type_in_df <- function(x, type, info = TRUE) { @@ -180,7 +215,7 @@ search_type_in_df <- function(x, type, info = TRUE) {
}
}
}
if (!is.null(found) & info == TRUE) {
msg <- paste0("NOTE: Using column `", font_bold(found), "` as input for `col_", type, "`.")
if (type %in% c("keyantibiotics", "specimen")) {
@ -222,8 +257,8 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) { @@ -222,8 +257,8 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) {
get(name, envir = asNamespace(pkg)),
error = function(e) {
if (isTRUE(error_on_fail)) {
stop_("function ", name, "() not found in package '", pkg,
"'. Please create an issue at https://github.com/msberends/AMR/issues. Many thanks!",
stop_("function ", name, "() not found in package '", pkg,
"'. Please create an issue at https://github.com/msberends/AMR/issues. Many thanks!",
call = FALSE)
} else {
return(NULL)
@ -231,6 +266,52 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) { @@ -231,6 +266,52 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) {
})
}
# this alternative to the message() function:
# - wraps text to never break lines within words
# - ignores formatted text while wrapping
# - adds indentation dependent on the type of message (like NOTE)
# - add additional formatting functions like blue or bold text
message_ <- function(..., appendLF = TRUE, add_fn = list(font_blue)) {
msg <- paste0(c(...), collapse = "")
# we need to correct for already applied style, that adds text like "\033[31m\"
msg_stripped <- font_stripstyle(msg)
# where are the spaces now?
msg_stripped_wrapped <- paste0(strwrap(msg_stripped,
simplify = TRUE,
width = 0.95 * getOption("width")),
collapse = "\n")
msg_stripped_spaces <- which(unlist(strsplit(msg_stripped, "")) == " ")
msg_stripped_wrapped_spaces <- which(unlist(strsplit(msg_stripped_wrapped, "")) == " ")
# so these are the indices of spaces that need to be replaced
replace_spaces <- which(!msg_stripped_spaces %in% msg_stripped_wrapped_spaces)
# put it together
msg <- unlist(strsplit(msg, " "))
msg[replace_spaces] <- paste0(msg[replace_spaces], "\n")
msg <- paste0(msg, collapse = " ")
msg <- gsub("\n ", "\n", msg, fixed = TRUE)
if (msg_stripped %like% "^NOTE: ") {
indentation <- 6
} else {
indentation <- 0
}
msg <- gsub("\n", paste0("\n", strrep(" ", indentation)), msg, fixed = TRUE)
if (length(add_fn) > 0) {
if (!is.list(add_fn)) {
add_fn <- list(add_fn)
}
for (i in seq_len(length(add_fn))) {
msg <- add_fn[[i]](msg)
}
}
message(msg, appendLF = appendLF)
}
# this alternative to the stop() function:
# - adds the function name where the error was thrown
# - wraps text to never break lines within words
stop_ <- function(..., call = TRUE) {
msg <- paste0(c(...), collapse = "")
if (!isFALSE(call)) {
@ -340,10 +421,10 @@ meet_criteria <- function(object, @@ -340,10 +421,10 @@ meet_criteria <- function(object,
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())
@ -352,7 +433,7 @@ meet_criteria <- function(object, @@ -352,7 +433,7 @@ meet_criteria <- function(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, '"', "")))
@ -361,32 +442,32 @@ meet_criteria <- function(object, @@ -361,32 +442,32 @@ meet_criteria <- function(object,
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),
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),
stop_if(any(dim(object) == 0),
"the data provided in argument `", obj_name,
"` must contain rows and columns (current dimensions: ",
"` 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 ", ""),
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 ", ""),
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)
}
@ -395,16 +476,16 @@ meet_criteria <- function(object, @@ -395,16 +476,16 @@ meet_criteria <- function(object,
object <- tolower(object)
is_in <- tolower(is_in)
}
stop_ifnot(all(object %in% is_in, na.rm = TRUE), "argument `", obj_name,
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),
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,
"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)
@ -463,7 +544,7 @@ has_colour <- function() { @@ -463,7 +544,7 @@ has_colour <- function() {
if (Sys.getenv("TERM") == "dumb") {
return(FALSE)
}
grepl(pattern = "^screen|^xterm|^vt100|color|ansi|cygwin|linux",
grepl(pattern = "^screen|^xterm|^vt100|color|ansi|cygwin|linux",
x = Sys.getenv("TERM"),
ignore.case = TRUE,
perl = TRUE)
@ -560,7 +641,7 @@ progress_ticker <- function(n = 1, n_min = 0, ...) { @@ -560,7 +641,7 @@ progress_ticker <- function(n = 1, n_min = 0, ...) {
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)) {
new_pillar_shaft_simple(x, ...)
new_pillar_shaft_simple(x, ...)
} else {
# does not exist in package 'pillar' anymore
structure(list(x),
@ -622,12 +703,12 @@ round2 <- function(x, digits = 0, force_zero = TRUE) { @@ -622,12 +703,12 @@ round2 <- function(x, digits = 0, force_zero = TRUE) {
if (digits > 0 & force_zero == TRUE) {
values_trans <- val[val != as.integer(val) & !is.na(val)]
val[val != as.integer(val) & !is.na(val)] <- paste0(values_trans,
strrep("0",
max(0,
strrep("0",
max(0,
digits - nchar(
format(
as.double(
gsub(".*[.](.*)$",
gsub(".*[.](.*)$",
"\\1",
values_trans)),
scientific = FALSE)))))
@ -638,7 +719,7 @@ round2 <- function(x, digits = 0, force_zero = TRUE) { @@ -638,7 +719,7 @@ round2 <- function(x, digits = 0, force_zero = TRUE) {
# percentage from our other package: 'cleaner'
percentage <- function(x, digits = NULL, ...) {
# getdecimalplaces() function
getdecimalplaces <- function(x, minimum = 0, maximum = 3) {
if (maximum < minimum) {
@ -647,20 +728,20 @@ percentage <- function(x, digits = NULL, ...) { @@ -647,20 +728,20 @@ percentage <- function(x, digits = NULL, ...) {
if (minimum > maximum) {
minimum <- maximum
}
max_places <- max(unlist(lapply(strsplit(sub("0+$", "",
max_places <- max(unlist(lapply(strsplit(sub("0+$", "",
as.character(x * 100)), ".", fixed = TRUE),
function(y) ifelse(length(y) == 2, nchar(y[2]), 0))), na.rm = TRUE)
max(min(max_places,
maximum, na.rm = TRUE),
minimum, na.rm = TRUE)
}
# format_percentage() function
format_percentage <- function(x, digits = NULL, ...) {
if (is.null(digits)) {
digits <- getdecimalplaces(x)
}
# round right: percentage(0.4455) and format(as.percentage(0.4455), 1) should return "44.6%", not "44.5%"
x_formatted <- format(round2(as.double(x), digits = digits + 2) * 100,
scientific = FALSE,
@ -671,7 +752,7 @@ percentage <- function(x, digits = NULL, ...) { @@ -671,7 +752,7 @@ percentage <- function(x, digits = NULL, ...) {
x_formatted[!grepl(pattern = "^[0-9.,e-]+$", x = x)] <- NA_character_
x_formatted
}
# the actual working part
x <- as.double(x)
if (is.null(digits)) {
@ -688,12 +769,12 @@ percentage <- function(x, digits = NULL, ...) { @@ -688,12 +769,12 @@ percentage <- function(x, digits = NULL, ...) {
# see here for the full list: https://github.com/r-lib/backports
strrep <- function(x, times) {
x <- as.character(x)
if (length(x) == 0L)
if (length(x) == 0L)
return(x)
unlist(.mapply(function(x, times) {
if (is.na(x) || is.na(times))
if (is.na(x) || is.na(times))
return(NA_character_)
if (times <= 0L)
if (times <= 0L)
return("")
paste0(replicate(times, x), collapse = "")
}, list(x = x, times = times), MoreArgs = list()), use.names = FALSE)
@ -701,9 +782,9 @@ strrep <- function(x, times) { @@ -701,9 +782,9 @@ strrep <- function(x, times) {
trimws <- function(x, which = c("both", "left", "right")) {
which <- match.arg(which)
mysub <- function(re, x) sub(re, "", x, perl = TRUE)
if (which == "left")
if (which == "left")
return(mysub("^[ \t\r\n]+", x))
if (which == "right")
if (which == "right")
return(mysub("[ \t\r\n]+$", x))
mysub("[ \t\r\n]+$", mysub("^[ \t\r\n]+", x))
}

13
R/like.R

@ -23,7 +23,7 @@ @@ -23,7 +23,7 @@
# how to conduct AMR analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
#' Pattern Matching
#' Pattern matching with keyboard shortcut
#'
#' Convenient wrapper around [grep()] to match a pattern: `x %like% pattern`. It always returns a [`logical`] vector and is always case-insensitive (use `x %like_case% pattern` for case-sensitive matching). Also, `pattern` can be as long as `x` to compare items of each index in both vectors, or they both can have the same length to iterate over all cases.
#' @inheritSection lifecycle Stable lifecycle
@ -41,9 +41,9 @@ @@ -41,9 +41,9 @@
#' * Checks if `pattern` is a regular expression and sets `fixed = TRUE` if not, to greatly improve speed
#' * Tries again with `perl = TRUE` if regex fails
#'
#' Using RStudio? This function can also be inserted from the Addins menu and can have its own Keyboard Shortcut like `Ctrl+Shift+L` or `Cmd+Shift+L` (see `Tools` > `Modify Keyboard Shortcuts...`).
#' Using RStudio? This function can also be inserted in your code from the Addins menu and can have its own Keyboard Shortcut like `Ctrl+Shift+L` or `Cmd+Shift+L` (see `Tools` > `Modify Keyboard Shortcuts...`). This addin iterates over all 'like' variants. So if you have defined the keyboard shortcut Ctrl/Cmd + L to this addin, it will first insert ` %like% ` and by pressing it again it will be replaced with ` %not_like% `, then ` %like_case% `, then ` %not_like_case% ` and then back to ` %like% `.
#'
#' The `"%not_like%"` and `"%like_perl%"` functions are wrappers around `"%like%"`.
#' The `"%not_like%"` and `"%not_like_case%"` functions are wrappers around `"%like%"` and `"%like_case%"`.
#' @source Idea from the [`like` function from the `data.table` package](https://github.com/Rdatatable/data.table/blob/master/R/like.R)
#' @seealso [grep()]
#' @inheritSection AMR Read more on our website!
@ -168,8 +168,15 @@ like <- function(x, pattern, ignore.case = TRUE) { @@ -168,8 +168,15 @@ like <- function(x, pattern, ignore.case = TRUE) {
like(x, pattern, ignore.case = FALSE)
}
#' @rdname like
#' @export
"%not_like_case%" <- function(x, pattern) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(pattern, allow_NA = FALSE)
!like(x, pattern, ignore.case = FALSE)
}
"%like_perl%" <- function(x, pattern) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(pattern, allow_NA = FALSE)

349
R/mo.R

File diff suppressed because it is too large Load Diff

118
R/mo_property.R

@ -9,7 +9,7 @@ @@ -9,7 +9,7 @@
# (c) 2018-2020 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@ -29,7 +29,7 @@ @@ -29,7 +29,7 @@
#' @inheritSection lifecycle Stable lifecycle
#' @param x any character (vector) that can be coerced to a valid microorganism code with [as.mo()]
#' @param property one of the column names of the [microorganisms] data set or `"shortname"`
#' @param language language of the returned text, defaults to system language (see [get_locale()]) and can be overwritten by setting the option `AMR_locale`, e.g. `options(AMR_locale = "de")`, see [translate]. Use `language = NULL` or `language = ""` to prevent translation.
#' @param language language of the returned text, defaults to system language (see [get_locale()]) and can be overwritten by setting the option `AMR_locale`, e.g. `options(AMR_locale = "de")`, see [translate]. Also used to translate text like "no growth". Use `language = NULL` or `language = ""` to prevent translation.
#' @param ... other parameters passed on to [as.mo()], such as 'allow_uncertain' and 'ignore_pattern'
#' @param open browse the URL using [utils::browseURL()]
#' @details All functions will return the most recently known taxonomic property according to the Catalogue of Life, except for [mo_ref()], [mo_authors()] and [mo_year()]. Please refer to this example, knowing that *Escherichia blattae* was renamed to *Shimwellia blattae* in 2010:
@ -38,7 +38,7 @@ @@ -38,7 +38,7 @@
#' - `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"`.
#'
#'
#' 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.
#'
#' The Gram stain - [mo_gramstain()] - will be determined based on the taxonomic kingdom and phylum. According to Cavalier-Smith (2002, [PMID 11837318](https://pubmed.ncbi.nlm.nih.gov/11837318)), who defined subkingdoms Negibacteria and Posibacteria, only these phyla are Posibacteria: Actinobacteria, Chloroflexi, Firmicutes and Tenericutes. These bacteria are considered Gram-positive - all other bacteria are considered Gram-negative. Species outside the kingdom of Bacteria will return a value `NA`. Functions [is_gram_negative()] and [is_gram_positive()] always return `TRUE` or `FALSE`, even for species outside the kingdom of Bacteria.
@ -148,7 +148,7 @@ @@ -148,7 +148,7 @@
mo_name <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
translate_AMR(mo_validate(x = x, property = "fullname", language = language, ...), language = language, only_unknown = FALSE)
}
@ -161,20 +161,20 @@ mo_fullname <- mo_name @@ -161,20 +161,20 @@ mo_fullname <- mo_name
mo_shortname <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
x.mo <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
replace_empty <- function(x) {
x[x == ""] <- "spp."
x
}
# get first char of genus and complete species in English
genera <- mo_genus(x.mo, language = NULL)
shortnames <- paste0(substr(genera, 1, 1), ". ", replace_empty(mo_species(x.mo, language = NULL)))
# exceptions for where no species is known
shortnames[shortnames %like% ".[.] spp[.]"] <- genera[shortnames %like% ".[.] spp[.]"]
# exceptions for Staphylococci
@ -184,7 +184,7 @@ mo_shortname <- function(x, language = get_locale(), ...) { @@ -184,7 +184,7 @@ mo_shortname <- function(x, language = get_locale(), ...) {
shortnames[shortnames %like% "S. group [ABCDFGHK]"] <- paste0("G", gsub("S. group ([ABCDFGHK])", "\\1", shortnames[shortnames %like% "S. group [ABCDFGHK]"]), "S")
# unknown species etc.
shortnames[shortnames %like% "unknown"] <- paste0("(", trimws(gsub("[^a-zA-Z -]", "", shortnames[shortnames %like% "unknown"])), ")")
load_mo_failures_uncertainties_renamed(metadata)
translate_AMR(shortnames, language = language, only_unknown = FALSE)
}
@ -194,7 +194,7 @@ mo_shortname <- function(x, language = get_locale(), ...) { @@ -194,7 +194,7 @@ mo_shortname <- function(x, language = get_locale(), ...) {
mo_subspecies <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
translate_AMR(mo_validate(x = x, property = "subspecies", language = language, ...), language = language, only_unknown = TRUE)
}
@ -203,7 +203,7 @@ mo_subspecies <- function(x, language = get_locale(), ...) { @@ -203,7 +203,7 @@ mo_subspecies <- function(x, language = get_locale(), ...) {
mo_species <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
translate_AMR(mo_validate(x = x, property = "species", language = language, ...), language = language, only_unknown = TRUE)
}
@ -212,7 +212,7 @@ mo_species <- function(x, language = get_locale(), ...) { @@ -212,7 +212,7 @@ mo_species <- function(x, language = get_locale(), ...) {
mo_genus <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
translate_AMR(mo_validate(x = x, property = "genus", language = language, ...), language = language, only_unknown = TRUE)
}
@ -221,7 +221,7 @@ mo_genus <- function(x, language = get_locale(), ...) { @@ -221,7 +221,7 @@ mo_genus <- function(x, language = get_locale(), ...) {
mo_family <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
translate_AMR(mo_validate(x = x, property = "family", language = language, ...), language = language, only_unknown = TRUE)
}
@ -230,7 +230,7 @@ mo_family <- function(x, language = get_locale(), ...) { @@ -230,7 +230,7 @@ mo_family <- function(x, language = get_locale(), ...) {
mo_order <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
translate_AMR(mo_validate(x = x, property = "order", language = language, ...), language = language, only_unknown = TRUE)
}
@ -239,7 +239,7 @@ mo_order <- function(x, language = get_locale(), ...) { @@ -239,7 +239,7 @@ mo_order <- function(x, language = get_locale(), ...) {
mo_class <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
translate_AMR(mo_validate(x = x, property = "class", language = language, ...), language = language, only_unknown = TRUE)
}
@ -248,7 +248,7 @@ mo_class <- function(x, language = get_locale(), ...) { @@ -248,7 +248,7 @@ mo_class <- function(x, language = get_locale(), ...) {
mo_phylum <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
translate_AMR(mo_validate(x = x, property = "phylum", language = language, ...), language = language, only_unknown = TRUE)
}
@ -257,7 +257,7 @@ mo_phylum <- function(x, language = get_locale(), ...) { @@ -257,7 +257,7 @@ mo_phylum <- function(x, language = get_locale(), ...) {
mo_kingdom <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
translate_AMR(mo_validate(x = x, property = "kingdom", language = language, ...), language = language, only_unknown = TRUE)
}
@ -270,7 +270,7 @@ mo_domain <- mo_kingdom @@ -270,7 +270,7 @@ mo_domain <- mo_kingdom
mo_type <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
translate_AMR(mo_validate(x = x, property = "kingdom", language = language, ...), language = language, only_unknown = FALSE)
}
@ -279,10 +279,10 @@ mo_type <- function(x, language = get_locale(), ...) { @@ -279,10 +279,10 @@ mo_type <- function(x, language = get_locale(), ...) {
mo_gramstain <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
x.mo <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
x.phylum <- mo_phylum(x.mo)
# DETERMINE GRAM STAIN FOR BACTERIA
# Source: https://itis.gov/servlet/SingleRpt/SingleRpt?search_topic=TSN&search_value=956097
@ -303,25 +303,35 @@ mo_gramstain <- function(x, language = get_locale(), ...) { @@ -303,25 +303,35 @@ mo_gramstain <- function(x, language = get_locale(), ...) {
"Firmicutes",
"Tenericutes")
| x.mo == "B_GRAMP"] <- "Gram-positive"
load_mo_failures_uncertainties_renamed(metadata)
translate_AMR(x, language = language, only_unknown = FALSE)
}
#' @rdname mo_property
#' @export
is_gram_negative <- function(x, ...) {
is_gram_negative <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
grams <- mo_gramstain(x, language = NULL, ...)
"Gram-negative" == grams & !is.na(grams)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
x.mo <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
grams <- mo_gramstain(x.mo, language = NULL)
load_mo_failures_uncertainties_renamed(metadata)
grams == "Gram-negative" & !is.na(grams)
}
#' @rdname mo_property
#' @export
is_gram_positive <- function(x, ...) {
is_gram_positive <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
grams <- mo_gramstain(x, language = NULL, ...)
"Gram-positive" == grams & !is.na(grams)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
x.mo <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
grams <- mo_gramstain(x.mo, language = NULL)
load_mo_failures_uncertainties_renamed(metadata)
grams == "Gram-positive" & !is.na(grams)
}
#' @rdname mo_property
@ -329,7 +339,7 @@ is_gram_positive <- function(x, ...) { @@ -329,7 +339,7 @@ is_gram_positive <- function(x, ...) {
mo_snomed <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
mo_validate(x = x, property = "snomed", language = language, ...)
}
@ -338,7 +348,7 @@ mo_snomed <- function(x, language = get_locale(), ...) { @@ -338,7 +348,7 @@ mo_snomed <- function(x, language = get_locale(), ...) {
mo_ref <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
mo_validate(x = x, property = "ref", language = language, ...)
}
@ -347,7 +357,7 @@ mo_ref <- function(x, language = get_locale(), ...) { @@ -347,7 +357,7 @@ mo_ref <- function(x, language = get_locale(), ...) {
mo_authors <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
x <- mo_validate(x = x, property = "ref", language = language, ...)
# remove last 4 digits and presumably the comma and space that preceed them
x[!is.na(x)] <- gsub(",? ?[0-9]{4}", "", x[!is.na(x)])
@ -359,7 +369,7 @@ mo_authors <- function(x, language = get_locale(), ...) { @@ -359,7 +369,7 @@ mo_authors <- function(x, language = get_locale(), ...) {
mo_year <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
x <- mo_validate(x = x, property = "ref", language = language, ...)
# get last 4 digits
x[!is.na(x)] <- gsub(".*([0-9]{4})$", "\\1", x[!is.na(x)])
@ -371,7 +381,7 @@ mo_year <- function(x, language = get_locale(), ...) { @@ -371,7 +381,7 @@ mo_year <- function(x, language = get_locale(), ...) {
mo_rank <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
mo_validate(x = x, property = "rank", language = language, ...)
}
@ -380,10 +390,10 @@ mo_rank <- function(x, language = get_locale(), ...) { @@ -380,10 +390,10 @@ mo_rank <- function(x, language = get_locale(), ...) {
mo_taxonomy <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
x <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
result <- list(kingdom = mo_kingdom(x, language = language),
phylum = mo_phylum(x, language = language),
class = mo_class(x, language = language),
@ -392,7 +402,7 @@ mo_taxonomy <- function(x, language = get_locale(), ...) { @@ -392,7 +402,7 @@ mo_taxonomy <- function(x, language = get_locale(), ...) {
genus = mo_genus(x, language = language),
species = mo_species(x, language = language),
subspecies = mo_subspecies(x, language = language))
load_mo_failures_uncertainties_renamed(metadata)
result
}
@ -402,10 +412,10 @@ mo_taxonomy <- function(x, language = get_locale(), ...) { @@ -402,10 +412,10 @@ mo_taxonomy <- function(x, language = get_locale(), ...) {
mo_synonyms <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
x <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
IDs <- mo_name(x = x, language = NULL)
syns <- lapply(IDs, function(newname) {
res <- sort(microorganisms.old[which(microorganisms.old$fullname_new == newname), "fullname"])
@ -421,7 +431,7 @@ mo_synonyms <- function(x, language = get_locale(), ...) { @@ -421,7 +431,7 @@ mo_synonyms <- function(x, language = get_locale(), ...) {
} else {
result <- unlist(syns)
}
load_mo_failures_uncertainties_renamed(metadata)
result
}
@ -431,10 +441,10 @@ mo_synonyms <- function(x, language = get_locale(), ...) { @@ -431,10 +441,10 @@ mo_synonyms <- function(x, language = get_locale(), ...) {
mo_info <- function(x, language = get_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
x <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
info <- lapply(x, function(y)
c(mo_taxonomy(y, language = language),
list(synonyms = mo_synonyms(y),
@ -447,7 +457,7 @@ mo_info <- function(x, language = get_locale(), ...) { @@ -447,7 +457,7 @@ mo_info <- function(x, language = get_locale(), ...) {
} else {
result <- info[[1L]]
}
load_mo_failures_uncertainties_renamed(metadata)
result
}
@ -458,11 +468,11 @@ mo_url <- function(x, open = FALSE, language = get_locale(), ...) { @@ -458,11 +468,11 @@ mo_url <- function(x, open = FALSE, language = get_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(open, allow_class = "logical", has_length = 1)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
mo <- as.mo(x = x, language = language, ... = ...)
mo_names <- mo_name(mo)
metadata <- get_mo_failures_uncertainties_renamed()
df <- data.frame(mo, stringsAsFactors = FALSE) %pm>%
pm_left_join(pm_select(microorganisms, mo, source, species_id), by = "mo")
df$url <- ifelse(df$source == "CoL",
@ -472,14 +482,14 @@ mo_url <- function(x, open = FALSE, language = get_locale(), ...) { @@ -472,14 +482,14 @@ mo_url <- function(x, open = FALSE, language = get_locale(), ...) {
NA_character_))
u <- df$url
names(u) <- mo_names
if (open == TRUE) {
if (length(u) > 1) {
warning("only the first URL will be opened, as `browseURL()` only suports one string.")
}
utils::browseURL(u[1L])
}
load_mo_failures_uncertainties_renamed(metadata)
u
}
@ -491,18 +501,18 @@ mo_property <- function(x, property = "fullname", language = get_locale(), ...) @@ -491,18 +501,18 @@ mo_property <- function(x, property = "fullname", language = get_locale(), ...)
meet_criteria(x, allow_NA = TRUE)
meet_criteria(property, allow_class = "character", has_length = 1, is_in = colnames(microorganisms))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
translate_AMR(mo_validate(x = x, property = property, language = language, ...), language = language, only_unknown = TRUE)
}
mo_validate <- function(x, property, language, ...) {
check_dataset_integrity()
if (tryCatch(all(x[!is.na(x)] %in% MO_lookup$mo) & length(list(...)) == 0, error = function(e) FALSE)) {
# special case for mo_* functions where class is already <mo>
return(MO_lookup[match(x, MO_lookup$mo), property, drop = TRUE])
}
dots <- list(...)
Becker <- dots$Becker
if (is.null(Becker)) {
@ -512,14 +522,14 @@ mo_validate <- function(x, property, language, ...) { @@ -512,14 +522,14 @@ mo_validate <- function(x, property, language, ...) {
if (is.null(Lancefield)) {
Lancefield <- FALSE
}
# try to catch an error when inputting an invalid parameter
# so the 'call.' can be set to FALSE
tryCatch(x[1L] %in% MO_lookup[1, property, drop = TRUE],
error = function(e) stop(e$message, call. = FALSE))
if (is.mo(x)
& !Becker %in% c(TRUE, "all")
if (is.mo(x)
& !Becker %in% c(TRUE, "all")
& !Lancefield %in% c(TRUE, "all")) {
# this will not reset mo_uncertainties and mo_failures
# because it's already a valid MO
@ -529,7 +539,7 @@ mo_validate <- function(x, property, language, ...) { @@ -529,7 +539,7 @@ mo_validate <- function(x, property, language, ...) {
| Lancefield %in% c(TRUE, "all")) {
x <- exec_as.mo(x, property = property, language = language, ...)
}
if (property == "mo") {
return(to_class_mo(x))
} else if (property == "snomed") {

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.9007</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9008</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.9007</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9008</span>
</span>
</div>

54
docs/articles/PCA.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</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9008</span>
</span>
</div>
@ -187,7 +187,8 @@ @@ -187,7 +187,8 @@
</header><script src="PCA_files/header-attrs-2.3/header-attrs.js"></script><script src="PCA_files/accessible-code-block-0.0.1/empty-anchor.js"></script><div class="row">
</header><script src="PCA_files/accessible-code-block-0.0.1/empty-anchor.js"></script><link href="PCA_files/anchor-sections-1.0/anchor-sections.css" rel="stylesheet">
<script src="PCA_files/anchor-sections-1.0/anchor-sections.js"></script><div class="row">
<div class="col-md-9 contents">
<div class="page-header toc-ignore">
<h1 data-toc-skip>How to conduct principal component analysis (PCA) for AMR</h1>
@ -210,9 +211,9 @@ @@ -210,9 +211,9 @@
<a href="#transforming" class="anchor"></a>Transforming</h1>
<p>For PCA, we need to transform our AMR data first. This is what the <code>example_isolates</code> data set in this package looks like:</p>
<div class="sourceCode" id="cb1"><pre class="downlit">
<span class="fu"><a href="https://rdrr.io/r/base/library.html">library</a></span>(<span class="kw"><a href="https://msberends.github.io/AMR">AMR</a></span>)
<span class="fu"><a href="https://rdrr.io/r/base/library.html">library</a></span>(<span class="kw"><a href="https://dplyr.tidyverse.org">dplyr</a></span>)
<span class="fu"><a href="https://tibble.tidyverse.org/reference/glimpse.html">glimpse</a></span>(<span class="kw">example_isolates</span>)
<span class="kw"><a href="https://rdrr.io/r/base/library.html">library</a></span><span class="op">(</span><span class="va"><a href="https://msberends.github.io/AMR/">AMR</a></span><span class="op">)</span>
<span class="kw"><a href="https://rdrr.io/r/base/library.html">library</a></span><span class="op">(</span><span class="va"><a href="https://dplyr.tidyverse.org">dplyr</a></span><span class="op">)</span>
<span class="fu"><a href="https://tibble.tidyverse.org/reference/glimpse.html">glimpse</a></span><span class="op">(</span><span class="va">example_isolates</span><span class="op">)</span>
<span class="co"># Rows: 2,000</span>
<span class="co"># Columns: 49</span>
<span class="co"># $ date &lt;date&gt; 2002-01-02, 2002-01-03, 2002-01-07, 2002-01-07, 2002…</span>
@ -263,18 +264,17 @@ @@ -263,18 +264,17 @@
<span class="co"># $ CHL &lt;rsi&gt; NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, N…</span>
<span class="co"># $ COL &lt;rsi&gt; NA, NA, R, R, R, R, R, R, R, R, R, R, NA, NA, NA, R, …</span>
<span class="co"># $ MUP &lt;rsi&gt; NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, N…</span>
<span class="co"># $ RIF &lt;rsi&gt; R, R, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, R, R, R…</span>
</pre></div>
<span class="co"># $ RIF &lt;rsi&gt; R, R, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, R, R, R…</span></pre></div>
<p>Now to transform this to a data set with only resistance percentages per taxonomic order and genus:</p>
<div class="sourceCode" id="cb2"><pre class="downlit">
<span class="kw">resistance_data</span> <span class="op">&lt;-</span> <span class="kw">example_isolates</span> <span class="op">%&gt;%</span>
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/group_by.html">group_by</a></span>(order = <span class="fu"><a href="../reference/mo_property.html">mo_order</a></span>(<span class="kw">mo</span>), <span class="co"># group on anything, like order</span>
genus = <span class="fu"><a href="../reference/mo_property.html">mo_genus</a></span>(<span class="kw">mo</span>)) <span class="op">%&gt;%</span> <span class="co"># and genus as we do here</span>
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/summarise_all.html">summarise_if</a></span>(<span class="kw">is.rsi</span>, <span class="kw">resistance</span>) <span class="op">%&gt;%</span> <span class="co"># then get resistance of all drugs</span>
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/select.html">select</a></span>(<span class="kw">order</span>, <span class="kw">genus</span>, <span class="kw">AMC</span>, <span class="kw">CXM</span>, <span class="kw">CTX</span>,
<span class="kw">CAZ</span>, <span class="kw">GEN</span>, <span class="kw">TOB</span>, <span class="kw">TMP</span>, <span class="kw">SXT</span>) <span class="co"># and select only relevant columns</span>
<span class="va">resistance_data</span> <span class="op">&lt;-</span> <span class="va">example_isolates</span> <span class="op">%&gt;%</span>
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/group_by.html">group_by</a></span><span class="op">(</span>order <span class="op">=</span> <span class="fu"><a href="../reference/mo_property.html">mo_order</a></span><span class="op">(</span><span class="va">mo</span><span class="op">)</span>, <span class="co"># group on anything, like order</span>
genus <span class="op">=</span> <span class="fu"><a href="../reference/mo_property.html">mo_genus</a></span><span class="op">(</span><span class="va">mo</span><span class="op">)</span><span class="op">)</span> <span class="op">%&gt;%</span> <span class="co"># and genus as we do here</span>
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/summarise_all.html">summarise_if</a></span><span class="op">(</span><span class="va">is.rsi</span>, <span class="va">resistance</span><span class="op">)</span> <span class="op">%&gt;%</span> <span class="co"># then get resistance of all drugs</span>
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/select.html">select</a></span><span class="op">(</span><span class="va">order</span>, <span class="va">genus</span>, <span class="va">AMC</span>, <span class="va">CXM</span>, <span class="va">CTX</span>,
<span class="va">CAZ</span>, <span class="va">GEN</span>, <span class="va">TOB</span>, <span class="va">TMP</span>, <span class="va">SXT</span><span class="op">)</span> <span class="co"># and select only relevant columns</span>
<span class="fu"><a href="https://rdrr.io/r/utils/head.html">head</a></span>(<span class="kw">resistance_data</span>)
<span class="fu"><a href="https://rdrr.io/r/utils/head.html">head</a></span><span class="op">(</span><span class="va">resistance_data</span><span class="op">)</span>
<span class="co"># # A tibble: 6 x 10</span>
<span class="co"># # Groups: order [2]</span>
<span class="co"># order genus AMC CXM CTX CAZ GEN TOB TMP SXT</span>
@ -284,46 +284,40 @@ @@ -284,46 +284,40 @@
<span class="co"># 3 Actinomycetales Cutibacterium NA NA NA NA NA NA NA NA</span>
<span class="co"># 4 Actinomycetales Dermabacter NA NA NA NA NA NA NA NA</span>
<span class="co"># 5 Actinomycetales Micrococcus NA NA NA NA NA NA NA NA</span>
<span class="co"># 6 Actinomycetales Rothia NA NA NA NA NA NA NA NA</span>
</pre></div>
<span class="co"># 6 Actinomycetales Rothia NA NA NA NA NA NA NA NA</span></pre></div>
</div>
<div id="perform-principal-component-analysis" class="section level1">
<h1 class="hasAnchor">
<a href="#perform-principal-component-analysis" class="anchor"></a>Perform principal component analysis</h1>
<p>The new <code><a href="../reference/pca.html">pca()</a></code> function will automatically filter on rows that contain numeric values in all selected variables, so we now only need to do:</p>
<div class="sourceCode" id="cb3"><pre class="downlit">
<span class="kw">pca_result</span> <span class="op">&lt;-</span> <span class="fu"><a href="../reference/pca.html">pca</a></span>(<span class="kw">resistance_data</span>)
<span class="va">pca_result</span> <span class="op">&lt;-</span> <span class="fu"><a href="../reference/pca.html">pca</a></span><span class="op">(</span><span class="va">resistance_data</span><span class="op">)</span>
<span class="co"># NOTE: Columns selected for PCA: AMC CXM CTX CAZ GEN TOB TMP SXT.</span>
<span class="co"># Total observations available: 7.</span>
</pre></div>
<span class="co"># Total observations available: 7.</span></pre></div>
<p>The result can be reviewed with the good old <code><a href="https://rdrr.io/r/base/summary.html">summary()</a></code> function:</p>
<div class="sourceCode" id="cb4"><pre class="downlit">
<span class="fu"><a href="https://rdrr.io/r/base/summary.html">summary</a></span>(<span class="kw">pca_result</span>)
<span class="fu"><a href="https://rdrr.io/r/base/summary.html">summary</a></span><span class="op">(</span><span class="va">pca_result</span><span class="op">)</span>
<span class="co"># Importance of components:</span>
<span class="co"># PC1 PC2 PC3 PC4 PC5 PC6 PC7</span>
<span class="co"># Standard deviation 2.154 1.6807 0.61365 0.33902 0.20757 0.03136 1.733e-16</span>
<span class="co"># Proportion of Variance 0.580 0.3531 0.04707 0.01437 0.00539 0.00012 0.000e+00</span>
<span class="co"># Cumulative Proportion 0.580 0.9331 0.98012 0.99449 0.99988 1.00000 1.000e+00</span>
</pre></div>
<span class="co"># Cumulative Proportion 0.580 0.9331 0.98012 0.99449 0.99988 1.00000 1.000e+00</span></pre></div>
<p>Good news. The first two components explain a total of 93.3% of the variance (see the PC1 and PC2 values of the <em>Proportion of Variance</em>. We can create a so-called biplot with the base R <code><a href="https://rdrr.io/r/stats/biplot.html">biplot()</a></code> function, to see which antimicrobial resistance per drug explain the difference per microorganism.</p>
</div>
<div id="plotting-the-results" class="section level1">
<h1 class="hasAnchor">
<a href="#plotting-the-results" class="anchor"></a>Plotting the results</h1>
<div class="sourceCode" id="cb5"><pre class="downlit">
<span class="fu"><a href="https://rdrr.io/r/stats/biplot.html">biplot</a></span>(<span class="kw">pca_result</span>)
</pre></div>
<span class="fu"><a href="https://rdrr.io/r/stats/biplot.html">biplot</a></span><span class="op">(</span><span class="va">pca_result</span><span class="op">)</span></pre></div>
<p><img src="PCA_files/figure-html/unnamed-chunk-5-1.png" width="750"></p>
<p>But we can’t see the explanation of the points. Perhaps this works better with our new <code><a href="../reference/ggplot_pca.html">ggplot_pca()</a></code> function, that automatically adds the right labels and even groups:</p>
<div class="sourceCode" id="cb6"><pre class="downlit">
<span class="fu"><a href="../reference/ggplot_pca.html">ggplot_pca</a></span>(<span class="kw">pca_result</span>)
</pre></div>
<span class="fu"><a href="../reference/ggplot_pca.html">ggplot_pca</a></span><span class="op">(</span><span class="va">pca_result</span><span class="op">)</span></pre></div>
<p><img src="PCA_files/figure-html/unnamed-chunk-6-1.png" width="750"></p>
<p>You can also print an ellipse per group, and edit the appearance:</p>
<div class="sourceCode" id="cb7"><pre class="downlit">
<span class="fu"><a href="../reference/ggplot_pca.html">ggplot_pca</a></span>(<span class="kw">pca_result</span>, ellipse = <span class="fl">TRUE</span>) <span class="op">+</span>
<span class="kw">ggplot2</span>::<span class="fu"><a href="https://ggplot2.tidyverse.org/reference/labs.html">labs</a></span>(title = <span class="st">"An AMR/PCA biplot!"</span>)
</pre></div>
<span class="fu"><a href="../reference/ggplot_pca.html">ggplot_pca</a></span><span class="op">(</span><span class="va">pca_result</span>, ellipse <span class="op">=</span> <span class="cn">TRUE</span><span class="op">)</span> <span class="op">+</span>
<span class="fu">ggplot2</span><span class="fu">::</span><span class="fu"><a href="https://ggplot2.tidyverse.org/reference/labs.html">labs</a></span><span class="op">(</span>title <span class="op">=</span> <span class="st">"An AMR/PCA biplot!"</span><span class="op">)</span></pre></div>
<p><img src="PCA_files/figure-html/unnamed-chunk-7-1.png" width="750"></p>
</div>
</div>
@ -343,7 +337,7 @@ @@ -343,7 +337,7 @@
</div>
<div class="pkgdown">
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.5.1.9000.</p>
<p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> 1.6.1.</p>
</div>
</footer>

4
docs/articles/PCA_files/anchor-sections-1.0/anchor-sections.css

@ -0,0 +1,4 @@ @@ -0,0 +1,4 @@
/* Styles for section anchors */
a.anchor-section {margin-left: 10px; visibility: hidden; color: inherit;}
a.anchor-section::before {content: '#';}
.hasAnchor:hover a.anchor-section {visibility: visible;}

33
docs/articles/PCA_files/anchor-sections-1.0/anchor-sections.js

@ -0,0 +1,33 @@ @@ -0,0 +1,33 @@
// Anchor sections v1.0 written by Atsushi Yasumoto on Oct 3rd, 2020.
document.addEventListener('DOMContentLoaded', function() {
// Do nothing if AnchorJS is used
if (typeof window.anchors === 'object' && anchors.hasOwnProperty('hasAnchorJSLink')) {
return;
}
const h = document.querySelectorAll('h1, h2, h3, h4, h5, h6');
// Do nothing if sections are already anchored
if (Array.from(h).some(x => x.classList.contains('hasAnchor'))) {
return null;
}
// Use section id when pandoc runs with --section-divs
const section_id = function(x) {
return ((x.classList.contains('section') || (x.tagName === 'SECTION'))
? x.id : '');
};
// Add anchors
h.forEach(function(x) {
const id = x.id || section_id(x.parentElement);
if (id === '') {
return null;
}
let anchor = document.createElement('a');
anchor.href = '#' + id;
anchor.classList = ['anchor-section'];
x.classList.add('hasAnchor');
x.appendChild(anchor);
});
});

BIN
docs/articles/PCA_files/figure-html/unnamed-chunk-5-1.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 86 KiB

After

Width:  |  Height:  |  Size: 47 KiB

BIN
docs/articles/PCA_files/figure-html/unnamed-chunk-6-1.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 143 KiB

After

Width:  |  Height:  |  Size: 90 KiB