Support nullable external_ptr<> (implement #312)

R/source.R

@@ -18,6 +18,13 @@
 #'   uses 'CXX11' if unset.
 #' @param dir The directory to store the generated source files. `tempfile()` is
 #'   used by default. The directory will be removed if `clean` is `TRUE`.
+#' @param local Passed to [dyn.load()]. If `TRUE` (the default) the shared
+#'   library is loaded with local symbols; if `FALSE` symbols are made global
+#'   (equivalent to `dyn.load(..., local = FALSE)`), which can be required when
+#'   other shared objects need to see RTTI/vtable symbols from this library.
+#' @note See the unit test that demonstrates this usage at
+#' \code{tests/testthat/test-source-local.R} (shows how `local = FALSE` exports
+#' the necessary symbols so separate shared objects can link against them).
 #' @return For [cpp_source()] and `[cpp_function()]` the results of
 #'   [dyn.load()] (invisibly). For `[cpp_eval()]` the results of the evaluated
 #'   expression.
@@ -65,7 +72,7 @@
 #' }
 #'
 #' @export
-cpp_source <- function(file, code = NULL, env = parent.frame(), clean = TRUE, quiet = TRUE, cxx_std = Sys.getenv("CXX_STD", "CXX11"), dir = tempfile()) {
+cpp_source <- function(file, code = NULL, env = parent.frame(), clean = TRUE, quiet = TRUE, cxx_std = Sys.getenv("CXX_STD", "CXX11"), dir = tempfile(), local = TRUE) {
   stop_unless_installed(c("brio", "callr", "cli", "decor", "desc", "glue", "tibble", "vctrs"))
   if (!missing(file) && !file.exists(file)) {
     stop("Can't find `file` at this path:\n", file, "\n", call. = FALSE)
@@ -145,7 +152,7 @@ cpp_source <- function(file, code = NULL, env = parent.frame(), clean = TRUE, qu
   brio::write_lines(r_functions, r_path)
   source(r_path, local = env)
 
-  dyn.load(shared_lib, local = TRUE, now = TRUE)
+  dyn.load(shared_lib, local = local, now = TRUE)
 }
 
 the <- new.env(parent = emptyenv())
@@ -183,7 +190,7 @@ generate_makevars <- function(includes, cxx_std) {
 
 #' @rdname cpp_source
 #' @export
-cpp_function <- function(code, env = parent.frame(), clean = TRUE, quiet = TRUE, cxx_std = Sys.getenv("CXX_STD", "CXX11")) {
+cpp_function <- function(code, env = parent.frame(), clean = TRUE, quiet = TRUE, cxx_std = Sys.getenv("CXX_STD", "CXX11"), local = TRUE) {
   cpp_source(code = paste(c('#include "cpp11.hpp"',
         "using namespace ::cpp11;",
         "namespace writable = ::cpp11::writable;",
@@ -193,15 +200,16 @@ cpp_function <- function(code, env = parent.frame(), clean = TRUE, quiet = TRUE,
     env = env,
     clean = clean,
     quiet = quiet,
-    cxx_std = cxx_std
+    cxx_std = cxx_std,
+    local = local
   )
 }
 
 utils::globalVariables("f")
 
 #' @rdname cpp_source
 #' @export
-cpp_eval <- function(code, env = parent.frame(), clean = TRUE, quiet = TRUE, cxx_std = Sys.getenv("CXX_STD", "CXX11")) {
+cpp_eval <- function(code, env = parent.frame(), clean = TRUE, quiet = TRUE, cxx_std = Sys.getenv("CXX_STD", "CXX11"), local = TRUE) {
   cpp_source(code = paste(c('#include "cpp11.hpp"',
         "using namespace ::cpp11;",
         "namespace writable = ::cpp11::writable;",
@@ -214,7 +222,8 @@ cpp_eval <- function(code, env = parent.frame(), clean = TRUE, quiet = TRUE, cxx
     env = env,
     clean = clean,
     quiet = quiet,
-    cxx_std = cxx_std
+    cxx_std = cxx_std,
+    local = local
   )
   f()
 }

README.md

@@ -78,3 +78,13 @@ Please note that the cpp11 project is released with a [Contributor Code of Condu
 
 cpp11 would not exist without Rcpp.
 Thanks to the Rcpp authors, Dirk Eddelbuettel, Romain Francois, JJ Allaire, Kevin Ushey, Qiang Kou, Nathan Russell, Douglas Bates and John Chambers for their work writing and maintaining Rcpp.
+
+## Clang format
+
+To match GHA, use clang-format-12 to format C++ code. With systems that provide clang-format-14 or newer, you can use Docker:
+
+```bash
+docker run --rm -v "$PWD":/work -w /work ubuntu:22.04 bash -lc "\
+  apt-get update && apt-get install -y clang-format-12 && \
+  find . -name '*.cpp' -o -name '*.hpp' -o -name '*.h' | xargs -r clang-format-12 -i"
+```

cpp11test/DESCRIPTION

@@ -20,4 +20,4 @@ Suggests:
     xml2
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.1.1
+RoxygenNote: 7.3.2

cpp11test/R/cpp11.R

@@ -88,6 +88,14 @@ cpp11_insert_ <- function(num_sxp) {
   .Call(`_cpp11test_cpp11_insert_`, num_sxp)
 }
 
+ordered_map_to_list_ <- function(x) {
+  .Call(`_cpp11test_ordered_map_to_list_`, x)
+}
+
+unordered_map_to_list_ <- function(x) {
+  .Call(`_cpp11test_unordered_map_to_list_`, x)
+}
+
 gibbs_cpp <- function(N, thin) {
   .Call(`_cpp11test_gibbs_cpp`, N, thin)
 }
@@ -108,6 +116,18 @@ row_sums <- function(x) {
   .Call(`_cpp11test_row_sums`, x)
 }
 
+mat_mat_copy_dimnames <- function(x) {
+  .Call(`_cpp11test_mat_mat_copy_dimnames`, x)
+}
+
+mat_sexp_copy_dimnames <- function(x) {
+  .Call(`_cpp11test_mat_sexp_copy_dimnames`, x)
+}
+
+mat_mat_create_dimnames <- function() {
+  .Call(`_cpp11test_mat_mat_create_dimnames`)
+}
+
 col_sums <- function(x) {
   .Call(`_cpp11test_col_sums`, x)
 }
@@ -236,6 +256,14 @@ rcpp_push_and_truncate_ <- function(size_sxp) {
   .Call(`_cpp11test_rcpp_push_and_truncate_`, size_sxp)
 }
 
+nullable_extptr_1 <- function() {
+  .Call(`_cpp11test_nullable_extptr_1`)
+}
+
+nullable_extptr_2 <- function() {
+  .Call(`_cpp11test_nullable_extptr_2`)
+}
+
 test_destruction_inner <- function() {
   invisible(.Call(`_cpp11test_test_destruction_inner`))
 }

cpp11test/src/cpp11.cpp

@@ -173,6 +173,20 @@ extern "C" SEXP _cpp11test_cpp11_insert_(SEXP num_sxp) {
     return cpp11::as_sexp(cpp11_insert_(cpp11::as_cpp<cpp11::decay_t<SEXP>>(num_sxp)));
   END_CPP11
 }
+// map.cpp
+SEXP ordered_map_to_list_(cpp11::doubles x);
+extern "C" SEXP _cpp11test_ordered_map_to_list_(SEXP x) {
+  BEGIN_CPP11
+    return cpp11::as_sexp(ordered_map_to_list_(cpp11::as_cpp<cpp11::decay_t<cpp11::doubles>>(x)));
+  END_CPP11
+}
+// map.cpp
+SEXP unordered_map_to_list_(cpp11::doubles x);
+extern "C" SEXP _cpp11test_unordered_map_to_list_(SEXP x) {
+  BEGIN_CPP11
+    return cpp11::as_sexp(unordered_map_to_list_(cpp11::as_cpp<cpp11::decay_t<cpp11::doubles>>(x)));
+  END_CPP11
+}
 // matrix.cpp
 SEXP gibbs_cpp(int N, int thin);
 extern "C" SEXP _cpp11test_gibbs_cpp(SEXP N, SEXP thin) {
@@ -209,6 +223,27 @@ extern "C" SEXP _cpp11test_row_sums(SEXP x) {
   END_CPP11
 }
 // matrix.cpp
+cpp11::doubles_matrix<> mat_mat_copy_dimnames(cpp11::doubles_matrix<> x);
+extern "C" SEXP _cpp11test_mat_mat_copy_dimnames(SEXP x) {
+  BEGIN_CPP11
+    return cpp11::as_sexp(mat_mat_copy_dimnames(cpp11::as_cpp<cpp11::decay_t<cpp11::doubles_matrix<>>>(x)));
+  END_CPP11
+}
+// matrix.cpp
+SEXP mat_sexp_copy_dimnames(cpp11::doubles_matrix<> x);
+extern "C" SEXP _cpp11test_mat_sexp_copy_dimnames(SEXP x) {
+  BEGIN_CPP11
+    return cpp11::as_sexp(mat_sexp_copy_dimnames(cpp11::as_cpp<cpp11::decay_t<cpp11::doubles_matrix<>>>(x)));
+  END_CPP11
+}
+// matrix.cpp
+cpp11::doubles_matrix<> mat_mat_create_dimnames();
+extern "C" SEXP _cpp11test_mat_mat_create_dimnames() {
+  BEGIN_CPP11
+    return cpp11::as_sexp(mat_mat_create_dimnames());
+  END_CPP11
+}
+// matrix.cpp
 cpp11::doubles col_sums(cpp11::doubles_matrix<cpp11::by_column> x);
 extern "C" SEXP _cpp11test_col_sums(SEXP x) {
   BEGIN_CPP11
@@ -443,6 +478,20 @@ extern "C" SEXP _cpp11test_rcpp_push_and_truncate_(SEXP size_sxp) {
     return cpp11::as_sexp(rcpp_push_and_truncate_(cpp11::as_cpp<cpp11::decay_t<SEXP>>(size_sxp)));
   END_CPP11
 }
+// test-external_pointer.cpp
+cpp11::external_pointer<int> nullable_extptr_1();
+extern "C" SEXP _cpp11test_nullable_extptr_1() {
+  BEGIN_CPP11
+    return cpp11::as_sexp(nullable_extptr_1());
+  END_CPP11
+}
+// test-external_pointer.cpp
+cpp11::external_pointer<int> nullable_extptr_2();
+extern "C" SEXP _cpp11test_nullable_extptr_2() {
+  BEGIN_CPP11
+    return cpp11::as_sexp(nullable_extptr_2());
+  END_CPP11
+}
 // test-protect-nested.cpp
 void test_destruction_inner();
 extern "C" SEXP _cpp11test_test_destruction_inner() {
@@ -488,6 +537,9 @@ static const R_CallMethodDef CallEntries[] = {
     {"_cpp11test_gibbs_rcpp",               (DL_FUNC) &_cpp11test_gibbs_rcpp,               2},
     {"_cpp11test_gibbs_rcpp2",              (DL_FUNC) &_cpp11test_gibbs_rcpp2,              2},
     {"_cpp11test_grow_",                    (DL_FUNC) &_cpp11test_grow_,                    1},
+    {"_cpp11test_mat_mat_copy_dimnames",    (DL_FUNC) &_cpp11test_mat_mat_copy_dimnames,    1},
+    {"_cpp11test_mat_mat_create_dimnames",  (DL_FUNC) &_cpp11test_mat_mat_create_dimnames,  0},
+    {"_cpp11test_mat_sexp_copy_dimnames",   (DL_FUNC) &_cpp11test_mat_sexp_copy_dimnames,   1},
     {"_cpp11test_my_message",               (DL_FUNC) &_cpp11test_my_message,               2},
     {"_cpp11test_my_message_n1",            (DL_FUNC) &_cpp11test_my_message_n1,            1},
     {"_cpp11test_my_message_n1fmt",         (DL_FUNC) &_cpp11test_my_message_n1fmt,         1},
@@ -500,6 +552,9 @@ static const R_CallMethodDef CallEntries[] = {
     {"_cpp11test_my_warning_n1",            (DL_FUNC) &_cpp11test_my_warning_n1,            1},
     {"_cpp11test_my_warning_n1fmt",         (DL_FUNC) &_cpp11test_my_warning_n1fmt,         1},
     {"_cpp11test_my_warning_n2fmt",         (DL_FUNC) &_cpp11test_my_warning_n2fmt,         2},
+    {"_cpp11test_nullable_extptr_1",        (DL_FUNC) &_cpp11test_nullable_extptr_1,        0},
+    {"_cpp11test_nullable_extptr_2",        (DL_FUNC) &_cpp11test_nullable_extptr_2,        0},
+    {"_cpp11test_ordered_map_to_list_",     (DL_FUNC) &_cpp11test_ordered_map_to_list_,     1},
     {"_cpp11test_protect_many_",            (DL_FUNC) &_cpp11test_protect_many_,            1},
     {"_cpp11test_protect_many_cpp11_",      (DL_FUNC) &_cpp11test_protect_many_cpp11_,      1},
     {"_cpp11test_protect_many_preserve_",   (DL_FUNC) &_cpp11test_protect_many_preserve_,   1},
@@ -533,6 +588,7 @@ static const R_CallMethodDef CallEntries[] = {
     {"_cpp11test_sum_int_foreach_",         (DL_FUNC) &_cpp11test_sum_int_foreach_,         1},
     {"_cpp11test_test_destruction_inner",   (DL_FUNC) &_cpp11test_test_destruction_inner,   0},
     {"_cpp11test_test_destruction_outer",   (DL_FUNC) &_cpp11test_test_destruction_outer,   0},
+    {"_cpp11test_unordered_map_to_list_",   (DL_FUNC) &_cpp11test_unordered_map_to_list_,   1},
     {"_cpp11test_upper_bound",              (DL_FUNC) &_cpp11test_upper_bound,              2},
     {"run_testthat_tests",                  (DL_FUNC) &run_testthat_tests,                  1},
     {NULL, NULL, 0}

cpp11test/src/map.cpp

@@ -0,0 +1,20 @@
+#include "cpp11/as.hpp"
+#include "cpp11/doubles.hpp"
+
+[[cpp11::register]] SEXP ordered_map_to_list_(cpp11::doubles x) {
+  std::map<double, int> counts;
+  int n = x.size();
+  for (int i = 0; i < n; i++) {
+    counts[x[i]]++;
+  }
+  return cpp11::as_sexp(counts);
+}
+
+[[cpp11::register]] SEXP unordered_map_to_list_(cpp11::doubles x) {
+  std::unordered_map<double, int> counts;
+  int n = x.size();
+  for (int i = 0; i < n; i++) {
+    counts[x[i]]++;
+  }
+  return cpp11::as_sexp(counts);
+}

cpp11test/src/matrix.cpp

@@ -1,6 +1,8 @@
 #include "cpp11/matrix.hpp"
 #include "Rmath.h"
 #include "cpp11/doubles.hpp"
+#include "cpp11/list.hpp"
+#include "cpp11/strings.hpp"
 using namespace cpp11;
 
 [[cpp11::register]] SEXP gibbs_cpp(int N, int thin) {
@@ -86,6 +88,40 @@ using namespace Rcpp;
   return sums;
 }
 
+[[cpp11::register]] cpp11::doubles_matrix<> mat_mat_copy_dimnames(
+    cpp11::doubles_matrix<> x) {
+  cpp11::writable::doubles_matrix<> out = x;
+
+  out.attr("dimnames") = x.attr("dimnames");
+
+  return out;
+}
+
+[[cpp11::register]] SEXP mat_sexp_copy_dimnames(cpp11::doubles_matrix<> x) {
+  cpp11::writable::doubles_matrix<> out = x;
+
+  out.attr("dimnames") = x.attr("dimnames");
+
+  return out;
+}
+
+[[cpp11::register]] cpp11::doubles_matrix<> mat_mat_create_dimnames() {
+  cpp11::writable::doubles_matrix<> out(2, 2);
+
+  out(0, 0) = 1;
+  out(0, 1) = 2;
+  out(1, 0) = 3;
+  out(1, 1) = 4;
+
+  cpp11::writable::list dimnames(2);
+  dimnames[0] = cpp11::strings({"a", "b"});
+  dimnames[1] = cpp11::strings({"c", "d"});
+
+  out.attr("dimnames") = dimnames;
+
+  return out;
+}
+
 [[cpp11::register]] cpp11::doubles col_sums(cpp11::doubles_matrix<cpp11::by_column> x) {
   cpp11::writable::doubles sums(x.ncol());
 

cpp11test/src/test-external_pointer.cpp

@@ -10,6 +10,15 @@ void deleter(int* ptr) {
   delete ptr;
 }
 
+// Pacha: Test nullable external_pointer (#312)
+[[cpp11::register]] cpp11::external_pointer<int> nullable_extptr_1() {
+  return cpp11::external_pointer<int>(nullptr);
+}
+
+[[cpp11::register]] cpp11::external_pointer<int> nullable_extptr_2() {
+  return cpp11::external_pointer<int>(R_NilValue);
+}
+
 context("external_pointer-C++") {
   test_that("external_pointer works") {
     std::vector<int>* v = new std::vector<int>;

cpp11test/tests/testthat/test-external-pointer.R

@@ -0,0 +1,11 @@
+# Pacha: test that nullable external pointer is consistent (#312)
+test_that("nullable external pointer is consistent", {
+
+  len <- 1e5
+  set.seed(42)
+  x <- rnorm(len)
+  sum_base <- sum(x)
+
+  expect_equal(nullable_extptr_1(), NULL)
+  expect_equal(nullable_extptr_2(), NULL)
+})

cpp11test/tests/testthat/test-map-to-list.R

@@ -0,0 +1,18 @@
+test_that("ordered and unordered C++ maps are converted to R lists", {
+  set.seed(42L)
+  x <- rnorm(10L)
+  xprime <- c(x, x[1])
+
+  om <- ordered_map_to_list_(x)
+  expect_type(om, "list")
+
+  om_doubles <- as.double(names(om))
+  expect_equal(om_doubles, sort(om_doubles))
+
+  omprime <- ordered_map_to_list_(xprime)
+  expect_equal(unlist(unique(omprime)), 1:2)
+
+  um <- unordered_map_to_list_(xprime)
+  expect_type(um, "list")
+  expect_equal(unlist(unique(um)), 1:2)
+})

cpp11test/tests/testthat/test-matrix.R

@@ -23,3 +23,19 @@ test_that("col_sums gives same result as colSums", {
   y[3, ] <- NA;
   expect_equal(col_sums(y), colSums(y))
 })
+
+test_that("doubles_matrix<> can return a matrix with colnames and rownames", {
+  x <- matrix(c(1, 2, 3, 4), nrow = 2, ncol = 2)
+  colnames(x) <- letters[1:2]
+  rownames(x) <- letters[3:4]
+
+  y <- mat_mat_copy_dimnames(x)
+  z <- mat_sexp_copy_dimnames(x)
+
+  expect_equal(x, y)
+  expect_equal(x, z)
+
+  r <- mat_mat_create_dimnames()
+  expect_equal(rownames(r), c("a", "b"))
+  expect_equal(colnames(r), c("c", "d"))
+})