tests/testthat/test-hilbert.R

In approxOT: Approximate and Exact Optimal Transport Methods

testthat::test_that("hilbert.projection works", {
  set.seed(20980)
  
  x <- matrix(rnorm(1000*10),1000,10)
  idx_x <- hilbert.projection(x)
  y <- matrix(rnorm(1000*10),1000,10)
  idx_y <- hilbert.projection(y)
  
  testtplan <- list()
  testtplan$from <- idx_x[order(idx_y)]
  testtplan$to <- 1:1000
  
  hilbert_dist <- sqrt(mean(rowSums((x[idx_x,] - y[idx_y,])^2)))
  hilbert_dist2 <- sqrt(mean(rowSums((x[testtplan$from,] - y[testtplan$to,])^2)))
  hilbert_dist3 <- sqrt(mean(rowSums((x[testtplan$from,] - y)^2)))
  tplan <- approxOT::transport_plan(x,y, p = 2, ground_p = 2, 
                                    observation.orientation = "rowwise",
                                    method = "hilbert")
  wass <- sqrt(mean(rowSums((x[tplan$tplan$from, ] - y[tplan$tplan$to,])^2)))
  testthat::expect_equal(tplan$tplan$from, testtplan$from)
  testthat::expect_equal(tplan$tplan$to, testtplan$to)
  testthat::expect_equal(hilbert_dist, wass)
  testthat::expect_equal(hilbert_dist2, wass)
  testthat::expect_equal(hilbert_dist3, wass)
  
})

testthat::test_that("hilbert.projection 1d wass", {
  set.seed(234234)
  n1 <- 100
  n2 <- 200
  d<- 1
  
  x <- matrix(rnorm(n1*d),n1,d)
  idx_x <- hilbert.projection(x)
  y <- matrix(rnorm(n2*d),n2,d)
  idx_y <- hilbert.projection(y)
  
  testthat::expect_equal(idx_x, order(x))
  testthat::expect_equal(idx_y, order(y))
  
})