add many more tests

pachadotdev · pachadotdev · commit 0323c60b9075 · 2025-11-30T09:24:15.000Z
diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml
@@ -34,14 +34,33 @@ jobs:
         run: |
           options(warn = 2)
           pak::local_install("./", dependencies = TRUE)
+          
+          # Override Makevars to avoid _FORTIFY_SOURCE warning with -O0
+          # covr adds --coverage which needs -O0, but _FORTIFY_SOURCE needs -O
+          makevars_content <- paste(
+            "PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS)",
+            "PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS)"
+            sep = "\n"
+          )
+          writeLines(makevars_content, "./extended-tests/cpp4rtest/src/Makevars")
+          
           pak::local_install("./extended-tests/cpp4rtest", dependencies = TRUE)
         shell: Rscript {0}
 
       - name: Test coverage
         run: |
-          coverage <- covr::package_coverage("./extended-tests/cpp4rtest", quiet = FALSE)
-          percent <- round(covr::percent_coverage(coverage))
-          cat("Coverage:", percent, "%\n")
+          coverage <- covr::package_coverage(
+            "./extended-tests/cpp4rtest",
+            type = "all",
+            quiet = FALSE
+          )
+          
+          # Debug: show coverage breakdown
+          print(coverage)
+          
+          percent_exact <- covr::percent_coverage(coverage)
+          percent <- floor(percent_exact)  # Use floor for conservative estimate
+          cat("\nCoverage:", percent_exact, "% (rounded down to", percent, "%)\n")
           
           # Create badge color based on coverage
           if (percent >= 90) {
diff --git a/extended-tests/cpp4rtest/NAMESPACE b/extended-tests/cpp4rtest/NAMESPACE
@@ -7,6 +7,5 @@ export(roxcpp3)
 export(roxcpp4)
 export(roxcpp5)
 export(roxcpp7)
-export(run_tests)
 exportPattern("_$")
 useDynLib(cpp4rtest, .registration = TRUE)
diff --git a/extended-tests/cpp4rtest/R/test.R b/extended-tests/cpp4rtest/R/test.R
diff --git a/extended-tests/cpp4rtest/man/run_tests.Rd b/extended-tests/cpp4rtest/man/run_tests.Rd
diff --git a/extended-tests/cpp4rtest/src/Makevars.in b/extended-tests/cpp4rtest/src/Makevars.in
@@ -9,4 +9,7 @@ PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS)
 # PKG_CPPFLAGS = -UDEBUG -g -I vendor/
 
 # uncomment to disable compiler optimizations
-PKG_CXXFLAGS = -Wall -O0 -pedantic
+# PKG_CXXFLAGS = -Wall -O0 -pedantic
+
+# for local test coverage
+# PKG_CXXFLAGS = -Wall -O2 -pedantic
diff --git a/extended-tests/cpp4rtest/src/main.cpp b/extended-tests/cpp4rtest/src/main.cpp
@@ -1,5 +1,6 @@
 #include <cpp4r.hpp>
 
+#include <R.h>      // RNG state functions
 #include <Rmath.h>  // for Rf_rgamma, Rf_rnorm
 #include <deque>    // for std::deque
 #include <numeric>  // for std::accumulate
diff --git a/extended-tests/cpp4rtest/src/matrix.h b/extended-tests/cpp4rtest/src/matrix.h
@@ -1,21 +1,24 @@
 [[cpp4r::register]] SEXP gibbs_cpp(int N, int thin) {
   cpp4r::writable::doubles_matrix<> mat(N, 2);
   double x = 0, y = 0;
+  GetRNGstate();
   for (int i = 0; i < N; i++) {
     for (int j = 0; j < thin; j++) {
       x = Rf_rgamma(3., 1. / double(y * y + 4));
       y = Rf_rnorm(1. / (x + 1.), 1. / sqrt(2. * (x + 1.)));
       // REprintf("x: %f y: %f\n", x, y);
     }
-    mat[i][0] = x;
-    mat[i][1] = y;
+    mat(i, 0) = x;
+    mat(i, 1) = y;
   }
+  PutRNGstate();
   return mat;
 }
 
 [[cpp4r::register]] cpp4r::doubles_matrix<> gibbs_cpp2(int N, int thin) {
   cpp4r::writable::doubles_matrix<> mat(N, 2);
   double x = 0, y = 0;
+  GetRNGstate();
   for (int i = 0; i < N; i++) {
     for (int j = 0; j < thin; j++) {
       x = Rf_rgamma(3., 1. / double(y * y + 4));
@@ -24,6 +27,7 @@
     mat(i, 0) = x;
     mat(i, 1) = y;
   }
+  PutRNGstate();
   return mat;
 }
 
diff --git a/extended-tests/cpp4rtest/tests/testthat/test-add.R b/extended-tests/cpp4rtest/tests/testthat/test-add.R
@@ -0,0 +1,19 @@
+# Tests for add.h functions
+
+test_that("cpp4r_add_vec_for_ works", {
+  x <- c(1.0, 2.0, 3.0)
+  result <- cpp4r_add_vec_for_(x, 10.0)
+  expect_equal(as.numeric(result), c(11.0, 12.0, 13.0))
+})
+
+test_that("cpp4r_add_vec_for_ handles empty vector", {
+  x <- numeric(0)
+  result <- cpp4r_add_vec_for_(x, 5.0)
+  expect_length(result, 0)
+})
+
+test_that("cpp4r_add_vec_for_ handles negative numbers", {
+  x <- c(-1.0, 0.0, 1.0)
+  result <- cpp4r_add_vec_for_(x, -5.0)
+  expect_equal(as.numeric(result), c(-6.0, -5.0, -4.0))
+})
diff --git a/extended-tests/cpp4rtest/tests/testthat/test-cpp.R b/extended-tests/cpp4rtest/tests/testthat/test-cpp.R
@@ -1 +1,19 @@
-run_cpp_tests("cpp4rtest")
+# Run C++ unit tests
+test_that("C++ unit tests run without unexpected errors", {
+    # https://stackoverflow.com/a/79565018/3720258
+    expect_warnings <- function(object, warnings, ...) {
+        wrns <- testthat::capture_warnings({
+            act <- testthat::quasi_label(rlang::enquo(object), arg = "object")
+        })
+        res <- vapply(warnings, function(wrn) any(grepl(wrn, wrns)), FUN.VALUE = logical(1))
+        if (all(res)) {
+            testthat::succeed()
+            return(invisible(act$val))
+        } else {
+            msg <- sprintf("%s did not produce one or more warnings: %s", act$lab, toString(names(res)[!res]))
+            testthat::fail(msg)
+        }
+        }
+
+    expect_warnings(run_cpp_tests("cpp4rtest"), rep("test", 3))
+})
diff --git a/extended-tests/cpp4rtest/tests/testthat/test-data-frame.R b/extended-tests/cpp4rtest/tests/testthat/test-data-frame.R
@@ -0,0 +1,10 @@
+# Tests for data_frame.h functions
+
+test_that("data_frame_ works", {
+  result <- data_frame_()
+  expect_s3_class(result, "data.frame")
+  expect_equal(nrow(result), 3)
+  expect_equal(ncol(result), 2)
+  expect_equal(result$nums, c(1, 2, 3))
+  expect_equal(result$letters, c("x", "y", "z"))
+})
diff --git a/extended-tests/cpp4rtest/tests/testthat/test-errors.R b/extended-tests/cpp4rtest/tests/testthat/test-errors.R
@@ -0,0 +1,14 @@
+# Tests for errors.h and errors_fmt.h functions
+
+# errors_fmt.h tests
+test_that("my_stop with extra arg works", {
+  expect_error(my_stop("test error", 1L), "test error")
+})
+
+test_that("my_warning with extra arg works", {
+  expect_warning(my_warning("test warning", "arg"), "test warning")
+})
+
+test_that("my_message with extra arg works", {
+  expect_message(my_message("test message", "arg"), "test message")
+})
diff --git a/extended-tests/cpp4rtest/tests/testthat/test-find-intervals.R b/extended-tests/cpp4rtest/tests/testthat/test-find-intervals.R
@@ -0,0 +1,48 @@
+# Tests for find-intervals.h functions
+
+test_that("remove_altrep works", {
+  x <- c(1.0, 2.0, 3.0)
+  result <- remove_altrep(x)
+  # Function copies doubles - verify type and length
+  expect_type(result, "double")
+  expect_length(result, length(x))
+})
+
+test_that("upper_bound works", {
+  breaks <- c(1.0, 2.0, 3.0, 4.0, 5.0)
+  # upper_bound returns 0-indexed position of first element > x
+  expect_equal(upper_bound(2.5, breaks), 2)  # position after 2.0
+  expect_equal(upper_bound(0.5, breaks), 0)  # before all elements
+  expect_equal(upper_bound(5.5, breaks), 5)  # after all elements
+})
+
+test_that("findInterval2 works", {
+  breaks <- c(1.0, 2.0, 3.0, 4.0, 5.0)
+  x <- c(0.5, 1.5, 2.5, 3.5, 4.5, 5.5)
+  result <- findInterval2(x, breaks)
+  expect_equal(result, c(0L, 1L, 2L, 3L, 4L, 5L))
+})
+
+test_that("findInterval2_5 works", {
+  breaks <- c(1.0, 2.0, 3.0, 4.0, 5.0)
+  x <- c(0.5, 1.5, 2.5, 3.5, 4.5, 5.5)
+  result <- findInterval2_5(x, breaks)
+  expect_equal(result, c(0L, 1L, 2L, 3L, 4L, 5L))
+})
+
+test_that("findInterval3 works", {
+  breaks <- c(1.0, 2.0, 3.0, 4.0, 5.0)
+  x <- c(0.5, 1.5, 2.5, 3.5, 4.5, 5.5)
+  result <- findInterval3(x, breaks)
+  expect_equal(result, c(0L, 1L, 2L, 3L, 4L, 5L))
+})
+
+test_that("findInterval functions match base R findInterval", {
+  breaks <- c(1.0, 2.0, 3.0, 4.0, 5.0)
+  x <- c(0.5, 1.5, 2.5, 3.5, 4.5, 5.5)
+  base_result <- findInterval(x, breaks)
+
+  expect_equal(findInterval2(x, breaks), base_result)
+  expect_equal(findInterval2_5(x, breaks), base_result)
+  expect_equal(findInterval3(x, breaks), base_result)
+})
diff --git a/extended-tests/cpp4rtest/tests/testthat/test-matrix-gibbs.R b/extended-tests/cpp4rtest/tests/testthat/test-matrix-gibbs.R
@@ -0,0 +1,41 @@
+# Tests for matrix.h Gibbs sampler and matrix operations
+
+test_that("gibbs_cpp works", {
+  set.seed(123)
+  result <- gibbs_cpp(10L, 5L)
+  expect_true(is.matrix(result))
+  expect_equal(dim(result), c(10L, 2L))
+  expect_type(result, "double")
+})
+
+test_that("gibbs_cpp2 works", {
+  set.seed(123)
+  result <- gibbs_cpp2(10L, 5L)
+  expect_true(is.matrix(result))
+  expect_equal(dim(result), c(10L, 2L))
+  expect_type(result, "double")
+})
+
+test_that("gibbs_cpp and gibbs_cpp2 produce same results with same seed", {
+  set.seed(123)
+  result1 <- gibbs_cpp(10L, 5L)
+  set.seed(123)
+  result2 <- gibbs_cpp2(10L, 5L)
+  expect_equal(result1, result2)
+})
+
+test_that("matrix_add works", {
+  x <- matrix(as.double(1:4), nrow = 2, ncol = 2)
+  y <- matrix(as.double(5:8), nrow = 2, ncol = 2)
+  result <- matrix_add(x, y)
+  expect_true(is.matrix(result))
+  expect_equal(dim(result), c(2L, 2L))
+  expect_equal(result, x + y)
+})
+
+test_that("matrix_add handles larger matrices", {
+  x <- matrix(as.double(1:100), nrow = 10, ncol = 10)
+  y <- matrix(as.double(101:200), nrow = 10, ncol = 10)
+  result <- matrix_add(x, y)
+  expect_equal(result, x + y)
+})
diff --git a/extended-tests/cpp4rtest/tests/testthat/test-protect.R b/extended-tests/cpp4rtest/tests/testthat/test-protect.R
@@ -0,0 +1,59 @@
+# Tests for protect.h and release.h functions
+# These test memory protection mechanisms - we verify they don't crash
+# and that the protected objects remain valid
+
+# protect.h tests - single object protection
+test_that("protect_one_ completes without error", {
+  x <- c(1.0, 2.0, 3.0)
+  # Run protection cycle and verify object is still valid after
+
+  protect_one_(x, 10L)
+  expect_equal(x, c(1.0, 2.0, 3.0))
+})
+
+test_that("protect_one_sexp_ completes without error", {
+  x <- c(1.0, 2.0, 3.0)
+  protect_one_sexp_(x, 10L)
+  expect_equal(x, c(1.0, 2.0, 3.0))
+})
+
+test_that("protect_one_cpp4r_ completes without error", {
+  x <- c(1.0, 2.0, 3.0)
+  protect_one_cpp4r_(x, 10L)
+  expect_equal(x, c(1.0, 2.0, 3.0))
+})
+
+test_that("protect_one_preserve_ completes without error", {
+  x <- c(1.0, 2.0, 3.0)
+  protect_one_preserve_(x, 10L)
+  expect_equal(x, c(1.0, 2.0, 3.0))
+})
+
+# protect.h tests - multiple object protection
+test_that("protect_many_ completes without error", {
+  # This creates n protected integers internally
+
+  expect_no_error(protect_many_(10L))
+})
+
+test_that("protect_many_cpp4r_ completes without error", {
+  expect_no_error(protect_many_cpp4r_(10L))
+})
+
+test_that("protect_many_sexp_ completes without error", {
+  expect_no_error(protect_many_sexp_(10L))
+})
+
+test_that("protect_many_preserve_ completes without error", {
+  expect_no_error(protect_many_preserve_(10L))
+})
+
+# release.h tests
+test_that("cpp4r_release_ completes without error", {
+  # This creates and releases n sexp objects
+ expect_no_error(cpp4r_release_(10L))
+})
+
+test_that("cpp4r_release_ handles larger allocations", {
+  expect_no_error(cpp4r_release_(100L))
+})
diff --git a/extended-tests/cpp4rtest/tests/testthat/test-roxygen-internal.R b/extended-tests/cpp4rtest/tests/testthat/test-roxygen-internal.R
@@ -0,0 +1,15 @@
+# Tests for internal (non-exported) roxygen functions
+
+# roxygen1.h tests (internal function)
+test_that("notroxcpp1_ works", {
+  expect_equal(notroxcpp1_(1.0), 2.0)
+  expect_equal(notroxcpp1_(0.0), 1.0)
+  expect_equal(notroxcpp1_(-1.0), 0.0)
+})
+
+# roxygen3.h tests (internal function)
+test_that("notroxcpp6_ works", {
+  expect_equal(notroxcpp6_(1.0), 7.0)
+  expect_equal(notroxcpp6_(0.0), 6.0)
+  expect_equal(notroxcpp6_(-1.0), 5.0)
+})
diff --git a/extended-tests/cpp4rtest/tests/testthat/test-safe.R b/extended-tests/cpp4rtest/tests/testthat/test-safe.R
@@ -0,0 +1,22 @@
+# Tests for safe.h functions
+
+test_that("cpp4r_safe_ works", {
+  x <- c(1.0, 2.0, 3.0)
+  result <- cpp4r_safe_(x)
+  expect_type(result, "double")
+  expect_length(result, 1)
+})
+
+test_that("cpp4r_safe_ handles single element", {
+  x <- 42.0
+  result <- cpp4r_safe_(x)
+  expect_type(result, "double")
+  expect_length(result, 1)
+})
+
+test_that("cpp4r_safe_ returns allocated vector via unwind_protect", {
+  x <- as.double(1:10)
+  result <- cpp4r_safe_(x)
+  # The function allocates a REALSXP of length 1 via unwind_protect
+  expect_true(is.double(result))
+})
diff --git a/extended-tests/cpp4rtest/tests/testthat/test-strings.R b/extended-tests/cpp4rtest/tests/testthat/test-strings.R
diff --git a/extended-tests/cpp4rtest/tests/testthat/test-sum.R b/extended-tests/cpp4rtest/tests/testthat/test-sum.R
diff --git a/extended-tests/cpp4rtest/tests/testthat/test-vector-operations.R b/extended-tests/cpp4rtest/tests/testthat/test-vector-operations.R
diff --git a/vignettes/16-FAQ.Rmd b/vignettes/16-FAQ.Rmd
