P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-07-09 02:03:04 +02:00
Code Releases Activity

(v1.4.0.9008) like variations

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2020-10-26 12:23:03 +01:00
parent f720c9ba0b
commit 760d69a3e0
64 changed files with 919 additions and 582 deletions
Download Patch File Download Diff File Expand all files Collapse all files

171
R/aa_helper_functions.R
View File

@ -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")) {
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() {
# 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() {
# 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() {
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) {
} 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) {
}
}
}
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) {
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) {
})
}
# 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,
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,
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,
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,
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() {
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, ...) {
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) {
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) {
# 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, ...) {
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, ...) {
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, ...) {
# 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) {
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
View File

@ -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 @@
#' * 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) {
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
View File

File diff suppressed because it is too large Load Diff

118
R/mo_property.R
View File

@ -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 @@
#' @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 @@
#' - `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 @@
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
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(), ...) {
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(), ...) {
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(), ...) {
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(), ...) {
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(), ...) {
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(), ...) {
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(), ...) {
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(), ...) {
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(), ...) {
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
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(), ...) {
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(), ...) {
"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, ...) {
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(), ...) {
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(), ...) {
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(), ...) {
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(), ...) {
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(), ...) {
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(), ...) {
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(), ...) {
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(), ...) {
} else {
result <- unlist(syns)
}
load_mo_failures_uncertainties_renamed(metadata)
result
}
@ -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(), ...) {
} else {
result <- info[[1L]]
}
load_mo_failures_uncertainties_renamed(metadata)
result
}
@ -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(), ...) {
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(), ...)
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, ...) {
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, ...) {
| 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") {