1#' @importFrom magrittr %>% 2#' @export 3magrittr::`%>%` 4 5dots <- function(...) { 6 eval_bare(substitute(alist(...))) 7} 8 9deparse_trunc <- function(x, width = getOption("width")) { 10 text <- deparse(x, width.cutoff = width) 11 if (length(text) == 1 && nchar(text) < width) return(text) 12 13 paste0(substr(text[1], 1, width - 3), "...") 14} 15 16any_apply <- function(xs, f) { 17 for (x in xs) { 18 if (f(x)) return(TRUE) 19 } 20 FALSE 21} 22 23deparse_names <- function(x) { 24 x <- map_if(x, is_quosure, quo_squash) 25 x <- map_if(x, is_bare_formula, f_rhs) 26 map_chr(x, deparse) 27} 28 29commas <- function(...) paste0(..., collapse = ", ") 30 31in_travis <- function() identical(Sys.getenv("TRAVIS"), "true") 32 33named <- function(...) { 34 x <- c(...) 35 36 missing_names <- names2(x) == "" 37 names(x)[missing_names] <- x[missing_names] 38 39 x 40} 41 42unique_name <- local({ 43 i <- 0 44 45 function() { 46 i <<- i + 1 47 paste0("zzz", i) 48 } 49}) 50 51succeeds <- function(x, quiet = FALSE) { 52 tryCatch( # 53 { 54 x 55 TRUE 56 }, 57 error = function(e) { 58 if (!quiet) { 59 inform(paste0("Error: ", e$message)) 60 } 61 FALSE 62 } 63 ) 64} 65 66is_1d <- function(x) { 67 # dimension check is for matrices and data.frames 68 (is_atomic(x) || is.list(x)) && length(dim(x)) <= 1 69} 70 71random_table_name <- function(n = 10) { 72 paste0(sample(letters, n, replace = TRUE), collapse = "") 73} 74 75attr_equal <- function(x, y) { 76 attr_x <- attributes(x) 77 if (!is.null(attr_x)) { 78 attr_x <- attr_x[sort(names(attr_x))] 79 } 80 81 attr_y <- attributes(y) 82 if (!is.null(attr_y)) { 83 attr_y <- attr_y[sort(names(attr_y))] 84 } 85 86 isTRUE(all.equal(attr_x, attr_y)) 87} 88 89unstructure <- function(x) { 90 attributes(x) <- NULL 91 x 92} 93 94compact_null <- function(x) { 95 Filter(function(elt) !is.null(elt), x) 96} 97 98paste_line <- function(...) { 99 paste(chr(...), collapse = "\n") 100} 101 102# Until fixed upstream. `vec_data()` should not return lists from data 103# frames. 104dplyr_vec_data <- function(x) { 105 out <- vec_data(x) 106 107 if (is.data.frame(x)) { 108 new_data_frame(out, n = nrow(x)) 109 } else { 110 out 111 } 112} 113 114# Until vctrs::new_data_frame() forwards row names automatically 115dplyr_new_data_frame <- function(x = data.frame(), 116 n = NULL, 117 ..., 118 row.names = NULL, 119 class = NULL) { 120 row.names <- row.names %||% .row_names_info(x, type = 0L) 121 122 new_data_frame( 123 x, 124 n = n, 125 ..., 126 row.names = row.names, 127 class = class 128 ) 129} 130 131maybe_restart <- function(restart) { 132 if (!is_null(findRestart(restart))) { 133 invokeRestart(restart) 134 } 135} 136 137expr_substitute <- function(expr, old, new) { 138 expr <- duplicate(expr) 139 switch(typeof(expr), 140 language = node_walk_replace(node_cdr(expr), old, new), 141 symbol = if (identical(expr, old)) return(new) 142 ) 143 expr 144} 145node_walk_replace <- function(node, old, new) { 146 while (!is_null(node)) { 147 switch(typeof(node_car(node)), 148 language = if (!is_call(node_car(node), c("~", "function")) || is_call(node_car(node), "~", n = 2)) node_walk_replace(node_cdar(node), old, new), 149 symbol = if (identical(node_car(node), old)) node_poke_car(node, new) 150 ) 151 node <- node_cdr(node) 152 } 153} 154