Merge pull request #14 from pachadotdev/matrix_attr

pachadotdev · web-flow · commit 5e945fc2a401 · 2025-09-16T11:39:21.000-04:00
Matrix attr
diff --git a/cpp11test/R/cpp11.R b/cpp11test/R/cpp11.R
@@ -124,6 +124,18 @@ col_sums <- function(x) {
   .Call(`_cpp11test_col_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`)
+}
+
 protect_one_ <- function(x, n) {
   invisible(.Call(`_cpp11test_protect_one_`, x, n))
 }
diff --git a/cpp11test/src/cpp11.cpp b/cpp11test/src/cpp11.cpp
@@ -236,6 +236,27 @@ extern "C" SEXP _cpp11test_col_sums(SEXP x) {
     return cpp11::as_sexp(col_sums(cpp11::as_cpp<cpp11::decay_t<cpp11::doubles_matrix<cpp11::by_column>>>(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
+}
 // protect.cpp
 void protect_one_(SEXP x, int n);
 extern "C" SEXP _cpp11test_protect_one_(SEXP x, SEXP n) {
@@ -609,6 +630,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_grow_strings_cpp11_",      (DL_FUNC) &_cpp11test_grow_strings_cpp11_,      2},
     {"_cpp11test_grow_strings_manual_",     (DL_FUNC) &_cpp11test_grow_strings_manual_,     2},
     {"_cpp11test_grow_strings_rcpp_",       (DL_FUNC) &_cpp11test_grow_strings_rcpp_,       2},
diff --git a/cpp11test/src/matrix.cpp b/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) {
@@ -104,3 +106,47 @@ using namespace Rcpp;
 
   return sums;
 }
+
+[[cpp11::register]] cpp11::doubles_matrix<> mat_mat_copy_dimnames(
+    cpp11::doubles_matrix<> x) {
+  cpp11::writable::doubles_matrix<> out = x;
+
+  // SEXP dimnames = x.attr("dimnames");
+  // if (dimnames != R_NilValue) {
+  //   Rf_setAttrib(out.data(), R_DimNamesSymbol, dimnames);
+  // }
+
+  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;
+
+  // SEXP dimnames = x.attr("dimnames");
+  // if (dimnames != R_NilValue) {
+  //   Rf_setAttrib(out.data(), R_DimNamesSymbol, dimnames);
+  // }
+
+  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;
+}
diff --git a/cpp11test/tests/testthat/test-matrix.R b/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"))
+})
diff --git a/inst/include/cpp11/matrix.hpp b/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 {
 
@@ -188,13 +190,49 @@ class matrix : public matrix_slices<S> {
 
   operator SEXP() const { return SEXP(vector_); }
 
-  // operator sexp() { return sexp(vector_); }
+  attribute_proxy<V> attr(const char* name) { return attribute_proxy<V>(vector_, name); }
 
-  sexp attr(const char* 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; }
+
+  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);
+  }
 
-  sexp attr(const std::string& name) const { return SEXP(vector_.attr(name)); }
+  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);
+  }
 
-  sexp attr(SEXP name) const { return SEXP(vector_.attr(name)); }
+  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()); }
 
