fix warnings, add docs, add tests

NAMESPACE

@@ -5,4 +5,5 @@ export(getSupportedMethods)
 export(stardiscrepancy)
 import(BBmisc)
 import(checkmate)
+importFrom(stats,runif)
 useDynLib(sampling, .registration = TRUE)

R/design.R

@@ -2,7 +2,8 @@
 #' Create a design.
 #'
 #' @description
-#' To be written ...
+#' Generate pseudo-randon or quasi-random designs. Basically a wrapper
+#' around different functions from packages \pkg{lhs} and \pkg{randtoolbox}.
 #'
 #' @param n [\code{integer(1)}]\cr
 #'   Number of design points (rows).
@@ -24,7 +25,7 @@
 #'     \item{maximinlhs}{Delegate to \code{\link[lhs]{maximinLHS}}.}
 #'     \item{geneticlhs}{Delegate to \code{\link[lhs]{geneticLHS}}.}
 #'     \item{halton}{Delegate to \code{\link[randtoolbox]{halton}}.}
-#'     \item{sobol}{Delegate to \code{\link[randtoolbox]{sobol}}.}
+#'     \item{sobol}{Delegate to \code{\link[randtoolbox]{sobol}} with option scrambling=3.}
 #'   }
 #' @param as.df [\code{logical(1)}]\cr
 #'   Return points as data frame?
@@ -35,7 +36,7 @@
 #' @examples
 #' methods = getSupportedMethods()
 #' designs = lapply(methods, function(method) {
-#'   design(n = 100, k = 2, method = method, l = -5, upper = c(5, 10), as.df = FALSE)
+#'   design(n = 100, k = 2, method = method, l = -5, u = c(5, 10), as.df = FALSE)
 #' })
 #'
 #' # pass down options to generator
@@ -65,12 +66,14 @@ design = function(n, k, method, l = 0, u = 1, as.df = TRUE, ...) {
     lhs::improvedLHS(n = n, k = k, ...)
   } else if (method == "maximinlhs") {
     lhs::maximinLHS(n = n, k = k, ...)
-  } else if (method == "improvedlhs") {
+  } else if (method == "geneticlhs") {
     lhs::geneticLHS(n = n, k = k, ...)
   } else if (method == "halton") {
     randtoolbox::halton(n = n, dim = k, ...)
   } else if (method == "sobol") {
-    randtoolbox::sobol(n = n, dim = k, scrambling = 3, seed = ceiling(runif(1L, min = 1, max = 1000000)))
+    args = BBmisc::insert(list(scrambling = 3, seed = ceiling(runif(1L, min = 1, max = 10000000))), list(...))
+    args$n = n; args$dim = k
+    do.call(randtoolbox::sobol, args)
   } else {
     BBmisc::stopf("[sampling::design] Unsupported method '%s'.", method)
   }

R/stardiscrepancy.R

@@ -1,32 +1,56 @@
 #' @title
-#' Calculate star discrepancy of a set of points.
+#' Star discrepancy calculation.
 #'
 #' @description
-#' To be written ...
+#' Method for calculating the (star) discrepancy of \eqn{n} points in \eqn{d}
+#' dimensions. The function offers an exact approach with running time
+#' \eqn{O(n^{1+d/2})} and a sophisticated approximation method based on
+#' threshold accepting introduced by Gnewuch, Wahlström, and Winzen [1].
 #'
 #' @param x [\code{matrix(n, d)}]\cr
 #'   An \eqn{n \times d} matrix where \eqn{n} is the number of points and \eqn{d}
 #'   is the dimension of the search space.
-#' @return [\numeric(1)]\cr Star discrepancy of \code{x}.
+#' @param method [\code{character(1)}]\cr
+#'   Use option \dQuote{exact} for exact star discrepancy calculation and
+#'   \dQuote{ta} for the threshold accepting based discrepancy algorithm by
+#'   Gnewuch, Wahlstroem and Winzen [1].
+#' @param iters [\code{integer(1)}]\cr
+#'   Number of iterations for the treshold accepting discrepancy approximation.
+#'   Default is 100000.
+#' @param trials [\code{integer(1)}]\cr
+#'   Number of independent trials of threshold accepting discrepancy approximation.
+#'   Default is 10.
+#' @return [\code{numeric}(1)]\cr Star discrepancy of \code{x}.
+#'
+#' @references [1] Gnewuch, Michael, Magnus Wahlström, and Carola Winzen. "A NEW RANDOMIZED
+#' ALGORITHM TO APPROXIMATE THE STAR DISCREPANCY BASED ON THRESHOLD ACCEPTING."
+#' SIAM Journal on Numerical Analysis 50, no. 2 (2012): 781-807.
+#' www.jstor.org/stable/41582760.
+#'
+#' @examples
+#' d = design(n = 20, k = 3, method = "uniform")
+#' stardiscrepancy(d)
+#' \dontrun{
+#' stardiscrepancy(d, method = "ta", iter = 100, trials = 3)
+#' }
 #' @export
-stardiscrepancy = function(x, force.exact = FALSE, iter = 1e4, trials = 10L) {
+stardiscrepancy = function(x, method = "exact", iters = 1e5, trials = 10) {
   if (checkmate::testDataFrame(x))
     x = unname(as.matrix(x))
 
   checkmate::assertMatrix(x, min.rows = 2L, min.cols = 2L, any.missing = FALSE, all.missing = FALSE, mode = "numeric")
   n = nrow(x)
-  k = ncol(x)
-  # if (n^(1+ceiling(k/2)) > 1e2) {
-
-  #   BBmisc::messagef("[sampling::stardiscrepancy] Exact star-discrepancy calculation requires
-  #     time O(n^{1+k/2}) time.\n We thus apply heuristic TA-algorithm.")
-
-  #   if (!force.exact)
-  #     return(.Call("starDiscrepancyTAC", t(x)))
-  # }
+  d = ncol(x)
 
-  #FIXME: seeding
-  return(.Call("starDiscrepancyTAC", t(x), as.integer(iter), as.integer(trials)))
+  checkmate::assertChoice(method, choices = c("exact", "ta"))
+  if (method == "exact") {
+    if (n^(1 + ceiling(d/2)) > 1e6) {
+      BBmisc::messagef("[sampling::stardiscrepancy] Exact star-discrepancy calculation requires
+        time O(n^{1+d/2}) time.\n Go grab yourself a coffee. This may take some time.")
+    }
+    return(.Call("starDiscrepancyC", t(x)))
+  }
 
-  # return(.Call("starDiscrepancyC", t(x)))
+  #SEEDING
+  return(.Call("starDiscrepancyTAC", t(x), as.integer(iters), as.integer(trials)))
 }

R/zzz.R

@@ -1,4 +1,5 @@
 #' @import BBmisc
 #' @import checkmate
+#' @importFrom stats runif
 #' @useDynLib sampling, .registration = TRUE
 NULL

tests/testthat/test_design.R

@@ -0,0 +1,22 @@
+context("design generation")
+
+test_that("designs are generated correctly", {
+  methods = getSupportedMethods()
+  dims = 2:4
+  n = 20L
+
+  # check basic functionality
+  for (method in methods) {
+    for (d in dims) {
+      des = design(n = n, k = d, method = method, as.df = TRUE)
+      checkmate::expect_data_frame(des, types = "numeric", nrows = n, ncols = d,
+        any.missing = FALSE, all.missing = FALSE)
+    }
+  }
+
+  # check if passing of further arguments works
+  # Here we deactivate scrambling and check whether it works
+  d1 = design(n = n, k = 2L, method = "sobol", as.df = FALSE, scrambling = 0)
+  d2 = design(n = n, k = 2L, method = "sobol", as.df = FALSE, scrambling = 0)
+  testthat::expect_true(all(d1 == d2))
+})

tests/testthat/test_discrepancy.R

@@ -0,0 +1,12 @@
+context("discrepancy")
+
+test_that("discrepancy calculation works", {
+  dims = 2:4
+  n = 20L
+
+  for (d in dims) {
+    des = design(n = n, k = d, method = "uniform", as.df = TRUE)
+    checkmate::expect_number(stardiscrepancy(des, method = "exact"), lower = 0, upper = 1)
+    checkmate::expect_number(stardiscrepancy(des, method = "ta", iters = 100L, trials = 1L), lower = 0, upper = 1)
+  }
+})