From 306d4d22b2798861600c94468f45fc0c62929c14 Mon Sep 17 00:00:00 2001 From: David Schoch Date: Thu, 28 May 2026 12:42:25 +0200 Subject: [PATCH] fix: synchronize R RNG state in hand-written C glue (#2211) Hand-written wrappers in src/rinterface_extra.c called igraph functions that consume the RNG without bracketing them with GetRNGstate()/ PutRNGstate(), so R's seeded RNG state was never read into the default igraph RNG. This made layout_with_fr() and other stochastic functions return different results on each call even under withr::with_seed(). Adds an Rx_PutRNGstate_pv helper registered via IGRAPH_FINALLY so the RNG state is also restored along error paths that longjmp out of IGRAPH_R_CHECK. The bracket is applied to the FR, KK, graphopt, LGL, DrL, merge_dla and walktrap_community wrappers, plus the legacy RNG_BEGIN/RNG_END calls in Rx_igraph_ac_random_numeric are expanded to the explicit API. Replaces the fragile sum(l) snapshot test for layout_with_fr() with shape + finitude checks, hoists the local check_matrix helper, and adds reproducibility tests for every stochastic layout plus sample_gnp/gnm/pa/smallworld, random_walk, and cluster_walktrap/louvain/leiden. Co-Authored-By: Claude Opus 4.7 (1M context) --- src/rinterface_extra.c | 61 +++++++++++++++++++++++++-- tests/testthat/test-layout.R | 68 ++++++++++++++++++++++++++----- tests/testthat/test-rng-seeding.R | 51 +++++++++++++++++++++++ 3 files changed, 165 insertions(+), 15 deletions(-) create mode 100644 tests/testthat/test-rng-seeding.R diff --git a/src/rinterface_extra.c b/src/rinterface_extra.c index e616295c64f..efff31ae5ab 100644 --- a/src/rinterface_extra.c +++ b/src/rinterface_extra.c @@ -132,6 +132,15 @@ void igraph_vector_int_list_destroy_pv(void *pv_ptr) igraph_vector_int_list_destroy((igraph_vector_int_list_t*) pv_ptr); } +/* Restores R's RNG state from the igraph finally stack, so it runs even when an + * igraph call longjmps out via IGRAPH_R_CHECK. Pair every GetRNGstate() call + * with IGRAPH_FINALLY(Rx_PutRNGstate_pv, NULL), then on the success path call + * PutRNGstate() and IGRAPH_FINALLY_CLEAN(1). */ +static void Rx_PutRNGstate_pv(void *pv_ptr) { + (void) pv_ptr; + PutRNGstate(); +} + igraph_error_t Rw_get_int_scalar(SEXP sexp, R_xlen_t index, igraph_integer_t *res) { if (Rf_xlength(sexp) <= index) @@ -1672,7 +1681,7 @@ SEXP Rx_igraph_ac_random_numeric(SEXP attr, PROTECT(attr2=AS_NUMERIC(attr)); PROTECT(res=NEW_NUMERIC(len)); - RNG_BEGIN(); + GetRNGstate(); for (igraph_integer_t i=0; i 0) { + expect_true(all(is.finite(mat))) + } +} + test_that("layout_with_fr() works", { skip_on_os("solaris") + g <- make_ring(10) withr::with_seed(42, { - g <- make_ring(10) l <- layout_with_fr(g, niter = 50, start.temp = sqrt(10) / 10) }) - expect_equal(sum(l), 4.57228, tolerance = 0.1) + check_matrix(l, nrow = 10, ncol = 2) + g <- make_star(30) withr::with_seed(42, { - g <- make_star(30) l <- layout_with_fr(g, niter = 500, dim = 3, start.temp = 20) }) - expect_equal(sum(l), -170.9312, tolerance = 0.1) + check_matrix(l, nrow = 30, ncol = 3) +}) + +test_that("stochastic layouts are reproducible with set.seed()", { + g <- make_ring(20) + make_star(10, mode = "undirected") + + expect_identical( + withr::with_seed(42, layout_with_fr(g, niter = 50)), + withr::with_seed(42, layout_with_fr(g, niter = 50)) + ) + expect_identical( + withr::with_seed(42, layout_with_fr(g, niter = 50, dim = 3)), + withr::with_seed(42, layout_with_fr(g, niter = 50, dim = 3)) + ) + expect_identical( + withr::with_seed(42, layout_with_kk(g, maxiter = 50)), + withr::with_seed(42, layout_with_kk(g, maxiter = 50)) + ) + expect_identical( + withr::with_seed(42, layout_with_kk(g, maxiter = 50, dim = 3)), + withr::with_seed(42, layout_with_kk(g, maxiter = 50, dim = 3)) + ) + expect_identical( + withr::with_seed(42, layout_with_dh(g, maxiter = 5)), + withr::with_seed(42, layout_with_dh(g, maxiter = 5)) + ) + expect_identical( + withr::with_seed(42, layout_with_gem(g, maxiter = 50)), + withr::with_seed(42, layout_with_gem(g, maxiter = 50)) + ) + expect_identical( + withr::with_seed(42, layout_with_graphopt(g, niter = 50)), + withr::with_seed(42, layout_with_graphopt(g, niter = 50)) + ) + g_connected <- make_ring(20) + expect_identical( + withr::with_seed(42, layout_with_lgl(g_connected, maxiter = 50)), + withr::with_seed(42, layout_with_lgl(g_connected, maxiter = 50)) + ) + expect_identical( + withr::with_seed(42, layout_with_drl(g)), + withr::with_seed(42, layout_with_drl(g)) + ) + expect_identical( + withr::with_seed(42, layout_with_drl(g, dim = 3)), + withr::with_seed(42, layout_with_drl(g, dim = 3)) + ) }) test_that("layout_with_fr() deprecated argument", { @@ -103,13 +156,6 @@ test_that("layout algorithms work for null graphs", { test_that("layout algorithms work for singleton graphs", { g <- make_empty_graph(1) - check_matrix <- function(mat, nrow = 1, ncol = 2) { - expect_equal(dim(mat), c(nrow, ncol)) - if (nrow > 0) { - expect_true(all(is.finite(mat))) - } - } - expect_silent(layout_as_tree(g)) check_matrix(layout_as_tree(g)) diff --git a/tests/testthat/test-rng-seeding.R b/tests/testthat/test-rng-seeding.R new file mode 100644 index 00000000000..c81b0de794c --- /dev/null +++ b/tests/testthat/test-rng-seeding.R @@ -0,0 +1,51 @@ +# Compare two graphs by their edge structure (ignoring the auto-generated +# `myid` UUID and `igraph` pointer that differ per object). +expect_same_graph <- function(g1, g2) { + expect_identical(as_edgelist(g1), as_edgelist(g2)) + expect_identical(vcount(g1), vcount(g2)) + expect_identical(is_directed(g1), is_directed(g2)) +} + +test_that("random graph generators are reproducible with set.seed()", { + expect_same_graph( + withr::with_seed(42, sample_gnp(50, 0.1)), + withr::with_seed(42, sample_gnp(50, 0.1)) + ) + expect_same_graph( + withr::with_seed(42, sample_gnm(50, 100)), + withr::with_seed(42, sample_gnm(50, 100)) + ) + expect_same_graph( + withr::with_seed(42, sample_pa(50, m = 2)), + withr::with_seed(42, sample_pa(50, m = 2)) + ) + expect_same_graph( + withr::with_seed(42, sample_smallworld(1, 20, 5, 0.05)), + withr::with_seed(42, sample_smallworld(1, 20, 5, 0.05)) + ) +}) + +test_that("random_walk() is reproducible with set.seed()", { + g <- make_ring(20) + expect_identical( + withr::with_seed(42, as.integer(random_walk(g, start = 1, steps = 10))), + withr::with_seed(42, as.integer(random_walk(g, start = 1, steps = 10))) + ) +}) + +test_that("community detection is reproducible with set.seed()", { + g <- make_graph("Zachary") + + expect_identical( + withr::with_seed(42, membership(cluster_walktrap(g))), + withr::with_seed(42, membership(cluster_walktrap(g))) + ) + expect_identical( + withr::with_seed(42, membership(cluster_louvain(g))), + withr::with_seed(42, membership(cluster_louvain(g))) + ) + expect_identical( + withr::with_seed(42, membership(cluster_leiden(g))), + withr::with_seed(42, membership(cluster_leiden(g))) + ) +})