mirror of https://github.com/msberends/AMR
111 changed files with 3199 additions and 2333 deletions
@ -0,0 +1,775 @@
@@ -0,0 +1,775 @@
|
||||
# ==================================================================== # |
||||
# TITLE # |
||||
# Antimicrobial Resistance (AMR) Analysis # |
||||
# # |
||||
# SOURCE # |
||||
# https://gitlab.com/msberends/AMR # |
||||
# # |
||||
# LICENCE # |
||||
# (c) 2018-2020 Berends MS, Luz CF et al. # |
||||
# # |
||||
# 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 more info: https://msberends.gitlab.io/AMR. # |
||||
# ==================================================================== # |
||||
|
||||
# ------------------------------------------------ |
||||
# THIS FILE WAS CREATED AUTOMATICALLY! |
||||
# Source file: data-raw/reproduction_of_poorman.R |
||||
# ------------------------------------------------ |
||||
|
||||
# Poorman: a package to replace all dplyr functions with base R so we can lose dependency on dplyr. |
||||
# These functions were downloaded from https://github.com/nathaneastwood/poorman, |
||||
# from this commit: https://github.com/nathaneastwood/poorman/tree/7d76d77f8f7bc663bf30fb5a161abb49801afa17 |
||||
# |
||||
# All code below was released under MIT license, that permits 'free of charge, to any person obtaining a |
||||
# copy of the software and associated documentation files (the "Software"), to deal in the Software |
||||
# without restriction, including without limitation the rights to use, copy, modify, merge, publish, |
||||
# distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software |
||||
# is furnished to do so', given that a copyright notice is given in the software. |
||||
# |
||||
# Copyright notice as found on https://github.com/nathaneastwood/poorman/blob/master/LICENSE on 2 May 2020: |
||||
# YEAR: 2020 |
||||
# COPYRIGHT HOLDER: Nathan Eastwood |
||||
|
||||
arrange <- function(.data, ...) { |
||||
check_is_dataframe(.data) |
||||
if ("grouped_data" %in% class(.data)) { |
||||
arrange.grouped_data(.data, ...) |
||||
} else { |
||||
arrange.default(.data, ...) |
||||
} |
||||
} |
||||
|
||||
arrange.default <- function(.data, ...) { |
||||
rows <- eval.parent(substitute(with(.data, order(...)))) |
||||
.data[rows, , drop = FALSE] |
||||
} |
||||
|
||||
arrange.grouped_data <- function(.data, ...) { |
||||
apply_grouped_function(.data, "arrange", ...) |
||||
} |
||||
between <- function(x, left, right) { |
||||
if (!is.null(attr(x, "class")) && !inherits(x, c("Date", "POSIXct"))) { |
||||
warning("`between()` called on numeric vector with S3 class") |
||||
} |
||||
if (!is.double(x)) x <- as.numeric(x) |
||||
x >= as.numeric(left) & x <= as.numeric(right) |
||||
} |
||||
count <- function(x, ..., wt = NULL, sort = FALSE, name = NULL) { |
||||
groups <- get_groups(x) |
||||
if (!missing(...)) x <- group_by(x, ..., .add = TRUE) |
||||
wt <- deparse_var(wt) |
||||
res <- do.call(tally, list(x, wt, sort, name)) |
||||
if (length(groups) > 0L) res <- do.call(group_by, list(res, as.name(groups))) |
||||
res |
||||
} |
||||
|
||||
tally <- function(x, wt = NULL, sort = FALSE, name = NULL) { |
||||
name <- check_name(x, name) |
||||
wt <- deparse_var(wt) |
||||
res <- do.call(summarise, set_names(list(x, as.name(tally_n(x, wt))), c(".data", name))) |
||||
res <- ungroup(res) |
||||
if (isTRUE(sort)) res <- do.call(arrange, list(res, call("desc", as.name(name)))) |
||||
rownames(res) <- NULL |
||||
res |
||||
} |
||||
|
||||
add_count <- function(x, ..., wt = NULL, sort = FALSE, name = NULL) { |
||||
name <- check_name(x, name) |
||||
row_names <- rownames(x) |
||||
wt <- deparse_var(wt) |
||||
if (!missing(...)) x <- group_by(x, ..., .add = TRUE) |
||||
res <- do.call(add_tally, list(x, wt, sort, name)) |
||||
res[row_names, ] |
||||
} |
||||
|
||||
add_tally <- function(x, wt = NULL, sort = FALSE, name = NULL) { |
||||
wt <- deparse_var(wt) |
||||
n <- tally_n(x, wt) |
||||
name <- check_name(x, name) |
||||
res <- do.call(mutate, set_names(list(x, as.name(n)), c(".data", name))) |
||||
|
||||
if (isTRUE(sort)) { |
||||
do.call(arrange, list(res, call("desc", as.name(name)))) |
||||
} else { |
||||
res |
||||
} |
||||
} |
||||
|
||||
tally_n <- function(x, wt) { |
||||
if (is.null(wt) && "n" %in% colnames(x)) { |
||||
message("Using `n` as weighting variable") |
||||
wt <- "n" |
||||
} |
||||
context$.data <- x |
||||
on.exit(rm(list = ".data", envir = context)) |
||||
if (is.null(wt)) { |
||||
"n()" |
||||
} else { |
||||
paste0("sum(", wt, ", na.rm = TRUE)") |
||||
} |
||||
} |
||||
|
||||
check_name <- function(df, name) { |
||||
if (is.null(name)) { |
||||
if ("n" %in% colnames(df)) { |
||||
stop( |
||||
"Column 'n' is already present in output\n", |
||||
"* Use `name = \"new_name\"` to pick a new name" |
||||
) |
||||
} |
||||
return("n") |
||||
} |
||||
|
||||
if (!is.character(name) || length(name) != 1) { |
||||
stop("`name` must be a single string") |
||||
} |
||||
|
||||
name |
||||
} |
||||
desc <- function(x) -xtfrm(x) |
||||
select_env <- new.env() |
||||
|
||||
peek_vars <- function() { |
||||
get(".col_names", envir = select_env) |
||||
} |
||||
|
||||
context <- new.env() |
||||
|
||||
n <- function() { |
||||
do.call(nrow, list(quote(.data)), envir = context) |
||||
} |
||||
filter <- function(.data, ...) { |
||||
check_is_dataframe(.data) |
||||
if ("grouped_data" %in% class(.data)) { |
||||
filter.grouped_data(.data, ...) |
||||
} else { |
||||
filter.default(.data, ...) |
||||
} |
||||
} |
||||
|
||||
filter.default <- function(.data, ...) { |
||||
conditions <- paste(deparse_dots(...), collapse = " & ") |
||||
context$.data <- .data |
||||
on.exit(rm(.data, envir = context)) |
||||
.data[do.call(with, list(.data, str2lang(unname(conditions)))), ] |
||||
} |
||||
|
||||
filter.grouped_data <- function(.data, ...) { |
||||
rows <- rownames(.data) |
||||
res <- apply_grouped_function(.data, "filter", ...) |
||||
res[rows[rows %in% rownames(res)], ] |
||||
} |
||||
group_by <- function(.data, ..., .add = FALSE) { |
||||
check_is_dataframe(.data) |
||||
pre_groups <- get_groups(.data) |
||||
groups <- deparse_dots(...) |
||||
if (isTRUE(.add)) groups <- unique(c(pre_groups, groups)) |
||||
unknown <- !(groups %in% colnames(.data)) |
||||
if (any(unknown)) stop("Invalid groups: ", groups[unknown]) |
||||
structure(.data, class = c("grouped_data", class(.data)), groups = groups) |
||||
} |
||||
|
||||
ungroup <- function(x, ...) { |
||||
check_is_dataframe(x) |
||||
rm_groups <- deparse_dots(...) |
||||
groups <- attr(x, "groups") |
||||
if (length(rm_groups) == 0L) rm_groups <- groups |
||||
attr(x, "groups") <- groups[!(groups %in% rm_groups)] |
||||
if (length(attr(x, "groups")) == 0L) { |
||||
attr(x, "groups") <- NULL |
||||
class(x) <- class(x)[!(class(x) %in% "grouped_data")] |
||||
} |
||||
x |
||||
} |
||||
|
||||
get_groups <- function(x) { |
||||
attr(x, "groups", exact = TRUE) |
||||
} |
||||
|
||||
has_groups <- function(x) { |
||||
groups <- get_groups(x) |
||||
if (is.null(groups)) FALSE else TRUE |
||||
} |
||||
|
||||
set_groups <- function(x, groups) { |
||||
attr(x, "groups") <- groups |
||||
x |
||||
} |
||||
|
||||
apply_grouped_function <- function(.data, fn, ...) { |
||||
groups <- get_groups(.data) |
||||
grouped <- split_into_groups(.data, groups) |
||||
res <- do.call(rbind, unname(lapply(grouped, fn, ...))) |
||||
if (any(groups %in% colnames(res))) { |
||||
class(res) <- c("grouped_data", class(res)) |
||||
attr(res, "groups") <- groups[groups %in% colnames(res)] |
||||
} |
||||
res |
||||
} |
||||
|
||||
split_into_groups <- function(.data, groups) { |
||||
class(.data) <- "data.frame" |
||||
group_factors <- lapply(groups, function(x, .data) as.factor(.data[, x]), .data) |
||||
res <- split(x = .data, f = group_factors) |
||||
res |
||||
} |
||||
|
||||
print.grouped_data <- function(x, ..., digits = NULL, quote = FALSE, right = TRUE, row.names = TRUE, max = NULL) { |
||||
class(x) <- "data.frame" |
||||
print(x, ..., digits = digits, quote = quote, right = right, row.names = row.names, max = max) |
||||
cat("\nGroups: ", paste(attr(x, "groups", exact = TRUE), collapse = ", "), "\n\n") |
||||
} |
||||
if_else <- function(condition, true, false, missing = NULL) { |
||||
if (!is.logical(condition)) stop("`condition` must be a logical vector.") |
||||
cls_true <- class(true) |
||||
cls_false <- class(false) |
||||
cls_missing <- class(missing) |
||||
if (!identical(cls_true, cls_false)) { |
||||
stop("The class of `true` <", class(true), "> is not the same as the class of `false` <", class(false), ">") |
||||
} |
||||
if (!is.null(missing) && !identical(cls_true, cls_missing)) { |
||||
stop("`missing` must be a ", cls_true, " vector, not a ", cls_missing, " vector.") |
||||
} |
||||
res <- ifelse(condition, true, false) |
||||
if (!is.null(missing)) res[is.na(res)] <- missing |
||||
attributes(res) <- attributes(true) |
||||
res |
||||
} |
||||
|
||||
inner_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) { |
||||
join_worker(x = x, y = y, by = by, suffix = suffix, sort = FALSE) |
||||
} |
||||
|
||||
left_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) { |
||||
join_worker(x = x, y = y, by = by, suffix = suffix, all.x = TRUE) |
||||
} |
||||
|
||||
right_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) { |
||||
join_worker(x = x, y = y, by = by, suffix = suffix, all.y = TRUE) |
||||
} |
||||
|
||||
full_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) { |
||||
join_worker(x = x, y = y, by = by, suffix = suffix, all = TRUE) |
||||
} |
||||
|
||||
join_worker <- function(x, y, by = NULL, suffix = c(".x", ".y"), ...) { |
||||
x[, ".join_id"] <- seq_len(nrow(x)) |
||||
if (is.null(by)) { |
||||
by <- intersect(names(x), names(y)) |
||||
join_message(by) |
||||
merged <- merge(x = x, y = y, by = by, suffixes = suffix, ...)[, union(names(x), names(y))] |
||||
} else if (is.null(names(by))) { |
||||
merged <- merge(x = x, y = y, by = by, suffixes = suffix, ...) |
||||
} else { |
||||
merged <- merge(x = x, y = y, by.x = names(by), by.y = by, suffixes = suffix, ...) |
||||
} |
||||
merged <- merged[order(merged[, ".join_id"]), colnames(merged) != ".join_id"] |
||||
rownames(merged) <- NULL |
||||
merged |
||||
} |
||||
|
||||
join_message <- function(by) { |
||||
if (length(by) > 1L) { |
||||
message("Joining, by = c(\"", paste0(by, collapse = "\", \""), "\")\n", sep = "") |
||||
} else { |
||||
message("Joining, by = \"", by, "\"\n", sep = "") |
||||
} |
||||
} |
||||
|
||||
anti_join <- function(x, y, by = NULL) { |
||||
filter_join_worker(x, y, by, type = "anti") |
||||
} |
||||
|
||||
semi_join <- function(x, y, by = NULL) { |
||||
filter_join_worker(x, y, by, type = "semi") |
||||
} |
||||
|
||||
# filter_join_worker <- function(x, y, by = NULL, type = c("anti", "semi")) { |
||||
# type <- match.arg(type, choices = c("anti", "semi"), several.ok = FALSE) |
||||
# if (is.null(by)) { |
||||
# by <- intersect(names(x), names(y)) |
||||
# join_message(by) |
||||
# } |
||||
# rows <- interaction(x[, by]) %in% interaction(y[, by]) |
||||
# if (type == "anti") rows <- !rows |
||||
# res <- x[rows, ] |
||||
# rownames(res) <- NULL |
||||
# res |
||||
# } |
||||
lag <- function (x, n = 1L, default = NA) { |
||||
if (inherits(x, "ts")) stop("`x` must be a vector, not a `ts` object, do you want `stats::lag()`?") |
||||
if (length(n) != 1L || !is.numeric(n) || n < 0L) stop("`n` must be a nonnegative integer scalar") |
||||
if (n == 0L) return(x) |
||||
tryCatch( |
||||
storage.mode(default) <- typeof(x), |
||||
warning = function(w) { |
||||
stop("Cannot convert `default` <", typeof(default), "> to `x` <", typeof(x), ">") |
||||
} |
||||
) |
||||
xlen <- length(x) |
||||
n <- pmin(n, xlen) |
||||
res <- c(rep(default, n), x[seq_len(xlen - n)]) |
||||
attributes(res) <- attributes(x) |
||||
res |
||||
} |
||||
|
||||
lead <- function (x, n = 1L, default = NA) { |
||||
if (length(n) != 1L || !is.numeric(n) || n < 0L) stop("n must be a nonnegative integer scalar") |
||||
if (n == 0L) return(x) |
||||
tryCatch( |
||||
storage.mode(default) <- typeof(x), |
||||
warning = function(w) { |
||||
stop("Cannot convert `default` <", typeof(default), "> to `x` <", typeof(x), ">") |
||||
} |
||||
) |
||||
xlen <- length(x) |
||||
n <- pmin(n, xlen) |
||||
res <- c(x[-seq_len(n)], rep(default, n)) |
||||
attributes(res) <- attributes(x) |
||||
res |
||||
} |
||||
mutate <- function(.data, ...) { |
||||
check_is_dataframe(.data) |
||||
if ("grouped_data" %in% class(.data)) { |
||||
mutate.grouped_data(.data, ...) |
||||
} else { |
||||
mutate.default(.data, ...) |
||||
} |
||||
} |
||||
|
||||
mutate.default <- function(.data, ...) { |
||||
conditions <- deparse_dots(...) |
||||
cond_names <- names(conditions) |
||||
unnamed <- which(nchar(cond_names) == 0L) |
||||
if (is.null(cond_names)) { |
||||
names(conditions) <- conditions |
||||
} else if (length(unnamed) > 0L) { |
||||
names(conditions)[unnamed] <- conditions[unnamed] |
||||
} |
||||
not_matched <- names(conditions)[!names(conditions) %in% names(.data)] |
||||
.data[, not_matched] <- NA |
||||
context$.data <- .data |
||||
on.exit(rm(.data, envir = context)) |
||||
for (i in seq_along(conditions)) { |
||||
.data[, names(conditions)[i]] <- do.call(with, list(.data, str2lang(unname(conditions)[i]))) |
||||
} |
||||
.data |
||||
} |
||||
|
||||
mutate.grouped_data <- function(.data, ...) { |
||||
rows <- rownames(.data) |
||||
res <- apply_grouped_function(.data, "mutate", ...) |
||||
res[rows, ] |
||||
} |
||||
n_distinct <- function(..., na.rm = FALSE) { |
||||
res <- c(...) |
||||
if (is.list(res)) return(nrow(unique(as.data.frame(res, stringsAsFactors = FALSE)))) |
||||
if (isTRUE(na.rm)) res <- res[!is.na(res)] |
||||
length(unique(res)) |
||||
} |
||||
`%>%` <- function(lhs, rhs) { |
||||
lhs <- substitute(lhs) |
||||
rhs <- substitute(rhs) |
||||
eval(as.call(c(rhs[[1L]], lhs, as.list(rhs[-1L]))), envir = parent.frame()) |
||||
} |
||||
pull <- function(.data, var = -1) { |
||||
var_deparse <- deparse_var(var) |
||||
col_names <- colnames(.data) |
||||
if (!(var_deparse %in% col_names) & grepl("^[[:digit:]]+L|[[:digit:]]", var_deparse)) { |
||||
var <- as.integer(gsub("L", "", var_deparse)) |
||||
var <- if_else(var < 1L, rev(col_names)[abs(var)], col_names[var]) |
||||
} else if (var_deparse %in% col_names) { |
||||
var <- var_deparse |
||||
} |
||||
.data[, var] |
||||
} |
||||
relocate <- function(.data, ..., .before = NULL, .after = NULL) { |
||||
check_is_dataframe(.data) |
||||
data_names <- colnames(.data) |
||||
col_pos <- select_positions(.data, ...) |
||||
|
||||
.before <- deparse_var(.before) |
||||
.after <- deparse_var(.after) |
||||
has_before <- !is.null(.before) |
||||
has_after <- !is.null(.after) |
||||
|
||||
if (has_before && has_after) { |
||||
stop("You must supply only one of `.before` and `.after`") |
||||
} else if (has_before) { |
||||
where <- min(match(.before, data_names)) |
||||
col_pos <- c(setdiff(col_pos, where), where) |
||||
} else if (has_after) { |
||||
where <- max(match(.after, data_names)) |
||||
col_pos <- c(where, setdiff(col_pos, where)) |
||||
} else { |
||||
where <- 1L |
||||
col_pos <- union(col_pos, where) |
||||
} |
||||
lhs <- setdiff(seq(1L, where - 1L), col_pos) |
||||
rhs <- setdiff(seq(where + 1L, ncol(.data)), col_pos) |
||||
col_pos <- unique(c(lhs, col_pos, rhs)) |
||||
col_pos <- col_pos[col_pos <= length(data_names)] |
||||
|
||||
res <- .data[col_pos] |
||||
if (has_groups(.data)) res <- set_groups(res, get_groups(.data)) |
||||
res |
||||
} |
||||
rename <- function(.data, ...) { |
||||
check_is_dataframe(.data) |
||||
new_names <- names(deparse_dots(...)) |
||||
if (length(new_names) == 0L) { |
||||
warning("You didn't give any new names") |
||||
return(.data) |
||||
} |
||||
col_pos <- select_positions(.data, ...) |
||||
old_names <- colnames(.data)[col_pos] |
||||
new_names_zero <- nchar(new_names) == 0L |
||||
if (any(new_names_zero)) { |
||||
warning("You didn't provide new names for: ", paste0("`", old_names[new_names_zero], collapse = ", "), "`") |
||||
new_names[new_names_zero] <- old_names[new_names_zero] |
||||
} |
||||
colnames(.data)[col_pos] <- new_names |
||||
.data |
||||
} |
||||
rownames_to_column <- function(.data, var = "rowname") { |
||||
check_is_dataframe(.data) |
||||
col_names <- colnames(.data) |
||||
if (var %in% col_names) stop("Column `", var, "` already exists in `.data`") |
||||
.data[, var] <- rownames(.data) |
||||
rownames(.data) <- NULL |
||||
.data[, c(var, setdiff(col_names, var))] |
||||
} |
||||
|
||||
select <- function(.data, ...) { |
||||
map <- names(deparse_dots(...)) |
||||
col_pos <- select_positions(.data, ..., group_pos = TRUE) |
||||
res <- .data[, col_pos, drop = FALSE] |
||||
to_map <- nchar(map) > 0L |
||||
colnames(res)[to_map] <- map[to_map] |
||||
if (has_groups(.data)) res <- set_groups(res, get_groups(.data)) |
||||
res |
||||
} |
||||
starts_with <- function(match, ignore.case = TRUE, vars = peek_vars()) { |
||||
grep(pattern = paste0("^", paste0(match, collapse = "|^")), x = vars, ignore.case = ignore.case) |
||||
} |
||||
|
||||
ends_with <- function(match, ignore.case = TRUE, vars = peek_vars()) { |
||||
grep(pattern = paste0(paste0(match, collapse = "$|"), "$"), x = vars, ignore.case = ignore.case) |
||||
} |
||||
|
||||
contains <- function(match, ignore.case = TRUE, vars = peek_vars()) { |
||||
matches <- lapply( |
||||
match, |
||||
function(x) { |
||||
if (isTRUE(ignore.case)) { |
||||
match_u <- toupper(x) |
||||
match_l <- tolower(x) |
||||
pos_u <- grep(pattern = match_u, x = toupper(vars), fixed = TRUE) |
||||
pos_l <- grep(pattern = match_l, x = tolower(vars), fixed = TRUE) |
||||
unique(c(pos_l, pos_u)) |
||||
} else { |
||||
grep(pattern = x, x = vars, fixed = TRUE) |
||||
} |
||||
} |
||||
) |
||||
unique(matches) |
||||
} |
||||
|
||||
matches <- function(match, ignore.case = TRUE, perl = FALSE, vars = peek_vars()) { |
||||
grep(pattern = match, x = vars, ignore.case = ignore.case, perl = perl) |
||||
} |
||||
|
||||
num_range <- function(prefix, range, width = NULL, vars = peek_vars()) { |
||||
if (!is.null(width)) { |
||||
range <- sprintf(paste0("%0", width, "d"), range) |
||||
} |
||||
find <- paste0(prefix, range) |
||||
if (any(duplicated(vars))) { |
||||
stop("Column names must be unique") |
||||
} else { |
||||
x <- match(find, vars) |
||||
x[!is.na(x)] |
||||
} |
||||
} |
||||
|
||||
all_of <- function(x, vars = peek_vars()) { |
||||
x_ <- !x %in% vars |
||||
if (any(x_)) { |
||||
which_x_ <- which(x_) |
||||
if (length(which_x_) == 1L) { |
||||
stop("The column ", x[which_x_], " does not exist.") |
||||
} else { |
||||
stop("The columns ", paste(x[which_x_], collapse = ", "), " do not exist.") |
||||
} |
||||
} else { |
||||
which(vars %in% x) |
||||
} |
||||
} |
||||
|
||||
any_of <- function(x, vars = peek_vars()) { |
||||
which(vars %in% x) |
||||
} |
||||
|
||||
everything <- function(vars = peek_vars()) { |
||||
seq_along(vars) |
||||
} |
||||
|
||||
last_col <- function(offset = 0L, vars = peek_vars()) { |
||||
if (!is_wholenumber(offset)) stop("`offset` must be an integer") |
||||
n <- length(vars) |
||||
if (offset && n <= offset) { |
||||
stop("`offset` must be smaller than the number of `vars`") |
||||
} else if (n == 0) { |
||||
stop("Can't select last column when `vars` is empty") |
||||
} else { |
||||
n - offset |
||||
} |
||||
} |
||||
select_positions <- function(.data, ..., group_pos = FALSE) { |
||||
cols <- eval(substitute(alist(...))) |
||||
data_names <- colnames(.data) |
||||
select_env$.col_names <- data_names |
||||
on.exit(rm(list = ".col_names", envir = select_env)) |
||||
exec_env <- parent.frame(2L) |
||||
pos <- unlist(lapply(cols, eval_expr, exec_env = exec_env)) |
||||
if (isTRUE(group_pos)) { |
||||
groups <- get_groups(.data) |
||||
missing_groups <- !(groups %in% cols) |
||||
if (any(missing_groups)) { |
||||
message("Adding missing grouping variables: `", paste(groups[missing_groups], collapse = "`, `"), "`") |
||||
pos <- c(match(groups[missing_groups], data_names), pos) |
||||
} |
||||
} |
||||
unique(pos) |
||||
} |
||||
|
||||
eval_expr <- function(x, exec_env) { |
||||
type <- typeof(x) |
||||
switch( |
||||
type, |
||||
"integer" = x, |
||||
"double" = as.integer(x), |
||||
"character" = select_char(x), |
||||
"symbol" = select_symbol(x, exec_env = exec_env), |
||||
"language" = eval_call(x), |
||||
stop("Expressions of type <", typeof(x), "> cannot be evaluated for use when subsetting.") |
||||
) |
||||
} |
||||
|
||||
select_char <- function(expr) { |
||||
pos <- match(expr, select_env$.col_names) |
||||
if (is.na(pos)) stop("Column `", expr, "` does not exist") |
||||
pos |
||||
} |
||||
|
||||
select_symbol <- function(expr, exec_env) { |
||||
res <- try(select_char(as.character(expr)), silent = TRUE) |
||||
if (inherits(res, "try-error")) { |
||||
res <- tryCatch( |
||||
select_char(eval(expr, envir = exec_env)), |
||||
error = function(e) stop("Column ", expr, " does not exist.") |
||||
) |
||||
} |
||||
res |
||||
} |
||||
|
||||
eval_call <- function(x) { |
||||
type <- as.character(x[[1]]) |
||||
switch( |
||||
type, |
||||
`:` = select_seq(x), |
||||
`!` = select_negate(x), |
||||
`-` = select_minus(x), |
||||
`c` = select_c(x), |
||||
`(` = select_bracket(x), |
||||
select_context(x) |
||||
) |
||||
} |
||||
|
||||
select_seq <- function(expr) { |
||||
x <- eval_expr(expr[[2]]) |
||||
y <- eval_expr(expr[[3]]) |
||||
x:y |
||||
} |
||||
|
||||
select_negate <- function(expr) { |
||||
x <- if (is_negated_colon(expr)) { |
||||
expr <- call(":", expr[[2]][[2]], expr[[2]][[3]][[2]]) |
||||
eval_expr(expr) |
||||
} else { |
||||
eval_expr(expr[[2]]) |
||||
} |
||||
x * -1L |
||||
} |
||||
|
||||
is_negated_colon <- function(expr) { |
||||
expr[[1]] == "!" && length(expr[[2]]) > 1L && expr[[2]][[1]] == ":" && expr[[2]][[3]][[1]] == "!" |
||||
} |
||||
|
||||
select_minus <- function(expr) { |
||||
x <- eval_expr(expr[[2]]) |
||||
x * -1L |
||||
} |
||||
|
||||
select_c <- function(expr) { |
||||
lst_expr <- as.list(expr) |
||||
lst_expr[[1]] <- NULL |
||||
unlist(lapply(lst_expr, eval_expr)) |
||||
} |
||||
|
||||
select_bracket <- function(expr) { |
||||
eval_expr(expr[[2]]) |
||||
} |
||||
|
||||
select_context <- function(expr) { |
||||
eval(expr, envir = context$.data) |
||||
} |
||||
slice <- function(.data, ...) { |
||||
check_is_dataframe(.data) |
||||
if ("grouped_data" %in% class(.data)) { |
||||
slice.grouped_data(.data, ...) |
||||
} else { |
||||
slice.default(.data, ...) |
||||
} |
||||
} |
||||
|
||||
slice.default <- function(.data, ...) { |
||||
rows <- c(...) |
||||
stopifnot(is.numeric(rows) | is.integer(rows)) |
||||
if (all(rows > 0L)) rows <- rows[rows <= nrow(.data)] |
||||
.data[rows, ] |
||||
} |
||||
|
||||
slice.grouped_data <- function(.data, ...) { |
||||
apply_grouped_function(.data, "slice", ...) |
||||
} |
||||
summarise <- function(.data, ...) { |
||||
check_is_dataframe(.data) |
||||
if ("grouped_data" %in% class(.data)) { |
||||
summarise.grouped_data(.data, ...) |
||||
} else { |
||||
summarise.default(.data, ...) |
||||
} |
||||
} |
||||
|
||||
summarise.default <- function(.data, ...) { |
||||
fns <- vapply(substitute(...()), deparse, NA_character_) |
||||
context$.data <- .data |
||||
on.exit(rm(.data, envir = context)) |
||||
if (has_groups(.data)) { |
||||
group <- unique(.data[, get_groups(.data), drop = FALSE]) |
||||
if (nrow(group) == 0L) return(NULL) |
||||
} |
||||
res <- lapply(fns, function(x) do.call(with, list(.data, str2lang(x)))) |
||||
res <- as.data.frame(res) |
||||
fn_names <- names(fns) |
||||
colnames(res) <- if (is.null(fn_names)) fns else fn_names |
||||
if (has_groups(.data)) res <- cbind(group, res) |
||||
res |
||||
} |
||||
|
||||
summarise.grouped_data <- function(.data, ...) { |
||||
groups <- get_groups(.data) |
||||
res <- apply_grouped_function(.data, "summarise", ...) |
||||
res <- res[do.call(order, lapply(groups, function(x) res[, x])), ] |
||||
rownames(res) <- NULL |
||||
res |
||||
} |
||||
|
||||
summarize <- summarise |
||||
summarize.default <- summarise.default |
||||
summarize.grouped_data <- summarise.grouped_data |
||||
transmute <- function(.data, ...) { |
||||
check_is_dataframe(.data) |
||||
if ("grouped_data" %in% class(.data)) { |
||||
transmute.grouped_data(.data, ...) |
||||
} else { |
||||
transmute.default(.data, ...) |
||||
} |
||||
} |
||||
|
||||
transmute.default <- function(.data, ...) { |
||||
conditions <- deparse_dots(...) |
||||
mutated <- mutate(.data, ...) |
||||
mutated[, names(conditions), drop = FALSE] |
||||
} |
||||
|
||||
transmute.grouped_data <- function(.data, ...) { |
||||
rows <- rownames(.data) |
||||
res <- apply_grouped_function(.data, "transmute", ...) |
||||
res[rows, ] |
||||
} |
||||
deparse_dots <- function(...) { |
||||
vapply(substitute(...()), deparse, NA_character_) |
||||
} |
||||
|
||||
deparse_var <- function(var) { |
||||
sub_var <- eval(substitute(substitute(var)), parent.frame()) |
||||
if (is.symbol(sub_var)) var <- | ||||