Work around match issues in R 3.3.0

by @krlmlr. Closes tidyverse#1810.
chriscorb · May 26, 2016 · 7168759 · 7168759
1 parent 1defb3b
commit 7168759
Show file tree

Hide file tree

Showing 7 changed files with 30 additions and 10 deletions.
diff --git a/inst/include/dplyr.h b/inst/include/dplyr.h
@@ -58,10 +58,6 @@ namespace dplyr {
     DataFrame subset( DataFrame df, const Index& indices, CharacterVector classes) ;
     void check_attribute_compatibility( SEXP left, SEXP right) ;
     bool same_levels( SEXP left, SEXP right ) ;
-
-    inline IntegerVector r_match( SEXP x, SEXP y) {
-      return Language( "match", x, y ).fast_eval() ;
-    }
 }
 dplyr::Result* get_handler( SEXP, const dplyr::LazySubsets&, const Environment& ) ;
 dplyr::Result* nth_prototype( SEXP call, const dplyr::LazySubsets& subsets, int nargs) ;

diff --git a/inst/include/tools/SymbolMap.h b/inst/include/tools/SymbolMap.h
@@ -16,7 +16,7 @@ namespace dplyr{
 
     class SymbolMap {
         public:
-            SymbolMap(): lookup(), r_match( "match" ), names(){}
+            SymbolMap(): lookup(), names(){}
 
             SymbolMapIndex insert( SEXP name ){
                 if( TYPEOF(name) == SYMSXP ) {
@@ -117,7 +117,6 @@ namespace dplyr{
 
 
             dplyr_hash_map<SEXP, int> lookup ;
-            Function r_match ;
             CharacterVector names ;
 
     } ;

diff --git a/inst/include/tools/match.h b/inst/include/tools/match.h
@@ -0,0 +1,25 @@
+#ifndef dplyr_tools_match_h
+#define dplyr_tools_match_h
+
+
+namespace dplyr {
+
+class RMatch {
+public:
+  RMatch() : match_fun("match", R_BaseEnv) {}
+  IntegerVector operator()(SEXP x, SEXP y) {
+    return match_fun(x, y, NA_INTEGER, CharacterVector());
+  }
+
+private:
+  Function match_fun;
+};
+
+inline IntegerVector r_match( SEXP x, SEXP y ) {
+  static RMatch m;
+  return m(x, y);
+}
+
+};
+
+#endif
diff --git a/inst/include/tools/tools.h b/inst/include/tools/tools.h
@@ -2,6 +2,7 @@
 #define dplyr_tools_tools_H
 
 #include <tools/Encoding.h>
+#include <tools/match.h>
 #include <tools/SymbolMap.h>
 #include <tools/StringUTF8.h>
 #include <tools/complex.h>

diff --git a/src/dplyr.cpp b/src/dplyr.cpp
@@ -1208,8 +1208,7 @@ SEXP resolve_vars( List new_groups, CharacterVector names){
     }
     // check that s is indeed in the data
 
-    Function match( "match" ) ;
-    int pos = as<int>(match( CharacterVector::create(PRINTNAME(s)), names));
+    int pos = as<int>(r_match( CharacterVector::create(PRINTNAME(s)), names ));
     if( pos == NA_INTEGER){
       stop("unknown variable to group by : %s", CHAR(PRINTNAME(s))) ;
     }

diff --git a/tests/testthat/test-group-by.r b/tests/testthat/test-group-by.r
@@ -240,6 +240,6 @@ test_that( "group_by supports column (#1012)", {
 test_that("group_by handles encodings (#1507)", {
   df <- data.frame(x=1:3, Eng=2:4)
   names(df) <- enc2utf8(c("\u00e9", "Eng"))
-  res <- group_by_(df, iconv("\u00e9", to = "latin1") )
+  res <- group_by_(df, iconv("\u00e9", from = "UTF-8", to = "latin1") )
   expect_equal( names(res), names(df) )
 })
diff --git a/tests/testthat/test-joins.r b/tests/testthat/test-joins.r
@@ -588,7 +588,7 @@ test_that( "left_join handles mix of encodings in column names (#1571)", {
   names(df1)[1] <- "l\u00f8penummer"
 
   df2 <- tibble::data_frame(x = 1:6, baz = 1:6)
-  names(df2)[1] <- iconv(  "l\u00f8penummer", to  = "latin1" )
+  names(df2)[1] <- iconv(  "l\u00f8penummer", from = "UTF-8", to  = "latin1" )
 
   expect_message( res <- left_join( df1, df2 ) )
   expect_equal( names(res), c("l\u00f8penummer", "foo", "baz") )