Fix type check for unclassed objects (tidyverse#1817)

NEWS.md

@@ -1,5 +1,7 @@
 # dplyr 0.4.3.9000
 
+* Avoiding segfaults in presence of `raw` columns (#1803, #1817, @krlmlr).
+
 * Fixed bug about joins when factor levels not equal (#1712, #1559).
 
 * anti and semi joins give correct result when by variable is a factor

R/RcppExports.R

@@ -61,6 +61,10 @@ distinct_impl <- function(df, vars, keep) {
     .Call('dplyr_distinct_impl', PACKAGE = 'dplyr', df, vars, keep)
 }
 
+assert_all_white_list <- function(data) {
+    invisible(.Call('dplyr_assert_all_white_list', PACKAGE = 'dplyr', data))
+}
+
 semi_join_impl <- function(x, y, by_x, by_y) {
     .Call('dplyr_semi_join_impl', PACKAGE = 'dplyr', x, y, by_x, by_y)
 }

R/rowwise.r

@@ -19,6 +19,7 @@
 rowwise <- function(data) {
   stopifnot(is.data.frame(data))
 
+  assert_all_white_list(data)
   structure(data, class = c("rowwise_df", "tbl_df", "tbl", "data.frame"))
 }
 

src/RcppExports.cpp

@@ -145,6 +145,16 @@ BEGIN_RCPP
     return __result;
 END_RCPP
 }
+// assert_all_white_list
+void assert_all_white_list(const DataFrame& data);
+RcppExport SEXP dplyr_assert_all_white_list(SEXP dataSEXP) {
+BEGIN_RCPP
+    Rcpp::RNGScope __rngScope;
+    Rcpp::traits::input_parameter< const DataFrame& >::type data(dataSEXP);
+    assert_all_white_list(data);
+    return R_NilValue;
+END_RCPP
+}
 // semi_join_impl
 DataFrame semi_join_impl(DataFrame x, DataFrame y, CharacterVector by_x, CharacterVector by_y);
 RcppExport SEXP dplyr_semi_join_impl(SEXP xSEXP, SEXP ySEXP, SEXP by_xSEXP, SEXP by_ySEXP) {

src/dplyr.cpp

@@ -625,6 +625,7 @@ void push_back( Container& x, typename Container::value_type value, int n ){
         x.push_back( value ) ;
 }
 
+// [[Rcpp::export]]
 void assert_all_white_list(const DataFrame& data){
     // checking variables are on the white list
     int nc = data.size() ;
@@ -636,9 +637,13 @@ void assert_all_white_list(const DataFrame& data){
 
             SEXP klass = Rf_getAttrib(v, R_ClassSymbol) ;
             if( !Rf_isNull(klass) ){
-                stop( "column '%s' has unsupported type : %s",
+                stop( "column '%s' has unsupported class : %s",
                     name_i.get_cstring() , get_single_class(v) );
             }
+            else {
+                stop( "column '%s' has unsupported type : %s",
+                    name_i.get_cstring() , Rf_type2char(TYPEOF(v)) );
+            }
 
         }
     }

tests/testthat/test-arrange.r

@@ -143,9 +143,15 @@ test_that("duplicated column name is explicit about which column (#996)", {
     expect_error( df %>% arrange, "found duplicated column name: x, y" )
 })
 
-test_that("arrange fails gracefully on list comumns (#1489)",{
+test_that("arrange fails gracefully on list columns (#1489)", {
   df <- expand.grid(group = 1:2, y = 1, x = 1) %>%
     group_by(group) %>%
     do(fit = lm(data = ., y ~ x))
   expect_error( arrange(df, fit), "Cannot order based on this column" )
 })
+
+test_that("arrange fails gracefully on raw columns (#1803)", {
+  df <- data_frame(a = 1:3, b = as.raw(1:3))
+  expect_error( arrange(df, a), "unsupported type" )
+  expect_error( arrange(df, b), "unsupported type" )
+})

tests/testthat/test-filter.r

@@ -192,7 +192,7 @@ X
   datesDF$X <- as.POSIXlt(datesDF$X)
   expect_error(
     filter(datesDF, X > as.POSIXlt("2014-03-13")),
-    "column 'X' has unsupported type"
+    "column 'X' has unsupported class"
   )
 })
 
@@ -383,3 +383,9 @@ test_that("each argument gets implicit parens", {
     expect_equal(collect(one[[i]]), collect(two[[i]]))
   })
 })
+
+test_that("filter fails gracefully on raw columns (#1803)", {
+  df <- data_frame(a = 1:3, b = as.raw(1:3))
+  expect_error( filter(df, a == 1), "unsupported type" )
+  expect_error( filter(df, b == 1), "unsupported type" )
+})

tests/testthat/test-group-by.r

@@ -243,3 +243,14 @@ test_that("group_by handles encodings (#1507)", {
   res <- group_by_(df, iconv("\u00e9", from = "UTF-8", to = "latin1") )
   expect_equal( names(res), names(df) )
 })
+
+test_that("group_by fails gracefully on raw columns (#1803)", {
+  df <- data_frame(a = 1:3, b = as.raw(1:3))
+  expect_error( group_by(df, a), "unsupported type" )
+  expect_error( group_by(df, b), "unsupported type" )
+})
+
+test_that("rowwise fails gracefully on raw columns (#1803)", {
+  df <- data_frame(a = 1:3, b = as.raw(1:3))
+  expect_error( rowwise(df), "unsupported type" )
+})

tests/testthat/test-mutate.r

@@ -586,3 +586,10 @@ test_that( "ntile falls back to R (#1750)", {
   res <- mutate( iris, a = ntile("Sepal.Length", 3))
   expect_equal( res$a, rep(1, 150))
 })
+
+test_that("mutate fails gracefully on raw columns (#1803)", {
+  df <- data_frame(a = 1:3, b = as.raw(1:3))
+  expect_error( mutate(df, a = 1), "unsupported type" )
+  expect_error( mutate(df, b = 1), "unsupported type" )
+  expect_error( mutate(df, c = 1), "unsupported type" )
+})

tests/testthat/test-select.r

@@ -158,3 +158,10 @@ test_that("invalid inputs raise error", {
   expect_error(combine_vars(names(mtcars), list(c(-1, 1))), "positive or negative")
   expect_error(combine_vars(names(mtcars), list(12)), "must be between")
 })
+
+test_that("select succeeds in presence of raw columns (#1803)", {
+  df <- data_frame(a = 1:3, b = as.raw(1:3))
+  expect_identical(select(df, a), df["a"])
+  expect_identical(select(df, b), df["b"])
+  expect_identical(select(df, -b), df["a"])
+})

tests/testthat/test-summarise.r

@@ -634,3 +634,13 @@ test_that("summarise() correctly coerces factors with different levels (#1678)",
   expect_equal( levels(res$z), c("a", "b") )
   expect_equal( as.character(res$z), c("a", "b", "b") )
 })
+
+test_that("summarise works if raw columns exist but are not involved (#1803)", {
+  df <- data_frame(a = 1:3, b = as.raw(1:3))
+  expect_equal(summarise(df, c = sum(a)), data_frame(c = 6L))
+})
+
+test_that("summarise fails gracefully on raw columns (#1803)", {
+  df <- data_frame(a = 1:3, b = as.raw(1:3))
+  expect_error( summarise(df, c = b[[1]]), "unsupported type" )
+})