mirror of https://github.com/msberends/AMR
You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
146 lines
6.2 KiB
146 lines
6.2 KiB
# ==================================================================== # |
|
# TITLE # |
|
# Antimicrobial Resistance (AMR) Data Analysis for R # |
|
# # |
|
# SOURCE # |
|
# https://github.com/msberends/AMR # |
|
# # |
|
# LICENCE # |
|
# (c) 2018-2022 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. # |
|
# # |
|
# This R package is free software; you can freely use and distribute # |
|
# it for both personal and commercial purposes under the terms of the # |
|
# GNU General Public License version 2.0 (GNU GPL-2), as published by # |
|
# the Free Software Foundation. # |
|
# We created this package for both routine data analysis and academic # |
|
# research and it was publicly released in the hope that it will be # |
|
# useful, but it comes WITHOUT ANY WARRANTY OR LIABILITY. # |
|
# # |
|
# Visit our website for the full manual and a complete tutorial about # |
|
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ # |
|
# ==================================================================== # |
|
|
|
#' Vectorised Pattern Matching with Keyboard Shortcut |
|
#' |
|
#' Convenient wrapper around [grepl()] 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 |
|
#' @param x a [character] vector where matches are sought, or an object which can be coerced by [as.character()] to a [character] vector. |
|
#' @param pattern a [character] vector containing regular expressions (or a [character] string for `fixed = TRUE`) to be matched in the given [character] vector. Coerced by [as.character()] to a [character] string if possible. |
|
#' @param ignore.case if `FALSE`, the pattern matching is *case sensitive* and if `TRUE`, case is ignored during matching. |
|
#' @return A [logical] vector |
|
#' @name like |
|
#' @rdname like |
|
#' @export |
|
#' @details |
|
#' These [like()] and `%like%`/`%unlike%` functions: |
|
#' * Are case-insensitive (use `%like_case%`/`%unlike_case%` for case-sensitive matching) |
|
#' * Support multiple patterns |
|
#' * Check if `pattern` is a valid regular expression and sets `fixed = TRUE` if not, to greatly improve speed (vectorised over `pattern`) |
|
#' * Always use compatibility with Perl unless `fixed = TRUE`, to greatly improve speed |
|
#' |
|
#' Using RStudio? The `%like%`/`%unlike%` functions can also be directly inserted in your code from the Addins menu and can have its own keyboard shortcut like `Shift+Ctrl+L` or `Shift+Cmd+L` (see menu `Tools` > `Modify Keyboard Shortcuts...`). If you keep pressing your shortcut, the inserted text will be iterated over `%like%` -> `%unlike%` -> `%like_case%` -> `%unlike_case%`. |
|
#' @source Idea from the [`like` function from the `data.table` package](https://github.com/Rdatatable/data.table/blob/ec1259af1bf13fc0c96a1d3f9e84d55d8106a9a4/R/like.R), although altered as explained in *Details*. |
|
#' @seealso [grepl()] |
|
#' @inheritSection AMR Read more on Our Website! |
|
#' @examples |
|
#' a <- "This is a test" |
|
#' b <- "TEST" |
|
#' a %like% b |
|
#' #> TRUE |
|
#' b %like% a |
|
#' #> FALSE |
|
#' |
|
#' # also supports multiple patterns |
|
#' a <- c("Test case", "Something different", "Yet another thing") |
|
#' b <- c( "case", "diff", "yet") |
|
#' a %like% b |
|
#' #> TRUE TRUE TRUE |
|
#' a %unlike% b |
|
#' #> FALSE FALSE FALSE |
|
#' |
|
#' a[1] %like% b |
|
#' #> TRUE FALSE FALSE |
|
#' a %like% b[1] |
|
#' #> TRUE FALSE FALSE |
|
#' |
|
#' # get isolates whose name start with 'Ent' or 'ent' |
|
#' example_isolates[which(mo_name(example_isolates$mo) %like% "^ent"), ] |
|
#' \donttest{ |
|
#' # faster way, since mo_name() is context-aware: |
|
#' example_isolates[which(mo_name() %like% "^ent"), ] |
|
#' |
|
#' if (require("dplyr")) { |
|
#' example_isolates %>% |
|
#' filter(mo_name() %like% "^ent") |
|
#' } |
|
#' } |
|
like <- function(x, pattern, ignore.case = TRUE) { |
|
meet_criteria(x, allow_NA = TRUE) |
|
meet_criteria(pattern, allow_NA = FALSE) |
|
meet_criteria(ignore.case, allow_class = "logical", has_length = 1) |
|
|
|
if (all(is.na(x))) { |
|
return(rep(FALSE, length(x))) |
|
} |
|
|
|
# set to fixed if no valid regex (vectorised) |
|
fixed <- !is_valid_regex(pattern) |
|
|
|
if (ignore.case == TRUE) { |
|
# set here, otherwise if fixed = TRUE, this warning will be thrown: argument `ignore.case = TRUE` will be ignored |
|
x <- tolower(x) |
|
pattern <- tolower(pattern) |
|
} |
|
|
|
if (is.factor(x)) { |
|
x <- as.character(x) |
|
} |
|
|
|
if (length(pattern) == 1) { |
|
grepl(pattern, x, ignore.case = FALSE, fixed = fixed, perl = !fixed) |
|
} else { |
|
if (length(x) == 1) { |
|
x <- rep(x, length(pattern)) |
|
} else if (length(pattern) != length(x)) { |
|
stop_("arguments `x` and `pattern` must be of same length, or either one must be 1 ", |
|
"(`x` has length ", length(x), " and `pattern` has length ", length(pattern), ")") |
|
} |
|
unlist( |
|
mapply(FUN = grepl, |
|
x = x, |
|
pattern = pattern, |
|
fixed = fixed, |
|
perl = !fixed, |
|
MoreArgs = list(ignore.case = FALSE), |
|
SIMPLIFY = FALSE, |
|
USE.NAMES = FALSE) |
|
) |
|
} |
|
} |
|
|
|
#' @rdname like |
|
#' @export |
|
"%like%" <- function(x, pattern) { |
|
like(x, pattern, ignore.case = TRUE) |
|
} |
|
|
|
#' @rdname like |
|
#' @export |
|
"%unlike%" <- function(x, pattern) { |
|
!like(x, pattern, ignore.case = TRUE) |
|
} |
|
|
|
#' @rdname like |
|
#' @export |
|
"%like_case%" <- function(x, pattern) { |
|
like(x, pattern, ignore.case = FALSE) |
|
} |
|
|
|
#' @rdname like |
|
#' @export |
|
"%unlike_case%" <- function(x, pattern) { |
|
!like(x, pattern, ignore.case = FALSE) |
|
}
|
|
|