Merge pull request #27 from pachadotdev/matrix_attr-clean

Correctly set dimnames for matrices

Author: pachadotdev

cpp11test/R/cpp11.R

@@ -116,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)
 }

cpp11test/src/cpp11.cpp

@@ -223,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
@@ -502,6 +523,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},

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/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"))
+})

inst/include/cpp11/matrix.hpp

@@ -1,13 +1,15 @@
 #pragma once
 
+#include <initializer_list>  // for initializer_list
 #include <iterator>
 #include <string>  // for string
 
-#include "cpp11/R.hpp"         // for SEXP, SEXPREC, R_xlen_t, INT...
-#include "cpp11/r_bool.hpp"    // for r_bool
-#include "cpp11/r_string.hpp"  // for r_string
-#include "cpp11/r_vector.hpp"  // for r_vector
-#include "cpp11/sexp.hpp"      // for sexp
+#include "cpp11/R.hpp"                // for SEXP, SEXPREC, R_xlen_t, INT...
+#include "cpp11/attribute_proxy.hpp"  // for attribute_proxy
+#include "cpp11/r_bool.hpp"           // for r_bool
+#include "cpp11/r_string.hpp"         // for r_string
+#include "cpp11/r_vector.hpp"         // for r_vector
+#include "cpp11/sexp.hpp"             // for sexp
 
 namespace cpp11 {
 
@@ -190,11 +192,49 @@ class matrix : public matrix_slices<S> {
 
   // operator sexp() { return sexp(vector_); }
 
-  sexp attr(const char* name) const { return SEXP(vector_.attr(name)); }
+  attribute_proxy<V> attr(const char* name) { return attribute_proxy<V>(vector_, name); }
 
-  sexp attr(const std::string& name) const { return SEXP(vector_.attr(name)); }
+  attribute_proxy<V> attr(const std::string& name) {
+    return attribute_proxy<V>(vector_, name.c_str());
+  }
+
+  attribute_proxy<V> attr(SEXP name) { return attribute_proxy<V>(vector_, name); }
+
+  void attr(const char* name, SEXP value) { vector_.attr(name) = value; }
+
+  void attr(const std::string& name, SEXP value) { vector_.attr(name) = value; }
 
-  sexp attr(SEXP name) const { return SEXP(vector_.attr(name)); }
+  void attr(SEXP name, SEXP value) { vector_.attr(name) = value; }
+
+  void attr(const char* name, std::initializer_list<SEXP> value) {
+    SEXP attr = PROTECT(Rf_allocVector(VECSXP, value.size()));
+    int i = 0;
+    for (SEXP v : value) {
+      SET_VECTOR_ELT(attr, i++, v);
+    }
+    vector_.attr(name) = attr;
+    UNPROTECT(1);
+  }
+
+  void attr(const std::string& name, std::initializer_list<SEXP> value) {
+    SEXP attr = PROTECT(Rf_allocVector(VECSXP, value.size()));
+    int i = 0;
+    for (SEXP v : value) {
+      SET_VECTOR_ELT(attr, i++, v);
+    }
+    vector_.attr(name) = attr;
+    UNPROTECT(1);
+  }
+
+  void attr(SEXP name, std::initializer_list<SEXP> value) {
+    SEXP attr = PROTECT(Rf_allocVector(VECSXP, value.size()));
+    int i = 0;
+    for (SEXP v : value) {
+      SET_VECTOR_ELT(attr, i++, v);
+    }
+    vector_.attr(name) = attr;
+    UNPROTECT(1);
+  }
 
   r_vector<r_string> names() const { return r_vector<r_string>(vector_.names()); }