diff --git a/cpp11test/R/cpp11.R b/cpp11test/R/cpp11.R index cd2ae44c..86a2a512 100644 --- a/cpp11test/R/cpp11.R +++ b/cpp11test/R/cpp11.R @@ -120,6 +120,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) } diff --git a/cpp11test/src/cpp11.cpp b/cpp11test/src/cpp11.cpp index 7d076299..ae1f147b 100644 --- a/cpp11test/src/cpp11.cpp +++ b/cpp11test/src/cpp11.cpp @@ -230,6 +230,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>>(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>>(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 x); extern "C" SEXP _cpp11test_col_sums(SEXP x) { BEGIN_CPP11 @@ -621,6 +642,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_cplx_", (DL_FUNC) &_cpp11test_grow_cplx_, 1}, {"_cpp11test_my_message", (DL_FUNC) &_cpp11test_my_message, 2}, {"_cpp11test_my_message_n1", (DL_FUNC) &_cpp11test_my_message_n1, 1}, diff --git a/cpp11test/src/matrix.cpp b/cpp11test/src/matrix.cpp index 10348945..97fd2921 100644 --- 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) { @@ -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 x) { cpp11::writable::doubles sums(x.ncol()); diff --git a/cpp11test/tests/testthat/test-matrix.R b/cpp11test/tests/testthat/test-matrix.R index a43f59b0..942d5ed8 100644 --- 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 index 32e789d0..6e1fb4e0 100644 --- a/inst/include/cpp11/matrix.hpp +++ b/inst/include/cpp11/matrix.hpp @@ -1,14 +1,15 @@ #pragma once +#include // for initializer_list #include #include // for string -#include "cpp11/R.hpp" // for SEXP, SEXPREC, R_xlen_t, INT... -#include "cpp11/r_bool.hpp" // for r_bool -#include "cpp11/r_complex.hpp" // for r_complex -#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 { @@ -191,11 +192,49 @@ class matrix : public matrix_slices { // operator sexp() { return sexp(vector_); } - sexp attr(const char* name) const { return SEXP(vector_.attr(name)); } + attribute_proxy attr(const char* name) { return attribute_proxy(vector_, name); } - sexp attr(const std::string& name) const { return SEXP(vector_.attr(name)); } + attribute_proxy attr(const std::string& name) { + return attribute_proxy(vector_, name.c_str()); + } + + attribute_proxy attr(SEXP name) { return attribute_proxy(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 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 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 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 names() const { return r_vector(vector_.names()); }