testthat::test_that("wasserstein gives 0 for same distribution", { set.seed(11289374) n <- 21 d <- 5 x <- matrix(stats::rnorm(n*d), nrow=d, ncol=n) y <- stats::rnorm(n) niter <- 1e2 # y <- matrix(stats::rnorm(n*d), nrow=d, ncol=n) exact <- WpProj::wasserstein(X = x, Y = x, p = 2, ground_p = 2, observation.orientation = "colwise", method = "exact") hilbert <- WpProj::wasserstein(X = x, Y = x, p = 2, ground_p = 2, observation.orientation = "colwise", method = "hilbert") rank <- WpProj::wasserstein(X = x, Y = x, p = 2, ground_p = 2, observation.orientation = "colwise", method = "rank") sinkhorn <- WpProj::wasserstein(X = x, Y = x, p = 2, ground_p = 2, observation.orientation = "colwise", method = "sinkhorn", niter = niter) # sinkhorn2 <- WpProj::wasserstein(X = x, Y = x, p = 2, # ground_p = 2, observation.orientation = "colwise", # method = "sinkhorn2", niter = niter) greenkhorn <- WpProj::wasserstein(X = x, Y = x, p = 2, ground_p = 2, observation.orientation = "colwise", method = "greenkhorn", niter = niter) # randkhorn <- WpProj::wasserstein(X = x, Y = x, p = 2, # ground_p = 2, observation.orientation = "colwise", # method = "randkhorn", niter = niter) # gandkhorn <- WpProj::wasserstein(X = x, Y = x, p = 2, # ground_p = 2, observation.orientation = "colwise", # method = "gandkhorn", niter = niter) uni.pwr <- WpProj::wasserstein(X = x, Y = x, p = 2, ground_p = 2, observation.orientation = "colwise", method = "univariate.approximation.pwr") # uni.app <- WpProj::wasserstein(X = x, Y = x, p = 2, # ground_p = 2, observation.orientation = "colwise", # method = "univariate.approximation") testthat::expect_equal(exact, 0) testthat::expect_equal(hilbert, 0) testthat::expect_lt(sinkhorn, 0.17) # testthat::expect_lt(sinkhorn2, 0.05) #compare espen bernton and pierre jacob's funct to one from Greenkhorn paper testthat::expect_lt(greenkhorn, 0.17) # testthat::expect_lt(randkhorn, 0.05) # testthat::expect_lt(gandkhorn, 0.06) testthat::expect_equal(uni.pwr, 0) # testthat::expect_equal(uni.app, 0) exact.uni <- WpProj::wasserstein(X = y, Y = y, p = 2, ground_p = 2, observation.orientation = "colwise", method = "exact") hilbert.uni <- WpProj::wasserstein(X = y, Y = y, p = 2, ground_p = 2, observation.orientation = "colwise", method = "hilbert") rank.uni <- WpProj::wasserstein(X = y, Y = y, p = 2, ground_p = 2, observation.orientation = "colwise", method = "hilbert") sinkhorn.uni <- WpProj::wasserstein(X = y, Y = y, p = 2, ground_p = 2, observation.orientation = "colwise", method = "sinkhorn", niter = niter, epsilon = 2.4) # sinkhorn2.uni <- WpProj::wasserstein(X = y, Y = y, p = 2, # ground_p = 2, observation.orientation = "colwise", # method = "sinkhorn2", niter = niter) greenkhorn.uni <- WpProj::wasserstein(X = y, Y = y, p = 2, ground_p = 2, observation.orientation = "colwise", method = "greenkhorn", niter = niter) # randkhorn.uni <- WpProj::wasserstein(X = y, Y = y, p = 2, # ground_p = 2, observation.orientation = "colwise", # method = "randkhorn", niter = niter) # gandkhorn.uni <- WpProj::wasserstein(X = y, Y = y, p = 2, # ground_p = 2, observation.orientation = "colwise", # method = "gandkhorn", niter = niter) uni.pwr.uni <- WpProj::wasserstein(X = y, Y = y, p = 2, ground_p = 2, observation.orientation = "colwise", method = "univariate.approximation.pwr") # uni.app.uni <- WpProj::wasserstein(X = y, Y = y, p = 2, # ground_p = 2, observation.orientation = "colwise", # method = "univariate.approximation") testthat::expect_equal(exact.uni, 0) testthat::expect_equal(hilbert.uni, 0) testthat::expect_equal(rank.uni, 0) testthat::expect_lt(sinkhorn.uni, 1.4) # testthat::expect_lt(sinkhorn2.uni, 0.15) testthat::expect_lt(greenkhorn.uni, 0.3) # testthat::expect_lt(randkhorn.uni, 0.15) # testthat::expect_lt(gandkhorn.uni, 0.5) testthat::expect_equal(uni.pwr.uni, 0) # testthat::expect_equal(uni.app.uni, 0) }) testthat::test_that("wasserstein matches transport package for shortsimplex", { testthat::skip_if_not_installed("transport") set.seed(11289374) n <- 21 d <- 5 x <- matrix(stats::rnorm(n*d), nrow=d, ncol=n) y <- matrix(stats::rnorm(n*d), nrow=d, ncol=n) z <- stats::rnorm(n) w <- stats::rnorm(n) # y <- matrix(stats::rnorm(n*d), nrow=d, ncol=n) exact <- WpProj::wasserstein(X = x, Y = y, p = 2, ground_p = 2, observation.orientation = "colwise", method = "exact") exact.trans <- transport::wasserstein(a = rep(1,n), b = rep(1,n), p = 2, tplan = NULL, costm = cost_calc(x,y, 2), method = "shortsimplex" ) uni <- WpProj::wasserstein(X = z, Y = w, 2, 2, "colwise", "univariate") uni.trans <- transport::wasserstein1d(a = z, b = w, 2) testthat::expect_equal(exact, exact.trans) testthat::expect_equal(uni, uni.trans) # check for rowwise orientation exact.row <- WpProj::wasserstein(X = t(x), Y = t(y), p = 2, ground_p = 2, observation.orientation = "rowwise", method = "exact") uni.row <- WpProj::wasserstein(X = t(t(z)), Y = t(t(w)), 2, 2, "rowwise", "univariate") testthat::expect_equal(exact.row, exact.trans) testthat::expect_equal(uni.row, uni.trans) }) testthat::test_that("wasserstein from sp matches transport package",{ testthat::skip_if_not_installed("transport") set.seed(32857) A <- matrix(stats::rnorm(100*104),nrow=104,ncol=100) B <- matrix(stats::rnorm(100*104),nrow=104,ncol=100) at <- t(A) bt <- t(B) cost <- cost_calc(at,bt,2) mass_a <- rep(1/ncol(at),ncol(at)) mass_b <- rep(1/ncol(bt),ncol(bt)) tplan <- transport_plan_given_C(mass_a, mass_b, 2, cost, "exact") loss <- wasserstein_(tplan$mass, cost, p = 2, tplan$from, tplan$to) loss_t <- transport::wasserstein(transport::pp(A),transport::pp(B),p=2, method = "shortsimplex") loss_t_def <- transport::wasserstein(mass_a,mass_b, tplan = data.frame(tplan), costm = cost, p=2, method = "shortsimplex") testthat::expect_equivalent(loss, loss_t) testthat::expect_equivalent(loss, loss_t_def) # microbenchmark::microbenchmark(transport::wasserstein(mass_a,mass_b, tplan = data.frame(tplan), costm = cost, p=2, method = "shortsimplex"), unit="us") # microbenchmark::microbenchmark(wasserstein_(tplan$mass, cost, p = 2, tplan$from, tplan$to), unit = "us") # microbenchmark::microbenchmark(sinkhorn_(mass_a, mass_b, cost^2, 0.05*median(cost^2), 100), unit="ms") C <- t(A[1:10,,drop = FALSE]) D <- t(B[1:2,,drop = FALSE]) cost2 <- cost_calc(C,D,2) mass_c <- rep(1/ncol(C),ncol(C)) mass_d <- rep(1/ncol(D),ncol(D)) tplan2 <- transport_plan_given_C(mass_c, mass_d, 2, cost2, "exact") loss <- wasserstein_(tplan2$mass, cost2, p = 2, tplan2$from, tplan2$to) loss_t_def <- transport::wasserstein(mass_c,mass_d, tplan = data.frame(tplan2), costm = cost2, p=2, method = "shortsimplex") testthat::expect_equivalent(loss, loss_t_def) }) testthat::test_that("make sure wass less than all other transports", { set.seed(32857) A <- matrix(stats::rnorm(100*124),nrow=124,ncol=100) B <- matrix(stats::rnorm(100*124),nrow=124,ncol=100) at <- t(A) bt <- t(B) cost <- cost_calc(at,bt,2) mass_a <- rep(1/ncol(at),ncol(at)) mass_b <- rep(1/ncol(bt),ncol(bt)) tplan <- transport_plan_given_C(mass_a, mass_b, 2, cost, "exact") loss <- wasserstein_(tplan$mass, cost, p = 2, tplan$from, tplan$to) hilbert <- wasserstein(at,bt, 2, 2, "colwise", "hilbert") rank <- wasserstein(at,bt, 2, 2, "colwise", "rank") uap <- wasserstein(at,bt, 2, 2, "colwise", "univariate.approximation.pwr") sink <- wasserstein(at,bt, 2, 2, "colwise", "sinkhorn") grnk <- wasserstein(at,bt, 2, 2, "colwise", "greenkhorn") # rand <- wasserstein(at,bt, 2, 2, "colwise", "randkhorn") # gand <- wasserstein(at,bt, 2, 2, "colwise", "gandkhorn") testthat::expect_lt(loss, hilbert) testthat::expect_lt(loss, rank) testthat::expect_lt(loss, sink) testthat::expect_lt(loss, grnk) # testthat::expect_lt(loss, rand) # testthat::expect_lt(loss, gand) testthat::expect_gt(loss, uap) }) testthat::test_that("make sure sinkhorn outputs agree and are less than wass", { set.seed(32857) A <- matrix(stats::rnorm(100*104),nrow=104,ncol=100) B <- matrix(stats::rnorm(100*104),nrow=104,ncol=100) at <- t(A) bt <- t(B) cost <- cost_calc(at,bt,2) mass_a <- rep(1/ncol(at),ncol(at)) mass_b <- rep(1/ncol(bt),ncol(bt)) tplan <- transport_plan_given_C(mass_a, mass_b, 2, cost, "exact") loss <- wasserstein_(tplan$mass, cost, p = 2, tplan$from, tplan$to) sink <- wasserstein(A, B, 2, 2, "colwise", "sinkhorn") # sinkcost1 <- sink$distances^(1/2) # sinkcost2 <- sum(sink$transportmatrix * cost^2)^(1/2) # testthat::expect_equivalent(sinkcost1, sinkcost2) testthat::expect_lt(loss, sink) }) testthat::test_that("give error when p < 1", { set.seed(32857) A <- matrix(stats::rnorm(100*124),nrow=124,ncol=100) B <- matrix(stats::rnorm(100*124),nrow=124,ncol=100) ground_p <- 2 p <- 0 testthat::expect_error(wasserstein(at,bt, p = p, ground_p = ground_p, "colwise", "hilbert")) testthat::expect_error(wasserstein(at,bt, p = p, ground_p = ground_p, "colwise", "rank")) testthat::expect_error(wasserstein(at,bt, p = p, ground_p = ground_p, "colwise", "univariate.approximation.pwr")) testthat::expect_error(wasserstein(at,bt, p = p, ground_p = ground_p, "colwise", "sinkhorn")) testthat::expect_error(wasserstein(at,bt, p = p, ground_p = ground_p, "colwise", "greenkhorn")) # testthat::expect_error(wasserstein(at,bt, p = p, ground_p = ground_p, "colwise", "randkhorn")) # testthat::expect_error(wasserstein(at,bt, p = p, ground_p = ground_p, "colwise", "gandkhorn")) })