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