diff --git a/cpp11test/R/cpp11.R b/cpp11test/R/cpp11.R index a4222108..93804a44 100644 --- a/cpp11test/R/cpp11.R +++ b/cpp11test/R/cpp11.R @@ -112,12 +112,16 @@ col_sums <- function(x) { .Call(`_cpp11test_col_sums`, x) } -log_mat_mat <- function(x) { - .Call(`_cpp11test_log_mat_mat`, x) +mat_mat_copy_dimnames <- function(x) { + .Call(`_cpp11test_mat_mat_copy_dimnames`, x) } -log_mat_sexp <- function(x) { - .Call(`_cpp11test_log_mat_sexp`, 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) { diff --git a/cpp11test/src/cpp11.cpp b/cpp11test/src/cpp11.cpp index a9a2f674..32487473 100644 --- a/cpp11test/src/cpp11.cpp +++ b/cpp11test/src/cpp11.cpp @@ -216,17 +216,24 @@ extern "C" SEXP _cpp11test_col_sums(SEXP x) { END_CPP11 } // matrix.cpp -cpp11::doubles_matrix<> log_mat_mat(cpp11::doubles_matrix<> x); -extern "C" SEXP _cpp11test_log_mat_mat(SEXP x) { +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(log_mat_mat(cpp11::as_cpp>>(x))); + return cpp11::as_sexp(mat_mat_copy_dimnames(cpp11::as_cpp>>(x))); END_CPP11 } // matrix.cpp -SEXP log_mat_sexp(cpp11::doubles_matrix<> x); -extern "C" SEXP _cpp11test_log_mat_sexp(SEXP x) { +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(log_mat_sexp(cpp11::as_cpp>>(x))); + 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 @@ -502,8 +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_log_mat_mat", (DL_FUNC) &_cpp11test_log_mat_mat, 1}, - {"_cpp11test_log_mat_sexp", (DL_FUNC) &_cpp11test_log_mat_sexp, 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 57cc7c38..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) { @@ -105,19 +107,13 @@ using namespace Rcpp; return sums; } -[[cpp11::register]] cpp11::doubles_matrix<> log_mat_mat(cpp11::doubles_matrix<> x) { - cpp11::writable::doubles_matrix<> out(x.nrow(), x.ncol()); - - for (int i = 0; i < x.nrow(); i++) { - for (int j = 0; j < x.ncol(); j++) { - out(i, j) = log(x(i, j)); - } - } +[[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); - // std::cout << "dimnames set successfully" << std::endl; // } out.attr("dimnames") = x.attr("dimnames"); @@ -125,14 +121,8 @@ using namespace Rcpp; return out; } -[[cpp11::register]] SEXP log_mat_sexp(cpp11::doubles_matrix<> x) { - cpp11::writable::doubles_matrix<> out(x.nrow(), x.ncol()); - - for (int i = 0; i < x.nrow(); i++) { - for (int j = 0; j < x.ncol(); j++) { - out(i, j) = log(x(i, j)); - } - } +[[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) { @@ -143,3 +133,20 @@ using namespace Rcpp; 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 de1a346f..942d5ed8 100644 --- a/cpp11test/tests/testthat/test-matrix.R +++ b/cpp11test/tests/testthat/test-matrix.R @@ -24,15 +24,18 @@ test_that("col_sums gives same result as colSums", { expect_equal(col_sums(y), colSums(y)) }) -test_that("log_mat_mat returns a matrix with colnames and rownames", { +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 <- log_mat_mat(x) - z <- log_mat_sexp(x) - r <- log(x) - - expect_equal(y, r) - expect_equal(z, r) + 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")) })