R/standalone-lazyeval.R

In tidyverse/rlang: Functions for Base Types and Core R and 'Tidyverse' Features

# ---
# repo: r-lib/rlang
# file: standalone-lazyeval.R
# last-updated: 2018-09-18
# license: https://unlicense.org
# imports: rlang
# ---
#
# This file serves as a reference for compatibility functions for lazyeval.
#
# nocov start

warn_underscored <- function() {
  return(NULL)
  warn(paste(
    "The underscored versions are deprecated in favour of",
    "tidy evaluation idioms. Please see the documentation",
    "for `quo()` in rlang"
  ))
}
warn_text_se <- function() {
  return(NULL)
  warn("Text parsing is deprecated, please supply an expression or formula")
}

compat_lazy <- function(lazy, env = caller_env(), warn = TRUE) {
  if (warn) warn_underscored()

  if (missing(lazy)) {
    return(quo())
  }
  if (is_quosure(lazy)) {
    return(lazy)
  }
  if (is_formula(lazy)) {
    return(as_quosure(lazy, env))
  }

  out <- switch(typeof(lazy),
    symbol = ,
    language = new_quosure(lazy, env),
    character = {
      if (warn) warn_text_se()
      parse_quo(lazy[[1]], env)
    },
    logical = ,
    integer = ,
    double = {
      if (length(lazy) > 1) {
        warn("Truncating vector to length 1")
        lazy <- lazy[[1]]
      }
      new_quosure(lazy, env)
    },
    list =
      if (inherits(lazy, "lazy")) {
        lazy = new_quosure(lazy$expr, lazy$env)
      }
  )

  if (is_null(out)) {
    abort(sprintf("Can't convert a %s to a quosure", typeof(lazy)))
  } else {
    out
  }
}

compat_lazy_dots <- function(dots, env, ..., .named = FALSE) {
  if (missing(dots)) {
    dots <- list()
  }
  if (inherits(dots, c("lazy", "formula"))) {
    dots <- list(dots)
  } else {
    dots <- unclass(dots)
  }
  dots <- c(dots, list(...))

  warn <- TRUE
  for (i in seq_along(dots)) {
    dots[[i]] <- compat_lazy(dots[[i]], env, warn)
    warn <- FALSE
  }

  named <- have_name(dots)
  if (.named && any(!named)) {
    nms <- vapply(dots[!named], function(x) expr_text(get_expr(x)), character(1))
    names(dots)[!named] <- nms
  }

  names(dots) <- names2(dots)
  dots
}

compat_as_lazy <- function(quo) {
  structure(class = "lazy", list(
    expr = get_expr(quo),
    env = get_env(quo)
  ))
}
compat_as_lazy_dots <- function(...) {
  structure(class = "lazy_dots", lapply(quos(...), compat_as_lazy))
}


# nocov end