################################################################################
verif_lgl <- function(x, n, i) {
if (is.logical(x) && length(x) %in% c(1, n)) return(x)
stop2("Expression #%d does not evaluate to a logical vector of length 1 or %d.", i, n)
}
################################################################################
#' @inherit dplyr::filter title description return params
#'
#' @param .data A [FDF][FDF-class].
#'
#' @importFrom dplyr filter
#' @export
#' @method filter FDF
#'
#' @rdname filter
#'
#' @examples
#' (test <- FDF(datasets::iris))
#' filter(test, Species == "setosa")
#' filter(test, Species == "setosa", Sepal.Length < 5)
filter.FDF <- function(.data, ...) {
dots <- quos(...)
if (length(dots) == 0) return(.data)
groups <- .data$groups
list_ind_row <- groups$ind_row
# Get some variables in memory
names_involved <- unique(unlist(lapply(dots, get_call_names)))
names_to_get <- intersect(.data$colnames, names_involved)
names_pulled <- lapply(set_names(names_to_get), function(var_name) {
extract_var(.data, var_name, list_ind_row)
})
parent_env <- lapply(dots, quo_get_env)
n_defined <- lapply(parent_env, find_n)
indices <- lapply(seq_along(list_ind_row), function(k) {
l_k <- length(indices_k <- list_ind_row[[k]])
names_pulled_group_k <- lapply(names_pulled, function(x) x[[k]])
list_bool <- lapply(seq_along(dots), function(i) {
q <- quo_modif(dots[[i]], n_defined[[i]], val = l_k, env = parent_env[[i]])
verif_lgl(eval_tidy(q, data = names_pulled_group_k), l_k, i)
})
indices_k[Reduce('&', list_bool)]
})
if (.data$is_grouped) {
groups$ind_row <- indices
.data$copy(ind_row = intersect(.data$ind_row, unlist(indices)),
groups_internal = groups[lengths(indices) != 0, ])
} else {
.data$copy(ind_row = indices[[1]])
}
}
################################################################################
#' @export
#'
#' @param subset Integer vector to (further) subset `.data$ind_row`.
#' @param check Whether to check `subset`? Default is `TRUE`.
#'
#' @rdname filter
#'
#' @examples
#' filter_int(test, 1:50)
filter_int <- function(.data, subset, check = TRUE) {
ind_row_filtered <- .data$ind_row[subset]
if (check && anyNA(ind_row_filtered))
stop2("'subset' must have values between 1 and %d", .data$nrow)
if (.data$is_grouped) {
## TODO: optimize
groups <- .data$groups
groups$ind_row <- lapply(groups$ind_row, function(ind) {
ind_rel <- match_int(ind, ind_row_filtered)
has_match <- !is.na(ind_rel)
ind[has_match][order(ind_rel[has_match])]
})
.data$copy(ind_row = ind_row_filtered,
groups_internal = groups[lengths(groups$ind_row) != 0, ])
} else {
.data$copy(ind_row = ind_row_filtered)
}
}
################################################################################
#' @exportMethod filter
#' @rdname filter
setGeneric("filter", dplyr::filter)
################################################################################
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.