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

pm fixes

This commit is contained in:
dr. M.S. (Matthijs) Berends 2023-02-08 16:51:41 +01:00
parent 822e9de82c
commit aa48c6bf53
11 changed files with 211 additions and 186 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 Package: AMR
Version: 1.8.2.9110 Version: 1.8.2.9111
Date: 2023-02-08 Date: 2023-02-08
Title: Antimicrobial Resistance Data Analysis Title: Antimicrobial Resistance Data Analysis
Description: Functions to simplify and standardise antimicrobial resistance (AMR) Description: Functions to simplify and standardise antimicrobial resistance (AMR)

2
NEWS.md
View File

@ -1,4 +1,4 @@
# AMR 1.8.2.9110 # AMR 1.8.2.9111
*(this beta version will eventually become v2.0! We're happy to reach a new major milestone soon!)* *(this beta version will eventually become v2.0! We're happy to reach a new major milestone soon!)*

342
R/aa_helper_pm_functions.R
View File

@ -59,7 +59,7 @@ pm_across <- function(.cols = everything(), .fns = NULL, ..., .names = NULL) {
.col <- setup$cols[i] .col <- setup$cols[i]
for (j in seq_along(fn_names)) { for (j in seq_along(fn_names)) {
.fn <- fn_names[j] .fn <- fn_names[j]
setup$names[id] <- gluestick(ref) setup$names[id] <- pm_gluestick(ref)
id <- id + 1 id <- id + 1
} }
} }
@ -75,7 +75,7 @@ pm_across <- function(.cols = everything(), .fns = NULL, ..., .names = NULL) {
if (is.null(names)) { if (is.null(names)) {
return(data) return(data)
} else { } else {
return(setNames(data, names)) return(stats::setNames(data, names))
} }
} }
n_fns <- length(funs) n_fns <- length(funs)
@ -95,13 +95,13 @@ pm_across <- function(.cols = everything(), .fns = NULL, ..., .names = NULL) {
pm_if_any <- function(.cols, .fns = NULL, ..., .names = NULL) { pm_if_any <- function(.cols, .fns = NULL, ..., .names = NULL) {
df <- do.call(across, list(.cols = substitute(.cols), .fns = .fns, ..., .names = .names)) df <- do.call(across, list(.cols = substitute(.cols), .fns = .fns, ..., .names = .names))
if (nrow(df) == 0L) return(FALSE) if (nrow(df) == 0L) return(FALSE)
check_if_types(df) pm_check_if_types(df)
Reduce(`|`, df) Reduce(`|`, df)
} }
pm_if_all <- function(.cols, .fns = NULL, ..., .names = NULL) { pm_if_all <- function(.cols, .fns = NULL, ..., .names = NULL) {
df <- do.call(across, list(.cols = substitute(.cols), .fns = .fns, ..., .names = .names)) df <- do.call(across, list(.cols = substitute(.cols), .fns = .fns, ..., .names = .names))
if (nrow(df) == 0L) return(FALSE) if (nrow(df) == 0L) return(FALSE)
check_if_types(df) pm_check_if_types(df)
Reduce(`&`, df) Reduce(`&`, df)
} }
pm_check_if_types <- function(df) { pm_check_if_types <- function(df) {
@ -127,7 +127,7 @@ pm_setup_across <- function(.cols, .fns, .names) {
names(funs)[miss] <- miss names(funs)[miss] <- miss
f_nms <- names(funs) f_nms <- names(funs)
} }
funs <- lapply(funs, as_function) funs <- lapply(funs, pm_as_function)
names <- if (!is.null(.names)) { names <- if (!is.null(.names)) {
.names .names
} else { } else {
@ -147,7 +147,7 @@ pm_arrange <- function(.data, ...) {
pm_arrange.data.frame <- function(.data, ..., .by_group = FALSE) { pm_arrange.data.frame <- function(.data, ..., .by_group = FALSE) {
dots <- pm_dotdotdot(...) dots <- pm_dotdotdot(...)
is_grouped <- pm_has_groups(.data) is_grouped <- pm_has_groups(.data)
if (isTRUE(.by_group)) dots <- c(groups(.data), dots) if (isTRUE(.by_group)) dots <- c(pm_groups(.data), dots)
rows <- pm_arrange_rows(.data = .data, dots) rows <- pm_arrange_rows(.data = .data, dots)
row_number <- attr(.data, "row.names") row_number <- attr(.data, "row.names")
out <- .data[rows, , drop = FALSE] out <- .data[rows, , drop = FALSE]
@ -155,7 +155,7 @@ pm_arrange.data.frame <- function(.data, ..., .by_group = FALSE) {
row.names(out) <- row_number row.names(out) <- row_number
} }
if (is_grouped) { if (is_grouped) {
attr(out, "groups") <- pm_calculate_groups(out, pm_group_vars(out)) attr(out, "pm_groups") <- pm_calculate_groups(out, pm_group_vars(out))
} }
out out
} }
@ -186,20 +186,20 @@ pm_arrange_rows <- function(.data, dots) {
} }
pm_bind_cols <- function(...) { pm_bind_cols <- function(...) {
lsts <- list(...) lsts <- list(...)
lsts <- squash(lsts) lsts <- pm_squash(lsts)
lsts <- Filter(Negate(is.null), lsts) lsts <- Filter(Negate(is.null), lsts)
if (length(lsts) == 0L) return(data.frame()) if (length(lsts) == 0L) return(data.frame())
lapply(lsts, function(x) is_df_or_vector(x)) lapply(lsts, function(x) pm_is_df_or_vector(x))
lsts <- do.call(cbind, lsts) lsts <- do.call(cbind, lsts)
if (!is.data.frame(lsts)) lsts <- as.data.frame(lsts) if (!is.data.frame(lsts)) lsts <- as.data.frame(lsts)
lsts lsts
} }
pm_bind_rows <- function(..., .id = NULL) { pm_bind_rows <- function(..., .id = NULL) {
lsts <- list(...) lsts <- list(...)
lsts <- flatten(lsts) lsts <- pm_flatten(lsts)
lsts <- Filter(Negate(is.null), lsts) lsts <- Filter(Negate(is.null), lsts)
lapply(lsts, function(x) is_df_or_vector(x)) lapply(lsts, function(x) pm_is_df_or_vector(x))
lapply(lsts, function(x) if (is.atomic(x) && !is_named(x)) stop("Vectors must be named.")) lapply(lsts, function(x) if (is.atomic(x) && !pm_is_named(x)) stop("Vectors must be named."))
if (!missing(.id)) { if (!missing(.id)) {
lsts <- lapply(seq_along(lsts), function(i) { lsts <- lapply(seq_along(lsts), function(i) {
nms <- names(lsts) nms <- names(lsts)
@ -233,11 +233,11 @@ pm_case_when <- function(...) {
value[[i]] <- eval(fs[[i]][[3]], envir = default_env) value[[i]] <- eval(fs[[i]][[3]], envir = default_env)
if (!is.logical(query[[i]])) stop(fs[[i]][[2]], " does not return a `logical` vector.") if (!is.logical(query[[i]])) stop(fs[[i]][[2]], " does not return a `logical` vector.")
} }
m <- validate_case_when_length(query, value, fs) m <- pm_validate_case_when_length(query, value, fs)
out <- value[[1]][rep(NA_integer_, m)] out <- value[[1]][rep(NA_integer_, m)]
replaced <- rep(FALSE, m) replaced <- rep(FALSE, m)
for (i in seq_len(n)) { for (i in seq_len(n)) {
out <- replace_with(out, query[[i]] & !replaced, value[[i]], NULL) out <- pm_replace_with(out, query[[i]] & !replaced, value[[i]], NULL)
replaced <- replaced | (query[[i]] & !is.na(query[[i]])) replaced <- replaced | (query[[i]] & !is.na(query[[i]]))
} }
out out
@ -283,80 +283,80 @@ pm_context$clean <- function() {
if (!is.null(pm_context$cur_column)) rm(list = c("cur_column"), envir = pm_context) if (!is.null(pm_context$cur_column)) rm(list = c("cur_column"), envir = pm_context)
} }
pm_n <- function() { pm_n <- function() {
check_pm_context("`n()`", pm_context$.data) pm_check_context("`n()`", pm_context$.data)
pm_context$get_nrow() pm_context$get_nrow()
} }
pm_cur_data <- function() { pm_cur_data <- function() {
check_pm_context("`cur_data()`", pm_context$.data) pm_check_context("`cur_data()`", pm_context$.data)
data <- pm_context$get_data() data <- pm_context$get_data()
data[, !(colnames(data) %in% pm_group_vars(data)), drop = FALSE] data[, !(colnames(data) %in% pm_group_vars(data)), drop = FALSE]
} }
pm_cur_data_all <- function() { pm_cur_data_all <- function() {
check_pm_context("`cur_data_all()`", pm_context$.data) pm_check_context("`cur_data_all()`", pm_context$.data)
pm_ungroup(pm_context$get_data()) pm_ungroup(pm_context$get_data())
} }
pm_cur_group <- function() { pm_cur_group <- function() {
check_pm_context("`cur_group()`", pm_context$.data) pm_check_context("`cur_group()`", pm_context$.data)
data <- pm_context$get_data() data <- pm_context$get_data()
res <- data[1L, pm_group_vars(data), drop = FALSE] res <- data[1L, pm_group_vars(data), drop = FALSE]
rownames(res) <- NULL rownames(res) <- NULL
res res
} }
pm_cur_pm_group_id <- function() { pm_cur_group_id <- function() {
check_pm_context("`cur_pm_group_id()`", pm_context$.data) pm_check_context("`cur_group_id()`", pm_context$.data)
data <- pm_context$get_data() data <- pm_context$get_data()
res <- data[1L, pm_group_vars(data), drop = FALSE] res <- data[1L, pm_group_vars(data), drop = FALSE]
details <- get_pm_group_details(data) details <- pm_get_group_details(data)
details[, ".pm_group_id"] <- seq_len(nrow(details)) details[, ".pm_group_id"] <- seq_len(nrow(details))
res <- suppressMessages(semi_join(details, res)) res <- suppressMessages(semi_join(details, res))
res[, ".pm_group_id"] res[, ".pm_group_id"]
} }
pm_cur_pm_group_rows <- function() { pm_cur_group_rows <- function() {
check_pm_context("`cur_pm_group_rows()`", pm_context$.data) pm_check_context("`cur_group_rows()`", pm_context$.data)
data <- pm_context$get_data() data <- pm_context$get_data()
res <- data[1L, pm_group_vars(data), drop = FALSE] res <- data[1L, pm_group_vars(data), drop = FALSE]
res <- suppressMessages(semi_join(get_pm_group_details(data), res)) res <- suppressMessages(semi_join(pm_get_group_details(data), res))
unlist(res[, ".rows"]) unlist(res[, ".rows"])
} }
pm_cur_column <- function() { pm_cur_column <- function() {
check_pm_context("`cur_column()`", pm_context$cur_column, "`across`") pm_check_context("`cur_column()`", pm_context$cur_column, "`across`")
pm_context$cur_column pm_context$cur_column
} }
pm_check_pm_context <- function(fn, pm_context, name = NULL) { pm_check_context <- function(fn, pm_context, name = NULL) {
if (is.null(pm_context)) { if (is.null(pm_context)) {
stop(fn, " must only be used inside ", if (is.null(name)) "poorman verbs" else name) stop(fn, " must only be used inside ", if (is.null(name)) "poorman verbs" else name)
} }
} }
pm_count <- function(x, ..., wt = NULL, sort = FALSE, name = NULL) { pm_count <- function(x, ..., wt = NULL, sort = FALSE, name = NULL) {
groups <- pm_group_vars(x) pm_groups <- pm_group_vars(x)
if (!missing(...)) x <- pm_group_by(x, ..., .add = TRUE) if (!missing(...)) x <- pm_group_by(x, ..., .add = TRUE)
wt <- pm_deparse_var(wt) wt <- pm_deparse_var(wt)
res <- do.call(tally, list(x, wt, sort, name)) res <- do.call(pm_tally, list(x, wt, sort, name))
if (length(groups) > 0L) res <- do.call(pm_group_by, list(res, as.name(groups))) if (length(pm_groups) > 0L) res <- do.call(pm_group_by, list(res, as.name(pm_groups)))
res res
} }
pm_tally <- function(x, wt = NULL, sort = FALSE, name = NULL) { pm_tally <- function(x, wt = NULL, sort = FALSE, name = NULL) {
name <- check_name(x, name) name <- pm_check_name(x, name)
wt <- pm_deparse_var(wt) wt <- pm_deparse_var(wt)
res <- do.call(pm_summarise, setNames(list(x, tally_n(x, wt)), c(".data", name))) res <- do.call(pm_summarise, stats::setNames(list(x, pm_tally_n(x, wt)), c(".data", name)))
res <- pm_ungroup(res) res <- pm_ungroup(res)
if (isTRUE(sort)) res <- do.call(pm_arrange, list(res, call("desc", as.name(name)))) if (isTRUE(sort)) res <- do.call(pm_arrange, list(res, call("desc", as.name(name))))
rownames(res) <- NULL rownames(res) <- NULL
res res
} }
pm_add_count <- function(x, ..., wt = NULL, sort = FALSE, name = NULL) { pm_add_count <- function(x, ..., wt = NULL, sort = FALSE, name = NULL) {
name <- check_name(x, name) name <- pm_check_name(x, name)
row_names <- rownames(x) row_names <- rownames(x)
wt <- pm_deparse_var(wt) wt <- pm_deparse_var(wt)
if (!missing(...)) x <- pm_group_by(x, ..., .add = TRUE) if (!missing(...)) x <- pm_group_by(x, ..., .add = TRUE)
res <- do.call(add_tally, list(x, wt, sort, name)) res <- do.call(pm_add_tally, list(x, wt, sort, name))
res[row_names, ] res[row_names, ]
} }
pm_add_tally <- function(x, wt = NULL, sort = FALSE, name = NULL) { pm_add_tally <- function(x, wt = NULL, sort = FALSE, name = NULL) {
wt <- pm_deparse_var(wt) wt <- pm_deparse_var(wt)
n <- tally_n(x, wt) n <- pm_tally_n(x, wt)
name <- check_name(x, name) name <- pm_check_name(x, name)
res <- do.call(pm_mutate, setNames(list(x, n), c(".data", name))) res <- do.call(pm_mutate, stats::setNames(list(x, n), c(".data", name)))
if (isTRUE(sort)) { if (isTRUE(sort)) {
do.call(pm_arrange, list(res, call("desc", as.name(name)))) do.call(pm_arrange, list(res, call("desc", as.name(name))))
} else { } else {
@ -456,7 +456,7 @@ pm_filter <- function(.data, ..., .preserve = FALSE) {
pm_filter.data.frame <- function(.data, ..., .preserve = FALSE) { pm_filter.data.frame <- function(.data, ..., .preserve = FALSE) {
conditions <- pm_dotdotdot(...) conditions <- pm_dotdotdot(...)
if (length(conditions) == 0L) return(.data) if (length(conditions) == 0L) return(.data)
check_filter(conditions) pm_check_filter(conditions)
cond_class <- vapply(conditions, typeof, NA_character_) cond_class <- vapply(conditions, typeof, NA_character_)
cond_class <- cond_class[!cond_class %in% c("language", "logical")] cond_class <- cond_class[!cond_class %in% c("language", "logical")]
if (length(cond_class) > 0L) stop("Conditions must be logical vectors") if (length(cond_class) > 0L) stop("Conditions must be logical vectors")
@ -476,22 +476,22 @@ pm_filter.grouped_df <- function(.data, ..., .preserve = FALSE) {
rows <- rownames(.data) rows <- rownames(.data)
res <- pm_apply_grouped_function("pm_filter", .data, drop = TRUE, ...) res <- pm_apply_grouped_function("pm_filter", .data, drop = TRUE, ...)
res <- res[rows[rows %in% rownames(res)], ] res <- res[rows[rows %in% rownames(res)], ]
groups <- pm_group_vars(.data) pm_groups <- pm_group_vars(.data)
pre_filtered_groups <- pm_group_data(.data) pre_filtered_groups <- pm_group_data(.data)
post_filtered_groups <- pm_calculate_groups(res, groups) post_filtered_groups <- pm_calculate_groups(res, pm_groups)
if (!(!.preserve && isTRUE(attr(pre_filtered_groups, ".drop")))) { if (!(!.preserve && isTRUE(attr(pre_filtered_groups, ".drop")))) {
filtered_groups <- anti_join(pre_filtered_groups, post_filtered_groups, by = groups) filtered_groups <- anti_join(pre_filtered_groups, post_filtered_groups, by = pm_groups)
filtered_groups <- filtered_groups[, groups, drop = FALSE] filtered_groups <- filtered_groups[, pm_groups, drop = FALSE]
filtered_groups[[".rows"]] <- rep(list(integer()), length.out = nrow(filtered_groups)) filtered_groups[[".rows"]] <- rep(list(integer()), length.out = nrow(filtered_groups))
post_filtered_groups <- bind_rows(post_filtered_groups, filtered_groups) post_filtered_groups <- bind_rows(post_filtered_groups, filtered_groups)
ordered <- do.call(pm_arrange_rows, list(post_filtered_groups, pm_as_symbols(groups))) ordered <- do.call(pm_arrange_rows, list(post_filtered_groups, pm_as_symbols(pm_groups)))
post_filtered_groups <- post_filtered_groups[ordered, ] post_filtered_groups <- post_filtered_groups[ordered, ]
} }
attr(res, "groups") <- post_filtered_groups attr(res, "pm_groups") <- post_filtered_groups
res res
} }
pm_check_filter <- function(conditions) { pm_check_filter <- function(conditions) {
named <- have_name(conditions) named <- pm_have_name(conditions)
for (i in which(named)) { for (i in which(named)) {
if (!is.logical(conditions[[i]])) { if (!is.logical(conditions[[i]])) {
stop( stop(
@ -503,6 +503,34 @@ pm_check_filter <- function(conditions) {
} }
} }
} }
pm_gluestick <- function(fmt, src = parent.frame(), open = "{", close = "}", eval = TRUE) {
nchar_open <- nchar(open)
nchar_close <- nchar(close)
stopifnot(exprs = {
is.character(fmt)
length(fmt) == 1L
is.character(open)
length(open) == 1L
nchar_open > 0L
is.character(close)
length(close) == 1
nchar_close > 0
})
open <- gsub("(.)", "\\\\\\1", open)
close <- gsub("(.)", "\\\\\\1", close)
re <- paste0(open, ".*?", close)
matches <- gregexpr(re, fmt)
exprs <- regmatches(fmt, matches)[[1]]
exprs <- substr(exprs, nchar_open + 1L, nchar(exprs) - nchar_close)
fmt_sprintf <- gsub(re, "%s", fmt)
fmt_sprintf <- gsub("%(?!s)", "%%", fmt_sprintf, perl = TRUE)
args <- if (eval) {
lapply(exprs, function(expr) eval(parse(text = expr), envir = src))
} else {
unname(mget(exprs, envir = as.environment(src)))
}
do.call(sprintf, c(list(fmt_sprintf), args))
}
pm_group_by <- function(.data, ..., .add = FALSE, .drop = pm_group_by_drop_default(.data)) { pm_group_by <- function(.data, ..., .add = FALSE, .drop = pm_group_by_drop_default(.data)) {
pm_group_by.data.frame(.data, ..., .add = FALSE, .drop = pm_group_by_drop_default(.data)) pm_group_by.data.frame(.data, ..., .add = FALSE, .drop = pm_group_by_drop_default(.data))
} }
@ -515,12 +543,12 @@ pm_group_by.data.frame <- function(.data, ..., .add = FALSE, .drop = pm_group_by
} }
new_cols <- pm_add_group_columns(.data, vars) new_cols <- pm_add_group_columns(.data, vars)
res <- new_cols$data res <- new_cols$data
groups <- new_cols$groups pm_groups <- new_cols$pm_groups
if (isTRUE(.add)) groups <- union(pm_group_vars(.data), groups) if (isTRUE(.add)) pm_groups <- union(pm_group_vars(.data), pm_groups)
unknown <- !(groups %in% colnames(res)) unknown <- !(pm_groups %in% colnames(res))
if (any(unknown)) stop("Invalid groups: ", groups[unknown]) if (any(unknown)) stop("Invalid pm_groups: ", pm_groups[unknown])
if (length(groups) > 0L) { if (length(pm_groups) > 0L) {
res <- pm_groups_set(res, groups, .drop) res <- pm_groups_set(res, pm_groups, .drop)
class(res) <- union("grouped_df", class(res)) class(res) <- union("grouped_df", class(res))
} }
res res
@ -546,7 +574,7 @@ pm_add_group_columns <- function(.data, vars) {
if (!is.null(needs_mutate)) { if (!is.null(needs_mutate)) {
.data <- do.call(pm_mutate, c(list(.data = pm_ungroup(.data)), vars[needs_mutate])) .data <- do.call(pm_mutate, c(list(.data = pm_ungroup(.data)), vars[needs_mutate]))
} }
list(data = .data, groups = names(vars)) list(data = .data, pm_groups = names(vars))
} }
pm_group_data <- function(.data) { pm_group_data <- function(.data) {
if ("grouped_df" %in% class(.data)) pm_group_data.grouped_df(.data) else pm_group_data.data.frame(.data) if ("grouped_df" %in% class(.data)) pm_group_data.grouped_df(.data) else pm_group_data.data.frame(.data)
@ -555,27 +583,27 @@ pm_group_data.data.frame <- function(.data) {
structure(list(.rows = list(seq_len(nrow(.data)))), class = "data.frame", row.names = c(NA, -1L)) structure(list(.rows = list(seq_len(nrow(.data)))), class = "data.frame", row.names = c(NA, -1L))
} }
pm_group_data.grouped_df <- function(.data) { pm_group_data.grouped_df <- function(.data) {
attr(.data, "groups") attr(.data, "pm_groups")
} }
pm_group_rows <- function(.data) { pm_group_rows <- function(.data) {
pm_group_data(.data)[[".rows"]] pm_group_data(.data)[[".rows"]]
} }
pm_group_indices <- function(.data) { pm_group_indices <- function(.data) {
if (!pm_has_groups(.data)) return(rep(1L, nrow(.data))) if (!pm_has_groups(.data)) return(rep(1L, nrow(.data)))
groups <- pm_group_vars(.data) pm_groups <- pm_group_vars(.data)
res <- unique(.data[, groups, drop = FALSE]) res <- unique(.data[, pm_groups, drop = FALSE])
res <- res[do.call(order, lapply(groups, function(x) res[, x])), , drop = FALSE] res <- res[do.call(order, lapply(pm_groups, function(x) res[, x])), , drop = FALSE]
class(res) <- "data.frame" class(res) <- "data.frame"
nrow_data <- nrow(.data) nrow_data <- nrow(.data)
rows <- rep(NA, nrow_data) rows <- rep(NA, nrow_data)
for (i in seq_len(nrow_data)) { for (i in seq_len(nrow_data)) {
rows[i] <- which(interaction(res[, groups]) %in% interaction(.data[i, groups])) rows[i] <- which(interaction(res[, pm_groups]) %in% interaction(.data[i, pm_groups]))
} }
rows rows
} }
pm_group_vars <- function(x) { pm_group_vars <- function(x) {
groups <- attr(x, "groups", exact = TRUE) pm_groups <- attr(x, "pm_groups", exact = TRUE)
if (is.null(groups)) character(0) else colnames(groups)[!colnames(groups) %in% c(".pm_group_id", ".rows")] if (is.null(pm_groups)) character(0) else colnames(pm_groups)[!colnames(pm_groups) %in% c(".pm_group_id", ".rows")]
} }
pm_groups <- function(x) { pm_groups <- function(x) {
pm_as_symbols(pm_group_vars(x)) pm_as_symbols(pm_group_vars(x))
@ -599,71 +627,71 @@ pm_group_split <- function(.data, ..., .keep = TRUE) {
} }
pm_context$setup(.data) pm_context$setup(.data)
on.exit(pm_context$clean(), add = TRUE) on.exit(pm_context$clean(), add = TRUE)
groups <- pm_group_vars(.data) pm_groups <- pm_group_vars(.data)
attr(pm_context$.data, "groups") <- NULL attr(pm_context$.data, "pm_groups") <- NULL
res <- pm_split_into_groups(pm_context$.data, groups) res <- pm_split_into_groups(pm_context$.data, pm_groups)
names(res) <- NULL names(res) <- NULL
if (!isTRUE(.keep)) { if (!isTRUE(.keep)) {
res <- lapply(res, function(x) x[, !colnames(x) %in% groups]) res <- lapply(res, function(x) x[, !colnames(x) %in% pm_groups])
} }
any_empty <- unlist(lapply(res, function(x) !(nrow(x) == 0L))) any_empty <- unlist(lapply(res, function(x) !(nrow(x) == 0L)))
res[any_empty] res[any_empty]
} }
pm_group_keys <- function(.data) { pm_group_keys <- function(.data) {
groups <- pm_group_vars(.data) pm_groups <- pm_group_vars(.data)
pm_context$setup(.data) pm_context$setup(.data)
res <- pm_context$get_columns(pm_context$get_colnames() %in% groups) res <- pm_context$get_columns(pm_context$get_colnames() %in% pm_groups)
res <- res[!duplicated(res), , drop = FALSE] res <- res[!duplicated(res), , drop = FALSE]
if (nrow(res) == 0L) return(res) if (nrow(res) == 0L) return(res)
class(res) <- "data.frame" class(res) <- "data.frame"
res <- res[do.call(order, lapply(groups, function(x) res[, x])), , drop = FALSE] res <- res[do.call(order, lapply(pm_groups, function(x) res[, x])), , drop = FALSE]
rownames(res) <- NULL rownames(res) <- NULL
res res
} }
pm_split_into_groups <- function(.data, groups, drop = FALSE, ...) { pm_split_into_groups <- function(.data, pm_groups, drop = FALSE, ...) {
class(.data) <- "data.frame" class(.data) <- "data.frame"
pm_group_factors <- lapply(groups, function(x, .data) as.factor(.data[, x]), .data) pm_group_factors <- lapply(pm_groups, function(x, .data) as.factor(.data[, x]), .data)
split(x = .data, f = pm_group_factors, drop = drop, ...) split(x = .data, f = pm_group_factors, drop = drop, ...)
} }
pm_groups_set <- function(x, groups, drop = pm_group_by_drop_default(x)) { pm_groups_set <- function(x, pm_groups, drop = pm_group_by_drop_default(x)) {
attr(x, "groups") <- if (is.null(groups) || length(groups) == 0L) { attr(x, "pm_groups") <- if (is.null(pm_groups) || length(pm_groups) == 0L) {
NULL NULL
} else { } else {
pm_calculate_groups(x, groups, drop) pm_calculate_groups(x, pm_groups, drop)
} }
x x
} }
pm_get_pm_group_details <- function(x) { pm_get_group_details <- function(x) {
groups <- attr(x, "groups", exact = TRUE) pm_groups <- attr(x, "pm_groups", exact = TRUE)
if (is.null(groups)) character(0) else groups if (is.null(pm_groups)) character(0) else pm_groups
} }
pm_has_groups <- function(x) { pm_has_groups <- function(x) {
groups <- pm_group_vars(x) pm_groups <- pm_group_vars(x)
if (length(groups) == 0L) FALSE else TRUE if (length(pm_groups) == 0L) FALSE else TRUE
} }
pm_apply_grouped_function <- function(fn, .data, drop = FALSE, ...) { pm_apply_grouped_function <- function(fn, .data, drop = FALSE, ...) {
groups <- pm_group_vars(.data) pm_groups <- pm_group_vars(.data)
grouped <- pm_split_into_groups(.data, groups, drop) grouped <- pm_split_into_groups(.data, pm_groups, drop)
res <- do.call(rbind, unname(lapply(grouped, fn, ...))) res <- do.call(rbind, unname(lapply(grouped, fn, ...)))
if (any(groups %in% colnames(res))) { if (any(pm_groups %in% colnames(res))) {
class(res) <- c("grouped_df", class(res)) class(res) <- c("grouped_df", class(res))
res <- pm_groups_set(res, groups[groups %in% colnames(res)]) res <- pm_groups_set(res, pm_groups[pm_groups %in% colnames(res)])
} }
res res
} }
pm_calculate_groups <- function(data, groups, drop = pm_group_by_drop_default(data)) { pm_calculate_groups <- function(data, pm_groups, drop = pm_group_by_drop_default(data)) {
data <- pm_ungroup(data) data <- pm_ungroup(data)
unknown <- setdiff(groups, colnames(data)) unknown <- setdiff(pm_groups, colnames(data))
if (length(unknown) > 0L) { if (length(unknown) > 0L) {
stop(sprintf("`groups` missing from `data`: %s.", paste0(groups, collapse = ", "))) stop(sprintf("`pm_groups` missing from `data`: %s.", paste0(pm_groups, collapse = ", ")))
} }
unique_groups <- unique(data[, groups, drop = FALSE]) unique_groups <- unique(data[, pm_groups, drop = FALSE])
is_factor <- do.call(c, lapply(unique_groups, function(x) is.factor(x))) is_factor <- do.call(c, lapply(unique_groups, function(x) is.factor(x)))
n_comb <- nrow(unique_groups) n_comb <- nrow(unique_groups)
rows <- rep(list(NA), n_comb) rows <- rep(list(NA), n_comb)
data_groups <- interaction(data[, groups, drop = TRUE]) data_groups <- interaction(data[, pm_groups, drop = TRUE])
for (i in seq_len(n_comb)) { for (i in seq_len(n_comb)) {
rows[[i]] <- which(data_groups %in% interaction(unique_groups[i, groups])) rows[[i]] <- which(data_groups %in% interaction(unique_groups[i, pm_groups]))
} }
if (!isTRUE(drop) && any(is_factor)) { if (!isTRUE(drop) && any(is_factor)) {
na_lvls <- do.call( na_lvls <- do.call(
@ -676,7 +704,7 @@ pm_calculate_groups <- function(data, groups, drop = pm_group_by_drop_default(da
} }
} }
unique_groups[[".rows"]] <- rows unique_groups[[".rows"]] <- rows
unique_groups <- unique_groups[do.call(order, lapply(groups, function(x) unique_groups[, x])), , drop = FALSE] unique_groups <- unique_groups[do.call(order, lapply(pm_groups, function(x) unique_groups[, x])), , drop = FALSE]
rownames(unique_groups) <- NULL rownames(unique_groups) <- NULL
structure(unique_groups, .drop = drop) structure(unique_groups, .drop = drop)
} }
@ -709,25 +737,25 @@ pm_filter_join_worker <- function(x, y, by = NULL, type = c("anti", "semi")) {
type <- match.arg(type, choices = c("anti", "semi"), several.ok = FALSE) type <- match.arg(type, choices = c("anti", "semi"), several.ok = FALSE)
if (is.null(by)) { if (is.null(by)) {
by <- intersect(names(x), names(y)) by <- intersect(names(x), names(y))
join_message(by) pm_join_message(by)
} }
rows <- interaction(x[, by]) %in% interaction(y[, by]) rows <- interaction(x[, by]) %in% interaction(y[, by])
if (type == "anti") rows <- !rows if (type == "anti") rows <- !rows
res <- x[rows, , drop = FALSE] res <- x[rows, , drop = FALSE]
rownames(res) <- NULL rownames(res) <- NULL
reconstruct_attrs(res, x) pm_reconstruct_attrs(res, x)
} }
pm_inner_join <- function(x, y, by = NULL, suffix = c(".x", ".y"), ..., na_matches = c("na", "never")) { pm_inner_join <- function(x, y, by = NULL, suffix = c(".x", ".y"), ..., na_matches = c("na", "never")) {
join_worker(x = x, y = y, by = by, suffix = suffix, sort = FALSE, ..., keep = FALSE, na_matches = na_matches) pm_join_worker(x = x, y = y, by = by, suffix = suffix, sort = FALSE, ..., keep = FALSE, na_matches = na_matches)
} }
pm_left_join <- function(x, y, by = NULL, suffix = c(".x", ".y"), ..., keep = FALSE, na_matches = c("na", "never")) { pm_left_join <- function(x, y, by = NULL, suffix = c(".x", ".y"), ..., keep = FALSE, na_matches = c("na", "never")) {
join_worker(x = x, y = y, by = by, suffix = suffix, all.x = TRUE, ..., keep = keep, na_matches = na_matches) pm_join_worker(x = x, y = y, by = by, suffix = suffix, all.x = TRUE, ..., keep = keep, na_matches = na_matches)
} }
pm_right_join <- function(x, y, by = NULL, suffix = c(".x", ".y"), ..., keep = FALSE, na_matches = c("na", "never")) { pm_right_join <- function(x, y, by = NULL, suffix = c(".x", ".y"), ..., keep = FALSE, na_matches = c("na", "never")) {
join_worker(x = x, y = y, by = by, suffix = suffix, all.y = TRUE, ..., keep = keep, na_matches = na_matches) pm_join_worker(x = x, y = y, by = by, suffix = suffix, all.y = TRUE, ..., keep = keep, na_matches = na_matches)
} }
pm_full_join <- function(x, y, by = NULL, suffix = c(".x", ".y"), ..., keep = FALSE, na_matches = c("na", "never")) { pm_full_join <- function(x, y, by = NULL, suffix = c(".x", ".y"), ..., keep = FALSE, na_matches = c("na", "never")) {
join_worker(x = x, y = y, by = by, suffix = suffix, all = TRUE, ..., keep = keep, na_matches = na_matches) pm_join_worker(x = x, y = y, by = by, suffix = suffix, all = TRUE, ..., keep = keep, na_matches = na_matches)
} }
pm_join_worker <- function(x, y, by = NULL, suffix = c(".x", ".y"), keep = FALSE, na_matches = c("na", "never"), ...) { pm_join_worker <- function(x, y, by = NULL, suffix = c(".x", ".y"), keep = FALSE, na_matches = c("na", "never"), ...) {
na_matches <- match.arg(arg = na_matches, choices = c("na", "never"), several.ok = FALSE) na_matches <- match.arg(arg = na_matches, choices = c("na", "never"), several.ok = FALSE)
@ -735,7 +763,7 @@ pm_join_worker <- function(x, y, by = NULL, suffix = c(".x", ".y"), keep = FALSE
x[, ".join_id"] <- seq_len(nrow(x)) x[, ".join_id"] <- seq_len(nrow(x))
merged <- if (is.null(by)) { merged <- if (is.null(by)) {
by <- intersect(names(x), names(y)) by <- intersect(names(x), names(y))
join_message(by) pm_join_message(by)
merge( merge(
x = x, y = y, by = by, suffixes = suffix, incomparables = incomparables, ... x = x, y = y, by = by, suffixes = suffix, incomparables = incomparables, ...
)[, union(names(x), names(y)), drop = FALSE] )[, union(names(x), names(y)), drop = FALSE]
@ -752,7 +780,7 @@ pm_join_worker <- function(x, y, by = NULL, suffix = c(".x", ".y"), keep = FALSE
merged[, paste0(by, suffix[2L])] <- merged[, x_by] merged[, paste0(by, suffix[2L])] <- merged[, x_by]
} }
rownames(merged) <- NULL rownames(merged) <- NULL
reconstruct_attrs(merged, x) pm_reconstruct_attrs(merged, x)
} }
pm_join_message <- function(by) { pm_join_message <- function(by) {
if (length(by) > 1L) { if (length(by) > 1L) {
@ -763,13 +791,13 @@ pm_join_message <- function(by) {
} }
pm_as_function <- function(x, env = parent.frame()) { pm_as_function <- function(x, env = parent.frame()) {
if (is.function(x)) return(x) if (is.function(x)) return(x)
if (is_formula(x)) { if (pm_is_formula(x)) {
if (length(x) > 2) stop("Can't convert a two-sided formula to a function") if (length(x) > 2) stop("Can't convert a two-sided formula to a function")
env <- attr(x, ".Environment", exact = TRUE) env <- attr(x, ".Environment", exact = TRUE)
rhs <- as.list(x)[[2]] rhs <- as.list(x)[[2]]
return(as.function(list(... = substitute(), .x = quote(..1), .y = quote(..2), . = quote(..1), rhs), envir = env)) return(as.function(list(... = substitute(), .x = quote(..1), .y = quote(..2), . = quote(..1), rhs), envir = env))
} }
if (is_string(x)) return(get(x, envir = env, mode = "function")) if (pm_is_string(x)) return(get(x, envir = env, mode = "function"))
stop("Can't convert an object of class ", class(x), " to a function.") stop("Can't convert an object of class ", class(x), " to a function.")
} }
pm_is_formula <- function(x) { pm_is_formula <- function(x) {
@ -787,12 +815,12 @@ pm_names_are_invalid <- function(x) {
pm_is_named <- function(x) { pm_is_named <- function(x) {
nms <- names(x) nms <- names(x)
if (is.null(nms)) return(FALSE) if (is.null(nms)) return(FALSE)
if (any(names_are_invalid(nms))) return(FALSE) if (any(pm_names_are_invalid(nms))) return(FALSE)
TRUE TRUE
} }
pm_have_name <- function(x) { pm_have_name <- function(x) {
nms <- names(x) nms <- names(x)
if (is.null(nms)) rep(FALSE, length(x)) else !names_are_invalid(nms) if (is.null(nms)) rep(FALSE, length(x)) else !pm_names_are_invalid(nms)
} }
pm_is_empty_list <- function(x) { pm_is_empty_list <- function(x) {
inherits(x, "list") && length(x) == 0L inherits(x, "list") && length(x) == 0L
@ -850,7 +878,7 @@ pm_lst <- function(...) {
envir = if (length(out) == 0) { envir = if (length(out) == 0) {
list_to_eval list_to_eval
} else { } else {
drop_dup_list(out[1:(element - 1)]) pm_drop_dup_list(out[1:(element - 1)])
} }
) )
} }
@ -989,10 +1017,10 @@ pm_nth <- function(x, n, order_by = NULL, default = pm_default_missing(x)) {
if (is.null(order_by)) x[[n]] else x[[order(order_by)[[n]]]] if (is.null(order_by)) x[[n]] else x[[order(order_by)[[n]]]]
} }
pm_first <- function(x, order_by = NULL, default = pm_default_missing(x)) { pm_first <- function(x, order_by = NULL, default = pm_default_missing(x)) {
nth(x, 1L, order_by = order_by, default = default) pm_nth(x, 1L, order_by = order_by, default = default)
} }
pm_last <- function(x, order_by = NULL, default = pm_default_missing(x)) { pm_last <- function(x, order_by = NULL, default = pm_default_missing(x)) {
nth(x, -1L, order_by = order_by, default = default) pm_nth(x, -1L, order_by = order_by, default = default)
} }
pm_default_missing <- function(x) { pm_default_missing <- function(x) {
pm_default_missing.data.frame(x) pm_default_missing.data.frame(x)
@ -1179,7 +1207,7 @@ pm_pivot_wider <- function(
stop(paste0("`values_fill` must be of type numeric."), call. = FALSE) stop(paste0("`values_fill` must be of type numeric."), call. = FALSE)
} else { } else {
for (i in new_cols) { for (i in new_cols) {
wide[[i]] <- replace_na(wide[[i]], replace = values_fill) wide[[i]] <- pm_replace_na(wide[[i]], replace = values_fill)
} }
} }
} else if (is.character(wide[[new_cols[1]]])) { } else if (is.character(wide[[new_cols[1]]])) {
@ -1187,7 +1215,7 @@ pm_pivot_wider <- function(
stop(paste0("`values_fill` must be of type character."), call. = FALSE) stop(paste0("`values_fill` must be of type character."), call. = FALSE)
} else { } else {
for (i in new_cols) { for (i in new_cols) {
wide[[i]] <- replace_na(wide[[i]], replace = values_fill) wide[[i]] <- pm_replace_na(wide[[i]], replace = values_fill)
} }
} }
} else if (is.factor(wide[[new_cols[1]]])) { } else if (is.factor(wide[[new_cols[1]]])) {
@ -1195,7 +1223,7 @@ pm_pivot_wider <- function(
stop(paste0("`values_fill` must be of type factor."), call. = FALSE) stop(paste0("`values_fill` must be of type factor."), call. = FALSE)
} else { } else {
for (i in new_cols) { for (i in new_cols) {
wide[[i]] <- replace_na(wide[[i]], replace = values_fill) wide[[i]] <- pm_replace_na(wide[[i]], replace = values_fill)
} }
} }
} }
@ -1270,7 +1298,7 @@ pm_rename_with <- function(.data, .fn, .cols = everything(), ...) {
} }
pm_rename_with.data.frame <- function(.data, .fn, .cols = everything(), ...) { pm_rename_with.data.frame <- function(.data, .fn, .cols = everything(), ...) {
if (!is.function(.fn)) stop("`", .fn, "` is not a valid function") if (!is.function(.fn)) stop("`", .fn, "` is not a valid function")
grouped <- is.grouped_df(.data) grouped <- pm_is.grouped_df(.data)
if (grouped) grp_pos <- which(colnames(.data) %in% pm_group_vars(.data)) if (grouped) grp_pos <- which(colnames(.data) %in% pm_group_vars(.data))
col_pos <- pm_eval_select_pos(.data = .data, .pm_group_pos = TRUE, .cols = substitute(.cols)) col_pos <- pm_eval_select_pos(.data = .data, .pm_group_pos = TRUE, .cols = substitute(.cols))
cols <- colnames(.data)[col_pos] cols <- colnames(.data)[col_pos]
@ -1282,13 +1310,13 @@ pm_rename_with.data.frame <- function(.data, .fn, .cols = everything(), ...) {
if (grouped) .data <- pm_groups_set(.data, colnames(.data)[grp_pos]) if (grouped) .data <- pm_groups_set(.data, colnames(.data)[grp_pos])
.data .data
} }
pm_starts_with <- function(match, ignore.case = TRUE, vars = peek_vars()) { pm_starts_with <- function(match, ignore.case = TRUE, vars = pm_peek_vars()) {
grep(pattern = paste0("^", paste0(match, collapse = "|^")), x = vars, ignore.case = ignore.case) grep(pattern = paste0("^", paste0(match, collapse = "|^")), x = vars, ignore.case = ignore.case)
} }
pm_ends_with <- function(match, ignore.case = TRUE, vars = peek_vars()) { pm_ends_with <- function(match, ignore.case = TRUE, vars = pm_peek_vars()) {
grep(pattern = paste0(paste0(match, collapse = "$|"), "$"), x = vars, ignore.case = ignore.case) grep(pattern = paste0(paste0(match, collapse = "$|"), "$"), x = vars, ignore.case = ignore.case)
} }
pm_contains <- function(match, ignore.case = TRUE, vars = peek_vars()) { pm_contains <- function(match, ignore.case = TRUE, vars = pm_peek_vars()) {
matches <- lapply( matches <- lapply(
match, match,
function(x) { function(x) {
@ -1305,10 +1333,10 @@ pm_contains <- function(match, ignore.case = TRUE, vars = peek_vars()) {
) )
unique(unlist(matches)) unique(unlist(matches))
} }
pm_matches <- function(match, ignore.case = TRUE, perl = FALSE, vars = peek_vars()) { pm_matches <- function(match, ignore.case = TRUE, perl = FALSE, vars = pm_peek_vars()) {
grep(pattern = match, x = vars, ignore.case = ignore.case, perl = perl) grep(pattern = match, x = vars, ignore.case = ignore.case, perl = perl)
} }
pm_num_range <- function(prefix, range, width = NULL, vars = peek_vars()) { pm_num_range <- function(prefix, range, width = NULL, vars = pm_peek_vars()) {
if (!is.null(width)) { if (!is.null(width)) {
range <- sprintf(paste0("%0", width, "d"), range) range <- sprintf(paste0("%0", width, "d"), range)
} }
@ -1320,7 +1348,7 @@ pm_num_range <- function(prefix, range, width = NULL, vars = peek_vars()) {
x[!is.na(x)] x[!is.na(x)]
} }
} }
pm_all_of <- function(x, vars = peek_vars()) { pm_all_of <- function(x, vars = pm_peek_vars()) {
x_ <- !x %in% vars x_ <- !x %in% vars
if (any(x_)) { if (any(x_)) {
which_x_ <- which(x_) which_x_ <- which(x_)
@ -1333,14 +1361,14 @@ pm_all_of <- function(x, vars = peek_vars()) {
which(vars %in% x) which(vars %in% x)
} }
} }
pm_any_of <- function(x, vars = peek_vars()) { pm_any_of <- function(x, vars = pm_peek_vars()) {
which(vars %in% x) which(vars %in% x)
} }
pm_everything <- function(vars = peek_vars()) { pm_everything <- function(vars = pm_peek_vars()) {
seq_along(vars) seq_along(vars)
} }
pm_last_col <- function(offset = 0L, vars = peek_vars()) { pm_last_col <- function(offset = 0L, vars = pm_peek_vars()) {
if (!is_wholenumber(offset)) stop("`offset` must be an integer") if (!pm_is_wholenumber(offset)) stop("`offset` must be an integer")
n <- length(vars) n <- length(vars)
if (offset && n <= offset) { if (offset && n <= offset) {
stop("`offset` must be smaller than the number of `vars`") stop("`offset` must be smaller than the number of `vars`")
@ -1367,15 +1395,15 @@ pm_select_positions <- function(.data, ..., .pm_group_pos = FALSE) {
oor <- pos[which(pos > col_len)] oor <- pos[which(pos > col_len)]
oor_len <- length(oor) oor_len <- length(oor)
stop( stop(
"Location", if (oor_len > 1) "s " else " ", collapse_to_sentence(oor), "Location", if (oor_len > 1) "s " else " ", pm_collapse_to_sentence(oor),
if (oor_len > 1) " don't " else " doesn't ", "exist. There are only ", col_len, " columns." if (oor_len > 1) " don't " else " doesn't ", "exist. There are only ", col_len, " columns."
) )
} }
if (isTRUE(.pm_group_pos)) { if (isTRUE(.pm_group_pos)) {
groups <- pm_group_vars(.data) pm_groups <- pm_group_vars(.data)
missing_groups <- !(groups %in% cols) missing_groups <- !(pm_groups %in% cols)
if (any(missing_groups)) { if (any(missing_groups)) {
sel_missing <- groups[missing_groups] sel_missing <- pm_groups[missing_groups]
readd <- match(sel_missing, data_names) readd <- match(sel_missing, data_names)
readd <- readd[!(readd %in% pos)] readd <- readd[!(readd %in% pos)]
if (length(readd) > 0L) { if (length(readd) > 0L) {
@ -1469,7 +1497,7 @@ pm_select_seq <- function(expr) {
x:y x:y
} }
pm_select_negate <- function(expr) { pm_select_negate <- function(expr) {
x <- if (is_negated_colon(expr)) { x <- if (pm_is_negated_colon(expr)) {
expr <- call(":", expr[[2]][[2]], expr[[2]][[3]][[2]]) expr <- call(":", expr[[2]][[2]], expr[[2]][[3]][[2]])
pm_eval_expr(expr) pm_eval_expr(expr)
} else { } else {
@ -1516,73 +1544,73 @@ pm_select <- function(.data, ...) {
if (pm_has_groups(.data)) res <- pm_groups_set(res, pm_group_vars(.data)) if (pm_has_groups(.data)) res <- pm_groups_set(res, pm_group_vars(.data))
res res
} }
pm_summarise <- function(.data, ..., .groups = NULL) { pm_summarise <- function(.data, ..., .pm_groups = NULL) {
if ("grouped_df" %in% class(.data)) pm_summarise.grouped_df(.data, ..., .groups = NULL) else pm_summarise.data.frame(.data, ..., .groups = NULL) if ("grouped_df" %in% class(.data)) pm_summarise.grouped_df(.data, ..., .pm_groups = NULL) else pm_summarise.data.frame(.data, ..., .pm_groups = NULL)
} }
pm_summarise.data.frame <- function(.data, ..., .groups = NULL) { pm_summarise.data.frame <- function(.data, ..., .pm_groups = NULL) {
fns <- pm_dotdotdot(...) fns <- pm_dotdotdot(...)
pm_context$setup(.data) pm_context$setup(.data)
on.exit(pm_context$clean(), add = TRUE) on.exit(pm_context$clean(), add = TRUE)
groups_exist <- pm_context$is_grouped() pm_groups_exist <- pm_context$is_grouped()
if (groups_exist) { if (pm_groups_exist) {
group <- unique(pm_context$get_columns(pm_group_vars(pm_context$.data))) group <- unique(pm_context$get_columns(pm_group_vars(pm_context$.data)))
} }
if (is_empty_list(fns)) { if (pm_is_empty_list(fns)) {
if (groups_exist) return(group) else return(data.frame()) if (pm_groups_exist) return(group) else return(data.frame())
} }
res <- vector(mode = "list", length = length(fns)) res <- vector(mode = "list", length = length(fns))
pm_eval_env <- c(as.list(pm_context$.data), vector(mode = "list", length = length(fns))) pm_eval_env <- c(as.list(pm_context$.data), vector(mode = "list", length = length(fns)))
new_pos <- seq(length(pm_context$.data) + 1L, length(pm_eval_env), 1L) new_pos <- seq(length(pm_context$.data) + 1L, length(pm_eval_env), 1L)
for (i in seq_along(fns)) { for (i in seq_along(fns)) {
pm_eval_env[[new_pos[i]]] <- do.call(with, list(pm_eval_env, fns[[i]])) pm_eval_env[[new_pos[i]]] <- do.call(with, list(pm_eval_env, fns[[i]]))
nms <- if (!is_named(pm_eval_env[[new_pos[i]]])) { nms <- if (!pm_is_named(pm_eval_env[[new_pos[i]]])) {
if (!is.null(names(fns)[[i]])) names(fns)[[i]] else deparse(fns[[i]]) if (!is.null(names(fns)[[i]])) names(fns)[[i]] else deparse(fns[[i]])
} else { } else {
NULL NULL
} }
if (!is.null(nms)) names(pm_eval_env)[[new_pos[i]]] <- nms if (!is.null(nms)) names(pm_eval_env)[[new_pos[i]]] <- nms
res[[i]] <- build_data_frame(pm_eval_env[[new_pos[i]]], nms = nms) res[[i]] <- pm_build_data_frame(pm_eval_env[[new_pos[i]]], nms = nms)
} }
res <- do.call(cbind, res) res <- do.call(cbind, res)
if (groups_exist) res <- cbind(group, res, row.names = NULL) if (pm_groups_exist) res <- cbind(group, res, row.names = NULL)
res res
} }
pm_summarise.grouped_df <- function(.data, ..., .groups = NULL) { pm_summarise.grouped_df <- function(.data, ..., .pm_groups = NULL) {
if (!is.null(.groups)) { if (!is.null(.pm_groups)) {
.groups <- match.arg(arg = .groups, choices = c("drop", "drop_last", "keep"), several.ok = FALSE) .pm_groups <- match.arg(arg = .pm_groups, choices = c("drop", "drop_last", "keep"), several.ok = FALSE)
} }
groups <- pm_group_vars(.data) pm_groups <- pm_group_vars(.data)
res <- pm_apply_grouped_function("pm_summarise", .data, drop = TRUE, ...) res <- pm_apply_grouped_function("pm_summarise", .data, drop = TRUE, ...)
res <- res[pm_arrange_rows(res, pm_as_symbols(groups)), , drop = FALSE] res <- res[pm_arrange_rows(res, pm_as_symbols(pm_groups)), , drop = FALSE]
verbose <- pm_summarise_verbose(.groups) verbose <- pm_summarise_verbose(.pm_groups)
if (is.null(.groups)) { if (is.null(.pm_groups)) {
all_one <- as.data.frame(table(res[, groups])) all_one <- as.data.frame(table(res[, pm_groups]))
all_one <- all_one[all_one$Freq != 0, ] all_one <- all_one[all_one$Freq != 0, ]
.groups <- if (all(all_one$Freq == 1)) "drop_last" else "keep" .pm_groups <- if (all(all_one$Freq == 1)) "drop_last" else "keep"
} }
if (.groups == "drop_last") { if (.pm_groups == "drop_last") {
n <- length(groups) n <- length(pm_groups)
if (n > 1) { if (n > 1) {
if (verbose) pm_summarise_inform(groups[-n]) if (verbose) pm_summarise_inform(pm_groups[-n])
res <- pm_groups_set(res, groups[-n], pm_group_by_drop_default(.data)) res <- pm_groups_set(res, pm_groups[-n], pm_group_by_drop_default(.data))
} }
} else if (.groups == "keep") { } else if (.pm_groups == "keep") {
if (verbose) pm_summarise_inform(groups) if (verbose) pm_summarise_inform(pm_groups)
res <- pm_groups_set(res, groups, pm_group_by_drop_default(.data)) res <- pm_groups_set(res, pm_groups, pm_group_by_drop_default(.data))
} else if (.groups == "drop") { } else if (.pm_groups == "drop") {
attr(res, "groups") <- NULL attr(res, "pm_groups") <- NULL
} }
rownames(res) <- NULL rownames(res) <- NULL
res res
} }
pm_summarise_inform <- function(new_groups) { pm_summarise_inform <- function(new_groups) {
message(sprintf( message(sprintf(
"`pm_summarise()` has grouped output by %s. You can override using the `.groups` argument.", "`pm_summarise()` has grouped output by %s. You can override using the `.pm_groups` argument.",
paste0("'", new_groups, "'", collapse = ", ") paste0("'", new_groups, "'", collapse = ", ")
)) ))
} }
pm_summarise_verbose <- function(.groups) { pm_summarise_verbose <- function(.pm_groups) {
is.null(.groups) && is.null(.pm_groups) &&
!identical(getOption("poorman.summarise.inform"), FALSE) !identical(getOption("poorman.summarise.inform"), FALSE)
} }
pm_transmute <- function(.data, ...) { pm_transmute <- function(.data, ...) {
@ -1601,11 +1629,11 @@ pm_ungroup <- function(x, ...) {
} }
pm_ungroup.data.frame <- function(x, ...) { pm_ungroup.data.frame <- function(x, ...) {
rm_groups <- pm_deparse_dots(...) rm_groups <- pm_deparse_dots(...)
groups <- pm_group_vars(x) pm_groups <- pm_group_vars(x)
if (length(rm_groups) == 0L) rm_groups <- groups if (length(rm_groups) == 0L) rm_groups <- pm_groups
x <- pm_groups_set(x, groups[!(groups %in% rm_groups)]) x <- pm_groups_set(x, pm_groups[!(pm_groups %in% rm_groups)])
if (length(attr(x, "groups")) == 0L) { if (length(attr(x, "pm_groups")) == 0L) {
attr(x, "groups") <- NULL attr(x, "pm_groups") <- NULL
class(x) <- class(x)[!(class(x) %in% "grouped_df")] class(x) <- class(x)[!(class(x) %in% "grouped_df")]
} }
x x
@ -1648,7 +1676,7 @@ pm_build_data_frame <- function(x, nms = NULL) {
} }
pm_is_nested <- function(lst) vapply(lst, function(x) inherits(x[1L], "list"), FALSE) pm_is_nested <- function(lst) vapply(lst, function(x) inherits(x[1L], "list"), FALSE)
pm_squash <- function(lst) { pm_squash <- function(lst) {
do.call(c, lapply(lst, function(x) if (is.list(x) && !is.data.frame(x)) squash(x) else list(x))) do.call(c, lapply(lst, function(x) if (is.list(x) && !is.data.frame(x)) pm_squash(x) else list(x)))
} }
pm_flatten <- function(lst) { pm_flatten <- function(lst) {
nested <- pm_is_nested(lst) nested <- pm_is_nested(lst)

4
R/aaa_helper_functions.R
View File

@ -259,7 +259,7 @@ is_valid_regex <- function(x) {
} }
stop_ifnot_installed <- function(package) { stop_ifnot_installed <- function(package) {
installed <- vapply(FUN.VALUE = logical(1), package, requireNamespace, quietly = TRUE) installed <- vapply(FUN.VALUE = logical(1), package, requireNamespace, lib.loc = base::.libPaths(), quietly = TRUE)
if (any(!installed) && any(package == "rstudioapi")) { if (any(!installed) && any(package == "rstudioapi")) {
stop("This function only works in RStudio when using R >= 3.2.", call. = FALSE) stop("This function only works in RStudio when using R >= 3.2.", call. = FALSE)
} else if (any(!installed)) { } else if (any(!installed)) {
@ -276,7 +276,7 @@ pkg_is_available <- function(pkg, also_load = TRUE, min_version = NULL) {
if (also_load == TRUE) { if (also_load == TRUE) {
out <- suppressWarnings(require(pkg, character.only = TRUE, warn.conflicts = FALSE)) out <- suppressWarnings(require(pkg, character.only = TRUE, warn.conflicts = FALSE))
} else { } else {
out <- requireNamespace(pkg, quietly = TRUE) out <- requireNamespace(pkg, lib.loc = base::.libPaths(), quietly = TRUE)
} }
if (!is.null(min_version)) { if (!is.null(min_version)) {
out <- out && utils::packageVersion(pkg) >= min_version out <- out && utils::packageVersion(pkg) >= min_version

12
R/ab_property.R
View File

@ -102,22 +102,18 @@
#' \donttest{ #' \donttest{
#' if (require("dplyr")) { #' if (require("dplyr")) {
#' example_isolates %>% #' example_isolates %>%
#' set_ab_names() %>% #' set_ab_names()
#' head()
#' #'
#' # this does the same: #' # this does the same:
#' example_isolates %>% #' example_isolates %>%
#' rename_with(set_ab_names) %>% #' rename_with(set_ab_names)
#' head()
#' #'
#' # set_ab_names() works with any AB property: #' # set_ab_names() works with any AB property:
#' example_isolates %>% #' example_isolates %>%
#' set_ab_names(property = "atc") %>% #' set_ab_names(property = "atc")
#' head()
#' #'
#' example_isolates %>% #' example_isolates %>%
#' set_ab_names(where(is.sir)) %>% #' set_ab_names(where(is.sir))
#' colnames()
#' #'
#' example_isolates %>% #' example_isolates %>%
#' set_ab_names(NIT:VAN) %>% #' set_ab_names(NIT:VAN) %>%

6
R/antibiogram.R
View File

@ -334,6 +334,9 @@ antibiogram <- function(x,
FUN = function(x) x) FUN = function(x) x)
counts <- out counts <- out
out$numerator <- ifelse(isTRUE(combine_SI), out$S + out$I, out$S)
out$minimum <- minimum
# regroup for summarising # regroup for summarising
if (isTRUE(has_syndromic_group)) { if (isTRUE(has_syndromic_group)) {
colnames(out)[1] <- "syndromic_group" colnames(out)[1] <- "syndromic_group"
@ -348,7 +351,6 @@ antibiogram <- function(x,
} }
out <- out %>% out <- out %>%
mutate(numerator = ifelse(isTRUE(combine_SI), S + I, S)) %>%
summarise(SI = ifelse(total >= minimum, numerator / total, NA_real_)) %>% summarise(SI = ifelse(total >= minimum, numerator / total, NA_real_)) %>%
filter(!is.na(SI)) filter(!is.na(SI))
@ -504,7 +506,7 @@ autoplot.antibiogram <- function(object, ...) {
#' @rdname antibiogram #' @rdname antibiogram
print.antibiogram <- function(x, as_kable = !interactive(), ...) { print.antibiogram <- function(x, as_kable = !interactive(), ...) {
meet_criteria(as_kable, allow_class = "logical", has_length = 1) meet_criteria(as_kable, allow_class = "logical", has_length = 1)
if (isTRUE(as_kable)) { if (isTRUE(as_kable) && !identical(Sys.getenv("IN_PKGDOWN"), "true")) {
stop_ifnot_installed("knitr") stop_ifnot_installed("knitr")
kable <- import_fn("kable", "knitr", error_on_fail = TRUE) kable <- import_fn("kable", "knitr", error_on_fail = TRUE)
kable(x, ...) kable(x, ...)

3
R/bug_drug_combinations.R
View File

@ -50,7 +50,6 @@
#' example_isolates #' example_isolates
#' #'
#' x <- bug_drug_combinations(example_isolates) #' x <- bug_drug_combinations(example_isolates)
#' head(x)
#' format(x, translate_ab = "name (atc)") #' format(x, translate_ab = "name (atc)")
#' #'
#' # Use FUN to change to transformation of microorganism codes #' # Use FUN to change to transformation of microorganism codes
@ -174,7 +173,7 @@ bug_drug_combinations <- function(x,
res <- do.call(rbind, unname(lapply(grouped, fn, ...))) res <- do.call(rbind, unname(lapply(grouped, fn, ...)))
if (any(groups %in% colnames(res))) { if (any(groups %in% colnames(res))) {
class(res) <- c("grouped_data", class(res)) class(res) <- c("grouped_data", class(res))
res <- pm_set_groups(res, groups[groups %in% colnames(res)]) res <- pm_groups_set(res, groups[groups %in% colnames(res)])
} }
res res
} }

2
R/sir_calc.R
View File

@ -334,7 +334,7 @@ sir_calc_df <- function(type, # "proportion", "count" or "both"
res <- do.call(rbind, unname(lapply(grouped, fn, ...))) res <- do.call(rbind, unname(lapply(grouped, fn, ...)))
if (any(groups %in% colnames(res))) { if (any(groups %in% colnames(res))) {
class(res) <- c("grouped_data", class(res)) class(res) <- c("grouped_data", class(res))
res <- pm_set_groups(res, groups[groups %in% colnames(res)]) res <- pm_groups_set(res, groups[groups %in% colnames(res)])
} }
res res
} }

11
data-raw/reproduction_of_poorman.R
View File

@ -1,6 +1,9 @@
# get complete filenames of all R files in the GitHub repository of nathaneastwood/poorman # get complete filenames of all R files in the GitHub repository of nathaneastwood/poorman
library(magrittr) library(magrittr)
`%like%` <- function(x, y) grepl(y, x, ignore.case = TRUE, perl = TRUE)
`%unlike%` <- function(x, y) !grepl(y, x, ignore.case = TRUE, perl = TRUE)
commit <- "3cc0a9920b1eb559dd166f548561244189586b3a" commit <- "3cc0a9920b1eb559dd166f548561244189586b3a"
files <- xml2::read_html(paste0("https://github.com/nathaneastwood/poorman/tree/", commit, "/R")) %>% files <- xml2::read_html(paste0("https://github.com/nathaneastwood/poorman/tree/", commit, "/R")) %>%
@ -13,7 +16,7 @@ files <- sort(paste0("https://raw.githubusercontent.com", gsub("blob/", "", file
# remove files with only pkg specific code # remove files with only pkg specific code
files <- files[files %unlike% "(zzz|init)[.]R$"] files <- files[files %unlike% "(zzz|init)[.]R$"]
# also, there's a lot of functions we don't use # also, there's a lot of functions we don't use
files <- files[files %unlike% "/(between|coalesce|cumulative|fill|glimpse|gluestick|group_cols|na_if|near|nest_by|poorman-package|print|recode|reconstruct|replace_na|replace_with|rownames|slice|union_all|unite|window_rank|with_groups)[.]R$"] files <- files[files %unlike% "/(between|coalesce|cumulative|fill|glimpse|group_cols|na_if|near|nest_by|check_filter|poorman-package|print|recode|reconstruct|replace_na|replace_with|rownames|slice|union_all|unite|window_rank|with_groups)[.]R$"]
# add our prepend file, containing info about the source of the data # add our prepend file, containing info about the source of the data
intro <- readLines("data-raw/poorman_prepend.R") %>% intro <- readLines("data-raw/poorman_prepend.R") %>%
@ -60,6 +63,7 @@ contents <- gsub("NextMethod\\(\"(.*)\"\\)", "\\1.data.frame(...)", contents)
# correct for 'default' method # correct for 'default' method
contents <- gsub(".default <-", ".data.frame <-", contents, fixed = TRUE) contents <- gsub(".default <-", ".data.frame <-", contents, fixed = TRUE)
contents <- gsub("pm_group_by_drop.data.frame", "pm_group_by_drop", contents, fixed = TRUE) contents <- gsub("pm_group_by_drop.data.frame", "pm_group_by_drop", contents, fixed = TRUE)
contents <- gsub("(stats::)?setNames", "stats::setNames", contents)
# now get all those pm_* functions to replace all untransformed function name calls as well # now get all those pm_* functions to replace all untransformed function name calls as well
new_pm_names <- sort(gsub("pm_(.*?) <-.*", "\\1", contents[grepl("^pm_", contents)])) new_pm_names <- sort(gsub("pm_(.*?) <-.*", "\\1", contents[grepl("^pm_", contents)]))
for (i in seq_len(length(new_pm_names))) { for (i in seq_len(length(new_pm_names))) {
@ -76,9 +80,10 @@ contents <- gsub("\\pm_n", "\\n", contents, fixed = TRUE)
# prefix other functions also with "pm_" # prefix other functions also with "pm_"
contents <- gsub("^([a-z_]+)(\\$|)", "pm_\\1\\2", contents) contents <- gsub("^([a-z_]+)(\\$|)", "pm_\\1\\2", contents)
# prefix environmental objects and functions # prefix environmental objects and functions
contents <- gsub("(eval_env|select_env|select_context|context|dotdotdot|as_symbols|insert_dot|deparse_|groups_set|apply_grouped_function|split_into_groups|calculate_groups|has_groups|eval_select_pos|select_positions|eval_expr|eval_call|add_group_columns|find_used|is_nested|setup_|select_|group_)", "pm_\\1", contents) contents <- gsub("(add_group_columns|add_tally|apply_grouped_function|as_function|as_symbols|build_data_frame|calculate_groups|check_filter|check_if_types|check_name|check_context|collapse_to_sentence|context|deparse_|dotdotdot|drop_dup_list|eval_call|eval_env|eval_expr|eval_select_pos|find_used|flatten|get_group_details|gluestick|group_|groups|groups_set|has_groups|have_name|insert_dot|is.grouped_df|is_df_or_vector|is_empty_list|is_formula|is_named|is_negated_colon|is_nested|is_string|is_wholenumber|join_message|join_worker|names_are_invalid|nth|peek_vars|reconstruct_attrs|replace_na|replace_with|select_|select_context|select_env|select_positions|setup_|split_into_groups|squash|tally|tally_n|validate_case_when_length)", "pm_\\1", contents)
# now some items are overprefixed # now a lot of items are overprefixed
contents <- gsub("(pm_)+", "pm_", contents) contents <- gsub("(pm_)+", "pm_", contents)
contents <- gsub("_pm_", "_", contents)
contents <- gsub("pm_if (\"grouped_df", "if (\"grouped_df", contents, fixed = TRUE) contents <- gsub("pm_if (\"grouped_df", "if (\"grouped_df", contents, fixed = TRUE)
# remove comments and empty lines # remove comments and empty lines
contents <- gsub("#.*", "", contents) contents <- gsub("#.*", "", contents)

12
man/ab_property.Rd
View File

@ -152,22 +152,18 @@ colnames(set_ab_names(example_isolates, NIT:VAN))
\donttest{ \donttest{
if (require("dplyr")) { if (require("dplyr")) {
example_isolates \%>\% example_isolates \%>\%
set_ab_names() \%>\% set_ab_names()
head()
# this does the same: # this does the same:
example_isolates \%>\% example_isolates \%>\%
rename_with(set_ab_names) \%>\% rename_with(set_ab_names)
head()
# set_ab_names() works with any AB property: # set_ab_names() works with any AB property:
example_isolates \%>\% example_isolates \%>\%
set_ab_names(property = "atc") \%>\% set_ab_names(property = "atc")
head()
example_isolates \%>\% example_isolates \%>\%
set_ab_names(where(is.sir)) \%>\% set_ab_names(where(is.sir))
colnames()
example_isolates \%>\% example_isolates \%>\%
set_ab_names(NIT:VAN) \%>\% set_ab_names(NIT:VAN) \%>\%

1
man/bug_drug_combinations.Rd
View File

@ -64,7 +64,6 @@ The function \code{\link[=format]{format()}} calculates the resistance per bug-d
example_isolates example_isolates
x <- bug_drug_combinations(example_isolates) x <- bug_drug_combinations(example_isolates)
head(x)
format(x, translate_ab = "name (atc)") format(x, translate_ab = "name (atc)")
# Use FUN to change to transformation of microorganism codes # Use FUN to change to transformation of microorganism codes