moodymudskipper

`:=` <- . <- function(...) {
  sc <- sys.call(-1)
  if(identical(sc[[1]], quote(`[.data.frame`))) {
    sf <- sys.frames()
    env <- sf[[length(sf) - 1]]
    sc[[1]] <- quote(`[`)
    sc[[2]] <- data.table::as.data.table(env$xx)
    rlang::return_from(env, as.data.frame(eval.parent(sc)))
  } else {
    stop("wrong usage!")

moodymudskipper

`+` <- function(e1, e2) {
  if(missing(e2)) {
    sc <- sys.calls()
    i <- sapply(sc, `[`, 1) == "`[.data.frame`()"
    i <- tail(which(i), 1)
    if(length(i)) {
      data <- eval.parent(sc[[c(i, 2)]])
      col <- as.character(substitute(e1))
      return(data[[col]])
    } 

moodymudskipper

makeActiveBinding("+", function() {
  # bind fun to `-`
  fun <- `-`
  # but give it a class so we can build a deceptive printing method
  fun_class <- "april1"
  # actually also give this class a class and a printing method, 
  # so printing the class to debug won't work either
  class(fun_class) <- "april1_class"
  class(fun) <- fun_class
  fun

moodymudskipper

mutate2 <- function(.data, ...) {
  dots <- rlang::enquos(...)
  has_tilde_lgl <- sapply(dots, function(x) {
    expr <- rlang::quo_get_expr(x)
    is.call(expr) && identical(expr[[1]], quote(`~`))
    })
  inds <- which(has_tilde_lgl)
  nms <- names(dots)[inds]
  exprs <- vector("list", length(inds))
  for(i in seq_along(inds)) {

moodymudskipper

`for` <- function(it, seq, expr) {
  if(!identical(substitute(it), quote(.))) {
    tryCatch(
      eval.parent(substitute(base::`for`(it, seq, expr))),
      error = function(e) {stop(c("In `for`: ", e$message), call. = FALSE)})
    return(invisible())
  }
  l <- length(seq[[1]])
  nms1 <- names(seq)
  nms2 <- paste0("*", names(seq), "*")

moodymudskipper

# run from R GUI or you might have methods registered by IDE

# first method scrape S3 method tables, classes with no methods are not found
# second method parses code to find `class(foo) <- bar` lines and extracts string litterals if found, we could be a bit smarter there
#   and find more, but that will still not be exhaustive, because we have things like `class(x) <- cl` and we'd have to check the code
#   to see what `cl` is.
# we could also check if some objects are built with `structure`
# calls to `inherits` might also be checked
# The C code should also be inspected or we won't find for instance the "error" or "try-error" classes.

moodymudskipper

`:=` <- function(var, value) {
  if(is.function(value)) {
    # leverage magic to edit attributes and add checks
    # return(edited_function)
    stop("not implemented")
  }
  var_nm <- as.character(substitute(var))
  eval.parent(substitute(
    makeActiveBinding(
      var_nm, 

moodymudskipper

options(typed.typed = TRUE)

`%typed%` <- function(e1, e2) {
  if(getOption("typed.typed")) {
    assert_call <- substitute(e1)
    assert_call[[1]] <- quote(assertthat::assert_that)
    eval.parent(assert_call)
  }
  e2
}

moodymudskipper

decompose <- function(expr) {
  expr <- substitute(expr)
  funs <- setdiff(all.names(expr), all.vars(expr))
  wrapped <- list()
  for (fun in funs) {
    fun_env <- environment(get(fun, envir = parent.frame()))
    if(is.null(fun_env))
      namespace <- "base"
    else
      namespace <- getNamespaceName(fun_env)

moodymudskipper

# install packages temporarily

tmp.install.packages <- function(pack, dependencies=TRUE, ...) {
  path <- tempdir()
  ## Add 'path' to .libPaths, and be sure that it is not
  ## at the first position, otherwise any other package during
  ## this session would be installed into 'path'
  firstpath <- .libPaths()[1]
  .libPaths(c(firstpath, path))