tests/testthat/test_SPDManifolds.R

In manifold: Operations for Riemannian Manifolds

# devtools::load_all()
library(testthat)

test_that('Helper functions for SPD(n) works', {
  
  # isSPD
  expect_true(isSPD(1))
  expect_true(isSPD(1e-10))
  expect_false(isSPD(0))

  # isSO
  expect_true(isSO(diag(2)))
  expect_false(isSO(diag(c(1, -1))))

  # NearestSPSD
  set.seed(1)
  d <- 3
  A <- matrix(rnorm(d^2), d, d)
  A <- A + t(A)
  B <- NearestSPSD(A)
  expect_true(isSPSD(B))
  expect_true(isSPD(B + diag(1e-13, d)))

  # MakeSym
  set.seed(1)
  v <- c(1, 2, 3) / 10
  A <- matrix(c(v[1], v[2], v[2], v[3]), 2, 2, byrow=TRUE)
  A1 <- matrix(c(v[1] * sqrt(2), v[2], v[2], v[3] * sqrt(2)), 2, 2, byrow=TRUE)
  Sv <- MakeSym(lowerTri=v)
  expect_equal(Sv, A)
  expect_true(isSymmetric(Sv))

  Sv1 <- MakeSym(lowerTri=v, doubleDiag=TRUE)
  expect_equal(Sv1, A1)

  # TransposeAsMatrix
  n <- 3
  T <- TransposeAsMatrix(n)
  expect_true(all(sapply(seq_len(10), function(i) {
    A <- matrix(rnorm(n^2), n, n)
    identical(t(A), matrix(T %*% c(A), n, n))
  })))
})


test_that('project.SPD and projectTangent.SPD works', {
  n <- 3
  A <- matrix(rnorm(n^2), n, n)
  A <- crossprod(A)
  expect_equal(project.SPD(NULL, c(A)), matrix(A))

  B <- MakeSym(matrix(rnorm(n^2), n, n))
  expect_equal(projectTangent.SPD(X=matrix(B)), matrix(B))

  C <- B
  C[2] <- C[2] + 1e-5
  expect_equal(projectTangent.SPD(X=matrix(C)), matrix((C + t(C)) / 2))
})


test_that('calcIntDim.SPD, calcGeomPar.SPD, calcTanDim.SPD work', {

  mfd <- structure(1, class='SPD')
  for (n in 2:4) {
    X <- diag(n)
    ambient <- length(X)
    intrinsic <- n * (n + 1) / 2
    tangent <- ambient

    expect_equal(calcGeomPar(mfd, dimTangent=tangent), n)
    expect_equal(calcIntDim(mfd, dimAmbient=ambient), intrinsic)
    expect_equal(calcIntDim(mfd, dimTangent=tangent), intrinsic)
    expect_equal(calcTanDim(mfd, dimAmbient=ambient), tangent)
    expect_equal(calcTanDim(mfd, dimIntrinsic=intrinsic), tangent)
    expect_error(calcGeomPar(mfd, 1, 2))
    expect_error(calcIntDim(mfd, 1, 2))
    expect_error(calcTanDim(mfd, 1, 2))
  }
})


test_that('rieLog.LogEu, rieExp.LogEu, distance.LogEu, metric.LogEu, norm.LogEu work', {
  
  for (n in 1:3) {
    mfd <- structure(list(), class='SPD')
    A <- matrix(rnorm(n ^ 2), n, n)
    O <- eigen(crossprod(A))$vectors

    ## rieLog.LogEu
    # scalar
    expect_equal(rieLog.LogEu(X=1), matrix(0))
    expect_equal(rieLog.LogEu(p=2, X=2), matrix(0))
    expect_equal(rieLog.LogEu(X=exp(1)), matrix(1))

    # matrix
    expect_equal(rieLog.LogEu(X=c(diag(n))), matrix(diag(0, n)))
    expect_equal(rieLog.LogEu(X=cbind(c(diag(n)), c(diag(n) * 2))), 
                 cbind(c(diag(0, n)), c(diag(log(2), n))))
    expect_equal(rieLog.LogEu(p=c(diag(2, n)), X=c(diag(2, n))), matrix(diag(0, n)))

    v <- exp(rnorm(n))
    expect_equal(rieLog.LogEu(X=c(O %*% diag(v, n) %*% t(O))), matrix(O %*% diag(log(v), n) %*% t(O)))

    ## rieExp.LogEu
    # scalar
    expect_equal(rieExp.LogEu(V=0), matrix(1))
    expect_equal(rieExp.LogEu(p=exp(-2), V=2), matrix(1))

    # matrix
    expect_equal(rieExp.LogEu(V=c(diag(0, n))), matrix(diag(1, n)))
    expect_equal(rieExp.LogEu(p=c(diag(2, n)), V=c(diag(-log(2), n))), 
                 matrix(diag(1, n)))
    expect_equal(rieExp.LogEu(V=c(O %*% diag(log(v), n) %*% t(O))), 
                 matrix(O %*% diag(v, n) %*% t(O)))

    ## distance.LogEu
    # scalar
    expect_equal(distance.LogEu(X=1, Y=1), 0)
    expect_equal(distance.LogEu(X=1, Y=2), log(2) - log(1))
    expect_equal(distance.LogEu(X=1, Y=2, assumeLogRep = TRUE), 1)

    # matrix
    M1 <- O %*% diag(v, n) %*% t(O)
    M2 <- O %*% diag(2 * v, n) %*% t(O)
    M3 <- diag(2, n)
    M4 <- diag(1, n)
    d34 <- sqrt(sum((log(diag(M3)) - log(diag(M4)))^2))
    expect_equal(distance.LogEu(X=cbind(c(M1), c(M2)), Y=cbind(c(M2), c(M1))), 
                 rep(log(2) * sqrt(n), 2))
    expect_equal(distance.LogEu(X=cbind(c(M3), c(M4)), Y=cbind(c(M4), c(M3))), 
                 rep(d34, 2))

    ## metric.LogEu
    U <- matrix(1:2, nrow=4, ncol=2, byrow=TRUE)
    V <- matrix(3:4, nrow=4, ncol=2, byrow=TRUE)
    expect_equal(metric.LogEu(mfd, U=U, V=V), c(12, 32))

    u <- -1
    v <- 1
    expect_equal(metric.LogEu(mfd, U=u, V=v), -1)

    ## norm.LogEu : read code
  }
})


# logmvec, expmvec, SqrtM, affineCenter
test_that('Helper functions for LogEu and AffInv work', {

  # logmvec and expmvec: Look at code
  expect_equal(logmvec(exp(1), 1), matrix(1))
  expect_equal(expmvec(0, 1), matrix(1))

  # SqrtM
  expect_equal(SqrtM(1), matrix(1))
  expect_equal(SqrtM(diag(1, 3)), diag(1, 3))
  expect_equal(SqrtM(diag(2, 3)), diag(sqrt(2), 3))
  a <- SqrtM(matrix(c(41, 12, 12, 34), 2, 2))
  b <- 1/5 * matrix(c(9 + 16 * sqrt(2), -12 + 12 * sqrt(2),
                      -12 + 12 * sqrt(2), 16 + 9 * sqrt(2)), 2, 2)
  expect_equal(a, b)
  expect_equal(SqrtM(diag(0.1, 2), -1), diag(10, 2))

  # affineCenter
  expect_equal(affineCenter(1, 2, d=1), matrix(2))
  expect_equal(affineCenter(c(diag(2)), c(diag(c(3, 2))), d=2), diag(c(3, 2)))
  expect_equal(affineCenter(s2=c(1, 3, 3, 10), S1HalfInv=diag(2), d=2), 
               matrix(c(1, 3, 3, 10), 2, 2))
  expect_equal(affineCenter(s2=c(1, 3, 3, 10), S1HalfInv=diag(1/2, 2), d=2), 
               matrix(c(1, 3, 3, 10) / 4, 2, 2))
})


test_that('rieLog.AffInv, rieExp.AffInv, distance.AffInv, metric.AffInv, norm.AffInv work', {
  
  for (n in c(1, 3, 100)) {
    mfd <- structure(list(), class='SPD')
    set.seed(n)
    A <- matrix(rnorm(n ^ 2), n, n)
    B <- matrix(rnorm(n ^ 2), n, n)
    BSym <- crossprod(B)
    C <- matrix(rnorm(n ^ 2), n, n)
    CSym <- crossprod(C)
    bv <- c(BSym)
    cv <- c(CSym)

    ## rieLog.AffInv
    # scalar
    expect_equal(rieLog.AffInv(p=1, X=1), matrix(0))
    expect_equal(rieLog.AffInv(p=2, X=2), matrix(0))
    expect_equal(rieLog.AffInv(p=1, X=exp(1)), matrix(1))

    # matrix
    expect_equal(cbind(rieLog.AffInv(p=bv, X=cv), rieLog.AffInv(p=cv, X=bv)), 
                 rieLog.AffInv(p=cbind(bv, cv), X=cbind(cv, bv)))
    expect_equal(rieLog.AffInv(p=c(diag(n)), X=c(diag(n))), matrix(diag(0, n)))
    expect_equal(rieLog.AffInv(p=c(diag(n)), X=cbind(c(diag(n)), c(diag(n) * 2))), 
                 cbind(c(diag(0, n)), c(diag(log(2), n))))
    expect_equal(rieLog.AffInv(p=c(diag(2, n)), X=c(diag(2, n))), matrix(diag(0, n)))


    ## rieExp.AffInv
    # scalar
    expect_equal(rieExp.AffInv(p=1, V=0), matrix(1))
    expect_equal(rieExp.AffInv(p=4, V=log(4)), matrix(16))

    # matrix
    expect_equal(rieExp.AffInv(p=c(diag(1, n)), V=c(diag(0, n))), matrix(diag(1, n)))
    expect_equal(rieExp.AffInv(p=c(diag(1/2, n)), V=c(diag(log(2), n))), 
                 matrix(diag(1, n)))
    expect_equal(cbind(rieExp.AffInv(p=bv, V=cv), rieExp.AffInv(p=cv, V=bv)),
                 rieExp.AffInv(p=cbind(bv, cv), V=cbind(cv, bv)))

    ## distance.AffInv : check code
    # scalar
    expect_equal(distance.AffInv(X=1, Y=1), 0)
    expect_equal(distance.AffInv(X=1, Y=4), log(4) - log(1))

    # rieLog.AffInv and rieExp.AffInv are inverse of each other
    expect_equal(cv, c(rieExp.AffInv(p=bv, V=rieLog.AffInv(p=bv, X=cv))))
    expect_equal(unname(cbind(cv, bv)), 
                 cbind(rieExp.AffInv(p=cbind(bv, cv), 
                                  V=rieLog.AffInv(p=cbind(bv, cv), 
                                               X=cbind(cv, bv)))))
    
    L <- rieLog.AffInv(p=bv, X=cv)
    expect_equal(c(L), c(rieLog.AffInv(p=bv, X=rieExp.AffInv(p=bv, V=c(L)))))

    # matrix
    # affine invariant property
    expect_equal(distance.AffInv(X=bv, Y=cv), 
                 distance.AffInv(X=c(A %*% BSym %*% t(A)), Y=c(A %*% CSym %*% t(A))))
    # symmetric
    expect_equal(distance.AffInv(X=bv, Y=cv), 
                 distance.AffInv(X=cv, Y=bv))

    expect_equal(distAffInv11(matrix(bv, n, n), matrix(cv, n, n)), 
                 distAffInv11_2(matrix(bv, n, n), matrix(cv, n, n)))

    expect_equal(distAffInv1m(matrix(bv, n, n), cbind(bv, cv)),
                 c(0, distAffInv11_2(matrix(bv, n, n), matrix(cv, n, n))))

    expect_equal(distance.AffInv(X=bv, Y=cbind(bv, cv)),
                 c(0, distAffInv11_2(matrix(bv, n, n), matrix(cv, n, n))))

    expect_equal(distance.AffInv(X=cbind(bv, cv), Y=cbind(bv, cv)),
                 c(0, 0))


    # microbenchmark::microbenchmark(
      # asymDist = distAffInv11(matrix(bv, n, n), matrix(cv, n, n)),
      # symDist = distAffInv11_2(matrix(bv, n, n), matrix(cv, n, n)), # Use the symmetric version
      # times=10
      # )

    # microbenchmark::microbenchmark(
      # mine = distance.AffInv(X=bv, Y=cv), 
      # joris = pdSpecEst::pdDist(matrix(bv, n, n), matrix(cv, n, n), 'Riemannian'),
      # times = 10
      # )

    # microbenchmark::microbenchmark(
      # mine = LogM_old(matrix(cv, n, n)), 
      # joris = pdSpecEst::Logm(diag(nrow=n), matrix(cv, n, n)),
      # times = 10
      # )


    ## metric.AffInv
    U <- matrix(1:2, nrow=4, ncol=2, byrow=TRUE)
    V <- matrix(3:4, nrow=4, ncol=2, byrow=TRUE)
    expect_equal(metric.AffInv(mfd, U=U, V=V), c(12, 32))

    u <- -1
    v <- 1
    expect_equal(metric.AffInv(mfd, U=u, V=v), -1)

    ## norm.AffInv : read code
  }
})