Permalink
Browse files

fixes # 158 by evaluating the .expr parameter and calling it one time…

… less if it actually is an expression and not a function
  • Loading branch information...
1 parent 67a818d commit fc312e1547759e26d1da46b9a1c2f1029466f916 @krlmlr krlmlr committed Oct 24, 2013
Showing with 224 additions and 39 deletions.
  1. +4 −16 R/r_ply.r
  2. +2 −7 R/raply.r
  3. +2 −7 R/rdply.r
  4. +75 −9 R/rlply.r
  5. +141 −0 inst/tests/test-rply.r
View
@@ -19,20 +19,8 @@
#' r_ply(10, plot(runif(50)))
#' r_ply(25, hist(runif(1000)))
r_ply <- function(.n, .expr, .progress = "none", .print = FALSE) {
- if (is.function(.expr)) {
- f <- .expr
- } else {
- f <- eval.parent(substitute(function() .expr))
- }
-
- progress <- create_progress_bar(.progress)
-
- progress$init(.n)
- on.exit(progress$term())
-
- for(i in seq_len(.n)) {
- f()
- progress$step()
- }
- progress$term()
+ .rlply_worker(.n, .progress,
+ eval.parent(substitute(function() .expr)),
+ .discard = TRUE, .print = .print)
+ invisible(NULL)
}
View
@@ -30,12 +30,7 @@
#' hist(raply(1000, mean(rexp(100))))
#' hist(raply(1000, mean(rexp(1000))))
raply <- function(.n, .expr, .progress = "none", .drop = TRUE) {
- if (is.function(.expr)) {
- f <- .expr
- } else {
- f <- eval.parent(substitute(function() .expr))
- }
-
- res <- rlply(.n = .n, .expr = f, .progress = .progress)
+ res <- .rlply_worker(.n, .progress,
+ eval.parent(substitute(function() .expr)))
list_to_array(res, NULL, .drop)
}
View
@@ -25,13 +25,8 @@
#' rdply(20, each(mean, var)(runif(100)))
#' rdply(20, data.frame(x = runif(2)))
rdply <- function(.n, .expr, .progress = "none", .id = ".n") {
- if (is.function(.expr)) {
- f <- .expr
- } else {
- f <- eval.parent(substitute(function() .expr))
- }
-
- res <- rlply(.n = .n, .expr = f, .progress = .progress)
+ res <- .rlply_worker(.n, .progress,
+ eval.parent(substitute(function() .expr)))
names(res) <- seq_len(.n)
list_to_dataframe(res, idname = .id)
}
View
@@ -21,22 +21,88 @@
#' mods <- rlply(100, lm(y ~ x, data=data.frame(x=rnorm(100), y=rnorm(100))))
#' hist(laply(mods, function(x) summary(x)$r.squared))
rlply <- function(.n, .expr, .progress = "none") {
- if (is.function(.expr)) {
- f <- .expr
- } else {
- f <- eval.parent(substitute(function() .expr))
- }
+ res <- .rlply_worker(.n, .progress,
+ eval.parent(substitute(function() .expr)))
+ res
+}
+
+.rlply_worker <- function(.n, .progress, .expr_wrap, .print = FALSE,
+ .discard = FALSE) {
+ if (!is.vector(.n, "numeric") || length(.n) > 1L)
+ stop(".n must be an integer vector of length 1")
+ if (.n == 0L)
+ return (list())
progress <- create_progress_bar(.progress)
- result <- vector("list", length = .n)
progress$init(.n)
on.exit(progress$term())
- for(i in seq_len(.n)) {
- result[i] <- list(f())
+ if (.print) {
+ wrap <- function(f) function() { print(f()) }
+ } else {
+ wrap <- identity
+ }
+
+ # The logic below is responsible for ascertaining that .expr is evaluated
+ # exactly .n times, whether it's a function or an expression. (See GitHub
+ # issue #158.) When the function .rlply_worker is called, the .expr_wrap
+ # argument is a function that returns the .expr argument passed to the calling
+ # r*ply function. The .wrapped_expr_to_fun function will convert the
+ # .expr_wrap argument to a list that contains a function and the result of the
+ # first evaluation, which is necessary because there seems to be no other way
+ # to find out if .expr is a function or an expression without evaluating it at
+ # least once. After that, only .n - 1 further evaluations are necessary.
+ #
+ # In addition, results are printed and/or discareded depending on the `wrap`
+ # function defined above.
+ fun <- .wrapped_expr_to_fun(.expr_wrap)
+ f <- wrap(fun$f)
+
+ if (.discard) {
+ wrap(function() fun$val)()
progress$step()
+
+ for(i in seq.int(from = 2L, length.out = .n - 1L)) {
+ f()
+ progress$step()
+ }
+
+ invisible(NULL)
+ } else {
+ result <- vector("list", length = .n)
+ result[1L] <- list(wrap(function() fun$val)())
+ progress$step()
+
+ for(i in seq.int(from = 2L, length.out = .n - 1L)) {
+ result[i] <- list(f())
+ progress$step()
+ }
+
+ result
}
+}
- result
+#' r*ply helper function
+#'
+#' Call a function to check if the result is a function or an expression, to
+#' support expressions as arguments to the r*ply family.
+#'
+#' @param .expr_wrap function to call
+#' @return named list with two components. f -- function, val -- result of first
+#' evaluation
+.wrapped_expr_to_fun <- function(.expr_wrap) {
+ # When .expr_wrap is evaluated, it will return either a function or an
+ # expression. In the first case, this function is assigned to the f
+ # component, and also called once explicitly to assign the val component. In
+ # the second case, this has been already the first evaluation of .expr -- the
+ # parameter wrapped by .expr_wrap; the results are reused for the val
+ # component, and the wrapped function is assigned to f.
+ res <- .expr_wrap()
+
+ if (is.function(res)) {
+ list(f = res, val = res())
+ } else {
+ list(f = .expr_wrap, val = res)
+ }
}
View
@@ -0,0 +1,141 @@
+context("r?ply")
+
+test_that("Side effects for r_ply", {
+ counts <- c(0, 1, 5)
+
+ # Simple function with side effect of incrementing i in an outer environment
+ # by one
+ inc <- function() { i <<- i + 1; invisible(NULL) }
+
+ # For each of the possible counts, check that exactly n side effects are seen
+ # for various types of invocations of inc: As a statement, as a function call
+ # or as a function calling the function. Calling r_ply with a function that
+ # returns the inc function should not produce any side effects, this is
+ # intentional.
+ for (n in counts) {
+ i <- 0
+ r_ply(n, inc)
+ expect_equal(i, n, info="inc")
+
+ i <- 0
+ r_ply(n, inc())
+ expect_equal(i, n, info="inc()")
+
+ i <- 0
+ r_ply(n, inc() + inc())
+ expect_equal(i, 2 * n, info="inc() + inc()")
+
+ i <- 0
+ r_ply(n, function() inc())
+ expect_equal(i, n, info="function() inc()")
+
+ i <- 0
+ r_ply(n, function() inc() + inc())
+ expect_equal(i, 2 * n, info="function() inc() + inc()")
+
+ i <- 0
+ r_ply(n, function() inc)
+ expect_equal(i, 0, info="function() inc")
+ }
+})
+
+test_that("Side effects for rlply", {
+ counts <- c(0, 1, 5)
+
+ # Similar to the test for r_ply, now there is also a return value in incition
+ # to the side effect
+ inc <- function() { i <<- i + 1 }
+
+ # The test now checks, in incition to side effect count, that the returned
+ # list is correct
+ for (n in counts) {
+ i <- 0
+ res <- rlply(n, inc)
+ expect_equal(res, as.list(seq_len(n)), info="inc")
+ expect_equal(i, n, info="inc")
+
+ i <- 0
+ res <- rlply(n, inc())
+ expect_equal(res, as.list(seq_len(n)), info="inc()")
+ expect_equal(i, n, info="inc()")
+
+ i <- 0
+ res <- rlply(n, function() inc())
+ expect_equal(res, as.list(seq_len(n)), info="function() inc()")
+ expect_equal(i, n, info="function() inc()")
+
+ # Funny case: A function that returns a function, this is not
+ # handled at all
+ i <- 0
+ rlply(n, function() inc)
+ expect_equal(i, 0, info="function() inc")
+ }
+})
+
+test_that("Side effects for raply", {
+ counts <- c(0, 1, 5)
+
+ inc <- function() { i <<- i + 1 }
+
+ for (n in counts) {
+ # This is funny. Why does raply(.n, inc) return a named vector only for
+ # .n == 1?
+ if (n == 0) {
+ exp_res <- logical()
+ } else if (n == 1) {
+ exp_res <- setNames(nm = 1)
+ } else
+ exp_res <- seq_len(n)
+
+ i <- 0
+ res <- raply(n, inc)
+ expect_equal(res, exp_res, info="inc")
+ expect_equal(i, n, info="inc")
+
+ i <- 0
+ res <- raply(n, inc())
+ expect_equal(res, exp_res, info="inc()")
+ expect_equal(i, n, info="inc()")
+
+ i <- 0
+ res <- raply(n, function() inc())
+ expect_equal(res, exp_res, info="function() inc()")
+ expect_equal(i, n, info="function() inc()")
+ }
+})
+
+test_that("Side effects for rdply", {
+ counts <- c(0, 1, 5)
+
+ inc <- function() { i <<- i + 1; data.frame(i = i) }
+
+ for (n in counts) {
+ if (n == 0) {
+ exp_res <- data.frame()
+ } else {
+ exp_res <- data.frame(.n = 1L:n, i = 1L:n)
+ }
+
+ i <- 0
+ res <- rdply(n, inc)
+ expect_equal(res, exp_res, info="inc")
+ expect_equal(i, n, info="inc")
+
+ i <- 0
+ res <- rdply(n, inc())
+ expect_equal(res, exp_res, info="inc()")
+ expect_equal(i, n, info="inc()")
+
+ i <- 0
+ res <- rdply(n, function() inc())
+ expect_equal(res, exp_res, info="function() inc()")
+ expect_equal(i, n, info="function() inc()")
+ }
+})
+
+test_that("Invalid arguments for r_ply", {
+ expect_error(r_ply(-3, identity))
+ expect_error(r_ply("abc", identity))
+ expect_error(r_ply(c(1,2), identity))
+ expect_error(r_ply(list(5), identity))
+})

0 comments on commit fc312e1

Please sign in to comment.