├── .Rbuildignore ├── .github ├── .gitignore └── workflows │ ├── R-CMD-check.yaml │ ├── pkgdown.yaml │ ├── pr-commands.yaml │ └── test-coverage.yaml ├── .gitignore ├── DESCRIPTION ├── LICENSE ├── Makefile ├── NAMESPACE ├── NEWS.md ├── R ├── aa-assertthat.R ├── aaa-async.R ├── assertions.R ├── backoff.R ├── call-function.R ├── constant.R ├── context.R ├── debug.R ├── deferred.R ├── delay.R ├── detect.R ├── event-loop.R ├── events.R ├── every.R ├── filter.R ├── http-sse.R ├── http.R ├── map.R ├── onload.R ├── process.R ├── r-process.R ├── race.R ├── reflect.R ├── replicate.R ├── retry.R ├── sequence.R ├── some.R ├── synchronise.R ├── timeout.R ├── timer.R ├── try-each.R ├── until.R ├── utils.R ├── uuid.R ├── when_all.R ├── when_any.R ├── whilst.R ├── worker-pool.R └── xprocess.R ├── README.Rmd ├── README.md ├── async.Rproj ├── codecov.yml ├── inst └── NEWS.md ├── man ├── async.Rd ├── async_backoff.Rd ├── async_constant.Rd ├── async_debug.Rd ├── async_detect.Rd ├── async_every.Rd ├── async_filter.Rd ├── async_map.Rd ├── async_race_some.Rd ├── async_reflect.Rd ├── async_replicate.Rd ├── async_retry.Rd ├── async_retryable.Rd ├── async_sequence.Rd ├── async_timeout.Rd ├── async_timer.Rd ├── async_try_each.Rd ├── async_until.Rd ├── async_whilst.Rd ├── call_function.Rd ├── call_with_callback.Rd ├── def__make_error_object.Rd ├── deferred.Rd ├── delay.Rd ├── event_emitter.Rd ├── external_process.Rd ├── http_get.Rd ├── http_head.Rd ├── http_post.Rd ├── http_setopt.Rd ├── http_stop_for_status.Rd ├── is_async.Rd ├── is_deferred.Rd ├── run_event_loop.Rd ├── run_process.Rd ├── run_r_process.Rd ├── sse_events.Rd ├── synchronise.Rd ├── when_all.Rd ├── when_some.Rd └── worker_pool.Rd ├── tests ├── testthat.R └── testthat │ ├── _snaps │ ├── backoff.md │ ├── http-sse.md │ └── http.md │ ├── helper-mock.R │ ├── helper.R │ ├── setup-httpbin.R │ ├── teardown-httpbin.R │ ├── test-amap.R │ ├── test-async.R │ ├── test-backoff.R │ ├── test-call-function.R │ ├── test-cancel-early.R │ ├── test-cancel-sync.R │ ├── test-cancel.R │ ├── test-constant.R │ ├── test-debug.R │ ├── test-deferred-http.R │ ├── test-deferred-pieces.R │ ├── test-deferred-then.R │ ├── test-deferred-timeout.R │ ├── test-deferred.R │ ├── test-detect.R │ ├── test-each-of.R │ ├── test-each.R │ ├── test-errors.R │ ├── test-event-emitter-async.R │ ├── test-event-emitter.R │ ├── test-event-loop.R │ ├── test-every.R │ ├── test-external-process.R │ ├── test-filter.R │ ├── test-http-events.R │ ├── test-http-file.R │ ├── test-http-sse.R │ ├── test-http.R │ ├── test-parallel.R │ ├── test-process.R │ ├── test-progress.R │ ├── test-race.R │ ├── test-reflect.R │ ├── test-replicate.R │ ├── test-retry.R │ ├── test-retryable.R │ ├── test-sequence.R │ ├── test-shared.R │ ├── test-some.R │ ├── test-synchronise.R │ ├── test-timeout.R │ ├── test-timer.R │ ├── test-try-each.R │ ├── test-until.R │ ├── test-when-all.R │ ├── test-when-any.R │ ├── test-when-some.R │ ├── test-whilst.R │ └── test-worker-pool.R └── vignettes ├── async-example.R ├── async-example.Rmd ├── async-example.html ├── internals.R ├── internals.Rmd └── internals.html /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^Makefile$ 4 | ^README.Rmd$ 5 | ^NEWS.md$ 6 | ^.travis.yml$ 7 | ^appveyor.yml$ 8 | ^src/async.so$ 9 | ^src/.*\.o$ 10 | ^.env$ 11 | ^\.Rprofile$ 12 | ^r-packages$ 13 | ^\.github$ 14 | ^vignettes$ 15 | ^codecov\.yml$ 16 | ^dev-lib$ 17 | -------------------------------------------------------------------------------- /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | # 4 | # NOTE: This workflow is overkill for most R packages and 5 | # check-standard.yaml is likely a better choice. 6 | # usethis::use_github_action("check-standard") will install it. 7 | on: 8 | push: 9 | branches: [main, master] 10 | pull_request: 11 | 12 | name: R-CMD-check.yaml 13 | 14 | permissions: read-all 15 | 16 | jobs: 17 | R-CMD-check: 18 | runs-on: ${{ matrix.config.os }} 19 | 20 | name: ${{ matrix.config.os }} (${{ matrix.config.r }}) 21 | 22 | strategy: 23 | fail-fast: false 24 | matrix: 25 | config: 26 | - {os: macos-latest, r: 'release'} 27 | 28 | - {os: windows-latest, r: 'release'} 29 | # use 4.0 or 4.1 to check with rtools40's older compiler 30 | - {os: windows-latest, r: 'oldrel-4'} 31 | 32 | - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} 33 | - {os: ubuntu-latest, r: 'release'} 34 | - {os: ubuntu-latest, r: 'oldrel-1'} 35 | - {os: ubuntu-latest, r: 'oldrel-2'} 36 | - {os: ubuntu-latest, r: 'oldrel-3'} 37 | - {os: ubuntu-latest, r: 'oldrel-4'} 38 | 39 | env: 40 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 41 | R_KEEP_PKG_SOURCE: yes 42 | 43 | steps: 44 | - uses: actions/checkout@v4 45 | 46 | - uses: r-lib/actions/setup-pandoc@v2 47 | 48 | - uses: r-lib/actions/setup-r@v2 49 | with: 50 | r-version: ${{ matrix.config.r }} 51 | http-user-agent: ${{ matrix.config.http-user-agent }} 52 | use-public-rspm: true 53 | 54 | - uses: r-lib/actions/setup-r-dependencies@v2 55 | with: 56 | extra-packages: any::rcmdcheck 57 | needs: check 58 | 59 | - uses: r-lib/actions/check-r-package@v2 60 | with: 61 | upload-snapshots: true 62 | build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' 63 | -------------------------------------------------------------------------------- /.github/workflows/pkgdown.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | release: 8 | types: [published] 9 | workflow_dispatch: 10 | 11 | name: pkgdown.yaml 12 | 13 | permissions: read-all 14 | 15 | jobs: 16 | pkgdown: 17 | runs-on: ubuntu-latest 18 | # Only restrict concurrency for non-PR jobs 19 | concurrency: 20 | group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} 21 | env: 22 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 23 | permissions: 24 | contents: write 25 | steps: 26 | - uses: actions/checkout@v4 27 | 28 | - uses: r-lib/actions/setup-pandoc@v2 29 | 30 | - uses: r-lib/actions/setup-r@v2 31 | with: 32 | use-public-rspm: true 33 | 34 | - uses: r-lib/actions/setup-r-dependencies@v2 35 | with: 36 | extra-packages: any::pkgdown, local::. 37 | needs: website 38 | 39 | - name: Build site 40 | run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE) 41 | shell: Rscript {0} 42 | 43 | - name: Deploy to GitHub pages 🚀 44 | if: github.event_name != 'pull_request' 45 | uses: JamesIves/github-pages-deploy-action@v4.5.0 46 | with: 47 | clean: false 48 | branch: gh-pages 49 | folder: docs 50 | -------------------------------------------------------------------------------- /.github/workflows/pr-commands.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | issue_comment: 5 | types: [created] 6 | 7 | name: pr-commands.yaml 8 | 9 | permissions: read-all 10 | 11 | jobs: 12 | document: 13 | if: ${{ github.event.issue.pull_request && (github.event.comment.author_association == 'MEMBER' || github.event.comment.author_association == 'OWNER') && startsWith(github.event.comment.body, '/document') }} 14 | name: document 15 | runs-on: ubuntu-latest 16 | env: 17 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 18 | permissions: 19 | contents: write 20 | steps: 21 | - uses: actions/checkout@v4 22 | 23 | - uses: r-lib/actions/pr-fetch@v2 24 | with: 25 | repo-token: ${{ secrets.GITHUB_TOKEN }} 26 | 27 | - uses: r-lib/actions/setup-r@v2 28 | with: 29 | use-public-rspm: true 30 | 31 | - uses: r-lib/actions/setup-r-dependencies@v2 32 | with: 33 | extra-packages: any::roxygen2 34 | needs: pr-document 35 | 36 | - name: Document 37 | run: roxygen2::roxygenise() 38 | shell: Rscript {0} 39 | 40 | - name: commit 41 | run: | 42 | git config --local user.name "$GITHUB_ACTOR" 43 | git config --local user.email "$GITHUB_ACTOR@users.noreply.github.com" 44 | git add man/\* NAMESPACE 45 | git commit -m 'Document' 46 | 47 | - uses: r-lib/actions/pr-push@v2 48 | with: 49 | repo-token: ${{ secrets.GITHUB_TOKEN }} 50 | 51 | style: 52 | if: ${{ github.event.issue.pull_request && (github.event.comment.author_association == 'MEMBER' || github.event.comment.author_association == 'OWNER') && startsWith(github.event.comment.body, '/style') }} 53 | name: style 54 | runs-on: ubuntu-latest 55 | env: 56 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 57 | permissions: 58 | contents: write 59 | steps: 60 | - uses: actions/checkout@v4 61 | 62 | - uses: r-lib/actions/pr-fetch@v2 63 | with: 64 | repo-token: ${{ secrets.GITHUB_TOKEN }} 65 | 66 | - uses: r-lib/actions/setup-r@v2 67 | 68 | - name: Install dependencies 69 | run: install.packages("styler") 70 | shell: Rscript {0} 71 | 72 | - name: Style 73 | run: styler::style_pkg() 74 | shell: Rscript {0} 75 | 76 | - name: commit 77 | run: | 78 | git config --local user.name "$GITHUB_ACTOR" 79 | git config --local user.email "$GITHUB_ACTOR@users.noreply.github.com" 80 | git add \*.R 81 | git commit -m 'Style' 82 | 83 | - uses: r-lib/actions/pr-push@v2 84 | with: 85 | repo-token: ${{ secrets.GITHUB_TOKEN }} 86 | -------------------------------------------------------------------------------- /.github/workflows/test-coverage.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | 8 | name: test-coverage.yaml 9 | 10 | permissions: read-all 11 | 12 | jobs: 13 | test-coverage: 14 | runs-on: ubuntu-latest 15 | env: 16 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 17 | 18 | steps: 19 | - uses: actions/checkout@v4 20 | 21 | - uses: r-lib/actions/setup-r@v2 22 | with: 23 | use-public-rspm: true 24 | 25 | - uses: r-lib/actions/setup-r-dependencies@v2 26 | with: 27 | extra-packages: any::covr, any::xml2 28 | needs: coverage 29 | 30 | - name: Test coverage 31 | run: | 32 | cov <- covr::package_coverage( 33 | quiet = FALSE, 34 | clean = FALSE, 35 | install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") 36 | ) 37 | covr::to_cobertura(cov) 38 | shell: Rscript {0} 39 | 40 | - uses: codecov/codecov-action@v4 41 | with: 42 | # Fail if error if not on PR, or if on PR and token is given 43 | fail_ci_if_error: ${{ github.event_name != 'pull_request' || secrets.CODECOV_TOKEN }} 44 | file: ./cobertura.xml 45 | plugin: noop 46 | disable_search: true 47 | token: ${{ secrets.CODECOV_TOKEN }} 48 | 49 | - name: Show testthat output 50 | if: always() 51 | run: | 52 | ## -------------------------------------------------------------------- 53 | find '${{ runner.temp }}/package' -name 'testthat.Rout*' -exec cat '{}' \; || true 54 | shell: bash 55 | 56 | - name: Upload test results 57 | if: failure() 58 | uses: actions/upload-artifact@v4 59 | with: 60 | name: coverage-test-failures 61 | path: ${{ runner.temp }}/package 62 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | /src/*.o 5 | /src/async.so 6 | /src/async.dll 7 | /.env 8 | /r-packages 9 | /dev-lib 10 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: async 2 | Title: Asynchronous Computation and 'I/O' 3 | Version: 0.0.0.9004 4 | Author: Gábor Csárdi 5 | Maintainer: Gábor Csárdi 6 | Description: The 'async' package brings asynchronous ('async') computation 7 | and 'I/O' to 'R'. It uses an event loop to schedule asynchronous 8 | functions that report their results via deferred values. Deferred 9 | values can be chained together for complex async computation, and they 10 | are evaluated lazily, at synchronisation points. 11 | License: MIT + file LICENSE 12 | URL: https://github.com/gaborcsardi/async#readme 13 | BugReports: https://github.com/gaborcsardi/async/issues 14 | RoxygenNote: 7.3.1.9000 15 | Depends: R (>= 3.2.0) 16 | Suggests: 17 | cli, 18 | covr, 19 | debugme, 20 | desc, 21 | jsonlite, 22 | pingr, 23 | webfakes, 24 | testthat (>= 3.2.0), 25 | withr 26 | Encoding: UTF-8 27 | Imports: 28 | callr (>= 3.7.6), 29 | curl (>= 3.2), 30 | processx (>= 3.3.0.9001), 31 | R6, 32 | utils 33 | Roxygen: list(markdown = TRUE, r6 = FALSE) 34 | KeepSource: yes 35 | Config/testthat/edition: 3 36 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2017 2 | COPYRIGHT HOLDER: Gábor Csárdi 3 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | all: README.md 3 | 4 | README.md: README.Rmd 5 | Rscript -e "library(knitr); knit('$<', output = '$@', quiet = TRUE)" 6 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(format,async_rejected) 4 | S3method(format,async_where) 5 | S3method(print,async_rejected) 6 | S3method(print,async_rejected_summary) 7 | S3method(print,async_where) 8 | S3method(summary,async_rejected) 9 | export(async) 10 | export(async_backoff) 11 | export(async_constant) 12 | export(async_debug) 13 | export(async_debug_remove_shortcuts) 14 | export(async_debug_shortcuts) 15 | export(async_detect) 16 | export(async_every) 17 | export(async_filter) 18 | export(async_list) 19 | export(async_map) 20 | export(async_next) 21 | export(async_race) 22 | export(async_race_some) 23 | export(async_reflect) 24 | export(async_reject) 25 | export(async_replicate) 26 | export(async_retry) 27 | export(async_retryable) 28 | export(async_sequence) 29 | export(async_some) 30 | export(async_step) 31 | export(async_step_back) 32 | export(async_timeout) 33 | export(async_timer) 34 | export(async_tree) 35 | export(async_try_each) 36 | export(async_until) 37 | export(async_wait_for) 38 | export(async_where) 39 | export(async_whilst) 40 | export(call_function) 41 | export(deferred) 42 | export(delay) 43 | export(event_emitter) 44 | export(external_process) 45 | export(http_get) 46 | export(http_head) 47 | export(http_post) 48 | export(http_setopt) 49 | export(http_stop_for_status) 50 | export(is_async) 51 | export(is_deferred) 52 | export(run_event_loop) 53 | export(run_process) 54 | export(run_r_process) 55 | export(sse_events) 56 | export(synchronise) 57 | export(when_all) 58 | export(when_any) 59 | export(when_some) 60 | importFrom(R6,R6Class) 61 | importFrom(utils,getSrcDirectory) 62 | importFrom(utils,getSrcFilename) 63 | importFrom(utils,getSrcLocation) 64 | importFrom(utils,head) 65 | importFrom(utils,modifyList) 66 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | inst/NEWS.md -------------------------------------------------------------------------------- /R/aa-assertthat.R: -------------------------------------------------------------------------------- 1 | 2 | assert_that <- function(..., env = parent.frame(), msg = NULL) { 3 | res <- see_if(..., env = env, msg = msg) 4 | if (res) return(TRUE) 5 | stop(res, "msg") 6 | } 7 | 8 | see_if <- function(..., env = parent.frame(), msg = NULL) { 9 | asserts <- eval(substitute(alist(...))) 10 | 11 | for (assertion in asserts) { 12 | res <- tryCatch({ 13 | eval(assertion, env) 14 | }, error = function(e) { 15 | structure(FALSE, msg = e$message) 16 | }) 17 | check_result(res) 18 | 19 | # Failed, so figure out message to produce 20 | if (!res) { 21 | if (is.null(msg)) 22 | msg <- get_message(res, assertion, env) 23 | return(structure(FALSE, msg = msg)) 24 | } 25 | } 26 | 27 | res 28 | } 29 | 30 | check_result <- function(x) { 31 | if (!is.logical(x)) 32 | stop("assert_that: assertion must return a logical value") 33 | if (any(is.na(x))) 34 | stop("assert_that: missing values present in assertion") 35 | if (length(x) != 1) { 36 | stop("assert_that: length of assertion is not 1") 37 | } 38 | 39 | TRUE 40 | } 41 | 42 | get_message <- function(res, call, env = parent.frame()) { 43 | stopifnot(is.call(call), length(call) >= 1) 44 | 45 | if (has_attr(res, "msg")) { 46 | return(attr(res, "msg")) 47 | } 48 | 49 | f <- eval(call[[1]], env) 50 | if (!is.primitive(f)) call <- match.call(f, call) 51 | fname <- deparse(call[[1]]) 52 | 53 | fail <- on_failure(f) %||% base_fs[[fname]] %||% fail_default 54 | fail(call, env) 55 | } 56 | 57 | # The default failure message works in the same way as stopifnot, so you can 58 | # continue to use any function that returns a logical value: you just won't 59 | # get a friendly error message. 60 | # The code below says you get the first 60 characters plus a ... 61 | fail_default <- function(call, env) { 62 | call_string <- deparse(call, width.cutoff = 60L) 63 | if (length(call_string) > 1L) { 64 | call_string <- paste0(call_string[1L], "...") 65 | } 66 | 67 | paste0(call_string, " is not TRUE") 68 | } 69 | 70 | on_failure <- function(x) attr(x, "fail") 71 | 72 | "on_failure<-" <- function(x, value) { 73 | stopifnot(is.function(x), identical(names(formals(value)), c("call", "env"))) 74 | attr(x, "fail") <- value 75 | x 76 | } 77 | 78 | has_attr <- function(x, which) !is.null(attr(x, which, exact = TRUE)) 79 | on_failure(has_attr) <- function(call, env) { 80 | paste0(deparse(call$x), " does not have attribute ", eval(call$which, env)) 81 | } 82 | "%has_attr%" <- has_attr 83 | 84 | base_fs <- new.env(parent = emptyenv()) 85 | -------------------------------------------------------------------------------- /R/aaa-async.R: -------------------------------------------------------------------------------- 1 | 2 | #' Create an async function 3 | #' 4 | #' Create an async function, that returns a deferred value, from a 5 | #' regular function. If `fun` is already an async function, then it does 6 | #' nothing, just returns it. 7 | #' 8 | #' The result function will have the same arguments, with the same default 9 | #' values, and the same environment as the original input function. 10 | #' 11 | #' @param fun Original function. 12 | #' @return Async version of the original function. 13 | #' 14 | #' @export 15 | #' @examples 16 | #' f <- function(x) 42 17 | #' af <- async(f) 18 | #' is_async(f) 19 | #' is_async(af) 20 | #' f() 21 | #' synchronise(dx <- af()) 22 | #' dx 23 | 24 | async <- function(fun) { 25 | fun <- as.function(fun) 26 | if (is_async(fun)) return(fun) 27 | 28 | async_fun <- fun 29 | body(async_fun) <- bquote({ 30 | mget(ls(environment(), all.names = TRUE), environment()) 31 | fun2 <- function() { 32 | evalq( 33 | .(body(fun)), 34 | envir = parent.env(environment()) 35 | ) 36 | } 37 | 38 | deferred$new( 39 | type = "async", 40 | action = function(resolve) resolve(fun2()) 41 | ) 42 | }) 43 | 44 | # This is needed, otherwise async_fun might not find 'deferred' 45 | async_env <- new.env(parent = environment(async_fun)) 46 | async_env$deferred <- deferred 47 | environment(async_fun) <- async_env 48 | 49 | mark_as_async(async_fun) 50 | } 51 | 52 | mark_as_async <- function(fun) { 53 | attr(body(fun), "async")$async <- TRUE 54 | 55 | ## These are not valid any more, anyway 56 | attr(fun, "srcref") <- NULL 57 | attr(body(fun), "srcref") <- NULL 58 | 59 | fun 60 | } 61 | 62 | #' Checks if a function is async 63 | #' 64 | #' If `fun` is not a function, an error is thrown. 65 | #' 66 | #' Currently, it checks for the `async` attribute, which is set by 67 | #' [async()]. 68 | #' 69 | #' @param fun Function. 70 | #' @return Logical scalar, whether `fun` is async. 71 | #' 72 | #' @export 73 | #' @examples 74 | #' f <- function(x) 42 75 | #' af <- async(f) 76 | #' is_async(f) 77 | #' is_async(af) 78 | #' f() 79 | #' synchronise(dx <- af()) 80 | #' dx 81 | 82 | is_async <- function(fun) { 83 | assert_that(is.function(fun)) 84 | is.list(a <- attr(body(fun), "async")) && identical(a$async, TRUE) 85 | } 86 | -------------------------------------------------------------------------------- /R/assertions.R: -------------------------------------------------------------------------------- 1 | 2 | is_string <- function(x) { 3 | is.character(x) && length(x) == 1 && !is.na(x) 4 | } 5 | 6 | on_failure(is_string) <- function(call, env) { 7 | paste0(deparse(call$x), " is not a string (length 1 character)") 8 | } 9 | 10 | is_flag <- function(x) { 11 | is.logical(x) && length(x) == 1 && !is.na(x) 12 | } 13 | 14 | on_failure(is_flag) <- function(call, env) { 15 | paste0(deparse(call$x), " is not a flag (length 1 logical)") 16 | } 17 | 18 | is_action_function <- function(x) { 19 | is.function(x) && length(formals(x)) %in% 1:2 20 | } 21 | 22 | on_failure(is_action_function) <- function(call, env) { 23 | paste0(deparse(call$x), " is not a function with two arguments") 24 | } 25 | 26 | is_time_interval <- function(x) { 27 | inherits(x, "difftime") || 28 | (is.numeric(x) && length(x) == 1 && !is.na(x) && x >= 0) 29 | } 30 | 31 | on_failure(is_time_interval) <- function(call, env) { 32 | paste0(deparse(call$x), " is not a valid time interval") 33 | } 34 | 35 | is_count <- function(x) { 36 | is.numeric(x) && length(x) == 1 && !is.na(x) && as.integer(x) == x 37 | } 38 | 39 | on_failure(is_count) <- function(call, env) { 40 | paste0(deparse(call$x), " is not a count (non-negative integer)") 41 | } 42 | 43 | is_flag <- function(x) { 44 | is.logical(x) && length(x) == 1 && !is.na(x) 45 | } 46 | 47 | on_failure(is_flag) <- function(call, env) { 48 | paste0(deparse(call$x), " must be a flag (length 1 logical)") 49 | } 50 | -------------------------------------------------------------------------------- /R/backoff.R: -------------------------------------------------------------------------------- 1 | 2 | #' Retry an asynchronous function with exponential backoff 3 | #' 4 | #' Keeps trying until the function's deferred value resolves without 5 | #' error, or `times` tries have been performed, or `time_limit` seconds 6 | #' have passed since the start of the first try. 7 | #' 8 | #' Note that all unnamed arguments are passed to `task`. 9 | #' 10 | #' @param task An asynchronous function. 11 | #' @param ... Arguments to pass to `task`. 12 | #' @param .args More arguments to pass to `task`. 13 | #' @param times Maximum number of tries. 14 | #' @param time_limit Maximum number of seconds to try. 15 | #' @param custom_backoff If not `NULL` then a callback function to 16 | #' calculate waiting time, after the `i`the try. `i` is passed as an 17 | #' argument. If `NULL`, then the default is used, which is a uniform 18 | #' random number of seconds between 1 and 2^i. 19 | #' @param on_progress Callback function for a progress bar. Retries are 20 | #' announced here, if not `NULL`. `on_progress` is called with two 21 | #' arguments. The first is a named list with entries: 22 | #' * `event`: string that is either `"retry"` or `"givenup"`, 23 | #' * `tries`: number of tried so far, 24 | #' * `spent`: number of seconds spent trying so far, 25 | #' * `error`: the error object for the last failure, 26 | #' * `retry_in`: number of seconds before the next try. 27 | #' The second argument is `progress_data`. 28 | #' @param progress_data `async_backoff()` will pass this object to 29 | #' `on_progress` as the second argument. 30 | #' @return Deferred value for the operation with retries. 31 | #' 32 | #' @family async control flow 33 | #' @export 34 | #' @examples 35 | #' \donttest{ 36 | #' afun <- function() { 37 | #' wait_100_ms <- function(i) 0.1 38 | #' async_backoff( 39 | #' function() if (runif(1) < 0.8) stop("nope") else "yes!", 40 | #' times = 5, 41 | #' custom_backoff = wait_100_ms 42 | #' ) 43 | #' } 44 | #' 45 | #' # There is a slight chance that it fails 46 | #' tryCatch(synchronise(afun()), error = function(e) e) 47 | #' } 48 | 49 | async_backoff <- function(task, ..., .args = list(), times = Inf, 50 | time_limit = Inf, custom_backoff = NULL, 51 | on_progress = NULL, progress_data = NULL) { 52 | 53 | task <- async(task) 54 | args <- c(list(...), .args) 55 | times <- times 56 | time_limit <- time_limit 57 | custom_backoff <- custom_backoff %||% default_backoff 58 | on_progress <- on_progress 59 | progress_data <- progress_data 60 | 61 | did <- 0L 62 | started <- NULL 63 | limit <- NULL 64 | 65 | self <- deferred$new( 66 | type = "backoff", call = sys.call(), 67 | action = function(resolve) { 68 | started <<- Sys.time() 69 | limit <<- started + time_limit 70 | do.call(task, args)$then(self) 71 | }, 72 | parent_reject = function(value, resolve) { 73 | did <<- did + 1L 74 | now <- Sys.time() 75 | if (did < times && now < limit) { 76 | wait <- custom_backoff(did) 77 | if (!is.null(on_progress)) { 78 | on_progress(list( 79 | event = "retry", 80 | tries = did, 81 | spent = now - started, 82 | error = value, 83 | retry_in = wait 84 | ), progress_data) 85 | } 86 | delay(wait)$ 87 | then(function() do.call(task, args))$ 88 | then(self) 89 | } else { 90 | if (!is.null(on_progress)) { 91 | on_progress(list( 92 | event = "givenup", 93 | tries = did, 94 | spent = now - started, 95 | error = value, 96 | retry_in = NA_real_ 97 | ), progress_data) 98 | } 99 | stop(value) 100 | } 101 | } 102 | ) 103 | } 104 | 105 | async_backoff <- mark_as_async(async_backoff) 106 | 107 | default_backoff <- function(i) { 108 | as.integer(stats::runif(1, min = 1, max = 2^i) * 1000) / 1000 109 | } 110 | -------------------------------------------------------------------------------- /R/call-function.R: -------------------------------------------------------------------------------- 1 | 2 | #' Asynchronous function call, in a worker pool 3 | #' 4 | #' The function will be called on another process, very much like 5 | #' [callr::r()]. 6 | #' 7 | #' @param func Function to call. See also the notes at [callr::r()]. 8 | #' @param args Arguments to pass to the function. They will be copied 9 | #' to the worker process. 10 | #' @return Deferred object. 11 | #' 12 | #' @export 13 | 14 | call_function <- function(func, args = list()) { 15 | func; args 16 | 17 | id <- NULL 18 | 19 | deferred$new( 20 | type = "pool-task", call = sys.call(), 21 | action = function(resolve) { 22 | resolve 23 | reject <- environment(resolve)$private$reject 24 | id <<- get_default_event_loop()$add_pool_task( 25 | function(err, res) if (is.null(err)) resolve(res) else reject(err), 26 | list(func = func, args = args)) 27 | }, 28 | on_cancel = function(reason) { 29 | if (!is.null(id)) { 30 | get_default_event_loop()$cancel(id) 31 | } 32 | } 33 | ) 34 | } 35 | 36 | call_function <- mark_as_async(call_function) 37 | -------------------------------------------------------------------------------- /R/constant.R: -------------------------------------------------------------------------------- 1 | 2 | #' Make a minimal deferred that resolves to the specified value 3 | #' 4 | #' This is sometimes useful to start a deferred chain. 5 | #' 6 | #' Note that the evaluation of `value` is forced when the deferred value 7 | #' is created. 8 | #' 9 | #' @param value The value to resolve to. 10 | #' @return A deferred value. 11 | #' 12 | #' @export 13 | #' @examples 14 | #' afun <- async(function() { 15 | #' async_constant(1/100)$ 16 | #' then(function(x) delay(x))$ 17 | #' then(function(x) print(x)) 18 | #' }) 19 | #' synchronise(afun()) 20 | 21 | async_constant <- function(value = NULL) { 22 | force(value) 23 | deferred$new( 24 | type = "constant", call = sys.call(), 25 | function(resolve) resolve(value)) 26 | } 27 | 28 | async_constant <- mark_as_async(async_constant) 29 | -------------------------------------------------------------------------------- /R/context.R: -------------------------------------------------------------------------------- 1 | 2 | async_env <- new.env(parent = emptyenv()) 3 | async_env$loops <- list() 4 | 5 | get_default_event_loop <- function() { 6 | num_loops <- length(async_env$loops) 7 | if (num_loops == 0) { 8 | err <- make_error( 9 | "You can only call async functions from an async context", 10 | class = "async_synchronization_barrier_error" 11 | ) 12 | stop(err) 13 | } 14 | 15 | async_env$loops[[num_loops]] 16 | } 17 | 18 | push_event_loop <- function() { 19 | num_loops <- length(async_env$loops) 20 | if (num_loops > 0) async_env$loops[[num_loops]]$suspend() 21 | new_el <- event_loop$new() 22 | async_env$loops <- c(async_env$loops, list(new_el)) 23 | new_el 24 | } 25 | 26 | pop_event_loop <- function() { 27 | num_loops <- length(async_env$loops) 28 | async_env$loops[[num_loops]] <- NULL 29 | if (num_loops > 1) async_env$loops[[num_loops - 1]]$wakeup() 30 | } 31 | -------------------------------------------------------------------------------- /R/delay.R: -------------------------------------------------------------------------------- 1 | 2 | #' Delay async computation for the specified time 3 | #' 4 | #' Since R is single-threaded, the deferred value might be resolved (much) 5 | #' later than the specified time period. 6 | #' 7 | #' @param delay Time interval in seconds, the amount of time to delay 8 | #' to delay the execution. It can be a fraction of a second. 9 | #' @return A deferred object. 10 | #' 11 | #' @export 12 | #' @examples 13 | #' \donttest{ 14 | #' ## Two HEAD requests with 1/2 sec delay between them 15 | #' resp <- list() 16 | #' afun <- async(function() { 17 | #' http_head("https://eu.httpbin.org?q=2")$ 18 | #' then(function(value) resp[[1]] <<- value$status_code)$ 19 | #' then(function(...) delay(1/2))$ 20 | #' then(function(...) http_head("https://eu.httpbin.org?q=2"))$ 21 | #' then(function(value) resp[[2]] <<- value$status_code) 22 | #' }) 23 | #' synchronise(afun()) 24 | #' resp 25 | #' } 26 | 27 | delay <- function(delay) { 28 | force(delay) 29 | id <- NULL 30 | deferred$new( 31 | type = "delay", call = sys.call(), 32 | action = function(resolve) { 33 | assert_that(is_time_interval(delay)) 34 | force(resolve) 35 | id <<- get_default_event_loop()$add_delayed( 36 | delay, 37 | function() TRUE, 38 | function(err, res) resolve(TRUE) 39 | ) 40 | }, 41 | on_cancel = function(reason) { 42 | if (!is.null(id)) get_default_event_loop()$cancel(id) 43 | } 44 | ) 45 | } 46 | 47 | delay <- mark_as_async(delay) 48 | -------------------------------------------------------------------------------- /R/detect.R: -------------------------------------------------------------------------------- 1 | 2 | #' Find the value of a match, asynchronously 3 | #' 4 | #' All predicates are running in parallel, and the returned match 5 | #' is not guaranteed to be the first one. 6 | #' 7 | #' @param .x A list or atomic vector. 8 | #' @param .p An asynchronous predicate function. 9 | #' @param ... Additional arguments to the predicate function. 10 | #' @param .limit Number of elements to process simulateneously. 11 | #' If it is 1, then the predicate is applied sequentially. 12 | #' @return A deferred value for the result. 13 | #' 14 | #' @family async iterators 15 | #' @export 16 | #' @examples 17 | #' \donttest{ 18 | #' synchronise(async_detect( 19 | #' c("https://eu.httpbin.org/status/404", "https://eu.httpbin.org", 20 | #' "https://eu.httpbin.org/status/403"), 21 | #' async_sequence(http_head, function(x) x$status_code == 200) 22 | #' )) 23 | #' } 24 | 25 | async_detect <- function(.x, .p, ..., .limit = Inf) { 26 | if (.limit < length(.x)) { 27 | async_detect_limit(.x, .p, ..., .limit = .limit) 28 | } else { 29 | async_detect_nolimit(.x, .p, ...) 30 | } 31 | } 32 | 33 | async_detect <- mark_as_async(async_detect) 34 | 35 | async_detect_nolimit <- function(.x, .p, ...) { 36 | defs <- lapply(.x, async(.p), ...) 37 | nx <- length(defs) 38 | done <- FALSE 39 | 40 | self <- deferred$new( 41 | type = "async_detect", call = sys.call(), 42 | action = function(resolve) { 43 | lapply(seq_along(defs), function(idx) { 44 | defs[[idx]]$then(function(val) if (isTRUE(val)) idx)$then(self) 45 | }) 46 | if (nx == 0) resolve(NULL) 47 | }, 48 | parent_resolve = function(value, resolve) { 49 | if (!done && !is.null(value)) { 50 | done <<- TRUE 51 | resolve(.x[[value]]) 52 | } else if (!done) { 53 | nx <<- nx - 1L 54 | if (nx == 0) resolve(NULL) 55 | } 56 | } 57 | ) 58 | } 59 | 60 | async_detect_limit <- function(.x, .p, ..., .limit = .limit) { 61 | len <- length(.x) 62 | nx <- len 63 | .p <- async(.p) 64 | args <- list(...) 65 | 66 | done <- FALSE 67 | nextone <- .limit + 1L 68 | firsts <- lapply(.x[seq_len(.limit)], .p, ...) 69 | 70 | self <- deferred$new( 71 | type = "async_detect (limit)", call = sys.call(), 72 | action = function(resolve) { 73 | lapply(seq_along(firsts), function(idx) { 74 | firsts[[idx]]$then(function(val) if (isTRUE(val)) idx)$then(self) 75 | }) 76 | if (nx == 0) resolve(NULL) 77 | }, 78 | parent_resolve = function(value, resolve) { 79 | if (!done && !is.null(value)) { 80 | done <<- TRUE 81 | resolve(.x[[value]]) 82 | } else if (!done) { 83 | nx <<- nx - 1L 84 | if (nx == 0) { 85 | resolve(NULL) 86 | } else if (nextone <= len) { 87 | idx <- nextone 88 | dx <- .p(.x[[nextone]], ...) 89 | dx$then(function(val) if (isTRUE(val)) idx)$then(self) 90 | nextone <<- nextone + 1L 91 | } 92 | } 93 | } 94 | ) 95 | 96 | self 97 | } 98 | -------------------------------------------------------------------------------- /R/every.R: -------------------------------------------------------------------------------- 1 | 2 | #' Do every or some elements of a list satisfy an asynchronous predicate? 3 | #' 4 | #' @param .x A list or atomic vector. 5 | #' @param .p An asynchronous predicate function. 6 | #' @param ... Additional arguments to the predicate function. 7 | #' @return A deferred value for the result. 8 | #' 9 | #' @family async iterators 10 | #' @export 11 | #' @examples 12 | #' # Check if all numbers are odd 13 | #' # Note the use of force() here. Otherwise x will be evaluated later, 14 | #' # and by then its value might change. 15 | #' is_odd <- async(function(x) { 16 | #' force(x) 17 | #' delay(1/1000)$then(function() as.logical(x %% 2)) 18 | #' }) 19 | #' synchronise(async_every(c(1,3,5,7,10,11), is_odd)) 20 | #' synchronise(async_every(c(1,3,5,7,11), is_odd)) 21 | 22 | async_every <- function(.x, .p, ...) { 23 | defs <- lapply(.x, async(.p), ...) 24 | nx <- length(defs) 25 | done <- FALSE 26 | 27 | deferred$new( 28 | type = "async_every", call = sys.call(), 29 | parents = defs, 30 | action = function(resolve) if (nx == 0) resolve(TRUE), 31 | parent_resolve = function(value, resolve) { 32 | if (!done && !isTRUE(value)) { 33 | done <<- TRUE 34 | resolve(FALSE) 35 | } else if (!done) { 36 | nx <<- nx - 1L 37 | if (nx == 0) resolve(TRUE) 38 | } 39 | } 40 | ) 41 | } 42 | 43 | async_every <- mark_as_async(async_every) 44 | -------------------------------------------------------------------------------- /R/filter.R: -------------------------------------------------------------------------------- 1 | 2 | #' Keep or drop elements using an asyncronous predicate function 3 | #' 4 | #' `async_filter` keep the elements for which `.p` is true. (Tested 5 | #' via `isTRUE()`. `async_reject` is the opposite, it drops them. 6 | #' 7 | #' @param .x A list or atomic vector. 8 | #' @param .p An asynchronous predicate function. 9 | #' @param ... Additional arguments to the predicate function. 10 | #' @return A deferred value for the result. 11 | #' 12 | #' @family async iterators 13 | #' @export 14 | #' @examples 15 | #' \donttest{ 16 | #' ## Filter out non-working URLs 17 | #' afun <- async(function(urls) { 18 | #' test_url <- async_sequence( 19 | #' http_head, function(x) identical(x$status_code, 200L)) 20 | #' async_filter(urls, test_url) 21 | #' }) 22 | #' urls <- c("https://eu.httpbin.org/get", 23 | #' "https://eu.httpbin.org/status/404") 24 | #' synchronise(afun(urls)) 25 | #' } 26 | 27 | async_filter <- function(.x, .p, ...) { 28 | when_all(.list = lapply(.x, async(.p), ...))$ 29 | then(function(res) .x[vlapply(res, isTRUE)]) 30 | } 31 | 32 | async_filter <- mark_as_async(async_filter) 33 | 34 | #' @rdname async_filter 35 | #' @export 36 | 37 | async_reject <- function(.x, .p, ...) { 38 | when_all(.list = lapply(.x, async(.p), ...))$ 39 | then(function(res) .x[! vlapply(res, isTRUE)]) 40 | } 41 | 42 | async_reject <- mark_as_async(async_reject) 43 | -------------------------------------------------------------------------------- /R/http-sse.R: -------------------------------------------------------------------------------- 1 | #' HTTP event emitter for server-sent events 2 | #' 3 | #' Server-sent events are a technique to stream events from a web server 4 | #' to a client, through an open HTTP connection. 5 | #' 6 | #' This class implements an event emitter on an async HTTP query created 7 | #' with [http_get()] and friends, that fires an `"event"` event when the 8 | #' server sends an event. An `"end"` event is emitted when the server 9 | #' closes the connection. 10 | #' 11 | #' An event is a named character vector, the names are the keys of the 12 | #' events. 13 | #' 14 | #' Example using our built-in toy web app: 15 | #' ```r 16 | #' http <- webfakes::new_app_process(async:::sseapp()) 17 | #' stream_events <- function() { 18 | #' query <- http_get(http$url("/sse")) 19 | #' sse <- sse_events$new(query) 20 | #' sse$ 21 | #' listen_on("event", function(event) { 22 | #' writeLines("Got an event:") 23 | #' print(event) 24 | #' })$ 25 | #' listen_on("end", function() { 26 | #' writeLines("Done.") 27 | #' }) 28 | #' query 29 | #' } 30 | #' 31 | #' response <- synchronise(stream_events()) 32 | #' ``` 33 | #' 34 | #' 35 | #' @export 36 | 37 | sse_events <- R6Class( 38 | "sse_events", 39 | inherit = event_emitter, 40 | public = list( 41 | initialize = function(http_handle) { 42 | super$initialize(async = FALSE) 43 | http_handle$event_emitter$listen_on("data", function(bytes) { 44 | private$data <- c(private$data, bytes) 45 | private$emit_events() 46 | }) 47 | http_handle$event_emitter$listen_on("end", function() { 48 | self$emit("end") 49 | }) 50 | } 51 | ), 52 | 53 | private = list( 54 | data = NULL, 55 | sep = as.raw(c(0xaL, 0xaL)), 56 | emit_events = function() { 57 | evs <- chunk_sse_events(private$data, private$sep) 58 | private$data <- evs$rest 59 | for (ev in evs$events) { 60 | self$emit("event", ev) 61 | } 62 | } 63 | ) 64 | ) 65 | 66 | chunk_sse_events <- function(data, sep = NULL) { 67 | # skip leading \n 68 | no <- 0L 69 | while (no <= length(data) && data[no + 1] == 0x0a) { 70 | no <- no + 1L 71 | } 72 | if (no > 0) { 73 | data <- data[(no + 1L):length(data)] 74 | } 75 | sep <- sep %||% as.raw(c(0xaL, 0xaL)) 76 | mtch <- grepRaw(sep, data, fixed = TRUE, all = TRUE) 77 | # shortcut for no events 78 | if (length(mtch) == 0) { 79 | return(list(events = list(), rest = data)) 80 | } 81 | 82 | events <- vector("list", length(mtch)) 83 | for (p in seq_along(mtch)) { 84 | from <- if (p == 1) 1L else mtch[p - 1] + 2L 85 | to <- mtch[p] - 1L 86 | events[[p]] <- parse_sse_event(data[from:to]) 87 | } 88 | events <- drop_nulls(events) 89 | 90 | restfrom <- mtch[length(mtch)] + 2L 91 | rest <- if (restfrom <= length(data)) { 92 | data[restfrom:length(data)] 93 | } else { 94 | raw() 95 | } 96 | list(events = events, rest = rest) 97 | } 98 | 99 | parse_sse_event <- function(data) { 100 | txt <- rawToChar(data) 101 | Encoding(txt) <- "UTF-8" 102 | lines <- strsplit(txt, "\n", fixed = TRUE)[[1]] 103 | lines <- lines[lines != ""] 104 | if (length(lines) == 0) { 105 | return(NULL) 106 | } 107 | keys <- sub(":.*$", "", lines) 108 | vals <- sub("^[^:]*:[ ]*", "", lines) 109 | structure(vals, names = keys) 110 | } 111 | 112 | drop_nulls <- function(x) { 113 | x[!vapply(x, is.null, logical(1))] 114 | } 115 | 116 | sseapp <- function() { 117 | app <- webfakes::new_app() 118 | app$get("/sse", function(req, res) { 119 | `%||%` <- function(l, r) if (is.null(l)) r else l 120 | if (is.null(res$locals$sse)) { 121 | duration <- as.double(req$query$duration %||% 2) 122 | delay <- as.double(req$query$delay %||% 0) 123 | numevents <- as.integer(req$query$numevents %||% 5) 124 | pause <- max(duration / numevents, 0.01) 125 | res$locals$sse <- list( 126 | sent = 0, 127 | numevents = numevents, 128 | pause = pause 129 | ) 130 | 131 | res$ 132 | set_header("cache-control", "no-cache")$ 133 | set_header("content-type", "text/event-stream")$ 134 | set_header("access-control-allow-origin", "*")$ 135 | set_header("connection", "keep-alive")$ 136 | set_status(200) 137 | 138 | if (delay > 0) { 139 | return(res$delay(delay)) 140 | } 141 | } 142 | 143 | msg <- paste0( 144 | "event: ", res$locals$sse$sent + 1L, "\n", 145 | "message: live long and prosper\n\n" 146 | ) 147 | res$locals$sse$sent <- res$locals$sse$sent + 1L 148 | res$write(msg) 149 | 150 | if (res$locals$sse$sent == res$locals$sse$numevents) { 151 | res$send("") 152 | } else { 153 | res$delay(res$locals$sse$pause) 154 | } 155 | }) 156 | } 157 | -------------------------------------------------------------------------------- /R/map.R: -------------------------------------------------------------------------------- 1 | 2 | #' Apply an asynchronous function to each element of a vector 3 | #' 4 | #' @param .x A list or atomic vector. 5 | #' @param .f Asynchronous function to apply. 6 | #' @param ... Additional arguments to `.f`. 7 | #' @param .args More additional arguments to `.f`. 8 | #' @param .limit Number of elements to process simulateneously. 9 | #' @return Deferred value that is resolved after all deferred values 10 | #' from the application of `.f` are resolved. 11 | #' 12 | #' @family async iterators 13 | #' @export 14 | #' @examples 15 | #' synchronise(async_map( 16 | #' seq(10, 100, by = 10) / 100, 17 | #' function(wait) delay(wait)$then(function() "OK") 18 | #' )) 19 | 20 | async_map <- function(.x, .f, ..., .args = list(), .limit = Inf) { 21 | if (.limit < length(.x)) { 22 | async_map_limit(.x, .f, ..., .args = .args, .limit = .limit) 23 | } else { 24 | defs <- do.call(lapply, c(list(.x, async(.f), ...), .args)) 25 | when_all(.list = defs) 26 | } 27 | } 28 | 29 | async_map <- mark_as_async(async_map) 30 | 31 | async_map_limit <- function(.x, .f, ..., .args = list(), .limit = Inf) { 32 | len <- length(.x) 33 | nx <- len 34 | .f <- async(.f) 35 | args <- c(list(...), .args) 36 | 37 | nextone <- .limit + 1L 38 | firsts <- lapply_args(.x[seq_len(.limit)], .f, .args = args) 39 | 40 | result <- structure( 41 | vector(mode = "list", length = len), 42 | names = names(.x) 43 | ) 44 | 45 | self <- deferred$new( 46 | type = "async_map (limit)", call = sys.call(), 47 | action = function(resolve) { 48 | self; nx; firsts 49 | lapply(seq_along(firsts), function(idx) { 50 | firsts[[idx]]$then(function(val) list(idx, val))$then(self) 51 | }) 52 | if (nx == 0) resolve(result) 53 | }, 54 | parent_resolve = function(value, resolve) { 55 | self; nx; nextone; result; .f 56 | nx <<- nx - 1L 57 | result[ value[[1]] ] <<- value[2] 58 | if (nx == 0) { 59 | resolve(result) 60 | } else if (nextone <= len) { 61 | idx <- nextone 62 | dx <- do.call(".f", c(list(.x[[nextone]]), args)) 63 | dx$then(function(val) list(idx, val))$then(self) 64 | nextone <<- nextone + 1L 65 | } 66 | } 67 | ) 68 | 69 | self 70 | } 71 | -------------------------------------------------------------------------------- /R/onload.R: -------------------------------------------------------------------------------- 1 | 2 | ## nocov start 3 | 4 | .onLoad <- function(libname, pkgname) { 5 | if (Sys.getenv("DEBUGME") != "" && 6 | requireNamespace("debugme", quietly = TRUE)) { 7 | debugme::debugme() 8 | } 9 | } 10 | 11 | ## nocov end 12 | -------------------------------------------------------------------------------- /R/process.R: -------------------------------------------------------------------------------- 1 | 2 | #' Asynchronous external process execution 3 | #' 4 | #' Start an external process in the background, and report its completion 5 | #' via a deferred. 6 | #' 7 | #' @inheritParams processx::run 8 | #' @param error_on_status Whether to reject the referred value if the 9 | #' program exits with a non-zero status. 10 | #' @return Deferred object. 11 | #' 12 | #' @family asynchronous external processes 13 | #' @export 14 | #' @examples 15 | #' \dontrun{ 16 | #' afun <- function() { 17 | #' run_process("ls", "-l")$ 18 | #' then(function(x) strsplit(x$stdout, "\r?\n")[[1]]) 19 | #' } 20 | #' synchronise(afun()) 21 | #' } 22 | 23 | run_process <- function(command = NULL, args = character(), 24 | error_on_status = TRUE, wd = NULL, env = NULL, 25 | windows_verbatim_args = FALSE, windows_hide_window = FALSE, 26 | encoding = "", ...) { 27 | 28 | command; args; error_on_status; wd; env; windows_verbatim_args; 29 | windows_hide_window; encoding; list(...) 30 | 31 | id <- NULL 32 | 33 | deferred$new( 34 | type = "process", call = sys.call(), 35 | action = function(resolve) { 36 | resolve 37 | reject <- environment(resolve)$private$reject 38 | stdout <- tempfile() 39 | stderr <- tempfile() 40 | px <- processx::process$new(command, args = args, 41 | stdout = stdout, stderr = stderr, poll_connection = TRUE, 42 | env = env, cleanup = TRUE, cleanup_tree = TRUE, wd = wd, 43 | encoding = encoding, ...) 44 | pipe <- px$get_poll_connection() 45 | id <<- get_default_event_loop()$add_process( 46 | list(pipe), 47 | function(err, res) if (is.null(err)) resolve(res) else reject(err), 48 | list(process = px, stdout = stdout, stderr = stderr, 49 | error_on_status = error_on_status, encoding = encoding)) 50 | }, 51 | on_cancel = function(reason) { 52 | if (!is.null(id)) get_default_event_loop()$cancel(id) 53 | } 54 | ) 55 | } 56 | 57 | run_process <- mark_as_async(run_process) 58 | -------------------------------------------------------------------------------- /R/r-process.R: -------------------------------------------------------------------------------- 1 | 2 | #' Asynchronous call to an R function, in a background R process 3 | #' 4 | #' Start a background R process and evaluate a function call in it. 5 | #' It uses [callr::r_process] internally. 6 | #' 7 | #' @inheritParams callr::r_bg 8 | #' @export 9 | #' 10 | #' @examples 11 | #' \dontrun{ 12 | #' afun <- function() { 13 | #' run_r_process(function() Sys.getpid()) 14 | #' } 15 | #' synchronise(afun()) 16 | #' } 17 | 18 | run_r_process <- function(func, args = list(), libpath = .libPaths(), 19 | repos = c(getOption("repos"), c(CRAN = "https://cloud.r-project.org")), 20 | cmdargs = c("--no-site-file", "--slave", "--no-save", "--no-restore"), 21 | system_profile = FALSE, user_profile = FALSE, env = callr::rcmd_safe_env()) { 22 | 23 | func; args; libpath; repos; cmdargs; system_profile; user_profile; env 24 | 25 | id <- NULL 26 | 27 | deferred$new( 28 | type = "r-process", call = sys.calls(), 29 | action = function(resolve) { 30 | resolve 31 | reject <- environment(resolve)$private$reject 32 | stdout <- tempfile() 33 | stderr <- tempfile() 34 | opts <- callr::r_process_options( 35 | func = func, args = args, libpath = libpath, repos = repos, 36 | cmdargs = cmdargs, system_profile = system_profile, 37 | user_profile = user_profile, env = env, stdout = stdout, 38 | stderr = stderr, extra = list(cleanup_tree = TRUE)) 39 | 40 | rx <- callr::r_process$new(opts) 41 | pipe <- rx$get_poll_connection() 42 | id <<- get_default_event_loop()$add_r_process( 43 | list(pipe), 44 | function(err, res) if (is.null(err)) resolve(res) else reject(err), 45 | list(process = rx, stdout = stdout, stderr = stderr, 46 | error_on_status = TRUE, encoding = "")) 47 | }, 48 | on_cancel = function(reason) { 49 | if (!is.null(id)) get_default_event_loop()$cancel(id) 50 | } 51 | ) 52 | } 53 | 54 | run_r_process <- mark_as_async(run_r_process) 55 | -------------------------------------------------------------------------------- /R/race.R: -------------------------------------------------------------------------------- 1 | 2 | #' A deferred value that resolves when the specified number of deferred 3 | #' values resolve, or is rejected when one of them is rejected 4 | #' 5 | #' These functions are similar to [when_some()] and [when_any()], but they 6 | #' do not ignore errors. If a deferred is rejected, then `async_race_some()` and 7 | #' `async_race()` are rejected as well. 8 | #' 9 | #' `async_race()` is a special case of `count = `: it resolves or is rejected 10 | #' as soon as one deferred resolves or is rejected. 11 | #' 12 | #' async has auto-cancellation, so if the required number of deferred values 13 | #' are resolved, or any deferred value is rejected, the rest are cancelled. 14 | #' 15 | #' @param count Number of deferred values that need to resolve. 16 | #' @param ... Deferred values. 17 | #' @param .list More deferred values. 18 | #' @return A deferred value, that is conditioned on all deferred values 19 | #' in `...` and `.list`. 20 | #' 21 | #' @export 22 | 23 | async_race_some <- function(count, ..., .list = list()) { 24 | when_some_internal(count, ..., .list = .list, .race = TRUE) 25 | } 26 | 27 | async_race_some <- mark_as_async(async_race_some) 28 | 29 | #' @export 30 | #' @rdname async_race_some 31 | 32 | async_race <- function(..., .list = list()) { 33 | when_some_internal(1L, ..., .list = .list, .race = TRUE)$ 34 | then(function(x) x[[1]]) 35 | } 36 | 37 | async_race <- mark_as_async(async_race) 38 | -------------------------------------------------------------------------------- /R/reflect.R: -------------------------------------------------------------------------------- 1 | 2 | #' Make an asynchronous function that always succeeds 3 | #' 4 | #' This is sometimes useful, if the function is applied to entries in 5 | #' a vector or list. 6 | #' 7 | #' @param task Function to transform. 8 | #' @return Async function returning a deferred value that is never 9 | #' rejected. Instead its value is a list with entries `error` and 10 | #' `result`. If the original deferred was resolved, then `error` is 11 | #' `NULL`. If the original deferred was rejected, then `result` is 12 | #' `NULL`. 13 | #' 14 | #' @family async control flow 15 | #' @export 16 | #' @examples 17 | #' badfun <- async(function() stop("oh no!")) 18 | #' safefun <- async_reflect(badfun) 19 | #' synchronise(when_all(safefun(), "good")) 20 | 21 | async_reflect <- function(task) { 22 | task <- async(task) 23 | function(...) { 24 | task(...)$ 25 | then(function(value) list(error = NULL, result = value))$ 26 | catch(error = function(reason) list(error = reason, result = NULL)) 27 | } 28 | } 29 | 30 | async_reflect <- mark_as_async(async_reflect) 31 | -------------------------------------------------------------------------------- /R/replicate.R: -------------------------------------------------------------------------------- 1 | 2 | #' Replicate an async function a number of times 3 | #' 4 | #' Similar to [base::replicate()], with some differences: 5 | #' * it takes an async function, instead of an expression, and 6 | #' * it always returns a list. 7 | #' 8 | #' @param n Number of replications. 9 | #' @param task Async function to call. 10 | #' @param ... Additional arguments to `task`. 11 | #' @param .limit Number of concurrent async processes to create. 12 | #' @return Resolves to a list of the results of the `n` `task` calls. 13 | #' 14 | #' @export 15 | #' @examples 16 | #' \donttest{ 17 | #' ## perform an HTTP request three times, and list the reponse times 18 | #' do <- function() { 19 | #' async_replicate(3, 20 | #' function() http_get("https://eu.httpbin.org")$then(function(x) x$times)) 21 | #' } 22 | #' synchronise(do()) 23 | #' } 24 | 25 | async_replicate <- function(n, task, ..., .limit = Inf) { 26 | assert_that( 27 | is_count(n), 28 | .limit == Inf || is_count(.limit), .limit >= 1L) 29 | 30 | force(list(...)) 31 | task <- async(task) 32 | 33 | if (n == 0) { 34 | async_constant(list()) 35 | } else if (n <= .limit) { 36 | async_replicate_nolimit(n, task, ...) 37 | } else { 38 | async_replicate_limit(n, task, ..., .limit = .limit) 39 | } 40 | } 41 | 42 | async_replicate_nolimit <- function(n, task, ...) { 43 | defs <- lapply(seq_len(n), function(i) task(...)) 44 | when_all(.list = defs) 45 | } 46 | 47 | async_replicate_limit <- function(n, task, ..., .limit = .limit) { 48 | n; .limit 49 | 50 | defs <- nextone <- result <- NULL 51 | 52 | self <- deferred$new( 53 | type = "async_replicate", call = sys.call(), 54 | action = function(resolve) { 55 | defs <<- lapply(seq_len(n), function(i) task(...)) 56 | result <<- vector(n, mode = "list") 57 | lapply(seq_len(.limit), function(idx) { 58 | defs[[idx]]$then(function(val) list(idx, val))$then(self) 59 | }) 60 | nextone <<- .limit + 1L 61 | }, 62 | parent_resolve = function(value, resolve) { 63 | result[ value[[1]] ] <<- value[2] 64 | if (nextone > n) { 65 | resolve(result) 66 | } else { 67 | idx <- nextone 68 | defs[[nextone]]$then(function(val) list(idx, val))$then(self) 69 | nextone <<- nextone + 1L 70 | } 71 | } 72 | ) 73 | 74 | self 75 | } 76 | -------------------------------------------------------------------------------- /R/retry.R: -------------------------------------------------------------------------------- 1 | 2 | #' Retry an asynchronous function a number of times 3 | #' 4 | #' Keeps trying until the function's deferred value resolves without 5 | #' error, or `times` tries have been performed. 6 | #' 7 | #' @param task An asynchronous function. 8 | #' @param times Number of tries. 9 | #' @param ... Arguments to pass to `task`. 10 | #' @return Deferred value for the operation with retries. 11 | #' 12 | #' @family async control flow 13 | #' @export 14 | #' @examples 15 | #' \donttest{ 16 | #' ## Try a download at most 5 times 17 | #' afun <- async(function() { 18 | #' async_retry( 19 | #' function() http_get("https://eu.httpbin.org"), 20 | #' times = 5 21 | #' )$then(function(x) x$status_code) 22 | #' }) 23 | #' 24 | #' synchronise(afun()) 25 | #' } 26 | 27 | async_retry <- function(task, times, ...) { 28 | task <- async(task) 29 | times <- times 30 | force(list(...)) 31 | 32 | self <- deferred$new( 33 | type = "retry", call = sys.call(), 34 | parents = list(task(...)), 35 | parent_reject = function(value, resolve) { 36 | times <<- times - 1L 37 | if (times > 0) { 38 | task(...)$then(self) 39 | } else { 40 | stop(value) 41 | } 42 | } 43 | ) 44 | } 45 | 46 | async_retry <- mark_as_async(async_retry) 47 | 48 | #' Make an asynchronous funcion retryable 49 | #' 50 | #' @param task An asynchronous function. 51 | #' @param times Number of tries. 52 | #' @return Asynchronous retryable function. 53 | #' 54 | #' @family async control flow 55 | #' @export 56 | #' @examples 57 | #' \donttest{ 58 | #' ## Create a downloader that retries five times 59 | #' http_get_5 <- async_retryable(http_get, times = 5) 60 | #' ret <- synchronise( 61 | #' http_get_5("https://eu.httpbin.org/get?q=1")$ 62 | #' then(function(x) rawToChar(x$content)) 63 | #' ) 64 | #' cat(ret) 65 | #' } 66 | 67 | async_retryable <- function(task, times) { 68 | task <- async(task) 69 | force(times) 70 | function(...) { 71 | async_retry(task, times, ...) 72 | } 73 | } 74 | -------------------------------------------------------------------------------- /R/sequence.R: -------------------------------------------------------------------------------- 1 | 2 | #' Compose asynchronous functions 3 | #' 4 | #' This is equivalent to using the `$then()` method of a deferred, but 5 | #' it is easier to use programmatically. 6 | #' 7 | #' @param ... Asynchronous functions to compose. 8 | #' @param .list Mose asynchronous functions to compose. 9 | #' @return Asynchronous function, the composition of all input functions. 10 | #' They are performed left to right, the ones in `.list` are the last 11 | #' ones. 12 | #' 13 | #' @family async control flow 14 | #' @export 15 | #' @examples 16 | #' \donttest{ 17 | #' check_url <- async_sequence( 18 | #' http_head, function(x) identical(x$status_code, 200L)) 19 | #' synchronise(check_url("https://eu.httpbin.org/status/404")) 20 | #' synchronise(check_url("https://eu.httpbin.org/status/200")) 21 | #' } 22 | 23 | async_sequence <- function(..., .list = NULL) { 24 | funcs <- c(list(...), .list) 25 | if (length(funcs) == 0) stop("Function list empty in `async_sequence`") 26 | 27 | function(...) { 28 | dx <- async(funcs[[1]])(...) 29 | for (i in seq_along(funcs)[-1]) dx <- dx$then(funcs[[i]]) 30 | dx 31 | } 32 | } 33 | 34 | async_sequence <- mark_as_async(async_sequence) 35 | -------------------------------------------------------------------------------- /R/some.R: -------------------------------------------------------------------------------- 1 | 2 | #' @export 3 | #' @rdname async_every 4 | 5 | async_some <- function(.x, .p, ...) { 6 | defs <- lapply(.x, async(.p), ...) 7 | nx <- length(defs) 8 | done <- FALSE 9 | 10 | deferred$new( 11 | type = "async_some", call = sys.call(), 12 | parents = defs, 13 | action = function(resolve) if (nx == 0) resolve(FALSE), 14 | parent_resolve = function(value, resolve) { 15 | if (!done && isTRUE(value)) { 16 | done <<- TRUE 17 | resolve(TRUE) 18 | } else if (!done) { 19 | nx <<- nx - 1L 20 | if (nx == 0) resolve(FALSE) 21 | } 22 | } 23 | ) 24 | } 25 | 26 | async_some <- mark_as_async(async_some) 27 | -------------------------------------------------------------------------------- /R/timeout.R: -------------------------------------------------------------------------------- 1 | 2 | #' Asynchronous function call with a timeout 3 | #' 4 | #' If the deferred value is not resolved before the timeout expires, 5 | #' `async_timeout()` throws an `async_timeout` error. 6 | #' 7 | #' @param task Asynchronous function. 8 | #' @param timeout Timeout as a `difftime` object, or number of seconds. 9 | #' @param ... Additional arguments to `task`. 10 | #' @return A deferred value. An `async_timeout` error is thrown if it is 11 | #' not resolved within the specified timeout. 12 | #' 13 | #' @family async utilities 14 | #' @export 15 | #' @examples 16 | #' ## You can catch the error, asynchronously 17 | #' synchronise( 18 | #' async_timeout(function() delay(1/10)$then(function() "OK"), 1/1000)$ 19 | #' catch(async_timeout = function(e) "Timed out", 20 | #' error = function(e) "Other error") 21 | #' ) 22 | #' 23 | #' ## Or synchronously 24 | #' tryCatch( 25 | #' synchronise( 26 | #' async_timeout(function() delay(1/10)$then(function() "OK"), 1/1000) 27 | #' ), 28 | #' async_timeout = function(e) "Timed out. :(", 29 | #' error = function(e) paste("Other error:", e$message) 30 | #' ) 31 | 32 | async_timeout <- function(task, timeout, ...) { 33 | task <- async(task) 34 | force(timeout) 35 | list(...) 36 | done <- FALSE 37 | 38 | self <- deferred$new( 39 | type = "timeout", call = sys.call(), 40 | action = function(resolve) { 41 | task(...)$then(function(x) list("ok", x))$then(self) 42 | delay(timeout)$then(function() list("timeout"))$then(self) 43 | }, 44 | parent_resolve = function(value, resolve) { 45 | if (!done) { 46 | done <<- TRUE 47 | if (value[[1]] == "ok") { 48 | resolve(value[[2]]) 49 | } else { 50 | cnd <- structure( 51 | list(message = "Aync operation timed out"), 52 | class = c("async_timeout", "error", "condition") 53 | ) 54 | stop(cnd) 55 | } 56 | } 57 | } 58 | ) 59 | } 60 | 61 | async_timeout <- mark_as_async(async_timeout) 62 | -------------------------------------------------------------------------------- /R/timer.R: -------------------------------------------------------------------------------- 1 | 2 | #' Repeated timer 3 | #' 4 | #' The supplied callback function will be called by the event loop 5 | #' every `delay` seconds. 6 | #' 7 | #' @section Usage: 8 | #' ``` 9 | #' t <- async_timer$new(delay, callback) 10 | #' t$cancel() 11 | #' ``` 12 | #' 13 | #' @section Arguments: 14 | #' * `delay`: Time interval in seconds, the amount of time to delay 15 | #' to delay the execution. It can be a fraction of a second. 16 | #' * `callback`: Callback function without arguments. It will be called 17 | #' from the event loop every `delay` seconds. 18 | #' 19 | #' @section Details: 20 | #' 21 | #' An `async_timer` is an `[event_emitter]` object with a `timeout` event. 22 | #' It is possible to add multiple listeners to this event, once the timer 23 | #' is created. Note, however, that removing all listeners does not cancel 24 | #' the timer, `timeout` events will be still emitted as usual. 25 | #' For proper cancellation you'll need to call the `cancel()` method. 26 | #' 27 | #' It is only possible to create `async_timer` objects in an asynchronous 28 | #' context, i.e. within a `synchronise()` or `run_event_loop()` call. 29 | #' A `synchronise()` call finishes as soon as its returned deferred value 30 | #' is resolved (or rejected), even if some timers are still active. The 31 | #' active timers will be automatically cancelled in this case. 32 | #' 33 | #' @section Errors: 34 | #' Errors are handled the same way as for generic event emitters. I.e. to 35 | #' catch errors thrown in the `callback` function, you need to add a 36 | #' listener to the `error` event, see the example below. 37 | #' 38 | #' @section Congestion: 39 | #' `async_timer` is _not_ a real-time timer. In particular, if `callback` 40 | #' does not return in time, before the next timer event, then all future 41 | #' timer events will be delayed. Even if `callback` returns promptly, the 42 | #' event loop might be busy with other events, and then the next timer 43 | #' event is not emitted in time. In general there is no guarantee about 44 | #' the timing of the timer events. 45 | #' 46 | #' @importFrom R6 R6Class 47 | #' @export 48 | #' @examples 49 | #' ## Call 10 times a second, cancel with 1/10 probability 50 | #' counter <- 0L 51 | #' do <- function() { 52 | #' cb <- function() { 53 | #' cat("called\n") 54 | #' counter <<- counter + 1L 55 | #' if (runif(1) < 0.1) t$cancel() 56 | #' } 57 | #' t <- async_timer$new(1/10, cb) 58 | #' } 59 | #' 60 | #' run_event_loop(do()) 61 | #' counter 62 | #' 63 | #' ## Error handling 64 | #' counter <- 0L 65 | #' do <- function() { 66 | #' cb <- function() { 67 | #' cat("called\n") 68 | #' counter <<- counter + 1L 69 | #' if (counter == 2L) stop("foobar") 70 | #' if (counter == 3L) t$cancel() 71 | #' } 72 | #' t <- async_timer$new(1/10, cb) 73 | #' handler <- function(err) { 74 | #' cat("Got error:", sQuote(conditionMessage(err)), ", handled\n") 75 | #' } 76 | #' t$listen_on("error", handler) 77 | #' } 78 | #' 79 | #' run_event_loop(do()) 80 | #' counter 81 | #' 82 | #' ## Error handling at the synchonization point 83 | #' counter <- 0L 84 | #' do <- function() { 85 | #' cb <- function() { 86 | #' cat("called\n") 87 | #' counter <<- counter + 1L 88 | #' if (counter == 2L) stop("foobar") 89 | #' if (counter == 3L) t$cancel() 90 | #' } 91 | #' t <- async_timer$new(1/10, cb) 92 | #' } 93 | #' 94 | #' tryCatch(run_event_loop(do()), error = function(x) x) 95 | #' counter 96 | 97 | async_timer <- R6Class( 98 | "async_timer", 99 | inherit = event_emitter, 100 | public = list( 101 | initialize = function(delay, callback) 102 | async_timer_init(self, private, super, delay, callback), 103 | cancel = function() 104 | async_timer_cancel(self, private) 105 | ), 106 | 107 | private = list( 108 | id = NULL 109 | ) 110 | ) 111 | 112 | async_timer_init <- function(self, private, super, delay, callback) { 113 | assert_that( 114 | is_time_interval(delay), 115 | is.function(callback) && length(formals(callback)) == 0) 116 | 117 | ## event emitter 118 | super$initialize() 119 | 120 | private$id <- get_default_event_loop()$add_delayed( 121 | delay, 122 | function() self$emit("timeout"), 123 | function(err, res) { 124 | if (!is.null(err)) self$emit("error", err) # nocov 125 | }, 126 | rep = TRUE) 127 | 128 | self$listen_on("timeout", callback) 129 | 130 | invisible(self) 131 | } 132 | 133 | async_timer_cancel <- function(self, private) { 134 | self; private 135 | self$remove_all_listeners("timeout") 136 | get_default_event_loop()$cancel(private$id) 137 | invisible(self) 138 | } 139 | -------------------------------------------------------------------------------- /R/try-each.R: -------------------------------------------------------------------------------- 1 | 2 | #' It runs each task in series but stops whenever any of the functions were 3 | #' successful. If one of the tasks were successful, the callback will be 4 | #' passed the result of the successful task. If all tasks fail, the 5 | #' callback will be passed the error and result (if any) of the final 6 | #' attempt. 7 | #' @param ... Deferred values to run in series. 8 | #' @param .list More deferred values to run, `.list` is easier to use 9 | #' programmatically. 10 | #' @return Resolves to the result of the first successful deferred. 11 | #' Otherwise throws an error. The error objects of all failed deferreds 12 | #' will be in the `errors` member of the error object. 13 | #' 14 | #' @family async control flow 15 | #' @export 16 | #' @examples 17 | #' do <- function() { 18 | #' async_try_each( 19 | #' async(function() stop("doh"))(), 20 | #' async(function() "cool")(), 21 | #' async(function() stop("doh2"))(), 22 | #' async(function() "cool2")() 23 | #' ) 24 | #' } 25 | #' synchronise(do()) 26 | 27 | async_try_each <- function(..., .list = list()) { 28 | defs <- c(list(...), .list) 29 | wh <- nx <- NULL 30 | errors <- list() 31 | 32 | self <- deferred$new( 33 | type = "async_try_each", call = sys.call(), 34 | action = function(resolve) { 35 | nx <<- length(defs) 36 | if (nx == 0) resolve(NULL) 37 | wh <<- 1L 38 | defs[[wh]]$then(self) 39 | }, 40 | parent_resolve = function(value, resolve) { 41 | resolve(value) 42 | }, 43 | parent_reject = function(value, resolve) { 44 | errors <<- c(errors, list(value)) 45 | if (wh == nx) { 46 | err <- structure( 47 | list(errors = errors, message = "async_try_each failed"), 48 | class = c("async_rejected", "error", "condition")) 49 | stop(err) 50 | } else { 51 | wh <<- wh + 1 52 | defs[[wh]]$then(self) 53 | } 54 | } 55 | ) 56 | 57 | self 58 | } 59 | 60 | async_try_each <- mark_as_async(async_try_each) 61 | -------------------------------------------------------------------------------- /R/until.R: -------------------------------------------------------------------------------- 1 | 2 | #' Repeatedly call task until it its test function returns `TRUE` 3 | #' 4 | #' @param test Synchronous test function. 5 | #' @param task Asynchronous function to call repeatedly. 6 | #' @param ... Arguments to pass to `task`. 7 | #' @return Deferred value, that is resolved when the iteration is done. 8 | #' 9 | #' @family async control flow 10 | #' @export 11 | #' @examples 12 | #' ## Keep calling until it "returns" a number less than < 0.1 13 | #' calls <- 0 14 | #' number <- Inf 15 | #' synchronise(async_until( 16 | #' function() number < 0.1, 17 | #' function() { 18 | #' calls <<- calls + 1 19 | #' number <<- runif(1) 20 | #' } 21 | #' )) 22 | #' calls 23 | 24 | async_until <- function(test, task, ...) { 25 | force(test) 26 | task <- async(task) 27 | 28 | self <- deferred$new( 29 | type = "async_until", call = sys.call(), 30 | parents = list(task(...)), 31 | parent_resolve = function(value, resolve) { 32 | if (test()) { 33 | resolve(value) 34 | } else { 35 | task(...)$then(self) 36 | } 37 | } 38 | ) 39 | 40 | self 41 | } 42 | 43 | async_until <- mark_as_async(async_until) 44 | -------------------------------------------------------------------------------- /R/utils.R: -------------------------------------------------------------------------------- 1 | 2 | `%||%` <- function(l, r) if (is.null(l)) r else l 3 | 4 | vlapply <- function(X, FUN, ..., FUN.VALUE = logical(1)) { 5 | vapply(X, FUN, FUN.VALUE = FUN.VALUE, ...) 6 | } 7 | 8 | viapply <- function(X, FUN, ..., FUN.VALUE = integer(1)) { 9 | vapply(X, FUN, FUN.VALUE = FUN.VALUE, ...) 10 | } 11 | 12 | vcapply <- function(X, FUN, ..., FUN.VALUE = character(1)) { 13 | vapply(X, FUN, FUN.VALUE = FUN.VALUE, ...) 14 | } 15 | 16 | make_error <- function(message, class = "simpleError", call = NULL) { 17 | class <- c(class, "error", "condition") 18 | structure( 19 | list(message = as.character(message), call = call), 20 | class = class 21 | ) 22 | } 23 | 24 | num_args <- function(fun) { 25 | length(formals(fun)) 26 | } 27 | 28 | get_private <- function(x) { 29 | x$.__enclos_env__$private 30 | } 31 | 32 | #' Call `func` and then call `callback` with the result 33 | #' 34 | #' `callback` will be called with two arguments, the first one will the 35 | #' error object if `func()` threw an error, or `NULL` otherwise. The second 36 | #' argument is `NULL` on error, and the result of `func()` otherwise. 37 | #' 38 | #' @param func Function to call. 39 | #' @param callback Callback to call with the result of `func()`, 40 | #' or the error thrown. 41 | #' @param info Extra info to add to the error object. Must be a named list. 42 | #' 43 | #' @keywords internal 44 | 45 | call_with_callback <- function(func, callback, info = NULL) { 46 | recerror <- NULL 47 | result <- NULL 48 | tryCatch( 49 | withCallingHandlers( 50 | result <- func(), 51 | error = function(e) { 52 | recerror <<- e 53 | recerror$aframe <<- recerror$aframe %||% find_async_data_frame() 54 | recerror$calls <<- recerror$calls %||% sys.calls() 55 | if (is.null(recerror[["call"]])) recerror[["call"]] <<- sys.call() 56 | recerror$parents <<- recerror$parents %||% sys.parents() 57 | recerror[names(info)] <<- info 58 | handler <- getOption("async.error") 59 | if (is.function(handler)) handler() 60 | } 61 | ), 62 | error = identity 63 | ) 64 | callback(recerror, result) 65 | } 66 | 67 | get_id <- local({ 68 | id <- 0L 69 | function() { 70 | id <<- id + 1L 71 | id 72 | } 73 | }) 74 | 75 | new_event_loop_id <- local({ 76 | id <- 0L 77 | function() { 78 | id <<- id + 1L 79 | id 80 | } 81 | }) 82 | 83 | lapply_args <- function(X, FUN, ..., .args = list()) { 84 | do.call("lapply", c(list(X = X, FUN = FUN), list(...), .args)) 85 | } 86 | 87 | drop_nulls <- function(x) { 88 | x[!vlapply(x, is.null)] 89 | } 90 | 91 | #' @importFrom utils getSrcDirectory getSrcFilename getSrcLocation 92 | 93 | get_source_position <- function(call) { 94 | list( 95 | filename = file.path( 96 | c(getSrcDirectory(call), "?")[1], 97 | c(getSrcFilename(call), "?")[1]), 98 | position = paste0( 99 | getSrcLocation(call, "line", TRUE) %||% "?", ":", 100 | getSrcLocation(call, "column", TRUE) %||% "?") 101 | ) 102 | } 103 | 104 | file_size <- function(...) { 105 | file.info(..., extra_cols = FALSE)$size 106 | } 107 | 108 | read_all <- function(filename, encoding) { 109 | if (is.null(filename)) return(NULL) 110 | r <- readBin(filename, what = raw(0), n = file_size(filename)) 111 | s <- rawToChar(r) 112 | Encoding(s) <- encoding 113 | s 114 | } 115 | 116 | crash <- function () { 117 | get("attach")(structure(list(), class = "UserDefinedDatabase")) 118 | } 119 | 120 | str_trim <- function(x) { 121 | sub("\\s+$", "", sub("^\\s+", "", x)) 122 | } 123 | 124 | expr_name <- function(expr) { 125 | if (is.null(expr)) { 126 | return("NULL") 127 | } 128 | 129 | if (is.symbol(expr)) { 130 | return(as.character(expr)) 131 | } 132 | 133 | if (is.call(expr)) { 134 | cl <- as.list(expr)[[1]] 135 | if (is.symbol(cl)) { 136 | return(as.character(cl)) 137 | } else { 138 | return(paste0(format(cl), collapse = "")) 139 | } 140 | } 141 | 142 | if (is.atomic(expr) && length(expr) == 1) { 143 | return(as.character(expr)) 144 | } 145 | 146 | gsub("\n.*$", "...", as.character(expr)) 147 | } 148 | -------------------------------------------------------------------------------- /R/uuid.R: -------------------------------------------------------------------------------- 1 | 2 | get_uuid <- function() { 3 | async_env$pid <- async_env$pid %||% Sys.getpid() 4 | async_env$counter <- async_env$counter %||% 0 5 | async_env$counter <- async_env$counter + 1L 6 | paste0(async_env$pid, "-", async_env$counter) 7 | } 8 | -------------------------------------------------------------------------------- /R/when_all.R: -------------------------------------------------------------------------------- 1 | 2 | #' Deferred value for a set of deferred values 3 | #' 4 | #' Create a deferred value that is resolved when all listed deferred values 5 | #' are resolved. Note that the error of an input deferred value 6 | #' triggers the error `when_all` as well. 7 | #' 8 | #' async has auto-cancellation, so if one deferred value errors, the rest 9 | #' of them will be automatically cancelled. 10 | #' 11 | #' @param ... Deferred values. 12 | #' @param .list More deferred values. 13 | #' @return A deferred value, that is conditioned on all deferred values 14 | #' in `...` and `.list`. 15 | #' 16 | #' @seealso [when_any()], [when_some()] 17 | #' @export 18 | #' @examples 19 | #' \donttest{ 20 | #' ## Check that the contents of two URLs are the same 21 | #' afun <- async(function() { 22 | #' u1 <- http_get("https://eu.httpbin.org") 23 | #' u2 <- http_get("https://eu.httpbin.org/get") 24 | #' when_all(u1, u2)$ 25 | #' then(function(x) identical(x[[1]]$content, x[[2]]$content)) 26 | #' }) 27 | #' synchronise(afun()) 28 | #' } 29 | 30 | when_all <- function(..., .list = list()) { 31 | 32 | defs <- c(list(...), .list) 33 | nx <- 0L 34 | 35 | self <- deferred$new( 36 | type = "when_all", 37 | call = sys.call(), 38 | action = function(resolve) { 39 | self; nx; defs 40 | lapply(seq_along(defs), function(idx) { 41 | idx 42 | if (is_deferred(defs[[idx]])) { 43 | nx <<- nx + 1L 44 | defs[[idx]]$then(function(val) list(idx, val))$then(self) 45 | } 46 | }) 47 | if (nx == 0) resolve(defs) 48 | }, 49 | parent_resolve = function(value, resolve) { 50 | defs[ value[[1]] ] <<- value[2] 51 | nx <<- nx - 1L 52 | if (nx == 0L) resolve(defs) 53 | } 54 | ) 55 | } 56 | 57 | when_all <- mark_as_async(when_all) 58 | -------------------------------------------------------------------------------- /R/when_any.R: -------------------------------------------------------------------------------- 1 | 2 | #' Resolve a deferred as soon as some deferred from a list resolve 3 | #' 4 | #' `when_some` creates a deferred value that is resolved as soon as the 5 | #' specified number of deferred values resolve. 6 | #' 7 | #' `when_any` is a special case for a single. 8 | #' 9 | #' If the specified number of deferred values cannot be resolved, then 10 | #' `when_any` throws an error. 11 | #' 12 | #' async has auto-cancellation, so if the required number of deferred values 13 | #' are resolved, or too many of them throw error, the rest of the are 14 | #' cancelled. 15 | #' 16 | #' If `when_any` throws an error, then all the underlying error objects 17 | #' are returned in the `errors` member of the error object thrown by 18 | #' `when_any`. 19 | #' 20 | #' @param count Number of deferred values that need to resolve. 21 | #' @param ... Deferred values. 22 | #' @param .list More deferred values. 23 | #' @return A deferred value, that is conditioned on all deferred values 24 | #' in `...` and `.list`. 25 | #' 26 | #' @seealso [when_all()] 27 | #' @export 28 | #' @examples 29 | #' \donttest{ 30 | #' ## Use the URL that returns first 31 | #' afun <- function() { 32 | #' u1 <- http_get("https://eu.httpbin.org") 33 | #' u2 <- http_get("https://eu.httpbin.org/get") 34 | #' when_any(u1, u2)$then(function(x) x$url) 35 | #' } 36 | #' synchronise(afun()) 37 | #' } 38 | 39 | when_some <- function(count, ..., .list = list()) { 40 | when_some_internal(count, ..., .list = .list, .race = FALSE) 41 | } 42 | 43 | when_some <- mark_as_async(when_some) 44 | 45 | when_some_internal <- function(count, ..., .list, .race) { 46 | force(count) 47 | force(.race) 48 | defs <- c(list(...), .list) 49 | num_defs <- length(defs) 50 | num_failed <- 0L 51 | ifdef <- vlapply(defs, is_deferred) 52 | resolved <- defs[!ifdef] 53 | errors <- list() 54 | 55 | cancel_all <- function() lapply(defs[ifdef], function(x) x$cancel()) 56 | 57 | deferred$new( 58 | type = "when_some", call = sys.call(), 59 | parents = defs[ifdef], 60 | action = function(resolve) { 61 | if (num_defs < count) { 62 | stop("Cannot resolve enough deferred values") 63 | } else if (length(resolved) >= count) { 64 | resolve(resolved[seq_len(count)]) 65 | } 66 | }, 67 | parent_resolve = function(value, resolve) { 68 | resolved <<- c(resolved, list(value)) 69 | if (length(resolved) == count) { 70 | resolve(resolved) 71 | } 72 | }, 73 | parent_reject = function(value, resolve) { 74 | if (.race) { 75 | stop(value) 76 | } 77 | num_failed <<- num_failed + 1L 78 | errors <<- c(errors, list(value)) 79 | if (num_failed + count == num_defs + 1L) { 80 | err <- structure( 81 | list(errors = errors, message = "when_some / when_any failed"), 82 | class = c("async_rejected", "error", "condition")) 83 | stop(err) 84 | } 85 | } 86 | ) 87 | } 88 | 89 | #' @export 90 | #' @rdname when_some 91 | 92 | when_any <- function(..., .list = list()) { 93 | when_some(1, ..., .list = .list)$then(function(x) x[[1]]) 94 | } 95 | 96 | when_any <- mark_as_async(when_any) 97 | -------------------------------------------------------------------------------- /R/whilst.R: -------------------------------------------------------------------------------- 1 | 2 | #' Repeatedly call task, while test returns true 3 | #' 4 | #' @param test Synchronous test function. 5 | #' @param task Asynchronous function to call repeatedly. 6 | #' @param ... Arguments to pass to `task`. 7 | #' @return Deferred value, that is resolved when the iteration is done. 8 | #' 9 | #' @family async control flow 10 | #' @export 11 | #' @examples 12 | #' ## Keep calling while result is bigger than 0.1 13 | #' calls <- 0 14 | #' number <- Inf 15 | #' synchronise(async_whilst( 16 | #' function() number >= 0.1, 17 | #' function() { 18 | #' calls <<- calls + 1 19 | #' number <<- runif(1) 20 | #' } 21 | #' )) 22 | #' calls 23 | 24 | async_whilst <- function(test, task, ...) { 25 | force(test) 26 | task <- async(task) 27 | 28 | self <- deferred$new( 29 | type = "async_whilst", call = sys.call(), 30 | action = function(resolve) { 31 | if (!test()) { 32 | resolve(NULL) 33 | } else { 34 | task(...)$then(self) 35 | } 36 | }, 37 | parent_resolve = function(value, resolve) { 38 | if (!test()) { 39 | resolve(value) 40 | } else { 41 | task(...)$then(self) 42 | } 43 | } 44 | ) 45 | 46 | self 47 | } 48 | 49 | async_whilst <- mark_as_async(async_whilst) 50 | -------------------------------------------------------------------------------- /R/xprocess.R: -------------------------------------------------------------------------------- 1 | 2 | #' External process via a process generator 3 | #' 4 | #' Wrap any [processx::process] object into a deferred value. The 5 | #' process is created by a generator function. 6 | #' 7 | #' @param process_generator Function that returns a [processx::process] 8 | #' object. See details below about the current requirements for the 9 | #' returned process. 10 | #' @param error_on_status Whether to fail if the process terminates 11 | #' with a non-zero exit status. 12 | #' @param ... Extra arguments, passed to `process_generator`. 13 | #' @return Deferred object. 14 | #' 15 | #' Current requirements for `process_generator`: 16 | #' * It must take a `...` argument, and pass it to 17 | #' `processx::process$new()`. 18 | #' * It must use the `poll_connection = TRUE` argument. 19 | #' These requirements might be relaxed in the future. 20 | #' 21 | #' If you want to obtain the standard output and/or error of the 22 | #' process, then `process_generator` must redirect them to files. 23 | #' If you want to discard them, `process_generator` can set them to 24 | #' `NULL`. 25 | #' 26 | #' `process_generator` should not use pipes (`"|"`) for the standard 27 | #' output or error, because the process will stop running if the 28 | #' pipe buffer gets full. We currently never read out the pipe buffer. 29 | #' 30 | #' @export 31 | #' @examples 32 | #' \dontrun{ 33 | #' lsgen <- function(dir = ".", ...) { 34 | #' processx::process$new( 35 | #' "ls", 36 | #' dir, 37 | #' poll_connection = TRUE, 38 | #' stdout = tempfile(), 39 | #' stderr = tempfile(), 40 | #' ... 41 | #' ) 42 | #' } 43 | #' afun <- function() { 44 | #' external_process(lsgen) 45 | #' } 46 | #' synchronise(afun()) 47 | #' } 48 | 49 | external_process <- function(process_generator, error_on_status = TRUE, 50 | ...) { 51 | 52 | process_generator; error_on_status; args <- list(...) 53 | args$encoding <- args$encoding %||% "" 54 | args$cleanup_tree <- args$cleanup_tree %||% TRUE 55 | 56 | id <- NULL 57 | 58 | deferred$new( 59 | type = "external_process", call = sys.call(), 60 | action = function(resolve) { 61 | resolve 62 | reject <- environment(resolve)$private$reject 63 | px <- do.call(process_generator, args) 64 | stdout <- px$get_output_file() 65 | stderr <- px$get_error_file() 66 | pipe <- px$get_poll_connection() 67 | id <<- get_default_event_loop()$add_process( 68 | list(pipe), 69 | function(err, res) if (is.null(err)) resolve(res) else reject(err), 70 | list(process = px, stdout = stdout, stderr = stderr, 71 | error_on_status = error_on_status, encoding = args$encoding) 72 | ) 73 | }, 74 | on_cancel = function(reason) { 75 | if (!is.null(id)) get_default_event_loop()$cancel(id) 76 | } 77 | ) 78 | } 79 | -------------------------------------------------------------------------------- /async.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: knitr 13 | LaTeX: XeLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | -------------------------------------------------------------------------------- /codecov.yml: -------------------------------------------------------------------------------- 1 | comment: false 2 | 3 | coverage: 4 | status: 5 | project: 6 | default: 7 | target: auto 8 | threshold: 1% 9 | informational: true 10 | patch: 11 | default: 12 | target: auto 13 | threshold: 1% 14 | informational: true 15 | -------------------------------------------------------------------------------- /inst/NEWS.md: -------------------------------------------------------------------------------- 1 | 2 | # 0.0.0.9000 3 | 4 | First public release. 5 | -------------------------------------------------------------------------------- /man/async.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/aaa-async.R 3 | \name{async} 4 | \alias{async} 5 | \title{Create an async function} 6 | \usage{ 7 | async(fun) 8 | } 9 | \arguments{ 10 | \item{fun}{Original function.} 11 | } 12 | \value{ 13 | Async version of the original function. 14 | } 15 | \description{ 16 | Create an async function, that returns a deferred value, from a 17 | regular function. If \code{fun} is already an async function, then it does 18 | nothing, just returns it. 19 | } 20 | \details{ 21 | The result function will have the same arguments, with the same default 22 | values, and the same environment as the original input function. 23 | } 24 | \examples{ 25 | f <- function(x) 42 26 | af <- async(f) 27 | is_async(f) 28 | is_async(af) 29 | f() 30 | synchronise(dx <- af()) 31 | dx 32 | } 33 | -------------------------------------------------------------------------------- /man/async_backoff.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/backoff.R 3 | \name{async_backoff} 4 | \alias{async_backoff} 5 | \title{Retry an asynchronous function with exponential backoff} 6 | \usage{ 7 | async_backoff( 8 | task, 9 | ..., 10 | .args = list(), 11 | times = Inf, 12 | time_limit = Inf, 13 | custom_backoff = NULL, 14 | on_progress = NULL, 15 | progress_data = NULL 16 | ) 17 | } 18 | \arguments{ 19 | \item{task}{An asynchronous function.} 20 | 21 | \item{...}{Arguments to pass to \code{task}.} 22 | 23 | \item{.args}{More arguments to pass to \code{task}.} 24 | 25 | \item{times}{Maximum number of tries.} 26 | 27 | \item{time_limit}{Maximum number of seconds to try.} 28 | 29 | \item{custom_backoff}{If not \code{NULL} then a callback function to 30 | calculate waiting time, after the \code{i}the try. \code{i} is passed as an 31 | argument. If \code{NULL}, then the default is used, which is a uniform 32 | random number of seconds between 1 and 2^i.} 33 | 34 | \item{on_progress}{Callback function for a progress bar. Retries are 35 | announced here, if not \code{NULL}. \code{on_progress} is called with two 36 | arguments. The first is a named list with entries: 37 | \itemize{ 38 | \item \code{event}: string that is either \code{"retry"} or \code{"givenup"}, 39 | \item \code{tries}: number of tried so far, 40 | \item \code{spent}: number of seconds spent trying so far, 41 | \item \code{error}: the error object for the last failure, 42 | \item \code{retry_in}: number of seconds before the next try. 43 | The second argument is \code{progress_data}. 44 | }} 45 | 46 | \item{progress_data}{\code{async_backoff()} will pass this object to 47 | \code{on_progress} as the second argument.} 48 | } 49 | \value{ 50 | Deferred value for the operation with retries. 51 | } 52 | \description{ 53 | Keeps trying until the function's deferred value resolves without 54 | error, or \code{times} tries have been performed, or \code{time_limit} seconds 55 | have passed since the start of the first try. 56 | } 57 | \details{ 58 | Note that all unnamed arguments are passed to \code{task}. 59 | } 60 | \examples{ 61 | \donttest{ 62 | afun <- function() { 63 | wait_100_ms <- function(i) 0.1 64 | async_backoff( 65 | function() if (runif(1) < 0.8) stop("nope") else "yes!", 66 | times = 5, 67 | custom_backoff = wait_100_ms 68 | ) 69 | } 70 | 71 | # There is a slight chance that it fails 72 | tryCatch(synchronise(afun()), error = function(e) e) 73 | } 74 | } 75 | \seealso{ 76 | Other async control flow: 77 | \code{\link{async_reflect}()}, 78 | \code{\link{async_retry}()}, 79 | \code{\link{async_retryable}()}, 80 | \code{\link{async_sequence}()}, 81 | \code{\link{async_try_each}()}, 82 | \code{\link{async_until}()}, 83 | \code{\link{async_whilst}()} 84 | } 85 | \concept{async control flow} 86 | -------------------------------------------------------------------------------- /man/async_constant.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/constant.R 3 | \name{async_constant} 4 | \alias{async_constant} 5 | \title{Make a minimal deferred that resolves to the specified value} 6 | \usage{ 7 | async_constant(value = NULL) 8 | } 9 | \arguments{ 10 | \item{value}{The value to resolve to.} 11 | } 12 | \value{ 13 | A deferred value. 14 | } 15 | \description{ 16 | This is sometimes useful to start a deferred chain. 17 | } 18 | \details{ 19 | Note that the evaluation of \code{value} is forced when the deferred value 20 | is created. 21 | } 22 | \examples{ 23 | afun <- async(function() { 24 | async_constant(1/100)$ 25 | then(function(x) delay(x))$ 26 | then(function(x) print(x)) 27 | }) 28 | synchronise(afun()) 29 | } 30 | -------------------------------------------------------------------------------- /man/async_detect.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/detect.R 3 | \name{async_detect} 4 | \alias{async_detect} 5 | \title{Find the value of a match, asynchronously} 6 | \usage{ 7 | async_detect(.x, .p, ..., .limit = Inf) 8 | } 9 | \arguments{ 10 | \item{.x}{A list or atomic vector.} 11 | 12 | \item{.p}{An asynchronous predicate function.} 13 | 14 | \item{...}{Additional arguments to the predicate function.} 15 | 16 | \item{.limit}{Number of elements to process simulateneously. 17 | If it is 1, then the predicate is applied sequentially.} 18 | } 19 | \value{ 20 | A deferred value for the result. 21 | } 22 | \description{ 23 | All predicates are running in parallel, and the returned match 24 | is not guaranteed to be the first one. 25 | } 26 | \examples{ 27 | \donttest{ 28 | synchronise(async_detect( 29 | c("https://eu.httpbin.org/status/404", "https://eu.httpbin.org", 30 | "https://eu.httpbin.org/status/403"), 31 | async_sequence(http_head, function(x) x$status_code == 200) 32 | )) 33 | } 34 | } 35 | \seealso{ 36 | Other async iterators: 37 | \code{\link{async_every}()}, 38 | \code{\link{async_filter}()}, 39 | \code{\link{async_map}()} 40 | } 41 | \concept{async iterators} 42 | -------------------------------------------------------------------------------- /man/async_every.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/every.R, R/some.R 3 | \name{async_every} 4 | \alias{async_every} 5 | \alias{async_some} 6 | \title{Do every or some elements of a list satisfy an asynchronous predicate?} 7 | \usage{ 8 | async_every(.x, .p, ...) 9 | 10 | async_some(.x, .p, ...) 11 | } 12 | \arguments{ 13 | \item{.x}{A list or atomic vector.} 14 | 15 | \item{.p}{An asynchronous predicate function.} 16 | 17 | \item{...}{Additional arguments to the predicate function.} 18 | } 19 | \value{ 20 | A deferred value for the result. 21 | } 22 | \description{ 23 | Do every or some elements of a list satisfy an asynchronous predicate? 24 | } 25 | \examples{ 26 | # Check if all numbers are odd 27 | # Note the use of force() here. Otherwise x will be evaluated later, 28 | # and by then its value might change. 29 | is_odd <- async(function(x) { 30 | force(x) 31 | delay(1/1000)$then(function() as.logical(x \%\% 2)) 32 | }) 33 | synchronise(async_every(c(1,3,5,7,10,11), is_odd)) 34 | synchronise(async_every(c(1,3,5,7,11), is_odd)) 35 | } 36 | \seealso{ 37 | Other async iterators: 38 | \code{\link{async_detect}()}, 39 | \code{\link{async_filter}()}, 40 | \code{\link{async_map}()} 41 | } 42 | \concept{async iterators} 43 | -------------------------------------------------------------------------------- /man/async_filter.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/filter.R 3 | \name{async_filter} 4 | \alias{async_filter} 5 | \alias{async_reject} 6 | \title{Keep or drop elements using an asyncronous predicate function} 7 | \usage{ 8 | async_filter(.x, .p, ...) 9 | 10 | async_reject(.x, .p, ...) 11 | } 12 | \arguments{ 13 | \item{.x}{A list or atomic vector.} 14 | 15 | \item{.p}{An asynchronous predicate function.} 16 | 17 | \item{...}{Additional arguments to the predicate function.} 18 | } 19 | \value{ 20 | A deferred value for the result. 21 | } 22 | \description{ 23 | \code{async_filter} keep the elements for which \code{.p} is true. (Tested 24 | via \code{isTRUE()}. \code{async_reject} is the opposite, it drops them. 25 | } 26 | \examples{ 27 | \donttest{ 28 | ## Filter out non-working URLs 29 | afun <- async(function(urls) { 30 | test_url <- async_sequence( 31 | http_head, function(x) identical(x$status_code, 200L)) 32 | async_filter(urls, test_url) 33 | }) 34 | urls <- c("https://eu.httpbin.org/get", 35 | "https://eu.httpbin.org/status/404") 36 | synchronise(afun(urls)) 37 | } 38 | } 39 | \seealso{ 40 | Other async iterators: 41 | \code{\link{async_detect}()}, 42 | \code{\link{async_every}()}, 43 | \code{\link{async_map}()} 44 | } 45 | \concept{async iterators} 46 | -------------------------------------------------------------------------------- /man/async_map.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/map.R 3 | \name{async_map} 4 | \alias{async_map} 5 | \title{Apply an asynchronous function to each element of a vector} 6 | \usage{ 7 | async_map(.x, .f, ..., .args = list(), .limit = Inf) 8 | } 9 | \arguments{ 10 | \item{.x}{A list or atomic vector.} 11 | 12 | \item{.f}{Asynchronous function to apply.} 13 | 14 | \item{...}{Additional arguments to \code{.f}.} 15 | 16 | \item{.args}{More additional arguments to \code{.f}.} 17 | 18 | \item{.limit}{Number of elements to process simulateneously.} 19 | } 20 | \value{ 21 | Deferred value that is resolved after all deferred values 22 | from the application of \code{.f} are resolved. 23 | } 24 | \description{ 25 | Apply an asynchronous function to each element of a vector 26 | } 27 | \examples{ 28 | synchronise(async_map( 29 | seq(10, 100, by = 10) / 100, 30 | function(wait) delay(wait)$then(function() "OK") 31 | )) 32 | } 33 | \seealso{ 34 | Other async iterators: 35 | \code{\link{async_detect}()}, 36 | \code{\link{async_every}()}, 37 | \code{\link{async_filter}()} 38 | } 39 | \concept{async iterators} 40 | -------------------------------------------------------------------------------- /man/async_race_some.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/race.R 3 | \name{async_race_some} 4 | \alias{async_race_some} 5 | \alias{async_race} 6 | \title{A deferred value that resolves when the specified number of deferred 7 | values resolve, or is rejected when one of them is rejected} 8 | \usage{ 9 | async_race_some(count, ..., .list = list()) 10 | 11 | async_race(..., .list = list()) 12 | } 13 | \arguments{ 14 | \item{count}{Number of deferred values that need to resolve.} 15 | 16 | \item{...}{Deferred values.} 17 | 18 | \item{.list}{More deferred values.} 19 | } 20 | \value{ 21 | A deferred value, that is conditioned on all deferred values 22 | in \code{...} and \code{.list}. 23 | } 24 | \description{ 25 | These functions are similar to \code{\link[=when_some]{when_some()}} and \code{\link[=when_any]{when_any()}}, but they 26 | do not ignore errors. If a deferred is rejected, then \code{async_race_some()} and 27 | \code{async_race()} are rejected as well. 28 | } 29 | \details{ 30 | \code{async_race()} is a special case of \verb{count = }: it resolves or is rejected 31 | as soon as one deferred resolves or is rejected. 32 | 33 | async has auto-cancellation, so if the required number of deferred values 34 | are resolved, or any deferred value is rejected, the rest are cancelled. 35 | } 36 | -------------------------------------------------------------------------------- /man/async_reflect.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/reflect.R 3 | \name{async_reflect} 4 | \alias{async_reflect} 5 | \title{Make an asynchronous function that always succeeds} 6 | \usage{ 7 | async_reflect(task) 8 | } 9 | \arguments{ 10 | \item{task}{Function to transform.} 11 | } 12 | \value{ 13 | Async function returning a deferred value that is never 14 | rejected. Instead its value is a list with entries \code{error} and 15 | \code{result}. If the original deferred was resolved, then \code{error} is 16 | \code{NULL}. If the original deferred was rejected, then \code{result} is 17 | \code{NULL}. 18 | } 19 | \description{ 20 | This is sometimes useful, if the function is applied to entries in 21 | a vector or list. 22 | } 23 | \examples{ 24 | badfun <- async(function() stop("oh no!")) 25 | safefun <- async_reflect(badfun) 26 | synchronise(when_all(safefun(), "good")) 27 | } 28 | \seealso{ 29 | Other async control flow: 30 | \code{\link{async_backoff}()}, 31 | \code{\link{async_retry}()}, 32 | \code{\link{async_retryable}()}, 33 | \code{\link{async_sequence}()}, 34 | \code{\link{async_try_each}()}, 35 | \code{\link{async_until}()}, 36 | \code{\link{async_whilst}()} 37 | } 38 | \concept{async control flow} 39 | -------------------------------------------------------------------------------- /man/async_replicate.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/replicate.R 3 | \name{async_replicate} 4 | \alias{async_replicate} 5 | \title{Replicate an async function a number of times} 6 | \usage{ 7 | async_replicate(n, task, ..., .limit = Inf) 8 | } 9 | \arguments{ 10 | \item{n}{Number of replications.} 11 | 12 | \item{task}{Async function to call.} 13 | 14 | \item{...}{Additional arguments to \code{task}.} 15 | 16 | \item{.limit}{Number of concurrent async processes to create.} 17 | } 18 | \value{ 19 | Resolves to a list of the results of the \code{n} \code{task} calls. 20 | } 21 | \description{ 22 | Similar to \code{\link[base:lapply]{base::replicate()}}, with some differences: 23 | \itemize{ 24 | \item it takes an async function, instead of an expression, and 25 | \item it always returns a list. 26 | } 27 | } 28 | \examples{ 29 | \donttest{ 30 | ## perform an HTTP request three times, and list the reponse times 31 | do <- function() { 32 | async_replicate(3, 33 | function() http_get("https://eu.httpbin.org")$then(function(x) x$times)) 34 | } 35 | synchronise(do()) 36 | } 37 | } 38 | -------------------------------------------------------------------------------- /man/async_retry.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/retry.R 3 | \name{async_retry} 4 | \alias{async_retry} 5 | \title{Retry an asynchronous function a number of times} 6 | \usage{ 7 | async_retry(task, times, ...) 8 | } 9 | \arguments{ 10 | \item{task}{An asynchronous function.} 11 | 12 | \item{times}{Number of tries.} 13 | 14 | \item{...}{Arguments to pass to \code{task}.} 15 | } 16 | \value{ 17 | Deferred value for the operation with retries. 18 | } 19 | \description{ 20 | Keeps trying until the function's deferred value resolves without 21 | error, or \code{times} tries have been performed. 22 | } 23 | \examples{ 24 | \donttest{ 25 | ## Try a download at most 5 times 26 | afun <- async(function() { 27 | async_retry( 28 | function() http_get("https://eu.httpbin.org"), 29 | times = 5 30 | )$then(function(x) x$status_code) 31 | }) 32 | 33 | synchronise(afun()) 34 | } 35 | } 36 | \seealso{ 37 | Other async control flow: 38 | \code{\link{async_backoff}()}, 39 | \code{\link{async_reflect}()}, 40 | \code{\link{async_retryable}()}, 41 | \code{\link{async_sequence}()}, 42 | \code{\link{async_try_each}()}, 43 | \code{\link{async_until}()}, 44 | \code{\link{async_whilst}()} 45 | } 46 | \concept{async control flow} 47 | -------------------------------------------------------------------------------- /man/async_retryable.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/retry.R 3 | \name{async_retryable} 4 | \alias{async_retryable} 5 | \title{Make an asynchronous funcion retryable} 6 | \usage{ 7 | async_retryable(task, times) 8 | } 9 | \arguments{ 10 | \item{task}{An asynchronous function.} 11 | 12 | \item{times}{Number of tries.} 13 | } 14 | \value{ 15 | Asynchronous retryable function. 16 | } 17 | \description{ 18 | Make an asynchronous funcion retryable 19 | } 20 | \examples{ 21 | \donttest{ 22 | ## Create a downloader that retries five times 23 | http_get_5 <- async_retryable(http_get, times = 5) 24 | ret <- synchronise( 25 | http_get_5("https://eu.httpbin.org/get?q=1")$ 26 | then(function(x) rawToChar(x$content)) 27 | ) 28 | cat(ret) 29 | } 30 | } 31 | \seealso{ 32 | Other async control flow: 33 | \code{\link{async_backoff}()}, 34 | \code{\link{async_reflect}()}, 35 | \code{\link{async_retry}()}, 36 | \code{\link{async_sequence}()}, 37 | \code{\link{async_try_each}()}, 38 | \code{\link{async_until}()}, 39 | \code{\link{async_whilst}()} 40 | } 41 | \concept{async control flow} 42 | -------------------------------------------------------------------------------- /man/async_sequence.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/sequence.R 3 | \name{async_sequence} 4 | \alias{async_sequence} 5 | \title{Compose asynchronous functions} 6 | \usage{ 7 | async_sequence(..., .list = NULL) 8 | } 9 | \arguments{ 10 | \item{...}{Asynchronous functions to compose.} 11 | 12 | \item{.list}{Mose asynchronous functions to compose.} 13 | } 14 | \value{ 15 | Asynchronous function, the composition of all input functions. 16 | They are performed left to right, the ones in \code{.list} are the last 17 | ones. 18 | } 19 | \description{ 20 | This is equivalent to using the \verb{$then()} method of a deferred, but 21 | it is easier to use programmatically. 22 | } 23 | \examples{ 24 | \donttest{ 25 | check_url <- async_sequence( 26 | http_head, function(x) identical(x$status_code, 200L)) 27 | synchronise(check_url("https://eu.httpbin.org/status/404")) 28 | synchronise(check_url("https://eu.httpbin.org/status/200")) 29 | } 30 | } 31 | \seealso{ 32 | Other async control flow: 33 | \code{\link{async_backoff}()}, 34 | \code{\link{async_reflect}()}, 35 | \code{\link{async_retry}()}, 36 | \code{\link{async_retryable}()}, 37 | \code{\link{async_try_each}()}, 38 | \code{\link{async_until}()}, 39 | \code{\link{async_whilst}()} 40 | } 41 | \concept{async control flow} 42 | -------------------------------------------------------------------------------- /man/async_timeout.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/timeout.R 3 | \name{async_timeout} 4 | \alias{async_timeout} 5 | \title{Asynchronous function call with a timeout} 6 | \usage{ 7 | async_timeout(task, timeout, ...) 8 | } 9 | \arguments{ 10 | \item{task}{Asynchronous function.} 11 | 12 | \item{timeout}{Timeout as a \code{difftime} object, or number of seconds.} 13 | 14 | \item{...}{Additional arguments to \code{task}.} 15 | } 16 | \value{ 17 | A deferred value. An \code{async_timeout} error is thrown if it is 18 | not resolved within the specified timeout. 19 | } 20 | \description{ 21 | If the deferred value is not resolved before the timeout expires, 22 | \code{async_timeout()} throws an \code{async_timeout} error. 23 | } 24 | \examples{ 25 | ## You can catch the error, asynchronously 26 | synchronise( 27 | async_timeout(function() delay(1/10)$then(function() "OK"), 1/1000)$ 28 | catch(async_timeout = function(e) "Timed out", 29 | error = function(e) "Other error") 30 | ) 31 | 32 | ## Or synchronously 33 | tryCatch( 34 | synchronise( 35 | async_timeout(function() delay(1/10)$then(function() "OK"), 1/1000) 36 | ), 37 | async_timeout = function(e) "Timed out. :(", 38 | error = function(e) paste("Other error:", e$message) 39 | ) 40 | } 41 | \concept{async utilities} 42 | -------------------------------------------------------------------------------- /man/async_timer.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/timer.R 3 | \name{async_timer} 4 | \alias{async_timer} 5 | \title{Repeated timer} 6 | \description{ 7 | The supplied callback function will be called by the event loop 8 | every \code{delay} seconds. 9 | } 10 | \section{Usage}{ 11 | 12 | 13 | \if{html}{\out{
}}\preformatted{t <- async_timer$new(delay, callback) 14 | t$cancel() 15 | }\if{html}{\out{
}} 16 | } 17 | 18 | \section{Arguments}{ 19 | 20 | \itemize{ 21 | \item \code{delay}: Time interval in seconds, the amount of time to delay 22 | to delay the execution. It can be a fraction of a second. 23 | \item \code{callback}: Callback function without arguments. It will be called 24 | from the event loop every \code{delay} seconds. 25 | } 26 | } 27 | 28 | \section{Details}{ 29 | 30 | 31 | An \code{async_timer} is an \verb{[event_emitter]} object with a \code{timeout} event. 32 | It is possible to add multiple listeners to this event, once the timer 33 | is created. Note, however, that removing all listeners does not cancel 34 | the timer, \code{timeout} events will be still emitted as usual. 35 | For proper cancellation you'll need to call the \code{cancel()} method. 36 | 37 | It is only possible to create \code{async_timer} objects in an asynchronous 38 | context, i.e. within a \code{synchronise()} or \code{run_event_loop()} call. 39 | A \code{synchronise()} call finishes as soon as its returned deferred value 40 | is resolved (or rejected), even if some timers are still active. The 41 | active timers will be automatically cancelled in this case. 42 | } 43 | 44 | \section{Errors}{ 45 | 46 | Errors are handled the same way as for generic event emitters. I.e. to 47 | catch errors thrown in the \code{callback} function, you need to add a 48 | listener to the \code{error} event, see the example below. 49 | } 50 | 51 | \section{Congestion}{ 52 | 53 | \code{async_timer} is \emph{not} a real-time timer. In particular, if \code{callback} 54 | does not return in time, before the next timer event, then all future 55 | timer events will be delayed. Even if \code{callback} returns promptly, the 56 | event loop might be busy with other events, and then the next timer 57 | event is not emitted in time. In general there is no guarantee about 58 | the timing of the timer events. 59 | } 60 | 61 | \examples{ 62 | ## Call 10 times a second, cancel with 1/10 probability 63 | counter <- 0L 64 | do <- function() { 65 | cb <- function() { 66 | cat("called\n") 67 | counter <<- counter + 1L 68 | if (runif(1) < 0.1) t$cancel() 69 | } 70 | t <- async_timer$new(1/10, cb) 71 | } 72 | 73 | run_event_loop(do()) 74 | counter 75 | 76 | ## Error handling 77 | counter <- 0L 78 | do <- function() { 79 | cb <- function() { 80 | cat("called\n") 81 | counter <<- counter + 1L 82 | if (counter == 2L) stop("foobar") 83 | if (counter == 3L) t$cancel() 84 | } 85 | t <- async_timer$new(1/10, cb) 86 | handler <- function(err) { 87 | cat("Got error:", sQuote(conditionMessage(err)), ", handled\n") 88 | } 89 | t$listen_on("error", handler) 90 | } 91 | 92 | run_event_loop(do()) 93 | counter 94 | 95 | ## Error handling at the synchonization point 96 | counter <- 0L 97 | do <- function() { 98 | cb <- function() { 99 | cat("called\n") 100 | counter <<- counter + 1L 101 | if (counter == 2L) stop("foobar") 102 | if (counter == 3L) t$cancel() 103 | } 104 | t <- async_timer$new(1/10, cb) 105 | } 106 | 107 | tryCatch(run_event_loop(do()), error = function(x) x) 108 | counter 109 | } 110 | -------------------------------------------------------------------------------- /man/async_try_each.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/try-each.R 3 | \name{async_try_each} 4 | \alias{async_try_each} 5 | \title{It runs each task in series but stops whenever any of the functions were 6 | successful. If one of the tasks were successful, the callback will be 7 | passed the result of the successful task. If all tasks fail, the 8 | callback will be passed the error and result (if any) of the final 9 | attempt.} 10 | \usage{ 11 | async_try_each(..., .list = list()) 12 | } 13 | \arguments{ 14 | \item{...}{Deferred values to run in series.} 15 | 16 | \item{.list}{More deferred values to run, \code{.list} is easier to use 17 | programmatically.} 18 | } 19 | \value{ 20 | Resolves to the result of the first successful deferred. 21 | Otherwise throws an error. The error objects of all failed deferreds 22 | will be in the \code{errors} member of the error object. 23 | } 24 | \description{ 25 | It runs each task in series but stops whenever any of the functions were 26 | successful. If one of the tasks were successful, the callback will be 27 | passed the result of the successful task. If all tasks fail, the 28 | callback will be passed the error and result (if any) of the final 29 | attempt. 30 | } 31 | \examples{ 32 | do <- function() { 33 | async_try_each( 34 | async(function() stop("doh"))(), 35 | async(function() "cool")(), 36 | async(function() stop("doh2"))(), 37 | async(function() "cool2")() 38 | ) 39 | } 40 | synchronise(do()) 41 | } 42 | \seealso{ 43 | Other async control flow: 44 | \code{\link{async_backoff}()}, 45 | \code{\link{async_reflect}()}, 46 | \code{\link{async_retry}()}, 47 | \code{\link{async_retryable}()}, 48 | \code{\link{async_sequence}()}, 49 | \code{\link{async_until}()}, 50 | \code{\link{async_whilst}()} 51 | } 52 | \concept{async control flow} 53 | -------------------------------------------------------------------------------- /man/async_until.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/until.R 3 | \name{async_until} 4 | \alias{async_until} 5 | \title{Repeatedly call task until it its test function returns \code{TRUE}} 6 | \usage{ 7 | async_until(test, task, ...) 8 | } 9 | \arguments{ 10 | \item{test}{Synchronous test function.} 11 | 12 | \item{task}{Asynchronous function to call repeatedly.} 13 | 14 | \item{...}{Arguments to pass to \code{task}.} 15 | } 16 | \value{ 17 | Deferred value, that is resolved when the iteration is done. 18 | } 19 | \description{ 20 | Repeatedly call task until it its test function returns \code{TRUE} 21 | } 22 | \examples{ 23 | ## Keep calling until it "returns" a number less than < 0.1 24 | calls <- 0 25 | number <- Inf 26 | synchronise(async_until( 27 | function() number < 0.1, 28 | function() { 29 | calls <<- calls + 1 30 | number <<- runif(1) 31 | } 32 | )) 33 | calls 34 | } 35 | \seealso{ 36 | Other async control flow: 37 | \code{\link{async_backoff}()}, 38 | \code{\link{async_reflect}()}, 39 | \code{\link{async_retry}()}, 40 | \code{\link{async_retryable}()}, 41 | \code{\link{async_sequence}()}, 42 | \code{\link{async_try_each}()}, 43 | \code{\link{async_whilst}()} 44 | } 45 | \concept{async control flow} 46 | -------------------------------------------------------------------------------- /man/async_whilst.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/whilst.R 3 | \name{async_whilst} 4 | \alias{async_whilst} 5 | \title{Repeatedly call task, while test returns true} 6 | \usage{ 7 | async_whilst(test, task, ...) 8 | } 9 | \arguments{ 10 | \item{test}{Synchronous test function.} 11 | 12 | \item{task}{Asynchronous function to call repeatedly.} 13 | 14 | \item{...}{Arguments to pass to \code{task}.} 15 | } 16 | \value{ 17 | Deferred value, that is resolved when the iteration is done. 18 | } 19 | \description{ 20 | Repeatedly call task, while test returns true 21 | } 22 | \examples{ 23 | ## Keep calling while result is bigger than 0.1 24 | calls <- 0 25 | number <- Inf 26 | synchronise(async_whilst( 27 | function() number >= 0.1, 28 | function() { 29 | calls <<- calls + 1 30 | number <<- runif(1) 31 | } 32 | )) 33 | calls 34 | } 35 | \seealso{ 36 | Other async control flow: 37 | \code{\link{async_backoff}()}, 38 | \code{\link{async_reflect}()}, 39 | \code{\link{async_retry}()}, 40 | \code{\link{async_retryable}()}, 41 | \code{\link{async_sequence}()}, 42 | \code{\link{async_try_each}()}, 43 | \code{\link{async_until}()} 44 | } 45 | \concept{async control flow} 46 | -------------------------------------------------------------------------------- /man/call_function.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/call-function.R 3 | \name{call_function} 4 | \alias{call_function} 5 | \title{Asynchronous function call, in a worker pool} 6 | \usage{ 7 | call_function(func, args = list()) 8 | } 9 | \arguments{ 10 | \item{func}{Function to call. See also the notes at \code{\link[callr:r]{callr::r()}}.} 11 | 12 | \item{args}{Arguments to pass to the function. They will be copied 13 | to the worker process.} 14 | } 15 | \value{ 16 | Deferred object. 17 | } 18 | \description{ 19 | The function will be called on another process, very much like 20 | \code{\link[callr:r]{callr::r()}}. 21 | } 22 | -------------------------------------------------------------------------------- /man/call_with_callback.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils.R 3 | \name{call_with_callback} 4 | \alias{call_with_callback} 5 | \title{Call \code{func} and then call \code{callback} with the result} 6 | \usage{ 7 | call_with_callback(func, callback, info = NULL) 8 | } 9 | \arguments{ 10 | \item{func}{Function to call.} 11 | 12 | \item{callback}{Callback to call with the result of \code{func()}, 13 | or the error thrown.} 14 | 15 | \item{info}{Extra info to add to the error object. Must be a named list.} 16 | } 17 | \description{ 18 | \code{callback} will be called with two arguments, the first one will the 19 | error object if \code{func()} threw an error, or \code{NULL} otherwise. The second 20 | argument is \code{NULL} on error, and the result of \code{func()} otherwise. 21 | } 22 | \keyword{internal} 23 | -------------------------------------------------------------------------------- /man/def__make_error_object.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/deferred.R 3 | \name{def__make_error_object} 4 | \alias{def__make_error_object} 5 | \title{Create an error object for a rejected deferred computation} 6 | \usage{ 7 | def__make_error_object(self, private, err) 8 | } 9 | \arguments{ 10 | \item{self}{self} 11 | 12 | \item{private}{private self} 13 | } 14 | \value{ 15 | error object 16 | } 17 | \description{ 18 | \itemize{ 19 | \item Make sure that the error is an error object. 20 | \item Make sure that the error has the correct classes. 21 | } 22 | } 23 | \keyword{internal} 24 | -------------------------------------------------------------------------------- /man/delay.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/delay.R 3 | \name{delay} 4 | \alias{delay} 5 | \title{Delay async computation for the specified time} 6 | \usage{ 7 | delay(delay) 8 | } 9 | \arguments{ 10 | \item{delay}{Time interval in seconds, the amount of time to delay 11 | to delay the execution. It can be a fraction of a second.} 12 | } 13 | \value{ 14 | A deferred object. 15 | } 16 | \description{ 17 | Since R is single-threaded, the deferred value might be resolved (much) 18 | later than the specified time period. 19 | } 20 | \examples{ 21 | \donttest{ 22 | ## Two HEAD requests with 1/2 sec delay between them 23 | resp <- list() 24 | afun <- async(function() { 25 | http_head("https://eu.httpbin.org?q=2")$ 26 | then(function(value) resp[[1]] <<- value$status_code)$ 27 | then(function(...) delay(1/2))$ 28 | then(function(...) http_head("https://eu.httpbin.org?q=2"))$ 29 | then(function(value) resp[[2]] <<- value$status_code) 30 | }) 31 | synchronise(afun()) 32 | resp 33 | } 34 | } 35 | -------------------------------------------------------------------------------- /man/event_emitter.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/events.R 3 | \name{event_emitter} 4 | \alias{event_emitter} 5 | \title{Generic Event Emitter} 6 | \description{ 7 | This is a generic class that can be used to create event emitters. 8 | It is mostly modelled after the 'node.js' \code{EventEmitter} class 9 | } 10 | \section{Usage}{ 11 | 12 | 13 | \if{html}{\out{
}}\preformatted{ee <- event_emitter$new(async = TRUE) 14 | ee$listen_on(event, callback) 15 | ee$listen_off(event, callback) 16 | ee$listen_once(event, callback) 17 | ee$emit(event, ...) 18 | ee$get_event_names() 19 | ee$get_listener_count(event) 20 | ee$remove_all_listeners(event) 21 | }\if{html}{\out{
}} 22 | } 23 | 24 | \section{Arguments}{ 25 | 26 | \itemize{ 27 | \item \code{async}: Whether to call listeners asynchronously, i.e. in the next 28 | tick of the event loop. 29 | \item \code{event}: String, name of the event. 30 | \item \code{callback}: Function, listener to call when the event is emitted. 31 | Its arguments must match the arguments passed to the \verb{$emit()} 32 | method. It is possible to add the same callback function multiple 33 | times as a listener. It will be called as many times, as many times 34 | it was added. 35 | \item \code{...}: Arguments to pass to the listeners. They can be named or 36 | unnnamed. 37 | } 38 | } 39 | 40 | \section{Details}{ 41 | 42 | 43 | \code{ee$listen_on()} adds \code{callback} as a new listener for \code{event}. It is 44 | always added to the end of the listener list. Listeners will be called in 45 | the order they were added. It returns a reference to the \code{event_emitter} 46 | object, so calls can be chained. 47 | 48 | \code{ee$listen_off()} removes the first instance of \code{callback} from the 49 | listener list of \code{event}. It uses \code{\link[base:identical]{base::identical()}} to find the 50 | listener to remove. If \code{callback} is not among the listeners, nothing 51 | happens. Note that if you call this method from an event handler, that 52 | does not affect the already emitted events. It returns a reference to 53 | the \code{event_emitter} object, so calls can be chained. 54 | 55 | \code{ee$listen_once} is similar to \code{ee$listen_on()}, but the callback will 56 | be only called for a single event, and then it will be removed. 57 | (Technically, the listener is removed before the callback is called.) 58 | It returns a reference to the \code{event_emitter} object, so calls can be 59 | chained. 60 | 61 | \code{ee$emit()} emits an event. All listeners in its listener list will be 62 | called, in the order they were added. The arguments are passed to the 63 | listeners, so they have to be compatible with them. 64 | 65 | \code{ee$get_event_names()} returns the names of the active events, 66 | in a character vector. An event is active if it has at least one 67 | listener. 68 | 69 | \code{ee$get_listener_count()} returns the number of listeners for an event. 70 | 71 | \code{ee$remove_all_listener()} removes all listeners for an an event. 72 | } 73 | 74 | \section{Error handling}{ 75 | 76 | Errors are handled by special \code{error} events. If a listener errors, 77 | and the event emitter has an active \code{error} event (i.e. some listeners 78 | exist for \code{error}, then \emph{all} listeners are called, in the order they 79 | were specified. They receive the originally thrown error object as the 80 | single argument. The error object has an \code{event} entry, which contains 81 | the event name the failed listener was called on. 82 | 83 | If the event emitter does not have any listeners for the \code{error} event, 84 | then it throws an error. This error propagates to the next 85 | synchronization barrier, i.e. the last \code{synchronise()} or 86 | \code{run_event_loop()} call, which fails. 87 | 88 | In an error happen within an \code{error} listener, then the same happens, 89 | the last \code{synchronise()} or \code{run_event_loop()} call fails. You can 90 | wrap the body of the error listeners in a \code{tryCatch()} call, 91 | if you want to avoid this. 92 | } 93 | 94 | -------------------------------------------------------------------------------- /man/external_process.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/xprocess.R 3 | \name{external_process} 4 | \alias{external_process} 5 | \title{External process via a process generator} 6 | \usage{ 7 | external_process(process_generator, error_on_status = TRUE, ...) 8 | } 9 | \arguments{ 10 | \item{process_generator}{Function that returns a \link[processx:process]{processx::process} 11 | object. See details below about the current requirements for the 12 | returned process.} 13 | 14 | \item{error_on_status}{Whether to fail if the process terminates 15 | with a non-zero exit status.} 16 | 17 | \item{...}{Extra arguments, passed to \code{process_generator}.} 18 | } 19 | \value{ 20 | Deferred object. 21 | 22 | Current requirements for \code{process_generator}: 23 | \itemize{ 24 | \item It must take a \code{...} argument, and pass it to 25 | \code{processx::process$new()}. 26 | \item It must use the \code{poll_connection = TRUE} argument. 27 | These requirements might be relaxed in the future. 28 | } 29 | 30 | If you want to obtain the standard output and/or error of the 31 | process, then \code{process_generator} must redirect them to files. 32 | If you want to discard them, \code{process_generator} can set them to 33 | \code{NULL}. 34 | 35 | \code{process_generator} should not use pipes (\code{"|"}) for the standard 36 | output or error, because the process will stop running if the 37 | pipe buffer gets full. We currently never read out the pipe buffer. 38 | } 39 | \description{ 40 | Wrap any \link[processx:process]{processx::process} object into a deferred value. The 41 | process is created by a generator function. 42 | } 43 | \examples{ 44 | \dontrun{ 45 | lsgen <- function(dir = ".", ...) { 46 | processx::process$new( 47 | "ls", 48 | dir, 49 | poll_connection = TRUE, 50 | stdout = tempfile(), 51 | stderr = tempfile(), 52 | ... 53 | ) 54 | } 55 | afun <- function() { 56 | external_process(lsgen) 57 | } 58 | synchronise(afun()) 59 | } 60 | } 61 | -------------------------------------------------------------------------------- /man/http_get.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/http.R 3 | \name{http_get} 4 | \alias{http_get} 5 | \title{Asynchronous HTTP GET request} 6 | \usage{ 7 | http_get( 8 | url, 9 | headers = character(), 10 | file = NULL, 11 | options = list(), 12 | on_progress = NULL 13 | ) 14 | } 15 | \arguments{ 16 | \item{url}{URL to connect to.} 17 | 18 | \item{headers}{HTTP headers to send.} 19 | 20 | \item{file}{If not \code{NULL}, it must be a string, specifying a file. 21 | The body of the response is written to this file.} 22 | 23 | \item{options}{Options to set on the handle. Passed to 24 | \code{\link[curl:handle]{curl::handle_setopt()}}.} 25 | 26 | \item{on_progress}{Progress handler function. It is only used if the 27 | response body is written to a file. See details below.} 28 | } 29 | \value{ 30 | Deferred object. 31 | } 32 | \description{ 33 | Start an HTTP GET request in the background, and report its completion 34 | via a deferred. 35 | } 36 | \section{HTTP event emitters}{ 37 | 38 | An async HTTP deferred object is also an event emitter, see 39 | \link{event_emitter}. Use \verb{$event_emitter} to access the event emitter API, 40 | and call \verb{$event_emitter$listen_on()} etc. to listen on HTTP events, 41 | etc. 42 | \itemize{ 43 | \item \code{"data"} is emitted when we receive data from the server, the data is 44 | passed on to the listeners as a raw vector. Note that zero-length 45 | raw vectors might also happen. 46 | \item \code{"end"} is emitted at the end of the HTTP data stream, without 47 | additional arguments (Also on error.) 48 | } 49 | 50 | Here is an example, that uses the web server from the webfakes 51 | package: 52 | 53 | \if{html}{\out{
}}\preformatted{http <- webfakes::new_app_process(webfakes::httpbin_app()) 54 | stream_http <- function() \{ 55 | query <- http_get(http$url("/drip?duration=3&numbytes=10")) 56 | query$event_emitter$ 57 | listen_on("data", function(bytes) \{ 58 | writeLines(paste("Got", length(bytes), "byte(s):")) 59 | print(bytes) 60 | \})$ 61 | listen_on("end", function() \{ 62 | writeLines("Done.") 63 | \}) 64 | query 65 | \} 66 | 67 | response <- synchronise(stream_http()) 68 | }\if{html}{\out{
}} 69 | } 70 | 71 | \section{Progress bars}{ 72 | 73 | 74 | \code{http_get} can report on the progress of the download, via the 75 | \code{on_progress} argument. This is called with a list, with entries: 76 | \itemize{ 77 | \item \code{url}: the specified url to download 78 | \item \code{handle}: the curl handle of the request. This can be queried using 79 | \code{\link[curl:handle]{curl::handle_data()}} to get the response status_code, the final 80 | URL (after redirections), timings, etc. 81 | \item \code{file}: the \code{file} argument. 82 | \item \code{total}: total bytes of the response. If this is unknown, it is set 83 | to zero. 84 | \item \code{current}: already received bytes of the response. 85 | } 86 | } 87 | 88 | \examples{ 89 | \donttest{ 90 | afun <- async(function() { 91 | http_get("https://eu.httpbin.org/status/200")$ 92 | then(function(x) x$status_code) 93 | }) 94 | synchronise(afun()) 95 | } 96 | } 97 | \seealso{ 98 | Other asyncronous HTTP calls: 99 | \code{\link{http_head}()}, 100 | \code{\link{http_setopt}()} 101 | } 102 | \concept{asyncronous HTTP calls} 103 | -------------------------------------------------------------------------------- /man/http_head.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/http.R 3 | \name{http_head} 4 | \alias{http_head} 5 | \title{Asynchronous HTTP HEAD request} 6 | \usage{ 7 | http_head( 8 | url, 9 | headers = character(), 10 | file = NULL, 11 | options = list(), 12 | on_progress = NULL 13 | ) 14 | } 15 | \arguments{ 16 | \item{url}{URL to connect to.} 17 | 18 | \item{headers}{HTTP headers to send.} 19 | 20 | \item{file}{If not \code{NULL}, it must be a string, specifying a file. 21 | The body of the response is written to this file.} 22 | 23 | \item{options}{Options to set on the handle. Passed to 24 | \code{\link[curl:handle]{curl::handle_setopt()}}.} 25 | 26 | \item{on_progress}{Progress handler function. It is only used if the 27 | response body is written to a file. See details below.} 28 | } 29 | \value{ 30 | Deferred object. 31 | } 32 | \description{ 33 | An async HTTP deferred object is also an event emitter, see 34 | \code{\link[=http_get]{http_get()}} for details, and also \link{event_emitter}. 35 | } 36 | \examples{ 37 | \donttest{ 38 | afun <- async(function() { 39 | dx <- http_head("https://eu.httpbin.org/status/200")$ 40 | then(function(x) x$status_code) 41 | }) 42 | synchronise(afun()) 43 | 44 | # Check a list of URLs in parallel 45 | afun <- function(urls) { 46 | when_all(.list = lapply(urls, http_head))$ 47 | then(function(x) lapply(x, "[[", "status_code")) 48 | } 49 | urls <- c("https://google.com", "https://eu.httpbin.org") 50 | synchronise(afun(urls)) 51 | } 52 | } 53 | \seealso{ 54 | Other asyncronous HTTP calls: 55 | \code{\link{http_get}()}, 56 | \code{\link{http_setopt}()} 57 | } 58 | \concept{asyncronous HTTP calls} 59 | -------------------------------------------------------------------------------- /man/http_post.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/http.R 3 | \name{http_post} 4 | \alias{http_post} 5 | \title{Asynchronous HTTP POST request} 6 | \usage{ 7 | http_post( 8 | url, 9 | data = NULL, 10 | data_file = NULL, 11 | data_form = NULL, 12 | headers = character(), 13 | file = NULL, 14 | options = list(), 15 | on_progress = NULL 16 | ) 17 | } 18 | \arguments{ 19 | \item{url}{URL to connect to.} 20 | 21 | \item{data}{Data to send. Either a raw vector, or a character string 22 | that will be converted to raw with \link[base:rawConversion]{base::charToRaw}. At most one of 23 | \code{data}, \code{data_file} and \code{data_form} can be non \code{NULL}.} 24 | 25 | \item{data_file}{Data file to send. At most one of \code{data}, \code{data_file} 26 | and \code{data_form} can be non \code{NULL}.} 27 | 28 | \item{data_form}{Form data to send. A name list, where each element 29 | is created with either \code{\link[curl:multipart]{curl::form_data()}} or \code{\link[curl:multipart]{curl::form_file()}}. 30 | At most one of \code{data}, \code{data_file} and \code{data_form} can be non \code{NULL}.} 31 | 32 | \item{headers}{HTTP headers to send.} 33 | 34 | \item{file}{If not \code{NULL}, it must be a string, specifying a file. 35 | The body of the response is written to this file.} 36 | 37 | \item{options}{Options to set on the handle. Passed to 38 | \code{\link[curl:handle]{curl::handle_setopt()}}.} 39 | 40 | \item{on_progress}{Progress handler function. It is only used if the 41 | response body is written to a file. See details at \code{\link[=http_get]{http_get()}}.} 42 | } 43 | \description{ 44 | Start an HTTP POST request in the background, and report its completion 45 | via a deferred value. 46 | } 47 | \details{ 48 | An async HTTP deferred object is also an event emitter, see 49 | \code{\link[=http_get]{http_get()}} for details, and also \link{event_emitter}. 50 | } 51 | \examples{ 52 | json <- jsonlite::toJSON(list(baz = 100, foo = "bar")) 53 | 54 | do <- function() { 55 | headers <- c("content-type" = "application/json") 56 | http_post("https://eu.httpbin.org/post", data = json, headers = headers)$ 57 | then(http_stop_for_status)$ 58 | then(function(x) { 59 | jsonlite::fromJSON(rawToChar(x$content))$json 60 | }) 61 | } 62 | 63 | synchronise(do()) 64 | } 65 | -------------------------------------------------------------------------------- /man/http_setopt.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/http.R 3 | \name{http_setopt} 4 | \alias{http_setopt} 5 | \title{Set curl HTTP options in an event loop} 6 | \usage{ 7 | http_setopt(total_con = NULL, host_con = NULL, multiplex = NULL) 8 | } 9 | \arguments{ 10 | \item{total_con, host_con, multiplex}{They are passed to 11 | \code{\link[curl:multi]{curl::multi_set()}}. If an argument is \code{NULL} (the default) then it is 12 | ignored.} 13 | } 14 | \description{ 15 | The event loop must be already running. In other words, you can only 16 | call this function from async functions. 17 | } 18 | \details{ 19 | The default values are set when the first deferred HTTP operation of the 20 | event loop is created, and they are taken from the \code{async_http_total_con}, 21 | \code{async_http_host_con} and \code{async_http_multiplex} options. 22 | } 23 | \seealso{ 24 | Other asyncronous HTTP calls: 25 | \code{\link{http_get}()}, 26 | \code{\link{http_head}()} 27 | } 28 | \concept{asyncronous HTTP calls} 29 | -------------------------------------------------------------------------------- /man/http_stop_for_status.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/http.R 3 | \name{http_stop_for_status} 4 | \alias{http_stop_for_status} 5 | \title{Throw R errors for HTTP errors} 6 | \usage{ 7 | http_stop_for_status(resp) 8 | } 9 | \arguments{ 10 | \item{resp}{HTTP response from \code{\link[=http_get]{http_get()}}, \code{\link[=http_head]{http_head()}}, etc.} 11 | } 12 | \value{ 13 | The HTTP response invisibly, if it is considered successful. 14 | Otherwise an error is thrown. 15 | } 16 | \description{ 17 | Status codes below 400 are considered successful, others will trigger 18 | errors. Note that this is different from the \code{httr} package, which 19 | considers the 3xx status code errors as well. 20 | } 21 | \examples{ 22 | \donttest{ 23 | afun <- async(function() { 24 | http_get("https://eu.httpbin.org/status/404")$ 25 | then(http_stop_for_status) 26 | }) 27 | 28 | tryCatch(synchronise(afun()), error = function(e) e) 29 | } 30 | } 31 | -------------------------------------------------------------------------------- /man/is_async.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/aaa-async.R 3 | \name{is_async} 4 | \alias{is_async} 5 | \title{Checks if a function is async} 6 | \usage{ 7 | is_async(fun) 8 | } 9 | \arguments{ 10 | \item{fun}{Function.} 11 | } 12 | \value{ 13 | Logical scalar, whether \code{fun} is async. 14 | } 15 | \description{ 16 | If \code{fun} is not a function, an error is thrown. 17 | } 18 | \details{ 19 | Currently, it checks for the \code{async} attribute, which is set by 20 | \code{\link[=async]{async()}}. 21 | } 22 | \examples{ 23 | f <- function(x) 42 24 | af <- async(f) 25 | is_async(f) 26 | is_async(af) 27 | f() 28 | synchronise(dx <- af()) 29 | dx 30 | } 31 | -------------------------------------------------------------------------------- /man/is_deferred.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/deferred.R 3 | \name{is_deferred} 4 | \alias{is_deferred} 5 | \title{Is object a deferred value?} 6 | \usage{ 7 | is_deferred(x) 8 | } 9 | \arguments{ 10 | \item{x}{object} 11 | } 12 | \value{ 13 | Whether it is a deferred value. 14 | } 15 | \description{ 16 | Is object a deferred value? 17 | } 18 | \examples{ 19 | is_deferred(1:10) 20 | afun <- function() { 21 | print(is_deferred(dx <- delay(1/100))) 22 | dx 23 | } 24 | synchronise(afun()) 25 | } 26 | -------------------------------------------------------------------------------- /man/run_event_loop.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/synchronise.R 3 | \name{run_event_loop} 4 | \alias{run_event_loop} 5 | \title{Run event loop to completion} 6 | \usage{ 7 | run_event_loop(expr) 8 | } 9 | \arguments{ 10 | \item{expr}{Expression to run after creating a new event loop.} 11 | } 12 | \value{ 13 | \code{NULL}, always. If the event loop is to return some value, 14 | you can use lexical scoping, see the example below. 15 | } 16 | \description{ 17 | Creates a new event loop, evaluates \code{expr} in it, and then runs the 18 | event loop to completion. It stops when the event loop does not have 19 | any tasks. 20 | } 21 | \details{ 22 | The expression typically creates event loop tasks. It should not create 23 | deferred values, though, because those will never be evaluated. 24 | 25 | Unhandled errors propagate to the \code{run_event_loop()} call, which fails. 26 | 27 | In case of an (unhandled) error, all event loop tasks will be cancelled. 28 | } 29 | \examples{ 30 | counter <- 0L 31 | do <- function() { 32 | callback <- function() { 33 | counter <<- counter + 1L 34 | if (runif(1) < 1/10) t$cancel() 35 | } 36 | t <- async_timer$new(1/1000, callback) 37 | } 38 | run_event_loop(do()) 39 | counter 40 | } 41 | -------------------------------------------------------------------------------- /man/run_process.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/process.R 3 | \name{run_process} 4 | \alias{run_process} 5 | \title{Asynchronous external process execution} 6 | \usage{ 7 | run_process( 8 | command = NULL, 9 | args = character(), 10 | error_on_status = TRUE, 11 | wd = NULL, 12 | env = NULL, 13 | windows_verbatim_args = FALSE, 14 | windows_hide_window = FALSE, 15 | encoding = "", 16 | ... 17 | ) 18 | } 19 | \arguments{ 20 | \item{command}{Character scalar, the command to run. If you are 21 | running \code{.bat} or \code{.cmd} files on Windows, make sure you read the 22 | 'Batch files' section in the \link[processx]{process} manual page.} 23 | 24 | \item{args}{Character vector, arguments to the command.} 25 | 26 | \item{error_on_status}{Whether to reject the referred value if the 27 | program exits with a non-zero status.} 28 | 29 | \item{wd}{Working directory of the process. If \code{NULL}, the current 30 | working directory is used.} 31 | 32 | \item{env}{Environment variables of the child process. If \code{NULL}, 33 | the parent's environment is inherited. On Windows, many programs 34 | cannot function correctly if some environment variables are not 35 | set, so we always set \code{HOMEDRIVE}, \code{HOMEPATH}, \code{LOGONSERVER}, 36 | \code{PATH}, \code{SYSTEMDRIVE}, \code{SYSTEMROOT}, \code{TEMP}, \code{USERDOMAIN}, 37 | \code{USERNAME}, \code{USERPROFILE} and \code{WINDIR}. To append new environment 38 | variables to the ones set in the current process, specify 39 | \code{"current"} in \code{env}, without a name, and the appended ones with 40 | names. The appended ones can overwrite the current ones.} 41 | 42 | \item{windows_verbatim_args}{Whether to omit the escaping of the 43 | command and the arguments on windows. Ignored on other platforms.} 44 | 45 | \item{windows_hide_window}{Whether to hide the window of the 46 | application on windows. Ignored on other platforms.} 47 | 48 | \item{encoding}{The encoding to assume for \code{stdout} and 49 | \code{stderr}. By default the encoding of the current locale is 50 | used. Note that \code{processx} always reencodes the output of 51 | both streams in UTF-8 currently.} 52 | 53 | \item{...}{Extra arguments are passed to \code{process$new()}, see 54 | \link[processx]{process}. Note that you cannot pass \code{stout} or \code{stderr} here, 55 | because they are used internally by \code{run()}. You can use the 56 | \code{stdout_callback}, \code{stderr_callback}, etc. arguments to manage 57 | the standard output and error, or the \link[processx]{process} class directly 58 | if you need more flexibility.} 59 | } 60 | \value{ 61 | Deferred object. 62 | } 63 | \description{ 64 | Start an external process in the background, and report its completion 65 | via a deferred. 66 | } 67 | \examples{ 68 | \dontrun{ 69 | afun <- function() { 70 | run_process("ls", "-l")$ 71 | then(function(x) strsplit(x$stdout, "\r?\n")[[1]]) 72 | } 73 | synchronise(afun()) 74 | } 75 | } 76 | \concept{asynchronous external processes} 77 | -------------------------------------------------------------------------------- /man/run_r_process.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/r-process.R 3 | \name{run_r_process} 4 | \alias{run_r_process} 5 | \title{Asynchronous call to an R function, in a background R process} 6 | \usage{ 7 | run_r_process( 8 | func, 9 | args = list(), 10 | libpath = .libPaths(), 11 | repos = c(getOption("repos"), c(CRAN = "https://cloud.r-project.org")), 12 | cmdargs = c("--no-site-file", "--slave", "--no-save", "--no-restore"), 13 | system_profile = FALSE, 14 | user_profile = FALSE, 15 | env = callr::rcmd_safe_env() 16 | ) 17 | } 18 | \arguments{ 19 | \item{func}{Function object to call in the new R process. 20 | The function should be self-contained and only refer to 21 | other functions and use variables explicitly from other packages 22 | using the \code{::} notation. By default the environment of the function 23 | is set to \code{.GlobalEnv} before passing it to the child process. 24 | (See the \code{package} option if you want to keep the environment.) 25 | Because of this, it is good practice to create an anonymous 26 | function and pass that to \code{callr}, instead of passing 27 | a function object from a (base or other) package. In particular 28 | 29 | \if{html}{\out{
}}\preformatted{r(.libPaths) 30 | }\if{html}{\out{
}} 31 | 32 | does not work, because \code{.libPaths} is defined in a special 33 | environment, but 34 | 35 | \if{html}{\out{
}}\preformatted{r(function() .libPaths()) 36 | }\if{html}{\out{
}} 37 | 38 | works just fine.} 39 | 40 | \item{args}{Arguments to pass to the function. Must be a list.} 41 | 42 | \item{libpath}{The library path.} 43 | 44 | \item{repos}{The \code{repos} option. If \code{NULL}, then no 45 | \code{repos} option is set. This options is only used if 46 | \code{user_profile} or \code{system_profile} is set \code{FALSE}, 47 | as it is set using the system or the user profile.} 48 | 49 | \item{cmdargs}{Command line arguments to pass to the R process. 50 | Note that \code{c("-f", rscript)} is appended to this, \code{rscript} 51 | is the name of the script file to run. This contains a call to the 52 | supplied function and some error handling code.} 53 | 54 | \item{system_profile}{Whether to use the system profile file.} 55 | 56 | \item{user_profile}{Whether to use the user's profile file. 57 | If this is \code{"project"}, then only the profile from the working 58 | directory is used, but the \code{R_PROFILE_USER} environment variable 59 | and the user level profile are not. See also "Security considerations" 60 | below.} 61 | 62 | \item{env}{Environment variables to set for the child process.} 63 | } 64 | \description{ 65 | Start a background R process and evaluate a function call in it. 66 | It uses \link[callr:r_process]{callr::r_process} internally. 67 | } 68 | \examples{ 69 | \dontrun{ 70 | afun <- function() { 71 | run_r_process(function() Sys.getpid()) 72 | } 73 | synchronise(afun()) 74 | } 75 | } 76 | -------------------------------------------------------------------------------- /man/sse_events.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/http-sse.R 3 | \name{sse_events} 4 | \alias{sse_events} 5 | \title{HTTP event emitter for server-sent events} 6 | \description{ 7 | Server-sent events are a technique to stream events from a web server 8 | to a client, through an open HTTP connection. 9 | } 10 | \details{ 11 | This class implements an event emitter on an async HTTP query created 12 | with \code{\link[=http_get]{http_get()}} and friends, that fires an \code{"event"} event when the 13 | server sends an event. An \code{"end"} event is emitted when the server 14 | closes the connection. 15 | 16 | An event is a named character vector, the names are the keys of the 17 | events. 18 | 19 | Example using our built-in toy web app: 20 | 21 | \if{html}{\out{
}}\preformatted{http <- webfakes::new_app_process(async:::sseapp()) 22 | stream_events <- function() \{ 23 | query <- http_get(http$url("/sse")) 24 | sse <- sse_events$new(query) 25 | sse$ 26 | listen_on("event", function(event) \{ 27 | writeLines("Got an event:") 28 | print(event) 29 | \})$ 30 | listen_on("end", function() \{ 31 | writeLines("Done.") 32 | \}) 33 | query 34 | \} 35 | 36 | response <- synchronise(stream_events()) 37 | }\if{html}{\out{
}} 38 | } 39 | -------------------------------------------------------------------------------- /man/synchronise.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/synchronise.R 3 | \name{synchronise} 4 | \alias{synchronise} 5 | \title{Synchronously wrap asynchronous code} 6 | \usage{ 7 | synchronise(expr) 8 | } 9 | \arguments{ 10 | \item{expr}{Async function call expression. If it does not evaluate 11 | to a deferred value, then it is just returned.} 12 | } 13 | \description{ 14 | Evaluate an expression in an async phase. It creates an event loop, 15 | then evaluates the supplied expression. If its result is a deferred 16 | value, it keeps running the event loop, until the deferred value is 17 | resolved, and returns its resolved value. 18 | } 19 | \details{ 20 | If an error is not handled in the async phase, \code{synchronise()} will 21 | re-throw that error. 22 | 23 | \code{synchronise()} cancels all async processes on interrupt or external 24 | error. 25 | } 26 | \examples{ 27 | \donttest{ 28 | http_status <- function(url, ...) { 29 | http_get(url, ...)$ 30 | then(function(x) x$status_code) 31 | } 32 | 33 | synchronise(http_status("https://eu.httpbin.org/status/418")) 34 | } 35 | } 36 | -------------------------------------------------------------------------------- /man/when_all.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/when_all.R 3 | \name{when_all} 4 | \alias{when_all} 5 | \title{Deferred value for a set of deferred values} 6 | \usage{ 7 | when_all(..., .list = list()) 8 | } 9 | \arguments{ 10 | \item{...}{Deferred values.} 11 | 12 | \item{.list}{More deferred values.} 13 | } 14 | \value{ 15 | A deferred value, that is conditioned on all deferred values 16 | in \code{...} and \code{.list}. 17 | } 18 | \description{ 19 | Create a deferred value that is resolved when all listed deferred values 20 | are resolved. Note that the error of an input deferred value 21 | triggers the error \code{when_all} as well. 22 | } 23 | \details{ 24 | async has auto-cancellation, so if one deferred value errors, the rest 25 | of them will be automatically cancelled. 26 | } 27 | \examples{ 28 | \donttest{ 29 | ## Check that the contents of two URLs are the same 30 | afun <- async(function() { 31 | u1 <- http_get("https://eu.httpbin.org") 32 | u2 <- http_get("https://eu.httpbin.org/get") 33 | when_all(u1, u2)$ 34 | then(function(x) identical(x[[1]]$content, x[[2]]$content)) 35 | }) 36 | synchronise(afun()) 37 | } 38 | } 39 | \seealso{ 40 | \code{\link[=when_any]{when_any()}}, \code{\link[=when_some]{when_some()}} 41 | } 42 | -------------------------------------------------------------------------------- /man/when_some.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/when_any.R 3 | \name{when_some} 4 | \alias{when_some} 5 | \alias{when_any} 6 | \title{Resolve a deferred as soon as some deferred from a list resolve} 7 | \usage{ 8 | when_some(count, ..., .list = list()) 9 | 10 | when_any(..., .list = list()) 11 | } 12 | \arguments{ 13 | \item{count}{Number of deferred values that need to resolve.} 14 | 15 | \item{...}{Deferred values.} 16 | 17 | \item{.list}{More deferred values.} 18 | } 19 | \value{ 20 | A deferred value, that is conditioned on all deferred values 21 | in \code{...} and \code{.list}. 22 | } 23 | \description{ 24 | \code{when_some} creates a deferred value that is resolved as soon as the 25 | specified number of deferred values resolve. 26 | } 27 | \details{ 28 | \code{when_any} is a special case for a single. 29 | 30 | If the specified number of deferred values cannot be resolved, then 31 | \code{when_any} throws an error. 32 | 33 | async has auto-cancellation, so if the required number of deferred values 34 | are resolved, or too many of them throw error, the rest of the are 35 | cancelled. 36 | 37 | If \code{when_any} throws an error, then all the underlying error objects 38 | are returned in the \code{errors} member of the error object thrown by 39 | \code{when_any}. 40 | } 41 | \examples{ 42 | \donttest{ 43 | ## Use the URL that returns first 44 | afun <- function() { 45 | u1 <- http_get("https://eu.httpbin.org") 46 | u2 <- http_get("https://eu.httpbin.org/get") 47 | when_any(u1, u2)$then(function(x) x$url) 48 | } 49 | synchronise(afun()) 50 | } 51 | } 52 | \seealso{ 53 | \code{\link[=when_all]{when_all()}} 54 | } 55 | -------------------------------------------------------------------------------- /man/worker_pool.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/worker-pool.R 3 | \name{worker_pool} 4 | \alias{worker_pool} 5 | \title{Worker pool} 6 | \description{ 7 | The worker pool functions are independent of the event loop, to allow 8 | independent testing. 9 | } 10 | \concept{worker pool functions} 11 | \keyword{internal} 12 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(async) 3 | 4 | test_check("async", reporter = "summary") 5 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/backoff.md: -------------------------------------------------------------------------------- 1 | # fail, success 2 | 3 | Code 4 | synchronise(async_backoff(uns, custom_backoff = bo)) 5 | Message 6 | not yet 7 | not yet 8 | not yet 9 | Output 10 | [1] "answer" 11 | 12 | --- 13 | 14 | Code 15 | synchronise(async_backoff(uns, custom_backoff = bo, times = 2)) 16 | Message 17 | not yet 18 | not yet 19 | Condition 20 | Error: 21 | ! not yet 22 | 23 | --- 24 | 25 | Code 26 | synchronise(async_backoff(uns, custom_backoff = bo, time_limit = 1)) 27 | Message 28 | not yet 29 | not yet 30 | not yet 31 | Output 32 | [1] "answer" 33 | 34 | --- 35 | 36 | Code 37 | synchronise(async_backoff(uns2, custom_backoff = bo, time_limit = 0.1)) 38 | Condition 39 | Error in `uns()`: 40 | ! not yet 41 | 42 | # progress 43 | 44 | Code 45 | synchronise(async_backoff(uns, custom_backoff = bo, on_progress = progress, 46 | progress_data = "data")) 47 | Message 48 | not yet 49 | Output 50 | $event 51 | [1] "retry" 52 | 53 | $tries 54 | [1] 1 55 | 56 | $spent 57 | Time difference of secs 58 | 59 | $error 60 | 61 | 62 | $retry_in 63 | [1] 0.1 64 | 65 | [1] "data" 66 | Message 67 | not yet 68 | Output 69 | $event 70 | [1] "retry" 71 | 72 | $tries 73 | [1] 2 74 | 75 | $spent 76 | Time difference of secs 77 | 78 | $error 79 | 80 | 81 | $retry_in 82 | [1] 0.1 83 | 84 | [1] "data" 85 | Message 86 | not yet 87 | Output 88 | $event 89 | [1] "retry" 90 | 91 | $tries 92 | [1] 3 93 | 94 | $spent 95 | Time difference of secs 96 | 97 | $error 98 | 99 | 100 | $retry_in 101 | [1] 0.1 102 | 103 | [1] "data" 104 | [1] "answer" 105 | 106 | --- 107 | 108 | Code 109 | synchronise(async_backoff(uns, custom_backoff = bo, times = 2, on_progress = progress, 110 | progress_data = "data")) 111 | Message 112 | not yet 113 | Output 114 | $event 115 | [1] "retry" 116 | 117 | $tries 118 | [1] 1 119 | 120 | $spent 121 | Time difference of secs 122 | 123 | $error 124 | 125 | 126 | $retry_in 127 | [1] 0.1 128 | 129 | [1] "data" 130 | Message 131 | not yet 132 | Output 133 | $event 134 | [1] "givenup" 135 | 136 | $tries 137 | [1] 2 138 | 139 | $spent 140 | Time difference of secs 141 | 142 | $error 143 | 144 | 145 | $retry_in 146 | [1] NA 147 | 148 | [1] "data" 149 | Condition 150 | Error: 151 | ! not yet 152 | 153 | # HTTP backoff example 154 | 155 | Code 156 | uniq(messages) 157 | Output 158 | [1] "http://127.0.0.1/unstable: got 0/0" 159 | [2] "http://127.0.0.1/unstable failed, retry in 0.100000 seconds" 160 | [3] "http://127.0.0.1/unstable: got 0/0" 161 | [4] "http://127.0.0.1/unstable failed, retry in 0.100000 seconds" 162 | [5] "http://127.0.0.1/unstable: got 0/0" 163 | [6] "http://127.0.0.1/unstable failed, retry in 0.100000 seconds" 164 | [7] "http://127.0.0.1/unstable: got 0/0" 165 | [8] "http://127.0.0.1/unstable: got 215/215" 166 | 167 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/http-sse.md: -------------------------------------------------------------------------------- 1 | # parse_sse_event 2 | 3 | Code 4 | parse_sse_event(charToRaw(txt)) 5 | Output 6 | foo 7 | "bar" 8 | 9 | --- 10 | 11 | Code 12 | parse_sse_event(charToRaw(txt)) 13 | Output 14 | foo 15 | "bar" 16 | 17 | --- 18 | 19 | Code 20 | parse_sse_event(charToRaw(txt)) 21 | Output 22 | foo baz and 23 | "bar" "foobar" "last" 24 | 25 | # chunk_sse_events 26 | 27 | Code 28 | chunk_sse_events(charToRaw(txt)) 29 | Output 30 | $events 31 | list() 32 | 33 | $rest 34 | [1] 66 6f 6f 3a 20 62 61 72 0a 62 61 7a 3a 20 66 6f 6f 0a 35 | 36 | 37 | --- 38 | 39 | Code 40 | chunk_sse_events(charToRaw(txt)) 41 | Output 42 | $events 43 | $events[[1]] 44 | foo baz 45 | "bar" "foobar" 46 | 47 | $events[[2]] 48 | another 49 | "event" 50 | 51 | $events[[3]] 52 | and 53 | "another" 54 | 55 | 56 | $rest 57 | raw(0) 58 | 59 | 60 | --- 61 | 62 | Code 63 | chunk_sse_events(charToRaw(txt)) 64 | Output 65 | $events 66 | $events[[1]] 67 | foo baz 68 | "bar" "foobar" 69 | 70 | $events[[2]] 71 | another 72 | "event" 73 | 74 | $events[[3]] 75 | and 76 | "another" 77 | 78 | 79 | $rest 80 | raw(0) 81 | 82 | 83 | --- 84 | 85 | Code 86 | chunk_sse_events(charToRaw(txt)) 87 | Output 88 | $events 89 | $events[[1]] 90 | foo baz 91 | "bar" "foobar" 92 | 93 | $events[[2]] 94 | another 95 | "event" 96 | 97 | 98 | $rest 99 | [1] 61 6e 64 3a 61 6e 6f 74 68 65 72 0a 100 | 101 | 102 | # sse 103 | 104 | Code 105 | events 106 | Output 107 | [[1]] 108 | event message 109 | "1" "live long and prosper" 110 | 111 | [[2]] 112 | event message 113 | "2" "live long and prosper" 114 | 115 | [[3]] 116 | event message 117 | "3" "live long and prosper" 118 | 119 | [[4]] 120 | event message 121 | "4" "live long and prosper" 122 | 123 | [[5]] 124 | event message 125 | "5" "live long and prosper" 126 | 127 | 128 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/http.md: -------------------------------------------------------------------------------- 1 | # http_post form 2 | 3 | Code 4 | obj$files 5 | Output 6 | $baz 7 | $baz$filename 8 | [1] "mrfile" 9 | 10 | $baz$value 11 | [1] "data:application/octet-stream;base64,MDEyMzQ1Njc4OQ==" 12 | 13 | 14 | 15 | --- 16 | 17 | Code 18 | obj$form 19 | Output 20 | $foo 21 | [1] "bar" 22 | 23 | 24 | -------------------------------------------------------------------------------- /tests/testthat/helper-mock.R: -------------------------------------------------------------------------------- 1 | fake <- local({ 2 | fake_through_tree <- function(tree, what, how) { 3 | for (d in tree) { 4 | for (parent in d) { 5 | parent_env <- parent[["parent_env"]] 6 | func_dict <- parent[["funcs"]] 7 | for (func_name in ls(func_dict, all.names = TRUE)) { 8 | func <- func_dict[[func_name]] 9 | func_env <- new.env(parent = environment(func)) 10 | 11 | what <- override_seperators(what, func_env) 12 | where_name <- override_seperators(func_name, parent_env) 13 | 14 | if (!is.function(how)) { 15 | assign(what, function(...) how, func_env) 16 | } else { 17 | assign(what, how, func_env) 18 | } 19 | 20 | environment(func) <- func_env 21 | locked <- exists(where_name, parent_env, inherits = FALSE) && 22 | bindingIsLocked(where_name, parent_env) 23 | if (locked) { 24 | baseenv()$unlockBinding(where_name, parent_env) 25 | } 26 | assign(where_name, func, parent_env) 27 | if (locked) { 28 | lockBinding(where_name, parent_env) 29 | } 30 | } 31 | } 32 | } 33 | } 34 | 35 | override_seperators <- function(name, env) { 36 | mangled_name <- NULL 37 | for (sep in c("::", "$")) { 38 | if (grepl(sep, name, fixed = TRUE)) { 39 | elements <- strsplit(name, sep, fixed = TRUE) 40 | mangled_name <- paste( 41 | elements[[1L]][1L], 42 | elements[[1L]][2L], 43 | sep = "XXX" 44 | ) 45 | 46 | stub_list <- c(mangled_name) 47 | if ("stub_list" %in% names(attributes(get(sep, env)))) { 48 | stub_list <- c(stub_list, attributes(get(sep, env))[["stub_list"]]) 49 | } 50 | 51 | create_new_name <- create_create_new_name_function( 52 | stub_list, 53 | env, 54 | sep 55 | ) 56 | assign(sep, create_new_name, env) 57 | } 58 | } 59 | mangled_name %||% name 60 | } 61 | 62 | backtick <- function(x) { 63 | encodeString(x, quote = "`", na.encode = FALSE) 64 | } 65 | 66 | create_create_new_name_function <- function(stub_list, env, sep) { 67 | force(stub_list) 68 | force(env) 69 | force(sep) 70 | 71 | create_new_name <- function(pkg, func) { 72 | pkg_name <- deparse(substitute(pkg)) 73 | func_name <- deparse(substitute(func)) 74 | for (stub in stub_list) { 75 | if (paste(pkg_name, func_name, sep = "XXX") == stub) { 76 | return(eval(parse(text = backtick(stub)), env)) 77 | } 78 | } 79 | 80 | # used to avoid recursively calling the replacement function 81 | eval_env <- new.env(parent = parent.frame()) 82 | assign(sep, eval(parse(text = paste0("`", sep, "`"))), eval_env) 83 | 84 | code <- paste(pkg_name, backtick(func_name), sep = sep) 85 | return(eval(parse(text = code), eval_env)) 86 | } 87 | attributes(create_new_name) <- list(stub_list = stub_list) 88 | create_new_name 89 | } 90 | 91 | build_function_tree <- function(test_env, where, where_name) { 92 | func_dict <- new.env() 93 | func_dict[[where_name]] <- where 94 | tree <- list( 95 | list( 96 | list(parent_env = test_env, funcs = func_dict) 97 | ) 98 | ) 99 | 100 | tree 101 | } 102 | 103 | fake <- function(where, what, how) { 104 | where_name <- deparse(substitute(where)) 105 | stopifnot(is.character(what), length(what) == 1) 106 | test_env <- parent.frame() 107 | tree <- build_function_tree(test_env, where, where_name) 108 | fake_through_tree(tree, what, how) 109 | } 110 | }) 111 | -------------------------------------------------------------------------------- /tests/testthat/helper.R: -------------------------------------------------------------------------------- 1 | 2 | skip_without_package <- function(package, version = NULL) { 3 | if (!requireNamespace(package, quietly = TRUE)) { 4 | skip(paste0("Needs ", package, " package")) 5 | } else if (!is.null(version) && packageVersion(package) < version) { 6 | skip(paste0("Needs ", package, ", version ", version, " at least")) 7 | } 8 | } 9 | 10 | get_private <- function(x) x$.__enclos_env__$private 11 | -------------------------------------------------------------------------------- /tests/testthat/setup-httpbin.R: -------------------------------------------------------------------------------- 1 | 2 | http <- webfakes::new_app_process( 3 | webfakes::httpbin_app(), opts = webfakes::server_opts(num_threads = 3) 4 | ) 5 | -------------------------------------------------------------------------------- /tests/testthat/teardown-httpbin.R: -------------------------------------------------------------------------------- 1 | 2 | http$stop() 3 | -------------------------------------------------------------------------------- /tests/testthat/test-amap.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("async_map", { 3 | list <- structure(as.list(1:10), names = letters[1:10]) 4 | 5 | fun <- async(function(x) { 6 | force(x) 7 | delay(1/100)$then(function(value) x * 2) 8 | }) 9 | 10 | result <- synchronise(async_map(list, fun)) 11 | expect_identical(result, as.list(unlist(list) * 2)) 12 | }) 13 | 14 | test_that("async_map with limit", { 15 | 16 | list <- structure(as.list(1:10), names = letters[1:10]) 17 | fun <- function(x) { 18 | force(x) 19 | delay(1/10000)$then(function(value) x * 2) 20 | } 21 | 22 | for (l in 1:10) { 23 | result <- synchronise(async_map(list, fun, .limit = l)) 24 | expect_identical(result, as.list(unlist(list) * 2)) 25 | } 26 | }) 27 | 28 | test_that("async_map with limit, error", { 29 | 30 | list <- structure(as.list(1:10), names = letters[1:10]) 31 | fun <- async(function(x) { 32 | force(x) 33 | delay(1/10000)$then(function() if (x == 7) stop("oops") else x * 2) 34 | }) 35 | 36 | for (l in c(1:10, Inf)) { 37 | expect_error(synchronise(async_map(list, fun, .limit = l)), "oops") 38 | } 39 | }) 40 | -------------------------------------------------------------------------------- /tests/testthat/test-async.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("it returns a function", { 3 | ret <- async(function() { }) 4 | expect_true(is.function(ret)) 5 | }) 6 | 7 | test_that("it returns a function with the same arity", { 8 | defs <- list( 9 | function(a, b, c) { }, 10 | function() { }, 11 | function(a, b, c, d, e, f, g, h) { }, 12 | function(x) { }, 13 | function(a = "foo", b = "bar") { }, 14 | function(...) { }, 15 | function(x = 10, ..., last = "foo") { } 16 | ) 17 | 18 | for (f in defs) { 19 | f2 <- async(f) 20 | expect_equal(formals(f), formals(f2)) 21 | } 22 | }) 23 | 24 | test_that("when called it returns a deferred", { 25 | fun <- async(function() "foo") 26 | synchronise(dx <- fun()) 27 | expect_true(is_deferred(dx)) 28 | }) 29 | 30 | test_that("preserves closure", { 31 | env <- new.env() 32 | foo <- local(envir = env, { 33 | baz <- list(x = 7) 34 | async(function() parent.env(parent.env(environment()))) 35 | }) 36 | 37 | do <- async(function() { 38 | dx <- foo()$ 39 | then(function(result) expect_identical(result, env)) 40 | }) 41 | 42 | synchronise(do()) 43 | }) 44 | 45 | test_that("resolves to the definition", { 46 | do <- async(function() { 47 | foo <- async(function () "blah") 48 | dx <- foo()$ 49 | then(function(result) expect_equal(result, "blah")) 50 | }) 51 | synchronise(do()) 52 | }) 53 | 54 | test_that("rejects with the thrown error", { 55 | do <- async(function() { 56 | act <- NULL 57 | exp <- simpleError("Expected thrown value to match rejection value") 58 | foo <- async(function() { stop(exp); "blah" }) 59 | dx <- foo()$ 60 | catch(error = function(err) { act <<- exp; exp })$ 61 | then(function(value) { 62 | if (is.null(act)) { 63 | stop("Extected function to throw") 64 | } else if (!identical(act, exp)) { 65 | stop(exp) 66 | } 67 | }) 68 | }) 69 | 70 | expect_silent(synchronise(do())) 71 | }) 72 | 73 | test_that("triggers error on unhandled rejection", { 74 | 75 | did_trigger <- FALSE 76 | do <- async(function() { 77 | foo <- async(function() stop("Nobody handled me")) 78 | foo() 79 | }) 80 | 81 | tryCatch( 82 | synchronise(do()), 83 | error = function(e) did_trigger <<- TRUE 84 | ) 85 | expect_true(did_trigger) 86 | }) 87 | 88 | test_that("can be cancelled", { 89 | 90 | called <- called2 <- FALSE 91 | do <- function() { 92 | afun <- async(function() called <<- TRUE) 93 | dx <- afun() 94 | dy <- dx$then(function() called2 <<- TRUE) 95 | dx$cancel() 96 | dy 97 | } 98 | 99 | err <- tryCatch(synchronise(do()), error = identity) 100 | expect_equal(conditionMessage(err), "Cancelled") 101 | expect_s3_class(err, "async_cancelled") 102 | expect_s3_class(err, "async_rejected") 103 | expect_false(called) 104 | expect_false(called2) 105 | }) 106 | 107 | test_that("built-ins are marked as async", { 108 | expect_true(is_async(async_constant)) 109 | expect_true(is_async(async_detect)) 110 | expect_true(is_async(async_every)) 111 | expect_true(is_async(async_filter)) 112 | expect_true(is_async(async_map)) 113 | expect_true(is_async(async_reflect)) 114 | expect_true(is_async(async_retry)) 115 | expect_true(is_async(async_sequence)) 116 | expect_true(is_async(async_some)) 117 | expect_true(is_async(async_timeout)) 118 | expect_true(is_async(async_until)) 119 | expect_true(is_async(async_whilst)) 120 | expect_true(is_async(delay)) 121 | expect_true(is_async(http_get)) 122 | expect_true(is_async(http_head)) 123 | expect_true(is_async(when_all)) 124 | expect_true(is_async(when_any)) 125 | expect_true(is_async(when_some)) 126 | }) 127 | -------------------------------------------------------------------------------- /tests/testthat/test-backoff.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("fail, success", { 3 | local_edition(3) 4 | did <- 0L 5 | uns <- function() { 6 | if (did == 3) { 7 | "answer" 8 | } else { 9 | did <<- did + 1 10 | message("not yet") 11 | stop("not yet") 12 | } 13 | } 14 | 15 | bo <- function(i) 0.1 16 | 17 | # ok 18 | did <- 0L 19 | expect_snapshot( 20 | synchronise(async_backoff(uns, custom_backoff = bo)) 21 | ) 22 | 23 | # not ok 24 | did <- 0L 25 | expect_snapshot( 26 | error = TRUE, 27 | synchronise(async_backoff(uns, custom_backoff = bo, times = 2)) 28 | ) 29 | 30 | # time_limit ok 31 | did <- 0L 32 | expect_snapshot( 33 | synchronise(async_backoff(uns, custom_backoff = bo, time_limit = 1)) 34 | ) 35 | 36 | # time_limit not ok 37 | did <- 0L 38 | uns2 <- function() { 39 | suppressMessages(uns()) 40 | } 41 | expect_snapshot( 42 | error = TRUE, 43 | synchronise(async_backoff(uns2, custom_backoff = bo, time_limit = 0.1)) 44 | ) 45 | }) 46 | 47 | test_that("progress", { 48 | local_edition(3) 49 | did <- 0L 50 | uns <- function() { 51 | if (did == 3) { 52 | "answer" 53 | } else { 54 | did <<- did + 1 55 | message("not yet") 56 | stop("not yet") 57 | } 58 | } 59 | 60 | bo <- function(i) 0.1 61 | 62 | progress <- function(status, data) { 63 | status$error$call <- status$error$calls <- status$error$aframe <- NULL 64 | class(status$error) <- setdiff(class(status$error), "async_rejected") 65 | print(status) 66 | print(data) 67 | } 68 | 69 | trfm <- function(x) { 70 | sub( 71 | "Time difference of [.0-9]+ secs", 72 | "Time difference of secs", 73 | x 74 | ) 75 | } 76 | 77 | # ok 78 | did <- 0L 79 | expect_snapshot( 80 | synchronise(async_backoff( 81 | uns, 82 | custom_backoff = bo, 83 | on_progress = progress, 84 | progress_data = "data" 85 | )), 86 | transform = trfm 87 | ) 88 | 89 | # not ok 90 | did <- 0L 91 | expect_snapshot( 92 | error = TRUE, 93 | synchronise(async_backoff( 94 | uns, 95 | custom_backoff = bo, 96 | times = 2, 97 | on_progress = progress, 98 | progress_data = "data" 99 | )), 100 | transform = trfm 101 | ) 102 | }) 103 | 104 | test_that("default_backoff", { 105 | bo <- sapply(1:10, default_backoff) 106 | expect_true(all(bo >= 1)) 107 | expect_true(all(bo <= 2^(1:10))) 108 | }) 109 | 110 | test_that("HTTP backoff example", { 111 | local_edition(3) 112 | 113 | flaky <- webfakes::new_app() 114 | flaky$get("/unstable", function(req, res) { 115 | if (identical(res$app$locals$counter, 3L)) { 116 | res$app$locals$counter <- NULL 117 | res$send_json(object = list(result = strrep("ok", 100))) 118 | } else { 119 | res$app$locals$counter <- c(res$app$locals$counter, 0L)[[1]] + 1L 120 | res$send_status(401) 121 | } 122 | }) 123 | 124 | pr <- webfakes::new_app_process(flaky) 125 | url <- pr$url("/unstable") 126 | 127 | messages <- character() 128 | 129 | cb_http <- function(data) { 130 | messages <<- c( 131 | messages, 132 | sprintf("%s: got %s/%s", url, data$current, data$total) 133 | ) 134 | } 135 | 136 | cb_backoff <- function(data, url) { 137 | messages <<- c( 138 | messages, 139 | if (data$event == "retry") { 140 | sprintf("%s failed, retry in %f seconds", url, data$retry_in) 141 | } else { 142 | sprintf("%s: given up after %d tries", url, data$tries) 143 | } 144 | ) 145 | } 146 | 147 | fun <- function() { 148 | 149 | query <- function(url) { 150 | http_get(url, on_progress = cb_http)$then(http_stop_for_status) 151 | } 152 | 153 | async_backoff( 154 | query, 155 | .args = list(url = url), 156 | times = 4, 157 | on_progress = cb_backoff, 158 | progress_data = url, 159 | custom_backoff = function(i) 0.1 160 | ) 161 | } 162 | 163 | synchronise(fun()) 164 | 165 | shift <- function(v) { 166 | if (length(v) == 0) { 167 | v 168 | } else { 169 | c(v[-1], "") 170 | } 171 | } 172 | 173 | uniq <- function(x) { 174 | x[x != shift(x)] 175 | } 176 | 177 | expect_snapshot( 178 | uniq(messages), 179 | transform = function(x) sub(":[0-9]+", "", x) 180 | ) 181 | }) 182 | -------------------------------------------------------------------------------- /tests/testthat/test-cancel.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("on_cancel callback is called", { 3 | 4 | dx <- NULL 5 | cancelled <- FALSE 6 | cancel_msg <- NULL 7 | do <- async(function() { 8 | dx <<- deferred$new( 9 | action = function(resolve) { }, 10 | on_cancel = function(msg) { 11 | cancelled <<- TRUE 12 | cancel_msg <<- msg 13 | }) 14 | dx$cancel("changed my mind") 15 | }) 16 | 17 | err <- tryCatch(synchronise(do()), error = function(e) e) 18 | expect_match(conditionMessage(err), "changed my mind") 19 | expect_s3_class(err, "async_cancelled") 20 | expect_equal(get_private(dx)$state, "rejected") 21 | expect_true(cancelled) 22 | expect_match(cancel_msg, "changed my mind") 23 | }) 24 | 25 | test_that("then() is also rejected on cancel", { 26 | 27 | dx <- dx2 <- NULL 28 | do <- async(function() { 29 | dx <<- deferred$new(action = function(resolve) { }) 30 | dx2 <<- dx$then(function() "not this far") 31 | dx$cancel("changed my mind") 32 | dx2 33 | }) 34 | 35 | err <- tryCatch(synchronise(do()), error = function(e) e) 36 | expect_match(conditionMessage(get_private(dx)$value), "changed my mind") 37 | expect_match(conditionMessage(get_private(dx2)$value), "changed my mind") 38 | expect_s3_class(get_private(dx)$value, "async_cancelled") 39 | expect_s3_class(get_private(dx2)$value, "async_cancelled") 40 | expect_equal(get_private(dx2)$state, "rejected") 41 | expect_equal(get_private(dx)$state, "rejected") 42 | }) 43 | 44 | test_that("can catch and handle cancellation", { 45 | 46 | err <- NULL 47 | do <- async(function() { 48 | dx <- deferred$new(action = function(resolve) { }) 49 | dx2 <- dx$catch(error = function(e) err <<- e) 50 | dx$cancel("changed my mind") 51 | dx2 52 | }) 53 | 54 | synchronise(do()) 55 | expect_s3_class(err, "async_cancelled") 56 | expect_match(conditionMessage(err), "changed my mind") 57 | }) 58 | 59 | test_that("cancel delay", { 60 | 61 | do <- function() { 62 | d1 <- delay(60) 63 | d1$cancel() 64 | } 65 | tic <- Sys.time() 66 | expect_error(synchronise(do()), "Cancelled", class = "async_cancelled") 67 | tac <- Sys.time() 68 | expect_true(tac - tic < as.difftime(30, units = "secs")) 69 | }) 70 | 71 | test_that("cancel delay after it has started", { 72 | 73 | cancelled <- NULL 74 | do <- function() { 75 | d1 <- delay(5) 76 | d1x <- d1$catch(error = identity) 77 | d2 <- delay(1/100)$ 78 | then(function() { d1$cancel("nope"); "OK" }) 79 | when_all(d1x, d2) 80 | } 81 | 82 | tic <- Sys.time() 83 | res <- synchronise(do()) 84 | tac <- Sys.time() 85 | 86 | expect_s3_class(res[[1]], "async_cancelled") 87 | expect_equal(conditionMessage(res[[1]]), "nope") 88 | expect_equal(res[[2]], "OK") 89 | expect_true(tac - tic < as.difftime(4, units = "secs")) 90 | }) 91 | -------------------------------------------------------------------------------- /tests/testthat/test-constant.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("creates a deferred value", { 3 | do <- function() { 4 | dx <- async_constant() 5 | expect_true(is_deferred(dx)) 6 | dx 7 | } 8 | synchronise(do()) 9 | 10 | do <- function() { 11 | dx <- async_constant("foobar") 12 | expect_true(is_deferred(dx)) 13 | dx 14 | } 15 | synchronise(do()) 16 | }) 17 | 18 | test_that("resolves to the specified value", { 19 | do <- function() { 20 | async_constant("foobar")$ 21 | then(function(x) expect_equal(x, "foobar")) 22 | } 23 | synchronise(do()) 24 | 25 | do <- function() { 26 | async_constant()$ 27 | then(function(x) expect_null(x)) 28 | } 29 | synchronise(do()) 30 | }) 31 | -------------------------------------------------------------------------------- /tests/testthat/test-deferred-http.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("GET", { 3 | do <- async(function() { 4 | http_get(http$url("/get", query = list(q = 42)))$ 5 | then(function(x) rawToChar(x$content))$ 6 | then(function(x) expect_match(x, "\"q\":[ ]*\"42\"", fixed = FALSE)) 7 | }) 8 | synchronise(do()) 9 | }) 10 | 11 | test_that("HEAD", { 12 | do <- async(function() { 13 | http_head(http$url("/"))$ 14 | then(function(x) expect_equal(x$status_code, 200)) 15 | }) 16 | synchronise(do()) 17 | }) 18 | 19 | test_that("http_stop_for_status", { 20 | do <- async(function() { 21 | http_get(http$url("/status/404"))$ 22 | then(http_stop_for_status) 23 | }) 24 | expect_error(synchronise(do()), "404", class = "async_http_404") 25 | }) 26 | -------------------------------------------------------------------------------- /tests/testthat/test-deferred-pieces.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("def__make_parent_*", { 3 | good <- list( 4 | NULL, 5 | function(x) x, 6 | function() 42, 7 | function(value, resolve) resolve(value) 8 | ) 9 | 10 | bad <- list( 11 | 123, 12 | function(a, b, c) resolve(value) 13 | ) 14 | 15 | eta <- function(value, resolve) { } 16 | 17 | for (f in good) { 18 | res <- def__make_parent_resolve(f) 19 | expect_equal(formals(res), formals(eta)) 20 | res2 <- def__make_parent_reject(f) 21 | expect_equal(formals(res2), formals(eta)) 22 | } 23 | 24 | for (f in bad) { 25 | expect_error(def__make_parent_resolve(f)) 26 | expect_error(def__make_parent_reject(f)) 27 | } 28 | }) 29 | 30 | test_that("def__make_parent_resolve", { 31 | ## NULL 32 | r1 <- def__make_parent_resolve(NULL) 33 | res <- NULL 34 | val <- NULL 35 | r1(42, function(x) { res <<- "resolve"; val <<- x }) 36 | expect_equal(res, "resolve") 37 | expect_equal(val, 42) 38 | 39 | ## function without args 40 | r2 <- def__make_parent_resolve(function() 42 * 42) 41 | res <- NULL 42 | val <- NULL 43 | r2(42, function(x) { res <<- "resolve"; val <<- x }) 44 | expect_equal(res, "resolve") 45 | expect_equal(val, 42 * 42) 46 | 47 | ## function with value arg 48 | r2 <- def__make_parent_resolve(function(val) val) 49 | res <- NULL 50 | val <- NULL 51 | r2(42, function(x) { res <<- "resolve"; val <<- x }) 52 | expect_equal(res, "resolve") 53 | expect_equal(val, 42) 54 | }) 55 | 56 | test_that("def__make_parent_resolve", { 57 | ## NULL 58 | r1 <- def__make_parent_reject(NULL) 59 | res <- NULL 60 | val <- NULL 61 | expect_error( 62 | r1("foobar", function(x) { res <<- "resolve"; val <<- x }), 63 | "foobar" 64 | ) 65 | expect_null(res) 66 | expect_null(val) 67 | 68 | ## function without args 69 | r2 <- def__make_parent_reject(function() 42 * 42) 70 | res <- NULL 71 | val <- NULL 72 | r2(42, function(x) { res <<- "resolve"; val <<- x }) 73 | expect_equal(res, "resolve") 74 | expect_equal(val, 42 * 42) 75 | 76 | ## function with value arg 77 | r2 <- def__make_parent_reject(function(val) val) 78 | res <- NULL 79 | val <- NULL 80 | r2(42, function(x) { res <<- "resolve"; val <<- x }) 81 | expect_equal(res, "resolve") 82 | expect_equal(val, 42) 83 | }) 84 | -------------------------------------------------------------------------------- /tests/testthat/test-deferred-then.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("HTTP HEAD & synchronous then", { 3 | do <- function() { 4 | http_head(http$url("/"))$ 5 | then(function(value) value$status_code)$ 6 | then(function(x) expect_equal(x, 200)) 7 | } 8 | synchronise(do()) 9 | }) 10 | 11 | test_that("HTTP HEAD & async then", { 12 | do <- function() { 13 | http_head(http$url("/"))$ 14 | then(function(value) http_get(value$url))$ 15 | then(function(value) expect_equal(value$status_code, 200)) 16 | } 17 | synchronise(do()) 18 | }) 19 | 20 | test_that("HTTP HEAD & async then & sync then", { 21 | do <- function() { 22 | http_head(http$url("/"))$ 23 | then(function(value) http_get(value$url))$ 24 | then(function(value) value$status_code)$ 25 | then(function(value) expect_equal(value, 200)) 26 | } 27 | synchronise(do()) 28 | }) 29 | 30 | test_that("then for fulfilled", { 31 | do <- async(function() { 32 | dx <- http_head(http$url("/status/404")) 33 | dx2 <- http_head(http$url("/status/404")) 34 | dx$then(function() { 35 | dx2$ 36 | then(function(value) value$status_code)$ 37 | then(function(value) expect_equal(value, 404)) 38 | }) 39 | }) 40 | synchronise(do()) 41 | }) 42 | 43 | test_that("multiple then clauses are not allowed", { 44 | do <- async(function() { 45 | dx <- delay(1/1000) 46 | dx$then(function() 1) 47 | dx$then(function() 2) 48 | }) 49 | 50 | err <- tryCatch(synchronise(do()), error = identity) 51 | expect_s3_class(err, "async_rejected") 52 | expect_match(conditionMessage(err), "already owned") 53 | }) 54 | 55 | test_that("compact function notation", { 56 | do <- function() { 57 | http_head(http$url("/"))$ 58 | then(function(.) http_get(.$url))$ 59 | then(function(.) .$status_code)$ 60 | then(function(.) expect_equal(., 200)) 61 | } 62 | synchronise(do()) 63 | }) 64 | 65 | test_that("embedded then", { 66 | add1 <- function(n) { n ; delay(10/1000)$then(function(value) n + 1) } 67 | mul3 <- function(n) { n ; delay(10/1000)$then(function(value) n * 3) } 68 | 69 | do <- function() { 70 | add1(4)$ 71 | then(mul3)$ 72 | then(function(.) expect_equal(., 15)) 73 | } 74 | synchronise(do()) 75 | }) 76 | 77 | test_that("more embedded thens", { 78 | 79 | steps <- numeric() 80 | do <- function() { 81 | async(function() steps <<- c(steps, 1))()$ 82 | then(function() { 83 | async_constant()$ 84 | then(function() steps <<- c(steps, 2))$ 85 | then(function() steps <<- c(steps, 3)) 86 | })$ 87 | then(function() { 88 | async_constant()$ 89 | then(function() steps <<- c(steps, 4))$ 90 | then(function() steps <<- c(steps, 5)) 91 | })$ 92 | then(function() steps <<- c(steps, 6)) 93 | } 94 | synchronise(do()) 95 | expect_equal(steps, 1:6) 96 | }) 97 | -------------------------------------------------------------------------------- /tests/testthat/test-deferred-timeout.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("deferred timeout", { 3 | skip_on_cran() 4 | 5 | good <- FALSE 6 | tic <- Sys.time() 7 | do <- async(function() { 8 | delay(1/4)$then(function(value) good <<- TRUE) 9 | }) 10 | synchronise(do()) 11 | expect_true(Sys.time() - tic >= as.difftime(1/4, unit = "secs")) 12 | expect_true(good) 13 | }) 14 | -------------------------------------------------------------------------------- /tests/testthat/test-deferred.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("action in formula notation", { 3 | do <- function() { 4 | dx1 <- deferred$new(function(resolve) resolve(TRUE))$ 5 | then(function(.) expect_true(.)) 6 | 7 | dx2 <- deferred$new(function(resolve) stop("oops"))$ 8 | catch(error = function(.) expect_match(conditionMessage(.), "oops")) 9 | 10 | dx3 <- deferred$new(function(resolve) if (TRUE) resolve(TRUE) else stop("oops"))$ 11 | then(function(.) expect_true(.)) 12 | 13 | dx4 <- deferred$new(function(resolve) if (FALSE) resolve(TRUE) else stop("oops"))$ 14 | catch(error = function(.) expect_match(conditionMessage(.), "oops")) 15 | 16 | when_all(dx1, dx2, dx3, dx4) 17 | } 18 | synchronise(do()) 19 | }) 20 | 21 | test_that("on_fulfilled / on_rejected without arguments", { 22 | do <- async(function() { 23 | dx1 <- deferred$new(function(resolve) resolve(TRUE))$ 24 | then(function() "OK")$ 25 | then(function(.) expect_equal(., "OK")) 26 | 27 | dx2 <- deferred$new(function(resolve) resolve(TRUE))$ 28 | then(function() stop("oops"))$ 29 | catch(error = function(.) expect_match(conditionMessage(.), "oops")) 30 | 31 | dx3 <- deferred$new(function(resolve) resolve(TRUE))$ 32 | then(function() stop("ooops"))$ 33 | catch(error = function(.) "aaah")$ 34 | then(function(.) expect_equal(., "aaah")) 35 | 36 | when_all(dx1, dx2, dx3) 37 | }) 38 | synchronise(do()) 39 | }) 40 | 41 | test_that("parent pointer", { 42 | 43 | ## Parent pointer is added when the deferred is created, but it 44 | ## is removed, once the promise is resolved 45 | do <- function() { 46 | d1 <- delay(1/1000) 47 | d2 <- d1$then(force) 48 | d3 <- d2$then(function() expect_true(is.null(get_private(d2)$parent))) 49 | expect_equal(length(get_private(d2)$parent), 0) 50 | d3 51 | } 52 | synchronise(do()) 53 | }) 54 | 55 | test_that("unused computation is never created", { 56 | called1 <- called2 <- FALSE 57 | do <- function() { 58 | d1 <- deferred$new( 59 | function(resolve, reject) { called1 <<- TRUE; resolve("foo") }) 60 | d2 <- deferred$new( 61 | function(resolve, reject) { called2 <<- TRUE; resolve("bar") }) 62 | d2 63 | } 64 | expect_equal(synchronise(do()), "bar") 65 | expect_false(called1) 66 | expect_true(called2) 67 | }) 68 | 69 | test_that("replacing promises does not leak", { 70 | 71 | loop <- function(limit = 5) { 72 | limit 73 | n <- 1 74 | x <- list() 75 | 76 | do <- function() { 77 | x <<- append(x, list(async_list())) 78 | if (n < limit) { 79 | n <<- n + 1 80 | delay(0)$then(do) 81 | } else { 82 | async_constant(x) 83 | } 84 | } 85 | 86 | do() 87 | } 88 | 89 | x <- synchronise(when_any(loop())) 90 | expect_equal(length(x), 5L) 91 | expect_equal(nrow(x[[2]]), nrow(x[[5]])) 92 | }) 93 | -------------------------------------------------------------------------------- /tests/testthat/test-detect.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("async_detect", { 3 | 4 | is_odd <- function(x) { 5 | force(x) 6 | delay(1/1000)$ 7 | then(function(value) as.logical(x %% 2)) 8 | } 9 | 10 | test <- function(limit) { 11 | d1 <- async_detect(1:10, is_odd, .limit = limit)$ 12 | then(function(.) expect_true(. %in% c(1L, 3L, 5L, 7L, 9L))) 13 | 14 | d2 <- async_detect(2:10, is_odd, .limit = limit)$ 15 | then(function(.) expect_true(. %in% c(3L, 5L, 7L, 9L))) 16 | 17 | d3 <- async_detect(2, is_odd, .limit = limit)$ 18 | then(function(.) expect_null(.)) 19 | 20 | d4 <- async_detect(c(1:10 * 2L, 43L), is_odd, .limit = limit)$ 21 | then(function(.) expect_identical(., 43L)) 22 | 23 | d5 <- async_detect(numeric(), is_odd, .limit = limit)$ 24 | then(function(.) expect_null(.)) 25 | 26 | d6 <- async_detect(1:10 * 2, is_odd, .limit = limit)$ 27 | then(function(.) expect_null(.)) 28 | 29 | when_all(d1, d2, d3, d4, d5, d6) 30 | } 31 | 32 | lapply(c(Inf, 1, 2, 3, 5, 10, 20), function(x) synchronise(test(x))) 33 | }) 34 | 35 | test_that("async_detect errors", { 36 | called <- FALSE 37 | do <- function() { 38 | async_detect(1:10, function(x) stop("doh"))$ 39 | then(function() called <<- TRUE)$ 40 | catch(error = function(e) { 41 | expect_equal(conditionMessage(e), "doh") 42 | expect_s3_class(e, "async_rejected") 43 | }) 44 | } 45 | 46 | synchronise(do()) 47 | expect_false(called) 48 | }) 49 | -------------------------------------------------------------------------------- /tests/testthat/test-each-of.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("each_of", { 3 | 4 | done <- character() 5 | index <- integer() 6 | 7 | coll <- letters[1:10] 8 | 9 | do <- async(function() { 10 | dx <- when_all( 11 | .list = lapply(seq_along(coll), function(i) { 12 | force(i) 13 | delay(1/1000)$then(function(value) { 14 | done <<- c(done, coll[[i]]) 15 | index <<- c(index, i) 16 | }) 17 | }) 18 | )$then(function(value) { 19 | expect_identical(sort(index), seq_along(coll)) 20 | expect_identical(sort(done), sort(coll)) 21 | }) 22 | }) 23 | synchronise(do()) 24 | }) 25 | -------------------------------------------------------------------------------- /tests/testthat/test-each.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("each", { 3 | 4 | do <- async(function() { 5 | done <- character() 6 | dx <- when_all( 7 | .list = lapply(letters[1:10], function(x) { 8 | force(x) 9 | delay(1/1000)$then(function(value) done <<- c(done, x)) 10 | }) 11 | )$ 12 | then(function(value) expect_identical(sort(done), sort(letters[1:10]))) 13 | }) 14 | synchronise(do()) 15 | }) 16 | -------------------------------------------------------------------------------- /tests/testthat/test-errors.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("rejection", { 3 | 4 | do <- async(function() { 5 | dx <- delay(1/10000)$ 6 | then(function() stop("ohno!"))$ 7 | catch(error = function(.) expect_match(.$message, "ohno!")) 8 | }) 9 | synchronise(do()) 10 | }) 11 | 12 | test_that("error propagates", { 13 | 14 | do <- async(function() { 15 | called <- FALSE 16 | dx <- delay(1/10000)$ 17 | then(function(.) .)$ 18 | then(function() stop("ohno!"))$ 19 | then(function(x) called <<- TRUE) 20 | 21 | dx$ 22 | catch(error = function(.) expect_match(.$message, "ohno!"))$ 23 | then(function(x) expect_false(called)) 24 | }) 25 | synchronise(do()) 26 | }) 27 | 28 | test_that("handled error is not an error any more", { 29 | 30 | do <- async(function() { 31 | delay(1/10000)$ 32 | then(function(x) stop("ohno!"))$ 33 | catch(error = function(x) "OK")$ 34 | then(function(.) expect_equal(., "OK"))$ 35 | catch(error = function() stop("not called")) 36 | }) 37 | synchronise(do()) 38 | }) 39 | 40 | test_that("catch", { 41 | do <- async(function() { 42 | dx <- delay(1/1000)$ 43 | then(function(.) .)$ 44 | then(function() stop("ooops"))$ 45 | then(function() "not this one")$ 46 | catch(error = function(.) "nothing to see here") 47 | }) 48 | expect_equal( 49 | synchronise(do()), 50 | "nothing to see here" 51 | ) 52 | }) 53 | 54 | test_that("finally", { 55 | called <- FALSE 56 | do <- async(function() { 57 | delay(1/1000)$ 58 | then(function(.) .)$ 59 | then(function() stop("oops"))$ 60 | then(function() "not this one")$ 61 | finally(function() called <<- TRUE) 62 | }) 63 | expect_error(synchronise(do()), "oops") 64 | expect_true(called) 65 | 66 | called <- FALSE 67 | do <- async(function() { 68 | delay(1/1000)$ 69 | then(function(.) .)$ 70 | then(function() "this one")$ 71 | finally(function() called <<- TRUE) 72 | }) 73 | expect_equal(synchronise(do()), "this one") 74 | expect_true(called) 75 | }) 76 | 77 | test_that("error in action", { 78 | do <- function() { 79 | deferred$new(function(resolve, reject) stop("foobar")) 80 | } 81 | 82 | err <- tryCatch(synchronise(do()), error = identity) 83 | expect_s3_class(err, "async_rejected") 84 | expect_match(conditionMessage(err), "foobar") 85 | }) 86 | 87 | test_that("error in then function", { 88 | do <- function() { 89 | delay(1/100)$then(function(x) stop("foobar")) 90 | } 91 | 92 | err <- tryCatch(synchronise(do()), error = identity) 93 | expect_s3_class(err, "async_rejected") 94 | expect_match(conditionMessage(err), "foobar") 95 | }) 96 | 97 | test_that("can catch error in action", { 98 | do <- function() { 99 | deferred$new(function(resolve, reject) stop("foobar"))$ 100 | catch(error = function(e) e) 101 | } 102 | 103 | err <- synchronise(do()) 104 | expect_s3_class(err, "async_rejected") 105 | expect_match(conditionMessage(err), "foobar") 106 | }) 107 | 108 | test_that("can catch error in then function", { 109 | do <- function() { 110 | delay(1/100)$ 111 | then(function(x) stop("foobar"))$ 112 | catch(error = function(e) e) 113 | } 114 | 115 | err <- synchronise(do()) 116 | expect_s3_class(err, "async_rejected") 117 | expect_match(conditionMessage(err), "foobar") 118 | }) 119 | 120 | test_that("catch handers", { 121 | 122 | spec <- foobar1 <- foobar2 <- NULL 123 | do <- async(function() { 124 | async_constant(42)$ 125 | then(function() { 126 | err <- structure( 127 | list(message = "foobar"), 128 | class = c("foobar", "error", "condition")) 129 | stop(err) 130 | })$ 131 | catch(special = function(e) spec <<- e)$ 132 | catch(foobar = function(e) foobar1 <<- e)$ 133 | then(function(e) foobar2 <<- e)$ 134 | then(function() "ok") 135 | }) 136 | 137 | expect_equal(synchronise(do()), "ok") 138 | expect_null(spec) 139 | expect_s3_class(foobar1, "foobar") 140 | expect_s3_class(foobar1, "error") 141 | expect_s3_class(foobar2, "foobar") 142 | expect_s3_class(foobar2, "error") 143 | }) 144 | -------------------------------------------------------------------------------- /tests/testthat/test-event-loop.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("create", { 3 | el <- event_loop$new() 4 | expect_s3_class(el, "event_loop") 5 | }) 6 | 7 | test_that("next tick", { 8 | el <- event_loop$new() 9 | 10 | ticked <- FALSE 11 | error <- "foo" 12 | result <- "bar" 13 | el$add_next_tick( 14 | function() ticked <<- TRUE, 15 | function(err, res) { error <<- err; result <<- res } 16 | ) 17 | el$run() 18 | 19 | expect_true(ticked) 20 | expect_null(error) 21 | expect_true(result) 22 | }) 23 | 24 | test_that("event loop with only timers sleeps", { 25 | tim <- system.time(synchronise(delay(1/2))) 26 | expect_true(tim[[1]] + tim[[2]] < 0.4) 27 | expect_true(tim[[3]] >= 0.4) 28 | }) 29 | 30 | test_that("repeated delay", { 31 | counter <- 0 32 | error <- "foo" 33 | result <- numeric() 34 | 35 | el <- event_loop$new() 36 | id <- el$add_delayed( 37 | 0.1, 38 | function() { 39 | counter <<- counter + 1 40 | if (counter == 10) el$cancel(id) 41 | counter 42 | }, 43 | function(err, res) { error <<- err; result <<- c(result, res) }, 44 | rep = TRUE 45 | ) 46 | 47 | start <- Sys.time() 48 | el$run() 49 | end <- Sys.time() 50 | 51 | expect_equal(counter, 10) 52 | expect_null(error) 53 | expect_equal(result, 1:10) 54 | expect_true(end - start >= as.difftime(1, units = "secs")) 55 | expect_true(end - start <= as.difftime(2, units = "secs")) 56 | }) 57 | 58 | test_that("nested event loops", { 59 | ## Create a function that finishes while its event loop is inactive 60 | afun1 <- function(x) { x; async_constant(x) } 61 | afun2 <- function(x1, x2) { 62 | x1; x2 63 | p1 <- afun1(x1) 64 | p2 <- delay(0)$then(function() synchronise(afun1(x2))) 65 | when_all(p1, p2) 66 | } 67 | 68 | res <- synchronise(afun2(1, 2)) 69 | expect_equal(res, list(1, 2)) 70 | }) 71 | -------------------------------------------------------------------------------- /tests/testthat/test-every.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("async_every", { 3 | 4 | is_odd <- function(x) { 5 | force(x) 6 | delay(1/1000)$then(function(value) as.logical(x %% 2)) 7 | } 8 | 9 | do <- function() { 10 | d1 <- async_every(1:10, is_odd)$ 11 | then(function(.) expect_identical(., FALSE)) 12 | 13 | d2 <- async_every(numeric(), is_odd)$ 14 | then(function(.) expect_identical(., TRUE)) 15 | 16 | d3 <- async_every(1:10 * 2 + 1, is_odd)$ 17 | then(function(.) expect_identical(., TRUE)) 18 | 19 | when_all(d1, d2, d3) 20 | } 21 | synchronise(do()) 22 | }) 23 | 24 | test_that("async_every, errors", { 25 | 26 | called <- FALSE 27 | do <- function() { 28 | async_every(1:10, function(x) stop("doh"))$ 29 | then(function() called <<- TRUE)$ 30 | catch(error = function(e) { 31 | expect_equal(conditionMessage(e), "doh") 32 | expect_s3_class(e, "async_rejected") 33 | }) 34 | } 35 | 36 | synchronise(do()) 37 | expect_false(called) 38 | }) 39 | -------------------------------------------------------------------------------- /tests/testthat/test-external-process.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("external_process", { 3 | px <- asNamespace("processx")$get_tool("px") 4 | pxgen <- function(...) { 5 | processx::process$new( 6 | px, 7 | c("outln", "foo", "errln", "bar"), 8 | stdout = tempfile(), 9 | stderr = tempfile(), 10 | ... 11 | ) 12 | } 13 | 14 | afun <- function() { 15 | when_all(external_process(pxgen), async_constant(13)) 16 | } 17 | 18 | res <- synchronise(afun()) 19 | expect_equal(res[[1]]$status, 0L) 20 | expect_match(res[[1]]$stdout, "foo\r?\n") 21 | expect_match(res[[1]]$stderr, "bar\r?\n") 22 | expect_false(res[[1]]$timeout) 23 | expect_equal(res[[2]], 13) 24 | }) 25 | 26 | test_that("cancel external_process", { 27 | px <- asNamespace("processx")$get_tool("px") 28 | proc <- NULL 29 | pxgen <- function(...) { 30 | proc <<- processx::process$new( 31 | px, 32 | c("sleep", "5"), 33 | stdout = tempfile(), 34 | stderr = tempfile(), 35 | ... 36 | ) 37 | } 38 | 39 | running <- NULL 40 | afun <- function() { 41 | when_all( 42 | external_process(pxgen), 43 | delay(0.001)$ 44 | then(function() { 45 | limit <- Sys.time() + as.difftime(2, units = "secs") 46 | while (Sys.time() < limit && !proc$is_alive()) Sys.sleep(0.1) 47 | running <<- proc$is_alive() 48 | })$ 49 | then(function() stop("failed")) 50 | ) 51 | } 52 | 53 | expect_error(synchronise(afun())) 54 | expect_true(running) 55 | 56 | limit <- Sys.time() + as.difftime(2, units = "secs") 57 | while (Sys.time() < limit && proc$is_alive()) Sys.sleep(0.1) 58 | expect_false(proc$is_alive()) 59 | }) 60 | 61 | test_that("discarding stdout/stderr works", { 62 | px <- asNamespace("processx")$get_tool("px") 63 | pxgen <- function(...) { 64 | processx::process$new( 65 | px, 66 | c("outln", "foo", "errln", "bar"), 67 | stdout = NULL, 68 | stderr = NULL, 69 | ... 70 | ) 71 | } 72 | 73 | afun <- function() external_process(pxgen) 74 | 75 | res <- synchronise(afun()) 76 | expect_equal(res$status, 0L) 77 | expect_null(res$stdout) 78 | expect_null(res$stderr) 79 | expect_false(res$timeout) 80 | }) 81 | 82 | test_that("can disable error on status", { 83 | px <- asNamespace("processx")$get_tool("px") 84 | pxgen <- function(...) { 85 | processx::process$new( 86 | px, 87 | c("return", "1"), 88 | ... 89 | ) 90 | } 91 | afun <- function(...) external_process(pxgen, ...) 92 | 93 | expect_error( 94 | synchronise(afun()), 95 | "exited with non-zero status" 96 | ) 97 | 98 | res <- synchronise(afun(error_on_status = FALSE)) 99 | expect_equal(res, list( 100 | status = 1L, 101 | stdout = NULL, 102 | stderr = NULL, 103 | timeout = FALSE 104 | )) 105 | }) 106 | -------------------------------------------------------------------------------- /tests/testthat/test-filter.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("async_filter", { 3 | 4 | is_odd <- function(x) { 5 | force(x) 6 | delay(1/1000)$then(function(value) as.logical(x %% 2)) 7 | } 8 | 9 | do <- function() { 10 | d1 <- async_filter(1:10, is_odd)$ 11 | then(function(.) expect_identical(., c(1L, 3L, 5L, 7L, 9L))) 12 | 13 | d2 <- async_filter(numeric(), is_odd)$ 14 | then(function(.) expect_identical(., numeric())) 15 | 16 | d3 <- async_filter(1:10 * 2, is_odd)$ 17 | then(function(.) expect_identical(., numeric())) 18 | 19 | when_all(d1, d2, d3) 20 | } 21 | synchronise(do()) 22 | }) 23 | 24 | test_that("async_filter, errors", { 25 | 26 | called <- FALSE 27 | do <- function() { 28 | async_filter(1:10, function(x) stop("doh"))$ 29 | then(function() called <<- TRUE)$ 30 | catch(error = function(e) { 31 | expect_equal(conditionMessage(e), "doh") 32 | expect_s3_class(e, "async_rejected") 33 | }) 34 | } 35 | 36 | synchronise(do()) 37 | expect_false(called) 38 | }) 39 | 40 | test_that("async_reject", { 41 | 42 | is_even <- function(x) { 43 | force(x) 44 | delay(1/1000)$then(function(value) as.logical(! (x %% 2))) 45 | } 46 | 47 | do <- function() { 48 | d1 <- async_reject(1:10, is_even)$ 49 | then(function(.) expect_identical(., c(1L, 3L, 5L, 7L, 9L))) 50 | 51 | d2 <- async_reject(numeric(), is_even)$ 52 | then(function(.) expect_identical(., numeric())) 53 | 54 | d3 <- async_reject(1:10 * 2, is_even)$ 55 | then(function(.) expect_identical(., numeric())) 56 | 57 | when_all(d1, d2, d3) 58 | } 59 | synchronise(do()) 60 | }) 61 | 62 | test_that("async_reject, errors", { 63 | 64 | called <- FALSE 65 | do <- function() { 66 | async_reject(1:10, function(x) stop("doh"))$ 67 | then(function() called <<- TRUE)$ 68 | catch(error = function(e) { 69 | expect_equal(conditionMessage(e), "doh") 70 | expect_s3_class(e, "async_rejected") 71 | }) 72 | } 73 | 74 | synchronise(do()) 75 | expect_false(called) 76 | }) 77 | -------------------------------------------------------------------------------- /tests/testthat/test-http-events.R: -------------------------------------------------------------------------------- 1 | test_that("end event", { 2 | done <- NULL 3 | do <- function() { 4 | p1 <- http_get(http$url("/get")) 5 | p2 <- p1$then(function() done <<- c(done, "done")) 6 | p1$event_emitter$listen_on("end", function(...) { 7 | done <<- c(done, "end") 8 | }) 9 | p2 10 | } 11 | 12 | synchronise(do()) 13 | expect_equal(done, c("end", "done")) 14 | }) 15 | 16 | test_that("data event", { 17 | skip_on_cran() 18 | chunks <- NULL 19 | called <- 0L 20 | do <- function() { 21 | p1 <- http_get(http$url("/drip?duration=1&numbytes=10")) 22 | p1$event_emitter$listen_on("data", function(bytes) { 23 | chunks <<- c(chunks, list(bytes)) 24 | }) 25 | p1$event_emitter$listen_on("data", function(bytes) { 26 | called <<- called + 1L 27 | }) 28 | p1 29 | } 30 | 31 | # there is an extra zero-length chunk currently, but let's not 32 | # rely on that 33 | synchronise(do()) 34 | expect_true(length(chunks) >= 10) 35 | expect_equal(length(unlist(chunks)), 10) 36 | expect_true(called >= 10) 37 | }) 38 | 39 | test_that("multiple end events", { 40 | done <- NULL 41 | do <- function() { 42 | p1 <- http_get(http$url("/get")) 43 | p2 <- p1$then(function() done <<- c(done, "done")) 44 | p1$event_emitter$listen_on("end", function(...) { 45 | done <<- c(done, "end1") 46 | }) 47 | p1$event_emitter$listen_on("end", function(...) { 48 | done <<- c(done, "end2") 49 | }) 50 | p2 51 | } 52 | 53 | synchronise(do()) 54 | expect_equal(done, c("end1", "end2", "done")) 55 | }) 56 | -------------------------------------------------------------------------------- /tests/testthat/test-http-file.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("GET file://", { 3 | tmp <- tempfile() 4 | on.exit(unlink(tmp), add = TRUE) 5 | cat("foobar", file = tmp) 6 | 7 | url <- paste0("file://", normalizePath(tmp)) 8 | ret <- synchronise(http_get(url)$then(http_stop_for_status)) 9 | expect_equal(ret$status_code, 0) 10 | expect_equal(ret$content, charToRaw("foobar")) 11 | }) 12 | 13 | test_that("HEAD file://", { 14 | tmp <- tempfile() 15 | on.exit(unlink(tmp), add = TRUE) 16 | cat("foobar\n", file = tmp) 17 | 18 | url <- paste0("file://", normalizePath(tmp)) 19 | ret <- synchronise(http_head(url)$then(http_stop_for_status)) 20 | expect_equal(ret$status_code, 0) 21 | }) 22 | 23 | test_that("file:// to file", { 24 | tmp <- tempfile() 25 | tmp2 <- tempfile() 26 | on.exit(unlink(c(tmp, tmp2)), add = TRUE) 27 | cat("foobar", file = tmp) 28 | 29 | url <- paste0("file://", normalizePath(tmp)) 30 | ret <- synchronise(http_get(url, file = tmp2)$then(http_stop_for_status)) 31 | expect_equal(ret$status_code, 0) 32 | expect_equal(readBin(tmp2, "raw", 100), charToRaw("foobar")) 33 | }) 34 | 35 | test_that("file:// does not exist", { 36 | tmp <- tempfile() 37 | url <- paste0("file://", tmp) 38 | expect_error(synchronise(http_get(url))) 39 | }) 40 | -------------------------------------------------------------------------------- /tests/testthat/test-http-sse.R: -------------------------------------------------------------------------------- 1 | test_that("parse_sse_event", { 2 | testthat::local_edition(3) 3 | 4 | txt <- "foo: bar" 5 | expect_snapshot(parse_sse_event(charToRaw(txt))) 6 | 7 | txt <- "foo:bar" 8 | expect_snapshot(parse_sse_event(charToRaw(txt))) 9 | 10 | txt <- "foo: bar\nbaz:foobar\nand:last" 11 | expect_snapshot(parse_sse_event(charToRaw(txt))) 12 | }) 13 | 14 | test_that("chunk_sse_events", { 15 | testthat::local_edition(3) 16 | 17 | # no events yet 18 | txt <- "foo: bar\nbaz: foo\n" 19 | expect_snapshot(chunk_sse_events(charToRaw(txt))) 20 | 21 | txt <- "foo: bar\nbaz: foobar\n\nanother: event\n\nand:another\n\n" 22 | expect_snapshot(chunk_sse_events(charToRaw(txt))) 23 | 24 | # slightly bad separators 25 | txt <- paste0( 26 | "\n\n\n", 27 | "foo: bar\nbaz: foobar", 28 | "\n\n\n\n\n", 29 | "another: event", 30 | "\n\n", 31 | "and:another", 32 | "\n\n" 33 | ) 34 | expect_snapshot(chunk_sse_events(charToRaw(txt))) 35 | 36 | # incomplete last event 37 | txt <- "foo: bar\nbaz: foobar\n\nanother: event\n\nand:another\n" 38 | expect_snapshot(chunk_sse_events(charToRaw(txt))) 39 | 40 | }) 41 | 42 | test_that("sse", { 43 | testthat::local_edition(3) 44 | server <- webfakes::new_app_process(sseapp()) 45 | url <- server$url("/sse") 46 | 47 | events <- NULL 48 | do <- function() { 49 | p1 <- http_get(url) 50 | evs <- sse_events$new(p1) 51 | evs$listen_on("event", function(ev) { 52 | events <<- c(events, list(ev)) 53 | }) 54 | p1 55 | } 56 | 57 | synchronise(do()) 58 | expect_snapshot(events) 59 | }) 60 | -------------------------------------------------------------------------------- /tests/testthat/test-parallel.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("parallel", { 3 | 4 | do <- async(function() { 5 | dx1 <- http_get(http$url("/get", query = list(q = "foo")))$ 6 | then( function(.) rawToChar(.$content)) 7 | dx2 <- http_get(http$url("/get", query = list(q = "bar")))$ 8 | then( function(.) rawToChar(.$content)) 9 | 10 | when_all( 11 | dx1$then(function(.) expect_match(., "\"q\":[ ]*\"foo\"")), 12 | dx2$then(function(.) expect_match(., "\"q\":[ ]*\"bar\"")) 13 | ) 14 | }) 15 | synchronise(do()) 16 | }) 17 | -------------------------------------------------------------------------------- /tests/testthat/test-process.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("process", { 3 | 4 | px <- asNamespace("processx")$get_tool("px") 5 | 6 | afun <- async(function() { 7 | when_all( 8 | delay = delay(1/1000)$ 9 | then(function(x) 1), 10 | process = run_process(px, c("outln", "foobar"))$ 11 | then(function(x) str_trim(x$stdout)), 12 | r_process = run_r_process(function() 2)$ 13 | then(function(x) x$result) 14 | ) 15 | }) 16 | 17 | res <- synchronise(afun()) 18 | 19 | expect_equal( 20 | res, 21 | list(delay = 1, 22 | process = "foobar", 23 | r_process = 2) 24 | ) 25 | }) 26 | 27 | test_that("process + http", { 28 | px <- asNamespace("processx")$get_tool("px") 29 | 30 | afun <- async(function() { 31 | when_all( 32 | delay = delay(1/1000)$ 33 | then(function() 1), 34 | http = http_get(http$url("/status/418"))$ 35 | then(function(x) x$status_code), 36 | process = run_process(px, c("outln", "foobar"))$ 37 | then(function(x) str_trim(x$stdout)), 38 | r_process = run_r_process(function() 2)$ 39 | then(function(x) x$result) 40 | ) 41 | }) 42 | 43 | res <- synchronise(afun()) 44 | 45 | expect_equal( 46 | res, 47 | list(delay = 1, 48 | http = 418, 49 | process = "foobar", 50 | r_process = 2) 51 | ) 52 | }) 53 | -------------------------------------------------------------------------------- /tests/testthat/test-progress.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("tick", { 3 | 4 | do <- async(function() { 5 | deferred$new( 6 | function(resolve, progress) { 7 | for (i in 1:10) progress(list(tick = 1)) 8 | progress(list(tick = 1)) 9 | resolve("done") 10 | } 11 | ) 12 | }) 13 | expect_equal(synchronise(do()), "done") 14 | 15 | ticked <- 0 16 | do <- async(function() { 17 | deferred$new( 18 | function(resolve, progress) { 19 | for (i in 1:10) progress(list(tick = 1)) 20 | resolve("done") 21 | }, 22 | function(data) ticked <<- ticked + data$tick 23 | ) 24 | }) 25 | expect_equal(synchronise(do()), "done") 26 | expect_equal(ticked, 10) 27 | }) 28 | 29 | test_that("total", { 30 | ticked <- 0 31 | totalx <- NULL 32 | do <- async(function() { 33 | deferred$new( 34 | function(resolve, progress) { 35 | progress(list(total = 10)) 36 | for (i in 1:10) progress(list(tick = 1)) 37 | resolve("done") 38 | }, 39 | function(data) { 40 | if (!is.null(data$total)) totalx <<- data$total 41 | if (!is.null(data$tick)) ticked <<- ticked + data$tick 42 | } 43 | ) 44 | }) 45 | expect_equal(synchronise(do()), "done") 46 | expect_equal(ticked, 10) 47 | expect_equal(totalx, 10) 48 | }) 49 | 50 | test_that("ratio", { 51 | ratiox <- 0 52 | do <- async(function() { 53 | deferred$new( 54 | function(resolve, progress) { 55 | for (i in 1:10) progress(list(ratio = i / 10)) 56 | resolve("done") 57 | }, 58 | function(data) ratiox <<- c(ratiox, data$ratio) 59 | ) 60 | }) 61 | expect_equal(synchronise(do()), "done") 62 | expect_equal(ratiox, (0:10) / 10) 63 | }) 64 | 65 | test_that("amount", { 66 | amountx <- 0 67 | totalx <- 0 68 | do <- async(function() { 69 | deferred$new( 70 | function(resolve, progress) { 71 | progress(list(total = 100)) 72 | for (i in 1:10) progress(list(amount = 10)) 73 | resolve("done") 74 | }, 75 | function(data) { 76 | if (!is.null(data$total)) totalx <<- data$total 77 | if (!is.null(data$amount)) amountx <<- amountx + data$amount 78 | } 79 | ) 80 | }) 81 | expect_equal(synchronise(do()), "done") 82 | expect_equal(totalx, 100) 83 | expect_equal(amountx, 100) 84 | }) 85 | -------------------------------------------------------------------------------- /tests/testthat/test-race.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("race() rejects (#76)", { 3 | defer_fail <- function() { 4 | deferred$new(action = function(resolve) stop("foo")) 5 | } 6 | 7 | expect_error( 8 | synchronise(async_race( 9 | delay(0.1), 10 | defer_fail() 11 | )), 12 | "foo" 13 | ) 14 | }) 15 | -------------------------------------------------------------------------------- /tests/testthat/test-reflect.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("async_reflect", { 3 | 4 | badfun <- async(function() stop("oh no!")) 5 | safefun <- async_reflect(badfun) 6 | 7 | do <- async(function() { 8 | when_all(safefun(), safefun(), safefun())$ 9 | then(function(result) { 10 | for (i in 1:3) { 11 | expect_s3_class(result[[i]]$error, "error") 12 | expect_null(result[[i]]$value) 13 | } 14 | }) 15 | }) 16 | synchronise(do()) 17 | }) 18 | -------------------------------------------------------------------------------- /tests/testthat/test-replicate.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("0 times", { 3 | do <- function() async_replicate(0, function() stop("doh")) 4 | expect_equal(synchronise(do()), list()) 5 | }) 6 | 7 | test_that("async_replicate", { 8 | do <- function(limit) { 9 | async_replicate(10, function() runif(1), .limit = limit) 10 | } 11 | 12 | for (lim in c(1, 2, 5, 10, 20, Inf)) { 13 | res <- synchronise(do(limit = lim)) 14 | expect_equal(length(res), 10) 15 | } 16 | }) 17 | -------------------------------------------------------------------------------- /tests/testthat/test-retry.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("unsuccessful async_retry", { 3 | 4 | do <- async(function() { 5 | x <- 5 6 | async_retry( 7 | function() { x <<- x - 1; if (x) stop("error") else "OK" }, 8 | times = 3 9 | )$ 10 | catch(error = function(e) expect_match(e$message, "error")) 11 | }) 12 | synchronise(do()) 13 | }) 14 | 15 | test_that("successful async_retry", { 16 | 17 | do <- async(function() { 18 | x <- 5 19 | async_retry( 20 | function() { x <<- x - 1; if (x) stop("error") else "OK" }, 21 | times = 5 22 | ) 23 | }) 24 | expect_equal(synchronise(do()), "OK") 25 | }) 26 | -------------------------------------------------------------------------------- /tests/testthat/test-retryable.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("async_retryable", { 3 | 4 | do <- async(function() { 5 | i <- 1 6 | f <- function() { 7 | i <<- i + 1 8 | if (i < 5) stop("error") else "OK" 9 | } 10 | 11 | async_retryable(f, 5)() 12 | }) 13 | expect_identical(synchronise(do()), "OK") 14 | }) 15 | -------------------------------------------------------------------------------- /tests/testthat/test-sequence.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("async_sequence", { 3 | 4 | add1 <- function(n) { n ; delay(10/1000)$then(function(value) n + 1) } 5 | mul3 <- function(n) { n ; delay(10/1000)$then(function(value) n * 3) } 6 | 7 | add1mul3 <- async_sequence(add1, mul3) 8 | result <- synchronise(add1mul3(4)) 9 | 10 | expect_equal(result, 15) 11 | }) 12 | -------------------------------------------------------------------------------- /tests/testthat/test-shared.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("can have multiple children", { 3 | do <- async(function() { 4 | d1 <- delay(1/1000)$share() 5 | d2 <- d1$then(function(.) "foo") 6 | d3 <- d1$then(function(.) "bar") 7 | when_all(d2, d3) 8 | }) 9 | expect_equal(synchronise(do()), list("foo", "bar")) 10 | }) 11 | 12 | test_that("not cancelled at auto-cancellation", { 13 | d1 <- d2 <- d3 <- NULL 14 | do <- async(function() { 15 | d1 <<- delay(1/1000)$share() 16 | d2 <<- d1$then(function(.) delay(3)) 17 | d3 <<- d2$then(function(.) "foo") 18 | d4 <- d3$then(function(.) "bar") 19 | d5 <- d4$catch(error = function(.) "ok") 20 | d6 <- d1$then(function(.) "bar")$then(function() { d4$cancel(); "ok2" }) 21 | when_all(d5, d6) 22 | }) 23 | expect_equal(synchronise(do()), list("ok", "ok2")) 24 | expect_false(get_private(d1)$cancelled) 25 | expect_true(get_private(d3)$cancelled) 26 | }) 27 | 28 | test_that("shared on an already fulfilled one", { 29 | 30 | do <- function() { 31 | d1 <- async_constant(42)$share() 32 | d1$then(function(x) d1$then(function(.) x + 1)) 33 | } 34 | expect_equal(synchronise(do()), 43) 35 | }) 36 | -------------------------------------------------------------------------------- /tests/testthat/test-some.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("async_some", { 3 | 4 | is_odd <- function(x) { 5 | force(x) 6 | delay(1/1000)$then(function(value) as.logical(x %% 2)) 7 | } 8 | 9 | result <- synchronise(async_some(1:10, is_odd)) 10 | expect_identical(result, TRUE) 11 | 12 | result <- synchronise(async_some(numeric(), is_odd)) 13 | expect_identical(result, FALSE) 14 | 15 | result <- synchronise(async_some(1:10 * 2, is_odd)) 16 | expect_identical(result, FALSE) 17 | 18 | }) 19 | 20 | test_that("async_some, errors", { 21 | 22 | called <- FALSE 23 | do <- function() { 24 | async_some(1:10, function(x) stop("doh"))$ 25 | then(function() called <<- TRUE)$ 26 | catch(error = function(e) { 27 | expect_equal(conditionMessage(e), "doh") 28 | expect_s3_class(e, "async_rejected") 29 | }) 30 | } 31 | 32 | synchronise(do()) 33 | expect_false(called) 34 | }) 35 | -------------------------------------------------------------------------------- /tests/testthat/test-timeout.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("timed out", { 3 | skip_on_cran() 4 | f <- function() delay(1/10)$then(function(value) "OK") 5 | expect_error(synchronise(async_timeout(f, 1/1000)), "Aync operation timed out") 6 | }) 7 | 8 | test_that("did not time out", { 9 | skip_on_cran() 10 | f <- function() delay(1/100)$then(function(value) "OK") 11 | expect_equal(synchronise(async_timeout(f, 1/10)), "OK") 12 | }) 13 | 14 | test_that("error before async_timeout", { 15 | skip_on_cran() 16 | f <- function() delay(1/1000)$then(function(value) stop("oops")) 17 | expect_error(synchronise(async_timeout(f, 1/10)), "oops") 18 | }) 19 | 20 | test_that("error after async_timeout", { 21 | skip_on_cran() 22 | f <- function() delay(1/10)$then(function(value) stop("oops")) 23 | expect_error(synchronise(async_timeout(f, 1/1000)), "Aync operation timed out") 24 | }) 25 | -------------------------------------------------------------------------------- /tests/testthat/test-timer.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("keeps event loop alive", { 3 | 4 | counter <- 0L 5 | do <- function() { 6 | cb <- function() { 7 | counter <<- counter + 1L 8 | if (counter == 3L) t$cancel() 9 | } 10 | t <- async_timer$new(1/100, cb) 11 | "done" 12 | } 13 | 14 | start <- Sys.time() 15 | res <- run_event_loop(do()) 16 | end <- Sys.time() 17 | 18 | expect_null(res) 19 | expect_true(end - start >= as.difftime(3/100, units = "secs")) 20 | expect_true(end - start <= as.difftime(2, units = "secs")) 21 | }) 22 | 23 | test_that("errors", { 24 | 25 | counter <- 0L 26 | do <- function() { 27 | cb <- function() { 28 | counter <<- counter + 1L 29 | if (counter == 2L) stop("foobar") 30 | if (counter == 3L) t$cancel() 31 | } 32 | t <- async_timer$new(1/100, cb) 33 | } 34 | 35 | expect_error(run_event_loop(do()), "foobar") 36 | expect_equal(counter, 2L) 37 | 38 | counter <- 0L 39 | error <- NULL 40 | do <- function() { 41 | cb <- function() { 42 | counter <<- counter + 1L 43 | if (counter == 2L) stop("foobar") 44 | if (counter == 3L) t$cancel() 45 | } 46 | t <- async_timer$new(1/100, cb) 47 | t$listen_on("error", function(err) error <<- err) 48 | } 49 | 50 | expect_silent(run_event_loop(do())) 51 | expect_equal(counter, 3L) 52 | expect_s3_class(error, "error") 53 | expect_equal(conditionMessage(error), "foobar") 54 | }) 55 | 56 | test_that("mixing deferred and timers", { 57 | 58 | counter <- 0L 59 | do <- function(s) { 60 | counter <<- 0L 61 | cb <- function() { 62 | counter <<- counter + 1L 63 | if (counter == 3L) t$cancel() 64 | } 65 | t <- async_timer$new(.6, cb) 66 | delay(s)$then(function() "OK") 67 | } 68 | 69 | ## Once we have the output, we quit 70 | start <- Sys.time() 71 | res <- synchronise(do(1)) 72 | end <- Sys.time() 73 | 74 | expect_equal(res, "OK") 75 | expect_true(end - start >= as.difftime(1, units = "secs")) 76 | expect_true(end - start <= as.difftime(2, units = "secs")) 77 | expect_equal(counter, 1L) 78 | 79 | ## Run the timer to the end 80 | start <- Sys.time() 81 | res <- synchronise(do(3)) 82 | end <- Sys.time() 83 | 84 | expect_equal(res, "OK") 85 | expect_true(end - start >= as.difftime(1/5, units = "secs")) 86 | expect_true(end - start <= as.difftime(5, units = "secs")) 87 | expect_equal(counter, 3L) 88 | }) 89 | -------------------------------------------------------------------------------- /tests/testthat/test-try-each.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("only one, success", { 3 | do <- function() { 4 | async_try_each( 5 | async(function() "cool")() 6 | ) 7 | } 8 | expect_equal(synchronise(do()), "cool") 9 | }) 10 | 11 | test_that("only one, fail", { 12 | err <- NULL 13 | do <- function() { 14 | async_try_each( 15 | async(function() stop("doh"))() 16 | )$catch(error = function(e) err <<- e) 17 | } 18 | synchronise(do()) 19 | expect_s3_class(err, "async_rejected") 20 | expect_equal(conditionMessage(err), "async_try_each failed") 21 | expect_equal(conditionMessage(err$errors[[1]]), "doh") 22 | }) 23 | 24 | test_that("first success", { 25 | do <- function() { 26 | async_try_each( 27 | async(function() "cool")(), 28 | async(function() "cool2")(), 29 | async(function() stop("doh"))() 30 | ) 31 | } 32 | expect_equal(synchronise(do()), "cool") 33 | }) 34 | 35 | test_that("second success", { 36 | do <- function() { 37 | async_try_each( 38 | async(function() stop("doh"))(), 39 | async(function() "cool")(), 40 | async(function() stop("doh2"))(), 41 | async(function() "cool2")() 42 | ) 43 | } 44 | expect_equal(synchronise(do()), "cool") 45 | }) 46 | 47 | test_that("empty", { 48 | do <- function() { 49 | async_try_each() 50 | } 51 | expect_null(synchronise(do())) 52 | }) 53 | 54 | test_that("all fail", { 55 | err <- NULL 56 | do <- function() { 57 | async_try_each( 58 | async(function() stop("doh"))(), 59 | async(function() stop("doh2"))(), 60 | async(function() stop("doh3"))() 61 | )$catch(error = function(e) err <<- e) 62 | } 63 | synchronise(do()) 64 | expect_s3_class(err, "async_rejected") 65 | expect_equal(conditionMessage(err), "async_try_each failed") 66 | expect_equal(conditionMessage(err$errors[[1]]), "doh") 67 | expect_equal(conditionMessage(err$errors[[2]]), "doh2") 68 | expect_equal(conditionMessage(err$errors[[3]]), "doh3") 69 | }) 70 | -------------------------------------------------------------------------------- /tests/testthat/test-until.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("async_until", { 3 | 4 | count <- 1 5 | 6 | result <- synchronise(async_until( 7 | function() count == 5, 8 | function() { 9 | delay(1/1000)$then(function(value) count <<- count + 1) 10 | } 11 | )) 12 | 13 | expect_equal(count, 5) 14 | expect_equal(result, 5) 15 | }) 16 | 17 | test_that("async_until is always called once", { 18 | 19 | called <- FALSE 20 | 21 | result <- synchronise(async_until( 22 | function() TRUE, 23 | function() { 24 | delay(1/1000)$then(function(value) called <<- TRUE) 25 | } 26 | )) 27 | 28 | expect_true(called) 29 | expect_true(result) 30 | }) 31 | 32 | test_that("error", { 33 | 34 | do <- function() { 35 | async_until( 36 | function() i > 5, 37 | function() delay(1/1000)$then(function(value) { 38 | i <<- i + 1 39 | if (i >= 3) stop("doh") 40 | }) 41 | ) 42 | } 43 | 44 | i <- 1 45 | expect_error(synchronise(do()), "doh") 46 | 47 | i <- 1 48 | do2 <- function() { 49 | do()$ 50 | catch(error = function(e) expect_equal(conditionMessage(e), "doh")) 51 | } 52 | synchronise(do2()) 53 | }) 54 | 55 | test_that("test function throws", { 56 | 57 | called <- FALSE 58 | 59 | do <- function() { 60 | async_until( 61 | function() stop("doh"), 62 | function() { 63 | delay(1/1000)$then(function(value) called <<- TRUE) 64 | } 65 | ) 66 | } 67 | 68 | expect_error(synchronise(do()), "doh") 69 | expect_true(called) 70 | 71 | called <- FALSE 72 | do2 <- function() { 73 | do()$ 74 | catch(error = function(e) expect_equal(conditionMessage(e), "doh")) 75 | } 76 | synchronise(do2()) 77 | expect_true(called) 78 | }) 79 | -------------------------------------------------------------------------------- /tests/testthat/test-when-all.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("when_all", { 3 | done <- FALSE 4 | do <- async(function() { 5 | d1 <- delay(1/1000)$then(function(value) "foo") 6 | d2 <- delay(1/1000)$then(function(value) "bar") 7 | 8 | when_all(d1, d2)$ 9 | then(function(value) { 10 | done <<- TRUE 11 | value 12 | }) 13 | }) 14 | expect_equal(synchronise(do()), list("foo", "bar")) 15 | expect_true(done) 16 | }) 17 | 18 | test_that("when_all, non-deferred", { 19 | done <- FALSE 20 | do <- async(function() { 21 | d1 <- delay(1/1000)$then(function(value) "foo") 22 | d2 <- "bar" 23 | 24 | when_all(d1, d2)$ 25 | then(function(value) { 26 | done <<- TRUE 27 | expect_equal(value, list("foo", "bar")) 28 | }) 29 | }) 30 | synchronise(do()) 31 | expect_true(done) 32 | }) 33 | 34 | test_that("when_all, non-deferred only", { 35 | done <- FALSE 36 | do <- function() { 37 | d1 <- "foo" 38 | d2 <- "bar" 39 | 40 | when_all(d1, d2)$ 41 | then(function(value) { 42 | done <<- TRUE 43 | expect_equal(value, list("foo", "bar")) 44 | }) 45 | } 46 | synchronise(do()) 47 | expect_true(done) 48 | }) 49 | 50 | test_that("when_all, empty list", { 51 | done <- FALSE 52 | do <- async(function() { 53 | when_all()$ 54 | then(function(value) { 55 | done <<- TRUE 56 | expect_equal(value, list()) 57 | }) 58 | }) 59 | synchronise(do()) 60 | expect_true(done) 61 | }) 62 | 63 | test_that("when_all, error", { 64 | done <- FALSE 65 | do <- async(function() { 66 | d1 <- delay(1/1000)$then(function(value) stop("foo")) 67 | d2 <- delay(1/1000)$then(function(value) "bar") 68 | 69 | when_all(d1, d2)$ 70 | catch(error = function(reason) { 71 | done <<- TRUE 72 | expect_match(reason$message, "foo") 73 | }) 74 | }) 75 | synchronise(do()) 76 | expect_true(done) 77 | }) 78 | 79 | test_that("when_all, multiple errors", { 80 | done <- FALSE 81 | err <- NULL 82 | do <- async(function() { 83 | d1 <- delay(2)$then(function(value) stop("foo")) 84 | d2 <- delay(1/10000)$then(function(value) stop("bar")) 85 | 86 | dx <- when_all(d1, d2)$ 87 | catch(error = function(reason) { 88 | done <<- TRUE 89 | err <<- reason 90 | }) 91 | }) 92 | synchronise(do()) 93 | expect_true(done) 94 | expect_match(conditionMessage(err), "bar") 95 | }) 96 | 97 | test_that("resolving to NULL", { 98 | do <- async(function() { 99 | when_all( 100 | delay(0)$then(function(.) NULL), 101 | delay(0)$then(function(.) 46) 102 | ) 103 | }) 104 | 105 | ret <- synchronise(do()) 106 | expect_equal(ret, list(NULL, 46)) 107 | }) 108 | -------------------------------------------------------------------------------- /tests/testthat/test-when-any.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("when_any", { 3 | do <- async(function() { 4 | d1 <- delay(1/10)$then(function(value) "foo") 5 | d2 <- delay(1/10000)$then(function(value) "bar") 6 | 7 | when_any(d1, d2)$ 8 | then(function(value) expect_equal(value, "bar")) 9 | }) 10 | synchronise(do()) 11 | }) 12 | 13 | test_that("when_any, non-deferred", { 14 | do <- async(function() { 15 | d1 <- delay(1/100)$then(function(value) "foo") 16 | d2 <- "bar" 17 | 18 | when_any(d1, d2)$ 19 | then(function(value) expect_equal(value, "bar"))$ 20 | then(function(.) d1)$ 21 | catch(error = identity) 22 | }) 23 | synchronise(do()) 24 | }) 25 | 26 | test_that("when_any, non-deferred only", { 27 | do <- async(function() { 28 | d1 <- "foo" 29 | d2 <- "bar" 30 | 31 | dx <- when_any(d1, d2)$ 32 | then(function(value) expect_true(value %in% c("foo", "bar"))) 33 | }) 34 | synchronise(do()) 35 | }) 36 | 37 | test_that("when_any, error first, success then", { 38 | do <- async(function() { 39 | d1 <- delay(1/10000)$then(function(value) stop("foo")) 40 | d2 <- delay(1/10)$then(function(value) "bar") 41 | 42 | dx <- when_any(d1, d2)$ 43 | then(function(value) expect_equal(value, "bar")) 44 | }) 45 | synchronise(do()) 46 | }) 47 | 48 | test_that("when_any, late error is ignored", { 49 | do <- async(function() { 50 | d1 <- delay(1/10)$then(function(value) stop("foo")) 51 | d2 <- delay(1/10000)$then(function(value) "bar") 52 | 53 | dx <- when_any(d1, d2)$ 54 | catch(error = function(value) expect_equal(value, "bar")) 55 | }) 56 | expect_silent(synchronise(do())) 57 | }) 58 | 59 | test_that("when_any, multiple errors", { 60 | skip_on_cran() 61 | errors <- list() 62 | do <- async(function() { 63 | d1 <- delay(1/10 )$then(function(value) stop("foo")) 64 | d2 <- delay(1/100000)$then(function(value) stop("bar")) 65 | 66 | dx <- when_any(d1, d2)$ 67 | catch(error = function(reason) { 68 | errors <<- reason$errors 69 | }) 70 | }) 71 | synchronise(do()) 72 | expect_match(conditionMessage(errors[[1]]), "bar") 73 | expect_match(conditionMessage(errors[[2]]), "foo") 74 | }) 75 | -------------------------------------------------------------------------------- /tests/testthat/test-when-some.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("when_some", { 3 | done <- FALSE 4 | do <- async(function() { 5 | d1 <- delay(1/10)$then(function(value) "foo") 6 | d2 <- delay(1/10000)$then(function(value) "bar") 7 | 8 | dx <- when_some(2, d1, d2)$ 9 | then(function(value) { 10 | done <<- TRUE 11 | expect_equal(value, list("bar", "foo")) 12 | }) 13 | }) 14 | synchronise(do()) 15 | expect_true(done) 16 | }) 17 | 18 | test_that("when_some, few errors", { 19 | done <- FALSE 20 | do <- async(function() { 21 | d1 <- delay(1/10)$then(function(value) "foo") 22 | d2 <- delay(1/10000)$then(function(.) stop("ooops")) 23 | d3 <- delay(1/10000)$then(function(value) "bar") 24 | 25 | dx <- when_some(2, d1, d2, d3)$ 26 | then(function(value) { 27 | done <<- TRUE 28 | expect_equal(value, list("bar", "foo")) 29 | }) 30 | }) 31 | synchronise(do()) 32 | expect_true(done) 33 | }) 34 | 35 | test_that("too many errors", { 36 | done <- FALSE 37 | do <- async(function() { 38 | d1 <- delay(1/10)$then(function(.) stop("ooops again")) 39 | d2 <- delay(1/10000)$then(function(.) stop("ooops")) 40 | d3 <- delay(1/10000)$then(function(value) "bar") 41 | 42 | when_some(2, d1, d2, d3) 43 | }) 44 | err <- tryCatch(synchronise(do()), error = identity) 45 | expect_equal(conditionMessage(err), "when_some / when_any failed") 46 | expect_equal(conditionMessage(err$errors[[1]]), "ooops") 47 | expect_equal(conditionMessage(err$errors[[2]]), "ooops again") 48 | }) 49 | 50 | test_that("not enough values", { 51 | do <- async(function() { 52 | when_some(3, delay(5), delay(5)) 53 | }) 54 | err <- tryCatch(synchronise(do()), error = identity) 55 | expect_s3_class(err, "async_rejected") 56 | 57 | do2 <- async(function() { 58 | do()$catch(error = function(.) "repaired") 59 | }) 60 | expect_equal(synchronise(do2()), "repaired") 61 | }) 62 | -------------------------------------------------------------------------------- /tests/testthat/test-whilst.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("async_whilst", { 3 | 4 | count <- 0 5 | result <- NULL 6 | 7 | result <- synchronise(async_whilst( 8 | function(...) count < 5, 9 | function() { 10 | delay(1/1000)$then(function(value) count <<- count + 1) 11 | } 12 | )) 13 | 14 | expect_equal(result, 5) 15 | }) 16 | 17 | test_that("async_whilst with false test", { 18 | 19 | result <- NULL 20 | 21 | expect_silent({ 22 | synchronise(async_whilst( 23 | function() FALSE, 24 | function() { 25 | delay(1/1000)$then(function(value) stop("Not reached")) 26 | } 27 | )) 28 | }) 29 | 30 | expect_null(result) 31 | }) 32 | 33 | test_that("error", { 34 | 35 | do <- function() { 36 | async_whilst( 37 | function() i < 5, 38 | function() delay(1/1000)$then(function(value) { 39 | i <<- i + 1 40 | if (i >= 3) stop("doh") 41 | }) 42 | ) 43 | } 44 | 45 | i <- 1 46 | expect_error(synchronise(do()), "doh") 47 | 48 | i <- 1 49 | do2 <- function() { 50 | do()$ 51 | catch(error = function(e) expect_equal(conditionMessage(e), "doh")) 52 | } 53 | synchronise(do2()) 54 | }) 55 | 56 | test_that("test throws", { 57 | 58 | called <- FALSE 59 | 60 | do <- function() { 61 | async_whilst( 62 | function() stop("doh"), 63 | function() { 64 | delay(1/1000)$then(function(value) called <<- TRUE) 65 | } 66 | ) 67 | } 68 | 69 | expect_error(synchronise(do()), "doh") 70 | expect_false(called) 71 | 72 | called <- FALSE 73 | do2 <- function() { 74 | do()$ 75 | catch(error = function(e) expect_equal(conditionMessage(e), "doh")) 76 | } 77 | synchronise(do2()) 78 | expect_false(called) 79 | }) 80 | -------------------------------------------------------------------------------- /tests/testthat/test-worker-pool.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("simple CRUD", { 3 | skip_on_cran() 4 | 5 | withr::with_options(c(async.worker_pool_size = 4), { 6 | wp <- worker_pool$new() 7 | on.exit(wp$kill_workers()) 8 | wl <- wp$list_workers() 9 | expect_equal(nrow(wl), 4) 10 | 11 | ## Schedule some work, it will not start until a process is ready 12 | for (i in 1:10) { 13 | wp$add_task(function() Sys.getpid(), list(), as.character(i), 42) 14 | } 15 | 16 | ## Wait until they have started 17 | conns <- wp$get_poll_connections() 18 | expect_equal(length(conns), 4) 19 | 20 | ready <- NULL 21 | while (!identical(unlist(ready, use.names = FALSE), rep("ready", 4))) { 22 | ready <- processx::poll(conns, 1000L) 23 | } 24 | 25 | ## Let the queue know that they have started 26 | ## Returns NULL because nothing has finished 27 | expect_null(wp$notify_event(names(conns), event_loop = 42)) 28 | 29 | ## Now four workers must be busy 30 | expect_equal(is.na(wp$list_workers()$task), rep(FALSE, 4)) 31 | 32 | ## Check for result 33 | pids <- wp$get_pids() 34 | expect_equal(length(pids), 4) 35 | ready <- NULL 36 | while (!identical(unlist(ready, use.names = FALSE), rep("ready", 4))) { 37 | ready <- processx::poll(conns, 1000L) 38 | } 39 | 40 | ## Results are in, four more tasks should be queued 41 | expect_equal( 42 | sort(wp$notify_event(pids = pids, event_loop = 42)), 43 | as.character(1:4)) 44 | res <- lapply(as.character(1:4), function(i) wp$get_result(i)) 45 | pids <- viapply(res, "[[", "result") 46 | expect_equal(pids, wp$list_workers()$pid) 47 | expect_equal(sum(wp$list_tasks()$status == "running"), 4) 48 | 49 | ## Cancel the rest 50 | for (i in 5:10) wp$cancel_task(as.character(i)) 51 | 52 | ## Workers are idle, no tasks 53 | expect_equal(is.na(wp$list_workers()$task), rep(TRUE, 4)) 54 | expect_equal(NROW(wp$list_tasks()), 0) 55 | 56 | wp$kill_workers() 57 | expect_equal(NROW(wp$list_workers()), 0) 58 | }) 59 | }) 60 | -------------------------------------------------------------------------------- /vignettes/internals.R: -------------------------------------------------------------------------------- 1 | ## ------------------------------------------------------------------------ 2 | library(async) 3 | 4 | --------------------------------------------------------------------------------