diff --git a/R/aaa-auto.R b/R/aaa-auto.R index f394c14d47..022e5b9128 100644 --- a/R/aaa-auto.R +++ b/R/aaa-auto.R @@ -3427,6 +3427,7 @@ voronoi_impl <- function( check_dots_empty() ensure_igraph(graph) generators <- as_igraph_vs(graph, generators) + generators <- generators - 1 if (is.null(weights) && "weight" %in% edge_attr_names(graph)) { weights <- E(graph)$weight } @@ -3449,7 +3450,7 @@ voronoi_impl <- function( res <- .Call( R_igraph_voronoi, graph, - generators - 1, + generators, weights, mode, tiebreaker @@ -5365,6 +5366,7 @@ is_chordal_impl <- function( } if (!is.null(alpham1)) { alpham1 <- as_igraph_vs(graph, alpham1) + alpham1 <- alpham1 - 1 } on.exit(.Call(R_igraph_finalizer)) @@ -5373,7 +5375,7 @@ is_chordal_impl <- function( R_igraph_is_chordal, graph, alpha, - alpham1 - 1 + alpham1 ) res @@ -7221,6 +7223,7 @@ site_percolation_impl <- function( ensure_igraph(graph) if (!is.null(vertex_order)) { vertex_order <- as_igraph_vs(graph, vertex_order) + vertex_order <- vertex_order - 1 } on.exit(.Call(R_igraph_finalizer)) @@ -7228,7 +7231,7 @@ site_percolation_impl <- function( res <- .Call( R_igraph_site_percolation, graph, - vertex_order - 1 + vertex_order ) res @@ -7371,6 +7374,7 @@ maximal_cliques_subset_impl <- function( # Argument checks ensure_igraph(graph) subset <- as_igraph_vs(graph, subset) + subset <- subset - 1 if (!is.null(outfile)) { check_string(outfile) @@ -7383,7 +7387,7 @@ maximal_cliques_subset_impl <- function( res <- .Call( R_igraph_maximal_cliques_subset, graph, - subset - 1, + subset, outfile, min_size, max_size @@ -7961,6 +7965,7 @@ layout_reingold_tilford_impl <- function( ) if (!is.null(roots)) { roots <- as_igraph_vs(graph, roots) + roots <- roots - 1 } if (!is.null(rootlevel)) { rootlevel <- as.numeric(rootlevel) @@ -7972,7 +7977,7 @@ layout_reingold_tilford_impl <- function( R_igraph_layout_reingold_tilford, graph, mode, - roots - 1, + roots, rootlevel ) @@ -7996,6 +8001,7 @@ layout_reingold_tilford_circular_impl <- function( ) if (!is.null(roots)) { roots <- as_igraph_vs(graph, roots) + roots <- roots - 1 } if (!is.null(rootlevel)) { rootlevel <- as.numeric(rootlevel) @@ -8007,7 +8013,7 @@ layout_reingold_tilford_circular_impl <- function( R_igraph_layout_reingold_tilford_circular, graph, mode, - roots - 1, + roots, rootlevel ) @@ -14105,12 +14111,13 @@ expand_path_to_pairs_impl <- function( ) { # Argument checks path <- as_igraph_vs(path, path) + path <- path - 1 on.exit(.Call(R_igraph_finalizer)) # Function call res <- .Call( R_igraph_expand_path_to_pairs, - path - 1 + path ) if (igraph_opt("return.vs.es")) { res <- create_vs(path, res) @@ -14189,6 +14196,171 @@ version_impl <- function( res } +bfs_closure_impl <- function( + graph, + root, + roots = NULL, + mode = c("out", "in", "all", "total"), + unreachable, + restricted = NULL, + callback +) { + # Argument checks + ensure_igraph(graph) + root <- as_igraph_vs(graph, root) + if (length(root) == 0) { + cli::cli_abort( + "{.arg root} must specify at least one vertex", + call = rlang::caller_env() + ) + } + if (!is.null(roots)) { + roots <- as_igraph_vs(graph, roots) + roots <- roots - 1 + } + mode <- switch_igraph_arg( + mode, + "out" = 1L, + "in" = 2L, + "all" = 3L, + "total" = 3L + ) + unreachable <- as.logical(unreachable) + if (!is.null(restricted)) { + restricted <- as_igraph_vs(graph, restricted) + restricted <- restricted - 1 + } + if (!is.null(callback)) { + if (!is.function(callback)) { + cli::cli_abort("{.arg callback} must be a function") + } + callback_wrapped <- function(...) { + tryCatch( + { + out <- callback(...) + if (is.logical(out) && length(out) == 1 && !is.na(out)) { + out + } else { + rlang::error_cnd(message = "Callback returned a value different from TRUE or FALSE") + } + }, + error = function(e) e, + interrupt = function(e) e + ) + } + } else { + callback_wrapped <- NULL + } + + + on.exit(.Call(R_igraph_finalizer)) + # Function call + res <- .Call( + R_igraph_bfs_closure, + graph, + root - 1, + roots, + mode, + unreachable, + restricted, + callback_wrapped + ) + if (igraph_opt("return.vs.es")) { + res$order <- create_vs(graph, res$order) + } + res +} + +dfs_closure_impl <- function( + graph, + root, + mode = c("out", "in", "all", "total"), + unreachable, + in_callback, + out_callback +) { + # Argument checks + ensure_igraph(graph) + root <- as_igraph_vs(graph, root) + if (length(root) == 0) { + cli::cli_abort( + "{.arg root} must specify at least one vertex", + call = rlang::caller_env() + ) + } + mode <- switch_igraph_arg( + mode, + "out" = 1L, + "in" = 2L, + "all" = 3L, + "total" = 3L + ) + unreachable <- as.logical(unreachable) + if (!is.null(in_callback)) { + if (!is.function(in_callback)) { + cli::cli_abort("{.arg callback} must be a function") + } + in_callback_wrapped <- function(...) { + tryCatch( + { + out <- in_callback(...) + if (is.logical(out) && length(out) == 1 && !is.na(out)) { + out + } else { + rlang::error_cnd(message = "Callback returned a value different from TRUE or FALSE") + } + }, + error = function(e) e, + interrupt = function(e) e + ) + } + } else { + in_callback_wrapped <- NULL + } + + if (!is.null(out_callback)) { + if (!is.function(out_callback)) { + cli::cli_abort("{.arg callback} must be a function") + } + out_callback_wrapped <- function(...) { + tryCatch( + { + out <- out_callback(...) + if (is.logical(out) && length(out) == 1 && !is.na(out)) { + out + } else { + rlang::error_cnd(message = "Callback returned a value different from TRUE or FALSE") + } + }, + error = function(e) e, + interrupt = function(e) e + ) + } + } else { + out_callback_wrapped <- NULL + } + + + on.exit(.Call(R_igraph_finalizer)) + # Function call + res <- .Call( + R_igraph_dfs_closure, + graph, + root - 1, + mode, + unreachable, + in_callback_wrapped, + out_callback_wrapped + ) + if (igraph_opt("return.vs.es")) { + res$order <- create_vs(graph, res$order) + } + if (igraph_opt("return.vs.es")) { + res$order_out <- create_vs(graph, res$order_out) + } + res +} + cliques_callback_closure_impl <- function( graph, min_size = 0, @@ -14205,8 +14377,16 @@ cliques_callback_closure_impl <- function( } callback_wrapped <- function(...) { tryCatch( - callback(...), - error = function(e) e + { + out <- callback(...) + if (is.logical(out) && length(out) == 1 && !is.na(out)) { + out + } else { + rlang::error_cnd(message = "Callback returned a value different from TRUE or FALSE") + } + }, + error = function(e) e, + interrupt = function(e) e ) } } else { @@ -14243,8 +14423,16 @@ maximal_cliques_callback_closure_impl <- function( } callback_wrapped <- function(...) { tryCatch( - callback(...), - error = function(e) e + { + out <- callback(...) + if (is.logical(out) && length(out) == 1 && !is.na(out)) { + out + } else { + rlang::error_cnd(message = "Callback returned a value different from TRUE or FALSE") + } + }, + error = function(e) e, + interrupt = function(e) e ) } } else { @@ -14299,8 +14487,16 @@ community_leading_eigenvector_callback_closure_impl <- function( } callback_wrapped <- function(...) { tryCatch( - callback(...), - error = function(e) e + { + out <- callback(...) + if (is.logical(out) && length(out) == 1 && !is.na(out)) { + out + } else { + rlang::error_cnd(message = "Callback returned a value different from TRUE or FALSE") + } + }, + error = function(e) e, + interrupt = function(e) e ) } } else { @@ -14386,8 +14582,16 @@ get_isomorphisms_vf2_callback_closure_impl <- function( } callback_wrapped <- function(...) { tryCatch( - callback(...), - error = function(e) e + { + out <- callback(...) + if (is.logical(out) && length(out) == 1 && !is.na(out)) { + out + } else { + rlang::error_cnd(message = "Callback returned a value different from TRUE or FALSE") + } + }, + error = function(e) e, + interrupt = function(e) e ) } } else { @@ -14469,8 +14673,16 @@ get_subisomorphisms_vf2_callback_closure_impl <- function( } callback_wrapped <- function(...) { tryCatch( - callback(...), - error = function(e) e + { + out <- callback(...) + if (is.logical(out) && length(out) == 1 && !is.na(out)) { + out + } else { + rlang::error_cnd(message = "Callback returned a value different from TRUE or FALSE") + } + }, + error = function(e) e, + interrupt = function(e) e ) } } else { @@ -14518,8 +14730,16 @@ simple_cycles_callback_closure_impl <- function( } callback_wrapped <- function(...) { tryCatch( - callback(...), - error = function(e) e + { + out <- callback(...) + if (is.logical(out) && length(out) == 1 && !is.na(out)) { + out + } else { + rlang::error_cnd(message = "Callback returned a value different from TRUE or FALSE") + } + }, + error = function(e) e, + interrupt = function(e) e ) } } else { @@ -14559,8 +14779,16 @@ motifs_randesu_callback_closure_impl <- function( } callback_wrapped <- function(...) { tryCatch( - callback(...), - error = function(e) e + { + out <- callback(...) + if (is.logical(out) && length(out) == 1 && !is.na(out)) { + out + } else { + rlang::error_cnd(message = "Callback returned a value different from TRUE or FALSE") + } + }, + error = function(e) e, + interrupt = function(e) e ) } } else { diff --git a/R/cliques.R b/R/cliques.R index c5c4fae129..fe3a85f0c3 100644 --- a/R/cliques.R +++ b/R/cliques.R @@ -204,8 +204,8 @@ clique.number <- function(graph) { #' @param ... These dots are for future extensions and must be empty. #' @param callback Optional function to call for each clique found. If provided, #' the function should accept one argument: `clique` (integer vector of vertex -#' IDs in the clique, 1-based indexing). The function should return `TRUE` to -#' continue the search or `FALSE` to stop it. If `NULL` (the default), all +#' IDs in the clique, 1-based indexing). The function should return `FALSE` to +#' continue the search or `TRUE` to stop it. If `NULL` (the default), all #' cliques are collected and returned as a list. #' #' **Important limitation:** Callback functions must NOT call any igraph diff --git a/R/cycles.R b/R/cycles.R index b67a0eee0f..d6482aeba0 100644 --- a/R/cycles.R +++ b/R/cycles.R @@ -77,8 +77,8 @@ find_cycle <- function(graph, mode = c("out", "in", "all", "total")) { #' @param callback Optional function to call for each cycle found. If provided, #' the function should accept two arguments: `vertices` (integer vector of vertex #' IDs in the cycle) and `edges` (integer vector of edge IDs -#' in the cycle). The function should return `TRUE` to continue -#' the search or `FALSE` to stop it. If `NULL` (the default), all cycles are +#' in the cycle). The function should return `FALSE` to continue +#' the search or `TRUE` to stop it. If `NULL` (the default), all cycles are #' collected and returned as a list. #' #' **Important limitation:** Callback functions must NOT call any igraph @@ -103,8 +103,8 @@ find_cycle <- function(graph, mode = c("out", "in", "all", "total")) { #' @param callback Optional function to call for each cycle found. If provided, #' the function should accept two arguments: `vertices` (integer vector of vertex #' IDs in the cycle) and `edges` (integer vector of edge IDs -#' in the cycle). The function should return `TRUE` to continue -#' the search or `FALSE` to stop it. If `NULL` (the default), all cycles are +#' in the cycle). The function should return `FALSE` to continue +#' the search or `TRUE` to stop it. If `NULL` (the default), all cycles are #' collected and returned as a list. #' #' **Important limitation:** Callback functions must NOT call any igraph diff --git a/R/motifs.R b/R/motifs.R index c0baf11fc6..252d69710a 100644 --- a/R/motifs.R +++ b/R/motifs.R @@ -139,7 +139,7 @@ dyad.census <- function(graph) { #' @param callback Optional callback function to call for each motif found. #' The function should accept two arguments: `vids` (integer vector of vertex IDs #' in the motif) and `isoclass` (the isomorphism class of the motif). -#' The function should return `TRUE` to continue the search or `FALSE` to stop it. +#' The function should return `FALSE` to continue the search or `TRUE` to stop it. #' If `NULL` (the default), motif counts are returned as a numeric vector. #' #' **Important limitation:** Callback functions must NOT call any igraph diff --git a/R/structural-properties.R b/R/structural-properties.R index 3bd2180cd1..e7c23846e9 100644 --- a/R/structural-properties.R +++ b/R/structural-properties.R @@ -2633,7 +2633,8 @@ count_loops <- function(graph) { #' @param dist Logical scalar, whether to return the distance from the root of #' the search tree. #' @param callback If not `NULL`, then it must be callback function. This -#' is called whenever a vertex is visited. See details below. +#' is called whenever a vertex is visited. The callback function should +#' return `FALSE` to continue the search or `TRUE` to stop it. See details below. #' @param extra Additional argument to supply to the callback function. #' @param rho The environment in which the callback function is evaluated. #' @param neimode `r lifecycle::badge("deprecated")` This argument is deprecated diff --git a/R/topology.R b/R/topology.R index 1ac92cc824..c07d59e785 100644 --- a/R/topology.R +++ b/R/topology.R @@ -770,7 +770,7 @@ graph.count.subisomorphisms.vf2 <- function( #' If provided, the function should accept two arguments: `map12` (integer vector #' mapping vertex IDs from graph1 to graph2, 1-based indexing) and `map21` #' (integer vector mapping vertex IDs from graph2 to graph1, 1-based indexing). -#' The function should return `TRUE` to continue the search or `FALSE` to stop it. +#' The function should return `FALSE` to continue the search or `TRUE` to stop it. #' If `NULL` (the default), all isomorphisms are collected and returned as a list. #' Only supported for `method = "vf2"`. #' @@ -895,7 +895,7 @@ isomorphisms <- function(graph1, graph2, method = "vf2", ..., callback = NULL) { #' If provided, the function should accept two arguments: `map12` (integer vector #' mapping vertex IDs from pattern to target, 1-based indexing) and `map21` #' (integer vector mapping vertex IDs from target to pattern, 1-based indexing). -#' The function should return `TRUE` to continue the search or `FALSE` to stop it. +#' The function should return `FALSE` to continue the search or `TRUE` to stop it. #' If `NULL` (the default), all subisomorphisms are collected and returned as a list. #' Only supported for `method = "vf2"`. #' diff --git a/man/bfs.Rd b/man/bfs.Rd index d72f3f7603..4f4bc9a4fd 100644 --- a/man/bfs.Rd +++ b/man/bfs.Rd @@ -62,7 +62,8 @@ vertices.} the search tree.} \item{callback}{If not \code{NULL}, then it must be callback function. This -is called whenever a vertex is visited. See details below.} +is called whenever a vertex is visited. The callback function should +return \code{FALSE} to continue the search or \code{TRUE} to stop it. See details below.} \item{extra}{Additional argument to supply to the callback function.} diff --git a/man/cliques.Rd b/man/cliques.Rd index 55f2f3b435..d404fdee5e 100644 --- a/man/cliques.Rd +++ b/man/cliques.Rd @@ -51,8 +51,8 @@ is_clique(graph, candidate, directed = FALSE) \item{callback}{Optional function to call for each clique found. If provided, the function should accept one argument: \code{clique} (integer vector of vertex -IDs in the clique, 1-based indexing). The function should return \code{TRUE} to -continue the search or \code{FALSE} to stop it. If \code{NULL} (the default), all +IDs in the clique, 1-based indexing). The function should return \code{FALSE} to +continue the search or \code{TRUE} to stop it. If \code{NULL} (the default), all cliques are collected and returned as a list. \strong{Important limitation:} Callback functions must NOT call any igraph diff --git a/man/graph.bfs.Rd b/man/graph.bfs.Rd index cb6d7d54b6..5564a9f98a 100644 --- a/man/graph.bfs.Rd +++ b/man/graph.bfs.Rd @@ -58,7 +58,8 @@ vertices.} the search tree.} \item{callback}{If not \code{NULL}, then it must be callback function. This -is called whenever a vertex is visited. See details below.} +is called whenever a vertex is visited. The callback function should +return \code{FALSE} to continue the search or \code{TRUE} to stop it. See details below.} \item{extra}{Additional argument to supply to the callback function.} diff --git a/man/isomorphisms.Rd b/man/isomorphisms.Rd index c91387201f..d10065f106 100644 --- a/man/isomorphisms.Rd +++ b/man/isomorphisms.Rd @@ -21,7 +21,7 @@ isomorphisms(graph1, graph2, method = "vf2", ..., callback = NULL) If provided, the function should accept two arguments: \code{map12} (integer vector mapping vertex IDs from graph1 to graph2, 1-based indexing) and \code{map21} (integer vector mapping vertex IDs from graph2 to graph1, 1-based indexing). -The function should return \code{TRUE} to continue the search or \code{FALSE} to stop it. +The function should return \code{FALSE} to continue the search or \code{TRUE} to stop it. If \code{NULL} (the default), all isomorphisms are collected and returned as a list. Only supported for \code{method = "vf2"}. diff --git a/man/motifs.Rd b/man/motifs.Rd index 6fca32bf26..ccbbe8ae6a 100644 --- a/man/motifs.Rd +++ b/man/motifs.Rd @@ -20,7 +20,7 @@ If \code{NULL}, the default, no cuts are made.} \item{callback}{Optional callback function to call for each motif found. The function should accept two arguments: \code{vids} (integer vector of vertex IDs in the motif) and \code{isoclass} (the isomorphism class of the motif). -The function should return \code{TRUE} to continue the search or \code{FALSE} to stop it. +The function should return \code{FALSE} to continue the search or \code{TRUE} to stop it. If \code{NULL} (the default), motif counts are returned as a numeric vector. \strong{Important limitation:} Callback functions must NOT call any igraph diff --git a/man/simple_cycles.Rd b/man/simple_cycles.Rd index 8fbf8d2b32..680840639d 100644 --- a/man/simple_cycles.Rd +++ b/man/simple_cycles.Rd @@ -29,8 +29,8 @@ and \code{all} ignores edge directions. Ignored in undirected graphs.} \item{callback}{Optional function to call for each cycle found. If provided, the function should accept two arguments: \code{vertices} (integer vector of vertex IDs in the cycle) and \code{edges} (integer vector of edge IDs -in the cycle). The function should return \code{TRUE} to continue -the search or \code{FALSE} to stop it. If \code{NULL} (the default), all cycles are +in the cycle). The function should return \code{FALSE} to continue +the search or \code{TRUE} to stop it. If \code{NULL} (the default), all cycles are collected and returned as a list. \strong{Important limitation:} Callback functions must NOT call any igraph diff --git a/man/subgraph_isomorphisms.Rd b/man/subgraph_isomorphisms.Rd index 319bf578f6..e0110693a1 100644 --- a/man/subgraph_isomorphisms.Rd +++ b/man/subgraph_isomorphisms.Rd @@ -31,7 +31,7 @@ mutual edges.} If provided, the function should accept two arguments: \code{map12} (integer vector mapping vertex IDs from pattern to target, 1-based indexing) and \code{map21} (integer vector mapping vertex IDs from target to pattern, 1-based indexing). -The function should return \code{TRUE} to continue the search or \code{FALSE} to stop it. +The function should return \code{FALSE} to continue the search or \code{TRUE} to stop it. If \code{NULL} (the default), all subisomorphisms are collected and returned as a list. Only supported for \code{method = "vf2"}. diff --git a/src/cpp11.cpp b/src/cpp11.cpp index d5ac141e44..1e0a248840 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -52,6 +52,7 @@ extern SEXP R_igraph_barabasi_game(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEX extern SEXP R_igraph_betweenness(SEXP, SEXP, SEXP, SEXP); extern SEXP R_igraph_betweenness_cutoff(SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP R_igraph_betweenness_subset(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); +extern SEXP R_igraph_bfs_closure(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP R_igraph_bfs_simple(SEXP, SEXP, SEXP); extern SEXP R_igraph_biadjacency(SEXP, SEXP, SEXP, SEXP); extern SEXP R_igraph_bibcoupling(SEXP, SEXP); @@ -137,6 +138,7 @@ extern SEXP R_igraph_delete_vertices(SEXP, SEXP); extern SEXP R_igraph_delete_vertices_idx(SEXP, SEXP); extern SEXP R_igraph_density(SEXP, SEXP); extern SEXP R_igraph_deterministic_optimal_imitation(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); +extern SEXP R_igraph_dfs_closure(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP R_igraph_diameter(SEXP, SEXP, SEXP); extern SEXP R_igraph_diameter_dijkstra(SEXP, SEXP, SEXP, SEXP); extern SEXP R_igraph_difference(SEXP, SEXP); @@ -657,6 +659,7 @@ static const R_CallMethodDef CallEntries[] = { {"R_igraph_betweenness", (DL_FUNC) &R_igraph_betweenness, 4}, {"R_igraph_betweenness_cutoff", (DL_FUNC) &R_igraph_betweenness_cutoff, 5}, {"R_igraph_betweenness_subset", (DL_FUNC) &R_igraph_betweenness_subset, 6}, + {"R_igraph_bfs_closure", (DL_FUNC) &R_igraph_bfs_closure, 7}, {"R_igraph_bfs_simple", (DL_FUNC) &R_igraph_bfs_simple, 3}, {"R_igraph_biadjacency", (DL_FUNC) &R_igraph_biadjacency, 4}, {"R_igraph_bibcoupling", (DL_FUNC) &R_igraph_bibcoupling, 2}, @@ -742,6 +745,7 @@ static const R_CallMethodDef CallEntries[] = { {"R_igraph_delete_vertices_idx", (DL_FUNC) &R_igraph_delete_vertices_idx, 2}, {"R_igraph_density", (DL_FUNC) &R_igraph_density, 2}, {"R_igraph_deterministic_optimal_imitation", (DL_FUNC) &R_igraph_deterministic_optimal_imitation, 6}, + {"R_igraph_dfs_closure", (DL_FUNC) &R_igraph_dfs_closure, 6}, {"R_igraph_diameter", (DL_FUNC) &R_igraph_diameter, 3}, {"R_igraph_diameter_dijkstra", (DL_FUNC) &R_igraph_diameter_dijkstra, 4}, {"R_igraph_difference", (DL_FUNC) &R_igraph_difference, 2}, diff --git a/src/rcallback.c b/src/rcallback.c index cbab37de64..bc0fe4369e 100644 --- a/src/rcallback.c +++ b/src/rcallback.c @@ -31,6 +31,12 @@ typedef struct { SEXP callback; } R_igraph_callback_data_t; +/* Structure to hold DFS callback data (both in and out callbacks) */ +typedef struct { + SEXP in_callback; + SEXP out_callback; +} R_igraph_dfs_callback_data_t; + /* Handler function for motifs callback - converts C types to R types */ igraph_error_t R_igraph_motifs_handler(const igraph_t *graph, igraph_vector_int_t *vids, @@ -62,12 +68,16 @@ igraph_error_t R_igraph_motifs_handler(const igraph_t *graph, igraph_error("Error in R callback function", __FILE__, __LINE__, IGRAPH_FAILURE); return IGRAPH_FAILURE; } + if (Rf_inherits(result, "interrupt")) { + UNPROTECT(4); + return IGRAPH_INTERRUPTED; + } cres = Rf_asLogical(result); UNPROTECT(4); - /* R callback returns TRUE to continue, FALSE to stop */ - return cres ? IGRAPH_SUCCESS : IGRAPH_STOP; + /* R callback returns TRUE to stop, FALSE to continue */ + return cres ? IGRAPH_STOP : IGRAPH_SUCCESS; } /* Closure function that wraps igraph_motifs_randesu_callback @@ -108,12 +118,16 @@ igraph_error_t R_igraph_clique_handler(const igraph_vector_int_t *clique, void * igraph_error("Error in R callback function", __FILE__, __LINE__, IGRAPH_FAILURE); return IGRAPH_FAILURE; } + if (Rf_inherits(result, "interrupt")) { + UNPROTECT(3); + return IGRAPH_INTERRUPTED; + } cres = Rf_asLogical(result); UNPROTECT(3); - /* R callback returns TRUE to continue, FALSE to stop */ - return cres ? IGRAPH_SUCCESS : IGRAPH_STOP; + /* R callback returns TRUE to stop, FALSE to continue */ + return cres ? IGRAPH_STOP : IGRAPH_SUCCESS; } /* Closure functions for clique callbacks */ @@ -176,12 +190,16 @@ igraph_error_t R_igraph_cycle_handler( igraph_error("Error in R callback function", __FILE__, __LINE__, IGRAPH_FAILURE); return IGRAPH_FAILURE; } + if (Rf_inherits(result, "interrupt")) { + UNPROTECT(4); + return IGRAPH_INTERRUPTED; + } cres = Rf_asLogical(result); UNPROTECT(4); - /* R callback returns TRUE to continue, FALSE to stop */ - return cres ? IGRAPH_SUCCESS : IGRAPH_STOP; + /* R callback returns TRUE to stop, FALSE to continue */ + return cres ? IGRAPH_STOP : IGRAPH_SUCCESS; } /* Closure function for simple_cycles_callback */ @@ -232,12 +250,16 @@ igraph_error_t R_igraph_isomorphism_handler( igraph_error("Error in R callback function", __FILE__, __LINE__, IGRAPH_FAILURE); return IGRAPH_FAILURE; } + if (Rf_inherits(result, "interrupt")) { + UNPROTECT(4); + return IGRAPH_INTERRUPTED; + } cres = Rf_asLogical(result); UNPROTECT(4); - /* R callback returns TRUE to continue, FALSE to stop */ - return cres ? IGRAPH_SUCCESS : IGRAPH_STOP; + /* R callback returns TRUE to stop, FALSE to continue */ + return cres ? IGRAPH_STOP : IGRAPH_SUCCESS; } /* Closure functions for isomorphism callbacks */ @@ -281,6 +303,217 @@ igraph_error_t igraph_get_subisomorphisms_vf2_callback_closure( NULL, NULL, &data); } +/* Handler function for BFS callbacks - converts C types to R types */ +igraph_error_t R_igraph_bfs_handler( + const igraph_t *graph, + igraph_integer_t vid, + igraph_integer_t pred, + igraph_integer_t succ, + igraph_integer_t rank, + igraph_integer_t dist, + void *extra) { + + R_igraph_callback_data_t *data = (R_igraph_callback_data_t *)extra; + SEXP callback = data->callback; + SEXP args, R_fcall, result, names; + igraph_bool_t cres; + + /* Create named integer vector with BFS information */ + PROTECT(args = NEW_INTEGER(5)); + PROTECT(names = NEW_CHARACTER(5)); + + SET_STRING_ELT(names, 0, Rf_mkChar("vid")); + SET_STRING_ELT(names, 1, Rf_mkChar("pred")); + SET_STRING_ELT(names, 2, Rf_mkChar("succ")); + SET_STRING_ELT(names, 3, Rf_mkChar("rank")); + SET_STRING_ELT(names, 4, Rf_mkChar("dist")); + INTEGER(args)[0] = vid + 1; /* R's 1-based indexing */ + INTEGER(args)[1] = pred + 1; + INTEGER(args)[2] = succ + 1; + INTEGER(args)[3] = rank + 1; + INTEGER(args)[4] = dist; + SET_NAMES(args, names); + + /* Call the R callback with the converted data */ + PROTECT(R_fcall = Rf_lang2(callback, args)); + PROTECT(result = Rf_eval(R_fcall, R_GlobalEnv)); + + /* Check if result is an error or interrupt condition */ + if (Rf_inherits(result, "error")) { + UNPROTECT(4); + igraph_error("Error in R callback function", __FILE__, __LINE__, IGRAPH_FAILURE); + return IGRAPH_FAILURE; + } + if (Rf_inherits(result, "interrupt")) { + UNPROTECT(4); + return IGRAPH_INTERRUPTED; + } + + /* Interpret result: TRUE = stop, FALSE = continue */ + cres = LOGICAL(AS_LOGICAL(result))[0]; + UNPROTECT(4); + + return cres ? IGRAPH_STOP : IGRAPH_SUCCESS; +} + +/* Closure function for BFS - connects R callback to C igraph_bfs */ +igraph_error_t igraph_bfs_closure( + const igraph_t *graph, + igraph_integer_t root, + const igraph_vector_int_t *roots, + igraph_neimode_t mode, + igraph_bool_t unreachable, + const igraph_vector_int_t *restricted, + igraph_vector_int_t *order, + igraph_vector_int_t *rank, + igraph_vector_int_t *parents, + igraph_vector_int_t *pred, + igraph_vector_int_t *succ, + igraph_vector_int_t *dist, + SEXP callback) { + + /* If callback is NULL, pass NULL to the C function */ + if (Rf_isNull(callback)) { + return igraph_bfs(graph, root, roots, mode, unreachable, restricted, + order, rank, parents, pred, succ, dist, NULL, NULL); + } + + /* Otherwise, use the handler */ + R_igraph_callback_data_t data = { .callback = callback }; + + return igraph_bfs(graph, root, roots, mode, unreachable, restricted, + order, rank, parents, pred, succ, dist, + R_igraph_bfs_handler, &data); +} + +/* Handler function for DFS in-callbacks */ +igraph_error_t R_igraph_dfs_handler_in( + const igraph_t *graph, + igraph_integer_t vid, + igraph_integer_t dist, + void *extra) { + + R_igraph_dfs_callback_data_t *data = (R_igraph_dfs_callback_data_t *)extra; + SEXP callback = data->in_callback; + SEXP args, R_fcall, result, names; + igraph_bool_t cres; + + /* If no in_callback, continue */ + if (Rf_isNull(callback)) { + return IGRAPH_SUCCESS; + } + + /* Create named integer vector with DFS information */ + PROTECT(args = NEW_INTEGER(2)); + PROTECT(names = NEW_CHARACTER(2)); + + SET_STRING_ELT(names, 0, Rf_mkChar("vid")); + SET_STRING_ELT(names, 1, Rf_mkChar("dist")); + INTEGER(args)[0] = vid + 1; /* R's 1-based indexing */ + INTEGER(args)[1] = dist; + SET_NAMES(args, names); + + /* Call the R callback */ + PROTECT(R_fcall = Rf_lang2(callback, args)); + PROTECT(result = Rf_eval(R_fcall, R_GlobalEnv)); + + /* Check if result is an error or interrupt condition */ + if (Rf_inherits(result, "error")) { + UNPROTECT(4); + igraph_error("Error in R callback function", __FILE__, __LINE__, IGRAPH_FAILURE); + return IGRAPH_FAILURE; + } + if (Rf_inherits(result, "interrupt")) { + UNPROTECT(4); + return IGRAPH_INTERRUPTED; + } + + /* Interpret result: TRUE = stop, FALSE = continue */ + cres = LOGICAL(AS_LOGICAL(result))[0]; + UNPROTECT(4); + + return cres ? IGRAPH_STOP : IGRAPH_SUCCESS; +} + +/* Handler function for DFS out-callbacks */ +igraph_error_t R_igraph_dfs_handler_out( + const igraph_t *graph, + igraph_integer_t vid, + igraph_integer_t dist, + void *extra) { + + R_igraph_dfs_callback_data_t *data = (R_igraph_dfs_callback_data_t *)extra; + SEXP callback = data->out_callback; + SEXP args, R_fcall, result, names; + igraph_bool_t cres; + + /* If no out_callback, continue */ + if (Rf_isNull(callback)) { + return IGRAPH_SUCCESS; + } + + /* Create named integer vector with DFS information */ + PROTECT(args = NEW_INTEGER(2)); + PROTECT(names = NEW_CHARACTER(2)); + + SET_STRING_ELT(names, 0, Rf_mkChar("vid")); + SET_STRING_ELT(names, 1, Rf_mkChar("dist")); + INTEGER(args)[0] = vid + 1; /* R's 1-based indexing */ + INTEGER(args)[1] = dist; + SET_NAMES(args, names); + + /* Call the R callback */ + PROTECT(R_fcall = Rf_lang2(callback, args)); + PROTECT(result = Rf_eval(R_fcall, R_GlobalEnv)); + + /* Check if result is an error or interrupt condition */ + if (Rf_inherits(result, "error")) { + UNPROTECT(4); + igraph_error("Error in R callback function", __FILE__, __LINE__, IGRAPH_FAILURE); + return IGRAPH_FAILURE; + } + if (Rf_inherits(result, "interrupt")) { + UNPROTECT(4); + return IGRAPH_INTERRUPTED; + } + + /* Interpret result: TRUE = stop, FALSE = continue */ + cres = LOGICAL(AS_LOGICAL(result))[0]; + UNPROTECT(4); + + return cres ? IGRAPH_STOP : IGRAPH_SUCCESS; +} + +/* Closure function for DFS - connects R callbacks to C igraph_dfs */ +igraph_error_t igraph_dfs_closure( + const igraph_t *graph, + igraph_integer_t root, + igraph_neimode_t mode, + igraph_bool_t unreachable, + igraph_vector_int_t *order, + igraph_vector_int_t *order_out, + igraph_vector_int_t *father, + igraph_vector_int_t *dist, + SEXP in_callback, + SEXP out_callback) { + + /* If both callbacks are NULL, pass NULL to the C function */ + if (Rf_isNull(in_callback) && Rf_isNull(out_callback)) { + return igraph_dfs(graph, root, mode, unreachable, order, order_out, + father, dist, NULL, NULL, NULL); + } + + /* Otherwise, use the handlers */ + R_igraph_dfs_callback_data_t data = { + .in_callback = in_callback, + .out_callback = out_callback + }; + + return igraph_dfs(graph, root, mode, unreachable, order, order_out, + father, dist, + R_igraph_dfs_handler_in, R_igraph_dfs_handler_out, &data); +} + /* Leading eigenvector community detection callback support */ /* Structure to hold ARPACK function pointer */ @@ -335,7 +568,7 @@ igraph_error_t R_igraph_levc_handler( PROTECT(s_evalue = NEW_NUMERIC(1)); REAL(s_evalue)[0] = eigenvalue; PROTECT(s_evector = Ry_igraph_vector_to_SEXP(eigenvector)); - + /* Create the ARPACK multiplier function accessible from R */ PROTECT(l1 = Rf_install("igraph.i.levc.arp")); PROTECT(l2 = R_MakeExternalPtr((void*)&cont, R_NilValue, R_NilValue)); @@ -387,8 +620,8 @@ igraph_error_t igraph_community_leading_eigenvector_callback_closure( } /* Otherwise, use the handler */ - R_igraph_levc_callback_data_t data = { - .callback = callback, + R_igraph_levc_callback_data_t data = { + .callback = callback, .extra = extra ? extra : R_NilValue, /* Convert NULL to R_NilValue */ .env = env ? env : R_GlobalEnv, /* Ensure env is never NULL */ .env_arp = env_arp ? env_arp : R_GlobalEnv /* Ensure env_arp is never NULL */ diff --git a/src/rinterface.c b/src/rinterface.c index 943281ca6d..d6c93c93b6 100644 --- a/src/rinterface.c +++ b/src/rinterface.c @@ -19037,6 +19037,179 @@ SEXP R_igraph_version(void) { return(r_result); } +/*-------------------------------------------/ +/ igraph_bfs_closure / +/-------------------------------------------*/ +SEXP R_igraph_bfs_closure(SEXP graph, SEXP root, SEXP roots, SEXP mode, SEXP unreachable, SEXP restricted, SEXP callback) { + /* Declarations */ + igraph_t c_graph; + igraph_integer_t c_root; + igraph_vector_int_t c_roots; + igraph_neimode_t c_mode; + igraph_bool_t c_unreachable; + igraph_vector_int_t c_restricted; + igraph_vector_int_t c_order; + igraph_vector_int_t c_rank; + igraph_vector_int_t c_parents; + igraph_vector_int_t c_pred; + igraph_vector_int_t c_succ; + igraph_vector_int_t c_dist; + + SEXP order; + SEXP rank; + SEXP parents; + SEXP pred; + SEXP succ; + SEXP dist; + + SEXP r_result, r_names; + /* Convert input */ + Rz_SEXP_to_igraph(graph, &c_graph); + c_root = (igraph_integer_t) REAL(root)[0]; + if (!Rf_isNull(roots)) { + Rz_SEXP_to_vector_int_copy(roots, &c_roots); + IGRAPH_FINALLY(igraph_vector_int_destroy, &c_roots); + } else { + IGRAPH_R_CHECK(igraph_vector_int_init(&c_roots, 0)); + IGRAPH_FINALLY(igraph_vector_int_destroy, &c_roots); + } + c_mode = (igraph_neimode_t) Rf_asInteger(mode); + IGRAPH_R_CHECK_BOOL(unreachable); + c_unreachable = LOGICAL(unreachable)[0]; + if (!Rf_isNull(restricted)) { + Rz_SEXP_to_vector_int_copy(restricted, &c_restricted); + IGRAPH_FINALLY(igraph_vector_int_destroy, &c_restricted); + } else { + IGRAPH_R_CHECK(igraph_vector_int_init(&c_restricted, 0)); + IGRAPH_FINALLY(igraph_vector_int_destroy, &c_restricted); + } + IGRAPH_R_CHECK(igraph_vector_int_init(&c_order, 0)); + IGRAPH_FINALLY(igraph_vector_int_destroy, &c_order); + IGRAPH_R_CHECK(igraph_vector_int_init(&c_rank, 0)); + IGRAPH_FINALLY(igraph_vector_int_destroy, &c_rank); + IGRAPH_R_CHECK(igraph_vector_int_init(&c_parents, 0)); + IGRAPH_FINALLY(igraph_vector_int_destroy, &c_parents); + IGRAPH_R_CHECK(igraph_vector_int_init(&c_pred, 0)); + IGRAPH_FINALLY(igraph_vector_int_destroy, &c_pred); + IGRAPH_R_CHECK(igraph_vector_int_init(&c_succ, 0)); + IGRAPH_FINALLY(igraph_vector_int_destroy, &c_succ); + IGRAPH_R_CHECK(igraph_vector_int_init(&c_dist, 0)); + IGRAPH_FINALLY(igraph_vector_int_destroy, &c_dist); + /* Call igraph */ + IGRAPH_R_CHECK(igraph_bfs_closure(&c_graph, c_root, (Rf_isNull(roots) ? 0 : &c_roots), c_mode, c_unreachable, (Rf_isNull(restricted) ? 0 : &c_restricted), &c_order, &c_rank, &c_parents, &c_pred, &c_succ, &c_dist, callback)); + + /* Convert output */ + PROTECT(r_result=NEW_LIST(6)); + PROTECT(r_names=NEW_CHARACTER(6)); + igraph_vector_int_destroy(&c_roots); + IGRAPH_FINALLY_CLEAN(1); + igraph_vector_int_destroy(&c_restricted); + IGRAPH_FINALLY_CLEAN(1); + PROTECT(order=Ry_igraph_vector_int_to_SEXPp1(&c_order)); + igraph_vector_int_destroy(&c_order); + IGRAPH_FINALLY_CLEAN(1); + PROTECT(rank=Ry_igraph_vector_int_to_SEXP(&c_rank)); + igraph_vector_int_destroy(&c_rank); + IGRAPH_FINALLY_CLEAN(1); + PROTECT(parents=Ry_igraph_vector_int_to_SEXP(&c_parents)); + igraph_vector_int_destroy(&c_parents); + IGRAPH_FINALLY_CLEAN(1); + PROTECT(pred=Ry_igraph_vector_int_to_SEXP(&c_pred)); + igraph_vector_int_destroy(&c_pred); + IGRAPH_FINALLY_CLEAN(1); + PROTECT(succ=Ry_igraph_vector_int_to_SEXP(&c_succ)); + igraph_vector_int_destroy(&c_succ); + IGRAPH_FINALLY_CLEAN(1); + PROTECT(dist=Ry_igraph_vector_int_to_SEXP(&c_dist)); + igraph_vector_int_destroy(&c_dist); + IGRAPH_FINALLY_CLEAN(1); + SET_VECTOR_ELT(r_result, 0, order); + SET_VECTOR_ELT(r_result, 1, rank); + SET_VECTOR_ELT(r_result, 2, parents); + SET_VECTOR_ELT(r_result, 3, pred); + SET_VECTOR_ELT(r_result, 4, succ); + SET_VECTOR_ELT(r_result, 5, dist); + SET_STRING_ELT(r_names, 0, Rf_mkChar("order")); + SET_STRING_ELT(r_names, 1, Rf_mkChar("rank")); + SET_STRING_ELT(r_names, 2, Rf_mkChar("parents")); + SET_STRING_ELT(r_names, 3, Rf_mkChar("pred")); + SET_STRING_ELT(r_names, 4, Rf_mkChar("succ")); + SET_STRING_ELT(r_names, 5, Rf_mkChar("dist")); + SET_NAMES(r_result, r_names); + UNPROTECT(7); + + UNPROTECT(1); + return(r_result); +} + +/*-------------------------------------------/ +/ igraph_dfs_closure / +/-------------------------------------------*/ +SEXP R_igraph_dfs_closure(SEXP graph, SEXP root, SEXP mode, SEXP unreachable, SEXP in_callback, SEXP out_callback) { + /* Declarations */ + igraph_t c_graph; + igraph_integer_t c_root; + igraph_neimode_t c_mode; + igraph_bool_t c_unreachable; + igraph_vector_int_t c_order; + igraph_vector_int_t c_order_out; + igraph_vector_int_t c_father; + igraph_vector_int_t c_dist; + + + SEXP order; + SEXP order_out; + SEXP father; + SEXP dist; + + SEXP r_result, r_names; + /* Convert input */ + Rz_SEXP_to_igraph(graph, &c_graph); + c_root = (igraph_integer_t) REAL(root)[0]; + c_mode = (igraph_neimode_t) Rf_asInteger(mode); + IGRAPH_R_CHECK_BOOL(unreachable); + c_unreachable = LOGICAL(unreachable)[0]; + IGRAPH_R_CHECK(igraph_vector_int_init(&c_order, 0)); + IGRAPH_FINALLY(igraph_vector_int_destroy, &c_order); + IGRAPH_R_CHECK(igraph_vector_int_init(&c_order_out, 0)); + IGRAPH_FINALLY(igraph_vector_int_destroy, &c_order_out); + IGRAPH_R_CHECK(igraph_vector_int_init(&c_father, 0)); + IGRAPH_FINALLY(igraph_vector_int_destroy, &c_father); + IGRAPH_R_CHECK(igraph_vector_int_init(&c_dist, 0)); + IGRAPH_FINALLY(igraph_vector_int_destroy, &c_dist); + /* Call igraph */ + IGRAPH_R_CHECK(igraph_dfs_closure(&c_graph, c_root, c_mode, c_unreachable, &c_order, &c_order_out, &c_father, &c_dist, in_callback, out_callback)); + + /* Convert output */ + PROTECT(r_result=NEW_LIST(4)); + PROTECT(r_names=NEW_CHARACTER(4)); + PROTECT(order=Ry_igraph_vector_int_to_SEXPp1(&c_order)); + igraph_vector_int_destroy(&c_order); + IGRAPH_FINALLY_CLEAN(1); + PROTECT(order_out=Ry_igraph_vector_int_to_SEXPp1(&c_order_out)); + igraph_vector_int_destroy(&c_order_out); + IGRAPH_FINALLY_CLEAN(1); + PROTECT(father=Ry_igraph_vector_int_to_SEXP(&c_father)); + igraph_vector_int_destroy(&c_father); + IGRAPH_FINALLY_CLEAN(1); + PROTECT(dist=Ry_igraph_vector_int_to_SEXP(&c_dist)); + igraph_vector_int_destroy(&c_dist); + IGRAPH_FINALLY_CLEAN(1); + SET_VECTOR_ELT(r_result, 0, order); + SET_VECTOR_ELT(r_result, 1, order_out); + SET_VECTOR_ELT(r_result, 2, father); + SET_VECTOR_ELT(r_result, 3, dist); + SET_STRING_ELT(r_names, 0, Rf_mkChar("order")); + SET_STRING_ELT(r_names, 1, Rf_mkChar("order_out")); + SET_STRING_ELT(r_names, 2, Rf_mkChar("father")); + SET_STRING_ELT(r_names, 3, Rf_mkChar("dist")); + SET_NAMES(r_result, r_names); + UNPROTECT(5); + + UNPROTECT(1); + return(r_result); +} + /*-------------------------------------------/ / igraph_cliques_callback_closure / /-------------------------------------------*/ diff --git a/src/rinterface.h b/src/rinterface.h index 7c04022dd9..c1a18271c7 100644 --- a/src/rinterface.h +++ b/src/rinterface.h @@ -235,6 +235,56 @@ igraph_error_t igraph_get_subisomorphisms_vf2_callback_closure( const igraph_vector_int_t *edge_color2, SEXP callback); +/* BFS */ +igraph_error_t R_igraph_bfs_handler( + const igraph_t *graph, + igraph_integer_t vid, + igraph_integer_t pred, + igraph_integer_t succ, + igraph_integer_t rank, + igraph_integer_t dist, + void *extra); + +igraph_error_t igraph_bfs_closure( + const igraph_t *graph, + igraph_integer_t root, + const igraph_vector_int_t *roots, + igraph_neimode_t mode, + igraph_bool_t unreachable, + const igraph_vector_int_t *restricted, + igraph_vector_int_t *order, + igraph_vector_int_t *rank, + igraph_vector_int_t *parents, + igraph_vector_int_t *pred, + igraph_vector_int_t *succ, + igraph_vector_int_t *dist, + SEXP callback); + +/* DFS */ +igraph_error_t R_igraph_dfs_handler_in( + const igraph_t *graph, + igraph_integer_t vid, + igraph_integer_t dist, + void *extra); + +igraph_error_t R_igraph_dfs_handler_out( + const igraph_t *graph, + igraph_integer_t vid, + igraph_integer_t dist, + void *extra); + +igraph_error_t igraph_dfs_closure( + const igraph_t *graph, + igraph_integer_t root, + igraph_neimode_t mode, + igraph_bool_t unreachable, + igraph_vector_int_t *order, + igraph_vector_int_t *order_out, + igraph_vector_int_t *father, + igraph_vector_int_t *dist, + SEXP in_callback, + SEXP out_callback); + /* Leading eigenvector community detection */ SEXP R_igraph_levc_arpack_multiplier(SEXP extP, SEXP extE, SEXP pv); diff --git a/tests/testthat/_snaps/aaa-auto.md b/tests/testthat/_snaps/aaa-auto.md index 754b76eac8..a34e62e8c4 100644 --- a/tests/testthat/_snaps/aaa-auto.md +++ b/tests/testthat/_snaps/aaa-auto.md @@ -4516,10 +4516,10 @@ site_percolation_impl(graph = g) Output $giant_size - numeric(0) + [1] 1 2 3 $edge_count - numeric(0) + [1] 0 1 2 # site_percolation_impl errors @@ -11355,6 +11355,115 @@ [1] 3 5 +# bfs_closure_impl works + + Code + cat("BFS result:\n") + Output + BFS result: + Code + print(result) + Output + $order + + 10/10 vertices: + [1] 1 2 10 3 9 4 8 5 7 6 + + $rank + [1] 0 1 3 5 7 9 8 6 4 2 + + $parents + [1] -1 0 1 2 3 4 7 8 9 0 + + $pred + [1] -1 0 9 8 7 6 4 3 2 1 + + $succ + [1] 1 9 8 7 6 -1 5 4 3 2 + + $dist + [1] 0 1 2 3 4 5 4 3 2 1 + + Code + cat("\nNumber of BFS visits:", length(bfs_visits), "\n") + Output + + Number of BFS visits: 10 + Code + if (length(bfs_visits) > 0) { + cat("First visit:\n") + print(bfs_visits[[1]]) + } + Output + First visit: + vid pred succ rank dist + 1 0 2 1 0 + +--- + + Code + bfs_closure_impl(graph = g, root = 1, mode = "out", unreachable = TRUE, + restricted = NULL, callback = function(args) { + NA + }) + Condition + Error in `bfs_closure_impl()`: + ! Error in R callback function. Failed + Source: : + +--- + + Code + bfs_closure_impl(graph = g, root = 1, mode = "out", unreachable = TRUE, + restricted = NULL, callback = function(args) { + NA + }) + Condition + Error in `bfs_closure_impl()`: + ! Error in R callback function. Failed + Source: : + +# dfs_closure_impl works + + Code + cat("DFS result:\n") + Output + DFS result: + Code + print(result) + Output + $order + + 10/10 vertices: + [1] 1 2 3 4 5 6 7 8 9 10 + + $order_out + + 10/10 vertices: + [1] 10 9 8 7 6 5 4 3 2 1 + + $father + [1] -1 0 1 2 3 4 5 6 7 8 + + $dist + [1] 0 1 2 3 4 5 6 7 8 9 + + Code + cat("\nNumber of DFS IN visits:", length(dfs_in_visits), "\n") + Output + + Number of DFS IN visits: 10 + Code + cat("Number of DFS OUT visits:", length(dfs_out_visits), "\n") + Output + Number of DFS OUT visits: 10 + Code + if (length(dfs_in_visits) > 0) { + cat("First IN visit:\n") + print(dfs_in_visits[[1]]) + } + Output + First IN visit: + vid dist + 1 0 + # motifs_randesu_callback_closure_impl basic Code diff --git a/tests/testthat/_snaps/motifs.md b/tests/testthat/_snaps/motifs.md index caf0f48c98..8b6c1a2df2 100644 --- a/tests/testthat/_snaps/motifs.md +++ b/tests/testthat/_snaps/motifs.md @@ -5,29 +5,22 @@ Output Number of motifs found: 12 Code - cat("Sample motif 1:\n") + motif_data[1:2] Output - Sample motif 1: - Code - print(motif_data[[1]]) - Output - $vids + [[1]] + [[1]]$vids [1] 1 4 2 - $isoclass + [[1]]$isoclass [1] 3 - Code - if (length(motif_data) > 1) { - cat("Sample motif 2:\n") - print(motif_data[[2]]) - } - Output - Sample motif 2: - $vids + + [[2]] + [[2]]$vids [1] 1 4 3 - $isoclass + [[2]]$isoclass [1] 4 + diff --git a/tests/testthat/test-aaa-auto.R b/tests/testthat/test-aaa-auto.R index 466ef44604..02ec2db379 100644 --- a/tests/testthat/test-aaa-auto.R +++ b/tests/testthat/test-aaa-auto.R @@ -11210,6 +11210,122 @@ test_that("independent_vertex_sets_impl basic", { # Callback functions +# bfs_closure_impl + +test_that("bfs_closure_impl works", { + withr::local_seed(20250125) + local_igraph_options(print.id = FALSE) + + g <- make_ring(10) + + # Collect BFS visit data + bfs_visits <- list() + result <- bfs_closure_impl( + graph = g, + root = 1, + mode = "out", + unreachable = TRUE, + restricted = NULL, + callback = function(args) { + bfs_visits[[length(bfs_visits) + 1]] <<- args + FALSE # Continue + } + ) + + expect_snapshot({ + cat("BFS result:\n") + print(result) + cat("\nNumber of BFS visits:", length(bfs_visits), "\n") + if (length(bfs_visits) > 0) { + cat("First visit:\n") + print(bfs_visits[[1]]) + } + }) + + # Test error handling + expect_snapshot_igraph_error({ + bfs_closure_impl( + graph = g, + root = 1, + mode = "out", + unreachable = TRUE, + restricted = NULL, + callback = function(args) { + NA + } + ) + }) + + expect_snapshot_igraph_error({ + bfs_closure_impl( + graph = g, + root = 1, + mode = "out", + unreachable = TRUE, + restricted = NULL, + callback = function(args) { + NA + } + ) + }) + + calls <- 0 + bfs_closure_impl( + graph = g, + root = 1, + mode = "out", + unreachable = TRUE, + restricted = NULL, + callback = function(args) { + calls <<- calls + 1 + calls > 3 # Stop after 3 calls + } + ) + expect_equal(calls, 4) # Called 4 times: 3 continue (FALSE), 1 stop (TRUE) +}) + +# dfs_closure_impl + +test_that("dfs_closure_impl works", { + withr::local_seed(20250125) + local_igraph_options(print.id = FALSE) + + g <- make_ring(10) + + # Collect DFS visit data + dfs_in_visits <- list() + dfs_out_visits <- list() + result <- dfs_closure_impl( + graph = g, + root = 1, + mode = "out", + unreachable = TRUE, + in_callback = function(args) { + dfs_in_visits[[length(dfs_in_visits) + 1]] <<- args + FALSE # Continue + }, + out_callback = function(args) { + dfs_out_visits[[length(dfs_out_visits) + 1]] <<- args + FALSE # Continue + } + ) + + expect_snapshot({ + cat("DFS result:\n") + print(result) + cat("\nNumber of DFS IN visits:", length(dfs_in_visits), "\n") + cat("Number of DFS OUT visits:", length(dfs_out_visits), "\n") + if (length(dfs_in_visits) > 0) { + cat("First IN visit:\n") + print(dfs_in_visits[[1]]) + } + }) + + # Structured tests + expect_equal(length(dfs_in_visits), 10) + expect_equal(length(dfs_out_visits), 10) +}) + # motifs_randesu_callback_closure_impl test_that("motifs_randesu_callback_closure_impl basic", { @@ -11229,7 +11345,7 @@ test_that("motifs_randesu_callback_closure_impl basic", { vids = vids, isoclass = isoclass ) - TRUE + FALSE # Continue } ) @@ -11283,7 +11399,7 @@ test_that("cliques_callback_closure_impl basic", { max_size = 4, callback = function(clique) { clique_data[[length(clique_data) + 1]] <<- clique - TRUE + FALSE # Continue } ) @@ -11337,9 +11453,9 @@ test_that("maximal_cliques_callback_closure_impl basic", { callback = function(clique) { clique_data[[length(clique_data) + 1]] <<- clique if (length(clique_data) >= 3) { - return(FALSE) - } # Stop after 3 - TRUE + return(TRUE) # Stop after 3 + } + FALSE # Continue } ) @@ -11396,7 +11512,7 @@ test_that("simple_cycles_callback_closure_impl basic", { vertices = vertices, edges = edges ) - TRUE + FALSE # Continue } ) @@ -11458,9 +11574,9 @@ test_that("get_isomorphisms_vf2_callback_closure_impl basic", { map21 = map21 ) if (length(iso_data) >= 2) { - return(FALSE) - } # Stop after 2 - TRUE + return(TRUE) # Stop after 2 + } + FALSE # Continue } ) @@ -11526,9 +11642,9 @@ test_that("get_subisomorphisms_vf2_callback_closure_impl basic", { map21 = map21 ) if (length(subiso_data) >= 2) { - return(FALSE) - } # Stop after 2 - TRUE + return(TRUE) # Stop after 2 + } + FALSE # Continue } ) diff --git a/tests/testthat/test-cliques.R b/tests/testthat/test-cliques.R index 989df28699..ef3fc43ca0 100644 --- a/tests/testthat/test-cliques.R +++ b/tests/testthat/test-cliques.R @@ -372,9 +372,9 @@ test_that("cliques_callback can stop early", { cliques(g, min = 3, callback = function(clique) { count <<- count + 1 if (count >= 5) { - FALSE # stop after 5 cliques + TRUE # stop after 5 cliques } else { - TRUE # continue + FALSE # continue } }) @@ -435,9 +435,9 @@ test_that("max_cliques can stop early with callback", { max_cliques(g, callback = function(clique) { count <<- count + 1 if (count >= 3) { - FALSE # stop after 3 cliques + TRUE # stop after 3 cliques } else { - TRUE # continue + FALSE # continue } }) diff --git a/tests/testthat/test-community.R b/tests/testthat/test-community.R index 1d5880863d..a5ba5644e7 100644 --- a/tests/testthat/test-community.R +++ b/tests/testthat/test-community.R @@ -229,7 +229,7 @@ test_that("cluster_leading_eigen works", { ev$vectors <- -ev$vectors } expect_equal(ev$vectors[, 1], vector) - 0 + FALSE # Continue } karate <- make_graph("Zachary") @@ -278,7 +278,7 @@ test_that("cluster_leading_eigen works", { BG <- B - diag(rowSums(B)) expect_equal(M, BG) - 0 + FALSE # Continue } A <- as_adjacency_matrix(karate, sparse = FALSE) @@ -286,6 +286,7 @@ test_that("cluster_leading_eigen works", { deg <- degree(karate) karate_lc2 <- cluster_leading_eigen(karate, callback = mod_mat_caller) }) + test_that("cluster_leading_eigen is deterministic", { ## Stress-test. We skip this on R 3.4 and 3.5 because it seems like ## the results are not entirely deterministic there. diff --git a/tests/testthat/test-cycles.R b/tests/testthat/test-cycles.R index c3b309e38d..99076866e4 100644 --- a/tests/testthat/test-cycles.R +++ b/tests/testthat/test-cycles.R @@ -75,9 +75,9 @@ test_that("simple_cycles_callback can stop early", { simple_cycles(g, callback = function(vertices, edges) { count <<- count + 1 if (count >= 2) { - FALSE # stop after 2 cycles + TRUE # stop after 2 cycles } else { - TRUE # continue + FALSE # continue } }) diff --git a/tests/testthat/test-motifs.R b/tests/testthat/test-motifs.R index a868460a39..1cacc02fab 100644 --- a/tests/testthat/test-motifs.R +++ b/tests/testthat/test-motifs.R @@ -190,7 +190,7 @@ test_that("motifs with callback works", { motifs(g, 3, callback = function(vids, isoclass) { count <<- count + 1 isoclasses <<- c(isoclasses, isoclass) - TRUE # continue search + FALSE # continue search }) expect_true(count > 0) @@ -209,9 +209,9 @@ test_that("motifs with callback can stop early", { motifs(g, 3, callback = function(vids, isoclass) { count <<- count + 1 if (count >= 3) { - FALSE # stop after 3 motifs + TRUE # stop after 3 motifs } else { - TRUE # continue + FALSE # continue } }) @@ -230,7 +230,7 @@ test_that("motifs with callback receives correct arguments", { expect_equal(length(vids), 3) expect_true(is.integer(isoclass)) expect_equal(length(isoclass), 1) - FALSE # stop after first motif + TRUE # stop after first motif }) }) @@ -260,17 +260,12 @@ test_that("motifs with callback output matches expected", { vids = vids, isoclass = isoclass ) - TRUE + FALSE # Continue }) # Snapshot test for motif structure expect_snapshot({ cat("Number of motifs found:", length(motif_data), "\n") - cat("Sample motif 1:\n") - print(motif_data[[1]]) - if (length(motif_data) > 1) { - cat("Sample motif 2:\n") - print(motif_data[[2]]) - } + motif_data[1:2] }) }) diff --git a/tests/testthat/test-topology.R b/tests/testthat/test-topology.R index aecd1beea0..78ab577b3c 100644 --- a/tests/testthat/test-topology.R +++ b/tests/testthat/test-topology.R @@ -463,9 +463,9 @@ test_that("isomorphisms can stop early", { isomorphisms(g1, g2, method = "vf2", callback = function(map12, map21) { count <<- count + 1 if (count >= 3) { - FALSE # stop after 3 isomorphisms + TRUE # stop after 3 isomorphisms } else { - TRUE # continue + FALSE # continue } }) @@ -546,9 +546,9 @@ test_that("subisomorphisms works with callback can stop early", { callback = function(map12, map21) { count <<- count + 1 if (count >= 3) { - FALSE # stop after 3 subisomorphisms + TRUE # stop after 3 subisomorphisms } else { - TRUE # continue + FALSE # continue } } ) diff --git a/tools/AGENTS.md b/tools/AGENTS.md index b10a140fa3..74c6899b14 100644 --- a/tools/AGENTS.md +++ b/tools/AGENTS.md @@ -53,17 +53,21 @@ igraph_error_t R_igraph_clique_handler(const igraph_vector_int_t *clique, void * /* Call the R function: callback(clique) */ PROTECT(R_fcall = Rf_lang2(callback, clique_r)); PROTECT(result = Rf_eval(R_fcall, R_GlobalEnv)); - + /* Check if result is an error condition (from tryCatch) */ if (Rf_inherits(result, "error")) { UNPROTECT(3); igraph_error("Error in R callback function", __FILE__, __LINE__, IGRAPH_FAILURE); return IGRAPH_FAILURE; } - + if (Rf_inherits(result, "interrupt")) { + UNPROTECT(3); + return IGRAPH_INTERRUPTED; + } + cres = Rf_asLogical(result); UNPROTECT(3); - + /* R callback returns TRUE to continue, FALSE to stop */ return cres ? IGRAPH_SUCCESS : IGRAPH_STOP; } @@ -86,9 +90,9 @@ igraph_error_t igraph_cliques_callback_closure( igraph_integer_t min_size, igraph_integer_t max_size, SEXP callback) { - + R_igraph_callback_data_t data = { .callback = callback }; - + return igraph_cliques_callback( graph, min_size, max_size, R_igraph_clique_handler, &data); @@ -191,7 +195,7 @@ In the appropriate R file (e.g., `R/cliques.R`), create a user-facing wrapper. E cliques_callback <- function(graph, ..., min = NULL, max = NULL, callback = NULL) { ensure_igraph(graph) check_dots_empty() - + min <- min %||% 0 max <- max %||% 0 @@ -212,7 +216,7 @@ cliques_callback <- function(graph, ..., min = NULL, max = NULL, callback = NULL - **Use `...` with `check_dots_empty()` to separate mandatory and optional arguments** - Document callback signature clearly - Include comprehensive examples -- Use `%||%` operator for NULL defaults +- Use `%||%` operator for NULL defaults - Call the autogenerated `*_closure_impl()` function - Return `invisible(NULL)` for consistency @@ -226,9 +230,9 @@ Add tests in two locations: test_that("cliques_callback_closure_impl basic", { withr::local_seed(20250909) local_igraph_options(print.id = FALSE) - + g <- make_full_graph(4) - + # Collect clique information for snapshot clique_data <- list() result <- cliques_callback_closure_impl( @@ -240,7 +244,7 @@ test_that("cliques_callback_closure_impl basic", { TRUE } ) - + expect_snapshot({ cat("Result:\n") print(result) @@ -248,7 +252,7 @@ test_that("cliques_callback_closure_impl basic", { cat("First clique:\n") print(clique_data[[1]]) }) - + # Structured tests expect_null(result) expect_true(length(clique_data) > 0) @@ -260,9 +264,9 @@ test_that("cliques_callback_closure_impl basic", { test_that("cliques_callback_closure_impl errors", { withr::local_seed(20250909) local_igraph_options(print.id = FALSE) - + g <- make_full_graph(4) - + expect_snapshot_igraph_error( cliques_callback_closure_impl( graph = g, @@ -280,13 +284,13 @@ test_that("cliques_callback_closure_impl errors", { test_that("cliques_callback works", { withr::local_seed(123) g <- sample_gnp(20, 0.3) - + count <- 0 cliques(g, min = 3, max = 4, callback = function(clique) { count <<- count + 1 TRUE }) - + expect_true(count > 0) }) diff --git a/tools/stimulus/functions-R.yaml b/tools/stimulus/functions-R.yaml index 018d397c6f..820337022b 100644 --- a/tools/stimulus/functions-R.yaml +++ b/tools/stimulus/functions-R.yaml @@ -448,6 +448,17 @@ igraph_bfs: # Has callback parameter (BFS_FUNC) IGNORE: RR, RC, RInit +igraph_bfs_closure: + PARAMS: |- + GRAPH graph, VERTEX root, OPTIONAL VERTEX_INDICES roots, + NEIMODE mode=OUT, BOOLEAN unreachable, + OPTIONAL VERTEX_INDICES restricted, + OUT VERTEX_INDICES order, OUT VECTOR_INT rank, + OUT VECTOR_INT parents, + OUT VECTOR_INT pred, OUT VECTOR_INT succ, + OUT VECTOR_INT dist, CLOSURE callback + DEPS: root ON graph, roots ON graph, restricted ON graph, order ON graph + igraph_bfs_simple: DEPS: root ON graph, order ON graph @@ -455,6 +466,14 @@ igraph_dfs: # Has callback parameter (DFS_FUNC) IGNORE: RR, RC, RInit +igraph_dfs_closure: + PARAMS: |- + GRAPH graph, VERTEX root, NEIMODE mode=OUT, BOOLEAN unreachable, + OUT VERTEX_INDICES order, OUT VERTEX_INDICES order_out, + OUT VECTOR_INT father, OUT VECTOR_INT dist, + CLOSURE in_callback, CLOSURE out_callback + DEPS: root ON graph, order ON graph, order_out ON graph + ####################################### # Bipartite graphs ####################################### diff --git a/tools/stimulus/types-RR.yaml b/tools/stimulus/types-RR.yaml index 73ff47ae80..8f523c8f39 100644 --- a/tools/stimulus/types-RR.yaml +++ b/tools/stimulus/types-RR.yaml @@ -253,10 +253,12 @@ VERTEX_SELECTOR: } VERTEX_INDICES: - CALL: '%I% - 1' + CALL: '%I%' DEFAULT: - ALL: V(%I1%) - INCONV: '%I% <- as_igraph_vs(%I1%, %I%)' + ALL: V(%I1%) - 1 + INCONV: |- + %I% <- as_igraph_vs(%I1%, %I%) + %I% <- %I% - 1 OUTCONV: OUT: |- if (igraph_opt("return.vs.es")) { @@ -266,10 +268,12 @@ VERTEX_INDICES: # Temporary, for https://github.com/igraph/rigraph/pull/1630 # We should call the `_PV` versions for all types in the future. VERTEX_INDICES_PV: - CALL: '%I% - 1' + CALL: '%I%' DEFAULT: - ALL: V(%I1%) - INCONV: '%I% <- as_igraph_vs(%I1%, %I%)' + ALL: V(%I1%) - 1 + INCONV: |- + %I% <- as_igraph_vs(%I1%, %I%) + %I% <- %I% - 1 OUTCONV: OUT: |- if (igraph_opt("return.vs.es")) { @@ -412,8 +416,16 @@ CLOSURE: } %I%_wrapped <- function(...) { tryCatch( - %I%(...), - error = function(e) e + { + out <- %I%(...) + if (is.logical(out) && length(out) == 1 && !is.na(out)) { + out + } else { + rlang::error_cnd(message = "Callback returned a value different from TRUE or FALSE") + } + }, + error = function(e) e, + interrupt = function(e) e ) } } else {