tests/testthat/test-traipse-geosphere-equivalence.R

In traipse: Shared Tools for Tracking Data

## test-traipse-geosphere-equivalence.R
##
## Comprehensive tests for the traipse geosphere -> geographiclib migration.
##
## Strategy:
##   1. Run this BEFORE the swap with geosphere to generate reference values
##   2. Swap geosphere -> geographiclib in the source
##   3. Run again — all tests should pass (within tolerance)
##
## The tolerance reflects that both geosphere::bearing() and geographiclib
## use the same underlying Karney algorithm, so results should agree to
## ~1e-10 or better. Any larger discrepancy indicates a bug in the swap.
##
## Usage: testthat::test_file("tests/testthat/test-geosphere-equivalence.R")

library(testthat)
library(traipse)

# ── Helper: dense realistic track data ──────────────────────────────────────

# Southern Ocean albatross-like track (many points, high latitude, large steps)
set.seed(42)
n <- 200
albatross <- data.frame(
  x = cumsum(c(147, rnorm(n - 1, 0.8, 0.5))),
  y = cumsum(c(-42, rnorm(n - 1, -0.3, 0.4)))
)
# Clamp latitude to valid range
albatross$y <- pmax(pmin(albatross$y, 89.9), -89.9)
# Wrap longitude
albatross$x <- ((albatross$x + 180) %% 360) - 180

# Equatorial track (low latitude, different geometry)
equatorial <- data.frame(
  x = seq(10, 50, length.out = 100),
  y = rnorm(100, 0, 2)
)

# Polar track (high latitude stress test - convergence of meridians)
polar <- data.frame(
  x = seq(-180, 180, length.out = 80),
  y = rep(-75, 80) + rnorm(80, 0, 2)
)

# Antimeridian crossing track (wrap-around stress test)
antimeridian <- data.frame(
  x = c(170, 175, 179, -179, -175, -170, -165, -160),
  y = c(-40, -41, -42, -43, -42, -41, -40, -39)
)

# Very short steps (sub-metre, tests numerical stability)
micro <- data.frame(
  x = c(0, 0 + 1e-7, 0 + 2e-7, 0 + 3e-7),
  y = c(0, 0 + 1e-7, 0 + 2e-7, 0 + 3e-7)
)

# Stationary points (zero distance, degenerate bearing)
stationary <- data.frame(
  x = c(100, 100, 100, 101, 101),
  y = c(-30, -30, -30, -31, -31)
)

# trips0 bundled data (the canonical test case)
trips0_id1 <- trips0[trips0$id == "1", ]

# ── 1. track_bearing() ─────────────────────────────────────────────────────
# Uses geosphere::bearing(p1, p2) where p1 = cbind(x[-n], y[-n]),
# p2 = cbind(x[-1], y[-1]), returns c(bearings, NA)

test_that("track_bearing returns correct length with trailing NA", {
  b <- track_bearing(albatross$x, albatross$y)
  expect_length(b, nrow(albatross))
  expect_true(is.na(b[length(b)]))
  expect_true(all(!is.na(b[-length(b)])))
})

test_that("track_bearing cardinal directions are correct", {
  # Due north
  expect_equal(track_bearing(c(0, 0), c(0, 1))[1], 0, tolerance = 1e-6)
  # Due east
  expect_equal(track_bearing(c(0, 1), c(0, 0))[1], 90, tolerance = 0.1)
  # Due south
  b_south <- track_bearing(c(0, 0), c(1, -1))[1]
  expect_true(abs(b_south) > 170)  # near +/-180
  # Due west
  expect_equal(track_bearing(c(1, 0), c(0, 0))[1], -90, tolerance = 0.1)
})

test_that("track_bearing handles antimeridian crossing", {
  b <- track_bearing(antimeridian$x, antimeridian$y)
  expect_length(b, nrow(antimeridian))
  # All bearings should be finite (no NaN from wrap)
  expect_true(all(is.finite(b[!is.na(b)])))
  # Bearings should be in [-180, 180]
  expect_true(all(b[!is.na(b)] >= -180 & b[!is.na(b)] <= 180))
})

test_that("track_bearing handles polar regions", {
  b <- track_bearing(polar$x, polar$y)
  expect_true(all(is.finite(b[!is.na(b)])))
})

test_that("track_bearing with dense albatross track", {
  b <- track_bearing(albatross$x, albatross$y)
  expect_length(b, nrow(albatross))
  # All non-NA values should be in valid range
  b_valid <- b[!is.na(b)]
  expect_true(all(b_valid >= -180 & b_valid <= 180))
})

test_that("track_bearing with stationary points", {
  b <- track_bearing(stationary$x, stationary$y)
  # First two stationary: bearing is 0 or NaN depending on implementation
  # geosphere::bearing returns 0 for identical points
  # Just check it doesn't error and returns correct length

  expect_length(b, nrow(stationary))
})

test_that("track_bearing reference values on trips0 id1", {
  b <- track_bearing(trips0_id1$x, trips0_id1$y)
  # First bearing should be ~34.5 degrees (from README)
  expect_equal(b[1], 34.5, tolerance = 1)
  # Check the bulk is reasonable
  expect_true(all(is.finite(b[!is.na(b)])))
})


# ── 2. track_angle() ───────────────────────────────────────────────────────
# Internal angle at each vertex (0 = straight, 180 = reversal)
# Uses geosphere::bearing to compute forward/back bearings then derives angle

test_that("track_angle returns correct length with padding NAs", {
  a <- track_angle(albatross$x, albatross$y)
  expect_length(a, nrow(albatross))
  expect_true(is.na(a[1]))
  expect_true(is.na(a[length(a)]))
})

test_that("track_angle straight line is 180 (collinear)", {
  # Points in a straight line (due east along equator)
  straight <- data.frame(x = seq(0, 10, by = 1), y = rep(0, 11))
  a <- track_angle(straight$x, straight$y)
  # Interior angles should be 180 (straight = no turn)
  interior <- a[!is.na(a)]
  expect_true(all(abs(interior - 180) < 1))
})

test_that("track_angle reversal is near 0", {
  # Out and back
  reverse <- data.frame(x = c(0, 5, 0), y = c(0, 0, 0))
  a <- track_angle(reverse$x, reverse$y)
  expect_equal(a[2], 0, tolerance = 1)
})

test_that("track_angle right angle is near 90", {
  # L-shaped path: east then north
  lshape <- data.frame(x = c(0, 5, 5), y = c(0, 0, 5))
  a <- track_angle(lshape$x, lshape$y)
  expect_equal(a[2], 90, tolerance = 2)  # geodesic effects at this scale
})

test_that("track_angle dense track has valid range", {
  a <- track_angle(albatross$x, albatross$y)
  a_valid <- a[!is.na(a)]
  # Internal angles should be [0, 180]
  expect_true(all(a_valid >= -0.1 & a_valid <= 180.1))
})

test_that("track_angle reference values on trips0 id1", {
  a <- track_angle(trips0_id1$x, trips0_id1$y)
  # From README: second value ~120 degrees
  expect_equal(a[2], 120, tolerance = 2)
})

test_that("track_angle handles antimeridian", {
  a <- track_angle(antimeridian$x, antimeridian$y)
  a_valid <- a[!is.na(a)]
  expect_true(all(is.finite(a_valid)))
})


# ── 3. track_turn() ────────────────────────────────────────────────────────
# Relative turn angle: signed, [-180, 180]
# Negative = left turn, positive = right turn
# Currently uses geosphere::bearing internally

test_that("track_turn returns correct length with padding NAs", {
  t <- track_turn(albatross$x, albatross$y)
  expect_length(t, nrow(albatross))
  expect_true(is.na(t[1]))
  expect_true(is.na(t[length(t)]))
})

test_that("track_turn straight line is near zero", {
  straight <- data.frame(x = seq(0, 10, by = 1), y = rep(0, 11))
  t <- track_turn(straight$x, straight$y)
  interior <- t[!is.na(t)]
  expect_true(all(abs(interior) < 1))
})

test_that("track_turn left vs right are signed correctly", {
  # East then north-east = left turn (negative? or positive? check convention)
  left <- data.frame(x = c(0, 5, 8), y = c(0, 0, 3))
  right <- data.frame(x = c(0, 5, 8), y = c(0, 0, -3))
  t_left <- track_turn(left$x, left$y)[2]
  t_right <- track_turn(right$x, right$y)[2]
  # They should have opposite signs

  expect_true(sign(t_left) != sign(t_right))
})

test_that("track_turn reference values on trips0 id1", {
  t <- track_turn(trips0_id1$x, trips0_id1$y)
  # From README: second value ~-61 degrees
  expect_equal(t[2], -61, tolerance = 2)
})

test_that("track_turn dense track in valid range", {
  t <- track_turn(albatross$x, albatross$y)
  t_valid <- t[!is.na(t)]
  expect_true(all(t_valid >= -180 & t_valid <= 180))
})

test_that("track_turn reversal is near +/-180", {
  reverse <- data.frame(x = c(0, 5, 0), y = c(0, 0, 0))
  t <- track_turn(reverse$x, reverse$y)
  expect_equal(abs(t[2]), 180, tolerance = 1)
})


# ── 4. track_bearing_to() ──────────────────────────────────────────────────
# Bearing from each point to a fixed target location
# Direct call to geosphere::bearing(xy, to_xy)

test_that("track_bearing_to returns correct length, no padding", {
  b <- track_bearing_to(albatross$x, albatross$y, 0, 0)
  expect_length(b, nrow(albatross))
  # No trailing NA — every point has a bearing to the target
  expect_true(all(is.finite(b)))
})

test_that("track_bearing_to cardinal directions", {
  # N E S W from origin
  b <- track_bearing_to(0, 0, c(0, 10, 0, -10), c(5, 0, -5, 0))
  expect_equal(b[1], 0, tolerance = 0.1)     # north
  expect_equal(b[2], 90, tolerance = 0.1)    # east
  expect_equal(abs(b[3]), 180, tolerance = 0.1)  # south
  expect_equal(b[4], -90, tolerance = 0.1)   # west
})

test_that("track_bearing_to single target recycling", {
  b <- track_bearing_to(trips0_id1$x, trips0_id1$y, 147, -42)
  expect_length(b, nrow(trips0_id1))
  expect_true(all(is.finite(b)))
  expect_true(all(b >= -180 & b <= 180))
})

test_that("track_bearing_to vectorised target", {
  # Each point has its own target
  n <- 10
  b <- track_bearing_to(
    trips0_id1$x[1:n], trips0_id1$y[1:n],
    trips0_id1$x[1:n] + 1, trips0_id1$y[1:n] + 1
  )
  expect_length(b, n)
  expect_true(all(is.finite(b)))
})

test_that("track_bearing_to antimeridian", {
  # Bearing from 170E to 170W (should go east, not west around the world)
  b <- track_bearing_to(170, 0, -170, 0)
  # Should be approximately east (90), not west (-90)
  expect_true(abs(b - 90) < 1 || abs(b - (-270)) < 1)
})


# ── 5. track_intermediate() ────────────────────────────────────────────────
# Uses geosphere::gcIntermediate for spherical interpolation
# Returns list-column of data frames

test_that("track_intermediate by distance returns list of correct length", {
  inter <- track_intermediate(
    trips0_id1$x[1:5], trips0_id1$y[1:5],
    date = trips0_id1$date[1:5],
    distance = 50000
  )
  expect_length(inter, 5)
  # Last element should be empty (terminal padding)
  expect_equal(nrow(inter[[5]]), 0)
})

test_that("track_intermediate by duration returns list of correct length", {
  inter <- track_intermediate(
    trips0_id1$x[1:5], trips0_id1$y[1:5],
    date = trips0_id1$date[1:5],
    duration = 3600
  )
  expect_length(inter, 5)
})

test_that("track_intermediate points lie between endpoints", {
  x <- c(0, 10)
  y <- c(0, 0)
  inter <- track_intermediate(x, y, distance = 100000)
  if (nrow(inter[[1]]) > 0) {
    # Interpolated x should be between 0 and 10
    expect_true(all(inter[[1]]$int_x >= -0.1 & inter[[1]]$int_x <= 10.1))
    # Interpolated y should be near 0 (equatorial great circle)
    expect_true(all(abs(inter[[1]]$int_y) < 1))
  }
})

test_that("track_intermediate with dense input", {
  inter <- track_intermediate(
    albatross$x[1:20], albatross$y[1:20],
    distance = 10000  # 10km spacing
  )
  expect_length(inter, 20)
  # Each interval should have ≥0 interpolated points
  expect_true(all(vapply(inter, nrow, integer(1)) >= 0))
})


# ── 6. track_distance() ────────────────────────────────────────────────────
# Uses geodist, NOT geosphere — should be unaffected by the swap
# But include for regression completeness

test_that("track_distance returns correct length with leading NA", {
  d <- track_distance(albatross$x, albatross$y)
  expect_length(d, nrow(albatross))
  expect_true(is.na(d[1]))
})

test_that("track_distance is always non-negative", {
  d <- track_distance(albatross$x, albatross$y)
  d_valid <- d[!is.na(d)]
  expect_true(all(d_valid >= 0))
})

test_that("track_distance reference values on trips0 id1", {
  d <- track_distance(trips0_id1$x, trips0_id1$y)
  # From README: second value ~129435
  expect_equal(d[2], 129435, tolerance = 100)
})

test_that("track_distance stationary is zero", {
  d <- track_distance(stationary$x, stationary$y)
  # Points 2 and 3 are identical to point 1
  expect_equal(d[2], 0, tolerance = 0.01)
  expect_equal(d[3], 0, tolerance = 0.01)
})


# ── 7. Consistency checks across functions ──────────────────────────────────

test_that("track_angle + track_turn are consistent", {
  # |turn| should equal angle (approximately) — they're different views
  # of the same geometry
  a <- track_angle(albatross$x[1:50], albatross$y[1:50])
  t <- track_turn(albatross$x[1:50], albatross$y[1:50])
  both_valid <- !is.na(a) & !is.na(t)
  # The relationship: angle = 180 - |turn| ... but check the actual convention
  # For now just verify they're in compatible ranges
  expect_true(all(is.finite(a[both_valid])))
  expect_true(all(is.finite(t[both_valid])))
})

test_that("track_speed = track_distance / track_time", {
  d <- track_distance(trips0_id1$x, trips0_id1$y)
  tm <- track_time(trips0_id1$date)
  s <- track_speed(trips0_id1$x, trips0_id1$y, trips0_id1$date)

  both_valid <- !is.na(d) & !is.na(tm) & !is.na(s)
  expect_equal(s[both_valid], d[both_valid] / tm[both_valid], tolerance = 1e-6)
})


# ── 8. Numerical equivalence snapshot (run BEFORE swap) ─────────────────────
# Uncomment and run this block before the geosphere->geographiclib swap
# to capture exact reference values. Then hardcode them below for
# post-swap verification.
#
# cat("── Reference values from geosphere ──\n")
# b_ref <- track_bearing(trips0_id1$x[1:10], trips0_id1$y[1:10])
# cat("bearing[1:9]:", paste(round(b_ref[1:9], 8), collapse = ", "), "\n")
#
# a_ref <- track_angle(trips0_id1$x[1:10], trips0_id1$y[1:10])
# cat("angle[2:9]:", paste(round(a_ref[2:9], 8), collapse = ", "), "\n")
#
# t_ref <- track_turn(trips0_id1$x[1:10], trips0_id1$y[1:10])
# cat("turn[2:9]:", paste(round(t_ref[2:9], 8), collapse = ", "), "\n")
#
# bt_ref <- track_bearing_to(trips0_id1$x[1:10], trips0_id1$y[1:10], 147, -42)
# cat("bearing_to[1:10]:", paste(round(bt_ref, 8), collapse = ", "), "\n")

# After capturing, paste the values here and enable these tests:
#
# test_that("bearing matches geosphere reference to 1e-6", {
#   b <- track_bearing(trips0_id1$x[1:10], trips0_id1$y[1:10])
#   b_ref <- c(...)  # paste from above
#   expect_equal(b[1:9], b_ref, tolerance = 1e-6)
# })


# ── 9. Edge cases ──────────────────────────────────────────────────────────

test_that("track_bearing and track_bearing_to handle length-1 input", {
  expect_length(track_bearing(0, 0), 1)
  expect_true(is.na(track_bearing(0, 0)))
  expect_length(track_bearing_to(0, 0, 10, 10), 1)
})

test_that("track_bearing handles length-2 input", {
  expect_length(track_bearing(c(0, 1), c(0, 1)), 2)
})

## KNOWN BUG: track_angle and track_turn error on length < 3
## (subscript out of bounds in internal matrix indexing)
## Fix during migration: early return of rep(NA_real_, n) for n < 3
test_that("track_angle errors on length < 3 (known bug)", {
  expect_equal(track_angle(0, 0), NA_real_)
  expect_equal(track_angle(c(0, 1), c(0, 1)), rep(NA_real_, 2L))
})

test_that("track_turn errors on length < 3 (known bug)", {
  expect_equal(track_turn(0, 0), NA_real_)
  expect_equal(track_turn(c(0, 1), c(0, 1)), rep(NA_real_, 2L))
})

test_that("track_angle and track_turn work at length 3 (minimum)", {
  a <- track_angle(c(0, 5, 10), c(0, 0, 0))
  expect_length(a, 3)
  expect_true(is.na(a[1]))
  expect_true(is.na(a[3]))
  expect_true(!is.na(a[2]))

  tu <- track_turn(c(0, 5, 10), c(0, 0, 0))
  expect_length(tu, 3)
  expect_true(is.na(tu[1]))
  expect_true(is.na(tu[3]))
  expect_true(!is.na(tu[2]))
})

test_that("functions handle NA in input", {
  x <- c(0, NA, 2, 3)
  y <- c(0, 1, NA, 3)
  # Should not error, NAs propagate
  expect_length(track_bearing(x, y), 4)
  expect_length(track_bearing_to(x, y, 10, 10), 4)
})

test_that("bearing at poles", {
  # From north pole, every direction is south
  b <- track_bearing_to(0, 89.999, 0, 0)
  expect_true(abs(abs(b) - 180) < 1)
  # From south pole to equator, everything is north
  b2 <- track_bearing_to(0, -89.999, 0, 0)
  expect_true(abs(b2) < 1)
})

test_that("track_turn could be rebuilt from track_bearing differences", {
  # This is the key insight for the refactor:
  # turn[i] = bearing[i] - bearing[i-1], normalised to [-180, 180]
  x <- albatross$x[1:20]
  y <- albatross$y[1:20]
  b <- track_bearing(x, y)
  t <- track_turn(x, y)

  # Manual calculation of turn from bearing differences
  for (i in 2:(length(x) - 1)) {
    if (!is.na(b[i]) && !is.na(b[i - 1]) && !is.na(t[i])) {
      diff <- b[i] - b[i - 1]
      # Normalise to [-180, 180]
      diff <- ((diff + 180) %% 360) - 180
      expect_equal(t[i], diff, tolerance = 0.01,
                   label = paste("turn[", i, "]"))
    }
  }
})