Merge pull request #17 from MindTheGap-ERC/dev

Dev

.Rbuildignore

@@ -12,3 +12,4 @@
 ^Meta$
 ^cran-comments\.md$
 ^CRAN-SUBMISSION$
+^.covrignore$

.covrignore

@@ -0,0 +1 @@
+R/zzz.R

R/p3_var_rate.R

@@ -51,7 +51,7 @@ p3_var_rate = function(x, y = NULL, from = 0, to = 1, f_max = 1, n = NULL){
     vol = stats::integrate(f, lower = from, upper = to)$value
     n = stats::rpois(1, lambda = vol)
   }
-  if (n <= 0){ return(c())}
+  if (n <= 0){ return(numeric())}
 
   # rejection sampling
   x = rej_samp(f = f,x_min = from, x_max = to, n = n, f_max = f_max)

R/rej_samp.R

@@ -1,4 +1,4 @@
-rej_samp = function(f, x_min, x_max, n = 1L, f_max = 1){
+rej_samp = function(f, x_min, x_max, n = 1L, f_max = 1, max_try = 10^4){
   #' @export
   #'
   #' @title rejection sampling
@@ -11,6 +11,7 @@ rej_samp = function(f, x_min, x_max, n = 1L, f_max = 1){
   #' @param x_max scalar. upper limit of the examined interval
   #' @param n integer. number of samples drawn
   #' @param f_max maximum value of `f` in the interval from `x_min` to `x_max`. If f attains values larger than `f_max` a warning is throw, `f_max` is adjusted, and sampling is started again
+  #' @param max_try maximum number of tries in the rejection sampling algorithm. If more tries are needed, an error is thrown. If this is the case, inspect of your function `f` is well-defined and positive, and if `f_max` provides a reasonable upper bound on it. Adjust `max_try` if you are certain that both is the case, e.g. if `f` is highly irregular.
   #'
   #' @examples
     #'
@@ -21,13 +22,13 @@ rej_samp = function(f, x_min, x_max, n = 1L, f_max = 1){
   #' @seealso [p3_var_rate()] for the derived variable rate Poisson point process implementation.
   #'
   #' @returns numeric vector, sample of size `n` drawn from the (pseudo) pdf specified by `f`
-  x = c()
+  x = numeric()
   warn = FALSE
   if (f_max <= 0) {stop("`f_max` must be positive.")}
   if (x_max <= x_min) {stop("`x_max` must be larger than `x_min`")}
 
   if (n <= 0){ return(x)  }
-
+  failed_attempts = 0
   while (length(x) < n) {
     x_draw = stats::runif(1, min = x_min, max = x_max)
     if (f(x_draw) > f_max){
@@ -38,6 +39,12 @@ rej_samp = function(f, x_min, x_max, n = 1L, f_max = 1){
       y_draw = stats::runif(1, min = 0, max = f_max)
       if (y_draw < f(x_draw)){
         x = c(x, x_draw)
+        failed_attempts = 0
+      } else{
+        failed_attempts = failed_attempts + 1
+        if (failed_attempts > max_try){
+          stop(paste0("could not find sample within " , max_try ," attempts. Check `f`, reduce `f_max` or increase `max_try`. "))
+        }
       }
     }
   }

README.md

@@ -3,7 +3,6 @@
 <!-- badges: start -->
 
 [![R-CMD-check](https://github.com/MindTheGap-ERC/StratPal/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/MindTheGap-ERC/StratPal/actions/workflows/R-CMD-check.yaml) [![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.13373351.svg)](https://doi.org/10.5281/zenodo.13373351) [![CRAN status](https://www.r-pkg.org/badges/version/StratPal)](https://CRAN.R-project.org/package=StratPal) [![fair-software.eu](https://img.shields.io/badge/fair--software.eu-%E2%97%8F%20%20%E2%97%8F%20%20%E2%97%8F%20%20%E2%97%8F%20%20%E2%97%8B-yellow)](https://fair-software.eu)
-[![Codecov test coverage](https://codecov.io/gh/MindTheGap-ERC/StratPal/graph/badge.svg)](https://app.codecov.io/gh/MindTheGap-ERC/StratPal)
 <!-- badges: end -->
 
 R package for stratigraphic paleobiology modeling pipelines.

tests/testthat/test_apply_niche.R

@@ -0,0 +1,5 @@
+test_that("returns fewer events", {
+  n = 10
+  x = runif(n, 0, 1)
+  expect_lt(length(apply_niche(x, niche_def = function(x) 0.5, gc =  function(x) 1)), n)
+})

tests/testthat/test_apply_taphonomy.R

@@ -0,0 +1,5 @@
+test_that("returns fewer events", {
+  n = 10
+  x = runif(n, 0, 1)
+  expect_lt(length(apply_taphonomy(x, pres_potential = function(x) 0.5, ctc =  function(x) 1)), n)
+})

tests/testthat/test_ornstein_uhlenbeck.R

@@ -11,3 +11,7 @@ test_that("wrong parameter values are caught correctly", {
   expect_error(ornstein_uhlenbeck(c(1,2), theta = -1))
   expect_error(ornstein_uhlenbeck(c(1,2), theta = 0, y0 = "stationary"))
 })
+
+test_that("return class is correct", {
+  expect_s3_class(ornstein_uhlenbeck(c(1,2), y0 = "stationary"), "timelist")
+})

tests/testthat/test_p3.R

@@ -10,3 +10,12 @@ test_that("contitioning on number of samples works",{
   n = 10
   expect_equal(length(p3(1, 0, 1, n = n)), n )
 })
+
+test_that("returns correct answer for 0 samples", {
+  expect_equal(p3(1, 0, 1, n = 0), numeric())
+})
+
+test_that("returns correct type", {
+  expect_type(p3(1,0,1), "double")
+  expect_type(p3(1,0,1, n = 0), "double")
+})

tests/testthat/test_p3_var_rate.R

@@ -10,3 +10,12 @@ test_that("retruns correct number of events under conditioning",{
   n = 10
   expect_equal(length(p3_var_rate(function(x) 1, from = 0, to = 1, n = n)), n)
 })
+
+test_that("runs without error", {
+  expect_no_condition(p3_var_rate(x = c(0, 1), y = c(1,1), 0, 1))
+})
+
+test_that("returns empty numeric vector for sample size 0", {
+  expect_type(p3_var_rate(identity, from = 0, to = 1, n = 0), "double")
+  expect_equal(length(p3_var_rate(identity, from = 0, to = 1, n = 0)), 0)
+})

tests/testthat/test_rej_samp.R

@@ -10,3 +10,16 @@ test_that("retruns correct no of samples",{
 test_that("throws warning if density is too high",{
   expect_warning(rej_samp(function(x) 10^6, 0, 1, n = 1000))
 })
+
+test_that("throws error for negative `f_max`", {
+  expect_error(rej_samp(identity, 0, 1, f_max = 0))
+})
+
+test_that("returns correct results for negative n", {
+  expect_equal(rej_samp(identity, 0, 1, n = 0), numeric())
+})
+
+
+test_that("throws error if no sample can be determined within sufficient tries", {
+  expect_error(rej_samp(function (x) rep(0, length(x)), 0, 1, max_try = 100))
+})