diff --git a/cpp11test/R/cpp11.R b/cpp11test/R/cpp11.R index 038e7b76..93804a44 100644 --- a/cpp11test/R/cpp11.R +++ b/cpp11test/R/cpp11.R @@ -112,6 +112,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 index 421de637..32487473 100644 --- a/cpp11test/src/cpp11.cpp +++ b/cpp11test/src/cpp11.cpp @@ -215,6 +215,27 @@ extern "C" SEXP _cpp11test_col_sums(SEXP x) { return cpp11::as_sexp(col_sums(cpp11::as_cpp>>(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 +} // protect.cpp void protect_one_(SEXP x, int n); extern "C" SEXP _cpp11test_protect_one_(SEXP x, SEXP n) { @@ -488,6 +509,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}, diff --git a/cpp11test/src/matrix.cpp b/cpp11test/src/matrix.cpp index 10348945..a875d73d 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) { @@ -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 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 8345068f..92113d50 100644 --- a/inst/include/cpp11/matrix.hpp +++ b/inst/include/cpp11/matrix.hpp @@ -1,13 +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_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 { operator SEXP() const { return SEXP(vector_); } - // operator sexp() { return sexp(vector_); } + attribute_proxy attr(const char* name) { return attribute_proxy(vector_, name); } - sexp attr(const char* 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; } + + 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); + } - sexp attr(const std::string& name) const { return SEXP(vector_.attr(name)); } + 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); + } - sexp attr(SEXP name) const { return SEXP(vector_.attr(name)); } + 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()); }