[
  {
    "path": ".Rbuildignore",
    "content": "^.*\\.Rproj$\n^\\.Rproj\\.user$\nbenchmark\n^\\.travis\\.yml$\n^cran-comments\\.md$\n^NEWS\\.md$\n^revdep$\n^CRAN-RELEASE$\n^\\.github$\n^CRAN-SUBMISSION$\n"
  },
  {
    "path": ".github/.gitignore",
    "content": "*.html\n"
  },
  {
    "path": ".github/workflows/R-CMD-check.yaml",
    "content": "# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples\n# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help\non:\n  push:\n    branches: [main, master]\n  pull_request:\n    branches: [main, master]\n\nname: R-CMD-check\n\njobs:\n  R-CMD-check:\n    runs-on: ${{ matrix.config.os }}\n\n    name: ${{ matrix.config.os }} (${{ matrix.config.r }})\n\n    strategy:\n      fail-fast: false\n      matrix:\n        config:\n          - {os: macos-latest,   r: 'release'}\n          - {os: windows-latest, r: 'release'}\n          - {os: ubuntu-latest,   r: 'devel', http-user-agent: 'release'}\n          - {os: ubuntu-latest,   r: 'release'}\n          - {os: ubuntu-latest,   r: 'oldrel-1'}\n\n    env:\n      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}\n      R_KEEP_PKG_SOURCE: yes\n\n    steps:\n      - uses: actions/checkout@v3\n\n      - uses: r-lib/actions/setup-pandoc@v2\n\n      - uses: r-lib/actions/setup-r@v2\n        with:\n          r-version: ${{ matrix.config.r }}\n          http-user-agent: ${{ matrix.config.http-user-agent }}\n          use-public-rspm: true\n\n      - uses: r-lib/actions/setup-r-dependencies@v2\n        with:\n          extra-packages: any::rcmdcheck\n          needs: check\n\n      - uses: r-lib/actions/check-r-package@v2\n        with:\n          upload-snapshots: true\n"
  },
  {
    "path": ".gitignore",
    "content": ".Rproj.user\n.Rhistory\n.RData\nsrc/*.o\nsrc/*.so\nsrc/*.dll\n"
  },
  {
    "path": ".travis.yml",
    "content": "# R for travis: see documentation at https://docs.travis-ci.com/user/languages/r\n\nlanguage: r\nsudo: false\ncache: packages\n\nmatrix:\n  include:\n    - r: 3.1\n    - r: oldrel\n    - r: release\n      env: R_CODECOV=true\n    - r: devel\n\nafter_success:\n  - if [[ \"${R_CODECOV}\" ]]; then R -e 'covr::codecov()'; fi\n"
  },
  {
    "path": "DESCRIPTION",
    "content": "Package: pryr\nTitle: Tools for Computing on the Language\nVersion: 0.1.6.9000\nAuthors@R: c(\n    person(\"Hadley\", \"Wickham\", , \"hadley@rstudio.com\", role = c(\"aut\", \"cre\")),\n    person(\"R Core team\", role = \"ctb\",\n           comment = \"Some code extracted from base R\")\n  )\nDescription: Useful tools to pry back the covers of R and understand the\n    language at a deeper level.\nLicense: GPL-2\nURL: https://github.com/hadley/pryr\nBugReports: https://github.com/hadley/pryr/issues\nDepends:\n    R (>= 3.1.0)\nImports:\n    codetools,\n    lobstr,\n    methods,\n    Rcpp (>= 0.11.0),\n    stringr\nSuggests:\n    testthat (>= 0.8.0)\nLinkingTo: \n    Rcpp\nEncoding: UTF-8\nRoxygenNote: 7.2.3\n"
  },
  {
    "path": "NAMESPACE",
    "content": "# Generated by roxygen2: do not edit by hand\n\nS3method(\"[\",envlist)\nS3method(print,envlist)\nS3method(print,inspect)\nS3method(print,inspect_NILSXP)\nS3method(print,pryr_bytes)\nexport(\"%.%\")\nexport(\"%<a-%\")\nexport(\"%<c-%\")\nexport(\"%<d-%\")\nexport(address)\nexport(as.envlist)\nexport(ast)\nexport(bits)\nexport(bytes)\nexport(call_tree)\nexport(compare_size)\nexport(compose)\nexport(do_call)\nexport(dots)\nexport(enclosing_env)\nexport(eval2)\nexport(explicit)\nexport(f)\nexport(fget)\nexport(find_funs)\nexport(find_uses)\nexport(ftype)\nexport(fun_args)\nexport(fun_body)\nexport(fun_calls)\nexport(inspect)\nexport(is_active_binding)\nexport(is_promise)\nexport(is_s3_generic)\nexport(is_s3_method)\nexport(make_call)\nexport(make_function)\nexport(mem_change)\nexport(mem_used)\nexport(method_from_call)\nexport(modify_call)\nexport(modify_lang)\nexport(named_dots)\nexport(names_c)\nexport(object_size)\nexport(otype)\nexport(parent_promise)\nexport(parenv)\nexport(parenvs)\nexport(partial)\nexport(promise_info)\nexport(rebind)\nexport(refs)\nexport(rls)\nexport(sexp_type)\nexport(show_c_source)\nexport(standardise_call)\nexport(subs)\nexport(substitute_q)\nexport(track_copy)\nexport(typename)\nexport(unenclose)\nexport(uneval)\nexport(where)\nimportFrom(Rcpp,sourceCpp)\nimportFrom(codetools,findGlobals)\nimportFrom(methods,getGroupMembers)\nimportFrom(methods,is)\nimportFrom(stringr,str_c)\nimportFrom(stringr,str_dup)\nimportFrom(stringr,str_length)\nimportFrom(stringr,str_sub)\nuseDynLib(pryr)\n"
  },
  {
    "path": "NEWS.md",
    "content": "# pryr (development version)\n\n# pryr 0.1.6\n\n* Switch from `sprintf()` to `snprintf()`.\n\n# pryr 0.1.5\n\n* Compatibility with R devel.\n\n# pryr 0.1.4\n\n* Compatibility with R devel.\n\n# pryr 0.1.3\n\n* Compatibility with R devel.\n\n* `object_size()` now supports dots in closure environments.\n\n# pryr 0.1.2\n\n* `track_copy()` no longer reports deletes as copies (#34).\n\n* Added `is_active_binding()` (@richfitz, #33).\n\n* Fixed think-o in `stop_list()`.\n\n* Fixed a warning in `%<a-%` when reassigning an active binding\n  (@leeper, #39).\n\n\n# pryr 0.1.1\n\n* `address()` no longer changes `NAMED()` status of x (#24).\n\n* Use non-internal `nonS3Methods()` where needed (#38).\n\n* `explicit()` and `eval2()` are deprecated. Please use the lazyeval\n  package instead (#27)\n"
  },
  {
    "path": "R/RcppExports.R",
    "content": "# Generated by using Rcpp::compileAttributes() -> do not edit by hand\n# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393\n\nbinary_repr <- function(x) {\n    .Call('_pryr_binary_repr', PACKAGE = 'pryr', x)\n}\n\nhex_repr <- function(x) {\n    .Call('_pryr_hex_repr', PACKAGE = 'pryr', x)\n}\n\nbinary2hex <- function(x) {\n    .Call('_pryr_binary2hex', PACKAGE = 'pryr', x)\n}\n\ninspect_ <- function(x, base_env) {\n    .Call('_pryr_inspect_', PACKAGE = 'pryr', x, base_env)\n}\n\naddress2 <- function(name, env) {\n    .Call('_pryr_address2', PACKAGE = 'pryr', name, env)\n}\n\nnamed2 <- function(name, env) {\n    .Call('_pryr_named2', PACKAGE = 'pryr', name, env)\n}\n\nis_promise2 <- function(name, env) {\n    .Call('_pryr_is_promise2', PACKAGE = 'pryr', name, env)\n}\n\npromise_code <- function(name, env) {\n    .Call('_pryr_promise_code', PACKAGE = 'pryr', name, env)\n}\n\npromise_value <- function(name, env) {\n    .Call('_pryr_promise_value', PACKAGE = 'pryr', name, env)\n}\n\npromise_evaled <- function(name, env) {\n    .Call('_pryr_promise_evaled', PACKAGE = 'pryr', name, env)\n}\n\npromise_env <- function(name, env) {\n    .Call('_pryr_promise_env', PACKAGE = 'pryr', name, env)\n}\n\nmakeExplicit <- function(prom) {\n    .Call('_pryr_makeExplicit', PACKAGE = 'pryr', prom)\n}\n\nexplicitPromise <- function(name, env) {\n    .Call('_pryr_explicitPromise', PACKAGE = 'pryr', name, env)\n}\n\nexplicitDots <- function(env) {\n    .Call('_pryr_explicitDots', PACKAGE = 'pryr', env)\n}\n\nslice <- function(x, k, sep = \" \") {\n    .Call('_pryr_slice', PACKAGE = 'pryr', x, k, sep)\n}\n\n#' @export\n#' @rdname inspect\nsexp_type <- function(x) {\n    .Call('_pryr_sexp_type', PACKAGE = 'pryr', x)\n}\n\ntypename2 <- function(name, env) {\n    .Call('_pryr_typename2', PACKAGE = 'pryr', name, env)\n}\n\n"
  },
  {
    "path": "R/active.r",
    "content": "#' Active binding info\n#' \n#' @param x unquoted object name\n#' @export\n#' @examples\n#' x <- 10\n#' is_active_binding(x)\n#' x %<a-% runif(1)\n#' is_active_binding(x)\n#' y <- x\n#' is_active_binding(y)\nis_active_binding <- function(x) {\n  bindingIsActive(substitute(x), parent.frame())\n}\n"
  },
  {
    "path": "R/assign-active.r",
    "content": "#' Create an active binding.\n#'\n#' Infix form of \\code{\\link{makeActiveBinding}} which creates an \\emph{active}\n#' binding between a name and an expression: every time the name is accessed\n#' the expression is recomputed.\n#'\n#' @usage x \\%<a-\\% value\n#' @param x unquoted expression naming variable to create\n#' @param value unquoted expression to evaluate every time \\code{name} is\n#'   accessed\n#' @export\n#' @rdname assign-active\n#' @examples\n#' x %<a-% runif(1)\n#' x\n#' x\n#' x %<a-% runif(10)\n#' x\n#' x\n#' rm(x)\n\"%<a-%\" <- function(x, value) {\n  x <- substitute(x)\n  value <- substitute(value)\n\n  if (!is.name(x)) stop(\"Left-hand side must be a name\")\n\n  env <- parent.frame()\n  f <- make_function(alist(value = ), value, env)\n\n  # Mimic regular assignment operation which overrides existing bindings\n  if (exists(deparse(x), envir = env, inherits = FALSE)) {\n    rm(list = deparse(x), envir = env)\n  }\n\n  makeActiveBinding(deparse(x), f, env)\n}\n"
  },
  {
    "path": "R/assign-constant.r",
    "content": "#' Create a constant (locked) binding.\n#'\n#' Infix wrapper for \\code{\\link{assign}} + \\code{\\link{lockBinding}} that\n#' creates a constant: a binding whose value can not be changed.\n#'\n#' @usage x \\%<c-\\% value\n#' @param x unquoted expression naming variable to create\n#' @param value constant value\n#' @export\n#' @rdname assign-constant\n#' @examples\n#' x %<c-% 10\n#' #' Generates an error:\n#' \\dontrun{x <- 20}\n#'\n#' # Note that because of R's operator precedence rules, you\n#' # need to wrap compound RHS expressions in ()\n#' y %<c-% 1 + 2\n#' y\n#' z %<c-% (1 + 2)\n#' z\n\"%<c-%\" <- function(x, value) {\n  name <- substitute(x)\n  if (!is.name(name)) stop(\"Left-hand side must be a name\")\n\n  env <- parent.frame()\n  assign(as.character(name), value, env)\n  lockBinding(name, env)\n\n  invisible(value)\n}\n"
  },
  {
    "path": "R/assign-delayed.r",
    "content": "#' Create an delayed binding.\n#'\n#' Infix form of \\code{\\link{delayedAssign}} which creates an \\emph{delayed}\n#' or lazy binding, which only evaluates the expression the first time it is\n#' used.\n#'\n#' @usage x \\%<d-\\% value\n#' @param x unquoted expression naming variable to create\n#' @param value unquoted expression to evaluate the first time \\code{name} is\n#'   accessed\n#' @export\n#' @rdname assign-delayed\n#' @examples\n#' x %<d-% (a + b)\n#' a <- 10\n#' b <- 100\n#' x\n\"%<d-%\" <- function(x, value) {\n  name <- substitute(x)\n  value <- substitute(value)\n\n  if (!is.name(name)) stop(\"Left-hand side must be a name\")\n\n  env <- parent.frame()\n  call <- substitute(delayedAssign(deparse(name), value,\n    eval.env = env, assign.env = env), list(value = value))\n  eval(call)\n\n  invisible()\n}\n"
  },
  {
    "path": "R/bytes.r",
    "content": "#' Print the byte-wise representation of a value\n#'\n#' @param x An \\R vector of type \\code{integer}, \\code{numeric}, \\code{logical}\n#'   or \\code{character}.\n#' @param split Whether we should split the output string at each byte.\n#' @export\n#' @examples\n#' ## Encoding doesn't change the internal bytes used to represent characters;\n#' ## it just changes how they are interpretted!\n#'\n#' x <- y <- z <- \"\\u9b3c\"\n#' Encoding(y) <- \"bytes\"\n#' Encoding(z) <- \"latin1\"\n#' print(x); print(y); print(z)\n#' bytes(x); bytes(y); bytes(z)\n#' bits(x); bits(y); bits(z)\n#'\n#' ## In R, integers are signed ints. The first bit indicates the sign, but\n#' ## values are stored in a two's complement representation. We see that\n#' ## NA_integer_ is really just the smallest negative integer that can be\n#' ## stored in 4 bytes\n#' bits(NA_integer_)\n#'\n#' ## There are multiple kinds of NAs, NaNs for real numbers\n#' ## (at least, on 64bit architectures)\n#' print( c(NA_real_, NA_real_ + 1) )\n#' rbind( bytes(NA_real_), bytes(NA_real_ + 1) )\n#' rbind( bytes(NaN), bytes(0/0) )\n#' @references\n#' \\url{https://en.wikipedia.org/wiki/Two's_complement} for more\n#' information on the representation used for \\code{int}s.\n#'\n#' \\url{https://en.wikipedia.org/wiki/IEEE_floating_point} for more\n#' information the floating-point representation used for \\code{double}s.\n#'\n#' \\url{https://en.wikipedia.org/wiki/Character_encoding} for an introduction\n#' to character encoding, and \\code{?\\link{Encoding}} for more information on\n#' how \\R handles character encoding.\nbytes <- function(x, split = TRUE) {\n  repr <- hex_repr(x)\n  if (split) slice(repr, 2L)\n  else repr\n}\n\n#' @rdname bytes\n#' @export\nbits <- function(x, split = TRUE) {\n  repr <- binary_repr(x)\n  if (split) slice(repr, 8L)\n  else repr\n}\n"
  },
  {
    "path": "R/compose.r",
    "content": "#' Compose multiple functions\n#'\n#' In infix and prefix forms.\n#'\n#' @param ... n functions to apply in order from right to left\n#' @param f,g two functions to compose for the infix form\n#'\n#' @export\n#' @examples\n#' not_null <- `!` %.% is.null\n#' not_null(4)\n#' not_null(NULL)\n#' \n#' add1 <- function(x) x + 1\n#' compose(add1,add1)(8)\ncompose <- function(...) {\n  fs <- lapply(list(...), match.fun)\n  n <- length(fs)\n\n  last <- fs[[n]]\n  rest <- fs[-n]\n\n  function(...) {\n    out <- last(...)\n    for (f in rev(rest)) {\n      out <- f(out)\n    }\n    out\n  }\n}\n\n#' @rdname compose\n#' @export\n#' @usage f \\%.\\% g\n'%.%' <- function(f, g) {\n  f <- match.fun(f)\n  g <- match.fun(g)\n  function(...) {\n    f(g(...))\n  }\n}\n"
  },
  {
    "path": "R/dots.r",
    "content": "#' Capture unevaluated dots.\n#'\n#' @param ... \\code{...} passed in to the parent function\n#' @return a list of expressions (not expression objects). \\code{named_dots}\n#'  will use the deparsed expressions as default names.\n#' @export\n#' @examples\n#' y <- 2\n#' str(dots(x = 1, y, z = ))\n#' str(named_dots(x = 1, y, z =))\ndots <- function(...) {\n  eval(substitute(alist(...)))\n}\n\n#' @rdname dots\n#' @export\nnamed_dots <- function(...) {\n  args <- dots(...)\n\n  nms <- names(args) %||% rep(\"\", length(args))\n  missing <- nms == \"\"\n  if (all(!missing)) return(args)\n\n  deparse2 <- function(x) paste(deparse(x, 500L), collapse = \"\")\n  defaults <- vapply(args[missing], deparse2, character(1), USE.NAMES = FALSE)\n\n  names(args)[missing] <- defaults\n  args\n}\n"
  },
  {
    "path": "R/draw-tree.r",
    "content": "#' Display a call (or expression) as a tree.\n#'\n#' \\code{call_tree} takes a quoted expression. \\code{ast} does the quoting\n#' for you.\n#'\n#' @param x quoted call, list of calls, or expression to display\n#' @param width displays width, defaults to current width as reported by\n#'   \\code{getOption(\"width\")}\n#' @export\n#' @examples\n#' call_tree(quote(f(x, 1, g(), h(i()))))\n#' call_tree(quote(if (TRUE) 3 else 4))\n#' call_tree(expression(1, 2, 3))\n#'\n#' ast(f(x, 1, g(), h(i())))\n#' ast(if (TRUE) 3 else 4)\n#' ast(function(a = 1, b = 2) {a + b})\n#' ast(f()()())\n#' @importFrom stringr str_c\ncall_tree <- function(x, width = getOption(\"width\")) {\n  if (is.expression(x) || is.list(x)) {\n    trees <- vapply(x, tree, character(1), width = width)\n    out <- str_c(trees, collapse = \"\\n\\n\")\n  } else {\n    out <- tree(x, width = width)\n  }\n\n  cat(out, \"\\n\")\n}\n\n#' @rdname call_tree\n#' @export\nast <- function(x) call_tree(substitute(x))\n\n#' @importFrom stringr str_c str_length str_sub\nstr_trunc <- function(x, width = getOption(\"width\")) {\n  ifelse(str_length(x) <= width, x, str_c(str_sub(x, 1, width - 3), \"...\"))\n}\n\n#' @importFrom stringr str_c str_dup\ntree <- function(x, level = 1, width = getOption(\"width\"), branch = \"\\\\- \") {\n  indent <- str_c(str_dup(\"  \", level - 1), branch)\n\n  if (is.atomic(x) && length(x) == 1) {\n    label <- paste0(\" \", deparse(x)[1])\n    children <- NULL\n  } else if (is.name(x)) {\n    x <- as.character(x)\n    if (x == \"\") {\n      # Special case the missing argument\n      label <- \"`MISSING\"\n    } else {\n      label <- paste0(\"`\", as.character(x))\n    }\n\n    children <- NULL\n  } else if (is.call(x)) {\n    label <- \"()\"\n    children <-  vapply(as.list(x), tree, character(1),\n      level = level + 1, width = width - 3)\n  } else if (is.pairlist(x)) {\n    label <- \"[]\"\n\n    branches <- paste(\"\\\\\", format(names(x)), \"=\")\n    children <- character(length(x))\n    for (i in seq_along(x)) {\n      children[i] <- tree(x[[i]], level = level + 1, width = width - 3,\n        branch = branches[i])\n    }\n  } else {\n    # Special case for srcrefs, since they're commonly seen\n    if (inherits(x, \"srcref\")) {\n      label <- \"<srcref>\"\n    } else {\n      label <- paste0(\"<\", typeof(x), \">\")\n    }\n    children <- NULL\n  }\n\n  label <- str_trunc(label, width - 3)\n\n  if (is.null(children)) {\n    paste0(indent, label)\n  } else {\n    paste0(indent, label, \"\\n\", paste0(children, collapse = \"\\n\"))\n  }\n}\n"
  },
  {
    "path": "R/enclosing.R",
    "content": "#' Find the environment that encloses of a function.\n#'\n#' This is a wrapper around \\code{\\link{environment}} with a\n#' consistent syntax.\n#'\n#' @param f The name of a function.\n#' @export\n#' @examples\n#' enclosing_env(\"plot\")\n#' enclosing_env(\"t.test\")\nenclosing_env <- function(f) {\n  f <- match.fun(f)\n  environment(f)\n}\n"
  },
  {
    "path": "R/explicit-promise.R",
    "content": "#' Tools for making promises explicit\n#'\n#' Deprecated: please use the lazyeval package instead.\n#'\n#' @param x expression to make explicit, or to evaluate.\n#' @export\nexplicit <- function(x) {\n  .Deprecated(\"Please use the lazyeval package instead\")\n\n  explicitPromise(substitute(x), parent.frame())\n}\n\n#' @rdname explicit\n#' @export\n#' @param data Data in which to evaluate code\n#' @param env Enclosing environment to use if data is a list or data frame.\neval2 <- function(x, data = NULL, env = parent.frame()) {\n  .Deprecated(\"Please use the lazyeval package instead\")\n  if (is.formula(x)) {\n    env <- environment(x)\n    x <- x[[2]] # RHS of the formula\n  }\n\n  if (is.atomic(x)) return(x)\n  stopifnot(is.call(x) || is.name(x))\n\n  if (!is.null(data)) {\n    eval(x, data, env)\n  } else {\n    eval(x, env)\n  }\n}\n\nis.formula <- function(x) inherits(x, \"formula\")\n"
  },
  {
    "path": "R/f.r",
    "content": "#' A compact syntax for anonymous functions.\n#'\n#' @param ... The last argument is the body of the function, all others are\n#'   arguments to the function.  If there is only one argument, the formals\n#'   are guessed from the code.\n#' @param .env parent environment of the created function\n#' @return a function\n#' @export\n#' @importFrom codetools findGlobals\n#' @examples\n#' f(x + y)\n#' f(x + y)(1, 10)\n#' f(x, y = 2, x + y)\n#'\n#' f({y <- runif(1); x + y})\nf <- function(..., .env = parent.frame()) {\n  dots <- match.call(expand.dots = FALSE)$`...`\n  n <- length(dots)\n\n  if (n == 1) {\n    fun <- make_function(alist(... = ), dots[[1]], .env)\n\n    names <- findGlobals(fun, merge = FALSE)$variables\n    args <- stats::setNames(rep(list(substitute()), length(names)), names)\n    formals(fun) <- args\n\n    fun\n  } else {\n    body <- dots[[n]]\n    args <- dots[-n]\n\n    # translate unnamed args into named empty symbols\n    bare <- (names(args) %||% rep(\"\", length(args))) == \"\"\n    bare_names <- vapply(args[bare], as.character, character(1))\n    bare_names[bare_names == \".dots\"] <- \"...\"\n\n    args[bare] <- rep(list(substitute()), sum(bare))\n    names(args)[bare] <- bare_names\n\n    make_function(args, body, .env)\n  }\n}\n"
  },
  {
    "path": "R/fget.r",
    "content": "#' Find a function with specified name.\n#'\n#' @param name length one character vector giving name\n#' @param env environment to start search in.\n#' @export\n#' @examples\n#' c <- 10\n#' fget(\"c\")\nfget <- function(name, env = parent.frame()) {\n  env <- to_env(env)\n  if (identical(env, emptyenv())) {\n    stop(\"Could not find function called \", name, call. = FALSE)\n  }\n\n  if (exists(name, env, inherits = FALSE) && is.function(env[[name]])) {\n    env[[name]]\n  } else {\n    fget(name, parent.env(env))\n  }\n}\n"
  },
  {
    "path": "R/find-funs.r",
    "content": "#' Find functions matching criteria.\n#'\n#' This is a flexible function that matches function component against\n#' a regular expression, returning the name of the function if there are any\n#' matches. \\code{fun_args} and \\code{fun_calls} are helper functions that\n#' make it possible to search for functions with specified argument names, or\n#' which call certain functions.\n#'\n#' @param env environment in which to search for functions\n#' @param extract component of function to extract. Should be a function that\n#'   takes a function as input as returns a character vector as output,\n#'   like \\code{fun_calls} or \\code{fun_args}.\n#' @param pattern \\pkg{stringr} regular expression to results of \\code{extract}\n#'   function.\n#' @param ... other arguments passed on to \\code{\\link{grepl}}\n#' @export\n#' @examples\n#' find_funs(\"package:base\", fun_calls, \"match.fun\", fixed = TRUE)\n#' find_funs(\"package:stats\", fun_args, \"^[A-Z]+$\")\n#'\n#' fun_calls(match.call)\n#' fun_calls(write.csv)\n#'\n#' fun_body(write.csv)\n#' find_funs(\"package:utils\", fun_body, \"write\", fixed = TRUE)\nfind_funs <- function(env = parent.frame(), extract, pattern, ...) {\n  env <- to_env(env)\n  if (length(pattern) > 1) pattern <- str_c(pattern, collapse = \"|\")\n\n  test <- function(x) {\n    f <- get(x, env)\n    if (!is.function(f)) return(FALSE)\n\n    any(grepl(pattern, extract(f) ,...))\n  }\n\n  fs <- ls(env)\n  Filter(test, fs)\n}\n\n#' @export\n#' @rdname find_funs\n#' @param f function to extract information from\nfun_calls <- function(f) {\n  if (is.function(f)) {\n    fun_calls(body(f))\n  } else if (is.call(f)) {\n    fname <- as.character(f[[1]])\n\n    # Calls inside .Internal are special and shouldn't be included\n    if (identical(fname, \".Internal\")) return(fname)\n\n    unique(c(fname, unlist(lapply(f[-1], fun_calls), use.names = FALSE)))\n  }\n}\n\n#' @export\n#' @rdname find_funs\nfun_args <- function(f) {\n  stopifnot(is.function(f))\n  names(formals(f))\n}\n\n#' @export\n#' @rdname find_funs\nfun_body <- function(f) deparse(body(f))\n"
  },
  {
    "path": "R/find_uses.R",
    "content": "#' Find all functions in that call supplied functions.\n#'\n#' @param envs Vector of environments to look in. Can be specified by\n#'   name, position or as environment\n#' @param funs Functions to look for\n#' @param match_any If \\code{TRUE} return functions that use any of \\code{funs}.\n#'   If \\code{FALSE}, return functions that use all of \\code{funs}.\n#' @export\n#' @examples\n#' names(find_uses(\"package:base\", \"sum\"))\n#'\n#' envs <- c(\"package:base\", \"package:utils\", \"package:stats\")\n#' funs <- c(\"match.call\", \"sys.call\")\n#' find_uses(envs, funs)\nfind_uses <- function(envs, funs, match_any = TRUE) {\n  envs <- lapply(envs, to_env, quiet = TRUE)\n\n  by_env <- lapply(envs, function(env) {\n    names <- ls(envir = env)\n    names(names) <- names\n    compact(lapply(names, function(x) matched_calls(get(x, envir = env), funs,\n      match_any = match_any)))\n  })\n\n  unlist(by_env, recursive = FALSE)\n}\n\nmatched_calls <- function(fun, calls, match_any = TRUE) {\n  if (!is.function(fun) || is.primitive(fun)) return()\n\n  called <- fun_calls(fun)\n  matches <- calls %in% called\n  match <- if (match_any) any(matches) else all(matches)\n\n  if (!match) return()\n  called[matches]\n}\n"
  },
  {
    "path": "R/ftype.r",
    "content": "#' Determine function type.\n#' \n#' This function figures out whether the input function is a \n#' regular/primitive/internal function, a internal/S3/S4 generic, or a \n#' S3/S4/RC method. This is function is slightly simplified as it's possible\n#' for a method from one class to be a generic for another class, but that\n#' seems like such a bad idea that hopefully no one has done it.\n#' \n#' @param f unquoted function name\n#' @return a character of vector of length 1 or 2.\n#' @family object inspection\n#' @importFrom methods is\n#' @export\n#' @examples\n#' ftype(`%in%`)\n#' ftype(sum)\n#' ftype(t.data.frame)\n#' ftype(t.test) # Tricky!\n#' ftype(writeLines)\n#' ftype(unlist)\nftype <- function(f) { \n  fexpr <- substitute(f)\n  env <- parent.frame()\n  fname <- if (is.name(fexpr)) as.character(fexpr) else NULL\n  \n  if (is.primitive(f)) {\n    c(\"primitive\", if (is_internal_generic(primitive_name(f))) \"generic\")\n  } else if (is_internal(f)) {\n    c(\"internal\", if (is_internal_generic(internal_name(f))) \"generic\")\n  } else if (is(f, \"standardGeneric\")) {\n    c(\"s4\", \"generic\")\n  } else if (is(f, \"MethodDefinition\")) {\n    c(\"s4\", \"method\")\n  } else if (is(f, \"refMethodDef\")) {\n    c(\"rc\", \"method\")\n  } else if (!is.null(fname) && is_s3_generic(fname, env)) {\n    c(\"s3\", \"generic\")\n  } else if (!is.null(fname) && is_s3_method(fname, env)) {\n    c(\"s3\", \"method\")\n  } else {\n    c(\"function\")\n  }  \n}\n\n# Hacky method to get name of primitive function\nprimitive_name <- function(f) {\n  stopifnot(is.primitive(f))\n\n  str <- deparse(f)\n  match <- regexec(\".Primitive\\\\([\\\"](.*?)[\\\"]\\\\)\", str)\n  regmatches(str, match)[[1]][2]\n}\n\nis_internal <- function(f) {\n  if (!is.function(f) || is.primitive(f)) return(FALSE)\n  calls <- findGlobals(f, merge = FALSE)$functions\n  any(calls %in% \".Internal\")\n}\n\n# fs <- stats::setNames(lapply(ls(\"package:base\"), get), ls(\"package:base\"))\n# internal <- Filter(is_internal, fs)\n# icall <- sapply(internal, internal_name)\n# icall[names(icall) != icall]\ninternal_name <- function(f) {\n  \n  internal_call <- function(x) {\n    if (is.name(x) || is.atomic(x)) return(NULL)\n    if (identical(x[[1]], quote(.Internal))) return(x)\n  \n    # Work backwards since likely to be near end last \n    # (and e.g. unlist has multiple .Internal calls)\n    for (i in rev(seq_along(x))) {\n      icall <- internal_call(x[[i]])\n      if (!is.null(icall)) return(icall)\n    }\n    NULL\n  }\n  call <- internal_call(body(f))\n  as.character(call[[2]][[1]])\n}\n"
  },
  {
    "path": "R/inspect.r",
    "content": "#' Inspect internal attributes of R objects.\n#'\n#' \\code{typename} determines the internal C typename, \\code{address}\n#' returns the memory location of the object, and \\code{refs} returns the\n#' number of references pointing to the underlying object.\n#'\n#' @section Non-standard evaluation:\n#' All functions uses non-standard evaluation to capture the symbol you are\n#' referring to and the environment in which it lives. This means that you can\n#' not call any of these functions on objects created in the function call.\n#' All the underlying C level functions use \\code{Rf_findVar} to get to the\n#' underlying SEXP.\n#'\n#' @param x name of object to inspect. This can not be a value.\n#' @param env When inspecting environments, don't go past this one.\n#' @family object inspection\n#' @examples\n#' x <- 1:10\n#' \\dontrun{.Internal(inspect(x))}\n#'\n#' typename(x)\n#' refs(x)\n#' address(x)\n#'\n#' y <- 1L\n#' typename(y)\n#' z <- list(1:10)\n#' typename(z)\n#' delayedAssign(\"a\", 1 + 2)\n#' typename(a)\n#' a\n#' typename(a)\n#'\n#' x <- 1:5\n#' address(x)\n#' x[1] <- 3L\n#' address(x)\n#' @name inspect\nNULL\n\n#' @export\n#' @rdname inspect\ninspect <- function(x, env = parent.frame()) {\n  inspect_(x, env)\n}\n\n#' @export\nprint.inspect <- function(x, level = 0, ...) {\n  indent <- paste(rep(\"  \", length = level), collapse = \"\")\n\n  if (!x$seen) {\n    cat(indent, \"<\", x$type, \" \", x$address, \">\\n\", sep = \"\")\n  } else {\n    cat(indent, \"[\", x$type, \" \", x$address, \"]\\n\", sep = \"\")\n  }\n  if (length(x$children) > 0) {\n    nms <- names(x$children) %||% rep(\"\", length(x$children))\n    Map(function(nm, val) {\n      if (nm != \"\") cat(indent, nm, \": \\n\", sep = \"\")\n      print(val, level = level + 1)\n    }, nms, x$children)\n  }\n}\n\n#' @export\nprint.inspect_NILSXP <- function(x, level = 0, ...) {\n  indent <- paste(rep(\"  \", length = level), collapse = \"\")\n  cat(indent, \"NULL\\n\", sep = \"\")\n}\n\n#' @export\n#' @rdname inspect\nrefs <- function(x) {\n  named2(check_name(substitute(x)), parent.frame())\n}\n\n#' @export\n#' @rdname inspect\naddress <- function(x) {\n  address2(check_name(substitute(x)), parent.frame())\n}\n\n\n#' @export\n#' @rdname inspect\ntypename <- function(x) {\n  typename2(check_name(substitute(x)), parent.frame())\n}\n\ncheck_name <- function(x) {\n  if (!is.name(x)) {\n    stop(\"x must be the name of an object\", call. = FALSE)\n  }\n  x\n}\n\n#' Track if an object is copied\n#'\n#' The title is somewhat misleading: rather than checking if an object is\n#' modified, this really checks to see if a name points to the same object.\n#'\n#' @param var variable name (unquoted)\n#' @param env environment name in which to track changes\n#' @param quiet if \\code{FALSE}, prints a message on change; if \\code{FALSE}\n#'   only the return value of the function is used\n#' @return a zero-arg function, that when called returns a boolean indicating\n#'   if the object has changed since the last time this function was called\n#' @export\n#' @examples\n#' a <- 1:5\n#' track_a <- track_copy(a)\n#' track_a()\n#' a[3] <- 3L\n#' track_a()\n#' a[3] <- 3\n#' track_a()\n#' rm(a)\n#' track_a()\ntrack_copy <- function(var, env = parent.frame(), quiet = FALSE) {\n  var <- substitute(var)\n  force(env)\n\n  old <- address2(var, env)\n  function() {\n    if (!exists(as.character(var), envir = env, inherits = FALSE))\n      return(invisible(FALSE))\n\n    new <- address2(var, env)\n    if (old == new) return(invisible(FALSE))\n\n    if (!quiet) message(var, \" copied\")\n    old <<- new\n    invisible(TRUE)\n  }\n}\n"
  },
  {
    "path": "R/make-call.R",
    "content": "#' Make and evaluate calls.\n#'\n#' @param f Function to call. For \\code{make_call}, either a string, a symbol\n#'   or a quoted call. For \\code{do_call}, a bare function name or call.\n#' @param ...,.args Arguments to the call either in or out of a list\n#' @param .env Environment in which to evaluate call. Defaults to parent frame.\n#' @export\n#' @examples\n#' # f can either be a string, a symbol or a call\n#' make_call(\"f\", a = 1)\n#' make_call(quote(f), a = 1)\n#' make_call(quote(f()), a = 1)\n#'\n#' #' Can supply arguments individual or in a list\n#' make_call(quote(f), a = 1, b = 2)\n#' make_call(quote(f), list(a = 1, b = 2))\nmake_call <- function(f, ..., .args = list()) {\n  if (is.character(f)) f <- as.name(f)\n  as.call(c(f, ..., .args))\n}\n\n#' @rdname make_call\n#' @export\ndo_call <- function(f, ..., .args = list(), .env = parent.frame()) {\n  f <- substitute(f)\n\n  call <- make_call(f, ..., .args)\n  eval(call, .env)\n}\n"
  },
  {
    "path": "R/make-function.r",
    "content": "#' Make a function from its components.\n#'\n#' This constructs a new function given it's three components:\n#' list of arguments, body code and parent environment.\n#'\n#' @param args A named list of default arguments.  Note that if you want\n#'  arguments that don't have defaults, you'll need to use the special function\n#'  \\code{\\link{alist}}, e.g. \\code{alist(a = , b = 1)}\n#' @param body A language object representing the code inside the function.\n#'   Usually this will be most easily generated with \\code{\\link{quote}}\n#' @param env The parent environment of the function, defaults to the calling\n#'  environment of \\code{make_function}\n#' @export\n#' @examples\n#' f <- function(x) x + 3\n#' g <- make_function(alist(x = ), quote(x + 3))\n#'\n#' # The components of the functions are identical\n#' identical(formals(f), formals(g))\n#' identical(body(f), body(g))\n#' identical(environment(f), environment(g))\n#'\n#' # But the functions are not identical because f has src code reference\n#' identical(f, g)\n#'\n#' attr(f, \"srcref\") <- NULL\n#' # Now they are:\n#' stopifnot(identical(f, g))\nmake_function <- function(args, body, env = parent.frame()) {\n  args <- as.pairlist(args)\n  stopifnot(\n    all_named(args),\n    is.language(body))\n  env <- to_env(env)\n\n  eval(call(\"function\", args, body), env)\n}\n"
  },
  {
    "path": "R/mem.R",
    "content": "#' How much memory is currently used by R?\n#'\n#' R breaks down memory usage into Vcells (memory used by vectors) and\n#' Ncells (memory used by everything else). However, neither this distinction\n#' nor the \"gc trigger\" and \"max used\" columns are typically important. What\n#' we're usually most interested in is the the first column: the total memory\n#' used. This function wraps around \\code{gc()} to return the total amount of\n#' memory (in megabytes) currently used by R.\n#'\n#' @export\n#' @return Megabytes of ram used by R objects.\n#' @examples\n#' mem_used()\nmem_used <- function() {\n  show_bytes(sum(gc()[, 1] * c(node_size(), 8)))\n}\n\nnode_size <- function() {\n  bit <- 8L * .Machine$sizeof.pointer\n  if (!(bit == 32L || bit == 64L)) {\n    stop(\"Unknown architecture\", call. = FALSE)\n  }\n\n  if (bit == 32L) 28L else 56L\n}\n\n#' Determine change in memory from running code\n#'\n#' @param code Code to evaluate.\n#' @return Change in memory (in megabytes) before and after running code.\n#' @examples\n#' # Need about 4 mb to store 1 million integers\n#' mem_change(x <- 1:1e6)\n#' # We get that memory back when we delete it\n#' mem_change(rm(x))\n#' @export\nmem_change <- function(code) {\n  start <- mem_used()\n\n  expr <- substitute(code)\n  eval(expr, parent.frame())\n  rm(code, expr)\n\n  show_bytes(mem_used() - start)\n}\n\nshow_bytes <- function(x) {\n  structure(x, class = \"pryr_bytes\")\n}\n\n#' @export\nprint.pryr_bytes <- function(x, digits = 3, ...) {\n  power <- min(floor(log(abs(x), 1000)), 4)\n  if (power < 1) {\n    unit <- \"B\"\n  } else {\n    unit <- c(\"kB\", \"MB\", \"GB\", \"TB\")[[power]]\n    x <- x / (1000 ^ power)\n  }\n\n  formatted <- format(signif(x, digits = digits), big.mark = \",\",\n    scientific = FALSE)\n\n  cat(formatted, \" \", unit, \"\\n\", sep = \"\")\n}\n"
  },
  {
    "path": "R/method-from-call.r",
    "content": "#' Given a function class, find correspoding S4 method\n#' \n#' @param call unquoted function call\n#' @param env environment in which to look for function definition\n#' @export\n#' @examples\n#' library(stats4)\n#' \n#' # From example(mle)\n#' y <- c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8)\n#' nLL <- function(lambda) -sum(dpois(y, lambda, log = TRUE))\n#' fit <- mle(nLL, start = list(lambda = 5), nobs = length(y))\n#' \n#' method_from_call(summary(fit))\n#' method_from_call(coef(fit))\n#' method_from_call(length(fit))\nmethod_from_call <- function(call, env = parent.frame()) {\n  call <- standardise_call(substitute(call), env)\n  \n  generic <- as.character(call[[1]])\n  g_args <- setdiff(names(formals(methods::getGeneric(generic))), \"...\")\n  \n  args_uneval <- as.list(call[intersect(g_args, names(call))])\n  args <- lapply(args_uneval, eval, env = env)\n  classes <- lapply(args, class)\n  \n  # Add in any missing args\n  missing <- setdiff(g_args, names(classes))\n  if (length(missing) > 0) {\n    classes[missing] <- rep(\"missing\", length(missing))  \n  }\n  \n  methods::selectMethod(generic, classes)  \n}\n"
  },
  {
    "path": "R/modify-call.R",
    "content": "#' Modify the arguments of a call.\n#'\n#' @param call A call to modify. It is first standardised with\n#'   \\code{\\link{standardise_call}}.\n#' @param new_args A named list of expressions (constants, names or calls)\n#'   used to modify the call. Use \\code{NULL} to remove arguments.\n#' @export\n#' @examples\n#' call <- quote(mean(x, na.rm = TRUE))\n#'\n#' # Modify an existing argument\n#' modify_call(call, list(na.rm = FALSE))\n#' modify_call(call, list(x = quote(y)))\n#'\n#' # Remove an argument\n#' modify_call(call, list(na.rm = NULL))\n#'\n#' # Add a new argument\n#' modify_call(call, list(trim = 0.1))\n#'\n#' # Add an explicit missing argument\n#' modify_call(call, list(na.rm = quote(expr = )))\nmodify_call <- function(call, new_args) {\n  stopifnot(is.call(call), is.list(new_args))\n\n  call <- standardise_call(call)\n\n  nms <- names(new_args) %||% rep(\"\", length(new_args))\n  if (any(nms == \"\")) {\n    stop(\"All new arguments must be named\", call. = FALSE)\n  }\n\n  for(nm in nms) {\n    call[[nm]] <- new_args[[nm]]\n  }\n  call\n}\n"
  },
  {
    "path": "R/modify-lang.r",
    "content": "#' Recursively modify a language object\n#'\n#' @param x object to modify: should be a call, expression, function or\n#'   list of the above.\n#' @param f function to apply to leaves\n#' @param ... other arguments passed to \\code{f}\n#' @export\n#' @examples\n#' a_to_b <- function(x) {\n#'   if (is.name(x) && identical(x, quote(a))) return(quote(b))\n#'   x\n#' }\n#' examples <- list(\n#'   quote(a <- 5),\n#'   alist(a = 1, c = a),\n#'   function(a = 1) a * 10,\n#'   expression(a <- 1, a, f(a), f(a = a))\n#' )\n#' modify_lang(examples, a_to_b)\n#' # Modifies all objects called a, but doesn't modify arguments named a\nmodify_lang <- function(x, f, ...) {\n  recurse <- function(y) {\n    # if (!is.null(names(y))) names(y) <- f2(names(y))\n    lapply(y, modify_lang, f = f, ...)\n  }\n\n  if (is.atomic(x) || is.name(x)) {\n    # Leaf\n    f(x, ...)\n  } else if (is.call(x)) {\n    as.call(recurse(x))\n  } else if (is.function(x)) {\n    formals(x) <- modify_lang(formals(x), f, ...)\n    body(x) <- modify_lang(body(x), f, ...)\n    x\n  } else if (is.pairlist(x)) {\n    # Formal argument lists (when creating functions)\n    as.pairlist(recurse(x))\n  } else if (is.expression(x)) {\n    # shouldn't occur inside tree, but might be useful top-level\n    as.expression(recurse(x))\n  } else if (is.list(x)) {\n    # shouldn't occur inside tree, but might be useful top-level\n    recurse(x)\n  } else {\n    stop(\"Unknown language class: \", paste(class(x), collapse = \"/\"),\n      call. = FALSE)\n  }\n}\n\n"
  },
  {
    "path": "R/names_c.R",
    "content": "#' Find C source code for internal R functions\n#'\n#' Opens a link to code search on github.\n#'\n#' @param fun .Internal or .Primitive function call.\n#' @export\n#' @examples\n#' \\donttest{\n#' show_c_source(.Internal(mean(x)))\n#' show_c_source(.Primitive(sum(x)))\n#' }\nshow_c_source  <- function(fun) {\n  fun <- substitute(fun)\n  stopifnot(is.call(fun))\n\n  name <- as.character(fun[[1]])\n  if (!(name %in% c(\".Internal\", \".Primitive\"))) {\n    stop(\"Only know how to look up .Internal and .Primitive calls\",\n      call. = FALSE)\n  }\n\n  internal_name <- as.character(fun[[2]][[1]])\n\n  names <- names_c()\n  found <- names[names$name == internal_name, , drop = FALSE]\n\n  if (nrow(found) != 1) {\n    stop(\"Could not find entry for \", internal_name, call. = FALSE)\n  }\n\n  message(internal_name, \" is implemented by \", found$cfun,\n    \" with op = \", found$offset)\n\n  query <- sprintf(\"SEXP attribute_hidden %s+repo:wch/r-source&type=Code\",\n    found$cfun)\n  url <- paste0(\"https://github.com/search?q=\", utils::URLencode(query))\n\n  if (interactive()) {\n    utils::browseURL(url)\n  } else {\n    message(\"Please visit \", url)\n  }\n}\n\n#' Extract function table from names.c from R subversion repository.\n#'\n#' Since this is an expensive operation, it is done once and cached within\n#' a session.\n#'\n#' @return A data frame with columns\n#' \\item{name}{the function name in R}\n#' \\item{c-entry}{The name of the corresponding C function, actually declared\n#'   in ../include/Internal.h. All start with \"do_\", return SEXP, and\n#'   have argument list (SEXP call, SEXP op, SEXP args, SEXP env)}\n#' \\item{offset}{the 'op' (offset pointer) above; used for C functions\n#' \t which deal with more than one R function}\n#' \\item{eval}{XYZ (three digits) \\cr\n#'  \\cr\n#'  X=0 says that we should force R_Visible on \\cr\n#'  X=1 says that we should force R_Visible off \\cr\n#'  X=2 says that we should switch R_Visible on but let the C code update it. \\cr\n#'  \\cr\n#'  Y=1 says that this is an internal function which must\n#'      be accessed with a\t.Internal(.) call, any other value is\n#'      accessible directly and printed in R as \".Primitive(..)\".\\cr\n#'  \\cr\n#'  Z=0 says don't evaluate (SPECIALSXP).\\cr\n#'  Z=1 says evaluate arguments before calling (BUILTINSXP)}\n#' \\item{arity}{How many arguments are required/allowed;  \"-1\"\tmeaning ``any''}\n#' \\item{pp-kind}{Deparsing Info (-> PPkind in ../include/Defn.h )}\n#' \\item{precedence}{Operator precedence (-> PPprec in ../include/Defn.h )}\n#' \\item{rightassoc}{Right or left associative operator}\n#' @keywords internal\n#' @export\nnames_c <- function() {\n  if (exists(\"names_c\", envir = cache)) return(cache$names_c)\n  lines <- readLines(\"http://svn.r-project.org/R/trunk/src/main/names.c\")\n\n  # Find lines starting with {\"\n  fun_table <- lines[grepl(\"^[{][\\\"]\", lines)]\n  # Strip out {}, trailing comma and comments\n  fun_table <- gsub(\"[{}]\", \"\", fun_table)\n  fun_table <- gsub(\",$\", \"\", fun_table)\n  fun_table <- gsub(\"/[*].*[*]/\", \"\", fun_table)\n\n  table <- utils::read.csv(text = fun_table, strip = TRUE, header = FALSE,\n    stringsAsFactors = FALSE)\n  names(table) <- c(\"name\", \"cfun\", \"offset\", \"eval\", \"arity\", \"pp_kind\",\n    \"precedence\", \"rightassoc\")\n\n  table$eval <- sprintf(\"%03d\", table$eval)\n  table$rightassoc <- table$rightassoc == 1\n\n  # Cache result\n  cache$names_c <- table\n  table\n}\n\ncache <- new.env(parent = emptyenv())\n"
  },
  {
    "path": "R/object_size.R",
    "content": "#' Compute the size of an object.\n#'\n#' \\code{object_size} works similarly to \\code{\\link{object.size}}, but counts\n#' more accurately and includes the size of environments. \\code{compare_size}\n#' makes it easy to compare the output of \\code{object_size} and\n#' \\code{object.size}.\n#'\n#' @section Environments:\n#'\n#' \\code{object_size} attempts to take into account the size of the\n#' environments associated with an object. This is particularly important\n#' for closures and formulas, since otherwise you may not realise that you've\n#' accidentally captured a large object. However, it's easy to over count:\n#' you don't want to include the size of every object in every environment\n#' leading back to the \\code{\\link{emptyenv}()}. \\code{object_size} takes\n#' a heuristic approach: it never counts the size of the global env,\n#' the base env, the empty env or any namespace.\n#'\n#' Additionally, the \\code{env} argument allows you to specify another\n#' environment at which to stop. This defaults to the environment from which\n#' \\code{object_size} is called to prevent double-counting of objects created\n#' elsewhere.\n#'\n#' @export\n#' @examples\n#' # object.size doesn't keep track of shared elements in an object\n#' # object_size does\n#' x <- 1:1e4\n#' z <- list(x, x, x)\n#' compare_size(z)\n#'\n#' # this means that object_size is not transitive\n#' object_size(x)\n#' object_size(z)\n#' object_size(x, z)\n#'\n#' # object.size doesn't include the size of environments, which makes\n#' # it easy to miss objects that are carrying around large environments\n#' f <- function() {\n#'   x <- 1:1e4\n#'   a ~ b\n#' }\n#' compare_size(f())\n#' @param x,... Set of objects to compute total size.\n#' @param env Environment in which to terminate search. This defaults to the\n#'   current environment so that you don't include the size of objects that\n#'   are already stored elsewhere.\n#' @return An estimate of the size of the object, in bytes.\nobject_size <- function(..., env = parent.frame()) {\n  lobstr::obj_size(..., env = env)\n}\n\n#' @export\n#' @rdname object_size\ncompare_size <- function(x) {\n  c(base = utils::object.size(x), pryr = object_size(x))\n}\n"
  },
  {
    "path": "R/otype.r",
    "content": "#' Determine object type.\n#'\n#' @details\n#' Figure out which object system an object belongs to:\n#'\n#' \\itemize{\n#'   \\item base: no class attribute\n#'   \\item S3: class attribute, but not S4\n#'   \\item S4: \\code{\\link{isS4}}, but not RC\n#'   \\item RC: inherits from \"refClass\"\n#' }\n#'\n#' @param x object to determine type of\n#' @export\n#' @family object inspection\n#' @examples\n#' otype(data.frame())\n#' otype(1:10)\notype <- function(x) {\n  if (!is.object(x)) {\n    \"base\"\n  } else if (!isS4(x)) {\n    \"S3\"\n  } else if (!is(x, \"refClass\")) {\n    \"S4\"\n  } else {\n    \"RC\"\n  }\n}\n"
  },
  {
    "path": "R/parenv.r",
    "content": "#' Given an environment or object, return an \\code{envlist} of its\n#' parent environments.\n#'\n#' If \\code{e} is not specified, it will start with environment from which\n#' the function was called.\n#'\n#' @param e An environment or other object.\n#' @param all If \\code{FALSE} (the default), stop at the global\n#'   environment or the empty environment. If \\code{TRUE}, print all\n#'   parents, stopping only at the empty environment (which is the\n#'   top-level environment).\n#' @examples\n#' # Print the current environment and its parents\n#' parenvs()\n#'\n#' # Print the parent environments of the load_all function\n#' e <- parenvs(parenvs)\n#' e\n#'\n#' # Get all parent environments, going all the way to empty env\n#' e <- parenvs(parenvs, TRUE)\n#' e\n#'\n#' # Print e with paths\n#' print(e, path = TRUE)\n#'\n#' # Print the first 6 environments in the envlist\n#' e[1:6]\n#'\n#' # Print just the parent environment of load_all.\n#' # This is an envlist with one element.\n#' e[1]\n#'\n#' # Pull that environment out of the envlist and see what's in it.\n#' e[[1]]\n#' ls(e[[1]], all.names = TRUE)\n#' @export\nparenvs <- function(e = parent.frame(), all = FALSE) {\n  if (!is.environment(e))  e <- environment(e)\n  if (is.null(e))  return(NULL)\n\n  envs <- list(e)\n  while (TRUE) {\n    if (identical(e, emptyenv())) break\n    if (!all && identical(e, globalenv()))  break\n\n    e <- parent.env(e)\n    envs <- c(envs, e)\n  }\n  as.envlist(envs)\n}\n\n#' Convert a list of environments to an \\code{envlist} object.\n#'\n#' @param x A list of environments.\n#' @keywords internal\n#' @export\nas.envlist <- function(x) {\n  if (!is.list(x) || !all(vapply(x, is.environment, logical(1)))) {\n    stop(\"Cannot convert to envlist: input is not a list of environments.\")\n  }\n  structure(x, class = \"envlist\")\n}\n\n#' @export\n`[.envlist` <- function(x, i) {\n  as.envlist(.subset(x, i))\n}\n\n#' Print an \\code{envlist}\n#'\n#' @param x An \\code{envlist} object to print.\n#' @param name If \\code{TRUE} (the default), print the \\code{name}\n#'   attribute of each environment.\n#' @param path If \\code{TRUE}, print the \\code{path} attribute of\n#'   each environment.\n#' @param ... Other arguments to be passed to \\code{print}.\n#' @keywords internal\n#' @export\n#' @method print envlist\nprint.envlist <- function(x, name = TRUE, path = FALSE, ...) {\n\n  labels <- vapply(x, format, FUN.VALUE = character(1))\n  dat <- data.frame(label = labels, stringsAsFactors = FALSE)\n\n  if (name) {\n    names <- vapply(x, FUN.VALUE = character(1),\n      function(e) paste('\"', attr(e, \"name\"), '\"', sep = \"\"))\n    dat <- cbind(dat, name = names, stringsAsFactors = FALSE)\n  }\n\n  if (path) {\n    paths <- vapply(x, FUN.VALUE = character(1),\n      function(e) paste('\"', attr(e, \"path\"), '\"', sep = \"\"))\n    dat <- cbind(dat, path = paths, stringsAsFactors = FALSE)\n  }\n\n  print(dat, ..., right = FALSE)\n\n  invisible(x)\n}\n\n\n#' Get parent/ancestor environment\n#'\n#' @param env an environment\n#' @param n number of parents to go up\n#' @export\n#' @examples\n#' adder <- function(x) function(y) x + y\n#' add2 <- adder(2)\n#' parenv(add2)\nparenv <- function(env = parent.frame(), n = 1) {\n  env <- to_env(env)\n  for(i in seq_len(n)) env <- parent.env(env)\n  env\n}\n"
  },
  {
    "path": "R/partial.r",
    "content": "#' Partial apply a function, filling in some arguments.\n#'\n#' Partial function application allows you to modify a function by pre-filling\n#' some of the arguments.  It is particularly useful in conjunction with\n#' functionals and other function operators.\n#'\n#' @section Design choices:\n#'\n#' There are many ways to implement partial function application in R.\n#' (see e.g. \\code{dots} in \\url{https://github.com/crowding/vadr} for another\n#' approach.)  This implementation is based on creating functions that are as\n#' similar as possible to the anonymous function that'd you'd create by hand,\n#' if you weren't using \\code{partial}.\n#'\n#' @param _f a function. For the output source to read well, this should be an\n#'   be a named function.  This argument has the weird (non-syntactic) name\n#'   \\code{_f} so it doesn't accidentally capture any argument names begining\n#'   with f.\n#' @param ... named arguments to \\code{f} that should be partially applied.\n#' @param .env the environment of the created function. Defaults to\n#'   \\code{\\link{parent.frame}} and you should rarely need to modify this.\n#' @param .lazy If \\code{TRUE} arguments evaluated lazily, if \\code{FALSE},\n#'   evaluated when \\code{partial} is called.\n#' @export\n#' @examples\n#' # Partial is designed to replace the use of anonymous functions for\n#' # filling in function arguments. Instead of:\n#' compact1 <- function(x) Filter(Negate(is.null), x)\n#'\n#' # we can write:\n#' compact2 <- partial(Filter, Negate(is.null))\n#'\n#' # and the generated source code is very similar to what we made by hand\n#' compact1\n#' compact2\n#'\n#' # Note that the evaluation occurs \"lazily\" so that arguments will be\n#' # repeatedly evaluated\n#' f <- partial(runif, n = rpois(1, 5))\n#' f\n#' f()\n#' f()\n#'\n#' # You can override this by saying .lazy = FALSE\n#' f <- partial(runif, n = rpois(1, 5), .lazy = FALSE)\n#' f\n#' f()\n#' f()\n#'\n#' # This also means that partial works fine with functions that do\n#' # non-standard evaluation\n#' my_long_variable <- 1:10\n#' plot2 <- partial(plot, my_long_variable)\n#' plot2()\n#' plot2(runif(10), type = \"l\")\npartial <- function(`_f`, ..., .env = parent.frame(), .lazy = TRUE) {\n  stopifnot(is.function(`_f`))\n\n  if (.lazy) {\n    fcall <- substitute(`_f`(...))\n  } else {\n    fcall <- make_call(substitute(`_f`), .args = list(...))\n  }\n  # Pass on ... from parent function\n  fcall[[length(fcall) + 1]] <- quote(...)\n\n  args <- list(\"...\" = quote(expr = ))\n  make_function(args, fcall, .env)\n}\n\n# Alternative implementation that is much more complicated and doesn't work\n# as well because missing values in the inputs to the partially applied\n# function propagate and make it harder to work with.\npartial2 <- function(`_f`, ..., .env = parent.frame()) {\n\n  f_name <- substitute(`_f`)\n\n  # Capture unevalated arguments, and convert positions to names\n  dots <- match.call(expand.dots = FALSE)$`...`\n  f_call <- as.call(c(list(f_name), dots))\n  new_args <- as.list(match.call(`_f`, f_call))[-1]\n\n  # Arguments to partially applied function should be the same as the original\n  # function, less the arguments that have been filled in\n  if (is.primitive(`_f`)) {\n    # Don't know actual arguments, so fall back to ...\n    arg_names <- \"...\"\n  } else {\n    arg_names <- names(formals(`_f`))\n  }\n  arg_names <- setdiff(arg_names, names(new_args))\n  names(arg_names) <- arg_names\n\n  reciever_args <- lapply(arg_names, function(x) quote(expr = ))\n  caller_args <- c(lapply(arg_names, as.symbol), new_args)\n  body <- as.call(c(f_name, caller_args))\n\n  make_function(reciever_args, body, .env)\n}\n"
  },
  {
    "path": "R/promise.r",
    "content": "#' Promise info\n#' \n#' @useDynLib pryr\n#' @importFrom Rcpp sourceCpp\n#' @param x unquoted object name\n#' @family promise tools\n#' @export\n#' @examples\n#' x <- 10\n#' is_promise(x)\n#' (function(x) is_promise(x))(x = 10)\nis_promise <- function(x) {\n  is_promise2(substitute(x), parent.frame())\n}\n\n#' @rdname is_promise\n#' @export\npromise_info <- function(x) {\n  name <- substitute(x)\n  env <- parent.frame()\n\n  stopifnot(is_promise2(name, env))\n\n  evaled <- promise_evaled(name, env)\n  list(\n    code = promise_code(name, env),\n    env = promise_env(name, env),\n    evaled = evaled,\n    value = if (evaled) promise_value(name, env)\n  )\n}\n\n#' Find the parent (first) promise.\n#' \n#' @param x unquoted name of promise to find initial value for for.\n#' @export\n#' @examples\n#' f <- function(x) g(x)\n#' g <- function(y) h(y)\n#' h <- function(z) parent_promise(z)\n#' \n#' h(x + 1)\n#' g(x + 1)\n#' f(x + 1)\nparent_promise <- function(x) {\n  name <- quote(x)\n  \n  for (frame in rev(sys.frames())) {\n    if (!is_promise2(name, frame)) return(name)\n    \n    name <- promise_code(name, frame)\n    if (!is.name(name)) return(name)    \n  }\n  \n  name\n}\n"
  },
  {
    "path": "R/rebind.r",
    "content": "#' Rebind an existing name.\n#'\n#' This function is similar to \\code{\\link{<<-}} with two exceptions:\n#'\n#' \\itemize{\n#'  \\item if no existing binding is found, it throws an error\n#'  \\item it does not recurse past the global environment into the attached\n#'    packages\n#'}\n#'\n#' @param name name of existing binding to re-assign\n#' @param value new value\n#' @param env environment to start search in.\n#' @export\n#' @examples\n#' a <- 1\n#' rebind(\"a\", 2)\n#' a\n#' # Throws error if no existing binding\n#' \\dontrun{rebind(\"b\", 2)}\n#'\n#' local({\n#'   rebind(\"a\", 3)\n#' })\n#' a\n#'\n#' # Can't find get because doesn't look past globalenv\n#' \\dontrun{rebind(\"get\", 1)}\nrebind <- function(name, value, env = parent.frame()) {\n  env <- to_env(env)\n\n  if (exists(name, env, inherits = FALSE)) {\n    assign(name, value, env)\n  } else {\n    # Don't recurse past global or emptyenv\n    if (identical(env, globalenv()) || identical(env, emptyenv())) {\n      stop(\"Can't find \", name, call. = FALSE)\n    }\n\n    rebind(name, value, parent.env(env))\n  }\n}\n"
  },
  {
    "path": "R/rls.r",
    "content": "#' Recursive ls.\n#'\n#' Performs \\code{\\link{ls}} all the way up to a top-level environment (either\n#' the parent of the global environment, the empty environment or a namespace\n#' environment).\n#'\n#' @param env environment to start the search at. Defaults to the\n#'  \\code{\\link{parent.frame}}. If a function is supplied, uses the environment\n#'  associated with the function.\n#' @param all.names Show all names, even those starting with \\code{.}?\n#'   Defaults to \\code{TRUE}, the opposite of \\code{\\link{ls}}\n#' @export\n#' @author Winston Chang\nrls <- function(env = parent.frame(), all.names = TRUE) {\n  env <- to_env(env)\n  if (terminal_env(env)) return()\n\n  names <- ls(env, all.names = all.names)\n  c(list(names), rls(parent.env(env), all.names = all.names))\n}\n\nterminal_env <- function(e) {\n  identical(e, parent.env(globalenv())) || identical(e, emptyenv()) ||\n      exists('.__NAMESPACE__.', e, inherits = FALSE)\n}\n"
  },
  {
    "path": "R/s3.r",
    "content": "#' Determine if a function is an S3 generic or S3 method.\n#'\n#' @description\n#' \\code{is_s3_generic} compares name checks for both internal and regular\n#' generics.\n#'\n#' \\code{is_s3_method} builds names of all possible generics for that function\n#' and then checks if any of them actually is a generic.\n#'\n#' @param name name of function as a string. Need name of function because\n#'   it's impossible to determine whether or not a function is a S3 method\n#'   based only on its contents.\n#' @param env environment to search in.\n#' @keywords internal\n#' @export\n#' @examples\n#' is_s3_generic(\"mean\")\n#' is_s3_generic(\"sum\")\n#' is_s3_generic(\"[[\")\n#' is_s3_generic(\"unlist\")\n#' is_s3_generic(\"runif\")\n#'\n#' is_s3_method(\"t.data.frame\")\n#' is_s3_method(\"t.test\") # Just tricking!\n#' is_s3_method(\"as.data.frame\")\n#' is_s3_method(\"mean.Date\")\nis_s3_generic <- function(fname, env = parent.frame()) {\n  if (!exists(fname, env)) return(FALSE)\n\n  f <- get(fname, env, mode = \"function\")\n  if (!is.function(f)) return(FALSE)\n\n  if (is.primitive(f) || is_internal(f)) {\n    is_internal_generic(fname)\n  } else {\n    uses <- findGlobals(f, merge = FALSE)$functions\n    any(uses == \"UseMethod\")\n  }\n}\n\n#' @rdname is_s3_generic\n#' @export\nis_s3_method <- function(name, env = parent.frame()) {\n  !is.null(find_generic(name, env))\n}\n\nstop_list <- function() {\n  if (getRversion() < \"3.3.0\") {\n    getNamespace(\"tools\")[[\".make_S3_methods_stop_list\"]](NULL)\n  } else {\n    tools::nonS3methods(NULL)\n  }\n}\n\nfind_generic <- function(name, env = parent.frame()) {\n  if (name %in% stop_list()) return(NULL)\n\n  pieces <- strsplit(name, \".\", fixed = TRUE)[[1]]\n  n <- length(pieces)\n\n  # No . in name, so can't be method\n  if (n == 1) return(NULL)\n\n  for(i in seq_len(n - 1)) {\n    generic <- paste0(pieces[seq_len(i)], collapse = \".\")\n    class <- paste0(pieces[(i + 1):n], collapse = \".\")\n    if (is_s3_generic(generic, env)) return(c(generic, class))\n  }\n  NULL\n}\n\nis_internal_generic <- function(x) {\n  x %in% internal_generics()\n}\n\n#' @importFrom methods getGroupMembers\ninternal_generics <- function() {\n  # Functions in S4 group generics should be the same\n  group <- c(getGroupMembers(\"Arith\"), getGroupMembers(\"Compare\"),\n    getGroupMembers(\"Logic\"), getGroupMembers(\"Math\"), getGroupMembers(\"Math2\"),\n    getGroupMembers(\"Summary\"), getGroupMembers(\"Complex\"))\n\n  primitive <- .S3PrimitiveGenerics\n\n  # Extracted from ?\"internal generic\"\n  internal <- c(\"[\", \"[[\", \"$\", \"[<-\", \"[[<-\", \"$<-\", \"unlist\",\n    \"cbind\", \"rbind\", \"as.vector\")\n\n  c(group, primitive, internal)\n}\n"
  },
  {
    "path": "R/standardise-call.r",
    "content": "#' Standardise a function call\n#'\n#' @param call A call\n#' @param env Environment in which to look up call value.\n#' @export\nstandardise_call <- function(call, env = parent.frame()) {\n  stopifnot(is.call(call))\n  f <- eval(call[[1]], env)\n  if (is.primitive(f)) return(call)\n\n  match.call(f, call)\n}\n"
  },
  {
    "path": "R/substitute.r",
    "content": "#' A version of substitute that evaluates its first argument.\n#'\n#' This version of substitute is needed because \\code{substitute} does not\n#' evaluate it's first argument, and it's often useful to be able to modify\n#' a quoted call.\n#'\n#' @param x a quoted call\n#' @param env an environment, or something that behaves like an environment\n#'   (like a list or data frame), or a reference to an environment (like a\n#'   positive integer or name, see \\code{\\link{as.environment}} for more\n#'   details)\n#' @export\n#' @examples\n#' x <- quote(a + b)\n#' substitute(x, list(a = 1, b = 2))\n#' substitute_q(x, list(a = 1, b = 2))\nsubstitute_q <- function(x, env) {\n  stopifnot(is.language(x))\n  env <- to_env(env)\n\n  call <- substitute(substitute(x, env), list(x = x))\n  eval(call)\n}\n\n#' A version of substitute that works in the global environment.\n#'\n#' This version of \\code{\\link{substitute}} is more suited for interactive\n#' exploration because it will perform substitution in the global environment:\n#' the regular version has a special case for the global environment where it\n#' effectively works like \\code{\\link{quote}}\n#'\n#' @section Substitution rules:\n#'\n#' Formally, substitution takes place by examining each name in the expression.\n#' If the name refers to:\n#'\n#' \\itemize{\n#'\n#'  \\item an ordinary variable, it's replaced by the value of the variable.\n#'\n#'  \\item a promise, it's replaced by the expression associated with the\n#'     promise.\n#'\n#'  \\item \\code{...}, it's replaced by the contents of \\code{...}\n#' }\n#' @inheritParams substitute_q\n#' @export\n#' @examples\n#' a <- 1\n#' b <- 2\n#'\n#' substitute(a + b)\n#' subs(a + b)\nsubs <- function(x, env = parent.frame()) {\n  if (identical(env, globalenv())) {\n    env <- as.list(env)\n  }\n\n  substitute_q(substitute(x), env)\n}\n"
  },
  {
    "path": "R/unenclose.r",
    "content": "#' Unenclose a closure.\n#'\n#' Unenclose a closure by substituting names for values found in the enclosing\n#' environment.\n#'\n#' @param f a closure\n#' @export\n#' @examples\n#' power <- function(exp) {\n#'   function(x) x ^ exp\n#' }\n#' square <- power(2)\n#' cube <- power(3)\n#'\n#' square\n#' cube\n#' unenclose(square)\n#' unenclose(cube)\nunenclose <- function(f) {\n  stopifnot(is.function(f))\n\n  env <- environment(f)\n  make_function(formals(f), substitute_q(body(f), env), parent.env(env))\n}\n"
  },
  {
    "path": "R/uneval.r",
    "content": "#' Capture the call associated with a promise.\n#'\n#' This is an alternative to subsitute that performs one job, and so gives\n#' a stronger signal regarding the intention of your code.  It returns an error\n#' if the name is not associated with a promise.\n#'\n#' @export\n#' @family promise tools\n#' @param x unquoted variable name that refers to a promise. An error will be\n#'   thrown if it's not a promise.\n#' @examples\n#' f <- function(x) {\n#'    uneval(x)\n#' }\n#' f(a + b)\n#' f(1 + 4)\n#' \n#' delayedAssign(\"x\", 1 + 4)\n#' uneval(x)\n#' x\n#' uneval(x)\nuneval <- function(x) {\n  name <- substitute(x)\n  stopifnot(is.name(name))\n\n  env <- parent.frame()\n\n  if (!is_promise2(name, env)) {\n    stop(name, \"is not a promise\", call. = FALSE)\n  }\n\n  promise_code(name, env)\n}\n"
  },
  {
    "path": "R/utils.r",
    "content": "all_named <- function(x) {\n  if (length(x) == 0) return(TRUE)\n  !is.null(names(x)) && all(names(x) != \"\")\n}\n\n\"%||%\" <- function(x, y) if (is.null(x)) y else x\n\ncompact <- function(x) Filter(Negate(is.null), x)\n\nto_env <- function(x, quiet = FALSE) {\n  if (is.environment(x)) {\n    x\n  } else if (is.list(x)) {\n    list2env(x)\n  } else if (is.function(x)) {\n    environment(x)\n  } else if (length(x) == 1 && is.character(x)) {\n    if (!quiet) message(\"Using environment \", x)\n    as.environment(x)\n  } else if (length(x) == 1 && is.numeric(x) && x > 0) {\n    if (!quiet) message(\"Using environment \", search()[x])\n    as.environment(x)\n  } else {\n    stop(\"Input can not be coerced to an environment\", call. = FALSE)\n  }\n}\n"
  },
  {
    "path": "R/where.r",
    "content": "#' Find where a name is defined.\n#'\n#' Implements the regular scoping rules, but instead of returning the value\n#' associated with a name, it returns the environment in which it is located.\n#'\n#' @param name name, as string, to look for\n#' @param env environment to start at. Defaults to the calling environment\n#'   of this function.\n#' @export\n#' @examples\n#' x <- 1\n#' where(\"x\")\n#' where(\"t.test\")\n#' where(\"mean\")\n#' where(\"where\")\nwhere <- function(name, env = parent.frame()) {\n  stopifnot(is.character(name), length(name) == 1)\n  env <- to_env(env)\n\n  if (identical(env, emptyenv())) {\n    stop(\"Can't find \", name, call. = FALSE)\n  }\n\n  if (exists(name, env, inherits = FALSE)) {\n    env\n  } else {\n    where(name, parent.env(env))\n  }\n}\n"
  },
  {
    "path": "README.md",
    "content": "# pryr\n\n<!-- badges: start -->\n[![Lifecycle: superseded](https://img.shields.io/badge/lifecycle-superseded-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html#superseded)\n[![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)\n<!-- badges: end -->\n\npryr is superseded. Please use:\n\n* [rlang](https://rlang.r-lib.org/) for low-level R programming.\n* [lobstr](https://lobstr.r-lib.org/) for object sizes & comparison.\n* [sloop](https://sloop.r-lib.org/) for OOP tools.\n"
  },
  {
    "path": "benchmark/make-function.r",
    "content": "make_function1 <- function(args, body, env = parent.frame()) {\n  args <- as.pairlist(args)\n  eval(call(\"function\", args, body), env)\n}\nmake_function2 <- function(args, body, env = parent.frame()) {\n  f <- function() {}\n  formals(f) <- args\n  body(f) <- body\n  environment(f) <- env\n\n  f\n}\nmake_function3 <- function(args, body, env = parent.frame()) {\n  as.function(c(args, body), env)\n}\nmake_function4 <- function(args, body, env = parent.frame()) {\n  subs <- list(args = as.pairlist(args), body = body)\n  eval(substitute(`function`(args, body), subs), env)\n}\n\nargs <- alist(a = 1, b = 2)\nbody <- quote(a + b)\nmake_function1(args, body)\nmake_function2(args, body)\nmake_function3(args, body)\nmake_function4(args, body)\n\nlibrary(microbenchmark)\nmicrobenchmark(\n  make_function1(args, body),\n  make_function2(args, body),\n  make_function3(args, body),\n  make_function4(args, body),\n  function(a = 1, b = 2) a + b\n)\n"
  },
  {
    "path": "cran-comments.md",
    "content": "## R CMD check results\n\n0 errors | 0 warnings | 0 notes\n\n## revdepcheck results\n\nThis is a patch release for R CMD check compliance so I did not re-check revdeps.\n"
  },
  {
    "path": "man/as.envlist.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/parenv.r\n\\name{as.envlist}\n\\alias{as.envlist}\n\\title{Convert a list of environments to an \\code{envlist} object.}\n\\usage{\nas.envlist(x)\n}\n\\arguments{\n\\item{x}{A list of environments.}\n}\n\\description{\nConvert a list of environments to an \\code{envlist} object.\n}\n\\keyword{internal}\n"
  },
  {
    "path": "man/assign-active.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/assign-active.r\n\\name{\\%<a-\\%}\n\\alias{\\%<a-\\%}\n\\title{Create an active binding.}\n\\usage{\nx \\%<a-\\% value\n}\n\\arguments{\n\\item{x}{unquoted expression naming variable to create}\n\n\\item{value}{unquoted expression to evaluate every time \\code{name} is\naccessed}\n}\n\\description{\nInfix form of \\code{\\link{makeActiveBinding}} which creates an \\emph{active}\nbinding between a name and an expression: every time the name is accessed\nthe expression is recomputed.\n}\n\\examples{\nx \\%<a-\\% runif(1)\nx\nx\nx \\%<a-\\% runif(10)\nx\nx\nrm(x)\n}\n"
  },
  {
    "path": "man/assign-constant.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/assign-constant.r\n\\name{\\%<c-\\%}\n\\alias{\\%<c-\\%}\n\\title{Create a constant (locked) binding.}\n\\usage{\nx \\%<c-\\% value\n}\n\\arguments{\n\\item{x}{unquoted expression naming variable to create}\n\n\\item{value}{constant value}\n}\n\\description{\nInfix wrapper for \\code{\\link{assign}} + \\code{\\link{lockBinding}} that\ncreates a constant: a binding whose value can not be changed.\n}\n\\examples{\nx \\%<c-\\% 10\n#' Generates an error:\n\\dontrun{x <- 20}\n\n# Note that because of R's operator precedence rules, you\n# need to wrap compound RHS expressions in ()\ny \\%<c-\\% 1 + 2\ny\nz \\%<c-\\% (1 + 2)\nz\n}\n"
  },
  {
    "path": "man/assign-delayed.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/assign-delayed.r\n\\name{\\%<d-\\%}\n\\alias{\\%<d-\\%}\n\\title{Create an delayed binding.}\n\\usage{\nx \\%<d-\\% value\n}\n\\arguments{\n\\item{x}{unquoted expression naming variable to create}\n\n\\item{value}{unquoted expression to evaluate the first time \\code{name} is\naccessed}\n}\n\\description{\nInfix form of \\code{\\link{delayedAssign}} which creates an \\emph{delayed}\nor lazy binding, which only evaluates the expression the first time it is\nused.\n}\n\\examples{\nx \\%<d-\\% (a + b)\na <- 10\nb <- 100\nx\n}\n"
  },
  {
    "path": "man/bytes.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/bytes.r\n\\name{bytes}\n\\alias{bytes}\n\\alias{bits}\n\\title{Print the byte-wise representation of a value}\n\\usage{\nbytes(x, split = TRUE)\n\nbits(x, split = TRUE)\n}\n\\arguments{\n\\item{x}{An \\R vector of type \\code{integer}, \\code{numeric}, \\code{logical}\nor \\code{character}.}\n\n\\item{split}{Whether we should split the output string at each byte.}\n}\n\\description{\nPrint the byte-wise representation of a value\n}\n\\examples{\n## Encoding doesn't change the internal bytes used to represent characters;\n## it just changes how they are interpretted!\n\nx <- y <- z <- \"\\u9b3c\"\nEncoding(y) <- \"bytes\"\nEncoding(z) <- \"latin1\"\nprint(x); print(y); print(z)\nbytes(x); bytes(y); bytes(z)\nbits(x); bits(y); bits(z)\n\n## In R, integers are signed ints. The first bit indicates the sign, but\n## values are stored in a two's complement representation. We see that\n## NA_integer_ is really just the smallest negative integer that can be\n## stored in 4 bytes\nbits(NA_integer_)\n\n## There are multiple kinds of NAs, NaNs for real numbers\n## (at least, on 64bit architectures)\nprint( c(NA_real_, NA_real_ + 1) )\nrbind( bytes(NA_real_), bytes(NA_real_ + 1) )\nrbind( bytes(NaN), bytes(0/0) )\n}\n\\references{\n\\url{https://en.wikipedia.org/wiki/Two's_complement} for more\ninformation on the representation used for \\code{int}s.\n\n\\url{https://en.wikipedia.org/wiki/IEEE_floating_point} for more\ninformation the floating-point representation used for \\code{double}s.\n\n\\url{https://en.wikipedia.org/wiki/Character_encoding} for an introduction\nto character encoding, and \\code{?\\link{Encoding}} for more information on\nhow \\R handles character encoding.\n}\n"
  },
  {
    "path": "man/call_tree.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/draw-tree.r\n\\name{call_tree}\n\\alias{call_tree}\n\\alias{ast}\n\\title{Display a call (or expression) as a tree.}\n\\usage{\ncall_tree(x, width = getOption(\"width\"))\n\nast(x)\n}\n\\arguments{\n\\item{x}{quoted call, list of calls, or expression to display}\n\n\\item{width}{displays width, defaults to current width as reported by\n\\code{getOption(\"width\")}}\n}\n\\description{\n\\code{call_tree} takes a quoted expression. \\code{ast} does the quoting\nfor you.\n}\n\\examples{\ncall_tree(quote(f(x, 1, g(), h(i()))))\ncall_tree(quote(if (TRUE) 3 else 4))\ncall_tree(expression(1, 2, 3))\n\nast(f(x, 1, g(), h(i())))\nast(if (TRUE) 3 else 4)\nast(function(a = 1, b = 2) {a + b})\nast(f()()())\n}\n"
  },
  {
    "path": "man/compose.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/compose.r\n\\name{compose}\n\\alias{compose}\n\\alias{\\%.\\%}\n\\title{Compose multiple functions}\n\\usage{\ncompose(...)\n\nf \\%.\\% g\n}\n\\arguments{\n\\item{...}{n functions to apply in order from right to left}\n\n\\item{f, g}{two functions to compose for the infix form}\n}\n\\description{\nIn infix and prefix forms.\n}\n\\examples{\nnot_null <- `!` \\%.\\% is.null\nnot_null(4)\nnot_null(NULL)\n\nadd1 <- function(x) x + 1\ncompose(add1,add1)(8)\n}\n"
  },
  {
    "path": "man/dots.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/dots.r\n\\name{dots}\n\\alias{dots}\n\\alias{named_dots}\n\\title{Capture unevaluated dots.}\n\\usage{\ndots(...)\n\nnamed_dots(...)\n}\n\\arguments{\n\\item{...}{\\code{...} passed in to the parent function}\n}\n\\value{\na list of expressions (not expression objects). \\code{named_dots}\n will use the deparsed expressions as default names.\n}\n\\description{\nCapture unevaluated dots.\n}\n\\examples{\ny <- 2\nstr(dots(x = 1, y, z = ))\nstr(named_dots(x = 1, y, z =))\n}\n"
  },
  {
    "path": "man/enclosing_env.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/enclosing.R\n\\name{enclosing_env}\n\\alias{enclosing_env}\n\\title{Find the environment that encloses of a function.}\n\\usage{\nenclosing_env(f)\n}\n\\arguments{\n\\item{f}{The name of a function.}\n}\n\\description{\nThis is a wrapper around \\code{\\link{environment}} with a\nconsistent syntax.\n}\n\\examples{\nenclosing_env(\"plot\")\nenclosing_env(\"t.test\")\n}\n"
  },
  {
    "path": "man/explicit.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/explicit-promise.R\n\\name{explicit}\n\\alias{explicit}\n\\alias{eval2}\n\\title{Tools for making promises explicit}\n\\usage{\nexplicit(x)\n\neval2(x, data = NULL, env = parent.frame())\n}\n\\arguments{\n\\item{x}{expression to make explicit, or to evaluate.}\n\n\\item{data}{Data in which to evaluate code}\n\n\\item{env}{Enclosing environment to use if data is a list or data frame.}\n}\n\\description{\nDeprecated: please use the lazyeval package instead.\n}\n"
  },
  {
    "path": "man/f.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/f.r\n\\name{f}\n\\alias{f}\n\\title{A compact syntax for anonymous functions.}\n\\usage{\nf(..., .env = parent.frame())\n}\n\\arguments{\n\\item{...}{The last argument is the body of the function, all others are\narguments to the function.  If there is only one argument, the formals\nare guessed from the code.}\n\n\\item{.env}{parent environment of the created function}\n}\n\\value{\na function\n}\n\\description{\nA compact syntax for anonymous functions.\n}\n\\examples{\nf(x + y)\nf(x + y)(1, 10)\nf(x, y = 2, x + y)\n\nf({y <- runif(1); x + y})\n}\n"
  },
  {
    "path": "man/fget.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/fget.r\n\\name{fget}\n\\alias{fget}\n\\title{Find a function with specified name.}\n\\usage{\nfget(name, env = parent.frame())\n}\n\\arguments{\n\\item{name}{length one character vector giving name}\n\n\\item{env}{environment to start search in.}\n}\n\\description{\nFind a function with specified name.\n}\n\\examples{\nc <- 10\nfget(\"c\")\n}\n"
  },
  {
    "path": "man/find_funs.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/find-funs.r\n\\name{find_funs}\n\\alias{find_funs}\n\\alias{fun_calls}\n\\alias{fun_args}\n\\alias{fun_body}\n\\title{Find functions matching criteria.}\n\\usage{\nfind_funs(env = parent.frame(), extract, pattern, ...)\n\nfun_calls(f)\n\nfun_args(f)\n\nfun_body(f)\n}\n\\arguments{\n\\item{env}{environment in which to search for functions}\n\n\\item{extract}{component of function to extract. Should be a function that\ntakes a function as input as returns a character vector as output,\nlike \\code{fun_calls} or \\code{fun_args}.}\n\n\\item{pattern}{\\pkg{stringr} regular expression to results of \\code{extract}\nfunction.}\n\n\\item{...}{other arguments passed on to \\code{\\link{grepl}}}\n\n\\item{f}{function to extract information from}\n}\n\\description{\nThis is a flexible function that matches function component against\na regular expression, returning the name of the function if there are any\nmatches. \\code{fun_args} and \\code{fun_calls} are helper functions that\nmake it possible to search for functions with specified argument names, or\nwhich call certain functions.\n}\n\\examples{\nfind_funs(\"package:base\", fun_calls, \"match.fun\", fixed = TRUE)\nfind_funs(\"package:stats\", fun_args, \"^[A-Z]+$\")\n\nfun_calls(match.call)\nfun_calls(write.csv)\n\nfun_body(write.csv)\nfind_funs(\"package:utils\", fun_body, \"write\", fixed = TRUE)\n}\n"
  },
  {
    "path": "man/find_uses.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/find_uses.R\n\\name{find_uses}\n\\alias{find_uses}\n\\title{Find all functions in that call supplied functions.}\n\\usage{\nfind_uses(envs, funs, match_any = TRUE)\n}\n\\arguments{\n\\item{envs}{Vector of environments to look in. Can be specified by\nname, position or as environment}\n\n\\item{funs}{Functions to look for}\n\n\\item{match_any}{If \\code{TRUE} return functions that use any of \\code{funs}.\nIf \\code{FALSE}, return functions that use all of \\code{funs}.}\n}\n\\description{\nFind all functions in that call supplied functions.\n}\n\\examples{\nnames(find_uses(\"package:base\", \"sum\"))\n\nenvs <- c(\"package:base\", \"package:utils\", \"package:stats\")\nfuns <- c(\"match.call\", \"sys.call\")\nfind_uses(envs, funs)\n}\n"
  },
  {
    "path": "man/ftype.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/ftype.r\n\\name{ftype}\n\\alias{ftype}\n\\title{Determine function type.}\n\\usage{\nftype(f)\n}\n\\arguments{\n\\item{f}{unquoted function name}\n}\n\\value{\na character of vector of length 1 or 2.\n}\n\\description{\nThis function figures out whether the input function is a \nregular/primitive/internal function, a internal/S3/S4 generic, or a \nS3/S4/RC method. This is function is slightly simplified as it's possible\nfor a method from one class to be a generic for another class, but that\nseems like such a bad idea that hopefully no one has done it.\n}\n\\examples{\nftype(`\\%in\\%`)\nftype(sum)\nftype(t.data.frame)\nftype(t.test) # Tricky!\nftype(writeLines)\nftype(unlist)\n}\n\\seealso{\nOther object inspection: \n\\code{\\link{otype}()},\n\\code{\\link{sexp_type}()}\n}\n\\concept{object inspection}\n"
  },
  {
    "path": "man/inspect.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/RcppExports.R, R/inspect.r\n\\name{sexp_type}\n\\alias{sexp_type}\n\\alias{inspect}\n\\alias{refs}\n\\alias{address}\n\\alias{typename}\n\\title{Inspect internal attributes of R objects.}\n\\usage{\nsexp_type(x)\n\ninspect(x, env = parent.frame())\n\nrefs(x)\n\naddress(x)\n\ntypename(x)\n}\n\\arguments{\n\\item{x}{name of object to inspect. This can not be a value.}\n\n\\item{env}{When inspecting environments, don't go past this one.}\n}\n\\description{\n\\code{typename} determines the internal C typename, \\code{address}\nreturns the memory location of the object, and \\code{refs} returns the\nnumber of references pointing to the underlying object.\n}\n\\section{Non-standard evaluation}{\n\nAll functions uses non-standard evaluation to capture the symbol you are\nreferring to and the environment in which it lives. This means that you can\nnot call any of these functions on objects created in the function call.\nAll the underlying C level functions use \\code{Rf_findVar} to get to the\nunderlying SEXP.\n}\n\n\\examples{\nx <- 1:10\n\\dontrun{.Internal(inspect(x))}\n\ntypename(x)\nrefs(x)\naddress(x)\n\ny <- 1L\ntypename(y)\nz <- list(1:10)\ntypename(z)\ndelayedAssign(\"a\", 1 + 2)\ntypename(a)\na\ntypename(a)\n\nx <- 1:5\naddress(x)\nx[1] <- 3L\naddress(x)\n}\n\\seealso{\nOther object inspection: \n\\code{\\link{ftype}()},\n\\code{\\link{otype}()}\n}\n\\concept{object inspection}\n"
  },
  {
    "path": "man/is_active_binding.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/active.r\n\\name{is_active_binding}\n\\alias{is_active_binding}\n\\title{Active binding info}\n\\usage{\nis_active_binding(x)\n}\n\\arguments{\n\\item{x}{unquoted object name}\n}\n\\description{\nActive binding info\n}\n\\examples{\nx <- 10\nis_active_binding(x)\nx \\%<a-\\% runif(1)\nis_active_binding(x)\ny <- x\nis_active_binding(y)\n}\n"
  },
  {
    "path": "man/is_promise.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/promise.r\n\\name{is_promise}\n\\alias{is_promise}\n\\alias{promise_info}\n\\title{Promise info}\n\\usage{\nis_promise(x)\n\npromise_info(x)\n}\n\\arguments{\n\\item{x}{unquoted object name}\n}\n\\description{\nPromise info\n}\n\\examples{\nx <- 10\nis_promise(x)\n(function(x) is_promise(x))(x = 10)\n}\n\\seealso{\nOther promise tools: \n\\code{\\link{uneval}()}\n}\n\\concept{promise tools}\n"
  },
  {
    "path": "man/is_s3_generic.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/s3.r\n\\name{is_s3_generic}\n\\alias{is_s3_generic}\n\\alias{is_s3_method}\n\\title{Determine if a function is an S3 generic or S3 method.}\n\\usage{\nis_s3_generic(fname, env = parent.frame())\n\nis_s3_method(name, env = parent.frame())\n}\n\\arguments{\n\\item{env}{environment to search in.}\n\n\\item{name}{name of function as a string. Need name of function because\nit's impossible to determine whether or not a function is a S3 method\nbased only on its contents.}\n}\n\\description{\n\\code{is_s3_generic} compares name checks for both internal and regular\ngenerics.\n\n\\code{is_s3_method} builds names of all possible generics for that function\nand then checks if any of them actually is a generic.\n}\n\\examples{\nis_s3_generic(\"mean\")\nis_s3_generic(\"sum\")\nis_s3_generic(\"[[\")\nis_s3_generic(\"unlist\")\nis_s3_generic(\"runif\")\n\nis_s3_method(\"t.data.frame\")\nis_s3_method(\"t.test\") # Just tricking!\nis_s3_method(\"as.data.frame\")\nis_s3_method(\"mean.Date\")\n}\n\\keyword{internal}\n"
  },
  {
    "path": "man/make_call.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/make-call.R\n\\name{make_call}\n\\alias{make_call}\n\\alias{do_call}\n\\title{Make and evaluate calls.}\n\\usage{\nmake_call(f, ..., .args = list())\n\ndo_call(f, ..., .args = list(), .env = parent.frame())\n}\n\\arguments{\n\\item{f}{Function to call. For \\code{make_call}, either a string, a symbol\nor a quoted call. For \\code{do_call}, a bare function name or call.}\n\n\\item{..., .args}{Arguments to the call either in or out of a list}\n\n\\item{.env}{Environment in which to evaluate call. Defaults to parent frame.}\n}\n\\description{\nMake and evaluate calls.\n}\n\\examples{\n# f can either be a string, a symbol or a call\nmake_call(\"f\", a = 1)\nmake_call(quote(f), a = 1)\nmake_call(quote(f()), a = 1)\n\n#' Can supply arguments individual or in a list\nmake_call(quote(f), a = 1, b = 2)\nmake_call(quote(f), list(a = 1, b = 2))\n}\n"
  },
  {
    "path": "man/make_function.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/make-function.r\n\\name{make_function}\n\\alias{make_function}\n\\title{Make a function from its components.}\n\\usage{\nmake_function(args, body, env = parent.frame())\n}\n\\arguments{\n\\item{args}{A named list of default arguments.  Note that if you want\narguments that don't have defaults, you'll need to use the special function\n\\code{\\link{alist}}, e.g. \\code{alist(a = , b = 1)}}\n\n\\item{body}{A language object representing the code inside the function.\nUsually this will be most easily generated with \\code{\\link{quote}}}\n\n\\item{env}{The parent environment of the function, defaults to the calling\nenvironment of \\code{make_function}}\n}\n\\description{\nThis constructs a new function given it's three components:\nlist of arguments, body code and parent environment.\n}\n\\examples{\nf <- function(x) x + 3\ng <- make_function(alist(x = ), quote(x + 3))\n\n# The components of the functions are identical\nidentical(formals(f), formals(g))\nidentical(body(f), body(g))\nidentical(environment(f), environment(g))\n\n# But the functions are not identical because f has src code reference\nidentical(f, g)\n\nattr(f, \"srcref\") <- NULL\n# Now they are:\nstopifnot(identical(f, g))\n}\n"
  },
  {
    "path": "man/mem_change.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/mem.R\n\\name{mem_change}\n\\alias{mem_change}\n\\title{Determine change in memory from running code}\n\\usage{\nmem_change(code)\n}\n\\arguments{\n\\item{code}{Code to evaluate.}\n}\n\\value{\nChange in memory (in megabytes) before and after running code.\n}\n\\description{\nDetermine change in memory from running code\n}\n\\examples{\n# Need about 4 mb to store 1 million integers\nmem_change(x <- 1:1e6)\n# We get that memory back when we delete it\nmem_change(rm(x))\n}\n"
  },
  {
    "path": "man/mem_used.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/mem.R\n\\name{mem_used}\n\\alias{mem_used}\n\\title{How much memory is currently used by R?}\n\\usage{\nmem_used()\n}\n\\value{\nMegabytes of ram used by R objects.\n}\n\\description{\nR breaks down memory usage into Vcells (memory used by vectors) and\nNcells (memory used by everything else). However, neither this distinction\nnor the \"gc trigger\" and \"max used\" columns are typically important. What\nwe're usually most interested in is the the first column: the total memory\nused. This function wraps around \\code{gc()} to return the total amount of\nmemory (in megabytes) currently used by R.\n}\n\\examples{\nmem_used()\n}\n"
  },
  {
    "path": "man/method_from_call.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/method-from-call.r\n\\name{method_from_call}\n\\alias{method_from_call}\n\\title{Given a function class, find correspoding S4 method}\n\\usage{\nmethod_from_call(call, env = parent.frame())\n}\n\\arguments{\n\\item{call}{unquoted function call}\n\n\\item{env}{environment in which to look for function definition}\n}\n\\description{\nGiven a function class, find correspoding S4 method\n}\n\\examples{\nlibrary(stats4)\n\n# From example(mle)\ny <- c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8)\nnLL <- function(lambda) -sum(dpois(y, lambda, log = TRUE))\nfit <- mle(nLL, start = list(lambda = 5), nobs = length(y))\n\nmethod_from_call(summary(fit))\nmethod_from_call(coef(fit))\nmethod_from_call(length(fit))\n}\n"
  },
  {
    "path": "man/modify_call.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/modify-call.R\n\\name{modify_call}\n\\alias{modify_call}\n\\title{Modify the arguments of a call.}\n\\usage{\nmodify_call(call, new_args)\n}\n\\arguments{\n\\item{call}{A call to modify. It is first standardised with\n\\code{\\link{standardise_call}}.}\n\n\\item{new_args}{A named list of expressions (constants, names or calls)\nused to modify the call. Use \\code{NULL} to remove arguments.}\n}\n\\description{\nModify the arguments of a call.\n}\n\\examples{\ncall <- quote(mean(x, na.rm = TRUE))\n\n# Modify an existing argument\nmodify_call(call, list(na.rm = FALSE))\nmodify_call(call, list(x = quote(y)))\n\n# Remove an argument\nmodify_call(call, list(na.rm = NULL))\n\n# Add a new argument\nmodify_call(call, list(trim = 0.1))\n\n# Add an explicit missing argument\nmodify_call(call, list(na.rm = quote(expr = )))\n}\n"
  },
  {
    "path": "man/modify_lang.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/modify-lang.r\n\\name{modify_lang}\n\\alias{modify_lang}\n\\title{Recursively modify a language object}\n\\usage{\nmodify_lang(x, f, ...)\n}\n\\arguments{\n\\item{x}{object to modify: should be a call, expression, function or\nlist of the above.}\n\n\\item{f}{function to apply to leaves}\n\n\\item{...}{other arguments passed to \\code{f}}\n}\n\\description{\nRecursively modify a language object\n}\n\\examples{\na_to_b <- function(x) {\n  if (is.name(x) && identical(x, quote(a))) return(quote(b))\n  x\n}\nexamples <- list(\n  quote(a <- 5),\n  alist(a = 1, c = a),\n  function(a = 1) a * 10,\n  expression(a <- 1, a, f(a), f(a = a))\n)\nmodify_lang(examples, a_to_b)\n# Modifies all objects called a, but doesn't modify arguments named a\n}\n"
  },
  {
    "path": "man/names_c.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/names_c.R\n\\name{names_c}\n\\alias{names_c}\n\\title{Extract function table from names.c from R subversion repository.}\n\\usage{\nnames_c()\n}\n\\value{\nA data frame with columns\n\\item{name}{the function name in R}\n\\item{c-entry}{The name of the corresponding C function, actually declared\n  in ../include/Internal.h. All start with \"do_\", return SEXP, and\n  have argument list (SEXP call, SEXP op, SEXP args, SEXP env)}\n\\item{offset}{the 'op' (offset pointer) above; used for C functions\n\t which deal with more than one R function}\n\\item{eval}{XYZ (three digits) \\cr\n \\cr\n X=0 says that we should force R_Visible on \\cr\n X=1 says that we should force R_Visible off \\cr\n X=2 says that we should switch R_Visible on but let the C code update it. \\cr\n \\cr\n Y=1 says that this is an internal function which must\n     be accessed with a\t.Internal(.) call, any other value is\n     accessible directly and printed in R as \".Primitive(..)\".\\cr\n \\cr\n Z=0 says don't evaluate (SPECIALSXP).\\cr\n Z=1 says evaluate arguments before calling (BUILTINSXP)}\n\\item{arity}{How many arguments are required/allowed;  \"-1\"\tmeaning ``any''}\n\\item{pp-kind}{Deparsing Info (-> PPkind in ../include/Defn.h )}\n\\item{precedence}{Operator precedence (-> PPprec in ../include/Defn.h )}\n\\item{rightassoc}{Right or left associative operator}\n}\n\\description{\nSince this is an expensive operation, it is done once and cached within\na session.\n}\n\\keyword{internal}\n"
  },
  {
    "path": "man/object_size.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/object_size.R\n\\name{object_size}\n\\alias{object_size}\n\\alias{compare_size}\n\\title{Compute the size of an object.}\n\\usage{\nobject_size(..., env = parent.frame())\n\ncompare_size(x)\n}\n\\arguments{\n\\item{env}{Environment in which to terminate search. This defaults to the\ncurrent environment so that you don't include the size of objects that\nare already stored elsewhere.}\n\n\\item{x, ...}{Set of objects to compute total size.}\n}\n\\value{\nAn estimate of the size of the object, in bytes.\n}\n\\description{\n\\code{object_size} works similarly to \\code{\\link{object.size}}, but counts\nmore accurately and includes the size of environments. \\code{compare_size}\nmakes it easy to compare the output of \\code{object_size} and\n\\code{object.size}.\n}\n\\section{Environments}{\n\n\n\\code{object_size} attempts to take into account the size of the\nenvironments associated with an object. This is particularly important\nfor closures and formulas, since otherwise you may not realise that you've\naccidentally captured a large object. However, it's easy to over count:\nyou don't want to include the size of every object in every environment\nleading back to the \\code{\\link{emptyenv}()}. \\code{object_size} takes\na heuristic approach: it never counts the size of the global env,\nthe base env, the empty env or any namespace.\n\nAdditionally, the \\code{env} argument allows you to specify another\nenvironment at which to stop. This defaults to the environment from which\n\\code{object_size} is called to prevent double-counting of objects created\nelsewhere.\n}\n\n\\examples{\n# object.size doesn't keep track of shared elements in an object\n# object_size does\nx <- 1:1e4\nz <- list(x, x, x)\ncompare_size(z)\n\n# this means that object_size is not transitive\nobject_size(x)\nobject_size(z)\nobject_size(x, z)\n\n# object.size doesn't include the size of environments, which makes\n# it easy to miss objects that are carrying around large environments\nf <- function() {\n  x <- 1:1e4\n  a ~ b\n}\ncompare_size(f())\n}\n"
  },
  {
    "path": "man/otype.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/otype.r\n\\name{otype}\n\\alias{otype}\n\\title{Determine object type.}\n\\usage{\notype(x)\n}\n\\arguments{\n\\item{x}{object to determine type of}\n}\n\\description{\nDetermine object type.\n}\n\\details{\nFigure out which object system an object belongs to:\n\n\\itemize{\n  \\item base: no class attribute\n  \\item S3: class attribute, but not S4\n  \\item S4: \\code{\\link{isS4}}, but not RC\n  \\item RC: inherits from \"refClass\"\n}\n}\n\\examples{\notype(data.frame())\notype(1:10)\n}\n\\seealso{\nOther object inspection: \n\\code{\\link{ftype}()},\n\\code{\\link{sexp_type}()}\n}\n\\concept{object inspection}\n"
  },
  {
    "path": "man/parent_promise.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/promise.r\n\\name{parent_promise}\n\\alias{parent_promise}\n\\title{Find the parent (first) promise.}\n\\usage{\nparent_promise(x)\n}\n\\arguments{\n\\item{x}{unquoted name of promise to find initial value for for.}\n}\n\\description{\nFind the parent (first) promise.\n}\n\\examples{\nf <- function(x) g(x)\ng <- function(y) h(y)\nh <- function(z) parent_promise(z)\n\nh(x + 1)\ng(x + 1)\nf(x + 1)\n}\n"
  },
  {
    "path": "man/parenv.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/parenv.r\n\\name{parenv}\n\\alias{parenv}\n\\title{Get parent/ancestor environment}\n\\usage{\nparenv(env = parent.frame(), n = 1)\n}\n\\arguments{\n\\item{env}{an environment}\n\n\\item{n}{number of parents to go up}\n}\n\\description{\nGet parent/ancestor environment\n}\n\\examples{\nadder <- function(x) function(y) x + y\nadd2 <- adder(2)\nparenv(add2)\n}\n"
  },
  {
    "path": "man/parenvs.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/parenv.r\n\\name{parenvs}\n\\alias{parenvs}\n\\title{Given an environment or object, return an \\code{envlist} of its\nparent environments.}\n\\usage{\nparenvs(e = parent.frame(), all = FALSE)\n}\n\\arguments{\n\\item{e}{An environment or other object.}\n\n\\item{all}{If \\code{FALSE} (the default), stop at the global\nenvironment or the empty environment. If \\code{TRUE}, print all\nparents, stopping only at the empty environment (which is the\ntop-level environment).}\n}\n\\description{\nIf \\code{e} is not specified, it will start with environment from which\nthe function was called.\n}\n\\examples{\n# Print the current environment and its parents\nparenvs()\n\n# Print the parent environments of the load_all function\ne <- parenvs(parenvs)\ne\n\n# Get all parent environments, going all the way to empty env\ne <- parenvs(parenvs, TRUE)\ne\n\n# Print e with paths\nprint(e, path = TRUE)\n\n# Print the first 6 environments in the envlist\ne[1:6]\n\n# Print just the parent environment of load_all.\n# This is an envlist with one element.\ne[1]\n\n# Pull that environment out of the envlist and see what's in it.\ne[[1]]\nls(e[[1]], all.names = TRUE)\n}\n"
  },
  {
    "path": "man/partial.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/partial.r\n\\name{partial}\n\\alias{partial}\n\\title{Partial apply a function, filling in some arguments.}\n\\usage{\npartial(`_f`, ..., .env = parent.frame(), .lazy = TRUE)\n}\n\\arguments{\n\\item{_f}{a function. For the output source to read well, this should be an\nbe a named function.  This argument has the weird (non-syntactic) name\n\\code{_f} so it doesn't accidentally capture any argument names begining\nwith f.}\n\n\\item{...}{named arguments to \\code{f} that should be partially applied.}\n\n\\item{.env}{the environment of the created function. Defaults to\n\\code{\\link{parent.frame}} and you should rarely need to modify this.}\n\n\\item{.lazy}{If \\code{TRUE} arguments evaluated lazily, if \\code{FALSE},\nevaluated when \\code{partial} is called.}\n}\n\\description{\nPartial function application allows you to modify a function by pre-filling\nsome of the arguments.  It is particularly useful in conjunction with\nfunctionals and other function operators.\n}\n\\section{Design choices}{\n\n\nThere are many ways to implement partial function application in R.\n(see e.g. \\code{dots} in \\url{https://github.com/crowding/vadr} for another\napproach.)  This implementation is based on creating functions that are as\nsimilar as possible to the anonymous function that'd you'd create by hand,\nif you weren't using \\code{partial}.\n}\n\n\\examples{\n# Partial is designed to replace the use of anonymous functions for\n# filling in function arguments. Instead of:\ncompact1 <- function(x) Filter(Negate(is.null), x)\n\n# we can write:\ncompact2 <- partial(Filter, Negate(is.null))\n\n# and the generated source code is very similar to what we made by hand\ncompact1\ncompact2\n\n# Note that the evaluation occurs \"lazily\" so that arguments will be\n# repeatedly evaluated\nf <- partial(runif, n = rpois(1, 5))\nf\nf()\nf()\n\n# You can override this by saying .lazy = FALSE\nf <- partial(runif, n = rpois(1, 5), .lazy = FALSE)\nf\nf()\nf()\n\n# This also means that partial works fine with functions that do\n# non-standard evaluation\nmy_long_variable <- 1:10\nplot2 <- partial(plot, my_long_variable)\nplot2()\nplot2(runif(10), type = \"l\")\n}\n"
  },
  {
    "path": "man/print.envlist.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/parenv.r\n\\name{print.envlist}\n\\alias{print.envlist}\n\\title{Print an \\code{envlist}}\n\\usage{\n\\method{print}{envlist}(x, name = TRUE, path = FALSE, ...)\n}\n\\arguments{\n\\item{x}{An \\code{envlist} object to print.}\n\n\\item{name}{If \\code{TRUE} (the default), print the \\code{name}\nattribute of each environment.}\n\n\\item{path}{If \\code{TRUE}, print the \\code{path} attribute of\neach environment.}\n\n\\item{...}{Other arguments to be passed to \\code{print}.}\n}\n\\description{\nPrint an \\code{envlist}\n}\n\\keyword{internal}\n"
  },
  {
    "path": "man/rebind.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/rebind.r\n\\name{rebind}\n\\alias{rebind}\n\\title{Rebind an existing name.}\n\\usage{\nrebind(name, value, env = parent.frame())\n}\n\\arguments{\n\\item{name}{name of existing binding to re-assign}\n\n\\item{value}{new value}\n\n\\item{env}{environment to start search in.}\n}\n\\description{\nThis function is similar to \\code{\\link{<<-}} with two exceptions:\n}\n\\details{\n\\itemize{\n \\item if no existing binding is found, it throws an error\n \\item it does not recurse past the global environment into the attached\n   packages\n}\n}\n\\examples{\na <- 1\nrebind(\"a\", 2)\na\n# Throws error if no existing binding\n\\dontrun{rebind(\"b\", 2)}\n\nlocal({\n  rebind(\"a\", 3)\n})\na\n\n# Can't find get because doesn't look past globalenv\n\\dontrun{rebind(\"get\", 1)}\n}\n"
  },
  {
    "path": "man/rls.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/rls.r\n\\name{rls}\n\\alias{rls}\n\\title{Recursive ls.}\n\\usage{\nrls(env = parent.frame(), all.names = TRUE)\n}\n\\arguments{\n\\item{env}{environment to start the search at. Defaults to the\n\\code{\\link{parent.frame}}. If a function is supplied, uses the environment\nassociated with the function.}\n\n\\item{all.names}{Show all names, even those starting with \\code{.}?\nDefaults to \\code{TRUE}, the opposite of \\code{\\link{ls}}}\n}\n\\description{\nPerforms \\code{\\link{ls}} all the way up to a top-level environment (either\nthe parent of the global environment, the empty environment or a namespace\nenvironment).\n}\n\\author{\nWinston Chang\n}\n"
  },
  {
    "path": "man/show_c_source.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/names_c.R\n\\name{show_c_source}\n\\alias{show_c_source}\n\\title{Find C source code for internal R functions}\n\\usage{\nshow_c_source(fun)\n}\n\\arguments{\n\\item{fun}{.Internal or .Primitive function call.}\n}\n\\description{\nOpens a link to code search on github.\n}\n\\examples{\n\\donttest{\nshow_c_source(.Internal(mean(x)))\nshow_c_source(.Primitive(sum(x)))\n}\n}\n"
  },
  {
    "path": "man/standardise_call.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/standardise-call.r\n\\name{standardise_call}\n\\alias{standardise_call}\n\\title{Standardise a function call}\n\\usage{\nstandardise_call(call, env = parent.frame())\n}\n\\arguments{\n\\item{call}{A call}\n\n\\item{env}{Environment in which to look up call value.}\n}\n\\description{\nStandardise a function call\n}\n"
  },
  {
    "path": "man/subs.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/substitute.r\n\\name{subs}\n\\alias{subs}\n\\title{A version of substitute that works in the global environment.}\n\\usage{\nsubs(x, env = parent.frame())\n}\n\\arguments{\n\\item{x}{a quoted call}\n\n\\item{env}{an environment, or something that behaves like an environment\n(like a list or data frame), or a reference to an environment (like a\npositive integer or name, see \\code{\\link{as.environment}} for more\ndetails)}\n}\n\\description{\nThis version of \\code{\\link{substitute}} is more suited for interactive\nexploration because it will perform substitution in the global environment:\nthe regular version has a special case for the global environment where it\neffectively works like \\code{\\link{quote}}\n}\n\\section{Substitution rules}{\n\n\nFormally, substitution takes place by examining each name in the expression.\nIf the name refers to:\n\n\\itemize{\n\n \\item an ordinary variable, it's replaced by the value of the variable.\n\n \\item a promise, it's replaced by the expression associated with the\n    promise.\n\n \\item \\code{...}, it's replaced by the contents of \\code{...}\n}\n}\n\n\\examples{\na <- 1\nb <- 2\n\nsubstitute(a + b)\nsubs(a + b)\n}\n"
  },
  {
    "path": "man/substitute_q.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/substitute.r\n\\name{substitute_q}\n\\alias{substitute_q}\n\\title{A version of substitute that evaluates its first argument.}\n\\usage{\nsubstitute_q(x, env)\n}\n\\arguments{\n\\item{x}{a quoted call}\n\n\\item{env}{an environment, or something that behaves like an environment\n(like a list or data frame), or a reference to an environment (like a\npositive integer or name, see \\code{\\link{as.environment}} for more\ndetails)}\n}\n\\description{\nThis version of substitute is needed because \\code{substitute} does not\nevaluate it's first argument, and it's often useful to be able to modify\na quoted call.\n}\n\\examples{\nx <- quote(a + b)\nsubstitute(x, list(a = 1, b = 2))\nsubstitute_q(x, list(a = 1, b = 2))\n}\n"
  },
  {
    "path": "man/track_copy.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/inspect.r\n\\name{track_copy}\n\\alias{track_copy}\n\\title{Track if an object is copied}\n\\usage{\ntrack_copy(var, env = parent.frame(), quiet = FALSE)\n}\n\\arguments{\n\\item{var}{variable name (unquoted)}\n\n\\item{env}{environment name in which to track changes}\n\n\\item{quiet}{if \\code{FALSE}, prints a message on change; if \\code{FALSE}\nonly the return value of the function is used}\n}\n\\value{\na zero-arg function, that when called returns a boolean indicating\n  if the object has changed since the last time this function was called\n}\n\\description{\nThe title is somewhat misleading: rather than checking if an object is\nmodified, this really checks to see if a name points to the same object.\n}\n\\examples{\na <- 1:5\ntrack_a <- track_copy(a)\ntrack_a()\na[3] <- 3L\ntrack_a()\na[3] <- 3\ntrack_a()\nrm(a)\ntrack_a()\n}\n"
  },
  {
    "path": "man/unenclose.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/unenclose.r\n\\name{unenclose}\n\\alias{unenclose}\n\\title{Unenclose a closure.}\n\\usage{\nunenclose(f)\n}\n\\arguments{\n\\item{f}{a closure}\n}\n\\description{\nUnenclose a closure by substituting names for values found in the enclosing\nenvironment.\n}\n\\examples{\npower <- function(exp) {\n  function(x) x ^ exp\n}\nsquare <- power(2)\ncube <- power(3)\n\nsquare\ncube\nunenclose(square)\nunenclose(cube)\n}\n"
  },
  {
    "path": "man/uneval.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/uneval.r\n\\name{uneval}\n\\alias{uneval}\n\\title{Capture the call associated with a promise.}\n\\usage{\nuneval(x)\n}\n\\arguments{\n\\item{x}{unquoted variable name that refers to a promise. An error will be\nthrown if it's not a promise.}\n}\n\\description{\nThis is an alternative to subsitute that performs one job, and so gives\na stronger signal regarding the intention of your code.  It returns an error\nif the name is not associated with a promise.\n}\n\\examples{\nf <- function(x) {\n   uneval(x)\n}\nf(a + b)\nf(1 + 4)\n\ndelayedAssign(\"x\", 1 + 4)\nuneval(x)\nx\nuneval(x)\n}\n\\seealso{\nOther promise tools: \n\\code{\\link{is_promise}()}\n}\n\\concept{promise tools}\n"
  },
  {
    "path": "man/where.Rd",
    "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/where.r\n\\name{where}\n\\alias{where}\n\\title{Find where a name is defined.}\n\\usage{\nwhere(name, env = parent.frame())\n}\n\\arguments{\n\\item{name}{name, as string, to look for}\n\n\\item{env}{environment to start at. Defaults to the calling environment\nof this function.}\n}\n\\description{\nImplements the regular scoping rules, but instead of returning the value\nassociated with a name, it returns the environment in which it is located.\n}\n\\examples{\nx <- 1\nwhere(\"x\")\nwhere(\"t.test\")\nwhere(\"mean\")\nwhere(\"where\")\n}\n"
  },
  {
    "path": "pryr.Rproj",
    "content": "Version: 1.0\n\nRestoreWorkspace: Default\nSaveWorkspace: Default\nAlwaysSaveHistory: Default\n\nEnableCodeIndexing: Yes\nUseSpacesForTab: Yes\nNumSpacesForTab: 2\nEncoding: UTF-8\n\nRnwWeave: Sweave\nLaTeX: pdfLaTeX\n\nAutoAppendNewline: Yes\nStripTrailingWhitespace: Yes\n\nBuildType: Package\nPackageUseDevtools: Yes\nPackageInstallArgs: --no-multiarch --with-keep.source\nPackageRoxygenize: rd,collate,namespace\n"
  },
  {
    "path": "src/.gitignore",
    "content": "*.o\n*.so\n*.dll"
  },
  {
    "path": "src/RcppExports.cpp",
    "content": "// Generated by using Rcpp::compileAttributes() -> do not edit by hand\n// Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393\n\n#include <Rcpp.h>\n\nusing namespace Rcpp;\n\n#ifdef RCPP_USE_GLOBAL_ROSTREAM\nRcpp::Rostream<true>&  Rcpp::Rcout = Rcpp::Rcpp_cout_get();\nRcpp::Rostream<false>& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get();\n#endif\n\n// binary_repr\nCharacterVector binary_repr(SEXP x);\nRcppExport SEXP _pryr_binary_repr(SEXP xSEXP) {\nBEGIN_RCPP\n    Rcpp::RObject rcpp_result_gen;\n    Rcpp::RNGScope rcpp_rngScope_gen;\n    Rcpp::traits::input_parameter< SEXP >::type x(xSEXP);\n    rcpp_result_gen = Rcpp::wrap(binary_repr(x));\n    return rcpp_result_gen;\nEND_RCPP\n}\n// hex_repr\nCharacterVector hex_repr(SEXP x);\nRcppExport SEXP _pryr_hex_repr(SEXP xSEXP) {\nBEGIN_RCPP\n    Rcpp::RObject rcpp_result_gen;\n    Rcpp::RNGScope rcpp_rngScope_gen;\n    Rcpp::traits::input_parameter< SEXP >::type x(xSEXP);\n    rcpp_result_gen = Rcpp::wrap(hex_repr(x));\n    return rcpp_result_gen;\nEND_RCPP\n}\n// binary2hex\nCharacterVector binary2hex(CharacterVector x);\nRcppExport SEXP _pryr_binary2hex(SEXP xSEXP) {\nBEGIN_RCPP\n    Rcpp::RObject rcpp_result_gen;\n    Rcpp::RNGScope rcpp_rngScope_gen;\n    Rcpp::traits::input_parameter< CharacterVector >::type x(xSEXP);\n    rcpp_result_gen = Rcpp::wrap(binary2hex(x));\n    return rcpp_result_gen;\nEND_RCPP\n}\n// inspect_\nList inspect_(SEXP x, Environment base_env);\nRcppExport SEXP _pryr_inspect_(SEXP xSEXP, SEXP base_envSEXP) {\nBEGIN_RCPP\n    Rcpp::RObject rcpp_result_gen;\n    Rcpp::RNGScope rcpp_rngScope_gen;\n    Rcpp::traits::input_parameter< SEXP >::type x(xSEXP);\n    Rcpp::traits::input_parameter< Environment >::type base_env(base_envSEXP);\n    rcpp_result_gen = Rcpp::wrap(inspect_(x, base_env));\n    return rcpp_result_gen;\nEND_RCPP\n}\n// address2\nstd::string address2(Symbol name, Environment env);\nRcppExport SEXP _pryr_address2(SEXP nameSEXP, SEXP envSEXP) {\nBEGIN_RCPP\n    Rcpp::RObject rcpp_result_gen;\n    Rcpp::RNGScope rcpp_rngScope_gen;\n    Rcpp::traits::input_parameter< Symbol >::type name(nameSEXP);\n    Rcpp::traits::input_parameter< Environment >::type env(envSEXP);\n    rcpp_result_gen = Rcpp::wrap(address2(name, env));\n    return rcpp_result_gen;\nEND_RCPP\n}\n// named2\nint named2(Symbol name, Environment env);\nRcppExport SEXP _pryr_named2(SEXP nameSEXP, SEXP envSEXP) {\nBEGIN_RCPP\n    Rcpp::RObject rcpp_result_gen;\n    Rcpp::RNGScope rcpp_rngScope_gen;\n    Rcpp::traits::input_parameter< Symbol >::type name(nameSEXP);\n    Rcpp::traits::input_parameter< Environment >::type env(envSEXP);\n    rcpp_result_gen = Rcpp::wrap(named2(name, env));\n    return rcpp_result_gen;\nEND_RCPP\n}\n// is_promise2\nbool is_promise2(Symbol name, Environment env);\nRcppExport SEXP _pryr_is_promise2(SEXP nameSEXP, SEXP envSEXP) {\nBEGIN_RCPP\n    Rcpp::RObject rcpp_result_gen;\n    Rcpp::RNGScope rcpp_rngScope_gen;\n    Rcpp::traits::input_parameter< Symbol >::type name(nameSEXP);\n    Rcpp::traits::input_parameter< Environment >::type env(envSEXP);\n    rcpp_result_gen = Rcpp::wrap(is_promise2(name, env));\n    return rcpp_result_gen;\nEND_RCPP\n}\n// promise_code\nSEXP promise_code(Symbol name, Environment env);\nRcppExport SEXP _pryr_promise_code(SEXP nameSEXP, SEXP envSEXP) {\nBEGIN_RCPP\n    Rcpp::RObject rcpp_result_gen;\n    Rcpp::RNGScope rcpp_rngScope_gen;\n    Rcpp::traits::input_parameter< Symbol >::type name(nameSEXP);\n    Rcpp::traits::input_parameter< Environment >::type env(envSEXP);\n    rcpp_result_gen = Rcpp::wrap(promise_code(name, env));\n    return rcpp_result_gen;\nEND_RCPP\n}\n// promise_value\nSEXP promise_value(Symbol name, Environment env);\nRcppExport SEXP _pryr_promise_value(SEXP nameSEXP, SEXP envSEXP) {\nBEGIN_RCPP\n    Rcpp::RObject rcpp_result_gen;\n    Rcpp::RNGScope rcpp_rngScope_gen;\n    Rcpp::traits::input_parameter< Symbol >::type name(nameSEXP);\n    Rcpp::traits::input_parameter< Environment >::type env(envSEXP);\n    rcpp_result_gen = Rcpp::wrap(promise_value(name, env));\n    return rcpp_result_gen;\nEND_RCPP\n}\n// promise_evaled\nbool promise_evaled(Symbol name, Environment env);\nRcppExport SEXP _pryr_promise_evaled(SEXP nameSEXP, SEXP envSEXP) {\nBEGIN_RCPP\n    Rcpp::RObject rcpp_result_gen;\n    Rcpp::RNGScope rcpp_rngScope_gen;\n    Rcpp::traits::input_parameter< Symbol >::type name(nameSEXP);\n    Rcpp::traits::input_parameter< Environment >::type env(envSEXP);\n    rcpp_result_gen = Rcpp::wrap(promise_evaled(name, env));\n    return rcpp_result_gen;\nEND_RCPP\n}\n// promise_env\nSEXP promise_env(Symbol name, Environment env);\nRcppExport SEXP _pryr_promise_env(SEXP nameSEXP, SEXP envSEXP) {\nBEGIN_RCPP\n    Rcpp::RObject rcpp_result_gen;\n    Rcpp::RNGScope rcpp_rngScope_gen;\n    Rcpp::traits::input_parameter< Symbol >::type name(nameSEXP);\n    Rcpp::traits::input_parameter< Environment >::type env(envSEXP);\n    rcpp_result_gen = Rcpp::wrap(promise_env(name, env));\n    return rcpp_result_gen;\nEND_RCPP\n}\n// makeExplicit\nRObject makeExplicit(SEXP prom);\nRcppExport SEXP _pryr_makeExplicit(SEXP promSEXP) {\nBEGIN_RCPP\n    Rcpp::RObject rcpp_result_gen;\n    Rcpp::RNGScope rcpp_rngScope_gen;\n    Rcpp::traits::input_parameter< SEXP >::type prom(promSEXP);\n    rcpp_result_gen = Rcpp::wrap(makeExplicit(prom));\n    return rcpp_result_gen;\nEND_RCPP\n}\n// explicitPromise\nRObject explicitPromise(Symbol name, Environment env);\nRcppExport SEXP _pryr_explicitPromise(SEXP nameSEXP, SEXP envSEXP) {\nBEGIN_RCPP\n    Rcpp::RObject rcpp_result_gen;\n    Rcpp::RNGScope rcpp_rngScope_gen;\n    Rcpp::traits::input_parameter< Symbol >::type name(nameSEXP);\n    Rcpp::traits::input_parameter< Environment >::type env(envSEXP);\n    rcpp_result_gen = Rcpp::wrap(explicitPromise(name, env));\n    return rcpp_result_gen;\nEND_RCPP\n}\n// explicitDots\nstd::vector<RObject> explicitDots(Environment env);\nRcppExport SEXP _pryr_explicitDots(SEXP envSEXP) {\nBEGIN_RCPP\n    Rcpp::RObject rcpp_result_gen;\n    Rcpp::RNGScope rcpp_rngScope_gen;\n    Rcpp::traits::input_parameter< Environment >::type env(envSEXP);\n    rcpp_result_gen = Rcpp::wrap(explicitDots(env));\n    return rcpp_result_gen;\nEND_RCPP\n}\n// slice\nCharacterVector slice(CharacterVector x, int k, std::string sep);\nRcppExport SEXP _pryr_slice(SEXP xSEXP, SEXP kSEXP, SEXP sepSEXP) {\nBEGIN_RCPP\n    Rcpp::RObject rcpp_result_gen;\n    Rcpp::RNGScope rcpp_rngScope_gen;\n    Rcpp::traits::input_parameter< CharacterVector >::type x(xSEXP);\n    Rcpp::traits::input_parameter< int >::type k(kSEXP);\n    Rcpp::traits::input_parameter< std::string >::type sep(sepSEXP);\n    rcpp_result_gen = Rcpp::wrap(slice(x, k, sep));\n    return rcpp_result_gen;\nEND_RCPP\n}\n// sexp_type\nstd::string sexp_type(SEXP x);\nRcppExport SEXP _pryr_sexp_type(SEXP xSEXP) {\nBEGIN_RCPP\n    Rcpp::RObject rcpp_result_gen;\n    Rcpp::RNGScope rcpp_rngScope_gen;\n    Rcpp::traits::input_parameter< SEXP >::type x(xSEXP);\n    rcpp_result_gen = Rcpp::wrap(sexp_type(x));\n    return rcpp_result_gen;\nEND_RCPP\n}\n// typename2\nstd::string typename2(Symbol name, Environment env);\nRcppExport SEXP _pryr_typename2(SEXP nameSEXP, SEXP envSEXP) {\nBEGIN_RCPP\n    Rcpp::RObject rcpp_result_gen;\n    Rcpp::RNGScope rcpp_rngScope_gen;\n    Rcpp::traits::input_parameter< Symbol >::type name(nameSEXP);\n    Rcpp::traits::input_parameter< Environment >::type env(envSEXP);\n    rcpp_result_gen = Rcpp::wrap(typename2(name, env));\n    return rcpp_result_gen;\nEND_RCPP\n}\n\nstatic const R_CallMethodDef CallEntries[] = {\n    {\"_pryr_binary_repr\", (DL_FUNC) &_pryr_binary_repr, 1},\n    {\"_pryr_hex_repr\", (DL_FUNC) &_pryr_hex_repr, 1},\n    {\"_pryr_binary2hex\", (DL_FUNC) &_pryr_binary2hex, 1},\n    {\"_pryr_inspect_\", (DL_FUNC) &_pryr_inspect_, 2},\n    {\"_pryr_address2\", (DL_FUNC) &_pryr_address2, 2},\n    {\"_pryr_named2\", (DL_FUNC) &_pryr_named2, 2},\n    {\"_pryr_is_promise2\", (DL_FUNC) &_pryr_is_promise2, 2},\n    {\"_pryr_promise_code\", (DL_FUNC) &_pryr_promise_code, 2},\n    {\"_pryr_promise_value\", (DL_FUNC) &_pryr_promise_value, 2},\n    {\"_pryr_promise_evaled\", (DL_FUNC) &_pryr_promise_evaled, 2},\n    {\"_pryr_promise_env\", (DL_FUNC) &_pryr_promise_env, 2},\n    {\"_pryr_makeExplicit\", (DL_FUNC) &_pryr_makeExplicit, 1},\n    {\"_pryr_explicitPromise\", (DL_FUNC) &_pryr_explicitPromise, 2},\n    {\"_pryr_explicitDots\", (DL_FUNC) &_pryr_explicitDots, 1},\n    {\"_pryr_slice\", (DL_FUNC) &_pryr_slice, 3},\n    {\"_pryr_sexp_type\", (DL_FUNC) &_pryr_sexp_type, 1},\n    {\"_pryr_typename2\", (DL_FUNC) &_pryr_typename2, 2},\n    {NULL, NULL, 0}\n};\n\nRcppExport void R_init_pryr(DllInfo *dll) {\n    R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);\n    R_useDynamicSymbols(dll, FALSE);\n}\n"
  },
  {
    "path": "src/bytes.cpp",
    "content": "#include <iomanip>\n#include <Rcpp.h>\n\nusing namespace Rcpp;\n\n// good enough for now, I suppose\n#if defined(__sparc__) || defined(__sparc) || defined(__ppc__) || defined(__ppc64__)\n#define IS_BIG_ENDIAN true\n#else\n#define IS_BIG_ENDIAN false\n#endif\n\n\nnamespace pryr {\n\n// traits to denote the internal C storage of an R type\nnamespace traits {\n\ntemplate <int RTYPE>\nstruct dataptr {\n  typedef typename Rcpp::traits::storage_type<RTYPE>::type* type;\n};\n\ntemplate <>\nstruct dataptr<STRSXP> {\n  typedef const char* type;\n};\n\n} // namespace traits\n\n// Declaring some types\n// We store the number of characters needed to represent a single byte of data\n// for a given representation\nstruct Bits {\n  static const int chars_per_byte = 8;\n};\nstruct Hex {\n  static const int chars_per_byte = 2;\n};\n\n// Utility functions\ntemplate <int RTYPE>\ntypename traits::dataptr<RTYPE>::type get_pointer(const Rcpp::Vector<RTYPE>& x, int i) {\n  return static_cast<typename traits::dataptr<RTYPE>::type>(dataptr(x)) + i;\n}\n\ntemplate <>\nconst char* get_pointer(const Rcpp::Vector<STRSXP>& x, int i) {\n  return CHAR(STRING_ELT(x, i));\n}\n\ntemplate <int RTYPE>\ninline size_t get_length_in_bytes(const Rcpp::Vector<RTYPE>& x, int i) {\n  return sizeof(typename ::Rcpp::traits::storage_type<RTYPE>::type);\n}\n\ntemplate <>\ninline size_t get_length_in_bytes(const Rcpp::Vector<STRSXP>& x, int i) {\n  return strlen( CHAR(STRING_ELT(x, i)) );\n}\n\n// Class handling the conversion logic (from T to bits or hex)\ntemplate <typename Repr, bool is_string>\nstruct Representation {\n\n  static const int chars_per_byte = Repr::chars_per_byte;\n\n  inline void operator()(const char* ptr, size_t n, char* output) {\n    return repr(ptr, n, output);\n  }\n\n  inline void repr(const char* ptr, size_t n, char* output);\n\n};\n\n// Depending on the type of data, we either want to read from left-to-right,\n// or right-to-left, to give an output that matches what we might expect\n// from the binary representation. In particular, we read the bits in a\n// string from left to right, while we read the bits in a numeric value\n// from right to left (endianness; TODO is to handle that in the dispatch\n// later on)\ntemplate <>\nvoid Representation<Bits, false>::repr(const char* ptr, size_t n, char* output) {\n  int counter = n * 8 - 1;\n  for (size_t i=0; i < n; ++i) {\n    char curr = ptr[i];\n    for (int j=0; j < 8; ++j) {\n      output[counter--] = curr & 1 ? '1' : '0';\n      curr >>= 1;\n    }\n  }\n}\n\ntemplate<>\nvoid Representation<Bits, true>::repr(const char* ptr, size_t n, char* output) {\n  int counter = n * 8 - 1;\n  for (int i = n - 1; i >= 0; --i) {\n    char curr = ptr[i];\n    for (int j=0; j < 8; ++j) {\n      output[counter--] = curr & 1 ? '1' : '0';\n      curr >>= 1;\n    }\n  }\n}\n\n// The hex version\ntemplate<>\nvoid Representation<Hex, true>::repr(const char* ptr, size_t n, char* output) {\n  int counter = 0;\n  for (size_t i = 0; i < n; ++i) {\n    snprintf(output + counter * 2, 2 + 1, \"%02X\", ptr[i] & 0xFF);\n    ++counter;\n  }\n}\n\ntemplate<>\nvoid Representation<Hex, false>::repr(const char* ptr, size_t n, char* output) {\n  int counter = 0;\n  for (int i = n - 1; i >= 0; --i) {\n    snprintf(output + counter * 2, 2 + 1, \"%02X\", ptr[i] & 0xFF);\n    ++counter;\n  }\n}\n\n// generic version for non-STRSXP\ntemplate <int RTYPE, typename Representation>\nCharacterVector representation(const Vector<RTYPE>& x, Representation fill_as) {\n\n  int n = x.size();\n  CharacterVector output = no_init(n);\n\n  // Allocate a buffer to hold printed results\n  size_t num_bytes = sizeof(typename Rcpp::traits::storage_type<RTYPE>::type);\n  size_t num_chars = Representation::chars_per_byte * num_bytes;\n  char* buff = new char[num_chars + 1];\n  buff[num_chars] = '\\0';\n\n  // Fill the buffer and the output vector\n  for (int i=0; i < n; ++i) {\n    const char* ptr = reinterpret_cast<const char*>(get_pointer(x, i));\n    fill_as(ptr, num_bytes, buff);\n    SET_STRING_ELT(output, i, Rf_mkChar(buff));\n  }\n\n  // Clean up and return\n  delete[] buff;\n  return output;\n}\n\n// STRSXP\ntemplate <typename Representation>\nCharacterVector representation_str(const Vector<STRSXP>& x, Representation fill_as) {\n\n  int n = x.size();\n  CharacterVector output = no_init(n);\n  size_t chars_per_byte = Representation::chars_per_byte;\n\n  for (int i=0; i < n; ++i) {\n    const char* ptr = reinterpret_cast<const char*>(get_pointer(x, i));\n    size_t num_bytes = get_length_in_bytes(x, i);\n    size_t num_chars = chars_per_byte * num_bytes;\n    char* buff = new char[num_chars + 1];\n    buff[num_chars] = '\\0';\n    fill_as(ptr, num_bytes, buff);\n    SET_STRING_ELT(output, i, Rf_mkChar(buff));\n    delete[] buff;\n  }\n\n  return output;\n}\n\n} // namespace pryr\n\nusing namespace pryr;\n\n// [[Rcpp::export]]\nCharacterVector binary_repr(SEXP x) {\n  switch (TYPEOF(x)) {\n  case INTSXP: return representation<INTSXP>(x, Representation<Bits, IS_BIG_ENDIAN>());\n  case REALSXP: return representation<REALSXP>(x, Representation<Bits, IS_BIG_ENDIAN>());\n  case LGLSXP: return representation<LGLSXP>(x, Representation<Bits, IS_BIG_ENDIAN>());\n  case STRSXP: return representation_str(x, Representation<Bits, true>());\n  default: {\n    std::stringstream ss;\n    ss << \"can't print binary representation for objects of type '\" <<\n      CHAR(Rf_type2str(TYPEOF(x))) << \"'\";\n    stop(ss.str());\n  }\n  }\n  return CharacterVector();\n}\n\n// [[Rcpp::export]]\nCharacterVector hex_repr(SEXP x) {\n  switch (TYPEOF(x)) {\n  case INTSXP: return representation<INTSXP>(x, Representation<Hex, IS_BIG_ENDIAN>());\n  case REALSXP: return representation<REALSXP>(x, Representation<Hex, IS_BIG_ENDIAN>());\n  case LGLSXP: return representation<LGLSXP>(x, Representation<Hex, IS_BIG_ENDIAN>());\n  case STRSXP: return representation_str(x, Representation<Hex, true>());\n  default: {\n    std::stringstream ss;\n    ss << \"can't print binary representation for objects of type '\" <<\n      CHAR(Rf_type2str(TYPEOF(x))) << \"'\";\n    stop(ss.str());\n  }\n  }\n  return CharacterVector();\n}\n\nnamespace pryr {\n\nstd::string binary2hex(const std::string& x) {\n  int n = x.size();\n  if (n % 8 != 0) {\n    stop(\"expecting a string of length 8n\");\n  }\n  std::stringstream output;\n  int nBytes = n / 8;\n  for (int i=0; i < nBytes; ++i) {\n    char curr;\n    int value = 0;\n    for (int j=0; j < 8; ++j) {\n      curr = x[i*8 + j];\n      if (!(curr == '0' or curr == '1')) stop(\"each character must be '0' or '1'\");\n      if (curr == '1') value += 1 << (7 - j);\n    }\n    std::stringstream ss;\n    ss << std::setfill('0') << std::setw(2) << std::uppercase << std::hex << (int) value;\n    output << ss.str();\n  }\n  return output.str();\n}\n\n} // namespace pryr\n\n// [[Rcpp::export]]\nCharacterVector binary2hex(CharacterVector x) {\n  int n = x.size();\n  CharacterVector output = no_init(n);\n  for (int i=0; i < n; ++i) {\n    output[i] = binary2hex( as<std::string>(x[i]) );\n  }\n  return output;\n}\n"
  },
  {
    "path": "src/inspect.cpp",
    "content": "#include <Rcpp.h>\nusing namespace Rcpp;\n\nbool is_namespace(Environment env) {\n  return Rf_findVarInFrame3(env, Rf_install(\".__NAMESPACE__.\"), FALSE) != R_UnboundValue;\n}\n\nstd::string sexp_type(SEXP x);\n\nstd::string address(SEXP x) {\n  std::ostringstream s;\n  s << x;\n  return s.str();\n}\n\n\nList inspect_rec(SEXP x, Environment base_env, std::set<SEXP>& seen) {\n  // If we've seen it before, return nothing\n  if (!seen.insert(x).second) {\n    List out =  List::create(\n      _[\"address\"] = address(x),\n      _[\"type\"] = sexp_type(x),\n      _[\"named\"] = NAMED(x),\n      _[\"seen\"] = true\n    );\n    std::vector<std::string> klass;\n    klass.push_back(\"inspect_\" + sexp_type(x));\n    klass.push_back(\"inspect\");\n    out.attr(\"class\") = klass;\n    return out;\n  }\n\n  List children;\n\n  switch (TYPEOF(x)) {\n    // Base case: non recursive objects\n    case LGLSXP:\n    case INTSXP:\n    case REALSXP:\n    case CPLXSXP:\n    case RAWSXP:\n    case CHARSXP:\n    case SYMSXP:\n    case NILSXP:\n    case SPECIALSXP:\n    case BUILTINSXP:\n      break;\n\n    // Strings\n    case STRSXP:\n      children = List(LENGTH(x));\n      for (int i = 0; i < LENGTH(x); i++) {\n        children[i] = inspect_rec(STRING_ELT(x, i), base_env, seen);\n      }\n      break;\n\n    // Generic vectors\n    case VECSXP:\n    case EXPRSXP:\n    case WEAKREFSXP:\n      children = List(XLENGTH(x));\n      for (int i = 0; i < LENGTH(x); i++) {\n        children[i] = inspect_rec(VECTOR_ELT(x, i), base_env, seen);\n      }\n      break;\n\n    // Linked lists\n    case LISTSXP:\n    case LANGSXP:\n    case BCODESXP:\n      children = List::create(\n        _[\"tag\"] = inspect_rec(TAG(x), base_env, seen), // name of first element\n        _[\"car\"] = inspect_rec(CAR(x), base_env, seen), // first element\n        _[\"cdr\"] = inspect_rec(CDR(x), base_env, seen) // pairlist (subsequent elements) or NILSXP\n      );\n      break;\n\n    // Environments\n    case ENVSXP:\n      if (x == R_BaseEnv || x == R_GlobalEnv || x == R_EmptyEnv ||\n          x == base_env || is_namespace(x)) break;\n\n      children = List::create(\n        _[\"frame\"] = inspect_rec(FRAME(x), base_env, seen),\n        _[\"enclos\"] = inspect_rec(ENCLOS(x), base_env, seen),\n        _[\"hashtab\"] = inspect_rec(HASHTAB(x), base_env, seen)\n      );\n      break;\n\n    // Functions\n    case CLOSXP:\n      children = List::create(\n        _[\"formals\"] = inspect_rec(FORMALS(x), base_env, seen),\n        _[\"body\"] = inspect_rec(BODY(x), base_env, seen),\n        _[\"env\"]  = inspect_rec(CLOENV(x), base_env, seen)\n      );\n      break;\n\n    case PROMSXP:\n      children = List::create(\n        _[\"value\"] = inspect_rec(PRVALUE(x), base_env, seen),\n        _[\"code\"] = inspect_rec(PRCODE(x), base_env, seen),\n        _[\"env\"]  = inspect_rec(PRENV(x), base_env, seen)\n      );\n      break;\n\n    case EXTPTRSXP:\n      children = List::create(\n        _[\"prot\"] = inspect_rec(EXTPTR_PROT(x), base_env, seen),\n        _[\"tag\"] = inspect_rec(EXTPTR_TAG(x), base_env, seen)\n      );\n      break;\n\n    case S4SXP:\n      children = List::create(\n        _[\"tag\"] = inspect_rec(TAG(x), base_env, seen)\n      );\n      break;\n\n    default:\n      Rcout << \"type: \" << TYPEOF(x);\n      stop(\"Unimplemented type\");\n  }\n\n\n  List out = List::create(\n    _[\"address\"] = address(x),\n    _[\"type\"] = sexp_type(x),\n    _[\"named\"] = NAMED(x),\n    _[\"seen\"] = false\n  );\n\n  if (ATTRIB(x) != R_NilValue) {\n    children[\"attributes\"] = inspect_rec(ATTRIB(x), base_env, seen);\n  }\n  if (children.size() > 0) {\n    out[\"children\"] = children;\n  }\n\n  std::vector<std::string> klass;\n  klass.push_back(\"inspect_\" + sexp_type(x));\n  klass.push_back(\"inspect\");\n  out.attr(\"class\") = klass;\n\n  return out;\n}\n\n// [[Rcpp::export]]\nList inspect_(SEXP x, Environment base_env) {\n  std::set<SEXP> seen;\n\n  return inspect_rec(x, base_env, seen);\n}\n\n\n// [[Rcpp::export]]\nstd::string address2(Symbol name, Environment env) {\n  SEXP object = Rf_findVar(name, env);\n  std::ostringstream s;\n  s << object;\n  return s.str();\n}\n\n// [[Rcpp::export]]\nint named2(Symbol name, Environment env) {\n  SEXP object = Rf_findVar(name, env);\n  return NAMED(object);\n}\n"
  },
  {
    "path": "src/promise.cpp",
    "content": "#include <Rcpp.h>\nusing namespace Rcpp;\n\n// [[Rcpp::export]]\nbool is_promise2(Symbol name, Environment env) {\n  SEXP object = Rf_findVar(name, env);\n\n  return (TYPEOF (object) == PROMSXP);\n}\n\n// [[Rcpp::export]]\nSEXP promise_code(Symbol name, Environment env) {\n  SEXP object = Rf_findVar(name, env);\n  return PRCODE(object);\n}\n// [[Rcpp::export]]\nSEXP promise_value(Symbol name, Environment env) {\n  SEXP object = Rf_findVar(name, env);\n  return PRVALUE(object);\n}\n// [[Rcpp::export]]\nbool promise_evaled(Symbol name, Environment env) {\n  SEXP object = Rf_findVar(name, env);\n  return PRVALUE(object) != R_UnboundValue;\n}\n// [[Rcpp::export]]\nSEXP promise_env(Symbol name, Environment env) {\n  SEXP object = Rf_findVar(name, env);\n  return PRENV(object);\n}\n\n\n// [[Rcpp::export]]\nRObject makeExplicit(SEXP prom) {\n  if (TYPEOF(prom) != PROMSXP) {\n    stop(\"Not a promise\");\n  }\n\n  // recurse until we find the real promise, not a promise of a promise\n  while(true) {\n    SEXP code = PRCODE(prom);\n    if(TYPEOF(code) != PROMSXP) break;\n    prom = code;\n  }\n\n  SEXP args = PROTECT(Rf_lcons(PRCODE(prom), R_NilValue));\n  RObject formula = Rf_lcons(Rf_install(\"~\"), args);\n  UNPROTECT(1);\n\n  formula.attr(\".Environment\") = PRENV(prom);\n  formula.attr(\"class\") = \"formula\";\n\n  return formula;\n}\n\n// [[Rcpp::export]]\nRObject explicitPromise(Symbol name, Environment env) {\n  SEXP prom = Rf_findVar(name, env);\n  return makeExplicit(prom);\n}\n\n// [[Rcpp::export]]\nstd::vector<RObject> explicitDots(Environment env) {\n  SEXP dots = env.find(\"...\");\n\n  std::vector<RObject> out;\n  std::vector<std::string> names;\n\n  dots = env.find(\"...\");\n\n  SEXP el;\n  for(SEXP nxt = dots; nxt != R_NilValue; el = CAR(nxt), nxt = CDR(nxt)) {\n    out.push_back(makeExplicit(el));\n\n    SEXP name = TAG(nxt);\n    if (Rf_isNull(name)) {\n      names.push_back(\"\");\n    } else {\n      names.push_back(\"\");\n    }\n  }\n\n\n  return out;\n}\n"
  },
  {
    "path": "src/slice.cpp",
    "content": "#include <Rcpp.h>\nusing namespace Rcpp;\n\nstd::string slice(std::string const& x, int k, std::string const& sep = \" \") {\n  std::string output;\n  int size = x.size();\n  int nSlices = size / k;\n  output.reserve(size + nSlices * sep.size() - 1);\n  for (int i=0; i < nSlices - 1; ++i) {\n    output += x.substr(i * k, k);\n    output += sep;\n  }\n  output += x.substr(size - k, k);\n  return output;\n}\n\n// [[Rcpp::export]]\nCharacterVector slice(CharacterVector x, int k, std::string sep = \" \") {\n  int n = x.size();\n  CharacterVector output = no_init(n);\n  for (int i=0; i < n; ++i) {\n    output[i] = slice( as<std::string>(x[i]), k, sep );\n  }\n  return output;\n}\n"
  },
  {
    "path": "src/typename.cpp",
    "content": "// Modified from src/main/inspect.C\n//\n// Copyright (C) 2009-2012 The R Core Team.\n// Copyright (C) 2013 Hadley Wickham\n//\n// This program is free software; you can redistribute it and/or modify\n// it under the terms of the GNU General Public License as published by\n// the Free Software Foundation; either version 2 of the License, or\n// (at your option) any later version.\n//\n// This program is distributed in the hope that it will be useful,\n// but WITHOUT ANY WARRANTY; without even the implied warranty of\n// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n// GNU General Public License for more details.\n//\n// A copy of the GNU General Public License is available at\n// http://www.r-project.org/Licenses/\n\n#include <Rcpp.h>\nusing namespace Rcpp;\n\n//' @export\n//' @rdname inspect\n// [[Rcpp::export]]\nstd::string sexp_type(SEXP x) {\n  switch (TYPEOF(x)) {\n    case NILSXP:  return \"NILSXP\";\n    case SYMSXP:  return \"SYMSXP\";\n    case LISTSXP: return \"LISTSXP\";\n    case CLOSXP:  return \"CLOSXP\";\n    case ENVSXP:  return \"ENVSXP\";\n    case PROMSXP: return \"PROMSXP\";\n    case LANGSXP: return \"LANGSXP\";\n    case SPECIALSXP:  return \"SPECIALSXP\";\n    case BUILTINSXP:  return \"BUILTINSXP\";\n    case CHARSXP: return \"CHARSXP\";\n    case LGLSXP:  return \"LGLSXP\";\n    case INTSXP:  return \"INTSXP\";\n    case REALSXP: return \"REALSXP\";\n    case CPLXSXP: return \"CPLXSXP\";\n    case STRSXP:  return \"STRSXP\";\n    case DOTSXP:  return \"DOTSXP\";\n    case ANYSXP:  return \"ANYSXP\";\n    case VECSXP:  return \"VECSXP\";\n    case EXPRSXP: return \"EXPRSXP\";\n    case BCODESXP:  return \"BCODESXP\";\n    case EXTPTRSXP: return \"EXTPTRSXP\";\n    case WEAKREFSXP:  return \"WEAKREFSXP\";\n    case S4SXP:   return \"S4SXP\";\n    case RAWSXP:  return \"RAWSXP\";\n    default:   return \"<unknown>\";\n  }\n}\n\n// [[Rcpp::export]]\nstd::string typename2(Symbol name, Environment env) {\n  SEXP object = Rf_findVar(name, env);\n  return sexp_type(object);\n}\n"
  },
  {
    "path": "tests/testthat/helper-object_size.R",
    "content": "\nexpect_same <- function(x) {\n  base <- as.vector(object.size(x))\n  pryr <- as.vector(object_size(x))\n\n  expect_equal(base, pryr)\n}\n"
  },
  {
    "path": "tests/testthat/test-active-binding.r",
    "content": "context(\"is_active_binding\")\n\ntest_that(\"active bindings can be detected\", {\n  x <- 10\n  expect_false(is_active_binding(x))\n\n  x %<a-% runif(1)\n  expect_true(is_active_binding(x))\n\n  y <- x\n  expect_false(is_active_binding(y))\n})\n"
  },
  {
    "path": "tests/testthat/test-bytes.r",
    "content": "context(\"bytes\")\n\ntest_that(\"bytes produces hex representations as expected\", {\n\n  expect_identical(\n    bytes(1L),\n    c(\"00 00 00 01\")\n  )\n\n  expect_identical(\n    bytes(1),\n    \"3F F0 00 00 00 00 00 00\"\n  )\n\n  expect_identical(\n    bytes(\"aa\"),\n    paste(bytes(\"a\"), bytes(\"a\"))\n  )\n\n})\n\ntest_that(\"bytes produces binary representations as expected\", {\n\n  expect_identical(\n    bits(1L),\n    \"00000000 00000000 00000000 00000001\"\n  )\n\n  expect_identical(\n    bits(1),\n    \"00111111 11110000 00000000 00000000 00000000 00000000 00000000 00000000\"\n  )\n\n})\n\ntest_that(\"encoding doesn't affect what bits / bytes are read\", {\n\n  x <- y <- z <- \"\\u9b3c\"\n  Encoding(y) <- \"bytes\"\n  Encoding(z) <- \"latin1\"\n  expect_identical( bytes(x), bytes(y) )\n  expect_identical( bytes(y), bytes(z) )\n\n  expect_identical( bits(x), bits(y) )\n  expect_identical( bits(y), bits(z) )\n\n})\n\n\ntest_that(\"we read character strings in the right order\", {\n\n  test_char_repr <- function(f) {\n    f <- match.fun(f)\n    repr <- f(c(\"a\", \"ab\", \"abc\"))\n    first_repr <- unlist(lapply(strsplit(repr, \" \"), \"[[\", 1))\n    lu <- length(unique(first_repr))\n    return(lu)\n  }\n\n  expect_equal(test_char_repr(bytes), 1)\n  expect_equal(test_char_repr(bits), 1)\n\n\n})\n"
  },
  {
    "path": "tests/testthat/test-ftype.r",
    "content": "context(\"ftype\")\n\ntest_that(\"S4 methods and generics return as expected\", {\n  e <- attach(NULL, name = \"test\")\n  on.exit(detach(\"test\"))\n  \n  A <- setClass(\"A\", contains = list(), where = e)\n\n  setGeneric(\"f\", function(x) 1, where = e)\n  f <- getGeneric(\"f\", where = e)\n  expect_equal(ftype(f), c(\"s4\", \"generic\"))\n\n  setMethod(\"f\", signature(x = \"A\"), function(x) 1, where = e)\n  m <- getMethod(\"f\", signature(x = \"A\"), where = e)\n  expect_equal(ftype(m), c(\"s4\", \"method\"))    \n})\n\ntest_that(\"RC methods return as expected\", {\n  B <- setRefClass(\"B\", methods = list(f = function(x) x))\n  b <- B$new()\n\n  expect_equal(ftype(b$f), c(\"rc\", \"method\"))\n})\n\ntest_that(\"primitive_name return as expected\", {\n\n  expect_equal(primitive_name(`@`), \"@\")\n\n  at <- `@`\n  expect_equal(primitive_name(at), \"@\")\n})\n"
  },
  {
    "path": "tests/testthat/test-method-from-call.r",
    "content": "context(\"Method from call\")\n\ne <- new.env()\nsetClass(\"A\", \"list\", where = e)\nsetClass(\"B\", \"list\", where = e)\nsetGeneric(\"gen0\", function(x, ...) standardGeneric(\"gen0\"), where = e)\n\ntest_that(\"finds method with missing args\", {\n  setMethod(\"gen0\", \"missing\", function(x, ...) \"missing\", where = e)\n\n  exp <- selectMethod(\"gen0\", \"missing\")\n  expect_identical(method_from_call(gen0(), e), exp)\n})\n\ntest_that(\"only uses arguments in generic\", {\n  setMethod(\"gen0\", \"A\", function(x, ...) \"A\", where = e)\n\n  exp <- selectMethod(\"gen0\", \"A\")\n  expect_identical(method_from_call(gen0(new(\"A\"), 1), e), exp)\n})\n"
  },
  {
    "path": "tests/testthat/test-object_size.R",
    "content": "context(\"Object_size\")\n\n# Compatibility with base ---------------------------------------------------\n\ntest_that(\"size scales correctly with length (accounting for vector pool)\", {\n  expect_same(numeric())\n  expect_same(1)\n  expect_same(2)\n  expect_same(1:10 + 0)\n  expect_same(1:1000 + 0)\n})\n\ntest_that(\"size correct for length one vectors\", {\n  expect_same(1)\n  expect_same(1L)\n  expect_same(\"abc\")\n  expect_same(paste(rep(\"banaana\", 100), collapse = \"\"))\n  expect_same(charToRaw(\"a\"))\n  expect_same(5 + 1i)\n})\n\ntest_that(\"size of list computed recursively\", {\n  expect_same(list())\n  expect_same(as.list(1))\n  expect_same(as.list(1:2))\n  expect_same(as.list(1:3))\n\n  expect_same(list(list(list(list(list())))))\n})\n\ntest_that(\"size of symbols same as base\", {\n  expect_same(quote(x))\n  expect_same(quote(asfsadfasdfasdfds))\n})\n\ntest_that(\"size of pairlists same as base\", {\n  expect_same(pairlist())\n  expect_same(pairlist(1))\n  expect_same(pairlist(1, 2, 3))\n})\n\ntest_that(\"size of attributes included in object size\", {\n  expect_same(c(x = 1))\n  expect_same(list(x = 1))\n  expect_same(c(x = \"y\"))\n})\n\ntest_that(\"duplicated CHARSXPS only counted once\", {\n  expect_same(\"x\")\n  expect_same(c(\"x\", \"y\", \"x\"))\n  expect_same(c(\"banana\", \"banana\", \"banana\"))\n})\n\n# Improved behaviour for shared components ------------------------------------\ntest_that(\"shared components only counted once\", {\n  x <- 1:1e3\n  z <- list(x, x, x)\n\n  expect_equal(object_size(z), object_size(x) + object_size(vector(\"list\", 3)))\n})\n\ntest_that(\"size of closures same as base\", {\n  f <- function() NULL\n  attributes(f) <- NULL # zap srcrefs\n  environment(f) <- emptyenv()\n  expect_same(f)\n})\n\n# Environment sizes -----------------------------------------------------------\ntest_that(\"terminal environments have size zero\", {\n  expect_equal(as.numeric(object_size(globalenv())), 0)\n  expect_equal(as.numeric(object_size(baseenv())), 0)\n  expect_equal(as.numeric(object_size(emptyenv())), 0)\n\n  expect_equal(as.numeric(object_size(asNamespace(\"stats\"))), 0)\n})\n\ntest_that(\"environment size computed recursively\", {\n  e <- new.env(parent = emptyenv())\n  e_size <- object_size(e)\n\n  f <- new.env(parent = e)\n  object_size(f)\n  expect_equal(object_size(f), 2 * object_size(e))\n})\n\ntest_that(\"size of function includes environment\", {\n  f <- function() {\n    y <- 1:1e3\n    a ~ b\n  }\n  g <- function() {\n    y <- 1:1e3\n    function() 10\n  }\n\n  expect_true(object_size(f()) > object_size(1:1e3))\n  expect_true(object_size(g()) > object_size(1:1e3))\n})\n\ntest_that(\"size doesn't include parents of current environment\", {\n  x <- 1:1e4 + 0\n  embedded <- (function() {\n    g <- function() {\n      x <- 1:1e3\n      a ~ b\n    }\n    object_size(g())\n  })()\n\n  expect_true(embedded < object_size(x))\n\n})\n\ntest_that(\"support dots in closure environments\", {\n  fn <- (function(...) function() NULL)(foo)\n  expect_error(object_size(fn), NA)\n})\n\n"
  },
  {
    "path": "tests/testthat/test-track-copy.R",
    "content": "context(\"track_copy\")\n\ntest_that(\"deletes are not copies\", {\n  a <- 1:5\n  tracker <- track_copy(a, quiet = TRUE)\n\n  expect_false(tracker())\n  rm(a)\n  expect_false(tracker())\n})\n\ntest_that(\"modifying type triggers copy\", {\n  a <- 1:5\n  tracker <- track_copy(a, quiet = TRUE)\n\n  expect_false(tracker())\n  a[3] <- 2.5\n  expect_true(tracker())\n})\n\ntest_that(\"modifying element in vector does not trigger copy\", {\n  a <- c(1L, 2L, 5L, 4L, 3L)\n  tracker <- track_copy(a, quiet = TRUE)\n\n  expect_false(tracker())\n  a[3] <- 3L\n  expect_false(tracker())\n})\n"
  },
  {
    "path": "tests/testthat.R",
    "content": "library(\"testthat\")\nlibrary(\"pryr\")\n\ntest_check(\"pryr\")\n"
  }
]