1
2
3trim_ws <- function(x) {
4  sub("\\s*$", "", sub("^\\s*", "", x))
5}
6
7## from devtools, among other places
8compact <- function(x) {
9  is_empty <- vapply(x, function(x) length(x) == 0, logical(1))
10  x[!is_empty]
11}
12
13## from purrr, among other places
14`%||%` <- function(x, y) {
15  if (is.null(x)) {
16    y
17  } else {
18    x
19  }
20}
21
22## as seen in purrr, with the name `has_names()`
23has_name <- function(x) {
24  nms <- names(x)
25  if (is.null(nms)) {
26    rep_len(FALSE, length(x))
27  } else {
28    !(is.na(nms) | nms == "")
29  }
30}
31
32has_no_names <- function(x) all(!has_name(x))
33
34## if all names are "", strip completely
35cleanse_names <- function(x) {
36  if (has_no_names(x)) {
37    names(x) <- NULL
38  }
39  x
40}
41
42## to process HTTP headers, i.e. combine defaults w/ user-specified headers
43## in the spirit of modifyList(), except
44## x and y are vectors (not lists)
45## name comparison is case insensitive
46## http://www.w3.org/Protocols/rfc2616/rfc2616-sec4.html#sec4.2
47## x will be default headers, y will be user-specified
48modify_vector <- function(x, y = NULL) {
49  if (length(y) == 0L) return(x)
50  lnames <- function(x) tolower(names(x))
51  c(x[!(lnames(x) %in% lnames(y))], y)
52}
53
54
55discard <- function(.x, .p, ...) {
56  sel <- probe(.x, .p, ...)
57  .x[is.na(sel) | !sel]
58}
59probe <- function(.x, .p, ...) {
60  if (is.logical(.p)) {
61    stopifnot(length(.p) == length(.x))
62    .p
63  } else {
64    vapply(.x, .p, logical(1), ...)
65  }
66}
67
68drop_named_nulls <- function(x) {
69  if (has_no_names(x)) return(x)
70  named <- has_name(x)
71  null <- vapply(x, is.null, logical(1))
72  cleanse_names(x[! named | ! null])
73}
74
75check_named_nas <- function(x) {
76  if (has_no_names(x)) return(x)
77  named <- has_name(x)
78  na <- vapply(x, FUN.VALUE = logical(1), function(v) {
79    is.atomic(v) && anyNA(v)
80  })
81  bad <- which(named & na)
82  if (length(bad)) {
83    str <- paste0("`", names(x)[bad], "`", collapse = ", ")
84    stop("Named NA parameters are not allowed: ", str)
85  }
86}
87
88can_load <- function(pkg) {
89  isTRUE(requireNamespace(pkg, quietly = TRUE))
90}
91
92is_interactive <- function() {
93  opt <- getOption("rlib_interactive")
94  if (isTRUE(opt)) {
95    TRUE
96  } else if (identical(opt, FALSE)) {
97    FALSE
98  } else if (tolower(getOption("knitr.in.progress", "false")) == "true") {
99    FALSE
100  } else if (identical(Sys.getenv("TESTTHAT"), "true")) {
101    FALSE
102  } else {
103    interactive()
104  }
105}
106