# 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"))
# })
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.