Hybrid tests (tidyverse#2306)

* with_hybrid(), without_hybrid(), eval_dots(), expectations, and machinery

- use f_capture()

- special-case enclosing list() call

* add various hybrid tests

- test n() and n_distinct()

- improve %in% tests

- test min() and max()

- test first(), last(), and nth()

- improve nth() tests

- test lead() and lag()

- test mean(), var(), sd() and sum()

- test row_number(), ntile(), min_rank(), percent_rank(), dense_rank(), and cume_dist()

- test complex numbers

- test call matching

- constfold-related test

- test nesting of hybrid handlers

- add failing test

* ntile() returns integer

* improve nth()

use typeof() instead of class()

keep treating n as numeric, it is a numeric anyway after trunc()

* add expect_error()

* skip failing tests

* failing on Windows

* add common use case for n()

* NEWS

DESCRIPTION

@@ -74,6 +74,7 @@ Collate:
     'group-indices.R'
     'group-size.r'
     'grouped-df.r'
+    'hybrid.R'
     'id.r'
     'if_else.R'
     'inline.r'

NEWS.md

@@ -1,5 +1,7 @@
 # dplyr 0.5.0.9000
 
+* Regular implementations of `nth()` and `ntile()` are more careful about proper data types of their return values (#2306).
+
 * Breaking change: The new `.data` and `.env` environments can be used inside all verbs that operate on data: `.data$column_name` accesses the column `column_name`, whereas `.env$var` accesses the external variable `var`. Columns or external variables named `.data` or `.env` are shadowed, use `.data$...` and/or `.env$...` to access them.
 
 * Breaking change: The `column()` and `global()` functions have been removed. They were never documented officially. Use the new `.data` and `.env` environments instead.

R/hybrid.R

@@ -0,0 +1,50 @@
+verify_hybrid <- function(x) {
+  stop("Not in hybrid evaluation", call. = FALSE)
+}
+
+verify_not_hybrid <- function(x) {
+  x
+}
+
+with_hybrid <- function(expr, ...) {
+  with_hybrid_(lazyeval::f_capture(expr), ...)
+}
+
+with_hybrid_ <- function(expr, ...) {
+  stopifnot(any(class(expr) == "formula"))
+  expr[[2]] <- prepend_call(expr[[2]], "verify_hybrid")
+  data <- data_frame(...)
+  summarise_(data, out = expr)["out"][[1]]
+}
+
+without_hybrid <- function(expr, ...) {
+  .dots <- lazyeval::lazy_dots(out = expr)[[1]]
+  without_hybrid_(lazyeval::f_new(.dots$expr, env = .dots$env), ...)
+}
+
+without_hybrid_ <- function(expr, ...) {
+  stopifnot(any(class(expr) == "formula"))
+  expr[[2]] <- prepend_call(expr[[2]], "verify_not_hybrid")
+  data <- data_frame(...)
+  summarise_(data, out = expr)["out"][[1]]
+}
+
+eval_dots <- function(expr, ...) {
+  eval_dots_(lazyeval::f_capture(expr), ...)
+}
+
+eval_dots_ <- function(expr, ...) {
+  data <- data_frame(...)
+  eval(expr[[2]], data, enclos = environment(expr))
+}
+
+# some(func()) -> name(some(func()))
+# list(some(func())) -> list(name(some(func())))
+prepend_call <- function(expr, name) {
+  if (is.call(expr) && expr[[1]] == quote(list)) {
+    stopifnot(length(expr) == 2L)
+    call("list", call(name, expr[[2]]))
+  } else {
+    call(name, expr)
+  }
+}

R/nth-value.R

@@ -35,7 +35,11 @@ nth <- function(x, n, order_by = NULL, default = default_missing(x)) {
   n <- trunc(n)
 
   if (n == 0 || n > length(x) || n < -length(x)) {
-    return(default)
+    if (is.list(x)) {
+      return(default)
+    } else {
+      return(as.vector(default, typeof(x)))
+    }
   }
 
   # Negative values index from RHS
@@ -46,7 +50,7 @@ nth <- function(x, n, order_by = NULL, default = default_missing(x)) {
   if (is.null(order_by)) {
     x[[n]]
   } else {
-    x[[order(order_by)[n]]]
+    x[[ order(order_by)[[n]] ]]
   }
 }
 

R/rank.R

@@ -51,7 +51,7 @@ row_number <- function(x) rank(x, ties.method = "first", na.last = "keep")
 #' @export
 #' @rdname ranking
 ntile <- function(x, n) {
-  floor((n * (row_number(x) - 1) / length(x)) + 1)
+  as.integer(floor((n * (row_number(x) - 1) / length(x)) + 1))
 }
 
 #' @export

inst/include/dplyr/HybridHandlerMap.h

@@ -13,6 +13,7 @@ void install_nth_handlers(HybridHandlerMap& handlers);
 void install_window_handlers(HybridHandlerMap& handlers);
 void install_offset_handlers(HybridHandlerMap& handlers);
 void install_in_handlers(HybridHandlerMap& handlers);
+void install_debug_handlers(HybridHandlerMap& handlers);
 
 bool hybridable(RObject arg);
 

src/hybrid.cpp

@@ -76,6 +76,7 @@ HybridHandlerMap& get_handlers() {
     install_window_handlers(handlers);
     install_offset_handlers(handlers);
     install_in_handlers(handlers);
+    install_debug_handlers(handlers);
   }
   return handlers;
 }

src/hybrid_debug.cpp

@@ -0,0 +1,92 @@
+#include <dplyr/main.h>
+
+#include <dplyr/HybridHandlerMap.h>
+
+#include <dplyr/Result/ILazySubsets.h>
+
+#include <dplyr/Result/Result.h>
+
+using namespace Rcpp;
+using namespace dplyr;
+
+
+class VerifyHybrid : public Result {
+public:
+  VerifyHybrid(SEXP x_) : x(x_) {}
+
+public:
+  SEXP process(const RowwiseDataFrame&) {
+    return x;
+  }
+
+  SEXP process(const GroupedDataFrame&) {
+    return x;
+  }
+
+  SEXP process(const FullDataFrame&) {
+    return x;
+  }
+
+  SEXP process(const SlicingIndex&) {
+    return x;
+  }
+
+private:
+  RObject x;
+};
+
+Result* verify_hybrid_prototype(SEXP call, const ILazySubsets& subsets, int nargs) {
+  // if not exactly one arg, let R handle it
+  if (nargs != 1)
+    return 0;
+
+  // if it isn't a constant, let R handle it
+  SEXP arg = CADR(call);
+  if (TYPEOF(arg) == SYMSXP || TYPEOF(arg) == LANGSXP)
+    return 0;
+
+  return new VerifyHybrid(arg);
+}
+
+class VerifyNotHybrid : public Result {
+public:
+  VerifyNotHybrid(SEXP x_) : x(x_) {}
+
+public:
+  SEXP process(const RowwiseDataFrame&) {
+    stop("In hybrid evaluation");
+  }
+
+  SEXP process(const GroupedDataFrame&) {
+    stop("In hybrid evaluation");
+  }
+
+  SEXP process(const FullDataFrame&) {
+    stop("In hybrid evaluation");
+  }
+
+  SEXP process(const SlicingIndex&) {
+    stop("In hybrid evaluation");
+  }
+
+private:
+  RObject x;
+};
+
+Result* verify_not_hybrid_prototype(SEXP call, const ILazySubsets& subsets, int nargs) {
+  // if not exactly one arg, let R handle it
+  if (nargs != 1)
+    return 0;
+
+  // if it isn't a constant, let R handle it
+  SEXP arg = CADR(call);
+  if (TYPEOF(arg) == SYMSXP || TYPEOF(arg) == LANGSXP)
+    return 0;
+
+  return new VerifyNotHybrid(arg);
+}
+
+void install_debug_handlers(HybridHandlerMap& handlers) {
+  handlers[ Rf_install("verify_hybrid") ] = verify_hybrid_prototype;
+  handlers[ Rf_install("verify_not_hybrid") ] = verify_not_hybrid_prototype;
+}

tests/testthat/helper-hybrid.R

@@ -0,0 +1,41 @@
+check_hybrid_result <- function(expr, ..., expected, test_eval = TRUE) {
+  check_hybrid_result_(lazyeval::f_capture(expr), ..., expected = expected, test_eval = test_eval)
+}
+
+check_hybrid_result_ <- function(expr, ..., expected, test_eval) {
+  expect_error(expect_identical(with_hybrid_(expr, ...), expected), NA)
+  if (test_eval) {
+    expect_identical(eval_dots_(expr, ...), expected)
+  }
+}
+
+check_not_hybrid_result <- function(expr, ..., expected, test_eval = TRUE) {
+  check_not_hybrid_result_(lazyeval::f_capture(expr), ..., expected = expected, test_eval = test_eval)
+}
+
+check_not_hybrid_result_ <- function(expr, ..., expected, test_eval) {
+  expect_error(expect_identical(without_hybrid_(expr, ...), expected), NA)
+  if (test_eval) {
+    expect_identical(eval_dots_(expr, ...), expected)
+  }
+}
+
+expect_hybrid_error <- function(expr, ..., error) {
+  expect_hybrid_error_(lazyeval::f_capture(expr), ..., error = error)
+}
+
+expect_hybrid_error_ <- function(expr, ..., error) {
+  expect_error(
+    with_hybrid_(expr, ...),
+    error)
+}
+
+expect_not_hybrid_error <- function(expr, ..., error) {
+  expect_not_hybrid_error_(lazyeval::f_capture(expr), ..., error = error)
+}
+
+expect_not_hybrid_error_ <- function(expr, ..., error) {
+  expect_error(
+    without_hybrid_(expr, ...),
+    error)
+}