mirror of
https://github.com/msberends/AMR.git
synced 2025-07-09 13:42:04 +02:00
fixes2
This commit is contained in:
@ -1424,30 +1424,6 @@ case_when <- function(...) {
|
||||
out
|
||||
}
|
||||
|
||||
# adapted from https://github.com/nathaneastwood/poorman/blob/52eb6947e0b4430cd588976ed8820013eddf955f/R/where.R#L17-L32
|
||||
where <- function(fn) {
|
||||
if (!is.function(fn)) {
|
||||
stop_("`", deparse(substitute(fn)), "()` is not a valid predicate function.")
|
||||
}
|
||||
df <- pm_select_env$.data
|
||||
cols <- pm_select_env$get_colnames()
|
||||
if (is.null(df)) {
|
||||
df <- get_current_data("where", call = FALSE)
|
||||
cols <- colnames(df)
|
||||
}
|
||||
preds <- unlist(lapply(
|
||||
df,
|
||||
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 <- cols
|
||||
cols <- data_cols[preds]
|
||||
which(data_cols %in% cols)
|
||||
}
|
||||
|
||||
|
||||
# dplyr implementations ----
|
||||
|
||||
@ -1478,6 +1454,7 @@ if (pkg_is_available("dplyr", also_load = FALSE)) {
|
||||
ungroup <- import_fn("ungroup", "dplyr", error_on_fail = FALSE)
|
||||
mutate <- import_fn("mutate", "dplyr", error_on_fail = FALSE)
|
||||
bind_rows <- import_fn("bind_rows", "dplyr", error_on_fail = FALSE)
|
||||
where <- import_fn("where", "dplyr", error_on_fail = FALSE)
|
||||
} else {
|
||||
`%>%` <- `%pm>%`
|
||||
anti_join <- pm_anti_join
|
||||
@ -1523,6 +1500,29 @@ if (pkg_is_available("dplyr", also_load = FALSE)) {
|
||||
mat <- do.call(rbind, mat_list)
|
||||
as.data.frame(mat, stringsAsFactors = FALSE)
|
||||
}
|
||||
where <- function(fn) {
|
||||
# adapted from https://github.com/nathaneastwood/poorman/blob/52eb6947e0b4430cd588976ed8820013eddf955f/R/where.R#L17-L32
|
||||
if (!is.function(fn)) {
|
||||
stop_("`", deparse(substitute(fn)), "()` is not a valid predicate function.")
|
||||
}
|
||||
df <- pm_select_env$.data
|
||||
cols <- pm_select_env$get_colnames()
|
||||
if (is.null(df)) {
|
||||
df <- get_current_data("where", call = FALSE)
|
||||
cols <- colnames(df)
|
||||
}
|
||||
preds <- unlist(lapply(
|
||||
df,
|
||||
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 <- cols
|
||||
cols <- data_cols[preds]
|
||||
which(data_cols %in% cols)
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
|
@ -362,13 +362,13 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale
|
||||
}
|
||||
|
||||
if (is.data.frame(data)) {
|
||||
if (tryCatch(length(list(...)) > 0, error = function(e) TRUE)) {
|
||||
out <- tryCatch(suppressWarnings(unlist(list(...))), error = function(e) NULL)
|
||||
if (!is.null(out)) {
|
||||
df <- data[, out, drop = FALSE]
|
||||
} else {
|
||||
df <- select(data, ...)
|
||||
}
|
||||
if (tryCatch(length(c(...)) > 1, error = function(e) TRUE)) {
|
||||
df <- tryCatch(suppressWarnings(select(data, ...)),
|
||||
error = function(e) {
|
||||
data[, c(...), drop = FALSE]
|
||||
})
|
||||
} else if (tryCatch(is.character(c(...)), error = function(e) FALSE)) {
|
||||
df <- data[, c(...), drop = FALSE]
|
||||
} else {
|
||||
df <- data
|
||||
}
|
||||
|
Reference in New Issue
Block a user