diff --git a/R/versions.R b/R/versions.R index 08d888e7e0a..cfda3984ae1 100644 --- a/R/versions.R +++ b/R/versions.R @@ -104,6 +104,9 @@ check_version <- function(graph) { } warn_version <- function(graph) { + # Calling for side effect: error if R_SEXP_to_igraph() fails + vcount_impl(graph) + if (graph_version() != graph_version(graph)) { message( "This graph was created by an old(er) igraph version.\n", diff --git a/src/rinterface_extra.c b/src/rinterface_extra.c index 5877b7ae5c7..bed4b7877cf 100644 --- a/src/rinterface_extra.c +++ b/src/rinterface_extra.c @@ -2883,16 +2883,52 @@ void R_igraph_set_pointer(SEXP result, const igraph_t* graph) { UNPROTECT(px); } +void R_igraph_restore_pointer(SEXP graph) { + igraph_t g; + igraph_vector_t v; + igraph_integer_t n=REAL(VECTOR_ELT(graph, igraph_t_idx_n))[0]; + igraph_bool_t directed=LOGICAL(VECTOR_ELT(graph, igraph_t_idx_directed))[0]; + + igraph_vector_t from; + R_SEXP_to_vector(VECTOR_ELT(graph, igraph_t_idx_from), &from); + + igraph_vector_t to; + R_SEXP_to_vector(VECTOR_ELT(graph, igraph_t_idx_to), &to); + + igraph_integer_t i, s=igraph_vector_size(&from); + igraph_vector_init(&v, s*2); + + for (i = 0; i < s; ++i) + { + igraph_vector_set(&v, i*2, VECTOR(to)[i]); + igraph_vector_set(&v, i*2+1, VECTOR(from)[i]); + } + + igraph_empty(&g, n, directed); + igraph_add_edges(&g, &v, NULL); + R_igraph_set_pointer(graph, &g); +} + igraph_t *R_igraph_get_pointer(SEXP graph) { if (GET_LENGTH(graph) != igraph_t_idx_max || !Rf_isEnvironment(R_igraph_graph_env(graph))) { - return NULL; + Rf_error("This graph was created by a now unsupported old igraph version.\n Call upgrade_version() before using igraph functions on that object."); } SEXP xp=Rf_findVar(Rf_install("igraph"), R_igraph_graph_env(graph)); if (xp == R_UnboundValue || xp == R_NilValue) { - return NULL; + R_igraph_restore_pointer(graph); + xp=Rf_findVar(Rf_install("igraph"), R_igraph_graph_env(graph)); + } + + igraph_t *pgraph=(igraph_t*)(R_ExternalPtrAddr(xp)); + + if (!pgraph) { + R_igraph_restore_pointer(graph); + xp=Rf_findVar(Rf_install("igraph"), R_igraph_graph_env(graph)); + pgraph=(igraph_t*)(R_ExternalPtrAddr(xp)); } - return (igraph_t*)(R_ExternalPtrAddr(xp)); + + return pgraph; } void R_igraph_set_n(SEXP rgraph, const igraph_t *graph) { @@ -2902,10 +2938,7 @@ void R_igraph_set_n(SEXP rgraph, const igraph_t *graph) { igraph_integer_t R_igraph_get_n(SEXP graph) { igraph_t *pgraph=R_igraph_get_pointer(graph); - if (pgraph) { - return pgraph->n; - } - return REAL(VECTOR_ELT(graph, igraph_t_idx_n))[0]; + return pgraph->n; } void R_igraph_set_directed(SEXP rgraph, const igraph_t *graph) { @@ -2915,10 +2948,7 @@ void R_igraph_set_directed(SEXP rgraph, const igraph_t *graph) { igraph_bool_t R_igraph_get_directed(SEXP graph) { igraph_t *pgraph=R_igraph_get_pointer(graph); - if (pgraph) { - return pgraph->directed; - } - return LOGICAL(VECTOR_ELT(graph, igraph_t_idx_directed))[0]; + return pgraph->directed; } void R_igraph_set_from(SEXP rgraph, const igraph_t *graph) { @@ -2930,11 +2960,7 @@ void R_igraph_set_from(SEXP rgraph, const igraph_t *graph) { void R_igraph_get_from(SEXP graph, igraph_vector_t* from) { igraph_t *pgraph=R_igraph_get_pointer(graph); - if (pgraph) { - *from = pgraph->from; - } else { - R_SEXP_to_vector(VECTOR_ELT(graph, igraph_t_idx_from), from); - } + *from = pgraph->from; } void R_igraph_set_to(SEXP rgraph, const igraph_t *graph) { @@ -2946,11 +2972,27 @@ void R_igraph_set_to(SEXP rgraph, const igraph_t *graph) { void R_igraph_get_to(SEXP graph, igraph_vector_t* to) { igraph_t *pgraph=R_igraph_get_pointer(graph); - if (pgraph) { - *to = pgraph->to; - } else { - R_SEXP_to_vector(VECTOR_ELT(graph, igraph_t_idx_to), to); - } + *to = pgraph->to; +} + +void R_igraph_get_oi(SEXP graph, igraph_vector_t* oi) { + igraph_t *pgraph=R_igraph_get_pointer(graph); + *oi = pgraph->oi; +} + +void R_igraph_get_ii(SEXP graph, igraph_vector_t* ii) { + igraph_t *pgraph=R_igraph_get_pointer(graph); + *ii = pgraph->ii; +} + +void R_igraph_get_os(SEXP graph, igraph_vector_t* os) { + igraph_t *pgraph=R_igraph_get_pointer(graph); + *os = pgraph->os; +} + +void R_igraph_get_is(SEXP graph, igraph_vector_t* is) { + igraph_t *pgraph=R_igraph_get_pointer(graph); + *is = pgraph->is; } SEXP R_igraph_to_SEXP(const igraph_t *graph) { @@ -2964,19 +3006,6 @@ SEXP R_igraph_to_SEXP(const igraph_t *graph) { R_igraph_set_directed(result, graph); R_igraph_set_from(result, graph); R_igraph_set_to(result, graph); - SET_VECTOR_ELT(result, igraph_t_idx_oi, NEW_NUMERIC(no_of_edges)); - SET_VECTOR_ELT(result, igraph_t_idx_ii, NEW_NUMERIC(no_of_edges)); - SET_VECTOR_ELT(result, igraph_t_idx_os, NEW_NUMERIC(no_of_nodes+1)); - SET_VECTOR_ELT(result, igraph_t_idx_is, NEW_NUMERIC(no_of_nodes+1)); - - memcpy(REAL(VECTOR_ELT(result, igraph_t_idx_oi)), graph->oi.stor_begin, - sizeof(igraph_real_t)*(size_t) no_of_edges); - memcpy(REAL(VECTOR_ELT(result, igraph_t_idx_ii)), graph->ii.stor_begin, - sizeof(igraph_real_t)*(size_t) no_of_edges); - memcpy(REAL(VECTOR_ELT(result, igraph_t_idx_os)), graph->os.stor_begin, - sizeof(igraph_real_t)*(size_t) (no_of_nodes+1)); - memcpy(REAL(VECTOR_ELT(result, igraph_t_idx_is)), graph->is.stor_begin, - sizeof(igraph_real_t)*(size_t) (no_of_nodes+1)); SET_CLASS(result, Rf_ScalarString(Rf_mkChar("igraph"))); @@ -3593,10 +3622,10 @@ int R_SEXP_to_igraph(SEXP graph, igraph_t *res) { res->directed=R_igraph_get_directed(graph); R_igraph_get_from(graph, &res->from); R_igraph_get_to(graph, &res->to); - R_SEXP_to_vector(VECTOR_ELT(graph, igraph_t_idx_oi), &res->oi); - R_SEXP_to_vector(VECTOR_ELT(graph, igraph_t_idx_ii), &res->ii); - R_SEXP_to_vector(VECTOR_ELT(graph, igraph_t_idx_os), &res->os); - R_SEXP_to_vector(VECTOR_ELT(graph, igraph_t_idx_is), &res->is); + R_igraph_get_oi(graph, &res->oi); + R_igraph_get_ii(graph, &res->ii); + R_igraph_get_os(graph, &res->os); + R_igraph_get_is(graph, &res->is); /* attributes */ REAL(VECTOR_ELT(VECTOR_ELT(graph, igraph_t_idx_attr), 0))[0] = 1; /* R objects refcount */ @@ -3617,14 +3646,18 @@ int R_SEXP_to_igraph_copy(SEXP graph, igraph_t *res) { igraph_vector_t to; R_igraph_get_to(graph, &to); igraph_vector_copy(&res->to, &to); - igraph_vector_init_copy(&res->oi, REAL(VECTOR_ELT(graph, igraph_t_idx_oi)), - GET_LENGTH(VECTOR_ELT(graph, igraph_t_idx_oi))); - igraph_vector_init_copy(&res->ii, REAL(VECTOR_ELT(graph, igraph_t_idx_ii)), - GET_LENGTH(VECTOR_ELT(graph, igraph_t_idx_ii))); - igraph_vector_init_copy(&res->os, REAL(VECTOR_ELT(graph, igraph_t_idx_os)), - GET_LENGTH(VECTOR_ELT(graph, igraph_t_idx_os))); - igraph_vector_init_copy(&res->is, REAL(VECTOR_ELT(graph, igraph_t_idx_is)), - GET_LENGTH(VECTOR_ELT(graph, igraph_t_idx_is))); + igraph_vector_t oi; + R_igraph_get_oi(graph, &oi); + igraph_vector_copy(&res->oi, &oi); + igraph_vector_t ii; + R_igraph_get_ii(graph, &ii); + igraph_vector_copy(&res->ii, &ii); + igraph_vector_t os; + R_igraph_get_os(graph, &os); + igraph_vector_copy(&res->os, &os); + igraph_vector_t is; + R_igraph_get_is(graph, &is); + igraph_vector_copy(&res->is, &is); /* attributes */ REAL(VECTOR_ELT(VECTOR_ELT(graph, igraph_t_idx_attr), 0))[0] = 1; /* R objects */ diff --git a/tests/testthat/_snaps/old-data-type.md b/tests/testthat/_snaps/old-data-type.md new file mode 100644 index 00000000000..7f19013e7d3 --- /dev/null +++ b/tests/testthat/_snaps/old-data-type.md @@ -0,0 +1,8 @@ +# VS/ES require explicit conversion + + Code + V(karate) + Error + This graph was created by a now unsupported old igraph version. + Call upgrade_version() before using igraph functions on that object. + diff --git a/tests/testthat/test-old-data-type.R b/tests/testthat/test-old-data-type.R index 684c0fc6f91..2bea91a070c 100644 --- a/tests/testthat/test-old-data-type.R +++ b/tests/testthat/test-old-data-type.R @@ -1,99 +1,105 @@ -test_that("VS/ES work with old data type", { - karate <- - structure( - list( - 34, - FALSE, - c( - 1, 2, 3, 4, 5, 6, 7, 8, 10, 11, 12, - 13, 17, 19, 21, 31, 2, 3, 7, 13, 17, 19, 21, 30, 3, 7, 8, 9, - 13, 27, 28, 32, 7, 12, 13, 6, 10, 6, 10, 16, 16, 30, 32, 33, - 33, 33, 32, 33, 32, 33, 32, 33, 33, 32, 33, 32, 33, 25, 27, 29, - 32, 33, 25, 27, 31, 31, 29, 33, 33, 31, 33, 32, 33, 32, 33, 32, - 33, 33 - ), - c( - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, - 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 4, 4, 5, - 5, 5, 6, 8, 8, 8, 9, 13, 14, 14, 15, 15, 18, 18, 19, 20, 20, - 22, 22, 23, 23, 23, 23, 23, 24, 24, 24, 25, 26, 26, 27, 28, 28, - 29, 29, 30, 30, 31, 31, 32 - ), - c( - 0, 1, 16, 2, 17, 24, 3, 4, 5, - 35, 37, 6, 18, 25, 32, 7, 26, 27, 8, 36, 38, 9, 10, 33, 11, 19, - 28, 34, 39, 40, 12, 20, 13, 21, 14, 22, 57, 62, 29, 58, 63, 30, - 59, 66, 23, 41, 15, 64, 65, 69, 31, 42, 46, 48, 50, 53, 55, 60, - 71, 73, 75, 43, 44, 45, 47, 49, 51, 52, 54, 56, 61, 67, 68, 70, - 72, 74, 76, 77 - ), - c( - 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, - 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, - 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, - 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, - 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, - 77 - ), - c( - 0, 0, 1, 3, 6, 7, 8, 11, 15, 17, 18, 21, 22, 24, 28, 28, - 28, 30, 32, 32, 34, 34, 36, 36, 36, 36, 38, 38, 41, 42, 44, 46, - 50, 61, 78 - ), - c( - 0, 16, 24, 32, 35, 37, 40, 41, 41, 44, 45, 45, - 45, 45, 46, 48, 50, 50, 50, 52, 53, 55, 55, 57, 62, 65, 66, 68, - 69, 71, 73, 75, 77, 78, 78 +names <- c( + "Mr Hi", "Actor 2", "Actor 3", "Actor 4", + "Actor 5", "Actor 6", "Actor 7", "Actor 8", "Actor 9", "Actor 10", + "Actor 11", "Actor 12", "Actor 13", "Actor 14", "Actor 15", "Actor 16", + "Actor 17", "Actor 18", "Actor 19", "Actor 20", "Actor 21", "Actor 22", + "Actor 23", "Actor 24", "Actor 25", "Actor 26", "Actor 27", "Actor 28", + "Actor 29", "Actor 30", "Actor 31", "Actor 32", "Actor 33", "John A" +) + +karate <- structure( + list( + 34, + FALSE, + c( + 1, 2, 3, 4, 5, 6, 7, 8, 10, 11, 12, + 13, 17, 19, 21, 31, 2, 3, 7, 13, 17, 19, 21, 30, 3, 7, 8, 9, + 13, 27, 28, 32, 7, 12, 13, 6, 10, 6, 10, 16, 16, 30, 32, 33, + 33, 33, 32, 33, 32, 33, 32, 33, 33, 32, 33, 32, 33, 25, 27, 29, + 32, 33, 25, 27, 31, 31, 29, 33, 33, 31, 33, 32, 33, 32, 33, 32, + 33, 33 + ), + c( + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, + 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 4, 4, 5, + 5, 5, 6, 8, 8, 8, 9, 13, 14, 14, 15, 15, 18, 18, 19, 20, 20, + 22, 22, 23, 23, 23, 23, 23, 24, 24, 24, 25, 26, 26, 27, 28, 28, + 29, 29, 30, 30, 31, 31, 32 + ), + c( + 0, 1, 16, 2, 17, 24, 3, 4, 5, + 35, 37, 6, 18, 25, 32, 7, 26, 27, 8, 36, 38, 9, 10, 33, 11, 19, + 28, 34, 39, 40, 12, 20, 13, 21, 14, 22, 57, 62, 29, 58, 63, 30, + 59, 66, 23, 41, 15, 64, 65, 69, 31, 42, 46, 48, 50, 53, 55, 60, + 71, 73, 75, 43, 44, 45, 47, 49, 51, 52, 54, 56, 61, 67, 68, 70, + 72, 74, 76, 77 + ), + c( + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, + 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, + 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, + 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, + 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, + 77 + ), + c( + 0, 0, 1, 3, 6, 7, 8, 11, 15, 17, 18, 21, 22, 24, 28, 28, + 28, 30, 32, 32, 34, 34, 36, 36, 36, 36, 38, 38, 41, 42, 44, 46, + 50, 61, 78 + ), + c( + 0, 16, 24, 32, 35, 37, 40, 41, 41, 44, 45, 45, + 45, 45, 46, 48, 50, 50, 50, 52, 53, 55, 55, 57, 62, 65, 66, 68, + 69, 71, 73, 75, 77, 78, 78 + ), + list( + c(1, 0, 1), + structure( + list( + name = "Zachary's karate club network", + Citation = "Wayne W. Zachary. An Information Flow Model for Conflict and Fission in Small Groups. Journal of Anthropological Research Vol. 33, No. 4 452-473", + Author = "Wayne W. Zachary" ), + .Names = c("name", "Citation", "Author") + ), + structure( list( - c(1, 0, 1), - structure( - list( - name = "Zachary's karate club network", - Citation = "Wayne W. Zachary. An Information Flow Model for Conflict and Fission in Small Groups. Journal of Anthropological Research Vol. 33, No. 4 452-473", - Author = "Wayne W. Zachary" - ), - .Names = c("name", "Citation", "Author") + Faction = c( + 1, 1, 1, 1, 1, 1, 1, 1, + 2, 2, 1, 1, 1, 1, 2, 2, 1, 1, 2, 1, 2, 1, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2 ), - structure( - list( - Faction = c( - 1, 1, 1, 1, 1, 1, 1, 1, - 2, 2, 1, 1, 1, 1, 2, 2, 1, 1, 2, 1, 2, 1, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2 - ), - name = c( - "Mr Hi", "Actor 2", "Actor 3", "Actor 4", - "Actor 5", "Actor 6", "Actor 7", "Actor 8", "Actor 9", "Actor 10", - "Actor 11", "Actor 12", "Actor 13", "Actor 14", "Actor 15", "Actor 16", - "Actor 17", "Actor 18", "Actor 19", "Actor 20", "Actor 21", "Actor 22", - "Actor 23", "Actor 24", "Actor 25", "Actor 26", "Actor 27", "Actor 28", - "Actor 29", "Actor 30", "Actor 31", "Actor 32", "Actor 33", "John A" - ) - ), - .Names = c("Faction", "name") - ), - structure( - list( - weight = c( - 4, - 5, 3, 3, 3, 3, 2, 2, 2, 3, 1, 3, 2, 2, 2, 2, 6, 3, 4, 5, 1, 2, - 2, 2, 3, 4, 5, 1, 3, 2, 2, 2, 3, 3, 3, 2, 3, 5, 3, 3, 3, 3, 3, - 4, 2, 3, 3, 2, 3, 4, 1, 2, 1, 3, 1, 2, 3, 5, 4, 3, 5, 4, 2, 3, - 2, 7, 4, 2, 4, 2, 2, 4, 2, 3, 3, 4, 4, 5 - ) - ), - .Names = "weight" - ) - ) + name = names + ), + .Names = c("Faction", "name") ), - class = "igraph" + structure( + list( + weight = c( + 4, + 5, 3, 3, 3, 3, 2, 2, 2, 3, 1, 3, 2, 2, 2, 2, 6, 3, 4, 5, 1, 2, + 2, 2, 3, 4, 5, 1, 3, 2, 2, 2, 3, 3, 3, 2, 3, 5, 3, 3, 3, 3, 3, + 4, 2, 3, 3, 2, 3, 4, 1, 2, 1, 3, 1, 2, 3, 5, 4, 3, 5, 4, 2, 3, + 2, 7, 4, 2, 4, 2, 2, 4, 2, 3, 3, 4, 4, 5 + ) + ), + .Names = "weight" + ) ) + ), + class = "igraph" +) + +test_that("VS/ES require explicit conversion", { + expect_snapshot(error = TRUE, { + V(karate) + }) +}) +test_that("VS/ES work with old data type", { karate2 <- upgrade_graph(karate) - vs <- V(karate) vs2 <- V(karate2) - expect_equal(length(vs), length(vs2)) - expect_equal(vs$name, vs2$name) + expect_equal(length(vs2), 34) + expect_equal(vs2$name, names) })