P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-01-15 23:21:37 +01:00
Code Releases Activity

fixes

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends 2022-09-19 11:59:36 +02:00
parent 127d8d868d
commit 96a9fd0382
7 changed files with 314 additions and 157 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
DESCRIPTION
View File

@ -1,5 +1,5 @@
Package: AMR Package: AMR
Version: 1.8.1.9057 Version: 1.8.1.9058
Date: 2022-09-19 Date: 2022-09-19
Title: Antimicrobial Resistance Data Analysis Title: Antimicrobial Resistance Data Analysis
Description: Functions to simplify and standardise antimicrobial resistance (AMR) Description: Functions to simplify and standardise antimicrobial resistance (AMR)

1
NAMESPACE
View File

@ -270,6 +270,7 @@ export(mo_domain)
export(mo_failures) export(mo_failures)
export(mo_family) export(mo_family)
export(mo_fullname) export(mo_fullname)
export(mo_gbif)
export(mo_genus) export(mo_genus)
export(mo_gramstain) export(mo_gramstain)
export(mo_info) export(mo_info)

2
NEWS.md
View File

@ -1,4 +1,4 @@
# AMR 1.8.1.9057 # AMR 1.8.1.9058
This version will eventually become v2.0! We're happy to reach a new major milestone soon! This version will eventually become v2.0! We're happy to reach a new major milestone soon!

234
R/aa_helper_functions.R
View File

@ -37,12 +37,12 @@ pm_left_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
if (length(by) == 1) { if (length(by) == 1) {
by <- rep(by, 2) by <- rep(by, 2)
} }
int_x <- colnames(x) %in% colnames(y) & colnames(x) != by[1] int_x <- colnames(x) %in% colnames(y) & colnames(x) != by[1]
int_y <- colnames(y) %in% colnames(x) & colnames(y) != by[2] int_y <- colnames(y) %in% colnames(x) & colnames(y) != by[2]
colnames(x)[int_x] <- paste0(colnames(x)[int_x], suffix[1L]) colnames(x)[int_x] <- paste0(colnames(x)[int_x], suffix[1L])
colnames(y)[int_y] <- paste0(colnames(y)[int_y], suffix[2L]) colnames(y)[int_y] <- paste0(colnames(y)[int_y], suffix[2L])
merged <- cbind( merged <- cbind(
x, x,
y[match( y[match(
@ -53,7 +53,7 @@ pm_left_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
drop = FALSE drop = FALSE
] ]
) )
rownames(merged) <- NULL rownames(merged) <- NULL
merged merged
} }
@ -89,7 +89,7 @@ quick_case_when <- function(...) {
if (n == 0L) { if (n == 0L) {
stop("No cases provided.") stop("No cases provided.")
} }
validate_case_when_length <- function(query, value, fs) { validate_case_when_length <- function(query, value, fs) {
lhs_lengths <- lengths(query) lhs_lengths <- lengths(query)
rhs_lengths <- lengths(value) rhs_lengths <- lengths(value)
@ -108,13 +108,13 @@ quick_case_when <- function(...) {
problems <- lhs_problems | rhs_problems problems <- lhs_problems | rhs_problems
if (any(problems)) { if (any(problems)) {
stop("The following formulas must be length ", len, " or 1, not ", stop("The following formulas must be length ", len, " or 1, not ",
paste(inconsistent_lengths, collapse = ", "), ".\n ", paste(inconsistent_lengths, collapse = ", "), ".\n ",
paste(fs[problems], collapse = "\n "), paste(fs[problems], collapse = "\n "),
call. = FALSE call. = FALSE
) )
} }
} }
replace_with <- function(x, i, val, arg_name) { replace_with <- function(x, i, val, arg_name) {
if (is.null(val)) { if (is.null(val)) {
return(x) return(x)
@ -127,7 +127,7 @@ quick_case_when <- function(...) {
} }
x x
} }
query <- vector("list", n) query <- vector("list", n)
value <- vector("list", n) value <- vector("list", n)
default_env <- parent.frame() default_env <- parent.frame()
@ -159,13 +159,13 @@ addin_insert_in <- function() {
# No export, no Rd # No export, no Rd
addin_insert_like <- function() { addin_insert_like <- function() {
# we want Shift + Ctrl/Cmd + L to iterate over %like%, %unlike%, %like_case%, and %unlike_case% # we want Shift + Ctrl/Cmd + L to iterate over %like%, %unlike%, %like_case%, and %unlike_case%
getActiveDocumentContext <- import_fn("getActiveDocumentContext", "rstudioapi") getActiveDocumentContext <- import_fn("getActiveDocumentContext", "rstudioapi")
insertText <- import_fn("insertText", "rstudioapi") insertText <- import_fn("insertText", "rstudioapi")
modifyRange <- import_fn("modifyRange", "rstudioapi") modifyRange <- import_fn("modifyRange", "rstudioapi")
document_range <- import_fn("document_range", "rstudioapi") document_range <- import_fn("document_range", "rstudioapi")
document_position <- import_fn("document_position", "rstudioapi") document_position <- import_fn("document_position", "rstudioapi")
context <- getActiveDocumentContext() context <- getActiveDocumentContext()
current_row <- context$selection[[1]]$range$end[1] current_row <- context$selection[[1]]$range$end[1]
current_col <- context$selection[[1]]$range$end[2] current_col <- context$selection[[1]]$range$end[2]
@ -174,15 +174,15 @@ addin_insert_like <- function() {
insertText(" %like% ") insertText(" %like% ")
return(invisible()) return(invisible())
} }
pos_preceded_by <- function(txt) { pos_preceded_by <- function(txt) {
if (tryCatch(substr(current_row_txt, current_col - nchar(trimws(txt, which = "right")), current_col) == trimws(txt, which = "right"), if (tryCatch(substr(current_row_txt, current_col - nchar(trimws(txt, which = "right")), current_col) == trimws(txt, which = "right"),
error = function(e) FALSE error = function(e) FALSE
)) { )) {
return(TRUE) return(TRUE)
} }
tryCatch(substr(current_row_txt, current_col - nchar(txt), current_col) %like% paste0("^", txt), tryCatch(substr(current_row_txt, current_col - nchar(txt), current_col) %like% paste0("^", txt),
error = function(e) FALSE error = function(e) FALSE
) )
} }
replace_pos <- function(old, with) { replace_pos <- function(old, with) {
@ -194,7 +194,7 @@ addin_insert_like <- function() {
id = context$id id = context$id
) )
} }
if (pos_preceded_by(" %like% ")) { if (pos_preceded_by(" %like% ")) {
replace_pos(" %like% ", with = " %unlike% ") replace_pos(" %like% ", with = " %unlike% ")
} else if (pos_preceded_by(" %unlike% ")) { } else if (pos_preceded_by(" %unlike% ")) {
@ -211,21 +211,21 @@ addin_insert_like <- function() {
search_type_in_df <- function(x, type, info = TRUE) { search_type_in_df <- function(x, type, info = TRUE) {
meet_criteria(x, allow_class = "data.frame") meet_criteria(x, allow_class = "data.frame")
meet_criteria(type, allow_class = "character", has_length = 1) meet_criteria(type, allow_class = "character", has_length = 1)
# try to find columns based on type # try to find columns based on type
found <- NULL found <- NULL
# remove attributes from other packages # remove attributes from other packages
x <- as.data.frame(x, stringsAsFactors = FALSE) x <- as.data.frame(x, stringsAsFactors = FALSE)
colnames_formatted <- tolower(generalise_antibiotic_name(colnames(x))) colnames_formatted <- tolower(generalise_antibiotic_name(colnames(x)))
# -- mo # -- mo
if (type == "mo") { if (type == "mo") {
if (any(vapply(FUN.VALUE = logical(1), x, is.mo))) { if (any(vapply(FUN.VALUE = logical(1), x, is.mo))) {
# take first <mo> column # take first <mo> column
found <- colnames(x)[vapply(FUN.VALUE = logical(1), x, is.mo)] found <- colnames(x)[vapply(FUN.VALUE = logical(1), x, is.mo)]
} else if ("mo" %in% colnames_formatted && } else if ("mo" %in% colnames_formatted &&
suppressWarnings(all(x$mo %in% c(NA, AMR::microorganisms$mo)))) { suppressWarnings(all(x$mo %in% c(NA, AMR::microorganisms$mo)))) {
found <- "mo" found <- "mo"
} else if (any(colnames_formatted %like_case% "^(mo|microorganism|organism|bacteria|ba[ck]terie)s?$")) { } else if (any(colnames_formatted %like_case% "^(mo|microorganism|organism|bacteria|ba[ck]terie)s?$")) {
found <- sort(colnames(x)[colnames_formatted %like_case% "^(mo|microorganism|organism|bacteria|ba[ck]terie)s?$"]) found <- sort(colnames(x)[colnames_formatted %like_case% "^(mo|microorganism|organism|bacteria|ba[ck]terie)s?$"])
@ -290,16 +290,16 @@ search_type_in_df <- function(x, type, info = TRUE) {
# this column should contain logicals # this column should contain logicals
if (!is.logical(x[, found, drop = TRUE])) { if (!is.logical(x[, found, drop = TRUE])) {
message_("Column '", font_bold(found), "' found as input for `col_", type, message_("Column '", font_bold(found), "' found as input for `col_", type,
"`, but this column does not contain 'logical' values (TRUE/FALSE) and was ignored.", "`, but this column does not contain 'logical' values (TRUE/FALSE) and was ignored.",
add_fn = font_red add_fn = font_red
) )
found <- NULL found <- NULL
} }
} }
} }
found <- found[1] found <- found[1]
if (!is.null(found) && info == TRUE) { if (!is.null(found) && info == TRUE) {
if (message_not_thrown_before("search_in_type", type)) { if (message_not_thrown_before("search_in_type", type)) {
msg <- paste0("Using column '", font_bold(found), "' as input for `col_", type, "`.") msg <- paste0("Using column '", font_bold(found), "' as input for `col_", type, "`.")
@ -345,16 +345,16 @@ stop_ifnot_installed <- function(package) {
# https://developer.r-project.org/Blog/public/2019/02/14/staged-install/index.html # https://developer.r-project.org/Blog/public/2019/02/14/staged-install/index.html
vapply(FUN.VALUE = character(1), package, function(pkg) { vapply(FUN.VALUE = character(1), package, function(pkg) {
tryCatch(get(".packageName", envir = asNamespace(pkg)), tryCatch(get(".packageName", envir = asNamespace(pkg)),
error = function(e) { error = function(e) {
if (pkg == "rstudioapi") { if (pkg == "rstudioapi") {
stop("This function only works in RStudio when using R >= 3.2.", call. = FALSE) stop("This function only works in RStudio when using R >= 3.2.", call. = FALSE)
} else if (pkg != "base") { } else if (pkg != "base") {
stop("This requires the '", pkg, "' package.", stop("This requires the '", pkg, "' package.",
"\nTry to install it with: install.packages(\"", pkg, "\")", "\nTry to install it with: install.packages(\"", pkg, "\")",
call. = FALSE call. = FALSE
) )
} }
} }
) )
}) })
return(invisible()) return(invisible())
@ -382,8 +382,8 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) {
error = function(e) { error = function(e) {
if (isTRUE(error_on_fail)) { if (isTRUE(error_on_fail)) {
stop_("function ", name, "() is not an exported object from 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!", "'. Please create an issue at https://github.com/msberends/AMR/issues. Many thanks!",
call = FALSE call = FALSE
) )
} else { } else {
return(NULL) return(NULL)
@ -403,11 +403,11 @@ word_wrap <- function(...,
width = 0.95 * getOption("width"), width = 0.95 * getOption("width"),
extra_indent = 0) { extra_indent = 0) {
msg <- paste0(c(...), collapse = "") msg <- paste0(c(...), collapse = "")
if (isTRUE(as_note)) { if (isTRUE(as_note)) {
msg <- paste0(pkg_env$info_icon, " ", gsub("^note:? ?", "", msg, ignore.case = TRUE)) msg <- paste0(pkg_env$info_icon, " ", gsub("^note:? ?", "", msg, ignore.case = TRUE))
} }
if (msg %like% "\n") { if (msg %like% "\n") {
# run word_wraps() over every line here, bind them and return again # run word_wraps() over every line here, bind them and return again
return(paste0(vapply( return(paste0(vapply(
@ -422,7 +422,7 @@ word_wrap <- function(...,
collapse = "\n" collapse = "\n"
)) ))
} }
# correct for operators (will add the space later on) # correct for operators (will add the space later on)
ops <- "([,./><\\]\\[])" ops <- "([,./><\\]\\[])"
msg <- gsub(paste0(ops, " ", ops), "\\1\\2", msg, perl = TRUE) msg <- gsub(paste0(ops, " ", ops), "\\1\\2", msg, perl = TRUE)
@ -430,13 +430,13 @@ word_wrap <- function(...,
msg_stripped <- font_stripstyle(msg) msg_stripped <- font_stripstyle(msg)
# where are the spaces now? # where are the spaces now?
msg_stripped_wrapped <- paste0(strwrap(msg_stripped, msg_stripped_wrapped <- paste0(strwrap(msg_stripped,
simplify = TRUE, simplify = TRUE,
width = width width = width
), ),
collapse = "\n" collapse = "\n"
) )
msg_stripped_wrapped <- paste0(unlist(strsplit(msg_stripped_wrapped, "(\n|\\*\\|\\*)")), msg_stripped_wrapped <- paste0(unlist(strsplit(msg_stripped_wrapped, "(\n|\\*\\|\\*)")),
collapse = "\n" collapse = "\n"
) )
msg_stripped_spaces <- which(unlist(strsplit(msg_stripped, "", fixed = TRUE)) == " ") msg_stripped_spaces <- which(unlist(strsplit(msg_stripped, "", fixed = TRUE)) == " ")
msg_stripped_wrapped_spaces <- which(unlist(strsplit(msg_stripped_wrapped, "", fixed = TRUE)) != "\n") msg_stripped_wrapped_spaces <- which(unlist(strsplit(msg_stripped_wrapped, "", fixed = TRUE)) != "\n")
@ -449,7 +449,7 @@ word_wrap <- function(...,
msg <- gsub(paste0(ops, ops), "\\1 \\2", msg, perl = TRUE) msg <- gsub(paste0(ops, ops), "\\1 \\2", msg, perl = TRUE)
msg <- paste0(msg, collapse = " ") msg <- paste0(msg, collapse = " ")
msg <- gsub("\n ", "\n", msg, fixed = TRUE) msg <- gsub("\n ", "\n", msg, fixed = TRUE)
if (msg_stripped %like% "\u2139 ") { if (msg_stripped %like% "\u2139 ") {
indentation <- 2 + extra_indent indentation <- 2 + extra_indent
} else if (msg_stripped %like% "^=> ") { } else if (msg_stripped %like% "^=> ") {
@ -460,7 +460,7 @@ word_wrap <- function(...,
msg <- gsub("\n", paste0("\n", strrep(" ", indentation)), msg, fixed = TRUE) msg <- gsub("\n", paste0("\n", strrep(" ", indentation)), msg, fixed = TRUE)
# remove trailing empty characters # remove trailing empty characters
msg <- gsub("(\n| )+$", "", msg) msg <- gsub("(\n| )+$", "", msg)
if (length(add_fn) > 0) { if (length(add_fn) > 0) {
if (!is.list(add_fn)) { if (!is.list(add_fn)) {
add_fn <- list(add_fn) add_fn <- list(add_fn)
@ -469,15 +469,15 @@ word_wrap <- function(...,
msg <- add_fn[[i]](msg) msg <- add_fn[[i]](msg)
} }
} }
# format backticks # format backticks
msg <- gsub("(`.+?`)", font_grey_bg("\\1"), msg) msg <- gsub("(`.+?`)", font_grey_bg("\\1"), msg)
# clean introduced whitespace between fullstops # clean introduced whitespace between fullstops
msg <- gsub("[.] +[.]", "..", msg) msg <- gsub("[.] +[.]", "..", msg)
# remove extra space that was introduced (case: "Smith et al., 2022") # remove extra space that was introduced (case: "Smith et al., 2022")
msg <- gsub(". ,", ".,", msg, fixed = TRUE) msg <- gsub(". ,", ".,", msg, fixed = TRUE)
msg msg
} }
@ -486,8 +486,8 @@ message_ <- function(...,
add_fn = list(font_blue), add_fn = list(font_blue),
as_note = TRUE) { as_note = TRUE) {
message(word_wrap(..., message(word_wrap(...,
add_fn = add_fn, add_fn = add_fn,
as_note = as_note as_note = as_note
), ),
appendLF = appendLF appendLF = appendLF
) )
@ -498,8 +498,8 @@ warning_ <- function(...,
immediate = FALSE, immediate = FALSE,
call = FALSE) { call = FALSE) {
warning(word_wrap(..., warning(word_wrap(...,
add_fn = add_fn, add_fn = add_fn,
as_note = FALSE as_note = FALSE
), ),
immediate. = immediate, immediate. = immediate,
call. = call call. = call
@ -732,13 +732,13 @@ meet_criteria <- function(object,
allow_NA = FALSE, allow_NA = FALSE,
ignore.case = FALSE, ignore.case = FALSE,
.call_depth = 0) { # depth in calling .call_depth = 0) { # depth in calling
obj_name <- deparse(substitute(object)) obj_name <- deparse(substitute(object))
call_depth <- -2 - abs(.call_depth) call_depth <- -2 - abs(.call_depth)
# if object is missing, or another error: # if object is missing, or another error:
tryCatch(invisible(object), tryCatch(invisible(object),
error = function(e) pkg_env$meet_criteria_error_txt <- e$message error = function(e) pkg_env$meet_criteria_error_txt <- e$message
) )
if (!is.null(pkg_env$meet_criteria_error_txt)) { if (!is.null(pkg_env$meet_criteria_error_txt)) {
error_txt <- pkg_env$meet_criteria_error_txt error_txt <- pkg_env$meet_criteria_error_txt
@ -746,7 +746,7 @@ meet_criteria <- function(object,
stop(error_txt, call. = FALSE) # don't use stop_() here, our pkg may not be loaded yet stop(error_txt, call. = FALSE) # don't use stop_() here, our pkg may not be loaded yet
} }
pkg_env$meet_criteria_error_txt <- NULL pkg_env$meet_criteria_error_txt <- NULL
if (is.null(object)) { if (is.null(object)) {
stop_if(allow_NULL == FALSE, "argument `", obj_name, "` must not be NULL", call = call_depth) stop_if(allow_NULL == FALSE, "argument `", obj_name, "` must not be NULL", call = call_depth)
return(invisible()) return(invisible())
@ -755,36 +755,36 @@ meet_criteria <- function(object,
stop_if(allow_NA == FALSE, "argument `", obj_name, "` must not be NA", call = call_depth) stop_if(allow_NA == FALSE, "argument `", obj_name, "` must not be NA", call = call_depth)
return(invisible()) return(invisible())
} }
if (!is.null(allow_class)) { if (!is.null(allow_class)) {
stop_ifnot(inherits(object, allow_class), "argument `", obj_name, stop_ifnot(inherits(object, allow_class), "argument `", obj_name,
"` must be ", format_class(allow_class, plural = isTRUE(has_length > 1)), "` must be ", format_class(allow_class, plural = isTRUE(has_length > 1)),
", i.e. not be ", format_class(class(object), plural = isTRUE(has_length > 1)), ", i.e. not be ", format_class(class(object), plural = isTRUE(has_length > 1)),
call = call_depth call = call_depth
) )
# check data.frames for data # check data.frames for data
if (inherits(object, "data.frame")) { if (inherits(object, "data.frame")) {
stop_if(any(dim(object) == 0), stop_if(any(dim(object) == 0),
"the data provided in argument `", obj_name, "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"), ")", paste(dim(object), collapse = "x"), ")",
call = call_depth call = call_depth
) )
} }
} }
if (!is.null(has_length)) { if (!is.null(has_length)) {
stop_ifnot(length(object) %in% has_length, "argument `", obj_name, stop_ifnot(length(object) %in% has_length, "argument `", obj_name,
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""), "` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
"be of length ", vector_or(has_length, quotes = FALSE), "be of length ", vector_or(has_length, quotes = FALSE),
", not ", length(object), ", not ", length(object),
call = call_depth call = call_depth
) )
} }
if (!is.null(looks_like)) { if (!is.null(looks_like)) {
stop_ifnot(object %like% looks_like, "argument `", obj_name, stop_ifnot(object %like% looks_like, "argument `", obj_name,
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""), "` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
"resemble the regular expression \"", looks_like, "\"", "resemble the regular expression \"", looks_like, "\"",
call = call_depth call = call_depth
) )
} }
if (!is.null(is_in)) { if (!is.null(is_in)) {
@ -793,44 +793,44 @@ meet_criteria <- function(object,
is_in <- tolower(is_in) 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, "` ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1, ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"must be either ", "must be either ",
"must only contain values " "must only contain values "
), ),
vector_or(is_in, quotes = !isTRUE(any(c("double", "numeric", "integer") %in% allow_class))), vector_or(is_in, quotes = !isTRUE(any(c("double", "numeric", "integer") %in% allow_class))),
ifelse(allow_NA == TRUE, ", or NA", ""), ifelse(allow_NA == TRUE, ", or NA", ""),
call = call_depth call = call_depth
) )
} }
if (isTRUE(is_positive)) { if (isTRUE(is_positive)) {
stop_if(is.numeric(object) && !all(object > 0, na.rm = TRUE), "argument `", obj_name, stop_if(is.numeric(object) && !all(object > 0, na.rm = TRUE), "argument `", obj_name,
"` must ", "` must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1, ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"be a number higher than zero", "be a number higher than zero",
"all be numbers higher than zero" "all be numbers higher than zero"
), ),
call = call_depth call = call_depth
) )
} }
if (isTRUE(is_positive_or_zero)) { if (isTRUE(is_positive_or_zero)) {
stop_if(is.numeric(object) && !all(object >= 0, na.rm = TRUE), "argument `", obj_name, stop_if(is.numeric(object) && !all(object >= 0, na.rm = TRUE), "argument `", obj_name,
"` must ", "` must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1, ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"be zero or a positive number", "be zero or a positive number",
"all be zero or numbers higher than zero" "all be zero or numbers higher than zero"
), ),
call = call_depth call = call_depth
) )
} }
if (isTRUE(is_finite)) { if (isTRUE(is_finite)) {
stop_if(is.numeric(object) && !all(is.finite(object[!is.na(object)]), na.rm = TRUE), "argument `", obj_name, stop_if(is.numeric(object) && !all(is.finite(object[!is.na(object)]), na.rm = TRUE), "argument `", obj_name,
"` must ", "` must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1, ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"be a finite number", "be a finite number",
"all be finite numbers" "all be finite numbers"
), ),
" (i.e. not be infinite)", " (i.e. not be infinite)",
call = call_depth call = call_depth
) )
} }
if (!is.null(contains_column_class)) { if (!is.null(contains_column_class)) {
@ -864,12 +864,12 @@ get_current_data <- function(arg_name, call) {
return(out) return(out)
} }
} }
# try a manual (base R) method, by going over all underlying environments with sys.frames() # try a manual (base R) method, by going over all underlying environments with sys.frames()
for (env in sys.frames()) { for (env in sys.frames()) {
if (!is.null(env$`.Generic`)) { if (!is.null(env$`.Generic`)) {
# don't check `".Generic" %in% names(env)`, because in R < 3.2, `names(env)` is always NULL # don't check `".Generic" %in% names(env)`, because in R < 3.2, `names(env)` is always NULL
if (valid_df(env$`.data`)) { if (valid_df(env$`.data`)) {
# an element `.data` will be in the environment when using `dplyr::select()` # an element `.data` will be in the environment when using `dplyr::select()`
# (but not when using `dplyr::filter()`, `dplyr::mutate()` or `dplyr::summarise()`) # (but not when using `dplyr::filter()`, `dplyr::mutate()` or `dplyr::summarise()`)
@ -883,7 +883,7 @@ get_current_data <- function(arg_name, call) {
} }
} }
} }
# no data.frame found, so an error must be returned: # no data.frame found, so an error must be returned:
if (is.na(arg_name)) { if (is.na(arg_name)) {
if (isTRUE(is.numeric(call))) { if (isTRUE(is.numeric(call))) {
@ -899,8 +899,8 @@ get_current_data <- function(arg_name, call) {
examples <- "" examples <- ""
} }
stop_("this function must be used inside a `dplyr` verb or `data.frame` call", stop_("this function must be used inside a `dplyr` verb or `data.frame` call",
examples, examples,
call = call call = call
) )
} else { } else {
# mimic a base R error that the argument is missing # mimic a base R error that the argument is missing
@ -917,7 +917,7 @@ get_current_column <- function() {
return(out) return(out)
} }
} }
# cur_column() doesn't always work (only allowed for certain conditions set by dplyr), but it's probably still possible: # cur_column() doesn't always work (only allowed for certain conditions set by dplyr), but it's probably still possible:
frms <- lapply(sys.frames(), function(env) { frms <- lapply(sys.frames(), function(env) {
if (!is.null(env$i)) { if (!is.null(env$i)) {
@ -937,7 +937,7 @@ get_current_column <- function() {
NULL NULL
} }
}) })
vars <- unlist(frms) vars <- unlist(frms)
if (length(vars) > 0) { if (length(vars) > 0) {
vars[length(vars)] vars[length(vars)]
@ -956,7 +956,7 @@ unique_call_id <- function(entire_session = FALSE, match_fn = NULL) {
if (entire_session == TRUE) { if (entire_session == TRUE) {
return(c(envir = "session", call = "session")) return(c(envir = "session", call = "session"))
} }
# combination of environment ID (such as "0x7fed4ee8c848") # combination of environment ID (such as "0x7fed4ee8c848")
# and relevant system call (where 'match_fn' is being called in) # and relevant system call (where 'match_fn' is being called in)
calls <- sys.calls() calls <- sys.calls()
@ -1007,7 +1007,7 @@ message_not_thrown_before <- function(fn, ..., entire_session = FALSE) {
has_colour <- function() { has_colour <- function() {
# this is a base R version of crayon::has_color, but disables colours on emacs # this is a base R version of crayon::has_color, but disables colours on emacs
if (Sys.getenv("EMACS") != "" || Sys.getenv("INSIDE_EMACS") != "") { if (Sys.getenv("EMACS") != "" || Sys.getenv("INSIDE_EMACS") != "") {
# disable on emacs, which only supports 8 colours # disable on emacs, which only supports 8 colours
return(FALSE) return(FALSE)
@ -1289,7 +1289,7 @@ round2 <- function(x, digits = 1, force_zero = TRUE) {
# percentage from our other package: 'cleaner' # percentage from our other package: 'cleaner'
percentage <- function(x, digits = NULL, ...) { percentage <- function(x, digits = NULL, ...) {
# getdecimalplaces() function # getdecimalplaces() function
getdecimalplaces <- function(x, minimum = 0, maximum = 3) { getdecimalplaces <- function(x, minimum = 0, maximum = 3) {
if (maximum < minimum) { if (maximum < minimum) {
@ -1306,14 +1306,14 @@ percentage <- function(x, digits = NULL, ...) {
function(y) ifelse(length(y) == 2, nchar(y[2]), 0) function(y) ifelse(length(y) == 2, nchar(y[2]), 0)
)), na.rm = TRUE) )), na.rm = TRUE)
max(min(max_places, max(min(max_places,
maximum, maximum,
na.rm = TRUE na.rm = TRUE
), ),
minimum, minimum,
na.rm = TRUE na.rm = TRUE
) )
} }
# format_percentage() function # format_percentage() function
format_percentage <- function(x, digits = NULL, ...) { format_percentage <- function(x, digits = NULL, ...) {
if (is.null(digits)) { if (is.null(digits)) {
@ -1322,19 +1322,19 @@ percentage <- function(x, digits = NULL, ...) {
if (is.null(digits) || is.na(digits) || !is.numeric(digits)) { if (is.null(digits) || is.na(digits) || !is.numeric(digits)) {
digits <- 2 digits <- 2
} }
# round right: percentage(0.4455) and format(as.percentage(0.4455), 1) should return "44.6%", not "44.5%" # 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, x_formatted <- format(round2(as.double(x), digits = digits + 2) * 100,
scientific = FALSE, scientific = FALSE,
digits = max(1, digits), digits = max(1, digits),
nsmall = digits, nsmall = digits,
... ...
) )
x_formatted <- paste0(x_formatted, "%") x_formatted <- paste0(x_formatted, "%")
x_formatted[!grepl(pattern = "^[0-9.,e-]+$", x = x)] <- NA_character_ x_formatted[!grepl(pattern = "^[0-9.,e-]+$", x = x)] <- NA_character_
x_formatted x_formatted
} }
# the actual working part # the actual working part
x <- as.double(x) x <- as.double(x)
if (is.null(digits)) { if (is.null(digits)) {
@ -1459,9 +1459,9 @@ if (getRversion() < "3.3.0") {
which <- match.arg(which) which <- match.arg(which)
mysub <- function(re, x) sub(re, "", x, perl = TRUE) mysub <- function(re, x) sub(re, "", x, perl = TRUE)
switch(which, switch(which,
left = mysub(paste0("^", whitespace, "+"), x), left = mysub(paste0("^", whitespace, "+"), x),
right = mysub(paste0(whitespace, "+$"), x), right = mysub(paste0(whitespace, "+$"), x),
both = mysub(paste0(whitespace, "+$"), mysub(paste0("^", whitespace, "+"), x)) both = mysub(paste0(whitespace, "+$"), mysub(paste0("^", whitespace, "+"), x))
) )
} }
} }

6
data-raw/_pre_commit_hook.R
View File

@ -476,10 +476,8 @@ invisible(capture.output(urlchecker::url_update()))
# Document pkg ------------------------------------------------------------ # Document pkg ------------------------------------------------------------
if (interactive()) { usethis::ui_info("Documenting package")
usethis::ui_info("Documenting package") suppressMessages(devtools::document(quiet = TRUE))
suppressMessages(devtools::document(quiet = TRUE))
}
# Style pkg --------------------------------------------------------------- # Style pkg ---------------------------------------------------------------

6
man/as.mo.Rd
View File

@ -16,9 +16,9 @@ as.mo(
Lancefield = FALSE, Lancefield = FALSE,
minimum_matching_score = NULL, minimum_matching_score = NULL,
allow_uncertain = TRUE, allow_uncertain = TRUE,
keep_synonyms = FALSE, keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
reference_df = get_mo_source(), reference_df = get_mo_source(),
ignore_pattern = getOption("AMR_ignore_pattern"), ignore_pattern = getOption("AMR_ignore_pattern", NULL),
language = get_AMR_locale(), language = get_AMR_locale(),
info = interactive(), info = interactive(),
... ...
@ -49,7 +49,7 @@ This excludes enterococci at default (who are in group D), use \code{Lancefield
\item{allow_uncertain}{a number between \code{0} (or \code{"none"}) and \code{3} (or \code{"all"}), or \code{TRUE} (= \code{2}) or \code{FALSE} (= \code{0}) to indicate whether the input should be checked for less probable results, see \emph{Details}} \item{allow_uncertain}{a number between \code{0} (or \code{"none"}) and \code{3} (or \code{"all"}), or \code{TRUE} (= \code{2}) or \code{FALSE} (= \code{0}) to indicate whether the input should be checked for less probable results, see \emph{Details}}
\item{keep_synonyms}{a \link{logical} to indicate if old, previously valid taxonomic names must be preserved and not be corrected to currently accepted names. The default is \code{FALSE} to always return the currently accepted names.} \item{keep_synonyms}{a \link{logical} to indicate if old, previously valid taxonomic names must be preserved and not be corrected to currently accepted names. The default is \code{TRUE}, which will return a note if old taxonomic names are returned. The default can be set with \code{options(AMR_keep_synonyms = ...)}.}
\item{reference_df}{a \link{data.frame} to be used for extra reference when translating \code{x} to a valid \code{\link{mo}}. See \code{\link[=set_mo_source]{set_mo_source()}} and \code{\link[=get_mo_source]{get_mo_source()}} to automate the usage of your own codes (e.g. used in your analysis or organisation).} \item{reference_df}{a \link{data.frame} to be used for extra reference when translating \code{x} to a valid \code{\link{mo}}. See \code{\link[=set_mo_source]{set_mo_source()}} and \code{\link[=get_mo_source]{get_mo_source()}} to automate the usage of your own codes (e.g. used in your analysis or organisation).}

220
man/mo_property.Rd
View File

@ -25,6 +25,7 @@
\alias{mo_authors} \alias{mo_authors}
\alias{mo_year} \alias{mo_year}
\alias{mo_lpsn} \alias{mo_lpsn}
\alias{mo_gbif}
\alias{mo_rank} \alias{mo_rank}
\alias{mo_taxonomy} \alias{mo_taxonomy}
\alias{mo_synonyms} \alias{mo_synonyms}
@ -32,68 +33,225 @@
\alias{mo_url} \alias{mo_url}
\title{Get Properties of a Microorganism} \title{Get Properties of a Microorganism}
\usage{ \usage{
mo_name(x, language = get_AMR_locale(), ...) mo_name(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_fullname(x, language = get_AMR_locale(), ...) mo_fullname(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_shortname(x, language = get_AMR_locale(), ...) mo_shortname(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_subspecies(x, language = get_AMR_locale(), ...) mo_subspecies(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_species(x, language = get_AMR_locale(), ...) mo_species(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_genus(x, language = get_AMR_locale(), ...) mo_genus(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_family(x, language = get_AMR_locale(), ...) mo_family(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_order(x, language = get_AMR_locale(), ...) mo_order(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_class(x, language = get_AMR_locale(), ...) mo_class(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_phylum(x, language = get_AMR_locale(), ...) mo_phylum(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_kingdom(x, language = get_AMR_locale(), ...) mo_kingdom(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_domain(x, language = get_AMR_locale(), ...) mo_domain(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_type(x, language = get_AMR_locale(), ...) mo_type(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_gramstain(x, language = get_AMR_locale(), ...) mo_gramstain(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_is_gram_negative(x, language = get_AMR_locale(), ...) mo_is_gram_negative(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_is_gram_positive(x, language = get_AMR_locale(), ...) mo_is_gram_positive(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_is_yeast(x, language = get_AMR_locale(), ...) mo_is_yeast(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_is_intrinsic_resistant(x, ab, language = get_AMR_locale(), ...) mo_is_intrinsic_resistant(
x,
ab,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_snomed(x, language = get_AMR_locale(), ...) mo_snomed(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_ref(x, language = get_AMR_locale(), ...) mo_ref(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_authors(x, language = get_AMR_locale(), ...) mo_authors(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_year(x, language = get_AMR_locale(), ...) mo_year(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_lpsn(x, language = get_AMR_locale(), ...) mo_lpsn(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_rank(x, language = get_AMR_locale(), ...) mo_gbif(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_taxonomy(x, language = get_AMR_locale(), ...) mo_rank(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_synonyms(x, language = get_AMR_locale(), ...) mo_taxonomy(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_info(x, language = get_AMR_locale(), ...) mo_synonyms(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_url(x, open = FALSE, language = get_AMR_locale(), ...) mo_info(
x,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_property(x, property = "fullname", language = get_AMR_locale(), ...) mo_url(
x,
open = FALSE,
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
mo_property(
x,
property = "fullname",
language = get_AMR_locale(),
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
...
)
} }
\arguments{ \arguments{
\item{x}{any \link{character} (vector) that can be coerced to a valid microorganism code with \code{\link[=as.mo]{as.mo()}}. Can be left blank for auto-guessing the column containing microorganism codes if used in a data set, see \emph{Examples}.} \item{x}{any \link{character} (vector) that can be coerced to a valid microorganism code with \code{\link[=as.mo]{as.mo()}}. Can be left blank for auto-guessing the column containing microorganism codes if used in a data set, see \emph{Examples}.}
\item{language}{language of the returned text, defaults to system language (see \code{\link[=get_AMR_locale]{get_AMR_locale()}}) and can be overwritten by setting the option \code{AMR_locale}, e.g. \code{options(AMR_locale = "de")}, see \link{translate}. Also used to translate text like "no growth". Use \code{language = NULL} or \code{language = ""} to prevent translation.} \item{language}{language to translate text like "no growth", which defaults to the system language (see \code{\link[=get_AMR_locale]{get_AMR_locale()}})}
\item{keep_synonyms}{a \link{logical} to indicate if old, previously valid taxonomic names must be preserved and not be corrected to currently accepted names. The default is \code{TRUE}, which will return a note if old taxonomic names are returned. The default can be set with \code{options(AMR_keep_synonyms = ...)}.}
\item{...}{other arguments passed on to \code{\link[=as.mo]{as.mo()}}, such as 'allow_uncertain' and 'ignore_pattern'} \item{...}{other arguments passed on to \code{\link[=as.mo]{as.mo()}}, such as 'allow_uncertain' and 'ignore_pattern'}
@ -116,7 +274,7 @@ mo_property(x, property = "fullname", language = get_AMR_locale(), ...)
Use these functions to return a specific property of a microorganism based on the latest accepted taxonomy. All input values will be evaluated internally with \code{\link[=as.mo]{as.mo()}}, which makes it possible to use microbial abbreviations, codes and names as input. See \emph{Examples}. Use these functions to return a specific property of a microorganism based on the latest accepted taxonomy. All input values will be evaluated internally with \code{\link[=as.mo]{as.mo()}}, which makes it possible to use microbial abbreviations, codes and names as input. See \emph{Examples}.
} }
\details{ \details{
All functions will return the most recently known taxonomic property \link[=microorganisms]{as included in this package}, except for \code{\link[=mo_ref]{mo_ref()}}, \code{\link[=mo_authors]{mo_authors()}} and \code{\link[=mo_year]{mo_year()}}. Please refer to this example, knowing that \emph{Escherichia blattae} was renamed to \emph{Shimwellia blattae} in 2010: All functions will, at default, keep old taxonomic properties. Please refer to this example, knowing that \emph{Escherichia blattae} was renamed to \emph{Shimwellia blattae} in 2010:
\itemize{ \itemize{
\item \code{mo_name("Escherichia blattae")} will return \code{"Shimwellia blattae"} (with a message about the renaming) \item \code{mo_name("Escherichia blattae")} will return \code{"Shimwellia blattae"} (with a message about the renaming)
\item \code{mo_ref("Escherichia blattae")} will return \code{"Burgess et al., 1973"} (with a message about the renaming) \item \code{mo_ref("Escherichia blattae")} will return \code{"Burgess et al., 1973"} (with a message about the renaming)