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