diff --git a/.Rbuildignore b/.Rbuildignore index 8238cf43..b875423c 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -23,3 +23,5 @@ ^_pkgdown\.yml$ ^docs$ ^pkgdown$ +^[\.]?air\.toml$ +^\.vscode$ diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 2f8799a4..5c1a076d 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -8,7 +8,6 @@ on: push: branches: [main, master] pull_request: - branches: [main, master] workflow_dispatch: name: R-CMD-check.yaml diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index b692e859..2c657e3b 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -4,7 +4,6 @@ on: push: branches: [main, master] pull_request: - branches: [main, master] release: types: [published] workflow_dispatch: diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index bbefd990..97591a6a 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -4,7 +4,6 @@ on: push: branches: [main, master] pull_request: - branches: [main, master] workflow_dispatch: name: test-coverage.yaml @@ -42,14 +41,16 @@ jobs: clean = FALSE, install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") ) + print(cov) covr::to_cobertura(cov) shell: Rscript {0} - - uses: codecov/codecov-action@v4 + - uses: codecov/codecov-action@v5 with: - fail_ci_if_error: ${{ github.event_name != 'pull_request' && true || false }} - file: ./cobertura.xml - plugin: noop + # Fail if error if not on PR, or if on PR and token is given + fail_ci_if_error: ${{ github.event_name != 'pull_request' || secrets.CODECOV_TOKEN }} + files: ./cobertura.xml + plugins: noop disable_search: true token: ${{ secrets.CODECOV_TOKEN }} diff --git a/.vscode/extensions.json b/.vscode/extensions.json new file mode 100644 index 00000000..344f76eb --- /dev/null +++ b/.vscode/extensions.json @@ -0,0 +1,5 @@ +{ + "recommendations": [ + "Posit.air-vscode" + ] +} diff --git a/.vscode/settings.json b/.vscode/settings.json new file mode 100644 index 00000000..f2d0b79d --- /dev/null +++ b/.vscode/settings.json @@ -0,0 +1,6 @@ +{ + "[r]": { + "editor.formatOnSave": true, + "editor.defaultFormatter": "Posit.air-vscode" + } +} diff --git a/DESCRIPTION b/DESCRIPTION index c42fd4c3..83f33ffb 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -3,7 +3,8 @@ Title: Cache 'CRAN'-Like Metadata and R Packages Version: 2.2.3.9000 Authors@R: c( person("Gábor", "Csárdi", , "csardi.gabor@gmail.com", role = c("aut", "cre")), - person("Posit Software, PBC", role = c("cph", "fnd")) + person("Posit Software, PBC", role = c("cph", "fnd"), + comment = c(ROR = "03wc8by49")) ) Description: Metadata and package cache for CRAN-like repositories. This is a utility package to be used by package management tools that want @@ -40,7 +41,8 @@ Suggests: zip Config/Needs/website: tidyverse/tidytemplate Config/testthat/edition: 3 +Config/usethis/last-upkeep: 2025-04-30 Encoding: UTF-8 Language: en-US Roxygen: list(markdown = TRUE, r6 = FALSE) -RoxygenNote: 7.3.2 +RoxygenNote: 7.3.2.9000 diff --git a/LICENSE b/LICENSE index 555a7c1f..b8d909ac 100644 --- a/LICENSE +++ b/LICENSE @@ -1,2 +1,2 @@ -YEAR: 2023 +YEAR: 2025 COPYRIGHT HOLDER: pkgcache authors diff --git a/LICENSE.md b/LICENSE.md index 82a828b5..31fe4048 100644 --- a/LICENSE.md +++ b/LICENSE.md @@ -1,6 +1,6 @@ # MIT License -Copyright (c) 2023 pkgcache authors +Copyright (c) 2025 pkgcache authors Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/R/aa-assertthat.R b/R/aa-assertthat.R index 2a7679fc..5d1d4900 100644 --- a/R/aa-assertthat.R +++ b/R/aa-assertthat.R @@ -1,4 +1,3 @@ - assert_that <- function(..., env = parent.frame(), msg = NULL) { res <- see_if(..., env = env, msg = msg) if (res) return(TRUE) @@ -6,7 +5,7 @@ assert_that <- function(..., env = parent.frame(), msg = NULL) { throw(new_assert_error(attr(res, "msg"))) } -new_assert_error <- function (message, call = NULL) { +new_assert_error <- function(message, call = NULL) { cond <- new_error(message, call. = call) class(cond) <- c("assert_error", class(cond)) cond @@ -16,17 +15,19 @@ see_if <- function(..., env = parent.frame(), msg = NULL) { asserts <- eval(substitute(alist(...))) for (assertion in asserts) { - res <- tryCatch({ - eval(assertion, env) - }, error = function(e) { - structure(FALSE, msg = e$message) - }) + res <- tryCatch( + { + eval(assertion, env) + }, + error = function(e) { + structure(FALSE, msg = e$message) + } + ) check_result(res) # Failed, so figure out message to produce if (!res) { - if (is.null(msg)) - msg <- get_message(res, assertion, env) + if (is.null(msg)) msg <- get_message(res, assertion, env) return(structure(FALSE, msg = msg)) } } @@ -36,7 +37,9 @@ see_if <- function(..., env = parent.frame(), msg = NULL) { check_result <- function(x) { if (!is.logical(x)) - throw(new_assert_error("assert_that: assertion must return a logical value")) + throw(new_assert_error( + "assert_that: assertion must return a logical value" + )) if (any(is.na(x))) throw(new_assert_error("assert_that: missing values present in assertion")) if (length(x) != 1) { @@ -68,7 +71,7 @@ get_message <- function(res, call, env = parent.frame()) { fail_default <- function(call, env) { call_string <- deparse(call, width.cutoff = 60L) if (length(call_string) > 1L) { - call_string <- paste0(call_string[1L], "...") + call_string <- paste0(call_string[1L], "...") } paste0(call_string, " is not TRUE") diff --git a/R/aaa-async.R b/R/aaa-async.R index e302cdd9..2227751a 100644 --- a/R/aaa-async.R +++ b/R/aaa-async.R @@ -1,4 +1,3 @@ - #' Create an async function #' #' Create an async function, that returns a deferred value, from a @@ -30,8 +29,8 @@ async <- function(fun) { mget(ls(environment(), all.names = TRUE), environment()) fun2 <- function() { evalq( - .(body(fun)), - envir = parent.env(environment()) + .(body(fun)), + envir = parent.env(environment()) ) } @@ -180,10 +179,16 @@ on_failure(is_flag) <- function(call, env) { #' tryCatch(synchronise(afun()), error = function(e) e) #' } -async_backoff <- function(task, ..., .args = list(), times = Inf, - time_limit = Inf, custom_backoff = NULL, - on_progress = NULL, progress_data = NULL) { - +async_backoff <- function( + task, + ..., + .args = list(), + times = Inf, + time_limit = Inf, + custom_backoff = NULL, + on_progress = NULL, + progress_data = NULL +) { task <- async(task) args <- c(list(...), .args) times <- times @@ -197,7 +202,8 @@ async_backoff <- function(task, ..., .args = list(), times = Inf, limit <- NULL self <- deferred$new( - type = "backoff", call = sys.call(), + type = "backoff", + call = sys.call(), action = function(resolve) { started <<- Sys.time() limit <<- started + time_limit @@ -209,26 +215,30 @@ async_backoff <- function(task, ..., .args = list(), times = Inf, if (did < times && now < limit) { wait <- custom_backoff(did) if (!is.null(on_progress)) { - on_progress(list( - event = "retry", - tries = did, - spent = now - started, - error = value, - retry_in = wait - ), progress_data) + on_progress( + list( + event = "retry", + tries = did, + spent = now - started, + error = value, + retry_in = wait + ), + progress_data + ) } - delay(wait)$ - then(function() do.call(task, args))$ - then(self) + delay(wait)$then(function() do.call(task, args))$then(self) } else { if (!is.null(on_progress)) { - on_progress(list( - event = "givenup", - tries = did, - spent = now - started, - error = value, - retry_in = NA_real_ - ), progress_data) + on_progress( + list( + event = "givenup", + tries = did, + spent = now - started, + error = value, + retry_in = NA_real_ + ), + progress_data + ) } stop(value) } @@ -255,18 +265,21 @@ default_backoff <- function(i) { #' @noRd call_function <- function(func, args = list()) { - func; args + func + args id <- NULL deferred$new( - type = "pool-task", call = sys.call(), + type = "pool-task", + call = sys.call(), action = function(resolve) { resolve reject <- environment(resolve)$private$reject id <<- get_default_event_loop()$add_pool_task( function(err, res) if (is.null(err)) resolve(res) else reject(err), - list(func = func, args = args)) + list(func = func, args = args) + ) }, on_cancel = function(reason) { if (!is.null(id)) { @@ -300,8 +313,10 @@ call_function <- mark_as_async(call_function) async_constant <- function(value = NULL) { force(value) deferred$new( - type = "constant", call = sys.call(), - function(resolve) resolve(value)) + type = "constant", + call = sys.call(), + function(resolve) resolve(value) + ) } async_constant <- mark_as_async(async_constant) @@ -440,7 +455,7 @@ async_next <- function(el = NULL) { el <- el %||% find_sync_frame()$new_el if (is.null(el)) stop("No async context") ## TODO: some visual indication that something has happened? - if (! el$run("once")) message("[ASYNC] async phase complete") + if (!el$run("once")) message("[ASYNC] async phase complete") } # nocov start @@ -455,7 +470,7 @@ async_step <- function() { ## TODO: some visual indication that something has happened? old <- options(async_debug_steps = TRUE) on.exit(options(old)) - if (! el$run("once")) { + if (!el$run("once")) { message("[ASYNC] async phase complete") } } @@ -560,8 +575,11 @@ async_wait_for <- function(id) { #' @aliases .aw #' @rdname async_debug -async_where <- function(calls = sys.calls(), parents = sys.parents(), - frm = get_async_frames()) { +async_where <- function( + calls = sys.calls(), + parents = sys.parents(), + frm = get_async_frames() +) { afrm <- viapply(frm, "[[", "frame") num <- seq_along(calls) @@ -607,29 +625,49 @@ print.async_where <- function(x, ...) { #' @noRd format.async_where <- function(x, ...) { - paste0(paste( - formatC(seq_len(nrow(x)), width = 3), - vcapply(x$call, expr_name), - paste0(" ", x$filename, ":", x$position), - ifelse (! x$async, "", - paste0("\n ", x$def_id, " ", x$def_cb_type, " ", - x$def_call, " ", x$def_filename, ":", x$def_position)), - collapse = "\n" - ), "\n") + paste0( + paste( + formatC(seq_len(nrow(x)), width = 3), + vcapply(x$call, expr_name), + paste0(" ", x$filename, ":", x$position), + ifelse( + !x$async, + "", + paste0( + "\n ", + x$def_id, + " ", + x$def_cb_type, + " ", + x$def_call, + " ", + x$def_filename, + ":", + x$def_position + ) + ), + collapse = "\n" + ), + "\n" + ) } get_async_frames <- function() { drop_nulls(lapply(seq_along(sys.frames()), function(i) { - if (! is.null(data <- sys.frame(i)$`__async_data__`)) { - list(frame = i + data$skip %||% 1L, deferred = data[[1]], type = data[[2]], - call = get_private(data[[3]])$mycall) + if (!is.null(data <- sys.frame(i)$`__async_data__`)) { + list( + frame = i + data$skip %||% 1L, + deferred = data[[1]], + type = data[[2]], + call = get_private(data[[3]])$mycall + ) } })) } find_sync_frame <- function() { for (i in seq_along(sys.frames())) { - cand <- sys.frame(-i) + cand <- sys.frame(-i) if (isTRUE(cand$`__async_synchronise_frame__`)) return(cand) } } @@ -637,7 +675,7 @@ find_sync_frame <- function() { find_async_data_frame <- function() { frames <- sys.frames() for (i in seq_along(frames)) { - cand <- sys.frame(-i) + cand <- sys.frame(-i) if (!is.null(data <- cand$`__async_data__`)) { return(list(frame = length(frames) - i + 1L, data = data)) } @@ -683,9 +721,9 @@ async_debug_shortcuts <- function() { async_debug_remove_shortcuts <- function() { tryCatch( - rm(list = c(".an", ".as", ".asb", ".al", ".at", ".aw"), - envir = .GlobalEnv), - error = function(x) x) + rm(list = c(".an", ".as", ".asb", ".al", ".at", ".aw"), envir = .GlobalEnv), + error = function(x) x + ) } # nocov end @@ -1084,22 +1122,38 @@ NULL deferred <- R6Class( "deferred", public = list( - initialize = function(action = NULL, on_progress = NULL, on_cancel = NULL, - parents = NULL, parent_resolve = NULL, - parent_reject = NULL, type = NULL, - call = sys.call(-1), event_emitter = NULL) - async_def_init(self, private, action, on_progress, on_cancel, - parents, parent_resolve, parent_reject, type, call, - event_emitter), - then = function(on_fulfilled) - def_then(self, private, on_fulfilled), - catch = function(...) - def_catch(self, private, ...), - finally = function(on_finally) - def_finally(self, private, on_finally), - cancel = function(reason = "Cancelled") - def_cancel(self, private, reason), - share = function() { private$shared <<- TRUE; invisible(self) }, + initialize = function( + action = NULL, + on_progress = NULL, + on_cancel = NULL, + parents = NULL, + parent_resolve = NULL, + parent_reject = NULL, + type = NULL, + call = sys.call(-1), + event_emitter = NULL + ) + async_def_init( + self, + private, + action, + on_progress, + on_cancel, + parents, + parent_resolve, + parent_reject, + type, + call, + event_emitter + ), + then = function(on_fulfilled) def_then(self, private, on_fulfilled), + catch = function(...) def_catch(self, private, ...), + finally = function(on_finally) def_finally(self, private, on_finally), + cancel = function(reason = "Cancelled") def_cancel(self, private, reason), + share = function() { + private$shared <<- TRUE + invisible(self) + }, event_emitter = NULL ), @@ -1123,38 +1177,40 @@ deferred <- R6Class( shared = FALSE, mycall = NULL, - run_action = function() - def__run_action(self, private), + run_action = function() def__run_action(self, private), - null = function() - def__null(self, private), + null = function() def__null(self, private), - resolve = function(value) - def__resolve(self, private, value), - reject = function(reason) - def__reject(self, private, reason), - progress = function(data) - def__progress(self, private, data), + resolve = function(value) def__resolve(self, private, value), + reject = function(reason) def__reject(self, private, reason), + progress = function(data) def__progress(self, private, data), make_error_object = function(err) def__make_error_object(self, private, err), maybe_cancel_parents = function(reason) def__maybe_cancel_parents(self, private, reason), - add_as_parent = function(child) - def__add_as_parent(self, private, child), + add_as_parent = function(child) def__add_as_parent(self, private, child), update_parent = function(old, new) def__update_parent(self, private, old, new), - get_info = function() - def__get_info(self, private) + get_info = function() def__get_info(self, private) ) ) -async_def_init <- function(self, private, action, on_progress, - on_cancel, parents, parent_resolve, - parent_reject, type, call, event_emitter) { - +async_def_init <- function( + self, + private, + action, + on_progress, + on_cancel, + parents, + parent_resolve, + parent_reject, + type, + call, + event_emitter +) { private$type <- type private$id <- get_id() private$event_loop <- get_default_event_loop() @@ -1207,8 +1263,10 @@ def__run_action <- function(self, private) { function() { if (isTRUE(getOption("async_debug_steps", FALSE))) debug1(action) `__async_data__` <- list(private$id, "action", self, skip = 2L) - do.call(action, args) }, - function(err, res) if (!is.null(err)) private$reject(err)) + do.call(action, args) + }, + function(err, res) if (!is.null(err)) private$reject(err) + ) } ## If some parents are done, we want them to notify us. @@ -1217,22 +1275,25 @@ def__run_action <- function(self, private) { prt_priv <- get_private(prt) if (prt_priv$state != "pending") { def__call_then( - if (prt_priv$state == "fulfilled") "parent_resolve" else "parent_reject", - self, prt_priv$value) + if (prt_priv$state == "fulfilled") "parent_resolve" else + "parent_reject", + self, + prt_priv$value + ) } prt_priv$run_action() } } -def_then <- function(self, private, on_fulfilled = NULL, - on_rejected = NULL) { +def_then <- function(self, private, on_fulfilled = NULL, on_rejected = NULL) { force(self) force(private) - if (! identical(private$event_loop, get_default_event_loop())) { + if (!identical(private$event_loop, get_default_event_loop())) { err <- make_error( "Cannot create deferred chain across synchronization barrier", - class = "async_synchronization_barrier_error") + class = "async_synchronization_barrier_error" + ) stop(err) } @@ -1240,12 +1301,13 @@ def_then <- function(self, private, on_fulfilled = NULL, parent_resolve <- def__make_parent_resolve(on_fulfilled) parent_reject <- def__make_parent_reject(on_rejected) - deferred$new(parents = list(self), - type = paste0("then-", private$id), - parent_resolve = parent_resolve, - parent_reject = parent_reject, - call = sys.call(-1)) - + deferred$new( + parents = list(self), + type = paste0("then-", private$id), + parent_resolve = parent_resolve, + parent_reject = parent_reject, + call = sys.call(-1) + ) } else { private$add_as_parent(on_fulfilled) child_private <- get_private(on_fulfilled) @@ -1309,13 +1371,11 @@ def__resolve <- function(self, private, value) { } val_pvt$run_action() - } else { - if (!private$dead_end && !length(private$children) && - !private$shared) { + if (!private$dead_end && !length(private$children) && !private$shared) { ## This cannot happen currently - "!DEBUG ??? DEAD END `private$id`" # nocov - warning("Computation going nowhere...") # nocov + "!DEBUG ??? DEAD END `private$id`" # nocov + warning("Computation going nowhere...") # nocov } "!DEBUG +++ RESOLVE `private$id`" @@ -1355,8 +1415,7 @@ def__make_parent_resolve <- function(fun) { function(value, resolve) resolve(fun()) } else if (num_args(fun) == 1) { function(value, resolve) resolve(fun(value)) - } else if (identical(names(formals(fun)), - c("value", "resolve"))) { + } else if (identical(names(formals(fun)), c("value", "resolve"))) { fun } else { stop("Invalid parent_resolve callback") @@ -1375,8 +1434,7 @@ def__make_parent_reject <- function(fun) { function(value, resolve) resolve(fun()) } else if (num_args(fun) == 1) { function(value, resolve) resolve(fun(value)) - } else if (identical(names(formals(fun)), - c("value", "resolve"))) { + } else if (identical(names(formals(fun)), c("value", "resolve"))) { fun } else { stop("Invalid parent_reject callback") @@ -1387,12 +1445,15 @@ def__make_parent_reject_catch <- function(handlers) { handlers <- lapply(handlers, as.function) function(value, resolve) { ok <- FALSE - ret <- tryCatch({ - quo <- as.call(c(list(quote(tryCatch), quote(stop(value))), handlers)) - ret <- eval(quo) - ok <- TRUE - ret - }, error = function(x) x) + ret <- tryCatch( + { + quo <- as.call(c(list(quote(tryCatch), quote(stop(value))), handlers)) + ret <- eval(quo) + ok <- TRUE + ret + }, + error = function(x) x + ) if (ok) resolve(ret) else stop(ret) } @@ -1431,8 +1492,8 @@ def__maybe_cancel_parents <- function(self, private, reason) { } } -def__call_then <- function(which, x, value) { - force(value); +def__call_then <- function(which, x, value) { + force(value) private <- get_private(x) if (!private$running) return() if (private$state != "pending") return() @@ -1441,21 +1502,23 @@ def__call_then <- function(which, x, value) { private$event_loop$add_next_tick( function() { if (isTRUE(getOption("async_debug_steps", FALSE))) { - debug1(private[[which]]) # nocov + debug1(private[[which]]) # nocov } `__async_data__` <- list(private$id, "parent", x) private[[which]](value, private$resolve) }, - function(err, res) if (!is.null(err)) private$reject(err)) + function(err, res) if (!is.null(err)) private$reject(err) + ) } def__add_as_parent <- function(self, private, child) { "!DEBUG EDGE [`private$id` -> `get_private(child)$id`]" - if (! identical(private$event_loop, get_private(child)$event_loop)) { + if (!identical(private$event_loop, get_private(child)$event_loop)) { err <- make_error( "Cannot create deferred chain across synchronization barrier", - class = "async_synchronization_barrier_error") + class = "async_synchronization_barrier_error" + ) stop(err) } if (length(private$children) && !private$shared) { @@ -1467,10 +1530,8 @@ def__add_as_parent <- function(self, private, child) { if (get_private(child)$running) private$run_action() if (private$state == "pending") { ## Nothing to do - } else if (private$state == "fulfilled") { def__call_then("parent_resolve", child, private$value) - } else { def__call_then("parent_reject", child, private$value) } @@ -1500,8 +1561,11 @@ def__get_info <- function(self, private) { parents = I(list(viapply(private$parents, function(x) get_private(x)$id))), label = as.character(private$id), call = I(list(private$mycall)), - children = I(list(viapply(private$children, function(x) get_private(x)$id))), - type = private$type %||% "unknown", + children = I(list(viapply( + private$children, + function(x) get_private(x)$id + ))), + type = private$type %||% "unknown", running = private$running, state = private$state, cancelled = private$cancelled, @@ -1511,11 +1575,16 @@ def__get_info <- function(self, private) { res$filename <- src$filename res$position <- src$position res$label <- paste0( - res$id, " ", + res$id, + " ", if (private$state == "fulfilled") paste0(cli::symbol$tick, " "), - if (private$state == "rejected") paste0(cli::symbol$cross, " "), - deparse(private$mycall)[1], " @ ", - res$filename, ":", res$position) + if (private$state == "rejected") paste0(cli::symbol$cross, " "), + deparse(private$mycall)[1], + " @ ", + res$filename, + ":", + res$position + ) res } @@ -1567,7 +1636,8 @@ delay <- function(delay) { force(delay) id <- NULL deferred$new( - type = "delay", call = sys.call(), + type = "delay", + call = sys.call(), action = function(resolve) { assert_that(is_time_interval(delay)) force(resolve) @@ -1624,7 +1694,8 @@ async_detect_nolimit <- function(.x, .p, ...) { done <- FALSE self <- deferred$new( - type = "async_detect", call = sys.call(), + type = "async_detect", + call = sys.call(), action = function(resolve) { lapply(seq_along(defs), function(idx) { defs[[idx]]$then(function(val) if (isTRUE(val)) idx)$then(self) @@ -1654,7 +1725,8 @@ async_detect_limit <- function(.x, .p, ..., .limit = .limit) { firsts <- lapply(.x[seq_len(.limit)], .p, ...) self <- deferred$new( - type = "async_detect (limit)", call = sys.call(), + type = "async_detect (limit)", + call = sys.call(), action = function(resolve) { lapply(seq_along(firsts), function(idx) { firsts[[idx]]$then(function(val) if (isTRUE(val)) idx)$then(self) @@ -1687,12 +1759,15 @@ async_detect_limit <- function(.x, .p, ..., .limit = .limit) { event_loop <- R6Class( "event_loop", public = list( - initialize = function() - el_init(self, private), - - add_http = function(handle, callback, file = NULL, progress = NULL, - data = NULL) - el_add_http(self, private, handle, callback, file, progress, data), + initialize = function() el_init(self, private), + + add_http = function( + handle, + callback, + file = NULL, + progress = NULL, + data = NULL + ) el_add_http(self, private, handle, callback, file, progress, data), http_setopt = function(total_con = NULL, host_con = NULL, multiplex = NULL) el_http_setopt(self, private, total_con, host_con, multiplex), @@ -1707,39 +1782,27 @@ event_loop <- R6Class( add_next_tick = function(func, callback, data = NULL) el_add_next_tick(self, private, func, callback, data), - cancel = function(id) - el_cancel(self, private, id), - cancel_all = function() - el_cancel_all(self, private), + cancel = function(id) el_cancel(self, private, id), + cancel_all = function() el_cancel_all(self, private), run = function(mode = c("default", "nowait", "once")) el_run(self, private, mode = match.arg(mode)), - suspend = function() - el_suspend(self, private), - wakeup = function() - el_wakeup(self, private) + suspend = function() el_suspend(self, private), + wakeup = function() el_wakeup(self, private) ), private = list( - create_task = function(callback, ..., id = NULL, type = "foobar") + create_task = function(callback, ..., id = NULL, type = "foobar") el__create_task(self, private, callback, ..., id = id, type = type), - ensure_pool = function() - el__ensure_pool(self, private), - get_poll_timeout = function() - el__get_poll_timeout(self, private), - run_pending = function() - el__run_pending(self, private), - run_timers = function() - el__run_timers(self, private), - is_alive = function() - el__is_alive(self, private), - update_time = function() - el__update_time(self, private), - io_poll = function(timeout) - el__io_poll(self, private, timeout), - update_curl_data = function() - el__update_curl_data(self, private), + ensure_pool = function() el__ensure_pool(self, private), + get_poll_timeout = function() el__get_poll_timeout(self, private), + run_pending = function() el__run_pending(self, private), + run_timers = function() el__run_timers(self, private), + is_alive = function() el__is_alive(self, private), + update_time = function() el__update_time(self, private), + io_poll = function(timeout) el__io_poll(self, private, timeout), + update_curl_data = function() el__update_curl_data(self, private), id = NULL, time = Sys.time(), @@ -1747,9 +1810,9 @@ event_loop <- R6Class( tasks = list(), timers = Sys.time()[numeric()], pool = NULL, - curl_fdset = NULL, # return value of multi_fdset() - curl_poll = TRUE, # should we poll for curl sockets? - curl_timer = NULL, # call multi_run() before this + curl_fdset = NULL, # return value of multi_fdset() + curl_poll = TRUE, # should we poll for curl sockets? + curl_timer = NULL, # call multi_run() before this next_ticks = character(), worker_pool = NULL, http_opts = NULL @@ -1761,12 +1824,20 @@ el_init <- function(self, private) { invisible(self) } -el_add_http <- function(self, private, handle, callback, progress, file, - data) { - self; private; handle; callback; progress; outfile <- file; data +el_add_http <- function(self, private, handle, callback, progress, file, data) { + self + private + handle + callback + progress + outfile <- file + data - id <- private$create_task(callback, list(handle = handle, data = data), - type = "http") + id <- private$create_task( + callback, + list(handle = handle, data = data), + type = "http" + ) private$ensure_pool() if (!is.null(outfile)) cat("", file = outfile) @@ -1794,7 +1865,10 @@ el_add_http <- function(self, private, handle, callback, progress, file, ## so limited in their numbers. con <- tryCatch( file(outfile, open = "ab"), - error = function(e) { gc(); file(outfile, open = "ab") } # nocov + error = function(e) { + gc() + file(outfile, open = "ab") + } # nocov ) writeBin(bytes, con) close(con) @@ -1806,8 +1880,11 @@ el_add_http <- function(self, private, handle, callback, progress, file, task <- private$tasks[[id]] private$tasks[[id]] <- NULL error <- make_error(message = error) - class(error) <- unique(c("async_rejected", "async_http_error", - class(error))) + class(error) <- unique(c( + "async_rejected", + "async_http_error", + class(error) + )) task$callback(error, NULL) } ) @@ -1815,19 +1892,30 @@ el_add_http <- function(self, private, handle, callback, progress, file, } el_add_process <- function(self, private, conns, callback, data) { - self; private; conns; callback; data + self + private + conns + callback + data data$conns <- conns private$create_task(callback, data, type = "process") } el_add_r_process <- function(self, private, conns, callback, data) { - self; private; conns; callback; data + self + private + conns + callback + data data$conns <- conns private$create_task(callback, data, type = "r-process") } el_add_pool_task <- function(self, private, callback, data) { - self; private; callback; data + self + private + callback + data id <- private$create_task(callback, data, type = "pool-task") if (is.null(async_env$worker_pool)) { async_env$worker_pool <- worker_pool$new() @@ -1837,7 +1925,11 @@ el_add_pool_task <- function(self, private, callback, data) { } el_add_delayed <- function(self, private, delay, func, callback, rep) { - force(self); force(private); force(delay); force(func); force(callback) + force(self) + force(private) + force(delay) + force(func) + force(callback) force(rep) id <- private$create_task( callback, @@ -1851,7 +1943,10 @@ el_add_delayed <- function(self, private, delay, func, callback, rep) { } el_add_next_tick <- function(self, private, func, callback, data) { - force(self) ; force(private) ; force(callback); force(data) + force(self) + force(private) + force(callback) + force(data) data$func <- func id <- private$create_task(callback, data = data, type = "nexttick") private$next_ticks <- c(private$next_ticks, id) @@ -1859,14 +1954,18 @@ el_add_next_tick <- function(self, private, func, callback, data) { el_cancel <- function(self, private, id) { private$next_ticks <- setdiff(private$next_ticks, id) - private$timers <- private$timers[setdiff(names(private$timers), id)] + private$timers <- private$timers[setdiff(names(private$timers), id)] if (id %in% names(private$tasks) && private$tasks[[id]]$type == "http") { curl::multi_cancel(private$tasks[[id]]$data$handle) - } else if (id %in% names(private$tasks) && - private$tasks[[id]]$type %in% c("process", "r-process")) { + } else if ( + id %in% + names(private$tasks) && + private$tasks[[id]]$type %in% c("process", "r-process") + ) { private$tasks[[id]]$data$process$kill() - } else if (id %in% names(private$tasks) && - private$tasks[[id]]$type == "pool-task") { + } else if ( + id %in% names(private$tasks) && private$tasks[[id]]$type == "pool-task" + ) { async_env$worker_pool$cancel_task(id) } private$tasks[[id]] <- NULL @@ -1886,17 +1985,16 @@ el_cancel_all <- function(self, private) { self$cancel(id) } - private$tasks <- list() + private$tasks <- list() invisible(self) } el_run <- function(self, private, mode) { - ## This is closely modeled after the libuv event loop, on purpose, ## because some time we might switch to that. alive <- private$is_alive() - if (! alive) private$update_time() + if (!alive) private$update_time() while (alive && !private$stop_flag) { private$update_time() @@ -1946,8 +2044,11 @@ el__run_pending <- function(self, private) { for (id in next_ticks) { task <- private$tasks[[id]] private$tasks[[id]] <- NULL - call_with_callback(task$data$func, task$callback, - info = task$data$error_info) + call_with_callback( + task$data$func, + task$callback, + info = task$data$error_info + ) } ## Check for workers from the pool finished before, while another @@ -1971,7 +2072,6 @@ el__run_pending <- function(self, private) { } el__io_poll <- function(self, private, timeout) { - types <- vcapply(private$tasks, "[[", "type") ## The things we need to poll, and their types @@ -1991,22 +2091,28 @@ el__io_poll <- function(self, private, timeout) { id = "curl", pollable = I(list(processx::curl_fds(private$curl_fdset))), type = "curl", - ready = "silent") + ready = "silent" + ) pollables <- rbind(pollables, curl_pollables) } ## Processes proc <- types %in% c("process", "r-process") if (sum(proc)) { - conns <- unlist(lapply( - private$tasks[proc], function(t) t$data$conns), - recursive = FALSE) + conns <- unlist( + lapply( + private$tasks[proc], + function(t) t$data$conns + ), + recursive = FALSE + ) proc_pollables <- data.frame( stringsAsFactors = FALSE, id = names(private$tasks)[proc], pollable = I(conns), type = types[proc], - ready = rep("silent", sum(proc))) + ready = rep("silent", sum(proc)) + ) pollables <- rbind(pollables, proc_pollables) } @@ -2020,7 +2126,8 @@ el__io_poll <- function(self, private, timeout) { id = names(px_pool), pollable = I(px_pool), type = rep("pool", length(px_pool)), - ready = rep("silent", length(px_pool))) + ready = rep("silent", length(px_pool)) + ) pollables <- rbind(pollables, pool_pollables) } @@ -2030,18 +2137,20 @@ el__io_poll <- function(self, private, timeout) { } if (nrow(pollables)) { - ## OK, ready to poll pollables$ready <- unlist(processx::poll(pollables$pollable, timeout)) ## Any HTTP? - if (private$curl_poll && - pollables$ready[match("curl", pollables$type)] == "event") { + if ( + private$curl_poll && + pollables$ready[match("curl", pollables$type)] == "event" + ) { curl::multi_run(timeout = 0L, poll = TRUE, pool = private$pool) } ## Any processes - proc_ready <- pollables$type %in% c("process", "r-process") & + proc_ready <- pollables$type %in% + c("process", "r-process") & pollables$ready == "ready" for (id in pollables$id[proc_ready]) { p <- private$tasks[[id]] @@ -2058,9 +2167,15 @@ el__io_poll <- function(self, private, timeout) { error <- FALSE if (p$type == "r-process") { - res$result <- tryCatch({ - p$data$process$get_result() - }, error = function(e) { error <<- TRUE; e }) + res$result <- tryCatch( + { + p$data$process$get_result() + }, + error = function(e) { + error <<- TRUE + e + } + ) } unlink(c(p$data$stdout, p$data$stderr)) @@ -2079,8 +2194,10 @@ el__io_poll <- function(self, private, timeout) { pool_ready <- pollables$type == "pool" & pollables$ready == "ready" if (sum(pool_ready)) { pool <- async_env$worker_pool - done <- pool$notify_event(as.integer(pollables$id[pool_ready]), - event_loop = private$id) + done <- pool$notify_event( + as.integer(pollables$id[pool_ready]), + event_loop = private$id + ) mine <- intersect(done, names(private$tasks)) for (tid in mine) { task <- private$tasks[[tid]] @@ -2091,7 +2208,6 @@ el__io_poll <- function(self, private, timeout) { task$callback(err, res) } } - } else if (length(private$timers) || !is.null(private$curl_timer)) { Sys.sleep(timeout / 1000) } @@ -2120,12 +2236,12 @@ el__ensure_pool <- function(self, private) { if (is.null(private$pool)) { private$http_opts <- list( total_con = getopt("total_con") %||% 100, - host_con = getopt("host_con") %||% 6, - multiplex = getopt("multiplex") %||% TRUE + host_con = getopt("host_con") %||% 6, + multiplex = getopt("multiplex") %||% TRUE ) private$pool <- curl::new_pool( total_con = private$http_opts$total_con, - host_con = private$http_opts$host_con, + host_con = private$http_opts$host_con, multiplex = private$http_opts$multiplex ) } @@ -2134,7 +2250,7 @@ el__ensure_pool <- function(self, private) { el_http_setopt <- function(self, private, total_con, host_con, multiplex) { private$ensure_pool() if (!is.null(total_con)) private$http_opts$total_con <- total_con - if (!is.null(host_con)) private$http_opts$host_con <- host_con + if (!is.null(host_con)) private$http_opts$host_con <- host_con if (!is.null(multiplex)) private$http_opts$multiplex <- multiplex curl::multi_set( pool = private$pool, @@ -2162,7 +2278,6 @@ el__get_poll_timeout <- function(self, private) { } el__run_timers <- function(self, private) { - expired <- names(private$timers)[private$timers <= private$time] expired <- expired[order(private$timers[expired])] for (id in expired) { @@ -2284,8 +2399,7 @@ el__update_curl_data <- function(self, private) { event_emitter <- R6Class( "event_emitter", public = list( - initialize = function(async = TRUE) - ee_init(self, private, async), + initialize = function(async = TRUE) ee_init(self, private, async), listen_on = function(event, callback) ee_listen_on(self, private, event, callback), @@ -2296,11 +2410,9 @@ event_emitter <- R6Class( listen_once = function(event, callback) ee_listen_once(self, private, event, callback), - emit = function(event, ...) - ee_emit(self, private, event, ...), + emit = function(event, ...) ee_emit(self, private, event, ...), - get_event_names = function() - ee_get_event_names(self, private), + get_event_names = function() ee_get_event_names(self, private), get_listener_count = function(event) ee_get_listener_count(self, private, event), @@ -2313,8 +2425,7 @@ event_emitter <- R6Class( lsts = NULL, async = NULL, - cleanup_events = function() - ee__cleanup_events(self, private), + cleanup_events = function() ee__cleanup_events(self, private), error_callback = function(err, res) ee__error_callback(self, private, err, res) ) @@ -2367,13 +2478,14 @@ ee_emit <- function(self, private, event, ...) { get_default_event_loop()$add_next_tick( function() lst$cb(...), private$error_callback, - data = list(error_info = list(event = event))) - + data = list(error_info = list(event = event)) + ) } else { call_with_callback( function() lst$cb(...), private$error_callback, - info = list(event = event)) + info = list(event = event) + ) } }) @@ -2440,7 +2552,8 @@ async_every <- function(.x, .p, ...) { done <- FALSE deferred$new( - type = "async_every", call = sys.call(), + type = "async_every", + call = sys.call(), parents = defs, action = function(resolve) if (nx == 0) resolve(TRUE), parent_resolve = function(value, resolve) { @@ -2483,8 +2596,9 @@ async_every <- mark_as_async(async_every) #' } async_filter <- function(.x, .p, ...) { - when_all(.list = lapply(.x, async(.p), ...))$ - then(function(res) .x[vlapply(res, isTRUE)]) + when_all(.list = lapply(.x, async(.p), ...))$then( + function(res) .x[vlapply(res, isTRUE)] + ) } async_filter <- mark_as_async(async_filter) @@ -2493,8 +2607,9 @@ async_filter <- mark_as_async(async_filter) #' @noRd async_reject <- function(.x, .p, ...) { - when_all(.list = lapply(.x, async(.p), ...))$ - then(function(res) .x[! vlapply(res, isTRUE)]) + when_all(.list = lapply(.x, async(.p), ...))$then( + function(res) .x[!vlapply(res, isTRUE)] + ) } async_reject <- mark_as_async(async_reject) @@ -2628,12 +2743,13 @@ sseapp <- function() { pause = pause ) - res$ - set_header("cache-control", "no-cache")$ - set_header("content-type", "text/event-stream")$ - set_header("access-control-allow-origin", "*")$ - set_header("connection", "keep-alive")$ - set_status(200) + res$set_header("cache-control", "no-cache")$set_header( + "content-type", + "text/event-stream" + )$set_header("access-control-allow-origin", "*")$set_header( + "connection", + "keep-alive" + )$set_status(200) if (delay > 0) { return(res$delay(delay)) @@ -2641,7 +2757,9 @@ sseapp <- function() { } msg <- paste0( - "event: ", res$locals$sse$sent + 1L, "\n", + "event: ", + res$locals$sse$sent + 1L, + "\n", "message: live long and prosper\n\n" ) res$locals$sse$sent <- res$locals$sse$sent + 1L @@ -2726,10 +2844,18 @@ sseapp <- function() { #' synchronise(afun()) #' } -http_get <- function(url, headers = character(), file = NULL, - options = list(), on_progress = NULL) { - - url; headers; file; options; on_progress +http_get <- function( + url, + headers = character(), + file = NULL, + options = list(), + on_progress = NULL +) { + url + headers + file + options + on_progress options <- get_default_curl_options(options) make_deferred_http( @@ -2791,10 +2917,18 @@ http_get <- mark_as_async(http_get) #' synchronise(afun(urls)) #' } -http_head <- function(url, headers = character(), file = NULL, - options = list(), on_progress = NULL) { - - url; headers; file; options; on_progress +http_head <- function( + url, + headers = character(), + file = NULL, + options = list(), + on_progress = NULL +) { + url + headers + file + options + on_progress options <- get_default_curl_options(options) make_deferred_http( @@ -2802,8 +2936,12 @@ http_head <- function(url, headers = character(), file = NULL, assert_that(is_string(url)) handle <- curl::new_handle(url = url) curl::handle_setheaders(handle, .list = headers) - curl::handle_setopt(handle, customrequest = "HEAD", nobody = TRUE, - .list = options) + curl::handle_setopt( + handle, + customrequest = "HEAD", + nobody = TRUE, + .list = options + ) list(handle = handle, options = options) }, file @@ -2847,11 +2985,24 @@ http_head <- mark_as_async(http_head) #' #' synchronise(do()) -http_post <- function(url, data = NULL, data_file = NULL, - data_form = NULL, headers = character(), file = NULL, - options = list(), on_progress = NULL) { - - url; data; data_file; data_form; headers; file; options; on_progress +http_post <- function( + url, + data = NULL, + data_file = NULL, + data_form = NULL, + headers = character(), + file = NULL, + options = list(), + on_progress = NULL +) { + url + data + data_file + data_form + headers + file + options + on_progress if ((!is.null(data) + !is.null(data_file) + !is.null(data_form)) > 1) { stop( "At most one of `data`, `data_file` and `data_form` ", @@ -2869,9 +3020,13 @@ http_post <- function(url, data = NULL, data_file = NULL, assert_that(is_string(url)) handle <- curl::new_handle(url = url) curl::handle_setheaders(handle, .list = headers) - curl::handle_setopt(handle, customrequest = "POST", - postfieldsize = length(data), postfields = data, - .list = options) + curl::handle_setopt( + handle, + customrequest = "POST", + postfieldsize = length(data), + postfields = data, + .list = options + ) if (!is.null(data_form)) { curl::handle_setform(handle, .list = data_form) } @@ -2883,9 +3038,15 @@ http_post <- function(url, data = NULL, data_file = NULL, http_post <- mark_as_async(http_post) -http_delete <- function(url, headers = character(), file = NULL, - options = list()) { - url; headers; options; +http_delete <- function( + url, + headers = character(), + file = NULL, + options = list() +) { + url + headers + options make_deferred_http( function() { @@ -2908,7 +3069,7 @@ get_default_curl_options <- function(options) { if (!is.null(v <- options[[nm]])) return(v) anm <- paste0("async_http_", nm) if (!is.null(v <- getOption(anm))) return(v) - if (!is.na(v <- Sys.getenv(toupper(anm), NA_character_))) return (v) + if (!is.na(v <- Sys.getenv(toupper(anm), NA_character_))) return(v) } modifyList( options, @@ -2943,13 +3104,16 @@ http_events <- R6Class( ) make_deferred_http <- function(cb, file) { - cb; file + cb + file id <- NULL ee <- http_events$new() deferred$new( - type = "http", call = sys.call(), + type = "http", + call = sys.call(), action = function(resolve, progress) { - resolve; progress + resolve + progress ## This is a temporary hack until we have proper pollables ## Then the deferred will have a "work" callback, which will ## be able to throw. @@ -3002,12 +3166,18 @@ http_error <- function(resp, call = sys.call(-1)) { reason <- http_status(status)$reason message <- sprintf("%s (HTTP %d).", reason, status) status_type <- (status %/% 100) * 100 - if (length(resp[["content"]]) == 0 && !is.null(resp$file) && - file.exists(resp$file)) { - tryCatch({ - n <- file.info(resp$file, extra_cols = FALSE)$size - resp$content <- readBin(resp$file, what = raw(), n = n) - }, error = identity) + if ( + length(resp[["content"]]) == 0 && + !is.null(resp$file) && + file.exists(resp$file) + ) { + tryCatch( + { + n <- file.info(resp$file, extra_cols = FALSE)$size + resp$content <- readBin(resp$file, what = raw(), n = n) + }, + error = identity + ) } http_class <- paste0("async_http_", unique(c(status, status_type, "error"))) structure( @@ -3022,8 +3192,13 @@ http_status <- function(status) { stop("Unknown http status code: ", status, call. = FALSE) } - status_types <- c("Information", "Success", "Redirection", "Client error", - "Server error") + status_types <- c( + "Information", + "Success", + "Redirection", + "Client error", + "Server error" + ) status_type <- status_types[[status %/% 100]] # create the final information message @@ -3148,7 +3323,7 @@ http_setopt <- function(total_con = NULL, host_con = NULL, multiplex = NULL) { #' )) async_map <- function(.x, .f, ..., .args = list(), .limit = Inf) { - if (.limit < length(.x)) { + if (.limit < length(.x)) { async_map_limit(.x, .f, ..., .args = .args, .limit = .limit) } else { defs <- do.call(lapply, c(list(.x, async(.f), ...), .args)) @@ -3173,18 +3348,25 @@ async_map_limit <- function(.x, .f, ..., .args = list(), .limit = Inf) { ) self <- deferred$new( - type = "async_map (limit)", call = sys.call(), + type = "async_map (limit)", + call = sys.call(), action = function(resolve) { - self; nx; firsts + self + nx + firsts lapply(seq_along(firsts), function(idx) { firsts[[idx]]$then(function(val) list(idx, val))$then(self) }) if (nx == 0) resolve(result) }, parent_resolve = function(value, resolve) { - self; nx; nextone; result; .f + self + nx + nextone + result + .f nx <<- nx - 1L - result[ value[[1]] ] <<- value[2] + result[value[[1]]] <<- value[2] if (nx == 0) { resolve(result) } else if (nextone <= len) { @@ -3202,8 +3384,10 @@ async_map_limit <- function(.x, .f, ..., .args = list(), .limit = Inf) { ## nocov start .onLoad <- function(libname, pkgname) { - if (Sys.getenv("DEBUGME") != "" && - requireNamespace("debugme", quietly = TRUE)) { + if ( + Sys.getenv("DEBUGME") != "" && + requireNamespace("debugme", quietly = TRUE) + ) { debugme::debugme() } } @@ -3231,33 +3415,62 @@ async_map_limit <- function(.x, .f, ..., .args = list(), .limit = Inf) { #' synchronise(afun()) #' } -run_process <- function(command = NULL, args = character(), - error_on_status = TRUE, wd = NULL, env = NULL, - windows_verbatim_args = FALSE, windows_hide_window = FALSE, - encoding = "", ...) { - - command; args; error_on_status; wd; env; windows_verbatim_args; - windows_hide_window; encoding; list(...) +run_process <- function( + command = NULL, + args = character(), + error_on_status = TRUE, + wd = NULL, + env = NULL, + windows_verbatim_args = FALSE, + windows_hide_window = FALSE, + encoding = "", + ... +) { + command + args + error_on_status + wd + env + windows_verbatim_args + windows_hide_window + encoding + list(...) id <- NULL deferred$new( - type = "process", call = sys.call(), + type = "process", + call = sys.call(), action = function(resolve) { resolve reject <- environment(resolve)$private$reject stdout <- tempfile() stderr <- tempfile() - px <- processx::process$new(command, args = args, - stdout = stdout, stderr = stderr, poll_connection = TRUE, - env = env, cleanup = TRUE, cleanup_tree = TRUE, wd = wd, - encoding = encoding, ...) + px <- processx::process$new( + command, + args = args, + stdout = stdout, + stderr = stderr, + poll_connection = TRUE, + env = env, + cleanup = TRUE, + cleanup_tree = TRUE, + wd = wd, + encoding = encoding, + ... + ) pipe <- px$get_poll_connection() id <<- get_default_event_loop()$add_process( list(pipe), function(err, res) if (is.null(err)) resolve(res) else reject(err), - list(process = px, stdout = stdout, stderr = stderr, - error_on_status = error_on_status, encoding = encoding)) + list( + process = px, + stdout = stdout, + stderr = stderr, + error_on_status = error_on_status, + encoding = encoding + ) + ) }, on_cancel = function(reason) { if (!is.null(id)) get_default_event_loop()$cancel(id) @@ -3283,35 +3496,62 @@ run_process <- mark_as_async(run_process) #' synchronise(afun()) #' } -run_r_process <- function(func, args = list(), libpath = .libPaths(), +run_r_process <- function( + func, + args = list(), + libpath = .libPaths(), repos = c(getOption("repos"), c(CRAN = "https://cloud.r-project.org")), cmdargs = c("--no-site-file", "--slave", "--no-save", "--no-restore"), - system_profile = FALSE, user_profile = FALSE, env = callr::rcmd_safe_env()) { - - func; args; libpath; repos; cmdargs; system_profile; user_profile; env + system_profile = FALSE, + user_profile = FALSE, + env = callr::rcmd_safe_env() +) { + func + args + libpath + repos + cmdargs + system_profile + user_profile + env id <- NULL deferred$new( - type = "r-process", call = sys.calls(), + type = "r-process", + call = sys.calls(), action = function(resolve) { resolve reject <- environment(resolve)$private$reject stdout <- tempfile() stderr <- tempfile() opts <- callr::r_process_options( - func = func, args = args, libpath = libpath, repos = repos, - cmdargs = cmdargs, system_profile = system_profile, - user_profile = user_profile, env = env, stdout = stdout, - stderr = stderr, extra = list(cleanup_tree = TRUE)) + func = func, + args = args, + libpath = libpath, + repos = repos, + cmdargs = cmdargs, + system_profile = system_profile, + user_profile = user_profile, + env = env, + stdout = stdout, + stderr = stderr, + extra = list(cleanup_tree = TRUE) + ) rx <- callr::r_process$new(opts) pipe <- rx$get_poll_connection() id <<- get_default_event_loop()$add_r_process( list(pipe), function(err, res) if (is.null(err)) resolve(res) else reject(err), - list(process = rx, stdout = stdout, stderr = stderr, - error_on_status = TRUE, encoding = "")) + list( + process = rx, + stdout = stdout, + stderr = stderr, + error_on_status = TRUE, + encoding = "" + ) + ) }, on_cancel = function(reason) { if (!is.null(id)) get_default_event_loop()$cancel(id) @@ -3352,8 +3592,9 @@ async_race_some <- mark_as_async(async_race_some) #' @rdname async_race_some async_race <- function(..., .list = list()) { - when_some_internal(1L, ..., .list = .list, .race = TRUE)$ - then(function(x) x[[1]]) + when_some_internal(1L, ..., .list = .list, .race = TRUE)$then( + function(x) x[[1]] + ) } async_race <- mark_as_async(async_race) @@ -3380,9 +3621,9 @@ async_race <- mark_as_async(async_race) async_reflect <- function(task) { task <- async(task) function(...) { - task(...)$ - then(function(value) list(error = NULL, result = value))$ - catch(error = function(reason) list(error = reason, result = NULL)) + task(...)$then(function(value) list(error = NULL, result = value))$catch( + error = function(reason) list(error = reason, result = NULL) + ) } } @@ -3411,10 +3652,12 @@ async_reflect <- mark_as_async(async_reflect) #' synchronise(do()) #' } -async_replicate <- function(n, task, ..., .limit = Inf) { +async_replicate <- function(n, task, ..., .limit = Inf) { assert_that( is_count(n), - .limit == Inf || is_count(.limit), .limit >= 1L) + .limit == Inf || is_count(.limit), + .limit >= 1L + ) force(list(...)) task <- async(task) @@ -3433,13 +3676,15 @@ async_replicate_nolimit <- function(n, task, ...) { when_all(.list = defs) } -async_replicate_limit <- function(n, task, ..., .limit = .limit) { - n; .limit +async_replicate_limit <- function(n, task, ..., .limit = .limit) { + n + .limit defs <- nextone <- result <- NULL self <- deferred$new( - type = "async_replicate", call = sys.call(), + type = "async_replicate", + call = sys.call(), action = function(resolve) { defs <<- lapply(seq_len(n), function(i) task(...)) result <<- vector(n, mode = "list") @@ -3449,7 +3694,7 @@ async_replicate_limit <- function(n, task, ..., .limit = .limit) { nextone <<- .limit + 1L }, parent_resolve = function(value, resolve) { - result[ value[[1]] ] <<- value[2] + result[value[[1]]] <<- value[2] if (nextone > n) { resolve(result) } else { @@ -3494,7 +3739,8 @@ async_retry <- function(task, times, ...) { force(list(...)) self <- deferred$new( - type = "retry", call = sys.call(), + type = "retry", + call = sys.call(), parents = list(task(...)), parent_reject = function(value, resolve) { times <<- times - 1L @@ -3579,7 +3825,8 @@ async_some <- function(.x, .p, ...) { done <- FALSE deferred$new( - type = "async_some", call = sys.call(), + type = "async_some", + call = sys.call(), parents = defs, action = function(resolve) if (nx == 0) resolve(FALSE), parent_resolve = function(value, resolve) { @@ -3625,7 +3872,13 @@ async_some <- mark_as_async(async_some) synchronise <- function(expr) { new_el <- push_event_loop() - on.exit({ new_el$cancel_all(); pop_event_loop() }, add = TRUE) + on.exit( + { + new_el$cancel_all() + pop_event_loop() + }, + add = TRUE + ) ## Mark this frame as a synchronization point, for debugging `__async_synchronise_frame__` <- TRUE @@ -3645,10 +3898,11 @@ synchronise <- function(expr) { res <- res$then(function(x) x) priv <- get_private(res) - if (! identical(priv$event_loop, new_el)) { + if (!identical(priv$event_loop, new_el)) { err <- make_error( "Cannot create deferred chain across synchronization barrier", - class = "async_synchronization_barrier_error") + class = "async_synchronization_barrier_error" + ) stop(err) } @@ -3667,7 +3921,9 @@ start_browser <- function() { cat("This is a standard `browser()` call, but you can also use the\n") cat("following extra commands:\n") cat("- .an / async_next(): next event loop iteration.\n") - cat("- .as / async_step(): next event loop, debug next action or parent callback.\n") + cat( + "- .as / async_step(): next event loop, debug next action or parent callback.\n" + ) cat("- .asb / async_step_back(): stop debugging of callbacks.\n") cat("- .al / async_list(): deferred values in the current async phase.\n") cat("- .at / async_tree(): DAG of the deferred values.\n") @@ -3710,7 +3966,13 @@ start_browser <- function() { run_event_loop <- function(expr) { new_el <- push_event_loop() - on.exit({ new_el$cancel_all(); pop_event_loop() }, add = TRUE) + on.exit( + { + new_el$cancel_all() + pop_event_loop() + }, + add = TRUE + ) ## Mark this frame as a synchronization point, for debugging `__async_synchronise_frame__` <- TRUE @@ -3748,10 +4010,18 @@ format.async_rejected <- function(x, ...) { x <- distill_error(x) src <- get_source_position(x$aframe$call) paste0( - "" + "` at ", + src$filename, + ":", + src$position, + ">" ) } @@ -3760,12 +4030,16 @@ format.async_rejected <- function(x, ...) { summary.async_rejected <- function(object, ...) { x <- distill_error(object) fmt_out <- format(object, ...) - stack <- async_where(calls = x$calls, parents = x$parents, - frm = list(x$aframe)) + stack <- async_where( + calls = x$calls, + parents = x$parents, + frm = list(x$aframe) + ) stack_out <- format(stack) structure( paste0(fmt_out, "\n\n", stack_out), - class = "async_rejected_summary") + class = "async_rejected_summary" + ) } # nocov start @@ -3816,7 +4090,8 @@ async_timeout <- function(task, timeout, ...) { done <- FALSE self <- deferred$new( - type = "timeout", call = sys.call(), + type = "timeout", + call = sys.call(), action = function(resolve) { task(...)$then(function(x) list("ok", x))$then(self) delay(timeout)$then(function() list("timeout"))$then(self) @@ -3941,8 +4216,7 @@ async_timer <- R6Class( public = list( initialize = function(delay, callback) async_timer_init(self, private, super, delay, callback), - cancel = function() - async_timer_cancel(self, private) + cancel = function() async_timer_cancel(self, private) ), private = list( @@ -3953,7 +4227,8 @@ async_timer <- R6Class( async_timer_init <- function(self, private, super, delay, callback) { assert_that( is_time_interval(delay), - is.function(callback) && length(formals(callback)) == 0) + is.function(callback) && length(formals(callback)) == 0 + ) ## event emitter super$initialize() @@ -3962,17 +4237,19 @@ async_timer_init <- function(self, private, super, delay, callback) { delay, function() self$emit("timeout"), function(err, res) { - if (!is.null(err)) self$emit("error", err) # nocov + if (!is.null(err)) self$emit("error", err) # nocov }, - rep = TRUE) + rep = TRUE + ) self$listen_on("timeout", callback) invisible(self) } -async_timer_cancel <- function(self, private) { - self; private +async_timer_cancel <- function(self, private) { + self + private self$remove_all_listeners("timeout") get_default_event_loop()$cancel(private$id) invisible(self) @@ -4009,7 +4286,8 @@ async_try_each <- function(..., .list = list()) { errors <- list() self <- deferred$new( - type = "async_try_each", call = sys.call(), + type = "async_try_each", + call = sys.call(), action = function(resolve) { nx <<- length(defs) if (nx == 0) resolve(NULL) @@ -4024,7 +4302,8 @@ async_try_each <- function(..., .list = list()) { if (wh == nx) { err <- structure( list(errors = errors, message = "async_try_each failed"), - class = c("async_rejected", "error", "condition")) + class = c("async_rejected", "error", "condition") + ) stop(err) } else { wh <<- wh + 1 @@ -4065,7 +4344,8 @@ async_until <- function(test, task, ...) { task <- async(task) self <- deferred$new( - type = "async_until", call = sys.call(), + type = "async_until", + call = sys.call(), parents = list(task(...)), parent_resolve = function(value, resolve) { if (test()) { @@ -4176,10 +4456,13 @@ get_source_position <- function(call) { list( filename = file.path( c(getSrcDirectory(call), "?")[1], - c(getSrcFilename(call), "?")[1]), + c(getSrcFilename(call), "?")[1] + ), position = paste0( - getSrcLocation(call, "line", TRUE) %||% "?", ":", - getSrcLocation(call, "column", TRUE) %||% "?") + getSrcLocation(call, "line", TRUE) %||% "?", + ":", + getSrcLocation(call, "column", TRUE) %||% "?" + ) ) } @@ -4195,7 +4478,7 @@ read_all <- function(filename, encoding) { s } -crash <- function () { +crash <- function() { get("attach")(structure(list(), class = "UserDefinedDatabase")) } @@ -4264,7 +4547,6 @@ get_uuid <- function() { #' } when_all <- function(..., .list = list()) { - defs <- c(list(...), .list) nx <- 0L @@ -4272,7 +4554,9 @@ when_all <- function(..., .list = list()) { type = "when_all", call = sys.call(), action = function(resolve) { - self; nx; defs + self + nx + defs lapply(seq_along(defs), function(idx) { idx if (is_deferred(defs[[idx]])) { @@ -4283,7 +4567,7 @@ when_all <- function(..., .list = list()) { if (nx == 0) resolve(defs) }, parent_resolve = function(value, resolve) { - defs[ value[[1]] ] <<- value[2] + defs[value[[1]]] <<- value[2] nx <<- nx - 1L if (nx == 0L) resolve(defs) } @@ -4348,7 +4632,8 @@ when_some_internal <- function(count, ..., .list, .race) { cancel_all <- function() lapply(defs[ifdef], function(x) x$cancel()) deferred$new( - type = "when_some", call = sys.call(), + type = "when_some", + call = sys.call(), parents = defs[ifdef], action = function(resolve) { if (num_defs < count) { @@ -4372,7 +4657,8 @@ when_some_internal <- function(count, ..., .list, .race) { if (num_failed + count == num_defs + 1L) { err <- structure( list(errors = errors, message = "when_some / when_any failed"), - class = c("async_rejected", "error", "condition")) + class = c("async_rejected", "error", "condition") + ) stop(err) } } @@ -4415,8 +4701,9 @@ async_whilst <- function(test, task, ...) { task <- async(task) self <- deferred$new( - type = "async_whilst", call = sys.call(), - action = function(resolve) { + type = "async_whilst", + call = sys.call(), + action = function(resolve) { if (!test()) { resolve(NULL) } else { @@ -4424,7 +4711,7 @@ async_whilst <- function(test, task, ...) { } }, parent_resolve = function(value, resolve) { - if (!test()) { + if (!test()) { resolve(value) } else { task(...)$then(self) @@ -4451,30 +4738,20 @@ NULL worker_pool <- R6Class( public = list( - initialize = function() - wp_init(self, private), + initialize = function() wp_init(self, private), add_task = function(func, args, id, event_loop) wp_add_task(self, private, func, args, id, event_loop), - get_fds = function() - wp_get_fds(self, private), - get_pids = function() - wp_get_pids(self, private), - get_poll_connections = function() - wp_get_poll_connections(self, private), + get_fds = function() wp_get_fds(self, private), + get_pids = function() wp_get_pids(self, private), + get_poll_connections = function() wp_get_poll_connections(self, private), notify_event = function(pids, event_loop) wp_notify_event(self, private, pids, event_loop), - start_workers = function() - wp_start_workers(self, private), - kill_workers = function() - wp_kill_workers(self, private), - cancel_task = function(id) - wp_cancel_task(self, private, id), - cancel_all_tasks = function() - wp_cancel_all_tasks(self, private), - get_result = function(id) - wp_get_result(self, private, id), - list_workers = function() - wp_list_workers(self, private), + start_workers = function() wp_start_workers(self, private), + kill_workers = function() wp_kill_workers(self, private), + cancel_task = function(id) wp_cancel_task(self, private, id), + cancel_all_tasks = function() wp_cancel_all_tasks(self, private), + get_result = function(id) wp_get_result(self, private, id), + list_workers = function() wp_list_workers(self, private), list_tasks = function(event_loop = NULL, status = NULL) wp_list_tasks(self, private, event_loop, status) ), @@ -4484,10 +4761,8 @@ worker_pool <- R6Class( tasks = list(), finalize = function() self$kill_workers(), - try_start = function() - wp__try_start(self, private), - interrupt_worker = function(pid) - wp__interrupt_worker(self, private, pid) + try_start = function() wp__try_start(self, private), + interrupt_worker = function(pid) wp__interrupt_worker(self, private, pid) ) ) @@ -4505,7 +4780,10 @@ wp_start_workers <- function(self, private) { ## Yeah, start some more to_start <- num - NROW(private$workers) sess <- lapply(1:to_start, function(x) callr::r_session$new(wait = FALSE)) - fd <- viapply(sess, function(x) processx::conn_get_fileno(x$get_poll_connection())) + fd <- viapply( + sess, + function(x) processx::conn_get_fileno(x$get_poll_connection()) + ) new_workers <- data.frame( stringsAsFactors = FALSE, session = I(sess), @@ -4524,8 +4802,13 @@ wp_add_task <- function(self, private, func, args, id, event_loop) { private$tasks, data.frame( stringsAsFactors = FALSE, - event_loop = event_loop, id = id, func = I(list(func)), - args = I(list(args)), status = "waiting", result = I(list(NULL))) + event_loop = event_loop, + id = id, + func = I(list(func)), + args = I(list(args)), + status = "waiting", + result = I(list(NULL)) + ) ) private$try_start() @@ -4548,9 +4831,9 @@ wp_get_poll_connections <- function(self, private) { sts <- vcapply(private$workers$session, function(x) x$get_state()) busy <- sts %in% c("starting", "busy") structure( - lapply(private$workers$session[busy], - function(x) x$get_poll_connection()), - names = private$workers$pid[busy]) + lapply(private$workers$session[busy], function(x) x$get_poll_connection()), + names = private$workers$pid[busy] + ) } wp_notify_event <- function(self, private, pids, event_loop) { @@ -4571,7 +4854,7 @@ wp_notify_event <- function(self, private, pids, event_loop) { } } if (length(dead)) { - private$workers <- private$workers[-dead,] + private$workers <- private$workers[-dead, ] self$start_workers() } @@ -4697,12 +4980,15 @@ wp__interrupt_worker <- function(self, private, pid) { if (pr == "ready") { msg <- sess$read() - if (! inherits(msg, "interrupt")) { - tryCatch({ - sess$write_input("base::Sys.sleep(0)\n") - sess$read_output() - sess$read_error() - }, error = function(e) kill <<- TRUE) + if (!inherits(msg, "interrupt")) { + tryCatch( + { + sess$write_input("base::Sys.sleep(0)\n") + sess$read_output() + sess$read_error() + }, + error = function(e) kill <<- TRUE + ) } private$workers$task[[ww]] <- NA_character_ } else { @@ -4766,17 +5052,18 @@ wp__interrupt_worker <- function(self, private, pid) { #' synchronise(afun()) #' } -external_process <- function(process_generator, error_on_status = TRUE, - ...) { - - process_generator; error_on_status; args <- list(...) +external_process <- function(process_generator, error_on_status = TRUE, ...) { + process_generator + error_on_status + args <- list(...) args$encoding <- args$encoding %||% "" args$cleanup_tree <- args$cleanup_tree %||% TRUE id <- NULL deferred$new( - type = "external_process", call = sys.call(), + type = "external_process", + call = sys.call(), action = function(resolve) { resolve reject <- environment(resolve)$private$reject @@ -4787,8 +5074,13 @@ external_process <- function(process_generator, error_on_status = TRUE, id <<- get_default_event_loop()$add_process( list(pipe), function(err, res) if (is.null(err)) resolve(res) else reject(err), - list(process = px, stdout = stdout, stderr = stderr, - error_on_status = error_on_status, encoding = args$encoding) + list( + process = px, + stdout = stdout, + stderr = stderr, + error_on_status = error_on_status, + encoding = args$encoding + ) ) }, on_cancel = function(reason) { diff --git a/R/aaa-rstudio-detect.R b/R/aaa-rstudio-detect.R index cc0b4c1a..1428330e 100644 --- a/R/aaa-rstudio-detect.R +++ b/R/aaa-rstudio-detect.R @@ -1,6 +1,4 @@ - rstudio <- local({ - standalone_env <- environment() parent.env(standalone_env) <- baseenv() @@ -18,7 +16,8 @@ rstudio <- local({ "RSTUDIO_CONSOLE_COLOR", "RSTUDIOAPI_IPC_REQUESTS_FILE", "XPC_SERVICE_NAME", - "ASCIICAST") + "ASCIICAST" + ) d <- list( pid = Sys.getpid(), @@ -55,8 +54,10 @@ rstudio <- local({ if (clear_cache) data <<- NULL if (!is.null(data)) return(get_caps(data)) - if ((rspid <- Sys.getenv("RSTUDIO_SESSION_PID")) != "" && - any(c("ps", "cli") %in% loadedNamespaces())) { + if ( + (rspid <- Sys.getenv("RSTUDIO_SESSION_PID")) != "" && + any(c("ps", "cli") %in% loadedNamespaces()) + ) { detect_new(rspid, clear_cache) } else { detect_old(clear_cache) @@ -89,31 +90,26 @@ rstudio <- local({ # direct subprocess new$type <- if (rspid == parentpid) { - if (pane == "job") { "rstudio_job" - } else if (pane == "build") { "rstudio_build_pane" - } else if (pane == "render") { "rstudio_render_pane" - - } else if (pane == "terminal" && new$tty && - new$envs["ASCIICAST"] != "true") { + } else if ( + pane == "terminal" && new$tty && new$envs["ASCIICAST"] != "true" + ) { # not possible, because there is a shell in between, just in case "rstudio_terminal" - } else { # don't know what kind of direct subprocess "rstudio_subprocess" } - - } else if (pane == "terminal" && new$tty && - new$envs[["ASCIICAST"]] != "true") { + } else if ( + pane == "terminal" && new$tty && new$envs[["ASCIICAST"]] != "true" + ) { # not a direct subproces, so check other criteria as well "rstudio_terminal" - } else { # don't know what kind of subprocess "rstudio_subprocess" @@ -123,7 +119,6 @@ rstudio <- local({ } detect_old <- function(clear_cache = FALSE) { - # Cache unless told otherwise cache <- TRUE new <- get_data() @@ -131,20 +126,16 @@ rstudio <- local({ new$type <- if (new$envs[["RSTUDIO"]] != "1") { # 1. Not RStudio at all "not_rstudio" - } else if (new$gui == "RStudio" && new$api) { # 2. RStudio console, properly initialized "rstudio_console" - - } else if (! new$api && basename(new$args[1]) == "RStudio") { + } else if (!new$api && basename(new$args[1]) == "RStudio") { # 3. RStudio console, initializing cache <- FALSE "rstudio_console_starting" - } else if (new$gui == "Rgui") { # Still not RStudio, but Rgui that was started from RStudio "not_rstudio" - } else if (new$tty && new$envs[["ASCIICAST"]] != "true") { # 4. R in the RStudio terminal # This could also be a subprocess of the console or build pane @@ -152,29 +143,31 @@ rstudio <- local({ # out, without inspecting some process data with ps::ps_*(). # At least we rule out asciicast "rstudio_terminal" - - } else if (! new$tty && - new$envs[["RSTUDIO_TERM"]] == "" && - new$envs[["R_BROWSER"]] == "false" && - new$envs[["R_PDFVIEWER"]] == "false" && - is_build_pane_command(new$args)) { + } else if ( + !new$tty && + new$envs[["RSTUDIO_TERM"]] == "" && + new$envs[["R_BROWSER"]] == "false" && + new$envs[["R_PDFVIEWER"]] == "false" && + is_build_pane_command(new$args) + ) { # 5. R in the RStudio build pane # https://github.com/rstudio/rstudio/blob/master/src/cpp/session/ # modules/build/SessionBuild.cpp#L231-L240 "rstudio_build_pane" - - } else if (new$envs[["RSTUDIOAPI_IPC_REQUESTS_FILE"]] != "" && - grepl("rstudio", new$envs[["XPC_SERVICE_NAME"]])) { + } else if ( + new$envs[["RSTUDIOAPI_IPC_REQUESTS_FILE"]] != "" && + grepl("rstudio", new$envs[["XPC_SERVICE_NAME"]]) + ) { # RStudio job, XPC_SERVICE_NAME=0 in the subprocess of a job # process. Hopefully this is reliable. "rstudio_job" - - } else if (new$envs[["RSTUDIOAPI_IPC_REQUESTS_FILE"]] != "" && - any(grepl("SourceWithProgress.R", new$args))) { + } else if ( + new$envs[["RSTUDIOAPI_IPC_REQUESTS_FILE"]] != "" && + any(grepl("SourceWithProgress.R", new$args)) + ) { # Or we can check SourceWithProgress.R in the command line, see # https://github.com/r-lib/cli/issues/367 "rstudio_job" - } else { # Otherwise it is a subprocess of the console, terminal or # build pane, and it is hard to say which, so we do not try. diff --git a/R/archive.R b/R/archive.R index 090e46bd..ed5e6eae 100644 --- a/R/archive.R +++ b/R/archive.R @@ -96,34 +96,40 @@ cran_archive_cache <- R6Class( "cran_archive_cache", public = list( - initialize = function(primary_path = NULL, - replica_path = tempfile(), - cran_mirror = default_cran_mirror(), - update_after = as.difftime(7, units = "days")) - cac_init(self, private, primary_path, replica_path, cran_mirror, - update_after), + initialize = function( + primary_path = NULL, + replica_path = tempfile(), + cran_mirror = default_cran_mirror(), + update_after = as.difftime(7, units = "days") + ) + cac_init( + self, + private, + primary_path, + replica_path, + cran_mirror, + update_after + ), list = function(packages = NULL, update_after = NULL) synchronise(self$async_list(packages, update_after)), async_list = function(packages = NULL, update_after = NULL) - cac_async_list(self, private, packages, - update_after %||% private$update_after), + cac_async_list( + self, + private, + packages, + update_after %||% private$update_after + ), - update = function() - synchronise(self$async_update()), - async_update = function() - cac_async_update(self, private), + update = function() synchronise(self$async_update()), + async_update = function() cac_async_update(self, private), - check_update = function() - synchronise(self$async_check_update()), - async_check_update = function() - cac_async_check_update(self, private), + check_update = function() synchronise(self$async_check_update()), + async_check_update = function() cac_async_check_update(self, private), - summary = function() - cac_summary(self, private), + summary = function() cac_summary(self, private), - cleanup = function(force = FALSE) - cac_cleanup(self, private, force) + cleanup = function(force = FALSE) cac_cleanup(self, private, force) ), private = list( @@ -140,15 +146,11 @@ cran_archive_cache <- R6Class( cac__get_current_data(self, private, max_age), get_memory_cache = function(max_age) cac__get_memory_cache(self, private, max_age), - load_replica = function(max_age) - cac__load_replica(self, private, max_age), - load_primary = function(max_age) - cac__load_primary(self, private, max_age), - - update_memory_cache = function() - cac__update_memory_cache(self, private), - update_replica = function() - cac__update_replica(self, private), + load_replica = function(max_age) cac__load_replica(self, private, max_age), + load_primary = function(max_age) cac__load_primary(self, private, max_age), + + update_memory_cache = function() cac__update_memory_cache(self, private), + update_replica = function() cac__update_replica(self, private), update_primary = function(lock = TRUE) cac__update_primary(self, private, lock), convert_archive_file = function(raw, out) @@ -170,8 +172,14 @@ cran_archive_cache <- R6Class( ) ) -cac_init <- function(self, private, primary_path, replica_path, - cran_mirror, update_after) { +cac_init <- function( + self, + private, + primary_path, + replica_path, + cran_mirror, + update_after +) { private$primary_path <- primary_path %||% get_user_cache_dir()$root private$replica_path <- replica_path private$cran_mirror <- cran_mirror @@ -182,54 +190,52 @@ cac_init <- function(self, private, primary_path, replica_path, cac_async_list <- function(self, private, packages, update_after) { assert_that(is.null(packages) || is_character(packages)) - private$async_ensure_cache(update_after)$ - then(function(x) { - if (is.null(packages)) x else x[x$package %in% packages, ] - }) + private$async_ensure_cache(update_after)$then(function(x) { + if (is.null(packages)) x else x[x$package %in% packages, ] + }) } cac_async_update <- function(self, private) { hash <- private$get_hash() if (!is.null(private$update_deferred)) { - return(private$update_deferred) # nocov + return(private$update_deferred) # nocov } - private$update_deferred <- private$update_replica()$ - then(function() private$update_primary())$ - then(function() private$data)$ - catch(error = function(err) { - err$message <- msg_wrap( # nocov - conditionMessage(err), "\n\n", # nocov - "Could not load or update archive cache. If you think your local ", # nocov - "cache is broken, try deleting it with `cran_archive_cleanup()` or ", # nocov - "the `$cleanup()` method.") # nocov - stop(err) # nocov - })$ - finally(function() private$update_deferred <- NULL)$ - share() + private$update_deferred <- private$update_replica()$then( + function() private$update_primary() + )$then(function() private$data)$catch(error = function(err) { + err$message <- msg_wrap( + # nocov + conditionMessage(err), + "\n\n", # nocov + "Could not load or update archive cache. If you think your local ", # nocov + "cache is broken, try deleting it with `cran_archive_cleanup()` or ", # nocov + "the `$cleanup()` method." + ) # nocov + stop(err) # nocov + })$finally(function() private$update_deferred <- NULL)$share() } cac_async_check_update <- function(self, private) { - self; private - - if (!is.null(private$update_deferred)) return(private$update_deferred) # nocov - if (!is.null(private$chk_update_deferred)) return(private$chk_update_deferred) # nocov - - private$chk_update_deferred <- async(private$update_replica)()$ - then(function(ret) { - rep_file <- private$get_cache_file("replica") - rep_time <- file_get_time(rep_file) - stat <- ret$response$status_code - if (stat < 300) { - private$update_primary() - private$data - - } else { - private$async_ensure_cache() - } - })$ - finally(function() private$chk_update_deferred <- NULL)$ - share() + self + private + + if (!is.null(private$update_deferred)) return(private$update_deferred) # nocov + if (!is.null(private$chk_update_deferred)) return(private$chk_update_deferred) # nocov + + private$chk_update_deferred <- async(private$update_replica)()$then(function( + ret + ) { + rep_file <- private$get_cache_file("replica") + rep_time <- file_get_time(rep_file) + stat <- ret$response$status_code + if (stat < 300) { + private$update_primary() + private$data + } else { + private$async_ensure_cache() + } + })$finally(function() private$chk_update_deferred <- NULL)$share() } cac_summary <- function(self, private) { @@ -257,7 +263,7 @@ cac_cleanup <- function(self, private, force) { pri_rds ) ans <- readline(msg) - if (! ans %in% c("y", "Y")) stop("Aborted") + if (!ans %in% c("y", "Y")) stop("Aborted") } rep_rds <- private$get_cache_file("replica") @@ -292,8 +298,10 @@ cac__async_ensure_cache <- function(self, private, max_age) { cac__get_current_data <- function(self, private, max_age) { if (is.null(private$data)) stop("No data loaded") - if (is.null(private$data_time) || - Sys.time() - private$data_time > max_age) { + if ( + is.null(private$data_time) || + Sys.time() - private$data_time > max_age + ) { stop("Loaded data outdated") } private$data @@ -363,7 +371,7 @@ cac__update_replica <- function(self, private) { url <- paste0(private$cran_mirror, "/src/contrib/Meta/archive.rds") rep_file <- private$get_cache_file("replica") if (!file.exists(rep_file)) { - tryCatch(private$load_primary(private$update_after), error = function(e) e) + tryCatch(private$load_primary(private$update_after), error = function(e) e) } etag_file <- paste0(rep_file, "-etag") @@ -373,25 +381,22 @@ cac__update_replica <- function(self, private) { file.create(tmp) key <- random_key() - async_constant()$ - then(function() start_auth_cache(key))$ - then(function() download_if_newer(url, tmp, etag_file, error_on_status = FALSE))$ - then(function(dl) { - if (dl$response$status_code >= 300 && dl$response$status_code != 304) { - stop("Failed to update package archive metadata") - } - dl - })$ - then(function(dl) { - if (dl$response$status_code != 304) { - private$convert_archive_file(tmp, rep_file) - } - dl - })$ - finally(function() { - unlink(tmp) - clear_auth_cache(key) - }) + async_constant()$then(function() start_auth_cache(key))$then( + function() download_if_newer(url, tmp, etag_file, error_on_status = FALSE) + )$then(function(dl) { + if (dl$response$status_code >= 300 && dl$response$status_code != 304) { + stop("Failed to update package archive metadata") + } + dl + })$then(function(dl) { + if (dl$response$status_code != 304) { + private$convert_archive_file(tmp, rep_file) + } + dl + })$finally(function() { + unlink(tmp) + clear_auth_cache(key) + }) } cac__convert_archive_file <- function(self, private, raw, out) { @@ -484,9 +489,11 @@ get_archive_cache <- function(cran_mirror) { #' @examplesIf pkgcache:::run_examples() #' cran_archive_list(packages = "readr") -cran_archive_list <- function(cran_mirror = default_cran_mirror(), - update_after = as.difftime(7, units = "days"), - packages = NULL) { +cran_archive_list <- function( + cran_mirror = default_cran_mirror(), + update_after = as.difftime(7, units = "days"), + packages = NULL +) { get_archive_cache(cran_mirror)$list( update_after = update_after, packages = packages @@ -510,8 +517,10 @@ cran_archive_update <- function(cran_mirror = default_cran_mirror()) { #' `cran_mirror`. #' @return `cran_archive_cleanup()` returns nothing. -cran_archive_cleanup <- function(cran_mirror = default_cran_mirror(), - force = FALSE) { +cran_archive_cleanup <- function( + cran_mirror = default_cran_mirror(), + force = FALSE +) { get_archive_cache(cran_mirror)$cleanup(force = force) invisible() } diff --git a/R/assertions.R b/R/assertions.R index cce73521..b5a7b346 100644 --- a/R/assertions.R +++ b/R/assertions.R @@ -1,6 +1,5 @@ - is_character <- function(x) { - is.character(x) && ! any(is.na(x)) + is.character(x) && !any(is.na(x)) } on_failure(is_character) <- function(call, env) { @@ -68,7 +67,7 @@ on_failure(is_path) <- function(call, env) { is_existing_file <- function(x) { assert_that(is_path(x)) - file.exists(x) && ! file.info(x)$isdir + file.exists(x) && !file.info(x)$isdir } on_failure(is_existing_file) <- function(call, env) { @@ -78,10 +77,13 @@ on_failure(is_existing_file) <- function(call, env) { is_dependencies <- function(x) { types <- dep_types() types <- c(types, tolower(types)) - is_na_scalar(x) || isTRUE(x) || identical(x, FALSE) || + is_na_scalar(x) || + isTRUE(x) || + identical(x, FALSE) || (is_character(x) && all(x %in% types)) || - (is.list(x) && all(names(x) == c("direct", "indirect")) && - all(unlist(x) %in% types)) + (is.list(x) && + all(names(x) == c("direct", "indirect")) && + all(unlist(x) %in% types)) } on_failure(is_dependencies) <- function(call, env) { diff --git a/R/async-http.R b/R/async-http.R index 15318f82..95e97db5 100644 --- a/R/async-http.R +++ b/R/async-http.R @@ -1,4 +1,3 @@ - default_http_version <- function() { os <- Sys.info()["sysname"] if (!is.na(os) && os %in% c("Darwin", "Linux")) { @@ -21,7 +20,7 @@ update_async_timeouts <- function(options) { if (!is.null(v <- options[[nm]])) return(v) anm <- paste0("pkgcache_", nm) if (!is.null(v <- getOption(anm))) return(v) - if (!is.na(v <- Sys.getenv(toupper(anm), NA_character_))) return (v) + if (!is.na(v <- Sys.getenv(toupper(anm), NA_character_))) return(v) } utils::modifyList( options, @@ -30,7 +29,9 @@ update_async_timeouts <- function(options) { connecttimeout = as.integer(getopt("connecttimeout") %||% 300), low_speed_time = as.integer(getopt("low_speed_time") %||% 0), low_speed_limit = as.integer(getopt("low_speed_limit") %||% 0), - http_version = as.integer(getopt("http_version") %||% default_http_version()) + http_version = as.integer( + getopt("http_version") %||% default_http_version() + ) ) ) } @@ -101,10 +102,16 @@ add_auth_header <- function(url, headers) { #' cat(rawToChar(err$response$content)) #' ``` -download_file <- function(url, destfile, etag_file = NULL, - tmp_destfile = paste0(destfile, ".tmp"), - error_on_status = TRUE, - options = list(), headers = character(), ...) { +download_file <- function( + url, + destfile, + etag_file = NULL, + tmp_destfile = paste0(destfile, ".tmp"), + error_on_status = TRUE, + options = list(), + headers = character(), + ... +) { "!DEBUG downloading `url`" assert_that( is_string(url), @@ -112,7 +119,8 @@ download_file <- function(url, destfile, etag_file = NULL, is_path(tmp_destfile), is_path_or_null(etag_file), is_flag(error_on_status), - is.list(options)) + is.list(options) + ) force(list(...)) options <- update_async_timeouts(options) @@ -122,25 +130,33 @@ download_file <- function(url, destfile, etag_file = NULL, headers <- add_auth_header(url, headers) - http_get(url, file = tmp_destfile, options = options, headers = headers, ...)$ - then(http_stop_for_status)$ - then(function(resp) { - "!DEBUG downloaded `url`" - file.rename(tmp_destfile, destfile) - etag <- curl::parse_headers_list(resp$headers)[["etag"]] %||% NA_character_ - if (!is.null(etag_file) && !is.na(etag[1])) { - mkdirp(dirname(etag_file)) - writeLines(etag, etag_file) - } - list(url = url, destfile = destfile, response = resp, etag = etag, - etag_file = etag_file) - })$ - catch(error = function(err) { - "!DEBUG downloading `url` failed" - err$destfile <- destfile - err$url <- url - if (error_on_status) stop(err) else err - }) + http_get( + url, + file = tmp_destfile, + options = options, + headers = headers, + ... + )$then(http_stop_for_status)$then(function(resp) { + "!DEBUG downloaded `url`" + file.rename(tmp_destfile, destfile) + etag <- curl::parse_headers_list(resp$headers)[["etag"]] %||% NA_character_ + if (!is.null(etag_file) && !is.na(etag[1])) { + mkdirp(dirname(etag_file)) + writeLines(etag, etag_file) + } + list( + url = url, + destfile = destfile, + response = resp, + etag = etag, + etag_file = etag_file + ) + })$catch(error = function(err) { + "!DEBUG downloading `url` failed" + err$destfile <- destfile + err$url <- url + if (error_on_status) stop(err) else err + }) } read_etag <- function(etag_file) { @@ -215,11 +231,16 @@ get_etag_header_from_file <- function(destfile, etag_file) { #' cat(rawToChar(err$response$content)) #' ``` -download_if_newer <- function(url, destfile, etag_file = NULL, - headers = NULL, - tmp_destfile = paste0(destfile, ".tmp"), - error_on_status = TRUE, - options = list(), ...) { +download_if_newer <- function( + url, + destfile, + etag_file = NULL, + headers = NULL, + tmp_destfile = paste0(destfile, ".tmp"), + error_on_status = TRUE, + options = list(), + ... +) { "!DEBUG download if newer `url`" headers <- headers %||% structure(character(), names = character()) assert_that( @@ -227,9 +248,11 @@ download_if_newer <- function(url, destfile, etag_file = NULL, is_path(destfile), is_path(tmp_destfile), is_path_or_null(etag_file), - is.character(headers), all_named(headers), + is.character(headers), + all_named(headers), is_flag(error_on_status), - is.list(options)) + is.list(options) + ) force(list(...)) options <- update_async_timeouts(options) @@ -241,37 +264,45 @@ download_if_newer <- function(url, destfile, etag_file = NULL, tmp_destfile <- normalizePath(tmp_destfile, mustWork = FALSE) mkdirp(dirname(tmp_destfile)) - http_get(url, file = tmp_destfile, headers = headers, - options = options, ...)$ - then(http_stop_for_status)$ - then(function(resp) { - if (resp$status_code == 304) { - "!DEBUG download not needed, `url` current" - etag <- unname(etag_old) - } else if (resp$status_code == 200 || resp$status_code == 0) { - "!DEBUG downloaded `url`" - file.rename(tmp_destfile, destfile) - etag <- curl::parse_headers_list(resp$headers)[["etag"]] %||% NA_character_ - if (!is.null(etag_file) && !is.na(etag[1])) { - mkdirp(dirname(etag_file)) - writeLines(etag, etag_file) - } - } else { - err <- structure( - list(response = resp, message = "Unknown HTTP response"), - class = c("error", "condition")) - stop(err) + http_get( + url, + file = tmp_destfile, + headers = headers, + options = options, + ... + )$then(http_stop_for_status)$then(function(resp) { + if (resp$status_code == 304) { + "!DEBUG download not needed, `url` current" + etag <- unname(etag_old) + } else if (resp$status_code == 200 || resp$status_code == 0) { + "!DEBUG downloaded `url`" + file.rename(tmp_destfile, destfile) + etag <- curl::parse_headers_list(resp$headers)[["etag"]] %||% + NA_character_ + if (!is.null(etag_file) && !is.na(etag[1])) { + mkdirp(dirname(etag_file)) + writeLines(etag, etag_file) } - list(url = url, destfile = destfile, response = resp, etag = etag, - etag_file = etag_file) - })$ - catch(error = function(err) { - "!DEBUG downloading `url` failed" - err$destfile <- destfile - err$url <- url - if (error_on_status) stop(err) else err - }) - + } else { + err <- structure( + list(response = resp, message = "Unknown HTTP response"), + class = c("error", "condition") + ) + stop(err) + } + list( + url = url, + destfile = destfile, + response = resp, + etag = etag, + etag_file = etag_file + ) + })$catch(error = function(err) { + "!DEBUG downloading `url` failed" + err$destfile <- destfile + err$url <- url + if (error_on_status) stop(err) else err + }) } #' Download a files from multiple candidate URLs @@ -332,18 +363,27 @@ download_if_newer <- function(url, destfile, etag_file = NULL, #' cat(rawToChar(res$errors[[1]]$response$content)) #' ``` -download_one_of <- function(urls, destfile, etag_file = NULL, - headers = NULL, error_on_status = TRUE, - options = list(), ...) { +download_one_of <- function( + urls, + destfile, + etag_file = NULL, + headers = NULL, + error_on_status = TRUE, + options = list(), + ... +) { "!DEBUG trying multiple URLs" headers <- headers %||% structure(character(), names = character()) assert_that( - is_character(urls), length(urls) >= 1, + is_character(urls), + length(urls) >= 1, is_path(destfile), is_path_or_null(etag_file), - is.character(headers), all_named(headers), + is.character(headers), + all_named(headers), is_flag(error_on_status), - is.list(options)) + is.list(options) + ) force(list(...)) options <- update_async_timeouts(options) @@ -352,24 +392,36 @@ download_one_of <- function(urls, destfile, etag_file = NULL, download_if_newer, url = urls, tmp_destfile = tmps, - MoreArgs = list(destfile = destfile, etag_file = etag_file, - headers = headers, options = options, ...), - SIMPLIFY = FALSE) + MoreArgs = list( + destfile = destfile, + etag_file = etag_file, + headers = headers, + options = options, + ... + ), + SIMPLIFY = FALSE + ) - when_any(.list = dls)$ - catch(error = function(err) { - err$message <- "All URLs failed" - class(err) <- c("download_one_of_error", class(err)) - if (error_on_status) stop(err) else err - }) + when_any(.list = dls)$catch(error = function(err) { + err$message <- "All URLs failed" + class(err) <- c("download_one_of_error", class(err)) + if (error_on_status) stop(err) else err + }) } -download_files <- function(data, error_on_status = TRUE, - options = list(), headers = NULL, ...) { - +download_files <- function( + data, + error_on_status = TRUE, + options = list(), + headers = NULL, + ... +) { if (any(dup <- duplicated(data$path))) { - stop("Duplicate target paths in download_files: ", - paste0("`", unique(data$path[dup]), "`", collapse = ", "), ".") + stop( + "Duplicate target paths in download_files: ", + paste0("`", unique(data$path[dup]), "`", collapse = ", "), + "." + ) } options <- update_async_timeouts(options) @@ -379,34 +431,39 @@ download_files <- function(data, error_on_status = TRUE, dls <- lapply(seq_len(nrow(data)), function(idx) { row <- data[idx, ] dx <- download_if_newer( - row$url, row$path, row$etag, + row$url, + row$path, + row$etag, headers = c(headers, row$headers[[1L]]), on_progress = prog_cb, error_on_status = error_on_status, - options = options, ... + options = options, + ... ) if ("fallback_url" %in% names(row) && !is.na(row$fallback_url)) { dx <- dx$catch(error = function(err) { download_if_newer( - row$fallback_url, row$path, row$etag, + row$fallback_url, + row$path, + row$etag, headers = c(headers, row$headers[[1L]]), error_on_status = error_on_status, - options = options, ... + options = options, + ... ) }) } - dx <- dx$ - then(function(result) { - status_code <- result$response$status_code - if (status_code == 304) { - update_progress_bar_uptodate(bar, row$url) - } else { - update_progress_bar_done(bar, row$url) - } - result - }) + dx <- dx$then(function(result) { + status_code <- result$response$status_code + if (status_code == 304) { + update_progress_bar_uptodate(bar, row$url) + } else { + update_progress_bar_done(bar, row$url) + } + result + }) if (isTRUE(row$mayfail)) { dx$catch(error = function(err) { @@ -419,7 +476,8 @@ download_files <- function(data, error_on_status = TRUE, }) ok <- FALSE - when_all(.list = dls)$ - then(function(result) { ok <<- TRUE; result })$ - finally(function() finish_progress_bar(ok, bar)) + when_all(.list = dls)$then(function(result) { + ok <<- TRUE + result + })$finally(function() finish_progress_bar(ok, bar)) } diff --git a/R/auth.R b/R/auth.R index 714a60cc..5b9baf66 100644 --- a/R/auth.R +++ b/R/auth.R @@ -55,9 +55,12 @@ #' #' @export -repo_auth <- function(r_version = getRversion(), bioc = TRUE, - cran_mirror = default_cran_mirror(), - check_credentials = TRUE) { +repo_auth <- function( + r_version = getRversion(), + bioc = TRUE, + cran_mirror = default_cran_mirror(), + check_credentials = TRUE +) { res <- cmc__get_repos( getOption("repos"), bioc = bioc, @@ -92,8 +95,10 @@ repo_auth <- function(r_version = getRversion(), bioc = TRUE, } } else { parsed_url <- parse_url_basic_auth(url) - if (length(parsed_url$username) == 0 || - nchar(parsed_url$username) == 0) { + if ( + length(parsed_url$username) == 0 || + nchar(parsed_url$username) == 0 + ) { next } res$username[w] <- parsed_url$username @@ -144,8 +149,8 @@ repo_auth_headers <- function( url, use_cache = TRUE, set_cache = TRUE, - warn = TRUE) { - + warn = TRUE +) { # shortcut to speed up the common case of no credentials if (!grepl("@", url)) { return(NULL) @@ -260,8 +265,10 @@ repo_auth_headers <- function( } clear_auth_cache <- function(key = NULL) { - if (is.null(key) || - identical(pkgenv$credentials[[".exit_handler"]], key)) { + if ( + is.null(key) || + identical(pkgenv$credentials[[".exit_handler"]], key) + ) { rm( list = ls(pkgenv$credentials, all.names = TRUE), envir = pkgenv$credentials @@ -270,7 +277,7 @@ clear_auth_cache <- function(key = NULL) { } start_auth_cache <- function(key) { - if (! ".exit_handler" %in% names(pkgenv$credentials)) { + if (!".exit_handler" %in% names(pkgenv$credentials)) { assign(".exit_handler", key, envir = pkgenv$credentials) } } @@ -343,7 +350,7 @@ repo_auth_netrc <- function(host, username) { lines <- readLines(netrc_path, warn = FALSE) # mark potential end of macros with NA lines[lines == ""] <- NA_character_ - tokens <- scan(text = lines, what = "" , quiet = TRUE) + tokens <- scan(text = lines, what = "", quiet = TRUE) idx <- 1L err <- FALSE diff --git a/R/bioc-sysreqs.R b/R/bioc-sysreqs.R index b9b1dcb2..145163d4 100644 --- a/R/bioc-sysreqs.R +++ b/R/bioc-sysreqs.R @@ -1,4 +1,3 @@ - list_bioc_repos <- function() { url <- "https://git.bioconductor.org/" resp <- curl::curl_fetch_memory(url) @@ -19,22 +18,25 @@ get_bioc_sysreqs <- function(pkg, ref = "HEAD") { } async_get_bioc_sysreqs <- function(pkg, ref = "HEAD") { - url <- sprintf("https://raw.githubusercontent.com/bioc/%s/%s/DESCRIPTION", pkg, ref) + url <- sprintf( + "https://raw.githubusercontent.com/bioc/%s/%s/DESCRIPTION", + pkg, + ref + ) tmp <- tempfile("pkgcache-bioc-") on.exit(unlink(tmp), add = TRUE) - http_get(url)$ - then(http_stop_for_status)$ - catch(async_http_404 = function(err) list(content = raw()))$ - then(function(res) { - on.exit(close(con), add = TRUE) - desc <- read.dcf(con <- rawConnection(res$content)) - if ("SystemRequirements" %in% colnames(desc)) { - unname(desc[, "SystemRequirements"]) - } else { - NA_character_ - } - }) + http_get(url)$then(http_stop_for_status)$catch( + async_http_404 = function(err) list(content = raw()) + )$then(function(res) { + on.exit(close(con), add = TRUE) + desc <- read.dcf(con <- rawConnection(res$content)) + if ("SystemRequirements" %in% colnames(desc)) { + unname(desc[, "SystemRequirements"]) + } else { + NA_character_ + } + }) } get_all_bioc_sysreqs <- function(ref = "HEAD") { @@ -46,8 +48,12 @@ get_all_bioc_sysreqs <- function(ref = "HEAD") { prog <- function() { cat( - "\r[", paste(format(done), collapse = "/"), "]", sep = "", - " -- ", format_time$pretty_dt(Sys.time() - start_at) + "\r[", + paste(format(done), collapse = "/"), + "]", + sep = "", + " -- ", + format_time$pretty_dt(Sys.time() - start_at) ) } @@ -56,19 +62,19 @@ get_all_bioc_sysreqs <- function(ref = "HEAD") { pkgs, function(pkg) { force(pkg) - async_get_bioc_sysreqs(pkg, ref = ref)$ - catch(error = function(e) { - message( - "\r", pkg, ": \n", - conditionMessage(e) - ) - NA_character_ - })$ - then(function(x) { - done[1] <<- done[1] + 1L - prog() - x - }) + async_get_bioc_sysreqs(pkg, ref = ref)$catch(error = function(e) { + message( + "\r", + pkg, + ": \n", + conditionMessage(e) + ) + NA_character_ + })$then(function(x) { + done[1] <<- done[1] + 1L + prog() + x + }) } )) sq <- data.frame( diff --git a/R/bioc.R b/R/bioc.R index dbc71a8b..0645af2b 100644 --- a/R/bioc.R +++ b/R/bioc.R @@ -68,6 +68,13 @@ #' R version is not in the builtin mapping. #' * 2020-11-21 Update internal map for 3.12. #' * 2023-05-08 Add 'books' repo. +#' * 2023-06-07 Add 3.18 +#' * 2023-10-31 Better version matching, do not include versions that +#' eventually change their mapping in the cache. +#' * 2023-12-10 Avoid `package_version(list())`, it fails on newer R. +#' * 2024-06-20 Need to import `utils::download.file()`. +#' * 2024-11-07 Update version mapping for R 4.4 -> Bioc 3.20. +#' * 2025-04-30 Reformat code with air. #' #' @name bioconductor #' @keywords internal @@ -77,7 +84,6 @@ NULL #' @importFrom utils download.file bioconductor <- local({ - # ------------------------------------------------------------------- # Configuration that does not change often @@ -89,35 +95,36 @@ bioconductor <- local({ } builtin_map <- list( - "2.1" = package_version("1.6"), - "2.2" = package_version("1.7"), - "2.3" = package_version("1.8"), - "2.4" = package_version("1.9"), - "2.5" = package_version("2.0"), - "2.6" = package_version("2.1"), - "2.7" = package_version("2.2"), - "2.8" = package_version("2.3"), - "2.9" = package_version("2.4"), + "2.1" = package_version("1.6"), + "2.2" = package_version("1.7"), + "2.3" = package_version("1.8"), + "2.4" = package_version("1.9"), + "2.5" = package_version("2.0"), + "2.6" = package_version("2.1"), + "2.7" = package_version("2.2"), + "2.8" = package_version("2.3"), + "2.9" = package_version("2.4"), "2.10" = package_version("2.5"), "2.11" = package_version("2.6"), "2.12" = package_version("2.7"), "2.13" = package_version("2.8"), "2.14" = package_version("2.9"), "2.15" = package_version("2.11"), - "3.0" = package_version("2.13"), - "3.1" = package_version("3.0"), - "3.2" = package_version("3.2"), - "3.3" = package_version("3.4"), - "3.4" = package_version("3.6"), - "3.5" = package_version("3.8"), - "3.6" = package_version("3.10"), - "4.0" = package_version("3.12"), - "4.1" = package_version("3.14"), - "4.2" = package_version("3.16"), - "4.3" = package_version("3.18"), - "4.4" = package_version("3.20") - # Do not include R 4.4 <-> Bioc 3.19, because R 4.4 will use - # Bioc 3.20 eventually. + "3.0" = package_version("2.13"), + "3.1" = package_version("3.0"), + "3.2" = package_version("3.2"), + "3.3" = package_version("3.4"), + "3.4" = package_version("3.6"), + "3.5" = package_version("3.8"), + "3.6" = package_version("3.10"), + "4.0" = package_version("3.12"), + "4.1" = package_version("3.14"), + "4.2" = package_version("3.16"), + "4.3" = package_version("3.18"), + "4.4" = package_version("3.20"), + NULL + # Do not include R 4.5 <-> Bioc 3.21, because R 4.5 will use + # Bioc 3.22 eventually. ) # ------------------------------------------------------------------- @@ -162,7 +169,7 @@ bioconductor <- local({ yaml <- get_yaml_config(forget) pattern <- "^release_version: \"(.*)\"" release_version <<- package_version( - sub(pattern, "\\1", grep(pattern, yaml, value=TRUE)) + sub(pattern, "\\1", grep(pattern, yaml, value = TRUE)) ) } release_version @@ -173,7 +180,7 @@ bioconductor <- local({ yaml <- get_yaml_config(forget) pattern <- "^devel_version: \"(.*)\"" devel_version <<- package_version( - sub(pattern, "\\1", grep(pattern, yaml, value=TRUE)) + sub(pattern, "\\1", grep(pattern, yaml, value = TRUE)) ) } devel_version @@ -197,7 +204,8 @@ bioconductor <- local({ # append final version for 'devel' R bioc <- c( - bioc, max(bioc) + bioc, + max(bioc) ) r <- c(r, package_version(paste(unlist(max(r)) + 0:1, collapse = "."))) status <- c(status, "future") @@ -205,7 +213,8 @@ bioconductor <- local({ version_map <<- rbind( .VERSION_MAP_SENTINEL, data.frame( - bioc_version = bioc, r_version = r, + bioc_version = bioc, + r_version = r, bioc_status = factor( status, levels = c("out-of-date", "release", "devel", "future") @@ -216,9 +225,10 @@ bioconductor <- local({ version_map } - get_matching_bioc_version <- function(r_version = getRversion(), - forget = FALSE) { - + get_matching_bioc_version <- function( + r_version = getRversion(), + forget = FALSE + ) { minor <- as.character(get_minor_r_version(r_version)) if (minor %in% names(builtin_map)) return(builtin_map[[minor]]) @@ -252,8 +262,7 @@ bioconductor <- local({ get_devel_version() } - get_bioc_version <- function(r_version = getRversion(), - forget = FALSE) { + get_bioc_version <- function(r_version = getRversion(), forget = FALSE) { if (nzchar(v <- Sys.getenv("R_BIOC_VERSION", ""))) { return(package_version(v)) } @@ -269,23 +278,25 @@ bioconductor <- local({ mirror <- Sys.getenv("R_BIOC_MIRROR", "https://bioconductor.org") mirror <- getOption("BioC_mirror", mirror) repos <- c( - BioCsoft = "{mirror}/packages/{bv}/bioc", - BioCann = "{mirror}/packages/{bv}/data/annotation", - BioCexp = "{mirror}/packages/{bv}/data/experiment", - BioCworkflows = - if (bioc_version >= "3.7") "{mirror}/packages/{bv}/workflows", - BioCextra = - if (bioc_version <= "3.5") "{mirror}/packages/{bv}/extra", - BioCbooks = - if (bioc_version >= "3.12") "{mirror}/packages/{bv}/books" + BioCsoft = "{mirror}/packages/{bv}/bioc", + BioCann = "{mirror}/packages/{bv}/data/annotation", + BioCexp = "{mirror}/packages/{bv}/data/experiment", + BioCworkflows = if (bioc_version >= "3.7") + "{mirror}/packages/{bv}/workflows", + BioCextra = if (bioc_version <= "3.5") "{mirror}/packages/{bv}/extra", + BioCbooks = if (bioc_version >= "3.12") "{mirror}/packages/{bv}/books" ) ## It seems that if a repo is not available yet for bioc-devel, ## they redirect to the bioc-release version, so we do not need to ## parse devel_repos from the config.yaml file - sub("{mirror}", mirror, fixed = TRUE, - sub("{bv}", bioc_version, repos, fixed = TRUE)) + sub( + "{mirror}", + mirror, + fixed = TRUE, + sub("{bv}", bioc_version, repos, fixed = TRUE) + ) } # ------------------------------------------------------------------- @@ -316,8 +327,8 @@ bioconductor <- local({ ) ) - get_minor_r_version <- function (x) { - package_version(x)[,1:2] + get_minor_r_version <- function(x) { + package_version(x)[, 1:2] } # ------------------------------------------------------------------- @@ -334,5 +345,6 @@ bioconductor <- local({ get_bioc_version = get_bioc_version, get_repos = get_repos ), - class = c("standalone_bioc", "standalone")) + class = c("standalone_bioc", "standalone") + ) }) diff --git a/R/cache-api.R b/R/cache-api.R index beb9780c..3a3d9d9f 100644 --- a/R/cache-api.R +++ b/R/cache-api.R @@ -1,4 +1,3 @@ - #' Functions to query and manipulate the package cache #' #' `pkg_cache_summary()` returns a short summary of the state of the cache, @@ -82,8 +81,12 @@ pkg_cache_delete_files <- function(cachepath = NULL, ...) { #' @rdname pkg_cache_api #' @export -pkg_cache_add_file <- function(cachepath = NULL, file, - relpath = dirname(file), ...) { +pkg_cache_add_file <- function( + cachepath = NULL, + file, + relpath = dirname(file), + ... +) { cachepath <- cachepath %||% get_user_cache_dir()$pkg package_cache$new(cachepath)$add(file = file, path = relpath, ...) } diff --git a/R/cache-dirs.R b/R/cache-dirs.R index 9bca8dd9..d9fdc543 100644 --- a/R/cache-dirs.R +++ b/R/cache-dirs.R @@ -1,4 +1,3 @@ - get_user_cache_dir <- function() { ichk <- Sys.getenv("_R_CHECK_PACKAGE_NAME_", "") != "" rdir <- Sys.getenv("R_USER_CACHE_DIR", "") @@ -26,7 +25,7 @@ get_user_cache_dir <- function() { res <- list( root = cdir, - pkg = file.path(cdir, "pkg"), + pkg = file.path(cdir, "pkg"), meta = file.path(cdir, "_metadata"), lock = file.path(cdir, "_metadata.lock") ) @@ -90,10 +89,8 @@ file_path <- function(...) { win_path_local <- function() { if (nzchar(lapp <- Sys.getenv("LOCALAPPDATA", ""))) { lapp - } else if (nzchar(usrprof <- Sys.getenv("USERPROFILE", ""))) { file.path(usrprof, "AppData", "Local") - } else { file.path(tempdir(), "r-pkg-cache") } diff --git a/R/compat-vctrs.R b/R/compat-vctrs.R index 34860cf4..4bb7bbae 100644 --- a/R/compat-vctrs.R +++ b/R/compat-vctrs.R @@ -1,627 +1,630 @@ - compat_vctrs <- local({ + # Modified from https://github.com/r-lib/rlang/blob/master/R/compat-vctrs.R -# Modified from https://github.com/r-lib/rlang/blob/master/R/compat-vctrs.R - -# Construction ------------------------------------------------------------ - -# Constructs data frames inheriting from `"tbl"`. This allows the -# pillar package to take over printing as soon as it is loaded. -# The data frame otherwise behaves like a base data frame. -data_frame <- function(...) { - new_data_frame(df_list(...), .class = "tbl") -} + # Construction ------------------------------------------------------------ -new_data_frame <- function(.x = list(), - ..., - .size = NULL, - .class = NULL) { - n_cols <- length(.x) - if (n_cols != 0 && is.null(names(.x))) { - stop("Columns must be named.", call. = FALSE) + # Constructs data frames inheriting from `"tbl"`. This allows the + # pillar package to take over printing as soon as it is loaded. + # The data frame otherwise behaves like a base data frame. + data_frame <- function(...) { + new_data_frame(df_list(...), .class = "tbl") } - if (is.null(.size)) { - if (n_cols == 0) { - .size <- 0 - } else { - .size <- vec_size(.x[[1]]) + new_data_frame <- function(.x = list(), ..., .size = NULL, .class = NULL) { + n_cols <- length(.x) + if (n_cols != 0 && is.null(names(.x))) { + stop("Columns must be named.", call. = FALSE) } - } - - structure( - .x, - class = c(.class, "data.frame"), - row.names = .set_row_names(.size), - ... - ) -} -df_list <- function(..., .size = NULL) { - vec_recycle_common(list(...), size = .size) -} - - -# Binding ----------------------------------------------------------------- + if (is.null(.size)) { + if (n_cols == 0) { + .size <- 0 + } else { + .size <- vec_size(.x[[1]]) + } + } -vec_rbind <- function(...) { - xs <- vec_cast_common(list(...)) - do.call(base::rbind, xs) -} + structure( + .x, + class = c(.class, "data.frame"), + row.names = .set_row_names(.size), + ... + ) + } -vec_cbind <- function(...) { - xs <- list(...) + df_list <- function(..., .size = NULL) { + vec_recycle_common(list(...), size = .size) + } - ptype <- vec_ptype_common(lapply(xs, `[`, 0)) - class <- setdiff(class(ptype), "data.frame") + # Binding ----------------------------------------------------------------- - xs <- vec_recycle_common(xs) - out <- do.call(base::cbind, xs) - new_data_frame(out, .class = class) -} + vec_rbind <- function(...) { + xs <- vec_cast_common(list(...)) + do.call(base::rbind, xs) + } + vec_cbind <- function(...) { + xs <- list(...) -# Slicing ----------------------------------------------------------------- + ptype <- vec_ptype_common(lapply(xs, `[`, 0)) + class <- setdiff(class(ptype), "data.frame") -vec_size <- function(x) { - if (is.data.frame(x)) { - nrow(x) - } else { - length(x) + xs <- vec_recycle_common(xs) + out <- do.call(base::cbind, xs) + new_data_frame(out, .class = class) } -} -vec_rep <- function(x, times) { - i <- rep.int(seq_len(vec_size(x)), times) - vec_slice(x, i) -} - -vec_recycle_common <- function(xs, size = NULL) { - sizes <- vapply(xs, vec_size, integer(1)) + # Slicing ----------------------------------------------------------------- - n <- unique(sizes) + vec_size <- function(x) { + if (is.data.frame(x)) { + nrow(x) + } else { + length(x) + } + } - if (length(n) == 1 && is.null(size)) { - return(xs) + vec_rep <- function(x, times) { + i <- rep.int(seq_len(vec_size(x)), times) + vec_slice(x, i) } - n <- setdiff(n, 1L) - ns <- length(n) + vec_recycle_common <- function(xs, size = NULL) { + sizes <- vapply(xs, vec_size, integer(1)) + + n <- unique(sizes) - if (ns == 0) { - if (is.null(size)) { + if (length(n) == 1 && is.null(size)) { return(xs) } - } else if (ns == 1) { - if (is.null(size)) { - size <- n - } else if (ns != size) { - stop("Inputs can't be recycled to `size`.", call. = FALSE) + n <- setdiff(n, 1L) + + ns <- length(n) + + if (ns == 0) { + if (is.null(size)) { + return(xs) + } + } else if (ns == 1) { + if (is.null(size)) { + size <- n + } else if (ns != size) { + stop("Inputs can't be recycled to `size`.", call. = FALSE) + } + } else { + stop("Inputs can't be recycled to a common size.", call. = FALSE) } - } else { - stop("Inputs can't be recycled to a common size.", call. = FALSE) + + to_recycle <- sizes == 1L + xs[to_recycle] <- lapply(xs[to_recycle], vec_rep, size) + + xs } - to_recycle <- sizes == 1L - xs[to_recycle] <- lapply(xs[to_recycle], vec_rep, size) + vec_slice <- function(x, i) { + if (is.logical(i)) { + i <- which(i) + } + stopifnot(is.numeric(i) || is.character(i)) - xs -} + if (is.null(x)) { + return(NULL) + } -vec_slice <- function(x, i) { - if (is.logical(i)) { - i <- which(i) - } - stopifnot(is.numeric(i) || is.character(i)) + if (is.data.frame(x)) { + # We need to be a bit careful to be generic. First empty all + # columns and expand the df to final size. + out <- x[i, 0, drop = FALSE] - if (is.null(x)) { - return(NULL) - } + # Then fill in with sliced columns + out[seq_along(x)] <- lapply(x, vec_slice, i) - if (is.data.frame(x)) { - # We need to be a bit careful to be generic. First empty all - # columns and expand the df to final size. - out <- x[i, 0, drop = FALSE] + # Reset automatic row names to work around `[` weirdness + if (is.numeric(attr(x, "row.names"))) { + row_names <- .set_row_names(nrow(out)) + } else { + row_names <- attr(out, "row.names") + } - # Then fill in with sliced columns - out[seq_along(x)] <- lapply(x, vec_slice, i) + return(out) + } - # Reset automatic row names to work around `[` weirdness - if (is.numeric(attr(x, "row.names"))) { - row_names <- .set_row_names(nrow(out)) + d <- vec_dims(x) + if (d == 1) { + if (is.object(x)) { + out <- x[i] + } else { + out <- x[i, drop = FALSE] + } + } else if (d == 2) { + out <- x[i, , drop = FALSE] } else { - row_names <- attr(out, "row.names") + j <- rep(list(quote(expr = )), d - 1) + out <- eval(as.call(list( + quote(`[`), + quote(x), + quote(i), + j, + drop = FALSE + ))) } - return(out) + out } - - d <- vec_dims(x) - if (d == 1) { - if (is.object(x)) { - out <- x[i] + vec_dims <- function(x) { + d <- dim(x) + if (is.null(d)) { + 1L } else { - out <- x[i, drop = FALSE] + length(d) } - } else if (d == 2) { - out <- x[i, , drop = FALSE] - } else { - j <- rep(list(quote(expr = )), d - 1) - out <- eval(as.call(list(quote(`[`), quote(x), quote(i), j, drop = FALSE))) } - out -} -vec_dims <- function(x) { - d <- dim(x) - if (is.null(d)) { - 1L - } else { - length(d) - } -} + vec_as_location <- function(i, n, names = NULL) { + out <- seq_len(n) + names(out) <- names -vec_as_location <- function(i, n, names = NULL) { - out <- seq_len(n) - names(out) <- names + # Special-case recycling to size 0 + if (is_logical(i, n = 1) && !length(out)) { + return(out) + } - # Special-case recycling to size 0 - if (is_logical(i, n = 1) && !length(out)) { - return(out) + unname(out[i]) } - unname(out[i]) -} + vec_init <- function(x, n = 1L) { + vec_slice(x, rep_len(NA_integer_, n)) + } -vec_init <- function(x, n = 1L) { - vec_slice(x, rep_len(NA_integer_, n)) -} + vec_assign <- function(x, i, value) { + if (is.null(x)) { + return(NULL) + } -vec_assign <- function(x, i, value) { - if (is.null(x)) { - return(NULL) - } + if (is.logical(i)) { + i <- which(i) + } + stopifnot( + is.numeric(i) || is.character(i) + ) - if (is.logical(i)) { - i <- which(i) - } - stopifnot( - is.numeric(i) || is.character(i) - ) + value <- vec_recycle(value, vec_size(i)) + value <- vec_cast(value, to = x) - value <- vec_recycle(value, vec_size(i)) - value <- vec_cast(value, to = x) + d <- vec_dims(x) - d <- vec_dims(x) + if (d == 1) { + x[i] <- value + } else if (d == 2) { + x[i, ] <- value + } else { + stop("Can't slice-assign arrays.", call. = FALSE) + } - if (d == 1) { - x[i] <- value - } else if (d == 2) { - x[i, ] <- value - } else { - stop("Can't slice-assign arrays.", call. = FALSE) + x } - x -} + vec_recycle <- function(x, size) { + if (is.null(x) || is.null(size)) { + return(NULL) + } + + n_x <- vec_size(x) -vec_recycle <- function(x, size) { - if (is.null(x) || is.null(size)) { - return(NULL) + if (n_x == size) { + x + } else if (size == 0L) { + vec_slice(x, 0L) + } else if (n_x == 1L) { + vec_slice(x, rep(1L, size)) + } else { + stop("Incompatible lengths: ", n_x, ", ", size, call. = FALSE) + } } - n_x <- vec_size(x) + # Coercion ---------------------------------------------------------------- - if (n_x == size) { - x - } else if (size == 0L) { - vec_slice(x, 0L) - } else if (n_x == 1L) { - vec_slice(x, rep(1L, size)) - } else { - stop("Incompatible lengths: ", n_x, ", ", size, call. = FALSE) + vec_cast_common <- function(xs, to = NULL) { + ptype <- vec_ptype_common(xs, ptype = to) + lapply(xs, vec_cast, to = ptype) } -} + vec_cast <- function(x, to) { + if (is.null(x)) { + return(NULL) + } + if (is.null(to)) { + return(x) + } -# Coercion ---------------------------------------------------------------- + if (vec_is_unspecified(x)) { + return(vec_init(to, vec_size(x))) + } -vec_cast_common <- function(xs, to = NULL) { - ptype <- vec_ptype_common(xs, ptype = to) - lapply(xs, vec_cast, to = ptype) -} + stop_incompatible_cast <- function(x, to) { + stop( + sprintf( + "Can't convert <%s> to <%s>.", + .rlang_vctrs_typeof(x), + .rlang_vctrs_typeof(to) + ), + call. = FALSE + ) + } -vec_cast <- function(x, to) { - if (is.null(x)) { - return(NULL) - } - if (is.null(to)) { - return(x) - } + lgl_cast <- function(x, to) { + lgl_cast_from_num <- function(x) { + if (any(!x %in% c(0L, 1L))) { + stop_incompatible_cast(x, to) + } + as.logical(x) + } - if (vec_is_unspecified(x)) { - return(vec_init(to, vec_size(x))) - } + switch( + .rlang_vctrs_typeof(x), + logical = x, + integer = , + double = lgl_cast_from_num(x), + stop_incompatible_cast(x, to) + ) + } + + int_cast <- function(x, to) { + int_cast_from_dbl <- function(x) { + out <- suppressWarnings(as.integer(x)) + if (any((out != x) | xor(is.na(x), is.na(out)))) { + stop_incompatible_cast(x, to) + } else { + out + } + } - stop_incompatible_cast <- function(x, to) { - stop( - sprintf("Can't convert <%s> to <%s>.", + switch( .rlang_vctrs_typeof(x), - .rlang_vctrs_typeof(to) - ), - call. = FALSE - ) - } + logical = as.integer(x), + integer = x, + double = int_cast_from_dbl(x), + stop_incompatible_cast(x, to) + ) + } - lgl_cast <- function(x, to) { - lgl_cast_from_num <- function(x) { - if (any(!x %in% c(0L, 1L))) { + dbl_cast <- function(x, to) { + switch( + .rlang_vctrs_typeof(x), + logical = , + integer = as.double(x), + double = x, stop_incompatible_cast(x, to) - } - as.logical(x) + ) } - switch( - .rlang_vctrs_typeof(x), - logical = x, - integer = , - double = lgl_cast_from_num(x), - stop_incompatible_cast(x, to) - ) - } + chr_cast <- function(x, to) { + switch( + .rlang_vctrs_typeof(x), + character = x, + stop_incompatible_cast(x, to) + ) + } - int_cast <- function(x, to) { - int_cast_from_dbl <- function(x) { - out <- suppressWarnings(as.integer(x)) - if (any((out != x) | xor(is.na(x), is.na(out)))) { + list_cast <- function(x, to) { + switch( + .rlang_vctrs_typeof(x), + list = x, stop_incompatible_cast(x, to) - } else { - out - } + ) } - switch( - .rlang_vctrs_typeof(x), - logical = as.integer(x), - integer = x, - double = int_cast_from_dbl(x), - stop_incompatible_cast(x, to) - ) - } + df_cast <- function(x, to) { + # Check for extra columns + if (length(setdiff(names(x), names(to))) > 0) { + stop( + "Can't convert data frame because of missing columns.", + call. = FALSE + ) + } - dbl_cast <- function(x, to) { - switch( - .rlang_vctrs_typeof(x), - logical = , - integer = as.double(x), - double = x, - stop_incompatible_cast(x, to) - ) - } + # Avoid expensive [.data.frame method + out <- as.list(x) - chr_cast <- function(x, to) { - switch( - .rlang_vctrs_typeof(x), - character = x, - stop_incompatible_cast(x, to) - ) - } + # Coerce common columns + common <- intersect(names(x), names(to)) + out[common] <- Map(vec_cast, out[common], to[common]) - list_cast <- function(x, to) { - switch( - .rlang_vctrs_typeof(x), - list = x, - stop_incompatible_cast(x, to) - ) - } + # Add new columns + from_type <- setdiff(names(to), names(x)) + out[from_type] <- lapply(to[from_type], vec_init, n = vec_size(x)) - df_cast <- function(x, to) { - # Check for extra columns - if (length(setdiff(names(x), names(to))) > 0 ) { - stop("Can't convert data frame because of missing columns.", call. = FALSE) - } + # Ensure columns are ordered according to `to` + out <- out[names(to)] - # Avoid expensive [.data.frame method - out <- as.list(x) + new_data_frame(out) + } - # Coerce common columns - common <- intersect(names(x), names(to)) - out[common] <- Map(vec_cast, out[common], to[common]) + rlib_df_cast <- function(x, to) { + new_data_frame(df_cast(x, to), .class = "tbl") + } + tib_cast <- function(x, to) { + new_data_frame(df_cast(x, to), .class = c("tbl_df", "tbl")) + } - # Add new columns - from_type <- setdiff(names(to), names(x)) - out[from_type] <- lapply(to[from_type], vec_init, n = vec_size(x)) + switch( + .rlang_vctrs_typeof(to), + logical = lgl_cast(x, to), + integer = int_cast(x, to), + double = dbl_cast(x, to), + character = chr_cast(x, to), + list = list_cast(x, to), - # Ensure columns are ordered according to `to` - out <- out[names(to)] + base_data_frame = df_cast(x, to), + rlib_data_frame = rlib_df_cast(x, to), + tibble = tib_cast(x, to), - new_data_frame(out) + stop_incompatible_cast(x, to) + ) } - rlib_df_cast <- function(x, to) { - new_data_frame(df_cast(x, to), .class = "tbl") - } - tib_cast <- function(x, to) { - new_data_frame(df_cast(x, to), .class = c("tbl_df", "tbl")) - } + vec_ptype_common <- function(xs, ptype = NULL) { + if (!is.null(ptype)) { + return(vec_ptype(ptype)) + } - switch( - .rlang_vctrs_typeof(to), - logical = lgl_cast(x, to), - integer = int_cast(x, to), - double = dbl_cast(x, to), - character = chr_cast(x, to), - list = list_cast(x, to), + xs <- Filter(function(x) !is.null(x), xs) - base_data_frame = df_cast(x, to), - rlib_data_frame = rlib_df_cast(x, to), - tibble = tib_cast(x, to), + if (length(xs) == 0) { + return(NULL) + } - stop_incompatible_cast(x, to) - ) -} + if (length(xs) == 1) { + out <- vec_ptype(xs[[1]]) + } else { + xs <- map(xs, vec_ptype) + out <- Reduce(vec_ptype2, xs) + } -vec_ptype_common <- function(xs, ptype = NULL) { - if (!is.null(ptype)) { - return(vec_ptype(ptype)) + vec_ptype_finalise(out) } - xs <- Filter(function(x) !is.null(x), xs) + vec_ptype_finalise <- function(x) { + if (is.data.frame(x)) { + x[] <- lapply(x, vec_ptype_finalise) + return(x) + } - if (length(xs) == 0) { - return(NULL) + if (inherits(x, "rlang_unspecified")) { + logical() + } else { + x + } } - if (length(xs) == 1) { - out <- vec_ptype(xs[[1]]) - } else { - xs <- map(xs, vec_ptype) - out <- Reduce(vec_ptype2, xs) - } + vec_ptype <- function(x) { + if (vec_is_unspecified(x)) { + return(.rlang_vctrs_unspecified()) + } - vec_ptype_finalise(out) -} + if (is.data.frame(x)) { + out <- new_data_frame(lapply(x, vec_ptype)) -vec_ptype_finalise <- function(x) { - if (is.data.frame(x)) { - x[] <- lapply(x, vec_ptype_finalise) - return(x) - } + attrib <- attributes(x) + attrib$row.names <- attr(out, "row.names") + attributes(out) <- attrib - if (inherits(x, "rlang_unspecified")) { - logical() - } else { - x - } -} + return(out) + } -vec_ptype <- function(x) { - if (vec_is_unspecified(x)) { - return(.rlang_vctrs_unspecified()) + vec_slice(x, 0) } - if (is.data.frame(x)) { - out <- new_data_frame(lapply(x, vec_ptype)) + vec_ptype2 <- function(x, y) { + stop_incompatible_type <- function(x, y) { + stop( + sprintf( + "Can't combine types <%s> and <%s>.", + .rlang_vctrs_typeof(x), + .rlang_vctrs_typeof(y) + ), + call. = FALSE + ) + } - attrib <- attributes(x) - attrib$row.names <- attr(out, "row.names") - attributes(out) <- attrib + x_type <- .rlang_vctrs_typeof(x) + y_type <- .rlang_vctrs_typeof(y) - return(out) - } + if (x_type == "unspecified" && y_type == "unspecified") { + return(.rlang_vctrs_unspecified()) + } + if (x_type == "unspecified") { + return(y) + } + if (y_type == "unspecified") { + return(x) + } - vec_slice(x, 0) -} + df_ptype2 <- function(x, y) { + set_partition <- function(x, y) { + list( + both = intersect(x, y), + only_x = setdiff(x, y), + only_y = setdiff(y, x) + ) + } -vec_ptype2 <- function(x, y) { - stop_incompatible_type <- function(x, y) { - stop( - sprintf("Can't combine types <%s> and <%s>.", - .rlang_vctrs_typeof(x), - .rlang_vctrs_typeof(y)), - call. = FALSE - ) - } + # Avoid expensive [.data.frame + x <- as.list(vec_slice(x, 0)) + y <- as.list(vec_slice(y, 0)) - x_type <- .rlang_vctrs_typeof(x) - y_type <- .rlang_vctrs_typeof(y) + # Find column types + names <- set_partition(names(x), names(y)) + if (length(names$both) > 0) { + common_types <- Map(vec_ptype2, x[names$both], y[names$both]) + } else { + common_types <- list() + } + only_x_types <- x[names$only_x] + only_y_types <- y[names$only_y] - if (x_type == "unspecified" && y_type == "unspecified") { - return(.rlang_vctrs_unspecified()) - } - if (x_type == "unspecified") { - return(y) - } - if (y_type == "unspecified") { - return(x) - } + # Combine and construct + out <- c(common_types, only_x_types, only_y_types) + out <- out[c(names(x), names$only_y)] + new_data_frame(out) + } - df_ptype2 <- function(x, y) { - set_partition <- function(x, y) { - list( - both = intersect(x, y), - only_x = setdiff(x, y), - only_y = setdiff(y, x) - ) + rlib_df_ptype2 <- function(x, y) { + new_data_frame(df_ptype2(x, y), .class = "tbl") + } + tib_ptype2 <- function(x, y) { + new_data_frame(df_ptype2(x, y), .class = c("tbl_df", "tbl")) } - # Avoid expensive [.data.frame - x <- as.list(vec_slice(x, 0)) - y <- as.list(vec_slice(y, 0)) + ptype <- switch( + x_type, - # Find column types - names <- set_partition(names(x), names(y)) - if (length(names$both) > 0) { - common_types <- Map(vec_ptype2, x[names$both], y[names$both]) - } else { - common_types <- list() - } - only_x_types <- x[names$only_x] - only_y_types <- y[names$only_y] + logical = switch( + y_type, + logical = x, + integer = y, + double = y, + stop_incompatible_type(x, y) + ), - # Combine and construct - out <- c(common_types, only_x_types, only_y_types) - out <- out[c(names(x), names$only_y)] - new_data_frame(out) - } + integer = switch( + .rlang_vctrs_typeof(y), + logical = x, + integer = x, + double = y, + stop_incompatible_type(x, y) + ), - rlib_df_ptype2 <- function(x, y) { - new_data_frame(df_ptype2(x, y), .class = "tbl") - } - tib_ptype2 <- function(x, y) { - new_data_frame(df_ptype2(x, y), .class = c("tbl_df", "tbl")) - } + double = switch( + .rlang_vctrs_typeof(y), + logical = x, + integer = x, + double = x, + stop_incompatible_type(x, y) + ), - ptype <- switch( - x_type, + character = switch( + .rlang_vctrs_typeof(y), + character = x, + stop_incompatible_type(x, y) + ), - logical = switch( - y_type, - logical = x, - integer = y, - double = y, - stop_incompatible_type(x, y) - ), + list = switch( + .rlang_vctrs_typeof(y), + list = x, + stop_incompatible_type(x, y) + ), - integer = switch( - .rlang_vctrs_typeof(y), - logical = x, - integer = x, - double = y, - stop_incompatible_type(x, y) - ), + base_data_frame = switch( + .rlang_vctrs_typeof(y), + base_data_frame = , + s3_data_frame = df_ptype2(x, y), + rlib_data_frame = rlib_df_ptype2(x, y), + tibble = tib_ptype2(x, y), + stop_incompatible_type(x, y) + ), - double = switch( - .rlang_vctrs_typeof(y), - logical = x, - integer = x, - double = x, - stop_incompatible_type(x, y) - ), + rlib_data_frame = switch( + .rlang_vctrs_typeof(y), + base_data_frame = , + rlib_data_frame = , + s3_data_frame = rlib_df_ptype2(x, y), + tibble = tib_ptype2(x, y), + stop_incompatible_type(x, y) + ), - character = switch( - .rlang_vctrs_typeof(y), - character = x, - stop_incompatible_type(x, y) - ), + tibble = switch( + .rlang_vctrs_typeof(y), + base_data_frame = , + rlib_data_frame = , + tibble = , + s3_data_frame = tib_ptype2(x, y), + stop_incompatible_type(x, y) + ), - list = switch( - .rlang_vctrs_typeof(y), - list = x, - stop_incompatible_type(x, y) - ), - - base_data_frame = switch( - .rlang_vctrs_typeof(y), - base_data_frame = , - s3_data_frame = df_ptype2(x, y), - rlib_data_frame = rlib_df_ptype2(x, y), - tibble = tib_ptype2(x, y), stop_incompatible_type(x, y) - ), - - rlib_data_frame = switch( - .rlang_vctrs_typeof(y), - base_data_frame = , - rlib_data_frame = , - s3_data_frame = rlib_df_ptype2(x, y), - tibble = tib_ptype2(x, y), - stop_incompatible_type(x, y) - ), - - tibble = switch( - .rlang_vctrs_typeof(y), - base_data_frame = , - rlib_data_frame = , - tibble = , - s3_data_frame = tib_ptype2(x, y), - stop_incompatible_type(x, y) - ), + ) - stop_incompatible_type(x, y) - ) + vec_slice(ptype, 0) + } - vec_slice(ptype, 0) -} + .rlang_vctrs_typeof <- function(x) { + if (is.object(x)) { + class <- class(x) -.rlang_vctrs_typeof <- function(x) { - if (is.object(x)) { - class <- class(x) + if (identical(class, "rlang_unspecified")) { + return("unspecified") + } + if (identical(class, "data.frame")) { + return("base_data_frame") + } + if (identical(class, c("tbl", "data.frame"))) { + return("rlib_data_frame") + } + if (identical(class, c("tbl_df", "tbl", "data.frame"))) { + return("tibble") + } + if (inherits(x, "data.frame")) { + return("s3_data_frame") + } - if (identical(class, "rlang_unspecified")) { - return("unspecified") - } - if (identical(class, "data.frame")) { - return("base_data_frame") - } - if (identical(class, c("tbl", "data.frame"))) { - return("rlib_data_frame") - } - if (identical(class, c("tbl_df", "tbl", "data.frame"))) { - return("tibble") - } - if (inherits(x, "data.frame")) { - return("s3_data_frame") + class <- paste0(class, collapse = "/") + stop(sprintf("Unimplemented class <%s>.", class), call. = FALSE) } - class <- paste0(class, collapse = "/") - stop(sprintf("Unimplemented class <%s>.", class), call. = FALSE) - } + type <- typeof(x) + switch( + type, + NULL = return("null"), + logical = if (vec_is_unspecified(x)) { + return("unspecified") + } else { + return(type) + }, + integer = , + double = , + character = , + raw = , + list = return(type) + ) - type <- typeof(x) - switch( - type, - NULL = return("null"), - logical = if (vec_is_unspecified(x)) { - return("unspecified") - } else { - return(type) - }, - integer = , - double = , - character = , - raw = , - list = return(type) - ) - - stop(sprintf("Unimplemented type <%s>.", type), call. = FALSE) -} + stop(sprintf("Unimplemented type <%s>.", type), call. = FALSE) + } -vec_is_unspecified <- function(x) { - !is.object(x) && - typeof(x) == "logical" && - length(x) && - all(vapply(x, identical, logical(1), NA)) -} + vec_is_unspecified <- function(x) { + !is.object(x) && + typeof(x) == "logical" && + length(x) && + all(vapply(x, identical, logical(1), NA)) + } -.rlang_vctrs_unspecified <- function(x = NULL) { - structure( - rep(NA, length(x)), - class = "rlang_unspecified" - ) -} + .rlang_vctrs_unspecified <- function(x = NULL) { + structure( + rep(NA, length(x)), + class = "rlang_unspecified" + ) + } -.rlang_vctrs_s3_method <- function(generic, class, env = parent.frame()) { - fn <- get(generic, envir = env) + .rlang_vctrs_s3_method <- function(generic, class, env = parent.frame()) { + fn <- get(generic, envir = env) - ns <- asNamespace(topenv(fn)) - tbl <- ns$.__S3MethodsTable__. + ns <- asNamespace(topenv(fn)) + tbl <- ns$.__S3MethodsTable__. - for (c in class) { - name <- paste0(generic, ".", c) - if (exists(name, envir = tbl, inherits = FALSE)) { - return(get(name, envir = tbl)) - } - if (exists(name, envir = globalenv(), inherits = FALSE)) { - return(get(name, envir = globalenv())) + for (c in class) { + name <- paste0(generic, ".", c) + if (exists(name, envir = tbl, inherits = FALSE)) { + return(get(name, envir = tbl)) + } + if (exists(name, envir = globalenv(), inherits = FALSE)) { + return(get(name, envir = globalenv())) + } } - } - NULL -} - -environment() + NULL + } + environment() }) data_frame <- compat_vctrs$data_frame diff --git a/R/cran-app.R b/R/cran-app.R index 6a4aaca7..639eab7b 100644 --- a/R/cran-app.R +++ b/R/cran-app.R @@ -1,4 +1,3 @@ - # nocov start fake_env <- new.env(parent = emptyenv()) @@ -30,13 +29,16 @@ dummy_so <- function() { on.exit(unlink(tmp, recursive = TRUE), add = TRUE) withr::local_dir(tmp) - writeLines(c( - "#include ", - "", - "SEXP minus1(SEXP i) {", - " return Rf_ScalarInteger(REAL(i)[0] - 1.0);", - "}" - ), "init.c") + writeLines( + c( + "#include ", + "", + "SEXP minus1(SEXP i) {", + " return Rf_ScalarInteger(REAL(i)[0] - 1.0);", + "}" + ), + "init.c" + ) callr::rcmd("SHLIB", c("-o", "foo.so", "init.c")) so <- readBin("foo.so", "raw", file.size("foo.so")) @@ -44,8 +46,12 @@ dummy_so <- function() { so } -make_dummy_binary <- function(data, path, platform = get_platform(), - r_version = getRversion()) { +make_dummy_binary <- function( + data, + path, + platform = get_platform(), + r_version = getRversion() +) { # Need these files: # NAMESPACE -- nded to add useDynLib() and import() as needed # DESCRIPTION -- need `Built` field @@ -71,7 +77,10 @@ make_dummy_binary <- function(data, path, platform = get_platform(), if (paste0("", data$NeedsCompilation) %in% c("yes", "true")) { # TODO: multi-arch on Windows - writeLines(paste0("useDynLib(", package, ")"), file.path(package, "NAMESPACE")) + writeLines( + paste0("useDynLib(", package, ")"), + file.path(package, "NAMESPACE") + ) sofile <- paste0(package, .Platform$dynlib.ext) sopath <- if (nzchar(.Platform$r_arch)) { file.path(package, "libs", .Platform$r_arch, sofile) @@ -88,7 +97,6 @@ make_dummy_binary <- function(data, path, platform = get_platform(), if (platform == "windows") { pkgfile <- paste0(package, "_", data$Version, ".zip") zip::zip(pkgfile, package) - } else if (platform == "macos") { pkgfile <- paste0(package, "_", data$Version, ".tgz") utils::tar(pkgfile, package) @@ -103,10 +111,11 @@ make_dummy_binary <- function(data, path, platform = get_platform(), } standardize_dummy_packages <- function(packages) { - packages <- packages %||% data.frame( - stringsAsFactors = FALSE, - Package = character() - ) + packages <- packages %||% + data.frame( + stringsAsFactors = FALSE, + Package = character() + ) if (!"Package" %in% names(packages)) { packages$Package <- paste0("pkg", seq_len(nrow(packages))) @@ -163,12 +172,18 @@ make_dummy_repo_platform <- function(repo, packages = NULL, options = list()) { extra$archive <- latest[extra$Package] != extra$Version for (i in seq_len(nrow(packages))) { - if (options[["platform"]] == "source" && - packages$Package[i] %in% options[["no_sources"]]) next - if (options[["platform"]] != "source" && - packages$Package[i] %in% options[["no_binaries"]]) next + if ( + options[["platform"]] == "source" && + packages$Package[i] %in% options[["no_sources"]] + ) + next + if ( + options[["platform"]] != "source" && + packages$Package[i] %in% options[["no_binaries"]] + ) + next if (extra$archive[i]) { - if (isTRUE(options$no_archive)) next; + if (isTRUE(options$no_archive)) next pkg_dir <- file.path(pkgs_dir, "Archive", packages$Package[i]) } else { pkg_dir <- pkgs_dir @@ -203,7 +218,6 @@ make_dummy_repo_platform <- function(repo, packages = NULL, options = list()) { file.remove(file.path(pkgs_dir, "PACKAGES.gz")) } else if (file.exists(file.path(pkgs_dir, "PACKAGES.gz"))) { # if empty - } if (isTRUE(options$no_packages_rds)) { @@ -211,7 +225,7 @@ make_dummy_repo_platform <- function(repo, packages = NULL, options = list()) { } if (!isTRUE(options$no_metadata)) { - current <- extra[!extra$archive,, drop = FALSE] + current <- extra[!extra$archive, , drop = FALSE] meta <- data.frame( stringsAsFactors = FALSE, file = current$file, @@ -227,7 +241,7 @@ make_dummy_repo_platform <- function(repo, packages = NULL, options = list()) { } if (!isTRUE(options$no_archive)) { - archive <- extra[extra$archive,, drop = FALSE] + archive <- extra[extra$archive, , drop = FALSE] adf <- list() adir <- file.path(pkgs_dir, "Archive") if (file.exists(adir)) { @@ -248,11 +262,12 @@ make_dummy_repo_platform <- function(repo, packages = NULL, options = list()) { invisible() } -cran_app <- function(packages = NULL, - log = interactive(), - basic_auth = NULL, - options = list()) { - +cran_app <- function( + packages = NULL, + log = interactive(), + basic_auth = NULL, + options = list() +) { app <- webfakes::new_app() # Log requests by default @@ -268,9 +283,10 @@ cran_app <- function(packages = NULL, ) hdr <- req$get_header("Authorization") %||% "" if (exp != hdr) { - res$ - set_header("WWW-Authenticate", "Basic realm=\"CRAN with auth\"")$ - send_status(401L) + res$set_header( + "WWW-Authenticate", + "Basic realm=\"CRAN with auth\"" + )$send_status(401L) } else { "next" } @@ -279,7 +295,11 @@ cran_app <- function(packages = NULL, # Parse all kinds of bodies app$use("json body parser" = webfakes::mw_json()) - app$use("text body parser" = webfakes::mw_text(type = c("text/plain", "application/json"))) + app$use( + "text body parser" = webfakes::mw_text( + type = c("text/plain", "application/json") + ) + ) app$use("multipart body parser" = webfakes::mw_multipart()) app$use("URL encoded body parser" = webfakes::mw_urlencoded()) @@ -322,7 +342,8 @@ dcf <- function(txt) { as.data.frame(read.dcf(textConnection(txt)), stringsAsFactors = FALSE) } -cran_app_pkgs <- dcf(" +cran_app_pkgs <- dcf( + " Package: pkg1 Version: 1.0.0 @@ -342,16 +363,14 @@ cran_app_pkgs <- dcf(" Package: pkg3 Version: 0.9.9 -") +" +) fix_port <- function(x) { gsub("http://127[.]0[.]0[.]1:[0-9]+", "http://127.0.0.1:", x) } -bioc_app <- function(packages = NULL, - log = interactive(), - options = list()) { - +bioc_app <- function(packages = NULL, log = interactive(), options = list()) { app <- webfakes::new_app() # Log requests by default @@ -359,7 +378,11 @@ bioc_app <- function(packages = NULL, # Parse all kinds of bodies app$use("json body parser" = webfakes::mw_json()) - app$use("text body parser" = webfakes::mw_text(type = c("text/plain", "application/json"))) + app$use( + "text body parser" = webfakes::mw_text( + type = c("text/plain", "application/json") + ) + ) app$use("multipart body parser" = webfakes::mw_multipart()) app$use("URL encoded body parser" = webfakes::mw_urlencoded()) @@ -398,7 +421,6 @@ bioc_app <- function(packages = NULL, } make_bioc_repo <- function(repo, packages, options) { - packages <- standardize_dummy_packages(packages) bioc_version <- options$bioc_version %||% bioconductor$get_bioc_version() @@ -413,27 +435,27 @@ make_bioc_repo <- function(repo, packages, options) { # BioCsoft options$repo_prefix <- sprintf("packages/%s/bioc", bioc_version) - pkg_soft <- packages[bioc_repo == "soft",, drop = FALSE] + pkg_soft <- packages[bioc_repo == "soft", , drop = FALSE] make_dummy_repo(repo, pkg_soft, options) # BioCann options$repo_prefix <- sprintf("packages/%s/data/annotation", bioc_version) - pkg_ann <- packages[bioc_repo == "ann",, drop = FALSE] + pkg_ann <- packages[bioc_repo == "ann", , drop = FALSE] make_dummy_repo(repo, pkg_ann, options) # BioCexp options$repo_prefix <- sprintf("packages/%s/data/experiment", bioc_version) - pkg_exp <- packages[bioc_repo == "exp",, drop = FALSE] + pkg_exp <- packages[bioc_repo == "exp", , drop = FALSE] make_dummy_repo(repo, pkg_ann, options) # BioCworkflows options$repo_prefix <- sprintf("packages/%s/workflows", bioc_version) - pkg_workflows <- packages[bioc_repo == "workflows",, drop = FALSE] + pkg_workflows <- packages[bioc_repo == "workflows", , drop = FALSE] make_dummy_repo(repo, pkg_workflows, options) # BioCbooks options$repo_prefix <- sprintf("packages/%s/books", bioc_version) - pkg_books <- packages[bioc_repo == "books",, drop = FALSE] + pkg_books <- packages[bioc_repo == "books", , drop = FALSE] make_dummy_repo(repo, pkg_books, options) config <- system.file("fixtures", "bioc-config.yaml", package = "pkgcache") @@ -446,20 +468,24 @@ make_bioc_repo <- function(repo, packages, options) { invisible() } -auth_proxy_app <- function(repo_url = NULL, username = "username", - password = "token") { +auth_proxy_app <- function( + repo_url = NULL, + username = "username", + password = "token" +) { repo_url <- repo_url %||% "https://cloud.r-project.org" webfakes::new_app()$get( - webfakes::new_regexp(""), function(req, res) { + webfakes::new_regexp(""), + function(req, res) { exp <- paste("Basic", base64_encode(paste0(username, ":", password))) hdr <- req$get_header("Authorization") %||% "" if (exp != hdr) { - res$ - set_header("WWW-Authenticate", "Basic realm=\"CRAN with auth\"")$ - send_status(401L) + res$set_header( + "WWW-Authenticate", + "Basic realm=\"CRAN with auth\"" + )$send_status(401L) } else { - res$ - redirect(sprintf("%s/%s", repo_url, req$path)) + res$redirect(sprintf("%s/%s", repo_url, req$path)) } } ) diff --git a/R/data-frame.R b/R/data-frame.R index 67ed540f..2651c2a4 100644 --- a/R/data-frame.R +++ b/R/data-frame.R @@ -1,4 +1,3 @@ - find_in_data_frame <- function(df, ..., .list = NULL) { cols <- drop_nulls(c(list(...), .list)) idx <- seq_len(nrow(df)) diff --git a/R/errors.R b/R/errors.R index 09123886..7d1d585a 100644 --- a/R/errors.R +++ b/R/errors.R @@ -1,4 +1,3 @@ - # # Standalone file for better error handling ---------------------------- # # If can allow package dependencies, then you are probably better off @@ -135,7 +134,6 @@ # deparsed `call` column in the trace is not compatible with rlang. err <- local({ - # -- dependencies ----------------------------------------------------- rstudio_detect <- rstudio$detect @@ -162,7 +160,8 @@ err <- local({ message <- .makeMessage(..., domain = domain) structure( list(message = message, call = call., srcref = srcref), - class = c("condition")) + class = c("condition") + ) } #' Create a new error condition @@ -240,9 +239,11 @@ err <- local({ # baseenv(), so it is almost as if it was in baseenv() itself, like # .Last.value. We save the print methods here as well, and then they # will be found automatically. - if (! "org:r-lib" %in% search()) { - do.call("attach", list(new.env(), pos = length(search()), - name = "org:r-lib")) + if (!"org:r-lib" %in% search()) { + do.call( + "attach", + list(new.env(), pos = length(search()), name = "org:r-lib") + ) } env <- as.environment("org:r-lib") env$.Last.error <- cond @@ -253,13 +254,15 @@ err <- local({ # If this is not an error, then we'll just return here. This allows # throwing interrupt conditions for example, with the same UI. - if (! inherits(cond, "error")) return(invisible()) + if (!inherits(cond, "error")) return(invisible()) .hide_from_trace <- NULL # Top-level handler, this is intended for testing only for now, # and its design might change. - if (!is.null(th <- getOption("rlib_error_handler")) && - is.function(th)) { + if ( + !is.null(th <- getOption("rlib_error_handler")) && + is.function(th) + ) { return(th(cond)) } @@ -307,16 +310,19 @@ err <- local({ .hide_from_trace <- 1 force(call) srcref <- utils::getSrcref(sys.call()) - withCallingHandlers({ - expr - }, error = function(e) { - .hide_from_trace <- 0:1 - e$srcref <- srcref - if (!inherits(err, "condition")) { - err <- new_error(err, call. = call) + withCallingHandlers( + { + expr + }, + error = function(e) { + .hide_from_trace <- 0:1 + e$srcref <- srcref + if (!inherits(err, "condition")) { + err <- new_error(err, call. = call) + } + throw_error(err, parent = e) } - throw_error(err, parent = e) - }) + ) } # -- rethrowing conditions from C code --------------------------------- @@ -346,7 +352,13 @@ err <- local({ name <- native_name(.NAME) err <- new_error("Native call to `", name, "` failed", call. = call1) cerror <- if (inherits(e, "simpleError")) "c_error" - class(err) <- c(cerror, "rlib_error_3_0", "rlib_error", "error", "condition") + class(err) <- c( + cerror, + "rlib_error_3_0", + "rlib_error", + "error", + "condition" + ) throw_error(err, parent = e) } ) @@ -380,7 +392,13 @@ err <- local({ name <- native_name(.NAME) err <- new_error("Native call to `", name, "` failed", call. = call1) cerror <- if (inherits(e, "simpleError")) "c_error" - class(err) <- c(cerror, "rlib_error_3_0", "rlib_error", "error", "condition") + class(err) <- c( + cerror, + "rlib_error_3_0", + "rlib_error", + "error", + "condition" + ) throw_error(err, parent = e) } ) @@ -399,7 +417,6 @@ err <- local({ #' @return A condition object, with the trace added. add_trace_back <- function(cond, frame = NULL) { - idx <- seq_len(sys.parent(1L)) frames <- sys.frames()[idx] @@ -460,15 +477,20 @@ err <- local({ mark_invisible_frames <- function(funs, frames) { visibles <- rep(TRUE, length(frames)) hide <- lapply(frames, "[[", ".hide_from_trace") - w_hide <- unlist(mapply(seq_along(hide), hide, FUN = function(i, w) { - i + w - }, SIMPLIFY = FALSE)) + w_hide <- unlist(mapply( + seq_along(hide), + hide, + FUN = function(i, w) { + i + w + }, + SIMPLIFY = FALSE + )) w_hide <- w_hide[w_hide <= length(frames)] visibles[w_hide] <- FALSE hide_from <- which(funs %in% names(invisible_frames)) for (start in hide_from) { - hide_this <- invisible_frames[[ funs[start] ]] + hide_this <- invisible_frames[[funs[start]]] for (i in seq_along(hide_this)) { if (start + i > length(funs)) break if (funs[start + i] != hide_this[i]) break @@ -485,7 +507,8 @@ err <- local({ "cli::cli_abort" = c( "rlang::abort", "rlang:::signal_abort", - "base::signalCondition"), + "base::signalCondition" + ), "rlang::abort" = c("rlang:::signal_abort", "base::signalCondition") ) @@ -506,10 +529,13 @@ err <- local({ get_call_scope <- function(call, ns) { if (is.na(ns)) return("global") if (!is.call(call)) return("") - if (is.call(call[[1]]) && - (call[[1]][[1]] == quote(`::`) || call[[1]][[1]] == quote(`:::`))) return("") + if ( + is.call(call[[1]]) && + (call[[1]][[1]] == quote(`::`) || call[[1]][[1]] == quote(`:::`)) + ) + return("") if (ns == "base") return("::") - if (! ns %in% loadedNamespaces()) return("") + if (!ns %in% loadedNamespaces()) return("") name <- call_name(call) nsenv <- asNamespace(ns)$.__NAMESPACE__. if (is.null(nsenv)) return("::") @@ -527,7 +553,15 @@ err <- local({ topenv(x, matchThisEnv = err_env) } - new_trace <- function (calls, parents, visibles, namespaces, scopes, srcrefs, pids) { + new_trace <- function( + calls, + parents, + visibles, + namespaces, + scopes, + srcrefs, + pids + ) { trace <- data.frame( stringsAsFactors = FALSE, parent = parents, @@ -579,9 +613,15 @@ err <- local({ # -- S3 methods ------------------------------------------------------- - format_error <- function(x, trace = FALSE, class = FALSE, - advice = !trace, full = trace, header = TRUE, - ...) { + format_error <- function( + x, + trace = FALSE, + class = FALSE, + advice = !trace, + full = trace, + header = TRUE, + ... + ) { if (has_cli()) { format_error_cli(x, trace, class, advice, full, header, ...) } else { @@ -589,8 +629,7 @@ err <- local({ } } - print_error <- function(x, trace = TRUE, class = TRUE, - advice = !trace, ...) { + print_error <- function(x, trace = TRUE, class = TRUE, advice = !trace, ...) { writeLines(format_error(x, trace, class, advice, ...)) } @@ -678,21 +717,20 @@ err <- local({ paste0(if (add_exp) exp, cond$message), if (inherits(cond$parent, "condition")) { msg <- if (full && inherits(cond$parent, "rlib_error_3_0")) { - format(cond$parent, - trace = FALSE, - full = TRUE, - class = FALSE, - header = FALSE, - advice = FALSE + format( + cond$parent, + trace = FALSE, + full = TRUE, + class = FALSE, + header = FALSE, + advice = FALSE ) } else { conditionMessage(cond$parent) } add_exp <- substr(cli::ansi_strip(msg[1]), 1, 1) != "!" if (add_exp) msg[1] <- paste0(exp, msg[1]) - c(format_header_line_cli(cond$parent, prefix = "Caused by error"), - msg - ) + c(format_header_line_cli(cond$parent, prefix = "Caused by error"), msg) } ) } @@ -706,12 +744,13 @@ err <- local({ paste0(if (add_exp) exp, cond$message), if (inherits(cond$parent, "condition")) { msg <- if (full && inherits(cond$parent, "rlib_error_3_0")) { - format(cond$parent, - trace = FALSE, - full = TRUE, - class = FALSE, - header = FALSE, - advice = FALSE + format( + cond$parent, + trace = FALSE, + full = TRUE, + class = FALSE, + header = FALSE, + advice = FALSE ) } else { conditionMessage(cond$parent) @@ -720,7 +759,8 @@ err <- local({ if (add_exp) { msg[1] <- paste0(exp, msg[1]) } - c(format_header_line_plain(cond$parent, prefix = "Caused by error"), + c( + format_header_line_plain(cond$parent, prefix = "Caused by error"), msg ) } @@ -736,9 +776,15 @@ err <- local({ # - error message, just `conditionMessage()` # - advice about .Last.error and/or .Last.error.trace - format_error_cli <- function(x, trace = TRUE, class = TRUE, - advice = !trace, full = trace, - header = TRUE, ...) { + format_error_cli <- function( + x, + trace = TRUE, + class = TRUE, + advice = !trace, + full = trace, + header = TRUE, + ... + ) { p_class <- if (class) format_class_cli(x) p_header <- if (header) format_header_line_cli(x) p_msg <- cnd_message_cli(x, full) @@ -747,11 +793,7 @@ err <- local({ c("---", "Backtrace:", format_trace_cli(x$trace)) } - c(p_class, - p_header, - p_msg, - p_advice, - p_trace) + c(p_class, p_header, p_msg, p_advice, p_trace) } format_header_line_cli <- function(x, prefix = NULL) { @@ -800,7 +842,6 @@ err <- local({ paste0("file://", ref$file), params = c(line = ref$line, col = ref$col) ) - } else { paste0("line ", ref$line) } @@ -841,7 +882,7 @@ err <- local({ lines <- paste0( cli::col_silver(format(x$num), ". "), - ifelse (visible, "", "| "), + ifelse(visible, "", "| "), scope, vapply(x$call, format_trace_call_cli, character(1)), srcref @@ -857,16 +898,24 @@ err <- local({ format_trace_call_cli <- function(call) { cl <- trimws(format(call)) - if (length(cl) > 1) { cl <- paste0(cl[1], " ", cli::symbol$ellipsis) } + if (length(cl) > 1) { + cl <- paste0(cl[1], " ", cli::symbol$ellipsis) + } fmc <- cli::code_highlight(cl)[1] cli::ansi_strtrim(fmc, cli::console_width() - 5) } # ---------------------------------------------------------------------- - format_error_plain <- function(x, trace = TRUE, class = TRUE, - advice = !trace, full = trace, header = TRUE, - ...) { + format_error_plain <- function( + x, + trace = TRUE, + class = TRUE, + advice = !trace, + full = trace, + header = TRUE, + ... + ) { p_class <- if (class) format_class_plain(x) p_header <- if (header) format_header_line_plain(x) p_msg <- cnd_message_plain(x, full) @@ -875,11 +924,7 @@ err <- local({ c("---", "Backtrace:", format_trace_plain(x$trace)) } - c(p_class, - p_header, - p_msg, - p_advice, - p_trace) + c(p_class, p_header, p_msg, p_advice, p_trace) } format_trace_plain <- function(x, ...) { @@ -909,7 +954,7 @@ err <- local({ lines <- paste0( paste0(format(x$num), ". "), - ifelse (visible, "", "| "), + ifelse(visible, "", "| "), scope, vapply(x$call, format_trace_call_plain, character(1)), srcref @@ -968,7 +1013,9 @@ err <- local({ format_trace_call_plain <- function(call) { fmc <- trimws(format(call)[1]) - if (length(fmc) > 1) { fmc <- paste0(fmc[1], " ...") } + if (length(fmc) > 1) { + fmc <- paste0(fmc[1], " ...") + } strtrim(fmc, getOption("width") - 5) } @@ -1025,7 +1072,9 @@ err <- local({ FALSE } else if (tolower(getOption("knitr.in.progress", "false")) == "true") { FALSE - } else if (tolower(getOption("rstudio.notebook.executing", "false")) == "true") { + } else if ( + tolower(getOption("rstudio.notebook.executing", "false")) == "true" + ) { FALSE } else if (identical(Sys.getenv("TESTTHAT"), "true")) { FALSE @@ -1040,13 +1089,14 @@ err <- local({ rstudio_stdout <- function() { rstudio <- rstudio_detect() - rstudio$type %in% c( - "rstudio_console", - "rstudio_console_starting", - "rstudio_build_pane", - "rstudio_job", - "rstudio_render_pane" - ) + rstudio$type %in% + c( + "rstudio_console", + "rstudio_console_starting", + "rstudio_build_pane", + "rstudio_job", + "rstudio_render_pane" + ) } default_output <- function() { @@ -1064,7 +1114,12 @@ err <- local({ registerS3method("format", "rlib_trace_3_0", format_trace, baseenv()) registerS3method("print", "rlib_error_3_0", print_error, baseenv()) registerS3method("print", "rlib_trace_3_0", print_trace, baseenv()) - registerS3method("conditionMessage", "rlib_error_3_0", cnd_message, baseenv()) + registerS3method( + "conditionMessage", + "rlib_error_3_0", + cnd_message, + baseenv() + ) } } @@ -1092,38 +1147,39 @@ err <- local({ structure( list( - .internal = err_env, - new_cond = new_cond, - new_error = new_error, - throw = throw, - throw_error = throw_error, - chain_error = chain_error, - chain_call = chain_call, + .internal = err_env, + new_cond = new_cond, + new_error = new_error, + throw = throw, + throw_error = throw_error, + chain_error = chain_error, + chain_call = chain_call, chain_clean_call = chain_clean_call, - add_trace_back = add_trace_back, - process_call = process_call, - onload_hook = onload_hook, + add_trace_back = add_trace_back, + process_call = process_call, + onload_hook = onload_hook, format = list( - advice = format_advice, - call = format_call, - class = format_class, - error = format_error, + advice = format_advice, + call = format_call, + class = format_class, + error = format_error, error_heading = format_error_heading, - header_line = format_header_line, - srcref = format_srcref, - trace = format_trace + header_line = format_header_line, + srcref = format_srcref, + trace = format_trace ) ), - class = c("standalone_errors", "standalone")) + class = c("standalone_errors", "standalone") + ) }) # These are optional, and feel free to remove them if you prefer to # call them through the `err` object. -new_cond <- err$new_cond -new_error <- err$new_error -throw <- err$throw -throw_error <- err$throw_error -chain_error <- err$chain_error -chain_call <- err$chain_call +new_cond <- err$new_cond +new_error <- err$new_error +throw <- err$throw +throw_error <- err$throw_error +chain_error <- err$chain_error +chain_call <- err$chain_call chain_clean_call <- err$chain_clean_call diff --git a/R/errors2.R b/R/errors2.R index 794ceb0e..d47a35f8 100644 --- a/R/errors2.R +++ b/R/errors2.R @@ -1,4 +1,3 @@ - new_pkgcache_cond <- function(..., call. = FALSE, class = NULL, data = NULL) { cnd <- new_cond(..., call. = call.) cnd[names(data)] <- data @@ -6,7 +5,12 @@ new_pkgcache_cond <- function(..., call. = FALSE, class = NULL, data = NULL) { cnd } -new_pkgcache_warning <- function(..., call. = FALSE, class = NULL, data = NULL) { +new_pkgcache_warning <- function( + ..., + call. = FALSE, + class = NULL, + data = NULL +) { cnd <- new_cond(..., call. = call.) cnd[names(data)] <- data class(cnd) <- c(class, "pkgcache_condition", "warning", class(cnd)) diff --git a/R/files.R b/R/files.R index 3061d5a3..e8fa193b 100644 --- a/R/files.R +++ b/R/files.R @@ -1,4 +1,3 @@ - mkdirp <- function(dir, msg = NULL) { s <- vlapply(dir, dir.create, recursive = TRUE, showWarnings = FALSE) invisible(s) @@ -11,7 +10,8 @@ file_get_time <- function(path) { file_set_time <- function(path, time = Sys.time()) { assert_that( is_character(path), - inherits(time, "POSIXct")) + inherits(time, "POSIXct") + ) vlapply(path, Sys.setFileTime, time = time) } @@ -20,9 +20,13 @@ file_set_time <- function(path, time = Sys.time()) { file_copy_with_time <- function(from, to) { mkdirp(dirname(to)) if (length(to) > 1) { - mapply(file.copy, from, to, - MoreArgs = list(overwrite = TRUE, copy.date = TRUE), - USE.NAMES = FALSE) + mapply( + file.copy, + from, + to, + MoreArgs = list(overwrite = TRUE, copy.date = TRUE), + USE.NAMES = FALSE + ) } else { file.copy(from, to, overwrite = TRUE, copy.date = TRUE) } diff --git a/R/installed.R b/R/installed.R index d6530e6c..21baebd1 100644 --- a/R/installed.R +++ b/R/installed.R @@ -1,4 +1,3 @@ - # This is not actually used anywhere, we I'll leave it here. # It might be useful for testing improvements for the more complicated # parsers. @@ -24,7 +23,7 @@ parse_description <- function(path) { } fix_encodings <- function(lst, col = "Encoding") { - if (! col %in% names(lst)) return(lst) + if (!col %in% names(lst)) return(lst) utf8 <- which(!is.na(lst[[col]]) & lst[[col]] == "UTF-8") other <- which(!is.na(lst[[col]]) & lst[[col]] != "UTf-8") unq <- unique(lst[[col]][other]) @@ -37,10 +36,13 @@ fix_encodings <- function(lst, col = "Encoding") { for (u in unq) { wh <- which(!is.na(lst[[col]]) & lst[[col]] == u) for (i in seq_along(lst)) { - tryCatch({ - trs <- iconv(lst[[i]][wh], u, "UTF-8") - lst[[i]][wh] <- ifelse(is.na(trs), lst[[i]][wh], trs) - }, error = function(e) NULL) + tryCatch( + { + trs <- iconv(lst[[i]][wh], u, "UTF-8") + lst[[i]][wh] <- ifelse(is.na(trs), lst[[i]][wh], trs) + }, + error = function(e) NULL + ) } } } @@ -85,7 +87,6 @@ parse_packages <- function(path, type = NULL) { type <- type %||% guess_packages_type(path) if (type == "rds") { tab <- readRDS(path) - } else { cmp <- .Call(pkgcache_read_raw, path)[[1]] if (is.character(cmp)) { @@ -96,7 +97,7 @@ parse_packages <- function(path, type = NULL) { if (getRversion() >= "4.0.0") { bts <- memDecompress(cmp, type = "gzip") } else { - bts <- gzip_decompress(cmp) # nocov + bts <- gzip_decompress(cmp) # nocov } } else if (type == "bzip2") { bts <- memDecompress(cmp, type = "bzip2") @@ -107,11 +108,12 @@ parse_packages <- function(path, type = NULL) { } # Might still be an RDS we just uncompressed - if (length(bts) >= 2 && + if ( + length(bts) >= 2 && bts[1] %in% as.raw(c(0x58, 0x41, 0x42)) && - bts[2] == 0x0a) { + bts[2] == 0x0a + ) { tab <- unserialize(bts) - } else { tab <- .Call(pkgcache_parse_packages_raw, bts) tab[] <- lapply(tab, function(x) { @@ -141,27 +143,39 @@ packages_types <- c("uncompressed", "gzip", "bzip2", "xz", "rds") guess_packages_type <- function(path) { buf <- readBin(path, what = "raw", 6) - if (length(buf) >= 3 && + if ( + length(buf) >= 3 && buf[1] == 0x1f && buf[2] == 0x8b && - buf[3] == 0x08) return("gzip") + buf[3] == 0x08 + ) + return("gzip") - if (length(buf) >= 3 && + if ( + length(buf) >= 3 && buf[1] == 0x42 && buf[2] == 0x5a && - buf[3] == 0x68) return("bzip2") + buf[3] == 0x68 + ) + return("bzip2") - if (length(buf) >= 6 && + if ( + length(buf) >= 6 && buf[1] == 0xFD && buf[2] == 0x37 && buf[3] == 0x7A && buf[4] == 0x58 && buf[5] == 0x5A && - buf[6] == 0x00) return("xz") + buf[6] == 0x00 + ) + return("xz") - if (length(buf) >= 2 && + if ( + length(buf) >= 2 && buf[1] %in% as.raw(c(0x58, 0x41, 0x42)) && - buf[2] == 0x0a) return("rds") + buf[2] == 0x0a + ) + return("rds") "uncompressed" } @@ -231,17 +245,22 @@ guess_packages_type <- function(path) { #' #' @export -parse_installed <- function(library = .libPaths(), priority = NULL, - lowercase = FALSE, reencode = TRUE, - packages = NULL) { +parse_installed <- function( + library = .libPaths(), + priority = NULL, + lowercase = FALSE, + reencode = TRUE, + packages = NULL +) { stopifnot( "`library` must be a character vector" = is.character(library), - "`priority` must be `NULL` or a character vector" = - is.null(priority) || is.character(priority) || identical(NA, priority), + "`priority` must be `NULL` or a character vector" = is.null(priority) || + is.character(priority) || + identical(NA, priority), "`library` cannot have length zero" = length(library) > 0, "`lowercase` must be a boolean flag" = is_flag(lowercase), - "`packages` must be `NULL` or a character vector" = - is.null(packages) || is.character(packages) + "`packages` must be `NULL` or a character vector" = is.null(packages) || + is.character(packages) ) # Merge multiple libraries @@ -293,7 +312,8 @@ parse_installed <- function(library = .libPaths(), priority = NULL, bad <- prs[[2]] != "" tbl <- tbl[!bad, ] cnd <- new_pkgcache_warning( - "Cannot read DESCRIPTION files:\n", paste0("* ", prs[[2]][bad], "\n"), + "Cannot read DESCRIPTION files:\n", + paste0("* ", prs[[2]][bad], "\n"), class = "pkgcache_broken_install", data = list(errors = data_frame(file = dscs[bad], error = prs[[2]][bad])) ) diff --git a/R/iso-date.R b/R/iso-date.R index 687af22a..8736e156 100644 --- a/R/iso-date.R +++ b/R/iso-date.R @@ -1,4 +1,3 @@ - milliseconds <- function(x) as.difftime(as.numeric(x) / 1000, units = "secs") seconds <- function(x) as.difftime(as.numeric(x), units = "secs") minutes <- function(x) as.difftime(as.numeric(x), units = "mins") @@ -22,7 +21,6 @@ parse_iso_8601 <- function(dates, default_tz = "UTC") { } parse_iso_parts <- function(mm, default_tz) { - num <- nrow(mm) ## ----------------------------------------------------------------- @@ -104,8 +102,11 @@ parse_iso_parts <- function(mm, default_tz) { if (default_tz != "UTC") { ftna <- mm$tzpm == "" & mm$tz == "" if (any(ftna)) { - dd <- as.POSIXct(format_iso_8601(date[ftna]), - "%Y-%m-%dT%H:%M:%S+00:00", tz = default_tz) + dd <- as.POSIXct( + format_iso_8601(date[ftna]), + "%Y-%m-%dT%H:%M:%S+00:00", + tz = default_tz + ) date[ftna] <- dd } } @@ -117,25 +118,29 @@ iso_regex <- paste0( "^\\s*", "(?[\\+-]?\\d{4}(?!\\d{2}\\b))", "(?:(?-?)", - "(?:(?0[1-9]|1[0-2])", - "(?:\\g{dash}(?[12]\\d|0[1-9]|3[01]))?", - "|W(?[0-4]\\d|5[0-3])(?:-?(?[1-7]))?", - "|(?00[1-9]|0[1-9]\\d|[12]\\d{2}|3", - "(?:[0-5]\\d|6[1-6])))", - "(?