tests/testthat/test.emd.R

In move: Visualizing and Analyzing Animal Track Data

#  n<-20
#  set.seed(124)
#  r1 <- raster(matrix(rweibull(n^2,3), nrow = n))
#  r2 <- raster(matrix(rweibull(n^2,3), nrow = n))
#  r1 <- r1 / cellStats(r1,"sum")
#  r2 <- r2 / cellStats(r2,"sum")
#  emd(r1,r2,th=100)
#
#


context("testing emd")
test_that("emd over simple distances", {
  r1 <- raster(matrix(c(0, 0, 1, 0), nrow = 2))
  r2 <- raster(matrix(c(0, 1, 0, 0), nrow = 2))
  r3 <- raster(matrix(c(1, 0, 0, 0), nrow = 2))
  r4 <- raster(matrix(c(.5, .5, 0, 0), nrow = 2))

  expect_equal(as.numeric(emd(r1, r2)), sqrt(2 * .5^2))
  expect_equal(as.numeric(emd(r1, r3)), .5, tolerance = 1e-6)
  expect_equal(as.numeric(emd(r3, r2)), .5, tolerance = 1e-6)
  expect_equal(as.numeric(emd(r3, r4)),
    .25,
    tolerance = 1e-6
  )
  expect_equal(as.numeric(emd(r4, r1)), .5 * .5 + sqrt(2 * .5^2) * .5,
    tolerance =
      1e-6
  )
})
test_that("emd is reversable", {
  set.seed(234)
  r1 <- raster(matrix(rweibull(100, 3), nrow = 10))
  r2 <- raster(matrix(rweibull(100, 3), nrow = 10))
  r1 <- r1 / cellStats(r1, "sum")
  r2 <- r2 / cellStats(r2, "sum")

  expect_identical(emd(r1, r2), emd(r2, r1))
})
test_that("emd works with long lat", {
  set.seed(234)
  m <- matrix(runif(40, min = -1, 1) * c(180, 90), byrow = T, ncol = 4)
  for (i in 1:nrow(m))
  {
    r1 <-
      raster(
        as.matrix(1),
        xmx = m[i, 1] + .1, xmn = m[i, 1] - .1,
        ymx = m[i, 2] + .1, ymn = m[i, 2] - .1
      )
    r2 <-
      raster(
        as.matrix(1),
        xmx = m[i, 3] + .1, xmn = m[i, 3] - .1,
        ymx = m[i, 4] + .1, ymn = m[i, 4] - .1
      )
    expect_equal(
      as.numeric(emd(r1, r2, gc = T)),
      distHaversine(m[i, 1:2], m[i, 3:4]) / 1000
    )

    expect_equal(
      as.numeric(emd(r1, r2, gc = F)),
      sqrt(sum((m[i, 1:2] - m[i, 3:4])^2))
    )
  }
})


test_that("emd thresholds simple cases", {
  r1 <- raster(matrix(c(0, 0, 1, 0), nrow = 2))
  r2 <- raster(matrix(c(0, 1, 0, 0), nrow = 2))
  r4 <- raster(matrix(c(.5, .5, 0, 0), nrow = 2))

  expect_equal(as.numeric(emd(r1, r2, th = 1)), sqrt(2 * .5^2))
  expect_equal(as.numeric(emd(r1, r2, th = .1)), .1)

  expect_equal(as.numeric(emd(r4, r1, th = 1)),
    .5 * .5 + sqrt(2 * .5^2) * .5,
    tolerance =  1e-6
  )
  expect_equal(as.numeric(emd(r4, r1, th = .6)),
    .5 * .5 + .6 * .5,
    tolerance =  1e-6
  )
  expect_equal(as.numeric(emd(r2, r4, threshold = .3)), .3 * .5)
})


test_that("emd th complex", {
  set.seed(124)
  r1 <- raster(matrix(rweibull(100, 3), nrow = 10))
  r2 <- raster(matrix(rweibull(100, 3), nrow = 10))
  r1 <- r1 / cellStats(r1, "sum")
  r2 <- r2 / cellStats(r2, "sum")
  expect_equal(emd(r1, r2, th = 12), emd(r2, r1), tolerance = 9e-5)
  expect_equal(as.numeric(emd(r1, r2, th = .01)),
    sum(values(abs(r1 - r2)) / 2) * .01,
    tolerance = 9e-6
  )
  expect_equal(as.numeric(emd(r1, r2, th = .021)),
    sum(values(abs(r1 - r2)) / 2) * .021,
    tolerance = 8e-6
  )
})

test_that("emd with gc and threshold unequal rasters", {
  r1 <- raster(
    as.matrix(1),
    xmx = 1, xmn = 0, ymx = 1, ymn = 0
  )
  r2 <- raster(
    as.matrix(1),
    xmx = 2, xmn = 1, ymx = 2, ymn = 1
  )
  expect_equal(as.numeric(emd(r1, r2, gc = T)), distHaversine(c(.5, .5), c(1.5, 1.5)) / 1000)

  expect_error(
    emd(r1, r2, gc = T, th = 1000),
    "spatial data locations are unequal between datasets, this does not work with the fast emd"
  )
  expect_error(
    emd(r1, r2, gc = F, th = 1000),
    "spatial data locations are unequal between datasets, this does not work with the fast emd"
  )
  expect_equal(as.numeric(emd(r1, r2, gc = F, th = NULL)), sqrt(2))
})
test_that("emd with gc and threshold equal rasters", {
  r1 <- raster(
    cbind(c(1:0), c(0, 0)),
    xmx = 2, xmn = 0, ymx = 2, ymn = 0
  )
  r2 <- raster(
    cbind(c(0, 0), c(0, 1)),
    xmx = 2, xmn = 0, ymx = 2, ymn = 0
  )
  expect_equal(as.numeric(emd(r1, r2, gc = T)), distHaversine(c(.5, .5), c(1.5, 1.5)) / 1000)
  expect_equal(as.numeric(emd(r1, r2, gc = T, th = 1000)), distHaversine(c(.5, .5), c(1.5, 1.5)) /
    1000)
  expect_equal(as.numeric(emd(r1, r2, gc = F, th = 1000)), sqrt(2))
  expect_equal(as.numeric(emd(r1, r2, gc = T, th = 100.123)), 100.123)
  expect_equal(as.numeric(emd(r1, r2, gc = F, th = NULL)), sqrt(2))
  expect_equal(as.numeric(emd(r1, r2, gc = F)), sqrt(2))
})

test_that("large threshold is same as full and order does not matter", {
  set.seed(23423)
  s1 <- SpatialPointsDataFrame(matrix(ncol = 2, rnorm(20)), data = data.frame(a = rep(.1, 10)))
  s2 <- s1
  s2$a <- 1:10 / 55

  expect_equal(e <- emd(s1, s2), emd(s1, s2, threshold = 100))
  expect_equal(e, emd(s1[sample(1:10), ], s2[sample(1:10), ]))
  expect_equal(e, emd(s1[sample(1:10), ], s2[sample(1:10), ]), threshold = 100)
})


test_that("emd for raster brick", {
  r <- raster(extent(0, 1, 0, 1))
  s <- stack(sl <- lapply(c(5, 10, 56, 87), function(x, r) {
    values(r)[x] <- 1
    r
  }, r = r))
  ss <- stack(ssl <- lapply(c(14, 57, 67), function(x, r) {
    values(r)[x] <- 1
    r
  }, r = r))

  expect_equivalent(emd(s), dist(rasterToPoints(s)[, 1:2]))
  expect_equivalent(
    emd(s, ss, gc = T),
    distm(rasterToPoints(s)[, 1:2], rasterToPoints(ss)[, 1:2], fun = distHaversine) / 1000
  )
  expect_equivalent(emd(s), dist(rasterToPoints(s)[, 1:2]))
  expect_equal(emd(s, ss, gc = T), emd(UDStack(s), UDStack(ss), gc = T))
  expect_equal(emd(s, ss, gc = T), emd(UDStack(sl), UDStack(ssl), gc = T))
})
test_that("emd with spatial objects, compare spdf and sp", {
  a <- SpatialPoints(matrix(rnorm(34), ncol = 2))
  ad <- SpatialPointsDataFrame(a, data = data.frame(w = rep(1 / length(a), length(a))))
  b <- SpatialPoints(matrix(rnorm(34), ncol = 2))
  bd <- SpatialPointsDataFrame(b, data = data.frame(w = rep(1 / length(b), length(b))))
  d <- SpatialPoints(matrix(rnorm(38), ncol = 2))
  dd <- SpatialPointsDataFrame(d, data = data.frame(w = rep(1 / length(d), length(d))))
  expect_equal(emd(a, b), emd(ad, bd))
  expect_equal(emd(a, d), emd(ad, dd))
})
test_that("emd of to dbbmms", {
  data(dbbmmstack)
  r <- split(dbbmmstack)
  expect_s3_class(emd(r[[1]], r[[2]]), "dist")
})