P281424
/
AMR
mirror of https://github.com/msberends/AMR.git
1
0
Fork 0
Code Releases Activity

fixes

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
Version: 1.8.1.9057
Version: 1.8.1.9058
Date: 2022-09-19
Title: Antimicrobial Resistance Data Analysis
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_family)
export(mo_fullname)
export(mo_gbif)
export(mo_genus)
export(mo_gramstain)
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!

158
R/aa_helper_functions.R
View File

@ -108,9 +108,9 @@ quick_case_when <- function(...) {
problems <- lhs_problems | rhs_problems
if (any(problems)) {
stop("The following formulas must be length ", len, " or 1, not ",
paste(inconsistent_lengths, collapse = ", "), ".\n ",
paste(fs[problems], collapse = "\n "),
call. = FALSE
paste(inconsistent_lengths, collapse = ", "), ".\n ",
paste(fs[problems], collapse = "\n "),
call. = FALSE
)
}
}
@ -177,12 +177,12 @@ addin_insert_like <- function() {
pos_preceded_by <- function(txt) {
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)
}
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) {
@ -225,7 +225,7 @@ search_type_in_df <- function(x, type, info = TRUE) {
# take first <mo> column
found <- colnames(x)[vapply(FUN.VALUE = logical(1), x, is.mo)]
} 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"
} 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?$"])
@ -290,8 +290,8 @@ search_type_in_df <- function(x, type, info = TRUE) {
# this column should contain logicals
if (!is.logical(x[, found, drop = TRUE])) {
message_("Column '", font_bold(found), "' found as input for `col_", type,
"`, but this column does not contain 'logical' values (TRUE/FALSE) and was ignored.",
add_fn = font_red
"`, but this column does not contain 'logical' values (TRUE/FALSE) and was ignored.",
add_fn = font_red
)
found <- NULL
}
@ -345,16 +345,16 @@ stop_ifnot_installed <- function(package) {
# https://developer.r-project.org/Blog/public/2019/02/14/staged-install/index.html
vapply(FUN.VALUE = character(1), package, function(pkg) {
tryCatch(get(".packageName", envir = asNamespace(pkg)),
error = function(e) {
if (pkg == "rstudioapi") {
stop("This function only works in RStudio when using R >= 3.2.", call. = FALSE)
} else if (pkg != "base") {
stop("This requires the '", pkg, "' package.",
"\nTry to install it with: install.packages(\"", pkg, "\")",
call. = FALSE
)
}
}
error = function(e) {
if (pkg == "rstudioapi") {
stop("This function only works in RStudio when using R >= 3.2.", call. = FALSE)
} else if (pkg != "base") {
stop("This requires the '", pkg, "' package.",
"\nTry to install it with: install.packages(\"", pkg, "\")",
call. = FALSE
)
}
}
)
})
return(invisible())
@ -382,8 +382,8 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) {
error = function(e) {
if (isTRUE(error_on_fail)) {
stop_("function ", name, "() is not an exported object from package '", pkg,
"'. Please create an issue at https://github.com/msberends/AMR/issues. Many thanks!",
call = FALSE
"'. Please create an issue at https://github.com/msberends/AMR/issues. Many thanks!",
call = FALSE
)
} else {
return(NULL)
@ -430,13 +430,13 @@ word_wrap <- function(...,
msg_stripped <- font_stripstyle(msg)
# where are the spaces now?
msg_stripped_wrapped <- paste0(strwrap(msg_stripped,
simplify = TRUE,
width = width
simplify = TRUE,
width = width
),
collapse = "\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_wrapped_spaces <- which(unlist(strsplit(msg_stripped_wrapped, "", fixed = TRUE)) != "\n")
@ -486,8 +486,8 @@ message_ <- function(...,
add_fn = list(font_blue),
as_note = TRUE) {
message(word_wrap(...,
add_fn = add_fn,
as_note = as_note
add_fn = add_fn,
as_note = as_note
),
appendLF = appendLF
)
@ -498,8 +498,8 @@ warning_ <- function(...,
immediate = FALSE,
call = FALSE) {
warning(word_wrap(...,
add_fn = add_fn,
as_note = FALSE
add_fn = add_fn,
as_note = FALSE
),
immediate. = immediate,
call. = call
@ -738,7 +738,7 @@ meet_criteria <- function(object,
# if object is missing, or another error:
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)) {
error_txt <- pkg_env$meet_criteria_error_txt
@ -758,33 +758,33 @@ meet_criteria <- function(object,
if (!is.null(allow_class)) {
stop_ifnot(inherits(object, allow_class), "argument `", obj_name,
"` must be ", format_class(allow_class, plural = isTRUE(has_length > 1)),
", i.e. not be ", format_class(class(object), plural = isTRUE(has_length > 1)),
call = call_depth
"` must be ", format_class(allow_class, plural = isTRUE(has_length > 1)),
", i.e. not be ", format_class(class(object), plural = isTRUE(has_length > 1)),
call = call_depth
)
# check data.frames for data
if (inherits(object, "data.frame")) {
stop_if(any(dim(object) == 0),
"the data provided in argument `", obj_name,
"` must contain rows and columns (current dimensions: ",
paste(dim(object), collapse = "x"), ")",
call = call_depth
"the data provided in argument `", obj_name,
"` must contain rows and columns (current dimensions: ",
paste(dim(object), collapse = "x"), ")",
call = call_depth
)
}
}
if (!is.null(has_length)) {
stop_ifnot(length(object) %in% has_length, "argument `", obj_name,
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
"be of length ", vector_or(has_length, quotes = FALSE),
", not ", length(object),
call = call_depth
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
"be of length ", vector_or(has_length, quotes = FALSE),
", not ", length(object),
call = call_depth
)
}
if (!is.null(looks_like)) {
stop_ifnot(object %like% looks_like, "argument `", obj_name,
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
"resemble the regular expression \"", looks_like, "\"",
call = call_depth
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
"resemble the regular expression \"", looks_like, "\"",
call = call_depth
)
}
if (!is.null(is_in)) {
@ -793,44 +793,44 @@ meet_criteria <- function(object,
is_in <- tolower(is_in)
}
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,
"must be either ",
"must only contain values "
),
vector_or(is_in, quotes = !isTRUE(any(c("double", "numeric", "integer") %in% allow_class))),
ifelse(allow_NA == TRUE, ", or NA", ""),
call = call_depth
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"must be either ",
"must only contain values "
),
vector_or(is_in, quotes = !isTRUE(any(c("double", "numeric", "integer") %in% allow_class))),
ifelse(allow_NA == TRUE, ", or NA", ""),
call = call_depth
)
}
if (isTRUE(is_positive)) {
stop_if(is.numeric(object) && !all(object > 0, na.rm = TRUE), "argument `", obj_name,
"` must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"be a number higher than zero",
"all be numbers higher than zero"
),
call = call_depth
"` must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"be a number higher than zero",
"all be numbers higher than zero"
),
call = call_depth
)
}
if (isTRUE(is_positive_or_zero)) {
stop_if(is.numeric(object) && !all(object >= 0, na.rm = TRUE), "argument `", obj_name,
"` must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"be zero or a positive number",
"all be zero or numbers higher than zero"
),
call = call_depth
"` must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"be zero or a positive number",
"all be zero or numbers higher than zero"
),
call = call_depth
)
}
if (isTRUE(is_finite)) {
stop_if(is.numeric(object) && !all(is.finite(object[!is.na(object)]), na.rm = TRUE), "argument `", obj_name,
"` must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"be a finite number",
"all be finite numbers"
),
" (i.e. not be infinite)",
call = call_depth
"` must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"be a finite number",
"all be finite numbers"
),
" (i.e. not be infinite)",
call = call_depth
)
}
if (!is.null(contains_column_class)) {
@ -899,8 +899,8 @@ get_current_data <- function(arg_name, call) {
examples <- ""
}
stop_("this function must be used inside a `dplyr` verb or `data.frame` call",
examples,
call = call
examples,
call = call
)
} else {
# mimic a base R error that the argument is missing
@ -1306,8 +1306,8 @@ percentage <- function(x, digits = NULL, ...) {
function(y) ifelse(length(y) == 2, nchar(y[2]), 0)
)), na.rm = TRUE)
max(min(max_places,
maximum,
na.rm = TRUE
maximum,
na.rm = TRUE
),
minimum,
na.rm = TRUE
@ -1325,10 +1325,10 @@ percentage <- function(x, digits = NULL, ...) {
# 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,
digits = max(1, digits),
nsmall = digits,
...
scientific = FALSE,
digits = max(1, digits),
nsmall = digits,
...
)
x_formatted <- paste0(x_formatted, "%")
x_formatted[!grepl(pattern = "^[0-9.,e-]+$", x = x)] <- NA_character_
@ -1459,9 +1459,9 @@ if (getRversion() < "3.3.0") {
which <- match.arg(which)
mysub <- function(re, x) sub(re, "", x, perl = TRUE)
switch(which,
left = mysub(paste0("^", whitespace, "+"), x),
right = mysub(paste0(whitespace, "+$"), x),
both = mysub(paste0(whitespace, "+$"), mysub(paste0("^", whitespace, "+"), x))
left = mysub(paste0("^", whitespace, "+"), x),
right = 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 ------------------------------------------------------------
if (interactive()) {
usethis::ui_info("Documenting package")
suppressMessages(devtools::document(quiet = TRUE))
}
usethis::ui_info("Documenting package")
suppressMessages(devtools::document(quiet = TRUE))
# Style pkg ---------------------------------------------------------------

6
man/as.mo.Rd
View File

@ -16,9 +16,9 @@ as.mo(
Lancefield = FALSE,
minimum_matching_score = NULL,
allow_uncertain = TRUE,
keep_synonyms = FALSE,
keep_synonyms = getOption("AMR_keep_synonyms", TRUE),
reference_df = get_mo_source(),
ignore_pattern = getOption("AMR_ignore_pattern"),
ignore_pattern = getOption("AMR_ignore_pattern", NULL),
language = get_AMR_locale(),
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{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).}

220
man/mo_property.Rd
View File

@ -25,6 +25,7 @@
\alias{mo_authors}
\alias{mo_year}
\alias{mo_lpsn}
\alias{mo_gbif}
\alias{mo_rank}
\alias{mo_taxonomy}
\alias{mo_synonyms}
@ -32,68 +33,225 @@
\alias{mo_url}
\title{Get Properties of a Microorganism}
\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{
\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'}
@ -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}.
}
\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{
\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)