(v1.7.1.9058) vars selection for set_ab_names()

R/aa_helper_functions.R

@@ -53,6 +53,25 @@ pm_left_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
   merged
 }
 
+# support where() like tidyverse:
+# adapted from https://github.com/nathaneastwood/poorman/blob/52eb6947e0b4430cd588976ed8820013eddf955f/R/where.R#L17-L32
+where <- function(fn) {
+  if (!is.function(fn)) {
+    stop(deparse_var(fn), " is not a valid predicate function.")
+  }
+  preds <- unlist(lapply(
+    pm_select_env$.data,
+    function(x, fn) {
+      do.call("fn", list(x))
+    },
+    fn
+  ))
+  if (!is.logical(preds)) stop("`where()` must be used with functions that return `TRUE` or `FALSE`.")
+  data_cols <- pm_select_env$get_colnames()
+  cols <- data_cols[preds]
+  which(data_cols %in% cols)
+}
+
 # copied and slightly rewritten from poorman under same license (2021-10-15)
 quick_case_when <- function (...) {
   fs <- list(...)

R/ab_property.R

@@ -33,7 +33,7 @@
 #' @param language language of the returned text, defaults to system language (see [get_locale()]) and can also be set with `getOption("AMR_locale")`. Use `language = NULL` or `language = ""` to prevent translation.
 #' @param administration way of administration, either `"oral"` or `"iv"`
 #' @param open browse the URL using [utils::browseURL()]
-#' @param ... other arguments passed on to [as.ab()]
+#' @param ... in case of [set_ab_names()] and `data` is a [data.frame]: variables to select (supports tidy selection like `AMX:VAN`), otherwise other arguments passed on to [as.ab()]
 #' @param data a [data.frame] of which the columns need to be renamed, or a [character] vector of column names
 #' @param snake_case a [logical] to indicate whether the names should be in so-called [snake case](https://en.wikipedia.org/wiki/Snake_case): in lower case and all spaces/slashes replaced with an underscore (`_`)
 #' @param only_first a [logical] to indicate whether only the first ATC code must be returned, with giving preference to J0-codes (i.e., the antimicrobial drug group)
@@ -97,6 +97,7 @@
 #' # use set_ab_names() for renaming columns
 #' colnames(example_isolates)
 #' colnames(set_ab_names(example_isolates))
+#' colnames(set_ab_names(example_isolates, NIT:VAN))
 #' \donttest{
 #' if (require("dplyr")) {
 #'   example_isolates %>%
@@ -109,6 +110,14 @@
 #'   # set_ab_names() works with any AB property:
 #'   example_isolates %>%
 #'     set_ab_names("atc")
+#'     
+#'  example_isolates %>%
+#'    set_ab_names(where(is.rsi)) %>%
+#'    colnames()
+#'    
+#'  example_isolates %>%
+#'    set_ab_names(NIT:VAN) %>%
+#'    colnames()
 #' }
 #' }
 ab_name <- function(x, language = get_locale(), tolower = FALSE, ...) {
@@ -328,7 +337,7 @@ ab_property <- function(x, property = "name", language = get_locale(), ...) {
 #' @rdname ab_property
 #' @aliases ATC
 #' @export
-set_ab_names <- function(data, property = "name", language = get_locale(), snake_case = NULL) {
+set_ab_names <- function(data, ..., property = "name", language = get_locale(), snake_case = NULL) {
   meet_criteria(data, allow_class = c("data.frame", "character"))
   meet_criteria(property, is_in = colnames(antibiotics), has_length = 1, ignore.case = TRUE)
   meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
@@ -345,7 +354,8 @@ set_ab_names <- function(data, property = "name", language = get_locale(), snake
   }
   
   if (is.data.frame(data)) {
-    vars <- get_column_abx(data, info = FALSE, only_rsi_columns = FALSE, sort = FALSE)
+    df <- pm_select(data, ...)
+    vars <- get_column_abx(df, info = FALSE, only_rsi_columns = FALSE, sort = FALSE)
     if (length(vars) == 0) {
       message_("No columns with antibiotic results found for `set_ab_names()`, leaving names unchanged.")
       return(data)

R/lifecycle.R

@@ -44,7 +44,7 @@
 #' \if{html}{\figure{lifecycle_stable.svg}{options: style=margin-bottom:5px} \cr}
 #' The [lifecycle][AMR::lifecycle] of this function is **stable**. In a stable function, major changes are unlikely. This means that the unlying code will generally evolve by adding new arguments; removing arguments or changing the meaning of existing arguments will be avoided.
 #' 
-#' If the unlying code needs breaking changes, they will occur gradually. For example, a argument will be deprecated and first continue to work, but will emit an message informing you of the change. Next, typically after at least one newly released version on CRAN, the message will be transformed to an error.
+#' If the unlying code needs breaking changes, they will occur gradually. For example, an argument will be deprecated and first continue to work, but will emit an message informing you of the change. Next, typically after at least one newly released version on CRAN, the message will be transformed to an error.
 #' @section Retired Lifecycle:
 #' \if{html}{\figure{lifecycle_retired.svg}{options: style=margin-bottom:5px} \cr}
 #' The [lifecycle][AMR::lifecycle] of this function is **retired**. A retired function is no longer under active development, and (if appropiate) a better alternative is available. No new arguments will be added, and only the most critical bugs will be fixed. In a future version, this function will be removed.

R/pca.R

@@ -90,7 +90,7 @@ pca <- function(x,
           # this is to support quoted variables: df %pm>% pca("mycol1", "mycol2")
           new_list[[i]] <- x[, new_list[[i]]]
         } else {
-          # remove item - it's a argument like `center`
+          # remove item - it's an argument like `center`
           new_list[[i]] <- NULL
         }
       }