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

… less if it actually is an expression and not a function

R/r_ply.r

@@ -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)
 }

R/raply.r

@@ -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)
 }

R/rdply.r

@@ -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)
 }

R/rlply.r

@@ -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)
+  }
 }

inst/tests/test-rply.r

@@ -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))
+})