From dde383dd4551060f9379d8769d085adda87a2954 Mon Sep 17 00:00:00 2001
From: Lionel Henry <lionel.hry@gmail.com>
Date: Fri, 30 Nov 2018 14:47:10 +0100
Subject: [PATCH] Handle primitive functions in `pluck()`

Closes #404
---
 NEWS.md                     |  2 ++
 src/pluck.c                 | 16 +++++++++++++---
 tests/testthat/test-pluck.R |  7 ++++++-
 3 files changed, 21 insertions(+), 4 deletions(-)

diff --git a/NEWS.md b/NEWS.md
index bc7fdcbd..7c97b12b 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -64,6 +64,8 @@ reduce2_right(.x = letters[1:4], .y = paste2, .f = c("-", ".", "-")) # working
 
 ## Minor improvements and fixes
 
+* `pluck()` now supports primitive functions (#404).
+
 * New `.rev` argument in `compose()`. If set to `FALSE`, the functions
   are composed from left to right rather than right to left.
 
diff --git a/src/pluck.c b/src/pluck.c
index 45a14e1e..e01f21a3 100644
--- a/src/pluck.c
+++ b/src/pluck.c
@@ -150,13 +150,23 @@ SEXP extract_s4(SEXP x, SEXP index_i, int i, bool strict) {
   return Rf_getAttrib(x, sym);
 }
 
-SEXP extract_clo(SEXP x, SEXP clo) {
+SEXP extract_fn(SEXP x, SEXP clo) {
   SEXP expr = PROTECT(Rf_lang2(clo, x));
   SEXP out = Rf_eval(expr, R_GlobalEnv);
 
   UNPROTECT(1);
   return out;
 }
+static bool is_function(SEXP x) {
+  switch (TYPEOF(x)) {
+  case CLOSXP:
+  case BUILTINSXP:
+  case SPECIALSXP:
+    return true;
+  default:
+    return false;
+  }
+}
 
 SEXP pluck_impl(SEXP x, SEXP index, SEXP missing, SEXP strict_arg) {
   if (TYPEOF(index) != VECSXP) {
@@ -169,8 +179,8 @@ SEXP pluck_impl(SEXP x, SEXP index, SEXP missing, SEXP strict_arg) {
   for (int i = 0; i < n; ++i) {
     SEXP index_i = VECTOR_ELT(index, i);
 
-    if (TYPEOF(index_i) == CLOSXP) {
-      x = extract_clo(x, index_i);
+    if (is_function(index_i)) {
+      x = extract_fn(x, index_i);
       continue;
     }
 
diff --git a/tests/testthat/test-pluck.R b/tests/testthat/test-pluck.R
index 2e4c564e..f05e3272 100644
--- a/tests/testthat/test-pluck.R
+++ b/tests/testthat/test-pluck.R
@@ -90,7 +90,7 @@ test_that("supports splicing", {
 })
 
 
-# closures ----------------------------------------------------------------
+# functions ---------------------------------------------------------------
 
 test_that("can pluck attributes", {
   x <- structure(
@@ -132,6 +132,11 @@ test_that("pluck() dispatches on global methods", {
   expect_identical(pluck(iris, "Species", levels), levels(iris$Species))
 })
 
+test_that("pluck() supports primitive functions (#404)", {
+  x <- list(a = "apple", n = 3, v = 1:5)
+  expect_identical(pluck(x, "n", as.character), "3")
+})
+
 
 # attribute extraction ----------------------------------------------------