Repository: hadley/pryr
Branch: master
Commit: 7f1600d7b64a
Files: 109
Total size: 122.8 KB

Directory structure:
gitextract_l8on2fz7/

├── .Rbuildignore
├── .github/
│   ├── .gitignore
│   └── workflows/
│       └── R-CMD-check.yaml
├── .gitignore
├── .travis.yml
├── DESCRIPTION
├── NAMESPACE
├── NEWS.md
├── R/
│   ├── RcppExports.R
│   ├── active.r
│   ├── assign-active.r
│   ├── assign-constant.r
│   ├── assign-delayed.r
│   ├── bytes.r
│   ├── compose.r
│   ├── dots.r
│   ├── draw-tree.r
│   ├── enclosing.R
│   ├── explicit-promise.R
│   ├── f.r
│   ├── fget.r
│   ├── find-funs.r
│   ├── find_uses.R
│   ├── ftype.r
│   ├── inspect.r
│   ├── make-call.R
│   ├── make-function.r
│   ├── mem.R
│   ├── method-from-call.r
│   ├── modify-call.R
│   ├── modify-lang.r
│   ├── names_c.R
│   ├── object_size.R
│   ├── otype.r
│   ├── parenv.r
│   ├── partial.r
│   ├── promise.r
│   ├── rebind.r
│   ├── rls.r
│   ├── s3.r
│   ├── standardise-call.r
│   ├── substitute.r
│   ├── unenclose.r
│   ├── uneval.r
│   ├── utils.r
│   └── where.r
├── README.md
├── benchmark/
│   └── make-function.r
├── cran-comments.md
├── man/
│   ├── as.envlist.Rd
│   ├── assign-active.Rd
│   ├── assign-constant.Rd
│   ├── assign-delayed.Rd
│   ├── bytes.Rd
│   ├── call_tree.Rd
│   ├── compose.Rd
│   ├── dots.Rd
│   ├── enclosing_env.Rd
│   ├── explicit.Rd
│   ├── f.Rd
│   ├── fget.Rd
│   ├── find_funs.Rd
│   ├── find_uses.Rd
│   ├── ftype.Rd
│   ├── inspect.Rd
│   ├── is_active_binding.Rd
│   ├── is_promise.Rd
│   ├── is_s3_generic.Rd
│   ├── make_call.Rd
│   ├── make_function.Rd
│   ├── mem_change.Rd
│   ├── mem_used.Rd
│   ├── method_from_call.Rd
│   ├── modify_call.Rd
│   ├── modify_lang.Rd
│   ├── names_c.Rd
│   ├── object_size.Rd
│   ├── otype.Rd
│   ├── parent_promise.Rd
│   ├── parenv.Rd
│   ├── parenvs.Rd
│   ├── partial.Rd
│   ├── print.envlist.Rd
│   ├── rebind.Rd
│   ├── rls.Rd
│   ├── show_c_source.Rd
│   ├── standardise_call.Rd
│   ├── subs.Rd
│   ├── substitute_q.Rd
│   ├── track_copy.Rd
│   ├── unenclose.Rd
│   ├── uneval.Rd
│   └── where.Rd
├── pryr.Rproj
├── src/
│   ├── .gitignore
│   ├── RcppExports.cpp
│   ├── bytes.cpp
│   ├── inspect.cpp
│   ├── promise.cpp
│   ├── slice.cpp
│   └── typename.cpp
└── tests/
    ├── testthat/
    │   ├── helper-object_size.R
    │   ├── test-active-binding.r
    │   ├── test-bytes.r
    │   ├── test-ftype.r
    │   ├── test-method-from-call.r
    │   ├── test-object_size.R
    │   └── test-track-copy.R
    └── testthat.R

================================================
FILE CONTENTS
================================================

================================================
FILE: .Rbuildignore
================================================
^.*\.Rproj$
^\.Rproj\.user$
benchmark
^\.travis\.yml$
^cran-comments\.md$
^NEWS\.md$
^revdep$
^CRAN-RELEASE$
^\.github$
^CRAN-SUBMISSION$


================================================
FILE: .github/.gitignore
================================================
*.html


================================================
FILE: .github/workflows/R-CMD-check.yaml
================================================
# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples
# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
on:
  push:
    branches: [main, master]
  pull_request:
    branches: [main, master]

name: R-CMD-check

jobs:
  R-CMD-check:
    runs-on: ${{ matrix.config.os }}

    name: ${{ matrix.config.os }} (${{ matrix.config.r }})

    strategy:
      fail-fast: false
      matrix:
        config:
          - {os: macos-latest,   r: 'release'}
          - {os: windows-latest, r: 'release'}
          - {os: ubuntu-latest,   r: 'devel', http-user-agent: 'release'}
          - {os: ubuntu-latest,   r: 'release'}
          - {os: ubuntu-latest,   r: 'oldrel-1'}

    env:
      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
      R_KEEP_PKG_SOURCE: yes

    steps:
      - uses: actions/checkout@v3

      - uses: r-lib/actions/setup-pandoc@v2

      - uses: r-lib/actions/setup-r@v2
        with:
          r-version: ${{ matrix.config.r }}
          http-user-agent: ${{ matrix.config.http-user-agent }}
          use-public-rspm: true

      - uses: r-lib/actions/setup-r-dependencies@v2
        with:
          extra-packages: any::rcmdcheck
          needs: check

      - uses: r-lib/actions/check-r-package@v2
        with:
          upload-snapshots: true


================================================
FILE: .gitignore
================================================
.Rproj.user
.Rhistory
.RData
src/*.o
src/*.so
src/*.dll


================================================
FILE: .travis.yml
================================================
# R for travis: see documentation at https://docs.travis-ci.com/user/languages/r

language: r
sudo: false
cache: packages

matrix:
  include:
    - r: 3.1
    - r: oldrel
    - r: release
      env: R_CODECOV=true
    - r: devel

after_success:
  - if [[ "${R_CODECOV}" ]]; then R -e 'covr::codecov()'; fi


================================================
FILE: DESCRIPTION
================================================
Package: pryr
Title: Tools for Computing on the Language
Version: 0.1.6.9000
Authors@R: c(
    person("Hadley", "Wickham", , "hadley@rstudio.com", role = c("aut", "cre")),
    person("R Core team", role = "ctb",
           comment = "Some code extracted from base R")
  )
Description: Useful tools to pry back the covers of R and understand the
    language at a deeper level.
License: GPL-2
URL: https://github.com/hadley/pryr
BugReports: https://github.com/hadley/pryr/issues
Depends:
    R (>= 3.1.0)
Imports:
    codetools,
    lobstr,
    methods,
    Rcpp (>= 0.11.0),
    stringr
Suggests:
    testthat (>= 0.8.0)
LinkingTo: 
    Rcpp
Encoding: UTF-8
RoxygenNote: 7.2.3


================================================
FILE: NAMESPACE
================================================
# Generated by roxygen2: do not edit by hand

S3method("[",envlist)
S3method(print,envlist)
S3method(print,inspect)
S3method(print,inspect_NILSXP)
S3method(print,pryr_bytes)
export("%.%")
export("%<a-%")
export("%<c-%")
export("%<d-%")
export(address)
export(as.envlist)
export(ast)
export(bits)
export(bytes)
export(call_tree)
export(compare_size)
export(compose)
export(do_call)
export(dots)
export(enclosing_env)
export(eval2)
export(explicit)
export(f)
export(fget)
export(find_funs)
export(find_uses)
export(ftype)
export(fun_args)
export(fun_body)
export(fun_calls)
export(inspect)
export(is_active_binding)
export(is_promise)
export(is_s3_generic)
export(is_s3_method)
export(make_call)
export(make_function)
export(mem_change)
export(mem_used)
export(method_from_call)
export(modify_call)
export(modify_lang)
export(named_dots)
export(names_c)
export(object_size)
export(otype)
export(parent_promise)
export(parenv)
export(parenvs)
export(partial)
export(promise_info)
export(rebind)
export(refs)
export(rls)
export(sexp_type)
export(show_c_source)
export(standardise_call)
export(subs)
export(substitute_q)
export(track_copy)
export(typename)
export(unenclose)
export(uneval)
export(where)
importFrom(Rcpp,sourceCpp)
importFrom(codetools,findGlobals)
importFrom(methods,getGroupMembers)
importFrom(methods,is)
importFrom(stringr,str_c)
importFrom(stringr,str_dup)
importFrom(stringr,str_length)
importFrom(stringr,str_sub)
useDynLib(pryr)


================================================
FILE: NEWS.md
================================================
# pryr (development version)

# pryr 0.1.6

* Switch from `sprintf()` to `snprintf()`.

# pryr 0.1.5

* Compatibility with R devel.

# pryr 0.1.4

* Compatibility with R devel.

# pryr 0.1.3

* Compatibility with R devel.

* `object_size()` now supports dots in closure environments.

# pryr 0.1.2

* `track_copy()` no longer reports deletes as copies (#34).

* Added `is_active_binding()` (@richfitz, #33).

* Fixed think-o in `stop_list()`.

* Fixed a warning in `%<a-%` when reassigning an active binding
  (@leeper, #39).


# pryr 0.1.1

* `address()` no longer changes `NAMED()` status of x (#24).

* Use non-internal `nonS3Methods()` where needed (#38).

* `explicit()` and `eval2()` are deprecated. Please use the lazyeval
  package instead (#27)


================================================
FILE: R/RcppExports.R
================================================
# Generated by using Rcpp::compileAttributes() -> do not edit by hand
# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393

binary_repr <- function(x) {
    .Call('_pryr_binary_repr', PACKAGE = 'pryr', x)
}

hex_repr <- function(x) {
    .Call('_pryr_hex_repr', PACKAGE = 'pryr', x)
}

binary2hex <- function(x) {
    .Call('_pryr_binary2hex', PACKAGE = 'pryr', x)
}

inspect_ <- function(x, base_env) {
    .Call('_pryr_inspect_', PACKAGE = 'pryr', x, base_env)
}

address2 <- function(name, env) {
    .Call('_pryr_address2', PACKAGE = 'pryr', name, env)
}

named2 <- function(name, env) {
    .Call('_pryr_named2', PACKAGE = 'pryr', name, env)
}

is_promise2 <- function(name, env) {
    .Call('_pryr_is_promise2', PACKAGE = 'pryr', name, env)
}

promise_code <- function(name, env) {
    .Call('_pryr_promise_code', PACKAGE = 'pryr', name, env)
}

promise_value <- function(name, env) {
    .Call('_pryr_promise_value', PACKAGE = 'pryr', name, env)
}

promise_evaled <- function(name, env) {
    .Call('_pryr_promise_evaled', PACKAGE = 'pryr', name, env)
}

promise_env <- function(name, env) {
    .Call('_pryr_promise_env', PACKAGE = 'pryr', name, env)
}

makeExplicit <- function(prom) {
    .Call('_pryr_makeExplicit', PACKAGE = 'pryr', prom)
}

explicitPromise <- function(name, env) {
    .Call('_pryr_explicitPromise', PACKAGE = 'pryr', name, env)
}

explicitDots <- function(env) {
    .Call('_pryr_explicitDots', PACKAGE = 'pryr', env)
}

slice <- function(x, k, sep = " ") {
    .Call('_pryr_slice', PACKAGE = 'pryr', x, k, sep)
}

#' @export
#' @rdname inspect
sexp_type <- function(x) {
    .Call('_pryr_sexp_type', PACKAGE = 'pryr', x)
}

typename2 <- function(name, env) {
    .Call('_pryr_typename2', PACKAGE = 'pryr', name, env)
}



================================================
FILE: R/active.r
================================================
#' Active binding info
#' 
#' @param x unquoted object name
#' @export
#' @examples
#' x <- 10
#' is_active_binding(x)
#' x %<a-% runif(1)
#' is_active_binding(x)
#' y <- x
#' is_active_binding(y)
is_active_binding <- function(x) {
  bindingIsActive(substitute(x), parent.frame())
}


================================================
FILE: R/assign-active.r
================================================
#' Create an active binding.
#'
#' Infix form of \code{\link{makeActiveBinding}} which creates an \emph{active}
#' binding between a name and an expression: every time the name is accessed
#' the expression is recomputed.
#'
#' @usage x \%<a-\% value
#' @param x unquoted expression naming variable to create
#' @param value unquoted expression to evaluate every time \code{name} is
#'   accessed
#' @export
#' @rdname assign-active
#' @examples
#' x %<a-% runif(1)
#' x
#' x
#' x %<a-% runif(10)
#' x
#' x
#' rm(x)
"%<a-%" <- function(x, value) {
  x <- substitute(x)
  value <- substitute(value)

  if (!is.name(x)) stop("Left-hand side must be a name")

  env <- parent.frame()
  f <- make_function(alist(value = ), value, env)

  # Mimic regular assignment operation which overrides existing bindings
  if (exists(deparse(x), envir = env, inherits = FALSE)) {
    rm(list = deparse(x), envir = env)
  }

  makeActiveBinding(deparse(x), f, env)
}


================================================
FILE: R/assign-constant.r
================================================
#' Create a constant (locked) binding.
#'
#' Infix wrapper for \code{\link{assign}} + \code{\link{lockBinding}} that
#' creates a constant: a binding whose value can not be changed.
#'
#' @usage x \%<c-\% value
#' @param x unquoted expression naming variable to create
#' @param value constant value
#' @export
#' @rdname assign-constant
#' @examples
#' x %<c-% 10
#' #' Generates an error:
#' \dontrun{x <- 20}
#'
#' # Note that because of R's operator precedence rules, you
#' # need to wrap compound RHS expressions in ()
#' y %<c-% 1 + 2
#' y
#' z %<c-% (1 + 2)
#' z
"%<c-%" <- function(x, value) {
  name <- substitute(x)
  if (!is.name(name)) stop("Left-hand side must be a name")

  env <- parent.frame()
  assign(as.character(name), value, env)
  lockBinding(name, env)

  invisible(value)
}


================================================
FILE: R/assign-delayed.r
================================================
#' Create an delayed binding.
#'
#' Infix form of \code{\link{delayedAssign}} which creates an \emph{delayed}
#' or lazy binding, which only evaluates the expression the first time it is
#' used.
#'
#' @usage x \%<d-\% value
#' @param x unquoted expression naming variable to create
#' @param value unquoted expression to evaluate the first time \code{name} is
#'   accessed
#' @export
#' @rdname assign-delayed
#' @examples
#' x %<d-% (a + b)
#' a <- 10
#' b <- 100
#' x
"%<d-%" <- function(x, value) {
  name <- substitute(x)
  value <- substitute(value)

  if (!is.name(name)) stop("Left-hand side must be a name")

  env <- parent.frame()
  call <- substitute(delayedAssign(deparse(name), value,
    eval.env = env, assign.env = env), list(value = value))
  eval(call)

  invisible()
}


================================================
FILE: R/bytes.r
================================================
#' Print the byte-wise representation of a value
#'
#' @param x An \R vector of type \code{integer}, \code{numeric}, \code{logical}
#'   or \code{character}.
#' @param split Whether we should split the output string at each byte.
#' @export
#' @examples
#' ## Encoding doesn't change the internal bytes used to represent characters;
#' ## it just changes how they are interpretted!
#'
#' x <- y <- z <- "\u9b3c"
#' Encoding(y) <- "bytes"
#' Encoding(z) <- "latin1"
#' print(x); print(y); print(z)
#' bytes(x); bytes(y); bytes(z)
#' bits(x); bits(y); bits(z)
#'
#' ## In R, integers are signed ints. The first bit indicates the sign, but
#' ## values are stored in a two's complement representation. We see that
#' ## NA_integer_ is really just the smallest negative integer that can be
#' ## stored in 4 bytes
#' bits(NA_integer_)
#'
#' ## There are multiple kinds of NAs, NaNs for real numbers
#' ## (at least, on 64bit architectures)
#' print( c(NA_real_, NA_real_ + 1) )
#' rbind( bytes(NA_real_), bytes(NA_real_ + 1) )
#' rbind( bytes(NaN), bytes(0/0) )
#' @references
#' \url{https://en.wikipedia.org/wiki/Two's_complement} for more
#' information on the representation used for \code{int}s.
#'
#' \url{https://en.wikipedia.org/wiki/IEEE_floating_point} for more
#' information the floating-point representation used for \code{double}s.
#'
#' \url{https://en.wikipedia.org/wiki/Character_encoding} for an introduction
#' to character encoding, and \code{?\link{Encoding}} for more information on
#' how \R handles character encoding.
bytes <- function(x, split = TRUE) {
  repr <- hex_repr(x)
  if (split) slice(repr, 2L)
  else repr
}

#' @rdname bytes
#' @export
bits <- function(x, split = TRUE) {
  repr <- binary_repr(x)
  if (split) slice(repr, 8L)
  else repr
}


================================================
FILE: R/compose.r
================================================
#' Compose multiple functions
#'
#' In infix and prefix forms.
#'
#' @param ... n functions to apply in order from right to left
#' @param f,g two functions to compose for the infix form
#'
#' @export
#' @examples
#' not_null <- `!` %.% is.null
#' not_null(4)
#' not_null(NULL)
#' 
#' add1 <- function(x) x + 1
#' compose(add1,add1)(8)
compose <- function(...) {
  fs <- lapply(list(...), match.fun)
  n <- length(fs)

  last <- fs[[n]]
  rest <- fs[-n]

  function(...) {
    out <- last(...)
    for (f in rev(rest)) {
      out <- f(out)
    }
    out
  }
}

#' @rdname compose
#' @export
#' @usage f \%.\% g
'%.%' <- function(f, g) {
  f <- match.fun(f)
  g <- match.fun(g)
  function(...) {
    f(g(...))
  }
}


================================================
FILE: R/dots.r
================================================
#' Capture unevaluated dots.
#'
#' @param ... \code{...} passed in to the parent function
#' @return a list of expressions (not expression objects). \code{named_dots}
#'  will use the deparsed expressions as default names.
#' @export
#' @examples
#' y <- 2
#' str(dots(x = 1, y, z = ))
#' str(named_dots(x = 1, y, z =))
dots <- function(...) {
  eval(substitute(alist(...)))
}

#' @rdname dots
#' @export
named_dots <- function(...) {
  args <- dots(...)

  nms <- names(args) %||% rep("", length(args))
  missing <- nms == ""
  if (all(!missing)) return(args)

  deparse2 <- function(x) paste(deparse(x, 500L), collapse = "")
  defaults <- vapply(args[missing], deparse2, character(1), USE.NAMES = FALSE)

  names(args)[missing] <- defaults
  args
}


================================================
FILE: R/draw-tree.r
================================================
#' Display a call (or expression) as a tree.
#'
#' \code{call_tree} takes a quoted expression. \code{ast} does the quoting
#' for you.
#'
#' @param x quoted call, list of calls, or expression to display
#' @param width displays width, defaults to current width as reported by
#'   \code{getOption("width")}
#' @export
#' @examples
#' call_tree(quote(f(x, 1, g(), h(i()))))
#' call_tree(quote(if (TRUE) 3 else 4))
#' call_tree(expression(1, 2, 3))
#'
#' ast(f(x, 1, g(), h(i())))
#' ast(if (TRUE) 3 else 4)
#' ast(function(a = 1, b = 2) {a + b})
#' ast(f()()())
#' @importFrom stringr str_c
call_tree <- function(x, width = getOption("width")) {
  if (is.expression(x) || is.list(x)) {
    trees <- vapply(x, tree, character(1), width = width)
    out <- str_c(trees, collapse = "\n\n")
  } else {
    out <- tree(x, width = width)
  }

  cat(out, "\n")
}

#' @rdname call_tree
#' @export
ast <- function(x) call_tree(substitute(x))

#' @importFrom stringr str_c str_length str_sub
str_trunc <- function(x, width = getOption("width")) {
  ifelse(str_length(x) <= width, x, str_c(str_sub(x, 1, width - 3), "..."))
}

#' @importFrom stringr str_c str_dup
tree <- function(x, level = 1, width = getOption("width"), branch = "\\- ") {
  indent <- str_c(str_dup("  ", level - 1), branch)

  if (is.atomic(x) && length(x) == 1) {
    label <- paste0(" ", deparse(x)[1])
    children <- NULL
  } else if (is.name(x)) {
    x <- as.character(x)
    if (x == "") {
      # Special case the missing argument
      label <- "`MISSING"
    } else {
      label <- paste0("`", as.character(x))
    }

    children <- NULL
  } else if (is.call(x)) {
    label <- "()"
    children <-  vapply(as.list(x), tree, character(1),
      level = level + 1, width = width - 3)
  } else if (is.pairlist(x)) {
    label <- "[]"

    branches <- paste("\\", format(names(x)), "=")
    children <- character(length(x))
    for (i in seq_along(x)) {
      children[i] <- tree(x[[i]], level = level + 1, width = width - 3,
        branch = branches[i])
    }
  } else {
    # Special case for srcrefs, since they're commonly seen
    if (inherits(x, "srcref")) {
      label <- "<srcref>"
    } else {
      label <- paste0("<", typeof(x), ">")
    }
    children <- NULL
  }

  label <- str_trunc(label, width - 3)

  if (is.null(children)) {
    paste0(indent, label)
  } else {
    paste0(indent, label, "\n", paste0(children, collapse = "\n"))
  }
}


================================================
FILE: R/enclosing.R
================================================
#' Find the environment that encloses of a function.
#'
#' This is a wrapper around \code{\link{environment}} with a
#' consistent syntax.
#'
#' @param f The name of a function.
#' @export
#' @examples
#' enclosing_env("plot")
#' enclosing_env("t.test")
enclosing_env <- function(f) {
  f <- match.fun(f)
  environment(f)
}


================================================
FILE: R/explicit-promise.R
================================================
#' Tools for making promises explicit
#'
#' Deprecated: please use the lazyeval package instead.
#'
#' @param x expression to make explicit, or to evaluate.
#' @export
explicit <- function(x) {
  .Deprecated("Please use the lazyeval package instead")

  explicitPromise(substitute(x), parent.frame())
}

#' @rdname explicit
#' @export
#' @param data Data in which to evaluate code
#' @param env Enclosing environment to use if data is a list or data frame.
eval2 <- function(x, data = NULL, env = parent.frame()) {
  .Deprecated("Please use the lazyeval package instead")
  if (is.formula(x)) {
    env <- environment(x)
    x <- x[[2]] # RHS of the formula
  }

  if (is.atomic(x)) return(x)
  stopifnot(is.call(x) || is.name(x))

  if (!is.null(data)) {
    eval(x, data, env)
  } else {
    eval(x, env)
  }
}

is.formula <- function(x) inherits(x, "formula")


================================================
FILE: R/f.r
================================================
#' A compact syntax for anonymous functions.
#'
#' @param ... The last argument is the body of the function, all others are
#'   arguments to the function.  If there is only one argument, the formals
#'   are guessed from the code.
#' @param .env parent environment of the created function
#' @return a function
#' @export
#' @importFrom codetools findGlobals
#' @examples
#' f(x + y)
#' f(x + y)(1, 10)
#' f(x, y = 2, x + y)
#'
#' f({y <- runif(1); x + y})
f <- function(..., .env = parent.frame()) {
  dots <- match.call(expand.dots = FALSE)$`...`
  n <- length(dots)

  if (n == 1) {
    fun <- make_function(alist(... = ), dots[[1]], .env)

    names <- findGlobals(fun, merge = FALSE)$variables
    args <- stats::setNames(rep(list(substitute()), length(names)), names)
    formals(fun) <- args

    fun
  } else {
    body <- dots[[n]]
    args <- dots[-n]

    # translate unnamed args into named empty symbols
    bare <- (names(args) %||% rep("", length(args))) == ""
    bare_names <- vapply(args[bare], as.character, character(1))
    bare_names[bare_names == ".dots"] <- "..."

    args[bare] <- rep(list(substitute()), sum(bare))
    names(args)[bare] <- bare_names

    make_function(args, body, .env)
  }
}


================================================
FILE: R/fget.r
================================================
#' Find a function with specified name.
#'
#' @param name length one character vector giving name
#' @param env environment to start search in.
#' @export
#' @examples
#' c <- 10
#' fget("c")
fget <- function(name, env = parent.frame()) {
  env <- to_env(env)
  if (identical(env, emptyenv())) {
    stop("Could not find function called ", name, call. = FALSE)
  }

  if (exists(name, env, inherits = FALSE) && is.function(env[[name]])) {
    env[[name]]
  } else {
    fget(name, parent.env(env))
  }
}


================================================
FILE: R/find-funs.r
================================================
#' Find functions matching criteria.
#'
#' This is a flexible function that matches function component against
#' a regular expression, returning the name of the function if there are any
#' matches. \code{fun_args} and \code{fun_calls} are helper functions that
#' make it possible to search for functions with specified argument names, or
#' which call certain functions.
#'
#' @param env environment in which to search for functions
#' @param extract component of function to extract. Should be a function that
#'   takes a function as input as returns a character vector as output,
#'   like \code{fun_calls} or \code{fun_args}.
#' @param pattern \pkg{stringr} regular expression to results of \code{extract}
#'   function.
#' @param ... other arguments passed on to \code{\link{grepl}}
#' @export
#' @examples
#' find_funs("package:base", fun_calls, "match.fun", fixed = TRUE)
#' find_funs("package:stats", fun_args, "^[A-Z]+$")
#'
#' fun_calls(match.call)
#' fun_calls(write.csv)
#'
#' fun_body(write.csv)
#' find_funs("package:utils", fun_body, "write", fixed = TRUE)
find_funs <- function(env = parent.frame(), extract, pattern, ...) {
  env <- to_env(env)
  if (length(pattern) > 1) pattern <- str_c(pattern, collapse = "|")

  test <- function(x) {
    f <- get(x, env)
    if (!is.function(f)) return(FALSE)

    any(grepl(pattern, extract(f) ,...))
  }

  fs <- ls(env)
  Filter(test, fs)
}

#' @export
#' @rdname find_funs
#' @param f function to extract information from
fun_calls <- function(f) {
  if (is.function(f)) {
    fun_calls(body(f))
  } else if (is.call(f)) {
    fname <- as.character(f[[1]])

    # Calls inside .Internal are special and shouldn't be included
    if (identical(fname, ".Internal")) return(fname)

    unique(c(fname, unlist(lapply(f[-1], fun_calls), use.names = FALSE)))
  }
}

#' @export
#' @rdname find_funs
fun_args <- function(f) {
  stopifnot(is.function(f))
  names(formals(f))
}

#' @export
#' @rdname find_funs
fun_body <- function(f) deparse(body(f))


================================================
FILE: R/find_uses.R
================================================
#' Find all functions in that call supplied functions.
#'
#' @param envs Vector of environments to look in. Can be specified by
#'   name, position or as environment
#' @param funs Functions to look for
#' @param match_any If \code{TRUE} return functions that use any of \code{funs}.
#'   If \code{FALSE}, return functions that use all of \code{funs}.
#' @export
#' @examples
#' names(find_uses("package:base", "sum"))
#'
#' envs <- c("package:base", "package:utils", "package:stats")
#' funs <- c("match.call", "sys.call")
#' find_uses(envs, funs)
find_uses <- function(envs, funs, match_any = TRUE) {
  envs <- lapply(envs, to_env, quiet = TRUE)

  by_env <- lapply(envs, function(env) {
    names <- ls(envir = env)
    names(names) <- names
    compact(lapply(names, function(x) matched_calls(get(x, envir = env), funs,
      match_any = match_any)))
  })

  unlist(by_env, recursive = FALSE)
}

matched_calls <- function(fun, calls, match_any = TRUE) {
  if (!is.function(fun) || is.primitive(fun)) return()

  called <- fun_calls(fun)
  matches <- calls %in% called
  match <- if (match_any) any(matches) else all(matches)

  if (!match) return()
  called[matches]
}


================================================
FILE: R/ftype.r
================================================
#' Determine function type.
#' 
#' This function figures out whether the input function is a 
#' regular/primitive/internal function, a internal/S3/S4 generic, or a 
#' S3/S4/RC method. This is function is slightly simplified as it's possible
#' for a method from one class to be a generic for another class, but that
#' seems like such a bad idea that hopefully no one has done it.
#' 
#' @param f unquoted function name
#' @return a character of vector of length 1 or 2.
#' @family object inspection
#' @importFrom methods is
#' @export
#' @examples
#' ftype(`%in%`)
#' ftype(sum)
#' ftype(t.data.frame)
#' ftype(t.test) # Tricky!
#' ftype(writeLines)
#' ftype(unlist)
ftype <- function(f) { 
  fexpr <- substitute(f)
  env <- parent.frame()
  fname <- if (is.name(fexpr)) as.character(fexpr) else NULL
  
  if (is.primitive(f)) {
    c("primitive", if (is_internal_generic(primitive_name(f))) "generic")
  } else if (is_internal(f)) {
    c("internal", if (is_internal_generic(internal_name(f))) "generic")
  } else if (is(f, "standardGeneric")) {
    c("s4", "generic")
  } else if (is(f, "MethodDefinition")) {
    c("s4", "method")
  } else if (is(f, "refMethodDef")) {
    c("rc", "method")
  } else if (!is.null(fname) && is_s3_generic(fname, env)) {
    c("s3", "generic")
  } else if (!is.null(fname) && is_s3_method(fname, env)) {
    c("s3", "method")
  } else {
    c("function")
  }  
}

# Hacky method to get name of primitive function
primitive_name <- function(f) {
  stopifnot(is.primitive(f))

  str <- deparse(f)
  match <- regexec(".Primitive\\([\"](.*?)[\"]\\)", str)
  regmatches(str, match)[[1]][2]
}

is_internal <- function(f) {
  if (!is.function(f) || is.primitive(f)) return(FALSE)
  calls <- findGlobals(f, merge = FALSE)$functions
  any(calls %in% ".Internal")
}

# fs <- stats::setNames(lapply(ls("package:base"), get), ls("package:base"))
# internal <- Filter(is_internal, fs)
# icall <- sapply(internal, internal_name)
# icall[names(icall) != icall]
internal_name <- function(f) {
  
  internal_call <- function(x) {
    if (is.name(x) || is.atomic(x)) return(NULL)
    if (identical(x[[1]], quote(.Internal))) return(x)
  
    # Work backwards since likely to be near end last 
    # (and e.g. unlist has multiple .Internal calls)
    for (i in rev(seq_along(x))) {
      icall <- internal_call(x[[i]])
      if (!is.null(icall)) return(icall)
    }
    NULL
  }
  call <- internal_call(body(f))
  as.character(call[[2]][[1]])
}


================================================
FILE: R/inspect.r
================================================
#' Inspect internal attributes of R objects.
#'
#' \code{typename} determines the internal C typename, \code{address}
#' returns the memory location of the object, and \code{refs} returns the
#' number of references pointing to the underlying object.
#'
#' @section Non-standard evaluation:
#' All functions uses non-standard evaluation to capture the symbol you are
#' referring to and the environment in which it lives. This means that you can
#' not call any of these functions on objects created in the function call.
#' All the underlying C level functions use \code{Rf_findVar} to get to the
#' underlying SEXP.
#'
#' @param x name of object to inspect. This can not be a value.
#' @param env When inspecting environments, don't go past this one.
#' @family object inspection
#' @examples
#' x <- 1:10
#' \dontrun{.Internal(inspect(x))}
#'
#' typename(x)
#' refs(x)
#' address(x)
#'
#' y <- 1L
#' typename(y)
#' z <- list(1:10)
#' typename(z)
#' delayedAssign("a", 1 + 2)
#' typename(a)
#' a
#' typename(a)
#'
#' x <- 1:5
#' address(x)
#' x[1] <- 3L
#' address(x)
#' @name inspect
NULL

#' @export
#' @rdname inspect
inspect <- function(x, env = parent.frame()) {
  inspect_(x, env)
}

#' @export
print.inspect <- function(x, level = 0, ...) {
  indent <- paste(rep("  ", length = level), collapse = "")

  if (!x$seen) {
    cat(indent, "<", x$type, " ", x$address, ">\n", sep = "")
  } else {
    cat(indent, "[", x$type, " ", x$address, "]\n", sep = "")
  }
  if (length(x$children) > 0) {
    nms <- names(x$children) %||% rep("", length(x$children))
    Map(function(nm, val) {
      if (nm != "") cat(indent, nm, ": \n", sep = "")
      print(val, level = level + 1)
    }, nms, x$children)
  }
}

#' @export
print.inspect_NILSXP <- function(x, level = 0, ...) {
  indent <- paste(rep("  ", length = level), collapse = "")
  cat(indent, "NULL\n", sep = "")
}

#' @export
#' @rdname inspect
refs <- function(x) {
  named2(check_name(substitute(x)), parent.frame())
}

#' @export
#' @rdname inspect
address <- function(x) {
  address2(check_name(substitute(x)), parent.frame())
}


#' @export
#' @rdname inspect
typename <- function(x) {
  typename2(check_name(substitute(x)), parent.frame())
}

check_name <- function(x) {
  if (!is.name(x)) {
    stop("x must be the name of an object", call. = FALSE)
  }
  x
}

#' Track if an object is copied
#'
#' The title is somewhat misleading: rather than checking if an object is
#' modified, this really checks to see if a name points to the same object.
#'
#' @param var variable name (unquoted)
#' @param env environment name in which to track changes
#' @param quiet if \code{FALSE}, prints a message on change; if \code{FALSE}
#'   only the return value of the function is used
#' @return a zero-arg function, that when called returns a boolean indicating
#'   if the object has changed since the last time this function was called
#' @export
#' @examples
#' a <- 1:5
#' track_a <- track_copy(a)
#' track_a()
#' a[3] <- 3L
#' track_a()
#' a[3] <- 3
#' track_a()
#' rm(a)
#' track_a()
track_copy <- function(var, env = parent.frame(), quiet = FALSE) {
  var <- substitute(var)
  force(env)

  old <- address2(var, env)
  function() {
    if (!exists(as.character(var), envir = env, inherits = FALSE))
      return(invisible(FALSE))

    new <- address2(var, env)
    if (old == new) return(invisible(FALSE))

    if (!quiet) message(var, " copied")
    old <<- new
    invisible(TRUE)
  }
}


================================================
FILE: R/make-call.R
================================================
#' Make and evaluate calls.
#'
#' @param f Function to call. For \code{make_call}, either a string, a symbol
#'   or a quoted call. For \code{do_call}, a bare function name or call.
#' @param ...,.args Arguments to the call either in or out of a list
#' @param .env Environment in which to evaluate call. Defaults to parent frame.
#' @export
#' @examples
#' # f can either be a string, a symbol or a call
#' make_call("f", a = 1)
#' make_call(quote(f), a = 1)
#' make_call(quote(f()), a = 1)
#'
#' #' Can supply arguments individual or in a list
#' make_call(quote(f), a = 1, b = 2)
#' make_call(quote(f), list(a = 1, b = 2))
make_call <- function(f, ..., .args = list()) {
  if (is.character(f)) f <- as.name(f)
  as.call(c(f, ..., .args))
}

#' @rdname make_call
#' @export
do_call <- function(f, ..., .args = list(), .env = parent.frame()) {
  f <- substitute(f)

  call <- make_call(f, ..., .args)
  eval(call, .env)
}


================================================
FILE: R/make-function.r
================================================
#' Make a function from its components.
#'
#' This constructs a new function given it's three components:
#' list of arguments, body code and parent environment.
#'
#' @param args A named list of default arguments.  Note that if you want
#'  arguments that don't have defaults, you'll need to use the special function
#'  \code{\link{alist}}, e.g. \code{alist(a = , b = 1)}
#' @param body A language object representing the code inside the function.
#'   Usually this will be most easily generated with \code{\link{quote}}
#' @param env The parent environment of the function, defaults to the calling
#'  environment of \code{make_function}
#' @export
#' @examples
#' f <- function(x) x + 3
#' g <- make_function(alist(x = ), quote(x + 3))
#'
#' # The components of the functions are identical
#' identical(formals(f), formals(g))
#' identical(body(f), body(g))
#' identical(environment(f), environment(g))
#'
#' # But the functions are not identical because f has src code reference
#' identical(f, g)
#'
#' attr(f, "srcref") <- NULL
#' # Now they are:
#' stopifnot(identical(f, g))
make_function <- function(args, body, env = parent.frame()) {
  args <- as.pairlist(args)
  stopifnot(
    all_named(args),
    is.language(body))
  env <- to_env(env)

  eval(call("function", args, body), env)
}


================================================
FILE: R/mem.R
================================================
#' How much memory is currently used by R?
#'
#' R breaks down memory usage into Vcells (memory used by vectors) and
#' Ncells (memory used by everything else). However, neither this distinction
#' nor the "gc trigger" and "max used" columns are typically important. What
#' we're usually most interested in is the the first column: the total memory
#' used. This function wraps around \code{gc()} to return the total amount of
#' memory (in megabytes) currently used by R.
#'
#' @export
#' @return Megabytes of ram used by R objects.
#' @examples
#' mem_used()
mem_used <- function() {
  show_bytes(sum(gc()[, 1] * c(node_size(), 8)))
}

node_size <- function() {
  bit <- 8L * .Machine$sizeof.pointer
  if (!(bit == 32L || bit == 64L)) {
    stop("Unknown architecture", call. = FALSE)
  }

  if (bit == 32L) 28L else 56L
}

#' Determine change in memory from running code
#'
#' @param code Code to evaluate.
#' @return Change in memory (in megabytes) before and after running code.
#' @examples
#' # Need about 4 mb to store 1 million integers
#' mem_change(x <- 1:1e6)
#' # We get that memory back when we delete it
#' mem_change(rm(x))
#' @export
mem_change <- function(code) {
  start <- mem_used()

  expr <- substitute(code)
  eval(expr, parent.frame())
  rm(code, expr)

  show_bytes(mem_used() - start)
}

show_bytes <- function(x) {
  structure(x, class = "pryr_bytes")
}

#' @export
print.pryr_bytes <- function(x, digits = 3, ...) {
  power <- min(floor(log(abs(x), 1000)), 4)
  if (power < 1) {
    unit <- "B"
  } else {
    unit <- c("kB", "MB", "GB", "TB")[[power]]
    x <- x / (1000 ^ power)
  }

  formatted <- format(signif(x, digits = digits), big.mark = ",",
    scientific = FALSE)

  cat(formatted, " ", unit, "\n", sep = "")
}


================================================
FILE: R/method-from-call.r
================================================
#' Given a function class, find correspoding S4 method
#' 
#' @param call unquoted function call
#' @param env environment in which to look for function definition
#' @export
#' @examples
#' library(stats4)
#' 
#' # From example(mle)
#' y <- c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8)
#' nLL <- function(lambda) -sum(dpois(y, lambda, log = TRUE))
#' fit <- mle(nLL, start = list(lambda = 5), nobs = length(y))
#' 
#' method_from_call(summary(fit))
#' method_from_call(coef(fit))
#' method_from_call(length(fit))
method_from_call <- function(call, env = parent.frame()) {
  call <- standardise_call(substitute(call), env)
  
  generic <- as.character(call[[1]])
  g_args <- setdiff(names(formals(methods::getGeneric(generic))), "...")
  
  args_uneval <- as.list(call[intersect(g_args, names(call))])
  args <- lapply(args_uneval, eval, env = env)
  classes <- lapply(args, class)
  
  # Add in any missing args
  missing <- setdiff(g_args, names(classes))
  if (length(missing) > 0) {
    classes[missing] <- rep("missing", length(missing))  
  }
  
  methods::selectMethod(generic, classes)  
}


================================================
FILE: R/modify-call.R
================================================
#' Modify the arguments of a call.
#'
#' @param call A call to modify. It is first standardised with
#'   \code{\link{standardise_call}}.
#' @param new_args A named list of expressions (constants, names or calls)
#'   used to modify the call. Use \code{NULL} to remove arguments.
#' @export
#' @examples
#' call <- quote(mean(x, na.rm = TRUE))
#'
#' # Modify an existing argument
#' modify_call(call, list(na.rm = FALSE))
#' modify_call(call, list(x = quote(y)))
#'
#' # Remove an argument
#' modify_call(call, list(na.rm = NULL))
#'
#' # Add a new argument
#' modify_call(call, list(trim = 0.1))
#'
#' # Add an explicit missing argument
#' modify_call(call, list(na.rm = quote(expr = )))
modify_call <- function(call, new_args) {
  stopifnot(is.call(call), is.list(new_args))

  call <- standardise_call(call)

  nms <- names(new_args) %||% rep("", length(new_args))
  if (any(nms == "")) {
    stop("All new arguments must be named", call. = FALSE)
  }

  for(nm in nms) {
    call[[nm]] <- new_args[[nm]]
  }
  call
}


================================================
FILE: R/modify-lang.r
================================================
#' Recursively modify a language object
#'
#' @param x object to modify: should be a call, expression, function or
#'   list of the above.
#' @param f function to apply to leaves
#' @param ... other arguments passed to \code{f}
#' @export
#' @examples
#' a_to_b <- function(x) {
#'   if (is.name(x) && identical(x, quote(a))) return(quote(b))
#'   x
#' }
#' examples <- list(
#'   quote(a <- 5),
#'   alist(a = 1, c = a),
#'   function(a = 1) a * 10,
#'   expression(a <- 1, a, f(a), f(a = a))
#' )
#' modify_lang(examples, a_to_b)
#' # Modifies all objects called a, but doesn't modify arguments named a
modify_lang <- function(x, f, ...) {
  recurse <- function(y) {
    # if (!is.null(names(y))) names(y) <- f2(names(y))
    lapply(y, modify_lang, f = f, ...)
  }

  if (is.atomic(x) || is.name(x)) {
    # Leaf
    f(x, ...)
  } else if (is.call(x)) {
    as.call(recurse(x))
  } else if (is.function(x)) {
    formals(x) <- modify_lang(formals(x), f, ...)
    body(x) <- modify_lang(body(x), f, ...)
    x
  } else if (is.pairlist(x)) {
    # Formal argument lists (when creating functions)
    as.pairlist(recurse(x))
  } else if (is.expression(x)) {
    # shouldn't occur inside tree, but might be useful top-level
    as.expression(recurse(x))
  } else if (is.list(x)) {
    # shouldn't occur inside tree, but might be useful top-level
    recurse(x)
  } else {
    stop("Unknown language class: ", paste(class(x), collapse = "/"),
      call. = FALSE)
  }
}



================================================
FILE: R/names_c.R
================================================
#' Find C source code for internal R functions
#'
#' Opens a link to code search on github.
#'
#' @param fun .Internal or .Primitive function call.
#' @export
#' @examples
#' \donttest{
#' show_c_source(.Internal(mean(x)))
#' show_c_source(.Primitive(sum(x)))
#' }
show_c_source  <- function(fun) {
  fun <- substitute(fun)
  stopifnot(is.call(fun))

  name <- as.character(fun[[1]])
  if (!(name %in% c(".Internal", ".Primitive"))) {
    stop("Only know how to look up .Internal and .Primitive calls",
      call. = FALSE)
  }

  internal_name <- as.character(fun[[2]][[1]])

  names <- names_c()
  found <- names[names$name == internal_name, , drop = FALSE]

  if (nrow(found) != 1) {
    stop("Could not find entry for ", internal_name, call. = FALSE)
  }

  message(internal_name, " is implemented by ", found$cfun,
    " with op = ", found$offset)

  query <- sprintf("SEXP attribute_hidden %s+repo:wch/r-source&type=Code",
    found$cfun)
  url <- paste0("https://github.com/search?q=", utils::URLencode(query))

  if (interactive()) {
    utils::browseURL(url)
  } else {
    message("Please visit ", url)
  }
}

#' Extract function table from names.c from R subversion repository.
#'
#' Since this is an expensive operation, it is done once and cached within
#' a session.
#'
#' @return A data frame with columns
#' \item{name}{the function name in R}
#' \item{c-entry}{The name of the corresponding C function, actually declared
#'   in ../include/Internal.h. All start with "do_", return SEXP, and
#'   have argument list (SEXP call, SEXP op, SEXP args, SEXP env)}
#' \item{offset}{the 'op' (offset pointer) above; used for C functions
#' 	 which deal with more than one R function}
#' \item{eval}{XYZ (three digits) \cr
#'  \cr
#'  X=0 says that we should force R_Visible on \cr
#'  X=1 says that we should force R_Visible off \cr
#'  X=2 says that we should switch R_Visible on but let the C code update it. \cr
#'  \cr
#'  Y=1 says that this is an internal function which must
#'      be accessed with a	.Internal(.) call, any other value is
#'      accessible directly and printed in R as ".Primitive(..)".\cr
#'  \cr
#'  Z=0 says don't evaluate (SPECIALSXP).\cr
#'  Z=1 says evaluate arguments before calling (BUILTINSXP)}
#' \item{arity}{How many arguments are required/allowed;  "-1"	meaning ``any''}
#' \item{pp-kind}{Deparsing Info (-> PPkind in ../include/Defn.h )}
#' \item{precedence}{Operator precedence (-> PPprec in ../include/Defn.h )}
#' \item{rightassoc}{Right or left associative operator}
#' @keywords internal
#' @export
names_c <- function() {
  if (exists("names_c", envir = cache)) return(cache$names_c)
  lines <- readLines("http://svn.r-project.org/R/trunk/src/main/names.c")

  # Find lines starting with {"
  fun_table <- lines[grepl("^[{][\"]", lines)]
  # Strip out {}, trailing comma and comments
  fun_table <- gsub("[{}]", "", fun_table)
  fun_table <- gsub(",$", "", fun_table)
  fun_table <- gsub("/[*].*[*]/", "", fun_table)

  table <- utils::read.csv(text = fun_table, strip = TRUE, header = FALSE,
    stringsAsFactors = FALSE)
  names(table) <- c("name", "cfun", "offset", "eval", "arity", "pp_kind",
    "precedence", "rightassoc")

  table$eval <- sprintf("%03d", table$eval)
  table$rightassoc <- table$rightassoc == 1

  # Cache result
  cache$names_c <- table
  table
}

cache <- new.env(parent = emptyenv())


================================================
FILE: R/object_size.R
================================================
#' Compute the size of an object.
#'
#' \code{object_size} works similarly to \code{\link{object.size}}, but counts
#' more accurately and includes the size of environments. \code{compare_size}
#' makes it easy to compare the output of \code{object_size} and
#' \code{object.size}.
#'
#' @section Environments:
#'
#' \code{object_size} attempts to take into account the size of the
#' environments associated with an object. This is particularly important
#' for closures and formulas, since otherwise you may not realise that you've
#' accidentally captured a large object. However, it's easy to over count:
#' you don't want to include the size of every object in every environment
#' leading back to the \code{\link{emptyenv}()}. \code{object_size} takes
#' a heuristic approach: it never counts the size of the global env,
#' the base env, the empty env or any namespace.
#'
#' Additionally, the \code{env} argument allows you to specify another
#' environment at which to stop. This defaults to the environment from which
#' \code{object_size} is called to prevent double-counting of objects created
#' elsewhere.
#'
#' @export
#' @examples
#' # object.size doesn't keep track of shared elements in an object
#' # object_size does
#' x <- 1:1e4
#' z <- list(x, x, x)
#' compare_size(z)
#'
#' # this means that object_size is not transitive
#' object_size(x)
#' object_size(z)
#' object_size(x, z)
#'
#' # object.size doesn't include the size of environments, which makes
#' # it easy to miss objects that are carrying around large environments
#' f <- function() {
#'   x <- 1:1e4
#'   a ~ b
#' }
#' compare_size(f())
#' @param x,... Set of objects to compute total size.
#' @param env Environment in which to terminate search. This defaults to the
#'   current environment so that you don't include the size of objects that
#'   are already stored elsewhere.
#' @return An estimate of the size of the object, in bytes.
object_size <- function(..., env = parent.frame()) {
  lobstr::obj_size(..., env = env)
}

#' @export
#' @rdname object_size
compare_size <- function(x) {
  c(base = utils::object.size(x), pryr = object_size(x))
}


================================================
FILE: R/otype.r
================================================
#' Determine object type.
#'
#' @details
#' Figure out which object system an object belongs to:
#'
#' \itemize{
#'   \item base: no class attribute
#'   \item S3: class attribute, but not S4
#'   \item S4: \code{\link{isS4}}, but not RC
#'   \item RC: inherits from "refClass"
#' }
#'
#' @param x object to determine type of
#' @export
#' @family object inspection
#' @examples
#' otype(data.frame())
#' otype(1:10)
otype <- function(x) {
  if (!is.object(x)) {
    "base"
  } else if (!isS4(x)) {
    "S3"
  } else if (!is(x, "refClass")) {
    "S4"
  } else {
    "RC"
  }
}


================================================
FILE: R/parenv.r
================================================
#' Given an environment or object, return an \code{envlist} of its
#' parent environments.
#'
#' If \code{e} is not specified, it will start with environment from which
#' the function was called.
#'
#' @param e An environment or other object.
#' @param all If \code{FALSE} (the default), stop at the global
#'   environment or the empty environment. If \code{TRUE}, print all
#'   parents, stopping only at the empty environment (which is the
#'   top-level environment).
#' @examples
#' # Print the current environment and its parents
#' parenvs()
#'
#' # Print the parent environments of the load_all function
#' e <- parenvs(parenvs)
#' e
#'
#' # Get all parent environments, going all the way to empty env
#' e <- parenvs(parenvs, TRUE)
#' e
#'
#' # Print e with paths
#' print(e, path = TRUE)
#'
#' # Print the first 6 environments in the envlist
#' e[1:6]
#'
#' # Print just the parent environment of load_all.
#' # This is an envlist with one element.
#' e[1]
#'
#' # Pull that environment out of the envlist and see what's in it.
#' e[[1]]
#' ls(e[[1]], all.names = TRUE)
#' @export
parenvs <- function(e = parent.frame(), all = FALSE) {
  if (!is.environment(e))  e <- environment(e)
  if (is.null(e))  return(NULL)

  envs <- list(e)
  while (TRUE) {
    if (identical(e, emptyenv())) break
    if (!all && identical(e, globalenv()))  break

    e <- parent.env(e)
    envs <- c(envs, e)
  }
  as.envlist(envs)
}

#' Convert a list of environments to an \code{envlist} object.
#'
#' @param x A list of environments.
#' @keywords internal
#' @export
as.envlist <- function(x) {
  if (!is.list(x) || !all(vapply(x, is.environment, logical(1)))) {
    stop("Cannot convert to envlist: input is not a list of environments.")
  }
  structure(x, class = "envlist")
}

#' @export
`[.envlist` <- function(x, i) {
  as.envlist(.subset(x, i))
}

#' Print an \code{envlist}
#'
#' @param x An \code{envlist} object to print.
#' @param name If \code{TRUE} (the default), print the \code{name}
#'   attribute of each environment.
#' @param path If \code{TRUE}, print the \code{path} attribute of
#'   each environment.
#' @param ... Other arguments to be passed to \code{print}.
#' @keywords internal
#' @export
#' @method print envlist
print.envlist <- function(x, name = TRUE, path = FALSE, ...) {

  labels <- vapply(x, format, FUN.VALUE = character(1))
  dat <- data.frame(label = labels, stringsAsFactors = FALSE)

  if (name) {
    names <- vapply(x, FUN.VALUE = character(1),
      function(e) paste('"', attr(e, "name"), '"', sep = ""))
    dat <- cbind(dat, name = names, stringsAsFactors = FALSE)
  }

  if (path) {
    paths <- vapply(x, FUN.VALUE = character(1),
      function(e) paste('"', attr(e, "path"), '"', sep = ""))
    dat <- cbind(dat, path = paths, stringsAsFactors = FALSE)
  }

  print(dat, ..., right = FALSE)

  invisible(x)
}


#' Get parent/ancestor environment
#'
#' @param env an environment
#' @param n number of parents to go up
#' @export
#' @examples
#' adder <- function(x) function(y) x + y
#' add2 <- adder(2)
#' parenv(add2)
parenv <- function(env = parent.frame(), n = 1) {
  env <- to_env(env)
  for(i in seq_len(n)) env <- parent.env(env)
  env
}


================================================
FILE: R/partial.r
================================================
#' Partial apply a function, filling in some arguments.
#'
#' Partial function application allows you to modify a function by pre-filling
#' some of the arguments.  It is particularly useful in conjunction with
#' functionals and other function operators.
#'
#' @section Design choices:
#'
#' There are many ways to implement partial function application in R.
#' (see e.g. \code{dots} in \url{https://github.com/crowding/vadr} for another
#' approach.)  This implementation is based on creating functions that are as
#' similar as possible to the anonymous function that'd you'd create by hand,
#' if you weren't using \code{partial}.
#'
#' @param _f a function. For the output source to read well, this should be an
#'   be a named function.  This argument has the weird (non-syntactic) name
#'   \code{_f} so it doesn't accidentally capture any argument names begining
#'   with f.
#' @param ... named arguments to \code{f} that should be partially applied.
#' @param .env the environment of the created function. Defaults to
#'   \code{\link{parent.frame}} and you should rarely need to modify this.
#' @param .lazy If \code{TRUE} arguments evaluated lazily, if \code{FALSE},
#'   evaluated when \code{partial} is called.
#' @export
#' @examples
#' # Partial is designed to replace the use of anonymous functions for
#' # filling in function arguments. Instead of:
#' compact1 <- function(x) Filter(Negate(is.null), x)
#'
#' # we can write:
#' compact2 <- partial(Filter, Negate(is.null))
#'
#' # and the generated source code is very similar to what we made by hand
#' compact1
#' compact2
#'
#' # Note that the evaluation occurs "lazily" so that arguments will be
#' # repeatedly evaluated
#' f <- partial(runif, n = rpois(1, 5))
#' f
#' f()
#' f()
#'
#' # You can override this by saying .lazy = FALSE
#' f <- partial(runif, n = rpois(1, 5), .lazy = FALSE)
#' f
#' f()
#' f()
#'
#' # This also means that partial works fine with functions that do
#' # non-standard evaluation
#' my_long_variable <- 1:10
#' plot2 <- partial(plot, my_long_variable)
#' plot2()
#' plot2(runif(10), type = "l")
partial <- function(`_f`, ..., .env = parent.frame(), .lazy = TRUE) {
  stopifnot(is.function(`_f`))

  if (.lazy) {
    fcall <- substitute(`_f`(...))
  } else {
    fcall <- make_call(substitute(`_f`), .args = list(...))
  }
  # Pass on ... from parent function
  fcall[[length(fcall) + 1]] <- quote(...)

  args <- list("..." = quote(expr = ))
  make_function(args, fcall, .env)
}

# Alternative implementation that is much more complicated and doesn't work
# as well because missing values in the inputs to the partially applied
# function propagate and make it harder to work with.
partial2 <- function(`_f`, ..., .env = parent.frame()) {

  f_name <- substitute(`_f`)

  # Capture unevalated arguments, and convert positions to names
  dots <- match.call(expand.dots = FALSE)$`...`
  f_call <- as.call(c(list(f_name), dots))
  new_args <- as.list(match.call(`_f`, f_call))[-1]

  # Arguments to partially applied function should be the same as the original
  # function, less the arguments that have been filled in
  if (is.primitive(`_f`)) {
    # Don't know actual arguments, so fall back to ...
    arg_names <- "..."
  } else {
    arg_names <- names(formals(`_f`))
  }
  arg_names <- setdiff(arg_names, names(new_args))
  names(arg_names) <- arg_names

  reciever_args <- lapply(arg_names, function(x) quote(expr = ))
  caller_args <- c(lapply(arg_names, as.symbol), new_args)
  body <- as.call(c(f_name, caller_args))

  make_function(reciever_args, body, .env)
}


================================================
FILE: R/promise.r
================================================
#' Promise info
#' 
#' @useDynLib pryr
#' @importFrom Rcpp sourceCpp
#' @param x unquoted object name
#' @family promise tools
#' @export
#' @examples
#' x <- 10
#' is_promise(x)
#' (function(x) is_promise(x))(x = 10)
is_promise <- function(x) {
  is_promise2(substitute(x), parent.frame())
}

#' @rdname is_promise
#' @export
promise_info <- function(x) {
  name <- substitute(x)
  env <- parent.frame()

  stopifnot(is_promise2(name, env))

  evaled <- promise_evaled(name, env)
  list(
    code = promise_code(name, env),
    env = promise_env(name, env),
    evaled = evaled,
    value = if (evaled) promise_value(name, env)
  )
}

#' Find the parent (first) promise.
#' 
#' @param x unquoted name of promise to find initial value for for.
#' @export
#' @examples
#' f <- function(x) g(x)
#' g <- function(y) h(y)
#' h <- function(z) parent_promise(z)
#' 
#' h(x + 1)
#' g(x + 1)
#' f(x + 1)
parent_promise <- function(x) {
  name <- quote(x)
  
  for (frame in rev(sys.frames())) {
    if (!is_promise2(name, frame)) return(name)
    
    name <- promise_code(name, frame)
    if (!is.name(name)) return(name)    
  }
  
  name
}


================================================
FILE: R/rebind.r
================================================
#' Rebind an existing name.
#'
#' This function is similar to \code{\link{<<-}} with two exceptions:
#'
#' \itemize{
#'  \item if no existing binding is found, it throws an error
#'  \item it does not recurse past the global environment into the attached
#'    packages
#'}
#'
#' @param name name of existing binding to re-assign
#' @param value new value
#' @param env environment to start search in.
#' @export
#' @examples
#' a <- 1
#' rebind("a", 2)
#' a
#' # Throws error if no existing binding
#' \dontrun{rebind("b", 2)}
#'
#' local({
#'   rebind("a", 3)
#' })
#' a
#'
#' # Can't find get because doesn't look past globalenv
#' \dontrun{rebind("get", 1)}
rebind <- function(name, value, env = parent.frame()) {
  env <- to_env(env)

  if (exists(name, env, inherits = FALSE)) {
    assign(name, value, env)
  } else {
    # Don't recurse past global or emptyenv
    if (identical(env, globalenv()) || identical(env, emptyenv())) {
      stop("Can't find ", name, call. = FALSE)
    }

    rebind(name, value, parent.env(env))
  }
}


================================================
FILE: R/rls.r
================================================
#' Recursive ls.
#'
#' Performs \code{\link{ls}} all the way up to a top-level environment (either
#' the parent of the global environment, the empty environment or a namespace
#' environment).
#'
#' @param env environment to start the search at. Defaults to the
#'  \code{\link{parent.frame}}. If a function is supplied, uses the environment
#'  associated with the function.
#' @param all.names Show all names, even those starting with \code{.}?
#'   Defaults to \code{TRUE}, the opposite of \code{\link{ls}}
#' @export
#' @author Winston Chang
rls <- function(env = parent.frame(), all.names = TRUE) {
  env <- to_env(env)
  if (terminal_env(env)) return()

  names <- ls(env, all.names = all.names)
  c(list(names), rls(parent.env(env), all.names = all.names))
}

terminal_env <- function(e) {
  identical(e, parent.env(globalenv())) || identical(e, emptyenv()) ||
      exists('.__NAMESPACE__.', e, inherits = FALSE)
}


================================================
FILE: R/s3.r
================================================
#' Determine if a function is an S3 generic or S3 method.
#'
#' @description
#' \code{is_s3_generic} compares name checks for both internal and regular
#' generics.
#'
#' \code{is_s3_method} builds names of all possible generics for that function
#' and then checks if any of them actually is a generic.
#'
#' @param name name of function as a string. Need name of function because
#'   it's impossible to determine whether or not a function is a S3 method
#'   based only on its contents.
#' @param env environment to search in.
#' @keywords internal
#' @export
#' @examples
#' is_s3_generic("mean")
#' is_s3_generic("sum")
#' is_s3_generic("[[")
#' is_s3_generic("unlist")
#' is_s3_generic("runif")
#'
#' is_s3_method("t.data.frame")
#' is_s3_method("t.test") # Just tricking!
#' is_s3_method("as.data.frame")
#' is_s3_method("mean.Date")
is_s3_generic <- function(fname, env = parent.frame()) {
  if (!exists(fname, env)) return(FALSE)

  f <- get(fname, env, mode = "function")
  if (!is.function(f)) return(FALSE)

  if (is.primitive(f) || is_internal(f)) {
    is_internal_generic(fname)
  } else {
    uses <- findGlobals(f, merge = FALSE)$functions
    any(uses == "UseMethod")
  }
}

#' @rdname is_s3_generic
#' @export
is_s3_method <- function(name, env = parent.frame()) {
  !is.null(find_generic(name, env))
}

stop_list <- function() {
  if (getRversion() < "3.3.0") {
    getNamespace("tools")[[".make_S3_methods_stop_list"]](NULL)
  } else {
    tools::nonS3methods(NULL)
  }
}

find_generic <- function(name, env = parent.frame()) {
  if (name %in% stop_list()) return(NULL)

  pieces <- strsplit(name, ".", fixed = TRUE)[[1]]
  n <- length(pieces)

  # No . in name, so can't be method
  if (n == 1) return(NULL)

  for(i in seq_len(n - 1)) {
    generic <- paste0(pieces[seq_len(i)], collapse = ".")
    class <- paste0(pieces[(i + 1):n], collapse = ".")
    if (is_s3_generic(generic, env)) return(c(generic, class))
  }
  NULL
}

is_internal_generic <- function(x) {
  x %in% internal_generics()
}

#' @importFrom methods getGroupMembers
internal_generics <- function() {
  # Functions in S4 group generics should be the same
  group <- c(getGroupMembers("Arith"), getGroupMembers("Compare"),
    getGroupMembers("Logic"), getGroupMembers("Math"), getGroupMembers("Math2"),
    getGroupMembers("Summary"), getGroupMembers("Complex"))

  primitive <- .S3PrimitiveGenerics

  # Extracted from ?"internal generic"
  internal <- c("[", "[[", "$", "[<-", "[[<-", "$<-", "unlist",
    "cbind", "rbind", "as.vector")

  c(group, primitive, internal)
}


================================================
FILE: R/standardise-call.r
================================================
#' Standardise a function call
#'
#' @param call A call
#' @param env Environment in which to look up call value.
#' @export
standardise_call <- function(call, env = parent.frame()) {
  stopifnot(is.call(call))
  f <- eval(call[[1]], env)
  if (is.primitive(f)) return(call)

  match.call(f, call)
}


================================================
FILE: R/substitute.r
================================================
#' A version of substitute that evaluates its first argument.
#'
#' This version of substitute is needed because \code{substitute} does not
#' evaluate it's first argument, and it's often useful to be able to modify
#' a quoted call.
#'
#' @param x a quoted call
#' @param env an environment, or something that behaves like an environment
#'   (like a list or data frame), or a reference to an environment (like a
#'   positive integer or name, see \code{\link{as.environment}} for more
#'   details)
#' @export
#' @examples
#' x <- quote(a + b)
#' substitute(x, list(a = 1, b = 2))
#' substitute_q(x, list(a = 1, b = 2))
substitute_q <- function(x, env) {
  stopifnot(is.language(x))
  env <- to_env(env)

  call <- substitute(substitute(x, env), list(x = x))
  eval(call)
}

#' A version of substitute that works in the global environment.
#'
#' This version of \code{\link{substitute}} is more suited for interactive
#' exploration because it will perform substitution in the global environment:
#' the regular version has a special case for the global environment where it
#' effectively works like \code{\link{quote}}
#'
#' @section Substitution rules:
#'
#' Formally, substitution takes place by examining each name in the expression.
#' If the name refers to:
#'
#' \itemize{
#'
#'  \item an ordinary variable, it's replaced by the value of the variable.
#'
#'  \item a promise, it's replaced by the expression associated with the
#'     promise.
#'
#'  \item \code{...}, it's replaced by the contents of \code{...}
#' }
#' @inheritParams substitute_q
#' @export
#' @examples
#' a <- 1
#' b <- 2
#'
#' substitute(a + b)
#' subs(a + b)
subs <- function(x, env = parent.frame()) {
  if (identical(env, globalenv())) {
    env <- as.list(env)
  }

  substitute_q(substitute(x), env)
}


================================================
FILE: R/unenclose.r
================================================
#' Unenclose a closure.
#'
#' Unenclose a closure by substituting names for values found in the enclosing
#' environment.
#'
#' @param f a closure
#' @export
#' @examples
#' power <- function(exp) {
#'   function(x) x ^ exp
#' }
#' square <- power(2)
#' cube <- power(3)
#'
#' square
#' cube
#' unenclose(square)
#' unenclose(cube)
unenclose <- function(f) {
  stopifnot(is.function(f))

  env <- environment(f)
  make_function(formals(f), substitute_q(body(f), env), parent.env(env))
}


================================================
FILE: R/uneval.r
================================================
#' Capture the call associated with a promise.
#'
#' This is an alternative to subsitute that performs one job, and so gives
#' a stronger signal regarding the intention of your code.  It returns an error
#' if the name is not associated with a promise.
#'
#' @export
#' @family promise tools
#' @param x unquoted variable name that refers to a promise. An error will be
#'   thrown if it's not a promise.
#' @examples
#' f <- function(x) {
#'    uneval(x)
#' }
#' f(a + b)
#' f(1 + 4)
#' 
#' delayedAssign("x", 1 + 4)
#' uneval(x)
#' x
#' uneval(x)
uneval <- function(x) {
  name <- substitute(x)
  stopifnot(is.name(name))

  env <- parent.frame()

  if (!is_promise2(name, env)) {
    stop(name, "is not a promise", call. = FALSE)
  }

  promise_code(name, env)
}


================================================
FILE: R/utils.r
================================================
all_named <- function(x) {
  if (length(x) == 0) return(TRUE)
  !is.null(names(x)) && all(names(x) != "")
}

"%||%" <- function(x, y) if (is.null(x)) y else x

compact <- function(x) Filter(Negate(is.null), x)

to_env <- function(x, quiet = FALSE) {
  if (is.environment(x)) {
    x
  } else if (is.list(x)) {
    list2env(x)
  } else if (is.function(x)) {
    environment(x)
  } else if (length(x) == 1 && is.character(x)) {
    if (!quiet) message("Using environment ", x)
    as.environment(x)
  } else if (length(x) == 1 && is.numeric(x) && x > 0) {
    if (!quiet) message("Using environment ", search()[x])
    as.environment(x)
  } else {
    stop("Input can not be coerced to an environment", call. = FALSE)
  }
}


================================================
FILE: R/where.r
================================================
#' Find where a name is defined.
#'
#' Implements the regular scoping rules, but instead of returning the value
#' associated with a name, it returns the environment in which it is located.
#'
#' @param name name, as string, to look for
#' @param env environment to start at. Defaults to the calling environment
#'   of this function.
#' @export
#' @examples
#' x <- 1
#' where("x")
#' where("t.test")
#' where("mean")
#' where("where")
where <- function(name, env = parent.frame()) {
  stopifnot(is.character(name), length(name) == 1)
  env <- to_env(env)

  if (identical(env, emptyenv())) {
    stop("Can't find ", name, call. = FALSE)
  }

  if (exists(name, env, inherits = FALSE)) {
    env
  } else {
    where(name, parent.env(env))
  }
}


================================================
FILE: README.md
================================================
# pryr

<!-- badges: start -->
[![Lifecycle: superseded](https://img.shields.io/badge/lifecycle-superseded-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html#superseded)
[![R-CMD-check](https://github.com/hadley/pryr/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/hadley/pryr/actions/workflows/R-CMD-check.yaml)
<!-- badges: end -->

pryr is superseded. Please use:

* [rlang](https://rlang.r-lib.org/) for low-level R programming.
* [lobstr](https://lobstr.r-lib.org/) for object sizes & comparison.
* [sloop](https://sloop.r-lib.org/) for OOP tools.


================================================
FILE: benchmark/make-function.r
================================================
make_function1 <- function(args, body, env = parent.frame()) {
  args <- as.pairlist(args)
  eval(call("function", args, body), env)
}
make_function2 <- function(args, body, env = parent.frame()) {
  f <- function() {}
  formals(f) <- args
  body(f) <- body
  environment(f) <- env

  f
}
make_function3 <- function(args, body, env = parent.frame()) {
  as.function(c(args, body), env)
}
make_function4 <- function(args, body, env = parent.frame()) {
  subs <- list(args = as.pairlist(args), body = body)
  eval(substitute(`function`(args, body), subs), env)
}

args <- alist(a = 1, b = 2)
body <- quote(a + b)
make_function1(args, body)
make_function2(args, body)
make_function3(args, body)
make_function4(args, body)

library(microbenchmark)
microbenchmark(
  make_function1(args, body),
  make_function2(args, body),
  make_function3(args, body),
  make_function4(args, body),
  function(a = 1, b = 2) a + b
)


================================================
FILE: cran-comments.md
================================================
## R CMD check results

0 errors | 0 warnings | 0 notes

## revdepcheck results

This is a patch release for R CMD check compliance so I did not re-check revdeps.


================================================
FILE: man/as.envlist.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/parenv.r
\name{as.envlist}
\alias{as.envlist}
\title{Convert a list of environments to an \code{envlist} object.}
\usage{
as.envlist(x)
}
\arguments{
\item{x}{A list of environments.}
}
\description{
Convert a list of environments to an \code{envlist} object.
}
\keyword{internal}


================================================
FILE: man/assign-active.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/assign-active.r
\name{\%<a-\%}
\alias{\%<a-\%}
\title{Create an active binding.}
\usage{
x \%<a-\% value
}
\arguments{
\item{x}{unquoted expression naming variable to create}

\item{value}{unquoted expression to evaluate every time \code{name} is
accessed}
}
\description{
Infix form of \code{\link{makeActiveBinding}} which creates an \emph{active}
binding between a name and an expression: every time the name is accessed
the expression is recomputed.
}
\examples{
x \%<a-\% runif(1)
x
x
x \%<a-\% runif(10)
x
x
rm(x)
}


================================================
FILE: man/assign-constant.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/assign-constant.r
\name{\%<c-\%}
\alias{\%<c-\%}
\title{Create a constant (locked) binding.}
\usage{
x \%<c-\% value
}
\arguments{
\item{x}{unquoted expression naming variable to create}

\item{value}{constant value}
}
\description{
Infix wrapper for \code{\link{assign}} + \code{\link{lockBinding}} that
creates a constant: a binding whose value can not be changed.
}
\examples{
x \%<c-\% 10
#' Generates an error:
\dontrun{x <- 20}

# Note that because of R's operator precedence rules, you
# need to wrap compound RHS expressions in ()
y \%<c-\% 1 + 2
y
z \%<c-\% (1 + 2)
z
}


================================================
FILE: man/assign-delayed.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/assign-delayed.r
\name{\%<d-\%}
\alias{\%<d-\%}
\title{Create an delayed binding.}
\usage{
x \%<d-\% value
}
\arguments{
\item{x}{unquoted expression naming variable to create}

\item{value}{unquoted expression to evaluate the first time \code{name} is
accessed}
}
\description{
Infix form of \code{\link{delayedAssign}} which creates an \emph{delayed}
or lazy binding, which only evaluates the expression the first time it is
used.
}
\examples{
x \%<d-\% (a + b)
a <- 10
b <- 100
x
}


================================================
FILE: man/bytes.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/bytes.r
\name{bytes}
\alias{bytes}
\alias{bits}
\title{Print the byte-wise representation of a value}
\usage{
bytes(x, split = TRUE)

bits(x, split = TRUE)
}
\arguments{
\item{x}{An \R vector of type \code{integer}, \code{numeric}, \code{logical}
or \code{character}.}

\item{split}{Whether we should split the output string at each byte.}
}
\description{
Print the byte-wise representation of a value
}
\examples{
## Encoding doesn't change the internal bytes used to represent characters;
## it just changes how they are interpretted!

x <- y <- z <- "\u9b3c"
Encoding(y) <- "bytes"
Encoding(z) <- "latin1"
print(x); print(y); print(z)
bytes(x); bytes(y); bytes(z)
bits(x); bits(y); bits(z)

## In R, integers are signed ints. The first bit indicates the sign, but
## values are stored in a two's complement representation. We see that
## NA_integer_ is really just the smallest negative integer that can be
## stored in 4 bytes
bits(NA_integer_)

## There are multiple kinds of NAs, NaNs for real numbers
## (at least, on 64bit architectures)
print( c(NA_real_, NA_real_ + 1) )
rbind( bytes(NA_real_), bytes(NA_real_ + 1) )
rbind( bytes(NaN), bytes(0/0) )
}
\references{
\url{https://en.wikipedia.org/wiki/Two's_complement} for more
information on the representation used for \code{int}s.

\url{https://en.wikipedia.org/wiki/IEEE_floating_point} for more
information the floating-point representation used for \code{double}s.

\url{https://en.wikipedia.org/wiki/Character_encoding} for an introduction
to character encoding, and \code{?\link{Encoding}} for more information on
how \R handles character encoding.
}


================================================
FILE: man/call_tree.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/draw-tree.r
\name{call_tree}
\alias{call_tree}
\alias{ast}
\title{Display a call (or expression) as a tree.}
\usage{
call_tree(x, width = getOption("width"))

ast(x)
}
\arguments{
\item{x}{quoted call, list of calls, or expression to display}

\item{width}{displays width, defaults to current width as reported by
\code{getOption("width")}}
}
\description{
\code{call_tree} takes a quoted expression. \code{ast} does the quoting
for you.
}
\examples{
call_tree(quote(f(x, 1, g(), h(i()))))
call_tree(quote(if (TRUE) 3 else 4))
call_tree(expression(1, 2, 3))

ast(f(x, 1, g(), h(i())))
ast(if (TRUE) 3 else 4)
ast(function(a = 1, b = 2) {a + b})
ast(f()()())
}


================================================
FILE: man/compose.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/compose.r
\name{compose}
\alias{compose}
\alias{\%.\%}
\title{Compose multiple functions}
\usage{
compose(...)

f \%.\% g
}
\arguments{
\item{...}{n functions to apply in order from right to left}

\item{f, g}{two functions to compose for the infix form}
}
\description{
In infix and prefix forms.
}
\examples{
not_null <- `!` \%.\% is.null
not_null(4)
not_null(NULL)

add1 <- function(x) x + 1
compose(add1,add1)(8)
}


================================================
FILE: man/dots.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/dots.r
\name{dots}
\alias{dots}
\alias{named_dots}
\title{Capture unevaluated dots.}
\usage{
dots(...)

named_dots(...)
}
\arguments{
\item{...}{\code{...} passed in to the parent function}
}
\value{
a list of expressions (not expression objects). \code{named_dots}
 will use the deparsed expressions as default names.
}
\description{
Capture unevaluated dots.
}
\examples{
y <- 2
str(dots(x = 1, y, z = ))
str(named_dots(x = 1, y, z =))
}


================================================
FILE: man/enclosing_env.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/enclosing.R
\name{enclosing_env}
\alias{enclosing_env}
\title{Find the environment that encloses of a function.}
\usage{
enclosing_env(f)
}
\arguments{
\item{f}{The name of a function.}
}
\description{
This is a wrapper around \code{\link{environment}} with a
consistent syntax.
}
\examples{
enclosing_env("plot")
enclosing_env("t.test")
}


================================================
FILE: man/explicit.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/explicit-promise.R
\name{explicit}
\alias{explicit}
\alias{eval2}
\title{Tools for making promises explicit}
\usage{
explicit(x)

eval2(x, data = NULL, env = parent.frame())
}
\arguments{
\item{x}{expression to make explicit, or to evaluate.}

\item{data}{Data in which to evaluate code}

\item{env}{Enclosing environment to use if data is a list or data frame.}
}
\description{
Deprecated: please use the lazyeval package instead.
}


================================================
FILE: man/f.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/f.r
\name{f}
\alias{f}
\title{A compact syntax for anonymous functions.}
\usage{
f(..., .env = parent.frame())
}
\arguments{
\item{...}{The last argument is the body of the function, all others are
arguments to the function.  If there is only one argument, the formals
are guessed from the code.}

\item{.env}{parent environment of the created function}
}
\value{
a function
}
\description{
A compact syntax for anonymous functions.
}
\examples{
f(x + y)
f(x + y)(1, 10)
f(x, y = 2, x + y)

f({y <- runif(1); x + y})
}


================================================
FILE: man/fget.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/fget.r
\name{fget}
\alias{fget}
\title{Find a function with specified name.}
\usage{
fget(name, env = parent.frame())
}
\arguments{
\item{name}{length one character vector giving name}

\item{env}{environment to start search in.}
}
\description{
Find a function with specified name.
}
\examples{
c <- 10
fget("c")
}


================================================
FILE: man/find_funs.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/find-funs.r
\name{find_funs}
\alias{find_funs}
\alias{fun_calls}
\alias{fun_args}
\alias{fun_body}
\title{Find functions matching criteria.}
\usage{
find_funs(env = parent.frame(), extract, pattern, ...)

fun_calls(f)

fun_args(f)

fun_body(f)
}
\arguments{
\item{env}{environment in which to search for functions}

\item{extract}{component of function to extract. Should be a function that
takes a function as input as returns a character vector as output,
like \code{fun_calls} or \code{fun_args}.}

\item{pattern}{\pkg{stringr} regular expression to results of \code{extract}
function.}

\item{...}{other arguments passed on to \code{\link{grepl}}}

\item{f}{function to extract information from}
}
\description{
This is a flexible function that matches function component against
a regular expression, returning the name of the function if there are any
matches. \code{fun_args} and \code{fun_calls} are helper functions that
make it possible to search for functions with specified argument names, or
which call certain functions.
}
\examples{
find_funs("package:base", fun_calls, "match.fun", fixed = TRUE)
find_funs("package:stats", fun_args, "^[A-Z]+$")

fun_calls(match.call)
fun_calls(write.csv)

fun_body(write.csv)
find_funs("package:utils", fun_body, "write", fixed = TRUE)
}


================================================
FILE: man/find_uses.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/find_uses.R
\name{find_uses}
\alias{find_uses}
\title{Find all functions in that call supplied functions.}
\usage{
find_uses(envs, funs, match_any = TRUE)
}
\arguments{
\item{envs}{Vector of environments to look in. Can be specified by
name, position or as environment}

\item{funs}{Functions to look for}

\item{match_any}{If \code{TRUE} return functions that use any of \code{funs}.
If \code{FALSE}, return functions that use all of \code{funs}.}
}
\description{
Find all functions in that call supplied functions.
}
\examples{
names(find_uses("package:base", "sum"))

envs <- c("package:base", "package:utils", "package:stats")
funs <- c("match.call", "sys.call")
find_uses(envs, funs)
}


================================================
FILE: man/ftype.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/ftype.r
\name{ftype}
\alias{ftype}
\title{Determine function type.}
\usage{
ftype(f)
}
\arguments{
\item{f}{unquoted function name}
}
\value{
a character of vector of length 1 or 2.
}
\description{
This function figures out whether the input function is a 
regular/primitive/internal function, a internal/S3/S4 generic, or a 
S3/S4/RC method. This is function is slightly simplified as it's possible
for a method from one class to be a generic for another class, but that
seems like such a bad idea that hopefully no one has done it.
}
\examples{
ftype(`\%in\%`)
ftype(sum)
ftype(t.data.frame)
ftype(t.test) # Tricky!
ftype(writeLines)
ftype(unlist)
}
\seealso{
Other object inspection: 
\code{\link{otype}()},
\code{\link{sexp_type}()}
}
\concept{object inspection}


================================================
FILE: man/inspect.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/RcppExports.R, R/inspect.r
\name{sexp_type}
\alias{sexp_type}
\alias{inspect}
\alias{refs}
\alias{address}
\alias{typename}
\title{Inspect internal attributes of R objects.}
\usage{
sexp_type(x)

inspect(x, env = parent.frame())

refs(x)

address(x)

typename(x)
}
\arguments{
\item{x}{name of object to inspect. This can not be a value.}

\item{env}{When inspecting environments, don't go past this one.}
}
\description{
\code{typename} determines the internal C typename, \code{address}
returns the memory location of the object, and \code{refs} returns the
number of references pointing to the underlying object.
}
\section{Non-standard evaluation}{

All functions uses non-standard evaluation to capture the symbol you are
referring to and the environment in which it lives. This means that you can
not call any of these functions on objects created in the function call.
All the underlying C level functions use \code{Rf_findVar} to get to the
underlying SEXP.
}

\examples{
x <- 1:10
\dontrun{.Internal(inspect(x))}

typename(x)
refs(x)
address(x)

y <- 1L
typename(y)
z <- list(1:10)
typename(z)
delayedAssign("a", 1 + 2)
typename(a)
a
typename(a)

x <- 1:5
address(x)
x[1] <- 3L
address(x)
}
\seealso{
Other object inspection: 
\code{\link{ftype}()},
\code{\link{otype}()}
}
\concept{object inspection}


================================================
FILE: man/is_active_binding.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/active.r
\name{is_active_binding}
\alias{is_active_binding}
\title{Active binding info}
\usage{
is_active_binding(x)
}
\arguments{
\item{x}{unquoted object name}
}
\description{
Active binding info
}
\examples{
x <- 10
is_active_binding(x)
x \%<a-\% runif(1)
is_active_binding(x)
y <- x
is_active_binding(y)
}


================================================
FILE: man/is_promise.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/promise.r
\name{is_promise}
\alias{is_promise}
\alias{promise_info}
\title{Promise info}
\usage{
is_promise(x)

promise_info(x)
}
\arguments{
\item{x}{unquoted object name}
}
\description{
Promise info
}
\examples{
x <- 10
is_promise(x)
(function(x) is_promise(x))(x = 10)
}
\seealso{
Other promise tools: 
\code{\link{uneval}()}
}
\concept{promise tools}


================================================
FILE: man/is_s3_generic.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/s3.r
\name{is_s3_generic}
\alias{is_s3_generic}
\alias{is_s3_method}
\title{Determine if a function is an S3 generic or S3 method.}
\usage{
is_s3_generic(fname, env = parent.frame())

is_s3_method(name, env = parent.frame())
}
\arguments{
\item{env}{environment to search in.}

\item{name}{name of function as a string. Need name of function because
it's impossible to determine whether or not a function is a S3 method
based only on its contents.}
}
\description{
\code{is_s3_generic} compares name checks for both internal and regular
generics.

\code{is_s3_method} builds names of all possible generics for that function
and then checks if any of them actually is a generic.
}
\examples{
is_s3_generic("mean")
is_s3_generic("sum")
is_s3_generic("[[")
is_s3_generic("unlist")
is_s3_generic("runif")

is_s3_method("t.data.frame")
is_s3_method("t.test") # Just tricking!
is_s3_method("as.data.frame")
is_s3_method("mean.Date")
}
\keyword{internal}


================================================
FILE: man/make_call.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/make-call.R
\name{make_call}
\alias{make_call}
\alias{do_call}
\title{Make and evaluate calls.}
\usage{
make_call(f, ..., .args = list())

do_call(f, ..., .args = list(), .env = parent.frame())
}
\arguments{
\item{f}{Function to call. For \code{make_call}, either a string, a symbol
or a quoted call. For \code{do_call}, a bare function name or call.}

\item{..., .args}{Arguments to the call either in or out of a list}

\item{.env}{Environment in which to evaluate call. Defaults to parent frame.}
}
\description{
Make and evaluate calls.
}
\examples{
# f can either be a string, a symbol or a call
make_call("f", a = 1)
make_call(quote(f), a = 1)
make_call(quote(f()), a = 1)

#' Can supply arguments individual or in a list
make_call(quote(f), a = 1, b = 2)
make_call(quote(f), list(a = 1, b = 2))
}


================================================
FILE: man/make_function.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/make-function.r
\name{make_function}
\alias{make_function}
\title{Make a function from its components.}
\usage{
make_function(args, body, env = parent.frame())
}
\arguments{
\item{args}{A named list of default arguments.  Note that if you want
arguments that don't have defaults, you'll need to use the special function
\code{\link{alist}}, e.g. \code{alist(a = , b = 1)}}

\item{body}{A language object representing the code inside the function.
Usually this will be most easily generated with \code{\link{quote}}}

\item{env}{The parent environment of the function, defaults to the calling
environment of \code{make_function}}
}
\description{
This constructs a new function given it's three components:
list of arguments, body code and parent environment.
}
\examples{
f <- function(x) x + 3
g <- make_function(alist(x = ), quote(x + 3))

# The components of the functions are identical
identical(formals(f), formals(g))
identical(body(f), body(g))
identical(environment(f), environment(g))

# But the functions are not identical because f has src code reference
identical(f, g)

attr(f, "srcref") <- NULL
# Now they are:
stopifnot(identical(f, g))
}


================================================
FILE: man/mem_change.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/mem.R
\name{mem_change}
\alias{mem_change}
\title{Determine change in memory from running code}
\usage{
mem_change(code)
}
\arguments{
\item{code}{Code to evaluate.}
}
\value{
Change in memory (in megabytes) before and after running code.
}
\description{
Determine change in memory from running code
}
\examples{
# Need about 4 mb to store 1 million integers
mem_change(x <- 1:1e6)
# We get that memory back when we delete it
mem_change(rm(x))
}


================================================
FILE: man/mem_used.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/mem.R
\name{mem_used}
\alias{mem_used}
\title{How much memory is currently used by R?}
\usage{
mem_used()
}
\value{
Megabytes of ram used by R objects.
}
\description{
R breaks down memory usage into Vcells (memory used by vectors) and
Ncells (memory used by everything else). However, neither this distinction
nor the "gc trigger" and "max used" columns are typically important. What
we're usually most interested in is the the first column: the total memory
used. This function wraps around \code{gc()} to return the total amount of
memory (in megabytes) currently used by R.
}
\examples{
mem_used()
}


================================================
FILE: man/method_from_call.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/method-from-call.r
\name{method_from_call}
\alias{method_from_call}
\title{Given a function class, find correspoding S4 method}
\usage{
method_from_call(call, env = parent.frame())
}
\arguments{
\item{call}{unquoted function call}

\item{env}{environment in which to look for function definition}
}
\description{
Given a function class, find correspoding S4 method
}
\examples{
library(stats4)

# From example(mle)
y <- c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8)
nLL <- function(lambda) -sum(dpois(y, lambda, log = TRUE))
fit <- mle(nLL, start = list(lambda = 5), nobs = length(y))

method_from_call(summary(fit))
method_from_call(coef(fit))
method_from_call(length(fit))
}


================================================
FILE: man/modify_call.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/modify-call.R
\name{modify_call}
\alias{modify_call}
\title{Modify the arguments of a call.}
\usage{
modify_call(call, new_args)
}
\arguments{
\item{call}{A call to modify. It is first standardised with
\code{\link{standardise_call}}.}

\item{new_args}{A named list of expressions (constants, names or calls)
used to modify the call. Use \code{NULL} to remove arguments.}
}
\description{
Modify the arguments of a call.
}
\examples{
call <- quote(mean(x, na.rm = TRUE))

# Modify an existing argument
modify_call(call, list(na.rm = FALSE))
modify_call(call, list(x = quote(y)))

# Remove an argument
modify_call(call, list(na.rm = NULL))

# Add a new argument
modify_call(call, list(trim = 0.1))

# Add an explicit missing argument
modify_call(call, list(na.rm = quote(expr = )))
}


================================================
FILE: man/modify_lang.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/modify-lang.r
\name{modify_lang}
\alias{modify_lang}
\title{Recursively modify a language object}
\usage{
modify_lang(x, f, ...)
}
\arguments{
\item{x}{object to modify: should be a call, expression, function or
list of the above.}

\item{f}{function to apply to leaves}

\item{...}{other arguments passed to \code{f}}
}
\description{
Recursively modify a language object
}
\examples{
a_to_b <- function(x) {
  if (is.name(x) && identical(x, quote(a))) return(quote(b))
  x
}
examples <- list(
  quote(a <- 5),
  alist(a = 1, c = a),
  function(a = 1) a * 10,
  expression(a <- 1, a, f(a), f(a = a))
)
modify_lang(examples, a_to_b)
# Modifies all objects called a, but doesn't modify arguments named a
}


================================================
FILE: man/names_c.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/names_c.R
\name{names_c}
\alias{names_c}
\title{Extract function table from names.c from R subversion repository.}
\usage{
names_c()
}
\value{
A data frame with columns
\item{name}{the function name in R}
\item{c-entry}{The name of the corresponding C function, actually declared
  in ../include/Internal.h. All start with "do_", return SEXP, and
  have argument list (SEXP call, SEXP op, SEXP args, SEXP env)}
\item{offset}{the 'op' (offset pointer) above; used for C functions
	 which deal with more than one R function}
\item{eval}{XYZ (three digits) \cr
 \cr
 X=0 says that we should force R_Visible on \cr
 X=1 says that we should force R_Visible off \cr
 X=2 says that we should switch R_Visible on but let the C code update it. \cr
 \cr
 Y=1 says that this is an internal function which must
     be accessed with a	.Internal(.) call, any other value is
     accessible directly and printed in R as ".Primitive(..)".\cr
 \cr
 Z=0 says don't evaluate (SPECIALSXP).\cr
 Z=1 says evaluate arguments before calling (BUILTINSXP)}
\item{arity}{How many arguments are required/allowed;  "-1"	meaning ``any''}
\item{pp-kind}{Deparsing Info (-> PPkind in ../include/Defn.h )}
\item{precedence}{Operator precedence (-> PPprec in ../include/Defn.h )}
\item{rightassoc}{Right or left associative operator}
}
\description{
Since this is an expensive operation, it is done once and cached within
a session.
}
\keyword{internal}


================================================
FILE: man/object_size.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/object_size.R
\name{object_size}
\alias{object_size}
\alias{compare_size}
\title{Compute the size of an object.}
\usage{
object_size(..., env = parent.frame())

compare_size(x)
}
\arguments{
\item{env}{Environment in which to terminate search. This defaults to the
current environment so that you don't include the size of objects that
are already stored elsewhere.}

\item{x, ...}{Set of objects to compute total size.}
}
\value{
An estimate of the size of the object, in bytes.
}
\description{
\code{object_size} works similarly to \code{\link{object.size}}, but counts
more accurately and includes the size of environments. \code{compare_size}
makes it easy to compare the output of \code{object_size} and
\code{object.size}.
}
\section{Environments}{


\code{object_size} attempts to take into account the size of the
environments associated with an object. This is particularly important
for closures and formulas, since otherwise you may not realise that you've
accidentally captured a large object. However, it's easy to over count:
you don't want to include the size of every object in every environment
leading back to the \code{\link{emptyenv}()}. \code{object_size} takes
a heuristic approach: it never counts the size of the global env,
the base env, the empty env or any namespace.

Additionally, the \code{env} argument allows you to specify another
environment at which to stop. This defaults to the environment from which
\code{object_size} is called to prevent double-counting of objects created
elsewhere.
}

\examples{
# object.size doesn't keep track of shared elements in an object
# object_size does
x <- 1:1e4
z <- list(x, x, x)
compare_size(z)

# this means that object_size is not transitive
object_size(x)
object_size(z)
object_size(x, z)

# object.size doesn't include the size of environments, which makes
# it easy to miss objects that are carrying around large environments
f <- function() {
  x <- 1:1e4
  a ~ b
}
compare_size(f())
}


================================================
FILE: man/otype.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/otype.r
\name{otype}
\alias{otype}
\title{Determine object type.}
\usage{
otype(x)
}
\arguments{
\item{x}{object to determine type of}
}
\description{
Determine object type.
}
\details{
Figure out which object system an object belongs to:

\itemize{
  \item base: no class attribute
  \item S3: class attribute, but not S4
  \item S4: \code{\link{isS4}}, but not RC
  \item RC: inherits from "refClass"
}
}
\examples{
otype(data.frame())
otype(1:10)
}
\seealso{
Other object inspection: 
\code{\link{ftype}()},
\code{\link{sexp_type}()}
}
\concept{object inspection}


================================================
FILE: man/parent_promise.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/promise.r
\name{parent_promise}
\alias{parent_promise}
\title{Find the parent (first) promise.}
\usage{
parent_promise(x)
}
\arguments{
\item{x}{unquoted name of promise to find initial value for for.}
}
\description{
Find the parent (first) promise.
}
\examples{
f <- function(x) g(x)
g <- function(y) h(y)
h <- function(z) parent_promise(z)

h(x + 1)
g(x + 1)
f(x + 1)
}


================================================
FILE: man/parenv.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/parenv.r
\name{parenv}
\alias{parenv}
\title{Get parent/ancestor environment}
\usage{
parenv(env = parent.frame(), n = 1)
}
\arguments{
\item{env}{an environment}

\item{n}{number of parents to go up}
}
\description{
Get parent/ancestor environment
}
\examples{
adder <- function(x) function(y) x + y
add2 <- adder(2)
parenv(add2)
}


================================================
FILE: man/parenvs.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/parenv.r
\name{parenvs}
\alias{parenvs}
\title{Given an environment or object, return an \code{envlist} of its
parent environments.}
\usage{
parenvs(e = parent.frame(), all = FALSE)
}
\arguments{
\item{e}{An environment or other object.}

\item{all}{If \code{FALSE} (the default), stop at the global
environment or the empty environment. If \code{TRUE}, print all
parents, stopping only at the empty environment (which is the
top-level environment).}
}
\description{
If \code{e} is not specified, it will start with environment from which
the function was called.
}
\examples{
# Print the current environment and its parents
parenvs()

# Print the parent environments of the load_all function
e <- parenvs(parenvs)
e

# Get all parent environments, going all the way to empty env
e <- parenvs(parenvs, TRUE)
e

# Print e with paths
print(e, path = TRUE)

# Print the first 6 environments in the envlist
e[1:6]

# Print just the parent environment of load_all.
# This is an envlist with one element.
e[1]

# Pull that environment out of the envlist and see what's in it.
e[[1]]
ls(e[[1]], all.names = TRUE)
}


================================================
FILE: man/partial.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/partial.r
\name{partial}
\alias{partial}
\title{Partial apply a function, filling in some arguments.}
\usage{
partial(`_f`, ..., .env = parent.frame(), .lazy = TRUE)
}
\arguments{
\item{_f}{a function. For the output source to read well, this should be an
be a named function.  This argument has the weird (non-syntactic) name
\code{_f} so it doesn't accidentally capture any argument names begining
with f.}

\item{...}{named arguments to \code{f} that should be partially applied.}

\item{.env}{the environment of the created function. Defaults to
\code{\link{parent.frame}} and you should rarely need to modify this.}

\item{.lazy}{If \code{TRUE} arguments evaluated lazily, if \code{FALSE},
evaluated when \code{partial} is called.}
}
\description{
Partial function application allows you to modify a function by pre-filling
some of the arguments.  It is particularly useful in conjunction with
functionals and other function operators.
}
\section{Design choices}{


There are many ways to implement partial function application in R.
(see e.g. \code{dots} in \url{https://github.com/crowding/vadr} for another
approach.)  This implementation is based on creating functions that are as
similar as possible to the anonymous function that'd you'd create by hand,
if you weren't using \code{partial}.
}

\examples{
# Partial is designed to replace the use of anonymous functions for
# filling in function arguments. Instead of:
compact1 <- function(x) Filter(Negate(is.null), x)

# we can write:
compact2 <- partial(Filter, Negate(is.null))

# and the generated source code is very similar to what we made by hand
compact1
compact2

# Note that the evaluation occurs "lazily" so that arguments will be
# repeatedly evaluated
f <- partial(runif, n = rpois(1, 5))
f
f()
f()

# You can override this by saying .lazy = FALSE
f <- partial(runif, n = rpois(1, 5), .lazy = FALSE)
f
f()
f()

# This also means that partial works fine with functions that do
# non-standard evaluation
my_long_variable <- 1:10
plot2 <- partial(plot, my_long_variable)
plot2()
plot2(runif(10), type = "l")
}


================================================
FILE: man/print.envlist.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/parenv.r
\name{print.envlist}
\alias{print.envlist}
\title{Print an \code{envlist}}
\usage{
\method{print}{envlist}(x, name = TRUE, path = FALSE, ...)
}
\arguments{
\item{x}{An \code{envlist} object to print.}

\item{name}{If \code{TRUE} (the default), print the \code{name}
attribute of each environment.}

\item{path}{If \code{TRUE}, print the \code{path} attribute of
each environment.}

\item{...}{Other arguments to be passed to \code{print}.}
}
\description{
Print an \code{envlist}
}
\keyword{internal}


================================================
FILE: man/rebind.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/rebind.r
\name{rebind}
\alias{rebind}
\title{Rebind an existing name.}
\usage{
rebind(name, value, env = parent.frame())
}
\arguments{
\item{name}{name of existing binding to re-assign}

\item{value}{new value}

\item{env}{environment to start search in.}
}
\description{
This function is similar to \code{\link{<<-}} with two exceptions:
}
\details{
\itemize{
 \item if no existing binding is found, it throws an error
 \item it does not recurse past the global environment into the attached
   packages
}
}
\examples{
a <- 1
rebind("a", 2)
a
# Throws error if no existing binding
\dontrun{rebind("b", 2)}

local({
  rebind("a", 3)
})
a

# Can't find get because doesn't look past globalenv
\dontrun{rebind("get", 1)}
}


================================================
FILE: man/rls.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/rls.r
\name{rls}
\alias{rls}
\title{Recursive ls.}
\usage{
rls(env = parent.frame(), all.names = TRUE)
}
\arguments{
\item{env}{environment to start the search at. Defaults to the
\code{\link{parent.frame}}. If a function is supplied, uses the environment
associated with the function.}

\item{all.names}{Show all names, even those starting with \code{.}?
Defaults to \code{TRUE}, the opposite of \code{\link{ls}}}
}
\description{
Performs \code{\link{ls}} all the way up to a top-level environment (either
the parent of the global environment, the empty environment or a namespace
environment).
}
\author{
Winston Chang
}


================================================
FILE: man/show_c_source.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/names_c.R
\name{show_c_source}
\alias{show_c_source}
\title{Find C source code for internal R functions}
\usage{
show_c_source(fun)
}
\arguments{
\item{fun}{.Internal or .Primitive function call.}
}
\description{
Opens a link to code search on github.
}
\examples{
\donttest{
show_c_source(.Internal(mean(x)))
show_c_source(.Primitive(sum(x)))
}
}


================================================
FILE: man/standardise_call.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/standardise-call.r
\name{standardise_call}
\alias{standardise_call}
\title{Standardise a function call}
\usage{
standardise_call(call, env = parent.frame())
}
\arguments{
\item{call}{A call}

\item{env}{Environment in which to look up call value.}
}
\description{
Standardise a function call
}


================================================
FILE: man/subs.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/substitute.r
\name{subs}
\alias{subs}
\title{A version of substitute that works in the global environment.}
\usage{
subs(x, env = parent.frame())
}
\arguments{
\item{x}{a quoted call}

\item{env}{an environment, or something that behaves like an environment
(like a list or data frame), or a reference to an environment (like a
positive integer or name, see \code{\link{as.environment}} for more
details)}
}
\description{
This version of \code{\link{substitute}} is more suited for interactive
exploration because it will perform substitution in the global environment:
the regular version has a special case for the global environment where it
effectively works like \code{\link{quote}}
}
\section{Substitution rules}{


Formally, substitution takes place by examining each name in the expression.
If the name refers to:

\itemize{

 \item an ordinary variable, it's replaced by the value of the variable.

 \item a promise, it's replaced by the expression associated with the
    promise.

 \item \code{...}, it's replaced by the contents of \code{...}
}
}

\examples{
a <- 1
b <- 2

substitute(a + b)
subs(a + b)
}


================================================
FILE: man/substitute_q.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/substitute.r
\name{substitute_q}
\alias{substitute_q}
\title{A version of substitute that evaluates its first argument.}
\usage{
substitute_q(x, env)
}
\arguments{
\item{x}{a quoted call}

\item{env}{an environment, or something that behaves like an environment
(like a list or data frame), or a reference to an environment (like a
positive integer or name, see \code{\link{as.environment}} for more
details)}
}
\description{
This version of substitute is needed because \code{substitute} does not
evaluate it's first argument, and it's often useful to be able to modify
a quoted call.
}
\examples{
x <- quote(a + b)
substitute(x, list(a = 1, b = 2))
substitute_q(x, list(a = 1, b = 2))
}


================================================
FILE: man/track_copy.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/inspect.r
\name{track_copy}
\alias{track_copy}
\title{Track if an object is copied}
\usage{
track_copy(var, env = parent.frame(), quiet = FALSE)
}
\arguments{
\item{var}{variable name (unquoted)}

\item{env}{environment name in which to track changes}

\item{quiet}{if \code{FALSE}, prints a message on change; if \code{FALSE}
only the return value of the function is used}
}
\value{
a zero-arg function, that when called returns a boolean indicating
  if the object has changed since the last time this function was called
}
\description{
The title is somewhat misleading: rather than checking if an object is
modified, this really checks to see if a name points to the same object.
}
\examples{
a <- 1:5
track_a <- track_copy(a)
track_a()
a[3] <- 3L
track_a()
a[3] <- 3
track_a()
rm(a)
track_a()
}


================================================
FILE: man/unenclose.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/unenclose.r
\name{unenclose}
\alias{unenclose}
\title{Unenclose a closure.}
\usage{
unenclose(f)
}
\arguments{
\item{f}{a closure}
}
\description{
Unenclose a closure by substituting names for values found in the enclosing
environment.
}
\examples{
power <- function(exp) {
  function(x) x ^ exp
}
square <- power(2)
cube <- power(3)

square
cube
unenclose(square)
unenclose(cube)
}


================================================
FILE: man/uneval.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/uneval.r
\name{uneval}
\alias{uneval}
\title{Capture the call associated with a promise.}
\usage{
uneval(x)
}
\arguments{
\item{x}{unquoted variable name that refers to a promise. An error will be
thrown if it's not a promise.}
}
\description{
This is an alternative to subsitute that performs one job, and so gives
a stronger signal regarding the intention of your code.  It returns an error
if the name is not associated with a promise.
}
\examples{
f <- function(x) {
   uneval(x)
}
f(a + b)
f(1 + 4)

delayedAssign("x", 1 + 4)
uneval(x)
x
uneval(x)
}
\seealso{
Other promise tools: 
\code{\link{is_promise}()}
}
\concept{promise tools}


================================================
FILE: man/where.Rd
================================================
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/where.r
\name{where}
\alias{where}
\title{Find where a name is defined.}
\usage{
where(name, env = parent.frame())
}
\arguments{
\item{name}{name, as string, to look for}

\item{env}{environment to start at. Defaults to the calling environment
of this function.}
}
\description{
Implements the regular scoping rules, but instead of returning the value
associated with a name, it returns the environment in which it is located.
}
\examples{
x <- 1
where("x")
where("t.test")
where("mean")
where("where")
}


================================================
FILE: pryr.Rproj
================================================
Version: 1.0

RestoreWorkspace: Default
SaveWorkspace: Default
AlwaysSaveHistory: Default

EnableCodeIndexing: Yes
UseSpacesForTab: Yes
NumSpacesForTab: 2
Encoding: UTF-8

RnwWeave: Sweave
LaTeX: pdfLaTeX

AutoAppendNewline: Yes
StripTrailingWhitespace: Yes

BuildType: Package
PackageUseDevtools: Yes
PackageInstallArgs: --no-multiarch --with-keep.source
PackageRoxygenize: rd,collate,namespace


================================================
FILE: src/.gitignore
================================================
*.o
*.so
*.dll

================================================
FILE: src/RcppExports.cpp
================================================
// Generated by using Rcpp::compileAttributes() -> do not edit by hand
// Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393

#include <Rcpp.h>

using namespace Rcpp;

#ifdef RCPP_USE_GLOBAL_ROSTREAM
Rcpp::Rostream<true>&  Rcpp::Rcout = Rcpp::Rcpp_cout_get();
Rcpp::Rostream<false>& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get();
#endif

// binary_repr
CharacterVector binary_repr(SEXP x);
RcppExport SEXP _pryr_binary_repr(SEXP xSEXP) {
BEGIN_RCPP
    Rcpp::RObject rcpp_result_gen;
    Rcpp::RNGScope rcpp_rngScope_gen;
    Rcpp::traits::input_parameter< SEXP >::type x(xSEXP);
    rcpp_result_gen = Rcpp::wrap(binary_repr(x));
    return rcpp_result_gen;
END_RCPP
}
// hex_repr
CharacterVector hex_repr(SEXP x);
RcppExport SEXP _pryr_hex_repr(SEXP xSEXP) {
BEGIN_RCPP
    Rcpp::RObject rcpp_result_gen;
    Rcpp::RNGScope rcpp_rngScope_gen;
    Rcpp::traits::input_parameter< SEXP >::type x(xSEXP);
    rcpp_result_gen = Rcpp::wrap(hex_repr(x));
    return rcpp_result_gen;
END_RCPP
}
// binary2hex
CharacterVector binary2hex(CharacterVector x);
RcppExport SEXP _pryr_binary2hex(SEXP xSEXP) {
BEGIN_RCPP
    Rcpp::RObject rcpp_result_gen;
    Rcpp::RNGScope rcpp_rngScope_gen;
    Rcpp::traits::input_parameter< CharacterVector >::type x(xSEXP);
    rcpp_result_gen = Rcpp::wrap(binary2hex(x));
    return rcpp_result_gen;
END_RCPP
}
// inspect_
List inspect_(SEXP x, Environment base_env);
RcppExport SEXP _pryr_inspect_(SEXP xSEXP, SEXP base_envSEXP) {
BEGIN_RCPP
    Rcpp::RObject rcpp_result_gen;
    Rcpp::RNGScope rcpp_rngScope_gen;
    Rcpp::traits::input_parameter< SEXP >::type x(xSEXP);
    Rcpp::traits::input_parameter< Environment >::type base_env(base_envSEXP);
    rcpp_result_gen = Rcpp::wrap(inspect_(x, base_env));
    return rcpp_result_gen;
END_RCPP
}
// address2
std::string address2(Symbol name, Environment env);
RcppExport SEXP _pryr_address2(SEXP nameSEXP, SEXP envSEXP) {
BEGIN_RCPP
    Rcpp::RObject rcpp_result_gen;
    Rcpp::RNGScope rcpp_rngScope_gen;
    Rcpp::traits::input_parameter< Symbol >::type name(nameSEXP);
    Rcpp::traits::input_parameter< Environment >::type env(envSEXP);
    rcpp_result_gen = Rcpp::wrap(address2(name, env));
    return rcpp_result_gen;
END_RCPP
}
// named2
int named2(Symbol name, Environment env);
RcppExport SEXP _pryr_named2(SEXP nameSEXP, SEXP envSEXP) {
BEGIN_RCPP
    Rcpp::RObject rcpp_result_gen;
    Rcpp::RNGScope rcpp_rngScope_gen;
    Rcpp::traits::input_parameter< Symbol >::type name(nameSEXP);
    Rcpp::traits::input_parameter< Environment >::type env(envSEXP);
    rcpp_result_gen = Rcpp::wrap(named2(name, env));
    return rcpp_result_gen;
END_RCPP
}
// is_promise2
bool is_promise2(Symbol name, Environment env);
RcppExport SEXP _pryr_is_promise2(SEXP nameSEXP, SEXP envSEXP) {
BEGIN_RCPP
    Rcpp::RObject rcpp_result_gen;
    Rcpp::RNGScope rcpp_rngScope_gen;
    Rcpp::traits::input_parameter< Symbol >::type name(nameSEXP);
    Rcpp::traits::input_parameter< Environment >::type env(envSEXP);
    rcpp_result_gen = Rcpp::wrap(is_promise2(name, env));
    return rcpp_result_gen;
END_RCPP
}
// promise_code
SEXP promise_code(Symbol name, Environment env);
RcppExport SEXP _pryr_promise_code(SEXP nameSEXP, SEXP envSEXP) {
BEGIN_RCPP
    Rcpp::RObject rcpp_result_gen;
    Rcpp::RNGScope rcpp_rngScope_gen;
    Rcpp::traits::input_parameter< Symbol >::type name(nameSEXP);
    Rcpp::traits::input_parameter< Environment >::type env(envSEXP);
    rcpp_result_gen = Rcpp::wrap(promise_code(name, env));
    return rcpp_result_gen;
END_RCPP
}
// promise_value
SEXP promise_value(Symbol name, Environment env);
RcppExport SEXP _pryr_promise_value(SEXP nameSEXP, SEXP envSEXP) {
BEGIN_RCPP
    Rcpp::RObject rcpp_result_gen;
    Rcpp::RNGScope rcpp_rngScope_gen;
    Rcpp::traits::input_parameter< Symbol >::type name(nameSEXP);
    Rcpp::traits::input_parameter< Environment >::type env(envSEXP);
    rcpp_result_gen = Rcpp::wrap(promise_value(name, env));
    return rcpp_result_gen;
END_RCPP
}
// promise_evaled
bool promise_evaled(Symbol name, Environment env);
RcppExport SEXP _pryr_promise_evaled(SEXP nameSEXP, SEXP envSEXP) {
BEGIN_RCPP
    Rcpp::RObject rcpp_result_gen;
    Rcpp::RNGScope rcpp_rngScope_gen;
    Rcpp::traits::input_parameter< Symbol >::type name(nameSEXP);
    Rcpp::traits::input_parameter< Environment >::type env(envSEXP);
    rcpp_result_gen = Rcpp::wrap(promise_evaled(name, env));
    return rcpp_result_gen;
END_RCPP
}
// promise_env
SEXP promise_env(Symbol name, Environment env);
RcppExport SEXP _pryr_promise_env(SEXP nameSEXP, SEXP envSEXP) {
BEGIN_RCPP
    Rcpp::RObject rcpp_result_gen;
    Rcpp::RNGScope rcpp_rngScope_gen;
    Rcpp::traits::input_parameter< Symbol >::type name(nameSEXP);
    Rcpp::traits::input_parameter< Environment >::type env(envSEXP);
    rcpp_result_gen = Rcpp::wrap(promise_env(name, env));
    return rcpp_result_gen;
END_RCPP
}
// makeExplicit
RObject makeExplicit(SEXP prom);
RcppExport SEXP _pryr_makeExplicit(SEXP promSEXP) {
BEGIN_RCPP
    Rcpp::RObject rcpp_result_gen;
    Rcpp::RNGScope rcpp_rngScope_gen;
    Rcpp::traits::input_parameter< SEXP >::type prom(promSEXP);
    rcpp_result_gen = Rcpp::wrap(makeExplicit(prom));
    return rcpp_result_gen;
END_RCPP
}
// explicitPromise
RObject explicitPromise(Symbol name, Environment env);
RcppExport SEXP _pryr_explicitPromise(SEXP nameSEXP, SEXP envSEXP) {
BEGIN_RCPP
    Rcpp::RObject rcpp_result_gen;
    Rcpp::RNGScope rcpp_rngScope_gen;
    Rcpp::traits::input_parameter< Symbol >::type name(nameSEXP);
    Rcpp::traits::input_parameter< Environment >::type env(envSEXP);
    rcpp_result_gen = Rcpp::wrap(explicitPromise(name, env));
    return rcpp_result_gen;
END_RCPP
}
// explicitDots
std::vector<RObject> explicitDots(Environment env);
RcppExport SEXP _pryr_explicitDots(SEXP envSEXP) {
BEGIN_RCPP
    Rcpp::RObject rcpp_result_gen;
    Rcpp::RNGScope rcpp_rngScope_gen;
    Rcpp::traits::input_parameter< Environment >::type env(envSEXP);
    rcpp_result_gen = Rcpp::wrap(explicitDots(env));
    return rcpp_result_gen;
END_RCPP
}
// slice
CharacterVector slice(CharacterVector x, int k, std::string sep);
RcppExport SEXP _pryr_slice(SEXP xSEXP, SEXP kSEXP, SEXP sepSEXP) {
BEGIN_RCPP
    Rcpp::RObject rcpp_result_gen;
    Rcpp::RNGScope rcpp_rngScope_gen;
    Rcpp::traits::input_parameter< CharacterVector >::type x(xSEXP);
    Rcpp::traits::input_parameter< int >::type k(kSEXP);
    Rcpp::traits::input_parameter< std::string >::type sep(sepSEXP);
    rcpp_result_gen = Rcpp::wrap(slice(x, k, sep));
    return rcpp_result_gen;
END_RCPP
}
// sexp_type
std::string sexp_type(SEXP x);
RcppExport SEXP _pryr_sexp_type(SEXP xSEXP) {
BEGIN_RCPP
    Rcpp::RObject rcpp_result_gen;
    Rcpp::RNGScope rcpp_rngScope_gen;
    Rcpp::traits::input_parameter< SEXP >::type x(xSEXP);
    rcpp_result_gen = Rcpp::wrap(sexp_type(x));
    return rcpp_result_gen;
END_RCPP
}
// typename2
std::string typename2(Symbol name, Environment env);
RcppExport SEXP _pryr_typename2(SEXP nameSEXP, SEXP envSEXP) {
BEGIN_RCPP
    Rcpp::RObject rcpp_result_gen;
    Rcpp::RNGScope rcpp_rngScope_gen;
    Rcpp::traits::input_parameter< Symbol >::type name(nameSEXP);
    Rcpp::traits::input_parameter< Environment >::type env(envSEXP);
    rcpp_result_gen = Rcpp::wrap(typename2(name, env));
    return rcpp_result_gen;
END_RCPP
}

static const R_CallMethodDef CallEntries[] = {
    {"_pryr_binary_repr", (DL_FUNC) &_pryr_binary_repr, 1},
    {"_pryr_hex_repr", (DL_FUNC) &_pryr_hex_repr, 1},
    {"_pryr_binary2hex", (DL_FUNC) &_pryr_binary2hex, 1},
    {"_pryr_inspect_", (DL_FUNC) &_pryr_inspect_, 2},
    {"_pryr_address2", (DL_FUNC) &_pryr_address2, 2},
    {"_pryr_named2", (DL_FUNC) &_pryr_named2, 2},
    {"_pryr_is_promise2", (DL_FUNC) &_pryr_is_promise2, 2},
    {"_pryr_promise_code", (DL_FUNC) &_pryr_promise_code, 2},
    {"_pryr_promise_value", (DL_FUNC) &_pryr_promise_value, 2},
    {"_pryr_promise_evaled", (DL_FUNC) &_pryr_promise_evaled, 2},
    {"_pryr_promise_env", (DL_FUNC) &_pryr_promise_env, 2},
    {"_pryr_makeExplicit", (DL_FUNC) &_pryr_makeExplicit, 1},
    {"_pryr_explicitPromise", (DL_FUNC) &_pryr_explicitPromise, 2},
    {"_pryr_explicitDots", (DL_FUNC) &_pryr_explicitDots, 1},
    {"_pryr_slice", (DL_FUNC) &_pryr_slice, 3},
    {"_pryr_sexp_type", (DL_FUNC) &_pryr_sexp_type, 1},
    {"_pryr_typename2", (DL_FUNC) &_pryr_typename2, 2},
    {NULL, NULL, 0}
};

RcppExport void R_init_pryr(DllInfo *dll) {
    R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
    R_useDynamicSymbols(dll, FALSE);
}


================================================
FILE: src/bytes.cpp
================================================
#include <iomanip>
#include <Rcpp.h>

using namespace Rcpp;

// good enough for now, I suppose
#if defined(__sparc__) || defined(__sparc) || defined(__ppc__) || defined(__ppc64__)
#define IS_BIG_ENDIAN true
#else
#define IS_BIG_ENDIAN false
#endif


namespace pryr {

// traits to denote the internal C storage of an R type
namespace traits {

template <int RTYPE>
struct dataptr {
  typedef typename Rcpp::traits::storage_type<RTYPE>::type* type;
};

template <>
struct dataptr<STRSXP> {
  typedef const char* type;
};

} // namespace traits

// Declaring some types
// We store the number of characters needed to represent a single byte of data
// for a given representation
struct Bits {
  static const int chars_per_byte = 8;
};
struct Hex {
  static const int chars_per_byte = 2;
};

// Utility functions
template <int RTYPE>
typename traits::dataptr<RTYPE>::type get_pointer(const Rcpp::Vector<RTYPE>& x, int i) {
  return static_cast<typename traits::dataptr<RTYPE>::type>(dataptr(x)) + i;
}

template <>
const char* get_pointer(const Rcpp::Vector<STRSXP>& x, int i) {
  return CHAR(STRING_ELT(x, i));
}

template <int RTYPE>
inline size_t get_length_in_bytes(const Rcpp::Vector<RTYPE>& x, int i) {
  return sizeof(typename ::Rcpp::traits::storage_type<RTYPE>::type);
}

template <>
inline size_t get_length_in_bytes(const Rcpp::Vector<STRSXP>& x, int i) {
  return strlen( CHAR(STRING_ELT(x, i)) );
}

// Class handling the conversion logic (from T to bits or hex)
template <typename Repr, bool is_string>
struct Representation {

  static const int chars_per_byte = Repr::chars_per_byte;

  inline void operator()(const char* ptr, size_t n, char* output) {
    return repr(ptr, n, output);
  }

  inline void repr(const char* ptr, size_t n, char* output);

};

// Depending on the type of data, we either want to read from left-to-right,
// or right-to-left, to give an output that matches what we might expect
// from the binary representation. In particular, we read the bits in a
// string from left to right, while we read the bits in a numeric value
// from right to left (endianness; TODO is to handle that in the dispatch
// later on)
template <>
void Representation<Bits, false>::repr(const char* ptr, size_t n, char* output) {
  int counter = n * 8 - 1;
  for (size_t i=0; i < n; ++i) {
    char curr = ptr[i];
    for (int j=0; j < 8; ++j) {
      output[counter--] = curr & 1 ? '1' : '0';
      curr >>= 1;
    }
  }
}

template<>
void Representation<Bits, true>::repr(const char* ptr, size_t n, char* output) {
  int counter = n * 8 - 1;
  for (int i = n - 1; i >= 0; --i) {
    char curr = ptr[i];
    for (int j=0; j < 8; ++j) {
      output[counter--] = curr & 1 ? '1' : '0';
      curr >>= 1;
    }
  }
}

// The hex version
template<>
void Representation<Hex, true>::repr(const char* ptr, size_t n, char* output) {
  int counter = 0;
  for (size_t i = 0; i < n; ++i) {
    snprintf(output + counter * 2, 2 + 1, "%02X", ptr[i] & 0xFF);
    ++counter;
  }
}

template<>
void Representation<Hex, false>::repr(const char* ptr, size_t n, char* output) {
  int counter = 0;
  for (int i = n - 1; i >= 0; --i) {
    snprintf(output + counter * 2, 2 + 1, "%02X", ptr[i] & 0xFF);
    ++counter;
  }
}

// generic version for non-STRSXP
template <int RTYPE, typename Representation>
CharacterVector representation(const Vector<RTYPE>& x, Representation fill_as) {

  int n = x.size();
  CharacterVector output = no_init(n);

  // Allocate a buffer to hold printed results
  size_t num_bytes = sizeof(typename Rcpp::traits::storage_type<RTYPE>::type);
  size_t num_chars = Representation::chars_per_byte * num_bytes;
  char* buff = new char[num_chars + 1];
  buff[num_chars] = '\0';

  // Fill the buffer and the output vector
  for (int i=0; i < n; ++i) {
    const char* ptr = reinterpret_cast<const char*>(get_pointer(x, i));
    fill_as(ptr, num_bytes, buff);
    SET_STRING_ELT(output, i, Rf_mkChar(buff));
  }

  // Clean up and return
  delete[] buff;
  return output;
}

// STRSXP
template <typename Representation>
CharacterVector representation_str(const Vector<STRSXP>& x, Representation fill_as) {

  int n = x.size();
  CharacterVector output = no_init(n);
  size_t chars_per_byte = Representation::chars_per_byte;

  for (int i=0; i < n; ++i) {
    const char* ptr = reinterpret_cast<const char*>(get_pointer(x, i));
    size_t num_bytes = get_length_in_bytes(x, i);
    size_t num_chars = chars_per_byte * num_bytes;
    char* buff = new char[num_chars + 1];
    buff[num_chars] = '\0';
    fill_as(ptr, num_bytes, buff);
    SET_STRING_ELT(output, i, Rf_mkChar(buff));
    delete[] buff;
  }

  return output;
}

} // namespace pryr

using namespace pryr;

// [[Rcpp::export]]
CharacterVector binary_repr(SEXP x) {
  switch (TYPEOF(x)) {
  case INTSXP: return representation<INTSXP>(x, Representation<Bits, IS_BIG_ENDIAN>());
  case REALSXP: return representation<REALSXP>(x, Representation<Bits, IS_BIG_ENDIAN>());
  case LGLSXP: return representation<LGLSXP>(x, Representation<Bits, IS_BIG_ENDIAN>());
  case STRSXP: return representation_str(x, Representation<Bits, true>());
  default: {
    std::stringstream ss;
    ss << "can't print binary representation for objects of type '" <<
      CHAR(Rf_type2str(TYPEOF(x))) << "'";
    stop(ss.str());
  }
  }
  return CharacterVector();
}

// [[Rcpp::export]]
CharacterVector hex_repr(SEXP x) {
  switch (TYPEOF(x)) {
  case INTSXP: return representation<INTSXP>(x, Representation<Hex, IS_BIG_ENDIAN>());
  case REALSXP: return representation<REALSXP>(x, Representation<Hex, IS_BIG_ENDIAN>());
  case LGLSXP: return representation<LGLSXP>(x, Representation<Hex, IS_BIG_ENDIAN>());
  case STRSXP: return representation_str(x, Representation<Hex, true>());
  default: {
    std::stringstream ss;
    ss << "can't print binary representation for objects of type '" <<
      CHAR(Rf_type2str(TYPEOF(x))) << "'";
    stop(ss.str());
  }
  }
  return CharacterVector();
}

namespace pryr {

std::string binary2hex(const std::string& x) {
  int n = x.size();
  if (n % 8 != 0) {
    stop("expecting a string of length 8n");
  }
  std::stringstream output;
  int nBytes = n / 8;
  for (int i=0; i < nBytes; ++i) {
    char curr;
    int value = 0;
    for (int j=0; j < 8; ++j) {
      curr = x[i*8 + j];
      if (!(curr == '0' or curr == '1')) stop("each character must be '0' or '1'");
      if (curr == '1') value += 1 << (7 - j);
    }
    std::stringstream ss;
    ss << std::setfill('0') << std::setw(2) << std::uppercase << std::hex << (int) value;
    output << ss.str();
  }
  return output.str();
}

} // namespace pryr

// [[Rcpp::export]]
CharacterVector binary2hex(CharacterVector x) {
  int n = x.size();
  CharacterVector output = no_init(n);
  for (int i=0; i < n; ++i) {
    output[i] = binary2hex( as<std::string>(x[i]) );
  }
  return output;
}


================================================
FILE: src/inspect.cpp
================================================
#include <Rcpp.h>
using namespace Rcpp;

bool is_namespace(Environment env) {
  return Rf_findVarInFrame3(env, Rf_install(".__NAMESPACE__."), FALSE) != R_UnboundValue;
}

std::string sexp_type(SEXP x);

std::string address(SEXP x) {
  std::ostringstream s;
  s << x;
  return s.str();
}


List inspect_rec(SEXP x, Environment base_env, std::set<SEXP>& seen) {
  // If we've seen it before, return nothing
  if (!seen.insert(x).second) {
    List out =  List::create(
      _["address"] = address(x),
      _["type"] = sexp_type(x),
      _["named"] = NAMED(x),
      _["seen"] = true
    );
    std::vector<std::string> klass;
    klass.push_back("inspect_" + sexp_type(x));
    klass.push_back("inspect");
    out.attr("class") = klass;
    return out;
  }

  List children;

  switch (TYPEOF(x)) {
    // Base case: non recursive objects
    case LGLSXP:
    case INTSXP:
    case REALSXP:
    case CPLXSXP:
    case RAWSXP:
    case CHARSXP:
    case SYMSXP:
    case NILSXP:
    case SPECIALSXP:
    case BUILTINSXP:
      break;

    // Strings
    case STRSXP:
      children = List(LENGTH(x));
      for (int i = 0; i < LENGTH(x); i++) {
        children[i] = inspect_rec(STRING_ELT(x, i), base_env, seen);
      }
      break;

    // Generic vectors
    case VECSXP:
    case EXPRSXP:
    case WEAKREFSXP:
      children = List(XLENGTH(x));
      for (int i = 0; i < LENGTH(x); i++) {
        children[i] = inspect_rec(VECTOR_ELT(x, i), base_env, seen);
      }
      break;

    // Linked lists
    case LISTSXP:
    case LANGSXP:
    case BCODESXP:
      children = List::create(
        _["tag"] = inspect_rec(TAG(x), base_env, seen), // name of first element
        _["car"] = inspect_rec(CAR(x), base_env, seen), // first element
        _["cdr"] = inspect_rec(CDR(x), base_env, seen) // pairlist (subsequent elements) or NILSXP
      );
      break;

    // Environments
    case ENVSXP:
      if (x == R_BaseEnv || x == R_GlobalEnv || x == R_EmptyEnv ||
          x == base_env || is_namespace(x)) break;

      children = List::create(
        _["frame"] = inspect_rec(FRAME(x), base_env, seen),
        _["enclos"] = inspect_rec(ENCLOS(x), base_env, seen),
        _["hashtab"] = inspect_rec(HASHTAB(x), base_env, seen)
      );
      break;

    // Functions
    case CLOSXP:
      children = List::create(
        _["formals"] = inspect_rec(FORMALS(x), base_env, seen),
        _["body"] = inspect_rec(BODY(x), base_env, seen),
        _["env"]  = inspect_rec(CLOENV(x), base_env, seen)
      );
      break;

    case PROMSXP:
      children = List::create(
        _["value"] = inspect_rec(PRVALUE(x), base_env, seen),
        _["code"] = inspect_rec(PRCODE(x), base_env, seen),
        _["env"]  = inspect_rec(PRENV(x), base_env, seen)
      );
      break;

    case EXTPTRSXP:
      children = List::create(
        _["prot"] = inspect_rec(EXTPTR_PROT(x), base_env, seen),
        _["tag"] = inspect_rec(EXTPTR_TAG(x), base_env, seen)
      );
      break;

    case S4SXP:
      children = List::create(
        _["tag"] = inspect_rec(TAG(x), base_env, seen)
      );
      break;

    default:
      Rcout << "type: " << TYPEOF(x);
      stop("Unimplemented type");
  }


  List out = List::create(
    _["address"] = address(x),
    _["type"] = sexp_type(x),
    _["named"] = NAMED(x),
    _["seen"] = false
  );

  if (ATTRIB(x) != R_NilValue) {
    children["attributes"] = inspect_rec(ATTRIB(x), base_env, seen);
  }
  if (children.size() > 0) {
    out["children"] = children;
  }

  std::vector<std::string> klass;
  klass.push_back("inspect_" + sexp_type(x));
  klass.push_back("inspect");
  out.attr("class") = klass;

  return out;
}

// [[Rcpp::export]]
List inspect_(SEXP x, Environment base_env) {
  std::set<SEXP> seen;

  return inspect_rec(x, base_env, seen);
}


// [[Rcpp::export]]
std::string address2(Symbol name, Environment env) {
  SEXP object = Rf_findVar(name, env);
  std::ostringstream s;
  s << object;
  return s.str();
}

// [[Rcpp::export]]
int named2(Symbol name, Environment env) {
  SEXP object = Rf_findVar(name, env);
  return NAMED(object);
}


================================================
FILE: src/promise.cpp
================================================
#include <Rcpp.h>
using namespace Rcpp;

// [[Rcpp::export]]
bool is_promise2(Symbol name, Environment env) {
  SEXP object = Rf_findVar(name, env);

  return (TYPEOF (object) == PROMSXP);
}

// [[Rcpp::export]]
SEXP promise_code(Symbol name, Environment env) {
  SEXP object = Rf_findVar(name, env);
  return PRCODE(object);
}
// [[Rcpp::export]]
SEXP promise_value(Symbol name, Environment env) {
  SEXP object = Rf_findVar(name, env);
  return PRVALUE(object);
}
// [[Rcpp::export]]
bool promise_evaled(Symbol name, Environment env) {
  SEXP object = Rf_findVar(name, env);
  return PRVALUE(object) != R_UnboundValue;
}
// [[Rcpp::export]]
SEXP promise_env(Symbol name, Environment env) {
  SEXP object = Rf_findVar(name, env);
  return PRENV(object);
}


// [[Rcpp::export]]
RObject makeExplicit(SEXP prom) {
  if (TYPEOF(prom) != PROMSXP) {
    stop("Not a promise");
  }

  // recurse until we find the real promise, not a promise of a promise
  while(true) {
    SEXP code = PRCODE(prom);
    if(TYPEOF(code) != PROMSXP) break;
    prom = code;
  }

  SEXP args = PROTECT(Rf_lcons(PRCODE(prom), R_NilValue));
  RObject formula = Rf_lcons(Rf_install("~"), args);
  UNPROTECT(1);

  formula.attr(".Environment") = PRENV(prom);
  formula.attr("class") = "formula";

  return formula;
}

// [[Rcpp::export]]
RObject explicitPromise(Symbol name, Environment env) {
  SEXP prom = Rf_findVar(name, env);
  return makeExplicit(prom);
}

// [[Rcpp::export]]
std::vector<RObject> explicitDots(Environment env) {
  SEXP dots = env.find("...");

  std::vector<RObject> out;
  std::vector<std::string> names;

  dots = env.find("...");

  SEXP el;
  for(SEXP nxt = dots; nxt != R_NilValue; el = CAR(nxt), nxt = CDR(nxt)) {
    out.push_back(makeExplicit(el));

    SEXP name = TAG(nxt);
    if (Rf_isNull(name)) {
      names.push_back("");
    } else {
      names.push_back("");
    }
  }


  return out;
}


================================================
FILE: src/slice.cpp
================================================
#include <Rcpp.h>
using namespace Rcpp;

std::string slice(std::string const& x, int k, std::string const& sep = " ") {
  std::string output;
  int size = x.size();
  int nSlices = size / k;
  output.reserve(size + nSlices * sep.size() - 1);
  for (int i=0; i < nSlices - 1; ++i) {
    output += x.substr(i * k, k);
    output += sep;
  }
  output += x.substr(size - k, k);
  return output;
}

// [[Rcpp::export]]
CharacterVector slice(CharacterVector x, int k, std::string sep = " ") {
  int n = x.size();
  CharacterVector output = no_init(n);
  for (int i=0; i < n; ++i) {
    output[i] = slice( as<std::string>(x[i]), k, sep );
  }
  return output;
}


================================================
FILE: src/typename.cpp
================================================
// Modified from src/main/inspect.C
//
// Copyright (C) 2009-2012 The R Core Team.
// Copyright (C) 2013 Hadley Wickham
//
// This program is free software; you can redistribute it and/or modify
// it under the terms of the GNU General Public License as published by
// the Free Software Foundation; either version 2 of the License, or
// (at your option) any later version.
//
// This program is distributed in the hope that it will be useful,
// but WITHOUT ANY WARRANTY; without even the implied warranty of
// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
// GNU General Public License for more details.
//
// A copy of the GNU General Public License is available at
// http://www.r-project.org/Licenses/

#include <Rcpp.h>
using namespace Rcpp;

//' @export
//' @rdname inspect
// [[Rcpp::export]]
std::string sexp_type(SEXP x) {
  switch (TYPEOF(x)) {
    case NILSXP:  return "NILSXP";
    case SYMSXP:  return "SYMSXP";
    case LISTSXP: return "LISTSXP";
    case CLOSXP:  return "CLOSXP";
    case ENVSXP:  return "ENVSXP";
    case PROMSXP: return "PROMSXP";
    case LANGSXP: return "LANGSXP";
    case SPECIALSXP:  return "SPECIALSXP";
    case BUILTINSXP:  return "BUILTINSXP";
    case CHARSXP: return "CHARSXP";
    case LGLSXP:  return "LGLSXP";
    case INTSXP:  return "INTSXP";
    case REALSXP: return "REALSXP";
    case CPLXSXP: return "CPLXSXP";
    case STRSXP:  return "STRSXP";
    case DOTSXP:  return "DOTSXP";
    case ANYSXP:  return "ANYSXP";
    case VECSXP:  return "VECSXP";
    case EXPRSXP: return "EXPRSXP";
    case BCODESXP:  return "BCODESXP";
    case EXTPTRSXP: return "EXTPTRSXP";
    case WEAKREFSXP:  return "WEAKREFSXP";
    case S4SXP:   return "S4SXP";
    case RAWSXP:  return "RAWSXP";
    default:   return "<unknown>";
  }
}

// [[Rcpp::export]]
std::string typename2(Symbol name, Environment env) {
  SEXP object = Rf_findVar(name, env);
  return sexp_type(object);
}


================================================
FILE: tests/testthat/helper-object_size.R
================================================

expect_same <- function(x) {
  base <- as.vector(object.size(x))
  pryr <- as.vector(object_size(x))

  expect_equal(base, pryr)
}


================================================
FILE: tests/testthat/test-active-binding.r
================================================
context("is_active_binding")

test_that("active bindings can be detected", {
  x <- 10
  expect_false(is_active_binding(x))

  x %<a-% runif(1)
  expect_true(is_active_binding(x))

  y <- x
  expect_false(is_active_binding(y))
})


================================================
FILE: tests/testthat/test-bytes.r
================================================
context("bytes")

test_that("bytes produces hex representations as expected", {

  expect_identical(
    bytes(1L),
    c("00 00 00 01")
  )

  expect_identical(
    bytes(1),
    "3F F0 00 00 00 00 00 00"
  )

  expect_identical(
    bytes("aa"),
    paste(bytes("a"), bytes("a"))
  )

})

test_that("bytes produces binary representations as expected", {

  expect_identical(
    bits(1L),
    "00000000 00000000 00000000 00000001"
  )

  expect_identical(
    bits(1),
    "00111111 11110000 00000000 00000000 00000000 00000000 00000000 00000000"
  )

})

test_that("encoding doesn't affect what bits / bytes are read", {

  x <- y <- z <- "\u9b3c"
  Encoding(y) <- "bytes"
  Encoding(z) <- "latin1"
  expect_identical( bytes(x), bytes(y) )
  expect_identical( bytes(y), bytes(z) )

  expect_identical( bits(x), bits(y) )
  expect_identical( bits(y), bits(z) )

})


test_that("we read character strings in the right order", {

  test_char_repr <- function(f) {
    f <- match.fun(f)
    repr <- f(c("a", "ab", "abc"))
    first_repr <- unlist(lapply(strsplit(repr, " "), "[[", 1))
    lu <- length(unique(first_repr))
    return(lu)
  }

  expect_equal(test_char_repr(bytes), 1)
  expect_equal(test_char_repr(bits), 1)


})


================================================
FILE: tests/testthat/test-ftype.r
================================================
context("ftype")

test_that("S4 methods and generics return as expected", {
  e <- attach(NULL, name = "test")
  on.exit(detach("test"))
  
  A <- setClass("A", contains = list(), where = e)

  setGeneric("f", function(x) 1, where = e)
  f <- getGeneric("f", where = e)
  expect_equal(ftype(f), c("s4", "generic"))

  setMethod("f", signature(x = "A"), function(x) 1, where = e)
  m <- getMethod("f", signature(x = "A"), where = e)
  expect_equal(ftype(m), c("s4", "method"))    
})

test_that("RC methods return as expected", {
  B <- setRefClass("B", methods = list(f = function(x) x))
  b <- B$new()

  expect_equal(ftype(b$f), c("rc", "method"))
})

test_that("primitive_name return as expected", {

  expect_equal(primitive_name(`@`), "@")

  at <- `@`
  expect_equal(primitive_name(at), "@")
})


================================================
FILE: tests/testthat/test-method-from-call.r
================================================
context("Method from call")

e <- new.env()
setClass("A", "list", where = e)
setClass("B", "list", where = e)
setGeneric("gen0", function(x, ...) standardGeneric("gen0"), where = e)

test_that("finds method with missing args", {
  setMethod("gen0", "missing", function(x, ...) "missing", where = e)

  exp <- selectMethod("gen0", "missing")
  expect_identical(method_from_call(gen0(), e), exp)
})

test_that("only uses arguments in generic", {
  setMethod("gen0", "A", function(x, ...) "A", where = e)

  exp <- selectMethod("gen0", "A")
  expect_identical(method_from_call(gen0(new("A"), 1), e), exp)
})


================================================
FILE: tests/testthat/test-object_size.R
================================================
context("Object_size")

# Compatibility with base ---------------------------------------------------

test_that("size scales correctly with length (accounting for vector pool)", {
  expect_same(numeric())
  expect_same(1)
  expect_same(2)
  expect_same(1:10 + 0)
  expect_same(1:1000 + 0)
})

test_that("size correct for length one vectors", {
  expect_same(1)
  expect_same(1L)
  expect_same("abc")
  expect_same(paste(rep("banaana", 100), collapse = ""))
  expect_same(charToRaw("a"))
  expect_same(5 + 1i)
})

test_that("size of list computed recursively", {
  expect_same(list())
  expect_same(as.list(1))
  expect_same(as.list(1:2))
  expect_same(as.list(1:3))

  expect_same(list(list(list(list(list())))))
})

test_that("size of symbols same as base", {
  expect_same(quote(x))
  expect_same(quote(asfsadfasdfasdfds))
})

test_that("size of pairlists same as base", {
  expect_same(pairlist())
  expect_same(pairlist(1))
  expect_same(pairlist(1, 2, 3))
})

test_that("size of attributes included in object size", {
  expect_same(c(x = 1))
  expect_same(list(x = 1))
  expect_same(c(x = "y"))
})

test_that("duplicated CHARSXPS only counted once", {
  expect_same("x")
  expect_same(c("x", "y", "x"))
  expect_same(c("banana", "banana", "banana"))
})

# Improved behaviour for shared components ------------------------------------
test_that("shared components only counted once", {
  x <- 1:1e3
  z <- list(x, x, x)

  expect_equal(object_size(z), object_size(x) + object_size(vector("list", 3)))
})

test_that("size of closures same as base", {
  f <- function() NULL
  attributes(f) <- NULL # zap srcrefs
  environment(f) <- emptyenv()
  expect_same(f)
})

# Environment sizes -----------------------------------------------------------
test_that("terminal environments have size zero", {
  expect_equal(as.numeric(object_size(globalenv())), 0)
  expect_equal(as.numeric(object_size(baseenv())), 0)
  expect_equal(as.numeric(object_size(emptyenv())), 0)

  expect_equal(as.numeric(object_size(asNamespace("stats"))), 0)
})

test_that("environment size computed recursively", {
  e <- new.env(parent = emptyenv())
  e_size <- object_size(e)

  f <- new.env(parent = e)
  object_size(f)
  expect_equal(object_size(f), 2 * object_size(e))
})

test_that("size of function includes environment", {
  f <- function() {
    y <- 1:1e3
    a ~ b
  }
  g <- function() {
    y <- 1:1e3
    function() 10
  }

  expect_true(object_size(f()) > object_size(1:1e3))
  expect_true(object_size(g()) > object_size(1:1e3))
})

test_that("size doesn't include parents of current environment", {
  x <- 1:1e4 + 0
  embedded <- (function() {
    g <- function() {
      x <- 1:1e3
      a ~ b
    }
    object_size(g())
  })()

  expect_true(embedded < object_size(x))

})

test_that("support dots in closure environments", {
  fn <- (function(...) function() NULL)(foo)
  expect_error(object_size(fn), NA)
})



================================================
FILE: tests/testthat/test-track-copy.R
================================================
context("track_copy")

test_that("deletes are not copies", {
  a <- 1:5
  tracker <- track_copy(a, quiet = TRUE)

  expect_false(tracker())
  rm(a)
  expect_false(tracker())
})

test_that("modifying type triggers copy", {
  a <- 1:5
  tracker <- track_copy(a, quiet = TRUE)

  expect_false(tracker())
  a[3] <- 2.5
  expect_true(tracker())
})

test_that("modifying element in vector does not trigger copy", {
  a <- c(1L, 2L, 5L, 4L, 3L)
  tracker <- track_copy(a, quiet = TRUE)

  expect_false(tracker())
  a[3] <- 3L
  expect_false(tracker())
})


================================================
FILE: tests/testthat.R
================================================
library("testthat")
library("pryr")

test_check("pryr")