Skip to content

Instantly share code, notes, and snippets.

@lionel-
lionel- / remap.R
Last active August 29, 2015 14:12
Preserving version of lowliner's map()
remap <- function(.x, .f, ...) {
.f <- lowliner:::as_function(.f)
if (inherits(.f, "fseq")) {
# Handle magrittr's functional sequences
f_env <- environment(.f)
f_env$`_function_list` <- map(f_env$`_function_list`, ~ {
env <- new.env(parent = environment(.))
environment(.) <- env
.
@lionel-
lionel- / by-group.R
Last active August 29, 2015 14:14
Making lowliner better understand data frames
set_groups <- function(.d, .cols = NULL) {
stopifnot(is.data.frame(.d))
if (is.null(.cols)) {
return(group_by_(.d, .dots = list()))
}
if (is.numeric(.cols)) {
.cols <- names(.d)[.cols]
}
.cols %>% map_call(dplyr::group_by_, .data = .d)
### Install monad-aware magrittr
devtools::dev_mode(TRUE)
devtools::install_github("lionel-/magrittr", ref = "monads")
### Monadic Infrastructure
bind <- function(x, fun, ...) {
UseMethod("bind")
library("rlang")
#' @import rlang
`%>%` <- function(x, y) {
lhs <- rlang:::captureArg(x)
lhs_value <- eval_bare(lhs$expr, lhs$env)
@lionel-
lionel- / depend.R
Last active December 2, 2017 14:01
Handle hard dependencies in library()
depend <- function(..., character.only = FALSE) {
# Mimic library()'s UI
if (character.only) {
packages <- c(...)
} else {
packages <- substitute(c(...))[-1]
if (!all(vapply(packages, is.symbol, logical(1)))) {
stop("Can't supply expressions if `character.only` is FALSE")
}
@lionel-
lionel- / magrittr-tidy-eval.R
Last active December 17, 2017 10:19
Unquoting RHS of magrittr pipe with quosure support
# Actually does not work because quosured magrittr pronouns are not
# evaluated in the right environment
library("magrittr")
library("rlang")
# Anticipate renaming of `quo_is_lang()` in rlang
quo_is_call <- quo_is_lang
@lionel-
lionel- / starts-with.R
Created April 9, 2019 08:31
Does a vector start with the same values as another vector
truncate_len <- function(x, n) {
if (length(x) < n) {
stop("Can't truncate vector to the given length because it is already shorter")
}
x[seq_len(n)]
}
truncate_along <- function(x, y) {
truncate_len(x, length(y))
@lionel-
lionel- / wrapping-dt.R
Created June 25, 2019 10:54
Wrapping DT
# Simple DT wrapper
summarise <- function(data, j, by) {
data <- data.table::as.data.table(data)
data[
i = ,
j = eval(substitute(j)),
by = eval(substitute(by))
]
}
@lionel-
lionel- / recode.R
Created July 22, 2019 12:30
Recoding values
# The general idea is to supply a recoding specification through a
# data frame of keys and values. They keys are a generalisation of
# names, they can be any type.
keys <- function(key, value) {
tibble::tibble(.key = key, .value = value)
}
dribbleys <- function(...) {
tibble::tribble(~ .key, ~ .value, ...)
makeDelayedBinding <- function(sym,
expr,
eval.env = parent.frame(1),
assign.env = parent.frame(1)) {
expr <- substitute(expr)
value <- NULL
forced <- FALSE
forceDelayed <- function() {