1# Helper function for checking that vectors have same contents, regardless of
2# order. Can be removed once something similar is incorporated into testthat
3# package. See
4# https://github.com/hadley/testthat/issues/473
5contents_identical <- function(a, b) {
6  # Convert to named vectors - needed for sorting later.
7  if (is.null(names(a))) {
8    names(a) <- rep("", length(a))
9  }
10  if (is.null(names(b))) {
11    names(b) <- rep("", length(b))
12  }
13
14  # Fast path for atomic vectors
15  if (is.atomic(a) && is.atomic(b)) {
16    # Sort first by names, then contents. This is so that the comparison can
17    # handle duplicated names.
18    a <- a[order(names(a), a)]
19    b <- b[order(names(b), b)]
20
21    return(identical(a, b))
22  }
23
24  # If we get here, we're on the slower path for lists
25
26  # Check if names are the same. If there are duplicated names, make sure
27  # there's the same number of duplicates of each.
28  if (!identical(sort(names(a)), sort(names(b)))) {
29    return(FALSE)
30  }
31
32  # Group each vector by names
33  by_names_a <- tapply(a, names(a), function(x) x)
34  by_names_b <- tapply(b, names(b), function(x) x)
35
36  # Compare each group
37  for (i in seq_along(by_names_a)) {
38    subset_a <- by_names_a[[i]]
39    subset_b <- by_names_b[[i]]
40
41    unique_subset_a <- unique(subset_a)
42    idx_a <- sort(match(subset_a, unique_subset_a))
43    idx_b <- sort(match(subset_b, unique_subset_a))
44    if (!identical(idx_a, idx_b)) {
45      return(FALSE)
46    }
47  }
48
49  TRUE
50}
51
52# Don't print out stack traces (which go to stderr)
53suppress_stacktrace <- function(expr) {
54  capture.output(force(expr), type = "message")
55}
56
57# Rewire copies the given function, f, and replaces any named
58# provided arguments in its execution.
59# Note #1: this only substitutes variables at the top-level function
60#   call. Recursive calls back into this function will not have the
61#   substitutions.
62# Note #2: this function won't work if the call includes the namespace.
63#   i.e. `rewire(f, ls=function(x))` will not rewire a call to `base::ls()`.
64#   See `rewire_namespace` below for this.
65rewire <- function(f, ...) {
66  orig_env <- environment(f)
67  new_env <- list2env(list(...), parent = orig_env)
68  environment(f) <- new_env
69  f
70}
71
72# rewire can't rewire a namespaced call like `base::print`. However, it can overload
73# the `::` function. This helper creates a function that can be used to rewire `::`
74rewire_namespace_handler <- function(pkgname, symbolname, value) {
75  function(pkg, name) {
76    pkg <- substitute(pkg)
77    name <- substitute(name)
78
79    if (identical(as.character(pkg), pkgname) && identical(as.character(name), symbolname)) {
80      return(value)
81    } else {
82      do.call(`::`, list(pkg, name))
83    }
84  }
85}
86