1
2repoman_data <- new.env(parent = emptyenv())
3
4`%||%` <- function(l, r) if (is.null(l)) r else l
5
6vcapply <- function(X, FUN, ...) {
7  vapply(X, FUN, FUN.VALUE = character(1), ...)
8}
9
10viapply <- function(X, FUN, ...) {
11  vapply(X, FUN, FUN.VALUE = integer(1), ...)
12}
13
14vlapply <- function(X, FUN, ...) {
15  vapply(X, FUN, FUN.VALUE = logical(1), ...)
16}
17
18vdapply <- function(X, FUN, ...) {
19  vapply(X, FUN, FUN.VALUE = double(1), ...)
20}
21
22# Like mapply, but better recycling rules, and no simplifying
23
24mapx <- function(...) {
25  args <- list(...)
26  if (length(args) == 0) stop("No arguments to `mapx()`")
27  fun <- args[[length(args)]]
28  if (!is.function(fun)) stop("Last `mapx()` argument not a function")
29  if (length(args) == 1) stop("No data to `mapx()`")
30  data <- args[-length(args)]
31
32  lens <- setdiff(unique(viapply(data, length)), 1L)
33  if (any(lens == 0)) {
34    data <- lapply(data, function(x) { length(x) <- 0; x })
35    lens <- 0
36  }
37  if (length(lens) > 1) {
38    stop(
39      "Incompatible data lengths in `mapx()`: ",
40       paste(lens, collapse = ", ")
41    )
42  }
43
44  do.call(
45    mapply,
46    c(list(FUN = fun, SIMPLIFY = FALSE, USE.NAMES = FALSE), data)
47  )
48}
49
50lapply_rows <-  function(df, fun, ...) {
51  lapply(seq_len(nrow(df)), function(i) fun(df[i,], ...))
52}
53
54zip_vecs <- function(...) {
55  mapply(c, ..., SIMPLIFY = FALSE, USE.NAMES = FALSE)
56}
57
58add_attr <- function(x, attr, value) {
59  attr(x, attr) <- value
60  x
61}
62
63get_platform <- function() {
64  R.version$platform
65}
66
67# Why are we using this?
68# AFAICT the only difference is that if `getOption("encoding")` is set,
69# then it is observed in `file()` and then `readLines()` converts the
70# file to UTF-8. (At least on R 4.1, earlier versions are probably
71# different.)
72#
73# OTOH it seems that we only use it to read the etag from a file, plus
74# in some test cases, so it should not matter much.
75
76read_lines <- function(con, ...) {
77  if (is.character(con)) {
78    con <- file(con)
79    on.exit(close(con))
80  }
81  readLines(con, ...)
82}
83
84dep_types_hard <- function() c("Depends", "Imports", "LinkingTo")
85dep_types_soft <- function() c("Suggests", "Enhances")
86dep_types <- function() c(dep_types_hard(), dep_types_soft())
87
88interpret_dependencies <- function(dp) {
89  hard <- dep_types_hard()
90
91  res <- if (isTRUE(dp)) {
92    list(c(hard, "Suggests"), hard)
93
94  } else if (identical(dp, FALSE)) {
95    list(character(), character())
96
97  } else if (is_na_scalar(dp)) {
98    list(hard, hard)
99
100  } else if (is.list(dp) && all(names(dp) == c("direct", "indirect"))) {
101    dp
102
103  } else {
104    list(dp, dp)
105  }
106
107  names(res) <- c("direct", "indirect")
108  res
109}
110
111## TODO: in theory the set of base packages can change over time,
112## so we would need an R version specific vector here.
113## Not an issue currently, might be in the future.
114
115base_packages <- function() {
116  if (is.null(repoman_data$base_packages)) {
117    repoman_data$base_packages <-
118      parse_installed(.Library, priority="base")$Package
119  }
120  repoman_data$base_packages
121}
122
123is_na_scalar <- function(x) {
124  identical(x, NA_character_) ||
125    identical(x, NA_integer_) ||
126    identical(x, NA_real_) ||
127    identical(x, NA_complex_) ||
128    identical(x, NA)
129}
130
131drop_nulls <- function(x)  {
132  x[! vlapply(x, is.null)]
133}
134
135null2na <- function(x) {
136  x %||% NA_character_
137}
138
139na_omit <- function(x) {
140  x[!is.na(x)]
141}
142
143#' @importFrom digest digest
144
145shasum256 <- function(x) {
146  digest(algo = "sha256", file = x)
147}
148
149file.size <- function (...) {
150  file.info(...)$size
151}
152
153msg_wrap <- function(..., .space = TRUE) {
154  ret <- paste(strwrap(paste0(...)), collapse = "\n")
155  if (.space) ret <- paste0("\n", ret, "\n")
156  ret
157}
158
159try_catch_null <- function(expr) {
160  tryCatch(expr, error = function(e) NULL)
161}
162
163run_examples <- function() {
164  if (Sys.getenv("_R_CHECK_PACKAGE_NAME_", "") == "") {
165    # If this is not a check, then OK
166    TRUE
167  } else if (identical(Sys.getenv("NOT_CRAN"), "true") &&
168      isTRUE(as.logical(Sys.getenv("CI")))) {
169    # If NOT_CRAN is set and we are on the CI, then we run examples
170    TRUE
171  } else {
172    FALSE
173  }
174}
175
176modify_vec <- function(old, new) {
177  old <- as.list(old)
178  new <- as.list(new)
179  unlist(utils::modifyList(old, new))
180}
181
182last <- function(x) {
183  x[[length(x)]]
184}
185
186get_os_type <- function() {
187  .Platform$OS.type
188}
189
190encode_path <- function(path) {
191  if (get_os_type() == "windows") {
192    enc2utf8(path)
193  } else {
194    enc2native(path)
195  }
196}
197
198gzip_decompress <- function(from, chunk_size = 5 * 1000 * 1000) {
199  con <- gzcon(rawConnection(from))
200  on.exit(close(con), add = TRUE)
201  pieces <- list()
202  while (1) {
203    pieces[[length(pieces) + 1]] <- readBin(con, what = "raw", n = chunk_size)
204    if (length(pieces[[length(pieces)]]) == 0) break;
205  }
206  do.call("c", pieces)
207}
208