From b9b53315aab2d9fd026944212a6f03f5cfb27c73 Mon Sep 17 00:00:00 2001 From: Joe Cheng Date: Tue, 26 Nov 2024 21:37:20 -0800 Subject: [PATCH 1/3] Crazy rewrite of all promise internals It was an attempt to shorten stack depth dramatically when used with coro async generators. I'm not sure if it worked --- R/domains.R | 62 +++---- R/promise.R | 309 +++++++++++++++++++++------------- tests/testthat/test-cpp.R | 2 +- tests/testthat/test-methods.R | 8 +- 4 files changed, 229 insertions(+), 152 deletions(-) diff --git a/R/domains.R b/R/domains.R index d0dff908..27e3a002 100644 --- a/R/domains.R +++ b/R/domains.R @@ -72,19 +72,17 @@ promiseDomain <- list( onRejected = if (shouldWrapRejected) domain$wrapOnRejected(onRejected) else onRejected ) results <- results[!vapply(results, is.null, logical(1))] - if (!is.null(domain)) { - # If there's a domain, ensure that before any callback is invoked, we - # reenter the domain. This is important for this kind of code: - # - # with_promise_domain(domain, { - # async_sleep(0.1) %...>% { - # async_sleep(0.1) %...>% { - # # Without re-entry, this would be outside the domain! - # } - # } - # }) - results <- lapply(results, wrap_callback_reenter, domain = domain) - } + # If there's a domain, ensure that before any callback is invoked, we + # reenter the domain. This is important for this kind of code: + # + # with_promise_domain(domain, { + # async_sleep(0.1) %...>% { + # async_sleep(0.1) %...>% { + # # Without re-entry, this would be outside the domain! + # } + # } + # }) + results <- lapply(results, wrap_callback_reenter, domain = domain) results }, onError = function(error) { @@ -99,24 +97,28 @@ wrap_callback_reenter <- function(callback, domain) { force(callback) force(domain) - wrapper <- function(...) { - reenter_promise_domain(domain, callback(...)) + # We can't simply take `...` as arguments and call `callback(...)`. There are + # parts of this package that will inspect formals() to see if there's a + # `.visible` parameter in the callback. Using `match.call()` here ensures that + # the callback is called with the same arguments as it would have been if it + # were called directly. + # + # IMPORTANT NOTE: This technique changes callback arguments from lazy eval to + # eager eval--make sure you're OK with that before using! + wrapper <- function() { + # Evaluate the arguments in the caller's environment + call <- match.call() + # The `[-1]` is to drop the function name from the call--we just want the + # arguments + args <- lapply(call[-1], eval, parent.frame()) + # Create and evaluate the callback call in our environment, wrapped in reenter_promise_domain + reenter_promise_domain(domain, rlang::exec(callback, !!!args), replace = TRUE) } + # Copy the formals from the original callback to the wrapper, so that the + # wrapper can be called with the same arguments as the original callback. + formals(wrapper) <- formals(callback) - # There are parts of this package that will inspect formals() to see if - # there's a `.visible` parameter in the callback. So it's important to have - # the returned wrapper have the same formals as the original callback. - wrap_with_signature(wrapper, formals(callback)) -} - -wrap_with_signature <- function(func, formal_args) { - # func must have a `...` signature - stopifnot("..." %in% names(formals(func))) - - args <- names(formal_args) - recall <- rlang::call2(func, !!!rlang::set_names(lapply(args, as.symbol), args)) - - rlang::new_function(formal_args, recall) + wrapper } globals <- new.env(parent = emptyenv()) @@ -171,7 +173,7 @@ with_promise_domain <- function(domain, expr, replace = FALSE) { } # Like with_promise_domain, but doesn't include the wrapSync call. -reenter_promise_domain <- function(domain, expr, replace = FALSE) { +reenter_promise_domain <- function(domain, expr, replace) { oldval <- current_promise_domain() if (replace) globals$domain <- domain diff --git a/R/promise.R b/R/promise.R index 7f2a4529..7dd2443e 100644 --- a/R/promise.R +++ b/R/promise.R @@ -3,99 +3,199 @@ #' @import later NULL +PromiseStateResolved <- R6::R6Class("PromiseStateResolved", + private = list( + value = NULL, + visible = TRUE + ), + public = list( + initialize = function(value, visible) { + private$value <- value + private$visible <- visible + }, + status = function() { + "fulfilled" + }, + format = function() { + classname <- class(private$value)[[1]] + if (length(classname) == 0) classname <- "" + sprintf("", self$status(), classname) + }, + register = function(onFulfilled = NULL, onRejected = NULL) { + force(onFulfilled) + force(onRejected) + + if (!is.null(onFulfilled)) { + later::later(function() { + lapply(onFulfilled, function(f) { + f(private$value, private$visible) + }) + }) + } + } + ) +) + +PromiseStateRejected <- R6::R6Class("PromiseStateRejected", + private = list( + reason = NULL + ), + public = list( + initialize = function(reason) { + private$reason <- reason + }, + status = function() { + "rejected" + }, + format = function() { + classname <- class(private$reason)[[1]] + if (length(classname) == 0) classname <- "" + sprintf("", self$status(), classname) + }, + register = function(onFulfilled = NULL, onRejected = NULL) { + force(onFulfilled) + force(onRejected) + + if (!is.null(onRejected)) { + later::later(function() { + lapply(onRejected, function(f) { + f(private$reason) + }) + }) + } + } + ) +) + +PromiseStatePending <- R6::R6Class("PromiseStatePending", + private = list( + onFulfilled = list(), + onRejected = list() + ), + public = list( + initialize = function() { + private$onFulfilled <- list() + private$onRejected <- list() + }, + status = function() { + "pending" + }, + format = function() { + "" + }, + register = function(onFulfilled = NULL, onRejected = NULL) { + force(onFulfilled) + force(onRejected) + + if (!is.null(onFulfilled)) { + stopifnot(is.list(onFulfilled)) + private$onFulfilled <- c(private$onFulfilled, onFulfilled) + } + if (!is.null(onRejected)) { + stopifnot(is.list(onRejected)) + private$onRejected <- c(private$onRejected, onRejected) + } + invisible(NULL) + }, + resolve = function(value, visible) { + force(value) + force(visible) + + # Resolving to promise should've been handled at a higher level + stopifnot(!is.promising(value)) + + new_state <- PromiseStateResolved$new(value, visible) + new_state$register(private$onFulfilled, private$onRejected) + private$onFulfilled <- list() + private$onRejected <- list() + new_state + }, + reject = function(reason) { + force(reason) + + new_state <- PromiseStateRejected$new(reason) + new_state$register(private$onFulfilled, private$onRejected) + private$onFulfilled <- list() + private$onRejected <- list() + new_state + }, + chain = function(new_state) { + force(new_state) + + if (identical(self, new_state)) { + new_new_state <- self$reject(simpleError("Chaining cycle detected for promise")) + return(new_new_state) + } + + new_state$register(private$onFulfilled, private$onRejected) + private$onFulfilled <- list() + private$onRejected <- list() + new_state + } + ) +) + + +PromiseStatePointer <- R6::R6Class("PromiseStatePointer", + public = list( + state = NULL, + initialize = function(state) { + self$state <- state + } + ) +) + #' @import R6 Promise <- R6::R6Class("Promise", private = list( - state = "pending", - value = NULL, - visible = TRUE, + ppstate = NULL, publicResolveRejectCalled = FALSE, - onFulfilled = list(), - onRejected = list(), - onFinally = list(), rejectionHandled = FALSE, - # Private resolve/reject differs from public resolve/reject - # in that the private versions are allowed to be called - # more than once, whereas public ones no-op after the first - # time they are invoked. + pstate = function() { + private$ppstate$state + }, + doResolve = function(value) { val <- withVisible(value) value <- val$value visible <- val$visible + stopifnot(private$pstate()$status() == "pending") + if (is.promising(value)) { value <- as.promise(value) - if (identical(self, attr(value, "promise_impl", exact = TRUE))) { - return(private$doReject(simpleError("Chaining cycle detected for promise"))) + p <- attr(value, "promise_impl", exact = TRUE) + if (identical(p, self)) { + stop("Chaining cycle detected for promise") } - # This then() call doesn't need promise domains; semantically, it doesn't - # really exist, as it's just a convenient way to implement the new promise - # inhabiting the old promise's corpse. - without_promise_domain({ - value$then( - private$doResolve, - private$doReject - ) - }) + private$ppstate <- p$.subsume(private$pstate()) } else { - private$doResolveFinalValue(value, visible) + private$ppstate$state <- private$pstate()$resolve(value, visible) } + invisible() }, doReject = function(reason) { - if (is.promising(reason)) { - reason <- as.promise(reason) - # This then() call doesn't need promise domains; semantically, it doesn't - # really exist, as it's just a convenient way to implement the new promise - # inhabiting the old promise's corpse. - without_promise_domain({ - reason$then( - private$doResolve, - private$doReject - ) - }) - } else { - private$doRejectFinalReason(reason) - } - }, - # These "final" versions of resolve/reject are for when we've - # established that the value/reason is not itself a promise. - doResolveFinalValue = function(value, visible) { - private$value <- value - private$visible <- visible - private$state <- "fulfilled" + force(reason) - later::later(function() { - lapply(private$onFulfilled, function(f) { - f(private$value, private$visible) - }) - private$onFulfilled <- list() - }) - }, - doRejectFinalReason = function(reason) { - private$value <- reason - private$state <- "rejected" - - later::later(function() { - lapply(private$onRejected, function(f) { - private$rejectionHandled <- TRUE - f(private$value) - }) - private$onRejected <- list() + stopifnot(private$pstate()$status() == "pending") - later::later(~{ - if (!private$rejectionHandled) { - # warning() was unreliable here - cat(file=stderr(), "Unhandled promise error: ", reason$message, "\n", sep = "") - } - }) - }) + private$ppstate$state <- private$pstate()$reject(reason) + # cat(file=stderr(), "Unhandled promise error: ", reason$message, "\n", sep = "") + invisible() } ), public = list( + initialize = function() { + private$ppstate <- PromiseStatePointer$new(PromiseStatePending$new()) + }, # "pending", "fulfilled", "rejected" status = function() { - private$state + private$pstate()$status() + }, + .subsume = function(other_pstate) { + other_pstate$chain(private$pstate()) + private$ppstate }, resolve = function(value) { # Only allow this to be called once, then no-op. @@ -147,51 +247,33 @@ Promise <- R6::R6Class("Promise", } promise2 <- promise(function(resolve, reject) { - res <- promiseDomain$onThen(onFulfilled, onRejected, onFinally) + res <- promiseDomain$onThen(onFulfilled, onRejected, onFinally) - if (!is.null(res)) { - onFulfilled <- res$onFulfilled - onRejected <- res$onRejected - } - - handleFulfill <- function(value, visible) { - if (is.function(onFulfilled)) { - resolve(onFulfilled(value, visible)) - } else { - resolve(if (visible) value else invisible(value)) - } - } + if (!is.null(res)) { + onFulfilled <- res$onFulfilled + onRejected <- res$onRejected + } - handleReject <- function(reason) { - if (is.function(onRejected)) { - # Yes, resolve, not reject. - resolve(onRejected(reason)) - } else { - # Yes, reject, not resolve. - reject(reason) - } + handleFulfill <- function(value, visible) { + if (is.function(onFulfilled)) { + resolve(onFulfilled(value, visible)) + } else { + resolve(if (visible) value else invisible(value)) } + } - if (private$state == "pending") { - private$onFulfilled <- c(private$onFulfilled, list( - handleFulfill - )) - private$onRejected <- c(private$onRejected, list( - handleReject - )) - } else if (private$state == "fulfilled") { - later::later(function() { - handleFulfill(private$value, private$visible) - }) - } else if (private$state == "rejected") { - later::later(function() { - private$rejectionHandled <- TRUE - handleReject(private$value) - }) + handleReject <- function(reason) { + if (is.function(onRejected)) { + # Yes, resolve, not reject. + resolve(onRejected(reason)) } else { - stop("Unexpected state ", private$state) + # Yes, reject, not resolve. + reject(reason) } - }) + } + + private$pstate()$register(list(handleFulfill), list(handleReject)) + }) invisible(promise2) }, @@ -204,14 +286,7 @@ Promise <- R6::R6Class("Promise", )) }, format = function() { - if (private$state == "pending") { - "" - } else { - classname <- class(private$value)[[1]] - if (length(classname) == 0) classname <- "" - - sprintf("", private$state, classname) - } + private$pstate()$format() } ) ) @@ -219,7 +294,7 @@ Promise <- R6::R6Class("Promise", normalizeOnFulfilled <- function(onFulfilled) { if (!is.function(onFulfilled)) { if (!is.null(onFulfilled)) { - warning("`onFulfilled` must be a function or `NULL`") + stop("`onFulfilled` must be a function or `NULL`") } return(NULL) } @@ -247,7 +322,7 @@ normalizeOnFulfilled <- function(onFulfilled) { normalizeOnRejected <- function(onRejected) { if (!is.function(onRejected)) { if (!is.null(onRejected)) { - warning("`onRejected` must be a function or `NULL`") + stop("`onRejected` must be a function or `NULL`") } return(NULL) } diff --git a/tests/testthat/test-cpp.R b/tests/testthat/test-cpp.R index d089f081..39cd7036 100644 --- a/tests/testthat/test-cpp.R +++ b/tests/testthat/test-cpp.R @@ -19,7 +19,7 @@ describe("C++ interface", { expect_identical(., 2) promise_resolve(TRUE) %...>% { expect_true(!is.null(current_promise_domain())) - expect_identical(cd$counts$onFulfilledCalled, 3L) + expect_identical(cd$counts$onFulfilledCalled, 2L) } } %>% wait_for_it() diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index b9ed6f7c..9f2d722e 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -32,14 +32,14 @@ describe("then()", { }) it("method ignores non-functions or NULL...", { p1 <- promise(~resolve(1)) - expect_warning( + expect_error( { p1 <- p1$then(10) }, "`onFulfilled` must be a function or `NULL`", fixed = TRUE ) - expect_warning( + expect_error( { p1 <- p1$then(NULL) }, @@ -86,14 +86,14 @@ describe("catch()", { }) it("method ignores non-functions or NULL...", { p1 <- promise(~ resolve(1)) - expect_warning( + expect_error( { p1 <- p1$catch(10) }, "`onRejected` must be a function or `NULL`", fixed = TRUE ) - expect_warning( + expect_error( { p1 <- p1$catch(NULL) }, From 3217788d44f60846ff0042e1810fd1a548190f50 Mon Sep 17 00:00:00 2001 From: Joe Cheng Date: Tue, 26 Nov 2024 22:21:10 -0800 Subject: [PATCH 2/3] Warn on unhandled rejection; allow reject(promise) --- R/promise.R | 48 ++++++++++++++++++++++++++++------- tests/testthat/test-domains.R | 2 +- 2 files changed, 40 insertions(+), 10 deletions(-) diff --git a/R/promise.R b/R/promise.R index 7dd2443e..ac5449b2 100644 --- a/R/promise.R +++ b/R/promise.R @@ -150,7 +150,10 @@ Promise <- R6::R6Class("Promise", private = list( ppstate = NULL, publicResolveRejectCalled = FALSE, - rejectionHandled = FALSE, + # If FALSE, then either then() has been called on this specific object, or + # this object has been used to resolve() another promise. We use this to + # determine whether to print a warning if rejection is not handled. + isTerminal = TRUE, pstate = function() { private$ppstate$state @@ -164,12 +167,7 @@ Promise <- R6::R6Class("Promise", stopifnot(private$pstate()$status() == "pending") if (is.promising(value)) { - value <- as.promise(value) - p <- attr(value, "promise_impl", exact = TRUE) - if (identical(p, self)) { - stop("Chaining cycle detected for promise") - } - private$ppstate <- p$.subsume(private$pstate()) + private$doChain(value) } else { private$ppstate$state <- private$pstate()$resolve(value, visible) } @@ -180,20 +178,50 @@ Promise <- R6::R6Class("Promise", stopifnot(private$pstate()$status() == "pending") - private$ppstate$state <- private$pstate()$reject(reason) - # cat(file=stderr(), "Unhandled promise error: ", reason$message, "\n", sep = "") + if (is.promising(reason)) { + private$doChain(reason) + } else { + private$ppstate$state <- private$pstate()$reject(reason) + } invisible() + }, + # We were resolved or rejected with a promise. Chain ourselves onto that + # promise. + doChain = function(obj) { + p <- attr(as.promise(obj), "promise_impl", exact = TRUE) + if (identical(p, self)) { + stop("Chaining cycle detected for promise") + } + private$ppstate <- p$.subsume(private$pstate()) + }, + # Call at rejection time. If the rejection is not handled by the end of the + # current tick, print a helpful warning. + checkForUnhandledPromiseError = function(reason) { + force(reason) + + if (private$isTerminal) { + # The rejection wasn't handled, but maybe it will be by the end of this + # tick (i.e. `promise_reject("boom") %...!% {}` is perfectly valid). + later::later(~{ + if (private$isTerminal) { + # Nobody has shown up to handle it. Print a warning. + cat(file=stderr(), "Unhandled promise error: ", conditionMessage(reason), "\n", sep = "") + } + }) + } } ), public = list( initialize = function() { private$ppstate <- PromiseStatePointer$new(PromiseStatePending$new()) + private$pstate()$register(onRejected = list(private$checkForUnhandledPromiseError)) }, # "pending", "fulfilled", "rejected" status = function() { private$pstate()$status() }, .subsume = function(other_pstate) { + private$isTerminal <- FALSE other_pstate$chain(private$pstate()) private$ppstate }, @@ -240,6 +268,8 @@ Promise <- R6::R6Class("Promise", invisible() }, then = function(onFulfilled = NULL, onRejected = NULL, onFinally = NULL) { + private$isTerminal <- FALSE + onFulfilled <- normalizeOnFulfilled(onFulfilled) onRejected <- normalizeOnRejected(onRejected) if (!is.function(onFinally)) { diff --git a/tests/testthat/test-domains.R b/tests/testthat/test-domains.R index b6c49304..3244e898 100644 --- a/tests/testthat/test-domains.R +++ b/tests/testthat/test-domains.R @@ -125,7 +125,7 @@ describe("Promise domains", { cd2 <- create_counting_domain(trackFinally = TRUE) p2 <- with_promise_domain(cd2, { - promise_reject(TRUE) %>% + promise_reject("bad") %>% finally(~{ expect_identical(cd2$counts$onFinallyActive, 1L) expect_identical(cd2$counts$onFulfilledActive, 0L) From 2f38fe502e6410bc83a855eae6db3a626570acb1 Mon Sep 17 00:00:00 2001 From: Barret Schloerke Date: Tue, 27 May 2025 12:05:24 -0400 Subject: [PATCH 3/3] `air format .` --- R/domains.R | 72 ++++++----- R/first_type.R | 6 +- R/function_type.R | 6 +- R/future_promise.R | 81 +++++++++---- R/is_something.R | 32 ++--- R/pipe.R | 2 +- R/promise.R | 96 +++++++++------ R/then.R | 12 +- R/utils.R | 12 +- tests/spelling.R | 9 +- tests/testthat/common.R | 34 +++--- tests/testthat/test-aplus-2-2.R | 38 ++++-- tests/testthat/test-combining.R | 18 ++- tests/testthat/test-cpp.R | 13 +- tests/testthat/test-domains.R | 129 +++++++++++--------- tests/testthat/test-methods.R | 76 ++++++------ tests/testthat/test-visibility.R | 148 +++++++++++++---------- tests/testthat/test-zzz-future_promise.R | 66 ++++++---- vignettes/future_promise/plots.R | 95 +++++++++------ 19 files changed, 557 insertions(+), 388 deletions(-) diff --git a/R/domains.R b/R/domains.R index 27e3a002..8e723246 100644 --- a/R/domains.R +++ b/R/domains.R @@ -22,10 +22,7 @@ finallyToFulfilled <- function(onFinally) { force(onFinally) function(value, .visible) { onFinally() - if (.visible) - value - else - invisible(value) + if (.visible) value else invisible(value) } } @@ -44,13 +41,19 @@ promiseDomain <- list( force(onFinally) # Verify that if onFinally is non-NULL, onFulfilled and onRejected are NULL - if (!is.null(onFinally) && (!is.null(onFulfilled) || !is.null(onRejected))) { - stop("A single `then` call cannot combine `onFinally` with `onFulfilled`/`onRejected`") + if ( + !is.null(onFinally) && (!is.null(onFulfilled) || !is.null(onRejected)) + ) { + stop( + "A single `then` call cannot combine `onFinally` with `onFulfilled`/`onRejected`" + ) } domain <- current_promise_domain() - shouldWrapFinally <- !is.null(onFinally) && !is.null(domain) && !is.null(domain$wrapOnFinally) + shouldWrapFinally <- !is.null(onFinally) && + !is.null(domain) && + !is.null(domain$wrapOnFinally) newOnFinally <- if (shouldWrapFinally) { domain$wrapOnFinally(onFinally) @@ -64,12 +67,18 @@ promiseDomain <- list( onRejected <- spliced$onRejected } - shouldWrapFulfilled <- !is.null(onFulfilled) && !is.null(domain) && !shouldWrapFinally - shouldWrapRejected <- !is.null(onRejected) && !is.null(domain) && !shouldWrapFinally + shouldWrapFulfilled <- !is.null(onFulfilled) && + !is.null(domain) && + !shouldWrapFinally + shouldWrapRejected <- !is.null(onRejected) && + !is.null(domain) && + !shouldWrapFinally results <- list( - onFulfilled = if (shouldWrapFulfilled) domain$wrapOnFulfilled(onFulfilled) else onFulfilled, - onRejected = if (shouldWrapRejected) domain$wrapOnRejected(onRejected) else onRejected + onFulfilled = if (shouldWrapFulfilled) + domain$wrapOnFulfilled(onFulfilled) else onFulfilled, + onRejected = if (shouldWrapRejected) + domain$wrapOnRejected(onRejected) else onRejected ) results <- results[!vapply(results, is.null, logical(1))] # If there's a domain, ensure that before any callback is invoked, we @@ -87,8 +96,7 @@ promiseDomain <- list( }, onError = function(error) { domain <- current_promise_domain() - if (is.null(domain)) - return() + if (is.null(domain)) return() domain$onError(error) } ) @@ -112,7 +120,11 @@ wrap_callback_reenter <- function(callback, domain) { # arguments args <- lapply(call[-1], eval, parent.frame()) # Create and evaluate the callback call in our environment, wrapped in reenter_promise_domain - reenter_promise_domain(domain, rlang::exec(callback, !!!args), replace = TRUE) + reenter_promise_domain( + domain, + rlang::exec(callback, !!!args), + replace = TRUE + ) } # Copy the formals from the original callback to the wrapper, so that the # wrapper can be called with the same arguments as the original callback. @@ -160,24 +172,17 @@ current_promise_domain <- function() { #' @export with_promise_domain <- function(domain, expr, replace = FALSE) { oldval <- current_promise_domain() - if (replace) - globals$domain <- domain - else + if (replace) globals$domain <- domain else globals$domain <- compose_domains(oldval, domain) on.exit(globals$domain <- oldval) - if (!is.null(domain)) - domain$wrapSync(expr) - else - force(expr) + if (!is.null(domain)) domain$wrapSync(expr) else force(expr) } # Like with_promise_domain, but doesn't include the wrapSync call. reenter_promise_domain <- function(domain, expr, replace) { oldval <- current_promise_domain() - if (replace) - globals$domain <- domain - else + if (replace) globals$domain <- domain else globals$domain <- compose_domains(oldval, domain) on.exit(globals$domain <- oldval) @@ -222,14 +227,17 @@ new_promise_domain <- function( ..., wrapOnFinally = NULL ) { - list2env(list( - wrapOnFulfilled = wrapOnFulfilled, - wrapOnRejected = wrapOnRejected, - wrapOnFinally = wrapOnFinally, - wrapSync = wrapSync, - onError = onError, - ... - ), parent = emptyenv()) + list2env( + list( + wrapOnFulfilled = wrapOnFulfilled, + wrapOnRejected = wrapOnRejected, + wrapOnFinally = wrapOnFinally, + wrapSync = wrapSync, + onError = onError, + ... + ), + parent = emptyenv() + ) } diff --git a/R/first_type.R b/R/first_type.R index e251676c..a5f942a2 100644 --- a/R/first_type.R +++ b/R/first_type.R @@ -2,8 +2,7 @@ # # @param a non-evaluated expression. # @return logical - TRUE if expr is of "first-argument" type, FALSE otherwise. -is_first <- function(expr) -{ +is_first <- function(expr) { !any(vapply(expr[-1L], identical, logical(1L), quote(.))) } @@ -11,7 +10,6 @@ is_first <- function(expr) # # @param a an expression which passes `is_first` # @return an expression prepared for functional sequence construction. -prepare_first <- function(expr) -{ +prepare_first <- function(expr) { as.call(c(expr[[1L]], quote(.), as.list(expr[-1L]))) } diff --git a/R/function_type.R b/R/function_type.R index 8b50e787..e5490f24 100644 --- a/R/function_type.R +++ b/R/function_type.R @@ -2,8 +2,7 @@ # # @param a non-evaluated expression. # @return logical - TRUE if expr represents a function, FALSE otherwise. -is_function <- function(expr) -{ +is_function <- function(expr) { is.symbol(expr) || is.function(expr) } @@ -11,8 +10,7 @@ is_function <- function(expr) # # @param a an expression which passes `is_function` # @return an expression prepared for functional sequence construction. -prepare_function <- function(f) -{ +prepare_function <- function(f) { as.call(list(f, quote(.))) } diff --git a/R/future_promise.R b/R/future_promise.R index 09713457..7b19aa26 100644 --- a/R/future_promise.R +++ b/R/future_promise.R @@ -1,4 +1,3 @@ - debug_msg_can_print <- FALSE debug_msg <- function(...) { if (debug_msg_can_print) { @@ -15,7 +14,13 @@ assert_work_queue_pkgs <- local({ list(name = "fastmap", version = "1.1.0") )) { if (!is_installed(pkg$name, pkg$version)) { - stop("Package `", pkg$name, "` (", pkg$version, ") needs to be installed") + stop( + "Package `", + pkg$name, + "` (", + pkg$version, + ") needs to be installed" + ) } } val <<- TRUE @@ -27,7 +32,8 @@ future_worker_is_free <- function() { } -Delay <- R6::R6Class("Delay", +Delay <- R6::R6Class( + "Delay", private = list( delay_count = 0 ), @@ -46,14 +52,16 @@ Delay <- R6::R6Class("Delay", delay = function() { stop("$delay() not implemented") } - ), active = list( + ), + active = list( count = function() { private$delay_count } ) ) -ExpoDelay <- R6::R6Class("ExpoDelay", +ExpoDelay <- R6::R6Class( + "ExpoDelay", inherit = Delay, private = list( base = 1 / 100, @@ -67,8 +75,12 @@ ExpoDelay <- R6::R6Class("ExpoDelay", max_seconds = 2 ) { stopifnot(length(base) == 1 && is.numeric(base) && base >= 0) - stopifnot(length(min_seconds) == 1 && is.numeric(min_seconds) && min_seconds >= 0) - stopifnot(length(max_seconds) == 1 && is.numeric(max_seconds) && max_seconds >= 0) + stopifnot( + length(min_seconds) == 1 && is.numeric(min_seconds) && min_seconds >= 0 + ) + stopifnot( + length(max_seconds) == 1 && is.numeric(max_seconds) && max_seconds >= 0 + ) private$base <- base private$max_seconds <- max_seconds @@ -81,7 +93,7 @@ ExpoDelay <- R6::R6Class("ExpoDelay", # will randomly backoff to avoid extra work on long poll times delay = function() { # calculate expo backoff value - expo_val <- private$base * ((2 ^ private$delay_count) - 1) + expo_val <- private$base * ((2^private$delay_count) - 1) # find random value random_val <- runif(n = 1, max = min(private$max_seconds, expo_val)) # perform `min()` on second step to avoid `runif(1, min = 5, max = 4)` which produces `NaN` @@ -121,7 +133,8 @@ ExpoDelay <- R6::R6Class("ExpoDelay", #' #' @seealso [future_promise_queue()] which returns a `WorkQueue` which is cached per R session. #' @keywords internal -WorkQueue <- R6::R6Class("WorkQueue", +WorkQueue <- R6::R6Class( + "WorkQueue", # TODO - private loop proposal: # The queued data would actually be a list of queues whose _key_ matches @@ -219,10 +232,9 @@ WorkQueue <- R6::R6Class("WorkQueue", } # If there are still items to be processed, but we can not proceed... - if (private$queue$size() > 0 && ! private$can_proceed()) { + if (private$queue$size() > 0 && !private$can_proceed()) { # If we are allowed to delay (default FALSE), or nothing is currently delaying if (can_delay || is.null(private$cancel_delayed_attempt_work)) { - # Try again later private$increase_delay() private$cancel_delayed_attempt_work <- @@ -282,8 +294,8 @@ WorkQueue <- R6::R6Class("WorkQueue", stopifnot(is.function(can_proceed)) stopifnot( is.function(queue$add) && - is.function(queue$remove) && - is.function(queue$size) + is.function(queue$remove) && + is.function(queue$size) ) stopifnot(inherits(loop, "event_loop")) delay <- ExpoDelay$new() @@ -414,9 +426,11 @@ future_promise <- function( ..., queue = future_promise_queue() ) { - # make sure queue is the right structure - stopifnot(is.function(queue$schedule_work) && length(formals(queue$schedule_work)) >= 1) + stopifnot( + is.function(queue$schedule_work) && + length(formals(queue$schedule_work)) >= 1 + ) if (substitute) expr <- substitute(expr) @@ -460,9 +474,7 @@ future_promise <- function( } - if (FALSE) { - # ConstDelay <- R6::R6Class("ConstDelay", # inherit = Delay, # private = list( @@ -512,7 +524,6 @@ if (FALSE) { # ) # ) - # dev_load <- pkgload::load_all # ## test @@ -524,7 +535,6 @@ if (FALSE) { # ## block main worker mid job # dev_load(); print_i(); start <- Sys.time(); promise_all(.list = lapply(1:10, function(x) { future_promise({ Sys.sleep(1); print(paste0(x)) })})) %...>% { print(Sys.time() - start) }; lapply(1:4, function(i) { later::later(function() { message("*************** adding blockage", i); fj <- future::future({ Sys.sleep(4); message("*************** blockage done", i); i}); then(fj, function(x) { print(paste0("block - ", i))}); }, delay = 0.5 + i/4) }) -> ignore; - # ## block workers pre job # dev_load(); print_i(); lapply(1:2, function(i) { message("*************** adding blockage", i); future::future({ Sys.sleep(4); message("*************** blockage done", i); i}) }) -> future_jobs; lapply(future_jobs, function(fj) { as.promise(fj) %...>% { print(.) } }); start <- Sys.time(); promise_all(.list = lapply(1:10, function(x) { future_promise({ Sys.sleep(1); print(paste0(x)) })})) %...>% { print(Sys.time() - start) }; @@ -535,7 +545,17 @@ if (FALSE) { debug_msg_can_print <- TRUE - print_i <- function(i = 0) { if (i <= 50) { print(i); later::later(function() { print_i(i + 1) }, delay = 0.1) } } + print_i <- function(i = 0) { + if (i <= 50) { + print(i) + later::later( + function() { + print_i(i + 1) + }, + delay = 0.1 + ) + } + } slow_calc <- function(n) { Sys.sleep(n) @@ -563,9 +583,20 @@ if (FALSE) { print("done assignement!") - a1 %...>% { message("end 1 - ", format(Sys.time())) } - a2 %...>% { message("end 2 - ", format(Sys.time())) } - a3 %...>% { message("end 3 - ", format(Sys.time())) } - a4 %...>% { message("end 4 - ", format(Sys.time())) } - + a1 %...>% + { + message("end 1 - ", format(Sys.time())) + } + a2 %...>% + { + message("end 2 - ", format(Sys.time())) + } + a3 %...>% + { + message("end 3 - ", format(Sys.time())) + } + a4 %...>% + { + message("end 4 - ", format(Sys.time())) + } } diff --git a/R/is_something.R b/R/is_something.R index 9b4f74ed..f1216c83 100644 --- a/R/is_something.R +++ b/R/is_something.R @@ -2,20 +2,18 @@ # # @param pipe A quoted symbol # @return logical - TRUE if a valid magrittr pipe, FALSE otherwise. -is_pipe <- function(pipe) -{ - identical(pipe, quote(`%>%`)) || - identical(pipe, quote(`%T>%`)) || - identical(pipe, quote(`%<>%`)) || - identical(pipe, quote(`%$%`)) +is_pipe <- function(pipe) { + identical(pipe, quote(`%>%`)) || + identical(pipe, quote(`%T>%`)) || + identical(pipe, quote(`%<>%`)) || + identical(pipe, quote(`%$%`)) } # Determine whether an non-evaluated call is parenthesized # # @param a non-evaluated expression # @retun logical - TRUE if expression is parenthesized, FALSE otherwise. -is_parenthesized <- function(expr) -{ +is_parenthesized <- function(expr) { is.call(expr) && identical(expr[[1L]], quote(`(`)) } @@ -23,8 +21,7 @@ is_parenthesized <- function(expr) # # @param pipe A (quoted) pipe # @return logical - TRUE if pipe is a tee, FALSE otherwise. -is_tee <- function(pipe) -{ +is_tee <- function(pipe) { identical(pipe, quote(`%T>%`)) } @@ -32,8 +29,7 @@ is_tee <- function(pipe) # # @param pipe A (quoted) pipe # @return logical - TRUE if pipe is the dollar pipe, FALSE otherwise. -is_dollar <- function(pipe) -{ +is_dollar <- function(pipe) { identical(pipe, quote(`%$%`)) } @@ -42,8 +38,7 @@ is_dollar <- function(pipe) # @param pipe A (quoted) pipe # @return logical - TRUE if pipe is the compound assignment pipe, # otherwise FALSE. -is_compound_pipe <- function(pipe) -{ +is_compound_pipe <- function(pipe) { identical(pipe, quote(`%<>%`)) } @@ -51,8 +46,7 @@ is_compound_pipe <- function(pipe) # # @param expr An expression to be tested. # @return logical - TRUE if expr is enclosed in `{`, FALSE otherwise. -is_funexpr <- function(expr) -{ +is_funexpr <- function(expr) { is.call(expr) && identical(expr[[1L]], quote(`{`)) } @@ -60,8 +54,7 @@ is_funexpr <- function(expr) # # @param expr An expression to be tested. # @return logical - TRUE if expr contains `::` or `:::`, FALSE otherwise. -is_colexpr <- function(expr) -{ +is_colexpr <- function(expr) { is.call(expr) && (identical(expr[[1L]], quote(`::`)) || identical(expr[[1L]], quote(`:::`))) } @@ -70,7 +63,6 @@ is_colexpr <- function(expr) # # @param symbol A (quoted) symbol # @return logical - TRUE if symbol is the magrittr placeholder, FALSE otherwise. -is_placeholder <- function(symbol) -{ +is_placeholder <- function(symbol) { identical(symbol, quote(.)) } diff --git a/R/pipe.R b/R/pipe.R index b4b1fa97..c0f15548 100644 --- a/R/pipe.R +++ b/R/pipe.R @@ -152,5 +152,5 @@ pipeify_rhs <- function(rhs, env) { rhs } - eval(call("function", as.pairlist(alist(.=, .visible=)), rhs), env, env) + eval(call("function", as.pairlist(alist(. = , .visible = )), rhs), env, env) } diff --git a/R/promise.R b/R/promise.R index ac5449b2..b2bcae55 100644 --- a/R/promise.R +++ b/R/promise.R @@ -3,7 +3,8 @@ #' @import later NULL -PromiseStateResolved <- R6::R6Class("PromiseStateResolved", +PromiseStateResolved <- R6::R6Class( + "PromiseStateResolved", private = list( value = NULL, visible = TRUE @@ -36,7 +37,8 @@ PromiseStateResolved <- R6::R6Class("PromiseStateResolved", ) ) -PromiseStateRejected <- R6::R6Class("PromiseStateRejected", +PromiseStateRejected <- R6::R6Class( + "PromiseStateRejected", private = list( reason = NULL ), @@ -67,7 +69,8 @@ PromiseStateRejected <- R6::R6Class("PromiseStateRejected", ) ) -PromiseStatePending <- R6::R6Class("PromiseStatePending", +PromiseStatePending <- R6::R6Class( + "PromiseStatePending", private = list( onFulfilled = list(), onRejected = list() @@ -123,7 +126,9 @@ PromiseStatePending <- R6::R6Class("PromiseStatePending", force(new_state) if (identical(self, new_state)) { - new_new_state <- self$reject(simpleError("Chaining cycle detected for promise")) + new_new_state <- self$reject(simpleError( + "Chaining cycle detected for promise" + )) return(new_new_state) } @@ -136,7 +141,8 @@ PromiseStatePending <- R6::R6Class("PromiseStatePending", ) -PromiseStatePointer <- R6::R6Class("PromiseStatePointer", +PromiseStatePointer <- R6::R6Class( + "PromiseStatePointer", public = list( state = NULL, initialize = function(state) { @@ -146,7 +152,8 @@ PromiseStatePointer <- R6::R6Class("PromiseStatePointer", ) #' @import R6 -Promise <- R6::R6Class("Promise", +Promise <- R6::R6Class( + "Promise", private = list( ppstate = NULL, publicResolveRejectCalled = FALSE, @@ -202,19 +209,29 @@ Promise <- R6::R6Class("Promise", if (private$isTerminal) { # The rejection wasn't handled, but maybe it will be by the end of this # tick (i.e. `promise_reject("boom") %...!% {}` is perfectly valid). - later::later(~{ - if (private$isTerminal) { - # Nobody has shown up to handle it. Print a warning. - cat(file=stderr(), "Unhandled promise error: ", conditionMessage(reason), "\n", sep = "") + later::later( + ~ { + if (private$isTerminal) { + # Nobody has shown up to handle it. Print a warning. + cat( + file = stderr(), + "Unhandled promise error: ", + conditionMessage(reason), + "\n", + sep = "" + ) + } } - }) + ) } } ), public = list( initialize = function() { private$ppstate <- PromiseStatePointer$new(PromiseStatePending$new()) - private$pstate()$register(onRejected = list(private$checkForUnhandledPromiseError)) + private$pstate()$register( + onRejected = list(private$checkForUnhandledPromiseError) + ) }, # "pending", "fulfilled", "rejected" status = function() { @@ -227,8 +244,7 @@ Promise <- R6::R6Class("Promise", }, resolve = function(value) { # Only allow this to be called once, then no-op. - if (private$publicResolveRejectCalled) - return(invisible()) + if (private$publicResolveRejectCalled) return(invisible()) private$publicResolveRejectCalled <- TRUE tryCatch( @@ -248,8 +264,7 @@ Promise <- R6::R6Class("Promise", }, reject = function(reason) { # Only allow this to be called once, then no-op. - if (private$publicResolveRejectCalled) - return(invisible()) + if (private$publicResolveRejectCalled) return(invisible()) private$publicResolveRejectCalled <- TRUE tryCatch( @@ -435,13 +450,17 @@ promise <- function(action) { if (is.function(action)) { action(p$resolve, p$reject) } else if (inherits(action, "formula")) { - eval(action[[2]], list( - resolve = p$resolve, - reject = p$reject, - return = function(value) { - warning("Can't return a value from a promise, use resolve/reject") - } - ), environment(action)) + eval( + action[[2]], + list( + resolve = p$resolve, + reject = p$reject, + return = function(value) { + warning("Can't return a value from a promise, use resolve/reject") + } + ), + environment(action) + ) } }, error = function(e) { @@ -485,13 +504,13 @@ promise <- function(action) { #' #' @export promise_resolve <- function(value) { - promise(~resolve(value)) + promise(~ resolve(value)) } #' @rdname promise_resolve #' @export promise_reject <- function(reason) { - promise(~reject(reason)) + promise(~ reject(reason)) } #' Coerce to a promise @@ -566,21 +585,26 @@ as.promise.Future <- function(x) { poll_interval <- 0.1 check <- function() { # timeout = 0 is important, the default waits for 200ms - is_resolved <- tryCatch({ - future::resolved(x, timeout = 0) - }, FutureError = function(e) { - reject(e) - TRUE - }) + is_resolved <- tryCatch( + { + future::resolved(x, timeout = 0) + }, + FutureError = function(e) { + reject(e) + TRUE + } + ) if (is_resolved) { tryCatch( { result <- future::value(x, signal = TRUE) resolve(result) - }, FutureError = function(e) { + }, + FutureError = function(e) { reject(e) TRUE - }, error = function(e) { + }, + error = function(e) { reject(e) } ) @@ -599,7 +623,11 @@ as.promise.Future <- function(x) { #' @export as.promise.default <- function(x) { # TODO: If x is an error or try-error, should this return a rejected promise? - stop("Don't know how to convert object of class ", class(x)[[1L]], " into a promise") + stop( + "Don't know how to convert object of class ", + class(x)[[1L]], + " into a promise" + ) } #' Fulfill a promise diff --git a/R/then.R b/R/then.R index 7956459d..bc85934b 100644 --- a/R/then.R +++ b/R/then.R @@ -110,10 +110,8 @@ then <- function(promise, onFulfilled = NULL, onRejected = NULL) { promise <- as.promise(promise) - if (!is.null(onFulfilled)) - onFulfilled <- rlang::as_function(onFulfilled) - if (!is.null(onRejected)) - onRejected <- rlang::as_function(onRejected) + if (!is.null(onFulfilled)) onFulfilled <- rlang::as_function(onFulfilled) + if (!is.null(onRejected)) onRejected <- rlang::as_function(onRejected) invisible(promise$then(onFulfilled = onFulfilled, onRejected = onRejected)) } @@ -128,8 +126,7 @@ then <- function(promise, onFulfilled = NULL, onRejected = NULL) { catch <- function(promise, onRejected, tee = FALSE) { promise <- as.promise(promise) - if (!is.null(onRejected)) - onRejected <- rlang::as_function(onRejected) + if (!is.null(onRejected)) onRejected <- rlang::as_function(onRejected) if (!tee) { return(promise$catch(onRejected)) @@ -151,7 +148,6 @@ catch <- function(promise, onRejected, tee = FALSE) { finally <- function(promise, onFinally) { promise <- as.promise(promise) - if (!is.null(onFinally)) - onFinally <- rlang::as_function(onFinally) + if (!is.null(onFinally)) onFinally <- rlang::as_function(onFinally) promise$finally(onFinally) } diff --git a/R/utils.R b/R/utils.R index 2f2191b0..56e31358 100644 --- a/R/utils.R +++ b/R/utils.R @@ -45,13 +45,15 @@ promise_all <- function(..., .list = NULL) { } if (length(.list) == 0) { - return(promise(~resolve(list()))) + return(promise(~ resolve(list()))) } # Verify that .list members are either all named or all unnamed nameCount <- sum(nzchar(names(.list))) if (nameCount != 0 && nameCount != length(.list)) { - stop("promise_all expects promise arguments (or list) to be either all named or all unnamed") + stop( + "promise_all expects promise arguments (or list) to be either all named or all unnamed" + ) } done <- list() @@ -69,7 +71,8 @@ promise_all <- function(..., .list = NULL) { # Forces correct/deterministic ordering of the result list's elements results[[key]] <<- NA - then(.list[[key]], + then( + .list[[key]], onFulfilled = function(value) { # Save the result so we can return it to the user. # This weird assignment is similar to `results[[key]] <- value`, except @@ -140,8 +143,7 @@ promise_race <- function(..., .list = NULL) { #' @export promise_map <- function(.x, .f, ...) { .f <- match.fun(.f) - if (!is.vector(.x) || is.object(.x)) - .x <- as.list(.x) + if (!is.vector(.x) || is.object(.x)) .x <- as.list(.x) x_names <- names(.x) results <- vector("list", length(.x)) diff --git a/tests/spelling.R b/tests/spelling.R index 6713838f..a8cf85b9 100644 --- a/tests/spelling.R +++ b/tests/spelling.R @@ -1,3 +1,6 @@ -if(requireNamespace('spelling', quietly = TRUE)) - spelling::spell_check_test(vignettes = TRUE, error = FALSE, - skip_on_cran = TRUE) +if (requireNamespace('spelling', quietly = TRUE)) + spelling::spell_check_test( + vignettes = TRUE, + error = FALSE, + skip_on_cran = TRUE + ) diff --git a/tests/testthat/common.R b/tests/testthat/common.R index e3dc3826..824ff936 100644 --- a/tests/testthat/common.R +++ b/tests/testthat/common.R @@ -57,18 +57,19 @@ extract <- function(promise) { resolve_later <- function(value, delaySecs) { force(value) - promise(~later::later(~resolve(value), delaySecs)) + promise(~ later::later(~ resolve(value), delaySecs)) } # Prevent "Unhandled promise error" warning that happens if you don't handle the # rejection of a promise squelch_unhandled_promise_error <- function(promise) { - promise %...!% (function(reason) { - if (inherits(reason, "failure")) { - # Don't squelch test failures - stop(reason) - } - }) + promise %...!% + (function(reason) { + if (inherits(reason, "failure")) { + # Don't squelch test failures + stop(reason) + } + }) } .GlobalEnv$.Last <- function() { @@ -77,14 +78,17 @@ squelch_unhandled_promise_error <- function(promise) { } create_counting_domain <- function(trackFinally = FALSE) { - counts <- list2env(parent = emptyenv(), list( - onFulfilledBound = 0L, - onFulfilledCalled = 0L, - onFulfilledActive = 0L, - onRejectedBound = 0L, - onRejectedCalled = 0L, - onRejectedActive = 0L - )) + counts <- list2env( + parent = emptyenv(), + list( + onFulfilledBound = 0L, + onFulfilledCalled = 0L, + onFulfilledActive = 0L, + onRejectedBound = 0L, + onRejectedCalled = 0L, + onRejectedActive = 0L + ) + ) incr <- function(field) { field <- as.character(substitute(field)) diff --git a/tests/testthat/test-aplus-2-2.R b/tests/testthat/test-aplus-2-2.R index 7603b8b1..c9597fcc 100644 --- a/tests/testthat/test-aplus-2-2.R +++ b/tests/testthat/test-aplus-2-2.R @@ -27,17 +27,19 @@ describe("2.2. The `then` Method", { x <- NULL p <- ext_promise() - p$promise %>% then(function(value) { x <<- value }) %>% wait_for_it() + p$promise %>% + then(function(value) { + x <<- value + }) %>% + wait_for_it() expect_identical(x, NULL) p$resolve(10) %>% wait_for_it() expect_identical(x, 10) }) it("2.2.2.2. it must not be called before promise is fulfilled.", { - }) it("2.2.2.3. it must not be called more than once.", { - }) }) describe("2.2.3. If onRejected is a function,", { @@ -45,7 +47,10 @@ describe("2.2. The `then` Method", { x <- NULL p <- ext_promise() - p$promise %>% then(onRejected = function(reason) { x <<- reason }) %>% + p$promise %>% + then(onRejected = function(reason) { + x <<- reason + }) %>% wait_for_it() expect_identical(x, NULL) @@ -57,7 +62,10 @@ describe("2.2. The `then` Method", { describe("2.2.4. onFulfilled or onRejected must not be called until the execution context stack contains only platform code. [3.1].", { it(" ", { x <- NULL - p <- promise(~resolve(TRUE)) %>% then(function(value) {x <<- value}) + p <- promise(~ resolve(TRUE)) %>% + then(function(value) { + x <<- value + }) expect_identical(x, NULL) p %>% wait_for_it() expect_identical(x, TRUE) @@ -114,32 +122,38 @@ describe("2.2. The `then` Method", { describe("2.2.7. `then` must return a promise [3.3].", { it(" ", { - promise(~{}) %>% then() %>% is.promise() %>% expect_true() + promise( + ~ { + } + ) %>% + then() %>% + is.promise() %>% + expect_true() }) it("2.2.7.1. If either onFulfilled or onRejected returns a value x, run the Promise Resolution Procedure [[Resolve]](promise2, x).", { - p1 <- promise(~resolve(TRUE)) %>% then(~"foo") + p1 <- promise(~ resolve(TRUE)) %>% then(~"foo") expect_identical(extract(p1), "foo") - p2 <- promise(~reject("boom")) %>% catch(~"bar") + p2 <- promise(~ reject("boom")) %>% catch(~"bar") expect_identical(extract(p2), "bar") }) it("2.2.7.2. If either onFulfilled or onRejected throws an exception e, promise2 must be rejected with e as the reason.", { - p1 <- promise(~resolve(TRUE)) %>% then(~stop("foo")) + p1 <- promise(~ resolve(TRUE)) %>% then(~ stop("foo")) expect_error(extract(p1), "^foo$") - p2 <- promise(~reject("boom")) %>% catch(~stop("bar")) + p2 <- promise(~ reject("boom")) %>% catch(~ stop("bar")) expect_error(extract(p2), "^bar$") }) it("2.2.7.3. If onFulfilled is not a function and promise1 is fulfilled, promise2 must be fulfilled with the same value as promise1.", { - p <- promise(~resolve("baz")) %>% then() + p <- promise(~ resolve("baz")) %>% then() expect_identical(extract(p), "baz") }) it("2.2.7.4. If onRejected is not a function and promise1 is rejected, promise2 must be rejected with the same reason as promise1.", { - p <- promise(~reject("qux")) %>% then() + p <- promise(~ reject("qux")) %>% then() expect_error(extract(p), "^qux$") }) }) diff --git a/tests/testthat/test-combining.R b/tests/testthat/test-combining.R index 4594f2b6..d10db508 100644 --- a/tests/testthat/test-combining.R +++ b/tests/testthat/test-combining.R @@ -8,17 +8,23 @@ describe("promise_all", { b <- resolve_later(2, 0.3) c <- resolve_later(3, 0.1) - x <- promise_all(.list = list(a=a, b=b, c=c)) - expect_identical(extract(x), list(a=1, b=2, c=3)) + x <- promise_all(.list = list(a = a, b = b, c = c)) + expect_identical(extract(x), list(a = 1, b = 2, c = 3)) }) it("Handles NULLs correctly", { - x <- promise_all(promise_resolve(NULL), promise_resolve(NULL), - promise_resolve(NULL)) + x <- promise_all( + promise_resolve(NULL), + promise_resolve(NULL), + promise_resolve(NULL) + ) expect_identical(extract(x), list(NULL, NULL, NULL)) - x <- promise_all(a = promise_resolve(NULL), b = promise_resolve(NULL), - c = promise_resolve(NULL)) + x <- promise_all( + a = promise_resolve(NULL), + b = promise_resolve(NULL), + c = promise_resolve(NULL) + ) expect_identical(extract(x), list(a = NULL, b = NULL, c = NULL)) }) }) diff --git a/tests/testthat/test-cpp.R b/tests/testthat/test-cpp.R index 39cd7036..2ba13a61 100644 --- a/tests/testthat/test-cpp.R +++ b/tests/testthat/test-cpp.R @@ -3,7 +3,9 @@ describe("C++ interface", { promise(function(resolve, reject) { asyncFib(resolve, reject, 3) }) %...>% - { expect_identical(., 2) } %>% + { + expect_identical(., 2) + } %>% wait_for_it() }) @@ -17,10 +19,11 @@ describe("C++ interface", { }) %...>% { expect_identical(., 2) - promise_resolve(TRUE) %...>% { - expect_true(!is.null(current_promise_domain())) - expect_identical(cd$counts$onFulfilledCalled, 2L) - } + promise_resolve(TRUE) %...>% + { + expect_true(!is.null(current_promise_domain())) + expect_identical(cd$counts$onFulfilledCalled, 2L) + } } %>% wait_for_it() }) diff --git a/tests/testthat/test-domains.R b/tests/testthat/test-domains.R index 3244e898..87be59ee 100644 --- a/tests/testthat/test-domains.R +++ b/tests/testthat/test-domains.R @@ -7,36 +7,41 @@ async_true <- function() { } describe("Promise domains", { - it("are reentered during handlers", { cd <- create_counting_domain(trackFinally = TRUE) p <- with_promise_domain(cd, { - async_true() %...>% { - expect_identical(cd$counts$onFulfilledCalled, 1L) - expect_identical(cd$counts$onFulfilledActive, 1L) - 10 # sync result - } %...>% { - expect_identical(cd$counts$onFulfilledCalled, 2L) - expect_identical(cd$counts$onFulfilledActive, 1L) - promise_resolve(20) # async result - } + async_true() %...>% + { + expect_identical(cd$counts$onFulfilledCalled, 1L) + expect_identical(cd$counts$onFulfilledActive, 1L) + 10 # sync result + } %...>% + { + expect_identical(cd$counts$onFulfilledCalled, 2L) + expect_identical(cd$counts$onFulfilledActive, 1L) + promise_resolve(20) # async result + } }) expect_identical(cd$counts$onFulfilledBound, 2L) - p <- p %...>% { - expect_identical(cd$counts$onFulfilledCalled, 2L) - expect_identical(cd$counts$onFulfilledActive, 0L) - } + p <- p %...>% + { + expect_identical(cd$counts$onFulfilledCalled, 2L) + expect_identical(cd$counts$onFulfilledActive, 0L) + } expect_identical(cd$counts$onFulfilledBound, 2L) p %>% wait_for_it() with_promise_domain(cd, { - p <- async_true() %>% finally(~{ - expect_identical(cd$counts$onFinallyCalled, 1L) - expect_identical(cd$counts$onFinallyActive, 1L) - }) + p <- async_true() %>% + finally( + ~ { + expect_identical(cd$counts$onFinallyCalled, 1L) + expect_identical(cd$counts$onFinallyActive, 1L) + } + ) expect_identical(cd$counts$onFinallyBound, 1L) expect_identical(cd$counts$onFulfilledBound, 2L) @@ -48,19 +53,21 @@ describe("Promise domains", { expect_identical(cd$counts$onFulfilledBound, 2L) with_promise_domain(cd, { - p <- async_true() %...>% { - expect_identical(., TRUE) - expect_identical(cd$counts$onFulfilledCalled, 3L) - ten <- 10 - # This tests if promise domain membership infects subscriptions made - # in handlers. - promise_resolve(invisible(ten)) %...>% (function(value, .visible) { - expect_identical(value, 10) - expect_false(.visible) - expect_true(!is.null(current_promise_domain())) - expect_identical(cd$counts$onFulfilledCalled, 4L) - }) - } + p <- async_true() %...>% + { + expect_identical(., TRUE) + expect_identical(cd$counts$onFulfilledCalled, 3L) + ten <- 10 + # This tests if promise domain membership infects subscriptions made + # in handlers. + promise_resolve(invisible(ten)) %...>% + (function(value, .visible) { + expect_identical(value, 10) + expect_false(.visible) + expect_true(!is.null(current_promise_domain())) + expect_identical(cd$counts$onFulfilledCalled, 4L) + }) + } }) expect_true(is.null(current_promise_domain())) @@ -74,10 +81,12 @@ describe("Promise domains", { with_promise_domain(cd1, { p1 <- async_true() %>% - finally(~{ - expect_identical(cd1$counts$onFulfilledActive, 1L) - expect_identical(cd1$counts$onRejectedActive, 0L) - }) + finally( + ~ { + expect_identical(cd1$counts$onFulfilledActive, 1L) + expect_identical(cd1$counts$onRejectedActive, 0L) + } + ) expect_identical(cd1$counts$onFulfilledBound, 1L) expect_identical(cd1$counts$onRejectedBound, 1L) p1 %>% wait_for_it() @@ -89,10 +98,12 @@ describe("Promise domains", { p2 <- with_promise_domain(cd2, { promise_reject("a problem") %>% - finally(~{ - expect_identical(cd2$counts$onFulfilledActive, 0L) - expect_identical(cd2$counts$onRejectedActive, 1L) - }) + finally( + ~ { + expect_identical(cd2$counts$onFulfilledActive, 0L) + expect_identical(cd2$counts$onRejectedActive, 1L) + } + ) }) %>% squelch_unhandled_promise_error() @@ -108,11 +119,13 @@ describe("Promise domains", { with_promise_domain(cd1, { p1 <- async_true() %>% - finally(~{ - expect_identical(cd1$counts$onFinallyActive, 1L) - expect_identical(cd1$counts$onFulfilledActive, 0L) - expect_identical(cd1$counts$onRejectedActive, 0L) - }) + finally( + ~ { + expect_identical(cd1$counts$onFinallyActive, 1L) + expect_identical(cd1$counts$onFulfilledActive, 0L) + expect_identical(cd1$counts$onRejectedActive, 0L) + } + ) expect_identical(cd1$counts$onFinallyBound, 1L) expect_identical(cd1$counts$onFulfilledBound, 0L) expect_identical(cd1$counts$onRejectedBound, 0L) @@ -126,12 +139,15 @@ describe("Promise domains", { p2 <- with_promise_domain(cd2, { promise_reject("bad") %>% - finally(~{ - expect_identical(cd2$counts$onFinallyActive, 1L) - expect_identical(cd2$counts$onFulfilledActive, 0L) - expect_identical(cd2$counts$onRejectedActive, 0L) - }) - }) %>% squelch_unhandled_promise_error() + finally( + ~ { + expect_identical(cd2$counts$onFinallyActive, 1L) + expect_identical(cd2$counts$onFulfilledActive, 0L) + expect_identical(cd2$counts$onRejectedActive, 0L) + } + ) + }) %>% + squelch_unhandled_promise_error() expect_identical(cd2$counts$onFinallyBound, 1L) expect_identical(cd2$counts$onFulfilledBound, 0L) @@ -151,7 +167,9 @@ describe("Promise domains", { cd <- create_counting_domain() with_promise_domain(cd, { promise_resolve(as.symbol("foo")) %...>% - { expect_identical(., as.symbol("foo")) } %>% + { + expect_identical(., as.symbol("foo")) + } %>% wait_for_it() }) }) @@ -162,11 +180,14 @@ describe("Promise domains", { x <- NULL with_promise_domain(cd, { promise_resolve(NULL) %...>% - { x <<- 1L } %...>% - { x <<- x + 1L } %>% + { + x <<- 1L + } %...>% + { + x <<- x + 1L + } %>% wait_for_it() }) expect_identical(x, 2L) - }) }) diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index 9f2d722e..d441d3c9 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -5,22 +5,24 @@ source("common.R") describe("then()", { it("honors .visible argument", { result <- NULL - p <- promise(~resolve(invisible(1))) %>% then(function(value, .visible) { - result <<- list(value = value, visible = .visible) - }) + p <- promise(~ resolve(invisible(1))) %>% + then(function(value, .visible) { + result <<- list(value = value, visible = .visible) + }) p %>% wait_for_it() expect_identical(result$value, 1) expect_identical(result$visible, FALSE) - p <- promise(~resolve(1)) %>% then(function(value, .visible) { - result <<- list(value = value, visible = .visible) - }) + p <- promise(~ resolve(1)) %>% + then(function(value, .visible) { + result <<- list(value = value, visible = .visible) + }) p %>% wait_for_it() expect_identical(result$value, 1) expect_identical(result$visible, TRUE) # .visible is preserved even with an intermediate then() or catch() - p <- promise(~resolve(invisible(1))) %>% + p <- promise(~ resolve(invisible(1))) %>% then() %>% catch(~"what error?") %>% then(function(value, .visible) { @@ -31,7 +33,7 @@ describe("then()", { expect_identical(result$visible, FALSE) }) it("method ignores non-functions or NULL...", { - p1 <- promise(~resolve(1)) + p1 <- promise(~ resolve(1)) expect_error( { p1 <- p1$then(10) @@ -48,25 +50,23 @@ describe("then()", { expect_identical(extract(p1), 1) }) it("...but function only ignores NULL, not non-functions", { - expect_error(promise(~resolve(1)) %>% then(10)) - expect_error(promise(~resolve(1)) %>% then(NULL), NA) + expect_error(promise(~ resolve(1)) %>% then(10)) + expect_error(promise(~ resolve(1)) %>% then(NULL), NA) }) it("honors visibility with no .visible argument", { result <- NULL - p <- promise_resolve(invisible(1))$ - then(function(value) { - result <<- withVisible(value) - }) + p <- promise_resolve(invisible(1))$then(function(value) { + result <<- withVisible(value) + }) p %>% wait_for_it() expect_identical(result$value, 1) expect_identical(result$visible, FALSE) result <- NULL - p <- promise_resolve(2)$ - then(function(value) { - result <<- withVisible(value) - }) + p <- promise_resolve(2)$then(function(value) { + result <<- withVisible(value) + }) p %>% wait_for_it() expect_identical(result$value, 2) expect_identical(result$visible, TRUE) @@ -81,7 +81,7 @@ describe("catch()", { expect_identical(extract(p2), TRUE) }) it("can throw", { - p <- promise(~stop("foo")) %>% catch(~stop("bar")) + p <- promise(~ stop("foo")) %>% catch(~ stop("bar")) expect_error(extract(p), "^bar$") }) it("method ignores non-functions or NULL...", { @@ -102,54 +102,58 @@ describe("catch()", { expect_identical(extract(p1), 1) }) it("...but function only ignores NULL, not non-functions", { - expect_error(promise(~resolve(1)) %>% catch(10)) - expect_error(promise(~resolve(1)) %>% catch(NULL), NA) + expect_error(promise(~ resolve(1)) %>% catch(10)) + expect_error(promise(~ resolve(1)) %>% catch(NULL), NA) }) }) describe("finally()", { it("calls back when a promise is resolved", { called <- FALSE - p <- promise(~resolve(10)) %>% - finally(~{ - called <<- TRUE - }) + p <- promise(~ resolve(10)) %>% + finally( + ~ { + called <<- TRUE + } + ) p %>% wait_for_it() expect_identical(called, TRUE) expect_identical(extract(p), 10) }) it("calls back when a promise is rejected", { called <- FALSE - (p <- promise(~reject("foobar")) %>% - finally(~{ - called <<- TRUE - })) %>% + (p <- promise(~ reject("foobar")) %>% + finally( + ~ { + called <<- TRUE + } + )) %>% squelch_unhandled_promise_error() %>% wait_for_it() expect_identical(called, TRUE) expect_error(extract(p), "^foobar$") }) it("does not affect the return value of the promise", { - p1 <- promise(~resolve(1)) %>% finally(~20) + p1 <- promise(~ resolve(1)) %>% finally(~20) expect_identical(extract(p1), 1) - p2 <- promise(~reject("err")) %>% finally(~20) + p2 <- promise(~ reject("err")) %>% finally(~20) expect_error(extract(p2), "^err$") }) it("errors replace the result of the promise", { - p1 <- promise(~resolve(1)) %>% finally(~stop("boom")) + p1 <- promise(~ resolve(1)) %>% finally(~ stop("boom")) expect_error(extract(p1), "^boom$") - p2 <- promise(~reject("foo")) %>% finally(~stop("bar")) + p2 <- promise(~ reject("foo")) %>% finally(~ stop("bar")) expect_error(extract(p2), "^bar$") }) it("method ignores non-functions or NULL...", { - p1 <- promise(~resolve(1))$finally(10)$finally(NULL) + p1 <- promise(~ resolve(1))$finally(10)$finally(NULL) expect_identical(extract(p1), 1) }) it("...but function only ignores NULL, not non-functions", { - expect_error(promise(~resolve(1)) %>% finally(10)) - expect_error(promise(~resolve(1)) %>% finally(NULL), NA) + expect_error(promise(~ resolve(1)) %>% finally(10)) + expect_error(promise(~ resolve(1)) %>% finally(NULL), NA) }) }) diff --git a/tests/testthat/test-visibility.R b/tests/testthat/test-visibility.R index e3820ad0..2b919dfa 100644 --- a/tests/testthat/test-visibility.R +++ b/tests/testthat/test-visibility.R @@ -3,7 +3,6 @@ library(testthat) source("common.R") describe("visibility", { - single_fn <- function(value) { info <- withVisible(value) if (info$visible) { @@ -18,77 +17,94 @@ describe("visibility", { # display in block to avoid indent of doom for (add_catch in c("false", "single", "double", "expr")) { - for (add_finally in c("false", "expr")) { - for (add_then in c("false", "single", "double", "expr")) { - - it( - paste0( - "survives ", paste0(c( - if (add_then != "false") paste0("then-", add_then), - if (add_catch != "false") paste0("catch-", add_catch), - if (add_finally != "false") paste0("finally-", add_finally), - "then" - ), collapse = ", ")), - { - - p <- promise_resolve(invisible(1)) + for (add_finally in c("false", "expr")) { + for (add_then in c("false", "single", "double", "expr")) { + it( + paste0( + "survives ", + paste0( + c( + if (add_then != "false") paste0("then-", add_then), + if (add_catch != "false") paste0("catch-", add_catch), + if (add_finally != "false") paste0("finally-", add_finally), + "then" + ), + collapse = ", " + ) + ), + { + p <- promise_resolve(invisible(1)) - p <- - switch(add_then, - "false" = p, - "single" = p %>% then(single_fn), - "double" = p %>% then(double_fn), - "expr" = p %>% then(~ { - info <- withVisible(.) - if (info$visible) { - info$value - } else { - invisible(info$value) - } - }) - ) - p <- - switch(add_catch, - "false" = p, - "single" = p %>% catch(single_fn), - "double" = p %>% catch(double_fn), - "expr" = p %>% catch(~ {}) - ) + p <- + switch( + add_then, + "false" = p, + "single" = p %>% then(single_fn), + "double" = p %>% then(double_fn), + "expr" = p %>% + then( + ~ { + info <- withVisible(.) + if (info$visible) { + info$value + } else { + invisible(info$value) + } + } + ) + ) + p <- + switch( + add_catch, + "false" = p, + "single" = p %>% catch(single_fn), + "double" = p %>% catch(double_fn), + "expr" = p %>% + catch( + ~ { + } + ) + ) - finally_val <- NULL - p <- - switch(add_finally, - "false" = p, - "expr" = p %>% finally(~ { - finally_val <<- TRUE - }) - ) + finally_val <- NULL + p <- + switch( + add_finally, + "false" = p, + "expr" = p %>% + finally( + ~ { + finally_val <<- TRUE + } + ) + ) - extended_val <- - p %>% - then(function(value, .visible) { - list(value = value, visible = .visible) - }) %>% - extract() + extended_val <- + p %>% + then(function(value, .visible) { + list(value = value, visible = .visible) + }) %>% + extract() - regular_val <- - p %>% - then(function(value) { - withVisible(value) - }) %>% - extract() + regular_val <- + p %>% + then(function(value) { + withVisible(value) + }) %>% + extract() - if (add_finally != "false") { - expect_true(finally_val) - } + if (add_finally != "false") { + expect_true(finally_val) + } - expect_identical(extended_val$value, 1) - expect_identical(extended_val$visible, FALSE) - - expect_identical(regular_val$value, 1) - expect_identical(regular_val$visible, FALSE) + expect_identical(extended_val$value, 1) + expect_identical(extended_val$visible, FALSE) + expect_identical(regular_val$value, 1) + expect_identical(regular_val$visible, FALSE) + } + ) } - ) - }}} + } + } }) diff --git a/tests/testthat/test-zzz-future_promise.R b/tests/testthat/test-zzz-future_promise.R index 4243bcdf..9c44df1c 100644 --- a/tests/testthat/test-zzz-future_promise.R +++ b/tests/testthat/test-zzz-future_promise.R @@ -14,12 +14,16 @@ local({ with_test_workers <- function(code) { # (Can not use a variable for workers if in a local({})) old_plan <- future::plan(future::multisession(workers = 2)) - on.exit({future::plan(old_plan)}, add = TRUE) + on.exit( + { + future::plan(old_plan) + }, + add = TRUE + ) force(code) } - start <- Sys.time() time_diffs <- c() @@ -40,10 +44,14 @@ local({ if (i > max) return() time_diffs <<- c(time_diffs, time_diff()) # Do it again, later - later::later(function() { run_every(i + 1, max = max, delay = delay) }, delay = delay) + later::later( + function() { + run_every(i + 1, max = max, delay = delay) + }, + delay = delay + ) } - worker_jobs <- 8 # allow for more time on CI (4s on CI vs 1s locally) worker_job_time <- if (on_ci) 4 else 1 @@ -60,11 +68,14 @@ local({ # expect `run_every()` delay to be < 1s (Expected 0.1s) expect_no_main_blocking = TRUE ) { - with_test_workers({ # prep future sessions - f1 <- future::future({1}) - f2 <- future::future({2}) + f1 <- future::future({ + 1 + }) + f2 <- future::future({ + 2 + }) c(future::value(future::resolve(f1)), future::value(future::resolve(f2))) expect_true(future_worker_is_free()) @@ -83,9 +94,10 @@ local({ future::future({ Sys.sleep(worker_job_time) time_diff() - }) %...>% { - future_exec_times <<- c(future_exec_times, .) - } + }) %...>% + { + future_exec_times <<- c(future_exec_times, .) + } }, delay = 1 ) @@ -99,7 +111,8 @@ local({ time_diff() }) }) %>% - promise_all(.list = .) %...>% { + promise_all(.list = .) %...>% + { exec_times <<- unlist(.) } post_lapply_time_diff <- time_diff() @@ -111,21 +124,28 @@ local({ # expect prom_fn to take a reasonable amount of time to finish exec_times_lag <- exec_times[-1] - exec_times[-length(exec_times)] - expect_equal(all(exec_times_lag < (2 * worker_job_time)), expect_reasonable_exec_lag_time) + expect_equal( + all(exec_times_lag < (2 * worker_job_time)), + expect_reasonable_exec_lag_time + ) # post_lapply_time_diff should be ~ 0s - expect_equal(post_lapply_time_diff < (worker_job_time * ((worker_jobs - n_workers) / n_workers)), expect_immediate_lapply) + expect_equal( + post_lapply_time_diff < + (worker_job_time * ((worker_jobs - n_workers) / n_workers)), + expect_immediate_lapply + ) # time_diffs should never grow by more than 1s; (Expected 0.1) time_diffs_lag <- time_diffs[-1] - time_diffs[-length(time_diffs)] - expect_equal(all(time_diffs_lag < worker_job_time), expect_no_main_blocking) + expect_equal( + all(time_diffs_lag < worker_job_time), + expect_no_main_blocking + ) }) - } - test_that("future_promise() allows the main thread to keep the main R process open", { - do_future_test( prom_fn = future_promise, # expect that the average finish lag time is less than 2 * n_time @@ -137,7 +157,6 @@ local({ ) }) - test_that("future::future() does not keep the main process open when all workers are busy", { do_future_test( prom_fn = future::future, @@ -150,9 +169,7 @@ local({ ) }) - test_that("future_promise() recovers from losing all future workers", { - do_future_test( prom_fn = future_promise, block_mid_session = TRUE, @@ -169,7 +186,7 @@ local({ test_that("future_promise reports unhandled errors", { with_test_workers({ - err <- capture.output(type="message", { + err <- capture.output(type = "message", { future_promise(stop("boom1")) wait_for_it() }) @@ -179,9 +196,12 @@ local({ test_that("future_promise doesn't report errors that have been handled", { with_test_workers({ - err <- capture.output(type="message", { + err <- capture.output(type = "message", { future_promise(stop("boom1")) %>% - then(onRejected = ~{}) %>% + then( + onRejected = ~ { + } + ) %>% wait_for_it() }) expect_equal(err, character(0)) diff --git a/vignettes/future_promise/plots.R b/vignettes/future_promise/plots.R index 9654d870..058eb68a 100644 --- a/vignettes/future_promise/plots.R +++ b/vignettes/future_promise/plots.R @@ -46,7 +46,7 @@ waiting_line <- function(x, y, group = y) { } save_image <- function(p, file, height = 4, width = 6, ...) { - p <- p + theme(aspect.ratio = 100/150) + p <- p + theme(aspect.ratio = 100 / 150) ggsave(file, p, height = height, width = NA, ...) } @@ -92,7 +92,8 @@ status_guide <- function(waiting = TRUE, promise = FALSE) { working = "solid" ), breaks = c(if (waiting) "waiting", "working"), - labels = if (promise) c("Waiting in promise", "Working in future") else c(if (waiting) "Waiting", "Working"), + labels = if (promise) c("Waiting in promise", "Working in future") else + c(if (waiting) "Waiting", "Working"), guide = guide_legend( order = 3, override.aes = list( @@ -153,8 +154,8 @@ p <- y = c("b", "b", "c", "c") ) + waiting_line( - x = c(0, 10, 0, 20), - y = c("c", "c", "d", "d") + x = c(0, 10, 0, 20), + y = c("c", "c", "d", "d") ) + route_type_guide(NULL, letters[1:4]) + scale_y_discrete( @@ -193,14 +194,12 @@ p <- save_image(p, "images/timing-plumber-future.png") - - p <- ggplot(mapping = aes(x = x, y = y, color = y)) + receive_point(letters[2:6]) + return_point( - x = c(10, 10, 20, 20, 0), - y = letters[2:6] + x = c(10, 10, 20, 20, 0), + y = letters[2:6] ) + working_line( x = c(0, 10, 0, 10, 10, 20, 10, 20), @@ -221,14 +220,18 @@ p <- save_image(p, "images/timing-plumber-limitation.png") - - - - future_constants <- list( scale_y_discrete( limits = rev(letters[1:7]), - labels = c("/fast/7", "/slow/6", "/slow/5", "/slow/4", "/slow/3", "/slow/2", "/slow/1") + labels = c( + "/fast/7", + "/slow/6", + "/slow/5", + "/slow/4", + "/slow/3", + "/slow/2", + "/slow/1" + ) ), constants[c(-2)], theme( @@ -246,23 +249,37 @@ p <- ) + waiting_line( x = c( - 10, 20, - 10, 20, - 0, 10,# 20, 30, - 0, 10,# 20, 30, - 0, 20, - 0, 20, - 0, 20 + 10, + 20, + 10, + 20, + 0, + 10, # 20, 30, + 0, + 10, # 20, 30, + 0, + 20, + 0, + 20, + 0, + 20 ), y = rep(letters[1:7], c(2, 2, 2, 2, 2, 2, 2)), group = c( - "a2", "a2", - "b2", "b2", - "c1", "c1", #"c2", "c2", - "d1", "d1", #"d2", "d2", - "e1", "e1", - "f1", "f1", - "g1", "g1" + "a2", + "a2", + "b2", + "b2", + "c1", + "c1", #"c2", "c2", + "d1", + "d1", #"d2", "d2", + "e1", + "e1", + "f1", + "f1", + "g1", + "g1" ) ) + working_line( @@ -298,17 +315,25 @@ p <- mapping = aes(group = group, linetype = linetype), data = data.frame( x = c( - 0, 10, - 0, 10, - 0, 20, - 0, 20 + 0, + 10, + 0, + 10, + 0, + 20, + 0, + 20 ), y = rep(c("c", "d", "e", "f"), each = 2), group = c( - "c1", "c1", - "d1", "d1", - "e1", "e1", - "f1", "f1" + "c1", + "c1", + "d1", + "d1", + "e1", + "e1", + "f1", + "f1" ), linetype = "waiting" )