File: utils.R

package info (click to toggle)
r-cran-withr 3.0.2%2Bdfsg-1
  • links: PTS, VCS
  • area: main
  • in suites: forky, sid, trixie
  • size: 620 kB
  • sloc: sh: 13; makefile: 2
file content (99 lines) | stat: -rw-r--r-- 2,097 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
make_call <- function(...) {
  as.call(list(...))
}

vlapply <- function(X, FUN, ..., FUN.VALUE = logical(1)) {
  vapply(X, FUN, ..., FUN.VALUE = FUN.VALUE)
}

names2 <- function(x) {
  nms <- names(x)
  if (is.null(nms)) {
    rep("", length(x))
  } else {
    nms[is.na(nms)] <- ""
    nms
  }
}

#' Shim for tools::makevars_user()
#' @keywords internal
#' @export
makevars_user <- function() {
  if (getRversion() >= "3.3") {
    return(tools::makevars_user())
  }
  # Below is tools::makevars_user() from R 3.6.2
  m <- character()
  if (.Platform$OS.type == "windows") {
    if (!is.na(f <- Sys.getenv("R_MAKEVARS_USER", NA_character_))) {
      if (file.exists(f))
        m <- f
    }
    else if ((Sys.getenv("R_ARCH") == "/x64") && file.exists(f <- path.expand("~/.R/Makevars.win64")))
      m <- f
    else if (file.exists(f <- path.expand("~/.R/Makevars.win")))
      m <- f
    else if (file.exists(f <- path.expand("~/.R/Makevars")))
      m <- f
  }
  else {
    if (!is.na(f <- Sys.getenv("R_MAKEVARS_USER", NA_character_))) {
      if (file.exists(f))
        m <- f
    }
    else if (file.exists(f <- path.expand(paste0("~/.R/Makevars-",
            Sys.getenv("R_PLATFORM")))))
      m <- f
    else if (file.exists(f <- path.expand("~/.R/Makevars")))
      m <- f
  }
  m
}

as_character <- function(x) {
  nms <- names(x)
  res <- as.character(x)
  names(res) <- nms
  res
}

list_combine <- function(rhs, lhs) {
  for (nme in names(lhs)) {
    rhs[nme] <- lhs[nme]
  }
  rhs
}

# Helper to implement `options()`-like splicing
auto_splice <- function(x) {
  if (length(x) == 1 && is.null(names(x)) && is.list(x[[1]])) {
    x[[1]]
  } else {
    x
  }
}

setNames <- function(x = nm, nm) {
  names(x) <- nm
  x
}

# base implementation of rlang::is_interactive()
is_interactive <- function() {
  opt <- getOption("rlang_interactive")
  if (!is.null(opt)) {
    return(opt)
  }
  if (knitr_in_progress()) {
    return(FALSE)
  }
  if (identical(Sys.getenv("TESTTHAT"), "true")) {
    return(FALSE)
  }
  interactive()
}

`%||%` <- function(x, y) {
  if (is.null(x)) y else x
}