Merge branch 'test/cch-suite'

Author: vlarmet

.Rbuildignore

@@ -5,4 +5,5 @@
 ^README\.md$
 ^README_files/
 ^\.git$
-^\.gitignore$
+^\.gitignore$
+^\.github$

.github/.gitignore

@@ -0,0 +1 @@
+*.html

.github/workflows/R-CMD-check.yaml

@@ -0,0 +1,50 @@
+# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples
+# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
+on:
+  push:
+    branches: [main, master]
+  pull_request:
+
+name: R-CMD-check.yaml
+
+permissions: read-all
+
+jobs:
+  R-CMD-check:
+    runs-on: ${{ matrix.config.os }}
+
+    name: ${{ matrix.config.os }} (${{ matrix.config.r }})
+
+    strategy:
+      fail-fast: false
+      matrix:
+        config:
+          - {os: macos-latest,   r: 'release'}
+          - {os: windows-latest, r: 'release'}
+          - {os: ubuntu-latest,   r: 'devel', http-user-agent: 'release'}
+          - {os: ubuntu-latest,   r: 'release'}
+          - {os: ubuntu-latest,   r: 'oldrel-1'}
+
+    env:
+      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+      R_KEEP_PKG_SOURCE: yes
+
+    steps:
+      - uses: actions/checkout@v6
+
+      - uses: r-lib/actions/setup-pandoc@v2
+
+      - uses: r-lib/actions/setup-r@v2
+        with:
+          r-version: ${{ matrix.config.r }}
+          http-user-agent: ${{ matrix.config.http-user-agent }}
+
+      - uses: r-lib/actions/setup-r-dependencies@v2
+        with:
+          extra-packages: any::rcmdcheck
+          needs: check
+
+      - uses: r-lib/actions/check-r-package@v2
+        with:
+          upload-snapshots: true
+          build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")'

DESCRIPTION

@@ -20,11 +20,12 @@ Description: Calculation of distances, shortest paths and isochrones on weighted
 License: GPL (>= 2)
 Encoding: UTF-8
 LazyData: true
-Imports: Rcpp (>= 1.0.7), RcppParallel, RcppProgress, data.table
+Imports: Rcpp (>= 1.0.7), RcppParallel, data.table
 LinkingTo: Rcpp, RcppParallel, RcppProgress
 SystemRequirements: GNU make
 URL: https://github.com/vlarmet/cppRouting
-Suggests: knitr, rmarkdown, igraph
+Suggests: knitr, rmarkdown, igraph, testthat (>= 3.0.0)
 VignetteBuilder: knitr
 NeedsCompilation: yes
 Config/roxygen2/version: 8.0.0
+Config/testthat/edition: 3

tests/testthat.R

@@ -0,0 +1,4 @@
+library(testthat)
+library(cppRouting)
+
+test_check("cppRouting")

tests/testthat/helper-graphs.R

@@ -0,0 +1,86 @@
+# Shared fixtures for the test suite. Kept small and deterministic (no real
+# road data - that lives in data_readme/ and is used by the bench_*.R
+# performance scripts instead, not by unit tests).
+
+# A hand-verifiable directed graph, small enough that shortest paths/costs
+# can be checked by inspection. Includes:
+# - a parallel edge pair (1->2) with different costs, to exercise
+#   "cheapest parallel edge wins" (a real bug class hit repeatedly while
+#   building aggregate_aux)
+# - an exact tie: two paths of equal total weight but different edge counts
+#   (1->4 via 1-2-4 and 1-3-4, both cost 5, hop count 2 either way here -
+#   kept simple; ties-with-different-hop-count are exercised in the bigger
+#   fixture below since they need more structure)
+toy_edges <- function() {
+  data.frame(
+    from = c(1, 1, 1, 2, 2, 3, 4, 4, 5),
+    to   = c(2, 2, 3, 4, 5, 4, 5, 6, 6),
+    dist = c(2, 5, 3, 3, 8, 2, 1, 6, 1),
+    stringsAsFactors = FALSE
+  )
+}
+
+toy_aux <- function() {
+  e <- toy_edges()
+  data.frame(hop = rep(1, nrow(e)), dist2 = e$dist * 2)
+}
+
+toy_graph <- function(directed = TRUE, aux = NULL) {
+  cppRouting::makegraph(toy_edges(), directed = directed, aux = aux)
+}
+
+# A small grid graph: realistic/near-planar topology (unlike a fully random
+# graph, which is an adversarial worst case for both CH and CCH elimination
+# ordering - see min_degree_order fill-in blowup found during development).
+# Big enough to exercise contraction/CCH/simplification meaningfully, small
+# enough to run fast. Nodes are numbered row-major, 1-based.
+grid_edges <- function(nrow = 6, ncol = 6, directed = TRUE, seed = 1) {
+  set.seed(seed)
+  node_id <- function(r, c) (r - 1) * ncol + c
+  from <- integer(0); to <- integer(0)
+  for (r in seq_len(nrow)) {
+    for (c in seq_len(ncol)) {
+      if (c < ncol) { from <- c(from, node_id(r, c)); to <- c(to, node_id(r, c + 1)) }
+      if (r < nrow) { from <- c(from, node_id(r, c)); to <- c(to, node_id(r + 1, c)) }
+    }
+  }
+  weight <- round(runif(length(from), 1, 10), 3)
+  data.frame(from = from, to = to, weight = weight)
+}
+
+grid_coords <- function(nrow = 6, ncol = 6) {
+  node_id <- function(r, c) (r - 1) * ncol + c
+  ids <- integer(0); x <- numeric(0); y <- numeric(0)
+  for (r in seq_len(nrow)) for (c in seq_len(ncol)) {
+    ids <- c(ids, node_id(r, c)); x <- c(x, c); y <- c(y, r)
+  }
+  data.frame(id = ids, x = x, y = y)
+}
+
+# Grid graph with two aux columns (a constant "hop" column, and one that
+# mirrors the main weight), coordinates, and capacity/alpha/beta so it can
+# be reused for aggregate_aux, A*/NBA and traffic-assignment tests alike.
+grid_graph <- function(nrow = 6, ncol = 6, directed = TRUE, seed = 1,
+                       with_coords = FALSE, with_aux = FALSE,
+                       with_traffic_attrs = FALSE) {
+  e <- grid_edges(nrow, ncol, directed, seed)
+  args <- list(df = e, directed = directed)
+  if (with_coords) args$coords <- grid_coords(nrow, ncol)
+  if (with_aux) args$aux <- data.frame(hop = rep(1, nrow(e)), dist2 = e$weight)
+  if (with_traffic_attrs) {
+    args$capacity <- round(runif(nrow(e), 50, 200), 1)
+    args$alpha <- rep(0.15, nrow(e))
+    args$beta <- rep(4, nrow(e))
+  }
+  do.call(cppRouting::makegraph, args)
+}
+
+# Duplicated edge with a strictly higher cost than its twin, to make sure
+# tests exercise "cheapest parallel edge wins" rather than an arbitrary one.
+with_parallel_edge <- function(edges, from, to, extra_cost = 5) {
+  base <- edges[edges$from == from & edges$to == to, ]
+  stopifnot(nrow(base) >= 1)
+  dup <- base[1, ]
+  dup[[3]] <- dup[[3]] + extra_cost
+  rbind(edges, dup)
+}

tests/testthat/test-aggregate_aux.R

@@ -0,0 +1,141 @@
+# aggregate_aux: single legacy vector, single named column out of a
+# data.frame, and multi-column data.frame - across get_distance_pair(),
+# get_distance_matrix(), normal/CH/CCH graphs and cpp_simplify().
+
+# A strictly linear, tie-free graph: only one possible path between any two
+# nodes, so aggregate_aux values can be hand-verified exactly.
+line_edges <- function() {
+  data.frame(from = c(1, 2, 3), to = c(2, 3, 4), dist = c(4, 6, 2))
+}
+
+test_that("legacy single aux vector: aggregate_aux = TRUE returns a plain vector/matrix", {
+  e <- line_edges()
+  g <- makegraph(e, directed = TRUE, aux = e$dist * 2) # aux = 2x the main weight
+
+  d <- get_distance_pair(g, 1, 4)
+  a <- get_distance_pair(g, 1, 4, aggregate_aux = TRUE)
+  expect_true(is.numeric(a) && !is.list(a))
+  expect_equal(a, 2 * d)
+
+  m <- get_distance_matrix(g, c(1, 2), c(3, 4))
+  am <- get_distance_matrix(g, c(1, 2), c(3, 4), aggregate_aux = TRUE)
+  expect_true(is.matrix(am))
+  expect_equal(unname(am), unname(2 * m))
+})
+
+test_that("data.frame aux with a single column resolved returns a length-1 list, not a bare vector/matrix", {
+  e <- line_edges()
+  g <- makegraph(e, directed = TRUE, aux = data.frame(dist2 = e$dist * 2))
+
+  a <- get_distance_pair(g, 1, 4, aggregate_aux = TRUE)
+  expect_s3_class(a, "data.frame")
+  expect_named(a, "dist2")
+  expect_equal(a$dist2, 2 * get_distance_pair(g, 1, 4))
+
+  am <- get_distance_matrix(g, c(1, 2), c(3, 4), aggregate_aux = TRUE)
+  expect_type(am, "list")
+  expect_named(am, "dist2")
+  expect_true(is.matrix(am$dist2))
+})
+
+test_that("multi-column data.frame aux: aggregate_aux = TRUE returns all columns, named", {
+  e <- line_edges()
+  g <- makegraph(e, directed = TRUE, aux = data.frame(hop = rep(1, nrow(e)), dist2 = e$dist * 2))
+  d <- get_distance_pair(g, 1, 4)
+
+  a <- get_distance_pair(g, 1, 4, aggregate_aux = TRUE)
+  expect_s3_class(a, "data.frame")
+  expect_named(a, c("hop", "dist2"))
+  expect_equal(a$hop, 3) # 3 edges on the only path 1->2->3->4
+  expect_equal(a$dist2, 2 * d)
+
+  am <- get_distance_matrix(g, c(1, 2), c(3, 4), aggregate_aux = TRUE)
+  expect_type(am, "list")
+  expect_named(am, c("hop", "dist2"))
+})
+
+test_that("character vector aggregate_aux selects a subset of columns", {
+  e <- line_edges()
+  g <- makegraph(e, directed = TRUE, aux = data.frame(hop = rep(1, nrow(e)), dist2 = e$dist * 2, dist3 = e$dist * 3))
+
+  a <- get_distance_pair(g, 1, 4, aggregate_aux = c("dist2", "dist3"))
+  expect_named(a, c("dist2", "dist3"))
+  expect_false("hop" %in% names(a))
+
+  a1 <- get_distance_pair(g, 1, 4, aggregate_aux = "hop")
+  expect_s3_class(a1, "data.frame")
+  expect_named(a1, "hop")
+})
+
+test_that("aggregate_aux errors on unknown column names and on a graph without aux", {
+  e <- line_edges()
+  g_no_aux <- makegraph(e, directed = TRUE)
+  expect_error(get_distance_pair(g_no_aux, 1, 4, aggregate_aux = TRUE))
+
+  g <- makegraph(e, directed = TRUE, aux = data.frame(hop = rep(1, nrow(e))))
+  expect_error(get_distance_pair(g, 1, 4, aggregate_aux = "not_a_column"))
+})
+
+test_that("negative aux values trigger a warning at makegraph() time", {
+  e <- line_edges()
+  expect_warning(makegraph(e, directed = TRUE, aux = c(-1, 2, 3)))
+  expect_warning(makegraph(e, directed = TRUE, aux = data.frame(a = c(-1, 2, 3))))
+})
+
+test_that("multi-column aggregate_aux agrees between normal graph and CH (no ties)", {
+  g <- grid_graph(6, 6, directed = TRUE, with_aux = TRUE)
+  ch <- cpp_contract(g, silent = TRUE)
+
+  set.seed(11)
+  nodes <- g$dict$ref
+  from <- sample(nodes, 20, replace = TRUE)
+  to <- sample(nodes, 20, replace = TRUE)
+
+  a_normal <- get_distance_pair(g, from, to, aggregate_aux = TRUE)
+  a_ch <- get_distance_pair(ch, from, to, aggregate_aux = TRUE)
+  expect_equal(a_normal$hop, a_ch$hop, tolerance = 1e-8)
+  expect_equal(a_normal$dist2, a_ch$dist2, tolerance = 1e-6)
+
+  m_normal <- get_distance_matrix(g, from[1:6], to[1:6], aggregate_aux = TRUE)
+  m_ch <- get_distance_matrix(ch, from[1:6], to[1:6], aggregate_aux = TRUE)
+  expect_equal(unname(m_normal$hop), unname(m_ch$hop), tolerance = 1e-8)
+  expect_equal(unname(m_normal$dist2), unname(m_ch$dist2), tolerance = 1e-6)
+})
+
+test_that("aggregate_aux on a tied-cost graph: the aux column proportional to the main weight always matches exactly, even when paths differ", {
+  # toy_graph has genuine cost ties (e.g. 1->4 via 1-2-4 or 1-3-4, both cost
+  # 5) - documented, expected behavior (see get_distance_pair()'s @details).
+  # dist2 = 2 * dist is linear in the optimized weight, so its sum along any
+  # optimal path always equals 2 * distance, regardless of which tied path a
+  # given algorithm/graph representation happens to pick.
+  g <- toy_graph(aux = toy_aux())
+  ch <- cpp_contract(g, silent = TRUE)
+
+  nodes <- g$dict$ref
+  from <- rep(nodes, times = length(nodes))
+  to <- rep(nodes, each = length(nodes))
+
+  d_normal <- get_distance_pair(g, from, to)
+  a_normal <- get_distance_pair(g, from, to, aggregate_aux = TRUE)
+  a_ch <- get_distance_pair(ch, from, to, aggregate_aux = TRUE)
+
+  ok <- !is.na(d_normal)
+  expect_equal(a_normal$dist2[ok], 2 * d_normal[ok], tolerance = 1e-8)
+  expect_equal(a_ch$dist2[ok], 2 * d_normal[ok], tolerance = 1e-8)
+})
+
+test_that("cpp_simplify sums multi-column aux correctly across merged edge chains", {
+  # a-b-c-d is a pure chain (b, c are non-intersection nodes and get
+  # contracted away by cpp_simplify); the merged edge's aux must equal the
+  # sum over the 3 original edges.
+  e <- data.frame(from = c("a", "b", "c"), to = c("b", "c", "d"), dist = c(1, 2, 3))
+  aux <- data.frame(hop = c(1, 1, 1), dist2 = e$dist * 2)
+  g <- makegraph(e, directed = TRUE, aux = aux)
+
+  simplified <- cpp_simplify(g, iterate = TRUE)
+  expect_equal(nrow(simplified$data), 1) # a-b-c-d collapsed to a single a->d edge
+
+  a <- get_distance_pair(simplified, "a", "d", aggregate_aux = TRUE)
+  expect_equal(a$hop, 3)
+  expect_equal(a$dist2, sum(aux$dist2))
+})

tests/testthat/test-assign_traffic.R

@@ -0,0 +1,72 @@
+traffic_graph <- function() {
+  grid_graph(4, 4, directed = TRUE, with_traffic_attrs = TRUE)
+}
+
+test_that("link-based algorithms (msa, fw, cfw, bfw) converge to a small gap", {
+  g <- traffic_graph()
+  set.seed(41)
+  nodes <- g$dict$ref
+  demand <- data.frame(from = sample(nodes, 5), to = sample(nodes, 5), demand = runif(5, 1, 10))
+
+  for (algo in c("msa", "fw", "cfw", "bfw")) {
+    res <- assign_traffic(g, from = demand$from, to = demand$to, demand = demand$demand,
+                          algorithm = algo, max_it = 50, verbose = FALSE)
+    expect_true(is.finite(res$gap))
+    expect_gte(res$gap, 0)
+    expect_true(all(res$data$flow >= 0))
+  }
+})
+
+test_that("bush-based algorithm (dial) converges to a small gap", {
+  g <- traffic_graph()
+  set.seed(42)
+  nodes <- g$dict$ref
+  demand <- data.frame(from = sample(nodes, 5), to = sample(nodes, 5), demand = runif(5, 1, 10))
+
+  res <- assign_traffic(g, from = demand$from, to = demand$to, demand = demand$demand,
+                        algorithm = "dial", max_it = 10, verbose = FALSE)
+  expect_true(is.finite(res$gap))
+  expect_gte(res$gap, 0)
+})
+
+test_that("aon_method = 'cch' auto-prepares a CCH when cch = NULL, and matches aon_method = 'bi'", {
+  g <- traffic_graph()
+  set.seed(43)
+  nodes <- g$dict$ref
+  demand <- data.frame(from = sample(nodes, 5), to = sample(nodes, 5), demand = runif(5, 1, 10))
+
+  # auto-preparation (cch = NULL) shows a progress bar for the underlying
+  # cpp_contract(customizable = TRUE) call; captured here to keep test output
+  # clean, not asserted on.
+  invisible(capture.output(
+    res_cch <- assign_traffic(g, from = demand$from, to = demand$to, demand = demand$demand,
+                              algorithm = "bfw", max_it = 50, aon_method = "cch", verbose = FALSE)
+  ))
+  res_bi <- assign_traffic(g, from = demand$from, to = demand$to, demand = demand$demand,
+                           algorithm = "bfw", max_it = 50, aon_method = "bi", verbose = FALSE)
+  expect_equal(res_cch$gap, res_bi$gap, tolerance = 1e-6)
+})
+
+test_that("a cch prepared for a different graph is rejected with a clear error", {
+  g1 <- traffic_graph()
+  g2 <- grid_graph(6, 6, directed = TRUE, with_traffic_attrs = TRUE) # different topology
+
+  wrong_cch <- cpp_contract(g2, customizable = TRUE, silent = TRUE)
+
+  demand <- data.frame(from = g1$dict$ref[1:3], to = g1$dict$ref[4:6], demand = c(1, 2, 3))
+  expect_error(
+    assign_traffic(g1, from = demand$from, to = demand$to, demand = demand$demand,
+                   algorithm = "bfw", aon_method = "cch", cch = wrong_cch, verbose = FALSE),
+    "topology|different number"
+  )
+})
+
+test_that("from/to/demand must have the same length", {
+  g <- traffic_graph()
+  expect_error(assign_traffic(g, from = c("1", "2"), to = "1", demand = c(1, 2)))
+})
+
+test_that("alpha, beta and capacity must be defined on the graph", {
+  g <- grid_graph(4, 4, directed = TRUE) # no traffic attributes
+  expect_error(assign_traffic(g, from = "1", to = "2", demand = 1))
+})