minimal support for raw vectors.

DESCRIPTION

@@ -26,3 +26,4 @@ VignetteBuilder: knitr
 LazyData: true
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 6.0.1
+Encoding: UTF-8

NAMESPACE

@@ -54,6 +54,7 @@ export(flatten_dfc)
 export(flatten_dfr)
 export(flatten_int)
 export(flatten_lgl)
+export(flatten_raw)
 export(has_element)
 export(head_while)
 export(imap)
@@ -63,6 +64,7 @@ export(imap_dfc)
 export(imap_dfr)
 export(imap_int)
 export(imap_lgl)
+export(imap_raw)
 export(invoke)
 export(invoke_map)
 export(invoke_map_chr)
@@ -72,6 +74,7 @@ export(invoke_map_dfc)
 export(invoke_map_dfr)
 export(invoke_map_int)
 export(invoke_map_lgl)
+export(invoke_map_raw)
 export(is_atomic)
 export(is_bare_atomic)
 export(is_bare_character)
@@ -124,6 +127,7 @@ export(map2_dfc)
 export(map2_dfr)
 export(map2_int)
 export(map2_lgl)
+export(map2_raw)
 export(map_at)
 export(map_call)
 export(map_chr)
@@ -134,6 +138,7 @@ export(map_dfr)
 export(map_if)
 export(map_int)
 export(map_lgl)
+export(map_raw)
 export(modify)
 export(modify_at)
 export(modify_depth)
@@ -149,6 +154,7 @@ export(pmap_dfc)
 export(pmap_dfr)
 export(pmap_int)
 export(pmap_lgl)
+export(pmap_raw)
 export(possibly)
 export(prepend)
 export(pwalk)

NEWS.md

@@ -22,6 +22,9 @@
 
 * `list_modify()`, `update_list()` and `list_merge()` now handle duplicate
   duplicate argument names correctly (#441, @mgirlich).
+
+* `map_raw`, `imap_raw`, `flatten_raw`, `invoke_map_raw`, `map2_raw` and `pmap_raw`
+  added to support raw vectors. (#455, @romainfrancois)
 
 # purrr 0.2.4
 

R/coerce.R

@@ -8,3 +8,4 @@ coerce_lgl <- function(x) coerce(x, "logical")
 coerce_int <- function(x) coerce(x, "integer")
 coerce_dbl <- function(x) coerce(x, "double")
 coerce_chr <- function(x) coerce(x, "character")
+coerce_raw <- function(x) coerce(x, "raw")

R/flatten.R

@@ -54,6 +54,12 @@ flatten_chr <- function(.x) {
   .Call(vflatten_impl, .x, "character")
 }
 
+#' @export
+#' @rdname flatten
+flatten_raw <- function(.x) {
+  .Call(vflatten_impl, .x, "raw")
+}
+
 #' @export
 #' @rdname flatten
 flatten_dfr <- function(.x, .id = NULL) {

R/imap.R

@@ -47,6 +47,13 @@ imap_dbl <- function(.x, .f, ...) {
   map2_dbl(.x, vec_index(.x), .f, ...)
 }
 
+#' @rdname imap
+#' @export
+imap_raw <- function(.x, .f, ...) {
+  .f <- as_mapper(.f, ...)
+  map2_raw(.x, vec_index(.x), .f, ...)
+}
+
 #' @rdname imap
 #' @export
 imap_dfr <- function(.x, .f, ..., .id = NULL) {

R/invoke.R

@@ -113,6 +113,13 @@ invoke_map_chr <- function(.f, .x = list(NULL), ..., .env = NULL) {
   .f <- as_invoke_function(.f)
   map2_chr(.f, .x, invoke, ..., .env = .env)
 }
+#' @rdname invoke
+#' @export
+invoke_map_raw <- function(.f, .x = list(NULL), ..., .env = NULL) {
+  .env <- .env %||% parent.frame()
+  .f <- as_invoke_function(.f)
+  map2_raw(.f, .x, invoke, ..., .env = .env)
+}
 
 #' @rdname invoke
 #' @export

R/map.R

@@ -155,6 +155,13 @@ map_dbl <- function(.x, .f, ...) {
   .Call(map_impl, environment(), ".x", ".f", "double")
 }
 
+#' @rdname map
+#' @export
+map_raw <- function(.x, .f, ...) {
+  .f <- as_mapper(.f, ...)
+  .Call(map_impl, environment(), ".x", ".f", "raw")
+}
+
 #' @rdname map
 #' @param .id Either a string or `NULL`. If a string, the output will contain
 #'   a variable with that name, storing either the name (if `.x` is named) or

R/map2-pmap.R

@@ -99,6 +99,12 @@ map2_chr <- function(.x, .y, .f, ...) {
   .f <- as_mapper(.f, ...)
   .Call(map2_impl, environment(), ".x", ".y", ".f", "character")
 }
+#' @export
+#' @rdname map2
+map2_raw <- function(.x, .y, .f, ...) {
+  .f <- as_mapper(.f, ...)
+  .Call(map2_impl, environment(), ".x", ".y", ".f", "raw")
+}
 #' @rdname map2
 #' @export
 map2_dfr <- function(.x, .y, .f, ..., .id = NULL) {
@@ -183,6 +189,16 @@ pmap_chr <- function(.l, .f, ...) {
 
   .Call(pmap_impl, environment(), ".l", ".f", "character")
 }
+#' @export
+#' @rdname map2
+pmap_raw <- function(.l, .f, ...) {
+  .f <- as_mapper(.f, ...)
+  if (is.data.frame(.l)) {
+    .l <- as.list(.l)
+  }
+
+  .Call(pmap_impl, environment(), ".l", ".f", "raw")
+}
 
 #' @rdname map2
 #' @export

src/coerce.c

@@ -3,6 +3,15 @@
 #include <Rinternals.h>
 #include <stdio.h>
 
+const char* sixteen = "0123456789abcdef" ;
+
+SEXP raw_to_char( Rbyte x){
+  char buf[2] ;
+  buf[0] = sixteen[ x >> 4] ;
+  buf[1] = sixteen[ x & 0x0F ] ;
+  return Rf_mkCharLen( buf, 2) ;
+}
+
 double logical_to_real(int x) {
   return (x == NA_LOGICAL) ? NA_REAL : x;
 }
@@ -58,6 +67,7 @@ void set_vector_value(SEXP to, int i, SEXP from, int j) {
     switch(TYPEOF(from)) {
     case LGLSXP: INTEGER(to)[i] = LOGICAL(from)[j]; break;
     case INTSXP: INTEGER(to)[i] = INTEGER(from)[j]; break;
+    case RAWSXP: INTEGER(to)[i] = RAW(from)[j]; break ;
     default: cant_coerce(from, to, i);
     }
     break;
@@ -66,6 +76,7 @@ void set_vector_value(SEXP to, int i, SEXP from, int j) {
     case LGLSXP:  REAL(to)[i] = logical_to_real(LOGICAL(from)[j]); break;
     case INTSXP:  REAL(to)[i] = integer_to_real(INTEGER(from)[j]); break;
     case REALSXP: REAL(to)[i] = REAL(from)[j]; break;
+    case RAWSXP:  REAL(to)[i] = RAW(from)[j]; break ;
     default: cant_coerce(from, to, i);
     }
     break;
@@ -75,12 +86,19 @@ void set_vector_value(SEXP to, int i, SEXP from, int j) {
     case INTSXP:  SET_STRING_ELT(to, i, integer_to_char(INTEGER(from)[j])); break;
     case REALSXP: SET_STRING_ELT(to, i, double_to_char(REAL(from)[j])); break;
     case STRSXP:  SET_STRING_ELT(to, i, STRING_ELT(from, j)); break;
+    case RAWSXP:  SET_STRING_ELT(to, i, raw_to_char(RAW(from)[j])); break;
     default: cant_coerce(from, to, i);
     }
     break;
   case VECSXP:
     SET_VECTOR_ELT(to, i, from);
     break;
+  case RAWSXP:
+    switch(TYPEOF(from)) {
+    case RAWSXP: RAW(to)[i] = RAW(from)[j]; break;
+    default: cant_coerce(from, to, i);
+    }
+    break ;
   default: cant_coerce(from, to, i);
   }
 }

src/extract.c

@@ -77,6 +77,7 @@ SEXP extract_vector(SEXP x, SEXP index_i, int i) {
   case REALSXP: return Rf_ScalarReal(REAL(x)[offset]);
   case STRSXP:  return Rf_ScalarString(STRING_ELT(x, offset));
   case VECSXP:  return VECTOR_ELT(x, offset);
+  case RAWSXP:  return Rf_ScalarRaw(RAW(x)[offset]) ;
   default:
     Rf_errorcall(R_NilValue,
       "Don't know how to index object of type %s at level %i",

tests/testthat/test-as-mapper.R

@@ -71,7 +71,10 @@ test_that("lists are wrapped", {
   expect_identical(mapper_list, base_list)
 })
 
-test_that("raw and complex types aren't supported for indexing", {
-  expect_error(as_mapper(1)(raw(2)))
+test_that("complex types aren't supported for indexing", {
   expect_error(as_mapper(1)(complex(2)))
 })
+
+test_that("raw vectors are supported for indexing", {
+  expect_equal( as_mapper(1)(raw(2)), raw(1) )
+})

tests/testthat/test-coerce.R

@@ -16,22 +16,29 @@ test_that("can't coerce downwards", {
   expect_error(coerce_dbl(list(1)), "Can't coerce")
   expect_error(coerce_int(list(1)), "Can't coerce")
   expect_error(coerce_lgl(list(1)), "Can't coerce")
+  expect_error(coerce_raw(list(1)), "Can't coerce")
 
   expect_error(coerce_dbl("a"), "Can't coerce")
   expect_error(coerce_int("a"), "Can't coerce")
   expect_error(coerce_lgl("a"), "Can't coerce")
+  expect_error(coerce_raw("a"), "Can't coerce")
 
   expect_error(coerce_int(1), "Can't coerce")
   expect_error(coerce_lgl(1), "Can't coerce")
+  expect_error(coerce_raw(1), "Can't coerce")
 
   expect_error(coerce_lgl(1L), "Can't coerce")
+  expect_error(coerce_raw(1L), "Can't coerce")
+
+  expect_error(coerce_raw(TRUE), "Can't coerce")
 })
 
 test_that("coercing to same type returns input", {
   expect_equal(coerce_lgl(c(TRUE, FALSE)), c(TRUE, FALSE))
   expect_equal(coerce_dbl(c(1, 2)), c(1, 2))
   expect_equal(coerce_int(c(1L, 2L)), c(1L, 2L))
   expect_equal(coerce_chr(c("a", "b")), c("a", "b"))
+  expect_equal(coerce_raw(as.raw(c(0,1))), as.raw(c(0,1)))
 })
 
 test_that("types automatically coerced upwards", {

tests/testthat/test-flatten.R

@@ -19,6 +19,7 @@ test_that("can flatten all atomic vectors", {
   expect_equal(flatten(list(1L)), list(1L))
   expect_equal(flatten(list(1)), list(1))
   expect_equal(flatten(list("a")), list("a"))
+  expect_equal(flatten_raw(list(as.raw(1))), as.raw(1))
 })
 
 test_that("NULLs are silently dropped", {

tests/testthat/test-imap.R

@@ -15,6 +15,7 @@ test_that("atomic vector imap works", {
   expect_length(imap_chr(x, paste), 3)
   expect_equal(imap_int(x, ~ .x + as.integer(.y)), x * 2)
   expect_equal(imap_dbl(x, ~ .x + as.numeric(.y)), x * 2)
+  expect_equal(imap_raw(as.raw(12), rawShift), rawShift(as.raw(12), 1) )
 })
 
 test_that("data frame imap works", {

tests/testthat/test-invoke.R

@@ -33,6 +33,8 @@ test_that("invoke_map() works with bare function", {
   expect_identical(invoke_map_int(`+`, data), c(3L, 7L))
   expect_identical(invoke_map_lgl(`&&`, data), c(TRUE, TRUE))
 
+  expect_identical(invoke_map_raw(identity, as.raw(1:3)), as.raw(1:3))
+
   ops <- set_names(c(`+`, `-`), c("a", "b"))
   expect_identical(invoke_map_dfr(ops, data), invoke_map_dfc(ops, data))
 })