tests/testthat/test-tsearchn.R

context("tsearchn")
test_that("tsearchn gives the expected output", {
  ## Simple example
  x <- c(-1, -1, 1)
  y <- c(-1, 1, -1)
  p <- cbind(x, y)
  tri <- matrix(c(1, 2, 3), 1, 3)
  ## Should be in triangle #1
  ts <- tsearchn(p, tri, cbind(-1, -1),fast=FALSE)
  expect_equal(ts$idx, 1)
  expect_equal(ts$p, cbind(1, 0, 0))
  ## Should be in triangle #1
  ts <- tsearchn(p, tri, cbind(1, -1), fast=FALSE)
  expect_equal(ts$idx, 1)
  expect_equal(ts$p, cbind(0, 0, 1))
  ## Should be in triangle #1
  ts <- tsearchn(p, tri, cbind(-1, 1), fast=FALSE)
  expect_equal(ts$idx, 1)
  expect_equal(ts$p, cbind(0, 1, 0))
  ## Centroid
  ts <- tsearchn(p, tri, cbind(-1/3, -1/3), fast=FALSE)
  expect_equal(ts$idx, 1)
  expect_equal(ts$p, cbind(1/3, 1/3, 1/3))
  ## Should be outside triangle #1, so should return NA
  ts <- tsearchn(p, tri, cbind(1, 1), fast=FALSE)
  expect_true(is.na(ts$idx))
  expect_true(all(is.na(ts$p)))

  ## Create a mesh with a zero-area element (degenerate simplex)
  p <- cbind(c(-1, -1, 0, 1, 2),
             c(-1,  1, 0, 0, 0))
  tri <- rbind(c(1, 2, 3),
               c(3, 4, 5))
  ## Look for one point in one of the simplices and a point outwith the
  ## simplices. This forces tsearchn to look in all simplices. It
  ## shouldn't fail on the degenerate simplex.
  expect_warning(ts <- tsearchn(p, tri, rbind(c(-0.5, 0), c(3, 1)), fast=FALSE))
  expect_equal(ts$idx, c(1, NA))
  ts <- tsearchn(p, tri, rbind(c(-0.5, 0), c(3, 1)), fast=TRUE)
  expect_equal(ts$idx, c(1, NA))
})



context("tsearchn_delaunayn")
test_that("tsearchn gives the expected output", {
  ## Erroneous input is caught safely. Force
  ## tsearchn_delaunayn to be called
  tfake <- matrix(1:3, 1, 3)
  class(tfake) <- "delaunayn"
  expect_error(suppressWarnings(tsearchn(NA, tfake, matrix(1:2, 1, 2))), "Delaunay triangulation has no delaunayn attribute")

  x <- cbind(c(-1, -1, 1),
             c(-1, 1, -1))

  dt <- delaunayn(x, output.options=TRUE)

  ## Should be in triangle #1
  xi <- cbind(-1, 1)
  expect_warning(ts <- tsearchn(NA, dt, xi))
  expect_equal(ts$idx, 1)
  expect_equal(bary2cart(x[dt$tri[ts$idx,],], ts$p), xi)

  ## Centroid
  xi <- cbind(-1/3, -1/3)
  expect_warning(ts <- tsearchn(NA, dt, xi))
  expect_equal(ts$idx, 1)
  expect_equal(ts$p, cbind(1/3, 1/3, 1/3))

  ## Should be outside triangle #1, so should return NA
  xi <- cbind(1, 1)
  expect_warning(ts <- tsearchn(NA, dt, xi))
  expect_true(is.na(ts$idx))
  expect_true(all(is.na(ts$p)))

  ## Check mutliple points work
  xi <- rbind(c(-1, 1),
              c(-1/3, -1/3))
  expect_warning(ts <- tsearchn(NA, dt, xi))
  expect_equal(ts$idx, c(1, 1))
  expect_equal(do.call(rbind, lapply(1:2, function(i) {
    bary2cart(x[dt$tri[ts$idx[i],],], ts$p[i,])
  })), xi)


  ## Test against original version
  p <- cbind(c(0, 0, 1, 1, 0.5),
             c(0, 1, 1, 0, 0.5))
  dt <- delaunayn(p, "FA") ## Interesting error, as default options are 'nixed
  dt <- delaunayn(p, output.options=TRUE)
  xi <- c(0.1, 0.5, 0.9, 0.5)
  yi <- c(0.5, 0.9, 0.5, 0.1)
  expect_warning(ts <- tsearchn(NA, dt, cbind(xi, yi)))
  expect_equal(ts$idx,
               tsearch(p[,1], p[,2], dt$tri,  xi, yi, method="orig"))

  ## 3D test
  x <- rbox(D=3, B=1)
  dt <- delaunayn(x, output.options=TRUE)

  xi <- rbind(c(0.5, 0.5, 0.5),
              c(-0.5, -0.5, -0.5),
              c(0.9, 0, 0))
  expect_warning(ts <- tsearchn(NA, dt, xi))
  expect_equal(do.call(rbind, lapply(1:3, function(i) {
    bary2cart(x[dt$tri[ts$idx[i],],], ts$p[i,])
  })), xi)

  ## 4D test
  ##
  ## This does not work yet. The "best" facet is not always the correct facet.
  ## x <- rbox(D=4, B=1)
  ## dt <- delaunayn(x, output.options=TRUE)

  ## xi <- rbind(c(0.5, 0.5, 0.5, 0.5),
  ##             c(-0.49, -0.49, -0.49, -0.49),
  ##             c(0.9, 0, 0, 0))
  ## ts <- tsearchn(dt, NA, xi)
  ## expect_equal(do.call(rbind, lapply(1:3, function(i) {
  ##   bary2cart(x[dt$tri[ts$idx[i],],], ts$p[i,])
  ## })), xi)
  
  ## We don't need to test when creating a mesh with a zero-area
  ## element (degenerate simplex), as these shouldn't be produced by
  ## qhull.

})

Try the geometry package in your browser

Any scripts or data that you put into this service are public.

geometry documentation built on Feb. 16, 2023, 10:08 p.m.