handle regular number, NA and NaN in comparison<REALSXP>. closes tidy…

…verse#275

R/RcppExports.R

@@ -157,6 +157,10 @@ summarise_impl <- function(df, args, env) {
     .Call('dplyr_summarise_impl', PACKAGE = 'dplyr', df, args, env)
 }
 
+test_comparisons <- function() {
+    .Call('dplyr_test_comparisons', PACKAGE = 'dplyr')
+}
+
 #' Cumulativate versions of any, all, and mean
 #'
 #' dplyr adds \code{cumall}, \code{cumany}, and \code{cummean} to complete

inst/include/dplyr/comparisons.h

@@ -64,28 +64,59 @@ struct comparisons<STRSXP> {
 // taking advantage of the particularity of NA_REAL
 template <>
 struct comparisons<REALSXP> {
+
     inline bool is_less(double lhs, double rhs) const {
-        bool res = is_na(rhs) || lhs < rhs ;
-        return res ;
+        if( is_nan(lhs) ) {
+            return false ;
+        } else if( is_na(lhs) ){
+            return is_nan(rhs) ;    
+        } else {
+            // lhs >= rhs is false if rhs is NA or NaN
+            return !( lhs >= rhs) ;
+        }
+
     }
 
     inline bool is_greater(double lhs, double rhs) const {
-        bool res = is_na(rhs) || lhs > rhs ;
-        return res ;
+        if( is_nan(lhs) ) {
+            return false ;
+        } else if( is_na(lhs) ){
+            return is_nan(rhs) ;    
+        } else {
+            // lhs <= rhs is false if rhs is NA or NaN
+            return !( lhs <= rhs) ;
+        }
+
     }
 
     inline bool is_equal(double lhs, double rhs ) const {
         return lhs == rhs ;    
     }
 
     inline bool equal_or_both_na( double lhs, double rhs ) const {
-        return lhs == rhs || ( is_na(lhs) && is_na(rhs) );    
+        return lhs == rhs ||
+            ( is_nan(lhs) && is_nan(rhs) ) ||
+            ( is_na(lhs) && is_na(rhs) );    
     }
 
     inline bool is_na(double x) const { 
-        return Rcpp::traits::is_na<REALSXP>(x); 
+        return ISNA(x); 
+    }
+
+    inline bool is_nan(double x) const {
+        return Rcpp::traits::is_nan<REALSXP>(x) ;    
+    }
+
+    inline void print(double x) const {
+        if( is_na(x) ) {
+            std::cout << "NA" ;
+        } else if( is_nan(x) ) {
+            std::cout << "NaN" ;
+        } else {
+            std::cout << x ;    
+        }
     }
-
+    
 } ;
 
 

inst/tests/test-internals.r

@@ -0,0 +1,7 @@
+context("internals")
+
+test_that("comparisons<REALSXP> works as expected (#275)", {
+  res <- test_comparisons()
+  expect_true( all(res) )  
+})
+

src/RcppExports.cpp

@@ -585,6 +585,20 @@ BEGIN_RCPP
     return __sexp_result;
 END_RCPP
 }
+// test_comparisons
+LogicalVector test_comparisons();
+RcppExport SEXP dplyr_test_comparisons() {
+BEGIN_RCPP
+    SEXP __sexp_result;
+    {
+        Rcpp::RNGScope __rngScope;
+        LogicalVector __result = test_comparisons();
+        PROTECT(__sexp_result = Rcpp::wrap(__result));
+    }
+    UNPROTECT(1);
+    return __sexp_result;
+END_RCPP
+}
 // cumall
 LogicalVector cumall(LogicalVector x);
 RcppExport SEXP dplyr_cumall(SEXP xSEXP) {

src/test.cpp

@@ -0,0 +1,20 @@
+#include <dplyr.h>
+
+using namespace Rcpp ;
+using namespace dplyr ;
+
+// [[Rcpp::export]]
+LogicalVector test_comparisons(){
+    dplyr::comparisons<REALSXP> comp ;
+    return LogicalVector::create( 
+        comp.is_less( 1.0, 2.0 ),
+        !comp.is_less( 2.0, 1.0 ),
+        comp.is_less( NA_REAL, R_NaN ),
+        ! comp.is_less( R_NaN, NA_REAL),
+        ! comp.is_less( NA_REAL, 1.0 ), 
+        ! comp.is_less( R_NaN, 1.0 ), 
+        comp.is_less( 1.0, NA_REAL ), 
+        comp.is_less( 1.0, R_NaN )
+        ) ;
+}
+