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