tests/testthat/test-assignment.R

In flownet: Transport Modeling: Network Processing, Route Enumeration, and Traffic Assignment

# Tests for run_assignment()

# Simple test graph from README
simple_graph <- data.frame(
 from = c(1, 2, 2, 3),
 to = c(2, 3, 4, 4),
 cost = c(5, 3, 2, 4)
)

simple_od <- data.frame(
 from = c(1, 2, 3),
 to = c(4, 4, 4),
 flow = c(100, 80, 60)
)

# --- AoN Method Tests ---

test_that("run_assignment AoN returns correct structure", {
 result <- run_assignment(simple_graph, simple_od,
                          cost.column = "cost",
                          method = "AoN",
                          verbose = FALSE)

 expect_s3_class(result, "flownet")
 expect_true("final_flows" %in% names(result))
 expect_true("od_pairs_used" %in% names(result))
 expect_true("call" %in% names(result))
})

test_that("run_assignment AoN final_flows has correct length", {
 result <- run_assignment(simple_graph, simple_od,
                          cost.column = "cost",
                          method = "AoN",
                          verbose = FALSE)

 expect_equal(length(result$final_flows), nrow(simple_graph))
})

test_that("run_assignment AoN return.extra='all' returns expected elements", {
 result <- run_assignment(simple_graph, simple_od,
                          cost.column = "cost",
                          method = "AoN",
                          return.extra = "all",
                          verbose = FALSE)

 expect_true("graph" %in% names(result))
 expect_true("paths" %in% names(result))
 expect_true("path_costs" %in% names(result))
 expect_true("edge_counts" %in% names(result))
})

test_that("run_assignment AoN assigns flow to shortest paths", {
 result <- run_assignment(simple_graph, simple_od,
                          cost.column = "cost",
                          method = "AoN",
                          verbose = FALSE)

 # All flow should be assigned (no flow lost)
 expect_true(sum(result$final_flows) > 0)

 # For AoN, flow goes only through shortest paths
 # Edge 3 (2->4, cost=2) should have high flow as it's on shortest paths
 expect_true(result$final_flows[3] > 0)
})

# --- PSL Method Tests ---

test_that("run_assignment PSL returns correct structure", {
 result <- run_assignment(simple_graph, simple_od,
                          cost.column = "cost",
                          method = "PSL",
                          angle.max = NA,
                          verbose = FALSE)

 expect_s3_class(result, "flownet")
 expect_true("final_flows" %in% names(result))
 expect_equal(length(result$final_flows), nrow(simple_graph))
})

test_that("run_assignment PSL with angle.max=NA matches expected output", {
 result <- run_assignment(simple_graph, simple_od,
                          cost.column = "cost",
                          method = "PSL",
                          angle.max = NA,
                          verbose = FALSE)

 # Expected values from README
 expected <- c(100.00000, 16.13649, 196.13649, 43.86351)
 expect_equal(result$final_flows, expected, tolerance = 1e-4)
})

test_that("run_assignment PSL return.extra='all' returns path weights", {
 result <- run_assignment(simple_graph, simple_od,
                          cost.column = "cost",
                          method = "PSL",
                          angle.max = NA,
                          return.extra = "all",
                          verbose = FALSE)

 expect_true("path_weights" %in% names(result))
 expect_true("paths" %in% names(result))
 expect_true("edges" %in% names(result))
})

test_that("run_assignment PSL produces more distributed flows than AoN", {
 result_psl <- run_assignment(simple_graph, simple_od,
                              cost.column = "cost",
                              method = "PSL",
                              angle.max = NA,
                              verbose = FALSE)

 result_aon <- run_assignment(simple_graph, simple_od,
                              cost.column = "cost",
                              method = "AoN",
                              verbose = FALSE)

 # PSL should have more non-zero edges or more even distribution
 # Check that PSL uses edge 4 (3->4) which AoN might not use as much
 expect_true(result_psl$final_flows[4] > 0)
})

test_that("run_assignment PSL beta parameter affects distribution", {
 result_beta0 <- run_assignment(simple_graph, simple_od,
                                cost.column = "cost",
                                method = "PSL",
                                beta = 0,
                                angle.max = NA,
                                verbose = FALSE)

 result_beta1 <- run_assignment(simple_graph, simple_od,
                                cost.column = "cost",
                                method = "PSL",
                                beta = 1,
                                angle.max = NA,
                                verbose = FALSE)

 # beta=0 (no overlap penalty) vs beta=1 should differ
 # At minimum, verify both run without error and produce valid flows
 expect_true(sum(result_beta0$final_flows) > 0)
 expect_true(sum(result_beta1$final_flows) > 0)
})

# --- Error Handling Tests ---

test_that("run_assignment errors on missing graph columns", {
 bad_graph <- data.frame(origin = c(1, 2), dest = c(2, 3), cost = c(1, 2))

 expect_error(
   run_assignment(bad_graph, simple_od, cost.column = "cost", verbose = FALSE)
 )
})

test_that("run_assignment errors on missing OD matrix columns", {
 bad_od <- data.frame(from = c(1, 2), to = c(3, 4))

 expect_error(
   run_assignment(simple_graph, bad_od, cost.column = "cost", verbose = FALSE),
   "flow"
 )
})

test_that("run_assignment errors on invalid cost.column", {
 expect_error(
   run_assignment(simple_graph, simple_od, cost.column = "nonexistent", verbose = FALSE),
   "cost.column"
 )
})

test_that("run_assignment errors on unknown nodes in OD matrix", {
 bad_od <- data.frame(from = c(1, 99), to = c(4, 4), flow = c(100, 50))

 expect_error(
   run_assignment(simple_graph, bad_od, cost.column = "cost", verbose = FALSE),
   "Unknown"
 )
})

# --- print.flownet Tests ---

test_that("print.flownet works without error", {
 result <- run_assignment(simple_graph, simple_od,
                          cost.column = "cost",
                          method = "AoN",
                          return.extra = "all",
                          verbose = FALSE)

 expect_output(print(result), "FlowNet object")
})

# --- return.extra Options and PSF Tests ---

test_that("run_assignment PSL return.extra='all' returns PSF", {
 result <- run_assignment(simple_graph, simple_od,
                          cost.column = "cost",
                          method = "PSL",
                          angle.max = NA,
                          return.extra = "all",
                          verbose = FALSE)

 expect_true("path_size_factors" %in% names(result))
 expect_true("edge_weights" %in% names(result))

 # PSF should be list of same length as od_pairs_used
 expect_equal(length(result$path_size_factors), length(result$od_pairs_used))

 # Each PSF vector should have same length as corresponding path_weights
 for (i in seq_along(result$path_size_factors)) {
   expect_equal(length(result$path_size_factors[[i]]),
                length(result$path_weights[[i]]))
 }
})

test_that("PSF values are between 0 and 1", {
 result <- run_assignment(simple_graph, simple_od,
                          cost.column = "cost",
                          method = "PSL",
                          angle.max = NA,
                          return.extra = "PSF",
                          verbose = FALSE)

 for (psf in result$path_size_factors) {
   expect_true(all(psf > 0 & psf <= 1))
 }
})

test_that("PSF computation is mathematically correct", {
 # Use a slightly larger graph for meaningful overlap
 graph <- data.frame(
   from = c(1, 1, 2, 2, 3, 3),
   to = c(2, 3, 3, 4, 4, 4),
   cost = c(1, 2, 1, 3, 1, 2)
 )
 od <- data.frame(from = 1, to = 4, flow = 100)

 result <- run_assignment(graph, od,
                          cost.column = "cost",
                          method = "PSL",
                          angle.max = NA,
                          return.extra = c("paths", "edges", "counts", "costs", "PSF", "weights"),
                          verbose = FALSE)

 # PSF formula: gamma_k = sum(cost_a / delta_a) / cost_k
 # where delta_a is number of paths using edge a
 cost <- graph$cost
 paths <- result$paths[[1]]
 edges <- result$edges[[1]]
 ecounts <- result$edge_counts[[1]]
 pcosts <- result$path_costs[[1]]
 psf <- result$path_size_factors[[1]]

 # Manually compute PSF for each path
 for (k in seq_along(paths)) {
   path_edges <- paths[[k]]
   edge_costs <- cost[path_edges]
   edge_overlaps <- ecounts[match(path_edges, edges)]
   expected_psf <- sum(edge_costs / edge_overlaps) / pcosts[k]
   expect_equal(psf[k], expected_psf, tolerance = 1e-10)
 }
})

test_that("path_weights computation is mathematically correct (PSL formula)", {
 graph <- data.frame(
   from = c(1, 1, 2, 2, 3, 3),
   to = c(2, 3, 3, 4, 4, 4),
   cost = c(1, 2, 1, 3, 1, 2)
 )
 od <- data.frame(from = 1, to = 4, flow = 100)

 beta <- 1
 result <- run_assignment(graph, od,
                          cost.column = "cost",
                          method = "PSL",
                          beta = beta,
                          angle.max = NA,
                          return.extra = c("costs", "PSF", "weights"),
                          verbose = FALSE)

 pcosts <- result$path_costs[[1]]
 psf <- result$path_size_factors[[1]]
 pweights <- result$path_weights[[1]]

 # PSL formula: prob_k = exp(-cost_k + beta * log(PSF_k)) / sum(...)
 expected <- proportions(exp(-pcosts + beta * log(psf)))
 expect_equal(pweights, expected, tolerance = 1e-10)
})

test_that("edge_weights are sum of path probabilities per edge", {
 result <- run_assignment(simple_graph, simple_od,
                          cost.column = "cost",
                          method = "PSL",
                          angle.max = NA,
                          return.extra = c("paths", "edges", "weights", "eweights"),
                          verbose = FALSE)

 # For each OD pair, verify edge_weights
 for (i in seq_along(result$od_pairs_used)) {
   paths <- result$paths[[i]]
   edges <- result$edges[[i]]
   pweights <- result$path_weights[[i]]
   eweights <- result$edge_weights[[i]]

   # Manually compute edge weights
   expected_eweights <- numeric(length(edges))
   for (k in seq_along(paths)) {
     path_edges <- paths[[k]]
     for (e in path_edges) {
       idx <- match(e, edges)
       expected_eweights[idx] <- expected_eweights[idx] + pweights[k]
     }
   }

   expect_equal(eweights, expected_eweights, tolerance = 1e-10)
 }
})

test_that("path_costs are sum of edge costs along path", {
 result <- run_assignment(simple_graph, simple_od,
                          cost.column = "cost",
                          method = "PSL",
                          angle.max = NA,
                          return.extra = c("paths", "costs"),
                          verbose = FALSE)

 cost <- simple_graph$cost

 for (i in seq_along(result$od_pairs_used)) {
   paths <- result$paths[[i]]
   pcosts <- result$path_costs[[i]]

   for (k in seq_along(paths)) {
     expected_cost <- sum(cost[paths[[k]]])
     expect_equal(pcosts[k], expected_cost, tolerance = 1e-10)
   }
 }
})

test_that("edge_counts match number of paths using each edge", {
 result <- run_assignment(simple_graph, simple_od,
                          cost.column = "cost",
                          method = "PSL",
                          angle.max = NA,
                          return.extra = c("paths", "edges", "counts"),
                          verbose = FALSE)

 for (i in seq_along(result$od_pairs_used)) {
   paths <- result$paths[[i]]
   edges <- result$edges[[i]]
   ecounts <- result$edge_counts[[i]]

   # Manually count edge usage
   expected_counts <- integer(length(edges))
   for (k in seq_along(paths)) {
     for (e in paths[[k]]) {
       idx <- match(e, edges)
       expected_counts[idx] <- expected_counts[idx] + 1L
     }
   }

   expect_equal(ecounts, expected_counts)
 }
})

test_that("final_flows equals sum of flow * path_weight * edge membership", {
 result <- run_assignment(simple_graph, simple_od,
                          cost.column = "cost",
                          method = "PSL",
                          angle.max = NA,
                          return.extra = c("paths", "weights"),
                          verbose = FALSE)

 # Manually compute final_flows
 n_edges <- nrow(simple_graph)
 expected_flows <- numeric(n_edges)

 for (i in seq_along(result$od_pairs_used)) {
   flow_i <- simple_od$flow[result$od_pairs_used[i]]
   paths <- result$paths[[i]]
   pweights <- result$path_weights[[i]]

   for (k in seq_along(paths)) {
     for (e in paths[[k]]) {
       expected_flows[e] <- expected_flows[e] + flow_i * pweights[k]
     }
   }
 }

 expect_equal(result$final_flows, expected_flows, tolerance = 1e-10)
})

test_that("PSL probabilities sum to 1 for each OD pair", {
 result <- run_assignment(simple_graph, simple_od,
                          cost.column = "cost",
                          method = "PSL",
                          angle.max = NA,
                          return.extra = "weights",
                          verbose = FALSE)

 for (pweights in result$path_weights) {
   expect_equal(sum(pweights), 1, tolerance = 1e-10)
 }
})

test_that("beta parameter affects PSF penalty correctly", {
 graph <- data.frame(
   from = c(1, 1, 2, 2, 3),
   to = c(2, 3, 3, 4, 4),
   cost = c(1, 2, 1, 2, 1)
 )
 od <- data.frame(from = 1, to = 4, flow = 100)

 result_b0 <- run_assignment(graph, od,
                             cost.column = "cost",
                             method = "PSL",
                             beta = 0,
                             angle.max = NA,
                             return.extra = c("costs", "PSF", "weights"),
                             verbose = FALSE)

 result_b5 <- run_assignment(graph, od,
                             cost.column = "cost",
                             method = "PSL",
                             beta = 5,
                             angle.max = NA,
                             return.extra = c("costs", "PSF", "weights"),
                             verbose = FALSE)

 # With beta=0, PSF should have no effect - pure cost-based logit
 pcosts <- result_b0$path_costs[[1]]
 expected_b0 <- proportions(exp(-pcosts))
 expect_equal(result_b0$path_weights[[1]], expected_b0, tolerance = 1e-10)

 # With higher beta, overlapping paths should be penalized more
 # PSF values should be the same, but weights different
 expect_equal(result_b0$path_size_factors[[1]],
              result_b5$path_size_factors[[1]], tolerance = 1e-10)

 # Verify beta=5 formula
 psf <- result_b5$path_size_factors[[1]]
 expected_b5 <- proportions(exp(-pcosts + 5 * log(psf)))
 expect_equal(result_b5$path_weights[[1]], expected_b5, tolerance = 1e-10)
})