From 68c8ba1964c2006807f3d6e4237c7a6a32c521da Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 08:49:32 +0200 Subject: [PATCH 01/59] added config --- .Rbuildignore | 2 ++ .gitignore | 1 - .vscode/extensions.json | 5 +++++ .vscode/settings.json | 6 ++++++ air.toml | 8 ++++++++ 5 files changed, 21 insertions(+), 1 deletion(-) create mode 100644 .vscode/extensions.json create mode 100644 .vscode/settings.json create mode 100644 air.toml diff --git a/.Rbuildignore b/.Rbuildignore index ec71d230ba6..0d063e73768 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -61,3 +61,5 @@ ^man/dot-extract_constructor_and_modifiers\.Rd$ ^man/dot-apply_modifiers\.Rd$ ^man/handle_vertex_type_arg\.Rd$ +^[\.]?air\.toml$ +^\.vscode$ diff --git a/.gitignore b/.gitignore index d8995fc49bf..0bd6b7ec103 100644 --- a/.gitignore +++ b/.gitignore @@ -9,7 +9,6 @@ /version_number igraph.Rcheck/ .venv/ -.vscode/ .Rproj.user /configure~ /src/build/ diff --git a/.vscode/extensions.json b/.vscode/extensions.json new file mode 100644 index 00000000000..344f76eba38 --- /dev/null +++ b/.vscode/extensions.json @@ -0,0 +1,5 @@ +{ + "recommendations": [ + "Posit.air-vscode" + ] +} diff --git a/.vscode/settings.json b/.vscode/settings.json new file mode 100644 index 00000000000..f2d0b79d67d --- /dev/null +++ b/.vscode/settings.json @@ -0,0 +1,6 @@ +{ + "[r]": { + "editor.formatOnSave": true, + "editor.defaultFormatter": "Posit.air-vscode" + } +} diff --git a/air.toml b/air.toml new file mode 100644 index 00000000000..489b4b12894 --- /dev/null +++ b/air.toml @@ -0,0 +1,8 @@ +[format] +line-width = 80 +indent-width = 2 +indent-style = "space" +line-ending = "auto" +persistent-line-breaks = true +default-exclude = TRUE +skip = ["tribble", "graph_from_literal","matrix","c"] \ No newline at end of file From 2107e74b148bb4c50461ccbab3f40c13d7c184e0 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 06:57:41 +0000 Subject: [PATCH 02/59] chore: Auto-update from GitHub Actions Run: https://github.com/igraph/rigraph/actions/runs/15552587806 --- .Rbuildignore | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.Rbuildignore b/.Rbuildignore index 0d063e73768..1754f054514 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -56,10 +56,10 @@ ^vendor-one\.sh$ ^patch$ ^src/deps\.mk$ +^[\.]?air\.toml$ +^\.vscode$ ^man/dot-igraph.progress\.Rd$ ^man/dot-igraph.status\.Rd$ ^man/dot-extract_constructor_and_modifiers\.Rd$ ^man/dot-apply_modifiers\.Rd$ ^man/handle_vertex_type_arg\.Rd$ -^[\.]?air\.toml$ -^\.vscode$ From 203df48e55f16c325000a186113ef408df092dbd Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 09:42:07 +0200 Subject: [PATCH 03/59] first batch of reformatting --- R/adjacency.R | 110 +++++++--- R/assortativity.R | 56 +++-- R/basic.R | 5 +- R/bipartite.R | 67 ++++-- R/centrality.R | 505 ++++++++++++++++++++++++++++++++++++--------- R/centralization.R | 171 +++++++++++---- 6 files changed, 724 insertions(+), 190 deletions(-) diff --git a/R/adjacency.R b/R/adjacency.R index 26949095c7b..448ea8fe50a 100644 --- a/R/adjacency.R +++ b/R/adjacency.R @@ -8,9 +8,28 @@ #' @inheritParams graph_from_adjacency_matrix #' @keywords internal #' @export -graph.adjacency <- function(adjmatrix, mode = c("directed", "undirected", "max", "min", "upper", "lower", "plus"), weighted = NULL, diag = TRUE, add.colnames = NULL, add.rownames = NA) { # nocov start - lifecycle::deprecate_soft("2.0.0", "graph.adjacency()", "graph_from_adjacency_matrix()") - graph_from_adjacency_matrix(adjmatrix = adjmatrix, mode = mode, weighted = weighted, diag = diag, add.colnames = add.colnames, add.rownames = add.rownames) +graph.adjacency <- function( + adjmatrix, + mode = c("directed", "undirected", "max", "min", "upper", "lower", "plus"), + weighted = NULL, + diag = TRUE, + add.colnames = NULL, + add.rownames = NA +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "graph.adjacency()", + "graph_from_adjacency_matrix()" + ) + graph_from_adjacency_matrix( + adjmatrix = adjmatrix, + mode = mode, + weighted = weighted, + diag = diag, + add.colnames = add.colnames, + add.rownames = add.rownames + ) } # nocov end ## ---------------------------------------------------------------- @@ -254,13 +273,22 @@ graph.adjacency <- function(adjmatrix, mode = c("directed", "undirected", "max", #' summary(g10) #' #' @export -graph_from_adjacency_matrix <- function(adjmatrix, - mode = c( - "directed", "undirected", "max", - "min", "upper", "lower", "plus" - ), - weighted = NULL, diag = TRUE, - add.colnames = NULL, add.rownames = NA) { +graph_from_adjacency_matrix <- function( + adjmatrix, + mode = c( + "directed", + "undirected", + "max", + "min", + "upper", + "lower", + "plus" + ), + weighted = NULL, + diag = TRUE, + add.colnames = NULL, + add.rownames = NA +) { ensure_no_na(adjmatrix, "adjacency matrix") mode <- igraph.match.arg(mode) @@ -284,9 +312,19 @@ graph_from_adjacency_matrix <- function(adjmatrix, } if (inherits(adjmatrix, "Matrix")) { - res <- graph.adjacency.sparse(adjmatrix, mode = mode, weighted = weighted, diag = diag) + res <- graph.adjacency.sparse( + adjmatrix, + mode = mode, + weighted = weighted, + diag = diag + ) } else { - res <- graph.adjacency.dense(adjmatrix, mode = mode, weighted = weighted, diag = diag) + res <- graph.adjacency.dense( + adjmatrix, + mode = mode, + weighted = weighted, + diag = diag + ) } ## Add columns and row names as attributes @@ -316,8 +354,9 @@ graph_from_adjacency_matrix <- function(adjmatrix, } } - if (!is.na(add.rownames) && !is.na(add.colnames) && - add.rownames == add.colnames) { + if ( + !is.na(add.rownames) && !is.na(add.colnames) && add.rownames == add.colnames + ) { cli::cli_warn("Same attribute for columns and rows, row names are ignored") add.rownames <- NA } @@ -348,14 +387,18 @@ is_symmetric <- function(x) { #' @param ... Passed to `graph_from_adjacency_matrix()`. #' @family adjacency #' @export -from_adjacency <- function(...) constructor_spec(graph_from_adjacency_matrix, ...) +from_adjacency <- function(...) { + constructor_spec(graph_from_adjacency_matrix, ...) +} graph.adjacency.dense <- function( - adjmatrix, + adjmatrix, + mode, + weighted = NULL, + diag = c("once", "twice", "ignore") +) { + mode <- switch( mode, - weighted = NULL, - diag = c("once", "twice", "ignore")) { - mode <- switch(mode, "directed" = 0L, "undirected" = 1L, "upper" = 2L, @@ -369,11 +412,7 @@ graph.adjacency.dense <- function( diag <- ifelse(diag, "once", "ignore") } diag <- igraph.match.arg(diag) - diag <- switch(diag, - "ignore" = 0L, - "twice" = 1L, - "once" = 2L - ) + diag <- switch(diag, "ignore" = 0L, "twice" = 1L, "once" = 2L) if (nrow(adjmatrix) != ncol(adjmatrix)) { stop("Adjacency matrices must be square.") @@ -421,13 +460,22 @@ pmin_AB <- function(A, B) { A } -graph.adjacency.sparse <- function(adjmatrix, mode, weighted = NULL, diag = TRUE, call = rlang::caller_env()) { +graph.adjacency.sparse <- function( + adjmatrix, + mode, + weighted = NULL, + diag = TRUE, + call = rlang::caller_env() +) { if (!is.null(weighted)) { if (is.logical(weighted) && weighted) { weighted <- "weight" } if (!is.character(weighted)) { - cli::cli_abort("Invalid value supplied for `weighted' argument, please see docs.", call = call) + cli::cli_abort( + "Invalid value supplied for `weighted' argument, please see docs.", + call = call + ) } } @@ -463,9 +511,15 @@ graph.adjacency.sparse <- function(adjmatrix, mode, weighted = NULL, diag = TRUE adjmatrix <- adjmatrix + Matrix::t(adjmatrix) adjmatrix <- Matrix::tril(adjmatrix) } else if (mode == "max") { - adjmatrix <- pmax_AB(Matrix::tril(adjmatrix), Matrix::t(Matrix::triu(adjmatrix))) + adjmatrix <- pmax_AB( + Matrix::tril(adjmatrix), + Matrix::t(Matrix::triu(adjmatrix)) + ) } else if (mode == "min") { - adjmatrix <- pmin_AB(Matrix::tril(adjmatrix), Matrix::t(Matrix::triu(adjmatrix))) + adjmatrix <- pmin_AB( + Matrix::tril(adjmatrix), + Matrix::t(Matrix::triu(adjmatrix)) + ) adjmatrix <- Matrix::drop0(adjmatrix) } el <- mysummary(adjmatrix) diff --git a/R/assortativity.R b/R/assortativity.R index 82af3004c56..cec0dd3aa83 100644 --- a/R/assortativity.R +++ b/R/assortativity.R @@ -8,9 +8,24 @@ #' @inheritParams assortativity_nominal #' @keywords internal #' @export -assortativity.nominal <- function(graph, types, directed = TRUE, normalized = TRUE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "assortativity.nominal()", "assortativity_nominal()") - assortativity_nominal(graph = graph, types = types, directed = directed, normalized = normalized) +assortativity.nominal <- function( + graph, + types, + directed = TRUE, + normalized = TRUE +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "assortativity.nominal()", + "assortativity_nominal()" + ) + assortativity_nominal( + graph = graph, + types = types, + directed = directed, + normalized = normalized + ) } # nocov end #' Assortativity coefficient @@ -23,8 +38,13 @@ assortativity.nominal <- function(graph, types, directed = TRUE, normalized = TR #' @inheritParams assortativity_degree #' @keywords internal #' @export -assortativity.degree <- function(graph, directed = TRUE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "assortativity.degree()", "assortativity_degree()") +assortativity.degree <- function(graph, directed = TRUE) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "assortativity.degree()", + "assortativity_degree()" + ) assortativity_degree(graph = graph, directed = directed) } # nocov end @@ -51,7 +71,6 @@ assortativity.degree <- function(graph, directed = TRUE) { # nocov start ## ## ----------------------------------------------------------------------- - #' Assortativity coefficient #' #' The assortativity coefficient is positive if similar vertices (based on some @@ -142,14 +161,16 @@ assortativity.degree <- function(graph, directed = TRUE) { # nocov start #' # BA model, tends to be dissortative #' assortativity_degree(sample_pa(10000, m = 4)) #' @cdocs igraph_assortativity -assortativity <- function(graph, - values, - ..., - values.in = NULL, - directed = TRUE, - normalized = TRUE, - types1 = NULL, - types2 = NULL) { +assortativity <- function( + graph, + values, + ..., + values.in = NULL, + directed = TRUE, + normalized = TRUE, + types1 = NULL, + types2 = NULL +) { if (...length() > 0) { lifecycle::deprecate_soft( "1.6.0", @@ -194,7 +215,12 @@ assortativity <- function(graph, assortativity_impl(graph, values, values.in, directed, normalized) } -assortativity_legacy <- function(graph, types1, types2 = NULL, directed = TRUE) { +assortativity_legacy <- function( + graph, + types1, + types2 = NULL, + directed = TRUE +) { assortativity_impl(graph, types1, types2, directed) } diff --git a/R/basic.R b/R/basic.R index ac16ca80f92..47b00f7e071 100644 --- a/R/basic.R +++ b/R/basic.R @@ -8,7 +8,8 @@ #' @inheritParams is_igraph #' @keywords internal #' @export -is.igraph <- function(graph) { # nocov start +is.igraph <- function(graph) { + # nocov start lifecycle::deprecate_soft("2.0.0", "is.igraph()", "is_igraph()") is_igraph(graph = graph) } # nocov end @@ -33,8 +34,6 @@ is.igraph <- function(graph) { # nocov start # ################################################################### - - #' Is this object an igraph graph? #' #' @param graph An R object. diff --git a/R/bipartite.R b/R/bipartite.R index cf764ddb242..25b72d5220e 100644 --- a/R/bipartite.R +++ b/R/bipartite.R @@ -8,8 +8,13 @@ #' @inheritParams bipartite_projection_size #' @keywords internal #' @export -bipartite.projection.size <- function(graph, types = NULL) { # nocov start - lifecycle::deprecate_soft("2.0.0", "bipartite.projection.size()", "bipartite_projection_size()") +bipartite.projection.size <- function(graph, types = NULL) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "bipartite.projection.size()", + "bipartite_projection_size()" + ) bipartite_projection_size(graph = graph, types = types) } # nocov end @@ -23,9 +28,28 @@ bipartite.projection.size <- function(graph, types = NULL) { # nocov start #' @inheritParams bipartite_projection #' @keywords internal #' @export -bipartite.projection <- function(graph, types = NULL, multiplicity = TRUE, probe1 = NULL, which = c("both", "true", "false"), remove.type = TRUE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "bipartite.projection()", "bipartite_projection()") - bipartite_projection(graph = graph, types = types, multiplicity = multiplicity, probe1 = probe1, which = which, remove.type = remove.type) +bipartite.projection <- function( + graph, + types = NULL, + multiplicity = TRUE, + probe1 = NULL, + which = c("both", "true", "false"), + remove.type = TRUE +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "bipartite.projection()", + "bipartite_projection()" + ) + bipartite_projection( + graph = graph, + types = types, + multiplicity = multiplicity, + probe1 = probe1, + which = which, + remove.type = remove.type + ) } # nocov end #' Decide whether a graph is bipartite @@ -38,8 +62,13 @@ bipartite.projection <- function(graph, types = NULL, multiplicity = TRUE, probe #' @inheritParams bipartite_mapping #' @keywords internal #' @export -bipartite.mapping <- function(graph) { # nocov start - lifecycle::deprecate_soft("2.0.0", "bipartite.mapping()", "bipartite_mapping()") +bipartite.mapping <- function(graph) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "bipartite.mapping()", + "bipartite_mapping()" + ) bipartite_mapping(graph = graph) } # nocov end # IGraph R package @@ -63,8 +92,6 @@ bipartite.mapping <- function(graph) { # nocov start # ################################################################### - - #' Project a bipartite graph #' #' A bipartite graph is projected into two one-mode networks @@ -132,10 +159,14 @@ bipartite.mapping <- function(graph) { # nocov start #' print(proj2[[1]], g = TRUE, e = TRUE) #' print(proj2[[2]], g = TRUE, e = TRUE) #' -bipartite_projection <- function(graph, types = NULL, - multiplicity = TRUE, probe1 = NULL, - which = c("both", "true", "false"), - remove.type = TRUE) { +bipartite_projection <- function( + graph, + types = NULL, + multiplicity = TRUE, + probe1 = NULL, + which = c("both", "true", "false"), + remove.type = TRUE +) { # Argument checks ensure_igraph(graph) types <- handle_vertex_type_arg(types, graph) @@ -147,7 +178,8 @@ bipartite_projection <- function(graph, types = NULL, } else { probe1 <- -1 } - which <- switch(igraph.match.arg(which), + which <- switch( + igraph.match.arg(which), "both" = 0L, "false" = 1L, "true" = 2L @@ -159,8 +191,11 @@ bipartite_projection <- function(graph, types = NULL, on.exit(.Call(R_igraph_finalizer)) # Function call res <- .Call( - R_igraph_bipartite_projection, graph, types, - as.numeric(probe1), which + R_igraph_bipartite_projection, + graph, + types, + as.numeric(probe1), + which ) if (remove.type) { if (is_igraph(res[[1]])) { diff --git a/R/centrality.R b/R/centrality.R index 06039c274e1..6ae92370186 100644 --- a/R/centrality.R +++ b/R/centrality.R @@ -8,8 +8,13 @@ #' @inheritParams subgraph_centrality #' @keywords internal #' @export -subgraph.centrality <- function(graph, diag = FALSE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "subgraph.centrality()", "subgraph_centrality()") +subgraph.centrality <- function(graph, diag = FALSE) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "subgraph.centrality()", + "subgraph_centrality()" + ) subgraph_centrality(graph = graph, diag = diag) } # nocov end @@ -23,9 +28,28 @@ subgraph.centrality <- function(graph, diag = FALSE) { # nocov start #' @inheritParams page_rank #' @keywords internal #' @export -page.rank <- function(graph, algo = c("prpack", "arpack"), vids = V(graph), directed = TRUE, damping = 0.85, personalized = NULL, weights = NULL, options = NULL) { # nocov start +page.rank <- function( + graph, + algo = c("prpack", "arpack"), + vids = V(graph), + directed = TRUE, + damping = 0.85, + personalized = NULL, + weights = NULL, + options = NULL +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "page.rank()", "page_rank()") - page_rank(graph = graph, algo = algo, vids = vids, directed = directed, damping = damping, personalized = personalized, weights = weights, options = options) + page_rank( + graph = graph, + algo = algo, + vids = vids, + directed = directed, + damping = damping, + personalized = personalized, + weights = weights, + options = options + ) } # nocov end #' Kleinberg's hub and authority centrality scores. @@ -38,7 +62,13 @@ page.rank <- function(graph, algo = c("prpack", "arpack"), vids = V(graph), dire #' @inheritParams hub_score #' @keywords internal #' @export -hub.score <- function(graph, scale = TRUE, weights = NULL, options = arpack_defaults()) { # nocov start +hub.score <- function( + graph, + scale = TRUE, + weights = NULL, + options = arpack_defaults() +) { + # nocov start lifecycle::deprecate_warn("2.0.0", "hub.score()", "hits_scores()") hub_score(graph = graph, scale = scale, weights = weights, options = options) } # nocov end @@ -53,9 +83,20 @@ hub.score <- function(graph, scale = TRUE, weights = NULL, options = arpack_defa #' @inheritParams authority_score #' @keywords internal #' @export -authority.score <- function(graph, scale = TRUE, weights = NULL, options = arpack_defaults()) { # nocov start +authority.score <- function( + graph, + scale = TRUE, + weights = NULL, + options = arpack_defaults() +) { + # nocov start lifecycle::deprecate_warn("2.0.0", "authority.score()", "hits_scores()") - authority_score(graph = graph, scale = scale, weights = weights, options = options) + authority_score( + graph = graph, + scale = scale, + weights = weights, + options = options + ) } # nocov end #' Strength or weighted vertex degree @@ -68,9 +109,22 @@ authority.score <- function(graph, scale = TRUE, weights = NULL, options = arpac #' @inheritParams strength #' @keywords internal #' @export -graph.strength <- function(graph, vids = V(graph), mode = c("all", "out", "in", "total"), loops = TRUE, weights = NULL) { # nocov start +graph.strength <- function( + graph, + vids = V(graph), + mode = c("all", "out", "in", "total"), + loops = TRUE, + weights = NULL +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "graph.strength()", "strength()") - strength(graph = graph, vids = vids, mode = mode, loops = loops, weights = weights) + strength( + graph = graph, + vids = vids, + mode = mode, + loops = loops, + weights = weights + ) } # nocov end #' Eigenvalues and eigenvectors of the adjacency matrix of a graph @@ -83,9 +137,27 @@ graph.strength <- function(graph, vids = V(graph), mode = c("all", "out", "in", #' @inheritParams spectrum #' @keywords internal #' @export -graph.eigen <- function(graph, algorithm = c("arpack", "auto", "lapack", "comp_auto", "comp_lapack", "comp_arpack"), which = list(), options = arpack_defaults()) { # nocov start +graph.eigen <- function( + graph, + algorithm = c( + "arpack", + "auto", + "lapack", + "comp_auto", + "comp_lapack", + "comp_arpack" + ), + which = list(), + options = arpack_defaults() +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "graph.eigen()", "spectrum()") - spectrum(graph = graph, algorithm = algorithm, which = which, options = options) + spectrum( + graph = graph, + algorithm = algorithm, + which = which, + options = options + ) } # nocov end #' Graph diversity @@ -98,7 +170,8 @@ graph.eigen <- function(graph, algorithm = c("arpack", "auto", "lapack", "comp_a #' @inheritParams diversity #' @keywords internal #' @export -graph.diversity <- function(graph, weights = NULL, vids = V(graph)) { # nocov start +graph.diversity <- function(graph, weights = NULL, vids = V(graph)) { + # nocov start lifecycle::deprecate_soft("2.0.0", "graph.diversity()", "diversity()") diversity(graph = graph, weights = weights, vids = vids) } # nocov end @@ -113,9 +186,22 @@ graph.diversity <- function(graph, weights = NULL, vids = V(graph)) { # nocov st #' @inheritParams eigen_centrality #' @keywords internal #' @export -evcent <- function(graph, directed = FALSE, scale = TRUE, weights = NULL, options = arpack_defaults()) { # nocov start +evcent <- function( + graph, + directed = FALSE, + scale = TRUE, + weights = NULL, + options = arpack_defaults() +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "evcent()", "eigen_centrality()") - eigen_centrality(graph = graph, directed = directed, scale = scale, weights = weights, options = options) + eigen_centrality( + graph = graph, + directed = directed, + scale = scale, + weights = weights, + options = options + ) } # nocov end #' Vertex and edge betweenness centrality @@ -128,9 +214,22 @@ evcent <- function(graph, directed = FALSE, scale = TRUE, weights = NULL, option #' @inheritParams edge_betweenness #' @keywords internal #' @export -edge.betweenness <- function(graph, e = E(graph), directed = TRUE, weights = NULL, cutoff = -1) { # nocov start +edge.betweenness <- function( + graph, + e = E(graph), + directed = TRUE, + weights = NULL, + cutoff = -1 +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "edge.betweenness()", "edge_betweenness()") - edge_betweenness(graph = graph, e = e, directed = directed, weights = weights, cutoff = cutoff) + edge_betweenness( + graph = graph, + e = e, + directed = directed, + weights = weights, + cutoff = cutoff + ) } # nocov end #' Find Bonacich Power Centrality Scores of Network Positions @@ -143,9 +242,26 @@ edge.betweenness <- function(graph, e = E(graph), directed = TRUE, weights = NUL #' @inheritParams power_centrality #' @keywords internal #' @export -bonpow <- function(graph, nodes = V(graph), loops = FALSE, exponent = 1, rescale = FALSE, tol = 1e-7, sparse = TRUE) { # nocov start +bonpow <- function( + graph, + nodes = V(graph), + loops = FALSE, + exponent = 1, + rescale = FALSE, + tol = 1e-7, + sparse = TRUE +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "bonpow()", "power_centrality()") - power_centrality(graph = graph, nodes = nodes, loops = loops, exponent = exponent, rescale = rescale, tol = tol, sparse = sparse) + power_centrality( + graph = graph, + nodes = nodes, + loops = loops, + exponent = exponent, + rescale = rescale, + tol = tol, + sparse = sparse + ) } # nocov end #' Find Bonacich alpha centrality scores of network positions @@ -158,9 +274,28 @@ bonpow <- function(graph, nodes = V(graph), loops = FALSE, exponent = 1, rescale #' @inheritParams alpha_centrality #' @keywords internal #' @export -alpha.centrality <- function(graph, nodes = V(graph), alpha = 1, loops = FALSE, exo = 1, weights = NULL, tol = 1e-7, sparse = TRUE) { # nocov start +alpha.centrality <- function( + graph, + nodes = V(graph), + alpha = 1, + loops = FALSE, + exo = 1, + weights = NULL, + tol = 1e-7, + sparse = TRUE +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "alpha.centrality()", "alpha_centrality()") - alpha_centrality(graph = graph, nodes = nodes, alpha = alpha, loops = loops, exo = exo, weights = weights, tol = tol, sparse = sparse) + alpha_centrality( + graph = graph, + nodes = nodes, + alpha = alpha, + loops = loops, + exo = exo, + weights = weights, + tol = tol, + sparse = sparse + ) } # nocov end # IGraph R package # Copyright (C) 2005-2012 Gabor Csardi @@ -194,7 +329,13 @@ alpha.centrality <- function(graph, nodes = V(graph), alpha = 1, loops = FALSE, #' @inheritParams betweenness #' @keywords internal #' @export -estimate_betweenness <- function(graph, vids = V(graph), directed = TRUE, cutoff, weights = NULL) { +estimate_betweenness <- function( + graph, + vids = V(graph), + directed = TRUE, + cutoff, + weights = NULL +) { lifecycle::deprecate_soft( "1.6.0", "estimate_betweenness()", @@ -202,7 +343,13 @@ estimate_betweenness <- function(graph, vids = V(graph), directed = TRUE, cutoff details = "with the cutoff argument." ) - betweenness(graph, v = vids, directed = directed, cutoff = cutoff, weights = weights) + betweenness( + graph, + v = vids, + directed = directed, + cutoff = cutoff, + weights = weights + ) } #' @export @@ -289,8 +436,14 @@ betweenness.estimate <- estimate_betweenness #' betweenness(g) #' edge_betweenness(g) #' -betweenness <- function(graph, v = V(graph), directed = TRUE, weights = NULL, - normalized = FALSE, cutoff = -1) { +betweenness <- function( + graph, + v = V(graph), + directed = TRUE, + weights = NULL, + normalized = FALSE, + cutoff = -1 +) { ensure_igraph(graph) v <- as_igraph_vs(graph, v) @@ -305,7 +458,14 @@ betweenness <- function(graph, v = V(graph), directed = TRUE, weights = NULL, } cutoff <- as.numeric(cutoff) on.exit(.Call(R_igraph_finalizer)) - res <- .Call(R_igraph_betweenness_cutoff, graph, v - 1, directed, weights, cutoff) + res <- .Call( + R_igraph_betweenness_cutoff, + graph, + v - 1, + directed, + weights, + cutoff + ) if (normalized) { vc <- as.numeric(vcount(graph)) if (is_directed(graph) && directed) { @@ -323,8 +483,13 @@ betweenness <- function(graph, v = V(graph), directed = TRUE, weights = NULL, #' @rdname betweenness #' @param e The edges for which the edge betweenness will be calculated. #' @export -edge_betweenness <- function(graph, e = E(graph), - directed = TRUE, weights = NULL, cutoff = -1) { +edge_betweenness <- function( + graph, + e = E(graph), + directed = TRUE, + weights = NULL, + cutoff = -1 +) { # Argument checks ensure_igraph(graph) @@ -342,7 +507,13 @@ edge_betweenness <- function(graph, e = E(graph), on.exit(.Call(R_igraph_finalizer)) # Function call - res <- .Call(R_igraph_edge_betweenness_cutoff, graph, directed, weights, cutoff) + res <- .Call( + R_igraph_edge_betweenness_cutoff, + graph, + directed, + weights, + cutoff + ) res[as.numeric(e)] } @@ -355,15 +526,26 @@ edge_betweenness <- function(graph, e = E(graph), #' @inheritParams edge_betweenness #' @keywords internal #' @export -estimate_edge_betweenness <- function(graph, e = E(graph), - directed = TRUE, cutoff, weights = NULL) { +estimate_edge_betweenness <- function( + graph, + e = E(graph), + directed = TRUE, + cutoff, + weights = NULL +) { lifecycle::deprecate_soft( "1.6.0", "estimate_edge_betweenness()", "edge_betweenness()", details = "with the cutoff argument." ) - edge_betweenness(graph, e, directed = directed, cutoff = cutoff, weights = weights) + edge_betweenness( + graph, + e, + directed = directed, + cutoff = cutoff, + weights = weights + ) } #' @export @@ -429,14 +611,20 @@ edge.betweenness.estimate <- estimate_edge_betweenness #' closeness(g2, mode = "out") #' closeness(g2, mode = "all") #' -closeness <- function(graph, vids = V(graph), - mode = c("out", "in", "all", "total"), weights = NULL, - normalized = FALSE, cutoff = -1) { +closeness <- function( + graph, + vids = V(graph), + mode = c("out", "in", "all", "total"), + weights = NULL, + normalized = FALSE, + cutoff = -1 +) { # Argument checks ensure_igraph(graph) vids <- as_igraph_vs(graph, vids) - mode <- switch(igraph.match.arg(mode), + mode <- switch( + igraph.match.arg(mode), "out" = 1, "in" = 2, "all" = 3, @@ -455,7 +643,15 @@ closeness <- function(graph, vids = V(graph), on.exit(.Call(R_igraph_finalizer)) # Function call - res <- .Call(R_igraph_closeness_cutoff, graph, vids - 1, mode, weights, normalized, cutoff)$res + res <- .Call( + R_igraph_closeness_cutoff, + graph, + vids - 1, + mode, + weights, + normalized, + cutoff + )$res if (igraph_opt("add.vertex.names") && is_named(graph)) { names(res) <- V(graph)$name[vids] } @@ -471,7 +667,14 @@ closeness <- function(graph, vids = V(graph), #' @inheritParams closeness #' @keywords internal #' @export -estimate_closeness <- function(graph, vids = V(graph), mode = c("out", "in", "all", "total"), cutoff, weights = NULL, normalized = FALSE) { +estimate_closeness <- function( + graph, + vids = V(graph), + mode = c("out", "in", "all", "total"), + cutoff, + weights = NULL, + normalized = FALSE +) { lifecycle::deprecate_soft( "1.6.0", "estimate_closeness()", @@ -479,7 +682,14 @@ estimate_closeness <- function(graph, vids = V(graph), mode = c("out", "in", "al details = "with the cutoff argument." ) - closeness(graph, vids, mode = mode, weights = weights, normalized = normalized, cutoff = cutoff) + closeness( + graph, + vids, + mode = mode, + weights = weights, + normalized = normalized, + cutoff = cutoff + ) } #' @export @@ -489,9 +699,20 @@ closeness.estimate <- estimate_closeness #' @export arpack_defaults <- function() { list( - bmat = "I", n = 0, which = "XX", nev = 1, tol = 0.0, - ncv = 3, ldv = 0, ishift = 1, maxiter = 3000, nb = 1, - mode = 1, start = 0, sigma = 0.0, sigmai = 0.0 + bmat = "I", + n = 0, + which = "XX", + nev = 1, + tol = 0.0, + ncv = 3, + ldv = 0, + ishift = 1, + maxiter = 3000, + nb = 1, + mode = 1, + start = 0, + sigma = 0.0, + sigmai = 0.0 ) } @@ -795,19 +1016,29 @@ arpack_defaults <- function() { #' ) #' @family arpack #' @export -arpack <- function(func, extra = NULL, sym = FALSE, options = arpack_defaults(), - env = parent.frame(), complex = !sym) { +arpack <- function( + func, + extra = NULL, + sym = FALSE, + options = arpack_defaults(), + env = parent.frame(), + complex = !sym +) { if (is.function(options)) { lifecycle::deprecate_soft( "1.6.0", "arpack(options = 'must be a list')", - details = c("`arpack_defaults()` is now a function, use `options = arpack_defaults()` instead of `options = arpack_defaults`.") + details = c( + "`arpack_defaults()` is now a function, use `options = arpack_defaults()` instead of `options = arpack_defaults`." + ) ) options <- options() } - if (!is.list(options) || - (is.null(names(options)) && length(options) != 0)) { + if ( + !is.list(options) || + (is.null(names(options)) && length(options) != 0) + ) { stop("options must be a named list") } if (any(names(options) == "")) { @@ -818,9 +1049,7 @@ arpack <- function(func, extra = NULL, sym = FALSE, options = arpack_defaults(), if (any(!names(options) %in% names(defaults))) { stop( "unkown ARPACK option(s): ", - paste(setdiff(names(options), names(defaults)), - collapse = ", " - ) + paste(setdiff(names(options), names(defaults)), collapse = ", ") ) } @@ -836,7 +1065,8 @@ arpack <- function(func, extra = NULL, sym = FALSE, options = arpack_defaults(), if (complex) { rew <- arpack.unpack.complex( - res$vectors, res$values, + res$vectors, + res$values, min(res$options$nev, res$options$nconv) ) res$vectors <- rew$vectors @@ -875,7 +1105,6 @@ arpack.unpack.complex <- function(vectors, values, nev) { } - #' Find subgraph centrality scores of network positions #' #' Subgraph centrality of a vertex measures the number of subgraphs a vertex @@ -996,17 +1225,32 @@ subgraph_centrality <- function(graph, diag = FALSE) { #' #' @family centrality #' @export -spectrum <- function(graph, algorithm = c("arpack", "auto", "lapack", "comp_auto", "comp_lapack", "comp_arpack"), which = list(), options = arpack_defaults()) { +spectrum <- function( + graph, + algorithm = c( + "arpack", + "auto", + "lapack", + "comp_auto", + "comp_lapack", + "comp_arpack" + ), + which = list(), + options = arpack_defaults() +) { if (is.function(options)) { lifecycle::deprecate_soft( "1.6.0", "spectrum(options = 'must be a list')", - details = c("`arpack_defaults()` is now a function, use `options = arpack_defaults()` instead of `options = arpack_defaults`.") + details = c( + "`arpack_defaults()` is now a function, use `options = arpack_defaults()` instead of `options = arpack_defaults`." + ) ) options <- options() } - eigen_adjacency_impl(graph, + eigen_adjacency_impl( + graph, algorithm = algorithm, which = which, options = options @@ -1015,8 +1259,13 @@ spectrum <- function(graph, algorithm = c("arpack", "auto", "lapack", "comp_auto eigen_defaults <- function() { list( - pos = "LM", howmany = 1L, il = -1L, iu = -1L, - vl = -Inf, vu = Inf, vestimate = 0L, + pos = "LM", + howmany = 1L, + il = -1L, + iu = -1L, + vl = -Inf, + vu = Inf, + vestimate = 0L, balance = "none" ) } @@ -1112,16 +1361,20 @@ eigen_defaults <- function() { #' @family centrality #' @export #' @cdocs igraph_eigenvector_centrality -eigen_centrality <- function(graph, - directed = FALSE, - scale = deprecated(), - weights = NULL, - options = arpack_defaults()) { +eigen_centrality <- function( + graph, + directed = FALSE, + scale = deprecated(), + weights = NULL, + options = arpack_defaults() +) { if (is.function(options)) { lifecycle::deprecate_soft( "1.6.0", "eigen_centrality(options = 'must be a list')", - details = c("`arpack_defaults()` is now a function, use `options = arpack_defaults()` instead of `options = arpack_defaults`.") + details = c( + "`arpack_defaults()` is now a function, use `options = arpack_defaults()` instead of `options = arpack_defaults`." + ) ) options <- options() } @@ -1294,7 +1547,13 @@ diversity <- diversity_impl #' hits_scores(g2) #' @family centrality #' @cdocs igraph_hub_and_authority_scores -hits_scores <- function(graph, ..., scale = TRUE, weights = NULL, options = arpack_defaults()) { +hits_scores <- function( + graph, + ..., + scale = TRUE, + weights = NULL, + options = arpack_defaults() +) { rlang::check_dots_empty() hub_and_authority_scores_impl( @@ -1310,14 +1569,21 @@ hits_scores <- function(graph, ..., scale = TRUE, weights = NULL, options = arpa #' @param options A named list, to override some ARPACK options. See #' [arpack()] for details. #' @export -authority_score <- function(graph, scale = TRUE, weights = NULL, options = arpack_defaults()) { +authority_score <- function( + graph, + scale = TRUE, + weights = NULL, + options = arpack_defaults() +) { lifecycle::deprecate_soft("2.1.0", "authority_score()", "hits_scores()") if (is.function(options)) { lifecycle::deprecate_soft( "1.6.0", I("arpack_defaults"), "arpack_defaults()", - details = c("So the function arpack_defaults(), not an object called arpack_defaults.") + details = c( + "So the function arpack_defaults(), not an object called arpack_defaults." + ) ) options <- arpack_defaults() } @@ -1348,14 +1614,21 @@ authority_score <- function(graph, scale = TRUE, weights = NULL, options = arpac #' [arpack()] for details. #' @family centrality #' @export -hub_score <- function(graph, scale = TRUE, weights = NULL, options = arpack_defaults()) { +hub_score <- function( + graph, + scale = TRUE, + weights = NULL, + options = arpack_defaults() +) { lifecycle::deprecate_soft("2.0.3", "hub_score()", "hits_scores()") if (is.function(options)) { lifecycle::deprecate_soft( "1.6.0", I("arpack_defaults"), "arpack_defaults()", - details = c("So the function arpack_defaults(), not an object called arpack_defaults.") + details = c( + "So the function arpack_defaults(), not an object called arpack_defaults." + ) ) options <- arpack_defaults() } @@ -1509,10 +1782,14 @@ page_rank <- personalized_pagerank_impl harmonic_centrality <- harmonic_centrality_cutoff_impl - -bonpow.dense <- function(graph, nodes = V(graph), - loops = FALSE, exponent = 1, - rescale = FALSE, tol = 1e-7) { +bonpow.dense <- function( + graph, + nodes = V(graph), + loops = FALSE, + exponent = 1, + rescale = FALSE, + tol = 1e-7 +) { ensure_igraph(graph) d <- as_adjacency_matrix(graph) @@ -1533,8 +1810,14 @@ bonpow.dense <- function(graph, nodes = V(graph), ev[as.numeric(nodes)] } -bonpow.sparse <- function(graph, nodes = V(graph), loops = FALSE, - exponent = 1, rescale = FALSE, tol = 1e-07) { +bonpow.sparse <- function( + graph, + nodes = V(graph), + loops = FALSE, + exponent = 1, + rescale = FALSE, + tol = 1e-07 +) { ## remove loops if requested if (!loops) { graph <- simplify(graph, remove.multiple = FALSE, remove.loops = TRUE) @@ -1561,7 +1844,6 @@ bonpow.sparse <- function(graph, nodes = V(graph), loops = FALSE, } - #' Find Bonacich Power Centrality Scores of Network Positions #' #' `power_centrality()` takes a graph (`dat`) and returns the Boncich power @@ -1675,9 +1957,15 @@ bonpow.sparse <- function(graph, nodes = V(graph), loops = FALSE, #' print(round(power_centrality(g.f, exp = e)[c(1, 2, 5)], 2)) #' } #' -power_centrality <- function(graph, nodes = V(graph), - loops = FALSE, exponent = 1, - rescale = FALSE, tol = 1e-7, sparse = TRUE) { +power_centrality <- function( + graph, + nodes = V(graph), + loops = FALSE, + exponent = 1, + rescale = FALSE, + tol = 1e-7, + sparse = TRUE +) { nodes <- as_igraph_vs(graph, nodes) if (sparse) { res <- bonpow.sparse(graph, nodes, loops, exponent, rescale, tol) @@ -1692,9 +1980,15 @@ power_centrality <- function(graph, nodes = V(graph), res } -alpha.centrality.dense <- function(graph, nodes = V(graph), alpha = 1, - loops = FALSE, exo = 1, weights = NULL, - tol = 1e-7) { +alpha.centrality.dense <- function( + graph, + nodes = V(graph), + alpha = 1, + loops = FALSE, + exo = 1, + weights = NULL, + tol = 1e-7 +) { ensure_igraph(graph) exo <- rep(exo, length.out = vcount(graph)) @@ -1730,9 +2024,15 @@ alpha.centrality.dense <- function(graph, nodes = V(graph), alpha = 1, ev[as.numeric(nodes)] } -alpha.centrality.sparse <- function(graph, nodes = V(graph), alpha = 1, - loops = FALSE, exo = 1, weights = NULL, - tol = 1e-7) { +alpha.centrality.sparse <- function( + graph, + nodes = V(graph), + alpha = 1, + loops = FALSE, + exo = 1, + weights = NULL, + tol = 1e-7 +) { ensure_igraph(graph) vc <- vcount(graph) @@ -1762,7 +2062,12 @@ alpha.centrality.sparse <- function(graph, nodes = V(graph), alpha = 1, M <- Matrix::t(as_adjacency_matrix(graph, attr = attr, sparse = TRUE)) ## Create an identity matrix - M2 <- Matrix::sparseMatrix(dims = c(vc, vc), i = 1:vc, j = 1:vc, x = rep(1, vc)) + M2 <- Matrix::sparseMatrix( + dims = c(vc, vc), + i = 1:vc, + j = 1:vc, + x = rep(1, vc) + ) ## exo exo <- cbind(rep(exo, length.out = vc)) @@ -1775,7 +2080,6 @@ alpha.centrality.sparse <- function(graph, nodes = V(graph), alpha = 1, } - #' Find Bonacich alpha centrality scores of network positions #' #' `alpha_centrality()` calculates the alpha centrality of some (or all) @@ -1838,19 +2142,36 @@ alpha.centrality.sparse <- function(graph, nodes = V(graph), alpha = 1, #' alpha_centrality(g.2) #' alpha_centrality(g.3, alpha = 0.5) #' -alpha_centrality <- function(graph, nodes = V(graph), alpha = 1, - loops = FALSE, exo = 1, weights = NULL, - tol = 1e-7, sparse = TRUE) { +alpha_centrality <- function( + graph, + nodes = V(graph), + alpha = 1, + loops = FALSE, + exo = 1, + weights = NULL, + tol = 1e-7, + sparse = TRUE +) { nodes <- as_igraph_vs(graph, nodes) if (sparse) { res <- alpha.centrality.sparse( - graph, nodes, alpha, loops, - exo, weights, tol + graph, + nodes, + alpha, + loops, + exo, + weights, + tol ) } else { res <- alpha.centrality.dense( - graph, nodes, alpha, loops, - exo, weights, tol + graph, + nodes, + alpha, + loops, + exo, + weights, + tol ) } if (igraph_opt("add.vertex.names") && is_named(graph)) { diff --git a/R/centralization.R b/R/centralization.R index 1b996582c0f..4db79aba77e 100644 --- a/R/centralization.R +++ b/R/centralization.R @@ -8,9 +8,14 @@ #' @inheritParams centralize #' @keywords internal #' @export -centralize.scores <- function(scores, theoretical.max = 0, normalized = TRUE) { # nocov start +centralize.scores <- function(scores, theoretical.max = 0, normalized = TRUE) { + # nocov start lifecycle::deprecate_soft("2.0.0", "centralize.scores()", "centralize()") - centralize(scores = scores, theoretical.max = theoretical.max, normalized = normalized) + centralize( + scores = scores, + theoretical.max = theoretical.max, + normalized = normalized + ) } # nocov end #' Theoretical maximum for betweenness centralization @@ -23,9 +28,24 @@ centralize.scores <- function(scores, theoretical.max = 0, normalized = TRUE) { #' @inheritParams centr_eigen_tmax #' @keywords internal #' @export -centralization.evcent.tmax <- function(graph = NULL, nodes = 0, directed = FALSE, scale = TRUE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "centralization.evcent.tmax()", "centr_eigen_tmax()") - centr_eigen_tmax(graph = graph, nodes = nodes, directed = directed, scale = scale) +centralization.evcent.tmax <- function( + graph = NULL, + nodes = 0, + directed = FALSE, + scale = TRUE +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "centralization.evcent.tmax()", + "centr_eigen_tmax()" + ) + centr_eigen_tmax( + graph = graph, + nodes = nodes, + directed = directed, + scale = scale + ) } # nocov end #' Centralize a graph according to the eigenvector centrality of vertices @@ -38,9 +58,22 @@ centralization.evcent.tmax <- function(graph = NULL, nodes = 0, directed = FALSE #' @inheritParams centr_eigen #' @keywords internal #' @export -centralization.evcent <- function(graph, directed = FALSE, scale = TRUE, options = arpack_defaults(), normalized = TRUE) { # nocov start +centralization.evcent <- function( + graph, + directed = FALSE, + scale = TRUE, + options = arpack_defaults(), + normalized = TRUE +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "centralization.evcent()", "centr_eigen()") - centr_eigen(graph = graph, directed = directed, scale = scale, options = options, normalized = normalized) + centr_eigen( + graph = graph, + directed = directed, + scale = scale, + options = options, + normalized = normalized + ) } # nocov end #' Theoretical maximum for degree centralization @@ -53,8 +86,18 @@ centralization.evcent <- function(graph, directed = FALSE, scale = TRUE, options #' @inheritParams centr_degree_tmax #' @keywords internal #' @export -centralization.degree.tmax <- function(graph = NULL, nodes = 0, mode = c("all", "out", "in", "total"), loops = FALSE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "centralization.degree.tmax()", "centr_degree_tmax()") +centralization.degree.tmax <- function( + graph = NULL, + nodes = 0, + mode = c("all", "out", "in", "total"), + loops = FALSE +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "centralization.degree.tmax()", + "centr_degree_tmax()" + ) centr_degree_tmax(graph = graph, nodes = nodes, mode = mode, loops = loops) } # nocov end @@ -68,9 +111,24 @@ centralization.degree.tmax <- function(graph = NULL, nodes = 0, mode = c("all", #' @inheritParams centr_degree #' @keywords internal #' @export -centralization.degree <- function(graph, mode = c("all", "out", "in", "total"), loops = TRUE, normalized = TRUE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "centralization.degree()", "centr_degree()") - centr_degree(graph = graph, mode = mode, loops = loops, normalized = normalized) +centralization.degree <- function( + graph, + mode = c("all", "out", "in", "total"), + loops = TRUE, + normalized = TRUE +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "centralization.degree()", + "centr_degree()" + ) + centr_degree( + graph = graph, + mode = mode, + loops = loops, + normalized = normalized + ) } # nocov end #' Theoretical maximum for closeness centralization @@ -83,8 +141,17 @@ centralization.degree <- function(graph, mode = c("all", "out", "in", "total"), #' @inheritParams centr_clo_tmax #' @keywords internal #' @export -centralization.closeness.tmax <- function(graph = NULL, nodes = 0, mode = c("out", "in", "all", "total")) { # nocov start - lifecycle::deprecate_soft("2.0.0", "centralization.closeness.tmax()", "centr_clo_tmax()") +centralization.closeness.tmax <- function( + graph = NULL, + nodes = 0, + mode = c("out", "in", "all", "total") +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "centralization.closeness.tmax()", + "centr_clo_tmax()" + ) centr_clo_tmax(graph = graph, nodes = nodes, mode = mode) } # nocov end @@ -98,8 +165,17 @@ centralization.closeness.tmax <- function(graph = NULL, nodes = 0, mode = c("out #' @inheritParams centr_clo #' @keywords internal #' @export -centralization.closeness <- function(graph, mode = c("out", "in", "all", "total"), normalized = TRUE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "centralization.closeness()", "centr_clo()") +centralization.closeness <- function( + graph, + mode = c("out", "in", "all", "total"), + normalized = TRUE +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "centralization.closeness()", + "centr_clo()" + ) centr_clo(graph = graph, mode = mode, normalized = normalized) } # nocov end @@ -113,8 +189,17 @@ centralization.closeness <- function(graph, mode = c("out", "in", "all", "total" #' @inheritParams centr_betw_tmax #' @keywords internal #' @export -centralization.betweenness.tmax <- function(graph = NULL, nodes = 0, directed = TRUE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "centralization.betweenness.tmax()", "centr_betw_tmax()") +centralization.betweenness.tmax <- function( + graph = NULL, + nodes = 0, + directed = TRUE +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "centralization.betweenness.tmax()", + "centr_betw_tmax()" + ) centr_betw_tmax(graph = graph, nodes = nodes, directed = directed) } # nocov end @@ -128,8 +213,17 @@ centralization.betweenness.tmax <- function(graph = NULL, nodes = 0, directed = #' @inheritParams centr_betw #' @keywords internal #' @export -centralization.betweenness <- function(graph, directed = TRUE, normalized = TRUE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "centralization.betweenness()", "centr_betw()") +centralization.betweenness <- function( + graph, + directed = TRUE, + normalized = TRUE +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "centralization.betweenness()", + "centr_betw()" + ) centr_betw(graph = graph, directed = directed, normalized = normalized) } # nocov end @@ -288,10 +382,12 @@ centr_degree <- centralization_degree_impl #' centr_degree(g, normalized = FALSE)$centralization %>% #' `/`(centr_degree_tmax(g, loops = FALSE)) #' centr_degree(g, normalized = TRUE)$centralization -centr_degree_tmax <- function(graph = NULL, - nodes = 0, - mode = c("all", "out", "in", "total"), - loops) { +centr_degree_tmax <- function( + graph = NULL, + nodes = 0, + mode = c("all", "out", "in", "total"), + loops +) { if (!lifecycle::is_present(loops)) { lifecycle::deprecate_warn( when = "2.0.0", @@ -305,7 +401,8 @@ centr_degree_tmax <- function(graph = NULL, ensure_igraph(graph, optional = TRUE) nodes <- as.numeric(nodes) - mode <- switch(igraph.match.arg(mode), + mode <- switch( + igraph.match.arg(mode), "out" = 1, "in" = 2, "all" = 3, @@ -518,12 +615,13 @@ centr_clo_tmax <- centralization_closeness_tmax_impl #' centr_eigen(g0)$centralization #' centr_eigen(g1)$centralization #' @cdocs igraph_centralization_eigenvector_centrality -centr_eigen <- function(graph, - directed = FALSE, - scale = deprecated(), - options = arpack_defaults(), - normalized = TRUE) { - +centr_eigen <- function( + graph, + directed = FALSE, + scale = deprecated(), + options = arpack_defaults(), + normalized = TRUE +) { if (lifecycle::is_present(scale)) { lifecycle::deprecate_soft( "2.2.0", @@ -569,11 +667,12 @@ centr_eigen <- function(graph, #' `/`(centr_eigen_tmax(g)) #' centr_eigen(g, normalized = TRUE)$centralization #' @cdocs igraph_centralization_eigenvector_centrality_tmax -centr_eigen_tmax <- function(graph = NULL, - nodes = 0, - directed = FALSE, - scale = deprecated()) { - +centr_eigen_tmax <- function( + graph = NULL, + nodes = 0, + directed = FALSE, + scale = deprecated() +) { if (lifecycle::is_present(scale)) { lifecycle::deprecate_soft( "2.2.0", From da0908f95838d286e4d0389f821c65231c4e5389 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:44:23 +0200 Subject: [PATCH 04/59] cliques.R --- R/cliques.R | 93 +++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 69 insertions(+), 24 deletions(-) diff --git a/R/cliques.R b/R/cliques.R index 6bd6ac72509..aa2f09713b9 100644 --- a/R/cliques.R +++ b/R/cliques.R @@ -8,8 +8,13 @@ #' @inheritParams max_ivs #' @keywords internal #' @export -maximal.independent.vertex.sets <- function(graph) { # nocov start - lifecycle::deprecate_soft("2.0.0", "maximal.independent.vertex.sets()", "max_ivs()") +maximal.independent.vertex.sets <- function(graph) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "maximal.independent.vertex.sets()", + "max_ivs()" + ) max_ivs(graph = graph) } # nocov end @@ -23,8 +28,18 @@ maximal.independent.vertex.sets <- function(graph) { # nocov start #' @inheritParams count_max_cliques #' @keywords internal #' @export -maximal.cliques.count <- function(graph, min = NULL, max = NULL, subset = NULL) { # nocov start - lifecycle::deprecate_soft("2.0.0", "maximal.cliques.count()", "count_max_cliques()") +maximal.cliques.count <- function( + graph, + min = NULL, + max = NULL, + subset = NULL +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "maximal.cliques.count()", + "count_max_cliques()" + ) count_max_cliques(graph = graph, min = min, max = max, subset = subset) } # nocov end @@ -38,7 +53,14 @@ maximal.cliques.count <- function(graph, min = NULL, max = NULL, subset = NULL) #' @inheritParams max_cliques #' @keywords internal #' @export -maximal.cliques <- function(graph, min = NULL, max = NULL, subset = NULL, file = NULL) { # nocov start +maximal.cliques <- function( + graph, + min = NULL, + max = NULL, + subset = NULL, + file = NULL +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "maximal.cliques()", "max_cliques()") max_cliques(graph = graph, min = min, max = max, subset = subset, file = file) } # nocov end @@ -53,8 +75,13 @@ maximal.cliques <- function(graph, min = NULL, max = NULL, subset = NULL, file = #' @inheritParams largest_ivs #' @keywords internal #' @export -largest.independent.vertex.sets <- function(graph) { # nocov start - lifecycle::deprecate_soft("2.0.0", "largest.independent.vertex.sets()", "largest_ivs()") +largest.independent.vertex.sets <- function(graph) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "largest.independent.vertex.sets()", + "largest_ivs()" + ) largest_ivs(graph = graph) } # nocov end @@ -68,7 +95,8 @@ largest.independent.vertex.sets <- function(graph) { # nocov start #' @inheritParams largest_cliques #' @keywords internal #' @export -largest.cliques <- function(graph) { # nocov start +largest.cliques <- function(graph) { + # nocov start lifecycle::deprecate_soft("2.0.0", "largest.cliques()", "largest_cliques()") largest_cliques(graph = graph) } # nocov end @@ -83,7 +111,8 @@ largest.cliques <- function(graph) { # nocov start #' @inheritParams ivs #' @keywords internal #' @export -independent.vertex.sets <- function(graph, min = NULL, max = NULL) { # nocov start +independent.vertex.sets <- function(graph, min = NULL, max = NULL) { + # nocov start lifecycle::deprecate_soft("2.0.0", "independent.vertex.sets()", "ivs()") ivs(graph = graph, min = min, max = max) } # nocov end @@ -98,7 +127,8 @@ independent.vertex.sets <- function(graph, min = NULL, max = NULL) { # nocov sta #' @inheritParams ivs_size #' @keywords internal #' @export -independence.number <- function(graph) { # nocov start +independence.number <- function(graph) { + # nocov start lifecycle::deprecate_soft("2.0.0", "independence.number()", "ivs_size()") ivs_size(graph = graph) } # nocov end @@ -113,7 +143,8 @@ independence.number <- function(graph) { # nocov start #' @inheritParams clique_num #' @keywords internal #' @export -clique.number <- function(graph) { # nocov start +clique.number <- function(graph) { + # nocov start lifecycle::deprecate_soft("2.0.0", "clique.number()", "clique_num()") clique_num(graph = graph) } # nocov end @@ -138,8 +169,6 @@ clique.number <- function(graph) { # nocov start # ################################################################### - - #' Functions to find cliques, i.e. complete subgraphs in a graph #' #' These functions find all, the largest or all the maximal cliques in an @@ -229,7 +258,13 @@ largest_cliques <- largest_cliques_impl #' in the file, given with the numeric ids of its vertices, separated by #' whitespace. #' @export -max_cliques <- function(graph, min = NULL, max = NULL, subset = NULL, file = NULL) { +max_cliques <- function( + graph, + min = NULL, + max = NULL, + subset = NULL, + file = NULL +) { ensure_igraph(graph) if (is.null(min)) { @@ -244,9 +279,11 @@ max_cliques <- function(graph, min = NULL, max = NULL, subset = NULL, file = NUL } if (!is.null(file)) { - if (!is.character(file) || - length(grep("://", file, fixed = TRUE)) > 0 || - length(grep("~", file, fixed = TRUE)) > 0) { + if ( + !is.character(file) || + length(grep("://", file, fixed = TRUE)) > 0 || + length(grep("~", file, fixed = TRUE)) > 0 + ) { tmpfile <- TRUE origfile <- file file <- tempfile() @@ -255,8 +292,12 @@ max_cliques <- function(graph, min = NULL, max = NULL, subset = NULL, file = NUL } on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_maximal_cliques_file, graph, subset, file, - as.numeric(min), as.numeric(max) + R_igraph_maximal_cliques_file, + graph, + subset, + file, + as.numeric(min), + as.numeric(max) ) if (tmpfile) { buffer <- read.graph.toraw(file) @@ -266,8 +307,11 @@ max_cliques <- function(graph, min = NULL, max = NULL, subset = NULL, file = NUL } else { on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_maximal_cliques, graph, subset, - as.numeric(min), as.numeric(max) + R_igraph_maximal_cliques, + graph, + subset, + as.numeric(min), + as.numeric(max) ) res <- lapply(res, function(x) x + 1) @@ -281,8 +325,7 @@ max_cliques <- function(graph, min = NULL, max = NULL, subset = NULL, file = NUL #' @rdname cliques #' @export -count_max_cliques <- function(graph, min = NULL, max = NULL, - subset = NULL) { +count_max_cliques <- function(graph, min = NULL, max = NULL, subset = NULL) { # Argument checks ensure_igraph(graph) @@ -450,7 +493,9 @@ ivs <- function(graph, min = NULL, max = NULL) { on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_independent_vertex_sets, graph, as.numeric(min), + R_igraph_independent_vertex_sets, + graph, + as.numeric(min), as.numeric(max) ) res <- lapply(res, `+`, 1) From e4cdf7f5e5e7051c40658445745891c68affcde9 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:44:46 +0200 Subject: [PATCH 05/59] cocitation --- R/cocitation.R | 2 -- 1 file changed, 2 deletions(-) diff --git a/R/cocitation.R b/R/cocitation.R index a98ef4a367f..885fdab879d 100644 --- a/R/cocitation.R +++ b/R/cocitation.R @@ -19,8 +19,6 @@ # ################################################################### - - #' Cocitation coupling #' #' Two vertices are cocited if there is another vertex citing both of them. From 5cfbcd1b2241a74d1233d7abffffbc9689b8a2fa Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:45:22 +0200 Subject: [PATCH 06/59] cohesive.blocks --- R/cohesive.blocks.R | 115 ++++++++++++++++++++++++++++++-------------- 1 file changed, 78 insertions(+), 37 deletions(-) diff --git a/R/cohesive.blocks.R b/R/cohesive.blocks.R index 83f3e1fa614..1a68ba66b98 100644 --- a/R/cohesive.blocks.R +++ b/R/cohesive.blocks.R @@ -8,9 +8,15 @@ #' @inheritParams export_pajek #' @keywords internal #' @export -exportPajek <- function(blocks, graph, file, project.file = TRUE) { # nocov start +exportPajek <- function(blocks, graph, file, project.file = TRUE) { + # nocov start lifecycle::deprecate_soft("2.0.0", "exportPajek()", "export_pajek()") - export_pajek(blocks = blocks, graph = graph, file = file, project.file = project.file) + export_pajek( + blocks = blocks, + graph = graph, + file = file, + project.file = project.file + ) } # nocov end #' Calculate Cohesive Blocks @@ -23,7 +29,12 @@ exportPajek <- function(blocks, graph, file, project.file = TRUE) { # nocov star #' @inheritParams plot_hierarchy #' @keywords internal #' @export -plotHierarchy <- function(blocks, layout = layout_as_tree(hierarchy(blocks), root = 1), ...) { # nocov start +plotHierarchy <- function( + blocks, + layout = layout_as_tree(hierarchy(blocks), root = 1), + ... +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "plotHierarchy()", "plot_hierarchy()") plot_hierarchy(blocks = blocks, layout = layout, ...) } # nocov end @@ -38,7 +49,8 @@ plotHierarchy <- function(blocks, layout = layout_as_tree(hierarchy(blocks), roo #' @inheritParams max_cohesion #' @keywords internal #' @export -maxcohesion <- function(blocks) { # nocov start +maxcohesion <- function(blocks) { + # nocov start lifecycle::deprecate_soft("2.0.0", "maxcohesion()", "max_cohesion()") max_cohesion(blocks = blocks) } # nocov end @@ -54,7 +66,8 @@ maxcohesion <- function(blocks) { # nocov start #' @param ... passed to `cohesion()` #' @keywords internal #' @export -graph.cohesion <- function(x, ...) { # nocov start +graph.cohesion <- function(x, ...) { + # nocov start lifecycle::deprecate_soft("2.0.0", "graph.cohesion()", "cohesion()") cohesion(x = x, ...) } # nocov end @@ -69,7 +82,8 @@ graph.cohesion <- function(x, ...) { # nocov start #' @inheritParams cohesive_blocks #' @keywords internal #' @export -cohesive.blocks <- function(graph, labels = TRUE) { # nocov start +cohesive.blocks <- function(graph, labels = TRUE) { + # nocov start lifecycle::deprecate_soft("2.0.0", "cohesive.blocks()", "cohesive_blocks()") cohesive_blocks(graph = graph, labels = labels) } # nocov end @@ -84,8 +98,13 @@ cohesive.blocks <- function(graph, labels = TRUE) { # nocov start #' @inheritParams graphs_from_cohesive_blocks #' @keywords internal #' @export -blockGraphs <- function(blocks, graph) { # nocov start - lifecycle::deprecate_soft("2.0.0", "blockGraphs()", "graphs_from_cohesive_blocks()") +blockGraphs <- function(blocks, graph) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "blockGraphs()", + "graphs_from_cohesive_blocks()" + ) graphs_from_cohesive_blocks(blocks = blocks, graph = graph) } # nocov end # IGraph R package @@ -109,8 +128,6 @@ blockGraphs <- function(blocks, graph) { # nocov start # ################################################################### - - #' Calculate Cohesive Blocks #' #' Calculates cohesive blocks for objects of class `igraph`. @@ -346,7 +363,12 @@ cohesive_blocks <- function(graph, labels = TRUE) { res$labels <- V(graph)$name } if (igraph_opt("return.vs.es")) { - res$blocks <- lapply(res$blocks, unsafe_create_vs, graph = graph, verts = V(graph)) + res$blocks <- lapply( + res$blocks, + unsafe_create_vs, + graph = graph, + verts = V(graph) + ) } res$vcount <- vcount(graph) @@ -408,7 +430,9 @@ print.cohesiveBlocks <- function(x, ...) { pp <- parent(x) si <- sapply(myb, length) - cs <- 3 + 2 + nchar(length(x)) + + cs <- 3 + + 2 + + nchar(length(x)) + max(distances(hierarchy(x), mode = "out", v = 1)) * 3 .plot <- function(b, ind = "") { @@ -419,9 +443,12 @@ print.cohesiveBlocks <- function(x, ...) { he <- format(paste(sep = "", "B-", b), width = cs) } cat( - sep = "", he, - "c ", format(ch[b], width = nchar(max(ch)), justify = "right"), - ", n ", format(si[b], width = nchar(x$vcount), justify = "right") + sep = "", + he, + "c ", + format(ch[b], width = nchar(max(ch)), justify = "right"), + ", n ", + format(si[b], width = nchar(x$vcount), justify = "right") ) if (x$vcount <= options("width")$width - 40 && b != 1) { @@ -442,7 +469,11 @@ print.cohesiveBlocks <- function(x, ...) { wc <- which(pp == b) sapply(wc, .plot, ind = ind) } - if (length(x) > 0) .plot(1) else cat("No cohesive blocks found.") + if (length(x) > 0) { + .plot(1) + } else { + cat("No cohesive blocks found.") + } invisible(x) } @@ -454,7 +485,8 @@ print.cohesiveBlocks <- function(x, ...) { summary.cohesiveBlocks <- function(object, ...) { cat( "Structurally cohesive block structure, with", - length(blocks(object)), "blocks.\n" + length(blocks(object)), + "blocks.\n" ) invisible(object) } @@ -464,24 +496,25 @@ summary.cohesiveBlocks <- function(object, ...) { #' @export #' @importFrom grDevices rainbow #' @importFrom graphics plot -plot.cohesiveBlocks <- function(x, y, - colbar = rainbow(max(cohesion(x)) + 1), - col = colbar[max_cohesion(x) + 1], - mark.groups = blocks(x)[-1], - ...) { - plot(y, - mark.groups = mark.groups, - vertex.color = col, ... - ) +plot.cohesiveBlocks <- function( + x, + y, + colbar = rainbow(max(cohesion(x)) + 1), + col = colbar[max_cohesion(x) + 1], + mark.groups = blocks(x)[-1], + ... +) { + plot(y, mark.groups = mark.groups, vertex.color = col, ...) } #' @rdname cohesive_blocks #' @export #' @importFrom graphics plot -plot_hierarchy <- function(blocks, - layout = layout_as_tree(hierarchy(blocks), - root = 1 - ), ...) { +plot_hierarchy <- function( + blocks, + layout = layout_as_tree(hierarchy(blocks), root = 1), + ... +) { plot(hierarchy(blocks), layout = layout, ...) } @@ -510,8 +543,14 @@ exportPajek.cohesiveblocks.pf <- function(blocks, graph, file) { thisb <- rep(0, vcount(graph)) thisb[myb[[b]]] <- 1 cat( - file = file, sep = "", "\r\n*Partition block_", b, ".clu\r\n", - "*Vertices ", vcount(graph), "\r\n " + file = file, + sep = "", + "\r\n*Partition block_", + b, + ".clu\r\n", + "*Vertices ", + vcount(graph), + "\r\n " ) cat(thisb, sep = "\r\n ", file = file) } @@ -527,7 +566,8 @@ exportPajek.cohesiveblocks.nopf <- function(blocks, graph, file) { write_graph(graph, file = paste(sep = "", file, ".net"), format = "pajek") ## The hierarchy graph - write_graph(hierarchy(blocks), + write_graph( + hierarchy(blocks), file = paste(sep = "", file, "_hierarchy.net"), format = "pajek" ) @@ -538,8 +578,10 @@ exportPajek.cohesiveblocks.nopf <- function(blocks, graph, file) { thisb <- rep(0, vcount(graph)) thisb[myb[[b]]] <- 1 cat( - file = paste(sep = "", file, "_block_", b, ".clu"), sep = "\r\n", - paste("*Vertices", vcount(graph)), thisb + file = paste(sep = "", file, "_block_", b, ".clu"), + sep = "\r\n", + paste("*Vertices", vcount(graph)), + thisb ) } @@ -548,8 +590,7 @@ exportPajek.cohesiveblocks.nopf <- function(blocks, graph, file) { #' @rdname cohesive_blocks #' @export -export_pajek <- function(blocks, graph, file, - project.file = TRUE) { +export_pajek <- function(blocks, graph, file, project.file = TRUE) { if (!project.file && !is.character(file)) { stop(paste( "`file' must be a filename (without extension) when writing", From 11ee6808d36c3923979fda1befd3a5b858cab4b9 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:46:04 +0200 Subject: [PATCH 07/59] community --- R/community.R | 843 +++++++++++++++++++++++++++++++++++++------------- 1 file changed, 624 insertions(+), 219 deletions(-) diff --git a/R/community.R b/R/community.R index fafae87c268..3772633e299 100644 --- a/R/community.R +++ b/R/community.R @@ -8,9 +8,22 @@ #' @inheritParams make_clusters #' @keywords internal #' @export -create.communities <- function(graph, membership = NULL, algorithm = NULL, merges = NULL, modularity = TRUE) { # nocov start +create.communities <- function( + graph, + membership = NULL, + algorithm = NULL, + merges = NULL, + modularity = TRUE +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "create.communities()", "make_clusters()") - make_clusters(graph = graph, membership = membership, algorithm = algorithm, merges = merges, modularity = modularity) + make_clusters( + graph = graph, + membership = membership, + algorithm = algorithm, + merges = merges, + modularity = modularity + ) } # nocov end #' Community structure via short random walks @@ -23,9 +36,28 @@ create.communities <- function(graph, membership = NULL, algorithm = NULL, merge #' @inheritParams cluster_walktrap #' @keywords internal #' @export -walktrap.community <- function(graph, weights = NULL, steps = 4, merges = TRUE, modularity = TRUE, membership = TRUE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "walktrap.community()", "cluster_walktrap()") - cluster_walktrap(graph = graph, weights = weights, steps = steps, merges = merges, modularity = modularity, membership = membership) +walktrap.community <- function( + graph, + weights = NULL, + steps = 4, + merges = TRUE, + modularity = TRUE, + membership = TRUE +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "walktrap.community()", + "cluster_walktrap()" + ) + cluster_walktrap( + graph = graph, + weights = weights, + steps = steps, + merges = merges, + modularity = modularity, + membership = membership + ) } # nocov end #' Finding communities in graphs based on statistical meachanics @@ -38,9 +70,40 @@ walktrap.community <- function(graph, weights = NULL, steps = 4, merges = TRUE, #' @inheritParams cluster_spinglass #' @keywords internal #' @export -spinglass.community <- function(graph, weights = NULL, vertex = NULL, spins = 25, parupdate = FALSE, start.temp = 1, stop.temp = 0.01, cool.fact = 0.99, update.rule = c("config", "random", "simple"), gamma = 1.0, implementation = c("orig", "neg"), gamma.minus = 1.0) { # nocov start - lifecycle::deprecate_soft("2.0.0", "spinglass.community()", "cluster_spinglass()") - cluster_spinglass(graph = graph, weights = weights, vertex = vertex, spins = spins, parupdate = parupdate, start.temp = start.temp, stop.temp = stop.temp, cool.fact = cool.fact, update.rule = update.rule, gamma = gamma, implementation = implementation, gamma.minus = gamma.minus) +spinglass.community <- function( + graph, + weights = NULL, + vertex = NULL, + spins = 25, + parupdate = FALSE, + start.temp = 1, + stop.temp = 0.01, + cool.fact = 0.99, + update.rule = c("config", "random", "simple"), + gamma = 1.0, + implementation = c("orig", "neg"), + gamma.minus = 1.0 +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "spinglass.community()", + "cluster_spinglass()" + ) + cluster_spinglass( + graph = graph, + weights = weights, + vertex = vertex, + spins = spins, + parupdate = parupdate, + start.temp = start.temp, + stop.temp = stop.temp, + cool.fact = cool.fact, + update.rule = update.rule, + gamma = gamma, + implementation = implementation, + gamma.minus = gamma.minus + ) } # nocov end #' Functions to deal with the result of network community detection @@ -53,7 +116,8 @@ spinglass.community <- function(graph, weights = NULL, vertex = NULL, spins = 25 #' @inheritParams show_trace #' @keywords internal #' @export -showtrace <- function(communities) { # nocov start +showtrace <- function(communities) { + # nocov start lifecycle::deprecate_soft("2.0.0", "showtrace()", "show_trace()") show_trace(communities = communities) } # nocov end @@ -68,7 +132,8 @@ showtrace <- function(communities) { # nocov start #' @inheritParams cluster_optimal #' @keywords internal #' @export -optimal.community <- function(graph, weights = NULL) { # nocov start +optimal.community <- function(graph, weights = NULL) { + # nocov start lifecycle::deprecate_soft("2.0.0", "optimal.community()", "cluster_optimal()") cluster_optimal(graph = graph, weights = weights) } # nocov end @@ -83,8 +148,13 @@ optimal.community <- function(graph, weights = NULL) { # nocov start #' @inheritParams cluster_louvain #' @keywords internal #' @export -multilevel.community <- function(graph, weights = NULL, resolution = 1) { # nocov start - lifecycle::deprecate_soft("2.0.0", "multilevel.community()", "cluster_louvain()") +multilevel.community <- function(graph, weights = NULL, resolution = 1) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "multilevel.community()", + "cluster_louvain()" + ) cluster_louvain(graph = graph, weights = weights, resolution = resolution) } # nocov end @@ -98,9 +168,22 @@ multilevel.community <- function(graph, weights = NULL, resolution = 1) { # noco #' @inheritParams modularity_matrix #' @keywords internal #' @export -mod.matrix <- function(graph, membership, weights = NULL, resolution = 1, directed = TRUE) { # nocov start +mod.matrix <- function( + graph, + membership, + weights = NULL, + resolution = 1, + directed = TRUE +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "mod.matrix()", "modularity_matrix()") - modularity_matrix(graph = graph, membership = membership, weights = weights, resolution = resolution, directed = directed) + modularity_matrix( + graph = graph, + membership = membership, + weights = weights, + resolution = resolution, + directed = directed + ) } # nocov end #' Community structure detecting based on the leading eigenvector of the community matrix @@ -113,9 +196,32 @@ mod.matrix <- function(graph, membership, weights = NULL, resolution = 1, direct #' @inheritParams cluster_leading_eigen #' @keywords internal #' @export -leading.eigenvector.community <- function(graph, steps = -1, weights = NULL, start = NULL, options = arpack_defaults(), callback = NULL, extra = NULL, env = parent.frame()) { # nocov start - lifecycle::deprecate_soft("2.0.0", "leading.eigenvector.community()", "cluster_leading_eigen()") - cluster_leading_eigen(graph = graph, steps = steps, weights = weights, start = start, options = options, callback = callback, extra = extra, env = env) +leading.eigenvector.community <- function( + graph, + steps = -1, + weights = NULL, + start = NULL, + options = arpack_defaults(), + callback = NULL, + extra = NULL, + env = parent.frame() +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "leading.eigenvector.community()", + "cluster_leading_eigen()" + ) + cluster_leading_eigen( + graph = graph, + steps = steps, + weights = weights, + start = start, + options = options, + callback = callback, + extra = extra, + env = env + ) } # nocov end #' Finding communities based on propagating labels @@ -128,9 +234,28 @@ leading.eigenvector.community <- function(graph, steps = -1, weights = NULL, sta #' @inheritParams cluster_label_prop #' @keywords internal #' @export -label.propagation.community <- function(graph, weights = NULL, ..., mode = c("out", "in", "all"), initial = NULL, fixed = NULL) { # nocov start - lifecycle::deprecate_soft("2.0.0", "label.propagation.community()", "cluster_label_prop()") - cluster_label_prop(graph = graph, weights = weights, mode = mode, initial = initial, fixed = fixed, ...) +label.propagation.community <- function( + graph, + weights = NULL, + ..., + mode = c("out", "in", "all"), + initial = NULL, + fixed = NULL +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "label.propagation.community()", + "cluster_label_prop()" + ) + cluster_label_prop( + graph = graph, + weights = weights, + mode = mode, + initial = initial, + fixed = fixed, + ... + ) } # nocov end #' Functions to deal with the result of network community detection @@ -143,7 +268,8 @@ label.propagation.community <- function(graph, weights = NULL, ..., mode = c("ou #' @inheritParams is_hierarchical #' @keywords internal #' @export -is.hierarchical <- function(communities) { # nocov start +is.hierarchical <- function(communities) { + # nocov start lifecycle::deprecate_soft("2.0.0", "is.hierarchical()", "is_hierarchical()") is_hierarchical(communities = communities) } # nocov end @@ -158,9 +284,22 @@ is.hierarchical <- function(communities) { # nocov start #' @inheritParams cluster_infomap #' @keywords internal #' @export -infomap.community <- function(graph, e.weights = NULL, v.weights = NULL, nb.trials = 10, modularity = TRUE) { # nocov start +infomap.community <- function( + graph, + e.weights = NULL, + v.weights = NULL, + nb.trials = 10, + modularity = TRUE +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "infomap.community()", "cluster_infomap()") - cluster_infomap(graph = graph, e.weights = e.weights, v.weights = v.weights, nb.trials = nb.trials, modularity = modularity) + cluster_infomap( + graph = graph, + e.weights = e.weights, + v.weights = v.weights, + nb.trials = nb.trials, + modularity = modularity + ) } # nocov end #' Community structure via greedy optimization of modularity @@ -173,9 +312,26 @@ infomap.community <- function(graph, e.weights = NULL, v.weights = NULL, nb.tria #' @inheritParams cluster_fast_greedy #' @keywords internal #' @export -fastgreedy.community <- function(graph, merges = TRUE, modularity = TRUE, membership = TRUE, weights = NULL) { # nocov start - lifecycle::deprecate_soft("2.0.0", "fastgreedy.community()", "cluster_fast_greedy()") - cluster_fast_greedy(graph = graph, merges = merges, modularity = modularity, membership = membership, weights = weights) +fastgreedy.community <- function( + graph, + merges = TRUE, + modularity = TRUE, + membership = TRUE, + weights = NULL +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "fastgreedy.community()", + "cluster_fast_greedy()" + ) + cluster_fast_greedy( + graph = graph, + merges = merges, + modularity = modularity, + membership = membership, + weights = weights + ) } # nocov end #' Community structure detection based on edge betweenness @@ -188,9 +344,32 @@ fastgreedy.community <- function(graph, merges = TRUE, modularity = TRUE, member #' @inheritParams cluster_edge_betweenness #' @keywords internal #' @export -edge.betweenness.community <- function(graph, weights = NULL, directed = TRUE, edge.betweenness = TRUE, merges = TRUE, bridges = TRUE, modularity = TRUE, membership = TRUE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "edge.betweenness.community()", "cluster_edge_betweenness()") - cluster_edge_betweenness(graph = graph, weights = weights, directed = directed, edge.betweenness = edge.betweenness, merges = merges, bridges = bridges, modularity = modularity, membership = membership) +edge.betweenness.community <- function( + graph, + weights = NULL, + directed = TRUE, + edge.betweenness = TRUE, + merges = TRUE, + bridges = TRUE, + modularity = TRUE, + membership = TRUE +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "edge.betweenness.community()", + "cluster_edge_betweenness()" + ) + cluster_edge_betweenness( + graph = graph, + weights = weights, + directed = directed, + edge.betweenness = edge.betweenness, + merges = merges, + bridges = bridges, + modularity = modularity, + membership = membership + ) } # nocov end #' Community structure dendrogram plots @@ -203,7 +382,8 @@ edge.betweenness.community <- function(graph, weights = NULL, directed = TRUE, e #' @inheritParams plot_dendrogram #' @keywords internal #' @export -dendPlot <- function(x, mode = igraph_opt("dend.plot.type"), ...) { # nocov start +dendPlot <- function(x, mode = igraph_opt("dend.plot.type"), ...) { + # nocov start lifecycle::deprecate_soft("2.0.0", "dendPlot()", "plot_dendrogram()") plot_dendrogram(x = x, mode = mode, ...) } # nocov end @@ -218,7 +398,8 @@ dendPlot <- function(x, mode = igraph_opt("dend.plot.type"), ...) { # nocov star #' @inheritParams cut_at #' @keywords internal #' @export -cutat <- function(communities, no, steps) { # nocov start +cutat <- function(communities, no, steps) { + # nocov start lifecycle::deprecate_soft("2.0.0", "cutat()", "cut_at()") cut_at(communities = communities, no = no, steps = steps) } # nocov end @@ -233,9 +414,18 @@ cutat <- function(communities, no, steps) { # nocov start #' @inheritParams contract #' @keywords internal #' @export -contract.vertices <- function(graph, mapping, vertex.attr.comb = igraph_opt("vertex.attr.comb")) { # nocov start +contract.vertices <- function( + graph, + mapping, + vertex.attr.comb = igraph_opt("vertex.attr.comb") +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "contract.vertices()", "contract()") - contract(graph = graph, mapping = mapping, vertex.attr.comb = vertex.attr.comb) + contract( + graph = graph, + mapping = mapping, + vertex.attr.comb = vertex.attr.comb + ) } # nocov end #' Functions to deal with the result of network community detection @@ -248,7 +438,8 @@ contract.vertices <- function(graph, mapping, vertex.attr.comb = igraph_opt("ver #' @inheritParams code_len #' @keywords internal #' @export -code.length <- function(communities) { # nocov start +code.length <- function(communities) { + # nocov start lifecycle::deprecate_soft("2.0.0", "code.length()", "code_len()") code_len(communities = communities) } # nocov end @@ -461,10 +652,13 @@ code.length <- function(communities) { # nocov start membership <- function(communities) { if (!is.null(communities$membership)) { res <- communities$membership - } else if (!is.null(communities$merges) && - !is.null(communities$modularity)) { + } else if ( + !is.null(communities$merges) && + !is.null(communities$modularity) + ) { res <- community.to.membership2( - communities$merges, communities$vcount, + communities$merges, + communities$vcount, which.max(communities$modularity) ) } else { @@ -514,13 +708,23 @@ print.communities <- function(x, ...) { } alg <- x$algorithm %||% "unknown" - cat("IGRAPH clustering ", alg, ", groups: ", noc, ", mod: ", mod, "\n", sep = "") + cat( + "IGRAPH clustering ", + alg, + ", groups: ", + noc, + ", mod: ", + mod, + "\n", + sep = "" + ) if (!is.null(x$membership)) { grp <- groups(x) cat("+ groups:\n") hp <- function(o) { - head_print(o, + head_print( + o, max_lines = igraph_opt("auto.print.lines"), omitted_footer = "+ ... omitted several groups/vertices\n", ) @@ -566,17 +770,28 @@ print.communities <- function(x, ...) { #' } #' @family community #' @export -make_clusters <- function(graph, membership = NULL, algorithm = NULL, - merges = NULL, modularity = TRUE) { +make_clusters <- function( + graph, + membership = NULL, + algorithm = NULL, + merges = NULL, + modularity = TRUE +) { stopifnot(is.null(membership) || is.numeric(membership)) - stopifnot(is.null(algorithm) || - (is.character(algorithm) && length(algorithm) == 1)) - stopifnot(is.null(merges) || - (is.matrix(merges) && is.numeric(merges) && ncol(merges) == 2)) - stopifnot(is.null(modularity) || - (is.logical(modularity) && length(modularity) == 1) || - (is.numeric(modularity) && - length(modularity) %in% c(1, length(membership)))) + stopifnot( + is.null(algorithm) || + (is.character(algorithm) && length(algorithm) == 1) + ) + stopifnot( + is.null(merges) || + (is.matrix(merges) && is.numeric(merges) && ncol(merges) == 2) + ) + stopifnot( + is.null(modularity) || + (is.logical(modularity) && length(modularity) == 1) || + (is.numeric(modularity) && + length(modularity) %in% c(1, length(membership))) + ) if (is.logical(modularity)) { if (modularity && !is.null(membership)) { @@ -688,20 +903,38 @@ modularity <- function(x, ...) { #' modularity(wtc) #' modularity(g, membership(wtc)) #' -modularity.igraph <- function(x, membership, weights = NULL, resolution = 1, directed = TRUE, ...) { +modularity.igraph <- function( + x, + membership, + weights = NULL, + resolution = 1, + directed = TRUE, + ... +) { # Argument checks ensure_igraph(x) - if (is.null(membership) || (!is.numeric(membership) && !is.factor(membership))) { + if ( + is.null(membership) || (!is.numeric(membership) && !is.factor(membership)) + ) { cli::cli_abort("Membership is not a numerical vector") } membership <- as.numeric(membership) - if (!is.null(weights)) weights <- as.numeric(weights) + if (!is.null(weights)) { + weights <- as.numeric(weights) + } resolution <- as.numeric(resolution) directed <- as.logical(directed) on.exit(.Call(R_igraph_finalizer)) # Function call - res <- .Call(R_igraph_modularity, x, membership - 1, weights, resolution, directed) + res <- .Call( + R_igraph_modularity, + x, + membership - 1, + weights, + resolution, + directed + ) res } @@ -712,18 +945,29 @@ modularity.communities <- function(x, ...) { if (!is.null(x$modularity)) { max(x$modularity) } else { - cli::cli_abort("cluster algorithm was run with {.arg modularity = FALSE} and no modularity value was computed.") + cli::cli_abort( + "cluster algorithm was run with {.arg modularity = FALSE} and no modularity value was computed." + ) } } #' @rdname modularity.igraph #' @export -modularity_matrix <- function(graph, membership = lifecycle::deprecated(), weights = NULL, resolution = 1, directed = TRUE) { +modularity_matrix <- function( + graph, + membership = lifecycle::deprecated(), + weights = NULL, + resolution = 1, + directed = TRUE +) { # Argument checks ensure_igraph(graph) if (!missing(membership)) { - lifecycle::deprecate_warn("2.1.0", "modularity_matrix(membership = 'is no longer used')") + lifecycle::deprecate_warn( + "2.1.0", + "modularity_matrix(membership = 'is no longer used')" + ) } if (is.null(weights) && "weight" %in% edge_attr_names(graph)) { @@ -826,8 +1070,12 @@ complete.dend <- function(comm, use.modularity) { #' @importFrom stats as.dendrogram #' @method as.dendrogram communities #' @export -as.dendrogram.communities <- function(object, hang = -1, use.modularity = FALSE, - ...) { +as.dendrogram.communities <- function( + object, + hang = -1, + use.modularity = FALSE, + ... +) { if (!is_hierarchical(object)) { cli::cli_abort("Not a hierarchical community structure") } @@ -869,7 +1117,8 @@ as.dendrogram.communities <- function(object, hang = -1, use.modularity = FALSE, if (any(neg <- x < leafs + 1)) { h0 <- if (hang < 0) 0 else max(0, oHgt[k] - hang * hMax) } - if (all(neg)) { # two leaves + if (all(neg)) { + # two leaves zk <- as.list(x) attr(zk, "members") <- two attr(zk, "midpoint") <- 0.5 # mean( c(0,1) ) @@ -879,7 +1128,8 @@ as.dendrogram.communities <- function(object, hang = -1, use.modularity = FALSE, attr(zk[[1]], "members") <- attr(zk[[2]], "members") <- one attr(zk[[1]], "height") <- attr(zk[[2]], "height") <- h0 attr(zk[[1]], "leaf") <- attr(zk[[2]], "leaf") <- TRUE - } else if (any(neg)) { # one leaf, one node + } else if (any(neg)) { + # one leaf, one node # as.character(x) is not okay as it starts converting values >= 100000 # to scientific notation X <- format(x, scientific = FALSE, trim = TRUE) @@ -899,7 +1149,8 @@ as.dendrogram.communities <- function(object, hang = -1, use.modularity = FALSE, attr(zk[[2 - isL]], "height") <- h0 attr(zk[[2 - isL]], "label") <- object$names[x[2 - isL]] attr(zk[[2 - isL]], "leaf") <- TRUE - } else { # two nodes + } else { + # two nodes # as.character(x) is not okay as it starts converting values >= 100000 # to scientific notation x <- format(x, scientific = FALSE, trim = TRUE) @@ -908,7 +1159,8 @@ as.dendrogram.communities <- function(object, hang = -1, use.modularity = FALSE, attr(z[[x[2]]], "members") attr(zk, "midpoint") <- (attr(z[[x[1]]], "members") + attr(z[[x[1]]], "midpoint") + - attr(z[[x[2]]], "midpoint")) / 2 + attr(z[[x[2]]], "midpoint")) / + 2 } attr(zk, "height") <- oHgt[k] z[[k <- format(k + leafs, scientific = FALSE)]] <- zk @@ -922,8 +1174,7 @@ as.dendrogram.communities <- function(object, hang = -1, use.modularity = FALSE, #' @importFrom stats as.hclust #' @method as.hclust communities #' @export -as.hclust.communities <- function(x, hang = -1, use.modularity = FALSE, - ...) { +as.hclust.communities <- function(x, hang = -1, use.modularity = FALSE, ...) { as.hclust(as.dendrogram(x, hang = hang, use.modularity = use.modularity)) } @@ -973,7 +1224,9 @@ as.phylo.communities <- function(x, use.modularity = FALSE, ...) { } obj <- list( - edge = edge, edge.length = edge.length / 2, tip.label = labels, + edge = edge, + edge.length = edge.length / 2, + tip.label = labels, Nnode = N ) class(obj) <- "phylo" @@ -990,8 +1243,10 @@ cut_at <- function(communities, no, steps) { cli::cli_abort("Not a hierarchical communitity structure") } - if ((!missing(no) && !missing(steps)) || - (missing(no) && missing(steps))) { + if ( + (!missing(no) && !missing(steps)) || + (missing(no) && missing(steps)) + ) { cli::cli_abort("Please use either {.arg no} or {.arg steps} (but not both)") } @@ -1027,24 +1282,31 @@ show_trace <- function(communities) { res <- character() i <- 1 while (i <= length(communities$history)) { - if (communities$history[i] == 2) { # IGRAPH_LEVC_HIST_SPLIT + if (communities$history[i] == 2) { + # IGRAPH_LEVC_HIST_SPLIT resnew <- paste( - "Splitting community", communities$history[i + 1], + "Splitting community", + communities$history[i + 1], "into two." ) i <- i + 2 - } else if (communities$history[i] == 3) { # IGRAPH_LEVC_HIST_FAILED + } else if (communities$history[i] == 3) { + # IGRAPH_LEVC_HIST_FAILED resnew <- paste( "Failed splitting community", - communities$history[i + 1], "into two." + communities$history[i + 1], + "into two." ) i <- i + 2 - } else if (communities$history[i] == 4) { # IGRAPH_LEVC_START_FULL + } else if (communities$history[i] == 4) { + # IGRAPH_LEVC_START_FULL resnew <- "Starting with the whole graph as a community." i <- i + 1 - } else if (communities$history[i] == 5) { # IGRAPH_LEVC_START_GIVEN + } else if (communities$history[i] == 5) { + # IGRAPH_LEVC_START_GIVEN resnew <- paste( - "Starting from the", communities$history[i + 1], + "Starting from the", + communities$history[i + 1], "given communities." ) i <- i + 2 @@ -1068,8 +1330,6 @@ community.to.membership2 <- function(merges, vcount, steps) { ##################################################################### - - #' Finding communities in graphs based on statistical meachanics #' #' This function tries to find communities in graphs via a spin-glass model and @@ -1194,12 +1454,20 @@ community.to.membership2 <- function(merges, vcount, steps) { #' cluster_spinglass(g, spins = 2) #' cluster_spinglass(g, vertex = 1) #' -cluster_spinglass <- function(graph, weights = NULL, vertex = NULL, spins = 25, - parupdate = FALSE, start.temp = 1, - stop.temp = 0.01, cool.fact = 0.99, - update.rule = c("config", "random", "simple"), - gamma = 1.0, implementation = c("orig", "neg"), - gamma.minus = 1.0) { +cluster_spinglass <- function( + graph, + weights = NULL, + vertex = NULL, + spins = 25, + parupdate = FALSE, + start.temp = 1, + stop.temp = 0.01, + cool.fact = 0.99, + update.rule = c("config", "random", "simple"), + gamma = 1.0, + implementation = c("orig", "neg"), + gamma.minus = 1.0 +) { ensure_igraph(graph) if (is.null(weights) && "weight" %in% edge_attr_names(graph)) { @@ -1212,12 +1480,9 @@ cluster_spinglass <- function(graph, weights = NULL, vertex = NULL, spins = 25, } update.rule <- igraph.match.arg(update.rule) - update.rule <- switch(update.rule, - "simple" = 0, - "random" = 0, - "config" = 1 - ) - implementation <- switch(igraph.match.arg(implementation), + update.rule <- switch(update.rule, "simple" = 0, "random" = 0, "config" = 1) + implementation <- switch( + igraph.match.arg(implementation), "orig" = 0, "neg" = 1 ) @@ -1225,12 +1490,18 @@ cluster_spinglass <- function(graph, weights = NULL, vertex = NULL, spins = 25, on.exit(.Call(R_igraph_finalizer)) if (is.null(vertex) || length(vertex) == 0) { res <- .Call( - R_igraph_spinglass_community, graph, weights, - as.numeric(spins), as.logical(parupdate), + R_igraph_spinglass_community, + graph, + weights, + as.numeric(spins), + as.logical(parupdate), as.numeric(start.temp), - as.numeric(stop.temp), as.numeric(cool.fact), - as.numeric(update.rule), as.numeric(gamma), - as.numeric(implementation), as.numeric(gamma.minus) + as.numeric(stop.temp), + as.numeric(cool.fact), + as.numeric(update.rule), + as.numeric(gamma), + as.numeric(implementation), + as.numeric(gamma.minus) ) res$algorithm <- "spinglass" res$vcount <- vcount(graph) @@ -1241,9 +1512,13 @@ cluster_spinglass <- function(graph, weights = NULL, vertex = NULL, spins = 25, class(res) <- "communities" } else { res <- .Call( - R_igraph_spinglass_my_community, graph, weights, - as_igraph_vs(graph, vertex) - 1, as.numeric(spins), - as.numeric(update.rule), as.numeric(gamma) + R_igraph_spinglass_my_community, + graph, + weights, + as_igraph_vs(graph, vertex) - 1, + as.numeric(spins), + as.numeric(update.rule), + as.numeric(gamma) ) res$community <- res$community + 1 } @@ -1355,12 +1630,18 @@ cluster_spinglass <- function(graph, weights = NULL, vertex = NULL, spins = 25, #' ldc <- cluster_leiden(g, resolution = r) #' print(ldc) #' plot(ldc, g) -cluster_leiden <- function(graph, objective_function = c("CPM", "modularity"), - ..., - weights = NULL, resolution = 1, - resolution_parameter = deprecated(), beta = 0.01, - initial_membership = NULL, - n_iterations = 2, vertex_weights = NULL) { +cluster_leiden <- function( + graph, + objective_function = c("CPM", "modularity"), + ..., + weights = NULL, + resolution = 1, + resolution_parameter = deprecated(), + beta = 0.01, + initial_membership = NULL, + n_iterations = 2, + vertex_weights = NULL +) { check_dots_empty() if (lifecycle::is_present(resolution_parameter)) { @@ -1376,10 +1657,7 @@ cluster_leiden <- function(graph, objective_function = c("CPM", "modularity"), # Parse objective function argument objective_function <- igraph.match.arg(objective_function) - objective_function <- switch(objective_function, - "cpm" = 0, - "modularity" = 1 - ) + objective_function <- switch(objective_function, "cpm" = 0, "modularity" = 1) # Parse edge weights argument if (is.null(weights) && "weight" %in% edge_attr_names(graph)) { @@ -1401,11 +1679,13 @@ cluster_leiden <- function(graph, objective_function = c("CPM", "modularity"), # Parse node weights argument if (!is.null(vertex_weights) && !any(is.na(vertex_weights))) { vertex_weights <- as.numeric(vertex_weights) - if (objective_function == 1) { # Using modularity + if (objective_function == 1) { + # Using modularity cli::cli_warn("Providing node weights contradicts using modularity.") } } else { - if (objective_function == 1) { # Using modularity + if (objective_function == 1) { + # Using modularity # Set correct node weights vertex_weights <- strength(graph, weights = weights) # Also correct resolution parameter @@ -1417,9 +1697,14 @@ cluster_leiden <- function(graph, objective_function = c("CPM", "modularity"), membership <- initial_membership if (n_iterations > 0) { res <- .Call( - R_igraph_community_leiden, graph, weights, - vertex_weights, as.numeric(resolution), - as.numeric(beta), !is.null(membership), as.numeric(n_iterations), + R_igraph_community_leiden, + graph, + weights, + vertex_weights, + as.numeric(resolution), + as.numeric(beta), + !is.null(membership), + as.numeric(n_iterations), membership ) membership <- res$membership @@ -1429,9 +1714,14 @@ cluster_leiden <- function(graph, objective_function = c("CPM", "modularity"), while (prev_quality < quality) { prev_quality <- quality res <- .Call( - R_igraph_community_leiden, graph, weights, - vertex_weights, as.numeric(resolution), - as.numeric(beta), !is.null(membership), 1, + R_igraph_community_leiden, + graph, + weights, + vertex_weights, + as.numeric(resolution), + as.numeric(beta), + !is.null(membership), + 1, membership ) membership <- res$membership @@ -1493,7 +1783,11 @@ cluster_fluid_communities <- function(graph, no.of.communities) { on.exit(.Call(R_igraph_finalizer)) # Function call - membership <- .Call(R_igraph_community_fluid_communities, graph, no.of.communities) + membership <- .Call( + R_igraph_community_fluid_communities, + graph, + no.of.communities + ) res <- list() res$membership <- membership + 1 @@ -1558,9 +1852,14 @@ cluster_fluid_communities <- function(graph, no.of.communities) { #' g <- add_edges(g, c(1, 6, 1, 11, 6, 11)) #' cluster_walktrap(g) #' -cluster_walktrap <- function(graph, weights = NULL, steps = 4, - merges = TRUE, modularity = TRUE, - membership = TRUE) { +cluster_walktrap <- function( + graph, + weights = NULL, + steps = 4, + merges = TRUE, + modularity = TRUE, + membership = TRUE +) { ensure_igraph(graph) if (membership && !modularity) { @@ -1578,8 +1877,13 @@ cluster_walktrap <- function(graph, weights = NULL, steps = 4, on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_walktrap_community, graph, weights, as.numeric(steps), - as.logical(merges), as.logical(modularity), as.logical(membership) + R_igraph_walktrap_community, + graph, + weights, + as.numeric(steps), + as.logical(merges), + as.logical(modularity), + as.logical(membership) ) if (igraph_opt("add.vertex.names") && is_named(graph)) { res$names <- V(graph)$name @@ -1598,7 +1902,6 @@ cluster_walktrap <- function(graph, weights = NULL, steps = 4, } - #' Community structure detection based on edge betweenness #' #' Community structure detection based on the betweenness of the edges @@ -1679,12 +1982,16 @@ cluster_walktrap <- function(graph, weights = NULL, steps = 4, #' eb <- cluster_edge_betweenness(g) #' eb #' -cluster_edge_betweenness <- function(graph, weights = NULL, - directed = TRUE, - edge.betweenness = TRUE, - merges = TRUE, bridges = TRUE, - modularity = TRUE, - membership = TRUE) { +cluster_edge_betweenness <- function( + graph, + weights = NULL, + directed = TRUE, + edge.betweenness = TRUE, + merges = TRUE, + bridges = TRUE, + modularity = TRUE, + membership = TRUE +) { ensure_igraph(graph) if (is.null(weights) && "weight" %in% edge_attr_names(graph)) { @@ -1698,11 +2005,15 @@ cluster_edge_betweenness <- function(graph, weights = NULL, on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_community_edge_betweenness, graph, weights, + R_igraph_community_edge_betweenness, + graph, + weights, as.logical(directed), as.logical(edge.betweenness), - as.logical(merges), as.logical(bridges), - as.logical(modularity), as.logical(membership) + as.logical(merges), + as.logical(bridges), + as.logical(modularity), + as.logical(membership) ) if (igraph_opt("add.vertex.names") && is_named(graph)) { res$names <- V(graph)$name @@ -1766,8 +2077,13 @@ cluster_edge_betweenness <- function(graph, weights = NULL, #' membership(fc) #' sizes(fc) #' -cluster_fast_greedy <- function(graph, merges = TRUE, modularity = TRUE, - membership = TRUE, weights = NULL) { +cluster_fast_greedy <- function( + graph, + merges = TRUE, + modularity = TRUE, + membership = TRUE, + weights = NULL +) { ensure_igraph(graph) if (is.null(weights) && "weight" %in% edge_attr_names(graph)) { @@ -1781,8 +2097,12 @@ cluster_fast_greedy <- function(graph, merges = TRUE, modularity = TRUE, on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_community_fastgreedy, graph, as.logical(merges), - as.logical(modularity), as.logical(membership), weights + R_igraph_community_fastgreedy, + graph, + as.logical(merges), + as.logical(modularity), + as.logical(membership), + weights ) if (igraph_opt("add.vertex.names") && is_named(graph)) { res$names <- V(graph)$name @@ -1804,7 +2124,6 @@ igraph.i.levc.arp <- function(externalP, externalE) { } - #' Community structure detecting based on the leading eigenvector of the #' community matrix #' @@ -1917,16 +2236,23 @@ igraph.i.levc.arp <- function(externalP, externalE) { #' #' cluster_leading_eigen(g, start = membership(lec)) #' -cluster_leading_eigen <- function(graph, steps = -1, weights = NULL, - start = NULL, - options = arpack_defaults(), - callback = NULL, extra = NULL, - env = parent.frame()) { +cluster_leading_eigen <- function( + graph, + steps = -1, + weights = NULL, + start = NULL, + options = arpack_defaults(), + callback = NULL, + extra = NULL, + env = parent.frame() +) { if (is.function(options)) { lifecycle::deprecate_soft( "1.6.0", "cluster_leading_eigen(options = 'must be a list')", - details = c("`arpack_defaults()` is now a function, use `options = arpack_defaults()` instead of `options = arpack_defaults`.") + details = c( + "`arpack_defaults()` is now a function, use `options = arpack_defaults()` instead of `options = arpack_defaults`." + ) ) options <- options() } @@ -1952,8 +2278,15 @@ cluster_leading_eigen <- function(graph, steps = -1, weights = NULL, on.exit(.Call(R_igraph_finalizer)) # Function call res <- .Call( - R_igraph_community_leading_eigenvector, graph, steps, - weights, options, start, callback, extra, env, + R_igraph_community_leading_eigenvector, + graph, + steps, + weights, + options, + start, + callback, + extra, + env, environment(igraph.i.levc.arp) ) if (igraph_opt("add.vertex.names") && is_named(graph)) { @@ -2034,12 +2367,13 @@ cluster_leading_eigen <- function(graph, steps = -1, weights = NULL, #' cluster_label_prop(g) #' cluster_label_prop <- function( - graph, - weights = NULL, - ..., - mode = c("out", "in", "all"), - initial = NULL, - fixed = NULL) { + graph, + weights = NULL, + ..., + mode = c("out", "in", "all"), + initial = NULL, + fixed = NULL +) { if (...length() > 0) { lifecycle::deprecate_soft( "1.6.0", @@ -2064,11 +2398,12 @@ cluster_label_prop <- function( } cluster_label_prop0 <- function( - graph, - weights = NULL, - mode = c("out", "in", "all"), - initial = NULL, - fixed = NULL) { + graph, + weights = NULL, + mode = c("out", "in", "all"), + initial = NULL, + fixed = NULL +) { # Argument checks ensure_igraph(graph) @@ -2080,23 +2415,31 @@ cluster_label_prop0 <- function( } else { weights <- NULL } - if (!is.null(initial)) initial <- as.numeric(initial) - if (!is.null(fixed)) fixed <- as.logical(fixed) + if (!is.null(initial)) { + initial <- as.numeric(initial) + } + if (!is.null(fixed)) { + fixed <- as.logical(fixed) + } - directed <- switch(igraph.match.arg(mode), + directed <- switch( + igraph.match.arg(mode), "out" = TRUE, "in" = TRUE, "all" = FALSE ) - mode <- switch(igraph.match.arg(mode), - "out" = 1L, - "in" = 2L, - "all" = 3L - ) + mode <- switch(igraph.match.arg(mode), "out" = 1L, "in" = 2L, "all" = 3L) on.exit(.Call(R_igraph_finalizer)) # Function call - membership <- .Call(R_igraph_community_label_propagation, graph, mode, weights, initial, fixed) + membership <- .Call( + R_igraph_community_label_propagation, + graph, + mode, + weights, + initial, + fixed + ) res <- list() if (igraph_opt("add.vertex.names") && is_named(graph)) { res$names <- V(graph)$name @@ -2110,7 +2453,6 @@ cluster_label_prop0 <- function( } - #' Finding community structure by multi-level optimization of modularity #' #' This function implements the multi-level modularity optimization algorithm @@ -2202,7 +2544,6 @@ cluster_louvain <- function(graph, weights = NULL, resolution = 1) { } - #' Optimal community structure #' #' This function calculates the optimal community structure of a graph, by @@ -2290,7 +2631,6 @@ cluster_optimal <- function(graph, weights = NULL) { } - #' Infomap community finding #' #' Find community structure that minimizes the expected description length of a @@ -2340,8 +2680,13 @@ cluster_optimal <- function(graph, weights = NULL) { #' membership(imc) #' communities(imc) #' -cluster_infomap <- function(graph, e.weights = NULL, v.weights = NULL, - nb.trials = 10, modularity = TRUE) { +cluster_infomap <- function( + graph, + e.weights = NULL, + v.weights = NULL, + nb.trials = 10, + modularity = TRUE +) { # Argument checks ensure_igraph(graph) @@ -2366,8 +2711,11 @@ cluster_infomap <- function(graph, e.weights = NULL, v.weights = NULL, on.exit(.Call(R_igraph_finalizer)) # Function call res <- .Call( - R_igraph_community_infomap, graph, e.weights, - v.weights, nb.trials + R_igraph_community_infomap, + graph, + e.weights, + v.weights, + nb.trials ) if (igraph_opt("add.vertex.names") && is_named(graph)) { @@ -2387,20 +2735,24 @@ cluster_infomap <- function(graph, e.weights = NULL, v.weights = NULL, #' @method plot communities #' @export #' @importFrom graphics plot -plot.communities <- function(x, y, - col = membership(x), - mark.groups = communities(x), - edge.color = c("black", "red")[crossing(x, y) + 1], - ...) { - plot(y, - vertex.color = col, mark.groups = mark.groups, +plot.communities <- function( + x, + y, + col = membership(x), + mark.groups = communities(x), + edge.color = c("black", "red")[crossing(x, y) + 1], + ... +) { + plot( + y, + vertex.color = col, + mark.groups = mark.groups, edge.color = edge.color, ... ) } - #' @rdname plot_dendrogram.communities #' @export plot_dendrogram <- function(x, mode = igraph_opt("dend.plot.type"), ...) { @@ -2408,7 +2760,6 @@ plot_dendrogram <- function(x, mode = igraph_opt("dend.plot.type"), ...) { } - #' Community structure dendrogram plots #' #' Plot a hierarchical community structure as a dendrogram. @@ -2489,10 +2840,13 @@ plot_dendrogram <- function(x, mode = igraph_opt("dend.plot.type"), ...) { #' fc <- cluster_fast_greedy(karate) #' plot_dendrogram(fc) #' -plot_dendrogram.communities <- function(x, - mode = igraph_opt("dend.plot.type"), ..., - use.modularity = FALSE, - palette = categorical_pal(8)) { +plot_dendrogram.communities <- function( + x, + mode = igraph_opt("dend.plot.type"), + ..., + use.modularity = FALSE, + palette = categorical_pal(8) +) { mode <- igraph.match.arg(mode, c("auto", "phylo", "hclust", "dendrogram")) old_palette <- palette(palette) @@ -2515,14 +2869,29 @@ plot_dendrogram.communities <- function(x, #' @importFrom grDevices palette #' @importFrom graphics plot #' @importFrom stats rect.hclust -dendPlotHclust <- function(communities, rect = length(communities), - colbar = palette(), hang = -1, ann = FALSE, - main = "", sub = "", xlab = "", ylab = "", ..., - use.modularity = FALSE) { +dendPlotHclust <- function( + communities, + rect = length(communities), + colbar = palette(), + hang = -1, + ann = FALSE, + main = "", + sub = "", + xlab = "", + ylab = "", + ..., + use.modularity = FALSE +) { hc <- as.hclust(communities, hang = hang, use.modularity = use.modularity) - ret <- plot(hc, - hang = hang, ann = ann, main = main, sub = sub, xlab = xlab, - ylab = ylab, ... + ret <- plot( + hc, + hang = hang, + ann = ann, + main = main, + sub = sub, + xlab = xlab, + ylab = ylab, + ... ) if (rect > 0) { rect.hclust(hc, k = rect, border = colbar) @@ -2531,8 +2900,12 @@ dendPlotHclust <- function(communities, rect = length(communities), } #' @importFrom graphics plot -dendPlotDendrogram <- function(communities, hang = -1, ..., - use.modularity = FALSE) { +dendPlotDendrogram <- function( + communities, + hang = -1, + ..., + use.modularity = FALSE +) { plot( as.dendrogram(communities, hang = hang, use.modularity = use.modularity), ... @@ -2541,12 +2914,16 @@ dendPlotDendrogram <- function(communities, hang = -1, ..., #' @importFrom grDevices palette #' @importFrom graphics plot -dendPlotPhylo <- function(communities, colbar = palette(), - col = colbar[membership(communities)], - mark.groups = communities(communities), - use.modularity = FALSE, - edge.color = "#AAAAAAFF", - edge.lty = c(1, 2), ...) { +dendPlotPhylo <- function( + communities, + colbar = palette(), + col = colbar[membership(communities)], + mark.groups = communities(communities), + use.modularity = FALSE, + edge.color = "#AAAAAAFF", + edge.lty = c(1, 2), + ... +) { phy <- ape::as.phylo(communities, use.modularity = use.modularity) getedges <- function(tip) { @@ -2630,33 +3007,51 @@ dendPlotPhylo <- function(communities, colbar = palette(), #' compare(sg, le, method = "rand") #' compare(membership(sg), membership(le)) #' -compare <- function(comm1, comm2, method = c( - "vi", "nmi", - "split.join", "rand", - "adjusted.rand" - )) { +compare <- function( + comm1, + comm2, + method = c( + "vi", + "nmi", + "split.join", + "rand", + "adjusted.rand" + ) +) { UseMethod("compare") } #' @method compare communities #' @family community #' @export -compare.communities <- function(comm1, comm2, - method = c( - "vi", "nmi", "split.join", "rand", - "adjusted.rand" - )) { +compare.communities <- function( + comm1, + comm2, + method = c( + "vi", + "nmi", + "split.join", + "rand", + "adjusted.rand" + ) +) { i_compare(comm1, comm2, method) } #' @method compare membership #' @family community #' @export -compare.membership <- function(comm1, comm2, - method = c( - "vi", "nmi", "split.join", "rand", - "adjusted.rand" - )) { +compare.membership <- function( + comm1, + comm2, + method = c( + "vi", + "nmi", + "split.join", + "rand", + "adjusted.rand" + ) +) { i_compare(comm1, comm2, method) } @@ -2665,10 +3060,17 @@ compare.membership <- function(comm1, comm2, #' @export compare.default <- compare.membership -i_compare <- function(comm1, comm2, method = c( - "vi", "nmi", "split.join", - "rand", "adjusted.rand" - )) { +i_compare <- function( + comm1, + comm2, + method = c( + "vi", + "nmi", + "split.join", + "rand", + "adjusted.rand" + ) +) { comm1 <- if (inherits(comm1, "communities")) { as.numeric(membership(comm1)) } else { @@ -2679,7 +3081,8 @@ i_compare <- function(comm1, comm2, method = c( } else { as.numeric(as.factor(comm2)) } - method <- switch(igraph.match.arg(method), + method <- switch( + igraph.match.arg(method), vi = 0L, nmi = 1L, split.join = 2L, @@ -2777,7 +3180,9 @@ groups <- function(x) { #' @export groups.default <- function(x) { vids <- names(x$membership) - if (is.null(vids)) vids <- seq_along(x$membership) + if (is.null(vids)) { + vids <- seq_along(x$membership) + } tapply(vids, x$membership, simplify = FALSE, function(x) x) } From ca157a1be41d08361153c775bf5c553ce1c028f9 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:46:36 +0200 Subject: [PATCH 08/59] console --- R/console.R | 66 +++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 46 insertions(+), 20 deletions(-) diff --git a/R/console.R b/R/console.R index de57f5813c2..8a9eabf802d 100644 --- a/R/console.R +++ b/R/console.R @@ -8,7 +8,8 @@ #' #' @keywords internal #' @export -igraph.console <- function() { # nocov start +igraph.console <- function() { + # nocov start lifecycle::deprecate_soft("2.0.0", "igraph.console()", "console()") console() } # nocov end @@ -34,7 +35,6 @@ igraph.console <- function() { # nocov start # ################################################################### - #' The igraph console #' #' The igraph console is a GUI window that shows what the currently running @@ -81,7 +81,8 @@ console <- function() { if (is.logical(type) && type) { .igraph.progress.txt(percent, message) } else { - switch(type, + switch( + type, "tk" = .igraph.progress.tk(percent, message), "tkconsole" = .igraph.progress.tkconsole(percent, message), stop("Cannot interpret 'verbose' option, this should not happen") @@ -97,7 +98,8 @@ console <- function() { if (is.logical(type) && type) { message(message, appendLF = FALSE) } else { - switch(type, + switch( + type, "tk" = message(message, appendLF = FALSE), "tkconsole" = .igraph.progress.tkconsole.message(message, start = TRUE), stop("Cannot interpret 'verbose' option, this should not happen") @@ -131,7 +133,12 @@ console <- function() { if (!is.null(pb)) { close(pb) } - pb <- tcltk::tkProgressBar(min = 0, max = 100, title = message, label = "0 %") + pb <- tcltk::tkProgressBar( + min = 0, + max = 100, + title = message, + label = "0 %" + ) } tcltk::setTkProgressBar(pb, percent, label = paste(percent, "%")) if (percent == 100) { @@ -159,7 +166,9 @@ console <- function() { ## Done assign(".igraph.pb", pb, envir = asNamespace("igraph")) - if (startmess) .igraph.progress.tkconsole.message("Console started.\n") + if (startmess) { + .igraph.progress.tkconsole.message("Console started.\n") + } 0L } @@ -170,19 +179,31 @@ console <- function() { fn <- tcltk::tkfont.create(family = "courier", size = 8) lfr <- tcltk::tkframe(console) - image <- tcltk::tkimage.create("photo", "img", + image <- tcltk::tkimage.create( + "photo", + "img", format = "gif", file = system.file("igraph2.gif", package = "igraph") ) - logo <- tcltk::tklabel(lfr, relief = "flat", padx = 10, pady = 10, image = image) + logo <- tcltk::tklabel( + lfr, + relief = "flat", + padx = 10, + pady = 10, + image = image + ) - scr <- tcltk::tkscrollbar(console, + scr <- tcltk::tkscrollbar( + console, repeatinterval = 5, command = function(...) tcltk::tkyview(txt, ...) ) - txt <- tcltk::tktext(console, + txt <- tcltk::tktext( + console, yscrollcommand = function(...) tcltk::tkset(scr, ...), - width = 60, height = 7, font = fn + width = 60, + height = 7, + font = fn ) tcltk::tkconfigure(txt, state = "disabled") pbar <- .igraph.progress.tkconsole.pbar(console) @@ -200,9 +221,14 @@ console <- function() { tcltk::tkdestroy(console) }) - tcltk::tkpack(logo, - side = "top", fill = "none", expand = 0, anchor = "n", - ipadx = 10, ipady = 10 + tcltk::tkpack( + logo, + side = "top", + fill = "none", + expand = 0, + anchor = "n", + ipadx = 10, + ipady = 10 ) tcltk::tkpack(bclear, side = "top", fill = "x", expand = 0, padx = 10) ## tcltk::tkpack(bstop, side="top", fill="x", expand=0, padx=10) @@ -264,8 +290,11 @@ close.igraphconsole <- function(con, ...) { fn <- tcltk::tkfont.create(family = "helvetica", size = 10) frame <- tcltk::tkframe(top) if (useText) { - .lab <- tcltk::tklabel(frame, - text = " ", font = fn, anchor = "w", + .lab <- tcltk::tklabel( + frame, + text = " ", + font = fn, + anchor = "w", padx = 20 ) tcltk::tkpack(.lab, side = "left", anchor = "w", padx = 5) @@ -273,10 +302,7 @@ close.igraphconsole <- function(con, ...) { .vlab <- tcltk::tklabel(frame, text = "0%", font = fn2, padx = 20) tcltk::tkpack(.vlab, side = "right") } else { - .lab <- tcltk::tklabel(frame, - text = " ", font = fn, anchor = "w", - pady = 5 - ) + .lab <- tcltk::tklabel(frame, text = " ", font = fn, anchor = "w", pady = 5) tcltk::tkpack(.lab, side = "top", anchor = "w", padx = 5) tcltk::tkpack(tcltk::tklabel(frame, text = "", font = fn), side = "bottom") .val <- tcltk::tclVar() From 1e8b2802fa11b3301296559ba288baf3708c3c59 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:47:02 +0200 Subject: [PATCH 09/59] conversion --- R/conversion.R | 403 +++++++++++++++++++++++++++++++++++-------------- 1 file changed, 289 insertions(+), 114 deletions(-) diff --git a/R/conversion.R b/R/conversion.R index 1ec8b3ddce2..2c4998909d6 100644 --- a/R/conversion.R +++ b/R/conversion.R @@ -8,7 +8,8 @@ #' @inheritParams as_graphnel #' @keywords internal #' @export -igraph.to.graphNEL <- function(graph) { # nocov start +igraph.to.graphNEL <- function(graph) { + # nocov start lifecycle::deprecate_soft("2.0.0", "igraph.to.graphNEL()", "as_graphnel()") as_graphnel(graph = graph) } # nocov end @@ -23,9 +24,24 @@ igraph.to.graphNEL <- function(graph) { # nocov start #' @inheritParams graph_from_graphnel #' @keywords internal #' @export -igraph.from.graphNEL <- function(graphNEL, name = TRUE, weight = TRUE, unlist.attrs = TRUE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "igraph.from.graphNEL()", "graph_from_graphnel()") - graph_from_graphnel(graphNEL = graphNEL, name = name, weight = weight, unlist.attrs = unlist.attrs) +igraph.from.graphNEL <- function( + graphNEL, + name = TRUE, + weight = TRUE, + unlist.attrs = TRUE +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "igraph.from.graphNEL()", + "graph_from_graphnel()" + ) + graph_from_graphnel( + graphNEL = graphNEL, + name = name, + weight = weight, + unlist.attrs = unlist.attrs + ) } # nocov end #' Create graphs from adjacency lists @@ -38,7 +54,12 @@ igraph.from.graphNEL <- function(graphNEL, name = TRUE, weight = TRUE, unlist.at #' @inheritParams graph_from_adj_list #' @keywords internal #' @export -graph.adjlist <- function(adjlist, mode = c("out", "in", "all", "total"), duplicate = TRUE) { # nocov start +graph.adjlist <- function( + adjlist, + mode = c("out", "in", "all", "total"), + duplicate = TRUE +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "graph.adjlist()", "graph_from_adj_list()") graph_from_adj_list(adjlist = adjlist, mode = mode, duplicate = duplicate) } # nocov end @@ -53,9 +74,26 @@ graph.adjlist <- function(adjlist, mode = c("out", "in", "all", "total"), duplic #' @inheritParams as_biadjacency_matrix #' @keywords internal #' @export -get.incidence <- function(graph, types = NULL, attr = NULL, names = TRUE, sparse = FALSE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "get.incidence()", "as_biadjacency_matrix()") - as_biadjacency_matrix(graph = graph, types = types, attr = attr, names = names, sparse = sparse) +get.incidence <- function( + graph, + types = NULL, + attr = NULL, + names = TRUE, + sparse = FALSE +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "get.incidence()", + "as_biadjacency_matrix()" + ) + as_biadjacency_matrix( + graph = graph, + types = types, + attr = attr, + names = names, + sparse = sparse + ) } # nocov end #' Convert a graph to an edge list @@ -68,7 +106,8 @@ get.incidence <- function(graph, types = NULL, attr = NULL, names = TRUE, sparse #' @inheritParams as_edgelist #' @keywords internal #' @export -get.edgelist <- function(graph, names = TRUE) { # nocov start +get.edgelist <- function(graph, names = TRUE) { + # nocov start lifecycle::deprecate_soft("2.0.0", "get.edgelist()", "as_edgelist()") as_edgelist(graph = graph, names = names) } # nocov end @@ -83,7 +122,8 @@ get.edgelist <- function(graph, names = TRUE) { # nocov start #' @inheritParams as_data_frame #' @keywords internal #' @export -get.data.frame <- function(x, what = c("edges", "vertices", "both")) { # nocov start +get.data.frame <- function(x, what = c("edges", "vertices", "both")) { + # nocov start lifecycle::deprecate_soft("2.0.0", "get.data.frame()", "as_data_frame()") as_data_frame(x = x, what = what) } # nocov end @@ -98,9 +138,24 @@ get.data.frame <- function(x, what = c("edges", "vertices", "both")) { # nocov s #' @inheritParams as_adjacency_matrix #' @keywords internal #' @export -get.adjacency <- function(graph, type = c("both", "upper", "lower"), attr = NULL, edges = FALSE, names = TRUE, sparse = igraph_opt("sparsematrices")) { # nocov start +get.adjacency <- function( + graph, + type = c("both", "upper", "lower"), + attr = NULL, + edges = FALSE, + names = TRUE, + sparse = igraph_opt("sparsematrices") +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "get.adjacency()", "as_adjacency_matrix()") - as_adjacency_matrix(graph = graph, type = type, attr = attr, edges = edges, names = names, sparse = sparse) + as_adjacency_matrix( + graph = graph, + type = type, + attr = attr, + edges = edges, + names = names, + sparse = sparse + ) } # nocov end #' Adjacency lists @@ -113,7 +168,13 @@ get.adjacency <- function(graph, type = c("both", "upper", "lower"), attr = NULL #' @inheritParams as_adj_list #' @keywords internal #' @export -get.adjlist <- function(graph, mode = c("all", "out", "in", "total"), loops = c("twice", "once", "ignore"), multiple = TRUE) { # nocov start +get.adjlist <- function( + graph, + mode = c("all", "out", "in", "total"), + loops = c("twice", "once", "ignore"), + multiple = TRUE +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "get.adjlist()", "as_adj_list()") as_adj_list(graph = graph, mode = mode, loops = loops, multiple = multiple) } # nocov end @@ -128,7 +189,12 @@ get.adjlist <- function(graph, mode = c("all", "out", "in", "total"), loops = c( #' @inheritParams as_adj_edge_list #' @keywords internal #' @export -get.adjedgelist <- function(graph, mode = c("all", "out", "in", "total"), loops = c("twice", "once", "ignore")) { # nocov start +get.adjedgelist <- function( + graph, + mode = c("all", "out", "in", "total"), + loops = c("twice", "once", "ignore") +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "get.adjedgelist()", "as_adj_edge_list()") as_adj_edge_list(graph = graph, mode = mode, loops = loops) } # nocov end @@ -153,8 +219,14 @@ get.adjedgelist <- function(graph, mode = c("all", "out", "in", "total"), loops # ################################################################### -get.adjacency.dense <- function(graph, type = c("both", "upper", "lower"), - attr = NULL, weights = NULL, loops = c("once", "twice", "ignore"), names = TRUE) { +get.adjacency.dense <- function( + graph, + type = c("both", "upper", "lower"), + attr = NULL, + weights = NULL, + loops = c("once", "twice", "ignore"), + names = TRUE +) { ensure_igraph(graph) type <- igraph.match.arg(type) @@ -162,33 +234,40 @@ get.adjacency.dense <- function(graph, type = c("both", "upper", "lower"), if (is.logical(loops)) { loops <- ifelse(loops, "once", "ignore") lifecycle::deprecate_soft( - "2.1.0", "get.adjacency.dense(loops = 'must be a character')", - details = sprintf("Converting to get.adjacency.dense (loops = '%s')", loops) + "2.1.0", + "get.adjacency.dense(loops = 'must be a character')", + details = sprintf( + "Converting to get.adjacency.dense (loops = '%s')", + loops + ) ) } loops <- igraph.match.arg(loops) - loops <- switch(loops, - "ignore" = 0L, - "twice" = 1L, - "once" = 2L - ) + loops <- switch(loops, "ignore" = 0L, "twice" = 1L, "once" = 2L) - if (!is.null(weights)) weights <- as.numeric(weights) + if (!is.null(weights)) { + weights <- as.numeric(weights) + } if (is.null(attr)) { on.exit(.Call(R_igraph_finalizer)) - type <- switch(type, - "upper" = 0, - "lower" = 1, - "both" = 2 - ) + type <- switch(type, "upper" = 0, "lower" = 1, "both" = 2) res <- .Call( - R_igraph_get_adjacency, graph, as.numeric(type), weights, + R_igraph_get_adjacency, + graph, + as.numeric(type), + weights, loops ) } else { # faster than a specialized implementation - res <- as.matrix(get.adjacency.sparse(graph, type = type, attr = attr, names = names, call = rlang::caller_env())) + res <- as.matrix(get.adjacency.sparse( + graph, + type = type, + attr = attr, + names = names, + call = rlang::caller_env() + )) } if (names && "name" %in% vertex_attr_names(graph)) { @@ -197,8 +276,13 @@ get.adjacency.dense <- function(graph, type = c("both", "upper", "lower"), res } -get.adjacency.sparse <- function(graph, type = c("both", "upper", "lower"), - attr = NULL, names = TRUE, call = rlang::caller_env()) { +get.adjacency.sparse <- function( + graph, + type = c("both", "upper", "lower"), + attr = NULL, + names = TRUE, + call = rlang::caller_env() +) { ensure_igraph(graph) type <- igraph.match.arg(type) @@ -225,25 +309,41 @@ get.adjacency.sparse <- function(graph, type = c("both", "upper", "lower"), } if (is_directed(graph)) { - res <- Matrix::sparseMatrix(dims = c(vc, vc), i = el[, 1], j = el[, 2], x = value, use.last.ij = use.last.ij) + res <- Matrix::sparseMatrix( + dims = c(vc, vc), + i = el[, 1], + j = el[, 2], + x = value, + use.last.ij = use.last.ij + ) } else { if (type == "upper") { ## upper res <- Matrix::sparseMatrix( - dims = c(vc, vc), i = pmin(el[, 1], el[, 2]), - j = pmax(el[, 1], el[, 2]), x = value, use.last.ij = use.last.ij + dims = c(vc, vc), + i = pmin(el[, 1], el[, 2]), + j = pmax(el[, 1], el[, 2]), + x = value, + use.last.ij = use.last.ij ) } else if (type == "lower") { ## lower res <- Matrix::sparseMatrix( - dims = c(vc, vc), i = pmax(el[, 1], el[, 2]), - j = pmin(el[, 1], el[, 2]), x = value, use.last.ij = use.last.ij + dims = c(vc, vc), + i = pmax(el[, 1], el[, 2]), + j = pmin(el[, 1], el[, 2]), + x = value, + use.last.ij = use.last.ij ) } else if (type == "both") { ## both res <- Matrix::sparseMatrix( - dims = c(vc, vc), i = pmin(el[, 1], el[, 2]), - j = pmax(el[, 1], el[, 2]), x = value, symmetric = TRUE, use.last.ij = use.last.ij + dims = c(vc, vc), + i = pmin(el[, 1], el[, 2]), + j = pmax(el[, 1], el[, 2]), + x = value, + symmetric = TRUE, + use.last.ij = use.last.ij ) res <- as(res, "generalMatrix") } @@ -306,9 +406,14 @@ get.adjacency.sparse <- function(graph, type = c("both", "upper", "lower"), #' as_adjacency_matrix(g, attr = "weight") #' @family conversion #' @export -as_adjacency_matrix <- function(graph, type = c("both", "upper", "lower"), - attr = NULL, edges = deprecated(), names = TRUE, - sparse = igraph_opt("sparsematrices")) { +as_adjacency_matrix <- function( + graph, + type = c("both", "upper", "lower"), + attr = NULL, + edges = deprecated(), + names = TRUE, + sparse = igraph_opt("sparsematrices") +) { ensure_igraph(graph) if (lifecycle::is_present(edges) && isTRUE(edges)) { @@ -318,7 +423,14 @@ as_adjacency_matrix <- function(graph, type = c("both", "upper", "lower"), if (sparse) { get.adjacency.sparse(graph, type = type, attr = attr, names = names) } else { - get.adjacency.dense(graph, type = type, attr = attr, weights = NULL, names = names, loops = "once") + get.adjacency.dense( + graph, + type = type, + attr = attr, + weights = NULL, + names = names, + loops = "once" + ) } } @@ -331,9 +443,14 @@ as_adjacency_matrix <- function(graph, type = c("both", "upper", "lower"), #' @export #' @inheritParams as_adjacency_matrix #' @keywords internal -as_adj <- function(graph, type = c("both", "upper", "lower"), - attr = NULL, edges = deprecated(), names = TRUE, - sparse = igraph_opt("sparsematrices")) { +as_adj <- function( + graph, + type = c("both", "upper", "lower"), + attr = NULL, + edges = deprecated(), + names = TRUE, + sparse = igraph_opt("sparsematrices") +) { lifecycle::deprecate_soft("2.1.0", "as_adj()", "as_adjacency_matrix()") as_adjacency_matrix( @@ -372,9 +489,7 @@ as_adj <- function(graph, type = c("both", "upper", "lower"), as_edgelist <- function(graph, names = TRUE) { ensure_igraph(graph) on.exit(.Call(R_igraph_finalizer)) - res <- matrix(.Call(R_igraph_get_edgelist, graph, TRUE), - ncol = 2 - ) + res <- matrix(.Call(R_igraph_get_edgelist, graph, TRUE), ncol = 2) res <- res + 1 if (names && "name" %in% vertex_attr_names(graph)) { res <- matrix(V(graph)$name[res], ncol = 2) @@ -384,7 +499,6 @@ as_edgelist <- function(graph, names = TRUE) { } - #' Convert between directed and undirected graphs #' #' `as_directed()` converts an undirected graph to directed, @@ -495,10 +609,15 @@ as_directed <- to_directed_impl #' combined. Please see [attribute.combination()] for details on #' this. #' @export -as_undirected <- function(graph, mode = c("collapse", "each", "mutual"), edge.attr.comb = igraph_opt("edge.attr.comb")) { +as_undirected <- function( + graph, + mode = c("collapse", "each", "mutual"), + edge.attr.comb = igraph_opt("edge.attr.comb") +) { # Argument checks ensure_igraph(graph) - mode <- switch(igraph.match.arg(mode), + mode <- switch( + igraph.match.arg(mode), "collapse" = 1L, "each" = 0L, "mutual" = 2L @@ -553,25 +672,18 @@ as_undirected <- function(graph, mode = c("collapse", "each", "mutual"), edge.at #' as_adj_list(g) #' as_adj_edge_list(g) #' -as_adj_list <- function(graph, - mode = c("all", "out", "in", "total"), - loops = c("twice", "once", "ignore"), - multiple = TRUE) { +as_adj_list <- function( + graph, + mode = c("all", "out", "in", "total"), + loops = c("twice", "once", "ignore"), + multiple = TRUE +) { ensure_igraph(graph) mode <- igraph.match.arg(mode) - mode <- as.numeric(switch(mode, - "out" = 1, - "in" = 2, - "all" = 3, - "total" = 3 - )) + mode <- as.numeric(switch(mode, "out" = 1, "in" = 2, "all" = 3, "total" = 3)) loops <- igraph.match.arg(loops) - loops <- as.numeric(switch(loops, - "ignore" = 0, - "twice" = 1, - "once" = 2 - )) + loops <- as.numeric(switch(loops, "ignore" = 0, "twice" = 1, "once" = 2)) if (is_directed(graph) && loops == 1) { loops <- 2 @@ -584,30 +696,25 @@ as_adj_list <- function(graph, if (igraph_opt("return.vs.es")) { res <- lapply(res, unsafe_create_vs, graph = graph, verts = V(graph)) } - if (is_named(graph)) names(res) <- V(graph)$name + if (is_named(graph)) { + names(res) <- V(graph)$name + } res } #' @rdname as_adj_list #' @export -as_adj_edge_list <- function(graph, - mode = c("all", "out", "in", "total"), - loops = c("twice", "once", "ignore")) { +as_adj_edge_list <- function( + graph, + mode = c("all", "out", "in", "total"), + loops = c("twice", "once", "ignore") +) { ensure_igraph(graph) mode <- igraph.match.arg(mode) - mode <- as.numeric(switch(mode, - "out" = 1, - "in" = 2, - "all" = 3, - "total" = 3 - )) + mode <- as.numeric(switch(mode, "out" = 1, "in" = 2, "all" = 3, "total" = 3)) loops <- igraph.match.arg(loops) - loops <- as.numeric(switch(loops, - "ignore" = 0, - "twice" = 1, - "once" = 2 - )) + loops <- as.numeric(switch(loops, "ignore" = 0, "twice" = 1, "once" = 2)) if (is_directed(graph) && loops == 1) { loops <- 2 @@ -616,7 +723,9 @@ as_adj_edge_list <- function(graph, on.exit(.Call(R_igraph_finalizer)) res <- .Call(R_igraph_get_adjedgelist, graph, mode, loops) res <- lapply(res, function(.x) E(graph)[.x + 1]) - if (is_named(graph)) names(res) <- V(graph)$name + if (is_named(graph)) { + names(res) <- V(graph)$name + } res } @@ -665,10 +774,16 @@ as_adj_edge_list <- function(graph, #' g4 #' @family conversion #' @export -graph_from_graphnel <- function(graphNEL, name = TRUE, weight = TRUE, - unlist.attrs = TRUE) { +graph_from_graphnel <- function( + graphNEL, + name = TRUE, + weight = TRUE, + unlist.attrs = TRUE +) { if (!inherits(graphNEL, "graphNEL")) { - cli::cli_abort("{.arg graphNEL} is {.obj_type_friendly {graphNEL}} and not a graphNEL graph") + cli::cli_abort( + "{.arg graphNEL} is {.obj_type_friendly {graphNEL}} and not a graphNEL graph" + ) } al <- lapply(graph::edgeL(graphNEL), "[[", "edges") @@ -762,8 +877,7 @@ as_graphnel <- function(graph) { cli::cli_abort("multiple edges are not supported in graphNEL graphs") } - if ("name" %in% vertex_attr_names(graph) && - is.character(V(graph)$name)) { + if ("name" %in% vertex_attr_names(graph) && is.character(V(graph)$name)) { name <- V(graph)$name } else { name <- as.character(seq(vcount(graph))) @@ -771,8 +885,7 @@ as_graphnel <- function(graph) { edgemode <- if (is_directed(graph)) "directed" else "undirected" - if ("weight" %in% edge_attr_names(graph) && - is.numeric(E(graph)$weight)) { + if ("weight" %in% edge_attr_names(graph) && is.numeric(E(graph)$weight)) { al <- lapply(as_adj_edge_list(graph, "out", loops = "once"), as.vector) for (i in seq(along.with = al)) { edges <- ends(graph, al[[i]], names = FALSE) @@ -835,7 +948,13 @@ as_graphnel <- function(graph) { res } -get.incidence.dense <- function(graph, types, names, attr, call = rlang::caller_env()) { +get.incidence.dense <- function( + graph, + types, + names, + attr, + call = rlang::caller_env() +) { if (is.null(attr)) { on.exit(.Call(R_igraph_finalizer)) ## Function call @@ -897,7 +1016,13 @@ get.incidence.dense <- function(graph, types, names, attr, call = rlang::caller_ } } -get.incidence.sparse <- function(graph, types, names, attr, call = rlang::caller_env()) { +get.incidence.sparse <- function( + graph, + types, + names, + attr, + call = rlang::caller_env() +) { vc <- vcount(graph) if (length(types) != vc) { cli::cli_abort("Invalid types vector", call = call) @@ -951,7 +1076,6 @@ get.incidence.sparse <- function(graph, types, names, attr, call = rlang::caller } - #' Bipartite adjacency matrix of a bipartite graph #' #' This function can return a sparse or dense bipartite adjacency matrix of a bipartite @@ -994,8 +1118,13 @@ get.incidence.sparse <- function(graph, types, names, attr, call = rlang::caller #' g <- make_bipartite_graph(c(0, 1, 0, 1, 0, 0), c(1, 2, 2, 3, 3, 4)) #' as_biadjacency_matrix(g) #' -as_biadjacency_matrix <- function(graph, types = NULL, attr = NULL, - names = TRUE, sparse = FALSE) { +as_biadjacency_matrix <- function( + graph, + types = NULL, + attr = NULL, + names = TRUE, + sparse = FALSE +) { # Argument checks ensure_igraph(graph) types <- handle_vertex_type_arg(types, graph) @@ -1004,7 +1133,13 @@ as_biadjacency_matrix <- function(graph, types = NULL, attr = NULL, sparse <- as.logical(sparse) if (sparse) { - get.incidence.sparse(graph, types = types, names = names, attr = attr, call = rlang::caller_env()) + get.incidence.sparse( + graph, + types = types, + names = names, + attr = attr, + call = rlang::caller_env() + ) } else { get.incidence.dense(graph, types = types, names = names, attr = attr) } @@ -1023,8 +1158,13 @@ as_biadjacency_matrix <- function(graph, types = NULL, attr = NULL, #' "bipartite incidence matrix". igraph 1.6.0 and later does not use #' this naming to avoid confusion with the edge-vertex incidence matrix. #' @export -as_incidence_matrix <- function(...) { # nocov start - lifecycle::deprecate_soft("1.6.0", "as_incidence_matrix()", "as_biadjacency_matrix()") +as_incidence_matrix <- function(...) { + # nocov start + lifecycle::deprecate_soft( + "1.6.0", + "as_incidence_matrix()", + "as_biadjacency_matrix()" + ) as_biadjacency_matrix(...) } # nocov end #' @rdname graph_from_data_frame @@ -1039,7 +1179,12 @@ as_data_frame <- function(x, what = c("edges", "vertices", "both")) { what <- igraph.match.arg(what) if (what %in% c("vertices", "both")) { - ver <- .Call(R_igraph_mybracket2, x, igraph_t_idx_attr, igraph_attr_idx_vertex) + ver <- .Call( + R_igraph_mybracket2, + x, + igraph_t_idx_attr, + igraph_attr_idx_vertex + ) class(ver) <- "data.frame" rn <- if (is_named(x)) { V(x)$name @@ -1149,7 +1294,12 @@ graph_from_adj_list <- adjlist_impl as_long_data_frame <- function(graph) { ensure_igraph(graph) - ver <- .Call(R_igraph_mybracket2, graph, igraph_t_idx_attr, igraph_attr_idx_vertex) + ver <- .Call( + R_igraph_mybracket2, + graph, + igraph_t_idx_attr, + igraph_attr_idx_vertex + ) class(ver) <- "data.frame" rn <- if (is_named(graph)) { V(graph)$name @@ -1160,7 +1310,8 @@ as_long_data_frame <- function(graph) { el <- as_edgelist(graph, names = FALSE) edg <- c( - list(from = el[, 1]), list(to = el[, 2]), + list(from = el[, 1]), + list(to = el[, 2]), .Call(R_igraph_mybracket2, graph, igraph_t_idx_attr, igraph_attr_idx_edge) ) class(edg) <- "data.frame" @@ -1170,7 +1321,11 @@ as_long_data_frame <- function(graph) { if (length(ver) > 0) { names(ver) <- paste0("from_", names(ver)) names(ver2) <- paste0("to_", names(ver2)) - edg <- cbind(edg, ver[el[, 1], , drop = FALSE], ver2[el[, 2], , drop = FALSE]) + edg <- cbind( + edg, + ver[el[, 1], , drop = FALSE], + ver2[el[, 2], , drop = FALSE] + ) } edg @@ -1213,7 +1368,8 @@ as_long_data_frame <- function(graph) { #' as.matrix.igraph <- function(x, matrix.type = c("adjacency", "edgelist"), ...) { mt <- match.arg(matrix.type) - switch(mt, + switch( + mt, adjacency = as_adjacency_matrix(graph = x, ...), edgelist = as_edgelist(graph = x, ...) ) @@ -1229,7 +1385,10 @@ as.matrix.igraph <- function(x, matrix.type = c("adjacency", "edgelist"), ...) { #' @inheritParams as_directed #' @keywords internal #' @export -as.directed <- function(graph, mode = c("mutual", "arbitrary", "random", "acyclic")) { +as.directed <- function( + graph, + mode = c("mutual", "arbitrary", "random", "acyclic") +) { lifecycle::deprecate_soft("2.1.0", "as.directed()", "as_directed()") as_directed(graph, mode = mode) } @@ -1244,9 +1403,11 @@ as.directed <- function(graph, mode = c("mutual", "arbitrary", "random", "acycli #' @inheritParams as_undirected #' @keywords internal #' @export -as.undirected <- function(graph, - mode = c("collapse", "each", "mutual"), - edge.attr.comb = igraph_opt("edge.attr.comb")) { +as.undirected <- function( + graph, + mode = c("collapse", "each", "mutual"), + edge.attr.comb = igraph_opt("edge.attr.comb") +) { lifecycle::deprecate_soft("2.1.0", "as.undirected()", "as_undirected()") as_undirected(graph = graph, mode = mode, edge.attr.comb = edge.attr.comb) } @@ -1261,8 +1422,13 @@ as.undirected <- function(graph, #' @inheritParams graph_from_edgelist #' @keywords internal #' @export -graph.edgelist <- function(el, directed = TRUE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "graph.edgelist()", "graph_from_edgelist()") +graph.edgelist <- function(el, directed = TRUE) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "graph.edgelist()", + "graph_from_edgelist()" + ) graph_from_edgelist(el = el, directed = directed) } # nocov end @@ -1276,8 +1442,13 @@ graph.edgelist <- function(el, directed = TRUE) { # nocov start #' @inheritParams graph_from_data_frame #' @keywords internal #' @export -graph.data.frame <- function(d, directed = TRUE, vertices = NULL) { # nocov start - lifecycle::deprecate_soft("2.0.0", "graph.data.frame()", "graph_from_data_frame()") +graph.data.frame <- function(d, directed = TRUE, vertices = NULL) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "graph.data.frame()", + "graph_from_data_frame()" + ) graph_from_data_frame(d = d, directed = directed, vertices = vertices) } # nocov end @@ -1419,7 +1590,9 @@ graph_from_data_frame <- function(d, directed = TRUE, vertices = NULL) { ensure_no_na(d, "edge data frame") if (!is.null(vertices) && any(is.na(vertices[, 1]))) { - cli::cli_warn("In {.code vertices[,1]}, {.code NA} elements were replaced with string {.str NA}.") + cli::cli_warn( + "In {.code vertices[,1]}, {.code NA} elements were replaced with string {.str NA}." + ) vertices[, 1][is.na(vertices[, 1])] <- "NA" } @@ -1435,7 +1608,9 @@ graph_from_data_frame <- function(d, directed = TRUE, vertices = NULL) { cli::cli_abort("{.arg vertices} contains duplicated vertex names") } if (any(!names2 %in% names)) { - cli::cli_abort("Some vertex names in {.arg d} are not listed in {.arg vertices}") + cli::cli_abort( + "Some vertex names in {.arg d} are not listed in {.arg vertices}" + ) } } From 2717bd4c1bcb53d6c0a8bec904b60d114776422b Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:47:53 +0200 Subject: [PATCH 10/59] decomposition --- R/decomposition.R | 36 ++++++++++++++++++++++++++++-------- 1 file changed, 28 insertions(+), 8 deletions(-) diff --git a/R/decomposition.R b/R/decomposition.R index d1852ed84e0..95842367096 100644 --- a/R/decomposition.R +++ b/R/decomposition.R @@ -8,9 +8,22 @@ #' @inheritParams is_chordal #' @keywords internal #' @export -is.chordal <- function(graph, alpha = NULL, alpham1 = NULL, fillin = FALSE, newgraph = FALSE) { # nocov start +is.chordal <- function( + graph, + alpha = NULL, + alpham1 = NULL, + fillin = FALSE, + newgraph = FALSE +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "is.chordal()", "is_chordal()") - is_chordal(graph = graph, alpha = alpha, alpham1 = alpham1, fillin = fillin, newgraph = newgraph) + is_chordal( + graph = graph, + alpha = alpha, + alpham1 = alpham1, + fillin = fillin, + newgraph = newgraph + ) } # nocov end # IGraph R package # Copyright (C) 2008-2012 Gabor Csardi @@ -37,8 +50,6 @@ is.chordal <- function(graph, alpha = NULL, alpham1 = NULL, fillin = FALSE, newg # Graph decomposition ################################################################### - - #' Chordality of a graph #' #' A graph is chordal (or triangulated) if each of its cycles of four or more @@ -105,8 +116,13 @@ is.chordal <- function(graph, alpha = NULL, alpham1 = NULL, fillin = FALSE, newg #' max_cardinality(g2) #' is_chordal(g2, fillin = TRUE) #' -is_chordal <- function(graph, alpha = NULL, alpham1 = NULL, - fillin = FALSE, newgraph = FALSE) { +is_chordal <- function( + graph, + alpha = NULL, + alpham1 = NULL, + fillin = FALSE, + newgraph = FALSE +) { ensure_igraph(graph) if (!is.null(alpha)) { alpha <- as.numeric(alpha) - 1 @@ -118,8 +134,12 @@ is_chordal <- function(graph, alpha = NULL, alpham1 = NULL, newgraph <- as.logical(newgraph) on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_is_chordal, graph, alpha, alpham1, - fillin, newgraph + R_igraph_is_chordal, + graph, + alpha, + alpham1, + fillin, + newgraph ) if (fillin) { res$fillin <- res$fillin + 1 From 8455f67329446dea4886fa45398307c8b9d4219e Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:48:08 +0200 Subject: [PATCH 11/59] degseq --- R/degseq.R | 24 +++++++++++++++++++----- 1 file changed, 19 insertions(+), 5 deletions(-) diff --git a/R/degseq.R b/R/degseq.R index f0856e8c44c..114d5e66576 100644 --- a/R/degseq.R +++ b/R/degseq.R @@ -1,4 +1,4 @@ -#' Is a degree sequence graphical? +#' Is a degree sequence graphical? #' #' @description #' `r lifecycle::badge("deprecated")` @@ -8,9 +8,22 @@ #' @inheritParams is_graphical #' @keywords internal #' @export -is.graphical.degree.sequence <- function(out.deg, in.deg = NULL, allowed.edge.types = c("simple", "loops", "multi", "all")) { # nocov start - lifecycle::deprecate_soft("2.0.0", "is.graphical.degree.sequence()", "is_graphical()") - is_graphical(out.deg = out.deg, in.deg = in.deg, allowed.edge.types = allowed.edge.types) +is.graphical.degree.sequence <- function( + out.deg, + in.deg = NULL, + allowed.edge.types = c("simple", "loops", "multi", "all") +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "is.graphical.degree.sequence()", + "is_graphical()" + ) + is_graphical( + out.deg = out.deg, + in.deg = in.deg, + allowed.edge.types = allowed.edge.types + ) } # nocov end #' Check if a degree sequence is valid for a multi-graph @@ -23,7 +36,8 @@ is.graphical.degree.sequence <- function(out.deg, in.deg = NULL, allowed.edge.ty #' @inheritParams is_degseq #' @keywords internal #' @export -is.degree.sequence <- function(out.deg, in.deg = NULL) { # nocov start +is.degree.sequence <- function(out.deg, in.deg = NULL) { + # nocov start lifecycle::deprecate_soft("2.0.0", "is.degree.sequence()", "is_degseq()") is_degseq(out.deg = out.deg, in.deg = in.deg) } # nocov end From 48cef3b7b05e2e6d3f91e2aecb66e1bc9281047b Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:48:21 +0200 Subject: [PATCH 12/59] demo --- R/demo.R | 26 +++++++++++++++----------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/R/demo.R b/R/demo.R index 50b5bcfb26b..e4fd3a00125 100644 --- a/R/demo.R +++ b/R/demo.R @@ -8,7 +8,8 @@ #' @inheritParams igraph_demo #' @keywords internal #' @export -igraphdemo <- function(which) { # nocov start +igraphdemo <- function(which) { + # nocov start lifecycle::deprecate_soft("2.0.0", "igraphdemo()", "igraph_demo()") igraph_demo(which = which) } # nocov end @@ -33,8 +34,6 @@ igraphdemo <- function(which) { # nocov start # ################################################################### - - #' Run igraph demos, step by step #' #' Run one of the accompanying igraph demos, somewhat interactively, using a Tk @@ -155,7 +154,9 @@ igraph_demo <- function(which) { tcltk::tktag.configure(txt, "chunk", "-relief", "sunken") if (length(ch) >= 2) { tcltk::tktag.add( - txt, "active", paste(sep = "", ch[1], ".0"), + txt, + "active", + paste(sep = "", ch[1], ".0"), paste(sep = "", ch[2] - 1, ".0") ) tcltk::tktag.configure(txt, "active", "-foreground", "red") @@ -165,7 +166,9 @@ igraph_demo <- function(which) { comm <- grep("^#", demolines) for (i in comm) { tcltk::tktag.add( - txt, "comment", paste(sep = "", i, ".0"), + txt, + "comment", + paste(sep = "", i, ".0"), paste(sep = "", i, ".end") ) } @@ -185,13 +188,14 @@ igraph_demo <- function(which) { }) tcltk::tkconfigure(top, "-menu", main.menu) - scr <- tcltk::tkscrollbar(top, - repeatinterval = 5, - command = function(...) tcltk::tkyview(txt, ...) - ) - txt <- tcltk::tktext(top, + scr <- tcltk::tkscrollbar(top, repeatinterval = 5, command = function(...) { + tcltk::tkyview(txt, ...) + }) + txt <- tcltk::tktext( + top, yscrollcommand = function(...) tcltk::tkset(scr, ...), - width = 80, height = 40 + width = 80, + height = 40 ) but <- tcltk::tkbutton(top, text = "Next", command = function() { .igraphdemo.next(top, txt) From 8f8996149d8d5b1d80a3efbeaec8d97293f4fde9 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:48:34 +0200 Subject: [PATCH 13/59] foreign --- R/foreign.R | 326 +++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 256 insertions(+), 70 deletions(-) diff --git a/R/foreign.R b/R/foreign.R index 38bc07f5db0..a142e7d9504 100644 --- a/R/foreign.R +++ b/R/foreign.R @@ -8,7 +8,23 @@ #' @inheritParams write_graph #' @keywords internal #' @export -write.graph <- function(graph, file, format = c("edgelist", "pajek", "ncol", "lgl", "graphml", "dimacs", "gml", "dot", "leda"), ...) { # nocov start +write.graph <- function( + graph, + file, + format = c( + "edgelist", + "pajek", + "ncol", + "lgl", + "graphml", + "dimacs", + "gml", + "dot", + "leda" + ), + ... +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "write.graph()", "write_graph()") write_graph(graph = graph, file = file, format = format, ...) } # nocov end @@ -23,7 +39,22 @@ write.graph <- function(graph, file, format = c("edgelist", "pajek", "ncol", "lg #' @inheritParams read_graph #' @keywords internal #' @export -read.graph <- function(file, format = c("edgelist", "pajek", "ncol", "lgl", "graphml", "dimacs", "graphdb", "gml", "dl"), ...) { # nocov start +read.graph <- function( + file, + format = c( + "edgelist", + "pajek", + "ncol", + "lgl", + "graphml", + "dimacs", + "graphdb", + "gml", + "dl" + ), + ... +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "read.graph()", "read_graph()") read_graph(file = file, format = format, ...) } # nocov end @@ -38,9 +69,30 @@ read.graph <- function(file, format = c("edgelist", "pajek", "ncol", "lgl", "gra #' @inheritParams graph_from_graphdb #' @keywords internal #' @export -graph.graphdb <- function(url = NULL, prefix = "iso", type = "r001", nodes = NULL, pair = "A", which = 0, base = "http://cneurocvs.rmki.kfki.hu/graphdb/gzip", compressed = TRUE, directed = TRUE) { # nocov start +graph.graphdb <- function( + url = NULL, + prefix = "iso", + type = "r001", + nodes = NULL, + pair = "A", + which = 0, + base = "http://cneurocvs.rmki.kfki.hu/graphdb/gzip", + compressed = TRUE, + directed = TRUE +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "graph.graphdb()", "graph_from_graphdb()") - graph_from_graphdb(url = url, prefix = prefix, type = type, nodes = nodes, pair = pair, which = which, base = base, compressed = compressed, directed = directed) + graph_from_graphdb( + url = url, + prefix = prefix, + type = type, + nodes = nodes, + pair = pair, + which = which, + base = base, + compressed = compressed, + directed = directed + ) } # nocov end # IGraph R package # Copyright (C) 2005-2012 Gabor Csardi @@ -109,7 +161,6 @@ write.graph.fromraw <- function(buffer, file) { } - #' Reading foreign file formats #' #' The `read_graph()` function is able to read graphs in various @@ -193,20 +244,34 @@ write.graph.fromraw <- function(buffer, file) { #' @cdocs igraph_read_graph_dimacs_flow igraph_read_graph_dl igraph_read_graph_edgelist #' @cdocs igraph_read_graph_gml igraph_read_graph_graphdb igraph_read_graph_graphml #' @cdocs igraph_read_graph_lgl igraph_read_graph_ncol igraph_read_graph_pajek -read_graph <- function(file, format = c( - "edgelist", "pajek", "ncol", "lgl", - "graphml", "dimacs", "graphdb", "gml", "dl" - ), - ...) { - if (!is.character(file) || length(grep("://", file, fixed = TRUE)) > 0 || - length(grep("~", file, fixed = TRUE)) > 0) { +read_graph <- function( + file, + format = c( + "edgelist", + "pajek", + "ncol", + "lgl", + "graphml", + "dimacs", + "graphdb", + "gml", + "dl" + ), + ... +) { + if ( + !is.character(file) || + length(grep("://", file, fixed = TRUE)) > 0 || + length(grep("~", file, fixed = TRUE)) > 0 + ) { buffer <- read.graph.toraw(file) file <- tempfile() write.graph.fromraw(buffer, file) } format <- igraph.match.arg(format) - res <- switch(format, + res <- switch( + format, "pajek" = read.graph.pajek(file, ...), "ncol" = read.graph.ncol(file, ...), "edgelist" = read.graph.edgelist(file, ...), @@ -222,7 +287,6 @@ read_graph <- function(file, format = c( } - #' Writing the graph to a file in some format #' #' `write_graph()` is a general function for exporting graphs to foreign @@ -278,15 +342,28 @@ read_graph <- function(file, format = c( #' unlink(file) #' } #' -write_graph <- function(graph, file, - format = c( - "edgelist", "pajek", "ncol", "lgl", - "graphml", "dimacs", "gml", "dot", "leda" - ), - ...) { +write_graph <- function( + graph, + file, + format = c( + "edgelist", + "pajek", + "ncol", + "lgl", + "graphml", + "dimacs", + "gml", + "dot", + "leda" + ), + ... +) { ensure_igraph(graph) - if (!is.character(file) || length(grep("://", file, fixed = TRUE)) > 0 || - length(grep("~", file, fixed = TRUE)) > 0) { + if ( + !is.character(file) || + length(grep("://", file, fixed = TRUE)) > 0 || + length(grep("~", file, fixed = TRUE)) > 0 + ) { tmpfile <- TRUE origfile <- file file <- tempfile() @@ -295,7 +372,8 @@ write_graph <- function(graph, file, } format <- igraph.match.arg(format) - res <- switch(format, + res <- switch( + format, "pajek" = write.graph.pajek(graph, file, ...), "edgelist" = write.graph.edgelist(graph, file, ...), "ncol" = write.graph.ncol(graph, file, ...), @@ -320,15 +398,16 @@ write_graph <- function(graph, file, # Plain edge list format, not sorted ################################################################ -read.graph.edgelist <- function(file, n = 0, - directed = TRUE, ...) { +read.graph.edgelist <- function(file, n = 0, directed = TRUE, ...) { if (length(list(...)) > 0) { stop("Unknown arguments to read_graph (edgelist format)") } on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_read_graph_edgelist, file, - as.numeric(n), as.logical(directed) + R_igraph_read_graph_edgelist, + file, + as.numeric(n), + as.logical(directed) ) } @@ -344,26 +423,41 @@ write.graph.edgelist <- function(graph, file, ...) { # NCOL and LGL formats, quite simple ################################################################ -read.graph.ncol <- function(file, predef = character(0), names = TRUE, - weights = c("auto", "yes", "no"), - directed = FALSE, ...) { +read.graph.ncol <- function( + file, + predef = character(0), + names = TRUE, + weights = c("auto", "yes", "no"), + directed = FALSE, + ... +) { if (length(list(...)) > 0) { stop("Unknown arguments to read_graph (NCOL format)") } - weights <- switch(igraph.match.arg(weights), + weights <- switch( + igraph.match.arg(weights), "no" = 0L, "yes" = 1L, "auto" = 2L ) on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_read_graph_ncol, file, as.character(predef), - as.logical(names), weights, as.logical(directed) + R_igraph_read_graph_ncol, + file, + as.character(predef), + as.logical(names), + weights, + as.logical(directed) ) } -write.graph.ncol <- function(graph, file, - names = "name", weights = "weight", ...) { +write.graph.ncol <- function( + graph, + file, + names = "name", + weights = "weight", + ... +) { if (length(list(...)) > 0) { stop("Unknown arguments to write_graph (NCOL format)") } @@ -378,33 +472,48 @@ write.graph.ncol <- function(graph, file, on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_write_graph_ncol, graph, file, - names, weights + R_igraph_write_graph_ncol, + graph, + file, + names, + weights ) } -read.graph.lgl <- function(file, names = TRUE, - weights = c("auto", "yes", "no"), - directed = FALSE, - ...) { +read.graph.lgl <- function( + file, + names = TRUE, + weights = c("auto", "yes", "no"), + directed = FALSE, + ... +) { if (length(list(...)) > 0) { stop("Unknown arguments to read_graph (LGL format)") } - weights <- switch(igraph.match.arg(weights), + weights <- switch( + igraph.match.arg(weights), "no" = 0L, "yes" = 1L, "auto" = 2L ) on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_read_graph_lgl, file, - as.logical(names), weights, as.logical(directed) + R_igraph_read_graph_lgl, + file, + as.logical(names), + weights, + as.logical(directed) ) } -write.graph.lgl <- function(graph, file, - names = "name", weights = "weight", - isolates = FALSE, ...) { +write.graph.lgl <- function( + graph, + file, + names = "name", + weights = "weight", + isolates = FALSE, + ... +) { if (length(list(...)) > 0) { stop("Unknown arguments to write_graph (LGL format)") } @@ -419,8 +528,12 @@ write.graph.lgl <- function(graph, file, on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_write_graph_lgl, graph, file, - names, weights, as.logical(isolates) + R_igraph_write_graph_lgl, + graph, + file, + names, + weights, + as.logical(isolates) ) } @@ -466,8 +579,14 @@ read.graph.dimacs <- function(file, directed = TRUE, ...) { } } -write.graph.dimacs <- function(graph, file, - source = NULL, target = NULL, capacity = NULL, ...) { +write.graph.dimacs <- function( + graph, + file, + source = NULL, + target = NULL, + capacity = NULL, + ... +) { if (length(list(...)) > 0) { stop("Unknown arguments to write_graph (DIMACS format)") } @@ -483,8 +602,12 @@ write.graph.dimacs <- function(graph, file, on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_write_graph_dimacs, graph, file, as.numeric(source), - as.numeric(target), as.numeric(capacity) + R_igraph_write_graph_dimacs, + graph, + file, + as.numeric(source), + as.numeric(target), + as.numeric(capacity) ) } @@ -563,8 +686,6 @@ write.graph.dot <- function(graph, file, ...) { # isomorphic problems ################################################################ - - #' Load a graph from the graph database for testing graph isomorphism. #' #' This function downloads a graph from a database created for the evaluation @@ -634,17 +755,59 @@ graph_from_graphdb <- function( if (is.null(url)) { prefixes <- c("iso", "si6", "mcs10", "mcs30", "mcs50", "mcs70", "mcs90") types <- c( - "r001", "r005", "r01", "r02", "m2D", "m2Dr2", "m2Dr4", "m2Dr6", - "m3D", "m3Dr2", "m3Dr4", "m3Dr6", "m4D", "m4Dr2", "m4Dr4", - "m4Dr6", "b03", "b03m", "b06", "b06m", "b09", "b09m" + "r001", + "r005", + "r01", + "r02", + "m2D", + "m2Dr2", + "m2Dr4", + "m2Dr6", + "m3D", + "m3Dr2", + "m3Dr4", + "m3Dr6", + "m4D", + "m4Dr2", + "m4Dr4", + "m4Dr6", + "b03", + "b03m", + "b06", + "b06m", + "b09", + "b09m" ) - sizecode <- if (nodes <= 100) "s" else if (nodes < 2000) "m" else "l" # "l" ???? + sizecode <- if (nodes <= 100) { + "s" + } else if (nodes < 2000) { + "m" + } else { + "l" + } # "l" ???? typegroups <- c( - "rand", "rand", "rand", "rand", - "m2D", "m2D", "m2D", "m2D", - "m2D", "m3D", "m3D", "m3D", - "m4D", "m4D", "m4D", "m4D", - "bvg", "bvg", "bvg", "bvg", "bvg", "bvg" + "rand", + "rand", + "rand", + "rand", + "m2D", + "m2D", + "m2D", + "m2D", + "m2D", + "m3D", + "m3D", + "m3D", + "m4D", + "m4D", + "m4D", + "m4D", + "bvg", + "bvg", + "bvg", + "bvg", + "bvg", + "bvg" ) typegroup <- typegroups[which(types == type)] @@ -662,9 +825,25 @@ graph_from_graphdb <- function( } suff <- if (compressed) ".gz" else "" filename <- paste( - sep = "", base, "/", prefix, "/", typegroup, "/", type, "/", - prefix, "_", type, "_", sizecode, nodes, - ".", pair, formatC(which, width = 2, flag = "0"), suff + sep = "", + base, + "/", + prefix, + "/", + typegroup, + "/", + type, + "/", + prefix, + "_", + type, + "_", + sizecode, + nodes, + ".", + pair, + formatC(which, width = 2, flag = "0"), + suff ) } else { filename <- url @@ -674,7 +853,9 @@ graph_from_graphdb <- function( f <- try(gzcon(file(filename, open = "rb"))) if (inherits(f, "try-error")) { - cli::cli_abort("Cannot open URL provided in {.arg filename}: {.url {filename}}") + cli::cli_abort( + "Cannot open URL provided in {.arg filename}: {.url {filename}}" + ) } buffer <- read.graph.toraw(f) @@ -692,8 +873,13 @@ read.graph.graphdb <- function(file, directed = TRUE, ...) { .Call(R_igraph_read_graph_graphdb, file, as.logical(directed)) } -write.graph.leda <- function(graph, file, vertex.attr = NULL, edge.attr = NULL, - ...) { +write.graph.leda <- function( + graph, + file, + vertex.attr = NULL, + edge.attr = NULL, + ... +) { if (length(list(...)) > 0) { stop("Unknown arguments to write_graph (LEDA format)") } From 35720b7992395f2ea0e981e6c4b4b9fa872be3a9 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:48:48 +0200 Subject: [PATCH 14/59] flow --- R/flow.R | 200 +++++++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 158 insertions(+), 42 deletions(-) diff --git a/R/flow.R b/R/flow.R index ea9ee2aa40c..0c72e19abcd 100644 --- a/R/flow.R +++ b/R/flow.R @@ -8,8 +8,13 @@ #' @inheritParams vertex_disjoint_paths #' @keywords internal #' @export -vertex.disjoint.paths <- function(graph, source = NULL, target = NULL) { # nocov start - lifecycle::deprecate_soft("2.0.0", "vertex.disjoint.paths()", "vertex_disjoint_paths()") +vertex.disjoint.paths <- function(graph, source = NULL, target = NULL) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "vertex.disjoint.paths()", + "vertex_disjoint_paths()" + ) vertex_disjoint_paths(graph = graph, source = source, target = target) } # nocov end @@ -23,9 +28,24 @@ vertex.disjoint.paths <- function(graph, source = NULL, target = NULL) { # nocov #' @inheritParams vertex_connectivity #' @keywords internal #' @export -vertex.connectivity <- function(graph, source = NULL, target = NULL, checks = TRUE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "vertex.connectivity()", "vertex_connectivity()") - vertex_connectivity(graph = graph, source = source, target = target, checks = checks) +vertex.connectivity <- function( + graph, + source = NULL, + target = NULL, + checks = TRUE +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "vertex.connectivity()", + "vertex_connectivity()" + ) + vertex_connectivity( + graph = graph, + source = source, + target = target, + checks = checks + ) } # nocov end #' List all minimum \((s,t)\)-cuts of a graph @@ -38,9 +58,15 @@ vertex.connectivity <- function(graph, source = NULL, target = NULL, checks = TR #' @inheritParams st_min_cuts #' @keywords internal #' @export -stMincuts <- function(graph, source, target, capacity = NULL) { # nocov start +stMincuts <- function(graph, source, target, capacity = NULL) { + # nocov start lifecycle::deprecate_soft("2.0.0", "stMincuts()", "st_min_cuts()") - st_min_cuts(graph = graph, source = source, target = target, capacity = capacity) + st_min_cuts( + graph = graph, + source = source, + target = target, + capacity = capacity + ) } # nocov end #' List all (s,t)-cuts of a graph @@ -53,7 +79,8 @@ stMincuts <- function(graph, source, target, capacity = NULL) { # nocov start #' @inheritParams st_cuts #' @keywords internal #' @export -stCuts <- function(graph, source, target) { # nocov start +stCuts <- function(graph, source, target) { + # nocov start lifecycle::deprecate_soft("2.0.0", "stCuts()", "st_cuts()") st_cuts(graph = graph, source = source, target = target) } # nocov end @@ -68,8 +95,13 @@ stCuts <- function(graph, source, target) { # nocov start #' @inheritParams min_separators #' @keywords internal #' @export -minimum.size.separators <- function(graph) { # nocov start - lifecycle::deprecate_soft("2.0.0", "minimum.size.separators()", "min_separators()") +minimum.size.separators <- function(graph) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "minimum.size.separators()", + "min_separators()" + ) min_separators(graph = graph) } # nocov end @@ -83,8 +115,13 @@ minimum.size.separators <- function(graph) { # nocov start #' @inheritParams min_st_separators #' @keywords internal #' @export -minimal.st.separators <- function(graph) { # nocov start - lifecycle::deprecate_soft("2.0.0", "minimal.st.separators()", "min_st_separators()") +minimal.st.separators <- function(graph) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "minimal.st.separators()", + "min_st_separators()" + ) min_st_separators(graph = graph) } # nocov end @@ -98,7 +135,8 @@ minimal.st.separators <- function(graph) { # nocov start #' @inheritParams is_separator #' @keywords internal #' @export -is.separator <- function(graph, candidate) { # nocov start +is.separator <- function(graph, candidate) { + # nocov start lifecycle::deprecate_soft("2.0.0", "is.separator()", "is_separator()") is_separator(graph = graph, candidate = candidate) } # nocov end @@ -113,8 +151,13 @@ is.separator <- function(graph, candidate) { # nocov start #' @inheritParams is_min_separator #' @keywords internal #' @export -is.minimal.separator <- function(graph, candidate) { # nocov start - lifecycle::deprecate_soft("2.0.0", "is.minimal.separator()", "is_min_separator()") +is.minimal.separator <- function(graph, candidate) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "is.minimal.separator()", + "is_min_separator()" + ) is_min_separator(graph = graph, candidate = candidate) } # nocov end @@ -128,9 +171,22 @@ is.minimal.separator <- function(graph, candidate) { # nocov start #' @inheritParams min_cut #' @keywords internal #' @export -graph.mincut <- function(graph, source = NULL, target = NULL, capacity = NULL, value.only = TRUE) { # nocov start +graph.mincut <- function( + graph, + source = NULL, + target = NULL, + capacity = NULL, + value.only = TRUE +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "graph.mincut()", "min_cut()") - min_cut(graph = graph, source = source, target = target, capacity = capacity, value.only = value.only) + min_cut( + graph = graph, + source = source, + target = target, + capacity = capacity, + value.only = value.only + ) } # nocov end #' Maximum flow in a graph @@ -143,7 +199,8 @@ graph.mincut <- function(graph, source = NULL, target = NULL, capacity = NULL, v #' @inheritParams max_flow #' @keywords internal #' @export -graph.maxflow <- function(graph, source, target, capacity = NULL) { # nocov start +graph.maxflow <- function(graph, source, target, capacity = NULL) { + # nocov start lifecycle::deprecate_soft("2.0.0", "graph.maxflow()", "max_flow()") max_flow(graph = graph, source = source, target = target, capacity = capacity) } # nocov end @@ -158,7 +215,8 @@ graph.maxflow <- function(graph, source, target, capacity = NULL) { # nocov star #' @inheritParams adhesion #' @keywords internal #' @export -graph.adhesion <- function(graph, checks = TRUE) { # nocov start +graph.adhesion <- function(graph, checks = TRUE) { + # nocov start lifecycle::deprecate_soft("2.0.0", "graph.adhesion()", "adhesion()") adhesion(graph = graph, checks = checks) } # nocov end @@ -173,9 +231,24 @@ graph.adhesion <- function(graph, checks = TRUE) { # nocov start #' @inheritParams edge_connectivity #' @keywords internal #' @export -edge.disjoint.paths <- function(graph, source = NULL, target = NULL, checks = TRUE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "edge.disjoint.paths()", "edge_connectivity()") - edge_connectivity(graph = graph, source = source, target = target, checks = checks) +edge.disjoint.paths <- function( + graph, + source = NULL, + target = NULL, + checks = TRUE +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "edge.disjoint.paths()", + "edge_connectivity()" + ) + edge_connectivity( + graph = graph, + source = source, + target = target, + checks = checks + ) } # nocov end #' Edge connectivity @@ -188,9 +261,24 @@ edge.disjoint.paths <- function(graph, source = NULL, target = NULL, checks = TR #' @inheritParams edge_connectivity #' @keywords internal #' @export -edge.connectivity <- function(graph, source = NULL, target = NULL, checks = TRUE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "edge.connectivity()", "edge_connectivity()") - edge_connectivity(graph = graph, source = source, target = target, checks = checks) +edge.connectivity <- function( + graph, + source = NULL, + target = NULL, + checks = TRUE +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "edge.connectivity()", + "edge_connectivity()" + ) + edge_connectivity( + graph = graph, + source = source, + target = target, + checks = checks + ) } # nocov end #' Dominator tree @@ -203,7 +291,8 @@ edge.connectivity <- function(graph, source = NULL, target = NULL, checks = TRUE #' @inheritParams dominator_tree #' @keywords internal #' @export -dominator.tree <- function(graph, root, mode = c("out", "in", "all", "total")) { # nocov start +dominator.tree <- function(graph, root, mode = c("out", "in", "all", "total")) { + # nocov start lifecycle::deprecate_soft("2.0.0", "dominator.tree()", "dominator_tree()") dominator_tree(graph = graph, root = root, mode = mode) } # nocov end @@ -294,7 +383,13 @@ dominator.tree <- function(graph, root, mode = c("out", "in", "all", "total")) { #' min_cut(g2, value.only = FALSE) #' @family flow #' @export -min_cut <- function(graph, source = NULL, target = NULL, capacity = NULL, value.only = TRUE) { +min_cut <- function( + graph, + source = NULL, + target = NULL, + capacity = NULL, + value.only = TRUE +) { ensure_igraph(graph) if (is.null(capacity) && "capacity" %in% edge_attr_names(graph)) { capacity <- E(graph)$capacity @@ -332,15 +427,19 @@ min_cut <- function(graph, source = NULL, target = NULL, capacity = NULL, value. } else { if (value.only) { res <- .Call( - R_igraph_st_mincut_value, graph, + R_igraph_st_mincut_value, + graph, as_igraph_vs(graph, source) - 1, - as_igraph_vs(graph, target) - 1, capacity + as_igraph_vs(graph, target) - 1, + capacity ) } else { res <- .Call( - R_igraph_st_mincut, graph, + R_igraph_st_mincut, + graph, as_igraph_vs(graph, source) - 1, - as_igraph_vs(graph, target) - 1, capacity + as_igraph_vs(graph, target) - 1, + capacity ) # No need to add +1 here; R_igraph_st_mincut() is autogenerated and # adds +1 already @@ -356,7 +455,6 @@ min_cut <- function(graph, source = NULL, target = NULL, capacity = NULL, value. } - #' Vertex connectivity #' #' The vertex connectivity of a graph or two vertices, this is recently also @@ -433,7 +531,12 @@ min_cut <- function(graph, source = NULL, target = NULL, capacity = NULL, value. #' g <- induced_subgraph(g, subcomponent(g, 1)) #' cohesion(g) #' -vertex_connectivity <- function(graph, source = NULL, target = NULL, checks = TRUE) { +vertex_connectivity <- function( + graph, + source = NULL, + target = NULL, + checks = TRUE +) { ensure_igraph(graph) if (is.null(source) && is.null(target)) { @@ -442,7 +545,9 @@ vertex_connectivity <- function(graph, source = NULL, target = NULL, checks = TR } else if (!is.null(source) && !is.null(target)) { on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_st_vertex_connectivity, graph, as_igraph_vs(graph, source) - 1, + R_igraph_st_vertex_connectivity, + graph, + as_igraph_vs(graph, source) - 1, as_igraph_vs(graph, target) - 1 ) } else { @@ -454,7 +559,6 @@ vertex_connectivity <- function(graph, source = NULL, target = NULL, checks = TR } - #' Edge connectivity #' #' The edge connectivity of a graph or two vertices, this is recently also @@ -533,7 +637,12 @@ vertex_connectivity <- function(graph, source = NULL, target = NULL, checks = TR #' g <- induced_subgraph(g, subcomponent(g, 1)) #' adhesion(g) #' -edge_connectivity <- function(graph, source = NULL, target = NULL, checks = TRUE) { +edge_connectivity <- function( + graph, + source = NULL, + target = NULL, + checks = TRUE +) { ensure_igraph(graph) if (is.null(source) && is.null(target)) { @@ -542,8 +651,10 @@ edge_connectivity <- function(graph, source = NULL, target = NULL, checks = TRUE } else if (!is.null(source) && !is.null(target)) { on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_st_edge_connectivity, graph, - as_igraph_vs(graph, source) - 1, as_igraph_vs(graph, target) - 1 + R_igraph_st_edge_connectivity, + graph, + as_igraph_vs(graph, source) - 1, + as_igraph_vs(graph, target) - 1 ) } else { cli::cli_abort(c( @@ -562,8 +673,10 @@ edge_disjoint_paths <- function(graph, source = NULL, target = NULL) { } on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_edge_disjoint_paths, graph, - as_igraph_vs(graph, source) - 1, as_igraph_vs(graph, target) - 1 + R_igraph_edge_disjoint_paths, + graph, + as_igraph_vs(graph, source) - 1, + as_igraph_vs(graph, target) - 1 ) } @@ -577,7 +690,9 @@ vertex_disjoint_paths <- function(graph, source = NULL, target = NULL) { on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_vertex_disjoint_paths, graph, as_igraph_vs(graph, source) - 1, + R_igraph_vertex_disjoint_paths, + graph, + as_igraph_vs(graph, source) - 1, as_igraph_vs(graph, target) - 1 ) } @@ -777,7 +892,8 @@ dominator_tree <- function(graph, root, mode = c("out", "in", "all", "total")) { } root <- as_igraph_vs(graph, root) - mode <- switch(igraph.match.arg(mode), + mode <- switch( + igraph.match.arg(mode), "out" = 1, "in" = 2, "all" = 3, From 081b671e85a587d1da6bbf4a090918991ad32d47 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:48:58 +0200 Subject: [PATCH 15/59] fit --- R/fit.R | 59 ++++++++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 44 insertions(+), 15 deletions(-) diff --git a/R/fit.R b/R/fit.R index 31182c33dcf..95a08fd92a9 100644 --- a/R/fit.R +++ b/R/fit.R @@ -8,9 +8,24 @@ #' @inheritParams fit_power_law #' @keywords internal #' @export -power.law.fit <- function(x, xmin = NULL, start = 2, force.continuous = FALSE, implementation = c("plfit", "R.mle"), ...) { # nocov start +power.law.fit <- function( + x, + xmin = NULL, + start = 2, + force.continuous = FALSE, + implementation = c("plfit", "R.mle"), + ... +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "power.law.fit()", "fit_power_law()") - fit_power_law(x = x, xmin = xmin, start = start, force.continuous = force.continuous, implementation = implementation, ...) + fit_power_law( + x = x, + xmin = xmin, + start = start, + force.continuous = force.continuous, + implementation = implementation, + ... + ) } # nocov end # IGraph R package # Copyright (C) 2005-2012 Gabor Csardi @@ -38,8 +53,6 @@ power.law.fit <- function(x, xmin = NULL, start = 2, force.continuous = FALSE, i # this is a common degree distribution in networks ################################################################### - - #' Fitting a power-law distribution function to discrete data #' #' `fit_power_law()` fits a power-law distribution to a data set. @@ -168,19 +181,22 @@ power.law.fit <- function(x, xmin = NULL, start = 2, force.continuous = FALSE, i #' stats4::logLik(fit2) #' fit_power_law <- function( - x, - xmin = NULL, - start = 2, - force.continuous = FALSE, - implementation = c("plfit", "R.mle"), - p.value = FALSE, - p.precision = NULL, - ...) { + x, + xmin = NULL, + start = 2, + force.continuous = FALSE, + implementation = c("plfit", "R.mle"), + p.value = FALSE, + p.precision = NULL, + ... +) { implementation <- igraph.match.arg(implementation) if (implementation == "r.mle") { if (isTRUE(p.value)) { - cli::cli_abort("{.arg p.value} is not supported for {.arg implementation} = {.str R.mle}") + cli::cli_abort( + "{.arg p.value} is not supported for {.arg implementation} = {.str R.mle}" + ) } power.law.fit.old(x, xmin, start, ...) } else if (implementation == "plfit.p") { @@ -237,7 +253,13 @@ power.law.fit.old <- function(x, xmin = NULL, start = 2, ...) { alpha } -power.law.fit.new <- function(data, xmin = -1, force.continuous = FALSE, p.value = FALSE, p.precision = 0.01) { +power.law.fit.new <- function( + data, + xmin = -1, + force.continuous = FALSE, + p.value = FALSE, + p.precision = 0.01 +) { # Argument checks data <- as.numeric(data) xmin <- as.numeric(xmin) @@ -245,7 +267,14 @@ power.law.fit.new <- function(data, xmin = -1, force.continuous = FALSE, p.value on.exit(.Call(R_igraph_finalizer)) # Function call - res <- .Call(R_igraph_power_law_fit_new, data, xmin, force.continuous, p.value, p.precision) + res <- .Call( + R_igraph_power_law_fit_new, + data, + xmin, + force.continuous, + p.value, + p.precision + ) res } From ff0c4d24181f0082800d737a993abdabbe99af03 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:49:25 +0200 Subject: [PATCH 16/59] epi --- R/epi.R | 52 +++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 39 insertions(+), 13 deletions(-) diff --git a/R/epi.R b/R/epi.R index b1073ba411d..8c19cc05ff3 100644 --- a/R/epi.R +++ b/R/epi.R @@ -102,8 +102,6 @@ quantile.sir <- function(x, comp = c("NI", "NS", "NR"), prob, ...) { # Outputs: None. Just produces the plot of all compartment curves, # with median and quantiles. - - #' Plotting the results on multiple SIR model runs #' #' This function can conveniently plot the results of multiple SIR model @@ -151,11 +149,23 @@ quantile.sir <- function(x, comp = c("NI", "NS", "NR"), prob, ...) { #' sm <- sir(g, beta = 5, gamma = 1) #' plot(sm) #' -plot.sir <- function(x, comp = c("NI", "NS", "NR"), - median = TRUE, quantiles = c(0.1, 0.9), color = NULL, - median_color = NULL, quantile_color = NULL, - lwd.median = 2, lwd.quantile = 2, lty.quantile = 3, - xlim = NULL, ylim = NULL, xlab = "Time", ylab = NULL, ...) { +plot.sir <- function( + x, + comp = c("NI", "NS", "NR"), + median = TRUE, + quantiles = c(0.1, 0.9), + color = NULL, + median_color = NULL, + quantile_color = NULL, + lwd.median = 2, + lwd.quantile = 2, + lty.quantile = 3, + xlim = NULL, + ylim = NULL, + xlab = "Time", + ylab = NULL, + ... +) { sir <- x if (!inherits(sir, "sir")) { @@ -197,7 +207,16 @@ plot.sir <- function(x, comp = c("NI", "NS", "NR"), } # Plot the stochastic curves individually. - plot(0, 0, type = "n", xlim = xlim, ylim = ylim, xlab = xlab, ylab = ylab, ...) + plot( + 0, + 0, + type = "n", + xlim = xlim, + ylim = ylim, + xlab = xlab, + ylab = ylab, + ... + ) lapply(seq_along(sir), function(i) { lines(sir[[i]]$times, sir[[i]][[comp]], col = color[1]) }) @@ -207,16 +226,23 @@ plot.sir <- function(x, comp = c("NI", "NS", "NR"), time.bin <- time_bins(sir, middle = TRUE) } if (median) { - lines(time.bin, median(sir)[[comp]], + lines( + time.bin, + median(sir)[[comp]], type = "l", - lwd = lwd.median, col = median_color + lwd = lwd.median, + col = median_color ) } for (i in seq_along(quantiles)) { my.ql <- quantile(sir, comp, quantiles[i]) - lines(time.bin, my.ql, - type = "l", lty = lty.quantile, - lwd = lwd.quantile, col = quantile_color[i] + lines( + time.bin, + my.ql, + type = "l", + lty = lty.quantile, + lwd = lwd.quantile, + col = quantile_color[i] ) } From 36e78aa80ac630399558d0934c9c68214efb56fd Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:50:37 +0200 Subject: [PATCH 17/59] games --- R/games.R | 959 +++++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 762 insertions(+), 197 deletions(-) diff --git a/R/games.R b/R/games.R index a49aea1d710..6661c7dcdc3 100644 --- a/R/games.R +++ b/R/games.R @@ -8,9 +8,28 @@ #' @inheritParams sample_smallworld #' @keywords internal #' @export -watts.strogatz.game <- function(dim, size, nei, p, loops = FALSE, multiple = FALSE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "watts.strogatz.game()", "sample_smallworld()") - sample_smallworld(dim = dim, size = size, nei = nei, p = p, loops = loops, multiple = multiple) +watts.strogatz.game <- function( + dim, + size, + nei, + p, + loops = FALSE, + multiple = FALSE +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "watts.strogatz.game()", + "sample_smallworld()" + ) + sample_smallworld( + dim = dim, + size = size, + nei = nei, + p = p, + loops = loops, + multiple = multiple + ) } # nocov end #' Scale-free random graphs, from vertex fitness scores @@ -23,9 +42,30 @@ watts.strogatz.game <- function(dim, size, nei, p, loops = FALSE, multiple = FAL #' @inheritParams sample_fitness_pl #' @keywords internal #' @export -static.power.law.game <- function(no.of.nodes, no.of.edges, exponent.out, exponent.in = -1, loops = FALSE, multiple = FALSE, finite.size.correction = TRUE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "static.power.law.game()", "sample_fitness_pl()") - sample_fitness_pl(no.of.nodes = no.of.nodes, no.of.edges = no.of.edges, exponent.out = exponent.out, exponent.in = exponent.in, loops = loops, multiple = multiple, finite.size.correction = finite.size.correction) +static.power.law.game <- function( + no.of.nodes, + no.of.edges, + exponent.out, + exponent.in = -1, + loops = FALSE, + multiple = FALSE, + finite.size.correction = TRUE +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "static.power.law.game()", + "sample_fitness_pl()" + ) + sample_fitness_pl( + no.of.nodes = no.of.nodes, + no.of.edges = no.of.edges, + exponent.out = exponent.out, + exponent.in = exponent.in, + loops = loops, + multiple = multiple, + finite.size.correction = finite.size.correction + ) } # nocov end #' Random graphs from vertex fitness scores @@ -38,9 +78,26 @@ static.power.law.game <- function(no.of.nodes, no.of.edges, exponent.out, expone #' @inheritParams sample_fitness #' @keywords internal #' @export -static.fitness.game <- function(no.of.edges, fitness.out, fitness.in = NULL, loops = FALSE, multiple = FALSE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "static.fitness.game()", "sample_fitness()") - sample_fitness(no.of.edges = no.of.edges, fitness.out = fitness.out, fitness.in = fitness.in, loops = loops, multiple = multiple) +static.fitness.game <- function( + no.of.edges, + fitness.out, + fitness.in = NULL, + loops = FALSE, + multiple = FALSE +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "static.fitness.game()", + "sample_fitness()" + ) + sample_fitness( + no.of.edges = no.of.edges, + fitness.out = fitness.out, + fitness.in = fitness.in, + loops = loops, + multiple = multiple + ) } # nocov end #' Sample stochastic block model @@ -53,9 +110,22 @@ static.fitness.game <- function(no.of.edges, fitness.out, fitness.in = NULL, loo #' @inheritParams sample_sbm #' @keywords internal #' @export -sbm.game <- function(n, pref.matrix, block.sizes, directed = FALSE, loops = FALSE) { # nocov start +sbm.game <- function( + n, + pref.matrix, + block.sizes, + directed = FALSE, + loops = FALSE +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "sbm.game()", "sample_sbm()") - sample_sbm(n = n, pref.matrix = pref.matrix, block.sizes = block.sizes, directed = directed, loops = loops) + sample_sbm( + n = n, + pref.matrix = pref.matrix, + block.sizes = block.sizes, + directed = directed, + loops = loops + ) } # nocov end #' Trait-based random generation @@ -68,9 +138,26 @@ sbm.game <- function(n, pref.matrix, block.sizes, directed = FALSE, loops = FALS #' @inheritParams sample_pref #' @keywords internal #' @export -preference.game <- function(nodes, types, type.dist = rep(1, types), fixed.sizes = FALSE, pref.matrix = matrix(1, types, types), directed = FALSE, loops = FALSE) { # nocov start +preference.game <- function( + nodes, + types, + type.dist = rep(1, types), + fixed.sizes = FALSE, + pref.matrix = matrix(1, types, types), + directed = FALSE, + loops = FALSE +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "preference.game()", "sample_pref()") - sample_pref(nodes = nodes, types = types, type.dist = type.dist, fixed.sizes = fixed.sizes, pref.matrix = pref.matrix, directed = directed, loops = loops) + sample_pref( + nodes = nodes, + types = types, + type.dist = type.dist, + fixed.sizes = fixed.sizes, + pref.matrix = pref.matrix, + directed = directed, + loops = loops + ) } # nocov end #' Random citation graphs @@ -83,9 +170,22 @@ preference.game <- function(nodes, types, type.dist = rep(1, types), fixed.sizes #' @inheritParams sample_last_cit #' @keywords internal #' @export -lastcit.game <- function(n, edges = 1, agebins = n / 7100, pref = (1:(agebins + 1))^-3, directed = TRUE) { # nocov start +lastcit.game <- function( + n, + edges = 1, + agebins = n / 7100, + pref = (1:(agebins + 1))^-3, + directed = TRUE +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "lastcit.game()", "sample_last_cit()") - sample_last_cit(n = n, edges = edges, agebins = agebins, pref = pref, directed = directed) + sample_last_cit( + n = n, + edges = edges, + agebins = agebins, + pref = pref, + directed = directed + ) } # nocov end #' Create a random regular graph @@ -98,9 +198,15 @@ lastcit.game <- function(n, edges = 1, agebins = n / 7100, pref = (1:(agebins + #' @inheritParams sample_k_regular #' @keywords internal #' @export -k.regular.game <- function(no.of.nodes, k, directed = FALSE, multiple = FALSE) { # nocov start +k.regular.game <- function(no.of.nodes, k, directed = FALSE, multiple = FALSE) { + # nocov start lifecycle::deprecate_soft("2.0.0", "k.regular.game()", "sample_k_regular()") - sample_k_regular(no.of.nodes = no.of.nodes, k = k, directed = directed, multiple = multiple) + sample_k_regular( + no.of.nodes = no.of.nodes, + k = k, + directed = directed, + multiple = multiple + ) } # nocov end #' A graph with subgraphs that are each a random graph. @@ -113,9 +219,24 @@ k.regular.game <- function(no.of.nodes, k, directed = FALSE, multiple = FALSE) { #' @inheritParams sample_islands #' @keywords internal #' @export -interconnected.islands.game <- function(islands.n, islands.size, islands.pin, n.inter) { # nocov start - lifecycle::deprecate_soft("2.0.0", "interconnected.islands.game()", "sample_islands()") - sample_islands(islands.n = islands.n, islands.size = islands.size, islands.pin = islands.pin, n.inter = n.inter) +interconnected.islands.game <- function( + islands.n, + islands.size, + islands.pin, + n.inter +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "interconnected.islands.game()", + "sample_islands()" + ) + sample_islands( + islands.n = islands.n, + islands.size = islands.size, + islands.pin = islands.pin, + n.inter = n.inter + ) } # nocov end #' Geometric random graphs @@ -128,7 +249,8 @@ interconnected.islands.game <- function(islands.n, islands.size, islands.pin, n. #' @inheritParams sample_grg #' @keywords internal #' @export -grg.game <- function(nodes, radius, torus = FALSE, coords = FALSE) { # nocov start +grg.game <- function(nodes, radius, torus = FALSE, coords = FALSE) { + # nocov start lifecycle::deprecate_soft("2.0.0", "grg.game()", "sample_grg()") sample_grg(nodes = nodes, radius = radius, torus = torus, coords = coords) } # nocov end @@ -143,8 +265,13 @@ grg.game <- function(nodes, radius, torus = FALSE, coords = FALSE) { # nocov sta #' @inheritParams sample_growing #' @keywords internal #' @export -growing.random.game <- function(n, m = 1, directed = TRUE, citation = FALSE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "growing.random.game()", "sample_growing()") +growing.random.game <- function(n, m = 1, directed = TRUE, citation = FALSE) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "growing.random.game()", + "sample_growing()" + ) sample_growing(n = n, m = m, directed = directed, citation = citation) } # nocov end @@ -158,9 +285,26 @@ growing.random.game <- function(n, m = 1, directed = TRUE, citation = FALSE) { # #' @inheritParams sample_forestfire #' @keywords internal #' @export -forest.fire.game <- function(nodes, fw.prob, bw.factor = 1, ambs = 1, directed = TRUE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "forest.fire.game()", "sample_forestfire()") - sample_forestfire(nodes = nodes, fw.prob = fw.prob, bw.factor = bw.factor, ambs = ambs, directed = directed) +forest.fire.game <- function( + nodes, + fw.prob, + bw.factor = 1, + ambs = 1, + directed = TRUE +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "forest.fire.game()", + "sample_forestfire()" + ) + sample_forestfire( + nodes = nodes, + fw.prob = fw.prob, + bw.factor = bw.factor, + ambs = ambs, + directed = directed + ) } # nocov end #' Graph generation based on different vertex types @@ -173,9 +317,24 @@ forest.fire.game <- function(nodes, fw.prob, bw.factor = 1, ambs = 1, directed = #' @inheritParams sample_traits #' @keywords internal #' @export -establishment.game <- function(nodes, types, k = 1, type.dist = rep(1, types), pref.matrix = matrix(1, types, types), directed = FALSE) { # nocov start +establishment.game <- function( + nodes, + types, + k = 1, + type.dist = rep(1, types), + pref.matrix = matrix(1, types, types), + directed = FALSE +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "establishment.game()", "sample_traits()") - sample_traits(nodes = nodes, types = types, k = k, type.dist = type.dist, pref.matrix = pref.matrix, directed = directed) + sample_traits( + nodes = nodes, + types = types, + k = k, + type.dist = type.dist, + pref.matrix = pref.matrix, + directed = directed + ) } # nocov end #' Generate random graphs with a given degree sequence @@ -188,8 +347,17 @@ establishment.game <- function(nodes, types, k = 1, type.dist = rep(1, types), p #' @inheritParams sample_degseq #' @keywords internal #' @export -degree.sequence.game <- function(out.deg, in.deg = NULL, method = c("simple", "vl", "simple.no.multiple", "simple.no.multiple.uniform")) { # nocov start - lifecycle::deprecate_soft("2.0.0", "degree.sequence.game()", "sample_degseq()") +degree.sequence.game <- function( + out.deg, + in.deg = NULL, + method = c("simple", "vl", "simple.no.multiple", "simple.no.multiple.uniform") +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "degree.sequence.game()", + "sample_degseq()" + ) sample_degseq(out.deg = out.deg, in.deg = in.deg, method = method) } # nocov end @@ -203,7 +371,12 @@ degree.sequence.game <- function(out.deg, in.deg = NULL, method = c("simple", "v #' @inheritParams connect #' @keywords internal #' @export -connect.neighborhood <- function(graph, order, mode = c("all", "out", "in", "total")) { # nocov start +connect.neighborhood <- function( + graph, + order, + mode = c("all", "out", "in", "total") +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "connect.neighborhood()", "connect()") connect(graph = graph, order = order, mode = mode) } # nocov end @@ -218,9 +391,28 @@ connect.neighborhood <- function(graph, order, mode = c("all", "out", "in", "tot #' @inheritParams sample_cit_cit_types #' @keywords internal #' @export -citing.cited.type.game <- function(n, edges = 1, types = rep(0, n), pref = matrix(1, nrow = length(types), ncol = length(types)), directed = TRUE, attr = TRUE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "citing.cited.type.game()", "sample_cit_cit_types()") - sample_cit_cit_types(n = n, edges = edges, types = types, pref = pref, directed = directed, attr = attr) +citing.cited.type.game <- function( + n, + edges = 1, + types = rep(0, n), + pref = matrix(1, nrow = length(types), ncol = length(types)), + directed = TRUE, + attr = TRUE +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "citing.cited.type.game()", + "sample_cit_cit_types()" + ) + sample_cit_cit_types( + n = n, + edges = edges, + types = types, + pref = pref, + directed = directed, + attr = attr + ) } # nocov end #' Random citation graphs @@ -233,9 +425,24 @@ citing.cited.type.game <- function(n, edges = 1, types = rep(0, n), pref = matri #' @inheritParams sample_cit_types #' @keywords internal #' @export -cited.type.game <- function(n, edges = 1, types = rep(0, n), pref = rep(1, length(types)), directed = TRUE, attr = TRUE) { # nocov start +cited.type.game <- function( + n, + edges = 1, + types = rep(0, n), + pref = rep(1, length(types)), + directed = TRUE, + attr = TRUE +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "cited.type.game()", "sample_cit_types()") - sample_cit_types(n = n, edges = edges, types = types, pref = pref, directed = directed, attr = attr) + sample_cit_types( + n = n, + edges = edges, + types = types, + pref = pref, + directed = directed, + attr = attr + ) } # nocov end #' Graph generation based on different vertex types @@ -248,9 +455,28 @@ cited.type.game <- function(n, edges = 1, types = rep(0, n), pref = rep(1, lengt #' @inheritParams sample_traits_callaway #' @keywords internal #' @export -callaway.traits.game <- function(nodes, types, edge.per.step = 1, type.dist = rep(1, types), pref.matrix = matrix(1, types, types), directed = FALSE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "callaway.traits.game()", "sample_traits_callaway()") - sample_traits_callaway(nodes = nodes, types = types, edge.per.step = edge.per.step, type.dist = type.dist, pref.matrix = pref.matrix, directed = directed) +callaway.traits.game <- function( + nodes, + types, + edge.per.step = 1, + type.dist = rep(1, types), + pref.matrix = matrix(1, types, types), + directed = FALSE +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "callaway.traits.game()", + "sample_traits_callaway()" + ) + sample_traits_callaway( + nodes = nodes, + types = types, + edge.per.step = edge.per.step, + type.dist = type.dist, + pref.matrix = pref.matrix, + directed = directed + ) } # nocov end #' Bipartite random graphs @@ -263,12 +489,30 @@ callaway.traits.game <- function(nodes, types, edge.per.step = 1, type.dist = re #' @inheritParams sample_bipartite #' @keywords internal #' @export -bipartite.random.game <- function(n1, n2, type = c("gnp", "gnm"), p, m, directed = FALSE, mode = c("out", "in", "all")) { # nocov start +bipartite.random.game <- function( + n1, + n2, + type = c("gnp", "gnm"), + p, + m, + directed = FALSE, + mode = c("out", "in", "all") +) { + # nocov start lifecycle::deprecate_warn( - "2.0.0", "bipartite.random.game()", + "2.0.0", + "bipartite.random.game()", details = "Use sample_bipartite_gnp() or sample_bipartite_gnm()" ) - sample_bipartite(n1 = n1, n2 = n2, type = type, p = p, m = m, directed = directed, mode = mode) + sample_bipartite( + n1 = n1, + n2 = n2, + type = type, + p = p, + m = m, + directed = directed, + mode = mode + ) } # nocov end #' Generate random graphs using preferential attachment @@ -281,9 +525,32 @@ bipartite.random.game <- function(n1, n2, type = c("gnp", "gnm"), p, m, directed #' @inheritParams sample_pa #' @keywords internal #' @export -barabasi.game <- function(n, power = 1, m = NULL, out.dist = NULL, out.seq = NULL, out.pref = FALSE, zero.appeal = 1, directed = TRUE, algorithm = c("psumtree", "psumtree-multiple", "bag"), start.graph = NULL) { # nocov start +barabasi.game <- function( + n, + power = 1, + m = NULL, + out.dist = NULL, + out.seq = NULL, + out.pref = FALSE, + zero.appeal = 1, + directed = TRUE, + algorithm = c("psumtree", "psumtree-multiple", "bag"), + start.graph = NULL +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "barabasi.game()", "sample_pa()") - sample_pa(n = n, power = power, m = m, out.dist = out.dist, out.seq = out.seq, out.pref = out.pref, zero.appeal = zero.appeal, directed = directed, algorithm = algorithm, start.graph = start.graph) + sample_pa( + n = n, + power = power, + m = m, + out.dist = out.dist, + out.seq = out.seq, + out.pref = out.pref, + zero.appeal = zero.appeal, + directed = directed, + algorithm = algorithm, + start.graph = start.graph + ) } # nocov end #' Generate random graphs using preferential attachment @@ -296,9 +563,32 @@ barabasi.game <- function(n, power = 1, m = NULL, out.dist = NULL, out.seq = NUL #' @inheritParams sample_pa #' @keywords internal #' @export -ba.game <- function(n, power = 1, m = NULL, out.dist = NULL, out.seq = NULL, out.pref = FALSE, zero.appeal = 1, directed = TRUE, algorithm = c("psumtree", "psumtree-multiple", "bag"), start.graph = NULL) { # nocov start +ba.game <- function( + n, + power = 1, + m = NULL, + out.dist = NULL, + out.seq = NULL, + out.pref = FALSE, + zero.appeal = 1, + directed = TRUE, + algorithm = c("psumtree", "psumtree-multiple", "bag"), + start.graph = NULL +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "ba.game()", "sample_pa()") - sample_pa(n = n, power = power, m = m, out.dist = out.dist, out.seq = out.seq, out.pref = out.pref, zero.appeal = zero.appeal, directed = directed, algorithm = algorithm, start.graph = start.graph) + sample_pa( + n = n, + power = power, + m = m, + out.dist = out.dist, + out.seq = out.seq, + out.pref = out.pref, + zero.appeal = zero.appeal, + directed = directed, + algorithm = algorithm, + start.graph = start.graph + ) } # nocov end #' Trait-based random generation @@ -311,9 +601,26 @@ ba.game <- function(n, power = 1, m = NULL, out.dist = NULL, out.seq = NULL, out #' @inheritParams sample_asym_pref #' @keywords internal #' @export -asymmetric.preference.game <- function(nodes, types, type.dist.matrix = matrix(1, types, types), pref.matrix = matrix(1, types, types), loops = FALSE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "asymmetric.preference.game()", "sample_asym_pref()") - sample_asym_pref(nodes = nodes, types = types, type.dist.matrix = type.dist.matrix, pref.matrix = pref.matrix, loops = loops) +asymmetric.preference.game <- function( + nodes, + types, + type.dist.matrix = matrix(1, types, types), + pref.matrix = matrix(1, types, types), + loops = FALSE +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "asymmetric.preference.game()", + "sample_asym_pref()" + ) + sample_asym_pref( + nodes = nodes, + types = types, + type.dist.matrix = type.dist.matrix, + pref.matrix = pref.matrix, + loops = loops + ) } # nocov end #' Generate an evolving random graph with preferential attachment and aging @@ -326,9 +633,40 @@ asymmetric.preference.game <- function(nodes, types, type.dist.matrix = matrix(1 #' @inheritParams sample_pa_age #' @keywords internal #' @export -aging.barabasi.game <- function(n, pa.exp, aging.exp, m = NULL, aging.bin = 300, out.dist = NULL, out.seq = NULL, out.pref = FALSE, directed = TRUE, zero.deg.appeal = 1, zero.age.appeal = 0, deg.coef = 1, age.coef = 1, time.window = NULL) { # nocov start +aging.barabasi.game <- function( + n, + pa.exp, + aging.exp, + m = NULL, + aging.bin = 300, + out.dist = NULL, + out.seq = NULL, + out.pref = FALSE, + directed = TRUE, + zero.deg.appeal = 1, + zero.age.appeal = 0, + deg.coef = 1, + age.coef = 1, + time.window = NULL +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "aging.barabasi.game()", "sample_pa_age()") - sample_pa_age(n = n, pa.exp = pa.exp, aging.exp = aging.exp, m = m, aging.bin = aging.bin, out.dist = out.dist, out.seq = out.seq, out.pref = out.pref, directed = directed, zero.deg.appeal = zero.deg.appeal, zero.age.appeal = zero.age.appeal, deg.coef = deg.coef, age.coef = age.coef, time.window = time.window) + sample_pa_age( + n = n, + pa.exp = pa.exp, + aging.exp = aging.exp, + m = m, + aging.bin = aging.bin, + out.dist = out.dist, + out.seq = out.seq, + out.pref = out.pref, + directed = directed, + zero.deg.appeal = zero.deg.appeal, + zero.age.appeal = zero.age.appeal, + deg.coef = deg.coef, + age.coef = age.coef, + time.window = time.window + ) } # nocov end #' Generate an evolving random graph with preferential attachment and aging @@ -341,9 +679,40 @@ aging.barabasi.game <- function(n, pa.exp, aging.exp, m = NULL, aging.bin = 300, #' @inheritParams sample_pa_age #' @keywords internal #' @export -aging.ba.game <- function(n, pa.exp, aging.exp, m = NULL, aging.bin = 300, out.dist = NULL, out.seq = NULL, out.pref = FALSE, directed = TRUE, zero.deg.appeal = 1, zero.age.appeal = 0, deg.coef = 1, age.coef = 1, time.window = NULL) { # nocov start +aging.ba.game <- function( + n, + pa.exp, + aging.exp, + m = NULL, + aging.bin = 300, + out.dist = NULL, + out.seq = NULL, + out.pref = FALSE, + directed = TRUE, + zero.deg.appeal = 1, + zero.age.appeal = 0, + deg.coef = 1, + age.coef = 1, + time.window = NULL +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "aging.ba.game()", "sample_pa_age()") - sample_pa_age(n = n, pa.exp = pa.exp, aging.exp = aging.exp, m = m, aging.bin = aging.bin, out.dist = out.dist, out.seq = out.seq, out.pref = out.pref, directed = directed, zero.deg.appeal = zero.deg.appeal, zero.age.appeal = zero.age.appeal, deg.coef = deg.coef, age.coef = age.coef, time.window = time.window) + sample_pa_age( + n = n, + pa.exp = pa.exp, + aging.exp = aging.exp, + m = m, + aging.bin = aging.bin, + out.dist = out.dist, + out.seq = out.seq, + out.pref = out.pref, + directed = directed, + zero.deg.appeal = zero.deg.appeal, + zero.age.appeal = zero.age.appeal, + deg.coef = deg.coef, + age.coef = age.coef, + time.window = time.window + ) } # nocov end #' Generate an evolving random graph with preferential attachment and aging @@ -356,9 +725,40 @@ aging.ba.game <- function(n, pa.exp, aging.exp, m = NULL, aging.bin = 300, out.d #' @inheritParams sample_pa_age #' @keywords internal #' @export -aging.prefatt.game <- function(n, pa.exp, aging.exp, m = NULL, aging.bin = 300, out.dist = NULL, out.seq = NULL, out.pref = FALSE, directed = TRUE, zero.deg.appeal = 1, zero.age.appeal = 0, deg.coef = 1, age.coef = 1, time.window = NULL) { # nocov start +aging.prefatt.game <- function( + n, + pa.exp, + aging.exp, + m = NULL, + aging.bin = 300, + out.dist = NULL, + out.seq = NULL, + out.pref = FALSE, + directed = TRUE, + zero.deg.appeal = 1, + zero.age.appeal = 0, + deg.coef = 1, + age.coef = 1, + time.window = NULL +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "aging.prefatt.game()", "sample_pa_age()") - sample_pa_age(n = n, pa.exp = pa.exp, aging.exp = aging.exp, m = m, aging.bin = aging.bin, out.dist = out.dist, out.seq = out.seq, out.pref = out.pref, directed = directed, zero.deg.appeal = zero.deg.appeal, zero.age.appeal = zero.age.appeal, deg.coef = deg.coef, age.coef = age.coef, time.window = time.window) + sample_pa_age( + n = n, + pa.exp = pa.exp, + aging.exp = aging.exp, + m = m, + aging.bin = aging.bin, + out.dist = out.dist, + out.seq = out.seq, + out.pref = out.pref, + directed = directed, + zero.deg.appeal = zero.deg.appeal, + zero.age.appeal = zero.age.appeal, + deg.coef = deg.coef, + age.coef = age.coef, + time.window = time.window + ) } # nocov end ## ----------------------------------------------------------------- @@ -474,20 +874,33 @@ aging.prefatt.game <- function(n, pa.exp, aging.exp, m = NULL, aging.bin = 300, #' g <- sample_pa(10000) #' degree_distribution(g) #' -sample_pa <- function(n, power = 1, m = NULL, out.dist = NULL, out.seq = NULL, - out.pref = FALSE, zero.appeal = 1, - directed = TRUE, algorithm = c( - "psumtree", - "psumtree-multiple", "bag" - ), - start.graph = NULL) { +sample_pa <- function( + n, + power = 1, + m = NULL, + out.dist = NULL, + out.seq = NULL, + out.pref = FALSE, + zero.appeal = 1, + directed = TRUE, + algorithm = c( + "psumtree", + "psumtree-multiple", + "bag" + ), + start.graph = NULL +) { if (!is.null(start.graph) && !is_igraph(start.graph)) { - cli::cli_abort("{.arg start.graph} must be an {.cls igraph} object, not {.obj_type_friendly {start.graph}}.") + cli::cli_abort( + "{.arg start.graph} must be an {.cls igraph} object, not {.obj_type_friendly {start.graph}}." + ) } # Checks if (!is.null(out.seq) && (!is.null(m) || !is.null(out.dist))) { - cli::cli_warn("if {.arg out.seq} is given {.arg m} and {.arg out.dist} should be {.code NULL}.") + cli::cli_warn( + "if {.arg out.seq} is given {.arg m} and {.arg out.dist} should be {.code NULL}." + ) m <- out.dist <- NULL } if (is.null(out.seq) && !is.null(out.dist) && !is.null(m)) { @@ -517,8 +930,11 @@ sample_pa <- function(n, power = 1, m = NULL, out.dist = NULL, out.seq = NULL, if (!is.null(out.dist)) { nn <- if (is.null(start.graph)) n else n - vcount(start.graph) - out.seq <- as.numeric(sample(0:(length(out.dist) - 1), nn, - replace = TRUE, prob = out.dist + out.seq <- as.numeric(sample( + 0:(length(out.dist) - 1), + nn, + replace = TRUE, + prob = out.dist )) } @@ -527,7 +943,8 @@ sample_pa <- function(n, power = 1, m = NULL, out.dist = NULL, out.seq = NULL, } algorithm <- igraph.match.arg(algorithm) - algorithm1 <- switch(algorithm, + algorithm1 <- switch( + algorithm, "psumtree" = 1, "psumtree-multiple" = 2, "bag" = 0 @@ -535,8 +952,16 @@ sample_pa <- function(n, power = 1, m = NULL, out.dist = NULL, out.seq = NULL, on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_barabasi_game, n, power, m, out.seq, out.pref, - zero.appeal, directed, algorithm1, start.graph + R_igraph_barabasi_game, + n, + power, + m, + out.seq, + out.pref, + zero.appeal, + directed, + algorithm1, + start.graph ) if (igraph_opt("add.params")) { @@ -558,7 +983,6 @@ pa <- function(...) constructor_spec(sample_pa, ...) ## ----------------------------------------------------------------- - #' Generate random graphs according to the \eqn{G(n,p)} Erdős-Rényi model #' #' Every possible edge is created independently with the same probability `p`. @@ -596,15 +1020,15 @@ pa <- function(...) constructor_spec(sample_pa, ...) #' plot(sample_gnp(6, 0.5)) sample_gnp <- function(n, p, directed = FALSE, loops = FALSE) { type <- "gnp" - type1 <- switch(type, - "gnp" = 0, - "gnm" = 1 - ) + type1 <- switch(type, "gnp" = 0, "gnm" = 1) on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_erdos_renyi_game_gnp, as.numeric(n), - as.numeric(p), as.logical(directed), as.logical(loops) + R_igraph_erdos_renyi_game_gnp, + as.numeric(n), + as.numeric(p), + as.logical(directed), + as.logical(loops) ) if (igraph_opt("add.params")) { @@ -623,8 +1047,6 @@ gnp <- function(...) constructor_spec(sample_gnp, ...) ## ----------------------------------------------------------------- - - #' Generate random graphs according to the \eqn{G(n,m)} Erdős-Rényi model #' #' Random graph with a fixed number of edges and vertices. @@ -651,15 +1073,15 @@ gnp <- function(...) constructor_spec(sample_gnp, ...) #' degree_distribution(g) sample_gnm <- function(n, m, directed = FALSE, loops = FALSE) { type <- "gnm" - type1 <- switch(type, - "gnp" = 0, - "gnm" = 1 - ) + type1 <- switch(type, "gnp" = 0, "gnm" = 1) on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_erdos_renyi_game_gnm, as.numeric(n), - as.numeric(m), as.logical(directed), as.logical(loops) + R_igraph_erdos_renyi_game_gnm, + as.numeric(n), + as.numeric(m), + as.logical(directed), + as.logical(loops) ) if (igraph_opt("add.params")) { @@ -713,8 +1135,13 @@ gnm <- function(...) constructor_spec(sample_gnm, ...) #' g <- erdos.renyi.game(1000, 1 / 1000) #' degree_distribution(g) #' -erdos.renyi.game <- function(n, p.or.m, type = c("gnp", "gnm"), - directed = FALSE, loops = FALSE) { +erdos.renyi.game <- function( + n, + p.or.m, + type = c("gnp", "gnm"), + directed = FALSE, + loops = FALSE +) { type <- igraph.match.arg(type) if (type == "gnp") { @@ -728,8 +1155,13 @@ erdos.renyi.game <- function(n, p.or.m, type = c("gnp", "gnm"), #' @family games #' @export -random.graph.game <- function(n, p.or.m, type = c("gnp", "gnm"), - directed = FALSE, loops = FALSE) { +random.graph.game <- function( + n, + p.or.m, + type = c("gnp", "gnm"), + directed = FALSE, + loops = FALSE +) { type <- igraph.match.arg(type) if (type == "gnp") { @@ -914,37 +1346,61 @@ random.graph.game <- function(n, p.or.m, type = c("gnp", "gnm"), #' powerlaw_vl_graph <- sample_degseq(powerlaw_degrees, method = "vl") #' all(degree(powerlaw_vl_graph) == powerlaw_degrees) #' -sample_degseq <- function(out.deg, in.deg = NULL, - method = c("configuration", "vl", "fast.heur.simple", "configuration.simple", "edge.switching.simple")) { +sample_degseq <- function( + out.deg, + in.deg = NULL, + method = c( + "configuration", + "vl", + "fast.heur.simple", + "configuration.simple", + "edge.switching.simple" + ) +) { if (missing(method)) { method <- method[1] } method <- igraph.match.arg( method, values = c( - "configuration", "vl", "fast.heur.simple", - "configuration.simple", "edge.switching.simple", - "simple", "simple.no.multiple", "simple.no.multiple.uniform" # old names + "configuration", + "vl", + "fast.heur.simple", + "configuration.simple", + "edge.switching.simple", + "simple", + "simple.no.multiple", + "simple.no.multiple.uniform" # old names ) ) if (method == "simple") { - lifecycle::deprecate_warn("2.1.0", "sample_degseq(method = 'must be configuration instead of simple')") + lifecycle::deprecate_warn( + "2.1.0", + "sample_degseq(method = 'must be configuration instead of simple')" + ) method <- "configuration" } if (method == "simple.no.multiple") { - lifecycle::deprecate_warn("2.1.0", "sample_degseq(method = 'must be fast.heur.simple instead of simple.no.multiple')") + lifecycle::deprecate_warn( + "2.1.0", + "sample_degseq(method = 'must be fast.heur.simple instead of simple.no.multiple')" + ) method <- "fast.heur.simple" } if (method == "simple.no.multiple.uniform") { - lifecycle::deprecate_warn("2.1.0", "sample_degseq(method = 'must be configuration.simple instead of simple.no.multiple.uniform')") + lifecycle::deprecate_warn( + "2.1.0", + "sample_degseq(method = 'must be configuration.simple instead of simple.no.multiple.uniform')" + ) method <- "configuration.simple" } # numbers from https://github.com/igraph/igraph/blob/640083c88bf85fd322ff7b748b9b4e16ebe32aa2/include/igraph_constants.h#L94 - method1 <- switch(method, + method1 <- switch( + method, "configuration" = 0, "vl" = 1, "fast.heur.simple" = 2, @@ -957,8 +1413,10 @@ sample_degseq <- function(out.deg, in.deg = NULL, on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_degree_sequence_game, as.numeric(out.deg), - in.deg, as.numeric(method1) + R_igraph_degree_sequence_game, + as.numeric(out.deg), + in.deg, + as.numeric(method1) ) if (igraph_opt("add.params")) { res$name <- "Degree sequence random graph" @@ -974,7 +1432,8 @@ sample_degseq <- function(out.deg, in.deg = NULL, #' @export degseq <- function(..., deterministic = FALSE) { constructor_spec( - if (deterministic) realize_degseq else sample_degseq, ... + if (deterministic) realize_degseq else sample_degseq, + ... ) } @@ -1015,7 +1474,6 @@ growing <- function(...) constructor_spec(sample_growing, ...) ## ----------------------------------------------------------------- - #' Generate an evolving random graph with preferential attachment and aging #' #' This function creates a random graph by simulating its evolution. Each time @@ -1110,15 +1568,27 @@ growing <- function(...) constructor_spec(sample_growing, ...) #' max(degree(g1)) #' max(degree(g2)) #' max(degree(g3)) -sample_pa_age <- function(n, pa.exp, aging.exp, m = NULL, aging.bin = 300, - out.dist = NULL, out.seq = NULL, - out.pref = FALSE, directed = TRUE, - zero.deg.appeal = 1, zero.age.appeal = 0, - deg.coef = 1, age.coef = 1, - time.window = NULL) { +sample_pa_age <- function( + n, + pa.exp, + aging.exp, + m = NULL, + aging.bin = 300, + out.dist = NULL, + out.seq = NULL, + out.pref = FALSE, + directed = TRUE, + zero.deg.appeal = 1, + zero.age.appeal = 0, + deg.coef = 1, + age.coef = 1, + time.window = NULL +) { # Checks if (!is.null(out.seq) && (!is.null(m) || !is.null(out.dist))) { - cli::cli_warn("if {.arg out.seq} is given {.arg m} and {.arg out.dist} should be {.code NULL}.") + cli::cli_warn( + "if {.arg out.seq} is given {.arg m} and {.arg out.dist} should be {.code NULL}." + ) m <- out.dist <- NULL } if (is.null(out.seq) && !is.null(out.dist) && !is.null(m)) { @@ -1126,7 +1596,9 @@ sample_pa_age <- function(n, pa.exp, aging.exp, m = NULL, aging.bin = 300, m <- NULL } if (!is.null(out.seq) && length(out.seq) != n) { - cli::cli_abort("{.arg out.seq} must have length {.val n}, not {.val {length( out.seq)}}.'") + cli::cli_abort( + "{.arg out.seq} must have length {.val n}, not {.val {length( out.seq)}}.'" + ) } if (!is.null(out.seq) && min(out.seq) < 0) { cli::cli_abort("{.arg out.seq} must not contain negative elements.") @@ -1144,7 +1616,9 @@ sample_pa_age <- function(n, pa.exp, aging.exp, m = NULL, aging.bin = 300, cli::cli_warn("Aging exponent {.arg aging.exp} is positive.") } if (zero.deg.appeal <= 0) { - cli::cli_warn("Initial attractiveness {.arg zero.deg.appeal} is not positive.") + cli::cli_warn( + "Initial attractiveness {.arg zero.deg.appeal} is not positive." + ) } if (is.null(m) && is.null(out.dist) && is.null(out.seq)) { @@ -1164,8 +1638,11 @@ sample_pa_age <- function(n, pa.exp, aging.exp, m = NULL, aging.bin = 300, out.pref <- as.logical(out.pref) if (!is.null(out.dist)) { - out.seq <- as.numeric(sample(0:(length(out.dist) - 1), n, - replace = TRUE, prob = out.dist + out.seq <- as.numeric(sample( + 0:(length(out.dist) - 1), + n, + replace = TRUE, + prob = out.dist )) } @@ -1176,18 +1653,33 @@ sample_pa_age <- function(n, pa.exp, aging.exp, m = NULL, aging.bin = 300, on.exit(.Call(R_igraph_finalizer)) res <- if (is.null(time.window)) { .Call( - R_igraph_barabasi_aging_game, as.numeric(n), - as.numeric(pa.exp), as.numeric(aging.exp), - as.numeric(aging.bin), m, out.seq, - out.pref, as.numeric(zero.deg.appeal), as.numeric(zero.age.appeal), - as.numeric(deg.coef), as.numeric(age.coef), directed + R_igraph_barabasi_aging_game, + as.numeric(n), + as.numeric(pa.exp), + as.numeric(aging.exp), + as.numeric(aging.bin), + m, + out.seq, + out.pref, + as.numeric(zero.deg.appeal), + as.numeric(zero.age.appeal), + as.numeric(deg.coef), + as.numeric(age.coef), + directed ) } else { .Call( - R_igraph_recent_degree_aging_game, as.numeric(n), - as.numeric(pa.exp), as.numeric(aging.exp), - as.numeric(aging.bin), m, out.seq, out.pref, as.numeric(zero.deg.appeal), - directed, time.window + R_igraph_recent_degree_aging_game, + as.numeric(n), + as.numeric(pa.exp), + as.numeric(aging.exp), + as.numeric(aging.bin), + m, + out.seq, + out.pref, + as.numeric(zero.deg.appeal), + directed, + time.window ) } if (igraph_opt("add.params")) { @@ -1251,16 +1743,24 @@ pa_age <- function(...) constructor_spec(sample_pa_age, ...) #' # two types of vertices, they like only themselves #' g1 <- sample_traits_callaway(1000, 2, pref.matrix = matrix(c(1, 0, 0, 1), ncol = 2)) #' g2 <- sample_traits(1000, 2, k = 2, pref.matrix = matrix(c(1, 0, 0, 1), ncol = 2)) -sample_traits_callaway <- function(nodes, types, edge.per.step = 1, - type.dist = rep(1, types), - pref.matrix = matrix(1, types, types), - directed = FALSE) { +sample_traits_callaway <- function( + nodes, + types, + edge.per.step = 1, + type.dist = rep(1, types), + pref.matrix = matrix(1, types, types), + directed = FALSE +) { on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_callaway_traits_game, as.double(nodes), - as.double(types), as.double(edge.per.step), - as.double(type.dist), matrix( - as.double(pref.matrix), types, + R_igraph_callaway_traits_game, + as.double(nodes), + as.double(types), + as.double(edge.per.step), + as.double(type.dist), + matrix( + as.double(pref.matrix), + types, types ), as.logical(directed) @@ -1283,13 +1783,21 @@ traits_callaway <- function(...) constructor_spec(sample_traits_callaway, ...) #' @rdname sample_traits_callaway #' @export -sample_traits <- function(nodes, types, k = 1, type.dist = rep(1, types), - pref.matrix = matrix(1, types, types), - directed = FALSE) { +sample_traits <- function( + nodes, + types, + k = 1, + type.dist = rep(1, types), + pref.matrix = matrix(1, types, types), + directed = FALSE +) { on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_establishment_game, as.double(nodes), - as.double(types), as.double(k), as.double(type.dist), + R_igraph_establishment_game, + as.double(nodes), + as.double(types), + as.double(k), + as.double(type.dist), matrix(as.double(pref.matrix), types, types), as.logical(directed) ) @@ -1341,8 +1849,11 @@ traits <- function(...) constructor_spec(sample_traits, ...) sample_grg <- function(nodes, radius, torus = FALSE, coords = FALSE) { on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_grg_game, as.double(nodes), as.double(radius), - as.logical(torus), as.logical(coords) + R_igraph_grg_game, + as.double(nodes), + as.double(radius), + as.logical(torus), + as.logical(coords) ) if (coords) { V(res[[1]])$x <- res[[2]] @@ -1363,7 +1874,6 @@ grg <- function(...) constructor_spec(sample_grg, ...) ## ----------------------------------------------------------------- - #' Trait-based random generation #' #' Generation of random graphs based on different vertex types. @@ -1422,10 +1932,15 @@ grg <- function(...) constructor_spec(sample_grg, ...) #' @examplesIf rlang::is_installed("tcltk") && rlang::is_interactive() #' tkplot(g, layout = layout_in_circle) #' -sample_pref <- function(nodes, types, type.dist = rep(1, types), - fixed.sizes = FALSE, - pref.matrix = matrix(1, types, types), - directed = FALSE, loops = FALSE) { +sample_pref <- function( + nodes, + types, + type.dist = rep(1, types), + fixed.sizes = FALSE, + pref.matrix = matrix(1, types, types), + directed = FALSE, + loops = FALSE +) { if (nrow(pref.matrix) != types || ncol(pref.matrix) != types) { cli::cli_abort(c( "{.arg pref.matrix} must have {.arg types} rows and columns.", @@ -1435,10 +1950,14 @@ sample_pref <- function(nodes, types, type.dist = rep(1, types), on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_preference_game, as.numeric(nodes), as.numeric(types), - as.double(type.dist), as.logical(fixed.sizes), + R_igraph_preference_game, + as.numeric(nodes), + as.numeric(types), + as.double(type.dist), + as.logical(fixed.sizes), matrix(as.double(pref.matrix), types, types), - as.logical(directed), as.logical(loops) + as.logical(directed), + as.logical(loops) ) V(res[[1]])$type <- res[[2]] + 1 if (igraph_opt("add.params")) { @@ -1460,10 +1979,13 @@ pref <- function(...) constructor_spec(sample_pref, ...) #' @rdname sample_pref #' @export -sample_asym_pref <- function(nodes, types, - type.dist.matrix = matrix(1, types, types), - pref.matrix = matrix(1, types, types), - loops = FALSE) { +sample_asym_pref <- function( + nodes, + types, + type.dist.matrix = matrix(1, types, types), + pref.matrix = matrix(1, types, types), + loops = FALSE +) { if (nrow(pref.matrix) != types || ncol(pref.matrix) != types) { cli::cli_abort(c( "{.arg pref.matrix} must have {.arg types} rows and columns.", @@ -1480,7 +2002,9 @@ sample_asym_pref <- function(nodes, types, on.exit(.Call(R_igraph_finalizer)) res <- .Call( R_igraph_asymmetric_preference_game, - as.numeric(nodes), as.numeric(types), as.numeric(types), + as.numeric(nodes), + as.numeric(types), + as.numeric(types), matrix(as.double(type.dist.matrix), types, types), matrix(as.double(pref.matrix), types, types), as.logical(loops) @@ -1504,23 +2028,19 @@ asym_pref <- function(...) constructor_spec(sample_asym_pref, ...) ## ----------------------------------------------------------------- - #' @rdname ego #' @export #' @family functions for manipulating graph structure connect <- function(graph, order, mode = c("all", "out", "in", "total")) { ensure_igraph(graph) mode <- igraph.match.arg(mode) - mode <- switch(mode, - "out" = 1, - "in" = 2, - "all" = 3, - "total" = 3 - ) + mode <- switch(mode, "out" = 1, "in" = 2, "all" = 3, "total" = 3) on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_connect_neighborhood, graph, as.numeric(order), + R_igraph_connect_neighborhood, + graph, + as.numeric(order), as.numeric(mode) ) } @@ -1571,13 +2091,23 @@ connect <- function(graph, order, mode = c("all", "out", "in", "total")) { #' mean_distance(g) #' transitivity(g, type = "average") #' -sample_smallworld <- function(dim, size, nei, p, loops = FALSE, - multiple = FALSE) { +sample_smallworld <- function( + dim, + size, + nei, + p, + loops = FALSE, + multiple = FALSE +) { on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_watts_strogatz_game, as.numeric(dim), - as.numeric(size), as.numeric(nei), as.numeric(p), - as.logical(loops), as.logical(multiple) + R_igraph_watts_strogatz_game, + as.numeric(dim), + as.numeric(size), + as.numeric(nei), + as.numeric(p), + as.logical(loops), + as.logical(multiple) ) if (igraph_opt("add.params")) { res$name <- "Watts-Strogatz random graph" @@ -1627,13 +2157,21 @@ smallworld <- function(...) constructor_spec(sample_smallworld, ...) #' @keywords graphs #' @family games #' @export -sample_last_cit <- function(n, edges = 1, agebins = n / 7100, pref = (1:(agebins + 1))^-3, - directed = TRUE) { +sample_last_cit <- function( + n, + edges = 1, + agebins = n / 7100, + pref = (1:(agebins + 1))^-3, + directed = TRUE +) { on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_lastcit_game, as.numeric(n), as.numeric(edges), + R_igraph_lastcit_game, + as.numeric(n), + as.numeric(edges), as.numeric(agebins), - as.numeric(pref), as.logical(directed) + as.numeric(pref), + as.logical(directed) ) if (igraph_opt("add.params")) { res$name <- "Random citation graph based on last citation" @@ -1650,13 +2188,22 @@ last_cit <- function(...) constructor_spec(sample_last_cit, ...) #' @rdname sample_last_cit #' @export -sample_cit_types <- function(n, edges = 1, types = rep(0, n), - pref = rep(1, length(types)), - directed = TRUE, attr = TRUE) { +sample_cit_types <- function( + n, + edges = 1, + types = rep(0, n), + pref = rep(1, length(types)), + directed = TRUE, + attr = TRUE +) { on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_cited_type_game, as.numeric(n), as.numeric(edges), - as.numeric(types), as.numeric(pref), as.logical(directed) + R_igraph_cited_type_game, + as.numeric(n), + as.numeric(edges), + as.numeric(types), + as.numeric(pref), + as.logical(directed) ) if (attr) { V(res)$type <- types @@ -1674,17 +2221,22 @@ cit_types <- function(...) constructor_spec(sample_cit_types, ...) #' @rdname sample_last_cit #' @export -sample_cit_cit_types <- function(n, edges = 1, types = rep(0, n), - pref = matrix(1, - nrow = length(types), - ncol = length(types) - ), - directed = TRUE, attr = TRUE) { +sample_cit_cit_types <- function( + n, + edges = 1, + types = rep(0, n), + pref = matrix(1, nrow = length(types), ncol = length(types)), + directed = TRUE, + attr = TRUE +) { pref[] <- as.numeric(pref) on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_citing_cited_type_game, as.numeric(n), - as.numeric(types), pref, as.numeric(edges), + R_igraph_citing_cited_type_game, + as.numeric(n), + as.numeric(types), + pref, + as.numeric(edges), as.logical(directed) ) if (attr) { @@ -1703,7 +2255,6 @@ cit_cit_types <- function(...) constructor_spec(sample_cit_cit_types, ...) ## ----------------------------------------------------------------- - #' Bipartite random graphs #' #' `r lifecycle::badge("deprecated")` Generate bipartite graphs using the Erdős-Rényi model. @@ -1745,8 +2296,15 @@ cit_cit_types <- function(...) constructor_spec(sample_cit_cit_types, ...) #' ## directed bipartite graph, G(n,m) #' sample_bipartite(10, 5, type = "Gnm", m = 20, directed = TRUE, mode = "all") #' -sample_bipartite <- function(n1, n2, type = c("gnp", "gnm"), p, m, - directed = FALSE, mode = c("out", "in", "all")) { +sample_bipartite <- function( + n1, + n2, + type = c("gnp", "gnm"), + p, + m, + directed = FALSE, + mode = c("out", "in", "all") +) { type <- igraph.match.arg(type) mode <- igraph.match.arg(mode) @@ -1845,10 +2403,14 @@ bipartite_gnp <- function(...) constructor_spec(sample_bipartite_gnp, ...) #' #' @family games #' @export -sample_bipartite_gnm <- function(n1, n2, m, - ..., - directed = FALSE, - mode = c("out", "in", "all")) { +sample_bipartite_gnm <- function( + n1, + n2, + m, + ..., + directed = FALSE, + mode = c("out", "in", "all") +) { check_dots_empty() mode <- igraph.match.arg(mode) m <- as.numeric(m) @@ -1870,10 +2432,14 @@ sample_bipartite_gnm <- function(n1, n2, m, } #' @rdname sample_bipartite_gnm #' @export -sample_bipartite_gnp <- function(n1, n2, p, - ..., - directed = FALSE, - mode = c("out", "in", "all")) { +sample_bipartite_gnp <- function( + n1, + n2, + p, + ..., + directed = FALSE, + mode = c("out", "in", "all") +) { check_dots_empty() mode <- igraph.match.arg(mode) p <- as.numeric(p) @@ -1895,7 +2461,6 @@ sample_bipartite_gnp <- function(n1, n2, p, } - #' Sample stochastic block model #' #' Sampling from the stochastic block model of networks @@ -2019,7 +2584,6 @@ hierarchical_sbm <- function(...) { ## ----------------------------------------------------------------- - #' Generate random graphs according to the random dot product graph model #' #' In this model, each vertex is represented by a latent position vector. @@ -2285,11 +2849,12 @@ sample_chung_lu <- chung_lu_game_impl #' @rdname sample_chung_lu #' @export chung_lu <- function( - out.weights, - in.weights = NULL, - ..., - loops = TRUE, - variant = c("original", "maxent", "nr")) { + out.weights, + in.weights = NULL, + ..., + loops = TRUE, + variant = c("original", "maxent", "nr") +) { variant <- rlang::arg_match(variant) constructor_spec( sample_chung_lu, From 92bf6f32b85bdbcb60201ee92ddb6adc55b90f00 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:50:50 +0200 Subject: [PATCH 18/59] glet --- R/glet.R | 41 ++++++++++++++++++++++++++++++++++------- 1 file changed, 34 insertions(+), 7 deletions(-) diff --git a/R/glet.R b/R/glet.R index f0b06db5af3..d685420ae43 100644 --- a/R/glet.R +++ b/R/glet.R @@ -8,9 +8,22 @@ #' @inheritParams graphlet_proj #' @keywords internal #' @export -graphlets.project <- function(graph, weights = NULL, cliques, niter = 1000, Mu = rep(1, length(cliques))) { # nocov start +graphlets.project <- function( + graph, + weights = NULL, + cliques, + niter = 1000, + Mu = rep(1, length(cliques)) +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "graphlets.project()", "graphlet_proj()") - graphlet_proj(graph = graph, weights = weights, cliques = cliques, niter = niter, Mu = Mu) + graphlet_proj( + graph = graph, + weights = weights, + cliques = cliques, + niter = niter, + Mu = Mu + ) } # nocov end #' Graphlet decomposition of a graph @@ -23,8 +36,13 @@ graphlets.project <- function(graph, weights = NULL, cliques, niter = 1000, Mu = #' @inheritParams graphlet_basis #' @keywords internal #' @export -graphlets.candidate.basis <- function(graph, weights = NULL) { # nocov start - lifecycle::deprecate_soft("2.0.0", "graphlets.candidate.basis()", "graphlet_basis()") +graphlets.candidate.basis <- function(graph, weights = NULL) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "graphlets.candidate.basis()", + "graphlet_basis()" + ) graphlet_basis(graph = graph, weights = weights) } # nocov end @@ -138,8 +156,13 @@ graphlet_basis <- function(graph, weights = NULL) { #' @rdname graphlet_basis #' @export -graphlet_proj <- function(graph, weights = NULL, cliques, niter = 1000, - Mu = rep(1, length(cliques))) { +graphlet_proj <- function( + graph, + weights = NULL, + cliques, + niter = 1000, + Mu = rep(1, length(cliques)) +) { # Argument checks ensure_igraph(graph) if (is.null(weights) && "weight" %in% edge_attr_names(graph)) { @@ -198,7 +221,11 @@ function() { D2[3:5, 3:5] <- 3 D3[2:5, 2:5] <- 1 - g <- graph_from_adjacency_matrix(D1 + D2 + D3, mode = "undirected", weighted = TRUE) + g <- graph_from_adjacency_matrix( + D1 + D2 + D3, + mode = "undirected", + weighted = TRUE + ) gl <- graphlets(g, iter = 1000) fitandplot(g, gl) From dd8645fb8699a70d6a3a4a098cd962301f92bc5a Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:51:01 +0200 Subject: [PATCH 19/59] has --- R/has.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/has.R b/R/has.R index e0b74e282bf..aff7284915a 100644 --- a/R/has.R +++ b/R/has.R @@ -22,7 +22,10 @@ has_graphml <- make_closure(graphml = NULL, function() { if (is.null(graphml)) { graphml <<- tryCatch( { - read_graph(rawConnection(charToRaw("")), format = "graphml") + read_graph( + rawConnection(charToRaw("")), + format = "graphml" + ) TRUE }, error = function(e) FALSE From 11857c67ec912a126480c66b0967b8d06787536e Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:51:13 +0200 Subject: [PATCH 20/59] hrg --- R/iterators.R | 345 ++++++++++++++++++++++++++++++++++---------------- 1 file changed, 236 insertions(+), 109 deletions(-) diff --git a/R/iterators.R b/R/iterators.R index 31144ce3111..4b7bf034066 100644 --- a/R/iterators.R +++ b/R/iterators.R @@ -154,10 +154,13 @@ set_complete_iterator <- function(x, value = TRUE) { } inside_square_error <- function(fn_name, call = rlang::caller_env()) { - cli::cli_abort(c( - "{.fun {fn_name}} must only be used inside index or vertex sequences like {.code E(g)[]} or {.code V(g)[]}.", - i = "See {.help [{.fun [.igraph.es}](igraph::`[.igraph.es`)} or {.help [{.fun [.igraph.vs}](igraph::`[.igraph.vs`)}." - ), call = call) + cli::cli_abort( + c( + "{.fun {fn_name}} must only be used inside index or vertex sequences like {.code E(g)[]} or {.code V(g)[]}.", + i = "See {.help [{.fun [.igraph.es}](igraph::`[.igraph.es`)} or {.help [{.fun [.igraph.vs}](igraph::`[.igraph.vs`)}." + ), + call = call + ) } @@ -249,14 +252,18 @@ V <- function(graph) { update_vs_ref(graph) res <- seq_len(vcount(graph)) - if (is_named(graph)) names(res) <- vertex_attr(graph)$name + if (is_named(graph)) { + names(res) <- vertex_attr(graph)$name + } class(res) <- "igraph.vs" res <- set_complete_iterator(res) add_vses_graph_ref(res, graph) } create_vs <- function(graph, idx, na_ok = FALSE) { - if (na_ok) idx <- ifelse(idx < 1 | idx > gorder(graph), NA, idx) + if (na_ok) { + idx <- ifelse(idx < 1 | idx > gorder(graph), NA, idx) + } res <- simple_vs_index(V(graph), idx, na_ok = na_ok) add_vses_graph_ref(res, graph) } @@ -356,15 +363,21 @@ E <- function(graph, P = NULL, path = NULL, directed = TRUE) { } else if (!is.null(P)) { on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_es_pairs, graph, as_igraph_vs(graph, P) - 1, + R_igraph_es_pairs, + graph, + as_igraph_vs(graph, P) - 1, as.logical(directed) - ) + 1 + ) + + 1 } else { on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_es_path, graph, as_igraph_vs(graph, path) - 1, + R_igraph_es_path, + graph, + as_igraph_vs(graph, path) - 1, as.logical(directed) - ) + 1 + ) + + 1 } if ("name" %in% edge_attr_names(graph)) { @@ -380,13 +393,17 @@ E <- function(graph, P = NULL, path = NULL, directed = TRUE) { } create_es <- function(graph, idx, na_ok = FALSE) { - if (na_ok) idx <- ifelse(idx < 1 | idx > gsize(graph), NA, idx) + if (na_ok) { + idx <- ifelse(idx < 1 | idx > gsize(graph), NA, idx) + } simple_es_index(E(graph), idx) } simple_vs_index <- function(x, i, na_ok = FALSE) { res <- unclass(x)[i] - if (!na_ok && any(is.na(res))) cli::cli_abort("Unknown vertex selected.") + if (!na_ok && any(is.na(res))) { + cli::cli_abort("Unknown vertex selected.") + } class(res) <- "igraph.vs" res } @@ -531,14 +548,20 @@ simple_vs_index <- function(x, i, na_ok = FALSE) { ## Special case, no argument (but we might get an artificial ## empty one - if (length(args) < 1 || - (length(args) == 1 && inherits(rlang::quo_get_expr(args[[1]]), "name") && - !nzchar(as.character(rlang::quo_get_expr(args[[1]]))))) { + if ( + length(args) < 1 || + (length(args) == 1 && + inherits(rlang::quo_get_expr(args[[1]]), "name") && + !nzchar(as.character(rlang::quo_get_expr(args[[1]])))) + ) { return(x) } ## Special case: single numeric argument - first_arg_is_numericish <- inherits(rlang::quo_get_expr(args[[1]]), "numeric") || + first_arg_is_numericish <- inherits( + rlang::quo_get_expr(args[[1]]), + "numeric" + ) || inherits(rlang::quo_get_expr(args[[1]]), "integer") if (length(args) == 1 && first_arg_is_numericish) { res <- simple_vs_index(x, rlang::quo_get_expr(args[[1]]), na_ok) @@ -548,7 +571,10 @@ simple_vs_index <- function(x, i, na_ok = FALSE) { ## Special case: single symbol argument, no such attribute if (length(args) == 1 && inherits(rlang::quo_get_expr(args[[1]]), "name")) { graph <- get_vs_graph(x) - if (!(as.character(rlang::quo_get_expr(args[[1]])) %in% vertex_attr_names(graph))) { + if ( + !(as.character(rlang::quo_get_expr(args[[1]])) %in% + vertex_attr_names(graph)) + ) { res <- simple_vs_index(x, rlang::eval_tidy(args[[1]]), na_ok) return(add_vses_graph_ref(res, graph)) } @@ -558,19 +584,17 @@ simple_vs_index <- function(x, i, na_ok = FALSE) { ## TRUE iff the vertex is a neighbor (any type) ## of at least one vertex in v mode <- igraph.match.arg(mode) - mode <- switch(mode, - "out" = 1, - "in" = 2, - "all" = 3, - "total" = 3 - ) + mode <- switch(mode, "out" = 1, "in" = 2, "all" = 3, "total" = 3) if (is.logical(v)) { v <- which(v) } on.exit(.Call(R_igraph_finalizer)) tmp <- .Call( - R_igraph_vs_nei, graph, x, as_igraph_vs(graph, v) - 1, + R_igraph_vs_nei, + graph, + x, + as_igraph_vs(graph, v) - 1, as.numeric(mode) ) tmp[as.numeric(x)] @@ -598,7 +622,10 @@ simple_vs_index <- function(x, i, na_ok = FALSE) { } on.exit(.Call(R_igraph_finalizer)) tmp <- .Call( - R_igraph_vs_adj, graph, x, as_igraph_es(graph, e) - 1, + R_igraph_vs_adj, + graph, + x, + as_igraph_es(graph, e) - 1, as.numeric(3) ) tmp[as.numeric(x)] @@ -616,7 +643,10 @@ simple_vs_index <- function(x, i, na_ok = FALSE) { } on.exit(.Call(R_igraph_finalizer)) tmp <- .Call( - R_igraph_vs_adj, graph, x, as_igraph_es(graph, e) - 1, + R_igraph_vs_adj, + graph, + x, + as_igraph_es(graph, e) - 1, as.numeric(1) ) tmp[as.numeric(x)] @@ -631,7 +661,10 @@ simple_vs_index <- function(x, i, na_ok = FALSE) { } on.exit(.Call(R_igraph_finalizer)) tmp <- .Call( - R_igraph_vs_adj, graph, x, as_igraph_es(graph, e) - 1, + R_igraph_vs_adj, + graph, + x, + as_igraph_es(graph, e) - 1, as.numeric(2) ) tmp[as.numeric(x)] @@ -652,27 +685,39 @@ simple_vs_index <- function(x, i, na_ok = FALSE) { } else { attrs <- vertex_attr(graph) xvec <- as.vector(x) - for (i in seq_along(attrs)) attrs[[i]] <- attrs[[i]][xvec] + for (i in seq_along(attrs)) { + attrs[[i]] <- attrs[[i]][xvec] + } env <- parent.frame() # Functions (only visible if called or if no duplicate) top <- rlang::new_environment(list( - .nei = .nei, nei = nei, - .innei = .innei, innei = innei, - .outnei = .outnei, outnei = outnei, - .inc = .inc, inc = inc, adj = adj, - .from = .from, from = from, - .to = .to, to = to, + .nei = .nei, + nei = nei, + .innei = .innei, + innei = innei, + .outnei = .outnei, + outnei = outnei, + .inc = .inc, + inc = inc, + adj = adj, + .from = .from, + from = from, + .to = .to, + to = to, .data = list(attrs) )) # Data objects (visible by default) - bottom <- rlang::new_environment(parent = top, c( - attrs, - .env = env, - .data = list(attrs) - )) + bottom <- rlang::new_environment( + parent = top, + c( + attrs, + .env = env, + .data = list(attrs) + ) + ) data_mask <- rlang::new_data_mask(bottom, top) @@ -683,7 +728,9 @@ simple_vs_index <- function(x, i, na_ok = FALSE) { return(NULL) } if (is.logical(ii) && (length(ii) != length(x) && length(ii) != 1)) { - cli::cli_abort("Error: Logical index length does not match the number of vertices. Recycling is not allowed.") + cli::cli_abort( + "Error: Logical index length does not match the number of vertices. Recycling is not allowed." + ) } ii <- simple_vs_index(x, ii, na_ok) @@ -795,7 +842,9 @@ simple_es_index <- function(x, i, na_ok = FALSE) { } else { res <- unclass(x)[i] } - if (!na_ok && any(is.na(res))) cli::cli_abort("Unknown edge selected") + if (!na_ok && any(is.na(res))) { + cli::cli_abort("Unknown edge selected") + } attr(res, "env") <- attr(x, "env") attr(res, "graph") <- attr(x, "graph") class(res) <- "igraph.es" @@ -922,9 +971,12 @@ simple_es_index <- function(x, i, na_ok = FALSE) { ## If indexing has no argument at all, then we still get one, ## but it is "empty", a name that is "" - if (length(args) < 1 || - (length(args) == 1 && inherits(rlang::quo_get_expr(args[[1]]), "name") && - !nzchar(as.character(rlang::quo_get_expr(args[[1]]))))) { + if ( + length(args) < 1 || + (length(args) == 1 && + inherits(rlang::quo_get_expr(args[[1]]), "name") && + !nzchar(as.character(rlang::quo_get_expr(args[[1]])))) + ) { return(x) } @@ -932,7 +984,10 @@ simple_es_index <- function(x, i, na_ok = FALSE) { ## TRUE iff the edge is incident to at least one vertex in v on.exit(.Call(R_igraph_finalizer)) tmp <- .Call( - R_igraph_es_adj, graph, x, as_igraph_vs(graph, v) - 1, + R_igraph_es_adj, + graph, + x, + as_igraph_vs(graph, v) - 1, as.numeric(3) ) tmp[as.numeric(x)] @@ -947,7 +1002,10 @@ simple_es_index <- function(x, i, na_ok = FALSE) { ## TRUE iff the edge originates from at least one vertex in v on.exit(.Call(R_igraph_finalizer)) tmp <- .Call( - R_igraph_es_adj, graph, x, as_igraph_vs(graph, v) - 1, + R_igraph_es_adj, + graph, + x, + as_igraph_vs(graph, v) - 1, as.numeric(1) ) tmp[as.numeric(x)] @@ -959,7 +1017,10 @@ simple_es_index <- function(x, i, na_ok = FALSE) { ## TRUE iff the edge points to at least one vertex in v on.exit(.Call(R_igraph_finalizer)) tmp <- .Call( - R_igraph_es_adj, graph, x, as_igraph_vs(graph, v) - 1, + R_igraph_es_adj, + graph, + x, + as_igraph_vs(graph, v) - 1, as.numeric(2) ) tmp[as.numeric(x)] @@ -975,27 +1036,38 @@ simple_es_index <- function(x, i, na_ok = FALSE) { } else { attrs <- edge_attr(graph) xvec <- as.vector(x) - for (i in seq_along(attrs)) attrs[[i]] <- attrs[[i]][xvec] + for (i in seq_along(attrs)) { + attrs[[i]] <- attrs[[i]][xvec] + } env <- parent.frame() # Functions (only visible if called or if no duplicate) top <- rlang::new_environment(list( - .inc = .inc, inc = inc, adj = adj, - .from = .from, from = from, - .to = .to, to = to, - `%--%` = `%--%`, `%->%` = `%->%`, `%<-%` = `%<-%` + .inc = .inc, + inc = inc, + adj = adj, + .from = .from, + from = from, + .to = .to, + to = to, + `%--%` = `%--%`, + `%->%` = `%->%`, + `%<-%` = `%<-%` )) # Data objects (visible by default) - bottom <- rlang::new_environment(parent = top, c( - attrs, - .igraph.from = list(.Call(R_igraph_copy_from, graph)[as.numeric(x)]), - .igraph.to = list(.Call(R_igraph_copy_to, graph)[as.numeric(x)]), - .igraph.graph = list(graph), - .env = env, - .data = list(attrs) - )) + bottom <- rlang::new_environment( + parent = top, + c( + attrs, + .igraph.from = list(.Call(R_igraph_copy_from, graph)[as.numeric(x)]), + .igraph.to = list(.Call(R_igraph_copy_to, graph)[as.numeric(x)]), + .igraph.graph = list(graph), + .env = env, + .data = list(attrs) + ) + ) data_mask <- rlang::new_data_mask(bottom, top) @@ -1006,7 +1078,9 @@ simple_es_index <- function(x, i, na_ok = FALSE) { return(NULL) } if (is.logical(ii) && (length(ii) != length(x) && length(ii) != 1)) { - cli::cli_abort("Error: Logical index length does not match the number of edges. Recycling is not allowed.") + cli::cli_abort( + "Error: Logical index length does not match the number of edges. Recycling is not allowed." + ) } ii <- simple_es_index(x, ii) @@ -1070,11 +1144,15 @@ simple_es_index <- function(x, i, na_ok = FALSE) { #' @name igraph-vs-attributes #' @export `[[<-.igraph.vs` <- function(x, i, value) { - if (!"name" %in% names(attributes(value)) || - !"value" %in% names(attributes(value))) { + if ( + !"name" %in% names(attributes(value)) || + !"value" %in% names(attributes(value)) + ) { cli::cli_abort("Invalid indexing.") } - if (is.null(get_vs_graph(x))) stop("Graph is unknown.") + if (is.null(get_vs_graph(x))) { + stop("Graph is unknown.") + } value } @@ -1088,11 +1166,15 @@ simple_es_index <- function(x, i, na_ok = FALSE) { #' @name igraph-es-attributes #' @export `[[<-.igraph.es` <- function(x, i, value) { - if (!"name" %in% names(attributes(value)) || - !"value" %in% names(attributes(value))) { + if ( + !"name" %in% names(attributes(value)) || + !"value" %in% names(attributes(value)) + ) { stop("Invalid indexing.") } - if (is.null(get_es_graph(x))) stop("Graph is unknown.") + if (is.null(get_es_graph(x))) { + stop("Graph is unknown.") + } value } @@ -1156,7 +1238,9 @@ simple_es_index <- function(x, i, na_ok = FALSE) { #' plot(g) `$.igraph.vs` <- function(x, name) { graph <- get_vs_graph(x) - if (is.null(graph)) cli::cli_abort("Graph is unknown") + if (is.null(graph)) { + cli::cli_abort("Graph is unknown") + } res <- vertex_attr(graph, name, x) if (is_single_index(x)) { res[[1]] @@ -1207,7 +1291,9 @@ simple_es_index <- function(x, i, na_ok = FALSE) { #' plot(g) `$.igraph.es` <- function(x, name) { graph <- get_es_graph(x) - if (is.null(graph)) cli::cli_abort("Graph is unknown") + if (is.null(graph)) { + cli::cli_abort("Graph is unknown") + } res <- edge_attr(graph, name, x) if (is_single_index(x)) { res[[1]] @@ -1223,7 +1309,9 @@ simple_es_index <- function(x, i, na_ok = FALSE) { #' @name igraph-vs-attributes #' @export `$<-.igraph.vs` <- function(x, name, value) { - if (is.null(get_vs_graph(x))) cli::cli_abort("Graph is unknown") + if (is.null(get_vs_graph(x))) { + cli::cli_abort("Graph is unknown") + } attr(x, "name") <- name attr(x, "value") <- value x @@ -1236,7 +1324,9 @@ simple_es_index <- function(x, i, na_ok = FALSE) { #' @export #' @family vertex and edge sequences `$<-.igraph.es` <- function(x, name, value) { - if (is.null(get_es_graph(x))) cli::cli_abort("Graph is unknown") + if (is.null(get_es_graph(x))) { + cli::cli_abort("Graph is unknown") + } attr(x, "name") <- name attr(x, "value") <- value x @@ -1246,13 +1336,18 @@ simple_es_index <- function(x, i, na_ok = FALSE) { #' @export `V<-` <- function(x, value) { ensure_igraph(x) - if (!"name" %in% names(attributes(value)) || - !"value" %in% names(attributes(value))) { + if ( + !"name" %in% names(attributes(value)) || + !"value" %in% names(attributes(value)) + ) { cli::cli_abort("invalid indexing") } - i_set_vertex_attr(x, attr(value, "name"), + i_set_vertex_attr( + x, + attr(value, "name"), index = value, - value = attr(value, "value"), check = FALSE + value = attr(value, "value"), + check = FALSE ) } @@ -1265,13 +1360,18 @@ simple_es_index <- function(x, i, na_ok = FALSE) { #' @export `E<-` <- function(x, path = NULL, P = NULL, directed = NULL, value) { ensure_igraph(x) - if (!"name" %in% names(attributes(value)) || - !"value" %in% names(attributes(value))) { + if ( + !"name" %in% names(attributes(value)) || + !"value" %in% names(attributes(value)) + ) { cli::cli_abort("invalid indexing") } - i_set_edge_attr(x, attr(value, "name"), + i_set_edge_attr( + x, + attr(value, "name"), index = value, - value = attr(value, "value"), check = FALSE + value = attr(value, "value"), + check = FALSE ) } @@ -1316,10 +1416,12 @@ simple_es_index <- function(x, i, na_ok = FALSE) { #' set_vertex_attr("color", value = "red") #' V(g4)[[]] #' V(g4)[[2:5, 7:8]] -print.igraph.vs <- function(x, - full = igraph_opt("print.full"), - id = igraph_opt("print.id"), - ...) { +print.igraph.vs <- function( + x, + full = igraph_opt("print.full"), + id = igraph_opt("print.id"), + ... +) { graph <- get_vs_graph(x) if (!is.null(graph)) { vertices <- V(graph) @@ -1329,23 +1431,34 @@ print.igraph.vs <- function(x, len <- length(x) gid <- graph_id(x) - title <- "+ " %+% chr(len) %+% "/" %+% + title <- "+ " %+% + chr(len) %+% + "/" %+% (if (is.null(vertices)) "?" else chr(length(vertices))) %+% (if (len == 1) " vertex" else " vertices") %+% (if (!is.null(names(vertices))) ", named" else "") %+% - (if (isTRUE(id) && !is.na(gid)) paste(", from", substr(gid, 1, 7)) else "") %+% + (if (isTRUE(id) && !is.na(gid)) { + paste(", from", substr(gid, 1, 7)) + } else { + "" + }) %+% (if (is.null(graph)) " (deleted)" else "") %+% ":\n" cat(title) - if (is_single_index(x) && !is.null(graph) && length(vertex_attr_names(graph) > 0)) { + if ( + is_single_index(x) && + !is.null(graph) && + length(vertex_attr_names(graph) > 0) + ) { ## Double bracket va <- vertex_attr(graph) if (all(sapply(va, is.atomic))) { - print(as.data.frame(va, - stringsAsFactors = - FALSE - )[as.vector(x), , drop = FALSE]) + print(as.data.frame(va, stringsAsFactors = FALSE)[ + as.vector(x), + , + drop = FALSE + ]) } else { print(lapply(va, "[", as.vector(x))) } @@ -1364,9 +1477,11 @@ print.igraph.vs <- function(x, if (is.logical(full) && full) { print(x2, quote = FALSE) } else { - head_print(x2, + head_print( + x2, omitted_footer = "+ ... omitted several vertices\n", - quote = FALSE, max_lines = igraph_opt("auto.print.lines") + quote = FALSE, + max_lines = igraph_opt("auto.print.lines") ) } } @@ -1418,15 +1533,21 @@ print.igraph.vs <- function(x, #' E(g4) #' E(g4)[[]] #' E(g4)[[1:5]] -print.igraph.es <- function(x, - full = igraph_opt("print.full"), - id = igraph_opt("print.id"), - ...) { +print.igraph.es <- function( + x, + full = igraph_opt("print.full"), + id = igraph_opt("print.id"), + ... +) { graph <- get_es_graph(x) ml <- if (identical(full, TRUE)) NULL else igraph_opt("auto.print.lines") .print.edges.compressed( - x = graph, edges = x, max.lines = ml, names = TRUE, - num = TRUE, id = id + x = graph, + edges = x, + max.lines = ml, + names = TRUE, + num = TRUE, + id = id ) invisible(x) } @@ -1434,8 +1555,7 @@ print.igraph.es <- function(x, # these are internal as_igraph_vs <- function(graph, v, na.ok = FALSE) { - if (inherits(v, "igraph.vs") && !is.null(graph) && - !warn_version(graph)) { + if (inherits(v, "igraph.vs") && !is.null(graph) && !warn_version(graph)) { if (get_graph_id(graph) != get_vs_graph_id(v)) { cli::cli_abort("Cannot use a vertex sequence from another graph.") } @@ -1462,8 +1582,7 @@ as_igraph_vs <- function(graph, v, na.ok = FALSE) { } as_igraph_es <- function(graph, e) { - if (inherits(e, "igraph.es") && !is.null(graph) && - !warn_version(graph)) { + if (inherits(e, "igraph.es") && !is.null(graph) && !warn_version(graph)) { if (get_graph_id(graph) != get_es_graph_id(e)) { cli::cli_abort("Cannot use an edge sequence from another graph.") } @@ -1518,7 +1637,9 @@ is_igraph_es <- function(x) { parse_op_args <- function(..., what, is_fun, as_fun, check_graph = TRUE) { args <- list(...) - if (any(!sapply(args, is_fun))) cli::cli_abort("Not {what} sequence") + if (any(!sapply(args, is_fun))) { + cli::cli_abort("Not {what} sequence") + } ## get the ids of all graphs graph_id <- sapply(args, get_vs_graph_id) %>% @@ -1555,16 +1676,20 @@ parse_op_args <- function(..., what, is_fun, as_fun, check_graph = TRUE) { parse_vs_op_args <- function(...) { - parse_op_args(..., - what = "a vertex", is_fun = is_igraph_vs, + parse_op_args( + ..., + what = "a vertex", + is_fun = is_igraph_vs, as_fun = as_igraph_vs ) } parse_es_op_args <- function(...) { - parse_op_args(..., - what = "an edge", is_fun = is_igraph_es, + parse_op_args( + ..., + what = "an edge", + is_fun = is_igraph_es, as_fun = as_igraph_es ) } @@ -1574,8 +1699,10 @@ create_op_result <- function(parsed, result, class, args) { result <- add_vses_graph_ref(result, parsed$graph) class(result) <- class ## c() drops names for zero length vectors. Why??? - if (!length(result) && - any(sapply(args, function(x) !is.null(names(x))))) { + if ( + !length(result) && + any(sapply(args, function(x) !is.null(names(x)))) + ) { names(result) <- character() } result From cc5b62d54c9298e529caac8f9c540ed9ee3aaf93 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:52:08 +0200 Subject: [PATCH 21/59] incidence --- R/incidence.R | 94 ++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 67 insertions(+), 27 deletions(-) diff --git a/R/incidence.R b/R/incidence.R index 2fee0c89e84..3ac1f48ec3d 100644 --- a/R/incidence.R +++ b/R/incidence.R @@ -8,9 +8,28 @@ #' @inheritParams graph_from_biadjacency_matrix #' @keywords internal #' @export -graph.incidence <- function(incidence, directed = FALSE, mode = c("all", "out", "in", "total"), multiple = FALSE, weighted = NULL, add.names = NULL) { # nocov start - lifecycle::deprecate_soft("2.0.0", "graph.incidence()", "graph_from_biadjacency_matrix()") - graph_from_biadjacency_matrix(incidence = incidence, directed = directed, mode = mode, multiple = multiple, weighted = weighted, add.names = add.names) +graph.incidence <- function( + incidence, + directed = FALSE, + mode = c("all", "out", "in", "total"), + multiple = FALSE, + weighted = NULL, + add.names = NULL +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "graph.incidence()", + "graph_from_biadjacency_matrix()" + ) + graph_from_biadjacency_matrix( + incidence = incidence, + directed = directed, + mode = mode, + multiple = multiple, + weighted = weighted, + add.names = add.names + ) } # nocov end ## ---------------------------------------------------------------- @@ -36,7 +55,6 @@ graph.incidence <- function(incidence, directed = FALSE, mode = c("all", "out", ## ## ----------------------------------------------------------------- - # adjust edgelist according to directionality of edges modify_edgelist <- function(el, mode, directed) { if (!directed || mode == "out") { @@ -50,8 +68,13 @@ modify_edgelist <- function(el, mode, directed) { rbind(el, reversed_edges) } -graph_incidence_build <- function(incidence, directed = FALSE, mode = "out", - multiple = FALSE, weighted = NULL) { +graph_incidence_build <- function( + incidence, + directed = FALSE, + mode = "out", + multiple = FALSE, + weighted = NULL +) { num_rows <- nrow(incidence) num_cols <- ncol(incidence) @@ -60,12 +83,7 @@ graph_incidence_build <- function(incidence, directed = FALSE, mode = "out", mode(incidence) <- "double" on.exit(.Call(R_igraph_finalizer)) - mode_num <- switch(mode, - "out" = 1, - "in" = 2, - "all" = 3, - "total" = 3 - ) + mode_num <- switch(mode, "out" = 1, "in" = 2, "all" = 3, "total" = 3) res <- .Call(R_igraph_biadjacency, incidence, directed, mode_num, multiple) return(set_vertex_attr(res$graph, "type", value = res$types)) } @@ -95,12 +113,14 @@ graph_incidence_build <- function(incidence, directed = FALSE, mode = "out", res <- make_graph(n = num_rows + num_cols, c(t(el)), directed = directed) } - set_vertex_attr(res, "type", value = c(rep(FALSE, num_rows), rep(TRUE, num_cols))) + set_vertex_attr( + res, + "type", + value = c(rep(FALSE, num_rows), rep(TRUE, num_cols)) + ) } - - #' Create graphs from a bipartite adjacency matrix #' #' `graph_from_biadjacency_matrix()` creates a bipartite igraph graph from an incidence @@ -163,10 +183,14 @@ graph_incidence_build <- function(incidence, directed = FALSE, mode = "out", #' this naming to avoid confusion with the edge-vertex incidence matrix. #' @family biadjacency #' @export -graph_from_biadjacency_matrix <- function(incidence, directed = FALSE, - mode = c("all", "out", "in", "total"), - multiple = FALSE, weighted = NULL, - add.names = NULL) { +graph_from_biadjacency_matrix <- function( + incidence, + directed = FALSE, + mode = c("all", "out", "in", "total"), + multiple = FALSE, + weighted = NULL, + add.names = NULL +) { # Argument checks ensure_no_na(incidence, "biadjacency matrix") directed <- as.logical(directed) @@ -198,9 +222,11 @@ graph_from_biadjacency_matrix <- function(incidence, directed = FALSE, } } - res <- graph_incidence_build(incidence, + res <- graph_incidence_build( + incidence, directed = directed, - mode = mode, multiple = multiple, + mode = mode, + multiple = multiple, weighted = weighted ) @@ -213,12 +239,16 @@ graph_from_biadjacency_matrix <- function(incidence, directed = FALSE, } } else if (!is.na(add.names)) { if (is.null(rownames(incidence)) || is.null(colnames(incidence))) { - cli::cli_warn("Cannot add row- and column names, at least one of them is missing.") + cli::cli_warn( + "Cannot add row- and column names, at least one of them is missing." + ) add.names <- NA } } if (!is.na(add.names)) { - res <- set_vertex_attr(res, add.names, + res <- set_vertex_attr( + res, + add.names, value = c(rownames(incidence), colnames(incidence)) ) } @@ -238,8 +268,13 @@ graph_from_biadjacency_matrix <- function(incidence, directed = FALSE, #' "bipartite incidence matrix". igraph 1.6.0 and later does not use #' this naming to avoid confusion with the edge-vertex incidence matrix. #' @export -from_incidence_matrix <- function(...) { # nocov start - lifecycle::deprecate_soft("1.6.0", "graph_from_incidence_matrix()", "graph_from_biadjacency_matrix()") +from_incidence_matrix <- function(...) { + # nocov start + lifecycle::deprecate_soft( + "1.6.0", + "graph_from_incidence_matrix()", + "graph_from_biadjacency_matrix()" + ) graph_from_biadjacency_matrix(...) } # nocov end #' From incidence matrix @@ -256,7 +291,12 @@ from_incidence_matrix <- function(...) { # nocov start #' "bipartite incidence matrix". igraph 1.6.0 and later does not use #' this naming to avoid confusion with the edge-vertex incidence matrix. #' @export -graph_from_incidence_matrix <- function(...) { # nocov start - lifecycle::deprecate_soft("1.6.0", "graph_from_incidence_matrix()", "graph_from_biadjacency_matrix()") +graph_from_incidence_matrix <- function(...) { + # nocov start + lifecycle::deprecate_soft( + "1.6.0", + "graph_from_incidence_matrix()", + "graph_from_biadjacency_matrix()" + ) graph_from_biadjacency_matrix(...) } # nocov end From b7b35c0d609c94c7028d67ffdb6927d82e787901 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:52:22 +0200 Subject: [PATCH 22/59] indexing --- R/indexing.R | 149 +++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 108 insertions(+), 41 deletions(-) diff --git a/R/indexing.R b/R/indexing.R index 2e3466ab7b7..293ed9e4d36 100644 --- a/R/indexing.R +++ b/R/indexing.R @@ -206,26 +206,43 @@ get_adjacency_submatrix <- function(x, i, j, attr = NULL) { #' @method [ igraph #' @export `[.igraph` <- function( - x, i, j, ..., from, to, - sparse = igraph_opt("sparsematrices"), - edges = FALSE, drop = TRUE, - attr = if (is_weighted(x)) "weight" else NULL) { + x, + i, + j, + ..., + from, + to, + sparse = igraph_opt("sparsematrices"), + edges = FALSE, + drop = TRUE, + attr = if (is_weighted(x)) "weight" else NULL +) { ################################################################ ## Argument checks - if ((!missing(from) || !missing(to)) && - (!missing(i) || !missing(j))) { - cli::cli_abort("Cannot use {.arg from}/{.arg to} together with regular indices") + if ( + (!missing(from) || !missing(to)) && + (!missing(i) || !missing(j)) + ) { + cli::cli_abort( + "Cannot use {.arg from}/{.arg to} together with regular indices" + ) } - if ((!missing(from) && missing(to)) || - (missing(from) && !missing(to))) { + if ( + (!missing(from) && missing(to)) || + (missing(from) && !missing(to)) + ) { cli::cli_abort("Cannot use {.arg from}/{.arg to} without the other") } if (!missing(from)) { if ((!is.numeric(from) && !is.character(from)) || any(is.na(from))) { - cli::cli_abort("{.arg from} must be a numeric or character vector without NAs") + cli::cli_abort( + "{.arg from} must be a numeric or character vector without NAs" + ) } if ((!is.numeric(to) && !is.character(to)) || any(is.na(to))) { - cli::cli_abort("{.arg to} must be a numeric or character vector without NAs") + cli::cli_abort( + "{.arg to} must be a numeric or character vector without NAs" + ) } if (length(from) != length(to)) { cli::cli_abort("{.arg from} and {.arg to} must have the same length") @@ -285,9 +302,9 @@ get_adjacency_submatrix <- function(x, i, j, attr = NULL) { } if (!sparse) { - as.matrix(sub_adjmat[, , drop = drop]) + as.matrix(sub_adjmat[,, drop = drop]) } else { - sub_adjmat[, , drop = drop] + sub_adjmat[,, drop = drop] } } @@ -348,14 +365,31 @@ get_adjacency_submatrix <- function(x, i, j, attr = NULL) { #' #' @method [[ igraph #' @export -`[[.igraph` <- function(x, i, j, from, to, ..., directed = TRUE, - edges = FALSE, exact = TRUE) { +`[[.igraph` <- function( + x, + i, + j, + from, + to, + ..., + directed = TRUE, + edges = FALSE, + exact = TRUE +) { getfun <- if (edges) as_adj_edge_list else as_adj_list - if (!missing(i) && !missing(from)) cli::cli_abort("Cannot use both {.arg i} and {.arg from}") - if (!missing(j) && !missing(to)) cli::cli_abort("Cannot use both {.arg j} and {.arg to}") - if (missing(i) && !missing(from)) i <- from - if (missing(j) && !missing(to)) j <- to + if (!missing(i) && !missing(from)) { + cli::cli_abort("Cannot use both {.arg i} and {.arg from}") + } + if (!missing(j) && !missing(to)) { + cli::cli_abort("Cannot use both {.arg j} and {.arg to}") + } + if (missing(i) && !missing(from)) { + i <- from + } + if (missing(j) && !missing(to)) { + j <- to + } if (missing(i) && missing(j)) { mode <- if (directed) "out" else "all" @@ -416,22 +450,37 @@ expand.grid.unordered <- function(i, j, loops = FALSE, directed = FALSE) { #' @method [<- igraph #' @family functions for manipulating graph structure #' @export -`[<-.igraph` <- function(x, i, j, ..., from, to, - attr = if (is_weighted(x)) "weight" else NULL, - loops = FALSE, - value) { +`[<-.igraph` <- function( + x, + i, + j, + ..., + from, + to, + attr = if (is_weighted(x)) "weight" else NULL, + loops = FALSE, + value +) { ################################################################ ## Argument checks - if ((!missing(from) || !missing(to)) && - (!missing(i) || !missing(j))) { - cli::cli_abort("Cannot use {.arg from}/{.arg to} together with regular indices") + if ( + (!missing(from) || !missing(to)) && + (!missing(i) || !missing(j)) + ) { + cli::cli_abort( + "Cannot use {.arg from}/{.arg to} together with regular indices" + ) } - if ((!missing(from) && missing(to)) || - (missing(from) && !missing(to))) { + if ( + (!missing(from) && missing(to)) || + (missing(from) && !missing(to)) + ) { cli::cli_abort("Cannot use {.arg from}/{.arg to} without the other") } - if (is.null(attr) && - (!is.null(value) && !is.numeric(value) && !is.logical(value))) { + if ( + is.null(attr) && + (!is.null(value) && !is.numeric(value) && !is.logical(value)) + ) { cli::cli_abort("New value should be NULL, numeric or logical") } if (is.null(attr) && !is.null(value) && length(value) != 1) { @@ -439,10 +488,14 @@ expand.grid.unordered <- function(i, j, loops = FALSE, directed = FALSE) { } if (!missing(from)) { if ((!is.numeric(from) && !is.character(from)) || any(is.na(from))) { - cli::cli_abort("{.arg from} must be a numeric or character vector without NAs") + cli::cli_abort( + "{.arg from} must be a numeric or character vector without NAs" + ) } if ((!is.numeric(to) && !is.character(to)) || any(is.na(to))) { - cli::cli_abort("{.arg to} must be a numeric or character vector without NAs") + cli::cli_abort( + "{.arg to} must be a numeric or character vector without NAs" + ) } if (length(from) != length(to)) { cli::cli_abort("{.arg from} and {.arg to} must have the same length") @@ -452,9 +505,11 @@ expand.grid.unordered <- function(i, j, loops = FALSE, directed = FALSE) { ################################################################## if (!missing(from)) { - if (is.null(value) || - (is.logical(value) && !value) || - (is.null(attr) && is.numeric(value) && value == 0)) { + if ( + is.null(value) || + (is.logical(value) && !value) || + (is.null(attr) && is.numeric(value) && value == 0) + ) { ## Delete edges todel <- get_edge_ids(x, c(rbind(from, to))) x <- delete_edges(x, todel) @@ -469,9 +524,11 @@ expand.grid.unordered <- function(i, j, loops = FALSE, directed = FALSE) { x <- set_edge_attr(x, attr, ids, value = value) } } - } else if (is.null(value) || - (is.logical(value) && !value) || - (is.null(attr) && is.numeric(value) && value == 0)) { + } else if ( + is.null(value) || + (is.logical(value) && !value) || + (is.null(attr) && is.numeric(value) && value == 0) + ) { ## Delete edges if (missing(i) && missing(j)) { todel <- seq_len(ecount(x)) @@ -490,14 +547,24 @@ expand.grid.unordered <- function(i, j, loops = FALSE, directed = FALSE) { i <- if (missing(i)) as.numeric(V(x)) else as_igraph_vs(x, i) j <- if (missing(j)) as.numeric(V(x)) else as_igraph_vs(x, j) if (length(i) != 0 && length(j) != 0) { - edge_pairs <- expand.grid.unordered(i, j, loops = loops, directed = is_directed(x)) + edge_pairs <- expand.grid.unordered( + i, + j, + loops = loops, + directed = is_directed(x) + ) edge_ids <- get_edge_ids(x, c(rbind(edge_pairs[, 1], edge_pairs[, 2]))) - toadd <- c(rbind(edge_pairs[edge_ids == 0, 1], edge_pairs[edge_ids == 0, 2])) + toadd <- c(rbind( + edge_pairs[edge_ids == 0, 1], + edge_pairs[edge_ids == 0, 2] + )) if (is.null(attr)) { if (value > 1) { - cli::cli_abort("{.arg value} greater than one but graph is not weighted and {.arg attr} was not specified.") + cli::cli_abort( + "{.arg value} greater than one but graph is not weighted and {.arg attr} was not specified." + ) } x <- add_edges(x, toadd) } else { From 2b21c7c105b96d123bf32ed364687c3fedbd9252 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:52:34 +0200 Subject: [PATCH 23/59] interface --- R/interface.R | 111 ++++++++++++++++++++++++++------------------------ 1 file changed, 58 insertions(+), 53 deletions(-) diff --git a/R/interface.R b/R/interface.R index 3c18f9aa27d..e5317fd54ed 100644 --- a/R/interface.R +++ b/R/interface.R @@ -8,7 +8,8 @@ #' @inheritParams is_directed #' @keywords internal #' @export -is.directed <- function(graph) { # nocov start +is.directed <- function(graph) { + # nocov start lifecycle::deprecate_soft("2.0.0", "is.directed()", "is_directed()") is_directed(graph = graph) } # nocov end @@ -23,7 +24,8 @@ is.directed <- function(graph) { # nocov start #' @inheritParams delete_vertices #' @keywords internal #' @export -delete.vertices <- function(graph, v) { # nocov start +delete.vertices <- function(graph, v) { + # nocov start lifecycle::deprecate_soft("2.0.0", "delete.vertices()", "delete_vertices()") delete_vertices(graph = graph, v = v) } # nocov end @@ -38,7 +40,8 @@ delete.vertices <- function(graph, v) { # nocov start #' @inheritParams delete_edges #' @keywords internal #' @export -delete.edges <- function(graph, edges) { # nocov start +delete.edges <- function(graph, edges) { + # nocov start lifecycle::deprecate_soft("2.0.0", "delete.edges()", "delete_edges()") delete_edges(graph = graph, edges = edges) } # nocov end @@ -53,7 +56,8 @@ delete.edges <- function(graph, edges) { # nocov start #' @inheritParams add_vertices #' @keywords internal #' @export -add.vertices <- function(graph, nv, ..., attr = list()) { # nocov start +add.vertices <- function(graph, nv, ..., attr = list()) { + # nocov start lifecycle::deprecate_soft("2.0.0", "add.vertices()", "add_vertices()") add_vertices(graph = graph, nv = nv, attr = attr, ...) } # nocov end @@ -68,7 +72,8 @@ add.vertices <- function(graph, nv, ..., attr = list()) { # nocov start #' @inheritParams add_edges #' @keywords internal #' @export -add.edges <- function(graph, edges, ..., attr = list()) { # nocov start +add.edges <- function(graph, edges, ..., attr = list()) { + # nocov start lifecycle::deprecate_soft("2.0.0", "add.edges()", "add_edges()") add_edges(graph = graph, edges = edges, attr = attr, ...) } # nocov end @@ -146,7 +151,11 @@ add_edges <- function(graph, edges, ..., attr = list()) { edges.orig <- ecount(graph) on.exit(.Call(R_igraph_finalizer)) - graph <- .Call(R_igraph_add_edges_manual, graph, as_igraph_vs(graph, edges) - 1) + graph <- .Call( + R_igraph_add_edges_manual, + graph, + as_igraph_vs(graph, edges) - 1 + ) edges.new <- ecount(graph) if (edges.new - edges.orig != 0) { @@ -342,12 +351,7 @@ neighbors <- function(graph, v, mode = c("out", "in", "all", "total")) { ensure_igraph(graph) if (is.character(mode)) { mode <- igraph.match.arg(mode) - mode <- switch(mode, - "out" = 1, - "in" = 2, - "all" = 3, - "total" = 3 - ) + mode <- switch(mode, "out" = 1, "in" = 2, "all" = 3, "total" = 3) } v <- as_igraph_vs(graph, v) if (length(v) == 0) { @@ -356,7 +360,9 @@ neighbors <- function(graph, v, mode = c("out", "in", "all", "total")) { on.exit(.Call(R_igraph_finalizer)) res <- .Call(R_igraph_neighbors, graph, v - 1, as.numeric(mode)) + 1L - if (igraph_opt("return.vs.es")) res <- create_vs(graph, res) + if (igraph_opt("return.vs.es")) { + res <- create_vs(graph, res) + } res } @@ -382,12 +388,7 @@ incident <- function(graph, v, mode = c("all", "out", "in", "total")) { ensure_igraph(graph) if (is_directed(graph)) { mode <- igraph.match.arg(mode) - mode <- switch(mode, - "out" = 1, - "in" = 2, - "all" = 3, - "total" = 3 - ) + mode <- switch(mode, "out" = 1, "in" = 2, "all" = 3, "total" = 3) } else { mode <- 1 } @@ -398,7 +399,9 @@ incident <- function(graph, v, mode = c("all", "out", "in", "total")) { on.exit(.Call(R_igraph_finalizer)) res <- .Call(R_igraph_incident, graph, v - 1, as.numeric(mode)) + 1L - if (igraph_opt("return.vs.es")) res <- create_es(graph, res) + if (igraph_opt("return.vs.es")) { + res <- create_es(graph, res) + } res } @@ -471,7 +474,9 @@ el_to_vec <- function(x, call = rlang::caller_env()) { if (typeof(x[[1]]) == typeof(x[[2]])) { c(rbind(x[[1]], x[[2]])) } else { - cli::cli_abort("The columns of the data.frame are of different type ({typeof(x[[1]])} and {typeof(x[[2]])}) ") + cli::cli_abort( + "The columns of the data.frame are of different type ({typeof(x[[1]])} and {typeof(x[[2]])}) " + ) } } else if (inherits(x, "matrix")) { dimx <- dim(x) @@ -492,12 +497,17 @@ el_to_vec <- function(x, call = rlang::caller_env()) { } else if (ncol == 2) { c(t(x)) } else { - cli::cli_abort("{.args vp} was supplied as a {dimx[1]} times {dimx[2]} matrix. Only n times 2 matrices are allowed") + cli::cli_abort( + "{.args vp} was supplied as a {dimx[1]} times {dimx[2]} matrix. Only n times 2 matrices are allowed" + ) } } else if (is.vector(x)) { x } else { - cli::cli_abort("Only two-column data.frames and matrices, and vectors are allowed for {.args vp}", call = call) + cli::cli_abort( + "Only two-column data.frames and matrices, and vectors are allowed for {.args vp}", + call = call + ) } } @@ -548,19 +558,20 @@ el_to_vec <- function(x, call = rlang::caller_env()) { #' eis #' E(g)[eis] #' -get_edge_ids <- function(graph, - vp, - directed = TRUE, - error = FALSE) { +get_edge_ids <- function(graph, vp, directed = TRUE, error = FALSE) { ensure_igraph(graph) vp <- el_to_vec(vp, call = rlang::caller_env()) on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_get_eids, graph, as_igraph_vs(graph, vp) - 1, - as.logical(directed), as.logical(error) - ) + 1 + R_igraph_get_eids, + graph, + as_igraph_vs(graph, vp) - 1, + as.logical(directed), + as.logical(error) + ) + + 1 } #' Find the edge ids based on the incident vertices of the edges @@ -575,11 +586,13 @@ get_edge_ids <- function(graph, #' `r lifecycle::badge("deprecated")` #' @keywords internal #' @export -get.edge.ids <- function(graph, - vp, - directed = TRUE, - error = FALSE, - multi = deprecated()) { +get.edge.ids <- function( + graph, + vp, + directed = TRUE, + error = FALSE, + multi = deprecated() +) { if (lifecycle::is_present(multi)) { if (isTRUE(multi)) { lifecycle::deprecate_stop("2.0.0", "get.edge.ids(multi = )") @@ -632,17 +645,11 @@ gorder <- vcount #' @examples #' g <- make_graph("Zachary") #' adjacent_vertices(g, c(1, 34)) -adjacent_vertices <- function(graph, v, - mode = c("out", "in", "all", "total")) { +adjacent_vertices <- function(graph, v, mode = c("out", "in", "all", "total")) { ensure_igraph(graph) vv <- as_igraph_vs(graph, v) - 1 - mode <- switch(match.arg(mode), - "out" = 1, - "in" = 2, - "all" = 3, - "total" = 3 - ) + mode <- switch(match.arg(mode), "out" = 1, "in" = 2, "all" = 3, "total" = 3) on.exit(.Call(R_igraph_finalizer)) @@ -653,7 +660,9 @@ adjacent_vertices <- function(graph, v, res <- lapply(res, unsafe_create_vs, graph = graph, verts = V(graph)) } - if (is_named(graph)) names(res) <- V(graph)$name[vv + 1] + if (is_named(graph)) { + names(res) <- V(graph)$name[vv + 1] + } res } @@ -675,17 +684,11 @@ adjacent_vertices <- function(graph, v, #' @examples #' g <- make_graph("Zachary") #' incident_edges(g, c(1, 34)) -incident_edges <- function(graph, v, - mode = c("out", "in", "all", "total")) { +incident_edges <- function(graph, v, mode = c("out", "in", "all", "total")) { ensure_igraph(graph) vv <- as_igraph_vs(graph, v) - 1 - mode <- switch(match.arg(mode), - "out" = 1, - "in" = 2, - "all" = 3, - "total" = 3 - ) + mode <- switch(match.arg(mode), "out" = 1, "in" = 2, "all" = 3, "total" = 3) on.exit(.Call(R_igraph_finalizer)) @@ -696,7 +699,9 @@ incident_edges <- function(graph, v, res <- lapply(res, unsafe_create_es, graph = graph, es = E(graph)) } - if (is_named(graph)) names(res) <- V(graph)$name[vv + 1] + if (is_named(graph)) { + names(res) <- V(graph)$name[vv + 1] + } res } From d30e64ffd1d589e9ca68a9fb1e86460cce7d1f01 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:53:28 +0200 Subject: [PATCH 24/59] layout --- R/layout.R | 670 ++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 506 insertions(+), 164 deletions(-) diff --git a/R/layout.R b/R/layout.R index ea855016d76..4915534df6a 100644 --- a/R/layout.R +++ b/R/layout.R @@ -1,4 +1,4 @@ -#' Merging graph layouts +#' Merging graph layouts #' #' @description #' `r lifecycle::badge("deprecated")` @@ -8,8 +8,13 @@ #' @inheritParams layout_components #' @keywords internal #' @export -piecewise.layout <- function(graph, layout = layout_with_kk, ...) { # nocov start - lifecycle::deprecate_soft("2.0.0", "piecewise.layout()", "layout_components()") +piecewise.layout <- function(graph, layout = layout_with_kk, ...) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "piecewise.layout()", + "layout_components()" + ) layout_components(graph = graph, layout = layout, ...) } # nocov end @@ -23,9 +28,30 @@ piecewise.layout <- function(graph, layout = layout_with_kk, ...) { # nocov star #' @inheritParams layout_with_sugiyama #' @keywords internal #' @export -layout.sugiyama <- function(graph, layers = NULL, hgap = 1, vgap = 1, maxiter = 100, weights = NULL, attributes = c("default", "all", "none")) { # nocov start - lifecycle::deprecate_soft("2.0.0", "layout.sugiyama()", "layout_with_sugiyama()") - layout_with_sugiyama(graph = graph, layers = layers, hgap = hgap, vgap = vgap, maxiter = maxiter, weights = weights, attributes = attributes) +layout.sugiyama <- function( + graph, + layers = NULL, + hgap = 1, + vgap = 1, + maxiter = 100, + weights = NULL, + attributes = c("default", "all", "none") +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "layout.sugiyama()", + "layout_with_sugiyama()" + ) + layout_with_sugiyama( + graph = graph, + layers = layers, + hgap = hgap, + vgap = vgap, + maxiter = maxiter, + weights = weights, + attributes = attributes + ) } # nocov end #' Generate coordinates to place the vertices of a graph in a star-shape @@ -38,7 +64,8 @@ layout.sugiyama <- function(graph, layers = NULL, hgap = 1, vgap = 1, maxiter = #' @inheritParams layout_as_star #' @keywords internal #' @export -layout.star <- function(graph, center = V(graph)[1], order = NULL) { # nocov start +layout.star <- function(graph, center = V(graph)[1], order = NULL) { + # nocov start lifecycle::deprecate_soft("2.0.0", "layout.star()", "layout_as_star()") layout_as_star(graph = graph, center = center, order = order) } # nocov end @@ -53,9 +80,26 @@ layout.star <- function(graph, center = V(graph)[1], order = NULL) { # nocov sta #' @inheritParams norm_coords #' @keywords internal #' @export -layout.norm <- function(layout, xmin = -1, xmax = 1, ymin = -1, ymax = 1, zmin = -1, zmax = 1) { # nocov start +layout.norm <- function( + layout, + xmin = -1, + xmax = 1, + ymin = -1, + ymax = 1, + zmin = -1, + zmax = 1 +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "layout.norm()", "norm_coords()") - norm_coords(layout = layout, xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax, zmin = zmin, zmax = zmax) + norm_coords( + layout = layout, + xmin = xmin, + xmax = xmax, + ymin = ymin, + ymax = ymax, + zmin = zmin, + zmax = zmax + ) } # nocov end #' Merging graph layouts @@ -68,7 +112,8 @@ layout.norm <- function(layout, xmin = -1, xmax = 1, ymin = -1, ymax = 1, zmin = #' @inheritParams merge_coords #' @keywords internal #' @export -layout.merge <- function(graphs, layouts, method = "dla") { # nocov start +layout.merge <- function(graphs, layouts, method = "dla") { + # nocov start lifecycle::deprecate_soft("2.0.0", "layout.merge()", "merge_coords()") merge_coords(graphs = graphs, layouts = layouts, method = method) } # nocov end @@ -83,7 +128,13 @@ layout.merge <- function(graphs, layouts, method = "dla") { # nocov start #' @inheritParams layout_with_mds #' @keywords internal #' @export -layout.mds <- function(graph, dist = NULL, dim = 2, options = arpack_defaults()) { # nocov start +layout.mds <- function( + graph, + dist = NULL, + dim = 2, + options = arpack_defaults() +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "layout.mds()", "layout_with_mds()") layout_with_mds(graph = graph, dist = dist, dim = dim, options = options) } # nocov end @@ -98,7 +149,8 @@ layout.mds <- function(graph, dist = NULL, dim = 2, options = arpack_defaults()) #' @inheritParams layout_on_grid #' @keywords internal #' @export -layout.grid <- function(graph, width = 0, height = 0, dim = 2) { # nocov start +layout.grid <- function(graph, width = 0, height = 0, dim = 2) { + # nocov start lifecycle::deprecate_soft("2.0.0", "layout.grid()", "layout_on_grid()") layout_on_grid(graph = graph, width = width, height = height, dim = dim) } # nocov end @@ -113,9 +165,32 @@ layout.grid <- function(graph, width = 0, height = 0, dim = 2) { # nocov start #' @inheritParams layout_with_graphopt #' @keywords internal #' @export -layout.graphopt <- function(graph, start = NULL, niter = 500, charge = 0.001, mass = 30, spring.length = 0, spring.constant = 1, max.sa.movement = 5) { # nocov start - lifecycle::deprecate_soft("2.0.0", "layout.graphopt()", "layout_with_graphopt()") - layout_with_graphopt(graph = graph, start = start, niter = niter, charge = charge, mass = mass, spring.length = spring.length, spring.constant = spring.constant, max.sa.movement = max.sa.movement) +layout.graphopt <- function( + graph, + start = NULL, + niter = 500, + charge = 0.001, + mass = 30, + spring.length = 0, + spring.constant = 1, + max.sa.movement = 5 +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "layout.graphopt()", + "layout_with_graphopt()" + ) + layout_with_graphopt( + graph = graph, + start = start, + niter = niter, + charge = charge, + mass = mass, + spring.length = spring.length, + spring.constant = spring.constant, + max.sa.movement = max.sa.movement + ) } # nocov end #' The GEM layout algorithm @@ -128,9 +203,24 @@ layout.graphopt <- function(graph, start = NULL, niter = 500, charge = 0.001, ma #' @inheritParams layout_with_gem #' @keywords internal #' @export -layout.gem <- function(graph, coords = NULL, maxiter = 40 * vcount(graph)^2, temp.max = max(vcount(graph), 1), temp.min = 1 / 10, temp.init = sqrt(max(vcount(graph), 1))) { # nocov start +layout.gem <- function( + graph, + coords = NULL, + maxiter = 40 * vcount(graph)^2, + temp.max = max(vcount(graph), 1), + temp.min = 1 / 10, + temp.init = sqrt(max(vcount(graph), 1)) +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "layout.gem()", "layout_with_gem()") - layout_with_gem(graph = graph, coords = coords, maxiter = maxiter, temp.max = temp.max, temp.min = temp.min, temp.init = temp.init) + layout_with_gem( + graph = graph, + coords = coords, + maxiter = maxiter, + temp.max = temp.max, + temp.min = temp.min, + temp.init = temp.init + ) } # nocov end #' The Davidson-Harel layout algorithm @@ -143,9 +233,36 @@ layout.gem <- function(graph, coords = NULL, maxiter = 40 * vcount(graph)^2, tem #' @inheritParams layout_with_dh #' @keywords internal #' @export -layout.davidson.harel <- function(graph, coords = NULL, maxiter = 10, fineiter = max(10, log2(vcount(graph))), cool.fact = 0.75, weight.node.dist = 1.0, weight.border = 0.0, weight.edge.lengths = edge_density(graph) / 10, weight.edge.crossings = 1.0 - sqrt(edge_density(graph)), weight.node.edge.dist = 0.2 * (1 - edge_density(graph))) { # nocov start - lifecycle::deprecate_soft("2.0.0", "layout.davidson.harel()", "layout_with_dh()") - layout_with_dh(graph = graph, coords = coords, maxiter = maxiter, fineiter = fineiter, cool.fact = cool.fact, weight.node.dist = weight.node.dist, weight.border = weight.border, weight.edge.lengths = weight.edge.lengths, weight.edge.crossings = weight.edge.crossings, weight.node.edge.dist = weight.node.edge.dist) +layout.davidson.harel <- function( + graph, + coords = NULL, + maxiter = 10, + fineiter = max(10, log2(vcount(graph))), + cool.fact = 0.75, + weight.node.dist = 1.0, + weight.border = 0.0, + weight.edge.lengths = edge_density(graph) / 10, + weight.edge.crossings = 1.0 - sqrt(edge_density(graph)), + weight.node.edge.dist = 0.2 * (1 - edge_density(graph)) +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "layout.davidson.harel()", + "layout_with_dh()" + ) + layout_with_dh( + graph = graph, + coords = coords, + maxiter = maxiter, + fineiter = fineiter, + cool.fact = cool.fact, + weight.node.dist = weight.node.dist, + weight.border = weight.border, + weight.edge.lengths = weight.edge.lengths, + weight.edge.crossings = weight.edge.crossings, + weight.node.edge.dist = weight.node.edge.dist + ) } # nocov end #' Simple two-row layout for bipartite graphs @@ -158,9 +275,26 @@ layout.davidson.harel <- function(graph, coords = NULL, maxiter = 10, fineiter = #' @inheritParams layout_as_bipartite #' @keywords internal #' @export -layout.bipartite <- function(graph, types = NULL, hgap = 1, vgap = 1, maxiter = 100) { # nocov start - lifecycle::deprecate_soft("2.0.0", "layout.bipartite()", "layout_as_bipartite()") - layout_as_bipartite(graph = graph, types = types, hgap = hgap, vgap = vgap, maxiter = maxiter) +layout.bipartite <- function( + graph, + types = NULL, + hgap = 1, + vgap = 1, + maxiter = 100 +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "layout.bipartite()", + "layout_as_bipartite()" + ) + layout_as_bipartite( + graph = graph, + types = types, + hgap = hgap, + vgap = vgap, + maxiter = maxiter + ) } # nocov end #' Choose an appropriate graph layout algorithm automatically @@ -173,7 +307,8 @@ layout.bipartite <- function(graph, types = NULL, hgap = 1, vgap = 1, maxiter = #' @inheritParams layout_nicely #' @keywords internal #' @export -layout.auto <- function(graph, dim = 2, ...) { # nocov start +layout.auto <- function(graph, dim = 2, ...) { + # nocov start lifecycle::deprecate_soft("2.0.0", "layout.auto()", "layout_nicely()") layout_nicely(graph = graph, dim = dim, ...) } # nocov end @@ -201,12 +336,10 @@ layout.auto <- function(graph, dim = 2, ...) { # nocov start ## ## ---------------------------------------------------------------- - ## ---------------------------------------------------------------- ## This is the new layout API ## ---------------------------------------------------------------- - #' Graph layouts #' #' This is a generic function to apply a layout function to @@ -256,13 +389,13 @@ layout.auto <- function(graph, dim = 2, ...) { # nocov start #' plot(g, layout = coords) layout_ <- function(graph, layout, ...) { modifiers <- list(...) - stopifnot(all(sapply(modifiers, inherits, - what = "igraph_layout_modifier" - ))) + stopifnot(all(sapply(modifiers, inherits, what = "igraph_layout_modifier"))) ids <- sapply(modifiers, "[[", "id") stopifnot(all(ids %in% c("component_wise", "normalize"))) - if (anyDuplicated(ids)) stop("Duplicate modifiers") + if (anyDuplicated(ids)) { + stop("Duplicate modifiers") + } names(modifiers) <- ids ## TODO: better, generic mechanism for modifiers @@ -285,7 +418,8 @@ layout_ <- function(graph, layout, ...) { if ("normalize" %in% ids) { result <- do_call( - norm_coords, list(result), + norm_coords, + list(result), modifiers[["normalize"]]$args ) } @@ -340,7 +474,8 @@ print.igraph_layout_spec <- function(x, ...) { cat(paste( sep = "", "igraph layout specification, see ?layout_:\n", - x$call_str, "\n" + x$call_str, + "\n" )) } @@ -401,8 +536,14 @@ component_wise <- function(merge_method = "dla") { #' @export #' @examples #' layout_(make_ring(10), with_fr(), normalize()) -normalize <- function(xmin = -1, xmax = 1, ymin = xmin, ymax = xmax, - zmin = xmin, zmax = xmax) { +normalize <- function( + xmin = -1, + xmax = 1, + ymin = xmin, + ymax = xmax, + zmin = xmin, + zmax = xmax +) { args <- grab_args() layout_modifier( @@ -415,7 +556,6 @@ normalize <- function(xmin = -1, xmax = 1, ymin = xmin, ymax = xmax, ## Layout definitions for the new API ## ---------------------------------------------------------------- - #' Simple two-row layout for bipartite graphs #' #' Minimize edge-crossings in a simple two-row (or column) layout for bipartite @@ -458,8 +598,13 @@ normalize <- function(xmin = -1, xmax = 1, ymin = xmin, ymax = xmax, #' g %>% #' add_layout_(as_bipartite()) %>% #' plot() -layout_as_bipartite <- function(graph, types = NULL, hgap = 1, vgap = 1, - maxiter = 100) { +layout_as_bipartite <- function( + graph, + types = NULL, + hgap = 1, + vgap = 1, + maxiter = 100 +) { ## Argument checks ensure_igraph(graph) types <- handle_vertex_type_arg(types, graph) @@ -484,7 +629,6 @@ as_bipartite <- function(...) layout_spec(layout_as_bipartite, ...) ## ---------------------------------------------------------------- - #' Generate coordinates to place the vertices of a graph in a star-shape #' #' A simple layout generator, that places one vertex in the center of a circle @@ -526,7 +670,9 @@ layout_as_star <- function(graph, center = V(graph)[1], order = NULL) { if (length(center) == 0) { center <- 1 } - if (!is.null(order)) order <- as.numeric(order) - 1 + if (!is.null(order)) { + order <- as.numeric(order) - 1 + } on.exit(.Call(R_igraph_finalizer)) # Function call @@ -544,7 +690,6 @@ as_star <- function(...) layout_spec(layout_as_star, ...) ## ---------------------------------------------------------------- - #' The Reingold-Tilford graph layout algorithm #' #' A tree-like layout, it is perfect for trees, acceptable for graphs with not @@ -601,14 +746,20 @@ as_star <- function(...) layout_spec(layout_as_star, ...) #' root = c(1, 11), #' rootlevel = c(2, 1) #' )) -layout_as_tree <- function(graph, root = numeric(), circular = FALSE, - rootlevel = numeric(), mode = c("out", "in", "all"), - flip.y = TRUE) { +layout_as_tree <- function( + graph, + root = numeric(), + circular = FALSE, + rootlevel = numeric(), + mode = c("out", "in", "all"), + flip.y = TRUE +) { ensure_igraph(graph) root <- as_igraph_vs(graph, root) - 1 circular <- as.logical(circular) rootlevel <- as.double(rootlevel) - mode <- switch(igraph.match.arg(mode), + mode <- switch( + igraph.match.arg(mode), "out" = 1, "in" = 2, "all" = 3, @@ -618,8 +769,12 @@ layout_as_tree <- function(graph, root = numeric(), circular = FALSE, on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_layout_reingold_tilford, graph, root, mode, - rootlevel, circular + R_igraph_layout_reingold_tilford, + graph, + root, + mode, + rootlevel, + circular ) if (flip.y && vcount(graph) > 0) { res[, 2] <- max(res[, 2]) - res[, 2] @@ -645,13 +800,16 @@ as_tree <- function(...) layout_spec(layout_as_tree, ...) #' @keywords internal #' @export layout.reingold.tilford <- function(..., params = list()) { - lifecycle::deprecate_soft("2.1.0", "layout.reingold.tilford()", "layout_as_tree()") + lifecycle::deprecate_soft( + "2.1.0", + "layout.reingold.tilford()", + "layout_as_tree()" + ) do_call(layout_as_tree, .args = c(list(...), params)) } ## ---------------------------------------------------------------- - #' Graph layout with vertices on a circle. #' #' Place vertices on a circle, in the order of their vertex ids. @@ -712,7 +870,6 @@ layout.circle <- function(..., params = list()) { ## ---------------------------------------------------------------- - #' Choose an appropriate graph layout algorithm automatically #' #' This function tries to choose an appropriate graph layout algorithm for the @@ -788,7 +945,9 @@ layout_nicely <- function(graph, dim = 2, ...) { if ("weight" %in% edge_attr_names(graph)) { weights <- E(graph)$weight if (any(weights <= 0, na.rm = TRUE)) { - cli::cli_warn("Non-positive edge weight found, ignoring all weights during graph layout.") + cli::cli_warn( + "Non-positive edge weight found, ignoring all weights during graph layout." + ) args$weights <- NA } } @@ -813,7 +972,6 @@ nicely <- function(...) layout_spec(layout_nicely, ...) ## ---------------------------------------------------------------- - #' Simple grid layout #' #' This layout places vertices on a rectangular grid, in two or three @@ -893,7 +1051,6 @@ layout.grid.3d <- function(graph, width = 0, height = 0) { ## ---------------------------------------------------------------- - #' Graph layout with vertices on the surface of a sphere #' #' Place vertices on a sphere, approximately uniformly, in the order of their @@ -942,7 +1099,6 @@ layout.sphere <- function(..., params = list()) { ## ---------------------------------------------------------------- - #' Randomly place vertices on a plane or in 3d space #' #' This function uniformly randomly places the vertices of the graph in two or @@ -996,8 +1152,6 @@ layout.random <- function(..., params = list()) { ## ---------------------------------------------------------------- - - #' The Davidson-Harel layout algorithm #' #' Place vertices of a graph on the plane, according to the simulated annealing @@ -1108,12 +1262,18 @@ layout.random <- function(..., params = list()) { #' path(4, 9, 20, 30, 36) + path(1, 7, 12, 14, 19, 24, 26, 30, 37) + #' path(5, 9, 13, 15, 19, 23, 25, 28, 33) + path(3, 12, 16, 25, 35, 26, 22, 13, 3) #' plot(g_12, layout = layout_with_dh, vertex.size = 5, vertex.label = NA) -layout_with_dh <- function(graph, coords = NULL, maxiter = 10, - fineiter = max(10, log2(vcount(graph))), cool.fact = 0.75, - weight.node.dist = 1.0, weight.border = 0.0, - weight.edge.lengths = edge_density(graph) / 10, - weight.edge.crossings = 1.0 - sqrt(edge_density(graph)), - weight.node.edge.dist = 0.2 * (1 - edge_density(graph))) { +layout_with_dh <- function( + graph, + coords = NULL, + maxiter = 10, + fineiter = max(10, log2(vcount(graph))), + cool.fact = 0.75, + weight.node.dist = 1.0, + weight.border = 0.0, + weight.edge.lengths = edge_density(graph) / 10, + weight.edge.crossings = 1.0 - sqrt(edge_density(graph)), + weight.node.edge.dist = 0.2 * (1 - edge_density(graph)) +) { # Argument checks ensure_igraph(graph) if (!is.null(coords)) { @@ -1135,9 +1295,17 @@ layout_with_dh <- function(graph, coords = NULL, maxiter = 10, on.exit(.Call(R_igraph_finalizer)) # Function call res <- .Call( - R_igraph_layout_davidson_harel, graph, coords, use.seed, - maxiter, fineiter, cool.fact, weight.node.dist, - weight.border, weight.edge.lengths, weight.edge.crossings, + R_igraph_layout_davidson_harel, + graph, + coords, + use.seed, + maxiter, + fineiter, + cool.fact, + weight.node.dist, + weight.border, + weight.edge.lengths, + weight.edge.crossings, weight.node.edge.dist ) @@ -1151,10 +1319,8 @@ layout_with_dh <- function(graph, coords = NULL, maxiter = 10, with_dh <- function(...) layout_spec(layout_with_dh, ...) - ## ---------------------------------------------------------------- - #' The Fruchterman-Reingold layout algorithm #' #' Place vertices on the plane using the force-directed layout algorithm by @@ -1232,14 +1398,26 @@ with_dh <- function(...) layout_spec(layout_with_dh, ...) #' axis(1) #' axis(2) #' -layout_with_fr <- function(graph, coords = NULL, dim = 2, - niter = 500, start.temp = sqrt(vcount(graph)), - grid = c("auto", "grid", "nogrid"), weights = NULL, - minx = NULL, maxx = NULL, miny = NULL, maxy = NULL, - minz = NULL, maxz = NULL, - coolexp = deprecated(), maxdelta = deprecated(), - area = deprecated(), repulserad = deprecated(), - maxiter = deprecated()) { +layout_with_fr <- function( + graph, + coords = NULL, + dim = 2, + niter = 500, + start.temp = sqrt(vcount(graph)), + grid = c("auto", "grid", "nogrid"), + weights = NULL, + minx = NULL, + maxx = NULL, + miny = NULL, + maxy = NULL, + minz = NULL, + maxz = NULL, + coolexp = deprecated(), + maxdelta = deprecated(), + area = deprecated(), + repulserad = deprecated(), + maxiter = deprecated() +) { # Argument checks ensure_igraph(graph) coords[] <- as.numeric(coords) @@ -1250,16 +1428,14 @@ layout_with_fr <- function(graph, coords = NULL, dim = 2, if (!missing(niter) && !missing(maxiter)) { stop("Both `niter' and `maxiter' are given, give only one of them") } - if (!missing(maxiter)) niter <- maxiter + if (!missing(maxiter)) { + niter <- maxiter + } niter <- as.numeric(niter) start.temp <- as.numeric(start.temp) grid <- igraph.match.arg(grid) - grid <- switch(grid, - "grid" = 0L, - "nogrid" = 1L, - "auto" = 2L - ) + grid <- switch(grid, "grid" = 0L, "nogrid" = 1L, "auto" = 2L) if (is.null(weights) && "weight" %in% edge_attr_names(graph)) { weights <- E(graph)$weight @@ -1269,12 +1445,24 @@ layout_with_fr <- function(graph, coords = NULL, dim = 2, } else { weights <- NULL } - if (!is.null(minx)) minx <- as.numeric(minx) - if (!is.null(maxx)) maxx <- as.numeric(maxx) - if (!is.null(miny)) miny <- as.numeric(miny) - if (!is.null(maxy)) maxy <- as.numeric(maxy) - if (!is.null(minz)) minz <- as.numeric(minz) - if (!is.null(maxz)) maxz <- as.numeric(maxz) + if (!is.null(minx)) { + minx <- as.numeric(minx) + } + if (!is.null(maxx)) { + maxx <- as.numeric(maxx) + } + if (!is.null(miny)) { + miny <- as.numeric(miny) + } + if (!is.null(maxy)) { + maxy <- as.numeric(maxy) + } + if (!is.null(minz)) { + minz <- as.numeric(minz) + } + if (!is.null(maxz)) { + maxz <- as.numeric(maxz) + } if (lifecycle::is_present(coolexp)) { lifecycle::deprecate_stop("0.8.0", "layout_with_fr(coolexp = )") } @@ -1291,14 +1479,32 @@ layout_with_fr <- function(graph, coords = NULL, dim = 2, on.exit(.Call(R_igraph_finalizer)) if (dim == 2) { res <- .Call( - R_igraph_layout_fruchterman_reingold, graph, coords, - niter, start.temp, weights, minx, maxx, miny, maxy, grid + R_igraph_layout_fruchterman_reingold, + graph, + coords, + niter, + start.temp, + weights, + minx, + maxx, + miny, + maxy, + grid ) } else { res <- .Call( - R_igraph_layout_fruchterman_reingold_3d, graph, coords, - niter, start.temp, weights, minx, maxx, miny, maxy, - minz, maxz + R_igraph_layout_fruchterman_reingold_3d, + graph, + coords, + niter, + start.temp, + weights, + minx, + maxx, + miny, + maxy, + minz, + maxz ) } res @@ -1321,13 +1527,16 @@ with_fr <- function(...) layout_spec(layout_with_fr, ...) #' @keywords internal #' @export layout.fruchterman.reingold <- function(..., params = list()) { - lifecycle::deprecate_soft("2.1.0", "layout.fruchterman.reingold()", "layout_with_fr()") + lifecycle::deprecate_soft( + "2.1.0", + "layout.fruchterman.reingold()", + "layout_with_fr()" + ) do_call(layout_with_fr, .args = c(list(...), params)) } ## ---------------------------------------------------------------- - #' The GEM layout algorithm #' #' Place vertices on the plane using the GEM force-directed layout algorithm. @@ -1366,9 +1575,14 @@ layout.fruchterman.reingold <- function(..., params = list()) { #' g <- make_ring(10) #' plot(g, layout = layout_with_gem) #' -layout_with_gem <- function(graph, coords = NULL, maxiter = 40 * vcount(graph)^2, - temp.max = max(vcount(graph), 1), temp.min = 1 / 10, - temp.init = sqrt(max(vcount(graph), 1))) { +layout_with_gem <- function( + graph, + coords = NULL, + maxiter = 40 * vcount(graph)^2, + temp.max = max(vcount(graph), 1), + temp.min = 1 / 10, + temp.init = sqrt(max(vcount(graph), 1)) +) { # Argument checks ensure_igraph(graph) if (!is.null(coords)) { @@ -1387,8 +1601,14 @@ layout_with_gem <- function(graph, coords = NULL, maxiter = 40 * vcount(graph)^2 on.exit(.Call(R_igraph_finalizer)) # Function call res <- .Call( - R_igraph_layout_gem, graph, coords, use.seed, maxiter, - temp.max, temp.min, temp.init + R_igraph_layout_gem, + graph, + coords, + use.seed, + maxiter, + temp.max, + temp.min, + temp.init ) res @@ -1403,7 +1623,6 @@ with_gem <- function(...) layout_spec(layout_with_gem, ...) ## ---------------------------------------------------------------- - #' The graphopt layout algorithm #' #' A force-directed layout algorithm, that scales relatively well to large @@ -1444,9 +1663,16 @@ with_gem <- function(...) layout_spec(layout_with_gem, ...) #' @keywords graphs #' @export #' @family graph layouts -layout_with_graphopt <- function(graph, start = NULL, niter = 500, charge = 0.001, - mass = 30, spring.length = 0, spring.constant = 1, - max.sa.movement = 5) { +layout_with_graphopt <- function( + graph, + start = NULL, + niter = 500, + charge = 0.001, + mass = 30, + spring.length = 0, + spring.constant = 1, + max.sa.movement = 5 +) { ensure_igraph(graph) start[] <- as.numeric(start) niter <- as.double(niter) @@ -1458,8 +1684,15 @@ layout_with_graphopt <- function(graph, start = NULL, niter = 500, charge = 0.00 on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_layout_graphopt, graph, niter, charge, mass, - spring.length, spring.constant, max.sa.movement, start + R_igraph_layout_graphopt, + graph, + niter, + charge, + mass, + spring.length, + spring.constant, + max.sa.movement, + start ) } @@ -1472,7 +1705,6 @@ with_graphopt <- function(...) layout_spec(layout_with_graphopt, ...) ## ---------------------------------------------------------------- - #' The Kamada-Kawai layout algorithm #' #' Place the vertices on the plane, or in 3D space, based on a physical @@ -1533,21 +1765,33 @@ with_graphopt <- function(...) layout_spec(layout_with_graphopt, ...) #' E(g)$weight <- rep(1:2, length.out = ecount(g)) #' plot(g, layout = layout_with_kk, edge.label = E(g)$weight) #' -layout_with_kk <- function(graph, coords = NULL, dim = 2, - maxiter = 50 * vcount(graph), - epsilon = 0.0, kkconst = max(vcount(graph), 1), - weights = NULL, minx = NULL, maxx = NULL, - miny = NULL, maxy = NULL, minz = NULL, maxz = NULL, - niter = deprecated(), - sigma = deprecated(), - initemp = deprecated(), - coolexp = deprecated(), - start = deprecated()) { +layout_with_kk <- function( + graph, + coords = NULL, + dim = 2, + maxiter = 50 * vcount(graph), + epsilon = 0.0, + kkconst = max(vcount(graph), 1), + weights = NULL, + minx = NULL, + maxx = NULL, + miny = NULL, + maxy = NULL, + minz = NULL, + maxz = NULL, + niter = deprecated(), + sigma = deprecated(), + initemp = deprecated(), + coolexp = deprecated(), + start = deprecated() +) { # Argument checks if (!missing(coords) && !missing(start)) { stop("Both `coords' and `start' are given, give only one of them.") } - if (!missing(start)) coords <- start + if (!missing(start)) { + coords <- start + } ensure_igraph(graph) coords[] <- as.numeric(coords) @@ -1567,12 +1811,24 @@ layout_with_kk <- function(graph, coords = NULL, dim = 2, } else { weights <- NULL } - if (!is.null(minx)) minx <- as.numeric(minx) - if (!is.null(maxx)) maxx <- as.numeric(maxx) - if (!is.null(miny)) miny <- as.numeric(miny) - if (!is.null(maxy)) maxy <- as.numeric(maxy) - if (!is.null(minz)) minz <- as.numeric(minz) - if (!is.null(maxz)) maxz <- as.numeric(maxz) + if (!is.null(minx)) { + minx <- as.numeric(minx) + } + if (!is.null(maxx)) { + maxx <- as.numeric(maxx) + } + if (!is.null(miny)) { + miny <- as.numeric(miny) + } + if (!is.null(maxy)) { + maxy <- as.numeric(maxy) + } + if (!is.null(minz)) { + minz <- as.numeric(minz) + } + if (!is.null(maxz)) { + maxz <- as.numeric(maxz) + } if (lifecycle::is_present(niter)) { lifecycle::deprecate_stop("0.8.0", "layout_with_kk(niter = )") @@ -1591,13 +1847,32 @@ layout_with_kk <- function(graph, coords = NULL, dim = 2, # Function call if (dim == 2) { res <- .Call( - R_igraph_layout_kamada_kawai, graph, coords, maxiter, - epsilon, kkconst, weights, minx, maxx, miny, maxy + R_igraph_layout_kamada_kawai, + graph, + coords, + maxiter, + epsilon, + kkconst, + weights, + minx, + maxx, + miny, + maxy ) } else { res <- .Call( - R_igraph_layout_kamada_kawai_3d, graph, coords, maxiter, - epsilon, kkconst, weights, minx, maxx, miny, maxy, minz, + R_igraph_layout_kamada_kawai_3d, + graph, + coords, + maxiter, + epsilon, + kkconst, + weights, + minx, + maxx, + miny, + maxy, + minz, maxz ) } @@ -1623,13 +1898,16 @@ with_kk <- function(...) layout_spec(layout_with_kk, ...) #' @keywords internal #' @export layout.kamada.kawai <- function(..., params = list()) { - lifecycle::deprecate_soft("2.1.0", "layout.kamada.kawai()", "layout_with_kk()") + lifecycle::deprecate_soft( + "2.1.0", + "layout.kamada.kawai()", + "layout_with_kk()" + ) do_call(layout_with_kk, .args = c(list(...), params)) } ## ---------------------------------------------------------------- - #' Large Graph Layout #' #' A layout generator for larger graphs. @@ -1658,10 +1936,16 @@ layout.kamada.kawai <- function(..., params = list()) { #' @keywords graphs #' @export #' @family graph layouts -layout_with_lgl <- function(graph, maxiter = 150, maxdelta = vcount(graph), - area = vcount(graph)^2, coolexp = 1.5, - repulserad = area * vcount(graph), - cellsize = sqrt(sqrt(area)), root = NULL) { +layout_with_lgl <- function( + graph, + maxiter = 150, + maxdelta = vcount(graph), + area = vcount(graph)^2, + coolexp = 1.5, + repulserad = area * vcount(graph), + cellsize = sqrt(sqrt(area)), + root = NULL +) { ensure_igraph(graph) if (is.null(root)) { root <- -1 @@ -1671,9 +1955,15 @@ layout_with_lgl <- function(graph, maxiter = 150, maxdelta = vcount(graph), on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_layout_lgl, graph, as.double(maxiter), - as.double(maxdelta), as.double(area), as.double(coolexp), - as.double(repulserad), as.double(cellsize), root + R_igraph_layout_lgl, + graph, + as.double(maxiter), + as.double(maxdelta), + as.double(area), + as.double(coolexp), + as.double(repulserad), + as.double(cellsize), + root ) } @@ -1700,8 +1990,6 @@ layout.lgl <- function(..., params = list()) { ## ---------------------------------------------------------------- - - #' Graph layout by multidimensional scaling #' #' Multidimensional scaling of some distance matrix defined on the vertices of @@ -1745,13 +2033,19 @@ layout.lgl <- function(..., params = list()) { #' g <- sample_gnp(100, 2 / 100) #' l <- layout_with_mds(g) #' plot(g, layout = l, vertex.label = NA, vertex.size = 3) -layout_with_mds <- function(graph, dist = NULL, dim = 2, - options = arpack_defaults()) { +layout_with_mds <- function( + graph, + dist = NULL, + dim = 2, + options = arpack_defaults() +) { if (is.function(options)) { lifecycle::deprecate_soft( "1.6.0", "layout_with_mds(options = 'must be a list')", - details = c("`arpack_defaults()` is now a function, use `options = arpack_defaults()` instead of `options = arpack_defaults`.") + details = c( + "`arpack_defaults()` is now a function, use `options = arpack_defaults()` instead of `options = arpack_defaults`." + ) ) options <- options() } @@ -1777,7 +2071,6 @@ with_mds <- function(...) layout_spec(layout_with_mds, ...) ## ---------------------------------------------------------------- - #' The Sugiyama graph layout generator #' #' Sugiyama layout algorithm for layered directed acyclic graphs. The algorithm @@ -1988,12 +2281,20 @@ with_mds <- function(...) layout_spec(layout_with_mds, ...) #' edge.arrow.mode = ifelse(realedge, 2, 0) #' ) #' -layout_with_sugiyama <- function(graph, layers = NULL, hgap = 1, vgap = 1, - maxiter = 100, weights = NULL, - attributes = c("default", "all", "none")) { +layout_with_sugiyama <- function( + graph, + layers = NULL, + hgap = 1, + vgap = 1, + maxiter = 100, + weights = NULL, + attributes = c("default", "all", "none") +) { # Argument checks ensure_igraph(graph) - if (!is.null(layers)) layers <- as.numeric(layers) - 1 + if (!is.null(layers)) { + layers <- as.numeric(layers) - 1 + } hgap <- as.numeric(hgap) vgap <- as.numeric(vgap) maxiter <- as.numeric(maxiter) @@ -2010,8 +2311,13 @@ layout_with_sugiyama <- function(graph, layers = NULL, hgap = 1, vgap = 1, on.exit(.Call(R_igraph_finalizer)) # Function call res <- .Call( - R_igraph_layout_sugiyama, graph, layers, hgap, - vgap, maxiter, weights + R_igraph_layout_sugiyama, + graph, + layers, + hgap, + vgap, + maxiter, + weights ) # Flip the y coordinates, more natural this way @@ -2033,7 +2339,9 @@ layout_with_sugiyama <- function(graph, layers = NULL, hgap = 1, vgap = 1, E(res$extd_graph)$orig <- res$extd_to_orig_eids res$extd_to_orig_eids <- NULL - res$extd_graph <- set_vertex_attr(res$extd_graph, "dummy", + res$extd_graph <- set_vertex_attr( + res$extd_graph, + "dummy", value = c( rep(FALSE, vc), rep(TRUE, nrow(res$res) - vc) @@ -2088,14 +2396,16 @@ layout_with_sugiyama <- function(graph, layers = NULL, hgap = 1, vgap = 1, ) for (ga in gatt) { res$extd_graph <- set_graph_attr( - res$extd_graph, ga, + res$extd_graph, + ga, graph_attr(graph, ga) ) } for (va in vatt) { notdummy <- which(!V(res$extd_graph)$dummy) res$extd_graph <- set_vertex_attr( - res$extd_graph, va, + res$extd_graph, + va, notdummy, vertex_attr(graph, va) ) @@ -2119,7 +2429,6 @@ with_sugiyama <- function(...) layout_spec(layout_with_sugiyama, ...) ## ---------------------------------------------------------------- - #' Merging graph layouts #' #' Place several graphs on the same layout @@ -2174,7 +2483,8 @@ merge_coords <- function(graphs, layouts, method = "dla") { on.exit(.Call(R_igraph_finalizer)) res <- .Call( R_igraph_layout_merge_dla, - graphs, layouts + graphs, + layouts ) } else { stop("Invalid `method'.") @@ -2183,7 +2493,6 @@ merge_coords <- function(graphs, layouts, method = "dla") { } - #' Normalize coordinates for plotting graphs #' #' Rescale coordinates linearly to be within given bounds. @@ -2204,8 +2513,15 @@ merge_coords <- function(graphs, layouts, method = "dla") { #' @export #' @family graph layouts #' @keywords graphs -norm_coords <- function(layout, xmin = -1, xmax = 1, ymin = -1, ymax = 1, - zmin = -1, zmax = 1) { +norm_coords <- function( + layout, + xmin = -1, + xmax = 1, + ymin = -1, + ymax = 1, + zmin = -1, + zmax = 1 +) { if (!is.matrix(layout)) { stop("`layout' must be a matrix") } @@ -2323,9 +2639,24 @@ layout.fruchterman.reingold.grid <- function(graph, ...) { #' @inheritParams layout_with_drl #' @keywords internal #' @export -layout.drl <- function(graph, use.seed = FALSE, seed = matrix(runif(vcount(graph) * 2), ncol = 2), options = drl_defaults$default, weights = NULL, dim = 2) { # nocov start +layout.drl <- function( + graph, + use.seed = FALSE, + seed = matrix(runif(vcount(graph) * 2), ncol = 2), + options = drl_defaults$default, + weights = NULL, + dim = 2 +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "layout.drl()", "layout_with_drl()") - layout_with_drl(graph = graph, use.seed = use.seed, seed = seed, options = options, weights = weights, dim = dim) + layout_with_drl( + graph = graph, + use.seed = use.seed, + seed = seed, + options = options, + weights = weights, + dim = dim + ) } # nocov end #' The DrL graph layout generator @@ -2459,11 +2790,14 @@ layout.drl <- function(graph, use.seed = FALSE, seed = matrix(runif(vcount(graph #' l <- layout_with_drl(g, options = list(simmer.attraction = 0)) #' plot(g, layout = l, vertex.size = 3, vertex.label = NA) #' -layout_with_drl <- function(graph, use.seed = FALSE, - seed = matrix(runif(vcount(graph) * 2), ncol = 2), - options = drl_defaults$default, - weights = NULL, - dim = 2) { +layout_with_drl <- function( + graph, + use.seed = FALSE, + seed = matrix(runif(vcount(graph) * 2), ncol = 2), + options = drl_defaults$default, + weights = NULL, + dim = 2 +) { ensure_igraph(graph) if (dim != 2 && dim != 3) { @@ -2487,12 +2821,20 @@ layout_with_drl <- function(graph, use.seed = FALSE, on.exit(.Call(R_igraph_finalizer)) if (dim == 2) { res <- .Call( - R_igraph_layout_drl, graph, seed, use.seed, options, + R_igraph_layout_drl, + graph, + seed, + use.seed, + options, weights ) } else { res <- .Call( - R_igraph_layout_drl_3d, graph, seed, use.seed, options, + R_igraph_layout_drl_3d, + graph, + seed, + use.seed, + options, weights ) } From 07e72edb9d0385b3f452fbc441614c924c403b28 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:53:43 +0200 Subject: [PATCH 25/59] palette --- R/palette.R | 108 ++++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 87 insertions(+), 21 deletions(-) diff --git a/R/palette.R b/R/palette.R index cae91257fbe..47b9ff0676f 100644 --- a/R/palette.R +++ b/R/palette.R @@ -21,7 +21,6 @@ ## ## ----------------------------------------------------------------------- - #' Palette for categories #' #' This is a color blind friendly palette from @@ -55,11 +54,19 @@ categorical_pal <- function(n) { stopifnot(n > 0) x <- c( - "#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", - "#D55E00", "#CC79A7", "#999999" + "#E69F00", + "#56B4E9", + "#009E73", + "#F0E442", + "#0072B2", + "#D55E00", + "#CC79A7", + "#999999" ) - if (n > length(x)) cli::cli_warn("Cannot make {n} categorical colors.") + if (n > length(x)) { + cli::cli_warn("Cannot make {n} categorical colors.") + } n <- min(n, length(x)) @@ -102,20 +109,40 @@ sequential_pal <- function(n) { c("#FEF0D9", "#FDCC8A", "#FC8D59", "#E34A33", "#B30000"), c("#FEF0D9", "#FDD49E", "#FDBB84", "#FC8D59", "#E34A33", "#B30000"), c( - "#FEF0D9", "#FDD49E", "#FDBB84", "#FC8D59", "#EF6548", "#D7301F", + "#FEF0D9", + "#FDD49E", + "#FDBB84", + "#FC8D59", + "#EF6548", + "#D7301F", "#990000" ), c( - "#FFF7EC", "#FEE8C8", "#FDD49E", "#FDBB84", "#FC8D59", "#EF6548", - "#D7301F", "#990000" + "#FFF7EC", + "#FEE8C8", + "#FDD49E", + "#FDBB84", + "#FC8D59", + "#EF6548", + "#D7301F", + "#990000" ), c( - "#FFF7EC", "#FEE8C8", "#FDD49E", "#FDBB84", "#FC8D59", "#EF6548", - "#D7301F", "#B30000", "#7F0000" + "#FFF7EC", + "#FEE8C8", + "#FDD49E", + "#FDBB84", + "#FC8D59", + "#EF6548", + "#D7301F", + "#B30000", + "#7F0000" ) ) - if (n > length(x)) cli::cli_warn("Cannot make {n} sequential colors.") + if (n > length(x)) { + cli::cli_warn("Cannot make {n} sequential colors.") + } n <- min(n, length(x)) @@ -170,28 +197,65 @@ diverging_pal <- function(n) { c("#E66101", "#FDB863", "#F7F7F7", "#B2ABD2", "#5E3C99"), c("#B35806", "#F1A340", "#FEE0B6", "#D8DAEB", "#998EC3", "#542788"), c( - "#B35806", "#F1A340", "#FEE0B6", "#F7F7F7", "#D8DAEB", "#998EC3", + "#B35806", + "#F1A340", + "#FEE0B6", + "#F7F7F7", + "#D8DAEB", + "#998EC3", "#542788" ), c( - "#B35806", "#E08214", "#FDB863", "#FEE0B6", "#D8DAEB", "#B2ABD2", - "#8073AC", "#542788" + "#B35806", + "#E08214", + "#FDB863", + "#FEE0B6", + "#D8DAEB", + "#B2ABD2", + "#8073AC", + "#542788" ), c( - "#B35806", "#E08214", "#FDB863", "#FEE0B6", "#F7F7F7", "#D8DAEB", - "#B2ABD2", "#8073AC", "#542788" + "#B35806", + "#E08214", + "#FDB863", + "#FEE0B6", + "#F7F7F7", + "#D8DAEB", + "#B2ABD2", + "#8073AC", + "#542788" ), c( - "#7F3B08", "#B35806", "#E08214", "#FDB863", "#FEE0B6", "#D8DAEB", - "#B2ABD2", "#8073AC", "#542788", "#2D004B" + "#7F3B08", + "#B35806", + "#E08214", + "#FDB863", + "#FEE0B6", + "#D8DAEB", + "#B2ABD2", + "#8073AC", + "#542788", + "#2D004B" ), c( - "#7F3B08", "#B35806", "#E08214", "#FDB863", "#FEE0B6", "#F7F7F7", - "#D8DAEB", "#B2ABD2", "#8073AC", "#542788", "#2D004B" + "#7F3B08", + "#B35806", + "#E08214", + "#FDB863", + "#FEE0B6", + "#F7F7F7", + "#D8DAEB", + "#B2ABD2", + "#8073AC", + "#542788", + "#2D004B" ) ) - if (n > length(x)) cli::cli_warn("Cannot make {n} divergent colors.") + if (n > length(x)) { + cli::cli_warn("Cannot make {n} divergent colors.") + } n <- min(n, length(x)) @@ -213,7 +277,9 @@ diverging_pal <- function(n) { #' @importFrom grDevices palette r_pal <- function(n) { x <- palette() - if (n > length(x)) cli::cli_warn("Cannot make {n} divergent colors.") + if (n > length(x)) { + cli::cli_warn("Cannot make {n} divergent colors.") + } n <- min(n, length(x)) if (n == 0) character() else x[[n]] } From d99195daa0ee218914763270ac14e64d2741637b Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:53:58 +0200 Subject: [PATCH 26/59] make --- R/make.R | 115 ++++++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 84 insertions(+), 31 deletions(-) diff --git a/R/make.R b/R/make.R index 90bac175b13..657bdb15462 100644 --- a/R/make.R +++ b/R/make.R @@ -20,8 +20,9 @@ graph <- function( # nocov start lifecycle::deprecate_soft("2.1.0", "graph()", "make_graph()") if (inherits(edges, "formula")) { - if (!missing(n)) + if (!missing(n)) { cli::cli_abort("{.arg n} should not be given for graph literals") + } if (!missing(isolates)) { cli::cli_abort("{.arg isolates} should not be given for graph literals") } @@ -41,11 +42,14 @@ graph <- function( cli::cli_abort("Only give one of {.arg dir} and {.arg directed}") } - if (!missing(dir) && missing(directed)) directed <- dir + if (!missing(dir) && missing(directed)) { + directed <- dir + } if (is.character(edges) && length(edges) == 1) { - if (!missing(n)) + if (!missing(n)) { cli::cli_warn("{.arg n} is ignored for the {.str {edges}} graph.") + } if (!missing(isolates)) { cli::cli_warn( "{.arg isolates} is ignored for the {.str {edges}} graph." @@ -59,7 +63,9 @@ graph <- function( if (!missing(dir)) { cli::cli_warn("{.arg dir} is ignored for the {.str {edges}} graph") } - if (length(list(...))) cli::cli_abort("Extra arguments in make_graph") + if (length(list(...))) { + cli::cli_abort("Extra arguments in make_graph") + } make_famous_graph(edges) @@ -69,7 +75,9 @@ graph <- function( is.null(edges) || (is.logical(edges) && length(edges) == 0) ) { - if (is.null(edges) || is.logical(edges)) edges <- as.numeric(edges) + if (is.null(edges) || is.logical(edges)) { + edges <- as.numeric(edges) + } if (!is.null(isolates)) { cli::cli_warn("{.arg isolates} ignored for numeric edge list.") } @@ -88,15 +96,21 @@ graph <- function( } args <- list(edges, ...) - if (!missing(n)) args <- c(args, list(n = n)) - if (!missing(directed)) args <- c(args, list(directed = directed)) + if (!missing(n)) { + args <- c(args, list(n = n)) + } + if (!missing(directed)) { + args <- c(args, list(directed = directed)) + } do.call(old_graph, args) } else if (is.character(edges)) { if (!missing(n)) { cli::cli_warn("{.arg n} is ignored for edge list with vertex names.") } - if (length(list(...))) cli::cli_abort("Extra arguments in make_graph") + if (length(list(...))) { + cli::cli_abort("Extra arguments in make_graph") + } el <- matrix(edges, ncol = 2, byrow = TRUE) res <- graph_from_edgelist(el, directed = directed) @@ -133,8 +147,9 @@ graph.famous <- function( # nocov start lifecycle::deprecate_soft("2.1.0", "graph.famous()", "make_graph()") if (inherits(edges, "formula")) { - if (!missing(n)) + if (!missing(n)) { cli::cli_abort("{.arg n} should not be given for graph literals") + } if (!missing(isolates)) { cli::cli_abort("{.arg isolates} should not be given for graph literals") } @@ -154,11 +169,14 @@ graph.famous <- function( cli::cli_abort("Only give one of {.arg dir} and {.arg directed}") } - if (!missing(dir) && missing(directed)) directed <- dir + if (!missing(dir) && missing(directed)) { + directed <- dir + } if (is.character(edges) && length(edges) == 1) { - if (!missing(n)) + if (!missing(n)) { cli::cli_warn("{.arg n} is ignored for the {.str {edges}} graph.") + } if (!missing(isolates)) { cli::cli_warn( "{.arg isolates} is ignored for the {.str {edges}} graph." @@ -172,7 +190,9 @@ graph.famous <- function( if (!missing(dir)) { cli::cli_warn("{.arg dir} is ignored for the {.str {edges}} graph.") } - if (length(list(...))) cli::cli_abort("Extra arguments in make_graph") + if (length(list(...))) { + cli::cli_abort("Extra arguments in make_graph") + } make_famous_graph(edges) @@ -182,7 +202,9 @@ graph.famous <- function( is.null(edges) || (is.logical(edges) && length(edges) == 0) ) { - if (is.null(edges) || is.logical(edges)) edges <- as.numeric(edges) + if (is.null(edges) || is.logical(edges)) { + edges <- as.numeric(edges) + } if (!is.null(isolates)) { cli::cli_warn("{.arg isolates} ignored for numeric edge list.") } @@ -201,15 +223,21 @@ graph.famous <- function( } args <- list(edges, ...) - if (!missing(n)) args <- c(args, list(n = n)) - if (!missing(directed)) args <- c(args, list(directed = directed)) + if (!missing(n)) { + args <- c(args, list(n = n)) + } + if (!missing(directed)) { + args <- c(args, list(directed = directed)) + } do.call(old_graph, args) } else if (is.character(edges)) { if (!missing(n)) { cli::cli_warn("{.arg n} is ignored for edge list with vertex names.") } - if (length(list(...))) cli::cli_abort("Extra arguments in make_graph") + if (length(list(...))) { + cli::cli_abort("Extra arguments in make_graph") + } el <- matrix(edges, ncol = 2, byrow = TRUE) res <- graph_from_edgelist(el, directed = directed) @@ -830,9 +858,15 @@ graph.atlas <- function(n) { ga <- graph_attr_names(graph) va <- vertex_attr_names(graph) ea <- edge_attr_names(graph) - for (g in ga) graph <- delete_graph_attr(graph, g) - for (v in va) graph <- delete_vertex_attr(graph, v) - for (e in ea) graph <- delete_edge_attr(graph, e) + for (g in ga) { + graph <- delete_graph_attr(graph, g) + } + for (v in va) { + graph <- delete_vertex_attr(graph, v) + } + for (e in ea) { + graph <- delete_edge_attr(graph, e) + } } else if (m$id == "without_loops") { graph <- simplify(graph, remove.loops = TRUE, remove.multiple = FALSE) } else if (m$id == "without_multiples") { @@ -1404,8 +1438,9 @@ make_graph <- function( simplify = TRUE ) { if (inherits(edges, "formula")) { - if (!missing(n)) + if (!missing(n)) { cli::cli_abort("{.arg n} should not be given for graph literals") + } if (!missing(isolates)) { cli::cli_abort("{.arg isolates} should not be given for graph literals") } @@ -1425,11 +1460,14 @@ make_graph <- function( cli::cli_abort("Only give one of {.arg dir} and {.arg directed}") } - if (!missing(dir) && missing(directed)) directed <- dir + if (!missing(dir) && missing(directed)) { + directed <- dir + } if (is.character(edges) && length(edges) == 1) { - if (!missing(n)) + if (!missing(n)) { cli::cli_warn("{.arg n} is ignored for the {.str {edges}} graph.") + } if (!missing(isolates)) { cli::cli_warn( "{.arg isolates} is ignored for the {.str {edges}} graph." @@ -1443,7 +1481,9 @@ make_graph <- function( if (!missing(dir)) { cli::cli_warn("{.arg dir} is ignored for the {.str {edges}} graph.") } - if (length(list(...))) cli::cli_abort("Extra arguments in make_graph") + if (length(list(...))) { + cli::cli_abort("Extra arguments in make_graph") + } make_famous_graph(edges) @@ -1453,7 +1493,9 @@ make_graph <- function( is.null(edges) || (is.logical(edges) && length(edges) == 0) ) { - if (is.null(edges) || is.logical(edges)) edges <- as.numeric(edges) + if (is.null(edges) || is.logical(edges)) { + edges <- as.numeric(edges) + } if (!is.null(isolates)) { cli::cli_warn("{.arg isolates} ignored for numeric edge list.") } @@ -1472,15 +1514,21 @@ make_graph <- function( } args <- list(edges, ...) - if (!missing(n)) args <- c(args, list(n = n)) - if (!missing(directed)) args <- c(args, list(directed = directed)) + if (!missing(n)) { + args <- c(args, list(n = n)) + } + if (!missing(directed)) { + args <- c(args, list(directed = directed)) + } do.call(old_graph, args) } else if (is.character(edges)) { if (!missing(n)) { cli::cli_warn("{.arg n} is ignored for edge list with vertex names.") } - if (length(list(...))) cli::cli_abort("Extra arguments in make_graph") + if (length(list(...))) { + cli::cli_abort("Extra arguments in make_graph") + } el <- matrix(edges, ncol = 2, byrow = TRUE) res <- graph_from_edgelist(el, directed = directed) @@ -1783,7 +1831,9 @@ graph_from_literal_i <- function(mf) { ids <- seq(along.with = v) names(ids) <- v res <- make_graph(unname(ids[edges]), n = length(v), directed = directed) - if (simplify) res <- simplify(res) + if (simplify) { + res <- simplify(res) + } res <- set_vertex_attr(res, "name", value = v) res } @@ -2078,8 +2128,9 @@ sample_tree <- tree_game_impl #' @rdname make_tree #' @param ... Passed to `make_tree()` or `sample_tree()`. #' @export -tree <- function(...) +tree <- function(...) { constructor_spec(list(make = make_tree, sample = sample_tree), ...) +} ## ----------------------------------------------------------------- @@ -2410,8 +2461,9 @@ make_full_bipartite_graph <- function( #' @rdname make_full_bipartite_graph #' @param ... Passed to `make_full_bipartite_graph()`. #' @export -full_bipartite_graph <- function(...) +full_bipartite_graph <- function(...) { constructor_spec(make_full_bipartite_graph, ...) +} ## ----------------------------------------------------------------- @@ -2525,8 +2577,9 @@ make_full_citation_graph <- function(n, directed = TRUE) { #' @rdname make_full_citation_graph #' @param ... Passed to `make_full_citation_graph()`. #' @export -full_citation_graph <- function(...) +full_citation_graph <- function(...) { constructor_spec(make_full_citation_graph, ...) +} ## ----------------------------------------------------------------- From e7583dc62ffa61c4587dab0a1713b403293a7cd9 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:54:10 +0200 Subject: [PATCH 27/59] mst --- R/minimum.spanning.tree.R | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/R/minimum.spanning.tree.R b/R/minimum.spanning.tree.R index b151057da7a..4a47836555d 100644 --- a/R/minimum.spanning.tree.R +++ b/R/minimum.spanning.tree.R @@ -8,7 +8,13 @@ #' @inheritParams mst #' @keywords internal #' @export -minimum.spanning.tree <- function(graph, weights = NULL, algorithm = NULL, ...) { # nocov start +minimum.spanning.tree <- function( + graph, + weights = NULL, + algorithm = NULL, + ... +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "minimum.spanning.tree()", "mst()") mst(graph = graph, weights = weights, algorithm = algorithm, ...) } # nocov end @@ -33,8 +39,6 @@ minimum.spanning.tree <- function(graph, weights = NULL, algorithm = NULL, ...) # ################################################################### - - #' Minimum spanning tree #' #' A *spanning tree* of a connected graph is a connected subgraph with @@ -75,8 +79,7 @@ minimum.spanning.tree <- function(graph, weights = NULL, algorithm = NULL, ...) #' g <- sample_gnp(100, 3 / 100) #' g_mst <- mst(g) #' -mst <- function(graph, weights = NULL, - algorithm = NULL, ...) { +mst <- function(graph, weights = NULL, algorithm = NULL, ...) { ensure_igraph(graph) if (is.null(algorithm)) { From a0d0f36cb2b5e0dc7c201f596c6122254f86b75f Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:54:25 +0200 Subject: [PATCH 28/59] motifs --- R/motifs.R | 65 ++++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 48 insertions(+), 17 deletions(-) diff --git a/R/motifs.R b/R/motifs.R index 5821a699814..0612315f14a 100644 --- a/R/motifs.R +++ b/R/motifs.R @@ -8,7 +8,8 @@ #' @inheritParams triad_census #' @keywords internal #' @export -triad.census <- function(graph) { # nocov start +triad.census <- function(graph) { + # nocov start lifecycle::deprecate_soft("2.0.0", "triad.census()", "triad_census()") triad_census(graph = graph) } # nocov end @@ -43,9 +44,22 @@ graph.motifs.no <- function(graph, size = 3, cut.prob = rep(0, size)) { #' @inheritParams sample_motifs #' @keywords internal #' @export -graph.motifs.est <- function(graph, size = 3, cut.prob = rep(0, size), sample.size = vcount(graph) / 10, sample = NULL) { # nocov start +graph.motifs.est <- function( + graph, + size = 3, + cut.prob = rep(0, size), + sample.size = vcount(graph) / 10, + sample = NULL +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "graph.motifs.est()", "sample_motifs()") - sample_motifs(graph = graph, size = size, cut.prob = cut.prob, sample.size = sample.size, sample = sample) + sample_motifs( + graph = graph, + size = size, + cut.prob = cut.prob, + sample.size = sample.size, + sample = sample + ) } # nocov end #' Graph motifs @@ -62,7 +76,8 @@ graph.motifs.est <- function(graph, size = 3, cut.prob = rep(0, size), sample.si #' @inheritParams motifs #' @keywords internal #' @export -graph.motifs <- function(graph, size = 3, cut.prob = rep(0, size)) { # nocov start +graph.motifs <- function(graph, size = 3, cut.prob = rep(0, size)) { + # nocov start lifecycle::deprecate_soft("2.0.0", "graph.motifs()", "motifs()") motifs(graph = graph, size = size, cut.prob = cut.prob) } # nocov end @@ -77,7 +92,8 @@ graph.motifs <- function(graph, size = 3, cut.prob = rep(0, size)) { # nocov sta #' @inheritParams dyad_census #' @keywords internal #' @export -dyad.census <- function(graph) { # nocov start +dyad.census <- function(graph) { + # nocov start lifecycle::deprecate_soft("2.0.0", "dyad.census()", "dyad_census()") dyad_census(graph = graph) } # nocov end @@ -137,7 +153,9 @@ dyad.census <- function(graph) { # nocov start motifs <- function(graph, size = 3, cut.prob = NULL) { ensure_igraph(graph) - if (!is.null(cut.prob)) cut.prob <- as.numeric(cut.prob) + if (!is.null(cut.prob)) { + cut.prob <- as.numeric(cut.prob) + } if (!is.null(cut.prob) && length(cut.prob) != size) { cli::cli_abort("{arg cut.prob} must be the same length as {.arg size}") @@ -145,7 +163,9 @@ motifs <- function(graph, size = 3, cut.prob = NULL) { on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_motifs_randesu, graph, as.numeric(size), + R_igraph_motifs_randesu, + graph, + as.numeric(size), cut.prob ) res[is.nan(res)] <- NA @@ -180,7 +200,9 @@ motifs <- function(graph, size = 3, cut.prob = NULL) { count_motifs <- function(graph, size = 3, cut.prob = NULL) { ensure_igraph(graph) - if (!is.null(cut.prob)) cut.prob <- as.numeric(cut.prob) + if (!is.null(cut.prob)) { + cut.prob <- as.numeric(cut.prob) + } if (!is.null(cut.prob) && length(cut.prob) != size) { cli::cli_abort("{arg cut.prob} must be the same length as {.arg size}") @@ -188,7 +210,9 @@ count_motifs <- function(graph, size = 3, cut.prob = NULL) { on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_motifs_randesu_no, graph, as.numeric(size), + R_igraph_motifs_randesu_no, + graph, + as.numeric(size), cut.prob ) } @@ -226,14 +250,17 @@ count_motifs <- function(graph, size = 3, cut.prob = NULL) { #' count_motifs(g, 3) #' sample_motifs(g, 3) sample_motifs <- function( - graph, - size = 3, - cut.prob = rep(0, size), - sample.size = NULL, - sample = NULL) { + graph, + size = 3, + cut.prob = rep(0, size), + sample.size = NULL, + sample = NULL +) { ensure_igraph(graph) - if (!is.null(cut.prob)) cut.prob <- as.numeric(cut.prob) + if (!is.null(cut.prob)) { + cut.prob <- as.numeric(cut.prob) + } if (!is.null(cut.prob) && length(cut.prob) != size) { cli::cli_abort("{arg cut.prob} must be the same length as {.arg size}") @@ -250,8 +277,12 @@ sample_motifs <- function( on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_motifs_randesu_estimate, graph, as.numeric(size), - cut.prob, as.numeric(sample.size), sample + R_igraph_motifs_randesu_estimate, + graph, + as.numeric(size), + cut.prob, + as.numeric(sample.size), + sample ) } From 52da86f4b9ad160041b08f0f07a74697b53fa7bc Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:54:35 +0200 Subject: [PATCH 29/59] operators --- R/operators.R | 150 +++++++++++++++++++++++++++++++++++--------------- 1 file changed, 105 insertions(+), 45 deletions(-) diff --git a/R/operators.R b/R/operators.R index 667596f4751..42298800a74 100644 --- a/R/operators.R +++ b/R/operators.R @@ -8,7 +8,8 @@ #' @inheritParams intersection #' @keywords internal #' @export -graph.intersection <- function(...) { # nocov start +graph.intersection <- function(...) { + # nocov start lifecycle::deprecate_soft("2.0.0", "graph.intersection()", "intersection()") intersection(...) } # nocov end @@ -23,7 +24,8 @@ graph.intersection <- function(...) { # nocov start #' @inheritParams union.igraph #' @keywords internal #' @export -graph.union <- function(..., byname = "auto") { # nocov start +graph.union <- function(..., byname = "auto") { + # nocov start lifecycle::deprecate_soft("2.0.0", "graph.union()", "union.igraph()") union.igraph(byname = byname, ...) } # nocov end @@ -38,7 +40,8 @@ graph.union <- function(..., byname = "auto") { # nocov start #' @inheritParams difference #' @keywords internal #' @export -graph.difference <- function(...) { # nocov start +graph.difference <- function(...) { + # nocov start lifecycle::deprecate_soft("2.0.0", "graph.difference()", "difference()") difference(...) } # nocov end @@ -53,8 +56,13 @@ graph.difference <- function(...) { # nocov start #' @inheritParams disjoint_union #' @keywords internal #' @export -graph.disjoint.union <- function(...) { # nocov start - lifecycle::deprecate_soft("2.0.0", "graph.disjoint.union()", "disjoint_union()") +graph.disjoint.union <- function(...) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "graph.disjoint.union()", + "disjoint_union()" + ) disjoint_union(...) } # nocov end @@ -68,7 +76,8 @@ graph.disjoint.union <- function(...) { # nocov start #' @inheritParams compose #' @keywords internal #' @export -graph.compose <- function(g1, g2, byname = "auto") { # nocov start +graph.compose <- function(g1, g2, byname = "auto") { + # nocov start lifecycle::deprecate_soft("2.0.0", "graph.compose()", "compose()") compose(g1 = g1, g2 = g2, byname = byname) } # nocov end @@ -83,7 +92,8 @@ graph.compose <- function(g1, g2, byname = "auto") { # nocov start #' @inheritParams complementer #' @keywords internal #' @export -graph.complementer <- function(graph, loops = FALSE) { # nocov start +graph.complementer <- function(graph, loops = FALSE) { + # nocov start lifecycle::deprecate_soft("2.0.0", "graph.complementer()", "complementer()") complementer(graph = graph, loops = loops) } # nocov end @@ -108,15 +118,23 @@ graph.complementer <- function(graph, loops = FALSE) { # nocov start # ################################################################### -rename.attr.if.needed <- function(type, graphs, newsize = NULL, maps = NULL, - maps2 = NULL, ignore = character()) { - listfun <- switch(type, +rename.attr.if.needed <- function( + type, + graphs, + newsize = NULL, + maps = NULL, + maps2 = NULL, + ignore = character() +) { + listfun <- switch( + type, "g" = graph_attr_names, "v" = vertex_attr_names, "e" = edge_attr_names, stop("Internal igraph error") ) - getfun <- switch(type, + getfun <- switch( + type, "g" = graph_attr, "v" = vertex_attr, "e" = edge_attr, @@ -160,7 +178,6 @@ rename.attr.if.needed <- function(type, graphs, newsize = NULL, maps = NULL, } - #' Disjoint union of graphs #' #' The union of two or more graphs are created. The graphs are assumed to have @@ -203,9 +220,12 @@ rename.attr.if.needed <- function(type, graphs, newsize = NULL, maps = NULL, #' print_all(g1 %du% g2) #' @export disjoint_union <- function(...) { - graphs <- unlist(recursive = FALSE, lapply(list(...), function(l) { - if (is_igraph(l)) list(l) else l - })) + graphs <- unlist( + recursive = FALSE, + lapply(list(...), function(l) { + if (is_igraph(l)) list(l) else l + }) + ) lapply(graphs, ensure_igraph) on.exit(.Call(R_igraph_finalizer)) @@ -252,10 +272,16 @@ disjoint_union <- function(...) { attr[[exattr[a]]] <- vctrs::vec_c(attr[[exattr[a]]], ea[[exattr[a]]]) } for (a in seq_along(noattr)) { - attr[[noattr[a]]] <- vctrs::vec_c(attr[[noattr[a]]], vctrs::unspecified(ec[[i]])) + attr[[noattr[a]]] <- vctrs::vec_c( + attr[[noattr[a]]], + vctrs::unspecified(ec[[i]]) + ) } for (a in seq_along(newattr)) { - attr[[newattr[a]]] <- vctrs::vec_c(vctrs::unspecified(cumec[[i]]), ea[[newattr[a]]]) + attr[[newattr[a]]] <- vctrs::vec_c( + vctrs::unspecified(cumec[[i]]), + ea[[newattr[a]]] + ) } } edge.attributes(res) <- attr @@ -270,11 +296,18 @@ disjoint_union <- function(...) { disjoint_union(x, y) } -.igraph.graph.union.or.intersection <- function(call, ..., byname, - keep.all.vertices) { - graphs <- unlist(recursive = FALSE, lapply(list(...), function(l) { - if (is_igraph(l)) list(l) else l - })) +.igraph.graph.union.or.intersection <- function( + call, + ..., + byname, + keep.all.vertices +) { + graphs <- unlist( + recursive = FALSE, + lapply(list(...), function(l) { + if (is_igraph(l)) list(l) else l + }) + ) lapply(graphs, ensure_igraph) if (byname != "auto" && !is.logical(byname)) { cli::cli_abort("{.arg bynam} must be \"auto\", or \"logical\".") @@ -283,7 +316,9 @@ disjoint_union <- function(...) { if (byname == "auto") { byname <- all(sapply(graphs, is_named)) if (nonamed != 0 && nonamed != length(graphs)) { - cli::cli_warn("Some, but not all graphs are named, not using vertex names.") + cli::cli_warn( + "Some, but not all graphs are named, not using vertex names." + ) } } else if (byname && nonamed != length(graphs)) { cli::cli_abort("Some graphs are not named.") @@ -318,7 +353,9 @@ disjoint_union <- function(...) { ## We might need to rename all attributes graph.attributes(res) <- rename.attr.if.needed("g", newgraphs) - vertex.attributes(res) <- rename.attr.if.needed("v", newgraphs, + vertex.attributes(res) <- rename.attr.if.needed( + "v", + newgraphs, vcount(res), ignore = "name" ) @@ -326,7 +363,9 @@ disjoint_union <- function(...) { ## Edges are a bit more difficult, we need a mapping if (edgemaps) { - edge.attributes(res) <- rename.attr.if.needed("e", newgraphs, + edge.attributes(res) <- rename.attr.if.needed( + "e", + newgraphs, ecount(res), maps = maps ) @@ -355,13 +394,16 @@ disjoint_union <- function(...) { ## We might need to rename all attributes graph.attributes(res) <- rename.attr.if.needed("g", graphs) vertex.attributes(res) <- rename.attr.if.needed( - "v", graphs, + "v", + graphs, vcount(res) ) ## Edges are a bit more difficult, we need a mapping if (edgemaps) { - edge.attributes(res) <- rename.attr.if.needed("e", graphs, + edge.attributes(res) <- rename.attr.if.needed( + "e", + graphs, ecount(res), maps = maps ) @@ -445,7 +487,9 @@ union.default <- function(...) { #' net2 <- graph_from_literal(D - A:F:Y, B - A - X - F - H - Z, F - Y) #' print_all(net1 %u% net2) union.igraph <- function(..., byname = "auto") { - .igraph.graph.union.or.intersection("union", ..., + .igraph.graph.union.or.intersection( + "union", + ..., byname = byname, keep.all.vertices = TRUE ) @@ -525,9 +569,14 @@ intersection <- function(...) { #' ) #' net2 <- graph_from_literal(D - A:F:Y, B - A - X - F - H - Z, F - Y) #' print_all(net1 %s% net2) -intersection.igraph <- function(..., byname = "auto", - keep.all.vertices = TRUE) { - .igraph.graph.union.or.intersection("intersection", ..., +intersection.igraph <- function( + ..., + byname = "auto", + keep.all.vertices = TRUE +) { + .igraph.graph.union.or.intersection( + "intersection", + ..., byname = byname, keep.all.vertices = keep.all.vertices ) @@ -619,7 +668,9 @@ difference.igraph <- function(big, small, byname = "auto", ...) { if (byname == "auto") { byname <- nonamed == 2 if (nonamed == 1) { - cli::cli_warn("One, but not both graphs are named, not using vertex names.") + cli::cli_warn( + "One, but not both graphs are named, not using vertex names." + ) } } else if (byname && nonamed != 2) { cli::cli_abort("Some graphs are not named.") @@ -654,7 +705,6 @@ difference.igraph <- function(big, small, byname = "auto", ...) { } - #' Complementer of a graph #' #' A complementer graph contains all edges that were not present in the input @@ -695,7 +745,6 @@ complementer <- function(graph, loops = FALSE) { } - #' Compose two graphs as binary relations #' #' Relational composition of two graph. @@ -768,7 +817,9 @@ compose <- function(g1, g2, byname = "auto") { if (byname == "auto") { byname <- nonamed == 2 if (nonamed == 1) { - cli::cli_warn("One, but not both graphs are named, not using vertex names.") + cli::cli_warn( + "One, but not both graphs are named, not using vertex names." + ) } } else if (byname && nonamed != 2) { cli::cli_abort("Some graphs are not named.") @@ -808,13 +859,17 @@ compose <- function(g1, g2, byname = "auto") { V(res)$name <- uninames } else { vertex.attributes(res) <- rename.attr.if.needed( - "v", graphs, + "v", + graphs, vcount(res) ) } if (edgemaps) { - edge.attributes(res) <- rename.attr.if.needed("e", graphs, ecount(res), + edge.attributes(res) <- rename.attr.if.needed( + "e", + graphs, + ecount(res), maps2 = maps ) } @@ -1195,7 +1250,9 @@ path <- function(...) { } else if (is.numeric(e2) || is.character(e2)) { res <- delete_vertices(e1, e2) } else { - cli::cli_abort("Cannot substract {.obj_type_friendly type} from igraph graph.") + cli::cli_abort( + "Cannot substract {.obj_type_friendly type} from igraph graph." + ) } res } @@ -1220,14 +1277,15 @@ path <- function(...) { #' @examples #' rings <- make_ring(5) * 5 rep.igraph <- function(x, n, mark = TRUE, ...) { - if (n < 0) cli::cli_abort("Number of replications must be positive") + if (n < 0) { + cli::cli_abort("Number of replications must be positive") + } - res <- do_call(disjoint_union, - .args = - replicate(n, x, simplify = FALSE) - ) + res <- do_call(disjoint_union, .args = replicate(n, x, simplify = FALSE)) - if (mark) V(res)$which <- rep(seq_len(n), each = gorder(x)) + if (mark) { + V(res)$which <- rep(seq_len(n), each = gorder(x)) + } res } @@ -1245,7 +1303,9 @@ rep.igraph <- function(x, n, mark = TRUE, ...) { if (is.numeric(n) && length(n) == 1) { rep.igraph(x, n) } else { - cli::cli_abort("Cannot multiply igraph graph with {.obj_type_friendly type}.") + cli::cli_abort( + "Cannot multiply igraph graph with {.obj_type_friendly type}." + ) } } From 698193b267f497443462768f2307165792feb55d Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:54:47 +0200 Subject: [PATCH 30/59] other --- R/other.R | 31 ++++++++++++++++++++----------- 1 file changed, 20 insertions(+), 11 deletions(-) diff --git a/R/other.R b/R/other.R index b28c27419cb..c6a86b55e95 100644 --- a/R/other.R +++ b/R/other.R @@ -8,7 +8,8 @@ #' @inheritParams running_mean #' @keywords internal #' @export -running.mean <- function(v, binwidth) { # nocov start +running.mean <- function(v, binwidth) { + # nocov start lifecycle::deprecate_soft("2.0.0", "running.mean()", "running_mean()") running_mean(v = v, binwidth = binwidth) } # nocov end @@ -23,7 +24,8 @@ running.mean <- function(v, binwidth) { # nocov start #' @inheritParams sample_seq #' @keywords internal #' @export -igraph.sample <- function(low, high, length) { # nocov start +igraph.sample <- function(low, high, length) { + # nocov start lifecycle::deprecate_soft("2.0.0", "igraph.sample()", "sample_seq()") sample_seq(low = low, high = high, length = length) } # nocov end @@ -38,7 +40,8 @@ igraph.sample <- function(low, high, length) { # nocov start #' @inheritParams convex_hull #' @keywords internal #' @export -convex.hull <- function(data) { # nocov start +convex.hull <- function(data) { + # nocov start lifecycle::deprecate_soft("2.0.0", "convex.hull()", "convex_hull()") convex_hull(data = data) } # nocov end @@ -63,8 +66,6 @@ convex.hull <- function(data) { # nocov start # ################################################################### - - #' Running mean of a time series #' #' `running_mean()` calculates the running mean in a vector with the given @@ -99,7 +100,6 @@ running_mean <- function(v, binwidth) { } - #' Sampling a random integer sequence #' #' This function provides a very efficient way to pull an integer random sample @@ -132,7 +132,9 @@ sample_seq <- function(low, high, length) { on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_random_sample, as.numeric(low), as.numeric(high), + R_igraph_random_sample, + as.numeric(low), + as.numeric(high), as.numeric(length) ) } @@ -169,7 +171,9 @@ handle_vertex_type_arg <- function(types, graph, required = T) { } } if (is.null(types) && required) { - cli::cli_abort("Not a bipartite graph, supply {.arg types} argument or add a vertex attribute named {.arg type}.") + cli::cli_abort( + "Not a bipartite graph, supply {.arg types} argument or add a vertex attribute named {.arg type}." + ) } return(types) } @@ -178,9 +182,14 @@ igraph.i.spMatrix <- function(M) { if (M$type == "triplet") { Matrix::sparseMatrix(dims = M$dim, i = M$i + 1L, j = M$p + 1L, x = M$x) } else { - new("dgCMatrix", - Dim = M$dim, Dimnames = list(NULL, NULL), - factors = list(), i = M$i, p = M$p, x = M$x + new( + "dgCMatrix", + Dim = M$dim, + Dimnames = list(NULL, NULL), + factors = list(), + i = M$i, + p = M$p, + x = M$x ) } } From f80a3380e57a0f1ee5e7c3bffe79e75f07146a93 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:55:07 +0200 Subject: [PATCH 31/59] printr --- R/printr.R | 63 +++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 48 insertions(+), 15 deletions(-) diff --git a/R/printr.R b/R/printr.R index ba79cbd5a9d..15ba158d0b7 100644 --- a/R/printr.R +++ b/R/printr.R @@ -32,7 +32,9 @@ #' @export printer_callback <- function(fun) { - if (!is.function(fun)) warning("'fun' is not a function") + if (!is.function(fun)) { + warning("'fun' is not a function") + } add_class(fun, "printer_callback") } @@ -77,8 +79,14 @@ print_head_foot <- function(head_foot) { #' #' @export -head_print <- function(x, max_lines = 20, header = "", footer = "", - omitted_footer = "", ...) { +head_print <- function( + x, + max_lines = 20, + header = "", + footer = "", + omitted_footer = "", + ... +) { if (is_printer_callback(x)) { head_print_callback(x, max_lines, header, footer, omitted_footer, ...) } else { @@ -87,8 +95,15 @@ head_print <- function(x, max_lines = 20, header = "", footer = "", invisible(x) } -head_print_object <- function(x, max_lines, header, footer, omitted_footer, - print_fun = print, ...) { +head_print_object <- function( + x, + max_lines, + header, + footer, + omitted_footer, + print_fun = print, + ... +) { print_header(header) cout <- capture.output(print_fun(x, ...)) @@ -97,15 +112,23 @@ head_print_object <- function(x, max_lines, header, footer, omitted_footer, print_footer(footer) - if (cout_no < length(cout)) print_footer(omitted_footer) + if (cout_no < length(cout)) { + print_footer(omitted_footer) + } invisible(c(lines = length(cout), printed = cout_no)) } #' @importFrom utils tail -head_print_callback <- function(x, max_lines, header, footer, - omitted_footer, ...) { +head_print_callback <- function( + x, + max_lines, + header, + footer, + omitted_footer, + ... +) { ## Header print_header(header) @@ -127,24 +150,32 @@ head_print_callback <- function(x, max_lines, header, footer, ## So how many items should we print? no <- tail(which(no_rows <= max_lines), 1) - if (is.null(no) || length(no) < 1 || is.na(no)) no <- can_max + if (is.null(no) || length(no) < 1 || is.na(no)) { + no <- can_max + } cat_pern <- function(..., sep = "\n") cat(..., sep = sep) ## Format them, and print out_lines <- head_print_object( x("print", no = no, ...), - print_fun = cat_pern, max_lines = max_lines, - header = "", footer = "", omitted_footer = "" + print_fun = cat_pern, + max_lines = max_lines, + header = "", + footer = "", + omitted_footer = "" ) done_stat <- c( - tried_items = no, tried_lines = out_lines[["lines"]], + tried_items = no, + tried_lines = out_lines[["lines"]], printed_lines = out_lines[["printed"]] ) - if (done_stat["tried_items"] < len || - done_stat["printed_lines"] < done_stat["tried_lines"]) { + if ( + done_stat["tried_items"] < len || + done_stat["printed_lines"] < done_stat["tried_lines"] + ) { print_footer(omitted_footer) } @@ -164,7 +195,9 @@ head_print_callback <- function(x, max_lines, header, footer, #' @export indent_print <- function(..., .indent = " ", .printer = print) { - if (length(.indent) != 1) stop(".indent must be a scalar") + if (length(.indent) != 1) { + stop(".indent must be a scalar") + } opt <- options(width = getOption("width") - nchar(.indent)) on.exit(options(opt), add = TRUE) From d6ee979587d6b74248c08be4e423cef2316ca6ed Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:55:20 +0200 Subject: [PATCH 32/59] print --- R/print.R | 128 ++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 82 insertions(+), 46 deletions(-) diff --git a/R/print.R b/R/print.R index b13906446fe..25058f30828 100644 --- a/R/print.R +++ b/R/print.R @@ -30,7 +30,9 @@ gal <- graph_attr_names(object) if (length(gal) != 0) { ga <- paste( - sep = "", gal, " (g/", + sep = "", + gal, + " (g/", .Call(R_igraph_get_attr_mode, object, 2L), ")" ) @@ -38,7 +40,9 @@ val <- vertex_attr_names(object) if (length(val) != 0) { va <- paste( - sep = "", val, " (v/", + sep = "", + val, + " (v/", .Call(R_igraph_get_attr_mode, object, 3L), ")" ) @@ -46,7 +50,9 @@ eal <- edge_attr_names(object) if (length(eal) != 0) { ea <- paste( - sep = "", edge_attr_names(object), " (e/", + sep = "", + edge_attr_names(object), + " (e/", .Call(R_igraph_get_attr_mode, object, 4L), ")" ) @@ -72,14 +78,19 @@ ) w <- getOption("width") if (nchar(title) < w && "name" %in% graph_attr_names(object)) { - title <- substring(paste(sep = "", title, as.character(object$name)[1]), 1, w - 1) + title <- substring( + paste(sep = "", title, as.character(object$name)[1]), + 1, + w - 1 + ) } cat(title, "\n", sep = "") atxt <- .get.attr.codes(object) atxt <- paste(atxt[atxt != ""], collapse = ", ") if (atxt != "") { - atxt <- strwrap(paste(sep = "", "+ attr: ", atxt), + atxt <- strwrap( + paste(sep = "", "+ attr: ", atxt), prefix = "| ", initial = "" ) @@ -134,7 +145,9 @@ .print.vertex.attributes <- function(x, full, max.lines) { pf <- function(x) .print.vertex.attributes.old(x, full, max.lines) - if (length(vertex_attr_names(x))) cat("+ vertex attributes:\n") + if (length(vertex_attr_names(x))) { + cat("+ vertex attributes:\n") + } indent_print(x, .indent = "| ", .printer = pf) } @@ -151,12 +164,14 @@ omitted.vertices <- vc - mp ind <- seq(length.out = mp) } - if (vc == 0 || - all(sapply(list, function(v) { - is.numeric(vertex_attr(x, v)) || - is.character(vertex_attr(x, v)) || - is.logical(vertex_attr(x, v)) - }))) { + if ( + vc == 0 || + all(sapply(list, function(v) { + is.numeric(vertex_attr(x, v)) || + is.character(vertex_attr(x, v)) || + is.logical(vertex_attr(x, v)) + })) + ) { ## create a table tab <- data.frame(v = paste(sep = "", "[", ind, "]"), row.names = "v") for (i in list) { @@ -176,7 +191,8 @@ if (omitted.vertices != 0) { cat(paste( '[ reached getOption("max.print") -- omitted', - omitted.vertices, "vertices ]\n\n" + omitted.vertices, + "vertices ]\n\n" )) } } @@ -195,11 +211,16 @@ if (names && !"name" %in% vertex_attr_names(x)) { names <- FALSE } - if (names && "name" %in% vertex_attr_names(x) && - !is.numeric(vertex_attr(x, "name")) && - !is.character(vertex_attr(x, "name")) && - !is.logical(vertex_attr(x, "name"))) { - cli::cli_warn("Can't print vertex names, complex {.val name} vertex attribute.") + if ( + names && + "name" %in% vertex_attr_names(x) && + !is.numeric(vertex_attr(x, "name")) && + !is.character(vertex_attr(x, "name")) && + !is.logical(vertex_attr(x, "name")) + ) { + cli::cli_warn( + "Can't print vertex names, complex {.val name} vertex attribute." + ) names <- FALSE } @@ -219,12 +240,14 @@ } else { seq(length.out = nrow(el)) } - if (ec == 0 || - all(sapply(list, function(v) { - is.numeric(edge_attr(x, v)) | - is.character(edge_attr(x, v)) | - is.logical(edge_attr(x, v)) - }))) { + if ( + ec == 0 || + all(sapply(list, function(v) { + is.numeric(edge_attr(x, v)) | + is.character(edge_attr(x, v)) | + is.logical(edge_attr(x, v)) + })) + ) { ## create a table tab <- data.frame(row.names = paste(sep = "", "[", ename, "]")) if (is.numeric(el)) { @@ -233,8 +256,10 @@ w <- max(nchar(el)) } tab["edge"] <- paste( - sep = "", format(el[, 1], width = w), - arrow, format(el[, 2], width = w) + sep = "", + format(el[, 1], width = w), + arrow, + format(el[, 2], width = w) ) for (i in list) { tab[i] <- edge_attr(x, i) @@ -254,30 +279,36 @@ } if (omitted.edges != 0) { cat(paste( - '[ reached getOption("max.print") -- omitted', omitted.edges, + '[ reached getOption("max.print") -- omitted', + omitted.edges, "edges ]\n\n" )) } } -.print.edges.compressed <- function(x, - edges = E(x), - names, - num = FALSE, - max.lines = igraph_opt("auto.print.lines"), - id = igraph_opt("print.id")) { +.print.edges.compressed <- function( + x, + edges = E(x), + names, + num = FALSE, + max.lines = igraph_opt("auto.print.lines"), + id = igraph_opt("print.id") +) { len <- length(edges) gid <- graph_id(edges) title <- "+" %+% (if (num) { - " " %+% chr(len) %+% "/" %+% - (if (is.null(x)) "?" else chr(gsize(x))) + " " %+% chr(len) %+% "/" %+% (if (is.null(x)) "?" else chr(gsize(x))) } else { "" }) %+% (if (len == 1) " edge" else " edges") %+% - (if (isTRUE(id) && !is.na(gid)) paste(" from", substr(gid, 1, 7)) else "") %+% + (if (isTRUE(id) && !is.na(gid)) { + paste(" from", substr(gid, 1, 7)) + } else { + "" + }) %+% (if (is.null(x)) " (deleted)" else "") %+% (if (is.null(attr(edges, "vnames"))) "" else " (vertex names)") %+% ":\n" @@ -352,8 +383,10 @@ } else if (q == "max") { can_max <<- no } else if (q == "done") { - if (no["tried_items"] < length(edges) || - no["printed_lines"] < no["tried_lines"]) { + if ( + no["tried_items"] < length(edges) || + no["printed_lines"] < no["tried_lines"] + ) { cat("+ ... omitted several edges\n") } } @@ -434,7 +467,6 @@ print_all <- function(object, ...) { } - #' Print graphs to the terminal #' #' These functions attempt to print a graph to the terminal in a human readable @@ -515,13 +547,17 @@ print_all <- function(object, ...) { #' g #' summary(g) #' -print.igraph <- function(x, full = igraph_opt("print.full"), - graph.attributes = igraph_opt("print.graph.attributes"), - vertex.attributes = igraph_opt("print.vertex.attributes"), - edge.attributes = igraph_opt("print.edge.attributes"), - names = TRUE, max.lines = igraph_opt("auto.print.lines"), - id = igraph_opt("print.id"), - ...) { +print.igraph <- function( + x, + full = igraph_opt("print.full"), + graph.attributes = igraph_opt("print.graph.attributes"), + vertex.attributes = igraph_opt("print.vertex.attributes"), + edge.attributes = igraph_opt("print.edge.attributes"), + names = TRUE, + max.lines = igraph_opt("auto.print.lines"), + id = igraph_opt("print.id"), + ... +) { ensure_igraph(x) head_lines <- .print.header(x, id) From 9cc9eebfcf6004825b3498f66c6b6746e6d2c54b Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:55:46 +0200 Subject: [PATCH 33/59] plot.shapes --- R/plot.shapes.R | 405 +++++++++++++++++++++++++++++++++++------------- 1 file changed, 301 insertions(+), 104 deletions(-) diff --git a/R/plot.shapes.R b/R/plot.shapes.R index eded0f3d7af..b3a2322edf7 100644 --- a/R/plot.shapes.R +++ b/R/plot.shapes.R @@ -8,7 +8,8 @@ #' @inheritParams shape_noplot #' @keywords internal #' @export -igraph.shape.noplot <- function(coords, v = NULL, params) { # nocov start +igraph.shape.noplot <- function(coords, v = NULL, params) { + # nocov start lifecycle::deprecate_soft("2.0.0", "igraph.shape.noplot()", "shape_noplot()") shape_noplot(coords = coords, v = v, params = params) } # nocov end @@ -23,7 +24,13 @@ igraph.shape.noplot <- function(coords, v = NULL, params) { # nocov start #' @inheritParams shape_noclip #' @keywords internal #' @export -igraph.shape.noclip <- function(coords, el, params, end = c("both", "from", "to")) { # nocov start +igraph.shape.noclip <- function( + coords, + el, + params, + end = c("both", "from", "to") +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "igraph.shape.noclip()", "shape_noclip()") shape_noclip(coords = coords, el = el, params = params, end = end) } # nocov end @@ -38,7 +45,8 @@ igraph.shape.noclip <- function(coords, el, params, end = c("both", "from", "to" #' @inheritParams shapes #' @keywords internal #' @export -vertex.shapes <- function(shape = NULL) { # nocov start +vertex.shapes <- function(shape = NULL) { + # nocov start lifecycle::deprecate_soft("2.0.0", "vertex.shapes()", "shapes()") shapes(shape = shape) } # nocov end @@ -53,7 +61,13 @@ vertex.shapes <- function(shape = NULL) { # nocov start #' @inheritParams add_shape #' @keywords internal #' @export -add.vertex.shape <- function(shape, clip = shape_noclip, plot = shape_noplot, parameters = list()) { # nocov start +add.vertex.shape <- function( + shape, + clip = shape_noclip, + plot = shape_noplot, + parameters = list() +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "add.vertex.shape()", "add_shape()") add_shape(shape = shape, clip = clip, plot = plot, parameters = parameters) } # nocov end @@ -336,8 +350,7 @@ shapes <- function(shape = NULL) { #' @rdname shapes #' @export -shape_noclip <- function(coords, el, params, - end = c("both", "from", "to")) { +shape_noclip <- function(coords, el, params, end = c("both", "from", "to")) { end <- igraph.match.arg(end) if (end == "both") { @@ -357,9 +370,12 @@ shape_noplot <- function(coords, v = NULL, params) { #' @rdname shapes #' @export -add_shape <- function(shape, clip = shape_noclip, - plot = shape_noplot, - parameters = list()) { +add_shape <- function( + shape, + clip = shape_noclip, + plot = shape_noplot, + parameters = list() +) { if (!is.character(shape) || length(shape) != 1) { cli::cli_abort(c( "{.arg shape} must be a character of length 1.", @@ -381,8 +397,10 @@ add_shape <- function(shape, clip = shape_noclip, )) } - if (length(parameters) > 0 && ( - !inherits(parameters, "list") || !rlang::is_named(parameters))) { + if ( + length(parameters) > 0 && + (!inherits(parameters, "list") || !rlang::is_named(parameters)) + ) { cli::cli_abort(c( "{.arg parameters} must be a named list.", i = "See {.help add_shape} for details." @@ -396,8 +414,12 @@ add_shape <- function(shape, clip = shape_noclip, ## These are the predefined shapes -.igraph.shape.circle.clip <- function(coords, el, params, - end = c("both", "from", "to")) { +.igraph.shape.circle.clip <- function( + coords, + el, + params, + end = c("both", "from", "to") +) { end <- match.arg(end) if (length(coords) == 0) { @@ -479,24 +501,45 @@ add_shape <- function(shape, clip = shape_noclip, if (length(vertex.frame.width) == 1) { symbols( - x = coords[, 1], y = coords[, 2], bg = vertex.color, fg = vertex.frame.color, - circles = vertex.size, lwd = vertex.frame.width, add = TRUE, inches = FALSE + x = coords[, 1], + y = coords[, 2], + bg = vertex.color, + fg = vertex.frame.color, + circles = vertex.size, + lwd = vertex.frame.width, + add = TRUE, + inches = FALSE ) } else { - mapply(coords[, 1], coords[, 2], vertex.color, vertex.frame.color, - vertex.size, vertex.frame.width, + mapply( + coords[, 1], + coords[, 2], + vertex.color, + vertex.frame.color, + vertex.size, + vertex.frame.width, FUN = function(x, y, bg, fg, size, lwd) { symbols( - x = x, y = y, bg = bg, fg = fg, lwd = lwd, - circles = size, add = TRUE, inches = FALSE + x = x, + y = y, + bg = bg, + fg = fg, + lwd = lwd, + circles = size, + add = TRUE, + inches = FALSE ) } ) } } -.igraph.shape.square.clip <- function(coords, el, params, - end = c("both", "from", "to")) { +.igraph.shape.square.clip <- function( + coords, + el, + params, + end = c("both", "from", "to") +) { end <- match.arg(end) if (length(coords) == 0) { @@ -508,21 +551,33 @@ add_shape <- function(shape, clip = shape_noclip, square.shift <- function(x0, y0, x1, y1, vsize) { m <- (y0 - y1) / (x0 - x1) l <- cbind( - x1 - vsize / m, y1 - vsize, - x1 - vsize, y1 - vsize * m, - x1 + vsize / m, y1 + vsize, - x1 + vsize, y1 + vsize * m + x1 - vsize / m, + y1 - vsize, + x1 - vsize, + y1 - vsize * m, + x1 + vsize / m, + y1 + vsize, + x1 + vsize, + y1 + vsize * m ) v <- cbind( - x1 - vsize <= l[, 1] & l[, 1] <= x1 + vsize & - y1 - vsize <= l[, 2] & l[, 2] <= y1 + vsize, - x1 - vsize <= l[, 3] & l[, 3] <= x1 + vsize & - y1 - vsize <= l[, 4] & l[, 4] <= y1 + vsize, - x1 - vsize <= l[, 5] & l[, 5] <= x1 + vsize & - y1 - vsize <= l[, 6] & l[, 6] <= y1 + vsize, - x1 - vsize <= l[, 7] & l[, 7] <= x1 + vsize & - y1 - vsize <= l[, 8] & l[, 8] <= y1 + vsize + x1 - vsize <= l[, 1] & + l[, 1] <= x1 + vsize & + y1 - vsize <= l[, 2] & + l[, 2] <= y1 + vsize, + x1 - vsize <= l[, 3] & + l[, 3] <= x1 + vsize & + y1 - vsize <= l[, 4] & + l[, 4] <= y1 + vsize, + x1 - vsize <= l[, 5] & + l[, 5] <= x1 + vsize & + y1 - vsize <= l[, 6] & + l[, 6] <= y1 + vsize, + x1 - vsize <= l[, 7] & + l[, 7] <= x1 + vsize & + y1 - vsize <= l[, 8] & + l[, 8] <= y1 + vsize ) d <- cbind( @@ -546,7 +601,10 @@ add_shape <- function(shape, clip = shape_noclip, vertex.size[el[, 1]] } res <- res1 <- square.shift( - coords[, 3], coords[, 4], coords[, 1], coords[, 2], + coords[, 3], + coords[, 4], + coords[, 1], + coords[, 2], vsize ) } @@ -557,7 +615,10 @@ add_shape <- function(shape, clip = shape_noclip, vertex.size[el[, 2]] } res <- res2 <- square.shift( - coords[, 1], coords[, 2], coords[, 3], coords[, 4], + coords[, 1], + coords[, 2], + coords[, 3], + coords[, 4], vsize ) } @@ -595,24 +656,45 @@ add_shape <- function(shape, clip = shape_noclip, if (length(vertex.frame.width) == 1) { symbols( - x = coords[, 1], y = coords[, 2], bg = vertex.color, fg = vertex.frame.color, - squares = 2 * vertex.size, lwd = vertex.frame.width, add = TRUE, inches = FALSE + x = coords[, 1], + y = coords[, 2], + bg = vertex.color, + fg = vertex.frame.color, + squares = 2 * vertex.size, + lwd = vertex.frame.width, + add = TRUE, + inches = FALSE ) } else { - mapply(coords[, 1], coords[, 2], vertex.color, vertex.frame.color, - vertex.size, vertex.frame.width, + mapply( + coords[, 1], + coords[, 2], + vertex.color, + vertex.frame.color, + vertex.size, + vertex.frame.width, FUN = function(x, y, bg, fg, size, lwd) { symbols( - x = x, y = y, bg = bg, fg = fg, lwd = lwd, - squares = 2 * size, add = TRUE, inches = FALSE + x = x, + y = y, + bg = bg, + fg = fg, + lwd = lwd, + squares = 2 * size, + add = TRUE, + inches = FALSE ) } ) } } -.igraph.shape.csquare.clip <- function(coords, el, params, - end = c("both", "from", "to")) { +.igraph.shape.csquare.clip <- function( + coords, + el, + params, + end = c("both", "from", "to") +) { end <- match.arg(end) if (length(coords) == 0) { @@ -623,10 +705,14 @@ add_shape <- function(shape, clip = shape_noclip, square.shift <- function(x0, y0, x1, y1, vsize) { l <- cbind( - x1, y1 - vsize, - x1 - vsize, y1, - x1, y1 + vsize, - x1 + vsize, y1 + x1, + y1 - vsize, + x1 - vsize, + y1, + x1, + y1 + vsize, + x1 + vsize, + y1 ) d <- cbind( @@ -649,7 +735,10 @@ add_shape <- function(shape, clip = shape_noclip, vertex.size[el[, 1]] } res <- res1 <- square.shift( - coords[, 3], coords[, 4], coords[, 1], coords[, 2], + coords[, 3], + coords[, 4], + coords[, 1], + coords[, 2], vsize ) } @@ -660,7 +749,10 @@ add_shape <- function(shape, clip = shape_noclip, vertex.size[el[, 2]] } res <- res2 <- square.shift( - coords[, 1], coords[, 2], coords[, 3], coords[, 4], + coords[, 1], + coords[, 2], + coords[, 3], + coords[, 4], vsize ) } @@ -673,8 +765,12 @@ add_shape <- function(shape, clip = shape_noclip, .igraph.shape.csquare.plot <- .igraph.shape.square.plot -.igraph.shape.rectangle.clip <- function(coords, el, params, - end = c("both", "from", "to")) { +.igraph.shape.rectangle.clip <- function( + coords, + el, + params, + end = c("both", "from", "to") +) { end <- match.arg(end) if (length(coords) == 0) { @@ -687,21 +783,33 @@ add_shape <- function(shape, clip = shape_noclip, rec.shift <- function(x0, y0, x1, y1, vsize, vsize2) { m <- (y0 - y1) / (x0 - x1) l <- cbind( - x1 - vsize2 / m, y1 - vsize2, - x1 - vsize, y1 - vsize * m, - x1 + vsize2 / m, y1 + vsize2, - x1 + vsize, y1 + vsize * m + x1 - vsize2 / m, + y1 - vsize2, + x1 - vsize, + y1 - vsize * m, + x1 + vsize2 / m, + y1 + vsize2, + x1 + vsize, + y1 + vsize * m ) v <- cbind( - x1 - vsize <= l[, 1] & l[, 1] <= x1 + vsize & - y1 - vsize2 <= l[, 2] & l[, 2] <= y1 + vsize2, - x1 - vsize <= l[, 3] & l[, 3] <= x1 + vsize & - y1 - vsize2 <= l[, 4] & l[, 4] <= y1 + vsize2, - x1 - vsize <= l[, 5] & l[, 5] <= x1 + vsize & - y1 - vsize2 <= l[, 6] & l[, 6] <= y1 + vsize2, - x1 - vsize <= l[, 7] & l[, 7] <= x1 + vsize & - y1 - vsize2 <= l[, 8] & l[, 8] <= y1 + vsize2 + x1 - vsize <= l[, 1] & + l[, 1] <= x1 + vsize & + y1 - vsize2 <= l[, 2] & + l[, 2] <= y1 + vsize2, + x1 - vsize <= l[, 3] & + l[, 3] <= x1 + vsize & + y1 - vsize2 <= l[, 4] & + l[, 4] <= y1 + vsize2, + x1 - vsize <= l[, 5] & + l[, 5] <= x1 + vsize & + y1 - vsize2 <= l[, 6] & + l[, 6] <= y1 + vsize2, + x1 - vsize <= l[, 7] & + l[, 7] <= x1 + vsize & + y1 - vsize2 <= l[, 8] & + l[, 8] <= y1 + vsize2 ) d <- cbind( @@ -730,8 +838,12 @@ add_shape <- function(shape, clip = shape_noclip, vertex.size2[el[, 1]] } res <- res1 <- rec.shift( - coords[, 3], coords[, 4], coords[, 1], coords[, 2], - vsize, vsize2 + coords[, 3], + coords[, 4], + coords[, 1], + coords[, 2], + vsize, + vsize2 ) } if (end %in% c("to", "both")) { @@ -746,8 +858,12 @@ add_shape <- function(shape, clip = shape_noclip, vertex.size2[el[, 2]] } res <- res2 <- rec.shift( - coords[, 1], coords[, 2], coords[, 3], coords[, 4], - vsize, vsize2 + coords[, 1], + coords[, 2], + coords[, 3], + coords[, 4], + vsize, + vsize2 ) } if (end == "both") { @@ -789,24 +905,46 @@ add_shape <- function(shape, clip = shape_noclip, if (length(vertex.frame.width) == 1) { symbols( - x = coords[, 1], y = coords[, 2], bg = vertex.color, fg = vertex.frame.color, - rectangles = 2 * vertex.size, lwd = vertex.frame.width, add = TRUE, inches = FALSE + x = coords[, 1], + y = coords[, 2], + bg = vertex.color, + fg = vertex.frame.color, + rectangles = 2 * vertex.size, + lwd = vertex.frame.width, + add = TRUE, + inches = FALSE ) } else { - mapply(coords[, 1], coords[, 2], vertex.color, vertex.frame.color, - vertex.size[, 1], vertex.size[, 2], vertex.frame.width, + mapply( + coords[, 1], + coords[, 2], + vertex.color, + vertex.frame.color, + vertex.size[, 1], + vertex.size[, 2], + vertex.frame.width, FUN = function(x, y, bg, fg, size, size2, lwd) { symbols( - x = x, y = y, bg = bg, fg = fg, lwd = lwd, - rectangles = 2 * cbind(size, size2), add = TRUE, inches = FALSE + x = x, + y = y, + bg = bg, + fg = fg, + lwd = lwd, + rectangles = 2 * cbind(size, size2), + add = TRUE, + inches = FALSE ) } ) } } -.igraph.shape.crectangle.clip <- function(coords, el, params, - end = c("both", "from", "to")) { +.igraph.shape.crectangle.clip <- function( + coords, + el, + params, + end = c("both", "from", "to") +) { end <- match.arg(end) if (length(coords) == 0) { @@ -818,10 +956,14 @@ add_shape <- function(shape, clip = shape_noclip, rec.shift <- function(x0, y0, x1, y1, vsize, vsize2) { l <- cbind( - x1, y1 - vsize2, - x1 - vsize, y1, - x1, y1 + vsize2, - x1 + vsize, y1 + x1, + y1 - vsize2, + x1 - vsize, + y1, + x1, + y1 + vsize2, + x1 + vsize, + y1 ) d <- cbind( @@ -849,8 +991,12 @@ add_shape <- function(shape, clip = shape_noclip, vertex.size2[el[, 1]] } res <- res1 <- rec.shift( - coords[, 3], coords[, 4], coords[, 1], coords[, 2], - vsize, vsize2 + coords[, 3], + coords[, 4], + coords[, 1], + coords[, 2], + vsize, + vsize2 ) } if (end %in% c("to", "both")) { @@ -865,8 +1011,12 @@ add_shape <- function(shape, clip = shape_noclip, vertex.size2[el[, 2]] } res <- res2 <- rec.shift( - coords[, 1], coords[, 2], coords[, 3], coords[, 4], - vsize, vsize2 + coords[, 1], + coords[, 2], + coords[, 3], + coords[, 4], + vsize, + vsize2 ) } if (end == "both") { @@ -878,8 +1028,12 @@ add_shape <- function(shape, clip = shape_noclip, .igraph.shape.crectangle.plot <- .igraph.shape.rectangle.plot -.igraph.shape.vrectangle.clip <- function(coords, el, params, - end = c("both", "from", "to")) { +.igraph.shape.vrectangle.clip <- function( + coords, + el, + params, + end = c("both", "from", "to") +) { end <- match.arg(end) if (length(coords) == 0) { @@ -915,8 +1069,12 @@ add_shape <- function(shape, clip = shape_noclip, vertex.size2[el[, 1]] } res <- res1 <- rec.shift( - coords[, 3], coords[, 4], coords[, 1], coords[, 2], - vsize, vsize2 + coords[, 3], + coords[, 4], + coords[, 1], + coords[, 2], + vsize, + vsize2 ) } if (end %in% c("to", "both")) { @@ -931,8 +1089,12 @@ add_shape <- function(shape, clip = shape_noclip, vertex.size2[el[, 2]] } res <- res2 <- rec.shift( - coords[, 1], coords[, 2], coords[, 3], coords[, 4], - vsize, vsize2 + coords[, 1], + coords[, 2], + coords[, 3], + coords[, 4], + vsize, + vsize2 ) } if (end == "both") { @@ -952,8 +1114,20 @@ add_shape <- function(shape, clip = shape_noclip, } #' @importFrom graphics par polygon -mypie <- function(x, y, values, radius, edges = 200, col = NULL, angle = 45, - density = NULL, border = NULL, lty = NULL, init.angle = 90, ...) { +mypie <- function( + x, + y, + values, + radius, + edges = 200, + col = NULL, + angle = 45, + density = NULL, + border = NULL, + lty = NULL, + init.angle = 90, + ... +) { values <- c(0, cumsum(values) / sum(values)) dx <- diff(values) nx <- length(dx) @@ -961,8 +1135,12 @@ mypie <- function(x, y, values, radius, edges = 200, col = NULL, angle = 45, if (is.null(col)) { col <- if (is.null(density)) { c( - "white", "lightblue", "mistyrose", "lightcyan", - "lavender", "cornsilk" + "white", + "lightblue", + "mistyrose", + "lightcyan", + "lavender", + "cornsilk" ) } else { par("fg") @@ -980,15 +1158,25 @@ mypie <- function(x, y, values, radius, edges = 200, col = NULL, angle = 45, for (i in 1:nx) { n <- max(2, floor(edges * dx[i])) P <- t2xy(seq.int(values[i], values[i + 1], length.out = n)) - polygon(x + c(P$x, 0), y + c(P$y, 0), - density = density[i], angle = angle[i], - border = border[i], col = col[i], lty = lty[i], ... + polygon( + x + c(P$x, 0), + y + c(P$y, 0), + density = density[i], + angle = angle[i], + border = border[i], + col = col[i], + lty = lty[i], + ... ) } } -.igraph.shape.pie.clip <- function(coords, el, params, - end = c("both", "from", "to")) { +.igraph.shape.pie.clip <- function( + coords, + el, + params, + end = c("both", "from", "to") +) { end <- match.arg(end) if (length(coords) == 0) { @@ -1074,8 +1262,12 @@ mypie <- function(x, y, values, radius, edges = 200, col = NULL, angle = 45, vertex.pie.color[[i]] } mypie( - x = coords[i, 1], y = coords[i, 2], pie, - radius = vertex.size[i], edges = 200, col = col, + x = coords[i, 1], + y = coords[i, 2], + pie, + radius = vertex.size[i], + edges = 200, + col = col, angle = na.omit(vertex.pie.angle[c(i, 1)])[1], density = na.omit(vertex.pie.density[c(i, 1)])[1], border = na.omit(vertex.frame.color[c(i, 1)])[1], @@ -1120,8 +1312,10 @@ mypie <- function(x, y, values, radius, edges = 200, col = NULL, angle = 45, vsp2 <- vertex.size[i] rasterImage( images[[whichImage[i]]], - coords[i, 1] - vsp2, coords[i, 2] - vsp2, - coords[i, 1] + vsp2, coords[i, 2] + vsp2 + coords[i, 1] - vsp2, + coords[i, 2] - vsp2, + coords[i, 1] + vsp2, + coords[i, 2] + vsp2 ) } } @@ -1145,8 +1339,11 @@ mypie <- function(x, y, values, radius, edges = 200, col = NULL, angle = 45, for (i in seq_len(nrow(coords))) { ras <- if (!is.list(raster) || length(raster) == 1) raster else raster[[i]] rasterImage( - ras, coords[i, 1] - size[i], coords[i, 2] - size2[i], - coords[i, 1] + size[i], coords[i, 2] + size2[i] + ras, + coords[i, 1] - size[i], + coords[i, 2] - size2[i], + coords[i, 1] + size[i], + coords[i, 2] + size2[i] ) } } From fc065e5ab59754764eb0ef5983181a0c724e71c8 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:56:01 +0200 Subject: [PATCH 34/59] plot --- R/plot.R | 1493 ++++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 1273 insertions(+), 220 deletions(-) diff --git a/R/plot.R b/R/plot.R index dc077b86c38..d3cb1c23192 100644 --- a/R/plot.R +++ b/R/plot.R @@ -19,8 +19,6 @@ # ################################################################### - - #' Plotting of graphs #' #' `plot.igraph()` is able to plot graphs to any R device. It is the @@ -82,15 +80,21 @@ #' g <- make_ring(10) #' plot(g, layout = layout_with_kk, vertex.color = "green") #' -plot.igraph <- function(x, - # SPECIFIC: ##################################### - axes = FALSE, add = FALSE, - xlim = c(-1, 1), ylim = c(-1, 1), - mark.groups = list(), mark.shape = 1 / 2, - mark.col = rainbow(length(mark.groups), alpha = 0.3), - mark.border = rainbow(length(mark.groups), alpha = 1), - mark.expand = 15, loop.size = 1, - ...) { +plot.igraph <- function( + x, + # SPECIFIC: ##################################### + axes = FALSE, + add = FALSE, + xlim = c(-1, 1), + ylim = c(-1, 1), + mark.groups = list(), + mark.shape = 1 / 2, + mark.col = rainbow(length(mark.groups), alpha = 0.3), + mark.border = rainbow(length(mark.groups), alpha = 1), + mark.expand = 15, + loop.size = 1, + ... +) { graph <- x ensure_igraph(graph) @@ -158,14 +162,29 @@ plot.igraph <- function(x, fact <- (1 - vertex.size.scaling) maxv <- 1 / 200 * max(vertex.size) - xlim <- c(xlim[1] - margin[2] - fact * maxv, xlim[2] + margin[4] + fact * maxv) - ylim <- c(ylim[1] - margin[1] - fact * maxv, ylim[2] + margin[3] + fact * maxv) + xlim <- c( + xlim[1] - margin[2] - fact * maxv, + xlim[2] + margin[4] + fact * maxv + ) + ylim <- c( + ylim[1] - margin[1] - fact * maxv, + ylim[2] + margin[3] + fact * maxv + ) } if (!add) { - plot(0, 0, - type = "n", xlab = xlab, ylab = ylab, xlim = xlim, ylim = ylim, - axes = axes, frame.plot = ifelse(is.null(frame.plot), axes, frame.plot), - asp = asp, main = main, sub = sub + plot( + 0, + 0, + type = "n", + xlab = xlab, + ylab = ylab, + xlim = xlim, + ylim = ylim, + axes = axes, + frame.plot = ifelse(is.null(frame.plot), axes, frame.plot), + asp = asp, + main = main, + sub = sub ) } @@ -175,9 +194,9 @@ plot.igraph <- function(x, newdots <- list(...) # vertex.size - vertex.size <- i.rescale.vertex(vertex.size, - minmax.relative.size = - params("vertex", "relative.size") + vertex.size <- i.rescale.vertex( + vertex.size, + minmax.relative.size = params("vertex", "relative.size") ) newdots$vertex.size <- vertex.size @@ -187,17 +206,20 @@ plot.igraph <- function(x, scalefactor <- parusr <- par("usr") scalefactor <- (parusr[2] - parusr[1]) / (parusr[4] - parusr[3]) - if ("vertex.size2" %in% names(newdots)) { # If the user provided -vertex.size2- + if ("vertex.size2" %in% names(newdots)) { + # If the user provided -vertex.size2- - scalefactor <- scalefactor * ( - max(params("vertex", "size2"), na.rm = TRUE) / max(params("vertex", "size"), na.rm = TRUE)) + scalefactor <- scalefactor * + (max(params("vertex", "size2"), na.rm = TRUE) / + max(params("vertex", "size"), na.rm = TRUE)) newdots$vertex.size2 <- i.rescale.vertex( params("vertex", "size2"), parusr[3:4] * scalefactor, params("vertex", "relative.size") ) - } else { # Otherwise use -vertex.size- + } else { + # Otherwise use -vertex.size- newdots$vertex.size2 <- i.rescale.vertex( params("vertex", "size"), parusr[3:4] * scalefactor, @@ -209,7 +231,10 @@ plot.igraph <- function(x, } else { params <- i.parse.plot.params( graph, - list(vertex.size = 1 / 200 * vertex.size, vertex.size2 = 1 / 200 * params("vertex", "size2")) + list( + vertex.size = 1 / 200 * vertex.size, + vertex.size2 = 1 / 200 * params("vertex", "size2") + ) ) vertex.size <- 1 / 200 * vertex.size } @@ -235,7 +260,8 @@ plot.igraph <- function(x, } else { vs <- rep(vertex.size, length.out = vcount(graph))[v] } - igraph.polygon(layout[v, , drop = FALSE], + igraph.polygon( + layout[v, , drop = FALSE], vertex.size = vs, expand.by = mark.expand[g] / 200, shape = mark.shape[g], @@ -273,23 +299,30 @@ plot.igraph <- function(x, edge.coords[, 4] <- layout[, 2][el[, 2]] if (length(unique(shape)) == 1) { ## same vertex shape for all vertices - ec <- .igraph.shapes[[shape[1]]]$clip(edge.coords, el, - params = params, end = "both" + ec <- .igraph.shapes[[shape[1]]]$clip( + edge.coords, + el, + params = params, + end = "both" ) } else { ## different vertex shapes, do it by "endpoint" shape <- rep(shape, length.out = vcount(graph)) ec <- edge.coords ec[, 1:2] <- t(sapply(seq(length.out = nrow(el)), function(x) { - .igraph.shapes[[shape[el[x, 1]]]]$clip(edge.coords[x, , drop = FALSE], + .igraph.shapes[[shape[el[x, 1]]]]$clip( + edge.coords[x, , drop = FALSE], el[x, , drop = FALSE], - params = params, end = "from" + params = params, + end = "from" ) })) ec[, 3:4] <- t(sapply(seq(length.out = nrow(el)), function(x) { - .igraph.shapes[[shape[el[x, 2]]]]$clip(edge.coords[x, , drop = FALSE], + .igraph.shapes[[shape[el[x, 2]]]]$clip( + edge.coords[x, , drop = FALSE], el[x, , drop = FALSE], - params = params, end = "to" + params = params, + end = "to" ) })) } @@ -323,35 +356,88 @@ plot.igraph <- function(x, sapply(dt, function(t) point.on.cubic.bezier(cp, t)) } - plot.bezier <- function(cp, points, color, width, arr, lty, arrow.size, arr.w) { + plot.bezier <- function( + cp, + points, + color, + width, + arr, + lty, + arrow.size, + arr.w + ) { p <- compute.bezier(cp, points) polygon(p[1, ], p[2, ], border = color, lwd = width, lty = lty) if (arr == 1 || arr == 3) { - igraph.Arrows(p[1, ncol(p) - 1], p[2, ncol(p) - 1], p[1, ncol(p)], p[2, ncol(p)], - sh.col = color, h.col = color, size = arrow.size, - sh.lwd = width, h.lwd = width, open = FALSE, code = 2, width = arr.w + igraph.Arrows( + p[1, ncol(p) - 1], + p[2, ncol(p) - 1], + p[1, ncol(p)], + p[2, ncol(p)], + sh.col = color, + h.col = color, + size = arrow.size, + sh.lwd = width, + h.lwd = width, + open = FALSE, + code = 2, + width = arr.w ) } if (arr == 2 || arr == 3) { - igraph.Arrows(p[1, 2], p[2, 2], p[1, 1], p[2, 1], - sh.col = color, h.col = color, size = arrow.size, - sh.lwd = width, h.lwd = width, open = FALSE, code = 2, width = arr.w + igraph.Arrows( + p[1, 2], + p[2, 2], + p[1, 1], + p[2, 1], + sh.col = color, + h.col = color, + size = arrow.size, + sh.lwd = width, + h.lwd = width, + open = FALSE, + code = 2, + width = arr.w ) } } - loop <- function(x0, y0, cx = x0, cy = y0, color, angle = 0, label = NA, label.color, - label.font, label.family, label.cex, - width = 1, arr = 2, lty = 1, arrow.size = arrow.size, - arr.w = arr.w, lab.x, lab.y, loopSize = loop.size) { + loop <- function( + x0, + y0, + cx = x0, + cy = y0, + color, + angle = 0, + label = NA, + label.color, + label.font, + label.family, + label.cex, + width = 1, + arr = 2, + lty = 1, + arrow.size = arrow.size, + arr.w = arr.w, + lab.x, + lab.y, + loopSize = loop.size + ) { rad <- angle center <- c(cx, cy) cp <- matrix( c( - x0, y0, x0 + .4 * loopSize, y0 + .2 * loopSize, - x0 + .4 * loopSize, y0 - .2 * loopSize, x0, y0 + x0, + y0, + x0 + .4 * loopSize, + y0 + .2 * loopSize, + x0 + .4 * loopSize, + y0 - .2 * loopSize, + x0, + y0 ), - ncol = 2, byrow = TRUE + ncol = 2, + byrow = TRUE ) phi <- atan2(cp[, 2] - center[2], cp[, 1] - center[1]) r <- sqrt((cp[, 1] - center[1])**2 + (cp[, 2] - center[2])**2) @@ -365,7 +451,16 @@ plot.igraph <- function(x, width <- 1 } - plot.bezier(cp, 50, color, width, arr = arr, lty = lty, arrow.size = arrow.size, arr.w = arr.w) + plot.bezier( + cp, + 50, + color, + width, + arr = arr, + lty = lty, + arrow.size = arrow.size, + arr.w = arr.w + ) if (is.language(label) || !is.na(label)) { lx <- x0 + .3 @@ -385,9 +480,14 @@ plot.igraph <- function(x, ly <- lab.y } - text(lx, ly, label, - col = label.color, font = label.font, - family = label.family, cex = label.cex + text( + lx, + ly, + label, + col = label.color, + font = label.font, + family = label.family, + cex = label.cex ) } } @@ -439,11 +539,24 @@ plot.igraph <- function(x, xx0 <- layout[loops.v, 1] + cos(la) * vs yy0 <- layout[loops.v, 2] - sin(la) * vs - mapply(loop, xx0, yy0, - color = ec, angle = -la, label = loop.labels, - label.color = lcol, label.family = lfam, label.font = lfon, label.cex = lcex, lty = lty, - width = ew, arr = arr, arrow.size = asize, arr.w = arrow.width, - lab.x = loop.labx, lab.y = loop.laby + mapply( + loop, + xx0, + yy0, + color = ec, + angle = -la, + label = loop.labels, + label.color = lcol, + label.family = lfam, + label.font = lfon, + label.cex = lcex, + lty = lty, + width = ew, + arr = arr, + arrow.size = asize, + arr.w = arrow.width, + lab.x = loop.labx, + lab.y = loop.laby ) } @@ -469,11 +582,22 @@ plot.igraph <- function(x, curved <- curved[nonloops.e] } if (length(unique(arrow.mode)) == 1) { - lc <- igraph.Arrows(x0, y0, x1, y1, - h.col = edge.color, sh.col = edge.color, - sh.lwd = edge.width, h.lwd = 1, open = FALSE, code = arrow.mode[1], - sh.lty = edge.lty, h.lty = 1, size = arrow.size, - width = arrow.width, curved = curved + lc <- igraph.Arrows( + x0, + y0, + x1, + y1, + h.col = edge.color, + sh.col = edge.color, + sh.lwd = edge.width, + h.lwd = 1, + open = FALSE, + code = arrow.mode[1], + sh.lty = edge.lty, + h.lty = 1, + size = arrow.size, + width = arrow.width, + curved = curved ) lc.x <- lc$lab.x lc.y <- lc$lab.y @@ -499,10 +623,22 @@ plot.igraph <- function(x, if (length(el) > 1) { el <- el[valid] } - lc <- igraph.Arrows(x0[valid], y0[valid], x1[valid], y1[valid], - code = code, sh.col = ec, h.col = ec, sh.lwd = ew, h.lwd = 1, - h.lty = 1, sh.lty = el, open = FALSE, size = arrow.size, - width = arrow.width, curved = curved[valid] + lc <- igraph.Arrows( + x0[valid], + y0[valid], + x1[valid], + y1[valid], + code = code, + sh.col = ec, + h.col = ec, + sh.lwd = ew, + h.lwd = 1, + h.lty = 1, + sh.lty = el, + open = FALSE, + size = arrow.size, + width = arrow.width, + curved = curved[valid] ) lc.x[valid] <- lc$lab.x lc.y[valid] <- lc$lab.y @@ -532,9 +668,14 @@ plot.igraph <- function(x, ecex <- ecex[nonloops.e] } - text(lc.x, lc.y, - labels = edge.labels, col = ecol, - family = efam, font = efon, cex = ecex + text( + lc.x, + lc.y, + labels = edge.labels, + col = ecol, + family = efam, + font = efon, + cex = ecex ) } @@ -547,7 +688,8 @@ plot.igraph <- function(x, .igraph.shapes[[shape[1]]]$plot(layout, params = params) } else { sapply(seq(length.out = vcount(graph)), function(x) { - .igraph.shapes[[shape[x]]]$plot(layout[x, , drop = FALSE], + .igraph.shapes[[shape[x]]]$plot( + layout[x, , drop = FALSE], v = x, params = params ) @@ -559,22 +701,31 @@ plot.igraph <- function(x, # add the labels old_xpd <- par(xpd = TRUE) on.exit(par(old_xpd), add = TRUE) - x <- layout[, 1] + label.dist * cos(-label.degree) * - (vertex.size + 6 * 8 * log10(2)) / 200 - y <- layout[, 2] + label.dist * sin(-label.degree) * - (vertex.size + 6 * 8 * log10(2)) / 200 + x <- layout[, 1] + + label.dist * cos(-label.degree) * (vertex.size + 6 * 8 * log10(2)) / 200 + y <- layout[, 2] + + label.dist * sin(-label.degree) * (vertex.size + 6 * 8 * log10(2)) / 200 if (vc > 0) { if (length(label.family) == 1) { - text(x, y, - labels = labels, col = label.color, family = label.family, - font = label.font, cex = label.cex + text( + x, + y, + labels = labels, + col = label.color, + family = label.family, + font = label.font, + cex = label.cex ) } else { if1 <- function(vect, idx) if (length(vect) == 1) vect else vect[idx] sapply(seq_len(vcount(graph)), function(v) { - text(x[v], y[v], - labels = if1(labels, v), col = if1(label.color, v), - family = if1(label.family, v), font = if1(label.font, v), + text( + x[v], + y[v], + labels = if1(labels, v), + col = if1(label.color, v), + family = if1(label.family, v), + font = if1(label.font, v), cex = if1(label.cex, v) ) }) @@ -585,7 +736,6 @@ plot.igraph <- function(x, } - #' 3D plotting of graphs with OpenGL #' #' Using the `rgl` package, `rglplot()` plots a graph in 3D. The plot @@ -637,73 +787,431 @@ rglplot.igraph <- function(x, ...) { if (am == 0) { edge <- rgl::qmesh3d( c( - -ew / 2, -ew / 2, dist, 1, ew / 2, -ew / 2, dist, 1, ew / 2, ew / 2, dist, 1, - -ew / 2, ew / 2, dist, 1, -ew / 2, -ew / 2, 0, 1, ew / 2, -ew / 2, 0, 1, - ew / 2, ew / 2, 0, 1, -ew / 2, ew / 2, 0, 1 + -ew / 2, + -ew / 2, + dist, + 1, + ew / 2, + -ew / 2, + dist, + 1, + ew / 2, + ew / 2, + dist, + 1, + -ew / 2, + ew / 2, + dist, + 1, + -ew / 2, + -ew / 2, + 0, + 1, + ew / 2, + -ew / 2, + 0, + 1, + ew / 2, + ew / 2, + 0, + 1, + -ew / 2, + ew / 2, + 0, + 1 ), - c(1, 2, 3, 4, 5, 6, 7, 8, 1, 2, 6, 5, 2, 3, 7, 6, 3, 4, 8, 7, 4, 1, 5, 8) + c( + 1, + 2, + 3, + 4, + 5, + 6, + 7, + 8, + 1, + 2, + 6, + 5, + 2, + 3, + 7, + 6, + 3, + 4, + 8, + 7, + 4, + 1, + 5, + 8 + ) ) } else if (am == 1) { edge <- rgl::qmesh3d( c( - -ew / 2, -ew / 2, dist, 1, ew / 2, -ew / 2, dist, 1, - ew / 2, ew / 2, dist, 1, -ew / 2, ew / 2, dist, 1, - -ew / 2, -ew / 2, al + r1, 1, ew / 2, -ew / 2, al + r1, 1, - ew / 2, ew / 2, al + r1, 1, -ew / 2, ew / 2, al + r1, 1, - -aw / 2, -aw / 2, al + r1, 1, aw / 2, -aw / 2, al + r1, 1, - aw / 2, aw / 2, al + r1, 1, -aw / 2, aw / 2, al + r1, 1, 0, 0, r1, 1 + -ew / 2, + -ew / 2, + dist, + 1, + ew / 2, + -ew / 2, + dist, + 1, + ew / 2, + ew / 2, + dist, + 1, + -ew / 2, + ew / 2, + dist, + 1, + -ew / 2, + -ew / 2, + al + r1, + 1, + ew / 2, + -ew / 2, + al + r1, + 1, + ew / 2, + ew / 2, + al + r1, + 1, + -ew / 2, + ew / 2, + al + r1, + 1, + -aw / 2, + -aw / 2, + al + r1, + 1, + aw / 2, + -aw / 2, + al + r1, + 1, + aw / 2, + aw / 2, + al + r1, + 1, + -aw / 2, + aw / 2, + al + r1, + 1, + 0, + 0, + r1, + 1 ), c( - 1, 2, 3, 4, 5, 6, 7, 8, 1, 2, 6, 5, 2, 3, 7, 6, 3, 4, 8, 7, 4, 1, 5, 8, - 9, 10, 11, 12, 9, 12, 13, 13, 9, 10, 13, 13, 10, 11, 13, 13, - 11, 12, 13, 13 + 1, + 2, + 3, + 4, + 5, + 6, + 7, + 8, + 1, + 2, + 6, + 5, + 2, + 3, + 7, + 6, + 3, + 4, + 8, + 7, + 4, + 1, + 5, + 8, + 9, + 10, + 11, + 12, + 9, + 12, + 13, + 13, + 9, + 10, + 13, + 13, + 10, + 11, + 13, + 13, + 11, + 12, + 13, + 13 ) ) } else if (am == 2) { box <- dist - r2 - al edge <- rgl::qmesh3d( c( - -ew / 2, -ew / 2, box, 1, ew / 2, -ew / 2, box, 1, ew / 2, ew / 2, box, 1, - -ew / 2, ew / 2, box, 1, -ew / 2, -ew / 2, 0, 1, ew / 2, -ew / 2, 0, 1, - ew / 2, ew / 2, 0, 1, -ew / 2, ew / 2, 0, 1, - -aw / 2, -aw / 2, box, 1, aw / 2, -aw / 2, box, 1, aw / 2, aw / 2, box, 1, - -aw / 2, aw / 2, box, 1, 0, 0, box + al, 1 + -ew / 2, + -ew / 2, + box, + 1, + ew / 2, + -ew / 2, + box, + 1, + ew / 2, + ew / 2, + box, + 1, + -ew / 2, + ew / 2, + box, + 1, + -ew / 2, + -ew / 2, + 0, + 1, + ew / 2, + -ew / 2, + 0, + 1, + ew / 2, + ew / 2, + 0, + 1, + -ew / 2, + ew / 2, + 0, + 1, + -aw / 2, + -aw / 2, + box, + 1, + aw / 2, + -aw / 2, + box, + 1, + aw / 2, + aw / 2, + box, + 1, + -aw / 2, + aw / 2, + box, + 1, + 0, + 0, + box + al, + 1 ), c( - 1, 2, 3, 4, 5, 6, 7, 8, 1, 2, 6, 5, 2, 3, 7, 6, 3, 4, 8, 7, 4, 1, 5, 8, - 9, 10, 11, 12, 9, 12, 13, 13, 9, 10, 13, 13, 10, 11, 13, 13, - 11, 12, 13, 13 + 1, + 2, + 3, + 4, + 5, + 6, + 7, + 8, + 1, + 2, + 6, + 5, + 2, + 3, + 7, + 6, + 3, + 4, + 8, + 7, + 4, + 1, + 5, + 8, + 9, + 10, + 11, + 12, + 9, + 12, + 13, + 13, + 9, + 10, + 13, + 13, + 10, + 11, + 13, + 13, + 11, + 12, + 13, + 13 ) ) } else { edge <- rgl::qmesh3d( c( - -ew / 2, -ew / 2, dist - al - r2, 1, ew / 2, -ew / 2, dist - al - r2, 1, - ew / 2, ew / 2, dist - al - r2, 1, -ew / 2, ew / 2, dist - al - r2, 1, - -ew / 2, -ew / 2, r1 + al, 1, ew / 2, -ew / 2, r1 + al, 1, - ew / 2, ew / 2, r1 + al, 1, -ew / 2, ew / 2, r1 + al, 1, - -aw / 2, -aw / 2, dist - al - r2, 1, aw / 2, -aw / 2, dist - al - r2, 1, - aw / 2, aw / 2, dist - al - r2, 1, -aw / 2, aw / 2, dist - al - r2, 1, - -aw / 2, -aw / 2, r1 + al, 1, aw / 2, -aw / 2, r1 + al, 1, - aw / 2, aw / 2, r1 + al, 1, -aw / 2, aw / 2, r1 + al, 1, - 0, 0, dist - r2, 1, 0, 0, r1, 1 + -ew / 2, + -ew / 2, + dist - al - r2, + 1, + ew / 2, + -ew / 2, + dist - al - r2, + 1, + ew / 2, + ew / 2, + dist - al - r2, + 1, + -ew / 2, + ew / 2, + dist - al - r2, + 1, + -ew / 2, + -ew / 2, + r1 + al, + 1, + ew / 2, + -ew / 2, + r1 + al, + 1, + ew / 2, + ew / 2, + r1 + al, + 1, + -ew / 2, + ew / 2, + r1 + al, + 1, + -aw / 2, + -aw / 2, + dist - al - r2, + 1, + aw / 2, + -aw / 2, + dist - al - r2, + 1, + aw / 2, + aw / 2, + dist - al - r2, + 1, + -aw / 2, + aw / 2, + dist - al - r2, + 1, + -aw / 2, + -aw / 2, + r1 + al, + 1, + aw / 2, + -aw / 2, + r1 + al, + 1, + aw / 2, + aw / 2, + r1 + al, + 1, + -aw / 2, + aw / 2, + r1 + al, + 1, + 0, + 0, + dist - r2, + 1, + 0, + 0, + r1, + 1 ), c( - 1, 2, 3, 4, 5, 6, 7, 8, 1, 2, 6, 5, 2, 3, 7, 6, 3, 4, 8, 7, 4, 1, 5, 8, - 9, 10, 11, 12, 9, 12, 17, 17, 9, 10, 17, 17, 10, 11, 17, 17, - 11, 12, 17, 17, - 13, 14, 15, 16, 13, 16, 18, 18, 13, 14, 18, 18, 14, 15, 18, 18, - 15, 16, 18, 18 + 1, + 2, + 3, + 4, + 5, + 6, + 7, + 8, + 1, + 2, + 6, + 5, + 2, + 3, + 7, + 6, + 3, + 4, + 8, + 7, + 4, + 1, + 5, + 8, + 9, + 10, + 11, + 12, + 9, + 12, + 17, + 17, + 9, + 10, + 17, + 17, + 10, + 11, + 17, + 17, + 11, + 12, + 17, + 17, + 13, + 14, + 15, + 16, + 13, + 16, + 18, + 18, + 13, + 14, + 18, + 18, + 14, + 15, + 18, + 18, + 15, + 16, + 18, + 18 ) ) } - ## rotate and shift it to its position phi <- -atan2(v2[2] - v1[2], v1[1] - v2[1]) - pi / 2 psi <- acos((v2[3] - v1[3]) / dist) - rot1 <- rbind(c(1, 0, 0), c(0, cos(psi), sin(psi)), c(0, -sin(psi), cos(psi))) - rot2 <- rbind(c(cos(phi), sin(phi), 0), c(-sin(phi), cos(phi), 0), c(0, 0, 1)) + rot1 <- rbind( + c(1, 0, 0), + c(0, cos(psi), sin(psi)), + c(0, -sin(psi), cos(psi)) + ) + rot2 <- rbind( + c(cos(phi), sin(phi), 0), + c(-sin(phi), cos(phi), 0), + c(0, 0, 1) + ) rot <- rot1 %*% rot2 edge <- rgl::transform3d(edge, rgl::rotationMatrix(matrix = rot)) edge <- rgl::transform3d(edge, rgl::translationMatrix(v1[1], v1[2], v1[3])) @@ -723,92 +1231,588 @@ rglplot.igraph <- function(x, ...) { if (am == 0) { edge <- rgl::qmesh3d( c( - -wi / 2, -ew / 2, 0, 1, -gap / 2, -ew / 2, 0, 1, - -gap / 2, ew / 2, 0, 1, -wi / 2, ew / 2, 0, 1, - -wi / 2, -ew / 2, hi - ew + r, 1, -gap / 2, -ew / 2, hi - ew + r, 1, - -gap / 2, ew / 2, hi - ew + r, 1, -wi / 2, ew / 2, hi - ew + r, 1, - wi / 2, -ew / 2, 0, 1, gap / 2, -ew / 2, 0, 1, - gap / 2, ew / 2, 0, 1, wi / 2, ew / 2, 0, 1, - wi / 2, -ew / 2, hi - ew + r, 1, gap / 2, -ew / 2, hi - ew + r, 1, - gap / 2, ew / 2, hi - ew + r, 1, wi / 2, ew / 2, hi - ew + r, 1, - -wi / 2, -ew / 2, hi + r, 1, -wi / 2, ew / 2, hi + r, 1, - wi / 2, -ew / 2, hi + r, 1, wi / 2, ew / 2, hi + r, 1 + -wi / 2, + -ew / 2, + 0, + 1, + -gap / 2, + -ew / 2, + 0, + 1, + -gap / 2, + ew / 2, + 0, + 1, + -wi / 2, + ew / 2, + 0, + 1, + -wi / 2, + -ew / 2, + hi - ew + r, + 1, + -gap / 2, + -ew / 2, + hi - ew + r, + 1, + -gap / 2, + ew / 2, + hi - ew + r, + 1, + -wi / 2, + ew / 2, + hi - ew + r, + 1, + wi / 2, + -ew / 2, + 0, + 1, + gap / 2, + -ew / 2, + 0, + 1, + gap / 2, + ew / 2, + 0, + 1, + wi / 2, + ew / 2, + 0, + 1, + wi / 2, + -ew / 2, + hi - ew + r, + 1, + gap / 2, + -ew / 2, + hi - ew + r, + 1, + gap / 2, + ew / 2, + hi - ew + r, + 1, + wi / 2, + ew / 2, + hi - ew + r, + 1, + -wi / 2, + -ew / 2, + hi + r, + 1, + -wi / 2, + ew / 2, + hi + r, + 1, + wi / 2, + -ew / 2, + hi + r, + 1, + wi / 2, + ew / 2, + hi + r, + 1 ), c( - 1, 2, 3, 4, 5, 6, 7, 8, 1, 2, 6, 5, 2, 3, 7, 6, 3, 4, 8, 7, - 1, 4, 18, 17, - 9, 10, 11, 12, 13, 14, 15, 16, 9, 10, 14, 13, 10, 11, 15, 14, - 11, 12, 16, 15, 9, 12, 20, 19, - 5, 13, 19, 17, 17, 18, 20, 19, 8, 16, 20, 18, 6, 7, 15, 14 + 1, + 2, + 3, + 4, + 5, + 6, + 7, + 8, + 1, + 2, + 6, + 5, + 2, + 3, + 7, + 6, + 3, + 4, + 8, + 7, + 1, + 4, + 18, + 17, + 9, + 10, + 11, + 12, + 13, + 14, + 15, + 16, + 9, + 10, + 14, + 13, + 10, + 11, + 15, + 14, + 11, + 12, + 16, + 15, + 9, + 12, + 20, + 19, + 5, + 13, + 19, + 17, + 17, + 18, + 20, + 19, + 8, + 16, + 20, + 18, + 6, + 7, + 15, + 14 ) ) } else if (am == 1 || am == 2) { edge <- rgl::qmesh3d( c( - -wi / 2, -ew / 2, r + al, 1, -gap / 2, -ew / 2, r + al, 1, - -gap / 2, ew / 2, r + al, 1, -wi / 2, ew / 2, r + al, 1, - -wi / 2, -ew / 2, hi - ew + r, 1, -gap / 2, -ew / 2, hi - ew + r, 1, - -gap / 2, ew / 2, hi - ew + r, 1, -wi / 2, ew / 2, hi - ew + r, 1, - wi / 2, -ew / 2, 0, 1, gap / 2, -ew / 2, 0, 1, - gap / 2, ew / 2, 0, 1, wi / 2, ew / 2, 0, 1, - wi / 2, -ew / 2, hi - ew + r, 1, gap / 2, -ew / 2, hi - ew + r, 1, - gap / 2, ew / 2, hi - ew + r, 1, wi / 2, ew / 2, hi - ew + r, 1, - -wi / 2, -ew / 2, hi + r, 1, -wi / 2, ew / 2, hi + r, 1, - wi / 2, -ew / 2, hi + r, 1, wi / 2, ew / 2, hi + r, 1, + -wi / 2, + -ew / 2, + r + al, + 1, + -gap / 2, + -ew / 2, + r + al, + 1, + -gap / 2, + ew / 2, + r + al, + 1, + -wi / 2, + ew / 2, + r + al, + 1, + -wi / 2, + -ew / 2, + hi - ew + r, + 1, + -gap / 2, + -ew / 2, + hi - ew + r, + 1, + -gap / 2, + ew / 2, + hi - ew + r, + 1, + -wi / 2, + ew / 2, + hi - ew + r, + 1, + wi / 2, + -ew / 2, + 0, + 1, + gap / 2, + -ew / 2, + 0, + 1, + gap / 2, + ew / 2, + 0, + 1, + wi / 2, + ew / 2, + 0, + 1, + wi / 2, + -ew / 2, + hi - ew + r, + 1, + gap / 2, + -ew / 2, + hi - ew + r, + 1, + gap / 2, + ew / 2, + hi - ew + r, + 1, + wi / 2, + ew / 2, + hi - ew + r, + 1, + -wi / 2, + -ew / 2, + hi + r, + 1, + -wi / 2, + ew / 2, + hi + r, + 1, + wi / 2, + -ew / 2, + hi + r, + 1, + wi / 2, + ew / 2, + hi + r, + 1, # the arrow - -wi2 / 2, -aw / 2, r + al, 1, -wi2 / 2 + aw, -aw / 2, r + al, 1, - -wi2 / 2 + aw, aw / 2, r + al, 1, -wi2 / 2, aw / 2, r + al, 1, - -wi2 / 2 + aw / 2, 0, r, 1 + -wi2 / 2, + -aw / 2, + r + al, + 1, + -wi2 / 2 + aw, + -aw / 2, + r + al, + 1, + -wi2 / 2 + aw, + aw / 2, + r + al, + 1, + -wi2 / 2, + aw / 2, + r + al, + 1, + -wi2 / 2 + aw / 2, + 0, + r, + 1 ), c( - 1, 2, 3, 4, 5, 6, 7, 8, 1, 2, 6, 5, 2, 3, 7, 6, 3, 4, 8, 7, - 1, 4, 18, 17, - 9, 10, 11, 12, 13, 14, 15, 16, 9, 10, 14, 13, 10, 11, 15, 14, - 11, 12, 16, 15, 9, 12, 20, 19, - 5, 13, 19, 17, 17, 18, 20, 19, 8, 16, 20, 18, 6, 7, 15, 14, + 1, + 2, + 3, + 4, + 5, + 6, + 7, + 8, + 1, + 2, + 6, + 5, + 2, + 3, + 7, + 6, + 3, + 4, + 8, + 7, + 1, + 4, + 18, + 17, + 9, + 10, + 11, + 12, + 13, + 14, + 15, + 16, + 9, + 10, + 14, + 13, + 10, + 11, + 15, + 14, + 11, + 12, + 16, + 15, + 9, + 12, + 20, + 19, + 5, + 13, + 19, + 17, + 17, + 18, + 20, + 19, + 8, + 16, + 20, + 18, + 6, + 7, + 15, + 14, # the arrow - 21, 22, 23, 24, 21, 22, 25, 25, 22, 23, 25, 25, 23, 24, 25, 25, - 21, 24, 25, 25 + 21, + 22, + 23, + 24, + 21, + 22, + 25, + 25, + 22, + 23, + 25, + 25, + 23, + 24, + 25, + 25, + 21, + 24, + 25, + 25 ) ) } else if (am == 3) { edge <- rgl::qmesh3d( c( - -wi / 2, -ew / 2, r + al, 1, -gap / 2, -ew / 2, r + al, 1, - -gap / 2, ew / 2, r + al, 1, -wi / 2, ew / 2, r + al, 1, - -wi / 2, -ew / 2, hi - ew + r, 1, -gap / 2, -ew / 2, hi - ew + r, 1, - -gap / 2, ew / 2, hi - ew + r, 1, -wi / 2, ew / 2, hi - ew + r, 1, - wi / 2, -ew / 2, r + al, 1, gap / 2, -ew / 2, r + al, 1, - gap / 2, ew / 2, r + al, 1, wi / 2, ew / 2, r + al, 1, - wi / 2, -ew / 2, hi - ew + r, 1, gap / 2, -ew / 2, hi - ew + r, 1, - gap / 2, ew / 2, hi - ew + r, 1, wi / 2, ew / 2, hi - ew + r, 1, - -wi / 2, -ew / 2, hi + r, 1, -wi / 2, ew / 2, hi + r, 1, - wi / 2, -ew / 2, hi + r, 1, wi / 2, ew / 2, hi + r, 1, + -wi / 2, + -ew / 2, + r + al, + 1, + -gap / 2, + -ew / 2, + r + al, + 1, + -gap / 2, + ew / 2, + r + al, + 1, + -wi / 2, + ew / 2, + r + al, + 1, + -wi / 2, + -ew / 2, + hi - ew + r, + 1, + -gap / 2, + -ew / 2, + hi - ew + r, + 1, + -gap / 2, + ew / 2, + hi - ew + r, + 1, + -wi / 2, + ew / 2, + hi - ew + r, + 1, + wi / 2, + -ew / 2, + r + al, + 1, + gap / 2, + -ew / 2, + r + al, + 1, + gap / 2, + ew / 2, + r + al, + 1, + wi / 2, + ew / 2, + r + al, + 1, + wi / 2, + -ew / 2, + hi - ew + r, + 1, + gap / 2, + -ew / 2, + hi - ew + r, + 1, + gap / 2, + ew / 2, + hi - ew + r, + 1, + wi / 2, + ew / 2, + hi - ew + r, + 1, + -wi / 2, + -ew / 2, + hi + r, + 1, + -wi / 2, + ew / 2, + hi + r, + 1, + wi / 2, + -ew / 2, + hi + r, + 1, + wi / 2, + ew / 2, + hi + r, + 1, # the arrows - -wi2 / 2, -aw / 2, r + al, 1, -wi2 / 2 + aw, -aw / 2, r + al, 1, - -wi2 / 2 + aw, aw / 2, r + al, 1, -wi2 / 2, aw / 2, r + al, 1, - -wi2 / 2 + aw / 2, 0, r, 1, - wi2 / 2, -aw / 2, r + al, 1, wi2 / 2 - aw, -aw / 2, r + al, 1, - wi2 / 2 - aw, aw / 2, r + al, 1, wi2 / 2, aw / 2, r + al, 1, - wi2 / 2 - aw / 2, 0, r, 1 + -wi2 / 2, + -aw / 2, + r + al, + 1, + -wi2 / 2 + aw, + -aw / 2, + r + al, + 1, + -wi2 / 2 + aw, + aw / 2, + r + al, + 1, + -wi2 / 2, + aw / 2, + r + al, + 1, + -wi2 / 2 + aw / 2, + 0, + r, + 1, + wi2 / 2, + -aw / 2, + r + al, + 1, + wi2 / 2 - aw, + -aw / 2, + r + al, + 1, + wi2 / 2 - aw, + aw / 2, + r + al, + 1, + wi2 / 2, + aw / 2, + r + al, + 1, + wi2 / 2 - aw / 2, + 0, + r, + 1 ), c( - 1, 2, 3, 4, 5, 6, 7, 8, 1, 2, 6, 5, 2, 3, 7, 6, 3, 4, 8, 7, - 1, 4, 18, 17, - 9, 10, 11, 12, 13, 14, 15, 16, 9, 10, 14, 13, 10, 11, 15, 14, - 11, 12, 16, 15, 9, 12, 20, 19, - 5, 13, 19, 17, 17, 18, 20, 19, 8, 16, 20, 18, 6, 7, 15, 14, + 1, + 2, + 3, + 4, + 5, + 6, + 7, + 8, + 1, + 2, + 6, + 5, + 2, + 3, + 7, + 6, + 3, + 4, + 8, + 7, + 1, + 4, + 18, + 17, + 9, + 10, + 11, + 12, + 13, + 14, + 15, + 16, + 9, + 10, + 14, + 13, + 10, + 11, + 15, + 14, + 11, + 12, + 16, + 15, + 9, + 12, + 20, + 19, + 5, + 13, + 19, + 17, + 17, + 18, + 20, + 19, + 8, + 16, + 20, + 18, + 6, + 7, + 15, + 14, # the arrows - 21, 22, 23, 24, 21, 22, 25, 25, 22, 23, 25, 25, 23, 24, 25, 25, - 21, 24, 25, 25, - 26, 27, 28, 29, 26, 27, 30, 30, 27, 28, 30, 30, 28, 29, 30, 30, - 26, 29, 30, 30 + 21, + 22, + 23, + 24, + 21, + 22, + 25, + 25, + 22, + 23, + 25, + 25, + 23, + 24, + 25, + 25, + 21, + 24, + 25, + 25, + 26, + 27, + 28, + 29, + 26, + 27, + 30, + 30, + 27, + 28, + 30, + 30, + 28, + 29, + 30, + 30, + 26, + 29, + 30, + 30 ) ) } # rotate and shift to its position - rot1 <- rbind(c(1, 0, 0), c(0, cos(la2), sin(la2)), c(0, -sin(la2), cos(la2))) + rot1 <- rbind( + c(1, 0, 0), + c(0, cos(la2), sin(la2)), + c(0, -sin(la2), cos(la2)) + ) rot2 <- rbind(c(cos(la), sin(la), 0), c(-sin(la), cos(la), 0), c(0, 0, 1)) rot <- rot1 %*% rot2 edge <- rgl::transform3d(edge, rgl::rotationMatrix(matrix = rot)) @@ -833,7 +1837,8 @@ rglplot.igraph <- function(x, ...) { # Rescaling vertex size if (vertex.size.scaling) { vertex.size <- i.rescale.vertex( - vertex.size, rgl::par3d("scale")[1:2] * c(-1, 1), + vertex.size, + rgl::par3d("scale")[1:2] * c(-1, 1), params("vertex", "relative.size") ) } else { @@ -915,17 +1920,20 @@ rglplot.igraph <- function(x, ...) { if (length(vertex.size) == 1) { vertex.size <- rep(vertex.size, nrow(layout)) } - rgl::spheres3d(layout[, 1], layout[, 2], layout[, 3], + rgl::spheres3d( + layout[, 1], + layout[, 2], + layout[, 3], radius = vertex.size, col = vertex.color ) # add the labels labels[is.na(labels)] <- "" - x <- layout[, 1] + label.dist * cos(-label.degree) * - (vertex.size + 6 * 10 * log10(2)) / 200 - y <- layout[, 2] + label.dist * sin(-label.degree) * - (vertex.size + 6 * 10 * log10(2)) / 200 + x <- layout[, 1] + + label.dist * cos(-label.degree) * (vertex.size + 6 * 10 * log10(2)) / 200 + y <- layout[, 2] + + label.dist * sin(-label.degree) * (vertex.size + 6 * 10 * log10(2)) / 200 z <- layout[, 3] rgl::text3d(x, y, z, labels, col = label.color, adj = 0) @@ -937,7 +1945,11 @@ rglplot.igraph <- function(x, ...) { y1 <- layout[, 2][el[, 2]] z0 <- layout[, 3][el[, 1]] z1 <- layout[, 3][el[, 2]] - rgl::text3d((x0 + x1) / 2, (y0 + y1) / 2, (z0 + z1) / 2, edge.labels, + rgl::text3d( + (x0 + x1) / 2, + (y0 + y1) / 2, + (z0 + z1) / 2, + edge.labels, col = label.color ) } @@ -953,23 +1965,27 @@ rglplot.igraph <- function(x, ...) { #' @importFrom graphics par xyinch segments xspline lines polygon igraph.Arrows <- - function(x1, y1, x2, y2, - code = 2, - size = 1, - width = 1.2 / 4 / cin, - open = TRUE, - sh.adj = 0.1, - sh.lwd = 1, - sh.col = par("fg"), - sh.lty = 1, - h.col = sh.col, - h.col.bo = sh.col, - h.lwd = sh.lwd, - h.lty = sh.lty, - curved = FALSE) - ## Author: Andreas Ruckstuhl, refined by Rene Locher - ## Version: 2005-10-17 - { + function( + x1, + y1, + x2, + y2, + code = 2, + size = 1, + width = 1.2 / 4 / cin, + open = TRUE, + sh.adj = 0.1, + sh.lwd = 1, + sh.col = par("fg"), + sh.lty = 1, + h.col = sh.col, + h.col.bo = sh.col, + h.lwd = sh.lwd, + h.lty = sh.lty, + curved = FALSE + ) { + ## Author: Andreas Ruckstuhl, refined by Rene Locher + ## Version: 2005-10-17 cin <- size * par("cin")[2] width <- width * (1.2 / 4 / cin) uin <- 1 / xyinch() @@ -1003,9 +2019,18 @@ igraph.Arrows <- x1d <- r.seg * cos(th.seg1) / uin[1] y1d <- r.seg * sin(th.seg1) / uin[2] } - if (is.logical(curved) && all(!curved) || - is.numeric(curved) && all(!curved)) { - segments(x1 + x1d, y1 + y1d, x2 + x2d, y2 + y2d, lwd = sh.lwd, col = sh.col, lty = sh.lty) + if ( + is.logical(curved) && all(!curved) || is.numeric(curved) && all(!curved) + ) { + segments( + x1 + x1d, + y1 + y1d, + x2 + x2d, + y2 + y2d, + lwd = sh.lwd, + col = sh.col, + lty = sh.lty + ) phi <- atan2(y1 - y2, x1 - x2) r <- sqrt((x1 - x2)^2 + (y1 - y2)^2) lc.x <- x2 + 2 / 3 * r * cos(phi) @@ -1034,8 +2059,14 @@ igraph.Arrows <- for (i in seq_len(length(c.x1))) { ## Straight line? if (lambda[i] == 0) { - segments(c.x1[i], c.y1[i], c.x2[i], c.y2[i], - lwd = sh.lwd[i], col = sh.col[i], lty = sh.lty[i] + segments( + c.x1[i], + c.y1[i], + c.x2[i], + c.y2[i], + lwd = sh.lwd[i], + col = sh.col[i], + lty = sh.lty[i] ) phi <- atan2(y1[i] - y2[i], x1[i] - x2[i]) r <- sqrt((x1[i] - x2[i])^2 + (y1[i] - y2[i])^2) @@ -1044,7 +2075,9 @@ igraph.Arrows <- } else { spl <- xspline( x = c(c.x1[i], spx[i], c.x2[i]), - y = c(c.y1[i], spy[i], c.y2[i]), shape = 1, draw = FALSE + y = c(c.y1[i], spy[i], c.y2[i]), + shape = 1, + draw = FALSE ) lines(spl, lwd = sh.lwd[i], col = sh.col[i], lty = sh.lty[i]) if (code %in% c(2, 3)) { @@ -1070,14 +2103,21 @@ igraph.Arrows <- ttheta <- rep(theta, Rep) + rep(deg.arr, lx) r.arr.rep <- rep(r.arr, lx) if (open) { - lines((p.x2 + r.arr.rep * cos(ttheta) / uin[1]), + lines( + (p.x2 + r.arr.rep * cos(ttheta) / uin[1]), (p.y2 + r.arr.rep * sin(ttheta) / uin[2]), - lwd = h.lwd, col = h.col.bo, lty = h.lty + lwd = h.lwd, + col = h.col.bo, + lty = h.lty ) } else { - polygon(p.x2 + r.arr.rep * cos(ttheta) / uin[1], p.y2 + r.arr * sin(ttheta) / uin[2], - col = h.col, lwd = h.lwd, - border = h.col.bo, lty = h.lty + polygon( + p.x2 + r.arr.rep * cos(ttheta) / uin[1], + p.y2 + r.arr * sin(ttheta) / uin[2], + col = h.col, + lwd = h.lwd, + border = h.col.bo, + lty = h.lty ) } } @@ -1101,14 +2141,21 @@ igraph.Arrows <- r.arr.rep <- rep(r.arr, lx) if (open) { - lines((p.x2 + r.arr.rep * cos(ttheta) / uin[1]), + lines( + (p.x2 + r.arr.rep * cos(ttheta) / uin[1]), (p.y2 + r.arr.rep * sin(ttheta) / uin[2]), - lwd = h.lwd, col = h.col.bo, lty = h.lty + lwd = h.lwd, + col = h.col.bo, + lty = h.lty ) } else { - polygon(p.x2 + r.arr.rep * cos(ttheta) / uin[1], p.y2 + r.arr.rep * sin(ttheta) / uin[2], - col = h.col, lwd = h.lwd, - border = h.col.bo, lty = h.lty + polygon( + p.x2 + r.arr.rep * cos(ttheta) / uin[1], + p.y2 + r.arr.rep * sin(ttheta) / uin[2], + col = h.col, + lwd = h.lwd, + border = h.col.bo, + lty = h.lty ) } } @@ -1117,8 +2164,14 @@ igraph.Arrows <- } # Arrows #' @importFrom graphics xspline -igraph.polygon <- function(points, vertex.size = 15 / 200, expand.by = 15 / 200, - shape = 1 / 2, col = "#ff000033", border = NA) { +igraph.polygon <- function( + points, + vertex.size = 15 / 200, + expand.by = 15 / 200, + shape = 1 / 2, + col = "#ff000033", + border = NA +) { by <- expand.by pp <- rbind( points, From 71d0801ea8ba1c8bf4a8fc11ebc4e844fb2bc960 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:56:18 +0200 Subject: [PATCH 35/59] plot.common --- R/plot.common.R | 4844 ++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 4133 insertions(+), 711 deletions(-) diff --git a/R/plot.common.R b/R/plot.common.R index 96240c87094..06a3327b9b9 100644 --- a/R/plot.common.R +++ b/R/plot.common.R @@ -504,7 +504,8 @@ NULL #' @inheritParams curve_multiple #' @keywords internal #' @export -autocurve.edges <- function(graph, start = 0.5) { # nocov start +autocurve.edges <- function(graph, start = 0.5) { + # nocov start lifecycle::deprecate_soft("2.0.0", "autocurve.edges()", "curve_multiple()") curve_multiple(graph = graph, start = start) } # nocov end @@ -594,9 +595,13 @@ i.parse.plot.params <- function(graph, params) { if (!is.function(p[[type]][[name]])) { if (any(is.na(p[[type]][[name]]))) { if (name != "label") { - cli::cli_warn("{type} attribute {name} contains NAs. Replacing with default value {i.default.values[[type]][[name]] - }") - p[[type]][[name]][is.na(p[[type]][[name]])] <- i.default.values[[type]][[name]] + cli::cli_warn( + "{type} attribute {name} contains NAs. Replacing with default value {i.default.values[[type]][[name]] + }" + ) + p[[type]][[name]][is.na(p[[type]][[name]])] <- i.default.values[[ + type + ]][[name]] } else { p[[type]][[name]][is.na(p[[type]][[name]])] <- "" } @@ -628,8 +633,11 @@ i.get.labels <- function(graph, labels = NULL) { } i.get.arrow.mode <- function(graph, arrow.mode = NULL) { - if (is.character(arrow.mode) && - length(arrow.mode) == 1 && substr(arrow.mode, 1, 2) == "a:") { + if ( + is.character(arrow.mode) && + length(arrow.mode) == 1 && + substr(arrow.mode, 1, 2) == "a:" + ) { arrow.mode <- vertex_attr(graph, substring(arrow.mode, 3)) } @@ -637,15 +645,7 @@ i.get.arrow.mode <- function(graph, arrow.mode = NULL) { arrow.mode <- map_dbl( arrow.mode, function(x) { - switch(x, - "<" = 1, - "<-" = 1, - ">" = 2, - "->" = 2, - "<>" = 3, - "<->" = 3, - 0 - ) + switch(x, "<" = 1, "<-" = 1, ">" = 2, "->" = 2, "<>" = 3, "<->" = 3, 0) } ) } @@ -746,696 +746,4109 @@ curve_multiple <- function(graph, start = 0.5) { } .igraph.logo.raster <- - structure(c( - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 311332508L, - 1217499541L, 1804702102L, 1066570390L, 211129749L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 379033495L, 1334940052L, -2104389227L, - -1450012011L, -2087546218L, 1368494484L, 412456341L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 41975936L, 1905496981L, - -141388906L, -7171435L, -7171435L, -7171435L, -325938283L, 1452380564L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 41975936L, 1905496981L, -158166379L, -7171435L, -7171435L, -7171435L, - -7171435L, -7171435L, -141389163L, 1972540052L, 41975936L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, -2037148780L, -7171435L, -24798561L, -12009013L, - -13250855L, -11616826L, -24340838L, -7171435L, 1586664085L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 311332508L, -963472747L, -7171435L, - -7171435L, -7171435L, -7171435L, -7236971L, -7171435L, -7171435L, - -7171435L, -7171435L, -946695531L, 361927314L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 798134930L, - -40791403L, -25321308L, -16061704L, -16715521L, -16715521L, -16715521L, - -15408144L, -24471653L, -258829418L, 344755353L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, -1483500650L, -7171435L, -7171435L, -7824996L, -12858668L, - -15212050L, -16519427L, -15212050L, -12858668L, -7890531L, -7171435L, - -7171435L, -1382903147L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 2056426132L, -7171435L, -13643043L, - -16715521L, -16715521L, -16715521L, -16715521L, -16715521L, -12139572L, - -7171435L, 1385337493L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 1452380564L, -7171435L, - -7171435L, -8936279L, -15800587L, -16715521L, -16715521L, -16715521L, - -16715521L, -16715521L, -15865867L, -9132373L, -7171435L, -7171435L, - 1485934996L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, -1433234795L, -7171435L, -15603981L, -16715521L, -16715521L, - -16715521L, -16715521L, -16715521L, -14100510L, -7171435L, -2104389227L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, -812412011L, -7171435L, -7432808L, -15080979L, - -16715521L, -16715521L, -16715521L, -16715521L, -16715521L, -16715521L, - -16715521L, -15277585L, -7498344L, -7171435L, -694971499L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, -1919774060L, - -7171435L, -14623768L, -16715521L, -16715521L, -16715521L, -16715521L, - -16715521L, -13120041L, -7171435L, 1704104597L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 177838489L, - -74280299L, -7171435L, -10439750L, -16715521L, -16715521L, -16715521L, - -16715521L, -16715521L, -16715521L, -16715521L, -16715521L, -16715521L, - -10701380L, -7171435L, -40725867L, 211129749L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 1368494484L, -7171435L, -10374471L, - -16715521L, -16715521L, -16715521L, -16715521L, -16584963L, -9067350L, - -7171435L, 714248856L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 999527315L, -7171435L, -7171435L, - -12270386L, -16715521L, -16715521L, -16715521L, -16715521L, -16715521L, - -16715521L, -16715521L, -16715521L, -16715521L, -12531503L, -7171435L, - -7171435L, 1033015958L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 33554431L, -1080913258L, -7171435L, -10701636L, -15277329L, - -16519427L, -14885141L, -9720911L, -7171435L, -1718381676L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 1217499541L, -7171435L, -7171435L, -12793389L, -16715521L, - -16715521L, -16715521L, -16715521L, -16715521L, -16715521L, -16715521L, - -16715521L, -16715521L, -13054505L, -7171435L, -7171435L, 1251053972L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 479367826L, -929918315L, -7171435L, -7171435L, -7236971L, -7171435L, - -7171435L, -1366060139L, 227117469L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 361927314L, - -7171435L, -7171435L, -10962753L, -16715521L, -16715521L, -16715521L, - -16715521L, -16715521L, -16715521L, -16715521L, -16715521L, -16715521L, - -11289661L, -7171435L, -7171435L, 412456341L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 1536398230L, - -7171435L, -778857580L, -1013804395L, -1752067691L, 1334940052L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, -544042347L, - -7171435L, -8086625L, -16061704L, -16715521L, -16715521L, -16715521L, - -16715521L, -16715521L, -16715521L, -16715521L, -16126983L, -8217439L, - -7171435L, -426601835L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, -1097690475L, -23948651L, - 579833750L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 76714645L, 1452446357L, -1986882923L, - -1785556331L, 1720881813L, 361927317L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, -2070703211L, -7171435L, - -7171435L, -10570822L, -16649985L, -16715521L, -16715521L, -16715521L, - -16715521L, -16715521L, -16649985L, -10636101L, -7171435L, -7171435L, - -2020503147L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 596808338L, -23948651L, -1114467692L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 747803285L, -829255019L, -7171435L, -7171435L, -7171435L, - -7171435L, -326004074L, 1418891925L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 127046290L, -728591723L, -7171435L, -7171435L, - -9786446L, -15603981L, -16715521L, -16715521L, -16715521L, -15538958L, - -9655375L, -7171435L, -7171435L, -661482859L, 144678815L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - -2053991786L, -7171435L, 1502778005L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 278041237L, -443444587L, - -7171435L, -10963009L, -14492954L, -15015956L, -12335666L, -24340839L, - -40725867L, 999461525L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 848598164L, -225275243L, -7171435L, -7171435L, -7171435L, - -8347998L, -9720911L, -8348254L, -7171435L, -7171435L, -7171435L, - -225275243L, 949129878L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 61516458L, -443379051L, -292384107L, - 127046290L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, -1835887979L, -7171435L, -12008757L, -16715521L, - -16715521L, -16715521L, -16715521L, -14492954L, -24013930L, -745368939L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 546279319L, -1114467692L, -7171435L, -7171435L, -7171435L, -7171435L, - -7171435L, -7171435L, -7171435L, -1064136043L, 546279319L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 1301451413L, -7171435L, -1835822188L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - -795700587L, -24340838L, -16519427L, -16715521L, -16715521L, - -16715521L, -16715521L, -16715521L, -9917004L, -7171435L, 361927317L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 33554431L, 1469289365L, -1752067691L, -896363883L, -242052459L, - -141389163L, -7171435L, -309095531L, 429496729L, 1301451413L, - -2104389227L, -1215130987L, -879586667L, -1701670251L, 1704104597L, - 798134930L, 75530368L, 16777215L, -1332571499L, -7171435L, 798134930L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, -174943595L, -9067350L, -16715521L, -16715521L, - -16715521L, -16715521L, -16715521L, -16715521L, -11420476L, -7171435L, - 999461525L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - -1986948715L, -7171435L, -7171435L, -7171435L, -7171435L, -7171435L, - -7171435L, -7171435L, -7171435L, -7171435L, -7171435L, -158166379L, - -1517120875L, -74280299L, -879586667L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, -812477803L, -24340839L, -16519427L, -16715521L, -16715521L, - -16715521L, -16715521L, -16715521L, -9851469L, -7171435L, 328372885L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 261724569L, -1248685419L, - -7171435L, -7171435L, -7171435L, -7171435L, -7171435L, -7566182L, - -8355679L, -7171435L, -7171435L, -7171435L, -7171435L, -7171435L, - -7171435L, -1869376618L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, -1902996843L, - -7171435L, -11681849L, -16715521L, -16715521L, -16715521L, -16715521L, - -14166045L, -7236714L, -208498027L, 882086803L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 1150456470L, -493710699L, -7171435L, -7171435L, -7303018L, - -10789959L, -13026608L, -14934812L, -16513548L, -16645131L, -15921426L, - -14013478L, -11973946L, -8618845L, -7171435L, -7171435L, -23948651L, - -1768779114L, 144678815L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 227709589L, -544107883L, -7171435L, - -10570822L, -13969951L, -14492954L, -11943478L, -24210280L, -23948651L, - -7171435L, -23948651L, -1517186668L, 529831060L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 596808338L, -174943595L, - -7171435L, -7171435L, -8684636L, -14605855L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16316174L, -11382080L, -7237226L, -7171435L, -7171435L, -1852665195L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 663917205L, -929918315L, -7171435L, -7171435L, - -7171435L, -7171435L, -393112938L, 1284674197L, 1049661588L, - -879586667L, -7171435L, -141389163L, -1986948715L, 261724569L, - 16777215L, 16777215L, 16777215L, 41975936L, -1013804395L, -7171435L, - -7171435L, -11184706L, -16316174L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -14342690L, -8158305L, -7171435L, -23948651L, - 1066570390L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 59937429L, 1234342549L, 2140312213L, - -1936551275L, 1486000789L, 294818453L, 16777215L, 16777215L, - 33554431L, 1519621014L, -527265131L, -7171435L, -342715755L, - 1821545109L, 93952409L, 16777215L, 1922142614L, -7171435L, -7171435L, - -9868880L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -14210851L, -7237227L, -7171435L, - -560819563L, 211129749L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 144678815L, 1989383061L, -258829675L, -7171435L, -644705643L, - 1804767894L, -141389163L, -7171435L, -7829349L, -15658261L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -11184706L, -7171435L, -7171435L, -1785622123L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 344755353L, -1835822188L, -91057515L, -7171435L, -7171435L, - -7171435L, -13289772L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16250383L, -8421470L, -7171435L, -292384107L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 647271572L, -409824619L, -7171435L, -7566183L, -16513548L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -11447872L, - -7171435L, -7171435L, 613782933L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - -460090475L, -7171435L, -9342293L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -13421357L, -7171435L, -7171435L, - 1502778005L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 965907093L, -1785556331L, -879586667L, -158166379L, -695037291L, - -1584229739L, 1435669141L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 412456341L, -7171435L, - -7171435L, -11184706L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -15263513L, -7171435L, -7171435L, -1903062635L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 143823509L, -1936551275L, -40725867L, - -7171435L, -7171435L, -7171435L, -7171435L, -7171435L, -7171435L, - -1299017067L, 412258965L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 1200853907L, -7171435L, -7171435L, -12895025L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16579339L, -7566183L, -7171435L, -1114467692L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, -1231908203L, -7171435L, -7171435L, -7171435L, -8282719L, - -9655375L, -8544092L, -7236714L, -7171435L, -7171435L, -577596779L, - 194155157L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 747737495L, -7171435L, -7171435L, -11908411L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -15987217L, -7171435L, - -7171435L, -1483566443L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 1720881813L, -7171435L, - -7171435L, -8348254L, -14231324L, -16715521L, -16715521L, -16715521L, - -15212050L, -9263188L, -7171435L, -7171435L, -1768779115L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 61516458L, -158166379L, - -7171435L, -10000462L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -14145060L, -7171435L, -7171435L, -91057515L, - -1315794284L, 1603375510L, 295081622L, 16777215L, 16777215L, - 16777215L, 16777215L, 127046293L, -242052459L, -7171435L, -7629158L, - -15538958L, -16715521L, -16715521L, -16715521L, -16715521L, -16715521L, - -16519427L, -8740442L, -7171435L, -23948651L, 747803285L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, -963472747L, -7171435L, - -8158305L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -12237111L, -7171435L, -7171435L, -7171435L, -7171435L, - -7171435L, -74280299L, -1164865131L, 1754502038L, 412456341L, - 16777215L, 915575445L, -7171435L, -7171435L, -12008757L, -16715521L, - -16715521L, -16715521L, -16715521L, -16715521L, -16715521L, -16715521L, - -13773857L, -7171435L, -7171435L, 1720881813L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, -1819110763L, -7171435L, -7171435L, - -15263513L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -9868879L, -7171435L, -74280299L, 1368560277L, -1651338603L, - -325938539L, -7171435L, -7171435L, -7171435L, -40725867L, -1013804395L, - -1382903147L, -7171435L, -7171435L, -14100510L, -16715521L, -16715521L, - -16715521L, -16715521L, -16715521L, -16715521L, -16715521L, -16061960L, - -7171435L, -7171435L, -1668115819L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 1402180499L, -7171435L, -7171435L, -9539923L, - -16579339L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -13816104L, -7171435L, - -7171435L, -946695531L, 16777215L, 16777215L, 61516458L, 1116967831L, - -1802333548L, -460090475L, -7171435L, -7171435L, -7171435L, -7171435L, - -7171435L, -14558233L, -16715521L, -16715521L, -16715521L, -16715521L, - -16715521L, -16715521L, -16715521L, -16388613L, -7302250L, -7171435L, - -1433234795L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, -1198353770L, -7171435L, -7171435L, -12500278L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -15987217L, -8092514L, -7171435L, -74280299L, 898666645L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 33554431L, - 949129878L, -1970105706L, -443379050L, -7171435L, -7171435L, - -12793389L, -16715521L, -16715521L, -16715521L, -16715521L, -16715521L, - -16715521L, -16715521L, -14558233L, -7171435L, -7171435L, 1972540053L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 479367826L, -258829675L, -7171435L, -7500391L, -14737438L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16447757L, - -10263627L, -7171435L, -7171435L, -2070703211L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 294818453L, -23948651L, -7171435L, -8478812L, -16323334L, - -16715521L, -16715521L, -16715521L, -16715521L, -16715521L, -16715521L, - -9917005L, -7171435L, -7171435L, 1083347605L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 1603375510L, - -7171435L, -7171435L, -7434600L, -12237111L, -16513548L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, -16645131L, - -16645131L, -16645131L, -15000603L, -9013337L, -7171435L, -7171435L, - -778923371L, 109084842L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - -1768779115L, -7171435L, -7171435L, -10178634L, -16061960L, -16715521L, - -16715521L, -16715521L, -16388612L, -11224382L, -7171435L, -7171435L, - -997027179L, 43160213L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 33554431L, -728591723L, -7171435L, - -7171435L, -7171435L, -9276502L, -14605855L, -16513549L, -16645131L, - -16645131L, -16645131L, -16645131L, -16645131L, -15789843L, -12171320L, - -7368809L, -7171435L, -7171435L, -376270187L, 781226134L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 194155157L, -577596779L, - -7171435L, -7171435L, -7890531L, -10636100L, -12335666L, -11028288L, - -8413533L, -7171435L, -7171435L, -174943595L, 613585557L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 33554431L, 579833750L, 261724569L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 160337550L, -1416457579L, -7171435L, -7171435L, -124611948L, - -7171435L, -7171435L, -7171435L, -7500391L, -9342293L, -11316288L, - -12171320L, -10263627L, -8355679L, -7171435L, -7171435L, -7171435L, - -7171435L, -1416457579L, 344755353L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 647139989L, -913141099L, - -7171435L, -7171435L, -7171435L, -7171435L, -7171435L, -7171435L, - -7171435L, -476933483L, 1150456469L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 1184010901L, -1131244907L, - -275606891L, -7171435L, -23948651L, -644705643L, -1768779114L, - 311332508L, 16777215L, 16777215L, 16777215L, 16777215L, 379033495L, - -929852523L, -7171435L, -23948651L, 2056426132L, 428838809L, - -1282305642L, -7171435L, -7171435L, -7171435L, -7171435L, -7171435L, - -7171435L, -7171435L, -7171435L, -7171435L, -7171435L, -325938539L, - 1485934996L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 59937429L, - 2039648917L, -711814507L, -40725867L, -7171435L, -7171435L, -510487915L, - -1752001899L, 261264021L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 211129749L, -1701670251L, -7171435L, -7171435L, - -7171435L, -7171435L, -7171435L, -7171435L, -7171435L, -426601835L, - 1234408342L, 16777215L, 16777215L, 697274261L, -544042347L, -7171435L, - -124611947L, 1485934996L, 16777215L, 16777215L, 16777215L, 1167365268L, - -2137943659L, -1248619627L, -376270187L, -7171435L, -7171435L, - -91057515L, -846032235L, -1752067691L, 1653772948L, 395350160L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 227709589L, 949129877L, 378704533L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, -1550741099L, -7171435L, -7171435L, -8021089L, - -11616570L, -13446949L, -12662830L, -10178634L, -7171435L, -7171435L, - -91057515L, 831689367L, 1133613460L, -275606891L, -7171435L, - -342715755L, 999527315L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 529831060L, 865178006L, - 144678815L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 1368494484L, -7171435L, -7171435L, -9851725L, -15996425L, -16715521L, - -16715521L, -16715521L, -16715521L, -13904672L, -7563622L, -7171435L, - -476933483L, -91057514L, -7171435L, -644705643L, 613782933L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, -846032235L, - -7171435L, -8217439L, -16061704L, -16715521L, -16715521L, -16715521L, - -16715521L, -16715521L, -16715521L, -12727853L, -7171435L, -7171435L, - -7171435L, -1030581611L, 311332508L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 109084842L, -91057515L, -7171435L, -12139828L, - -16715521L, -16715521L, -16715521L, -16715521L, -16715521L, -16715521L, - -16715521L, -16649985L, -7890531L, -7171435L, -695037291L, 109084842L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 831689367L, -7171435L, -7171435L, -13970208L, -16715521L, -16715521L, - -16715521L, -16715521L, -16715521L, -16715521L, -16715521L, -16715521L, - -9720911L, -7171435L, -1080913258L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 596808338L, -7171435L, - -7171435L, -13512485L, -16715521L, -16715521L, -16715521L, -16715521L, - -16715521L, -16715521L, -16715521L, -16715521L, -9197652L, -7171435L, - -1299017067L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 33554431L, -258829675L, -7171435L, -11355453L, - -16715521L, -16715521L, -16715521L, -16715521L, -16715521L, -16715521L, - -16715521L, -16192519L, -7498343L, -7171435L, 2089980564L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, -1265462635L, -7171435L, -7367273L, -14950677L, -16715521L, - -16715521L, -16715521L, -16715521L, -16715521L, -16715521L, -10897730L, - -7171435L, -7171435L, 1049661588L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 630296984L, - -174943595L, -7171435L, -8086625L, -14100766L, -16715521L, -16715521L, - -16715521L, -16323077L, -11028288L, -7171435L, -7171435L, -1550741099L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 1821545109L, -7171435L, - -7171435L, -7236971L, -8740186L, -10439750L, -9655375L, -7825252L, - -7171435L, -7171435L, -476933483L, 277843855L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 1385337493L, -376270187L, -7171435L, - -7171435L, -7171435L, -7171435L, -7171435L, -7171435L, -1332571499L, - 395350160L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 344755353L, 1922142614L, -1533898091L, - -728591723L, -1080913258L, -1903062635L, 1284805780L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, 16777215L, - 16777215L, 16777215L, 16777215L - ), .Dim = c(64L, 64L), class = "nativeRaster", channels = 4L) + structure( + c( + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 311332508L, + 1217499541L, + 1804702102L, + 1066570390L, + 211129749L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 379033495L, + 1334940052L, + -2104389227L, + -1450012011L, + -2087546218L, + 1368494484L, + 412456341L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 41975936L, + 1905496981L, + -141388906L, + -7171435L, + -7171435L, + -7171435L, + -325938283L, + 1452380564L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 41975936L, + 1905496981L, + -158166379L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -141389163L, + 1972540052L, + 41975936L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + -2037148780L, + -7171435L, + -24798561L, + -12009013L, + -13250855L, + -11616826L, + -24340838L, + -7171435L, + 1586664085L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 311332508L, + -963472747L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7236971L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -946695531L, + 361927314L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 798134930L, + -40791403L, + -25321308L, + -16061704L, + -16715521L, + -16715521L, + -16715521L, + -15408144L, + -24471653L, + -258829418L, + 344755353L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + -1483500650L, + -7171435L, + -7171435L, + -7824996L, + -12858668L, + -15212050L, + -16519427L, + -15212050L, + -12858668L, + -7890531L, + -7171435L, + -7171435L, + -1382903147L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 2056426132L, + -7171435L, + -13643043L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -12139572L, + -7171435L, + 1385337493L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 1452380564L, + -7171435L, + -7171435L, + -8936279L, + -15800587L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -15865867L, + -9132373L, + -7171435L, + -7171435L, + 1485934996L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + -1433234795L, + -7171435L, + -15603981L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -14100510L, + -7171435L, + -2104389227L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + -812412011L, + -7171435L, + -7432808L, + -15080979L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -15277585L, + -7498344L, + -7171435L, + -694971499L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + -1919774060L, + -7171435L, + -14623768L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -13120041L, + -7171435L, + 1704104597L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 177838489L, + -74280299L, + -7171435L, + -10439750L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -10701380L, + -7171435L, + -40725867L, + 211129749L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 1368494484L, + -7171435L, + -10374471L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16584963L, + -9067350L, + -7171435L, + 714248856L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 999527315L, + -7171435L, + -7171435L, + -12270386L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -12531503L, + -7171435L, + -7171435L, + 1033015958L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 33554431L, + -1080913258L, + -7171435L, + -10701636L, + -15277329L, + -16519427L, + -14885141L, + -9720911L, + -7171435L, + -1718381676L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 1217499541L, + -7171435L, + -7171435L, + -12793389L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -13054505L, + -7171435L, + -7171435L, + 1251053972L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 479367826L, + -929918315L, + -7171435L, + -7171435L, + -7236971L, + -7171435L, + -7171435L, + -1366060139L, + 227117469L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 361927314L, + -7171435L, + -7171435L, + -10962753L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -11289661L, + -7171435L, + -7171435L, + 412456341L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 1536398230L, + -7171435L, + -778857580L, + -1013804395L, + -1752067691L, + 1334940052L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + -544042347L, + -7171435L, + -8086625L, + -16061704L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16126983L, + -8217439L, + -7171435L, + -426601835L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + -1097690475L, + -23948651L, + 579833750L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 76714645L, + 1452446357L, + -1986882923L, + -1785556331L, + 1720881813L, + 361927317L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + -2070703211L, + -7171435L, + -7171435L, + -10570822L, + -16649985L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16649985L, + -10636101L, + -7171435L, + -7171435L, + -2020503147L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 596808338L, + -23948651L, + -1114467692L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 747803285L, + -829255019L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -326004074L, + 1418891925L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 127046290L, + -728591723L, + -7171435L, + -7171435L, + -9786446L, + -15603981L, + -16715521L, + -16715521L, + -16715521L, + -15538958L, + -9655375L, + -7171435L, + -7171435L, + -661482859L, + 144678815L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + -2053991786L, + -7171435L, + 1502778005L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 278041237L, + -443444587L, + -7171435L, + -10963009L, + -14492954L, + -15015956L, + -12335666L, + -24340839L, + -40725867L, + 999461525L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 848598164L, + -225275243L, + -7171435L, + -7171435L, + -7171435L, + -8347998L, + -9720911L, + -8348254L, + -7171435L, + -7171435L, + -7171435L, + -225275243L, + 949129878L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 61516458L, + -443379051L, + -292384107L, + 127046290L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + -1835887979L, + -7171435L, + -12008757L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -14492954L, + -24013930L, + -745368939L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 546279319L, + -1114467692L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -1064136043L, + 546279319L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 1301451413L, + -7171435L, + -1835822188L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + -795700587L, + -24340838L, + -16519427L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -9917004L, + -7171435L, + 361927317L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 33554431L, + 1469289365L, + -1752067691L, + -896363883L, + -242052459L, + -141389163L, + -7171435L, + -309095531L, + 429496729L, + 1301451413L, + -2104389227L, + -1215130987L, + -879586667L, + -1701670251L, + 1704104597L, + 798134930L, + 75530368L, + 16777215L, + -1332571499L, + -7171435L, + 798134930L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + -174943595L, + -9067350L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -11420476L, + -7171435L, + 999461525L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + -1986948715L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -158166379L, + -1517120875L, + -74280299L, + -879586667L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + -812477803L, + -24340839L, + -16519427L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -9851469L, + -7171435L, + 328372885L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 261724569L, + -1248685419L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7566182L, + -8355679L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -1869376618L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + -1902996843L, + -7171435L, + -11681849L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -14166045L, + -7236714L, + -208498027L, + 882086803L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 1150456470L, + -493710699L, + -7171435L, + -7171435L, + -7303018L, + -10789959L, + -13026608L, + -14934812L, + -16513548L, + -16645131L, + -15921426L, + -14013478L, + -11973946L, + -8618845L, + -7171435L, + -7171435L, + -23948651L, + -1768779114L, + 144678815L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 227709589L, + -544107883L, + -7171435L, + -10570822L, + -13969951L, + -14492954L, + -11943478L, + -24210280L, + -23948651L, + -7171435L, + -23948651L, + -1517186668L, + 529831060L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 596808338L, + -174943595L, + -7171435L, + -7171435L, + -8684636L, + -14605855L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16316174L, + -11382080L, + -7237226L, + -7171435L, + -7171435L, + -1852665195L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 663917205L, + -929918315L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -393112938L, + 1284674197L, + 1049661588L, + -879586667L, + -7171435L, + -141389163L, + -1986948715L, + 261724569L, + 16777215L, + 16777215L, + 16777215L, + 41975936L, + -1013804395L, + -7171435L, + -7171435L, + -11184706L, + -16316174L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -14342690L, + -8158305L, + -7171435L, + -23948651L, + 1066570390L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 59937429L, + 1234342549L, + 2140312213L, + -1936551275L, + 1486000789L, + 294818453L, + 16777215L, + 16777215L, + 33554431L, + 1519621014L, + -527265131L, + -7171435L, + -342715755L, + 1821545109L, + 93952409L, + 16777215L, + 1922142614L, + -7171435L, + -7171435L, + -9868880L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -14210851L, + -7237227L, + -7171435L, + -560819563L, + 211129749L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 144678815L, + 1989383061L, + -258829675L, + -7171435L, + -644705643L, + 1804767894L, + -141389163L, + -7171435L, + -7829349L, + -15658261L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -11184706L, + -7171435L, + -7171435L, + -1785622123L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 344755353L, + -1835822188L, + -91057515L, + -7171435L, + -7171435L, + -7171435L, + -13289772L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16250383L, + -8421470L, + -7171435L, + -292384107L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 647271572L, + -409824619L, + -7171435L, + -7566183L, + -16513548L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -11447872L, + -7171435L, + -7171435L, + 613782933L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + -460090475L, + -7171435L, + -9342293L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -13421357L, + -7171435L, + -7171435L, + 1502778005L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 965907093L, + -1785556331L, + -879586667L, + -158166379L, + -695037291L, + -1584229739L, + 1435669141L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 412456341L, + -7171435L, + -7171435L, + -11184706L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -15263513L, + -7171435L, + -7171435L, + -1903062635L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 143823509L, + -1936551275L, + -40725867L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -1299017067L, + 412258965L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 1200853907L, + -7171435L, + -7171435L, + -12895025L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16579339L, + -7566183L, + -7171435L, + -1114467692L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + -1231908203L, + -7171435L, + -7171435L, + -7171435L, + -8282719L, + -9655375L, + -8544092L, + -7236714L, + -7171435L, + -7171435L, + -577596779L, + 194155157L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 747737495L, + -7171435L, + -7171435L, + -11908411L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -15987217L, + -7171435L, + -7171435L, + -1483566443L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 1720881813L, + -7171435L, + -7171435L, + -8348254L, + -14231324L, + -16715521L, + -16715521L, + -16715521L, + -15212050L, + -9263188L, + -7171435L, + -7171435L, + -1768779115L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 61516458L, + -158166379L, + -7171435L, + -10000462L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -14145060L, + -7171435L, + -7171435L, + -91057515L, + -1315794284L, + 1603375510L, + 295081622L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 127046293L, + -242052459L, + -7171435L, + -7629158L, + -15538958L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16519427L, + -8740442L, + -7171435L, + -23948651L, + 747803285L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + -963472747L, + -7171435L, + -8158305L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -12237111L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -74280299L, + -1164865131L, + 1754502038L, + 412456341L, + 16777215L, + 915575445L, + -7171435L, + -7171435L, + -12008757L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -13773857L, + -7171435L, + -7171435L, + 1720881813L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + -1819110763L, + -7171435L, + -7171435L, + -15263513L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -9868879L, + -7171435L, + -74280299L, + 1368560277L, + -1651338603L, + -325938539L, + -7171435L, + -7171435L, + -7171435L, + -40725867L, + -1013804395L, + -1382903147L, + -7171435L, + -7171435L, + -14100510L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16061960L, + -7171435L, + -7171435L, + -1668115819L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 1402180499L, + -7171435L, + -7171435L, + -9539923L, + -16579339L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -13816104L, + -7171435L, + -7171435L, + -946695531L, + 16777215L, + 16777215L, + 61516458L, + 1116967831L, + -1802333548L, + -460090475L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -14558233L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16388613L, + -7302250L, + -7171435L, + -1433234795L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + -1198353770L, + -7171435L, + -7171435L, + -12500278L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -15987217L, + -8092514L, + -7171435L, + -74280299L, + 898666645L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 33554431L, + 949129878L, + -1970105706L, + -443379050L, + -7171435L, + -7171435L, + -12793389L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -14558233L, + -7171435L, + -7171435L, + 1972540053L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 479367826L, + -258829675L, + -7171435L, + -7500391L, + -14737438L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16447757L, + -10263627L, + -7171435L, + -7171435L, + -2070703211L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 294818453L, + -23948651L, + -7171435L, + -8478812L, + -16323334L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -9917005L, + -7171435L, + -7171435L, + 1083347605L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 1603375510L, + -7171435L, + -7171435L, + -7434600L, + -12237111L, + -16513548L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -15000603L, + -9013337L, + -7171435L, + -7171435L, + -778923371L, + 109084842L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + -1768779115L, + -7171435L, + -7171435L, + -10178634L, + -16061960L, + -16715521L, + -16715521L, + -16715521L, + -16388612L, + -11224382L, + -7171435L, + -7171435L, + -997027179L, + 43160213L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 33554431L, + -728591723L, + -7171435L, + -7171435L, + -7171435L, + -9276502L, + -14605855L, + -16513549L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -16645131L, + -15789843L, + -12171320L, + -7368809L, + -7171435L, + -7171435L, + -376270187L, + 781226134L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 194155157L, + -577596779L, + -7171435L, + -7171435L, + -7890531L, + -10636100L, + -12335666L, + -11028288L, + -8413533L, + -7171435L, + -7171435L, + -174943595L, + 613585557L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 33554431L, + 579833750L, + 261724569L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 160337550L, + -1416457579L, + -7171435L, + -7171435L, + -124611948L, + -7171435L, + -7171435L, + -7171435L, + -7500391L, + -9342293L, + -11316288L, + -12171320L, + -10263627L, + -8355679L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -1416457579L, + 344755353L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 647139989L, + -913141099L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -476933483L, + 1150456469L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 1184010901L, + -1131244907L, + -275606891L, + -7171435L, + -23948651L, + -644705643L, + -1768779114L, + 311332508L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 379033495L, + -929852523L, + -7171435L, + -23948651L, + 2056426132L, + 428838809L, + -1282305642L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -325938539L, + 1485934996L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 59937429L, + 2039648917L, + -711814507L, + -40725867L, + -7171435L, + -7171435L, + -510487915L, + -1752001899L, + 261264021L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 211129749L, + -1701670251L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -426601835L, + 1234408342L, + 16777215L, + 16777215L, + 697274261L, + -544042347L, + -7171435L, + -124611947L, + 1485934996L, + 16777215L, + 16777215L, + 16777215L, + 1167365268L, + -2137943659L, + -1248619627L, + -376270187L, + -7171435L, + -7171435L, + -91057515L, + -846032235L, + -1752067691L, + 1653772948L, + 395350160L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 227709589L, + 949129877L, + 378704533L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + -1550741099L, + -7171435L, + -7171435L, + -8021089L, + -11616570L, + -13446949L, + -12662830L, + -10178634L, + -7171435L, + -7171435L, + -91057515L, + 831689367L, + 1133613460L, + -275606891L, + -7171435L, + -342715755L, + 999527315L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 529831060L, + 865178006L, + 144678815L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 1368494484L, + -7171435L, + -7171435L, + -9851725L, + -15996425L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -13904672L, + -7563622L, + -7171435L, + -476933483L, + -91057514L, + -7171435L, + -644705643L, + 613782933L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + -846032235L, + -7171435L, + -8217439L, + -16061704L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -12727853L, + -7171435L, + -7171435L, + -7171435L, + -1030581611L, + 311332508L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 109084842L, + -91057515L, + -7171435L, + -12139828L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16649985L, + -7890531L, + -7171435L, + -695037291L, + 109084842L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 831689367L, + -7171435L, + -7171435L, + -13970208L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -9720911L, + -7171435L, + -1080913258L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 596808338L, + -7171435L, + -7171435L, + -13512485L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -9197652L, + -7171435L, + -1299017067L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 33554431L, + -258829675L, + -7171435L, + -11355453L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16192519L, + -7498343L, + -7171435L, + 2089980564L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + -1265462635L, + -7171435L, + -7367273L, + -14950677L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -16715521L, + -10897730L, + -7171435L, + -7171435L, + 1049661588L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 630296984L, + -174943595L, + -7171435L, + -8086625L, + -14100766L, + -16715521L, + -16715521L, + -16715521L, + -16323077L, + -11028288L, + -7171435L, + -7171435L, + -1550741099L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 1821545109L, + -7171435L, + -7171435L, + -7236971L, + -8740186L, + -10439750L, + -9655375L, + -7825252L, + -7171435L, + -7171435L, + -476933483L, + 277843855L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 1385337493L, + -376270187L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -7171435L, + -1332571499L, + 395350160L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 344755353L, + 1922142614L, + -1533898091L, + -728591723L, + -1080913258L, + -1903062635L, + 1284805780L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L, + 16777215L + ), + .Dim = c(64L, 64L), + class = "nativeRaster", + channels = 4L + ) i.vertex.default <- list( color = 1, @@ -1453,8 +4866,12 @@ i.vertex.default <- list( shape = "circle", pie = 1, pie.color = list(c( - "white", "lightblue", "mistyrose", - "lightcyan", "lavender", "cornsilk" + "white", + "lightblue", + "mistyrose", + "lightcyan", + "lavender", + "cornsilk" )), pie.angle = 45, pie.density = -1, @@ -1515,13 +4932,18 @@ i.default.values[["plot"]] <- i.plot.default # # To use the default values (calling par()), it should be done after calling # the device and specifying its dimmensions. -i.rescale.vertex <- function(size, plot.reg.coords = par("usr")[1:2], - minmax.relative.size) { +i.rescale.vertex <- function( + size, + plot.reg.coords = par("usr")[1:2], + minmax.relative.size +) { # Adjusting ran <- range(size, na.rm = TRUE) scal <- (plot.reg.coords[2] - plot.reg.coords[1]) * minmax.relative.size - size <- (size - ran[1] + 1e-15) / (ran[2] - ran[1] + 1e-15) * - (scal[2] - scal[1]) + scal[1] + size <- (size - ran[1] + 1e-15) / + (ran[2] - ran[1] + 1e-15) * + (scal[2] - scal[1]) + + scal[1] return(size) } From d1a48ed0a8fa1c507284f90bf7fda983b364bc57 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:56:30 +0200 Subject: [PATCH 36/59] paths --- R/paths.R | 51 +++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 39 insertions(+), 12 deletions(-) diff --git a/R/paths.R b/R/paths.R index 5ce9bf967c0..66ecc75f271 100644 --- a/R/paths.R +++ b/R/paths.R @@ -8,7 +8,8 @@ #' @inheritParams distance_table #' @keywords internal #' @export -path.length.hist <- function(graph, directed = TRUE) { # nocov start +path.length.hist <- function(graph, directed = TRUE) { + # nocov start lifecycle::deprecate_soft("2.0.0", "path.length.hist()", "distance_table()") distance_table(graph = graph, directed = directed) } # nocov end @@ -23,8 +24,13 @@ path.length.hist <- function(graph, directed = TRUE) { # nocov start #' @inheritParams max_cardinality #' @keywords internal #' @export -maximum.cardinality.search <- function(graph) { # nocov start - lifecycle::deprecate_soft("2.0.0", "maximum.cardinality.search()", "max_cardinality()") +maximum.cardinality.search <- function(graph) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "maximum.cardinality.search()", + "max_cardinality()" + ) max_cardinality(graph = graph) } # nocov end @@ -38,7 +44,8 @@ maximum.cardinality.search <- function(graph) { # nocov start #' @inheritParams is_dag #' @keywords internal #' @export -is.dag <- function(graph) { # nocov start +is.dag <- function(graph) { + # nocov start lifecycle::deprecate_soft("2.0.0", "is.dag()", "is_dag()") is_dag(graph = graph) } # nocov end @@ -99,14 +106,19 @@ is.dag <- function(graph) { # nocov start #' #' @family paths #' @export -all_simple_paths <- function(graph, from, to = V(graph), - mode = c("out", "in", "all", "total"), - cutoff = -1) { +all_simple_paths <- function( + graph, + from, + to = V(graph), + mode = c("out", "in", "all", "total"), + cutoff = -1 +) { ## Argument checks ensure_igraph(graph) from <- as_igraph_vs(graph, from) to <- as_igraph_vs(graph, to) - mode <- switch(igraph.match.arg(mode), + mode <- switch( + igraph.match.arg(mode), "out" = 1, "in" = 2, "all" = 3, @@ -117,8 +129,12 @@ all_simple_paths <- function(graph, from, to = V(graph), ## Function call res <- .Call( - R_igraph_get_all_simple_paths, graph, from - 1, to - 1, - as.numeric(cutoff), mode + R_igraph_get_all_simple_paths, + graph, + from - 1, + to - 1, + as.numeric(cutoff), + mode ) res <- get.all.simple.paths.pp(res) @@ -264,7 +280,13 @@ max_cardinality <- maximum_cardinality_search_impl #' @family paths #' @export #' @cdocs igraph_eccentricity_dijkstra -eccentricity <- function(graph, vids = V(graph), ..., weights = NULL, mode = c("all", "out", "in", "total")) { +eccentricity <- function( + graph, + vids = V(graph), + ..., + weights = NULL, + mode = c("all", "out", "in", "total") +) { if (...length() > 0) { lifecycle::deprecate_soft( "2.1.0", @@ -313,7 +335,12 @@ eccentricity <- function(graph, vids = V(graph), ..., weights = NULL, mode = c(" #' @family paths #' @export #' @cdocs igraph_radius_dijkstra -radius <- function(graph, ..., weights = NULL, mode = c("all", "out", "in", "total")) { +radius <- function( + graph, + ..., + weights = NULL, + mode = c("all", "out", "in", "total") +) { if (...length() > 0) { lifecycle::deprecate_soft( "2.1.0", From b42b6b80e13ccf6bc7e03b157ab59a6e8a94304c Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:56:40 +0200 Subject: [PATCH 37/59] par --- R/par.R | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/R/par.R b/R/par.R index 0eac3c66e18..9507dc039b3 100644 --- a/R/par.R +++ b/R/par.R @@ -8,7 +8,8 @@ #' @inheritParams igraph_options #' @keywords internal #' @export -igraph.options <- function(...) { # nocov start +igraph.options <- function(...) { + # nocov start lifecycle::deprecate_soft("2.0.0", "igraph.options()", "igraph_options()") igraph_i_options(...) } # nocov end @@ -23,7 +24,8 @@ igraph.options <- function(...) { # nocov start #' @inheritParams igraph_opt #' @keywords internal #' @export -getIgraphOpt <- function(x, default = NULL) { # nocov start +getIgraphOpt <- function(x, default = NULL) { + # nocov start lifecycle::deprecate_soft("2.0.0", "getIgraphOpt()", "igraph_opt()") if (missing(default)) { @@ -222,7 +224,8 @@ igraph_i_options <- function(..., .in = parent.frame()) { temp <- list(...) if (length(temp) == 1 && is.null(names(temp))) { arg <- temp[[1]] - switch(mode(arg), + switch( + mode(arg), list = temp <- arg, character = return(.igraph.pars[arg]), cli::cli_abort("invalid argument: {arg}.") @@ -234,7 +237,9 @@ igraph_i_options <- function(..., .in = parent.frame()) { ## Callbacks n <- names(temp) - if (is.null(n)) cli::cli_abort("options must be given by name.") + if (is.null(n)) { + cli::cli_abort("options must be given by name.") + } cb <- intersect(names(igraph.pars.callbacks), n) for (cn in cb) { temp[[cn]] <- igraph.pars.callbacks[[cn]](temp[[cn]]) From 5abd33e45d3f0a6ef853d2ffc7c1cb62ad5e0d44 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:57:12 +0200 Subject: [PATCH 38/59] random_walk --- R/random_walk.R | 26 ++++++++++++++------------ 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/R/random_walk.R b/R/random_walk.R index 2583aed2cb6..3df2c6edd8a 100644 --- a/R/random_walk.R +++ b/R/random_walk.R @@ -49,12 +49,13 @@ #' cor(table(w), pg) #' @cdocs igraph_random_walk random_walk <- function( - graph, - start, - steps, - weights = NULL, - mode = c("out", "in", "all", "total"), - stuck = c("return", "error")) { + graph, + start, + steps, + weights = NULL, + mode = c("out", "in", "all", "total"), + stuck = c("return", "error") +) { mode <- match.arg(mode) stuck <- match.arg(stuck) out <- random_walk_impl(graph, start, steps, weights, mode, stuck) @@ -66,12 +67,13 @@ random_walk <- function( #' @export #' @cdocs igraph_random_walk random_edge_walk <- function( - graph, - start, - steps, - weights = NULL, - mode = c("out", "in", "all", "total"), - stuck = c("return", "error")) { + graph, + start, + steps, + weights = NULL, + mode = c("out", "in", "all", "total"), + stuck = c("return", "error") +) { mode <- match.arg(mode) stuck <- match.arg(stuck) out <- random_walk_impl(graph, start, steps, weights, mode, stuck) From 0e9e816f901d5320511fb38245ebede694332183 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:57:29 +0200 Subject: [PATCH 39/59] rewire --- R/rewire.R | 21 ++++++++++++++++----- 1 file changed, 16 insertions(+), 5 deletions(-) diff --git a/R/rewire.R b/R/rewire.R index 83087f2bc7b..54f57250499 100644 --- a/R/rewire.R +++ b/R/rewire.R @@ -21,7 +21,6 @@ ## ## ----------------------------------------------------------------------- - #' Rewiring edges of a graph #' #' See the links below for the implemented rewiring methods. @@ -125,8 +124,14 @@ rewire_keeping_degseq <- function(graph, loops, niter) { #' g <- sample_pa(1000) #' g2 <- g %>% rewire(each_edge(mode = "in", multiple = TRUE, prob = 0.2)) #' degree(g, mode = "in") == degree(g2, mode = "in") -each_edge <- function(prob, loops = FALSE, multiple = FALSE, mode = c("all", "out", "in", "total")) { - mode <- switch(igraph.match.arg(mode), +each_edge <- function( + prob, + loops = FALSE, + multiple = FALSE, + mode = c("all", "out", "in", "total") +) { + mode <- switch( + igraph.match.arg(mode), "out" = 1, "in" = 2, "all" = 3, @@ -155,7 +160,10 @@ rewire_each_edge <- function(graph, prob, loops, multiple) { on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_rewire_edges, graph, as.numeric(prob), as.logical(loops), + R_igraph_rewire_edges, + graph, + as.numeric(prob), + as.logical(loops), as.logical(multiple) ) } @@ -165,7 +173,10 @@ rewire_each_directed_edge <- function(graph, prob, loops, mode) { on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_rewire_directed_edges, graph, as.numeric(prob), as.logical(loops), + R_igraph_rewire_directed_edges, + graph, + as.numeric(prob), + as.logical(loops), as.numeric(mode) ) } From 040354d5423bc8ee6314c2fc5459911b81d44474 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:58:19 +0200 Subject: [PATCH 40/59] scan --- R/scan.R | 98 +++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 65 insertions(+), 33 deletions(-) diff --git a/R/scan.R b/R/scan.R index 2df4a6aa10d..377353eed89 100644 --- a/R/scan.R +++ b/R/scan.R @@ -102,9 +102,16 @@ #' graph.them = pair$graph2, #' neighborhoods = Neigh_1 #' ) -local_scan <- function(graph.us, graph.them = NULL, k = 1, FUN = NULL, - weighted = FALSE, mode = c("out", "in", "all"), - neighborhoods = NULL, ...) { +local_scan <- function( + graph.us, + graph.them = NULL, + k = 1, + FUN = NULL, + weighted = FALSE, + mode = c("out", "in", "all"), + neighborhoods = NULL, + ... +) { ## Must be igraph object stopifnot(is_igraph(graph.us)) @@ -118,15 +125,20 @@ local_scan <- function(graph.us, graph.them = NULL, k = 1, FUN = NULL, stopifnot(length(k) == 1, k >= 0, trunc(k) == k) ## Must be NULL or a function - stopifnot(is.null(FUN) || is.function(FUN) || - (is.character(FUN) && length(FUN) == 1)) + stopifnot( + is.null(FUN) || is.function(FUN) || (is.character(FUN) && length(FUN) == 1) + ) ## Logical scalar stopifnot(is.logical(weighted), length(weighted) == 1) ## If weighted, then the graph(s) must be weighted - stopifnot(!weighted || (is_weighted(graph.us) && (is.null(graph.them) || - is_weighted(graph.them)))) + stopifnot( + !weighted || + (is_weighted(graph.us) && + (is.null(graph.them) || + is_weighted(graph.them))) + ) ## Check if 'neighborhoods' makes sense if (!is.null(neighborhoods)) { @@ -140,12 +152,7 @@ local_scan <- function(graph.us, graph.them = NULL, k = 1, FUN = NULL, ## Check mode argument mode <- igraph.match.arg(mode) - cmode <- switch(mode, - out = 1, - `in` = 2, - all = 3, - total = 3 - ) + cmode <- switch(mode, out = 1, `in` = 2, all = 3, total = 3) sumweights <- function(g) sum(E(g)$weight) @@ -161,14 +168,16 @@ local_scan <- function(graph.us, graph.them = NULL, k = 1, FUN = NULL, }) on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_local_scan_neighborhood_ecount, graph.us, + R_igraph_local_scan_neighborhood_ecount, + graph.us, if (weighted) as.numeric(E(graph.us)$weight) else NULL, neighborhoods ) } else { sapply( lapply(neighborhoods, induced.subgraph, graph = graph.us), - FUN, ... + FUN, + ... ) } } else { @@ -176,32 +185,41 @@ local_scan <- function(graph.us, graph.them = NULL, k = 1, FUN = NULL, if (k == 0) { on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_local_scan_0, graph.us, - if (weighted) as.numeric(E(graph.us)$weight) else NULL, cmode + R_igraph_local_scan_0, + graph.us, + if (weighted) as.numeric(E(graph.us)$weight) else NULL, + cmode ) ## scan-1, ecount - } else if (k == 1 && is.character(FUN) && - FUN %in% c("ecount", "sumweights")) { + } else if ( + k == 1 && is.character(FUN) && FUN %in% c("ecount", "sumweights") + ) { on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_local_scan_1_ecount, graph.us, - if (weighted) as.numeric(E(graph.us)$weight) else NULL, cmode + R_igraph_local_scan_1_ecount, + graph.us, + if (weighted) as.numeric(E(graph.us)$weight) else NULL, + cmode ) ## scan-k, ecount } else if (is.character(FUN) && FUN %in% c("ecount", "sumweights")) { on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_local_scan_k_ecount, graph.us, as.numeric(k), - if (weighted) as.numeric(E(graph.us)$weight) else NULL, cmode + R_igraph_local_scan_k_ecount, + graph.us, + as.numeric(k), + if (weighted) as.numeric(E(graph.us)$weight) else NULL, + cmode ) ## General } else { sapply( make_ego_graph(graph.us, order = k, V(graph.us), mode = mode), - FUN, ... + FUN, + ... ) } } @@ -214,14 +232,16 @@ local_scan <- function(graph.us, graph.them = NULL, k = 1, FUN = NULL, }) on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_local_scan_neighborhood_ecount, graph.them, + R_igraph_local_scan_neighborhood_ecount, + graph.them, if (weighted) as.numeric(E(graph.them)$weight) else NULL, neighborhoods ) } else { sapply( lapply(neighborhoods, induced.subgraph, graph = graph.them), - FUN, ... + FUN, + ... ) } } else { @@ -229,17 +249,22 @@ local_scan <- function(graph.us, graph.them = NULL, k = 1, FUN = NULL, if (k == 0) { on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_local_scan_0_them, graph.us, graph.them, + R_igraph_local_scan_0_them, + graph.us, + graph.them, if (weighted) as.numeric(E(graph.them)$weight) else NULL, cmode ) ## scan-1, ecount - } else if (k == 1 && is.character(FUN) && - FUN %in% c("ecount", "sumweights")) { + } else if ( + k == 1 && is.character(FUN) && FUN %in% c("ecount", "sumweights") + ) { on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_local_scan_1_ecount_them, graph.us, graph.them, + R_igraph_local_scan_1_ecount_them, + graph.us, + graph.them, if (weighted) as.numeric(E(graph.them)$weight) else NULL, cmode ) @@ -248,7 +273,9 @@ local_scan <- function(graph.us, graph.them = NULL, k = 1, FUN = NULL, } else if (is.character(FUN) && FUN %in% c("ecount", "sumweights")) { on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_local_scan_k_ecount_them, graph.us, graph.them, + R_igraph_local_scan_k_ecount_them, + graph.us, + graph.them, as.numeric(k), if (weighted) as.numeric(E(graph.them)$weight) else NULL, cmode @@ -329,8 +356,13 @@ local_scan <- function(graph.us, graph.them = NULL, k = 1, FUN = NULL, #' #' scan_stat(graphs = tsg, k = 1, tau = 4, ell = 2) #' scan_stat(graphs = tsg, locality = "them", k = 1, tau = 4, ell = 2) -scan_stat <- function(graphs, tau = 1, ell = 0, - locality = c("us", "them"), ...) { +scan_stat <- function( + graphs, + tau = 1, + ell = 0, + locality = c("us", "them"), + ... +) { ## List of igraph graphs, all have same directedness and ## weightedness stopifnot( From a0664aa13bcc7668da0f6a80e4afa8d3af335327 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:58:24 +0200 Subject: [PATCH 41/59] sgm --- R/sgm.R | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/R/sgm.R b/R/sgm.R index d7460049f75..2f8b8a30580 100644 --- a/R/sgm.R +++ b/R/sgm.R @@ -4,9 +4,15 @@ solve_LSAP <- function(x, maximum = FALSE) { } nr <- nrow(x) nc <- ncol(x) - if (nr > nc) stop("x must not have more rows than columns.") - if (nc > nr) x <- rbind(x, matrix(2 * sum(x), nc - nr, nc)) - if (maximum) x <- max(x) - x + if (nr > nc) { + stop("x must not have more rows than columns.") + } + if (nc > nr) { + x <- rbind(x, matrix(2 * sum(x), nc - nr, nc)) + } + if (maximum) { + x <- max(x) - x + } storage.mode(x) <- "double" out <- .Call(R_igraph_solve_lsap, x, as.numeric(nc)) + 1L out[seq_len(nr)] From 8cbb888965397b4c6705ea9ac6a343ec75b881e7 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:58:30 +0200 Subject: [PATCH 42/59] similarities --- R/similarity.R | 54 ++++++++++++++++++++++++++++++-------------------- 1 file changed, 33 insertions(+), 21 deletions(-) diff --git a/R/similarity.R b/R/similarity.R index 30273dec513..b86fd2f9c3e 100644 --- a/R/similarity.R +++ b/R/similarity.R @@ -50,16 +50,22 @@ #' g <- make_ring(5) #' similarity(g, method = "dice") #' similarity(g, method = "jaccard") -similarity <- function(graph, vids = V(graph), - mode = c( - "all", "out", "in", - "total" - ), - loops = FALSE, - method = c( - "jaccard", - "dice", "invlogweighted" - )) { +similarity <- function( + graph, + vids = V(graph), + mode = c( + "all", + "out", + "in", + "total" + ), + loops = FALSE, + method = c( + "jaccard", + "dice", + "invlogweighted" + ) +) { method <- igraph.match.arg(method) if (method == "jaccard") { similarity_jaccard_impl(graph, vids, mode, loops) @@ -79,10 +85,12 @@ similarity <- function(graph, vids = V(graph), #' @inheritParams similarity #' @keywords internal #' @export -similarity.jaccard <- function(graph, - vids = V(graph), - mode = c("all", "out", "in", "total"), - loops = FALSE) { +similarity.jaccard <- function( + graph, + vids = V(graph), + mode = c("all", "out", "in", "total"), + loops = FALSE +) { lifecycle::deprecate_soft( "2.1.0", "similarity.jaccard()", @@ -108,10 +116,12 @@ similarity.jaccard <- function(graph, #' @inheritParams similarity #' @keywords internal #' @export -similarity.dice <- function(graph, - vids = V(graph), - mode = c("all", "out", "in", "total"), - loops = FALSE) { +similarity.dice <- function( + graph, + vids = V(graph), + mode = c("all", "out", "in", "total"), + loops = FALSE +) { lifecycle::deprecate_soft( "2.1.0", "similarity.dice()", @@ -137,9 +147,11 @@ similarity.dice <- function(graph, #' @inheritParams similarity #' @keywords internal #' @export -similarity.invlogweighted <- function(graph, - vids = V(graph), - mode = c("all", "out", "in", "total")) { +similarity.invlogweighted <- function( + graph, + vids = V(graph), + mode = c("all", "out", "in", "total") +) { lifecycle::deprecate_soft( "2.1.0", "similarity.invlogweighted()", From 5095b01a0959b8768c83d47e89c72481376f6274 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:58:37 +0200 Subject: [PATCH 43/59] stochastic_matrix --- R/stochastic_matrix.R | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/R/stochastic_matrix.R b/R/stochastic_matrix.R index ef8693bd8a5..f6113d8a86d 100644 --- a/R/stochastic_matrix.R +++ b/R/stochastic_matrix.R @@ -8,7 +8,12 @@ #' @inheritParams stochastic_matrix #' @keywords internal #' @export -get.stochastic <- function(graph, column.wise = FALSE, sparse = igraph_opt("sparsematrices")) { # nocov start +get.stochastic <- function( + graph, + column.wise = FALSE, + sparse = igraph_opt("sparsematrices") +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "get.stochastic()", "stochastic_matrix()") stochastic_matrix(graph = graph, column.wise = column.wise, sparse = sparse) } # nocov end @@ -69,8 +74,11 @@ get.stochastic <- function(graph, column.wise = FALSE, sparse = igraph_opt("spar #' ## may not be exactly 1, due to numerical errors #' max(abs(rowSums(W)) - 1) #' -stochastic_matrix <- function(graph, column.wise = FALSE, - sparse = igraph_opt("sparsematrices")) { +stochastic_matrix <- function( + graph, + column.wise = FALSE, + sparse = igraph_opt("sparsematrices") +) { ensure_igraph(graph) column.wise <- as.logical(column.wise) From 77ad9e486f4d07a72a9f5beaf2f6cb91b18d7107 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:58:48 +0200 Subject: [PATCH 44/59] structural-properties --- R/structural-properties.R | 954 +++++++++++++++++++++++++++----------- 1 file changed, 685 insertions(+), 269 deletions(-) diff --git a/R/structural-properties.R b/R/structural-properties.R index 716fcae8567..4e03068af8c 100644 --- a/R/structural-properties.R +++ b/R/structural-properties.R @@ -8,9 +8,30 @@ #' @inheritParams shortest_paths #' @keywords internal #' @export -get.shortest.paths <- function(graph, from, to = V(graph), mode = c("out", "all", "in"), weights = NULL, output = c("vpath", "epath", "both"), predecessors = FALSE, inbound.edges = FALSE, algorithm = c("automatic", "unweighted", "dijkstra", "bellman-ford")) { # nocov start +get.shortest.paths <- function( + graph, + from, + to = V(graph), + mode = c("out", "all", "in"), + weights = NULL, + output = c("vpath", "epath", "both"), + predecessors = FALSE, + inbound.edges = FALSE, + algorithm = c("automatic", "unweighted", "dijkstra", "bellman-ford") +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "get.shortest.paths()", "shortest_paths()") - shortest_paths(graph = graph, from = from, to = to, mode = mode, weights = weights, output = output, predecessors = predecessors, inbound.edges = inbound.edges, algorithm = algorithm) + shortest_paths( + graph = graph, + from = from, + to = to, + mode = mode, + weights = weights, + output = output, + predecessors = predecessors, + inbound.edges = inbound.edges, + algorithm = algorithm + ) } # nocov end #' Shortest (directed or undirected) paths between vertices @@ -23,9 +44,26 @@ get.shortest.paths <- function(graph, from, to = V(graph), mode = c("out", "all" #' @inheritParams all_shortest_paths #' @keywords internal #' @export -get.all.shortest.paths <- function(graph, from, to = V(graph), mode = c("out", "all", "in"), weights = NULL) { # nocov start - lifecycle::deprecate_soft("2.0.0", "get.all.shortest.paths()", "all_shortest_paths()") - all_shortest_paths(graph = graph, from = from, to = to, mode = mode, weights = weights) +get.all.shortest.paths <- function( + graph, + from, + to = V(graph), + mode = c("out", "all", "in"), + weights = NULL +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "get.all.shortest.paths()", + "all_shortest_paths()" + ) + all_shortest_paths( + graph = graph, + from = from, + to = to, + mode = mode, + weights = weights + ) } # nocov end #' Diameter of a graph @@ -38,9 +76,20 @@ get.all.shortest.paths <- function(graph, from, to = V(graph), mode = c("out", " #' @inheritParams get_diameter #' @keywords internal #' @export -get.diameter <- function(graph, directed = TRUE, unconnected = TRUE, weights = NULL) { # nocov start +get.diameter <- function( + graph, + directed = TRUE, + unconnected = TRUE, + weights = NULL +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "get.diameter()", "get_diameter()") - get_diameter(graph = graph, directed = directed, unconnected = unconnected, weights = weights) + get_diameter( + graph = graph, + directed = directed, + unconnected = unconnected, + weights = weights + ) } # nocov end #' Convert a general graph into a forest @@ -53,7 +102,8 @@ get.diameter <- function(graph, directed = TRUE, unconnected = TRUE, weights = N #' @inheritParams unfold_tree #' @keywords internal #' @export -unfold.tree <- function(graph, mode = c("all", "out", "in", "total"), roots) { # nocov start +unfold.tree <- function(graph, mode = c("all", "out", "in", "total"), roots) { + # nocov start lifecycle::deprecate_soft("2.0.0", "unfold.tree()", "unfold_tree()") unfold_tree(graph = graph, mode = mode, roots = roots) } # nocov end @@ -68,7 +118,8 @@ unfold.tree <- function(graph, mode = c("all", "out", "in", "total"), roots) { # #' @inheritParams topo_sort #' @keywords internal #' @export -topological.sort <- function(graph, mode = c("out", "all", "in")) { # nocov start +topological.sort <- function(graph, mode = c("out", "all", "in")) { + # nocov start lifecycle::deprecate_soft("2.0.0", "topological.sort()", "topo_sort()") topo_sort(graph = graph, mode = mode) } # nocov end @@ -83,11 +134,32 @@ topological.sort <- function(graph, mode = c("out", "all", "in")) { # nocov star #' @inheritParams distances #' @keywords internal #' @export -shortest.paths <- function(graph, v = V(graph), to = V(graph), mode = c("all", "out", "in"), weights = NULL, algorithm = c("automatic", "unweighted", "dijkstra", "bellman-ford", "johnson")) { # nocov start +shortest.paths <- function( + graph, + v = V(graph), + to = V(graph), + mode = c("all", "out", "in"), + weights = NULL, + algorithm = c( + "automatic", + "unweighted", + "dijkstra", + "bellman-ford", + "johnson" + ) +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "shortest.paths()", "distances()") algorithm <- igraph.match.arg(algorithm) mode <- igraph.match.arg(mode) - distances(graph = graph, v = v, to = to, mode = mode, weights = weights, algorithm = algorithm) + distances( + graph = graph, + v = v, + to = to, + mode = mode, + weights = weights, + algorithm = algorithm + ) } # nocov end #' Neighborhood of graph vertices @@ -100,9 +172,22 @@ shortest.paths <- function(graph, v = V(graph), to = V(graph), mode = c("all", " #' @inheritParams ego_size #' @keywords internal #' @export -neighborhood.size <- function(graph, order = 1, nodes = V(graph), mode = c("all", "out", "in"), mindist = 0) { # nocov start +neighborhood.size <- function( + graph, + order = 1, + nodes = V(graph), + mode = c("all", "out", "in"), + mindist = 0 +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "neighborhood.size()", "ego_size()") - ego_size(graph = graph, order = order, nodes = nodes, mode = mode, mindist = mindist) + ego_size( + graph = graph, + order = order, + nodes = nodes, + mode = mode, + mindist = mindist + ) } # nocov end #' Matching @@ -115,9 +200,24 @@ neighborhood.size <- function(graph, order = 1, nodes = V(graph), mode = c("all" #' @inheritParams max_bipartite_match #' @keywords internal #' @export -maximum.bipartite.matching <- function(graph, types = NULL, weights = NULL, eps = .Machine$double.eps) { # nocov start - lifecycle::deprecate_soft("2.0.0", "maximum.bipartite.matching()", "max_bipartite_match()") - max_bipartite_match(graph = graph, types = types, weights = weights, eps = eps) +maximum.bipartite.matching <- function( + graph, + types = NULL, + weights = NULL, + eps = .Machine$double.eps +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "maximum.bipartite.matching()", + "max_bipartite_match()" + ) + max_bipartite_match( + graph = graph, + types = types, + weights = weights, + eps = eps + ) } # nocov end #' Find mutual edges in a directed graph @@ -130,7 +230,8 @@ maximum.bipartite.matching <- function(graph, types = NULL, weights = NULL, eps #' @inheritParams which_mutual #' @keywords internal #' @export -is.mutual <- function(graph, eids = E(graph), loops = TRUE) { # nocov start +is.mutual <- function(graph, eids = E(graph), loops = TRUE) { + # nocov start lifecycle::deprecate_soft("2.0.0", "is.mutual()", "which_mutual()") which_mutual(graph = graph, eids = eids, loops = loops) } # nocov end @@ -145,7 +246,8 @@ is.mutual <- function(graph, eids = E(graph), loops = TRUE) { # nocov start #' @inheritParams which_multiple #' @keywords internal #' @export -is.multiple <- function(graph, eids = E(graph)) { # nocov start +is.multiple <- function(graph, eids = E(graph)) { + # nocov start lifecycle::deprecate_soft("2.0.0", "is.multiple()", "which_multiple()") which_multiple(graph = graph, eids = eids) } # nocov end @@ -160,8 +262,13 @@ is.multiple <- function(graph, eids = E(graph)) { # nocov start #' @inheritParams is_max_matching #' @keywords internal #' @export -is.maximal.matching <- function(graph, matching, types = NULL) { # nocov start - lifecycle::deprecate_soft("2.0.0", "is.maximal.matching()", "is_max_matching()") +is.maximal.matching <- function(graph, matching, types = NULL) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "is.maximal.matching()", + "is_max_matching()" + ) is_max_matching(graph = graph, matching = matching, types = types) } # nocov end @@ -175,7 +282,8 @@ is.maximal.matching <- function(graph, matching, types = NULL) { # nocov start #' @inheritParams is_matching #' @keywords internal #' @export -is.matching <- function(graph, matching, types = NULL) { # nocov start +is.matching <- function(graph, matching, types = NULL) { + # nocov start lifecycle::deprecate_soft("2.0.0", "is.matching()", "is_matching()") is_matching(graph = graph, matching = matching, types = types) } # nocov end @@ -190,7 +298,8 @@ is.matching <- function(graph, matching, types = NULL) { # nocov start #' @inheritParams which_loop #' @keywords internal #' @export -is.loop <- function(graph, eids = E(graph)) { # nocov start +is.loop <- function(graph, eids = E(graph)) { + # nocov start lifecycle::deprecate_soft("2.0.0", "is.loop()", "which_loop()") which_loop(graph = graph, eids = eids) } # nocov end @@ -205,7 +314,8 @@ is.loop <- function(graph, eids = E(graph)) { # nocov start #' @inheritParams is_connected #' @keywords internal #' @export -is.connected <- function(graph, mode = c("weak", "strong")) { # nocov start +is.connected <- function(graph, mode = c("weak", "strong")) { + # nocov start lifecycle::deprecate_soft("2.0.0", "is.connected()", "is_connected()") is_connected(graph = graph, mode = mode) } # nocov end @@ -220,7 +330,12 @@ is.connected <- function(graph, mode = c("weak", "strong")) { # nocov start #' @inheritParams induced_subgraph #' @keywords internal #' @export -induced.subgraph <- function(graph, vids, impl = c("auto", "copy_and_delete", "create_from_scratch")) { # nocov start +induced.subgraph <- function( + graph, + vids, + impl = c("auto", "copy_and_delete", "create_from_scratch") +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "induced.subgraph()", "induced_subgraph()") induced_subgraph(graph = graph, vids = vids, impl = impl) } # nocov end @@ -235,7 +350,8 @@ induced.subgraph <- function(graph, vids, impl = c("auto", "copy_and_delete", "c #' @inheritParams any_multiple #' @keywords internal #' @export -has.multiple <- function(graph) { # nocov start +has.multiple <- function(graph) { + # nocov start lifecycle::deprecate_soft("2.0.0", "has.multiple()", "any_multiple()") any_multiple(graph = graph) } # nocov end @@ -250,9 +366,22 @@ has.multiple <- function(graph) { # nocov start #' @inheritParams make_ego_graph #' @keywords internal #' @export -graph.neighborhood <- function(graph, order = 1, nodes = V(graph), mode = c("all", "out", "in"), mindist = 0) { # nocov start +graph.neighborhood <- function( + graph, + order = 1, + nodes = V(graph), + mode = c("all", "out", "in"), + mindist = 0 +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "graph.neighborhood()", "make_ego_graph()") - make_ego_graph(graph = graph, order = order, nodes = nodes, mode = mode, mindist = mindist) + make_ego_graph( + graph = graph, + order = order, + nodes = nodes, + mode = mode, + mindist = mindist + ) } # nocov end #' Graph Laplacian @@ -265,9 +394,20 @@ graph.neighborhood <- function(graph, order = 1, nodes = V(graph), mode = c("all #' @inheritParams laplacian_matrix #' @keywords internal #' @export -graph.laplacian <- function(graph, normalized = FALSE, weights = NULL, sparse = igraph_opt("sparsematrices")) { # nocov start +graph.laplacian <- function( + graph, + normalized = FALSE, + weights = NULL, + sparse = igraph_opt("sparsematrices") +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "graph.laplacian()", "laplacian_matrix()") - laplacian_matrix(graph = graph, normalized = normalized, weights = weights, sparse = sparse) + laplacian_matrix( + graph = graph, + normalized = normalized, + weights = weights, + sparse = sparse + ) } # nocov end #' Average nearest neighbor degree @@ -280,9 +420,22 @@ graph.laplacian <- function(graph, normalized = FALSE, weights = NULL, sparse = #' @inheritParams knn #' @keywords internal #' @export -graph.knn <- function(graph, vids = V(graph), mode = c("all", "out", "in", "total"), neighbor.degree.mode = c("all", "out", "in", "total"), weights = NULL) { # nocov start +graph.knn <- function( + graph, + vids = V(graph), + mode = c("all", "out", "in", "total"), + neighbor.degree.mode = c("all", "out", "in", "total"), + weights = NULL +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "graph.knn()", "knn()") - knn(graph = graph, vids = vids, mode = mode, neighbor.degree.mode = neighbor.degree.mode, weights = weights) + knn( + graph = graph, + vids = vids, + mode = mode, + neighbor.degree.mode = neighbor.degree.mode, + weights = weights + ) } # nocov end #' Depth-first search @@ -296,9 +449,38 @@ graph.knn <- function(graph, vids = V(graph), mode = c("all", "out", "in", "tota #' @inheritParams dfs #' @keywords internal #' @export -graph.dfs <- function(graph, root, mode = c("out", "in", "all", "total"), unreachable = TRUE, order = TRUE, order.out = FALSE, father = FALSE, dist = FALSE, in.callback = NULL, out.callback = NULL, extra = NULL, rho = parent.frame(), neimode) { # nocov start +graph.dfs <- function( + graph, + root, + mode = c("out", "in", "all", "total"), + unreachable = TRUE, + order = TRUE, + order.out = FALSE, + father = FALSE, + dist = FALSE, + in.callback = NULL, + out.callback = NULL, + extra = NULL, + rho = parent.frame(), + neimode +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "graph.dfs()", "dfs()") - dfs(graph = graph, root = root, mode = mode, unreachable = unreachable, order = order, order.out = order.out, parent = father, dist = dist, in.callback = in.callback, out.callback = out.callback, extra = extra, rho = rho, neimode = neimode) + dfs( + graph = graph, + root = root, + mode = mode, + unreachable = unreachable, + order = order, + order.out = order.out, + parent = father, + dist = dist, + in.callback = in.callback, + out.callback = out.callback, + extra = extra, + rho = rho, + neimode = neimode + ) } # nocov end #' Graph density @@ -311,7 +493,8 @@ graph.dfs <- function(graph, root, mode = c("out", "in", "all", "total"), unreac #' @inheritParams edge_density #' @keywords internal #' @export -graph.density <- function(graph, loops = FALSE) { # nocov start +graph.density <- function(graph, loops = FALSE) { + # nocov start lifecycle::deprecate_soft("2.0.0", "graph.density()", "edge_density()") edge_density(graph = graph, loops = loops) } # nocov end @@ -326,7 +509,8 @@ graph.density <- function(graph, loops = FALSE) { # nocov start #' @inheritParams coreness #' @keywords internal #' @export -graph.coreness <- function(graph, mode = c("all", "out", "in")) { # nocov start +graph.coreness <- function(graph, mode = c("all", "out", "in")) { + # nocov start lifecycle::deprecate_soft("2.0.0", "graph.coreness()", "coreness()") coreness(graph = graph, mode = mode) } # nocov end @@ -342,9 +526,42 @@ graph.coreness <- function(graph, mode = c("all", "out", "in")) { # nocov start #' @param father Logical scalar, whether to return the father of the vertices. #' @keywords internal #' @export -graph.bfs <- function(graph, root, mode = c("out", "in", "all", "total"), unreachable = TRUE, restricted = NULL, order = TRUE, rank = FALSE, father = FALSE, pred = FALSE, succ = FALSE, dist = FALSE, callback = NULL, extra = NULL, rho = parent.frame(), neimode) { # nocov start +graph.bfs <- function( + graph, + root, + mode = c("out", "in", "all", "total"), + unreachable = TRUE, + restricted = NULL, + order = TRUE, + rank = FALSE, + father = FALSE, + pred = FALSE, + succ = FALSE, + dist = FALSE, + callback = NULL, + extra = NULL, + rho = parent.frame(), + neimode +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "graph.bfs()", "bfs()") - bfs(graph = graph, root = root, mode = mode, unreachable = unreachable, restricted = restricted, order = order, rank = rank, parent = father, pred = pred, succ = succ, dist = dist, callback = callback, extra = extra, rho = rho, neimode = neimode) + bfs( + graph = graph, + root = root, + mode = mode, + unreachable = unreachable, + restricted = restricted, + order = order, + rank = rank, + parent = father, + pred = pred, + succ = succ, + dist = dist, + callback = callback, + extra = extra, + rho = rho, + neimode = neimode + ) } # nocov end #' Diameter of a graph @@ -357,9 +574,20 @@ graph.bfs <- function(graph, root, mode = c("out", "in", "all", "total"), unreac #' @inheritParams farthest_vertices #' @keywords internal #' @export -farthest.nodes <- function(graph, directed = TRUE, unconnected = TRUE, weights = NULL) { # nocov start +farthest.nodes <- function( + graph, + directed = TRUE, + unconnected = TRUE, + weights = NULL +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "farthest.nodes()", "farthest_vertices()") - farthest_vertices(graph = graph, directed = directed, unconnected = unconnected, weights = weights) + farthest_vertices( + graph = graph, + directed = directed, + unconnected = unconnected, + weights = weights + ) } # nocov end #' Degree and degree distribution of the vertices @@ -372,8 +600,13 @@ farthest.nodes <- function(graph, directed = TRUE, unconnected = TRUE, weights = #' @inheritParams degree_distribution #' @keywords internal #' @export -degree.distribution <- function(graph, cumulative = FALSE, ...) { # nocov start - lifecycle::deprecate_soft("2.0.0", "degree.distribution()", "degree_distribution()") +degree.distribution <- function(graph, cumulative = FALSE, ...) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "degree.distribution()", + "degree_distribution()" + ) degree_distribution(graph = graph, cumulative = cumulative, ...) } # nocov end @@ -387,7 +620,8 @@ degree.distribution <- function(graph, cumulative = FALSE, ...) { # nocov start #' @inheritParams count_multiple #' @keywords internal #' @export -count.multiple <- function(graph, eids = E(graph)) { # nocov start +count.multiple <- function(graph, eids = E(graph)) { + # nocov start lifecycle::deprecate_soft("2.0.0", "count.multiple()", "count_multiple()") count_multiple(graph = graph, eids = eids) } # nocov end @@ -402,7 +636,8 @@ count.multiple <- function(graph, eids = E(graph)) { # nocov start #' @inheritParams components #' @keywords internal #' @export -clusters <- function(graph, mode = c("weak", "strong")) { # nocov start +clusters <- function(graph, mode = c("weak", "strong")) { + # nocov start lifecycle::deprecate_soft("2.0.0", "clusters()", "components()") components(graph = graph, mode = mode) } # nocov end @@ -417,9 +652,22 @@ clusters <- function(graph, mode = c("weak", "strong")) { # nocov start #' @inheritParams mean_distance #' @keywords internal #' @export -average.path.length <- function(graph, weights = NULL, directed = TRUE, unconnected = TRUE, details = FALSE) { # nocov start +average.path.length <- function( + graph, + weights = NULL, + directed = TRUE, + unconnected = TRUE, + details = FALSE +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "average.path.length()", "mean_distance()") - mean_distance(graph = graph, weights = weights, directed = directed, unconnected = unconnected, details = details) + mean_distance( + graph = graph, + weights = weights, + directed = directed, + unconnected = unconnected, + details = details + ) } # nocov end # IGraph R package # Copyright (C) 2005-2012 Gabor Csardi @@ -446,8 +694,6 @@ average.path.length <- function(graph, weights = NULL, directed = TRUE, unconnec # Structural properties ################################################################### - - #' Diameter of a graph #' #' The diameter of a graph is the length of the longest geodesic. @@ -504,7 +750,12 @@ average.path.length <- function(graph, weights = NULL, directed = TRUE, unconnec #' diameter(g, weights = NA) #' get_diameter(g, weights = NA) #' -diameter <- function(graph, directed = TRUE, unconnected = TRUE, weights = NULL) { +diameter <- function( + graph, + directed = TRUE, + unconnected = TRUE, + weights = NULL +) { ensure_igraph(graph) if (is.null(weights) && "weight" %in% edge_attr_names(graph)) { @@ -518,15 +769,22 @@ diameter <- function(graph, directed = TRUE, unconnected = TRUE, weights = NULL) on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_diameter, graph, as.logical(directed), - as.logical(unconnected), weights + R_igraph_diameter, + graph, + as.logical(directed), + as.logical(unconnected), + weights ) } #' @rdname diameter #' @export -get_diameter <- function(graph, directed = TRUE, unconnected = TRUE, - weights = NULL) { +get_diameter <- function( + graph, + directed = TRUE, + unconnected = TRUE, + weights = NULL +) { ensure_igraph(graph) if (is.null(weights) && "weight" %in% edge_attr_names(graph)) { @@ -540,9 +798,13 @@ get_diameter <- function(graph, directed = TRUE, unconnected = TRUE, on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_get_diameter, graph, as.logical(directed), - as.logical(unconnected), weights - ) + 1L + R_igraph_get_diameter, + graph, + as.logical(directed), + as.logical(unconnected), + weights + ) + + 1L if (igraph_opt("return.vs.es")) { res <- create_vs(graph, res) @@ -553,8 +815,12 @@ get_diameter <- function(graph, directed = TRUE, unconnected = TRUE, #' @rdname diameter #' @export -farthest_vertices <- function(graph, directed = TRUE, unconnected = TRUE, - weights = NULL) { +farthest_vertices <- function( + graph, + directed = TRUE, + unconnected = TRUE, + weights = NULL +) { ensure_igraph(graph) if (is.null(weights) && "weight" %in% edge_attr_names(graph)) { @@ -568,8 +834,11 @@ farthest_vertices <- function(graph, directed = TRUE, unconnected = TRUE, on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_farthest_points, graph, as.logical(directed), - as.logical(unconnected), weights + R_igraph_farthest_points, + graph, + as.logical(directed), + as.logical(unconnected), + weights ) res <- list(vertices = res[1:2] + 1L, distance = res[3]) @@ -586,7 +855,6 @@ farthest_vertices <- function(graph, directed = TRUE, unconnected = TRUE, mean_distance <- average_path_length_dijkstra_impl - #' Degree and degree distribution of the vertices #' #' The degree of a vertex is its most basic structural property, the number of @@ -625,23 +893,25 @@ mean_distance <- average_path_length_dijkstra_impl #' max_degree(g2) #' degree_distribution(g2) #' -degree <- function(graph, v = V(graph), - mode = c("all", "out", "in", "total"), loops = TRUE, - normalized = FALSE) { +degree <- function( + graph, + v = V(graph), + mode = c("all", "out", "in", "total"), + loops = TRUE, + normalized = FALSE +) { ensure_igraph(graph) v <- as_igraph_vs(graph, v) mode <- igraph.match.arg(mode) - mode <- switch(mode, - "out" = 1, - "in" = 2, - "all" = 3, - "total" = 3 - ) + mode <- switch(mode, "out" = 1, "in" = 2, "all" = 3, "total" = 3) on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_degree, graph, v - 1, - as.numeric(mode), as.logical(loops) + R_igraph_degree, + graph, + v - 1, + as.numeric(mode), + as.logical(loops) ) if (normalized) { res <- res / (vcount(graph) - 1) @@ -676,7 +946,6 @@ degree_distribution <- function(graph, cumulative = FALSE, ...) { } - #' Shortest (directed or undirected) paths between vertices #' #' `distances()` calculates the length of all the shortest paths from @@ -880,13 +1149,21 @@ degree_distribution <- function(graph, cumulative = FALSE, ...) { #' g2 <- add_edges(make_empty_graph(10), t(el[, 1:2]), weight = el[, 3]) #' distances(g2, mode = "out") #' -distances <- function(graph, v = V(graph), to = V(graph), - mode = c("all", "out", "in"), - weights = NULL, - algorithm = c( - "automatic", "unweighted", "dijkstra", - "bellman-ford", "johnson", "floyd-warshall" - )) { +distances <- function( + graph, + v = V(graph), + to = V(graph), + mode = c("all", "out", "in"), + weights = NULL, + algorithm = c( + "automatic", + "unweighted", + "dijkstra", + "bellman-ford", + "johnson", + "floyd-warshall" + ) +) { ensure_igraph(graph) # make sure that the lower-level function in C gets mode == "out" @@ -899,13 +1176,10 @@ distances <- function(graph, v = V(graph), to = V(graph), v <- as_igraph_vs(graph, v) to <- as_igraph_vs(graph, to) mode <- igraph.match.arg(mode) - mode <- switch(mode, - "out" = 1, - "in" = 2, - "all" = 3 - ) + mode <- switch(mode, "out" = 1, "in" = 2, "all" = 3) algorithm <- igraph.match.arg(algorithm) - algorithm <- switch(algorithm, + algorithm <- switch( + algorithm, "automatic" = 0, "unweighted" = 1, "dijkstra" = 2, @@ -933,8 +1207,13 @@ distances <- function(graph, v = V(graph), to = V(graph), on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_shortest_paths, graph, v - 1, to - 1, - as.numeric(mode), weights, as.numeric(algorithm) + R_igraph_shortest_paths, + graph, + v - 1, + to - 1, + as.numeric(mode), + weights, + as.numeric(algorithm) ) if (igraph_opt("add.vertex.names") && is_named(graph)) { @@ -967,27 +1246,25 @@ distances <- function(graph, v = V(graph), to = V(graph), #' the vector. Note that the search terminates if all the vertices in `to` #' are reached. #' @export -shortest_paths <- function(graph, from, to = V(graph), - mode = c("out", "all", "in"), - weights = NULL, - output = c("vpath", "epath", "both"), - predecessors = FALSE, inbound.edges = FALSE, - algorithm = c("automatic", "unweighted", "dijkstra", "bellman-ford")) { +shortest_paths <- function( + graph, + from, + to = V(graph), + mode = c("out", "all", "in"), + weights = NULL, + output = c("vpath", "epath", "both"), + predecessors = FALSE, + inbound.edges = FALSE, + algorithm = c("automatic", "unweighted", "dijkstra", "bellman-ford") +) { ensure_igraph(graph) mode <- igraph.match.arg(mode) - mode <- switch(mode, - "out" = 1, - "in" = 2, - "all" = 3 - ) + mode <- switch(mode, "out" = 1, "in" = 2, "all" = 3) output <- igraph.match.arg(output) - output <- switch(output, - "vpath" = 0, - "epath" = 1, - "both" = 2 - ) + output <- switch(output, "vpath" = 0, "epath" = 1, "both" = 2) algorithm <- igraph.match.arg(algorithm) - algorithm <- switch(algorithm, + algorithm <- switch( + algorithm, "automatic" = 0, "unweighted" = 1, "dijkstra" = 2, @@ -1014,10 +1291,16 @@ shortest_paths <- function(graph, from, to = V(graph), to <- as_igraph_vs(graph, to) - 1 on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_get_shortest_paths, graph, - as_igraph_vs(graph, from) - 1, to, as.numeric(mode), - as.numeric(length(to)), weights, as.numeric(output), - as.logical(predecessors), as.logical(inbound.edges), + R_igraph_get_shortest_paths, + graph, + as_igraph_vs(graph, from) - 1, + to, + as.numeric(mode), + as.numeric(length(to)), + weights, + as.numeric(output), + as.logical(predecessors), + as.logical(inbound.edges), as.numeric(algorithm) ) @@ -1036,19 +1319,31 @@ shortest_paths <- function(graph, from, to = V(graph), if (igraph_opt("return.vs.es")) { if (!is.null(res$vpath)) { - res$vpath <- lapply(res$vpath, unsafe_create_vs, graph = graph, verts = V(graph)) + res$vpath <- lapply( + res$vpath, + unsafe_create_vs, + graph = graph, + verts = V(graph) + ) } if (!is.null(res$epath)) { - res$epath <- lapply(res$epath, unsafe_create_es, graph = graph, es = E(graph)) + res$epath <- lapply( + res$epath, + unsafe_create_es, + graph = graph, + es = E(graph) + ) } if (!is.null(res$predecessors)) { - res$predecessors <- create_vs(res$predecessors, + res$predecessors <- create_vs( + res$predecessors, graph = graph, na_ok = TRUE ) } if (!is.null(res$inbound_edges)) { - res$inbound_edges <- create_es(res$inbound_edges, + res$inbound_edges <- create_es( + res$inbound_edges, graph = graph, na_ok = TRUE ) @@ -1060,17 +1355,16 @@ shortest_paths <- function(graph, from, to = V(graph), #' @export #' @rdname distances -all_shortest_paths <- function(graph, from, - to = V(graph), - mode = c("out", "all", "in"), - weights = NULL) { +all_shortest_paths <- function( + graph, + from, + to = V(graph), + mode = c("out", "all", "in"), + weights = NULL +) { ensure_igraph(graph) mode <- igraph.match.arg(mode) - mode <- switch(mode, - "out" = 1, - "in" = 2, - "all" = 3 - ) + mode <- switch(mode, "out" = 1, "in" = 2, "all" = 3) if (is.null(weights)) { if ("weight" %in% edge_attr_names(graph)) { @@ -1087,20 +1381,30 @@ all_shortest_paths <- function(graph, from, on.exit(.Call(R_igraph_finalizer)) if (is.null(weights)) { res <- .Call( - R_igraph_get_all_shortest_paths, graph, - as_igraph_vs(graph, from) - 1, as_igraph_vs(graph, to) - 1, + R_igraph_get_all_shortest_paths, + graph, + as_igraph_vs(graph, from) - 1, + as_igraph_vs(graph, to) - 1, as.numeric(mode) ) } else { res <- .Call( - R_igraph_get_all_shortest_paths_dijkstra, graph, - as_igraph_vs(graph, from) - 1, as_igraph_vs(graph, to) - 1, - weights, as.numeric(mode) + R_igraph_get_all_shortest_paths_dijkstra, + graph, + as_igraph_vs(graph, from) - 1, + as_igraph_vs(graph, to) - 1, + weights, + as.numeric(mode) ) } if (igraph_opt("return.vs.es")) { - res$vpaths <- lapply(res$vpaths, unsafe_create_vs, graph = graph, verts = V(graph)) + res$vpaths <- lapply( + res$vpaths, + unsafe_create_vs, + graph = graph, + verts = V(graph) + ) } # Transitional, eventually, remove $res @@ -1173,19 +1477,20 @@ k_shortest_paths <- get_k_shortest_paths_impl subcomponent <- function(graph, v, mode = c("all", "out", "in")) { ensure_igraph(graph) mode <- igraph.match.arg(mode) - mode <- switch(mode, - "out" = 1, - "in" = 2, - "all" = 3 - ) + mode <- switch(mode, "out" = 1, "in" = 2, "all" = 3) on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_subcomponent, graph, as_igraph_vs(graph, v) - 1, + R_igraph_subcomponent, + graph, + as_igraph_vs(graph, v) - 1, as.numeric(mode) - ) + 1L + ) + + 1L - if (igraph_opt("return.vs.es")) res <- create_vs(graph, res) + if (igraph_opt("return.vs.es")) { + res <- create_vs(graph, res) + } res } @@ -1237,11 +1542,16 @@ subgraph <- function(graph, vids) { #' automatically, using heuristics based on the size of the original and the #' result graph. #' @export -induced_subgraph <- function(graph, vids, impl = c("auto", "copy_and_delete", "create_from_scratch")) { +induced_subgraph <- function( + graph, + vids, + impl = c("auto", "copy_and_delete", "create_from_scratch") +) { # Argument checks ensure_igraph(graph) vids <- as_igraph_vs(graph, vids) - impl <- switch(igraph.match.arg(impl), + impl <- switch( + igraph.match.arg(impl), "auto" = 0L, "copy_and_delete" = 1L, "create_from_scratch" = 2L @@ -1282,9 +1592,18 @@ subgraph_from_edges <- function(graph, eids, delete.vertices = TRUE) { #' @inheritParams subgraph_from_edges #' @keywords internal #' @export -subgraph.edges <- function(graph, eids, delete.vertices = TRUE) { # nocov start - lifecycle::deprecate_soft("2.1.0", "subgraph.edges()", "subgraph_from_edges()") - subgraph_from_edges(graph = graph, eids = eids, delete.vertices = delete.vertices) +subgraph.edges <- function(graph, eids, delete.vertices = TRUE) { + # nocov start + lifecycle::deprecate_soft( + "2.1.0", + "subgraph.edges()", + "subgraph_from_edges()" + ) + subgraph_from_edges( + graph = graph, + eids = eids, + delete.vertices = delete.vertices + ) } # nocov end @@ -1401,16 +1720,28 @@ subgraph.edges <- function(graph, eids, delete.vertices = TRUE) { # nocov start #' all(is.na(t1) == is.na(t2)) #' all(na.omit(t1 == t2)) #' -transitivity <- function(graph, type = c( - "undirected", "global", "globalundirected", - "localundirected", "local", "average", - "localaverage", "localaverageundirected", - "barrat", "weighted" - ), - vids = NULL, weights = NULL, isolates = c("NaN", "zero")) { +transitivity <- function( + graph, + type = c( + "undirected", + "global", + "globalundirected", + "localundirected", + "local", + "average", + "localaverage", + "localaverageundirected", + "barrat", + "weighted" + ), + vids = NULL, + weights = NULL, + isolates = c("NaN", "zero") +) { ensure_igraph(graph) type <- igraph.match.arg(type) - type <- switch(type, + type <- switch( + type, "undirected" = 0L, "global" = 0L, "globalundirected" = 0L, @@ -1433,10 +1764,7 @@ transitivity <- function(graph, type = c( } isolates <- igraph.match.arg(isolates) - isolates <- as.double(switch(isolates, - "nan" = 0, - "zero" = 1 - )) + isolates <- as.double(switch(isolates, "nan" = 0, "zero" = 1)) on.exit(.Call(R_igraph_finalizer)) if (type == 0) { @@ -1451,7 +1779,9 @@ transitivity <- function(graph, type = c( } else { vids <- as_igraph_vs(graph, vids) res <- .Call( - R_igraph_transitivity_local_undirected, graph, vids - 1, + R_igraph_transitivity_local_undirected, + graph, + vids - 1, isolates ) if (igraph_opt("add.vertex.names") && is_named(graph)) { @@ -1468,12 +1798,17 @@ transitivity <- function(graph, type = c( vids <- as_igraph_vs(graph, vids) res <- if (is.null(weights)) { .Call( - R_igraph_transitivity_local_undirected, graph, vids - 1, + R_igraph_transitivity_local_undirected, + graph, + vids - 1, isolates ) } else { .Call( - R_igraph_transitivity_barrat, graph, vids - 1, weights, + R_igraph_transitivity_barrat, + graph, + vids - 1, + weights, isolates ) } @@ -1546,7 +1881,6 @@ constraint <- function(graph, nodes = V(graph), weights = NULL) { } - #' Reciprocity of graphs #' #' Calculates the reciprocity of a directed graph. @@ -1626,21 +1960,25 @@ edge_density <- density_impl #' @rdname ego #' @export -ego_size <- function(graph, order = 1, nodes = V(graph), - mode = c("all", "out", "in"), mindist = 0) { +ego_size <- function( + graph, + order = 1, + nodes = V(graph), + mode = c("all", "out", "in"), + mindist = 0 +) { ensure_igraph(graph) mode <- igraph.match.arg(mode) - mode <- switch(mode, - "out" = 1, - "in" = 2, - "all" = 3 - ) + mode <- switch(mode, "out" = 1, "in" = 2, "all" = 3) mindist <- as.numeric(mindist) on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_neighborhood_size, graph, - as_igraph_vs(graph, nodes) - 1, as.numeric(order), as.numeric(mode), + R_igraph_neighborhood_size, + graph, + as_igraph_vs(graph, nodes) - 1, + as.numeric(order), + as.numeric(mode), mindist ) } @@ -1736,22 +2074,26 @@ neighborhood_size <- ego_size #' g <- make_ring(10) #' g <- connect(g, 2) #' -ego <- function(graph, order = 1, nodes = V(graph), - mode = c("all", "out", "in"), mindist = 0) { +ego <- function( + graph, + order = 1, + nodes = V(graph), + mode = c("all", "out", "in"), + mindist = 0 +) { ensure_igraph(graph) mode <- igraph.match.arg(mode) - mode <- switch(mode, - "out" = 1, - "in" = 2, - "all" = 3 - ) + mode <- switch(mode, "out" = 1, "in" = 2, "all" = 3) mindist <- as.numeric(mindist) on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_neighborhood, graph, - as_igraph_vs(graph, nodes) - 1, as.numeric(order), - as.numeric(mode), mindist + R_igraph_neighborhood, + graph, + as_igraph_vs(graph, nodes) - 1, + as.numeric(order), + as.numeric(mode), + mindist ) res <- lapply(res, function(x) x + 1) @@ -1767,22 +2109,26 @@ ego <- function(graph, order = 1, nodes = V(graph), neighborhood <- ego #' @rdname ego #' @export -make_ego_graph <- function(graph, order = 1, nodes = V(graph), - mode = c("all", "out", "in"), mindist = 0) { +make_ego_graph <- function( + graph, + order = 1, + nodes = V(graph), + mode = c("all", "out", "in"), + mindist = 0 +) { ensure_igraph(graph) mode <- igraph.match.arg(mode) - mode <- switch(mode, - "out" = 1L, - "in" = 2L, - "all" = 3L - ) + mode <- switch(mode, "out" = 1L, "in" = 2L, "all" = 3L) mindist <- as.numeric(mindist) on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_neighborhood_graphs, graph, - as_igraph_vs(graph, nodes) - 1, as.numeric(order), - as.integer(mode), mindist + R_igraph_neighborhood_graphs, + graph, + as_igraph_vs(graph, nodes) - 1, + as.numeric(order), + as.integer(mode), + mindist ) res } @@ -1829,11 +2175,7 @@ make_neighborhood_graph <- make_ego_graph coreness <- function(graph, mode = c("all", "out", "in")) { ensure_igraph(graph) mode <- igraph.match.arg(mode) - mode <- switch(mode, - "out" = 1, - "in" = 2, - "all" = 3 - ) + mode <- switch(mode, "out" = 1, "in" = 2, "all" = 3) on.exit(.Call(R_igraph_finalizer)) res <- .Call(R_igraph_coreness, graph, as.numeric(mode)) @@ -1844,7 +2186,6 @@ coreness <- function(graph, mode = c("all", "out", "in")) { } - #' Topological sorting of vertices in a graph #' #' A topological sorting of a directed acyclic graph is a linear ordering of @@ -1877,16 +2218,14 @@ coreness <- function(graph, mode = c("all", "out", "in")) { topo_sort <- function(graph, mode = c("out", "all", "in")) { ensure_igraph(graph) mode <- igraph.match.arg(mode) - mode <- switch(mode, - "out" = 1, - "in" = 2, - "all" = 3 - ) + mode <- switch(mode, "out" = 1, "in" = 2, "all" = 3) on.exit(.Call(R_igraph_finalizer)) res <- .Call(R_igraph_topological_sorting, graph, as.numeric(mode)) + 1L - if (igraph_opt("return.vs.es")) res <- create_vs(graph, res) + if (igraph_opt("return.vs.es")) { + res <- create_vs(graph, res) + } res } @@ -2234,24 +2573,24 @@ any_loop <- has_loop_impl #' bfs(make_ring(10) %du% make_ring(10), root = 1, callback = f) #' bfs <- function( - graph, - root, - mode = c("out", "in", "all", "total"), - ..., - unreachable = TRUE, - restricted = NULL, - order = TRUE, - rank = FALSE, - parent = FALSE, - pred = FALSE, - succ = FALSE, - dist = FALSE, - callback = NULL, - extra = NULL, - rho = parent.frame(), - neimode = deprecated(), - father = deprecated()) { - + graph, + root, + mode = c("out", "in", "all", "total"), + ..., + unreachable = TRUE, + restricted = NULL, + order = TRUE, + rank = FALSE, + parent = FALSE, + pred = FALSE, + succ = FALSE, + dist = FALSE, + callback = NULL, + extra = NULL, + rho = parent.frame(), + neimode = deprecated(), + father = deprecated() +) { rlang::check_dots_empty() ensure_igraph(graph) @@ -2278,7 +2617,8 @@ bfs <- function( roots <- as_igraph_vs(graph, root) - 1 root <- 0 # ignored anyway } - mode <- switch(igraph.match.arg(mode), + mode <- switch( + igraph.match.arg(mode), "out" = 1, "in" = 2, "all" = 3, @@ -2294,36 +2634,71 @@ bfs <- function( on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_bfs, graph, root, roots, mode, unreachable, + R_igraph_bfs, + graph, + root, + roots, + mode, + unreachable, restricted, - as.logical(order), as.logical(rank), as.logical(parent), - as.logical(pred), as.logical(succ), as.logical(dist), - callback, extra, rho + as.logical(order), + as.logical(rank), + as.logical(parent), + as.logical(pred), + as.logical(succ), + as.logical(dist), + callback, + extra, + rho ) # Remove in 1.4.0 res$neimode <- res$mode - if (order) res$order <- res$order + 1 - if (rank) res$rank <- res$rank + 1 - if (parent) res$parent <- res$parent + 1 - if (pred) res$pred <- res$pred + 1 - if (succ) res$succ <- res$succ + 1 + if (order) { + res$order <- res$order + 1 + } + if (rank) { + res$rank <- res$rank + 1 + } + if (parent) { + res$parent <- res$parent + 1 + } + if (pred) { + res$pred <- res$pred + 1 + } + if (succ) { + res$succ <- res$succ + 1 + } if (igraph_opt("return.vs.es")) { - if (order) res$order <- V(graph)[.env$res$order, na_ok = TRUE] - if (parent) res$parent <- create_vs(graph, res$parent, na_ok = TRUE) - if (pred) res$pred <- create_vs(graph, res$pred, na_ok = TRUE) + if (order) { + res$order <- V(graph)[.env$res$order, na_ok = TRUE] + } + if (parent) { + res$parent <- create_vs(graph, res$parent, na_ok = TRUE) + } + if (pred) { + res$pred <- create_vs(graph, res$pred, na_ok = TRUE) + } if (succ) res$succ <- create_vs(graph, res$succ, na_ok = TRUE) } else { if (order) res$order <- res$order[res$order != 0] } if (igraph_opt("add.vertex.names") && is_named(graph)) { - if (rank) names(res$rank) <- V(graph)$name - if (parent) names(res$parent) <- V(graph)$name - if (pred) names(res$pred) <- V(graph)$name - if (succ) names(res$succ) <- V(graph)$name + if (rank) { + names(res$rank) <- V(graph)$name + } + if (parent) { + names(res$parent) <- V(graph)$name + } + if (pred) { + names(res$pred) <- V(graph)$name + } + if (succ) { + names(res$succ) <- V(graph)$name + } if (dist) names(res$dist) <- V(graph)$name } @@ -2342,7 +2717,6 @@ bfs <- function( } - #' Depth-first search #' #' Depth-first search is an algorithm to traverse a graph. It starts from a @@ -2463,15 +2837,23 @@ bfs <- function( #' out.callback = f.out #' ) #' -dfs <- function(graph, root, mode = c("out", "in", "all", "total"), - ..., - unreachable = TRUE, - order = TRUE, order.out = FALSE, - parent = FALSE, dist = FALSE, - in.callback = NULL, out.callback = NULL, extra = NULL, - rho = parent.frame(), neimode = deprecated(), - father = deprecated()) { - +dfs <- function( + graph, + root, + mode = c("out", "in", "all", "total"), + ..., + unreachable = TRUE, + order = TRUE, + order.out = FALSE, + parent = FALSE, + dist = FALSE, + in.callback = NULL, + out.callback = NULL, + extra = NULL, + rho = parent.frame(), + neimode = deprecated(), + father = deprecated() +) { rlang::check_dots_empty() ensure_igraph(graph) @@ -2491,7 +2873,8 @@ dfs <- function(graph, root, mode = c("out", "in", "all", "total"), } root <- as_igraph_vs(graph, root) - 1 - mode <- switch(igraph.match.arg(mode), + mode <- switch( + igraph.match.arg(mode), "out" = 1, "in" = 2, "all" = 3, @@ -2507,29 +2890,53 @@ dfs <- function(graph, root, mode = c("out", "in", "all", "total"), on.exit(.Call(R_igraph_finalizer)) res <- .Call( - R_igraph_dfs, graph, root, mode, unreachable, - as.logical(order), as.logical(order.out), as.logical(parent), - as.logical(dist), in.callback, out.callback, extra, rho + R_igraph_dfs, + graph, + root, + mode, + unreachable, + as.logical(order), + as.logical(order.out), + as.logical(parent), + as.logical(dist), + in.callback, + out.callback, + extra, + rho ) # Remove in 1.4.0 res$neimode <- res$mode - if (order) res$order <- res$order + 1 - if (order.out) res$order.out <- res$order.out + 1 - if (parent) res$parent <- res$parent + 1 + if (order) { + res$order <- res$order + 1 + } + if (order.out) { + res$order.out <- res$order.out + 1 + } + if (parent) { + res$parent <- res$parent + 1 + } if (igraph_opt("return.vs.es")) { - if (order) res$order <- V(graph)[.env$res$order, na_ok = TRUE] - if (order.out) res$order.out <- V(graph)[.env$res$order.out, na_ok = TRUE] + if (order) { + res$order <- V(graph)[.env$res$order, na_ok = TRUE] + } + if (order.out) { + res$order.out <- V(graph)[.env$res$order.out, na_ok = TRUE] + } if (parent) res$parent <- create_vs(graph, res$parent, na_ok = TRUE) } else { - if (order) res$order <- res$order[res$order != 0] + if (order) { + res$order <- res$order[res$order != 0] + } if (order.out) res$order.out <- res$order.out[res$order.out != 0] } if (igraph_opt("add.vertex.names") && is_named(graph)) { - if (parent) names(res$parent) <- V(graph)$name + if (parent) { + names(res$parent) <- V(graph)$name + } if (dist) names(res$dist) <- V(graph)$name } @@ -2607,10 +3014,7 @@ dfs <- function(graph, root, mode = c("out", "in", "all", "total"), components <- function(graph, mode = c("weak", "strong")) { # Argument checks ensure_igraph(graph) - mode <- switch(igraph.match.arg(mode), - "weak" = 1, - "strong" = 2 - ) + mode <- switch(igraph.match.arg(mode), "weak" = 1, "strong" = 2) on.exit(.Call(R_igraph_finalizer)) # Function call @@ -2633,10 +3037,7 @@ is_connected <- is_connected_impl count_components <- function(graph, mode = c("weak", "strong")) { ensure_igraph(graph) mode <- igraph.match.arg(mode) - mode <- switch(mode, - "weak" = 1L, - "strong" = 2L - ) + mode <- switch(mode, "weak" = 1L, "strong" = 2L) on.exit(.Call(R_igraph_finalizer)) .Call(R_igraph_no_components, graph, mode) @@ -2684,7 +3085,8 @@ count_components <- function(graph, mode = c("weak", "strong")) { unfold_tree <- function(graph, mode = c("all", "out", "in", "total"), roots) { # Argument checks ensure_igraph(graph) - mode <- switch(igraph.match.arg(mode), + mode <- switch( + igraph.match.arg(mode), "out" = 1, "in" = 2, "all" = 3, @@ -2752,14 +3154,21 @@ unfold_tree <- function(graph, mode = c("all", "out", "in", "total"), roots) { #' #' @cdocs igraph_get_laplacian #' @cdocs igraph_get_laplacian_sparse -laplacian_matrix <- function(graph, weights = NULL, - sparse = igraph_opt("sparsematrices"), normalization = c("unnormalized", "symmetric", "left", "right"), normalized) { +laplacian_matrix <- function( + graph, + weights = NULL, + sparse = igraph_opt("sparsematrices"), + normalization = c("unnormalized", "symmetric", "left", "right"), + normalized +) { # Argument checks if (lifecycle::is_present(normalized)) { lifecycle::deprecate_soft( "2.0.3", "make_lattice(normalized = 'provide normalization instead')", - details = c("`normalized` is now deprecated, use `normalization` instead.") + details = c( + "`normalized` is now deprecated, use `normalization` instead." + ) ) normalized <- as.logical(normalized) @@ -2926,8 +3335,12 @@ is_max_matching <- function(graph, matching, types = NULL) { #' @export #' @rdname matching -max_bipartite_match <- function(graph, types = NULL, weights = NULL, - eps = .Machine$double.eps) { +max_bipartite_match <- function( + graph, + types = NULL, + weights = NULL, + eps = .Machine$double.eps +) { # Argument checks ensure_igraph(graph) types <- handle_vertex_type_arg(types, graph) @@ -2944,8 +3357,11 @@ max_bipartite_match <- function(graph, types = NULL, weights = NULL, on.exit(.Call(R_igraph_finalizer)) # Function call res <- .Call( - R_igraph_maximum_bipartite_matching, graph, types, - weights, eps + R_igraph_maximum_bipartite_matching, + graph, + types, + weights, + eps ) res$matching[res$matching == 0] <- NA From cea2e314ab35acd23146e7551a36a307c2c664d4 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 13:58:54 +0200 Subject: [PATCH 45/59] structure.info --- R/structure.info.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/structure.info.R b/R/structure.info.R index 4f605e03265..f358d441165 100644 --- a/R/structure.info.R +++ b/R/structure.info.R @@ -8,7 +8,8 @@ #' @inheritParams are_adjacent #' @keywords internal #' @export -are.connected <- function(graph, v1, v2) { # nocov start +are.connected <- function(graph, v1, v2) { + # nocov start lifecycle::deprecate_soft("2.0.0", "are.connected()", "are_adjacent()") are_adjacent(graph = graph, v1 = v1, v2 = v2) } # nocov end From 46b8fa231fd3e891ef4eba5b571a81a94e111485 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 14:00:53 +0200 Subject: [PATCH 46/59] tkplot --- R/tkplot.R | 794 ++++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 567 insertions(+), 227 deletions(-) diff --git a/R/tkplot.R b/R/tkplot.R index acc2f722ef9..37f24efab1a 100644 --- a/R/tkplot.R +++ b/R/tkplot.R @@ -8,7 +8,8 @@ #' @inheritParams tk_set_coords #' @keywords internal #' @export -tkplot.setcoords <- function(tkp.id, coords) { # nocov start +tkplot.setcoords <- function(tkp.id, coords) { + # nocov start lifecycle::deprecate_soft("2.0.0", "tkplot.setcoords()", "tk_set_coords()") tk_set_coords(tkp.id = tkp.id, coords = coords) } # nocov end @@ -23,7 +24,8 @@ tkplot.setcoords <- function(tkp.id, coords) { # nocov start #' @inheritParams tk_rotate #' @keywords internal #' @export -tkplot.rotate <- function(tkp.id, degree = NULL, rad = NULL) { # nocov start +tkplot.rotate <- function(tkp.id, degree = NULL, rad = NULL) { + # nocov start lifecycle::deprecate_soft("2.0.0", "tkplot.rotate()", "tk_rotate()") tk_rotate(tkp.id = tkp.id, degree = degree, rad = rad) } # nocov end @@ -38,7 +40,8 @@ tkplot.rotate <- function(tkp.id, degree = NULL, rad = NULL) { # nocov start #' @inheritParams tk_reshape #' @keywords internal #' @export -tkplot.reshape <- function(tkp.id, newlayout, ..., params) { # nocov start +tkplot.reshape <- function(tkp.id, newlayout, ..., params) { + # nocov start lifecycle::deprecate_soft("2.0.0", "tkplot.reshape()", "tk_reshape()") tk_reshape(tkp.id = tkp.id, newlayout = newlayout, params = params, ...) } # nocov end @@ -53,7 +56,8 @@ tkplot.reshape <- function(tkp.id, newlayout, ..., params) { # nocov start #' #' @keywords internal #' @export -tkplot.off <- function() { # nocov start +tkplot.off <- function() { + # nocov start lifecycle::deprecate_soft("2.0.0", "tkplot.off()", "tk_off()") tk_off() } # nocov end @@ -68,7 +72,8 @@ tkplot.off <- function() { # nocov start #' @inheritParams tk_coords #' @keywords internal #' @export -tkplot.getcoords <- function(tkp.id, norm = FALSE) { # nocov start +tkplot.getcoords <- function(tkp.id, norm = FALSE) { + # nocov start lifecycle::deprecate_soft("2.0.0", "tkplot.getcoords()", "tk_coords()") tk_coords(tkp.id = tkp.id, norm = norm) } # nocov end @@ -83,7 +88,8 @@ tkplot.getcoords <- function(tkp.id, norm = FALSE) { # nocov start #' @inheritParams tk_fit #' @keywords internal #' @export -tkplot.fit.to.screen <- function(tkp.id, width = NULL, height = NULL) { # nocov start +tkplot.fit.to.screen <- function(tkp.id, width = NULL, height = NULL) { + # nocov start lifecycle::deprecate_soft("2.0.0", "tkplot.fit.to.screen()", "tk_fit()") tk_fit(tkp.id = tkp.id, width = width, height = height) } # nocov end @@ -98,8 +104,13 @@ tkplot.fit.to.screen <- function(tkp.id, width = NULL, height = NULL) { # nocov #' @inheritParams tk_postscript #' @keywords internal #' @export -tkplot.export.postscript <- function(tkp.id) { # nocov start - lifecycle::deprecate_soft("2.0.0", "tkplot.export.postscript()", "tk_postscript()") +tkplot.export.postscript <- function(tkp.id) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "tkplot.export.postscript()", + "tk_postscript()" + ) tk_postscript(tkp.id = tkp.id) } # nocov end @@ -113,7 +124,8 @@ tkplot.export.postscript <- function(tkp.id) { # nocov start #' @inheritParams tk_close #' @keywords internal #' @export -tkplot.close <- function(tkp.id, window.close = TRUE) { # nocov start +tkplot.close <- function(tkp.id, window.close = TRUE) { + # nocov start lifecycle::deprecate_soft("2.0.0", "tkplot.close()", "tk_close()") tk_close(tkp.id = tkp.id, window.close = window.close) } # nocov end @@ -128,7 +140,8 @@ tkplot.close <- function(tkp.id, window.close = TRUE) { # nocov start #' @inheritParams tk_center #' @keywords internal #' @export -tkplot.center <- function(tkp.id) { # nocov start +tkplot.center <- function(tkp.id) { + # nocov start lifecycle::deprecate_soft("2.0.0", "tkplot.center()", "tk_center()") tk_center(tkp.id = tkp.id) } # nocov end @@ -143,7 +156,8 @@ tkplot.center <- function(tkp.id) { # nocov start #' @inheritParams tk_canvas #' @keywords internal #' @export -tkplot.canvas <- function(tkp.id) { # nocov start +tkplot.canvas <- function(tkp.id) { + # nocov start lifecycle::deprecate_soft("2.0.0", "tkplot.canvas()", "tk_canvas()") tk_canvas(tkp.id = tkp.id) } # nocov end @@ -180,8 +194,6 @@ assign(".next", 1, .tkplot.env) # Main function ################################################################### - - #' Interactive plotting of graphs #' #' `tkplot()` and its companion functions serve as an interactive graph @@ -343,8 +355,10 @@ tkplot <- function(graph, canvas.width = 450, canvas.height = 450, ...) { # Adjusting size vertex.size <- i.rescale.vertex( - vertex.size, c(-canvas.width, canvas.height)/2, - params("vertex", "relative.size")) + vertex.size, + c(-canvas.width, canvas.height) / 2, + params("vertex", "relative.size") + ) vertex.frame.color <- .tkplot.convert.color(params("vertex", "frame.color")) @@ -377,9 +391,11 @@ tkplot <- function(graph, canvas.width = 450, canvas.height = 450, ...) { # Create window & canvas top <- tcltk::tktoplevel(background = "lightgrey") - canvas <- tcltk::tkcanvas(top, + canvas <- tcltk::tkcanvas( + top, relief = "raised", - width = canvas.width, height = canvas.height, + width = canvas.width, + height = canvas.height, borderwidth = 2 ) tcltk::tkpack(canvas, fill = "both", expand = 1) @@ -394,27 +410,41 @@ tkplot <- function(graph, canvas.width = 450, canvas.height = 450, ...) { params <- list( vertex.params = vertex.params, - edge.color = edge.color, label.color = label.color, - labels.state = 1, edge.width = edge.width, + edge.color = edge.color, + label.color = label.color, + labels.state = 1, + edge.width = edge.width, padding = margin * 300 + max(vertex.size) + 5, - grid = 0, label.degree = label.degree, - label.dist = label.dist, edge.labels = edge.labels, + grid = 0, + label.degree = label.degree, + label.dist = label.dist, + edge.labels = edge.labels, vertex.frame.color = vertex.frame.color, - loop.angle = loop.angle, edge.lty = edge.lty, arrow.mode = arrow.mode, + loop.angle = loop.angle, + edge.lty = edge.lty, + arrow.mode = arrow.mode, edge.label.font = edge.label.font, - edge.label.color = edge.label.color, arrow.size = arrow.size, + edge.label.color = edge.label.color, + arrow.size = arrow.size, curved = curved ) # The popup menu popup.menu <- tcltk::tkmenu(canvas) - tcltk::tkadd(popup.menu, "command", label = "Fit to screen", command = function() { - tk_fit(tkp.id) - }) + tcltk::tkadd( + popup.menu, + "command", + label = "Fit to screen", + command = function() { + tk_fit(tkp.id) + } + ) # Different popup menu for vertices vertex.popup.menu <- tcltk::tkmenu(canvas) - tcltk::tkadd(vertex.popup.menu, "command", + tcltk::tkadd( + vertex.popup.menu, + "command", label = "Vertex color", command = function() { tkp <- .tkplot.get(tkp.id) @@ -432,7 +462,9 @@ tkplot <- function(graph, canvas.width = 450, canvas.height = 450, ...) { .tkplot.update.vertex.color(tkp.id, vids, color) } ) - tcltk::tkadd(vertex.popup.menu, "command", + tcltk::tkadd( + vertex.popup.menu, + "command", label = "Vertex size", command = function() { tkp <- .tkplot.get(tkp.id) @@ -453,7 +485,9 @@ tkplot <- function(graph, canvas.width = 450, canvas.height = 450, ...) { # Different popup menu for edges edge.popup.menu <- tcltk::tkmenu(canvas) - tcltk::tkadd(edge.popup.menu, "command", + tcltk::tkadd( + edge.popup.menu, + "command", label = "Edge color", command = function() { tkp <- .tkplot.get(tkp.id) @@ -462,7 +496,8 @@ tkplot <- function(graph, canvas.width = 450, canvas.height = 450, ...) { return(FALSE) } - initialcolor <- ifelse(length(tkp$params$edge.color) > 1, + initialcolor <- ifelse( + length(tkp$params$edge.color) > 1, tkp$params$edge.color[eids[1]], tkp$params$edge.color ) @@ -474,7 +509,9 @@ tkplot <- function(graph, canvas.width = 450, canvas.height = 450, ...) { .tkplot.update.edge.color(tkp.id, eids, color) } ) - tcltk::tkadd(edge.popup.menu, "command", + tcltk::tkadd( + edge.popup.menu, + "command", label = "Edge width", command = function() { tkp <- .tkplot.get(tkp.id) @@ -483,7 +520,8 @@ tkplot <- function(graph, canvas.width = 450, canvas.height = 450, ...) { return(FALSE) } - initialwidth <- ifelse(length(tkp$params$edge.width) > 1, + initialwidth <- ifelse( + length(tkp$params$edge.width) > 1, tkp$params$edge.width[eids[1]], tkp$params$edge.width ) @@ -496,11 +534,15 @@ tkplot <- function(graph, canvas.width = 450, canvas.height = 450, ...) { } ) - # Create plot object tkp <- list( - top = top, canvas = canvas, graph = graph, coords = layout, - labels = labels, params = params, popup.menu = popup.menu, + top = top, + canvas = canvas, + graph = graph, + coords = layout, + labels = labels, + params = params, + popup.menu = popup.menu, vertex.popup.menu = vertex.popup.menu, edge.popup.menu = edge.popup.menu ) @@ -518,18 +560,31 @@ tkplot <- function(graph, canvas.width = 450, canvas.height = 450, ...) { tcltk::tkadd(main.menu, "cascade", label = "Layout", menu = layout.menu) view.menu <- tcltk::tkmenu(main.menu) tcltk::tkadd(main.menu, "cascade", label = "View", menu = view.menu) - tcltk::tkadd(view.menu, "command", label = "Fit to screen", command = function() { - tk_fit(tkp.id) - }) - tcltk::tkadd(view.menu, "command", label = "Center on screen", command = function() { - tk_center(tkp.id) - }) + tcltk::tkadd( + view.menu, + "command", + label = "Fit to screen", + command = function() { + tk_fit(tkp.id) + } + ) + tcltk::tkadd( + view.menu, + "command", + label = "Center on screen", + command = function() { + tk_center(tkp.id) + } + ) tcltk::tkadd(view.menu, "separator") view.menu.labels <- tcltk::tclVar(1) view.menu.grid <- tcltk::tclVar(0) - tcltk::tkadd(view.menu, "checkbutton", + tcltk::tkadd( + view.menu, + "checkbutton", label = "Labels", - variable = view.menu.labels, command = function() { + variable = view.menu.labels, + command = function() { .tkplot.toggle.labels(tkp.id) } ) @@ -543,8 +598,11 @@ tkplot <- function(graph, canvas.width = 450, canvas.height = 450, ...) { sapply( c(-90, -45, -15, -5, -1, 1, 5, 15, 45, 90), function(deg) { - tcltk::tkadd(rotate.menu, "command", - label = paste(deg, "degree"), command = function() { + tcltk::tkadd( + rotate.menu, + "command", + label = paste(deg, "degree"), + command = function() { tk_rotate(tkp.id, degree = deg) } ) @@ -552,9 +610,14 @@ tkplot <- function(graph, canvas.width = 450, canvas.height = 450, ...) { ) export.menu <- tcltk::tkmenu(main.menu) tcltk::tkadd(main.menu, "cascade", label = "Export", menu = export.menu) - tcltk::tkadd(export.menu, "command", label = "Postscript", command = function() { - tk_postscript(tkp.id) - }) + tcltk::tkadd( + export.menu, + "command", + label = "Postscript", + command = function() { + tk_postscript(tkp.id) + } + ) tcltk::tkconfigure(top, "-menu", main.menu) # plot it @@ -577,43 +640,54 @@ tkplot <- function(graph, canvas.width = 450, canvas.height = 450, ...) { .tkplot.select.current(tkp.id) # tcltk::tkitemraise(canvas, "current") }) - tcltk::tkitembind(canvas, "vertex||label||edge", "", function(x, y) { - canvas <- .tkplot.get(tkp.id, "canvas") - curtags <- as.character(tcltk::tkgettags(canvas, "current")) - seltags <- as.character(tcltk::tkgettags(canvas, "selected")) - if ("vertex" %in% curtags && "vertex" %in% seltags) { - if ("selected" %in% curtags) { - .tkplot.deselect.current(tkp.id) - } else { - .tkplot.select.current(tkp.id) - } - } else if ("edge" %in% curtags && "edge" %in% seltags) { - if ("selected" %in% curtags) { - .tkplot.deselect.current(tkp.id) + tcltk::tkitembind( + canvas, + "vertex||label||edge", + "", + function(x, y) { + canvas <- .tkplot.get(tkp.id, "canvas") + curtags <- as.character(tcltk::tkgettags(canvas, "current")) + seltags <- as.character(tcltk::tkgettags(canvas, "selected")) + if ("vertex" %in% curtags && "vertex" %in% seltags) { + if ("selected" %in% curtags) { + .tkplot.deselect.current(tkp.id) + } else { + .tkplot.select.current(tkp.id) + } + } else if ("edge" %in% curtags && "edge" %in% seltags) { + if ("selected" %in% curtags) { + .tkplot.deselect.current(tkp.id) + } else { + .tkplot.select.current(tkp.id) + } + } else if ("label" %in% curtags && "vertex" %in% seltags) { + vtag <- curtags[pmatch("v-", curtags)] + tkid <- as.numeric(tcltk::tkfind( + canvas, + "withtag", + paste(sep = "", "vertex&&", vtag) + )) + vtags <- as.character(tcltk::tkgettags(canvas, tkid)) + if ("selected" %in% vtags) { + .tkplot.deselect.vertex(tkp.id, tkid) + } else { + .tkplot.select.vertex(tkp.id, tkid) + } } else { + .tkplot.deselect.all(tkp.id) .tkplot.select.current(tkp.id) } - } else if ("label" %in% curtags && "vertex" %in% seltags) { - vtag <- curtags[pmatch("v-", curtags)] - tkid <- as.numeric(tcltk::tkfind( - canvas, "withtag", - paste(sep = "", "vertex&&", vtag) - )) - vtags <- as.character(tcltk::tkgettags(canvas, tkid)) - if ("selected" %in% vtags) { - .tkplot.deselect.vertex(tkp.id, tkid) - } else { - .tkplot.select.vertex(tkp.id, tkid) - } - } else { - .tkplot.deselect.all(tkp.id) - .tkplot.select.current(tkp.id) } - }) - tcltk::tkitembind(canvas, "vertex||edge||label", "", function(x, y) { - canvas <- .tkplot.get(tkp.id, "canvas") - tcltk::tkitemlower(canvas, "current") - }) + ) + tcltk::tkitembind( + canvas, + "vertex||edge||label", + "", + function(x, y) { + canvas <- .tkplot.get(tkp.id, "canvas") + tcltk::tkitemlower(canvas, "current") + } + ) tcltk::tkitembind(canvas, "vertex||edge||label", "", function(x, y) { canvas <- .tkplot.get(tkp.id, "canvas") tcltk::tkitemraise(canvas, "current") @@ -624,7 +698,8 @@ tkplot <- function(graph, canvas.width = 450, canvas.height = 450, ...) { if ("label" %in% tags) { vtag <- tags[pmatch("v-", tags)] vid <- as.character(tcltk::tkfind( - canvas, "withtag", + canvas, + "withtag", paste(sep = "", "vertex&&", vtag) )) tags <- as.character(tcltk::tkgettags(canvas, vid)) @@ -675,10 +750,9 @@ tkplot <- function(graph, canvas.width = 450, canvas.height = 450, ...) { # get the id tags <- as.character(tcltk::tkgettags(tkp$canvas, "selected")) - id <- as.numeric(strsplit(tags[pmatch("v-", tags)], - "-", - fixed = TRUE - )[[1]][2]) + id <- as.numeric(strsplit(tags[pmatch("v-", tags)], "-", fixed = TRUE)[[1]][ + 2 + ]) if (is.na(id)) { return() } @@ -693,10 +767,9 @@ tkplot <- function(graph, canvas.width = 450, canvas.height = 450, ...) { y <- as.numeric(y) # get the id tags <- as.character(tcltk::tkgettags(tkp$canvas, "selected")) - id <- as.numeric(strsplit(tags[pmatch("v-", tags)], - "-", - fixed = TRUE - )[[1]][2]) + id <- as.numeric(strsplit(tags[pmatch("v-", tags)], "-", fixed = TRUE)[[ + 1 + ]][2]) if (is.na(id)) { return() } @@ -708,9 +781,21 @@ tkplot <- function(graph, canvas.width = 450, canvas.height = 450, ...) { # We don't need these any more, they are stored in the environment rm( - tkp, params, layout, vertex.color, edge.color, top, canvas, - main.menu, layout.menu, view.menu, export.menu, label.font, label.degree, - vertex.frame.color, vertex.params + tkp, + params, + layout, + vertex.color, + edge.color, + top, + canvas, + main.menu, + layout.menu, + view.menu, + export.menu, + label.font, + label.degree, + vertex.frame.color, + vertex.params ) tkp.id @@ -740,8 +825,14 @@ tkplot <- function(graph, canvas.width = 450, canvas.height = 450, ...) { assign("tmp", defaults, .tkplot.env) for (i in seq(along.with = defaults)) { cmd <- paste( - sep = "", '.layouts[["', name, '"]]$params[[', i, - "]]$default <- tmp[[", i, "]]" + sep = "", + '.layouts[["', + name, + '"]]$params[[', + i, + "]]$default <- tmp[[", + i, + "]]" ) eval(parse(text = cmd), .tkplot.env) } @@ -860,9 +951,11 @@ tk_fit <- function(tkp.id, width = NULL, height = NULL) { coords[, 1] <- coords[, 1] - min(coords[, 1]) coords[, 2] <- coords[, 2] - min(coords[, 2]) # Scale - coords[, 1] <- coords[, 1] / max(coords[, 1]) * + coords[, 1] <- coords[, 1] / + max(coords[, 1]) * (width - (tkp$params$padding[2] + tkp$params$padding[4])) - coords[, 2] <- coords[, 2] / max(coords[, 2]) * + coords[, 2] <- coords[, 2] / + max(coords[, 2]) * (height - (tkp$params$padding[1] + tkp$params$padding[3])) # Padding coords[, 1] <- coords[, 1] + tkp$params$padding[2] @@ -903,7 +996,10 @@ tk_center <- function(tkp.id) { #' @export tk_reshape <- function(tkp.id, newlayout, ..., params) { tkp <- .tkplot.get(tkp.id) - new_coords <- do_call(newlayout, .args = c(list(tkp$graph), list(...), params)) + new_coords <- do_call( + newlayout, + .args = c(list(tkp$graph), list(...), params) + ) .tkplot.set(tkp.id, "coords", new_coords) tk_fit(tkp.id) .tkplot.update.vertices(tkp.id) @@ -1020,7 +1116,18 @@ tk_canvas <- function(tkp.id) { } .tkplot.set.vertex.coords <- function(tkp.id, id, x, y) { - cmd <- paste(sep = "", "tkp.", tkp.id, "$coords[", id, ",]<-c(", x, ",", y, ")") + cmd <- paste( + sep = "", + "tkp.", + tkp.id, + "$coords[", + id, + ",]<-c(", + x, + ",", + y, + ")" + ) eval(parse(text = cmd), .tkplot.env) TRUE } @@ -1037,8 +1144,13 @@ tk_canvas <- function(tkp.id) { rm("tmp", envir = .tkplot.env) } else { cmd <- paste( - sep = "", "tkp.", tkp.id, "$params$label.degree[", id, - "] <- ", phi + sep = "", + "tkp.", + tkp.id, + "$params$label.degree[", + id, + "] <- ", + phi ) eval(parse(text = cmd), .tkplot.env) } @@ -1054,19 +1166,27 @@ tk_canvas <- function(tkp.id) { tkp <- .tkplot.get(tkp.id) vertex.size <- tkp$params$vertex.params[id, "vertex.size"] vertex.color <- tkp$params$vertex.params[id, "vertex.color"] - vertex.frame.color <- ifelse(length(tkp$params$vertex.frame.color) > 1, + vertex.frame.color <- ifelse( + length(tkp$params$vertex.frame.color) > 1, tkp$params$vertex.frame.color[id], tkp$params$vertex.frame.color ) - item <- tcltk::tkcreate(tkp$canvas, "oval", x - vertex.size, y - vertex.size, - x + vertex.size, y + vertex.size, + item <- tcltk::tkcreate( + tkp$canvas, + "oval", + x - vertex.size, + y - vertex.size, + x + vertex.size, + y + vertex.size, width = 1, - outline = vertex.frame.color, fill = vertex.color + outline = vertex.frame.color, + fill = vertex.color ) tcltk::tkaddtag(tkp$canvas, "vertex", "withtag", item) tcltk::tkaddtag(tkp$canvas, paste("v-", id, sep = ""), "withtag", item) if (!is.na(label)) { - label.degree <- ifelse(length(tkp$params$label.degree) > 1, + label.degree <- ifelse( + length(tkp$params$label.degree) > 1, tkp$params$label.degree[id], tkp$params$label.degree ) @@ -1076,18 +1196,28 @@ tk_canvas <- function(tkp.id) { tkp$params$label.color } label.dist <- tkp$params$label.dist - label.x <- x + label.dist * cos(label.degree) * - (vertex.size + 6 + 4 * (ceiling(log10(id)))) - label.y <- y + label.dist * sin(label.degree) * - (vertex.size + 6 + 4 * (ceiling(log10(id)))) + label.x <- x + + label.dist * + cos(label.degree) * + (vertex.size + 6 + 4 * (ceiling(log10(id)))) + label.y <- y + + label.dist * + sin(label.degree) * + (vertex.size + 6 + 4 * (ceiling(log10(id)))) if (label.dist == 0) { afill <- label.color } else { afill <- "red" } - litem <- tcltk::tkcreate(tkp$canvas, "text", label.x, label.y, - text = as.character(label), state = "normal", - fill = label.color, activefill = afill, + litem <- tcltk::tkcreate( + tkp$canvas, + "text", + label.x, + label.y, + text = as.character(label), + state = "normal", + fill = label.color, + activefill = afill, font = tkp$params$vertex.params[id, "label.font"] ) tcltk::tkaddtag(tkp$canvas, "label", "withtag", litem) @@ -1106,25 +1236,35 @@ tk_canvas <- function(tkp.id) { mapply( function(v, l, x, y) .tkplot.create.vertex(tkp.id, v, l, x, y), - 1:n, labels, tkp$coords[, 1], tkp$coords[, 2] + 1:n, + labels, + tkp$coords[, 1], + tkp$coords[, 2] ) } .tkplot.update.label <- function(tkp.id, id, x, y) { tkp <- .tkplot.get(tkp.id) vertex.size <- tkp$params$vertex.params[id, "vertex.size"] - label.degree <- ifelse(length(tkp$params$label.degree) > 1, + label.degree <- ifelse( + length(tkp$params$label.degree) > 1, tkp$params$label.degree[id], tkp$params$label.degree ) label.dist <- tkp$params$label.dist - label.x <- x + label.dist * cos(label.degree) * - (vertex.size + 6 + 4 * (ceiling(log10(id)))) - label.y <- y + label.dist * sin(label.degree) * - (vertex.size + 6 + 4 * (ceiling(log10(id)))) + label.x <- x + + label.dist * + cos(label.degree) * + (vertex.size + 6 + 4 * (ceiling(log10(id)))) + label.y <- y + + label.dist * + sin(label.degree) * + (vertex.size + 6 + 4 * (ceiling(log10(id)))) tcltk::tkcoords( - tkp$canvas, paste("label&&v-", id, sep = ""), - label.x, label.y + tkp$canvas, + paste("label&&v-", id, sep = ""), + label.x, + label.y ) } @@ -1133,20 +1273,25 @@ tk_canvas <- function(tkp.id) { vertex.size <- tkp$params$vertex.params[id, "vertex.size"] # Vertex tcltk::tkcoords( - tkp$canvas, paste("vertex&&v-", id, sep = ""), - x - vertex.size, y - vertex.size, - x + vertex.size, y + vertex.size + tkp$canvas, + paste("vertex&&v-", id, sep = ""), + x - vertex.size, + y - vertex.size, + x + vertex.size, + y + vertex.size ) # Label .tkplot.update.label(tkp.id, id, x, y) # Edges edge.from.ids <- as.numeric(tcltk::tkfind( - tkp$canvas, "withtag", + tkp$canvas, + "withtag", paste("from-", id, sep = "") )) edge.to.ids <- as.numeric(tcltk::tkfind( - tkp$canvas, "withtag", + tkp$canvas, + "withtag", paste("to-", id, sep = "") )) for (i in seq(along.with = edge.from.ids)) { @@ -1161,8 +1306,10 @@ tk_canvas <- function(tkp.id) { tkp <- .tkplot.get(tkp.id) n <- vcount(tkp$graph) mapply( - function(v, x, y) .tkplot.update.vertex(tkp.id, v, x, y), 1:n, - tkp$coords[, 1], tkp$coords[, 2] + function(v, x, y) .tkplot.update.vertex(tkp.id, v, x, y), + 1:n, + tkp$coords[, 1], + tkp$coords[, 2] ) } @@ -1171,19 +1318,23 @@ tk_canvas <- function(tkp.id) { tkp <- .tkplot.get(tkp.id) from.c <- tkp$coords[from, ] to.c <- tkp$coords[to, ] - edge.color <- ifelse(length(tkp$params$edge.color) > 1, + edge.color <- ifelse( + length(tkp$params$edge.color) > 1, tkp$params$edge.color[id], tkp$params$edge.color ) - edge.width <- ifelse(length(tkp$params$edge.width) > 1, + edge.width <- ifelse( + length(tkp$params$edge.width) > 1, tkp$params$edge.width[id], tkp$params$edge.width ) - edge.lty <- ifelse(length(tkp$params$edge.lty) > 1, + edge.lty <- ifelse( + length(tkp$params$edge.lty) > 1, tkp$params$edge.lty[[id]], tkp$params$edge.lty ) - arrow.mode <- ifelse(length(tkp$params$arrow.mode) > 1, + arrow.mode <- ifelse( + length(tkp$params$arrow.mode) > 1, tkp$params$arrow.mode[[id]], tkp$params$arrow.mode ) @@ -1193,7 +1344,9 @@ tk_canvas <- function(tkp.id) { if (from != to) { ## non-loop edge - if (is.logical(curved)) curved <- curved * 0.5 + if (is.logical(curved)) { + curved <- curved * 0.5 + } if (curved != 0) { smooth <- TRUE midx <- (from.c[1] + to.c[1]) / 2 @@ -1205,14 +1358,20 @@ tk_canvas <- function(tkp.id) { smooth <- FALSE coords <- c(from.c[1], from.c[2], to.c[1], to.c[2]) } - args <- c(list(tkp$canvas, "line"), + args <- c( + list(tkp$canvas, "line"), coords, list( - width = edge.width, activewidth = 2 * edge.width, - arrow = arrow, arrowshape = arrow.size * c(10, 10, 5), - fill = edge.color, activefill = "red", dash = edge.lty, + width = edge.width, + activewidth = 2 * edge.width, + arrow = arrow, + arrowshape = arrow.size * c(10, 10, 5), + fill = edge.color, + activefill = "red", + dash = edge.lty, tags = c( - "edge", paste(sep = "", "edge-", id), + "edge", + paste(sep = "", "edge-", id), paste(sep = "", "from-", from), paste(sep = "", "to-", to) ) @@ -1223,34 +1382,58 @@ tk_canvas <- function(tkp.id) { } else { ## loop edge ## the coordinates are not correct but we will call update anyway... - tcltk::tkcreate(tkp$canvas, "line", from.c[1], from.c[2], - from.c[1] + 20, from.c[1] - 10, from.c[2] + 30, from.c[2], - from.c[1] + 20, from.c[1] + 10, from.c[1], from.c[2], - width = edge.width, activewidth = 2 * edge.width, - arrow = arrow, arrowshape = arrow.size * c(10, 10, 5), dash = edge.lty, - fill = edge.color, activefill = "red", smooth = TRUE, + tcltk::tkcreate( + tkp$canvas, + "line", + from.c[1], + from.c[2], + from.c[1] + 20, + from.c[1] - 10, + from.c[2] + 30, + from.c[2], + from.c[1] + 20, + from.c[1] + 10, + from.c[1], + from.c[2], + width = edge.width, + activewidth = 2 * edge.width, + arrow = arrow, + arrowshape = arrow.size * c(10, 10, 5), + dash = edge.lty, + fill = edge.color, + activefill = "red", + smooth = TRUE, tags = c( - "edge", "loop", paste(sep = "", "edge-", id), + "edge", + "loop", + paste(sep = "", "edge-", id), paste(sep = "", "from-", from), paste(sep = "", "to-", to) ) ) } - edge.label <- ifelse(length(tkp$params$edge.labels) > 1, + edge.label <- ifelse( + length(tkp$params$edge.labels) > 1, tkp$params$edge.labels[id], tkp$params$edge.labels ) if (!is.na(edge.label)) { - label.color <- ifelse(length(tkp$params$edge.label.color) > 1, + label.color <- ifelse( + length(tkp$params$edge.label.color) > 1, tkp$params$edge.label.color[id], tkp$params$edge.label.color ) ## not correct for loop edges but we will update anyway... label.x <- (to.c[1] + from.c[1]) / 2 label.y <- (to.c[2] + from.c[2]) / 2 - litem <- tcltk::tkcreate(tkp$canvas, "text", label.x, label.y, - text = as.character(edge.label), state = "normal", + litem <- tcltk::tkcreate( + tkp$canvas, + "text", + label.x, + label.y, + text = as.character(edge.label), + state = "normal", fill = label.color, font = tkp$params$edge.label.font ) @@ -1267,7 +1450,8 @@ tk_canvas <- function(tkp.id) { mapply( function(from, to, id) .tkplot.create.edge(tkp.id, from, to, id), edgematrix[, 1], - edgematrix[, 2], 1:nrow(edgematrix) + edgematrix[, 2], + 1:nrow(edgematrix) ) } @@ -1275,7 +1459,10 @@ tk_canvas <- function(tkp.id) { .tkplot.update.edge <- function(tkp.id, itemid) { tkp <- .tkplot.get(tkp.id) tags <- as.character(tcltk::tkgettags(tkp$canvas, itemid)) - from <- as.numeric(substring(grep("from-", tags, value = TRUE, fixed = TRUE), 6)) + from <- as.numeric(substring( + grep("from-", tags, value = TRUE, fixed = TRUE), + 6 + )) to <- as.numeric(substring(grep("to-", tags, value = TRUE, fixed = TRUE), 4)) from.c <- tkp$coords[from, ] to.c <- tkp$coords[to, ] @@ -1292,29 +1479,47 @@ tk_canvas <- function(tkp.id) { to.c[2] <- from.c[2] + (r - vertex.size) * sin(phi) from.c[1] <- from.c[1] + vertex.size2 * cos(phi) from.c[2] <- from.c[2] + vertex.size2 * sin(phi) - if (is.logical(curved)) curved <- curved * 0.5 + if (is.logical(curved)) { + curved <- curved * 0.5 + } if (curved == 0) { - tcltk::tkcoords(tkp$canvas, itemid, from.c[1], from.c[2], to.c[1], to.c[2]) + tcltk::tkcoords( + tkp$canvas, + itemid, + from.c[1], + from.c[2], + to.c[1], + to.c[2] + ) } else { midx <- (from.c[1] + to.c[1]) / 2 midy <- (from.c[2] + to.c[2]) / 2 spx <- midx - curved * 1 / 2 * (from.c[2] - to.c[2]) spy <- midy + curved * 1 / 2 * (from.c[1] - to.c[1]) tcltk::tkcoords( - tkp$canvas, itemid, from.c[1], from.c[2], spx, spy, - to.c[1], to.c[2] + tkp$canvas, + itemid, + from.c[1], + from.c[2], + spx, + spy, + to.c[1], + to.c[2] ) } } else { vertex.size <- tkp$params$vertex.params[to, "vertex.size"] - loop.angle <- ifelse(length(tkp$param$loop.angle) > 1, + loop.angle <- ifelse( + length(tkp$param$loop.angle) > 1, tkp$params$loop.angle[edgeid], tkp$params$loop.angle ) xx <- from.c[1] + cos(loop.angle / 180 * pi) * vertex.size yy <- from.c[2] + sin(loop.angle / 180 * pi) * vertex.size - cc <- matrix(c(xx, yy, xx + 20, yy - 10, xx + 30, yy, xx + 20, yy + 10, xx, yy), - ncol = 2, byrow = TRUE + cc <- matrix( + c(xx, yy, xx + 20, yy - 10, xx + 30, yy, xx + 20, yy + 10, xx, yy), + ncol = 2, + byrow = TRUE ) phi <- atan2(cc[, 2] - yy, cc[, 1] - xx) @@ -1323,12 +1528,23 @@ tk_canvas <- function(tkp.id) { cc[, 1] <- xx + r * cos(phi) cc[, 2] <- yy + r * sin(phi) tcltk::tkcoords( - tkp$canvas, itemid, cc[1, 1], cc[1, 2], cc[2, 1], cc[2, 2], - cc[3, 1], cc[3, 2], cc[4, 1], cc[4, 2], cc[5, 1] + 0.001, cc[5, 2] + 0.001 + tkp$canvas, + itemid, + cc[1, 1], + cc[1, 2], + cc[2, 1], + cc[2, 2], + cc[3, 1], + cc[3, 2], + cc[4, 1], + cc[4, 2], + cc[5, 1] + 0.001, + cc[5, 2] + 0.001 ) } - edge.label <- ifelse(length(tkp$params$edge.labels) > 1, + edge.label <- ifelse( + length(tkp$params$edge.labels) > 1, tkp$params$edge.labels[edgeid], tkp$params$edge.labels ) @@ -1342,7 +1558,8 @@ tk_canvas <- function(tkp.id) { label.y <- yy + sin(loop.angle / 180 * pi) * 30 } litem <- as.numeric(tcltk::tkfind( - tkp$canvas, "withtag", + tkp$canvas, + "withtag", paste(sep = "", "label&&edge-", edgeid) )) tcltk::tkcoords(tkp$canvas, litem, label.x, label.y) @@ -1351,7 +1568,8 @@ tk_canvas <- function(tkp.id) { .tkplot.toggle.labels <- function(tkp.id) { .tkplot.set.params( - tkp.id, "labels.state", + tkp.id, + "labels.state", 1 - .tkplot.get(tkp.id, "params")$labels.state ) tkp <- .tkplot.get(tkp.id) @@ -1361,7 +1579,8 @@ tk_canvas <- function(tkp.id) { .tkplot.toggle.grid <- function(tkp.id) { .tkplot.set.params( - tkp.id, "grid", + tkp.id, + "grid", 1 - .tkplot.get(tkp.id, "params")$grid ) tkp <- .tkplot.get(tkp.id) @@ -1474,13 +1693,20 @@ tk_canvas <- function(tkp.id) { .tkplot.select.number <- function(label, initial, low = 1, high = 100) { dialog <- tcltk::tktoplevel() SliderValue <- tcltk::tclVar(as.character(initial)) - SliderValueLabel <- tcltk::tklabel(dialog, text = as.character(tcltk::tclvalue(SliderValue))) + SliderValueLabel <- tcltk::tklabel( + dialog, + text = as.character(tcltk::tclvalue(SliderValue)) + ) tcltk::tkgrid(tcltk::tklabel(dialog, text = label), SliderValueLabel) tcltk::tkconfigure(SliderValueLabel, textvariable = SliderValue) - slider <- tcltk::tkscale(dialog, - from = high, to = low, - showvalue = F, variable = SliderValue, - resolution = 1, orient = "horizontal" + slider <- tcltk::tkscale( + dialog, + from = high, + to = low, + showvalue = F, + variable = SliderValue, + resolution = 1, + orient = "horizontal" ) OnOK <- function() { SliderValue <<- as.numeric(tcltk::tclvalue(SliderValue)) @@ -1524,7 +1750,8 @@ tk_canvas <- function(tkp.id) { vids <- unique(vids) for (i in vids) { tkid <- as.numeric(tcltk::tkfind( - canvas, "withtag", + canvas, + "withtag", paste(sep = "", "vertex&&v-", i) )) .tkplot.select.vertex(tkp.id, tkid) @@ -1562,8 +1789,12 @@ tk_canvas <- function(tkp.id) { canvas <- .tkplot.get(tkp.id, "canvas") tcltk::tkaddtag(canvas, "selected", "withtag", tkid) tcltk::tkitemconfigure( - canvas, tkid, "-outline", "red", - "-width", 2 + canvas, + tkid, + "-outline", + "red", + "-width", + 2 ) } @@ -1584,13 +1815,18 @@ tk_canvas <- function(tkp.id) { tkp <- .tkplot.get(tkp.id) tags <- as.character(tcltk::tkgettags(canvas, tkid)) id <- as.numeric(substring(tags[pmatch("v-", tags)], 3)) - vertex.frame.color <- ifelse(length(tkp$params$vertex.frame.color) > 1, + vertex.frame.color <- ifelse( + length(tkp$params$vertex.frame.color) > 1, tkp$params$vertex.frame.color[id], tkp$params$vertex.frame.color ) tcltk::tkitemconfigure( - canvas, tkid, "-outline", vertex.frame.color, - "-width", 1 + canvas, + tkid, + "-outline", + vertex.frame.color, + "-width", + 1 ) } @@ -1600,7 +1836,8 @@ tk_canvas <- function(tkp.id) { tkp <- .tkplot.get(tkp.id) tags <- as.character(tcltk::tkgettags(canvas, tkid)) id <- as.numeric(substring(tags[pmatch("edge-", tags)], 6)) - edge.lty <- ifelse(length(tkp$params$edge.lty) > 1, + edge.lty <- ifelse( + length(tkp$params$edge.lty) > 1, tkp$params$edge.lty[[id]], tkp$params$edge.lty ) @@ -1636,7 +1873,8 @@ tk_canvas <- function(tkp.id) { if (tkp$params$label.dist == 0) { id <- tags[pmatch("v-", tags)] tkid <- as.character(tcltk::tkfind( - canvas, "withtag", + canvas, + "withtag", paste(sep = "", "vertex&&", id) )) .tkplot.select.vertex(tkp.id, tkid) @@ -1658,7 +1896,8 @@ tk_canvas <- function(tkp.id) { if (tkp$params$label.dist == 0) { id <- tags[pmatch("v-", tags)] tkid <- as.character(tcltk::tkfind( - canvas, "withtag", + canvas, + "withtag", paste(sep = "", "vertex&&", id) )) .tkplot.deselect.vertex(tkp.id, tkid) @@ -1701,28 +1940,36 @@ tk_canvas <- function(tkp.id) { .tkplot.select.menu <- function(tkp.id, main.menu) { select.menu <- tcltk::tkmenu(main.menu) - tcltk::tkadd(select.menu, "command", + tcltk::tkadd( + select.menu, + "command", label = "Select all vertices", command = function() { .tkplot.deselect.all(tkp.id) .tkplot.select.all.vertices(tkp.id) } ) - tcltk::tkadd(select.menu, "command", + tcltk::tkadd( + select.menu, + "command", label = "Select all edges", command = function() { .tkplot.deselect.all(tkp.id) .tkplot.select.all.edges(tkp.id) } ) - tcltk::tkadd(select.menu, "command", + tcltk::tkadd( + select.menu, + "command", label = "Select some vertices...", command = function() { vids <- .tkplot.get.numeric.vector("Select vertices") .tkplot.select.some.vertices(tkp.id, vids[[1]]) } ) - tcltk::tkadd(select.menu, "command", + tcltk::tkadd( + select.menu, + "command", label = "Select some edges...", command = function() { fromto <- .tkplot.get.numeric.vector( @@ -1733,7 +1980,9 @@ tk_canvas <- function(tkp.id) { } ) tcltk::tkadd(select.menu, "separator") - tcltk::tkadd(select.menu, "command", + tcltk::tkadd( + select.menu, + "command", label = "Deselect everything", command = function() { .tkplot.deselect.all(tkp.id) @@ -1747,7 +1996,9 @@ tk_canvas <- function(tkp.id) { layout.menu <- tcltk::tkmenu(main.menu) sapply(.tkplot.getlayoutlist(), function(n) { - tcltk::tkadd(layout.menu, "command", + tcltk::tkadd( + layout.menu, + "command", label = .tkplot.getlayoutname(n), command = function() { .tkplot.layout.dialog(tkp.id, n) @@ -1771,7 +2022,8 @@ tk_canvas <- function(tkp.id) { names(realparams) <- names(params) <- names(layout$params) for (i in seq(along.with = layout$params)) { realparams[[i]] <- - params[[i]] <- switch(layout$params[[i]]$type, + params[[i]] <- switch( + layout$params[[i]]$type, "numeric" = as.numeric(tcltk::tkget(values[[i]])), "character" = as.character(tcltk::tkget(values[[i]])), "logical" = as.logical(tcltk::tclvalue(values[[i]])), @@ -1779,8 +2031,10 @@ tk_canvas <- function(tkp.id) { "initial" = as.logical(tcltk::tclvalue(values[[i]])), "expression" = as.numeric(tcltk::tkget(values[[i]])) ) - if (layout$params[[i]]$type == "initial" && - params[[i]]) { + if ( + layout$params[[i]]$type == "initial" && + params[[i]] + ) { realparams[[i]] <- tk_coords(tkp.id, norm = TRUE) } } @@ -1797,37 +2051,78 @@ tk_canvas <- function(tkp.id) { tcltk::tkwm.transient(dialog, .tkplot.get(tkp.id, "top")) tcltk::tkgrid( - tcltk::tklabel(dialog, + tcltk::tklabel( + dialog, text = paste(layout$name, "layout"), - font = tcltk::tkfont.create(family = "helvetica", size = 20, weight = "bold") + font = tcltk::tkfont.create( + family = "helvetica", + size = 20, + weight = "bold" + ) ), - row = 0, column = 0, columnspan = 2, padx = 10, pady = 10 + row = 0, + column = 0, + columnspan = 2, + padx = 10, + pady = 10 ) row <- 1 values <- list() for (i in seq(along.with = layout$params)) { - tcltk::tkgrid(tcltk::tklabel(dialog, text = paste(sep = "", layout$params[[i]]$name, ":")), - row = row, column = 0, sticky = "ne", padx = 5, pady = 5 + tcltk::tkgrid( + tcltk::tklabel( + dialog, + text = paste(sep = "", layout$params[[i]]$name, ":") + ), + row = row, + column = 0, + sticky = "ne", + padx = 5, + pady = 5 ) if (layout$params[[i]]$type %in% c("numeric", "character")) { values[[i]] <- tcltk::tkentry(dialog) tcltk::tkinsert(values[[i]], 0, as.character(layout$params[[i]]$default)) - tcltk::tkgrid(values[[i]], row = row, column = 1, sticky = "nw", padx = 5, pady = 5) + tcltk::tkgrid( + values[[i]], + row = row, + column = 1, + sticky = "nw", + padx = 5, + pady = 5 + ) } else if (layout$params[[i]]$type == "logical") { values[[i]] <- tcltk::tclVar(as.character(layout$params[[i]]$default)) - tmp <- tcltk::tkcheckbutton(dialog, - onvalue = "TRUE", offvalue = "FALSE", + tmp <- tcltk::tkcheckbutton( + dialog, + onvalue = "TRUE", + offvalue = "FALSE", variable = values[[i]] ) - tcltk::tkgrid(tmp, row = row, column = 1, sticky = "nw", padx = 5, pady = 5) + tcltk::tkgrid( + tmp, + row = row, + column = 1, + sticky = "nw", + padx = 5, + pady = 5 + ) } else if (layout$params[[i]]$type == "choice") { tmp.frame <- tcltk::tkframe(dialog) - tcltk::tkgrid(tmp.frame, row = row, column = 1, sticky = "nw", padx = 5, pady = 5) + tcltk::tkgrid( + tmp.frame, + row = row, + column = 1, + sticky = "nw", + padx = 5, + pady = 5 + ) values[[i]] <- tcltk::tclVar(layout$params[[i]]$default) for (j in 1:length(layout$params[[i]]$values)) { - tmp <- tcltk::tkradiobutton(tmp.frame, + tmp <- tcltk::tkradiobutton( + tmp.frame, variable = values[[i]], value = layout$params[[i]]$values[j], text = layout$params[[i]]$values[j] @@ -1837,52 +2132,82 @@ tk_canvas <- function(tkp.id) { } else if (layout$params[[i]]$type == "initial") { values[[i]] <- tcltk::tclVar(as.character(layout$params[[i]]$default)) tcltk::tkgrid( - tcltk::tkcheckbutton(dialog, - onvalue = "TRUE", offvalue = "FALSE", + tcltk::tkcheckbutton( + dialog, + onvalue = "TRUE", + offvalue = "FALSE", variable = values[[i]] ), - row = row, column = 1, sticky = "nw", padx = 5, pady = 5 + row = row, + column = 1, + sticky = "nw", + padx = 5, + pady = 5 ) } else if (layout$param[[i]]$type == "expression") { values[[i]] <- tcltk::tkentry(dialog) .tkplot.g <- .tkplot.get(tkp.id, "graph") - tcltk::tkinsert(values[[i]], 0, as.character(eval(layout$params[[i]]$default))) - tcltk::tkgrid(values[[i]], row = row, column = 1, sticky = "nw", padx = 5, pady = 5) + tcltk::tkinsert( + values[[i]], + 0, + as.character(eval(layout$params[[i]]$default)) + ) + tcltk::tkgrid( + values[[i]], + row = row, + column = 1, + sticky = "nw", + padx = 5, + pady = 5 + ) } row <- row + 1 } # for along layout$params - tcltk::tkgrid(tcltk::tklabel(dialog, text = "Set these as defaults"), + tcltk::tkgrid( + tcltk::tklabel(dialog, text = "Set these as defaults"), sticky = "ne", - row = row, column = 0, padx = 5, pady = 5 + row = row, + column = 0, + padx = 5, + pady = 5 ) save.default <- tcltk::tclVar("FALSE") tcltk::tkgrid( - tcltk::tkcheckbutton(dialog, - onvalue = "TRUE", offvalue = "FALSE", - variable = save.default, text = "" + tcltk::tkcheckbutton( + dialog, + onvalue = "TRUE", + offvalue = "FALSE", + variable = save.default, + text = "" ), row = row, - column = 1, sticky = "nw", padx = 5, pady = 5 + column = 1, + sticky = "nw", + padx = 5, + pady = 5 ) row <- row + 1 - tcltk::tkgrid(tcltk::tkbutton(dialog, text = "OK", command = submit), row = row, column = 0) tcltk::tkgrid( - tcltk::tkbutton(dialog, - text = "Cancel", - command = function() { - tcltk::tkdestroy(dialog) - invisible(TRUE) - } - ), - row = row, column = 1 + tcltk::tkbutton(dialog, text = "OK", command = submit), + row = row, + column = 0 + ) + tcltk::tkgrid( + tcltk::tkbutton(dialog, text = "Cancel", command = function() { + tcltk::tkdestroy(dialog) + invisible(TRUE) + }), + row = row, + column = 1 ) } .tkplot.select.color <- function(initialcolor) { - color <- tcltk::tclvalue(tcltk::tcl("tk_chooseColor", + color <- tcltk::tclvalue(tcltk::tcl( + "tk_chooseColor", initialcolor = initialcolor, title = "Choose a color" )) @@ -1901,7 +2226,9 @@ tk_canvas <- function(tkp.id) { col <- col %% length(p) col[col == 0] <- length(p) col <- palette()[col] - } else if (is.character(col) && any(substr(col, 1, 1) == "#" & nchar(col) == 9)) { + } else if ( + is.character(col) && any(substr(col, 1, 1) == "#" & nchar(col) == 9) + ) { ## drop alpha channel, tcltk doesn't support it idx <- substr(col, 1, 1) == "#" & nchar(col) == 9 col[idx] <- substr(col[idx], 1, 7) @@ -1959,7 +2286,9 @@ tk_canvas <- function(tkp.id) { } newfont <- tcltk::tkfont.create( - family = tkfamily, slant = slant, weight = weight, + family = tkfamily, + slant = slant, + weight = weight, size = as.integer(12 * cex) ) as.character(newfont) @@ -1971,14 +2300,25 @@ i.tkplot.get.edge.lty <- function(edge.lty) { lty <- c(" ", "", "-", ".", "-.", "--", "--.") edge.lty <- lty[edge.lty %% 7 + 1] } else if (is.character(edge.lty)) { - wh <- edge.lty %in% c( - "blank", "solid", "dashed", "dotted", "dotdash", - "longdash", "twodash" - ) + wh <- edge.lty %in% + c( + "blank", + "solid", + "dashed", + "dotted", + "dotdash", + "longdash", + "twodash" + ) lty <- c(" ", "", "-", ".", "-.", "--", "--.") names(lty) <- c( - "blank", "solid", "dashed", "dotted", "dotdash", - "longdash", "twodash" + "blank", + "solid", + "dashed", + "dotted", + "dotdash", + "longdash", + "twodash" ) edge.lty[wh] <- lty[edge.lty[wh]] } From d416282d12ecd2cc20929089e570421ff7e9d99c Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 14:00:59 +0200 Subject: [PATCH 47/59] topology --- R/topology.R | 175 +++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 135 insertions(+), 40 deletions(-) diff --git a/R/topology.R b/R/topology.R index 5b71496ee36..caee0c3e80c 100644 --- a/R/topology.R +++ b/R/topology.R @@ -8,7 +8,8 @@ #' @inheritParams permute #' @keywords internal #' @export -permute.vertices <- function(graph, permutation) { # nocov start +permute.vertices <- function(graph, permutation) { + # nocov start lifecycle::deprecate_soft("2.0.0", "permute.vertices()", "permute()") permute(graph = graph, permutation = permutation) } # nocov end @@ -23,9 +24,18 @@ permute.vertices <- function(graph, permutation) { # nocov start #' @inheritParams graph_from_isomorphism_class #' @keywords internal #' @export -graph.isocreate <- function(size, number, directed = TRUE) { # nocov start - lifecycle::deprecate_soft("2.0.0", "graph.isocreate()", "graph_from_isomorphism_class()") - graph_from_isomorphism_class(size = size, number = number, directed = directed) +graph.isocreate <- function(size, number, directed = TRUE) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "graph.isocreate()", + "graph_from_isomorphism_class()" + ) + graph_from_isomorphism_class( + size = size, + number = number, + directed = directed + ) } # nocov end #' Number of automorphisms @@ -38,8 +48,17 @@ graph.isocreate <- function(size, number, directed = TRUE) { # nocov start #' @inheritParams count_automorphisms #' @keywords internal #' @export -graph.automorphisms <- function(graph, colors = NULL, sh = c("fm", "f", "fs", "fl", "flm", "fsm")) { # nocov start - lifecycle::deprecate_soft("2.0.0", "graph.automorphisms()", "count_automorphisms()") +graph.automorphisms <- function( + graph, + colors = NULL, + sh = c("fm", "f", "fs", "fl", "flm", "fsm") +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "graph.automorphisms()", + "count_automorphisms()" + ) count_automorphisms(graph = graph, colors = colors, sh = sh) } # nocov end @@ -53,8 +72,17 @@ graph.automorphisms <- function(graph, colors = NULL, sh = c("fm", "f", "fs", "f #' @inheritParams canonical_permutation #' @keywords internal #' @export -canonical.permutation <- function(graph, colors = NULL, sh = c("fm", "f", "fs", "fl", "flm", "fsm")) { # nocov start - lifecycle::deprecate_soft("2.0.0", "canonical.permutation()", "canonical_permutation()") +canonical.permutation <- function( + graph, + colors = NULL, + sh = c("fm", "f", "fs", "fl", "flm", "fsm") +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "canonical.permutation()", + "canonical_permutation()" + ) canonical_permutation(graph = graph, colors = colors, sh = sh) } # nocov end @@ -68,7 +96,12 @@ canonical.permutation <- function(graph, colors = NULL, sh = c("fm", "f", "fs", #' @inheritParams count_automorphisms #' @keywords internal #' @export -automorphisms <- function(graph, colors = NULL, sh = c("fm", "f", "fs", "fl", "flm", "fsm")) { # nocov start +automorphisms <- function( + graph, + colors = NULL, + sh = c("fm", "f", "fs", "fl", "flm", "fsm") +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "automorphisms()", "count_automorphisms()") count_automorphisms(graph = graph, colors = colors, sh = sh) } # nocov end @@ -95,9 +128,14 @@ automorphisms <- function(graph, colors = NULL, sh = c("fm", "f", "fs", "fl", "f ################################################################### #' @export -graph.get.isomorphisms.vf2 <- function(graph1, graph2, vertex.color1, - vertex.color2, edge.color1, - edge.color2) { +graph.get.isomorphisms.vf2 <- function( + graph1, + graph2, + vertex.color1, + vertex.color2, + edge.color1, + edge.color2 +) { # Argument checks ensure_igraph(graph1) ensure_igraph(graph2) @@ -145,17 +183,27 @@ graph.get.isomorphisms.vf2 <- function(graph1, graph2, vertex.color1, on.exit(.Call(R_igraph_finalizer)) # Function call res <- .Call( - R_igraph_get_isomorphisms_vf2, graph1, graph2, vertex.color1, - vertex.color2, edge.color1, edge.color2 + R_igraph_get_isomorphisms_vf2, + graph1, + graph2, + vertex.color1, + vertex.color2, + edge.color1, + edge.color2 ) lapply(res, function(.x) V(graph2)[.x + 1]) } #' @export -graph.get.subisomorphisms.vf2 <- function(graph1, graph2, vertex.color1, - vertex.color2, edge.color1, - edge.color2) { +graph.get.subisomorphisms.vf2 <- function( + graph1, + graph2, + vertex.color1, + vertex.color2, + edge.color1, + edge.color2 +) { # Argument checks ensure_igraph(graph1) ensure_igraph(graph2) @@ -203,8 +251,13 @@ graph.get.subisomorphisms.vf2 <- function(graph1, graph2, vertex.color1, on.exit(.Call(R_igraph_finalizer)) # Function call res <- .Call( - R_igraph_get_subisomorphisms_vf2, graph1, graph2, - vertex.color1, vertex.color2, edge.color1, edge.color2 + R_igraph_get_subisomorphisms_vf2, + graph1, + graph2, + vertex.color1, + vertex.color2, + edge.color1, + edge.color2 ) lapply(res, function(.x) V(graph1)[.x + 1]) @@ -223,9 +276,15 @@ graph.isoclass.subgraph <- function(graph, vids) { } #' @export -graph.subisomorphic.lad <- function(pattern, target, domains = NULL, - induced = FALSE, map = TRUE, all.maps = FALSE, - time.limit = Inf) { +graph.subisomorphic.lad <- function( + pattern, + target, + domains = NULL, + induced = FALSE, + map = TRUE, + all.maps = FALSE, + time.limit = Inf +) { # Argument checks ensure_igraph(pattern) ensure_igraph(target) @@ -239,10 +298,14 @@ graph.subisomorphic.lad <- function(pattern, target, domains = NULL, all.maps <- as.logical(all.maps) if (!is.null(domains)) { if (!is.list(domains)) { - cli::cli_abort("{.arg domains} must be a list of vertex vectors from {.arg target}.") + cli::cli_abort( + "{.arg domains} must be a list of vertex vectors from {.arg target}." + ) } if (length(domains) != vcount(pattern)) { - cli::cli_abort("{.arg domains} length and {.arg pattern} number of vertices must match.") + cli::cli_abort( + "{.arg domains} length and {.arg pattern} number of vertices must match." + ) } domains <- lapply(domains, function(x) as_igraph_vs(target, x) - 1) } @@ -250,8 +313,14 @@ graph.subisomorphic.lad <- function(pattern, target, domains = NULL, on.exit(.Call(R_igraph_finalizer)) # Function call res <- .Call( - R_igraph_subisomorphic_lad, pattern, target, domains, - induced, time.limit, map, all.maps + R_igraph_subisomorphic_lad, + pattern, + target, + domains, + induced, + time.limit, + map, + all.maps ) if (map) { @@ -260,7 +329,9 @@ graph.subisomorphic.lad <- function(pattern, target, domains = NULL, names(res$map) <- V(target)$name[res$map] } } - if (all.maps) res$maps <- lapply(res$maps, function(.x) V(target)[.x + 1]) + if (all.maps) { + res$maps <- lapply(res$maps, function(.x) V(target)[.x + 1]) + } res } @@ -371,10 +442,17 @@ graph.subisomorphic.lad <- function(pattern, target, domains = NULL, #' vertex.color1 = NULL, #' vertex.color2 = NULL #' ) -isomorphic <- function(graph1, graph2, method = c( - "auto", "direct", - "vf2", "bliss" - ), ...) { +isomorphic <- function( + graph1, + graph2, + method = c( + "auto", + "direct", + "vf2", + "bliss" + ), + ... +) { ensure_igraph(graph1) ensure_igraph(graph2) method <- igraph.match.arg(method) @@ -500,15 +578,24 @@ is_isomorphic_to <- isomorphic #' pattern <- make_graph(~ 1:2:3, 1 -+ 2:3) #' dring <- make_ring(10, directed = TRUE) #' subgraph_isomorphic(pattern, dring) -subgraph_isomorphic <- function(pattern, target, - method = c("auto", "lad", "vf2"), ...) { +subgraph_isomorphic <- function( + pattern, + target, + method = c("auto", "lad", "vf2"), + ... +) { method <- igraph.match.arg(method) - if (method == "auto") method <- "lad" + if (method == "auto") { + method <- "lad" + } if (method == "lad") { - graph.subisomorphic.lad(pattern, target, - map = FALSE, all.maps = FALSE, + graph.subisomorphic.lad( + pattern, + target, + map = FALSE, + all.maps = FALSE, ... )$iso } else if (method == "vf2") { @@ -631,8 +718,12 @@ graph.count.isomorphisms.vf2 <- count_isomorphisms_vf2_impl #' #' @export #' @family graph isomorphism -count_subgraph_isomorphisms <- function(pattern, target, - method = c("lad", "vf2"), ...) { +count_subgraph_isomorphisms <- function( + pattern, + target, + method = c("lad", "vf2"), + ... +) { method <- igraph.match.arg(method) if (method == "lad") { @@ -726,8 +817,12 @@ isomorphisms <- function(graph1, graph2, method = "vf2", ...) { #' #' @export #' @family graph isomorphism -subgraph_isomorphisms <- function(pattern, target, - method = c("lad", "vf2"), ...) { +subgraph_isomorphisms <- function( + pattern, + target, + method = c("lad", "vf2"), + ... +) { method <- igraph.match.arg(method) if (method == "lad") { From beb66233271de13814963735610c576c81a6e2f7 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 14:01:04 +0200 Subject: [PATCH 48/59] trees --- R/trees.R | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/R/trees.R b/R/trees.R index 46fa72a8628..5a0f135fe90 100644 --- a/R/trees.R +++ b/R/trees.R @@ -41,7 +41,11 @@ #' @family trees #' @export #' @cdocs igraph_is_tree -is_tree <- function(graph, mode = c("out", "in", "all", "total"), details = FALSE) { +is_tree <- function( + graph, + mode = c("out", "in", "all", "total"), + details = FALSE +) { out <- is_tree_impl(graph, mode, details) if (isTRUE(details) && !out$res && vcount(graph) > 0) { out$root <- V(graph)[1] From 9b661653a4b0e347d833a724e1a4b95f9ebe0da5 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 14:01:09 +0200 Subject: [PATCH 49/59] triangles --- R/triangles.R | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/R/triangles.R b/R/triangles.R index 340917114f5..d9d31fe665c 100644 --- a/R/triangles.R +++ b/R/triangles.R @@ -8,8 +8,13 @@ #' @inheritParams count_triangles #' @keywords internal #' @export -adjacent.triangles <- function(graph, vids = V(graph)) { # nocov start - lifecycle::deprecate_soft("2.0.0", "adjacent.triangles()", "count_triangles()") +adjacent.triangles <- function(graph, vids = V(graph)) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "adjacent.triangles()", + "count_triangles()" + ) count_triangles(graph = graph, vids = vids) } # nocov end @@ -36,7 +41,6 @@ adjacent.triangles <- function(graph, vids = V(graph)) { # nocov start ## ## ----------------------------------------------------------------------- - #' Find triangles in graphs #' #' Count how many triangles a vertex is part of, in a graph, or just list the From 0143c66beca4632ea0a7e8f8b448e2bbf1be7c80 Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 14:01:17 +0200 Subject: [PATCH 50/59] utils-assert-args --- R/utils-assert-args.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/utils-assert-args.R b/R/utils-assert-args.R index 75952217dbf..c6fc65f708c 100644 --- a/R/utils-assert-args.R +++ b/R/utils-assert-args.R @@ -36,6 +36,9 @@ igraph.match.arg <- function(arg, values, error_call = rlang::caller_env()) { #' @importFrom rlang caller_env ensure_no_na <- function(x, what, call = caller_env()) { if (anyNA(x)) { - cli::cli_abort("Cannot create a graph object because the {what} contains NAs.", call = call) + cli::cli_abort( + "Cannot create a graph object because the {what} contains NAs.", + call = call + ) } } From 85b15bf073462377e45361b35fbd1e8a0e40fcbd Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 14:01:23 +0200 Subject: [PATCH 51/59] utils-s3 --- R/utils-s3.R | 27 ++++++++++++++++----------- 1 file changed, 16 insertions(+), 11 deletions(-) diff --git a/R/utils-s3.R b/R/utils-s3.R index ac18c529de6..139c3fab1d4 100644 --- a/R/utils-s3.R +++ b/R/utils-s3.R @@ -33,7 +33,6 @@ s3_register <- function(generic, class, method = NULL) { method_fn <- get_method(method) stopifnot(is.function(method_fn)) - # Only register if generic can be accessed if (exists(generic, envir)) { registerS3method(generic, class, method_fn, envir = envir) @@ -47,7 +46,10 @@ s3_register <- function(generic, class, method = NULL) { package ), "i" = "This message is only shown to developers using devtools.", - "i" = sprintf("Do you need to update %s to the latest version?", package) + "i" = sprintf( + "Do you need to update %s to the latest version?", + package + ) )) } } @@ -76,21 +78,23 @@ s3_register <- function(generic, class, method = NULL) { .rlang_s3_register_compat <- function(fn, try_rlang = TRUE) { # Compats that behave the same independently of rlang's presence - out <- switch(fn, + out <- switch( + fn, is_installed = return(function(pkg) requireNamespace(pkg, quietly = TRUE)) ) # Only use rlang if it is fully loaded (#1482) - if (try_rlang && - requireNamespace("rlang", quietly = TRUE) && - environmentIsLocked(asNamespace("rlang"))) { - switch(fn, - is_interactive = return(rlang::is_interactive) - ) + if ( + try_rlang && + requireNamespace("rlang", quietly = TRUE) && + environmentIsLocked(asNamespace("rlang")) + ) { + switch(fn, is_interactive = return(rlang::is_interactive)) # Make sure rlang knows about "x" and "i" bullets if (utils::packageVersion("rlang") >= "0.4.2") { - switch(fn, + switch( + fn, abort = return(rlang::abort), warn = return((rlang::warn)), inform = return(rlang::inform) @@ -110,7 +114,8 @@ s3_register <- function(generic, class, method = NULL) { } format_msg <- function(x) paste(x, collapse = "\n") - switch(fn, + switch( + fn, is_interactive = return(is_interactive_compat), abort = return(function(msg) stop(format_msg(msg), call. = FALSE)), warn = return(function(msg) warning(format_msg(msg), call. = FALSE)), From abcb8cf39970e46fdbf447b452ae33e016dddfec Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 10 Jun 2025 14:01:28 +0200 Subject: [PATCH 52/59] utils --- R/utils.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/R/utils.R b/R/utils.R index f81495fd283..fad1d5c10e6 100644 --- a/R/utils.R +++ b/R/utils.R @@ -22,7 +22,9 @@ ## ----------------------------------------------------------------------- make_call <- function(f, ..., .args = list()) { - if (is.character(f)) f <- as.name(f) + if (is.character(f)) { + f <- as.name(f) + } as.call(c(f, ..., .args)) } From b50493fc694ed110c3d50f51787561d7d434b878 Mon Sep 17 00:00:00 2001 From: schochastics Date: Thu, 12 Jun 2025 11:22:15 +0200 Subject: [PATCH 53/59] reformatted with make_graph as skip --- R/components.R | 107 ++- R/hrg.R | 192 +++- R/simple.R | 3 +- R/sparsedf.R | 7 +- air.toml | 4 +- demo/centrality.R | 23 +- demo/cohesive.R | 13 +- demo/community.R | 18 +- demo/crashR.R | 1 - demo/hrg.R | 10 +- demo/smallworld.R | 15 +- inst/benchmarks/correlated.R | 16 +- inst/benchmarks/local.scan.R | 161 +++- inst/benchmarks/time_call.R | 37 +- inst/benchmarks/time_dirSelect.R | 18 +- inst/benchmarks/time_fr_layout.R | 37 +- inst/benchmarks/time_kk_layout.R | 55 +- inst/benchmarks/time_print.R | 177 ++-- inst/benchmarks/time_sgm.R | 33 +- inst/benchmarks/time_sir.R | 19 +- inst/lifecycle/deprecated-table-creation.R | 4 +- man/roxygen/meta.R | 2 +- tests/testthat/test-adjacency.R | 108 ++- tests/testthat/test-assortativity.R | 8 +- tests/testthat/test-bipartite.R | 8 +- tests/testthat/test-centrality.R | 132 ++- tests/testthat/test-cliques.R | 26 +- tests/testthat/test-community.R | 154 +++- tests/testthat/test-components.R | 33 +- tests/testthat/test-conversion.R | 135 ++- tests/testthat/test-decomposition.R | 16 +- tests/testthat/test-efficiency.R | 10 +- tests/testthat/test-embedding.R | 966 +++++++++++++++------ tests/testthat/test-eulerian.R | 5 +- tests/testthat/test-flow.R | 83 +- tests/testthat/test-foreign.R | 10 +- tests/testthat/test-games.R | 318 +++++-- tests/testthat/test-glet.R | 20 +- tests/testthat/test-incidence.R | 77 +- tests/testthat/test-indexing.R | 82 +- tests/testthat/test-iterators.R | 4 +- tests/testthat/test-layout.R | 4 +- tests/testthat/test-make.R | 94 +- tests/testthat/test-motifs.R | 18 +- tests/testthat/test-operators.R | 99 ++- tests/testthat/test-other.R | 16 +- tests/testthat/test-plot.R | 3 +- tests/testthat/test-print.R | 45 +- tests/testthat/test-random_walk.R | 12 +- tests/testthat/test-sgm.R | 14 +- tests/testthat/test-sparsedf.R | 5 +- tests/testthat/test-topology.R | 67 +- tests/testthat/test-trees.R | 30 +- tests/testthat/test-versions.R | 2 +- tests/testthat/test-weakref.R | 3 +- tools/add-ctags.R | 42 +- tools/deprecate-make.R | 64 +- tools/deprecate-tests.R | 26 +- tools/deprecate.R | 63 +- tools/expect_equal.R | 20 +- tools/extract_examples.R | 9 +- tools/find-duplicate-seealso.R | 14 +- tools/rd.R | 12 +- tools/sync-yaml.R | 17 +- tools/update-examples.R | 20 +- 65 files changed, 2897 insertions(+), 949 deletions(-) diff --git a/R/components.R b/R/components.R index 6d8cacc0ec5..67e8a4fcbb5 100644 --- a/R/components.R +++ b/R/components.R @@ -8,7 +8,8 @@ #' @inheritParams count_components #' @keywords internal #' @export -no.clusters <- function(graph, mode = c("weak", "strong")) { # nocov start +no.clusters <- function(graph, mode = c("weak", "strong")) { + # nocov start lifecycle::deprecate_soft("2.0.0", "no.clusters()", "count_components()") count_components(graph = graph, mode = mode) } # nocov end @@ -23,9 +24,20 @@ no.clusters <- function(graph, mode = c("weak", "strong")) { # nocov start #' @inheritParams decompose #' @keywords internal #' @export -decompose.graph <- function(graph, mode = c("weak", "strong"), max.comps = NA, min.vertices = 0) { # nocov start +decompose.graph <- function( + graph, + mode = c("weak", "strong"), + max.comps = NA, + min.vertices = 0 +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "decompose.graph()", "decompose()") - decompose(graph = graph, mode = mode, max.comps = max.comps, min.vertices = min.vertices) + decompose( + graph = graph, + mode = mode, + max.comps = max.comps, + min.vertices = min.vertices + ) } # nocov end #' Connected components of a graph @@ -38,9 +50,24 @@ decompose.graph <- function(graph, mode = c("weak", "strong"), max.comps = NA, m #' @inheritParams component_distribution #' @keywords internal #' @export -cluster.distribution <- function(graph, cumulative = FALSE, mul.size = FALSE, ...) { # nocov start - lifecycle::deprecate_soft("2.0.0", "cluster.distribution()", "component_distribution()") - component_distribution(graph = graph, cumulative = cumulative, mul.size = mul.size, ...) +cluster.distribution <- function( + graph, + cumulative = FALSE, + mul.size = FALSE, + ... +) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "cluster.distribution()", + "component_distribution()" + ) + component_distribution( + graph = graph, + cumulative = cumulative, + mul.size = mul.size, + ... + ) } # nocov end #' Biconnected components @@ -53,8 +80,13 @@ cluster.distribution <- function(graph, cumulative = FALSE, mul.size = FALSE, .. #' @inheritParams biconnected_components #' @keywords internal #' @export -biconnected.components <- function(graph) { # nocov start - lifecycle::deprecate_soft("2.0.0", "biconnected.components()", "biconnected_components()") +biconnected.components <- function(graph) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "biconnected.components()", + "biconnected_components()" + ) biconnected_components(graph = graph) } # nocov end @@ -68,8 +100,13 @@ biconnected.components <- function(graph) { # nocov start #' @inheritParams articulation_points #' @keywords internal #' @export -articulation.points <- function(graph) { # nocov start - lifecycle::deprecate_soft("2.0.0", "articulation.points()", "articulation_points()") +articulation.points <- function(graph) { + # nocov start + lifecycle::deprecate_soft( + "2.0.0", + "articulation.points()", + "articulation_points()" + ) articulation_points(graph = graph) } # nocov end # IGraph R package @@ -105,8 +142,12 @@ articulation.points <- function(graph) { # nocov start #' @family components #' @export #' @importFrom graphics hist -component_distribution <- function(graph, cumulative = FALSE, mul.size = FALSE, - ...) { +component_distribution <- function( + graph, + cumulative = FALSE, + mul.size = FALSE, + ... +) { ensure_igraph(graph) cs <- components(graph, ...)$csize @@ -125,7 +166,6 @@ component_distribution <- function(graph, cumulative = FALSE, mul.size = FALSE, } - #' Decompose a graph into components #' #' Creates a separate graph for each connected component of a graph. @@ -156,22 +196,26 @@ component_distribution <- function(graph, cumulative = FALSE, mul.size = FALSE, #' components <- decompose(g, min.vertices = 2) #' sapply(components, diameter) #' -decompose <- function(graph, mode = c("weak", "strong"), max.comps = NA, - min.vertices = 0) { +decompose <- function( + graph, + mode = c("weak", "strong"), + max.comps = NA, + min.vertices = 0 +) { ensure_igraph(graph) mode <- igraph.match.arg(mode) - mode <- switch(mode, - "weak" = 1L, - "strong" = 2L - ) + mode <- switch(mode, "weak" = 1L, "strong" = 2L) if (is.na(max.comps)) { max.comps <- -1 } on.exit(.Call(R_igraph_finalizer)) .Call( - R_igraph_decompose, graph, as.numeric(mode), - as.numeric(max.comps), as.numeric(min.vertices) + R_igraph_decompose, + graph, + as.numeric(mode), + as.numeric(max.comps), + as.numeric(min.vertices) ) } @@ -277,16 +321,31 @@ biconnected_components <- function(graph) { # See https://github.com/igraph/rigraph/issues/1203 if (igraph_opt("return.vs.es")) { - res$tree_edges <- lapply(res$tree_edges, unsafe_create_es, graph = graph, es = E(graph)) + res$tree_edges <- lapply( + res$tree_edges, + unsafe_create_es, + graph = graph, + es = E(graph) + ) res$tree.edges <- NULL } if (igraph_opt("return.vs.es")) { - res$component_edges <- lapply(res$component_edges, unsafe_create_es, graph = graph, es = E(graph)) + res$component_edges <- lapply( + res$component_edges, + unsafe_create_es, + graph = graph, + es = E(graph) + ) res$component.edges <- NULL } if (igraph_opt("return.vs.es")) { - res$components <- lapply(res$components, unsafe_create_vs, graph = graph, verts = V(graph)) + res$components <- lapply( + res$components, + unsafe_create_vs, + graph = graph, + verts = V(graph) + ) } if (igraph_opt("return.vs.es")) { res$articulation_points <- create_vs(graph, res$articulation_points) diff --git a/R/hrg.R b/R/hrg.R index 30ae99e2a7e..8ba3ee800c8 100644 --- a/R/hrg.R +++ b/R/hrg.R @@ -8,9 +8,22 @@ #' @inheritParams predict_edges #' @keywords internal #' @export -hrg.predict <- function(graph, hrg = NULL, start = FALSE, num.samples = 10000, num.bins = 25) { # nocov start +hrg.predict <- function( + graph, + hrg = NULL, + start = FALSE, + num.samples = 10000, + num.bins = 25 +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "hrg.predict()", "predict_edges()") - predict_edges(graph = graph, hrg = hrg, start = start, num.samples = num.samples, num.bins = num.bins) + predict_edges( + graph = graph, + hrg = hrg, + start = start, + num.samples = num.samples, + num.bins = num.bins + ) } # nocov end #' Fit a hierarchical random graph model @@ -23,7 +36,8 @@ hrg.predict <- function(graph, hrg = NULL, start = FALSE, num.samples = 10000, n #' @inheritParams fit_hrg #' @keywords internal #' @export -hrg.fit <- function(graph, hrg = NULL, start = FALSE, steps = 0) { # nocov start +hrg.fit <- function(graph, hrg = NULL, start = FALSE, steps = 0) { + # nocov start lifecycle::deprecate_soft("2.0.0", "hrg.fit()", "fit_hrg()") fit_hrg(graph = graph, hrg = hrg, start = start, steps = steps) } # nocov end @@ -38,7 +52,8 @@ hrg.fit <- function(graph, hrg = NULL, start = FALSE, steps = 0) { # nocov start #' @inheritParams sample_hrg #' @keywords internal #' @export -hrg.game <- function(hrg) { # nocov start +hrg.game <- function(hrg) { + # nocov start lifecycle::deprecate_soft("2.0.0", "hrg.game()", "sample_hrg()") sample_hrg(hrg = hrg) } # nocov end @@ -53,7 +68,8 @@ hrg.game <- function(hrg) { # nocov start #' @inheritParams hrg_tree #' @keywords internal #' @export -hrg.dendrogram <- function(hrg) { # nocov start +hrg.dendrogram <- function(hrg) { + # nocov start lifecycle::deprecate_soft("2.0.0", "hrg.dendrogram()", "hrg_tree()") hrg_tree(hrg = hrg) } # nocov end @@ -68,7 +84,8 @@ hrg.dendrogram <- function(hrg) { # nocov start #' @inheritParams hrg #' @keywords internal #' @export -hrg.create <- function(graph, prob) { # nocov start +hrg.create <- function(graph, prob) { + # nocov start lifecycle::deprecate_soft("2.0.0", "hrg.create()", "hrg()") hrg(graph = graph, prob = prob) } # nocov end @@ -83,9 +100,20 @@ hrg.create <- function(graph, prob) { # nocov start #' @inheritParams consensus_tree #' @keywords internal #' @export -hrg.consensus <- function(graph, hrg = NULL, start = FALSE, num.samples = 10000) { # nocov start +hrg.consensus <- function( + graph, + hrg = NULL, + start = FALSE, + num.samples = 10000 +) { + # nocov start lifecycle::deprecate_soft("2.0.0", "hrg.consensus()", "consensus_tree()") - consensus_tree(graph = graph, hrg = hrg, start = start, num.samples = num.samples) + consensus_tree( + graph = graph, + hrg = hrg, + start = start, + num.samples = num.samples + ) } # nocov end # IGraph R package # Copyright (C) 2011-2012 Gabor Csardi @@ -209,7 +237,10 @@ fit_hrg <- function(graph, hrg = NULL, start = FALSE, steps = 0) { ensure_igraph(graph) if (is.null(hrg)) { hrg <- list( - left = c(), right = c(), prob = c(), edges = c(), + left = c(), + right = c(), + prob = c(), + edges = c(), vertices = c() ) } @@ -303,9 +334,10 @@ hrg <- hrg_create_impl #' @export #' @cdocs igraph_from_hrg_dendrogram hrg_tree <- function(hrg) { - if (!inherits(hrg, "igraphHRG")) { - cli::cli_abort("{.arg hrg} must be an {.cls igraphHRG} object, not {.obj_type_friendly {hrg}}.") + cli::cli_abort( + "{.arg hrg} must be an {.cls igraphHRG} object, not {.obj_type_friendly {hrg}}." + ) } out <- from_hrg_dendrogram_impl(hrg) @@ -327,9 +359,10 @@ hrg_tree <- function(hrg) { #' @export #' @cdocs igraph_hrg_game sample_hrg <- function(hrg) { - if (!inherits(hrg, "igraphHRG")) { - cli::cli_abort("{.arg hrg} must be an {.cls igraphHRG} object, not {.obj_type_friendly {hrg}}.") + cli::cli_abort( + "{.arg hrg} must be an {.cls igraphHRG} object, not {.obj_type_friendly {hrg}}." + ) } hrg_game_impl(hrg) @@ -391,13 +424,21 @@ sample_hrg <- function(hrg) { #' predict_edges(g2) #' @export #' @family hierarchical random graph functions -predict_edges <- function(graph, hrg = NULL, start = FALSE, num.samples = 10000, - num.bins = 25) { +predict_edges <- function( + graph, + hrg = NULL, + start = FALSE, + num.samples = 10000, + num.bins = 25 +) { # Argument checks ensure_igraph(graph) if (is.null(hrg)) { hrg <- list( - left = c(), right = c(), prob = c(), edges = c(), + left = c(), + right = c(), + prob = c(), + edges = c(), vertices = c() ) } @@ -412,7 +453,11 @@ predict_edges <- function(graph, hrg = NULL, start = FALSE, num.samples = 10000, on.exit(.Call(R_igraph_finalizer)) # Function call res <- .Call( - R_igraph_hrg_predict, graph, hrg, start, num.samples, + R_igraph_hrg_predict, + graph, + hrg, + start, + num.samples, num.bins ) res$edges <- matrix(res$edges, ncol = 2, byrow = TRUE) @@ -421,7 +466,6 @@ predict_edges <- function(graph, hrg = NULL, start = FALSE, num.samples = 10000, } - #' Conversion to igraph #' #' These functions convert various objects to igraph graphs. @@ -481,9 +525,11 @@ buildMerges <- function(object) { while (length(S) != 0) { curr <- S[length(S)] ## coming from parent? going left if possible. - if (is.null(prev) || - (prev < 0 && object$left[-prev] == curr) || - (prev < 0 && object$right[-prev] == curr)) { + if ( + is.null(prev) || + (prev < 0 && object$left[-prev] == curr) || + (prev < 0 && object$right[-prev] == curr) + ) { if (curr < 0) { S <- c(S, object$left[-curr]) } @@ -527,7 +573,8 @@ as.dendrogram.igraphHRG <- function(object, hang = 0.01, ...) { if (any(neg <- x >= 0)) { h0 <- if (hang < 0) 0 else max(0, oHgt[k] - hang * hMax) } - if (all(neg)) { # two leaves + if (all(neg)) { + # two leaves zk <- as.list(x + 1) attr(zk, "members") <- 2L attr(zk, "midpoint") <- 1 / 2 # mean( c(0,1) ) @@ -537,7 +584,8 @@ as.dendrogram.igraphHRG <- function(object, hang = 0.01, ...) { attr(zk[[1]], "members") <- attr(zk[[2]], "members") <- 1L attr(zk[[1]], "height") <- attr(zk[[2]], "height") <- h0 attr(zk[[1]], "leaf") <- attr(zk[[2]], "leaf") <- TRUE - } else if (any(neg)) { # one leaf, one node + } else if (any(neg)) { + # one leaf, one node X <- paste0("g", -x) isL <- x[1] >= 0 zk <- if (isL) list(x[1] + 1, z[[X[2]]]) else list(z[[X[1]]], x[2] + 1) @@ -548,14 +596,16 @@ as.dendrogram.igraphHRG <- function(object, hang = 0.01, ...) { attr(zk[[2 - isL]], "height") <- h0 attr(zk[[2 - isL]], "label") <- mynames[x[2 - isL] + 1] attr(zk[[2 - isL]], "leaf") <- TRUE - } else { # two nodes + } else { + # two nodes X <- paste0("g", -x) zk <- list(z[[X[1]]], z[[X[2]]]) attr(zk, "members") <- attr(z[[X[1]]], "members") + attr(z[[X[2]]], "members") attr(zk, "midpoint") <- (attr(z[[X[1]]], "members") + attr(z[[X[1]]], "midpoint") + - attr(z[[X[2]]], "midpoint")) / 2 + attr(z[[X[2]]], "midpoint")) / + 2 } attr(zk, "height") <- oHgt[k] z[[k <- paste0("g", -merges[k, 3])]] <- zk @@ -600,8 +650,11 @@ as.hclust.igraphHRG <- function(x, ...) { mynames <- if (is.null(x$names)) 1:n else x$names res <- list( - merge = merge, height = 1:nrow(merge), order = order, - labels = mynames, method = NA_character_, + merge = merge, + height = 1:nrow(merge), + order = order, + labels = mynames, + method = NA_character_, dist.method = NA_character_ ) class(res) <- "hclust" @@ -621,7 +674,9 @@ as.phylo.igraphHRG <- function(x, ...) { edge.length <- rep(0.5, nrow(edge)) labels <- if (is.null(x$names)) 1:ovc else x$names obj <- list( - edge = edge, edge.length = edge.length / 2, tip.label = labels, + edge = edge, + edge.length = edge.length / 2, + tip.label = labels, Nnode = ivc ) class(obj) <- "phylo" @@ -705,7 +760,11 @@ rlang::on_load(s3_register("ape::as.phylo", "igraphHRG")) #' hrg <- fit_hrg(g) #' plot_dendrogram(hrg) #' -plot_dendrogram.igraphHRG <- function(x, mode = igraph_opt("dend.plot.type"), ...) { +plot_dendrogram.igraphHRG <- function( + x, + mode = igraph_opt("dend.plot.type"), + ... +) { if (mode == "auto") { have_ape <- requireNamespace("ape", quietly = TRUE) mode <- if (have_ape) "phylo" else "hclust" @@ -723,13 +782,28 @@ plot_dendrogram.igraphHRG <- function(x, mode = igraph_opt("dend.plot.type"), .. #' @importFrom graphics plot #' @importFrom grDevices rainbow #' @importFrom stats rect.hclust -hrgPlotHclust <- function(x, rect = 0, colbar = rainbow(rect), hang = .01, - ann = FALSE, main = "", sub = "", xlab = "", ylab = "", - ...) { +hrgPlotHclust <- function( + x, + rect = 0, + colbar = rainbow(rect), + hang = .01, + ann = FALSE, + main = "", + sub = "", + xlab = "", + ylab = "", + ... +) { hc <- as.hclust(x) - ret <- plot(hc, - hang = hang, ann = ann, main = main, sub = sub, xlab = xlab, - ylab = ylab, ... + ret <- plot( + hc, + hang = hang, + ann = ann, + main = main, + sub = sub, + xlab = xlab, + ylab = ylab, + ... ) if (rect > 0) { rect.hclust(hc, k = rect, border = colbar) @@ -744,8 +818,13 @@ hrgPlotDendrogram <- function(x, ...) { #' @importFrom graphics plot #' @importFrom grDevices rainbow -hrgPlotPhylo <- function(x, colbar = rainbow(11, start = .7, end = .1), - edge.color = NULL, use.edge.length = FALSE, ...) { +hrgPlotPhylo <- function( + x, + colbar = rainbow(11, start = .7, end = .1), + edge.color = NULL, + use.edge.length = FALSE, + ... +) { vc <- length(x$left) + 1 phy <- ape::as.phylo(x) br <- seq(0, 1, length.out = length(colbar)) @@ -801,8 +880,12 @@ hrgPlotPhylo <- function(x, colbar = rainbow(11, start = .7, end = .1), #' @method print igraphHRG #' @export #' @family hierarchical random graph functions -print.igraphHRG <- function(x, type = c("auto", "tree", "plain"), - level = 3, ...) { +print.igraphHRG <- function( + x, + type = c("auto", "tree", "plain"), + level = 3, + ... +) { type <- igraph.match.arg(type) if (type == "auto") { type <- if (length(x$left <= 100)) "tree" else "plain" @@ -908,19 +991,26 @@ print1.igraphHRG <- function(x, level = 3, ...) { lf <- paste(collapse = "\n", lf) } op <- paste( - sep = "", format(he, width = cs), - " p=", format(x$prob[b], digits = 2, width = pw, justify = "left"), - " ", paste(collapse = " ", lf) + sep = "", + format(he, width = cs), + " p=", + format(x$prob[b], digits = 2, width = pw, justify = "left"), + " ", + paste(collapse = " ", lf) ) cat(op, fill = TRUE) ## recursive call - if (x$left[b] < 0 && l < level) .plot(-x$left[b], l + 1, ind) + if (x$left[b] < 0 && l < level) { + .plot(-x$left[b], l + 1, ind) + } if (x$right[b] < 0 && l < level) .plot(-x$right[b], l + 1, ind) } ## Do it - if (length(x$left) > 0) .plot(b = 1, l = 1) + if (length(x$left) > 0) { + .plot(b = 1, l = 1) + } invisible(x) } @@ -943,9 +1033,13 @@ print2.igraphHRG <- function(x, ...) { nn[x$right[i] + 1] } paste( - sep = "", format(paste(sep = "", "g", i), width = bw), + sep = "", + format(paste(sep = "", "g", i), width = bw), format(paste(sep = "", " p=", p[i]), width = pw), - "-> ", lc, " ", rc + "-> ", + lc, + " ", + rc ) }) op <- format(op, justify = "left") @@ -987,9 +1081,11 @@ print.igraphHRGConsensus <- function(x, ...) { mych <- gsub(" ", "x", mych, fixed = TRUE) mych <- paste(collapse = " ", mych) pref <- paste(collapse = "", rep(" ", bw + 5)) - mych <- strwrap(mych, + mych <- strwrap( + mych, width = getOption("width") - bw - 4, - initial = "", prefix = pref + initial = "", + prefix = pref ) mych <- gsub("x", " ", mych, fixed = TRUE) mych <- paste(collapse = "\n", mych) diff --git a/R/simple.R b/R/simple.R index 51037f6f229..0eb9c38e488 100644 --- a/R/simple.R +++ b/R/simple.R @@ -8,7 +8,8 @@ #' @inheritParams is_simple #' @keywords internal #' @export -is.simple <- function(graph) { # nocov start +is.simple <- function(graph) { + # nocov start lifecycle::deprecate_soft("2.0.0", "is.simple()", "is_simple()") is_simple(graph = graph) } # nocov end diff --git a/R/sparsedf.R b/R/sparsedf.R index 979747eaba8..b52aba0a6b1 100644 --- a/R/sparsedf.R +++ b/R/sparsedf.R @@ -26,8 +26,11 @@ sdf <- function(..., row.names = NULL, NROW = NULL) { cols <- list(...) - if (is.null(names(cols)) || any(names(cols) == "") || - any(duplicated(names(cols)))) { + if ( + is.null(names(cols)) || + any(names(cols) == "") || + any(duplicated(names(cols))) + ) { cli::cli_abort("Columns must be have (unique) names.") } diff --git a/air.toml b/air.toml index 489b4b12894..56cfb63f106 100644 --- a/air.toml +++ b/air.toml @@ -4,5 +4,5 @@ indent-width = 2 indent-style = "space" line-ending = "auto" persistent-line-breaks = true -default-exclude = TRUE -skip = ["tribble", "graph_from_literal","matrix","c"] \ No newline at end of file +default-exclude = true +skip = ["tribble", "graph_from_literal", "matrix", "c", "make_graph"] diff --git a/demo/centrality.R b/demo/centrality.R index 80e23048d62..83e5a5c09b9 100644 --- a/demo/centrality.R +++ b/demo/centrality.R @@ -1,4 +1,3 @@ - pause <- function() {} ### Traditional approaches: degree, closeness, betweenness @@ -34,10 +33,16 @@ pause() ### Take a look at it plotG <- function(g) { - plot(g, - asp = FALSE, vertex.label.color = "blue", vertex.label.cex = 1.5, - vertex.label.font = 2, vertex.size = 25, vertex.color = "white", - vertex.frame.color = "white", edge.color = "black" + plot( + g, + asp = FALSE, + vertex.label.color = "blue", + vertex.label.cex = 1.5, + vertex.label.font = 2, + vertex.size = 25, + vertex.color = "white", + vertex.frame.color = "white", + edge.color = "black" ) } plotG(g) @@ -93,7 +98,13 @@ pause() ### Pairs plot pairs(cent, lower.panel = function(x, y) { usr <- par("usr") - text(mean(usr[1:2]), mean(usr[3:4]), round(cor(x, y), 3), cex = 2, col = "blue") + text( + mean(usr[1:2]), + mean(usr[3:4]), + round(cor(x, y), 3), + cex = 2, + col = "blue" + ) }) pause() diff --git a/demo/cohesive.R b/demo/cohesive.R index 29c086a7f01..f38e3e696ee 100644 --- a/demo/cohesive.R +++ b/demo/cohesive.R @@ -1,4 +1,3 @@ - pause <- function() {} ### The Zachary Karate club network @@ -36,16 +35,18 @@ plot_hierarchy(cbKarate) ## Plot the first level, blocks 1 & 2 -plot(cbKarate, karate, - mark.groups = blocks(cbKarate)[1:2 + 1], - col = "cyan" -) +plot(cbKarate, karate, mark.groups = blocks(cbKarate)[1:2 + 1], col = "cyan") pause() ### The second group is simple, plot its more cohesive subgroup -plot(cbKarate, karate, mark.groups = blocks(cbKarate)[c(2, 5) + 1], col = "cyan") +plot( + cbKarate, + karate, + mark.groups = blocks(cbKarate)[c(2, 5) + 1], + col = "cyan" +) pause() diff --git a/demo/community.R b/demo/community.R index 6ef423db61f..4dbf578a746 100644 --- a/demo/community.R +++ b/demo/community.R @@ -1,4 +1,3 @@ - pause <- function() {} ### A modular graph has dense subgraphs @@ -142,11 +141,15 @@ coords <- layout_with_kk(karate) lapply(seq_along(communities), function(x) { m <- modularity(communities[[x]]) par(mar = c(1, 1, 3, 1)) - plot(communities[[x]], karate, + plot( + communities[[x]], + karate, layout = coords, main = paste( - names(communities)[x], "\n", - "Modularity:", round(m, 3) + names(communities)[x], + "\n", + "Modularity:", + round(m, 3) ) ) }) @@ -159,10 +162,13 @@ clique.community <- function(graph, k) { edges <- c() for (i in seq(along.with = clq)) { for (j in seq(along.with = clq)) { - if (length(unique(c( + if ( + length(unique(c( clq[[i]], clq[[j]] - ))) == k + 1) { + ))) == + k + 1 + ) { edges <- c(edges, c(i, j)) } } diff --git a/demo/crashR.R b/demo/crashR.R index 33bfa555850..07d4b8390cd 100644 --- a/demo/crashR.R +++ b/demo/crashR.R @@ -1,4 +1,3 @@ - pause <- function() {} ### R objects, (real) numbers diff --git a/demo/hrg.R b/demo/hrg.R index 0bf4d3efe4c..5c5fe4a1b6a 100644 --- a/demo/hrg.R +++ b/demo/hrg.R @@ -1,4 +1,3 @@ - pause <- function() {} ### Construct the Zachary Karate Club network @@ -44,9 +43,12 @@ colbar <- rainbow(length(optcom)) vc <- ifelse(is.na(V(ihrg)$prob), colbar[V(karate)$comm], "darkblue") V(ihrg)$label <- ifelse(is.na(V(ihrg)$prob), vn, round(V(ihrg)$prob, 2)) par(mar = c(0, 0, 3, 0)) -plot(ihrg, - vertex.size = 10, edge.arrow.size = 0.2, - vertex.shape = "none", vertex.label.color = vc, +plot( + ihrg, + vertex.size = 10, + edge.arrow.size = 0.2, + vertex.shape = "none", + vertex.label.color = vc, main = "Hierarchical network model of the Karate Club" ) diff --git a/demo/smallworld.R b/demo/smallworld.R index 79cb592e2c9..8d66545fb7f 100644 --- a/demo/smallworld.R +++ b/demo/smallworld.R @@ -1,4 +1,3 @@ - pause <- function() {} ### Create a star-like graph @@ -174,11 +173,17 @@ dim(ws.result) pause() ### Plot it -plot(rewire.prob, ws.result[1, ] / ws.result[1, 1], - log = "x", pch = 22, - xlab = "p", ylab = "" +plot( + rewire.prob, + ws.result[1, ] / ws.result[1, 1], + log = "x", + pch = 22, + xlab = "p", + ylab = "" ) points(rewire.prob, ws.result[2, ] / ws.result[2, 1], pch = 20) -legend("bottomleft", c(expression(C(p) / C(0)), expression(L(p) / L(0))), +legend( + "bottomleft", + c(expression(C(p) / C(0)), expression(L(p) / L(0))), pch = c(22, 20) ) diff --git a/inst/benchmarks/correlated.R b/inst/benchmarks/correlated.R index 2397d0ef9f8..5e46fc94829 100644 --- a/inst/benchmarks/correlated.R +++ b/inst/benchmarks/correlated.R @@ -1,8 +1,12 @@ - time_group("correlated E-R graphs, v1") -time_that("sample_correlated_gnp is fast", replications=10, - init={ library(igraph) }, - { sample_correlated_gnp_pair(100, corr=.8, p=5/100) }) - - +time_that( + "sample_correlated_gnp is fast", + replications = 10, + init = { + library(igraph) + }, + { + sample_correlated_gnp_pair(100, corr = .8, p = 5 / 100) + } +) diff --git a/inst/benchmarks/local.scan.R b/inst/benchmarks/local.scan.R index 9453ce1fd58..ce5b197af06 100644 --- a/inst/benchmarks/local.scan.R +++ b/inst/benchmarks/local.scan.R @@ -1,57 +1,132 @@ - time_group("local scan v1") -init <- expression({library(igraph); set.seed(42) }) -reinit <- expression({g <- random.graph.game(1000, p=.1) - E(g)$weight <- sample(ecount(g)) - gp <- random.graph.game(1000, p=.1) - E(gp)$weight <- sample(ecount(gp)) - }) +init <- expression({ + library(igraph) + set.seed(42) +}) +reinit <- expression({ + g <- random.graph.game(1000, p = .1) + E(g)$weight <- sample(ecount(g)) + gp <- random.graph.game(1000, p = .1) + E(gp)$weight <- sample(ecount(gp)) +}) -time_that("us, scan-0, unweighted", - replications=10, init=init, reinit=reinit, - { local_scan(g, k=0) }) +time_that( + "us, scan-0, unweighted", + replications = 10, + init = init, + reinit = reinit, + { + local_scan(g, k = 0) + } +) -time_that("us, scan-0, weighted", - replications=10, init=init, reinit=reinit, - { local_scan(g, k=0, weighted=TRUE) }) +time_that( + "us, scan-0, weighted", + replications = 10, + init = init, + reinit = reinit, + { + local_scan(g, k = 0, weighted = TRUE) + } +) -time_that("us, scan-1, unweighted", - replications=10, init=init, reinit=reinit, - { local_scan(g, k=1) }) +time_that( + "us, scan-1, unweighted", + replications = 10, + init = init, + reinit = reinit, + { + local_scan(g, k = 1) + } +) -time_that("us, scan-1, weighted", - replications=10, init=init, reinit=reinit, - { local_scan(g, k=1, weighted=TRUE) }) +time_that( + "us, scan-1, weighted", + replications = 10, + init = init, + reinit = reinit, + { + local_scan(g, k = 1, weighted = TRUE) + } +) -time_that("us, scan-2, unweighted", - replications=10, init=init, reinit=reinit, - { local_scan(g, k=2) }) +time_that( + "us, scan-2, unweighted", + replications = 10, + init = init, + reinit = reinit, + { + local_scan(g, k = 2) + } +) -time_that("us, scan-2, weighted", - replications=10, init=init, reinit=reinit, - { local_scan(g, k=2, weighted=TRUE) }) +time_that( + "us, scan-2, weighted", + replications = 10, + init = init, + reinit = reinit, + { + local_scan(g, k = 2, weighted = TRUE) + } +) -time_that("them, scan-0, unweighted", - replications=10, init=init, reinit=reinit, - { local_scan(g, gp, k=0) }) +time_that( + "them, scan-0, unweighted", + replications = 10, + init = init, + reinit = reinit, + { + local_scan(g, gp, k = 0) + } +) -time_that("them, scan-0, weighted", - replications=10, init=init, reinit=reinit, - { local_scan(g, gp, k=0, weighted=TRUE) }) +time_that( + "them, scan-0, weighted", + replications = 10, + init = init, + reinit = reinit, + { + local_scan(g, gp, k = 0, weighted = TRUE) + } +) -time_that("them, scan-1, unweighted", - replications=10, init=init, reinit=reinit, - { local_scan(g, gp, k=1)} ) +time_that( + "them, scan-1, unweighted", + replications = 10, + init = init, + reinit = reinit, + { + local_scan(g, gp, k = 1) + } +) -time_that("them, scan-1, weighted", - replications=10, init=init, reinit=reinit, - { local_scan(g, gp, k=1, weighted=TRUE) }) +time_that( + "them, scan-1, weighted", + replications = 10, + init = init, + reinit = reinit, + { + local_scan(g, gp, k = 1, weighted = TRUE) + } +) -time_that("them, scan-2, unweighted", - replications=10, init=init, reinit=reinit, - { local_scan(g, gp, k=2) }) +time_that( + "them, scan-2, unweighted", + replications = 10, + init = init, + reinit = reinit, + { + local_scan(g, gp, k = 2) + } +) -time_that("them, scan-2, weigthed", - replications=10, init=init, reinit=reinit, - { local_scan(g, gp, k=2, weighted=TRUE) }) +time_that( + "them, scan-2, weigthed", + replications = 10, + init = init, + reinit = reinit, + { + local_scan(g, gp, k = 2, weighted = TRUE) + } +) diff --git a/inst/benchmarks/time_call.R b/inst/benchmarks/time_call.R index 5f9debd73cc..23cfaa3483a 100644 --- a/inst/benchmarks/time_call.R +++ b/inst/benchmarks/time_call.R @@ -1,14 +1,29 @@ - time_group(".Call from R") -time_that("Redefining .Call does not have much overhead #1", replications=10, - init = { library(igraph) ; g <- graph.ring(100) }, - { for (i in 1:20000) { - .Call(R_igraph_vcount, g) - } }) +time_that( + "Redefining .Call does not have much overhead #1", + replications = 10, + init = { + library(igraph) + g <- graph.ring(100) + }, + { + for (i in 1:20000) { + .Call(R_igraph_vcount, g) + } + } +) -time_that("Redefining .Call does not have much overhead #1", replications=10, - init = { library(igraph) ; g <- graph.ring(100) }, - { for (i in 1:20000) { - igraph:::.Call(R_igraph_vcount, g) - } }) +time_that( + "Redefining .Call does not have much overhead #1", + replications = 10, + init = { + library(igraph) + g <- graph.ring(100) + }, + { + for (i in 1:20000) { + igraph:::.Call(R_igraph_vcount, g) + } + } +) diff --git a/inst/benchmarks/time_dirSelect.R b/inst/benchmarks/time_dirSelect.R index 94f89165de4..915aa97adb2 100644 --- a/inst/benchmarks/time_dirSelect.R +++ b/inst/benchmarks/time_dirSelect.R @@ -1,7 +1,15 @@ - time_group("dimensionality selection") -time_that("dimensionaility selection is fast", replications=10, - init = { library(igraph) }, - reinit = { sv <- c(rnorm(2000), rnorm(2000)/5) }, - { dim_select(sv) }) +time_that( + "dimensionaility selection is fast", + replications = 10, + init = { + library(igraph) + }, + reinit = { + sv <- c(rnorm(2000), rnorm(2000)/5) + }, + { + dim_select(sv) + } +) diff --git a/inst/benchmarks/time_fr_layout.R b/inst/benchmarks/time_fr_layout.R index 7a670c43bc8..4f67c282cda 100644 --- a/inst/benchmarks/time_fr_layout.R +++ b/inst/benchmarks/time_fr_layout.R @@ -1,12 +1,31 @@ - time_group("Fruchterman-Reingold layout") -time_that("FR layout is fast, connected", replications=10, - init = { library(igraph); set.seed(42) }, - reinit = { g <- sample_pa(400) }, - { layout_with_fr(g, niter=500) }) +time_that( + "FR layout is fast, connected", + replications = 10, + init = { + library(igraph) + set.seed(42) + }, + reinit = { + g <- sample_pa(400) + }, + { + layout_with_fr(g, niter = 500) + } +) -time_that("FR layout is fast, unconnected", replications=10, - init = { library(igraph); set.seed(42) }, - reinit = { g <- sample_gnm(400, 400) }, - { layout_with_fr(g, niter=500) }) +time_that( + "FR layout is fast, unconnected", + replications = 10, + init = { + library(igraph) + set.seed(42) + }, + reinit = { + g <- sample_gnm(400, 400) + }, + { + layout_with_fr(g, niter = 500) + } +) diff --git a/inst/benchmarks/time_kk_layout.R b/inst/benchmarks/time_kk_layout.R index eb6854cd75b..ed26cd23871 100644 --- a/inst/benchmarks/time_kk_layout.R +++ b/inst/benchmarks/time_kk_layout.R @@ -1,17 +1,46 @@ - time_group("Kamada-Kawai layout") -time_that("KK layout is fast, connected", replications=10, - init = { library(igraph); set.seed(42) }, - reinit = { g <- sample_pa(400) }, - { layout_with_kk(g, maxiter=500) }) +time_that( + "KK layout is fast, connected", + replications = 10, + init = { + library(igraph) + set.seed(42) + }, + reinit = { + g <- sample_pa(400) + }, + { + layout_with_kk(g, maxiter = 500) + } +) -time_that("KK layout is fast, unconnected", replications=10, - init = { library(igraph); set.seed(42) }, - reinit = { g <- sample_gnm(400, 400) }, - { layout_with_kk(g, maxiter=500) }) +time_that( + "KK layout is fast, unconnected", + replications = 10, + init = { + library(igraph) + set.seed(42) + }, + reinit = { + g <- sample_gnm(400, 400) + }, + { + layout_with_kk(g, maxiter = 500) + } +) -time_that("KK layout is fast for large graphs", replications=10, - init = { library(igraph); set.seed(42) }, - reinit = { g <- sample_pa(3000) }, - { layout_with_kk(g, maxiter=500) }) +time_that( + "KK layout is fast for large graphs", + replications = 10, + init = { + library(igraph) + set.seed(42) + }, + reinit = { + g <- sample_pa(3000) + }, + { + layout_with_kk(g, maxiter = 500) + } +) diff --git a/inst/benchmarks/time_print.R b/inst/benchmarks/time_print.R index 28ed27b9c1e..1bc5bb4a569 100644 --- a/inst/benchmarks/time_print.R +++ b/inst/benchmarks/time_print.R @@ -1,54 +1,127 @@ - time_group("Printing graphs to the screen") -time_that("Print large graphs without attributes", replications = 10, - init = { library(igraph); set.seed(42) }, - reinit = { g <- make_lattice(c(1000, 1000)) }, - { print(g) }) - -time_that("Summarize large graphs without attributes", replications = 10, - init = { library(igraph); set.seed(42) }, - reinit = { g <- make_lattice(c(1000, 1000)) }, - { summary(g) }) - -time_that("Print large graphs with large graph attributes", - replications = 10, - init = { library(igraph); set.seed(42) }, - reinit = { g <- make_lattice(c(1000, 1000)); - g <- set_graph_attr(g, "foo", 1:1000000) }, - { print(g) }) - -time_that("Summarize large graphs with large graph attributes", - replications = 10, - init = { library(igraph); set.seed(42) }, - reinit = { g <- make_lattice(c(1000, 1000)); - g <- set_graph_attr(g, "foo", 1:1000000) }, - { summary(g) }) - -time_that("Print large graphs with vertex attributes", replications = 10, - init = { library(igraph); set.seed(42) }, - reinit = { g <- make_lattice(c(1000, 1000)); - g <- set_vertex_attr(g, 'foo', - value = as.character(seq_len(gorder(g)))) }, - { print(g) }) - -time_that("Summarize large graphs with vertex attributes", replications = 10, - init = { library(igraph); set.seed(42) }, - reinit = { g <- make_lattice(c(1000, 1000)); - g <- set_vertex_attr(g, 'foo', - value = as.character(seq_len(gorder(g)))) }, - { print(g) }) - -time_that("Print large graphs with edge attributes", replications = 10, - init = { library(igraph); set.seed(42) }, - reinit = { g <- make_lattice(c(1000, 1000)); - g <- set_edge_attr(g, 'foo', - value = as.character(seq_len(gsize(g)))) }, - { print(g) }) - -time_that("Summarize large graphs with edge attributes", replications = 10, - init = { library(igraph); set.seed(42) }, - reinit = { g <- make_lattice(c(1000, 1000)); - g <- set_edge_attr(g, 'foo', - value = as.character(seq_len(gsize(g)))) }, - { print(g) }) +time_that( + "Print large graphs without attributes", + replications = 10, + init = { + library(igraph) + set.seed(42) + }, + reinit = { + g <- make_lattice(c(1000, 1000)) + }, + { + print(g) + } +) + +time_that( + "Summarize large graphs without attributes", + replications = 10, + init = { + library(igraph) + set.seed(42) + }, + reinit = { + g <- make_lattice(c(1000, 1000)) + }, + { + summary(g) + } +) + +time_that( + "Print large graphs with large graph attributes", + replications = 10, + init = { + library(igraph) + set.seed(42) + }, + reinit = { + g <- make_lattice(c(1000, 1000)) + g <- set_graph_attr(g, "foo", 1:1000000) + }, + { + print(g) + } +) + +time_that( + "Summarize large graphs with large graph attributes", + replications = 10, + init = { + library(igraph) + set.seed(42) + }, + reinit = { + g <- make_lattice(c(1000, 1000)) + g <- set_graph_attr(g, "foo", 1:1000000) + }, + { + summary(g) + } +) + +time_that( + "Print large graphs with vertex attributes", + replications = 10, + init = { + library(igraph) + set.seed(42) + }, + reinit = { + g <- make_lattice(c(1000, 1000)) + g <- set_vertex_attr(g, 'foo', value = as.character(seq_len(gorder(g)))) + }, + { + print(g) + } +) + +time_that( + "Summarize large graphs with vertex attributes", + replications = 10, + init = { + library(igraph) + set.seed(42) + }, + reinit = { + g <- make_lattice(c(1000, 1000)) + g <- set_vertex_attr(g, 'foo', value = as.character(seq_len(gorder(g)))) + }, + { + print(g) + } +) + +time_that( + "Print large graphs with edge attributes", + replications = 10, + init = { + library(igraph) + set.seed(42) + }, + reinit = { + g <- make_lattice(c(1000, 1000)) + g <- set_edge_attr(g, 'foo', value = as.character(seq_len(gsize(g)))) + }, + { + print(g) + } +) + +time_that( + "Summarize large graphs with edge attributes", + replications = 10, + init = { + library(igraph) + set.seed(42) + }, + reinit = { + g <- make_lattice(c(1000, 1000)) + g <- set_edge_attr(g, 'foo', value = as.character(seq_len(gsize(g)))) + }, + { + print(g) + } +) diff --git a/inst/benchmarks/time_sgm.R b/inst/benchmarks/time_sgm.R index 8e849cb3563..7347fd5a909 100644 --- a/inst/benchmarks/time_sgm.R +++ b/inst/benchmarks/time_sgm.R @@ -1,11 +1,26 @@ - time_group("Seeded graph matching") -time_that("SGM is fast(er)", replications=10, - init = { library(igraph); set.seed(42); vc <- 200; nos=10 }, - reinit = { g1 <- erdos.renyi.game(vc, .01); - perm <- c(1:nos, sample(vc-nos)+nos) - g2 <- sample_correlated_gnp(g1, corr=.7, p=g1$p, permutation=perm) - }, - { match_vertices(g1[], g2[], m=nos, start=matrix(1/(vc-nos), vc-nos, vc-nos), - iteration = 20) }) +time_that( + "SGM is fast(er)", + replications = 10, + init = { + library(igraph) + set.seed(42) + vc <- 200 + nos = 10 + }, + reinit = { + g1 <- erdos.renyi.game(vc, .01) + perm <- c(1:nos, sample(vc-nos)+nos) + g2 <- sample_correlated_gnp(g1, corr = .7, p = g1$p, permutation = perm) + }, + { + match_vertices( + g1[], + g2[], + m = nos, + start = matrix(1/(vc-nos), vc-nos, vc-nos), + iteration = 20 + ) + } +) diff --git a/inst/benchmarks/time_sir.R b/inst/benchmarks/time_sir.R index 309f947b9c9..b5dde1402e7 100644 --- a/inst/benchmarks/time_sir.R +++ b/inst/benchmarks/time_sir.R @@ -1,7 +1,16 @@ - time_group("SIR epidemics models on networks") -time_that("SIR is fast", replications=10, - init = { library(igraph); set.seed(42) }, - reinit = { g <- sample_gnm(40, 40) }, - { sir(g, beta=5, gamma=1, no.sim=100) }) +time_that( + "SIR is fast", + replications = 10, + init = { + library(igraph) + set.seed(42) + }, + reinit = { + g <- sample_gnm(40, 40) + }, + { + sir(g, beta = 5, gamma = 1, no.sim = 100) + } +) diff --git a/inst/lifecycle/deprecated-table-creation.R b/inst/lifecycle/deprecated-table-creation.R index e56e4e22d55..41878d935c1 100644 --- a/inst/lifecycle/deprecated-table-creation.R +++ b/inst/lifecycle/deprecated-table-creation.R @@ -20,7 +20,7 @@ tibblify_call <- function(deprecated_call) { args <- deprecated_call |> xml2::xml_parent() |> xml2::xml_siblings() |> - purrr::keep(~xml2::xml_name(.x) == "expr") + purrr::keep(~ xml2::xml_name(.x) == "expr") old <- xml2::xml_text(args[[1]]) new <- xml2::xml_text(args[[2]]) tibble::tibble(old = gsub('"', '', old), new = new) @@ -32,7 +32,7 @@ deprecated_df <- do.call(rbind, deprecated_df) deprecated_df[["new"]] <- purrr::map_chr( deprecated_df[["new"]], - ~downlit::autolink(sprintf("igraph::%s", .x)) + ~ downlit::autolink(sprintf("igraph::%s", .x)) ) readr::write_csv( diff --git a/man/roxygen/meta.R b/man/roxygen/meta.R index fa637ea9725..f9797eaa1c0 100644 --- a/man/roxygen/meta.R +++ b/man/roxygen/meta.R @@ -14,5 +14,5 @@ list( scg = "Spectral Coarse Graining", sgm = "Graph matching", `constructor modifiers` = "Constructor modifiers (and related functions)" - ) + ) ) diff --git a/tests/testthat/test-adjacency.R b/tests/testthat/test-adjacency.R index 0812b24973b..8f92cfe4845 100644 --- a/tests/testthat/test-adjacency.R +++ b/tests/testthat/test-adjacency.R @@ -422,7 +422,11 @@ test_that("graph_from_adjacency_matrix() works -- dgCMatrix", { c(1, 0, 0, 0), c(1, 0, 2, 0) ) - g8 <- graph_from_adjacency_matrix(as(M8, "dgCMatrix"), mode = "directed", weighted = TRUE) + g8 <- graph_from_adjacency_matrix( + as(M8, "dgCMatrix"), + mode = "directed", + weighted = TRUE + ) el8 <- cbind(as_edgelist(g8), E(g8)$weight) expect_equal( el8[order(el8[, 1], el8[, 2]), ], @@ -439,7 +443,11 @@ test_that("graph_from_adjacency_matrix() works -- dgCMatrix", { c(1, 0, 0, 2), c(3, 0, 2, 0) ) - g9 <- graph_from_adjacency_matrix(as(M9, "dgCMatrix"), mode = "undirected", weighted = TRUE) + g9 <- graph_from_adjacency_matrix( + as(M9, "dgCMatrix"), + mode = "undirected", + weighted = TRUE + ) el9 <- cbind(as_edgelist(g9), E(g9)$weight) expect_equal( el9[order(el9[, 1], el9[, 2]), ], @@ -456,7 +464,11 @@ test_that("graph_from_adjacency_matrix() works -- dgCMatrix", { c(1, 0, 0, 0), c(1, 0, 2, 0) ) - g10 <- graph_from_adjacency_matrix(as(M10, "dgCMatrix"), mode = "max", weighted = TRUE) + g10 <- graph_from_adjacency_matrix( + as(M10, "dgCMatrix"), + mode = "max", + weighted = TRUE + ) el10 <- cbind(as_edgelist(g10), E(g10)$weight) expect_equal( el10[order(el10[, 1], el10[, 2]), ], @@ -473,7 +485,11 @@ test_that("graph_from_adjacency_matrix() works -- dgCMatrix", { c(1, 0, 0, 0), c(1, 0, 2, 0) ) - g11 <- graph_from_adjacency_matrix(as(M11, "dgCMatrix"), mode = "min", weighted = TRUE) + g11 <- graph_from_adjacency_matrix( + as(M11, "dgCMatrix"), + mode = "min", + weighted = TRUE + ) el11 <- cbind(as_edgelist(g11), E(g11)$weight) expect_equal( el11[order(el11[, 1], el11[, 2]), ], @@ -490,7 +506,11 @@ test_that("graph_from_adjacency_matrix() works -- dgCMatrix", { c(1, 0, 0, 0), c(1, 0, 2, 0) ) - g12 <- graph_from_adjacency_matrix(as(M12, "dgCMatrix"), mode = "lower", weighted = TRUE) + g12 <- graph_from_adjacency_matrix( + as(M12, "dgCMatrix"), + mode = "lower", + weighted = TRUE + ) el12 <- cbind(as_edgelist(g12), E(g12)$weight) expect_equal( el12[order(el12[, 1], el12[, 2]), ], @@ -507,7 +527,11 @@ test_that("graph_from_adjacency_matrix() works -- dgCMatrix", { c(1, 0, 0, 0), c(1, 0, 2, 0) ) - g13 <- graph_from_adjacency_matrix(as(M13, "dgCMatrix"), mode = "upper", weighted = TRUE) + g13 <- graph_from_adjacency_matrix( + as(M13, "dgCMatrix"), + mode = "upper", + weighted = TRUE + ) el13 <- cbind(as_edgelist(g13), E(g13)$weight) expect_equal( el13[order(el13[, 1], el13[, 2]), ], @@ -524,7 +548,11 @@ test_that("graph_from_adjacency_matrix() works -- dgCMatrix", { c(1, 0, 0, 0), c(1, 0, 2, 0) ) - g14 <- graph_from_adjacency_matrix(as(M14, "dgCMatrix"), mode = "plus", weighted = TRUE) + g14 <- graph_from_adjacency_matrix( + as(M14, "dgCMatrix"), + mode = "plus", + weighted = TRUE + ) el14 <- cbind(as_edgelist(g14), E(g14)$weight) expect_equal( el14[order(el14[, 1], el14[, 2]), ], @@ -539,7 +567,11 @@ test_that("graph_from_adjacency_matrix() works -- dgCMatrix", { M15 <- rbind( c(1) ) - g15 <- graph_from_adjacency_matrix(as(M15, "dgCMatrix"), mode = "undirected", diag = FALSE) + g15 <- graph_from_adjacency_matrix( + as(M15, "dgCMatrix"), + mode = "undirected", + diag = FALSE + ) el15 <- cbind(as_edgelist(g15), E(g15)$weight) expect_equal( el15[order(el15[, 1], el15[, 2]), ], @@ -549,7 +581,11 @@ test_that("graph_from_adjacency_matrix() works -- dgCMatrix", { M16 <- rbind( c(1) ) - g16 <- graph_from_adjacency_matrix(as(M16, "dgCMatrix"), mode = "lower", diag = FALSE) + g16 <- graph_from_adjacency_matrix( + as(M16, "dgCMatrix"), + mode = "lower", + diag = FALSE + ) el16 <- cbind(as_edgelist(g16), E(g16)$weight) expect_equal( el16[order(el16[, 1], el16[, 2]), ], @@ -559,7 +595,11 @@ test_that("graph_from_adjacency_matrix() works -- dgCMatrix", { M17 <- rbind( c(1) ) - g17 <- graph_from_adjacency_matrix(as(M17, "dgCMatrix"), mode = "plus", diag = FALSE) + g17 <- graph_from_adjacency_matrix( + as(M17, "dgCMatrix"), + mode = "plus", + diag = FALSE + ) el17 <- cbind(as_edgelist(g17), E(g17)$weight) expect_equal( el17[order(el17[, 1], el17[, 2]), ], @@ -616,7 +656,11 @@ test_that("graph_from_adjacency_matrix() snapshot for sparse matrices", { graph_from_adjacency_matrix(m, weighted = TRUE) graph_from_adjacency_matrix(m, weighted = "w") - m2 <- Matrix::sparseMatrix(2:1, 1:2, x = c(0.00211360121966095, 0.00211360121966098)) + m2 <- Matrix::sparseMatrix( + 2:1, + 1:2, + x = c(0.00211360121966095, 0.00211360121966098) + ) graph_from_adjacency_matrix(m2, mode = "undirected") }) }) @@ -691,23 +735,53 @@ test_that("sparse/dense matrices min/max/plus", { A <- matrix(0, 5, 5) A[1, 2] <- 3 A[2, 1] <- 2 - g <- graph_from_adjacency_matrix(A, diag = FALSE, mode = "max", weighted = TRUE) + g <- graph_from_adjacency_matrix( + A, + diag = FALSE, + mode = "max", + weighted = TRUE + ) expect_equal(E(g)$weight[1], 3) - g <- graph_from_adjacency_matrix(A, diag = FALSE, mode = "min", weighted = TRUE) + g <- graph_from_adjacency_matrix( + A, + diag = FALSE, + mode = "min", + weighted = TRUE + ) expect_equal(E(g)$weight[1], 2) - g <- graph_from_adjacency_matrix(A, diag = FALSE, mode = "plus", weighted = TRUE) + g <- graph_from_adjacency_matrix( + A, + diag = FALSE, + mode = "plus", + weighted = TRUE + ) expect_equal(E(g)$weight[1], 5) A <- as(A, "dgCMatrix") - g <- graph_from_adjacency_matrix(A, diag = FALSE, mode = "max", weighted = TRUE) + g <- graph_from_adjacency_matrix( + A, + diag = FALSE, + mode = "max", + weighted = TRUE + ) expect_equal(E(g)$weight[1], 3) - g <- graph_from_adjacency_matrix(A, diag = FALSE, mode = "min", weighted = TRUE) + g <- graph_from_adjacency_matrix( + A, + diag = FALSE, + mode = "min", + weighted = TRUE + ) expect_equal(E(g)$weight[1], 2) - g <- graph_from_adjacency_matrix(A, diag = FALSE, mode = "plus", weighted = TRUE) + g <- graph_from_adjacency_matrix( + A, + diag = FALSE, + mode = "plus", + weighted = TRUE + ) expect_equal(E(g)$weight[1], 5) }) diff --git a/tests/testthat/test-assortativity.R b/tests/testthat/test-assortativity.R index 0cc0a56dce1..77915bf3090 100644 --- a/tests/testthat/test-assortativity.R +++ b/tests/testthat/test-assortativity.R @@ -27,7 +27,10 @@ test_that("assortativity works", { p <- read_graph(f <- gzfile("power.gml.gz"), format = "gml") expect_equal(assortativity_degree(p), assortativity(p, degree(p))) - expect_equal(assortativity_degree(p), reference_assortativity(as_directed(p, mode = "mutual"))) + expect_equal( + assortativity_degree(p), + reference_assortativity(as_directed(p, mode = "mutual")) + ) }) test_that("nominal assortativity works", { @@ -44,7 +47,8 @@ test_that("nominal assortativity works", { etm[t2, t1] <- etm[t2, t1] + 1 } etm <- etm / sum(etm) - reference_nominal_assortativity <- (sum(diag(etm)) - sum(etm %*% etm)) / (1 - sum(etm %*% etm)) + reference_nominal_assortativity <- (sum(diag(etm)) - sum(etm %*% etm)) / + (1 - sum(etm %*% etm)) expect_equal(nominal_assortativity, reference_nominal_assortativity) }) diff --git a/tests/testthat/test-bipartite.R b/tests/testthat/test-bipartite.R index 58d4b01df55..8e2c04f8a83 100644 --- a/tests/testthat/test-bipartite.R +++ b/tests/testthat/test-bipartite.R @@ -21,7 +21,13 @@ test_that("bipartite_projection works", { proj2 <- bipartite_projection(g2) expect_equal( as_unnamed_dense_matrix(proj2[[1]][]), - cbind(c(0, 2, 0, 2, 2), c(2, 0, 1, 2, 2), c(0, 1, 0, 0, 0), c(2, 2, 0, 0, 2), c(2, 2, 0, 2, 0)) + cbind( + c(0, 2, 0, 2, 2), + c(2, 0, 1, 2, 2), + c(0, 1, 0, 0, 0), + c(2, 2, 0, 0, 2), + c(2, 2, 0, 2, 0) + ) ) expect_equal( as_unnamed_dense_matrix(proj2[[2]][]), diff --git a/tests/testthat/test-centrality.R b/tests/testthat/test-centrality.R index 7d09640d59b..a10a69a8991 100644 --- a/tests/testthat/test-centrality.R +++ b/tests/testthat/test-centrality.R @@ -2,14 +2,20 @@ test_that("subgraph_centrality() works", { frucht_graph <- make_graph("Frucht") expect_equal( subgraph_centrality(frucht_graph), - Matrix::diag(Matrix::expm(as_adjacency_matrix(frucht_graph, sparse = FALSE))), + Matrix::diag(Matrix::expm(as_adjacency_matrix( + frucht_graph, + sparse = FALSE + ))), tolerance = 1e-10 ) grotzsch_graph <- make_graph("Grotzsch") expect_equal( subgraph_centrality(grotzsch_graph), - Matrix::diag(Matrix::expm(as_adjacency_matrix(grotzsch_graph, sparse = FALSE))), + Matrix::diag(Matrix::expm(as_adjacency_matrix( + grotzsch_graph, + sparse = FALSE + ))), tolerance = 1e-10 ) }) @@ -280,7 +286,13 @@ test_that("betweenness() works for kite graph", { nf <- (vcount(kite) - 1) * (vcount(kite) - 2) / 2 bet <- structure(betweenness(kite) / nf, names = V(kite)$name) bet <- round(sort(bet, decreasing = TRUE), 3) - expect_equal(bet, structure(c(0.389, 0.231, 0.231, 0.222, 0.102, 0.023, 0.023, 0.000, 0.000, 0.000), names = c("Heather", "Fernando", "Garth", "Ike", "Diane", "Andre", "Beverly", "Carol", "Ed", "Jane"))) + expect_equal( + bet, + structure( + c(0.389, 0.231, 0.231, 0.222, 0.102, 0.023, 0.023, 0.000, 0.000, 0.000), + names = c("Heather", "Fernando", "Garth", "Ike", "Diane", "Andre", "Beverly", "Carol", "Ed", "Jane") + ) + ) bet2 <- structure(betweenness(kite, normalized = TRUE), names = V(kite)$name) bet2 <- round(sort(bet2, decreasing = TRUE), 3) @@ -350,7 +362,10 @@ test_that("betweenness() -- shortest paths are compared with tolerance when calc g <- graph_from_data_frame(edges, directed = FALSE) result <- betweenness(g, weights = edges.dists) - expect_equal(result[1:5], c("1" = 0, "2" = 44, "3" = 71, "4" = 36.5, "6" = 44)) + expect_equal( + result[1:5], + c("1" = 0, "2" = 44, "3" = 71, "4" = 36.5, "6" = 44) + ) }) test_that("edge_betweenness() works", { @@ -444,26 +459,76 @@ test_that("power_centrality() works", { fig1.bp <- lapply(seq(0, 0.8, by = 0.2), function(x) { round(power_centrality(fig1, exponent = x), 2) }) - expect_equal(fig1.bp, list(c(A = 0.89, B = 1.79, C = 0, D = 0), c(A = 1.15, B = 1.64, C = 0, D = 0), c(A = 1.34, B = 1.49, C = 0, D = 0), c(A = 1.48, B = 1.35, C = 0, D = 0), c(A = 1.59, B = 1.22, C = 0, D = 0))) + expect_equal( + fig1.bp, + list( + c(A = 0.89, B = 1.79, C = 0, D = 0), + c(A = 1.15, B = 1.64, C = 0, D = 0), + c(A = 1.34, B = 1.49, C = 0, D = 0), + c(A = 1.48, B = 1.35, C = 0, D = 0), + c(A = 1.59, B = 1.22, C = 0, D = 0) + ) + ) g.c <- make_graph(c(1, 2, 1, 3, 2, 4, 3, 5), dir = FALSE) bp.c <- lapply(seq(-.5, .5, by = 0.1), function(x) { round(power_centrality(g.c, exponent = x), 2)[c(1, 2, 4)] }) - expect_equal(bp.c, list(c(0.00, 1.58, 0.00), c(0.73, 1.45, 0.36), c(0.97, 1.34, 0.49), c(1.09, 1.27, 0.54), c(1.15, 1.23, 0.58), c(1.20, 1.20, 0.60), c(1.22, 1.17, 0.61), c(1.25, 1.16, 0.62), c(1.26, 1.14, 0.63), c(1.27, 1.13, 0.64), c(1.28, 1.12, 0.64))) + expect_equal( + bp.c, + list( + c(0.00, 1.58, 0.00), + c(0.73, 1.45, 0.36), + c(0.97, 1.34, 0.49), + c(1.09, 1.27, 0.54), + c(1.15, 1.23, 0.58), + c(1.20, 1.20, 0.60), + c(1.22, 1.17, 0.61), + c(1.25, 1.16, 0.62), + c(1.26, 1.14, 0.63), + c(1.27, 1.13, 0.64), + c(1.28, 1.12, 0.64) + ) + ) g.d <- make_graph(c(1, 2, 1, 3, 1, 4, 2, 5, 3, 6, 4, 7), dir = FALSE) bp.d <- lapply(seq(-.4, .4, by = 0.1), function(x) { round(power_centrality(g.d, exponent = x), 2)[c(1, 2, 5)] }) - expect_equal(bp.d, list(c(1.62, 1.08, 0.54), c(1.62, 1.08, 0.54), c(1.62, 1.08, 0.54), c(1.62, 1.08, 0.54), c(1.62, 1.08, 0.54), c(1.62, 1.08, 0.54), c(1.62, 1.08, 0.54), c(1.62, 1.08, 0.54), c(1.62, 1.08, 0.54))) + expect_equal( + bp.d, + list( + c(1.62, 1.08, 0.54), + c(1.62, 1.08, 0.54), + c(1.62, 1.08, 0.54), + c(1.62, 1.08, 0.54), + c(1.62, 1.08, 0.54), + c(1.62, 1.08, 0.54), + c(1.62, 1.08, 0.54), + c(1.62, 1.08, 0.54), + c(1.62, 1.08, 0.54) + ) + ) g.e <- make_graph(c(1, 2, 1, 3, 1, 4, 2, 5, 2, 6, 3, 7, 3, 8, 4, 9, 4, 10), dir = FALSE) bp.e <- lapply(seq(-.4, .4, by = 0.1), function(x) { round(power_centrality(g.e, exponent = x), 2)[c(1, 2, 5)] }) - expect_equal(bp.e, list(c(-1.00, 1.67, -0.33), c(0.36, 1.81, 0.12), c(1.00, 1.67, 0.33), c(1.30, 1.55, 0.43), c(1.46, 1.46, 0.49), c(1.57, 1.40, 0.52), c(1.63, 1.36, 0.54), c(1.68, 1.33, 0.56), c(1.72, 1.30, 0.57))) + expect_equal( + bp.e, + list( + c(-1.00, 1.67, -0.33), + c(0.36, 1.81, 0.12), + c(1.00, 1.67, 0.33), + c(1.30, 1.55, 0.43), + c(1.46, 1.46, 0.49), + c(1.57, 1.40, 0.52), + c(1.63, 1.36, 0.54), + c(1.68, 1.33, 0.56), + c(1.72, 1.30, 0.57) + ) + ) g.f <- make_graph(c(1, 2, 1, 3, 1, 4, 2, 5, 2, 6, 2, 7, 3, 8, 3, 9, 3, 10, 4, 11, 4, 12, 4, 13), dir = FALSE @@ -473,7 +538,17 @@ test_that("power_centrality() works", { }) expect_equal( bp.f, - list(c(-1.72, 1.53, -0.57), c(-0.55, 2.03, -0.18), c(0.44, 2.05, 0.15), c(1.01, 1.91, 0.34), c(1.33, 1.78, 0.44), c(1.52, 1.67, 0.51), c(1.65, 1.59, 0.55), c(1.74, 1.53, 0.58), c(1.80, 1.48, 0.60)) + list( + c(-1.72, 1.53, -0.57), + c(-0.55, 2.03, -0.18), + c(0.44, 2.05, 0.15), + c(1.01, 1.91, 0.34), + c(1.33, 1.78, 0.44), + c(1.52, 1.67, 0.51), + c(1.65, 1.59, 0.55), + c(1.74, 1.53, 0.58), + c(1.80, 1.48, 0.60) + ) ) }) @@ -491,8 +566,13 @@ test_that("eigen_centrality() works", { Jane - Ike ) evc <- round(eigen_centrality(kite)$vector, 3) - expect_equal(evc, structure(c(0.732, 0.732, 0.594, 1, 0.827, 0.594, 0.827, 0.407, 0.1, 0.023), .Names = c("Andre", "Beverly", "Carol", "Diane", "Fernando", "Ed", "Garth", "Heather", "Ike", "Jane"))) - + expect_equal( + evc, + structure( + c(0.732, 0.732, 0.594, 1, 0.827, 0.594, 0.827, 0.407, 0.1, 0.023), + .Names = c("Andre", "Beverly", "Carol", "Diane", "Fernando", "Ed", "Garth", "Heather", "Ike", "Jane") + ) + ) ## Eigenvector-centrality, small stress-test @@ -511,7 +591,11 @@ test_that("eigen_centrality() works", { for (i in 1:1000) { G <- sample_gnm(10, sample(1:20, 1)) ev <- eigen_centrality(G) - expect_true(is.good(as_adjacency_matrix(G, sparse = FALSE), ev$vector, ev$value)) + expect_true(is.good( + as_adjacency_matrix(G, sparse = FALSE), + ev$vector, + ev$value + )) } }) @@ -613,7 +697,11 @@ test_that("spectrum() works for symmetric matrices", { rlang::local_options(lifecycle_verbosity = "warning") expect_warning( - e3 <- spectrum(g, which = list(howmany = 4, pos = "SA"), options = arpack_defaults) + e3 <- spectrum( + g, + which = list(howmany = 4, pos = "SA"), + options = arpack_defaults + ) ) }) @@ -622,7 +710,11 @@ test_that("arpack lifecycle warning", { f <- function(x, extra = NULL) x expect_warning( - res <- arpack(f, options = function() list(n = 10, nev = 2, ncv = 4), sym = TRUE) + res <- arpack( + f, + options = function() list(n = 10, nev = 2, ncv = 4), + sym = TRUE + ) ) expect_equal(res$values, c(1, 1)) }) @@ -674,7 +766,11 @@ test_that("arpack works for non-symmetric matrices", { ) f <- function(x, extra = NULL) A %*% x - res <- arpack(f, options = list(n = 10, nev = 3, ncv = 7, which = "LM"), sym = FALSE) + res <- arpack( + f, + options = list(n = 10, nev = 3, ncv = 7, which = "LM"), + sym = FALSE + ) ## This is needed because they might return a different complex conjugate expect_equal(abs(res$values / eigen(A)$values[1:3]), c(1, 1, 1)) expect_equal( @@ -691,7 +787,11 @@ test_that("arpack works for non-symmetric matrices", { ) f <- function(x, extra = NULL) A %*% x - res <- arpack(f, options = list(n = 10, nev = 4, ncv = 9, which = "LM"), sym = FALSE) + res <- arpack( + f, + options = list(n = 10, nev = 4, ncv = 9, which = "LM"), + sym = FALSE + ) ## This is needed because they might return a different complex conjugate expect_equal(abs(res$values / eigen(A)$values[1:4]), rep(1, 4)) expect_equal( diff --git a/tests/testthat/test-cliques.R b/tests/testthat/test-cliques.R index 5063560033b..79734f3540e 100644 --- a/tests/testthat/test-cliques.R +++ b/tests/testthat/test-cliques.R @@ -31,7 +31,10 @@ test_that("clique_size_counts() works", { expect_equal(clique_size_counts(g, maximal = TRUE), c(0, 0, 1, 0, 1)) expect_equal(clique_size_counts(g, min = 3, maximal = TRUE), c(0, 0, 1, 0, 1)) expect_equal(clique_size_counts(g, max = 4, maximal = TRUE), c(0, 0, 1)) - expect_equal(clique_size_counts(g, min = 2, max = 4, maximal = TRUE), c(0, 0, 1)) + expect_equal( + clique_size_counts(g, min = 2, max = 4, maximal = TRUE), + c(0, 0, 1) + ) }) test_that("weighted_cliques works", { @@ -40,7 +43,8 @@ test_that("weighted_cliques works", { is_clique_weight <- function(graph, vids, min_weight) { s <- induced_subgraph(graph, vids) - ecount(s) == vcount(s) * (vcount(s) - 1) / 2 && sum(V(s)$weight) >= min_weight + ecount(s) == vcount(s) * (vcount(s) - 1) / 2 && + sum(V(s)$weight) >= min_weight } expect_equal( @@ -49,7 +53,12 @@ test_that("weighted_cliques works", { ) V(g)$weight <- weights - cl <- sapply(weighted_cliques(g, min.weight = 9), is_clique_weight, graph = g, min_weight = 9) + cl <- sapply( + weighted_cliques(g, min.weight = 9), + is_clique_weight, + graph = g, + min_weight = 9 + ) expect_equal(cl, rep(TRUE, 14)) karate <- make_graph("zachary") @@ -171,8 +180,11 @@ test_that("max_cliques() work", { X <- numeric() } PX <- list( - PX = c(P, X), PS = 1, PE = length(P), - XS = length(P) + 1, XE = length(P) + length(X) + PX = c(P, X), + PS = 1, + PE = length(P), + XS = length(P) + 1, + XE = length(P) + length(X) ) res <- c(res, bkpivot(PX, cord[v])) } @@ -240,7 +252,9 @@ test_that("ivs() works, cliques of complement", { ivs_with_equivalent <- map_lgl( ivs, - function(element, cliques) any(map_lgl(cliques, function(x) identical(x, element))), + function(element, cliques) { + any(map_lgl(cliques, function(x) identical(x, element))) + }, cliques = cliques ) expect_equal(sum(ivs_with_equivalent), length(ivs)) diff --git a/tests/testthat/test-community.R b/tests/testthat/test-community.R index a2069b1a283..6ee2e8d453e 100644 --- a/tests/testthat/test-community.R +++ b/tests/testthat/test-community.R @@ -2,11 +2,17 @@ test_that("community detection functions work", { withr::local_seed(42) cluster_algos <- list( - "cluster_edge_betweenness", "cluster_fast_greedy", - "cluster_label_prop", "cluster_leading_eigen", - "cluster_louvain", "cluster_spinglass", "cluster_walktrap" + "cluster_edge_betweenness", + "cluster_fast_greedy", + "cluster_label_prop", + "cluster_leading_eigen", + "cluster_louvain", + "cluster_spinglass", + "cluster_walktrap" ) - if (has_glpk()) cluster_algos <- c(cluster_algos, "cluster_optimal") + if (has_glpk()) { + cluster_algos <- c(cluster_algos, "cluster_optimal") + } karate <- make_graph("Zachary") @@ -22,7 +28,8 @@ test_that("community detection functions work", { flat_karate_communities <- unlist(karate_comunities) is_vertex_in_several_clusters <- duplicated(flat_karate_communities) expect_false(any(is_vertex_in_several_clusters)) - is_cluster_id_valid <- flat_karate_communities <= vcount(karate) & flat_karate_communities >= 1 + is_cluster_id_valid <- flat_karate_communities <= vcount(karate) & + flat_karate_communities >= 1 expect_true(all(is_cluster_id_valid)) expect_length(karate_clustering, max(membership(karate_clustering))) } @@ -69,7 +76,8 @@ test_that("creating communities objects works", { membership <- sample(1:2, vcount(karate), replace = TRUE) mod <- modularity(karate, membership) comm <- make_clusters( - algorithm = "random", membership = membership, + algorithm = "random", + membership = membership, modularity = mod ) @@ -92,7 +100,8 @@ test_that("communities function works", { `3` = c(9L, 10L, 15L, 16L, 19L, 21L, 23L, 27L, 30L, 31L, 33L, 34L), `4` = c(24L, 25L, 26L, 28L, 29L, 32L) ), - .Dim = 4L, .Dimnames = list(c("1", "2", "3", "4")) + .Dim = 4L, + .Dimnames = list(c("1", "2", "3", "4")) ) ) @@ -107,7 +116,8 @@ test_that("communities function works", { `1` = letters[1:5], `2` = letters[6:10] ), - .Dim = 2L, .Dimnames = list(c("1", "2")) + .Dim = 2L, + .Dimnames = list(c("1", "2")) ) ) }) @@ -116,7 +126,10 @@ test_that("cluster_edge_betweenness works", { karate <- make_graph("Zachary") karate_ebc <- cluster_edge_betweenness(karate) - expect_equal(max(karate_ebc$modularity), modularity(karate, karate_ebc$membership)) + expect_equal( + max(karate_ebc$modularity), + modularity(karate, karate_ebc$membership) + ) expect_equal( membership(karate_ebc), c( @@ -151,7 +164,10 @@ test_that("cluster_fast_greedy works", { karate <- make_graph("Zachary") karate_fc <- cluster_fast_greedy(karate) - expect_equal(modularity(karate, karate_fc$membership), max(karate_fc$modularity)) + expect_equal( + modularity(karate, karate_fc$membership), + max(karate_fc$modularity) + ) expect_equal( membership(karate_fc), c( @@ -184,13 +200,23 @@ test_that("label.propagation.community works", { expect_in(membership(karate_lpc), seq_len(length(karate_lpc))) expect_s3_class(sizes(karate_lpc), "table") expect_equal(sum(sizes(karate_lpc)), vcount(karate)) - expect_identical(sizes(karate_lpc), table(membership(karate_lpc), dnn = "Community sizes")) + expect_identical( + sizes(karate_lpc), + table(membership(karate_lpc), dnn = "Community sizes") + ) }) test_that("cluster_leading_eigen works", { withr::local_seed(20230115) - check_eigen_value <- function(membership, community, value, vector, multiplier, extra) { + check_eigen_value <- function( + membership, + community, + value, + vector, + multiplier, + extra + ) { M <- sapply(1:length(vector), function(x) { v <- rep(0, length(vector)) v[x] <- 1 @@ -224,15 +250,24 @@ test_that("cluster_leading_eigen works", { structure( c(7L, 12L, 9L, 6L), .Dim = 4L, - .Dimnames = structure(list(`Community sizes` = c("1", "2", "3", "4")), + .Dimnames = structure( + list(`Community sizes` = c("1", "2", "3", "4")), .Names = "Community sizes" - ), class = "table" + ), + class = "table" ) ) ## Check that the modularity matrix is correct - mod_mat_caller <- function(membership, community, value, vector, multiplier, extra) { + mod_mat_caller <- function( + membership, + community, + value, + vector, + multiplier, + extra + ) { M <- sapply(1:length(vector), function(x) { v <- rep(0, length(vector)) v[x] <- 1 @@ -288,9 +323,11 @@ test_that("cluster_leiden works", { structure( c(17L, 17L), .Dim = 2L, - .Dimnames = structure(list(`Community sizes` = c("1", "2")), + .Dimnames = structure( + list(`Community sizes` = c("1", "2")), .Names = "Community sizes" - ), class = "table" + ), + class = "table" ) ) @@ -310,9 +347,11 @@ test_that("cluster_leiden works", { structure( c(11L, 5L, 12L, 6L), .Dim = 4L, - .Dimnames = structure(list(`Community sizes` = c("1", "2", "3", "4")), + .Dimnames = structure( + list(`Community sizes` = c("1", "2", "3", "4")), .Names = "Community sizes" - ), class = "table" + ), + class = "table" ) ) }) @@ -323,7 +362,11 @@ test_that("modularity_matrix works", { karate_fc <- cluster_fast_greedy(karate) karate_m1 <- modularity(karate, membership(karate_fc)) - karate_m2 <- modularity(karate, membership(karate_fc), weights = rep(1, ecount(karate))) + karate_m2 <- modularity( + karate, + membership(karate_fc), + weights = rep(1, ecount(karate)) + ) expect_equal(karate_m1, karate_m2) karate_modmat1 <- modularity_matrix(karate) @@ -346,12 +389,18 @@ test_that("cluster_louvain works", { karate_mc <- cluster_louvain(karate) expect_in(membership(karate_mc), 1:4) - expect_equal(modularity(karate, karate_mc$membership), max(karate_mc$modularity)) + expect_equal( + modularity(karate, karate_mc$membership), + max(karate_mc$modularity) + ) expect_in(length(karate_mc), 3:4) expect_in(membership(karate_mc), seq_len(length(karate_mc))) expect_s3_class(sizes(karate_mc), "table") expect_equal(sum(sizes(karate_mc)), vcount(karate)) - expect_identical(sizes(karate_mc), table(membership(karate_mc), dnn = "Community sizes")) + expect_identical( + sizes(karate_mc), + table(membership(karate_mc), dnn = "Community sizes") + ) }) test_that("cluster_optimal works", { @@ -368,16 +417,21 @@ test_that("cluster_optimal works", { 3, 4, 4, 4, 3, 4, 4, 3, 3, 4, 3, 3 ) ) - expect_equal(modularity(karate, karate_optimal$membership), karate_optimal$modularity) + expect_equal( + modularity(karate, karate_optimal$membership), + karate_optimal$modularity + ) expect_length(karate_optimal, 4) expect_equal( sizes(karate_optimal), structure( c(11L, 5L, 12L, 6L), .Dim = 4L, - .Dimnames = structure(list(`Community sizes` = c("1", "2", "3", "4")), + .Dimnames = structure( + list(`Community sizes` = c("1", "2", "3", "4")), .Names = "Community sizes" - ), class = "table" + ), + class = "table" ) ) }) @@ -388,7 +442,11 @@ test_that("weighted cluster_optimal works", { withr::local_seed(42) graph_full_ring <- make_full_graph(5) + make_ring(5) - E(graph_full_ring)$weight <- sample(1:2, ecount(graph_full_ring), replace = TRUE) + E(graph_full_ring)$weight <- sample( + 1:2, + ecount(graph_full_ring), + replace = TRUE + ) graph_full_ring_optimal <- cluster_optimal(graph_full_ring) expect_equal(modularity(graph_full_ring_optimal), 0.4032) @@ -400,7 +458,10 @@ test_that("cluster_walktrap works", { karate <- make_graph("Zachary") karate_walktrap <- cluster_walktrap(karate) - expect_equal(modularity(karate, membership(karate_walktrap)), modularity(karate_walktrap)) + expect_equal( + modularity(karate, membership(karate_walktrap)), + modularity(karate_walktrap) + ) expect_equal( membership(karate_walktrap), c(1, 1, 2, 1, 5, 5, 5, 1, 2, 2, 5, 1, 1, 2, 3, 3, 5, 1, 3, 1, 3, 1, 3, 4, 4, 4, 3, 4, 2, 3, 2, 2, 3, 3) @@ -408,9 +469,14 @@ test_that("cluster_walktrap works", { expect_length(karate_walktrap, 5) expect_equal( sizes(karate_walktrap), - structure(c(9L, 7L, 9L, 4L, 5L), + structure( + c(9L, 7L, 9L, 4L, 5L), .Dim = 5L, - .Dimnames = structure(list(`Community sizes` = c("1", "2", "3", "4", "5")), .Names = "Community sizes"), class = "table" + .Dimnames = structure( + list(`Community sizes` = c("1", "2", "3", "4", "5")), + .Names = "Community sizes" + ), + class = "table" ) ) @@ -440,12 +506,26 @@ test_that("groups works", { g <- make_ring(10) + make_full_graph(5) gr <- groups(components(g)) - expect_equal(gr, structure(list(`1` = 1:10, `2` = 11:15), .Dim = 2L, .Dimnames = list(c("1", "2")))) + expect_equal( + gr, + structure( + list(`1` = 1:10, `2` = 11:15), + .Dim = 2L, + .Dimnames = list(c("1", "2")) + ) + ) V(g)$name <- letters[1:15] gr <- groups(components(g)) - expect_equal(gr, structure(list(`1` = letters[1:10], `2` = letters[11:15]), .Dim = 2L, .Dimnames = list(c("1", "2")))) + expect_equal( + gr, + structure( + list(`1` = letters[1:10], `2` = letters[11:15]), + .Dim = 2L, + .Dimnames = list(c("1", "2")) + ) + ) }) test_that("voronoi works", { @@ -469,14 +549,18 @@ test_that("contract works", { V(g)$name <- letters[1:vcount(g)] E(g)$weight <- sample(ecount(g)) - g2 <- contract(g, rep(1:5, each = 2), - vertex.attr.comb = toString - ) + g2 <- contract(g, rep(1:5, each = 2), vertex.attr.comb = toString) expect_equal(g2$name, g$name) expect_equal(V(g2)$name, c("a, b", "c, d", "e, f", "g, h", "i, j")) expect_equal( as_unnamed_dense_matrix(g2[]), - cbind(c(10, 9, 0, 0, 7), c(9, 3, 6, 0, 0), c(0, 6, 4, 8, 0), c(0, 0, 8, 5, 1), c(7, 0, 0, 1, 2)) + cbind( + c(10, 9, 0, 0, 7), + c(9, 3, 6, 0, 0), + c(0, 6, 4, 8, 0), + c(0, 0, 8, 5, 1), + c(7, 0, 0, 1, 2) + ) ) }) diff --git a/tests/testthat/test-components.R b/tests/testthat/test-components.R index dec3f6a0b6d..271f1e26ead 100644 --- a/tests/testthat/test-components.R +++ b/tests/testthat/test-components.R @@ -5,7 +5,9 @@ test_that("components works", { largest_component(sample_gnp(n, 1 / n)) } - random_lg_list <- lapply(1:30, function(x) random_largest_component(sample(100, 1))) + random_lg_list <- lapply(1:30, function(x) { + random_largest_component(sample(100, 1)) + }) lg_size <- sapply(random_lg_list, vcount) dis_union <- disjoint_union(random_lg_list) @@ -140,7 +142,10 @@ test_that("articulation_points works", { test_that("bridges works", { kite <- make_graph("krackhardt_kite") - expect_equal(sort(as.vector(bridges(kite))), (ecount(kite) - 1):(ecount(kite))) + expect_equal( + sort(as.vector(bridges(kite))), + (ecount(kite) - 1):(ecount(kite)) + ) }) test_that("biconnected_components works", { @@ -156,18 +161,24 @@ test_that("biconnected_components works", { bc <- biconnected_components(g) expect_equal(bc$no, 3) - expect_equal(sortlist(bc$tree_edges), list(c(11, 15, 18, 20), c(1, 5, 8, 10), 21)) + expect_equal( + sortlist(bc$tree_edges), + list(c(11, 15, 18, 20), c(1, 5, 8, 10), 21) + ) expect_equal(sortlist(bc$component_edges), list(11:20, 1:10, 21)) expect_equal(sortlist(bc$components), list(1:5, c(1, 6), 6:10)) expect_equal(sort(as.vector(bc$articulation_points)), c(1, 6)) - expect_equal(sort(names(bc)), c( + expect_equal( + sort(names(bc)), + c( "articulation_points", "component_edges", "components", "no", "tree_edges" - )) + ) + ) expect_s3_class(bc$articulation_points, "igraph.vs") expect_s3_class(bc$components[[1]], "igraph.vs") expect_s3_class(bc$component_edges[[1]], "igraph.es") @@ -187,18 +198,24 @@ test_that("biconnected_components works without igraph.vs.es", { bc <- biconnected_components(g) expect_equal(bc$no, 3) - expect_equal(sortlist(bc$tree_edges), list(c(11, 15, 18, 20), c(1, 5, 8, 10), 21)) + expect_equal( + sortlist(bc$tree_edges), + list(c(11, 15, 18, 20), c(1, 5, 8, 10), 21) + ) expect_equal(sortlist(bc$component_edges), list(11:20, 1:10, 21)) expect_equal(sortlist(bc$components), list(1:5, c(1, 6), 6:10)) expect_equal(sort(bc$articulation_points), c(1, 6)) - expect_equal(sort(names(bc)), c( + expect_equal( + sort(names(bc)), + c( "articulation_points", "component_edges", "components", "no", "tree_edges" - )) + ) + ) }) test_that("is_biconnected works", { diff --git a/tests/testthat/test-conversion.R b/tests/testthat/test-conversion.R index 21ba3d302f5..5fddb5f12fb 100644 --- a/tests/testthat/test-conversion.R +++ b/tests/testthat/test-conversion.R @@ -31,11 +31,17 @@ test_that("as_directed keeps attributes", { E(g)$weight <- seq_len(ecount(g)) g_mutual <- as_directed(g, "mutual") df_mutual <- as_data_frame(g_mutual) - expect_equal(df_mutual[order(df_mutual[, 1], df_mutual[, 2]), ]$weight, c(1, 2, 1, 3, 3, 2)) + expect_equal( + df_mutual[order(df_mutual[, 1], df_mutual[, 2]), ]$weight, + c(1, 2, 1, 3, 3, 2) + ) g_arbitrary <- as_directed(g, "arbitrary") df_arbitrary <- as_data_frame(g_arbitrary) - expect_equal(df_arbitrary[order(df_arbitrary[, 1], df_arbitrary[, 2]), ]$weight, 1:3) + expect_equal( + df_arbitrary[order(df_arbitrary[, 1], df_arbitrary[, 2]), ]$weight, + 1:3 + ) }) test_that("as.directed() deprecation", { @@ -65,12 +71,18 @@ test_that("as_undirected() keeps attributes", { g_each <- as_undirected(g, mode = "each") df_each <- as_data_frame(g_each) expect_equal(g_each$name, g$name) - expect_equal(df_each[order(df_each[, 1], df_each[, 2]), ]$weight, c(1, 3, 2, 4, 5)) + expect_equal( + df_each[order(df_each[, 1], df_each[, 2]), ]$weight, + c(1, 3, 2, 4, 5) + ) g_mutual <- as_undirected(g, mode = "mutual") df_mutual <- as_data_frame(g_mutual) expect_equal(g_mutual$name, g$name) - expect_equal(df_mutual[order(df_mutual[, 1], df_mutual[, 2]), ]$weight, c(4, 9)) + expect_equal( + df_mutual[order(df_mutual[, 1], df_mutual[, 2]), ]$weight, + c(4, 9) + ) }) test_that("as_adjacency_matrix() works -- sparse", { @@ -185,10 +197,16 @@ test_that("as_adjacency_matrix() works -- dense", { test_that("as_adjacency_matrix() errors well -- dense", { g <- make_graph(c(1, 2, 2, 1, 2, 2, 3, 3, 3, 3, 3, 4, 4, 2, 4, 2, 4, 2), directed = TRUE) - expect_snapshot(as_adjacency_matrix(g, attr = "bla", sparse = FALSE), error = TRUE) + expect_snapshot( + as_adjacency_matrix(g, attr = "bla", sparse = FALSE), + error = TRUE + ) E(g)$bla <- letters[1:ecount(g)] - expect_snapshot(as_adjacency_matrix(g, attr = "bla", sparse = FALSE), error = TRUE) + expect_snapshot( + as_adjacency_matrix(g, attr = "bla", sparse = FALSE), + error = TRUE + ) }) @@ -306,7 +324,9 @@ test_that("as_adj_list works", { expect_s3_class(adj_list[[1]], "igraph.vs") g_same <- graph_from_adj_list(adj_list, mode = "all") expect_isomorphic(g, g_same) - expect_isomorphic(g, g_same, + expect_isomorphic( + g, + g_same, method = "vf2", vertex.color1 = seq_len(vcount(g)), vertex.color2 = seq_len(vcount(g_same)) @@ -316,23 +336,47 @@ test_that("as_adj_list works", { expect_s3_class(adj_el_list[[1]], "igraph.es") for (i in seq_len(vcount(g))) { incident_to_i <- E(g)[.inc(i)] - expect_equal(length(incident_to_i), length(adj_el_list[[i]]), ignore_attr = TRUE) - expect_equal(sort(adj_el_list[[i]]), sort(incident_to_i), ignore_attr = TRUE) + expect_equal( + length(incident_to_i), + length(adj_el_list[[i]]), + ignore_attr = TRUE + ) + expect_equal( + sort(adj_el_list[[i]]), + sort(incident_to_i), + ignore_attr = TRUE + ) } g <- sample_gnp(50, 4 / 50, directed = TRUE) adj_el_list_out <- as_adj_edge_list(g, mode = "out") for (i in seq_len(vcount(g))) { incident_to_i <- E(g)[.from(i)] - expect_equal(length(incident_to_i), length(adj_el_list_out[[i]]), ignore_attr = TRUE) - expect_equal(sort(adj_el_list_out[[i]]), sort(incident_to_i), ignore_attr = TRUE) + expect_equal( + length(incident_to_i), + length(adj_el_list_out[[i]]), + ignore_attr = TRUE + ) + expect_equal( + sort(adj_el_list_out[[i]]), + sort(incident_to_i), + ignore_attr = TRUE + ) } adj_el_list_in <- as_adj_edge_list(g, mode = "in") for (i in seq_len(vcount(g))) { incident_to_i <- E(g)[.to(i)] - expect_equal(length(incident_to_i), length(adj_el_list_in[[i]]), ignore_attr = TRUE) - expect_equal(sort(adj_el_list_in[[i]]), sort(incident_to_i), ignore_attr = TRUE) + expect_equal( + length(incident_to_i), + length(adj_el_list_in[[i]]), + ignore_attr = TRUE + ) + expect_equal( + sort(adj_el_list_in[[i]]), + sort(incident_to_i), + ignore_attr = TRUE + ) } }) @@ -345,7 +389,9 @@ test_that("as_adj_list works when return.vs.es is FALSE", { expect_s3_class(adj_list[[1]], NA) g2 <- graph_from_adj_list(adj_list, mode = "all") expect_isomorphic(g, g2) - expect_isomorphic(g, g2, + expect_isomorphic( + g, + g2, method = "vf2", vertex.color1 = 1:vcount(g), vertex.color2 = 1:vcount(g2) @@ -354,23 +400,47 @@ test_that("as_adj_list works when return.vs.es is FALSE", { adj_el_list <- as_adj_edge_list(g) for (i in seq_len(vcount(g))) { incident_to_i <- E(g)[.inc(i)] - expect_equal(length(incident_to_i), length(adj_el_list[[i]]), ignore_attr = TRUE) - expect_equal(sort(adj_el_list[[i]]), sort(incident_to_i), ignore_attr = TRUE) + expect_equal( + length(incident_to_i), + length(adj_el_list[[i]]), + ignore_attr = TRUE + ) + expect_equal( + sort(adj_el_list[[i]]), + sort(incident_to_i), + ignore_attr = TRUE + ) } g <- sample_gnp(50, 4 / 50, directed = TRUE) adj_el_list_out <- as_adj_edge_list(g, mode = "out") for (i in seq_len(vcount(g))) { incident_to_i <- E(g)[.from(i)] - expect_equal(length(incident_to_i), length(adj_el_list_out[[i]]), ignore_attr = TRUE) - expect_equal(sort(adj_el_list_out[[i]]), sort(incident_to_i), ignore_attr = TRUE) + expect_equal( + length(incident_to_i), + length(adj_el_list_out[[i]]), + ignore_attr = TRUE + ) + expect_equal( + sort(adj_el_list_out[[i]]), + sort(incident_to_i), + ignore_attr = TRUE + ) } adj_el_list_in <- as_adj_edge_list(g, mode = "in") for (i in seq_len(vcount(g))) { incident_to_i <- E(g)[.to(i)] - expect_equal(length(incident_to_i), length(adj_el_list_in[[i]]), ignore_attr = TRUE) - expect_equal(sort(adj_el_list_in[[i]]), sort(incident_to_i), ignore_attr = TRUE) + expect_equal( + length(incident_to_i), + length(adj_el_list_in[[i]]), + ignore_attr = TRUE + ) + expect_equal( + sort(adj_el_list_in[[i]]), + sort(incident_to_i), + ignore_attr = TRUE + ) } }) @@ -531,7 +601,8 @@ test_that("graph_from_data_frame works", { "Bob", "Alice" ), same.dept = c(FALSE, FALSE, TRUE, FALSE, FALSE, TRUE), - friendship = c(4, 5, 5, 2, 1, 1), advice = c(4, 5, 5, 4, 2, 3), + friendship = c(4, 5, 5, 2, 1, 1), + advice = c(4, 5, 5, 4, 2, 3), stringsAsFactors = FALSE ) g <- graph_from_data_frame(relations, directed = TRUE, vertices = actors) @@ -542,7 +613,12 @@ test_that("graph_from_data_frame works", { }) test_that("graph_from_data_frame() creates attributes for zero-row data frames (#466)", { - x <- data.frame(from = integer(), to = integer(), foo = integer(), bar = numeric()) + x <- data.frame( + from = integer(), + to = integer(), + foo = integer(), + bar = numeric() + ) g <- graph_from_data_frame(x) expect_identical(E(g)$foo, integer()) expect_identical(E(g)$bar, numeric()) @@ -573,10 +649,12 @@ test_that("edge names work", { g3 <- delete_edges(g, c("a|b", "f|g", "c|b")) expect_equal( as_edgelist(g3), - structure(c("c", "d", "e", "g", "h", "i", "a", "d", "e", "f", "h", "i", "j", "j"), .Dim = c(7L, 2L)) + structure( + c("c", "d", "e", "g", "h", "i", "a", "d", "e", "f", "h", "i", "j", "j"), + .Dim = c(7L, 2L) + ) ) - ## no names at all, but select edges based on vertices g <- make_ring(10) g4 <- delete_edges(g, c("1|2", "8|7", "1|10")) @@ -585,7 +663,6 @@ test_that("edge names work", { structure(c(2, 3, 4, 5, 6, 8, 9, 3, 4, 5, 6, 7, 9, 10), .Dim = c(7L, 2L)) ) - ## mix edge names and vertex names g <- make_ring(10) V(g)$name <- letters[1:vcount(g)] @@ -593,7 +670,10 @@ test_that("edge names work", { g5 <- delete_edges(g, c("a|b", "F", "j|i")) expect_equal( as_edgelist(g5), - structure(c("b", "c", "d", "e", "g", "h", "a", "c", "d", "e", "f", "h", "i", "j"), .Dim = c(7L, 2L)) + structure( + c("b", "c", "d", "e", "g", "h", "a", "c", "d", "e", "f", "h", "i", "j"), + .Dim = c(7L, 2L) + ) ) }) @@ -615,7 +695,8 @@ test_that("graph_from_data_frame works with factors", { ), to = c("Alice", "Bob", "Alice", "Alice", "Bob", "Alice"), same.dept = c(FALSE, FALSE, TRUE, FALSE, FALSE, TRUE), - friendship = c(4, 5, 5, 2, 1, 1), advice = c(4, 5, 5, 4, 2, 3) + friendship = c(4, 5, 5, 2, 1, 1), + advice = c(4, 5, 5, 4, 2, 3) ) g <- graph_from_data_frame(relations, directed = TRUE, vertices = actors) diff --git a/tests/testthat/test-decomposition.R b/tests/testthat/test-decomposition.R index 0bbd6c7a0cc..c53322405de 100644 --- a/tests/testthat/test-decomposition.R +++ b/tests/testthat/test-decomposition.R @@ -8,7 +8,13 @@ test_that("is_chordal works", { mc <- max_cardinality(g1) mc$alpham1 <- as.vector(mc$alpham1) - expect_equal(mc, list(alpha = c(9, 4, 6, 8, 3, 5, 7, 2, 1), alpham1 = c(9, 8, 5, 2, 6, 3, 7, 4, 1))) + expect_equal( + mc, + list( + alpha = c(9, 4, 6, 8, 3, 5, 7, 2, 1), + alpham1 = c(9, 8, 5, 2, 6, 3, 7, 4, 1) + ) + ) ic <- is_chordal(g1, fillin = TRUE) expect_equal(ic$chordal, FALSE) @@ -23,7 +29,13 @@ test_that("is_chordal works", { mc2 <- max_cardinality(g2) mc2$alpham1 <- as.vector(mc2$alpham1) - expect_equal(mc2, list(alpha = c(10, 8, 9, 6, 7, 5, 4, 2, 3, 1), alpham1 = c(10, 8, 9, 7, 6, 4, 5, 2, 3, 1))) + expect_equal( + mc2, + list( + alpha = c(10, 8, 9, 6, 7, 5, 4, 2, 3, 1), + alpham1 = c(10, 8, 9, 7, 6, 4, 5, 2, 3, 1) + ) + ) ic2 <- is_chordal(g2, fillin = TRUE) expect_equal(ic2, list(chordal = TRUE, fillin = numeric(), newgraph = NULL)) diff --git a/tests/testthat/test-efficiency.R b/tests/testthat/test-efficiency.R index 64d6f7c5412..78b525f2390 100644 --- a/tests/testthat/test-efficiency.R +++ b/tests/testthat/test-efficiency.R @@ -17,8 +17,14 @@ test_that("local_efficiency works", { expect_equal(average_local_efficiency(g), mean(local_efficiency(g))) g <- graph_from_literal(A -+ B -+ C -+ D -+ A) - expect_equal(as.vector(local_efficiency(g, directed = F)), rep(0.5, vcount(g))) - expect_equal(average_local_efficiency(g, directed = F), mean(local_efficiency(g, directed = F))) + expect_equal( + as.vector(local_efficiency(g, directed = F)), + rep(0.5, vcount(g)) + ) + expect_equal( + average_local_efficiency(g, directed = F), + mean(local_efficiency(g, directed = F)) + ) expect_equal(as.vector(local_efficiency(g, mode = "in")), rep(0, vcount(g))) expect_equal(as.vector(local_efficiency(g, mode = "out")), rep(0, vcount(g))) }) diff --git a/tests/testthat/test-embedding.R b/tests/testthat/test-embedding.R index 42ddd9c42ab..50927d52c09 100644 --- a/tests/testthat/test-embedding.R +++ b/tests/testthat/test-embedding.R @@ -23,52 +23,83 @@ test_that("embed_adjacency_matrix -- Undirected, unweighted case works", { no <- 7 A <- g[] - A <- A + 1 / 2 * as(Matrix::Matrix(diag(degree(g)), doDiag = FALSE), "generalMatrix") + A <- A + + 1 / 2 * as(Matrix::Matrix(diag(degree(g)), doDiag = FALSE), "generalMatrix") ss <- eigen(A) U <- standardize_eigen_signs(ss$vectors) X <- standardize_eigen_signs(ss$vectors %*% sqrt(diag(abs(ss$values)))) - au_la <- embed_adjacency_matrix(g, - no = no, which = "la", - cvec = degree(g) / 2, scaled = TRUE + au_la <- embed_adjacency_matrix( + g, + no = no, + which = "la", + cvec = degree(g) / 2, + scaled = TRUE ) - as_la <- embed_adjacency_matrix(g, - no = no, which = "la", - cvec = degree(g) / 2, scaled = FALSE + as_la <- embed_adjacency_matrix( + g, + no = no, + which = "la", + cvec = degree(g) / 2, + scaled = FALSE ) expect_equal(as_la$D, ss$values[1:no]) expect_equal(au_la$D, ss$values[1:no]) - expect_equal(standardize_eigen_signs(as_la$X), standardize_eigen_signs(U[, 1:no])) + expect_equal( + standardize_eigen_signs(as_la$X), + standardize_eigen_signs(U[, 1:no]) + ) expect_equal(standardize_eigen_signs(au_la$X), X[, 1:no]) - au_lm <- embed_adjacency_matrix(g, - no = no, which = "lm", - cvec = degree(g) / 2, scaled = TRUE + au_lm <- embed_adjacency_matrix( + g, + no = no, + which = "lm", + cvec = degree(g) / 2, + scaled = TRUE ) - as_lm <- embed_adjacency_matrix(g, - no = no, which = "lm", - cvec = degree(g) / 2, scaled = FALSE + as_lm <- embed_adjacency_matrix( + g, + no = no, + which = "lm", + cvec = degree(g) / 2, + scaled = FALSE ) expect_equal(as_lm$D, sort_by_magnitude(ss$values)[1:no]) expect_equal(au_lm$D, sort_by_magnitude(ss$values)[1:no]) - expect_equal(standardize_eigen_signs(as_lm$X), standardize_eigen_signs(U[, order_by_magnitude(ss$values)][, 1:no])) - expect_equal(standardize_eigen_signs(au_lm$X), X[, order_by_magnitude(ss$values)][, 1:no]) + expect_equal( + standardize_eigen_signs(as_lm$X), + standardize_eigen_signs(U[, order_by_magnitude(ss$values)][, 1:no]) + ) + expect_equal( + standardize_eigen_signs(au_lm$X), + X[, order_by_magnitude(ss$values)][, 1:no] + ) - au_sa <- embed_adjacency_matrix(g, - no = no, which = "sa", - cvec = degree(g) / 2, scaled = TRUE + au_sa <- embed_adjacency_matrix( + g, + no = no, + which = "sa", + cvec = degree(g) / 2, + scaled = TRUE ) - as_sa <- embed_adjacency_matrix(g, - no = no, which = "sa", - cvec = degree(g) / 2, scaled = FALSE + as_sa <- embed_adjacency_matrix( + g, + no = no, + which = "sa", + cvec = degree(g) / 2, + scaled = FALSE ) expect_equal(as_sa$D, ss$values[vcount(g) - 1:no + 1]) expect_equal(au_sa$D, ss$values[vcount(g) - 1:no + 1]) - expect_equal(standardize_eigen_signs(as_sa$X), standardize_eigen_signs(U[, vcount(g) - 1:no + 1])) + expect_equal( + standardize_eigen_signs(as_sa$X), + standardize_eigen_signs(U[, vcount(g) - 1:no + 1]) + ) expect_equal(standardize_eigen_signs(au_sa$X), X[, vcount(g) - 1:no + 1]) }) @@ -79,50 +110,81 @@ test_that("embed_adjacency_matrix -- Undirected, weighted case works", { no <- 3 A <- g[] - A <- A + 1 / 2 * as(Matrix::Matrix(diag(degree(g)), doDiag = FALSE), "generalMatrix") + A <- A + + 1 / 2 * as(Matrix::Matrix(diag(degree(g)), doDiag = FALSE), "generalMatrix") ss <- eigen(A) U <- standardize_eigen_signs(ss$vectors) X <- standardize_eigen_signs(ss$vectors %*% sqrt(diag(abs(ss$values)))) - au_la <- embed_adjacency_matrix(g, - no = no, which = "la", - cvec = degree(g) / 2, scaled = TRUE + au_la <- embed_adjacency_matrix( + g, + no = no, + which = "la", + cvec = degree(g) / 2, + scaled = TRUE ) - as_la <- embed_adjacency_matrix(g, - no = no, which = "la", - cvec = degree(g) / 2, scaled = FALSE + as_la <- embed_adjacency_matrix( + g, + no = no, + which = "la", + cvec = degree(g) / 2, + scaled = FALSE ) expect_equal(as_la$D, ss$values[1:no]) - expect_equal(standardize_eigen_signs(as_la$X), standardize_eigen_signs(U[, 1:no])) + expect_equal( + standardize_eigen_signs(as_la$X), + standardize_eigen_signs(U[, 1:no]) + ) expect_equal(au_la$D, ss$values[1:no]) expect_equal(standardize_eigen_signs(au_la$X), X[, 1:no]) - au_lm <- embed_adjacency_matrix(g, - no = no, which = "lm", - cvec = degree(g) / 2, scaled = TRUE + au_lm <- embed_adjacency_matrix( + g, + no = no, + which = "lm", + cvec = degree(g) / 2, + scaled = TRUE ) - as_lm <- embed_adjacency_matrix(g, - no = no, which = "lm", - cvec = degree(g) / 2, scaled = FALSE + as_lm <- embed_adjacency_matrix( + g, + no = no, + which = "lm", + cvec = degree(g) / 2, + scaled = FALSE ) expect_equal(as_lm$D, sort_by_magnitude(ss$values)[1:no]) expect_equal(au_lm$D, sort_by_magnitude(ss$values)[1:no]) - expect_equal(standardize_eigen_signs(as_lm$X), standardize_eigen_signs(U[, order_by_magnitude(ss$values)][, 1:no])) - expect_equal(standardize_eigen_signs(au_lm$X), X[, order_by_magnitude(ss$values)][, 1:no]) + expect_equal( + standardize_eigen_signs(as_lm$X), + standardize_eigen_signs(U[, order_by_magnitude(ss$values)][, 1:no]) + ) + expect_equal( + standardize_eigen_signs(au_lm$X), + X[, order_by_magnitude(ss$values)][, 1:no] + ) - au_sa <- embed_adjacency_matrix(g, - no = no, which = "sa", - cvec = degree(g) / 2, scaled = TRUE + au_sa <- embed_adjacency_matrix( + g, + no = no, + which = "sa", + cvec = degree(g) / 2, + scaled = TRUE ) - as_sa <- embed_adjacency_matrix(g, - no = no, which = "sa", - cvec = degree(g) / 2, scaled = FALSE + as_sa <- embed_adjacency_matrix( + g, + no = no, + which = "sa", + cvec = degree(g) / 2, + scaled = FALSE ) - expect_equal(standardize_eigen_signs(as_sa$X), standardize_eigen_signs(U[, vcount(g) - 1:no + 1])) + expect_equal( + standardize_eigen_signs(as_sa$X), + standardize_eigen_signs(U[, vcount(g) - 1:no + 1]) + ) expect_equal(standardize_eigen_signs(au_sa$X), X[, vcount(g) - 1:no + 1]) }) @@ -132,7 +194,8 @@ test_that("embed_adjacency_matrix -- Directed, unweighted case works", { no <- 3 A <- g[] - A <- A + 1 / 2 * as(Matrix::Matrix(diag(degree(g)), doDiag = FALSE), "generalMatrix") + A <- A + + 1 / 2 * as(Matrix::Matrix(diag(degree(g)), doDiag = FALSE), "generalMatrix") ss <- svd(A) U <- standardize_eigen_signs(ss$u) @@ -140,51 +203,87 @@ test_that("embed_adjacency_matrix -- Directed, unweighted case works", { X <- standardize_eigen_signs(ss$u %*% sqrt(diag(ss$d))) Y <- standardize_eigen_signs(ss$v %*% sqrt(diag(ss$d))) - au_la <- embed_adjacency_matrix(g, - no = no, which = "la", - cvec = degree(g) / 2, scaled = TRUE + au_la <- embed_adjacency_matrix( + g, + no = no, + which = "la", + cvec = degree(g) / 2, + scaled = TRUE ) - as_la <- embed_adjacency_matrix(g, - no = no, which = "la", - cvec = degree(g) / 2, scaled = FALSE + as_la <- embed_adjacency_matrix( + g, + no = no, + which = "la", + cvec = degree(g) / 2, + scaled = FALSE ) expect_equal(as_la$D, ss$d[1:no]) expect_equal(au_la$D, ss$d[1:no]) - expect_equal(standardize_eigen_signs(as_la$X), standardize_eigen_signs(U[, 1:no])) - expect_equal(standardize_eigen_signs(as_la$Y), standardize_eigen_signs(V[, 1:no])) + expect_equal( + standardize_eigen_signs(as_la$X), + standardize_eigen_signs(U[, 1:no]) + ) + expect_equal( + standardize_eigen_signs(as_la$Y), + standardize_eigen_signs(V[, 1:no]) + ) expect_equal(standardize_eigen_signs(au_la$X), X[, 1:no]) expect_equal(standardize_eigen_signs(au_la$Y), Y[, 1:no]) - au_lm <- embed_adjacency_matrix(g, - no = no, which = "lm", - cvec = degree(g) / 2, scaled = TRUE + au_lm <- embed_adjacency_matrix( + g, + no = no, + which = "lm", + cvec = degree(g) / 2, + scaled = TRUE ) - as_lm <- embed_adjacency_matrix(g, - no = no, which = "lm", - cvec = degree(g) / 2, scaled = FALSE + as_lm <- embed_adjacency_matrix( + g, + no = no, + which = "lm", + cvec = degree(g) / 2, + scaled = FALSE ) expect_equal(as_lm$D, ss$d[1:no]) expect_equal(au_lm$D, ss$d[1:no]) - expect_equal(standardize_eigen_signs(as_lm$X), standardize_eigen_signs(U[, 1:no])) - expect_equal(standardize_eigen_signs(as_lm$Y), standardize_eigen_signs(V[, 1:no])) + expect_equal( + standardize_eigen_signs(as_lm$X), + standardize_eigen_signs(U[, 1:no]) + ) + expect_equal( + standardize_eigen_signs(as_lm$Y), + standardize_eigen_signs(V[, 1:no]) + ) expect_equal(standardize_eigen_signs(au_lm$X), X[, 1:no]) expect_equal(standardize_eigen_signs(au_lm$Y), Y[, 1:no]) - au_sa <- embed_adjacency_matrix(g, - no = no, which = "sa", - cvec = degree(g) / 2, scaled = TRUE + au_sa <- embed_adjacency_matrix( + g, + no = no, + which = "sa", + cvec = degree(g) / 2, + scaled = TRUE ) - as_sa <- embed_adjacency_matrix(g, - no = no, which = "sa", - cvec = degree(g) / 2, scaled = FALSE + as_sa <- embed_adjacency_matrix( + g, + no = no, + which = "sa", + cvec = degree(g) / 2, + scaled = FALSE ) expect_equal(as_sa$D, ss$d[vcount(g) - 1:no + 1]) expect_equal(au_sa$D, ss$d[vcount(g) - 1:no + 1]) - expect_equal(standardize_eigen_signs(as_sa$X), standardize_eigen_signs(U[, vcount(g) - 1:no + 1])) - expect_equal(standardize_eigen_signs(as_sa$Y), standardize_eigen_signs(V[, vcount(g) - 1:no + 1])) + expect_equal( + standardize_eigen_signs(as_sa$X), + standardize_eigen_signs(U[, vcount(g) - 1:no + 1]) + ) + expect_equal( + standardize_eigen_signs(as_sa$Y), + standardize_eigen_signs(V[, vcount(g) - 1:no + 1]) + ) expect_equal(standardize_eigen_signs(au_sa$X), X[, vcount(g) - 1:no + 1]) expect_equal(standardize_eigen_signs(au_sa$Y), Y[, vcount(g) - 1:no + 1]) }) @@ -196,7 +295,8 @@ test_that("embed_adjacency_matrix -- Directed, weighted case works", { no <- 3 A <- g[] - A <- A + 1 / 2 * as(Matrix::Matrix(diag(degree(g)), doDiag = FALSE), "generalMatrix") + A <- A + + 1 / 2 * as(Matrix::Matrix(diag(degree(g)), doDiag = FALSE), "generalMatrix") ss <- svd(A) U <- standardize_eigen_signs(ss$u) @@ -204,45 +304,81 @@ test_that("embed_adjacency_matrix -- Directed, weighted case works", { X <- standardize_eigen_signs(ss$u %*% sqrt(diag(ss$d))) Y <- standardize_eigen_signs(ss$v %*% sqrt(diag(ss$d))) - au_la <- embed_adjacency_matrix(g, - no = no, which = "la", - cvec = degree(g) / 2, scaled = TRUE + au_la <- embed_adjacency_matrix( + g, + no = no, + which = "la", + cvec = degree(g) / 2, + scaled = TRUE ) - as_la <- embed_adjacency_matrix(g, - no = no, which = "la", - cvec = degree(g) / 2, scaled = FALSE + as_la <- embed_adjacency_matrix( + g, + no = no, + which = "la", + cvec = degree(g) / 2, + scaled = FALSE ) - expect_equal(standardize_eigen_signs(as_la$X), standardize_eigen_signs(U[, 1:no])) - expect_equal(standardize_eigen_signs(as_la$Y), standardize_eigen_signs(V[, 1:no])) + expect_equal( + standardize_eigen_signs(as_la$X), + standardize_eigen_signs(U[, 1:no]) + ) + expect_equal( + standardize_eigen_signs(as_la$Y), + standardize_eigen_signs(V[, 1:no]) + ) expect_equal(standardize_eigen_signs(au_la$X), X[, 1:no]) expect_equal(standardize_eigen_signs(au_la$Y), Y[, 1:no]) - au_lm <- embed_adjacency_matrix(g, - no = no, which = "lm", - cvec = degree(g) / 2, scaled = TRUE + au_lm <- embed_adjacency_matrix( + g, + no = no, + which = "lm", + cvec = degree(g) / 2, + scaled = TRUE ) - as_lm <- embed_adjacency_matrix(g, - no = no, which = "lm", - cvec = degree(g) / 2, scaled = FALSE + as_lm <- embed_adjacency_matrix( + g, + no = no, + which = "lm", + cvec = degree(g) / 2, + scaled = FALSE ) - expect_equal(standardize_eigen_signs(as_lm$X), standardize_eigen_signs(U[, 1:no])) - expect_equal(standardize_eigen_signs(as_lm$Y), standardize_eigen_signs(V[, 1:no])) + expect_equal( + standardize_eigen_signs(as_lm$X), + standardize_eigen_signs(U[, 1:no]) + ) + expect_equal( + standardize_eigen_signs(as_lm$Y), + standardize_eigen_signs(V[, 1:no]) + ) expect_equal(standardize_eigen_signs(au_lm$X), X[, 1:no]) expect_equal(standardize_eigen_signs(au_lm$Y), Y[, 1:no]) - au_sa <- embed_adjacency_matrix(g, - no = no, which = "sa", - cvec = degree(g) / 2, scaled = TRUE + au_sa <- embed_adjacency_matrix( + g, + no = no, + which = "sa", + cvec = degree(g) / 2, + scaled = TRUE ) - as_sa <- embed_adjacency_matrix(g, - no = no, which = "sa", - cvec = degree(g) / 2, scaled = FALSE + as_sa <- embed_adjacency_matrix( + g, + no = no, + which = "sa", + cvec = degree(g) / 2, + scaled = FALSE ) - expect_equal(standardize_eigen_signs(as_sa$X), standardize_eigen_signs(U[, vcount(g) - 1:no + 1])) - expect_equal(standardize_eigen_signs(as_sa$Y), standardize_eigen_signs(V[, vcount(g) - 1:no + 1])) + expect_equal( + standardize_eigen_signs(as_sa$X), + standardize_eigen_signs(U[, vcount(g) - 1:no + 1]) + ) + expect_equal( + standardize_eigen_signs(as_sa$Y), + standardize_eigen_signs(V[, vcount(g) - 1:no + 1]) + ) expect_equal(standardize_eigen_signs(au_sa$X), X[, vcount(g) - 1:no + 1]) expect_equal(standardize_eigen_signs(au_sa$Y), Y[, vcount(g) - 1:no + 1]) }) @@ -279,7 +415,8 @@ test_that("embed_laplacian_matrix -- Undirected, unweighted, D-A case works", { g <- sample_gnm(10, 20, directed = FALSE) no <- 3 - A <- as(Matrix::Matrix(diag(degree(g)), doDiag = FALSE), "generalMatrix") - g[] + A <- as(Matrix::Matrix(diag(degree(g)), doDiag = FALSE), "generalMatrix") - + g[] ss <- eigen(A) D <- ss$values @@ -289,51 +426,87 @@ test_that("embed_laplacian_matrix -- Undirected, unweighted, D-A case works", { ## LA - au_la <- embed_laplacian_matrix(g, - no = no, which = "la", type = "D-A", + au_la <- embed_laplacian_matrix( + g, + no = no, + which = "la", + type = "D-A", scaled = TRUE ) - as_la <- embed_laplacian_matrix(g, - no = no, which = "la", type = "D-A", + as_la <- embed_laplacian_matrix( + g, + no = no, + which = "la", + type = "D-A", scaled = FALSE ) expect_equal(au_la$D, D[1:no]) - expect_equal(standardize_eigen_signs(au_la$X), standardize_eigen_signs(X[, 1:no])) + expect_equal( + standardize_eigen_signs(au_la$X), + standardize_eigen_signs(X[, 1:no]) + ) expect_equal(as_la$D, D[1:no]) - expect_equal(standardize_eigen_signs(as_la$X), standardize_eigen_signs(U[, 1:no])) + expect_equal( + standardize_eigen_signs(as_la$X), + standardize_eigen_signs(U[, 1:no]) + ) ## LM - au_lm <- embed_laplacian_matrix(g, - no = no, which = "lm", type = "D-A", + au_lm <- embed_laplacian_matrix( + g, + no = no, + which = "lm", + type = "D-A", scaled = TRUE ) - as_lm <- embed_laplacian_matrix(g, - no = no, which = "lm", type = "D-A", + as_lm <- embed_laplacian_matrix( + g, + no = no, + which = "lm", + type = "D-A", scaled = FALSE ) expect_equal(au_lm$D, sort_by_magnitude(D)[1:no]) - expect_equal(standardize_eigen_signs(au_lm$X), standardize_eigen_signs(X[, order_by_magnitude(D)][, 1:no])) + expect_equal( + standardize_eigen_signs(au_lm$X), + standardize_eigen_signs(X[, order_by_magnitude(D)][, 1:no]) + ) expect_equal(as_lm$D, sort_by_magnitude(D)[1:no]) - expect_equal(standardize_eigen_signs(as_lm$X), standardize_eigen_signs(U[, order_by_magnitude(D)][, 1:no])) + expect_equal( + standardize_eigen_signs(as_lm$X), + standardize_eigen_signs(U[, order_by_magnitude(D)][, 1:no]) + ) ## SA - au_sa <- embed_laplacian_matrix(g, - no = no, which = "sa", type = "D-A", + au_sa <- embed_laplacian_matrix( + g, + no = no, + which = "sa", + type = "D-A", scaled = TRUE ) - as_sa <- embed_laplacian_matrix(g, - no = no, which = "sa", type = "D-A", + as_sa <- embed_laplacian_matrix( + g, + no = no, + which = "sa", + type = "D-A", scaled = FALSE ) expect_equal(au_sa$D, D[vcount(g) - 1:no + 1]) - expect_equal(standardize_eigen_signs(au_sa$X), standardize_eigen_signs(X[, vcount(g) - 1:no + 1])) + expect_equal( + standardize_eigen_signs(au_sa$X), + standardize_eigen_signs(X[, vcount(g) - 1:no + 1]) + ) expect_equal(as_sa$D, D[vcount(g) - 1:no + 1]) - expect_equal(standardize_eigen_signs(as_sa$X), standardize_eigen_signs(U[, vcount(g) - 1:no + 1])) + expect_equal( + standardize_eigen_signs(as_sa$X), + standardize_eigen_signs(U[, vcount(g) - 1:no + 1]) + ) }) test_that("embed_laplacian_matrix -- Undirected, unweighted, DAD case works", { @@ -352,51 +525,87 @@ test_that("embed_laplacian_matrix -- Undirected, unweighted, DAD case works", { ## LA - au_la <- embed_laplacian_matrix(g, - no = no, which = "la", type = "DAD", + au_la <- embed_laplacian_matrix( + g, + no = no, + which = "la", + type = "DAD", scaled = TRUE ) - as_la <- embed_laplacian_matrix(g, - no = no, which = "la", type = "DAD", + as_la <- embed_laplacian_matrix( + g, + no = no, + which = "la", + type = "DAD", scaled = FALSE ) expect_equal(au_la$D, abs(D[1:no])) - expect_equal(standardize_eigen_signs(au_la$X), standardize_eigen_signs(X[, 1:no])) + expect_equal( + standardize_eigen_signs(au_la$X), + standardize_eigen_signs(X[, 1:no]) + ) expect_equal(as_la$D, D[1:no]) - expect_equal(standardize_eigen_signs(as_la$X), standardize_eigen_signs(U[, 1:no])) + expect_equal( + standardize_eigen_signs(as_la$X), + standardize_eigen_signs(U[, 1:no]) + ) ## LM - au_lm <- embed_laplacian_matrix(g, - no = no, which = "lm", type = "DAD", + au_lm <- embed_laplacian_matrix( + g, + no = no, + which = "lm", + type = "DAD", scaled = TRUE ) - as_lm <- embed_laplacian_matrix(g, - no = no, which = "lm", type = "DAD", + as_lm <- embed_laplacian_matrix( + g, + no = no, + which = "lm", + type = "DAD", scaled = FALSE ) expect_equal(au_lm$D, sort_by_magnitude(D)[1:no]) - expect_equal(standardize_eigen_signs(au_lm$X), standardize_eigen_signs(X[, order_by_magnitude(D)][, 1:no])) + expect_equal( + standardize_eigen_signs(au_lm$X), + standardize_eigen_signs(X[, order_by_magnitude(D)][, 1:no]) + ) expect_equal(as_lm$D, sort_by_magnitude(D)[1:no]) - expect_equal(standardize_eigen_signs(as_lm$X), standardize_eigen_signs(U[, order_by_magnitude(D)][, 1:no])) + expect_equal( + standardize_eigen_signs(as_lm$X), + standardize_eigen_signs(U[, order_by_magnitude(D)][, 1:no]) + ) ## SA - au_sa <- embed_laplacian_matrix(g, - no = no, which = "sa", type = "DAD", + au_sa <- embed_laplacian_matrix( + g, + no = no, + which = "sa", + type = "DAD", scaled = TRUE ) - as_sa <- embed_laplacian_matrix(g, - no = no, which = "sa", type = "DAD", + as_sa <- embed_laplacian_matrix( + g, + no = no, + which = "sa", + type = "DAD", scaled = FALSE ) expect_equal(au_sa$D, D[vcount(g) - 1:no + 1]) - expect_equal(standardize_eigen_signs(au_sa$X), standardize_eigen_signs(X[, vcount(g) - 1:no + 1])) + expect_equal( + standardize_eigen_signs(au_sa$X), + standardize_eigen_signs(X[, vcount(g) - 1:no + 1]) + ) expect_equal(as_sa$D, D[vcount(g) - 1:no + 1]) - expect_equal(standardize_eigen_signs(as_sa$X), standardize_eigen_signs(U[, vcount(g) - 1:no + 1])) + expect_equal( + standardize_eigen_signs(as_sa$X), + standardize_eigen_signs(U[, vcount(g) - 1:no + 1]) + ) }) test_that("embed_laplacian_matrix -- Undirected, unweighted, I-DAD case works", { @@ -415,51 +624,87 @@ test_that("embed_laplacian_matrix -- Undirected, unweighted, I-DAD case works", ## LA - au_la <- embed_laplacian_matrix(g, - no = no, which = "la", type = "I-DAD", + au_la <- embed_laplacian_matrix( + g, + no = no, + which = "la", + type = "I-DAD", scaled = TRUE ) - as_la <- embed_laplacian_matrix(g, - no = no, which = "la", type = "I-DAD", + as_la <- embed_laplacian_matrix( + g, + no = no, + which = "la", + type = "I-DAD", scaled = FALSE ) expect_equal(au_la$D, abs(D[1:no])) - expect_equal(standardize_eigen_signs(au_la$X), standardize_eigen_signs(X[, 1:no])) + expect_equal( + standardize_eigen_signs(au_la$X), + standardize_eigen_signs(X[, 1:no]) + ) expect_equal(as_la$D, D[1:no]) - expect_equal(standardize_eigen_signs(as_la$X), standardize_eigen_signs(U[, 1:no])) + expect_equal( + standardize_eigen_signs(as_la$X), + standardize_eigen_signs(U[, 1:no]) + ) ## LM - au_lm <- embed_laplacian_matrix(g, - no = no, which = "lm", type = "I-DAD", + au_lm <- embed_laplacian_matrix( + g, + no = no, + which = "lm", + type = "I-DAD", scaled = TRUE ) - as_lm <- embed_laplacian_matrix(g, - no = no, which = "lm", type = "I-DAD", + as_lm <- embed_laplacian_matrix( + g, + no = no, + which = "lm", + type = "I-DAD", scaled = FALSE ) expect_equal(au_lm$D, sort_by_magnitude(D)[1:no]) - expect_equal(standardize_eigen_signs(au_lm$X), standardize_eigen_signs(X[, order_by_magnitude(D)][, 1:no])) + expect_equal( + standardize_eigen_signs(au_lm$X), + standardize_eigen_signs(X[, order_by_magnitude(D)][, 1:no]) + ) expect_equal(as_lm$D, sort_by_magnitude(D)[1:no]) - expect_equal(standardize_eigen_signs(as_lm$X), standardize_eigen_signs(U[, order_by_magnitude(D)][, 1:no])) + expect_equal( + standardize_eigen_signs(as_lm$X), + standardize_eigen_signs(U[, order_by_magnitude(D)][, 1:no]) + ) ## SA - au_sa <- embed_laplacian_matrix(g, - no = no, which = "sa", type = "I-DAD", + au_sa <- embed_laplacian_matrix( + g, + no = no, + which = "sa", + type = "I-DAD", scaled = TRUE ) - as_sa <- embed_laplacian_matrix(g, - no = no, which = "sa", type = "I-DAD", + as_sa <- embed_laplacian_matrix( + g, + no = no, + which = "sa", + type = "I-DAD", scaled = FALSE ) expect_equal(au_sa$D, D[vcount(g) - 1:no + 1]) - expect_equal(standardize_eigen_signs(au_sa$X), standardize_eigen_signs(X[, vcount(g) - 1:no + 1])) + expect_equal( + standardize_eigen_signs(au_sa$X), + standardize_eigen_signs(X[, vcount(g) - 1:no + 1]) + ) expect_equal(as_sa$D, D[vcount(g) - 1:no + 1]) - expect_equal(standardize_eigen_signs(as_sa$X), standardize_eigen_signs(U[, vcount(g) - 1:no + 1])) + expect_equal( + standardize_eigen_signs(as_sa$X), + standardize_eigen_signs(U[, vcount(g) - 1:no + 1]) + ) }) test_that("embed_laplacian_matrix -- Undirected, weighted, D-A case works", { @@ -468,7 +713,8 @@ test_that("embed_laplacian_matrix -- Undirected, weighted, D-A case works", { E(g)$weight <- sample(1:5, ecount(g), replace = TRUE) no <- 3 - A <- as(Matrix::Matrix(diag(strength(g)), doDiag = FALSE), "generalMatrix") - g[] + A <- as(Matrix::Matrix(diag(strength(g)), doDiag = FALSE), "generalMatrix") - + g[] ss <- eigen(A) D <- ss$values @@ -478,51 +724,84 @@ test_that("embed_laplacian_matrix -- Undirected, weighted, D-A case works", { ## LA - au_la <- embed_laplacian_matrix(g, - no = no, which = "la", type = "D-A", + au_la <- embed_laplacian_matrix( + g, + no = no, + which = "la", + type = "D-A", scaled = TRUE ) - as_la <- embed_laplacian_matrix(g, - no = no, which = "la", type = "D-A", + as_la <- embed_laplacian_matrix( + g, + no = no, + which = "la", + type = "D-A", scaled = FALSE ) expect_equal(au_la$D, abs(D[1:no])) - expect_equal(standardize_eigen_signs(au_la$X), standardize_eigen_signs(X[, 1:no])) + expect_equal( + standardize_eigen_signs(au_la$X), + standardize_eigen_signs(X[, 1:no]) + ) expect_equal(as_la$D, D[1:no]) - expect_equal(standardize_eigen_signs(as_la$X), standardize_eigen_signs(U[, 1:no])) + expect_equal( + standardize_eigen_signs(as_la$X), + standardize_eigen_signs(U[, 1:no]) + ) ## LM - au_lm <- embed_laplacian_matrix(g, - no = no, which = "lm", type = "D-A", + au_lm <- embed_laplacian_matrix( + g, + no = no, + which = "lm", + type = "D-A", scaled = TRUE ) - as_lm <- embed_laplacian_matrix(g, - no = no, which = "lm", type = "D-A", + as_lm <- embed_laplacian_matrix( + g, + no = no, + which = "lm", + type = "D-A", scaled = FALSE ) expect_equal(au_lm$D, sort_by_magnitude(D)[1:no]) - expect_equal(standardize_eigen_signs(au_lm$X), standardize_eigen_signs(X[, order_by_magnitude(D)][, 1:no])) + expect_equal( + standardize_eigen_signs(au_lm$X), + standardize_eigen_signs(X[, order_by_magnitude(D)][, 1:no]) + ) expect_equal(as_lm$D, sort_by_magnitude(D)[1:no]) - expect_equal(standardize_eigen_signs(as_lm$X), standardize_eigen_signs(U[, order_by_magnitude(D)][, 1:no])) + expect_equal( + standardize_eigen_signs(as_lm$X), + standardize_eigen_signs(U[, order_by_magnitude(D)][, 1:no]) + ) ## SA - au_sa <- embed_laplacian_matrix(g, - no = no, which = "sa", type = "D-A", + au_sa <- embed_laplacian_matrix( + g, + no = no, + which = "sa", + type = "D-A", scaled = TRUE ) - as_sa <- embed_laplacian_matrix(g, - no = no, which = "sa", type = "D-A", + as_sa <- embed_laplacian_matrix( + g, + no = no, + which = "sa", + type = "D-A", scaled = FALSE ) expect_equal(au_sa$D, D[vcount(g) - 1:no + 1]) expect_equal(standardize_eigen_signs(au_sa$X), X[, vcount(g) - 1:no + 1]) expect_equal(as_sa$D, D[vcount(g) - 1:no + 1]) - expect_equal(standardize_eigen_signs(as_sa$X), standardize_eigen_signs(U[, vcount(g) - 1:no + 1])) + expect_equal( + standardize_eigen_signs(as_sa$X), + standardize_eigen_signs(U[, vcount(g) - 1:no + 1]) + ) }) test_that("embed_laplacian_matrix -- Undirected, unweighted, DAD case works", { @@ -542,51 +821,87 @@ test_that("embed_laplacian_matrix -- Undirected, unweighted, DAD case works", { ## LA - au_la <- embed_laplacian_matrix(g, - no = no, which = "la", type = "DAD", + au_la <- embed_laplacian_matrix( + g, + no = no, + which = "la", + type = "DAD", scaled = TRUE ) - as_la <- embed_laplacian_matrix(g, - no = no, which = "la", type = "DAD", + as_la <- embed_laplacian_matrix( + g, + no = no, + which = "la", + type = "DAD", scaled = FALSE ) expect_equal(au_la$D, abs(D[1:no])) - expect_equal(standardize_eigen_signs(au_la$X), standardize_eigen_signs(X[, 1:no])) + expect_equal( + standardize_eigen_signs(au_la$X), + standardize_eigen_signs(X[, 1:no]) + ) expect_equal(as_la$D, D[1:no]) - expect_equal(standardize_eigen_signs(as_la$X), standardize_eigen_signs(U[, 1:no])) + expect_equal( + standardize_eigen_signs(as_la$X), + standardize_eigen_signs(U[, 1:no]) + ) ## LM - au_lm <- embed_laplacian_matrix(g, - no = no, which = "lm", type = "DAD", + au_lm <- embed_laplacian_matrix( + g, + no = no, + which = "lm", + type = "DAD", scaled = TRUE ) - as_lm <- embed_laplacian_matrix(g, - no = no, which = "lm", type = "DAD", + as_lm <- embed_laplacian_matrix( + g, + no = no, + which = "lm", + type = "DAD", scaled = FALSE ) expect_equal(au_lm$D, sort_by_magnitude(D)[1:no]) - expect_equal(standardize_eigen_signs(au_lm$X), standardize_eigen_signs(X[, order_by_magnitude(D)][, 1:no])) + expect_equal( + standardize_eigen_signs(au_lm$X), + standardize_eigen_signs(X[, order_by_magnitude(D)][, 1:no]) + ) expect_equal(as_lm$D, sort_by_magnitude(D)[1:no]) - expect_equal(standardize_eigen_signs(as_lm$X), standardize_eigen_signs(U[, order_by_magnitude(D)][, 1:no])) + expect_equal( + standardize_eigen_signs(as_lm$X), + standardize_eigen_signs(U[, order_by_magnitude(D)][, 1:no]) + ) ## SA - au_sa <- embed_laplacian_matrix(g, - no = no, which = "sa", type = "DAD", + au_sa <- embed_laplacian_matrix( + g, + no = no, + which = "sa", + type = "DAD", scaled = TRUE ) - as_sa <- embed_laplacian_matrix(g, - no = no, which = "sa", type = "DAD", + as_sa <- embed_laplacian_matrix( + g, + no = no, + which = "sa", + type = "DAD", scaled = FALSE ) expect_equal(au_sa$D, D[vcount(g) - 1:no + 1]) - expect_equal(standardize_eigen_signs(au_sa$X), standardize_eigen_signs(X[, vcount(g) - 1:no + 1])) + expect_equal( + standardize_eigen_signs(au_sa$X), + standardize_eigen_signs(X[, vcount(g) - 1:no + 1]) + ) expect_equal(as_sa$D, D[vcount(g) - 1:no + 1]) - expect_equal(standardize_eigen_signs(as_sa$X), standardize_eigen_signs(U[, vcount(g) - 1:no + 1])) + expect_equal( + standardize_eigen_signs(as_sa$X), + standardize_eigen_signs(U[, vcount(g) - 1:no + 1]) + ) }) test_that("embed_laplacian_matrix -- Undirected, unweighted, I-DAD case works", { @@ -606,51 +921,87 @@ test_that("embed_laplacian_matrix -- Undirected, unweighted, I-DAD case works", ## LA - au_la <- embed_laplacian_matrix(g, - no = no, which = "la", type = "I-DAD", + au_la <- embed_laplacian_matrix( + g, + no = no, + which = "la", + type = "I-DAD", scaled = TRUE ) - as_la <- embed_laplacian_matrix(g, - no = no, which = "la", type = "I-DAD", + as_la <- embed_laplacian_matrix( + g, + no = no, + which = "la", + type = "I-DAD", scaled = FALSE ) expect_equal(au_la$D, abs(D[1:no])) - expect_equal(standardize_eigen_signs(au_la$X), standardize_eigen_signs(X[, 1:no])) + expect_equal( + standardize_eigen_signs(au_la$X), + standardize_eigen_signs(X[, 1:no]) + ) expect_equal(as_la$D, D[1:no]) - expect_equal(standardize_eigen_signs(as_la$X), standardize_eigen_signs(U[, 1:no])) + expect_equal( + standardize_eigen_signs(as_la$X), + standardize_eigen_signs(U[, 1:no]) + ) ## LM - au_lm <- embed_laplacian_matrix(g, - no = no, which = "lm", type = "I-DAD", + au_lm <- embed_laplacian_matrix( + g, + no = no, + which = "lm", + type = "I-DAD", scaled = TRUE ) - as_lm <- embed_laplacian_matrix(g, - no = no, which = "lm", type = "I-DAD", + as_lm <- embed_laplacian_matrix( + g, + no = no, + which = "lm", + type = "I-DAD", scaled = FALSE ) expect_equal(au_lm$D, sort_by_magnitude(D)[1:no]) - expect_equal(standardize_eigen_signs(au_lm$X), standardize_eigen_signs(X[, order_by_magnitude(D)][, 1:no])) + expect_equal( + standardize_eigen_signs(au_lm$X), + standardize_eigen_signs(X[, order_by_magnitude(D)][, 1:no]) + ) expect_equal(as_lm$D, sort_by_magnitude(D)[1:no]) - expect_equal(standardize_eigen_signs(as_lm$X), standardize_eigen_signs(U[, order_by_magnitude(D)][, 1:no])) + expect_equal( + standardize_eigen_signs(as_lm$X), + standardize_eigen_signs(U[, order_by_magnitude(D)][, 1:no]) + ) ## SA - au_sa <- embed_laplacian_matrix(g, - no = no, which = "sa", type = "I-DAD", + au_sa <- embed_laplacian_matrix( + g, + no = no, + which = "sa", + type = "I-DAD", scaled = TRUE ) - as_sa <- embed_laplacian_matrix(g, - no = no, which = "sa", type = "I-DAD", + as_sa <- embed_laplacian_matrix( + g, + no = no, + which = "sa", + type = "I-DAD", scaled = FALSE ) expect_equal(au_sa$D, D[vcount(g) - 1:no + 1]) - expect_equal(standardize_eigen_signs(au_sa$X), standardize_eigen_signs(X[, vcount(g) - 1:no + 1])) + expect_equal( + standardize_eigen_signs(au_sa$X), + standardize_eigen_signs(X[, vcount(g) - 1:no + 1]) + ) expect_equal(as_sa$D, D[vcount(g) - 1:no + 1]) - expect_equal(standardize_eigen_signs(as_sa$X), standardize_eigen_signs(U[, vcount(g) - 1:no + 1])) + expect_equal( + standardize_eigen_signs(as_sa$X), + standardize_eigen_signs(U[, vcount(g) - 1:no + 1]) + ) }) test_that("embed_laplacian_matrix -- Directed, unweighted, OAP case works", { @@ -670,53 +1021,108 @@ test_that("embed_laplacian_matrix -- Directed, unweighted, OAP case works", { X <- standardize_eigen_signs(ss$u %*% sqrt(diag(ss$d))) Y <- standardize_eigen_signs(ss$v %*% sqrt(diag(ss$d))) - au_la <- embed_laplacian_matrix(g, - no = no, which = "la", type = "OAP", + au_la <- embed_laplacian_matrix( + g, + no = no, + which = "la", + type = "OAP", scaled = TRUE ) - as_la <- embed_laplacian_matrix(g, - no = no, which = "la", type = "OAP", + as_la <- embed_laplacian_matrix( + g, + no = no, + which = "la", + type = "OAP", scaled = FALSE ) expect_equal(au_la$D, D[1:no]) - expect_equal(standardize_eigen_signs(au_la$X), standardize_eigen_signs(X[, 1:no])) - expect_equal(standardize_eigen_signs(au_la$Y), standardize_eigen_signs(Y[, 1:no])) + expect_equal( + standardize_eigen_signs(au_la$X), + standardize_eigen_signs(X[, 1:no]) + ) + expect_equal( + standardize_eigen_signs(au_la$Y), + standardize_eigen_signs(Y[, 1:no]) + ) expect_equal(as_la$D, D[1:no]) - expect_equal(standardize_eigen_signs(as_la$X), standardize_eigen_signs(U[, 1:no])) - expect_equal(standardize_eigen_signs(as_la$Y), standardize_eigen_signs(V[, 1:no])) + expect_equal( + standardize_eigen_signs(as_la$X), + standardize_eigen_signs(U[, 1:no]) + ) + expect_equal( + standardize_eigen_signs(as_la$Y), + standardize_eigen_signs(V[, 1:no]) + ) - au_lm <- embed_laplacian_matrix(g, - no = no, which = "lm", type = "OAP", + au_lm <- embed_laplacian_matrix( + g, + no = no, + which = "lm", + type = "OAP", scaled = TRUE ) - as_lm <- embed_laplacian_matrix(g, - no = no, which = "lm", type = "OAP", + as_lm <- embed_laplacian_matrix( + g, + no = no, + which = "lm", + type = "OAP", scaled = FALSE ) expect_equal(au_lm$D, D[1:no]) - expect_equal(standardize_eigen_signs(au_lm$X), standardize_eigen_signs(X[, 1:no])) - expect_equal(standardize_eigen_signs(au_lm$Y), standardize_eigen_signs(Y[, 1:no])) + expect_equal( + standardize_eigen_signs(au_lm$X), + standardize_eigen_signs(X[, 1:no]) + ) + expect_equal( + standardize_eigen_signs(au_lm$Y), + standardize_eigen_signs(Y[, 1:no]) + ) expect_equal(as_lm$D, D[1:no]) - expect_equal(standardize_eigen_signs(as_lm$X), standardize_eigen_signs(U[, 1:no])) - expect_equal(standardize_eigen_signs(as_lm$Y), standardize_eigen_signs(V[, 1:no])) + expect_equal( + standardize_eigen_signs(as_lm$X), + standardize_eigen_signs(U[, 1:no]) + ) + expect_equal( + standardize_eigen_signs(as_lm$Y), + standardize_eigen_signs(V[, 1:no]) + ) - au_sa <- embed_laplacian_matrix(g, - no = no, which = "sa", type = "OAP", + au_sa <- embed_laplacian_matrix( + g, + no = no, + which = "sa", + type = "OAP", scaled = TRUE ) - as_sa <- embed_laplacian_matrix(g, - no = no, which = "sa", type = "OAP", + as_sa <- embed_laplacian_matrix( + g, + no = no, + which = "sa", + type = "OAP", scaled = FALSE ) expect_equal(au_sa$D, D[vcount(g) - 1:no + 1]) - expect_equal(standardize_eigen_signs(au_sa$X), standardize_eigen_signs(X[, vcount(g) - 1:no + 1])) - expect_equal(standardize_eigen_signs(au_sa$Y), standardize_eigen_signs(Y[, vcount(g) - 1:no + 1]), tolerance = 1e-6) + expect_equal( + standardize_eigen_signs(au_sa$X), + standardize_eigen_signs(X[, vcount(g) - 1:no + 1]) + ) + expect_equal( + standardize_eigen_signs(au_sa$Y), + standardize_eigen_signs(Y[, vcount(g) - 1:no + 1]), + tolerance = 1e-6 + ) expect_equal(as_sa$D, D[vcount(g) - 1:no + 1]) - expect_equal(standardize_eigen_signs(as_sa$X), standardize_eigen_signs(U[, vcount(g) - 1:no + 1])) - expect_equal(standardize_eigen_signs(as_sa$Y), standardize_eigen_signs(V[, vcount(g) - 1:no + 1])) + expect_equal( + standardize_eigen_signs(as_sa$X), + standardize_eigen_signs(U[, vcount(g) - 1:no + 1]) + ) + expect_equal( + standardize_eigen_signs(as_sa$Y), + standardize_eigen_signs(V[, vcount(g) - 1:no + 1]) + ) }) test_that("embed_laplacian_matrix -- Directed, weighted case works", { @@ -737,53 +1143,107 @@ test_that("embed_laplacian_matrix -- Directed, weighted case works", { X <- standardize_eigen_signs(ss$u %*% sqrt(diag(ss$d))) Y <- standardize_eigen_signs(ss$v %*% sqrt(diag(ss$d))) - au_la <- embed_laplacian_matrix(g, - no = no, which = "la", type = "OAP", + au_la <- embed_laplacian_matrix( + g, + no = no, + which = "la", + type = "OAP", scaled = TRUE ) - as_la <- embed_laplacian_matrix(g, - no = no, which = "la", type = "OAP", + as_la <- embed_laplacian_matrix( + g, + no = no, + which = "la", + type = "OAP", scaled = FALSE ) expect_equal(au_la$D, D[1:no]) - expect_equal(standardize_eigen_signs(au_la$X), standardize_eigen_signs(X[, 1:no])) - expect_equal(standardize_eigen_signs(au_la$Y), standardize_eigen_signs(Y[, 1:no])) + expect_equal( + standardize_eigen_signs(au_la$X), + standardize_eigen_signs(X[, 1:no]) + ) + expect_equal( + standardize_eigen_signs(au_la$Y), + standardize_eigen_signs(Y[, 1:no]) + ) expect_equal(as_la$D, D[1:no]) - expect_equal(standardize_eigen_signs(as_la$X), standardize_eigen_signs(U[, 1:no])) - expect_equal(standardize_eigen_signs(as_la$Y), standardize_eigen_signs(V[, 1:no])) + expect_equal( + standardize_eigen_signs(as_la$X), + standardize_eigen_signs(U[, 1:no]) + ) + expect_equal( + standardize_eigen_signs(as_la$Y), + standardize_eigen_signs(V[, 1:no]) + ) - au_lm <- embed_laplacian_matrix(g, - no = no, which = "lm", type = "OAP", + au_lm <- embed_laplacian_matrix( + g, + no = no, + which = "lm", + type = "OAP", scaled = TRUE ) - as_lm <- embed_laplacian_matrix(g, - no = no, which = "lm", type = "OAP", + as_lm <- embed_laplacian_matrix( + g, + no = no, + which = "lm", + type = "OAP", scaled = FALSE ) expect_equal(au_lm$D, D[1:no]) - expect_equal(standardize_eigen_signs(au_lm$X), standardize_eigen_signs(X[, 1:no])) - expect_equal(standardize_eigen_signs(au_lm$Y), standardize_eigen_signs(Y[, 1:no])) + expect_equal( + standardize_eigen_signs(au_lm$X), + standardize_eigen_signs(X[, 1:no]) + ) + expect_equal( + standardize_eigen_signs(au_lm$Y), + standardize_eigen_signs(Y[, 1:no]) + ) expect_equal(as_lm$D, D[1:no]) - expect_equal(standardize_eigen_signs(as_lm$X), standardize_eigen_signs(U[, 1:no])) - expect_equal(standardize_eigen_signs(as_lm$Y), standardize_eigen_signs(V[, 1:no])) + expect_equal( + standardize_eigen_signs(as_lm$X), + standardize_eigen_signs(U[, 1:no]) + ) + expect_equal( + standardize_eigen_signs(as_lm$Y), + standardize_eigen_signs(V[, 1:no]) + ) - au_sa <- embed_laplacian_matrix(g, - no = no, which = "sa", type = "OAP", + au_sa <- embed_laplacian_matrix( + g, + no = no, + which = "sa", + type = "OAP", scaled = TRUE ) - as_sa <- embed_laplacian_matrix(g, - no = no, which = "sa", type = "OAP", + as_sa <- embed_laplacian_matrix( + g, + no = no, + which = "sa", + type = "OAP", scaled = FALSE ) expect_equal(au_sa$D, D[vcount(g) - 1:no + 1]) - expect_equal(standardize_eigen_signs(au_sa$X), standardize_eigen_signs(X[, vcount(g) - 1:no + 1])) - expect_equal(standardize_eigen_signs(au_sa$Y), standardize_eigen_signs(Y[, vcount(g) - 1:no + 1])) + expect_equal( + standardize_eigen_signs(au_sa$X), + standardize_eigen_signs(X[, vcount(g) - 1:no + 1]) + ) + expect_equal( + standardize_eigen_signs(au_sa$Y), + standardize_eigen_signs(Y[, vcount(g) - 1:no + 1]) + ) expect_equal(as_sa$D, D[vcount(g) - 1:no + 1]) - expect_equal(standardize_eigen_signs(as_sa$X), standardize_eigen_signs(U[, vcount(g) - 1:no + 1])) - expect_equal(standardize_eigen_signs(as_sa$Y), standardize_eigen_signs(V[, vcount(g) - 1:no + 1])) + expect_equal( + standardize_eigen_signs(as_sa$X), + standardize_eigen_signs(U[, vcount(g) - 1:no + 1]) + ) + expect_equal( + standardize_eigen_signs(as_sa$Y), + standardize_eigen_signs(V[, vcount(g) - 1:no + 1]) + ) }) test_that("Sampling from a Dirichlet distribution works", { diff --git a/tests/testthat/test-eulerian.R b/tests/testthat/test-eulerian.R index 12126127556..806cd3b1a0d 100644 --- a/tests/testthat/test-eulerian.R +++ b/tests/testthat/test-eulerian.R @@ -31,7 +31,10 @@ test_that("eulerian_path works", { path <- eulerian_path(g) path$epath <- as.vector(path$epath) path$vpath <- as.vector(path$vpath) - expect_equal(path$epath, as.vector(E(g, path = c(1, 2, 3, 4, 2, 6, 1, 5, 4, 6, 5)))) + expect_equal( + path$epath, + as.vector(E(g, path = c(1, 2, 3, 4, 2, 6, 1, 5, 4, 6, 5))) + ) expect_equal(path$vpath, c(1, 2, 3, 4, 2, 6, 1, 5, 4, 6, 5)) g <- graph_from_literal(A - B - C - D - A - D - C, B - D, simplify = FALSE) diff --git a/tests/testthat/test-flow.R b/tests/testthat/test-flow.R index 170a392a241..3083a8bbf72 100644 --- a/tests/testthat/test-flow.R +++ b/tests/testthat/test-flow.R @@ -55,17 +55,33 @@ test_that("st_cuts() works", { expect_equal( unvs(all_cuts_star_v7$cuts), list( - c(1, 2), c(1, 7), c(2, 3, 4, 5, 6), c(2, 3, 4, 5, 10), - c(2, 3, 4, 6, 9), c(2, 3, 4, 9, 10), c(2, 3, 5, 6, 8), - c(2, 3, 5, 8, 10), c(2, 3, 6, 8, 9), c(2, 3, 8, 9, 10), c(3, 7) + c(1, 2), + c(1, 7), + c(2, 3, 4, 5, 6), + c(2, 3, 4, 5, 10), + c(2, 3, 4, 6, 9), + c(2, 3, 4, 9, 10), + c(2, 3, 5, 6, 8), + c(2, 3, 5, 8, 10), + c(2, 3, 6, 8, 9), + c(2, 3, 8, 9, 10), + c(3, 7) ) ) expect_equal( unvs(all_cuts_star_v7$partition1s), list( - 1, c(1, 3), c(1, 2), c(1, 2, 7), c(1, 2, 6), - c(1, 2, 6, 7), c(1, 2, 5), c(1, 2, 5, 7), - c(1, 2, 5, 6), c(1, 2, 5, 6, 7), c(1, 2, 5, 6, 7, 3) + 1, + c(1, 3), + c(1, 2), + c(1, 2, 7), + c(1, 2, 6), + c(1, 2, 6, 7), + c(1, 2, 5), + c(1, 2, 5, 7), + c(1, 2, 5, 6), + c(1, 2, 5, 6, 7), + c(1, 2, 5, 6, 7, 3) ) ) @@ -73,7 +89,10 @@ test_that("st_cuts() works", { all_cuts_star_v9 <- st_min_cuts(g_star_v9, source = "s", target = "t") expect_equal(all_cuts_star_v9$value, 2) expect_equal(unvs(all_cuts_star_v9$cuts), list(c(1, 2), c(1, 9), c(3, 9))) - expect_equal(unvs(all_cuts_star_v9$partition1s), list(1, c(1, 3), c(1, 3, 2, 9, 8, 7, 6, 5))) + expect_equal( + unvs(all_cuts_star_v9$partition1s), + list(1, c(1, 3), c(1, 3, 2, 9, 8, 7, 6, 5)) + ) }) test_that("st_cuts errors work", { @@ -81,12 +100,25 @@ test_that("st_cuts errors work", { expect_snapshot(st_cuts(g_path, source = "a", target = NULL), error = TRUE) expect_snapshot(st_cuts(g_path, source = NULL, target = "a"), error = TRUE) - expect_snapshot(st_min_cuts(g_path, source = "a", target = NULL), error = TRUE) - expect_snapshot(st_min_cuts(g_path, source = NULL, target = "a"), error = TRUE) + expect_snapshot( + st_min_cuts(g_path, source = "a", target = NULL), + error = TRUE + ) + expect_snapshot( + st_min_cuts(g_path, source = NULL, target = "a"), + error = TRUE + ) }) test_that("max_flow works", { - edge_mat <- rbind(c(1, 3, 3), c(3, 4, 1), c(4, 2, 2), c(1, 5, 1), c(5, 6, 2), c(6, 2, 10)) + edge_mat <- rbind( + c(1, 3, 3), + c(3, 4, 1), + c(4, 2, 2), + c(1, 5, 1), + c(5, 6, 2), + c(6, 2, 10) + ) colnames(edge_mat) <- c("from", "to", "capacity") g_ring_acyc <- graph_from_data_frame(as.data.frame(edge_mat)) flow <- max_flow(g_ring_acyc, source = "1", target = "2") @@ -118,7 +150,6 @@ test_that("edge_connectivity works", { expect_equal(edge_connectivity(g_full), 4) expect_equal(edge_connectivity(g_full, source = 1, target = 2), 4) - g_path <- make_ring(5, directed = TRUE, circular = FALSE) expect_equal(edge_connectivity(g_path), 0) expect_equal(edge_connectivity(g_path, source = 1, target = 3), 1) @@ -161,8 +192,14 @@ test_that("edge_disjoint_paths works", { test_that("edge_disjoint_paths error works", { g_path <- make_ring(5, circular = FALSE) - expect_snapshot(edge_disjoint_paths(g_path, source = 1, target = NULL), error = TRUE) - expect_snapshot(edge_disjoint_paths(g_path, source = NULL, target = 1), error = TRUE) + expect_snapshot( + edge_disjoint_paths(g_path, source = 1, target = NULL), + error = TRUE + ) + expect_snapshot( + edge_disjoint_paths(g_path, source = NULL, target = 1), + error = TRUE + ) }) test_that("vertex_disjoint_paths works", { @@ -193,7 +230,10 @@ test_that("vertex_disjoint_paths error works", { test_that("dominator_tree works", { - g_tree <- graph_from_edgelist(matrix(c(1, 2, 2, 3, 3, 4, 2, 5, 5, 6), byrow = TRUE, ncol = 2), directed = TRUE) + g_tree <- graph_from_edgelist( + matrix(c(1, 2, 2, 3, 3, 4, 2, 5, 5, 6), byrow = TRUE, ncol = 2), + directed = TRUE + ) dom_tree_tree <- dominator_tree(g_tree, 1) expect_equal(dom_tree_tree$dom[2], 1) @@ -208,7 +248,10 @@ test_that("dominator_tree works", { }) test_that("dominator_tree errors work", { - g_tree <- graph_from_edgelist(matrix(c(1, 2, 2, 3, 3, 4, 2, 5, 5, 6), byrow = TRUE, ncol = 2), directed = TRUE) + g_tree <- graph_from_edgelist( + matrix(c(1, 2, 2, 3, 3, 4, 2, 5, 5, 6), byrow = TRUE, ncol = 2), + directed = TRUE + ) expect_snapshot(dominator_tree(g_tree), error = TRUE) expect_snapshot(dominator_tree(g_tree, root = NULL), error = TRUE) }) @@ -223,11 +266,17 @@ test_that("dominator_tree works -- legacy", { names <- c("$root", V(g)$name) dtree$dom <- names[ifelse(dtree$dom < 0, 1, dtree$dom + 1)] dtree$leftout <- V(g)$name[dtree$leftout] - expect_equal(dtree$dom, c("$root", "R", "R", "R", "R", "R", "C", "C", "D", "R", "R", "G", "R")) + expect_equal( + dtree$dom, + c("$root", "R", "R", "R", "R", "R", "C", "C", "D", "R", "R", "G", "R") + ) expect_equal(dtree$leftout, character()) expect_equal( as_edgelist(dtree$domtree), - structure(c("R", "R", "R", "R", "R", "C", "C", "D", "R", "R", "G", "R", "A", "B", "C", "D", "E", "F", "G", "L", "H", "I", "J", "K"), .Dim = c(12L, 2L)) + structure( + c("R", "R", "R", "R", "R", "C", "C", "D", "R", "R", "G", "R", "A", "B", "C", "D", "E", "F", "G", "L", "H", "I", "J", "K"), + .Dim = c(12L, 2L) + ) ) }) diff --git a/tests/testthat/test-foreign.R b/tests/testthat/test-foreign.R index b22e898ce71..37f3d2a2a63 100644 --- a/tests/testthat/test-foreign.R +++ b/tests/testthat/test-foreign.R @@ -48,6 +48,12 @@ test_that("graph_from_graphdb works", { expect_snapshot(g <- graph_from_graphdb(nodes = 1000)) expect_snapshot(g <- graph_from_graphdb(), error = TRUE) - expect_snapshot(g <- graph_from_graphdb(nodes = 10, prefix = "not_existing"), error = TRUE) - expect_snapshot(g <- graph_from_graphdb(nodes = 10, type = "not_existing"), error = TRUE) + expect_snapshot( + g <- graph_from_graphdb(nodes = 10, prefix = "not_existing"), + error = TRUE + ) + expect_snapshot( + g <- graph_from_graphdb(nodes = 10, type = "not_existing"), + error = TRUE + ) }) diff --git a/tests/testthat/test-games.R b/tests/testthat/test-games.R index 881f3abda26..0c786e1d23a 100644 --- a/tests/testthat/test-games.R +++ b/tests/testthat/test-games.R @@ -32,7 +32,10 @@ test_that("sample_degseq() works -- sample_gnp()", { test_that("sample_degseq() works -- 'configuration' generator, connected", { original_graph <- largest_component(sample_gnp(1000, 2 / 1000)) - simple_graph <- sample_degseq(degree(original_graph), method = "configuration") + simple_graph <- sample_degseq( + degree(original_graph), + method = "configuration" + ) expect_equal(degree(simple_graph), degree(original_graph)) vl_graph <- sample_degseq(degree(simple_graph), method = "vl") @@ -50,14 +53,24 @@ test_that("sample_degseq() works -- vl generator", { test_that("sample_degseq() works -- exponential degree ok", { withr::local_seed(1) - exponential_degrees <- sample(1:100, 100, replace = TRUE, prob = exp(-0.5 * (1:100))) + exponential_degrees <- sample( + 1:100, + 100, + replace = TRUE, + prob = exp(-0.5 * (1:100)) + ) exp_vl_graph <- sample_degseq(exponential_degrees, method = "vl") expect_equal(degree(exp_vl_graph), exponential_degrees) }) test_that("sample_degseq() works -- exponential degree error", { withr::local_seed(11) - exponential_degrees <- sample(1:100, 100, replace = TRUE, prob = exp(-0.5 * (1:100))) + exponential_degrees <- sample( + 1:100, + 100, + replace = TRUE, + prob = exp(-0.5 * (1:100)) + ) expect_snapshot( { sample_degseq(exponential_degrees, method = "vl") @@ -101,7 +114,8 @@ test_that("sample_degseq() works -- fast.heur.simple", { test_that("sample_degseq() works -- configuration.simple", { g <- sample_gnp(1000, 1 / 1000) - simple_nmu_graph <- sample_degseq(degree(g, mode = "out"), + simple_nmu_graph <- sample_degseq( + degree(g, mode = "out"), degree(g, mode = "in"), method = "configuration.simple" ) @@ -111,11 +125,15 @@ test_that("sample_degseq() works -- configuration.simple", { test_that("sample_degseq() works -- edge.switching.simple directed", { g <- sample_gnp(1000, 1 / 1000, directed = TRUE) - simple_switch_graph <- sample_degseq(degree(g, mode = "out"), + simple_switch_graph <- sample_degseq( + degree(g, mode = "out"), degree(g, mode = "in"), method = "edge.switching.simple" ) - expect_equal(degree(simple_switch_graph, mode = "out"), degree(g, mode = "out")) + expect_equal( + degree(simple_switch_graph, mode = "out"), + degree(g, mode = "out") + ) expect_equal(degree(simple_switch_graph, mode = "in"), degree(g, mode = "in")) }) @@ -125,7 +143,10 @@ test_that("sample_degseq() works -- edge.switching.simple undirected", { degree(g, mode = "all"), method = "edge.switching.simple" ) - expect_equal(degree(simple_switch_graph, mode = "all"), degree(g, mode = "all")) + expect_equal( + degree(simple_switch_graph, mode = "all"), + degree(g, mode = "all") + ) }) test_that("sample_degseq supports the sample_(...) syntax", { @@ -162,13 +183,25 @@ test_that("sample_chung_lu works", { chung_lu_small <- sample_chung_lu(c(3, 3, 2, 2, 1, 1)) expect_false(any_multiple(chung_lu_small)) - chung_lu_no_loop_1 <- sample_chung_lu(c(3, 3, 2, 2, 1, 1), loops = FALSE, variant = "original") + chung_lu_no_loop_1 <- sample_chung_lu( + c(3, 3, 2, 2, 1, 1), + loops = FALSE, + variant = "original" + ) expect_true(is_simple(chung_lu_no_loop_1)) - chung_lu_no_loop_2 <- sample_chung_lu(c(3, 3, 2, 2, 1, 1), loops = FALSE, variant = "maxent") + chung_lu_no_loop_2 <- sample_chung_lu( + c(3, 3, 2, 2, 1, 1), + loops = FALSE, + variant = "maxent" + ) expect_true(is_simple(chung_lu_no_loop_2)) - chung_lu_no_loop_3 <- sample_chung_lu(c(3, 3, 2, 2, 1, 1), loops = FALSE, variant = "nr") + chung_lu_no_loop_3 <- sample_chung_lu( + c(3, 3, 2, 2, 1, 1), + loops = FALSE, + variant = "nr" + ) expect_true(is_simple(chung_lu_no_loop_3)) }) @@ -210,29 +243,50 @@ test_that("sample_forestfire() works -- dense", { test_that("Generating stochastic block models works", { pm <- matrix(1, nrow = 2, ncol = 2) bs <- c(4, 6) - sbm_small <- sample_sbm(10, - pref.matrix = pm, block.sizes = bs, - directed = FALSE, loops = FALSE + sbm_small <- sample_sbm( + 10, + pref.matrix = pm, + block.sizes = bs, + directed = FALSE, + loops = FALSE + ) + expect_isomorphic( + sbm_small, + make_full_graph(10, directed = FALSE, loops = FALSE) ) - expect_isomorphic(sbm_small, make_full_graph(10, directed = FALSE, loops = FALSE)) - sbm_small_loops <- sample_sbm(10, - pref.matrix = pm, block.sizes = bs, - directed = FALSE, loops = TRUE + sbm_small_loops <- sample_sbm( + 10, + pref.matrix = pm, + block.sizes = bs, + directed = FALSE, + loops = TRUE ) full_graph_loops <- make_full_graph(10, directed = FALSE, loops = TRUE) - expect_equal(sbm_small_loops[sparse = FALSE], full_graph_loops[sparse = FALSE]) + expect_equal( + sbm_small_loops[sparse = FALSE], + full_graph_loops[sparse = FALSE] + ) - sbm_small_directed <- sample_sbm(10, - pref.matrix = pm, block.sizes = bs, - directed = TRUE, loops = FALSE + sbm_small_directed <- sample_sbm( + 10, + pref.matrix = pm, + block.sizes = bs, + directed = TRUE, + loops = FALSE ) full_graph_directed <- make_full_graph(10, directed = TRUE, loops = FALSE) - expect_equal(sbm_small_directed[sparse = FALSE], full_graph_directed[sparse = FALSE]) + expect_equal( + sbm_small_directed[sparse = FALSE], + full_graph_directed[sparse = FALSE] + ) - sbm_small_all <- sample_sbm(10, - pref.matrix = pm, block.sizes = bs, - directed = TRUE, loops = TRUE + sbm_small_all <- sample_sbm( + 10, + pref.matrix = pm, + block.sizes = bs, + directed = TRUE, + loops = TRUE ) full_graph_all <- make_full_graph(10, directed = TRUE, loops = TRUE) expect_equal(sbm_small_all[sparse = FALSE], full_graph_all[sparse = FALSE]) @@ -276,7 +330,12 @@ test_that("sample_pa() works", { test_that("sample_pa can start from a graph", { withr::local_seed(20231029) - g_pa1 <- sample_pa(10, m = 1, algorithm = "bag", start.graph = make_empty_graph(5)) + g_pa1 <- sample_pa( + 10, + m = 1, + algorithm = "bag", + start.graph = make_empty_graph(5) + ) expect_ecount(g_pa1, 5) expect_vcount(g_pa1, 10) @@ -294,21 +353,27 @@ test_that("sample_pa can start from a graph", { g_pa2 <- sample_pa(10, m = 1, algorithm = "bag", start.graph = make_star(10)) expect_isomorphic(g_pa2, make_star(10)) - g_pa3 <- sample_pa(10, - m = 3, algorithm = "psumtree-multiple", + g_pa3 <- sample_pa( + 10, + m = 3, + algorithm = "psumtree-multiple", start.graph = make_empty_graph(5) ) expect_equal(degree(g_pa3, mode = "out"), c(0, 0, 0, 0, 0, 3, 3, 3, 3, 3)) - g_pa4 <- sample_pa(10, - m = 3, algorithm = "psumtree-multiple", + g_pa4 <- sample_pa( + 10, + m = 3, + algorithm = "psumtree-multiple", start.graph = make_star(5) ) expect_equal(degree(g_pa4, mode = "out"), c(0, 1, 1, 1, 1, 3, 3, 3, 3, 3)) expect_isomorphic(induced_subgraph(g_pa4, 1:5), make_star(5)) - g_pa5 <- sample_pa(10, - m = 3, algorithm = "psumtree-multiple", + g_pa5 <- sample_pa( + 10, + m = 3, + algorithm = "psumtree-multiple", start.graph = make_star(10) ) expect_isomorphic(g_pa5, make_star(10)) @@ -343,7 +408,13 @@ test_that("sample_bipartite works -- directed gnp", { expect_true(is_directed(g_rand_bip_dir)) expect_output(print_all(g_rand_bip_dir), "5->11") - g_rand_bip_in <- sample_bipartite_gnp(10, 5, p = .1, directed = TRUE, mode = "in") + g_rand_bip_in <- sample_bipartite_gnp( + 10, + 5, + p = .1, + directed = TRUE, + mode = "in" + ) expect_output(print_all(g_rand_bip_in), "11->3") }) @@ -362,17 +433,35 @@ test_that("sample_bipartite works -- directed gnm", { expect_true(is_directed(g_rand_bip_gnm_dir)) expect_output(print_all(g_rand_bip_gnm_dir), "5->12") - g_rand_bip_gnm_in <- sample_bipartite_gnm(10, 5, m = 8, directed = TRUE, mode = "in") + g_rand_bip_gnm_in <- sample_bipartite_gnm( + 10, + 5, + m = 8, + directed = TRUE, + mode = "in" + ) expect_vcount(g_rand_bip_gnm_in, 15) expect_ecount(g_rand_bip_gnm_in, 8) expect_true(bipartite_mapping(g_rand_bip_gnm_in)$res) expect_true(is_directed(g_rand_bip_gnm_in)) expect_output(print_all(g_rand_bip_gnm_in), "12->10") - g_rand_bip_full <- sample_bipartite_gnp(10, 5, p = 0.9999, directed = TRUE, mode = "all") + g_rand_bip_full <- sample_bipartite_gnp( + 10, + 5, + p = 0.9999, + directed = TRUE, + mode = "all" + ) expect_ecount(g_rand_bip_full, 100) - g_rand_bip_edges <- sample_bipartite_gnm(10, 5, m = 99, directed = TRUE, mode = "all") + g_rand_bip_edges <- sample_bipartite_gnm( + 10, + 5, + m = 99, + directed = TRUE, + mode = "all" + ) expect_ecount(g_rand_bip_edges, 99) }) @@ -381,10 +470,20 @@ test_that("sample_correlated_gnp works", { withr::local_seed(42) gnp_graph <- sample_gnp(10, .1) - cor_gnp_graph_1 <- sample_correlated_gnp(gnp_graph, corr = 1, p = gnp_graph$p, permutation = NULL) + cor_gnp_graph_1 <- sample_correlated_gnp( + gnp_graph, + corr = 1, + p = gnp_graph$p, + permutation = NULL + ) expect_equal(gnp_graph[], cor_gnp_graph_1[]) - cor_gnp_graph_0 <- sample_correlated_gnp(gnp_graph, corr = 0, p = gnp_graph$p, permutation = NULL) + cor_gnp_graph_0 <- sample_correlated_gnp( + gnp_graph, + corr = 0, + p = gnp_graph$p, + permutation = NULL + ) graph_cor_1 <- cor(as.vector(gnp_graph[]), as.vector(cor_gnp_graph_0[])) expect_true(abs(graph_cor_1) < .3) @@ -412,7 +511,12 @@ test_that("sample_correlated_gnp works even for non-ER graphs", { test_that("sample_correlated_gnp_pair works", { withr::local_seed(42) - cor_gnp_pair <- sample_correlated_gnp_pair(10, corr = .95, p = .1, permutation = NULL) + cor_gnp_pair <- sample_correlated_gnp_pair( + 10, + corr = .95, + p = .1, + permutation = NULL + ) expect_true(abs(ecount(cor_gnp_pair[[1]]) - ecount(cor_gnp_pair[[2]])) < 3) }) @@ -427,18 +531,34 @@ test_that("sample_correlated_gnp corner cases work", { } gnp_graph <- sample_gnp(10, .3) - cor_gnp_full <- sample_correlated_gnp(gnp_graph, corr = 0.000001, p = .99999999) + cor_gnp_full <- sample_correlated_gnp( + gnp_graph, + corr = 0.000001, + p = .99999999 + ) expect_true(is_full(cor_gnp_full)) - cor_gnp_empty <- sample_correlated_gnp(gnp_graph, corr = 0.000001, p = 0.0000001) + cor_gnp_empty <- sample_correlated_gnp( + gnp_graph, + corr = 0.000001, + p = 0.0000001 + ) expect_ecount(cor_gnp_empty, 0) expect_vcount(cor_gnp_empty, 10) gnp_graph_directed <- sample_gnp(10, .3, directed = TRUE) - cor_gnp_directed <- sample_correlated_gnp(gnp_graph_directed, corr = 0.000001, p = .99999999) + cor_gnp_directed <- sample_correlated_gnp( + gnp_graph_directed, + corr = 0.000001, + p = .99999999 + ) expect_true(is_full(cor_gnp_directed)) - cor_gnp_directed_empty <- sample_correlated_gnp(gnp_graph_directed, corr = 0.000001, p = 0.0000001) + cor_gnp_directed_empty <- sample_correlated_gnp( + gnp_graph_directed, + corr = 0.000001, + p = 0.0000001 + ) expect_ecount(cor_gnp_directed_empty, 0) expect_vcount(cor_gnp_directed_empty, 10) }) @@ -448,12 +568,22 @@ test_that("permutation works for sample_correlated_gnp", { gnp_graph <- sample_gnp(10, .3) perm <- sample(vcount(gnp_graph)) - cor_gnp_graph <- sample_correlated_gnp(gnp_graph, corr = .99999, p = .3, permutation = perm) + cor_gnp_graph <- sample_correlated_gnp( + gnp_graph, + corr = .99999, + p = .3, + permutation = perm + ) gnp_graph <- permute(gnp_graph, perm) expect_equal(gnp_graph[], cor_gnp_graph[]) perm <- sample(vcount(gnp_graph)) - cor_gnp_graph <- sample_correlated_gnp(gnp_graph, corr = 1, p = .3, permutation = perm) + cor_gnp_graph <- sample_correlated_gnp( + gnp_graph, + corr = 1, + p = .3, + permutation = perm + ) gnp_graph <- permute(gnp_graph, perm) expect_equal(gnp_graph[], cor_gnp_graph[]) }) @@ -467,28 +597,52 @@ test_that("HSBM works", { 0, 1 / 2, 1 / 2 ), nrow = 3) - g_hsbm1 <- sample_hierarchical_sbm(100, 10, rho = c(3, 3, 4) / 10, C = C, p = 0) + g_hsbm1 <- sample_hierarchical_sbm( + 100, + 10, + rho = c(3, 3, 4) / 10, + C = C, + p = 0 + ) expect_ecount(g_hsbm1, 172) expect_vcount(g_hsbm1, 100) expect_false(is_directed(g_hsbm1)) withr::local_seed(42) - g_hsbm2 <- sample_hierarchical_sbm(100, 10, rho = c(3, 3, 4) / 10, C = C, p = 1) + g_hsbm2 <- sample_hierarchical_sbm( + 100, + 10, + rho = c(3, 3, 4) / 10, + C = C, + p = 1 + ) expect_ecount(g_hsbm2, ecount(g_hsbm1) + 10 * 9 * (90 + 10) / 2) expect_vcount(g_hsbm2, 100) expect_true(is_simple(g_hsbm2)) withr::local_seed(42) - g_hsbm3 <- sample_hierarchical_sbm(100, 10, rho = c(3, 3, 4) / 10, C = C, p = 1e-15) + g_hsbm3 <- sample_hierarchical_sbm( + 100, + 10, + rho = c(3, 3, 4) / 10, + C = C, + p = 1e-15 + ) expect_ecount(g_hsbm3, ecount(g_hsbm1)) expect_vcount(g_hsbm3, 100) expect_true(is_simple(g_hsbm3)) withr::local_seed(42) - g_hsbm4 <- sample_hierarchical_sbm(100, 10, rho = c(3, 3, 4) / 10, C = C, p = 1 - 1e-15) + g_hsbm4 <- sample_hierarchical_sbm( + 100, + 10, + rho = c(3, 3, 4) / 10, + C = C, + p = 1 - 1e-15 + ) expect_ecount(g_hsbm4, ecount(g_hsbm2)) expect_vcount(g_hsbm4, 100) expect_true(is_simple(g_hsbm4)) @@ -515,14 +669,18 @@ test_that("HSBM with list arguments works", { g_hsbm1 <- sample_hierarchical_sbm( blocks * vertices_per_block, vertices_per_block, - rho = rho, C = C, p = 0 + rho = rho, + C = C, + p = 0 ) withr::local_seed(42) g_hsbm2 <- sample_hierarchical_sbm( blocks * vertices_per_block, rep(vertices_per_block, blocks), - rho = rho, C = C, p = 0 + rho = rho, + C = C, + p = 0 ) expect_equal(g_hsbm1[], g_hsbm2[]) @@ -530,7 +688,9 @@ test_that("HSBM with list arguments works", { g_hsbm3 <- sample_hierarchical_sbm( blocks * vertices_per_block, vertices_per_block, - rho = replicate(blocks, rho, simplify = FALSE), C = C, p = 0 + rho = replicate(blocks, rho, simplify = FALSE), + C = C, + p = 0 ) expect_equal(g_hsbm1[], g_hsbm3[]) @@ -538,7 +698,9 @@ test_that("HSBM with list arguments works", { g_hsbm4 <- sample_hierarchical_sbm( blocks * vertices_per_block, vertices_per_block, - rho = rho, C = replicate(blocks, C, simplify = FALSE), p = 0 + rho = rho, + C = replicate(blocks, C, simplify = FALSE), + p = 0 ) expect_equal(g_hsbm1[], g_hsbm4[]) @@ -547,7 +709,9 @@ test_that("HSBM with list arguments works", { sample_hierarchical_sbm( blocks * vertices_per_block, rep(vertices_per_block, blocks), - rho = list(rho, rho), C = C, p = 0 + rho = list(rho, rho), + C = C, + p = 0 ) ) @@ -564,16 +728,22 @@ test_that("HSBM with list arguments works", { rho4 <- n(c(2, 1)) C4 <- matrix(0, nrow = 2, ncol = 2) - g_hsbm5 <- sample_hierarchical_sbm(21, - m = c(3, 10, 5, 3), rho = list(rho1, rho2, rho3, rho4), - C = list(C1, C2, C3, C4), p = 1 + g_hsbm5 <- sample_hierarchical_sbm( + 21, + m = c(3, 10, 5, 3), + rho = list(rho1, rho2, rho3, rho4), + C = list(C1, C2, C3, C4), + p = 1 ) expect_true(is_simple(g_hsbm5)) withr::local_seed(42) - g_hsbm6 <- sample_hierarchical_sbm(21, - m = c(3, 10, 5, 3), rho = list(rho1, rho2, rho3, rho4), - C = list(C1, C2, C3, C4), p = 1 - 1e-10 + g_hsbm6 <- sample_hierarchical_sbm( + 21, + m = c(3, 10, 5, 3), + rho = list(rho1, rho2, rho3, rho4), + C = list(C1, C2, C3, C4), + p = 1 - 1e-10 ) expect_equal(g_hsbm5[], g_hsbm6[]) @@ -585,15 +755,21 @@ test_that("HSBM with list arguments works", { C3 <- matrix(1) rho4 <- n(c(2, 1)) C4 <- matrix(1, nrow = 2, ncol = 2) - g_hsbm7 <- sample_hierarchical_sbm(21, - m = c(3, 10, 5, 3), rho = list(rho1, rho2, rho3, rho4), - C = list(C1, C2, C3, C4), p = 0 + g_hsbm7 <- sample_hierarchical_sbm( + 21, + m = c(3, 10, 5, 3), + rho = list(rho1, rho2, rho3, rho4), + C = list(C1, C2, C3, C4), + p = 0 ) expect_true(is_simple(g_hsbm7)) - g_hsbm8 <- sample_hierarchical_sbm(21, - m = c(3, 10, 5, 3), rho = list(rho1, rho2, rho3, rho4), - C = list(C1, C2, C3, C4), p = 1 + g_hsbm8 <- sample_hierarchical_sbm( + 21, + m = c(3, 10, 5, 3), + rho = list(rho1, rho2, rho3, rho4), + C = list(C1, C2, C3, C4), + p = 1 ) expect_equal(g_hsbm5[] + g_hsbm7[], g_hsbm8[]) }) @@ -601,7 +777,9 @@ test_that("HSBM with list arguments works", { test_that("Dot product rng works", { withr::local_seed(42) vecs <- cbind( - c(0, 1, 1, 1, 0) / 3, c(0, 1, 1, 0, 1) / 3, c(1, 1, 1, 1, 0) / 4, + c(0, 1, 1, 1, 0) / 3, + c(0, 1, 1, 0, 1) / 3, + c(1, 1, 1, 1, 0) / 4, c(0, 1, 1, 1, 0) ) @@ -627,10 +805,12 @@ test_that("Dot product rng works", { test_that("sample_dot_product generates edges with correct probabilities", { withr::local_seed(42) latent_features <- cbind( - c(0, 1, 1, 1, 0) / 3, c(0, 1, 1, 0, 1) / 3, c(1, 1, 1, 1, 0) / 4, + c(0, 1, 1, 1, 0) / 3, + c(0, 1, 1, 0, 1) / 3, + c(1, 1, 1, 1, 0) / 4, c(0, 1, 1, 1, 0) ) - expected_probs <- t(latent_features)%*%latent_features + expected_probs <- t(latent_features) %*% latent_features diag(expected_probs) <- 0 num_graphs <- 1000 edge_counts <- matrix(0, nrow = 4, ncol = 4) diff --git a/tests/testthat/test-glet.R b/tests/testthat/test-glet.R index 2f899c84742..af7cd8b615d 100644 --- a/tests/testthat/test-glet.R +++ b/tests/testthat/test-glet.R @@ -30,7 +30,11 @@ test_that("Graphlets filtering works", { weight = c(8, 8, 8, 5, 5, 5, 5, 5) ) - g <- graph_from_data_frame(df, directed = FALSE, vertices = data.frame(LETTERS[1:5])) + g <- graph_from_data_frame( + df, + directed = FALSE, + vertices = data.frame(LETTERS[1:5]) + ) glet <- sortgl(graphlet_basis(g)) expect_equal(glet$cliques, list(1:3, 2:5)) @@ -95,8 +99,12 @@ graphlets.project.old <- function(graph, cliques, iter, Mu = NULL) { if (min(E(graph)$weight) <= 0 || any(!is.finite(E(graph)$weight))) { stop("Edge weights must be non-negative and finite") } - if (length(iter) != 1 || !is.numeric(iter) || - !is.finite(iter) || iter != as.integer(iter)) { + if ( + length(iter) != 1 || + !is.numeric(iter) || + !is.finite(iter) || + iter != as.integer(iter) + ) { stop("`iter' must be a non-negative finite integer scalar") } @@ -157,7 +165,11 @@ test_that("Graphlet projection works", { D1[1:3, 1:3] <- 2 D2[3:5, 3:5] <- 3 D3[2:5, 2:5] <- 1 - g <- graph_from_adjacency_matrix(D1 + D2 + D3, mode = "undirected", weighted = TRUE) + g <- graph_from_adjacency_matrix( + D1 + D2 + D3, + mode = "undirected", + weighted = TRUE + ) g <- simplify(g) gl <- graphlet_basis(g) diff --git a/tests/testthat/test-incidence.R b/tests/testthat/test-incidence.R index 9966a8986c1..3f4b1ba7c43 100644 --- a/tests/testthat/test-incidence.R +++ b/tests/testthat/test-incidence.R @@ -9,7 +9,9 @@ test_that("graph_from_biadjacency_matrix() works -- dense", { expect_snapshot((g <- graph_from_biadjacency_matrix(inc))) expect_false(is_weighted(g)) - expect_snapshot((weighted_g <- graph_from_biadjacency_matrix(inc, weighted = TRUE))) + expect_snapshot( + (weighted_g <- graph_from_biadjacency_matrix(inc, weighted = TRUE)) + ) expect_true(is_weighted(weighted_g)) }) @@ -48,7 +50,10 @@ test_that("graph_from_biadjacency_matrix() works - dense, modes", { mutual_g <- graph_from_biadjacency_matrix(inc, directed = TRUE, mode = "all") expect_true(is_directed(mutual_g)) expect_length(E(mutual_g), 14) - expect_equal(as_adj_list(mutual_g, mode = "all")$A %>% as.numeric(), c(6, 6, 7, 7)) + expect_equal( + as_adj_list(mutual_g, mode = "all")$A %>% as.numeric(), + c(6, 6, 7, 7) + ) }) test_that("graph_from_biadjacency_matrix() works - dense, modes, weighted", { @@ -59,25 +64,48 @@ test_that("graph_from_biadjacency_matrix() works - dense, modes, weighted", { colnames(inc) <- letters[1:5] rownames(inc) <- LETTERS[1:3] - out_g <- graph_from_biadjacency_matrix(inc, directed = TRUE, mode = "out", weighted = TRUE) + out_g <- graph_from_biadjacency_matrix( + inc, + directed = TRUE, + mode = "out", + weighted = TRUE + ) expect_true(is_directed(out_g)) expect_length(E(out_g), 8) expect_equal(as_adj_list(out_g, mode = "out")$A %>% as.numeric(), c(6, 7, 8)) - in_g <- graph_from_biadjacency_matrix(inc, directed = TRUE, mode = "in", weighted = TRUE) + in_g <- graph_from_biadjacency_matrix( + inc, + directed = TRUE, + mode = "in", + weighted = TRUE + ) expect_true(is_directed(in_g)) expect_length(E(in_g), 8) expect_equal(as_adj_list(in_g, mode = "in")$A %>% as.numeric(), c(6, 7, 8)) - mutual_g <- graph_from_biadjacency_matrix(inc, directed = TRUE, mode = "all", weighted = TRUE) + mutual_g <- graph_from_biadjacency_matrix( + inc, + directed = TRUE, + mode = "all", + weighted = TRUE + ) expect_true(is_directed(mutual_g)) expect_length(E(mutual_g), 16) - expect_equal(as_adj_list(mutual_g, mode = "all")$A %>% as.numeric(), c(6, 6, 7, 7, 8, 8)) + expect_equal( + as_adj_list(mutual_g, mode = "all")$A %>% as.numeric(), + c(6, 6, 7, 7, 8, 8) + ) inc_frac <- matrix(runif(15), 3, 5) colnames(inc_frac) <- letters[1:5] rownames(inc_frac) <- LETTERS[1:3] - frac_g <- graph_from_biadjacency_matrix(inc_frac, directed = TRUE, mode = "out", weighted = TRUE) + frac_g <- graph_from_biadjacency_matrix( + inc_frac, + directed = TRUE, + mode = "out", + weighted = TRUE + ) expect_equal(inc_frac, as_biadjacency_matrix(frac_g, attr = "weight")) }) @@ -93,7 +121,9 @@ test_that("graph_from_biadjacency_matrix() works -- sparse", { expect_snapshot((g <- graph_from_biadjacency_matrix(inc))) expect_false(is_weighted(g)) - expect_snapshot((weighted_g <- graph_from_biadjacency_matrix(inc, weighted = TRUE))) + expect_snapshot( + (weighted_g <- graph_from_biadjacency_matrix(inc, weighted = TRUE)) + ) expect_true(is_weighted(weighted_g)) }) @@ -132,7 +162,10 @@ test_that("graph_from_biadjacency_matrix() works - sparse, modes", { mutual_g <- graph_from_biadjacency_matrix(inc, directed = TRUE, mode = "all") expect_true(is_directed(mutual_g)) expect_length(E(mutual_g), 14) - expect_equal(as_adj_list(mutual_g, mode = "all")$A %>% as.numeric(), c(6, 6, 7, 7)) + expect_equal( + as_adj_list(mutual_g, mode = "all")$A %>% as.numeric(), + c(6, 6, 7, 7) + ) }) test_that("graph_from_biadjacency_matrix() works - sparse, modes, weighted", { @@ -144,20 +177,38 @@ test_that("graph_from_biadjacency_matrix() works - sparse, modes, weighted", { colnames(inc) <- letters[1:5] rownames(inc) <- LETTERS[1:3] - out_g <- graph_from_biadjacency_matrix(inc, directed = TRUE, mode = "out", weighted = TRUE) + out_g <- graph_from_biadjacency_matrix( + inc, + directed = TRUE, + mode = "out", + weighted = TRUE + ) expect_true(is_directed(out_g)) expect_length(E(out_g), 8) expect_equal(as_adj_list(out_g, mode = "out")$A %>% as.numeric(), c(6, 7, 8)) - in_g <- graph_from_biadjacency_matrix(inc, directed = TRUE, mode = "in", weighted = TRUE) + in_g <- graph_from_biadjacency_matrix( + inc, + directed = TRUE, + mode = "in", + weighted = TRUE + ) expect_true(is_directed(in_g)) expect_length(E(in_g), 8) expect_equal(as_adj_list(in_g, mode = "in")$A %>% as.numeric(), c(6, 7, 8)) - mutual_g <- graph_from_biadjacency_matrix(inc, directed = TRUE, mode = "all", weighted = TRUE) + mutual_g <- graph_from_biadjacency_matrix( + inc, + directed = TRUE, + mode = "all", + weighted = TRUE + ) expect_true(is_directed(mutual_g)) expect_length(E(mutual_g), 16) - expect_equal(as_adj_list(mutual_g, mode = "all")$A %>% as.numeric(), c(6, 6, 7, 7, 8, 8)) + expect_equal( + as_adj_list(mutual_g, mode = "all")$A %>% as.numeric(), + c(6, 6, 7, 7, 8, 8) + ) }) test_that("graph_from_biadjacency_matrix() errors well", { diff --git a/tests/testthat/test-indexing.R b/tests/testthat/test-indexing.R index e6b7c27617f..90fa16749a2 100644 --- a/tests/testthat/test-indexing.R +++ b/tests/testthat/test-indexing.R @@ -55,11 +55,14 @@ test_that("[ indexing works with logical vectors", { 0, 0, 0, 0, 0, 0, 0, 0 ), .Dim = c(2L, 20L), - .Dimnames = list(c("b", "c"), c( + .Dimnames = list( + c("b", "c"), + c( "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t" - )) + ) + ) ) expect_equal(g[degree(g, mode = "in") == 0, 2], 1) expect_equal(as.matrix(g[2:3, TRUE]), lres) @@ -204,7 +207,18 @@ test_that("[[ indexing works with filtering on both ends", { expect_equal( g[[1:10, 1:10]], - list(a = V(g)[2:3], b = V(g)[4:5], c = V(g)[6:7], d = V(g)[8:9], e = V(g)[10], f = V(g)[numeric()], g = V(g)[numeric()], h = V(g)[numeric()], i = V(g)[numeric()], j = V(g)[numeric()]), + list( + a = V(g)[2:3], + b = V(g)[4:5], + c = V(g)[6:7], + d = V(g)[8:9], + e = V(g)[10], + f = V(g)[numeric()], + g = V(g)[numeric()], + h = V(g)[numeric()], + i = V(g)[numeric()], + j = V(g)[numeric()] + ), ignore_attr = TRUE ) }) @@ -280,7 +294,18 @@ test_that("[[ queries edges with vertex names", { ## Filtering on both ends expect_equal( g[[1:10, 1:10, edges = TRUE]], - list(E(g)[1:2], E(g)[3:4], E(g)[5:6], E(g)[7:8], E(g)[9], E(g)[numeric()], E(g)[numeric()], E(g)[numeric()], E(g)[numeric()], E(g)[numeric()]), + list( + E(g)[1:2], + E(g)[3:4], + E(g)[5:6], + E(g)[7:8], + E(g)[9], + E(g)[numeric()], + E(g)[numeric()], + E(g)[numeric()], + E(g)[numeric()], + E(g)[numeric()] + ), ignore_attr = TRUE ) }) @@ -378,7 +403,10 @@ test_that("[ handles duplicated i/j well", { g <- graph_from_adjacency_matrix(A, "directed") expect_equal(as_unnamed_dense_matrix(g[c(1, 2, 2), ]), A[c(1, 2, 2), ]) expect_equal(as_unnamed_dense_matrix(g[, c(3, 3, 4, 4)]), A[, c(3, 3, 4, 4)]) - expect_equal(as_unnamed_dense_matrix(g[c(1, 2, 2), c(3, 3, 4, 4)]), A[c(1, 2, 2), c(3, 3, 4, 4)]) + expect_equal( + as_unnamed_dense_matrix(g[c(1, 2, 2), c(3, 3, 4, 4)]), + A[c(1, 2, 2), c(3, 3, 4, 4)] + ) }) test_that("[ can add and delete edges", { @@ -435,7 +463,11 @@ test_that("[ can add edges and ste weights via vertex names", { A["b", "c"] <- g["b", "c"] <- TRUE expect_equal(as_unnamed_dense_matrix(g[]), as_unnamed_dense_matrix(A)) - A[c("a", "f"), c("f", "a")] <- g[c("a", "f"), c("f", "a"), loops = TRUE] <- TRUE + A[c("a", "f"), c("f", "a")] <- g[ + c("a", "f"), + c("f", "a"), + loops = TRUE + ] <- TRUE expect_equal(as_unnamed_dense_matrix(g[]), as_unnamed_dense_matrix(A)) A[A == 1] <- NA @@ -458,11 +490,18 @@ test_that("[ and the from-to notation", { ) expect_equal(as_unnamed_dense_matrix(g[]), as_unnamed_dense_matrix(A)) - g[from = c("a", "c", "h", "a"), to = c("a", "a", "a", "e"), attr = "weight"] <- 3 + g[ + from = c("a", "c", "h", "a"), + to = c("a", "a", "a", "e"), + attr = "weight" + ] <- 3 A[A != 0] <- NA A["a", "a"] <- A["c", "a"] <- A["h", "a"] <- A["a", "e"] <- 3 expect_equal( - g[from = c("a", "c", "h", "a", "c", "c"), to = c("a", "a", "a", "e", "f", "b")], + g[ + from = c("a", "c", "h", "a", "c", "c"), + to = c("a", "a", "a", "e", "f", "b") + ], c(3, 3, 3, 3, 0, NA) ) expect_equal(as_unnamed_dense_matrix(g[]), as_unnamed_dense_matrix(A)) @@ -476,14 +515,21 @@ test_that("[ and from-to with multiple values", { g[from = c("a", "c", "h"), to = c("a", "b", "c")] <- 1 A["a", "a"] <- A["c", "b"] <- A["h", "c"] <- 1 - g[from = c("a", "c", "h", "a"), to = c("a", "a", "a", "e"), attr = "weight"] <- 5:8 + g[ + from = c("a", "c", "h", "a"), + to = c("a", "a", "a", "e"), + attr = "weight" + ] <- 5:8 A[A != 0] <- NA A["a", "a"] <- 5 A["c", "a"] <- 6 A["h", "a"] <- 7 A["a", "e"] <- 8 expect_equal( - g[from = c("a", "c", "h", "a", "c", "c"), to = c("a", "a", "a", "e", "f", "b")], + g[ + from = c("a", "c", "h", "a", "c", "c"), + to = c("a", "a", "a", "e", "f", "b") + ], c(5:8, 0, NA) ) expect_equal(as_unnamed_dense_matrix(g[]), as_unnamed_dense_matrix(A)) @@ -626,13 +672,19 @@ test_that("Weighted indexing does not remove edges", { expect_equal(E(g)$weight, c(0, rep(NA, 9))) el <- as_edgelist(g) - g[from = el[, 1], to = el[, 2], attr = "sim"] <- rep(0:1, length.out = ecount(g)) + g[from = el[, 1], to = el[, 2], attr = "sim"] <- rep( + 0:1, + length.out = ecount(g) + ) expect_in("sim", edge_attr_names(g)) expect_equal(E(g)$sim, rep(0:1, 5)) V(g)$name <- letters[seq_len(vcount(g))] el <- as_edgelist(g) - g[from = el[, 1], to = el[, 2], attr = "sim"] <- rep(1:0, length.out = ecount(g)) + g[from = el[, 1], to = el[, 2], attr = "sim"] <- rep( + 1:0, + length.out = ecount(g) + ) expect_equal(E(g)$sim, rep(1:0, 5)) }) @@ -669,7 +721,11 @@ test_that("indexing an es twice works", { x <- E(g)["BOS" %->% "JFK"][carrier == "foo"] - expect_equal(ignore_attr = TRUE, x, E(g)[carrier == "foo" & .from("BOS") & .to("JFK")]) + expect_equal( + ignore_attr = TRUE, + x, + E(g)[carrier == "foo" & .from("BOS") & .to("JFK")] + ) }) diff --git a/tests/testthat/test-iterators.R b/tests/testthat/test-iterators.R index abb487d41cc..50790e1623a 100644 --- a/tests/testthat/test-iterators.R +++ b/tests/testthat/test-iterators.R @@ -18,9 +18,9 @@ test_that("iterators work", { test_that("subsetting returns the whole if no argument", { g <- make_ring(10) - expect_length(V(g)[, ], 10) + expect_length(V(g)[,], 10) expect_length(V(g)[, na_ok = FALSE], 10) - expect_length(E(g)[, ], 10) + expect_length(E(g)[,], 10) }) test_that("complex attributes work", { diff --git a/tests/testthat/test-layout.R b/tests/testthat/test-layout.R index 862f12a5514..9aafc1b5dad 100644 --- a/tests/testthat/test-layout.R +++ b/tests/testthat/test-layout.R @@ -179,7 +179,9 @@ test_that("Kamada-Kawai layout generator works", { return(TRUE) } - dists <- apply(layout[-nrow(layout), ] - layout[-1, ], 1, function(x) sqrt(sum(x**2))) + dists <- apply(layout[-nrow(layout), ] - layout[-1, ], 1, function(x) { + sqrt(sum(x**2)) + }) norm_dists <- (dists - mean(dists)) / mean(dists) all(abs(norm_dists) < eps) } diff --git a/tests/testthat/test-make.R b/tests/testthat/test-make.R index 40ab46057ab..153c895174f 100644 --- a/tests/testthat/test-make.R +++ b/tests/testthat/test-make.R @@ -62,7 +62,7 @@ test_that("error messages are proper", { test_that("we pass arguments unevaluated", { rlang::local_options(lifecycle_verbosity = "quiet") g0 <- graph_from_literal(A -+ B:C) - g1 <- graph_(from_literal(A -+ B:C)) + g1 <- graph_(from_literal(A - +B:C)) expect_identical_graphs(g0, g1) }) @@ -147,7 +147,8 @@ test_that("make_full_graph works", { test_that("make_lattice works", { lattice_make <- make_lattice(dim = 2, length = 3, periodic = FALSE) - lattice_elist <- make_empty_graph(n = 9) + edges(c( + lattice_elist <- make_empty_graph(n = 9) + + edges(c( 1, 2, 1, 4, 2, 3, @@ -164,7 +165,8 @@ test_that("make_lattice works", { expect_equal(as_edgelist(lattice_make), as_edgelist(lattice_elist)) lattice_make_periodic <- make_lattice(dim = 2, length = 3, periodic = TRUE) - lattice_elist_periodic <- make_empty_graph(n = 9) + edges(c( + lattice_elist_periodic <- make_empty_graph(n = 9) + + edges(c( 1, 2, 1, 4, 2, 3, @@ -184,13 +186,21 @@ test_that("make_lattice works", { 7, 9, 3, 9 )) - expect_equal(as_edgelist(lattice_make_periodic), as_edgelist(lattice_elist_periodic)) + expect_equal( + as_edgelist(lattice_make_periodic), + as_edgelist(lattice_elist_periodic) + ) }) test_that("make_lattice prints a warning for fractional length)", { - expect_warning(make_lattice(dim = 2, length = sqrt(2000)), "`length` was rounded") + expect_warning( + make_lattice(dim = 2, length = sqrt(2000)), + "`length` was rounded" + ) - suppressWarnings(lattice_rounded <- make_lattice(dim = 2, length = sqrt(2000))) + suppressWarnings( + lattice_rounded <- make_lattice(dim = 2, length = sqrt(2000)) + ) lattice_integer <- make_lattice(dim = 2, length = 45) expect_identical_graphs(lattice_rounded, lattice_integer) }) @@ -221,19 +231,29 @@ test_that("make_graph works for numeric edges and isolates", { test_that("make_graph handles names", { graph_make_names <- make_graph(letters[1:10]) - graph_elist_names <- make_empty_graph() + vertices(letters[1:10]) + edges(letters[1:10]) + graph_elist_names <- make_empty_graph() + + vertices(letters[1:10]) + + edges(letters[1:10]) expect_identical_graphs(graph_make_names, graph_elist_names) }) test_that("make_graph handles names and isolates", { graph_make_iso <- make_graph(letters[1:10], isolates = letters[11:20]) - graph_elist_iso <- make_empty_graph() + vertices(letters[1:20]) + edges(letters[1:10]) + graph_elist_iso <- make_empty_graph() + + vertices(letters[1:20]) + + edges(letters[1:10]) expect_identical_graphs(graph_make_iso, graph_elist_iso) }) test_that("make_graph gives warning for ignored arguments", { - expect_warning(make_graph(letters[1:10], n = 10), "ignored for edge list with vertex names") - expect_warning(make_graph(1:10, isolates = 11:12), "ignored for numeric edge list") + expect_warning( + make_graph(letters[1:10], n = 10), + "ignored for edge list with vertex names" + ) + expect_warning( + make_graph(1:10, isolates = 11:12), + "ignored for numeric edge list" + ) }) test_that("compatibility when arguments are not named", { @@ -254,14 +274,20 @@ test_that("make_empty_graph gives an error for invalid arguments", { test_that("make_graph_atlas works", { atlas_124 <- graph_from_atlas(124) - expect_isomorphic(atlas_124, make_graph(c(1, 2, 2, 3, 3, 4, 4, 5, 1, 5, 1, 3, 2, 6), + expect_isomorphic( + atlas_124, + make_graph(c(1, 2, 2, 3, 3, 4, 4, 5, 1, 5, 1, 3, 2, 6), directed = FALSE - )) + ) + ) atlas_234 <- graph_from_atlas(234) - expect_isomorphic(atlas_234, make_graph(c(1, 6, 2, 6, 3, 6, 4, 6, 5, 6), + expect_isomorphic( + atlas_234, + make_graph(c(1, 6, 2, 6, 3, 6, 4, 6, 5, 6), n = 7, directed = FALSE - )) + ) + ) }) test_that("make_chordal_ring works", { @@ -283,10 +309,13 @@ test_that("make_de_bruijn_graph works", { de_bruijn22 <- make_de_bruijn_graph(2, 2) de_bruijn21_line <- make_line_graph(de_bruijn21) - expect_isomorphic(de_bruijn21_line, make_graph(c( + expect_isomorphic( + de_bruijn21_line, + make_graph(c( 1, 1, 3, 1, 1, 2, 3, 2, 2, 3, 4, 3, 2, 4, 4, 4 - ))) + )) + ) expect_isomorphic(de_bruijn22, de_bruijn21_line) }) @@ -302,7 +331,10 @@ test_that("make_bipartite_graph works", { numeric() } })) - bip_from_make <- make_bipartite_graph(seq_len(nrow(inc_mat_rand) + ncol(inc_mat_rand)) > nrow(inc_mat_rand), edges) + bip_from_make <- make_bipartite_graph( + seq_len(nrow(inc_mat_rand) + ncol(inc_mat_rand)) > nrow(inc_mat_rand), + edges + ) inc_mat_bip <- as_biadjacency_matrix(bip_from_make) expect_equal(inc_mat_bip, inc_mat_rand, ignore_attr = TRUE) @@ -314,10 +346,21 @@ test_that("make_bipartite_graph works with vertex names", { edges <- c("A", "B", "C", "D", "E", "F", "A", "D", "D", "E", "B", "C", "C", "F") bip_grap <- make_bipartite_graph(types, edges) - expect_equal(V(bip_grap)$name, c("A", "B", "C", "D", "E", "F"), ignore_attr = TRUE) - expect_equal(V(bip_grap)$type, c(FALSE, TRUE, FALSE, TRUE, FALSE, TRUE), ignore_attr = TRUE) + expect_equal( + V(bip_grap)$name, + c("A", "B", "C", "D", "E", "F"), + ignore_attr = TRUE + ) + expect_equal( + V(bip_grap)$type, + c(FALSE, TRUE, FALSE, TRUE, FALSE, TRUE), + ignore_attr = TRUE + ) - expect_error(make_bipartite_graph(types, c(edges, "Q")), "edge vector contains a vertex name that is not found") + expect_error( + make_bipartite_graph(types, c(edges, "Q")), + "edge vector contains a vertex name that is not found" + ) }) test_that("make_full_bipartite_graph works", { @@ -337,8 +380,10 @@ test_that("make_kautz_graph works", { el <- as_edgelist(kautz) el <- el[order(el[, 1], el[, 2]), ] - expect_equal(el, structure( - c( + expect_equal( + el, + structure( + c( 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, 7, 7, 8, 8, 9, 9, 10, 10, 11, 11, 12, 12, 13, 13, 14, 14, 15, 15, 16, 16, 17, @@ -349,8 +394,9 @@ test_that("make_kautz_graph works", { 20, 21, 22, 23, 24, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16 ), - .Dim = c(48L, 2L) - )) + .Dim = c(48L, 2L) + ) + ) }) test_that("make_graph for notable graphs is case insensitive", { diff --git a/tests/testthat/test-motifs.R b/tests/testthat/test-motifs.R index bdbcd1e39bd..596f2c50add 100644 --- a/tests/testthat/test-motifs.R +++ b/tests/testthat/test-motifs.R @@ -120,9 +120,15 @@ test_that("motifs works", { ) ) - expect_equal(m4 / m, c(NA, NA, 0.439770385262173, NA, 0.441040560282398, 0.224489795918367, 0.438752023472278, 0.534246575342466, NaN, 0.430769230769231, NaN, 0.391304347826087, NaN, NaN, NaN, NaN)) + expect_equal( + m4 / m, + c(NA, NA, 0.439770385262173, NA, 0.441040560282398, 0.224489795918367, 0.438752023472278, 0.534246575342466, NaN, 0.430769230769231, NaN, 0.391304347826087, NaN, NaN, NaN, NaN) + ) - expect_equal(m5 / m, c(NA, NA, 0.444436015122204, NA, 0.445736750036052, 0.489795918367347, 0.445353601780656, 0.575342465753425, NaN, 0.415384615384615, NaN, 0.347826086956522, NaN, NaN, NaN, NaN)) + expect_equal( + m5 / m, + c(NA, NA, 0.444436015122204, NA, 0.445736750036052, 0.489795918367347, 0.445353601780656, 0.575342465753425, NaN, 0.415384615384615, NaN, 0.347826086956522, NaN, NaN, NaN, NaN) + ) }) test_that("sample_motifs works", { @@ -135,10 +141,14 @@ test_that("sample_motifs works", { expect_true(0 <= motif_count && motif_count <= n * (n - 1) * (n - 2) / 6) motif_count_letters <- sample_motifs(g, sample = c("C", "D", "E", "F")) - expect_true(0 <= motif_count_letters && motif_count_letters <= n * (n - 1) * (n - 2) / 6) + expect_true( + 0 <= motif_count_letters && motif_count_letters <= n * (n - 1) * (n - 2) / 6 + ) motif_count_all <- sample_motifs(g, sample = V(g)) - expect_true(0 <= motif_count_all && motif_count_all <= n * (n - 1) * (n - 2) / 6) + expect_true( + 0 <= motif_count_all && motif_count_all <= n * (n - 1) * (n - 2) / 6 + ) }) test_that("dyad_census works", { diff --git a/tests/testthat/test-operators.R b/tests/testthat/test-operators.R index 5ced6f9ceae..15cb124f9ce 100644 --- a/tests/testthat/test-operators.R +++ b/tests/testthat/test-operators.R @@ -102,17 +102,25 @@ test_that("compose works for named graphs", { g <- compose(g1, g2) df <- as_data_frame(g, what = "both") - df.v <- read.table(stringsAsFactors = FALSE, textConnection(" + df.v <- read.table( + stringsAsFactors = FALSE, + textConnection( + " bar1 foo_1 foo_2 bar2 name A 1 a a 1 A B 2 b b 2 B D 3 c NA NA D E 4 d c 3 E C 5 e NA NA C -")) +" + ) + ) expect_equal(df$vertices, df.v) - df.e <- read.table(stringsAsFactors = FALSE, textConnection(" + df.e <- read.table( + stringsAsFactors = FALSE, + textConnection( + " from to bar1 foo_1 foo_2 bar2 1 A B 3 c c 3 2 A A 3 c b 2 @@ -130,7 +138,9 @@ C 5 e NA NA C 14 B E 3 c a 1 15 E C 5 e c 3 16 A C 5 e a 1 -")) +" + ) + ) rownames(df$edges) <- rownames(df$edges) expect_equal(df$edges, df.e) }) @@ -192,7 +202,8 @@ test_that("vertices() works", { expect_identical(V(g_mix_named_unnamed)$name[-1], c("a", "b")) expect_equal(V(g_mix_named_unnamed)$foo, c(NA, 5, 5)) - g_mix_bigger_attribute <- make_empty_graph(1) + vertices("a", "b", "c", foo = 5:7, bar = 8) + g_mix_bigger_attribute <- make_empty_graph(1) + + vertices("a", "b", "c", foo = 5:7, bar = 8) expect_s3_class(V(g_mix_bigger_attribute), "igraph.vs") expect_identical(V(g_mix_bigger_attribute)$name, c(NA, "a", "b", "c")) expect_equal(V(g_mix_bigger_attribute)$foo, c(NA, 5, 6, 7)) @@ -238,7 +249,10 @@ test_that("infix operators work", { g <- make_ring(10) V(g)$name <- letters[1:10] g <- g - path("a", "b") - expect_isomorphic(g, graph_from_literal(a, b - c - d - e - f - g - h - i - j - a)) + expect_isomorphic( + g, + graph_from_literal(a, b - c - d - e - f - g - h - i - j - a) + ) g <- g + path("a", "b") expect_isomorphic(g, make_ring(10)) @@ -303,7 +317,10 @@ test_that("disjoint union gives warning for non-unique vertex names", { g2 <- make_ring(5) V(g2)$name <- letters[5:9] - expect_warning(disjoint_union(g1, g2), "Duplicate vertex names in disjoint union") + expect_warning( + disjoint_union(g1, g2), + "Duplicate vertex names in disjoint union" + ) }) @@ -337,8 +354,11 @@ test_that("union of unnamed graphs works", { df1 <- as_data_frame(g) df1 <- df1[order(df1$from, df1$to), c(1, 2, 3, 5, 4, 6)] - df2 <- merge(as_data_frame(g1), as_data_frame(g2), - by = c("from", "to"), all = TRUE + df2 <- merge( + as_data_frame(g1), + as_data_frame(g2), + by = c("from", "to"), + all = TRUE ) rownames(df1) <- seq_len(nrow(df1)) colnames(df2) <- c("from", "to", "weight_1", "b1", "weight_2", "b2") @@ -378,7 +398,10 @@ test_that("union of named graphs works", { df1 <- as_data_frame(g, what = "both") - g.v <- read.table(stringsAsFactors = FALSE, textConnection(" + g.v <- read.table( + stringsAsFactors = FALSE, + textConnection( + " a1 a2 name a 1 11 a b 2 12 b @@ -393,10 +416,15 @@ j 10 20 j k NA 21 k l NA 22 l m NA 23 m -")) +" + ) + ) expect_equal(df1$vertices, g.v) - g.e <- read.table(stringsAsFactors = FALSE, textConnection(" + g.e <- read.table( + stringsAsFactors = FALSE, + textConnection( + " from to weight_1 weight_2 b1 b2 1 l m NA 2 NA v 2 k l NA 3 NA u @@ -412,7 +440,9 @@ m NA 23 m 12 a m NA 1 NA w 13 a j 10 NA j NA 14 a b 1 13 a k -")) +" + ) + ) rownames(df1$edges) <- rownames(df1$edges) expect_equal(df1$edges, g.e) }) @@ -450,7 +480,10 @@ test_that("intersection of named graphs works", { df1 <- as_data_frame(g, what = "both") - g.e <- read.table(stringsAsFactors = FALSE, textConnection(" + g.e <- read.table( + stringsAsFactors = FALSE, + textConnection( + " from to weight_1 weight_2 b1 b2 1 i j 9 5 i s 2 h i 8 6 h r @@ -461,11 +494,16 @@ test_that("intersection of named graphs works", { 7 c d 3 11 c m 8 b c 2 12 b l 9 a b 1 13 a k -")) +" + ) + ) rownames(df1$edges) <- rownames(df1$edges) expect_equal(df1$edges, g.e) - g.v <- read.table(stringsAsFactors = FALSE, textConnection(" + g.v <- read.table( + stringsAsFactors = FALSE, + textConnection( + " a1 a2 name a 1 11 a b 2 12 b @@ -477,7 +515,9 @@ g 7 17 g h 8 18 h i 9 19 i j 10 20 j -")) +" + ) + ) expect_equal(df1$vertices, g.v) gg <- intersection(g1, g2, keep.all.vertices = TRUE) @@ -487,7 +527,10 @@ j 10 20 j rownames(df2$edges) <- rownames(df2$edges) expect_equal(df2$edges, g.e) - gg.v <- read.table(stringsAsFactors = FALSE, textConnection(" + gg.v <- read.table( + stringsAsFactors = FALSE, + textConnection( + " a1 a2 name a 1 11 a b 2 12 b @@ -502,7 +545,9 @@ j 10 20 j k NA 21 k l NA 22 l m NA 23 m -")) +" + ) + ) expect_equal(df2$vertices, gg.v) }) @@ -520,7 +565,8 @@ test_that("difference of named graphs works", { t1.e <- read.table( stringsAsFactors = FALSE, - textConnection(" + textConnection( + " from to 1 a j 2 b k @@ -538,12 +584,20 @@ test_that("difference of named graphs works", { 14 g h 15 h i 16 i j -") +" + ) ) rownames(df1$edges) <- rownames(df1$edges) expect_equal(df1$edges, t1.e) - expect_equal(df1$vertices, data.frame(row.names = letters[1:11], name = letters[1:11], stringsAsFactors = FALSE)) + expect_equal( + df1$vertices, + data.frame( + row.names = letters[1:11], + name = letters[1:11], + stringsAsFactors = FALSE + ) + ) gg <- sg - g @@ -692,7 +746,6 @@ test_that("c on detached vs, names", { }) - test_that("union on attached vs", { g <- make_ring(10) diff --git a/tests/testthat/test-other.R b/tests/testthat/test-other.R index d872400ea7b..6ccd5cf2c45 100644 --- a/tests/testthat/test-other.R +++ b/tests/testthat/test-other.R @@ -1,5 +1,8 @@ test_that("convex_hull works", { - xy <- cbind(c(0, 1, 2, 3, 4, 0, 1, 2, 3, 1, 2), c(0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2)) + xy <- cbind( + c(0, 1, 2, 3, 4, 0, 1, 2, 3, 1, 2), + c(0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2) + ) vp <- convex_hull(xy) expect_equal(vp$resverts, c(1, 6, 10, 11, 5)) expect_equal(vp$rescoords, xy[vp$resverts, ]) @@ -39,7 +42,11 @@ test_that("R help contains guarantee on number of RNG bits", { get_help_file <- get(".getHelpFile", envir = asNamespace("utils")) text <- capture.output(tools::Rd2txt(get_help_file(help("Random")))) - expect_true(any(grepl("all give at least 30 varying bits", text, fixed = TRUE))) + expect_true(any(grepl( + "all give at least 30 varying bits", + text, + fixed = TRUE + ))) }) test_that("serialization works", { @@ -48,7 +55,10 @@ test_that("serialization works", { g <- make_ring(3, directed = TRUE) gs <- unserialize(serialize(g, NULL)) - expect_identical(unclass(g)[-igraph_t_idx_env], unclass(gs)[-igraph_t_idx_env]) + expect_identical( + unclass(g)[-igraph_t_idx_env], + unclass(gs)[-igraph_t_idx_env] + ) expect_snapshot({ g diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index 82cc2e908d1..d444050058f 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -119,7 +119,8 @@ test_that("Edges stop at outside of rectangle node", { c(-2.01, -1.16, -1.24, -2.74, -0.13), c(1.27, 2.1, 3.14, 0.56, 2.01) ) - plot(g, + plot( + g, vertex.size = 30, vertex.size2 = 30, vertex.color = rgb(0.1, 0.7, 0.8, 0.1), diff --git a/tests/testthat/test-print.R b/tests/testthat/test-print.R index 1738a73ca49..bc1655df5e9 100644 --- a/tests/testthat/test-print.R +++ b/tests/testthat/test-print.R @@ -47,12 +47,45 @@ test_that("print.igraph() works", { expect_output(print(g6), " ") kite <- make_empty_graph(directed = FALSE) + LETTERS[1:10] - kite <- kite + edges( - "A", "B", "A", "C", "A", "D", "A", "F", - "B", "D", "B", "E", "B", "G", "C", "D", "C", "F", - "D", "E", "D", "F", "D", "G", "E", "G", - "F", "G", "F", "H", "G", "H", "H", "I", "I", "J" - ) + kite <- kite + + edges( + "A", + "B", + "A", + "C", + "A", + "D", + "A", + "F", + "B", + "D", + "B", + "E", + "B", + "G", + "C", + "D", + "C", + "F", + "D", + "E", + "D", + "F", + "D", + "G", + "E", + "G", + "F", + "G", + "F", + "H", + "G", + "H", + "H", + "I", + "I", + "J" + ) expect_output(print(kite), "A -- ") }) diff --git a/tests/testthat/test-random_walk.R b/tests/testthat/test-random_walk.R index e5d96b64449..015babffceb 100644 --- a/tests/testthat/test-random_walk.R +++ b/tests/testthat/test-random_walk.R @@ -53,10 +53,18 @@ test_that("directed random_edge_walk works", { g <- make_ring(10, directed = TRUE) w <- random_edge_walk(g, start = 1, steps = 5) - expect_equal(ignore_attr = TRUE, w, structure(c(1L, 2L, 3L, 4L, 5L), class = "igraph.es")) + expect_equal( + ignore_attr = TRUE, + w, + structure(c(1L, 2L, 3L, 4L, 5L), class = "igraph.es") + ) w <- random_edge_walk(g, start = 1, steps = 5, mode = "in") - expect_equal(ignore_attr = TRUE, w, structure(c(10L, 9L, 8L, 7L, 6L), class = "igraph.es")) + expect_equal( + ignore_attr = TRUE, + w, + structure(c(10L, 9L, 8L, 7L, 6L), class = "igraph.es") + ) w <- random_edge_walk(g, start = 1, steps = 10, mode = "all") expect_length(w, 10) diff --git a/tests/testthat/test-sgm.R b/tests/testthat/test-sgm.R index 4664f003ee7..4b9b721d65e 100644 --- a/tests/testthat/test-sgm.R +++ b/tests/testthat/test-sgm.R @@ -8,8 +8,11 @@ test_that("SGM works", { g1 <- sample_gnp(vc, .5) randperm <- c(1:nos, nos + sample(vc - nos)) g2 <- sample_correlated_gnp(g1, corr = .7, p = g1$p, permutation = randperm) - P <- match_vertices(g1[], g2[], - m = nos, start = matrix(1 / (vc - nos), vc - nos, vc - nos), + P <- match_vertices( + g1[], + g2[], + m = nos, + start = matrix(1 / (vc - nos), vc - nos, vc - nos), iteration = 20 ) @@ -30,8 +33,11 @@ test_that("SGM works", { perm <- c(1:nos, sample(vc - nos) + nos) g2 <- sample_correlated_gnp(g1, corr = 1, p = g1$p, permutation = perm) - P <- match_vertices(g1[], g2[], - m = nos, start = matrix(1 / (vc - nos), vc - nos, vc - nos), + P <- match_vertices( + g1[], + g2[], + m = nos, + start = matrix(1 / (vc - nos), vc - nos, vc - nos), iteration = 20 ) diff --git a/tests/testthat/test-sparsedf.R b/tests/testthat/test-sparsedf.R index 3434f5dcbfa..d9a93a94bdf 100644 --- a/tests/testthat/test-sparsedf.R +++ b/tests/testthat/test-sparsedf.R @@ -54,6 +54,9 @@ test_that("sdf works", { sdf2[5:6, "color"] <- "white" expect_equal( as.data.frame(sdf2), - data.frame(id = 1:10, color = c(rep("black", 4), rep("white", 2), rep("black", 4))) + data.frame( + id = 1:10, + color = c(rep("black", 4), rep("white", 2), rep("black", 4)) + ) ) }) diff --git a/tests/testthat/test-topology.R b/tests/testthat/test-topology.R index 527a8de74a9..12dec658e91 100644 --- a/tests/testthat/test-topology.R +++ b/tests/testthat/test-topology.R @@ -32,7 +32,10 @@ test_that("automorphism_group works", { test_that("automorphism_group works with colored graphs", { full <- make_full_graph(4) - aut_full <- lapply(automorphism_group(full, colors = c(1, 2, 1, 2)), as.vector) + aut_full <- lapply( + automorphism_group(full, colors = c(1, 2, 1, 2)), + as.vector + ) aut_full <- aut_full[order(sapply(aut_full, "[[", 1))] expect_equal(aut_full, list(c(1, 4, 3, 2), c(3, 2, 1, 4))) @@ -47,9 +50,11 @@ test_that("isomorphisms() works", { vertices("D1", "D2", type = c("type1", "type1")) + edges("D1", "D2", type = c("type2")) motif_iso <- isomorphisms( - motif, motif, + motif, + motif, method = "vf2", - vertex.color1 = 2:1, vertex.color2 = 1:2 + vertex.color1 = 2:1, + vertex.color2 = 1:2 ) expect_length(motif_iso, 1) expect_equal(as.numeric(motif_iso[[1]]), 2:1) @@ -60,8 +65,11 @@ test_that("subgraph_isomorphisms works", { vertices("D1", "D2", type = c("type1", "type1")) + edges("D1", "D2", type = c("type2")) out <- subgraph_isomorphisms( - target = motif, pattern = motif, method = "vf2", - vertex.color1 = 2:1, vertex.color2 = 1:2 + target = motif, + pattern = motif, + method = "vf2", + vertex.color1 = 2:1, + vertex.color2 = 1:2 ) expect_length(out, 1) expect_equal(as.numeric(out[[1]]), 2:1) @@ -126,12 +134,22 @@ test_that("graph.subisomorphic, method = 'lad' works", { 8 - 4:9, 9 - 6:4:8 ) domains <- list( - `1` = c(1, 3, 9), `2` = c(5, 6, 7, 8), `3` = c(2, 4, 6, 7, 8, 9), - `4` = c(1, 3, 9), `5` = c(2, 4, 8, 9) + `1` = c(1, 3, 9), + `2` = c(5, 6, 7, 8), + `3` = c(2, 4, 6, 7, 8, 9), + `4` = c(1, 3, 9), + `5` = c(2, 4, 8, 9) ) sub_iso1 <- subgraph_isomorphic(pattern, target, method = "lad") - sub_iso2 <- subgraph_isomorphic(pattern, target, induced = TRUE, method = "lad") - sub_iso3 <- subgraph_isomorphic(pattern, target, + sub_iso2 <- subgraph_isomorphic( + pattern, + target, + induced = TRUE, + method = "lad" + ) + sub_iso3 <- subgraph_isomorphic( + pattern, + target, domains = domains, method = "lad" ) @@ -150,10 +168,7 @@ test_that("LAD stress test", { target <- sample_gnp(20, .5) pn <- sample(4:18, 1) pattern <- induced_subgraph(target, sample(vcount(target), pn)) - iso <- subgraph_isomorphic(pattern, target, - induced = TRUE, - method = "lad" - ) + iso <- subgraph_isomorphic(pattern, target, induced = TRUE, method = "lad") expect_true(iso) } @@ -163,10 +178,7 @@ test_that("LAD stress test", { target <- sample_gnp(20, 1 / 20) pn <- sample(5:18, 1) pattern <- sample_gnp(pn, .6) - iso <- subgraph_isomorphic(pattern, target, - induced = TRUE, - method = "lad" - ) + iso <- subgraph_isomorphic(pattern, target, induced = TRUE, method = "lad") expect_false(iso) } }) @@ -228,7 +240,8 @@ test_that("count_isomorphisms", { test_that("count_isomorphisms_with_colors", { expect_equal( - count_isomorphisms(make_ring(3), + count_isomorphisms( + make_ring(3), make_ring(3), edge.color1 = c(2, 2, 2), edge.color2 = c(2, 2, 2), @@ -240,7 +253,8 @@ test_that("count_isomorphisms_with_colors", { ) expect_equal( - count_isomorphisms(make_ring(3), + count_isomorphisms( + make_ring(3), make_ring(3), edge.color1 = c(2, 2, 2), edge.color2 = c(2, 2, 2), @@ -252,7 +266,8 @@ test_that("count_isomorphisms_with_colors", { ) expect_equal( - count_isomorphisms(make_ring(3), + count_isomorphisms( + make_ring(3), make_ring(3), edge.color1 = c(2, 2, 3), edge.color2 = c(3, 2, 2), @@ -312,7 +327,11 @@ test_that("subgraph_isomorphisms, lad", { V(g1)[4, 1, 2] ) - expect_equal(ignore_attr = TRUE, subgraph_isomorphisms(g2, g1, method = "lad"), res) + expect_equal( + ignore_attr = TRUE, + subgraph_isomorphisms(g2, g1, method = "lad"), + res + ) g3 <- graph_from_literal(X - Y - Z - X) expect_equal(subgraph_isomorphisms(g3, g1, method = "lad"), list()) @@ -333,7 +352,11 @@ test_that("subgraph_isomorphisms, vf2", { V(g1)[4, 3, 2] ) - expect_equal(ignore_attr = TRUE, subgraph_isomorphisms(g2, g1, method = "vf2"), res) + expect_equal( + ignore_attr = TRUE, + subgraph_isomorphisms(g2, g1, method = "vf2"), + res + ) g3 <- graph_from_literal(X - Y - Z - X) expect_equal(subgraph_isomorphisms(g3, g1, method = "vf2"), list()) diff --git a/tests/testthat/test-trees.R b/tests/testthat/test-trees.R index b02ee6a4d72..14b6ef56394 100644 --- a/tests/testthat/test-trees.R +++ b/tests/testthat/test-trees.R @@ -16,17 +16,29 @@ test_that("is_tree works for undirected trees", { # g <- permute(make_tree(7, 2), c(5, 2, 3, 4, 1, 6, 7)) g <- make_tree(7, 2) expect_true(is_tree(g)) - expect_equal(ignore_attr = TRUE, is_tree(g, details = TRUE), list(res = TRUE, root = V(g)[1])) + expect_equal( + ignore_attr = TRUE, + is_tree(g, details = TRUE), + list(res = TRUE, root = V(g)[1]) + ) }) test_that("is_tree works for directed in-trees", { g <- permute(make_tree(7, 2, mode = "in"), c(5, 2, 3, 4, 1, 6, 7)) expect_true(is_tree(g, mode = "in")) - expect_equal(ignore_attr = TRUE, is_tree(g, mode = "in", details = TRUE), list(res = TRUE, root = V(g)[5])) + expect_equal( + ignore_attr = TRUE, + is_tree(g, mode = "in", details = TRUE), + list(res = TRUE, root = V(g)[5]) + ) expect_true(is_tree(g, mode = "all")) - expect_equal(ignore_attr = TRUE, is_tree(g, mode = "all", details = TRUE), list(res = TRUE, root = V(g)[1])) + expect_equal( + ignore_attr = TRUE, + is_tree(g, mode = "all", details = TRUE), + list(res = TRUE, root = V(g)[1]) + ) expect_false(is_tree(g, mode = "out")) expect_false(is_tree(g, mode = "out", details = TRUE)$res) @@ -36,10 +48,18 @@ test_that("is_tree works for directed out-trees", { g <- permute(make_tree(7, 2, mode = "out"), c(3, 2, 1, 4, 5, 6, 7)) expect_true(is_tree(g, mode = "out")) - expect_equal(ignore_attr = TRUE, is_tree(g, mode = "out", details = TRUE), list(res = TRUE, root = V(g)[3])) + expect_equal( + ignore_attr = TRUE, + is_tree(g, mode = "out", details = TRUE), + list(res = TRUE, root = V(g)[3]) + ) expect_true(is_tree(g, mode = "all")) - expect_equal(ignore_attr = TRUE, is_tree(g, mode = "all", details = TRUE), list(res = TRUE, root = V(g)[1])) + expect_equal( + ignore_attr = TRUE, + is_tree(g, mode = "all", details = TRUE), + list(res = TRUE, root = V(g)[1]) + ) expect_false(is_tree(g, mode = "in")) expect_false(is_tree(g, mode = "in", details = TRUE)$res) diff --git a/tests/testthat/test-versions.R b/tests/testthat/test-versions.R index b7824c95c7f..65ee19e0b0d 100644 --- a/tests/testthat/test-versions.R +++ b/tests/testthat/test-versions.R @@ -130,7 +130,7 @@ test_that("igraph_version returns a version string", { expect_match(igraph_version("R"), regex) expect_match(igraph_version(), regex) - + c_regex <- paste0( "\\b", # word boundary "(?:0|[1-9][0-9]*)\\.", # major diff --git a/tests/testthat/test-weakref.R b/tests/testthat/test-weakref.R index 7b76b6fe138..615130fdcab 100644 --- a/tests/testthat/test-weakref.R +++ b/tests/testthat/test-weakref.R @@ -70,7 +70,8 @@ test_that("embed myself, and weak ref as attribute", { fin <- function(env) hello <<- "world" z <- "footoo" attr(z, "env") <- make_weak_ref( - key = g[[1]], value = value, + key = g[[1]], + value = value, finalizer = fin ) diff --git a/tools/add-ctags.R b/tools/add-ctags.R index 9a73382fbbd..7131d0645a6 100644 --- a/tools/add-ctags.R +++ b/tools/add-ctags.R @@ -20,7 +20,10 @@ treat_impl <- function(impl) { } function_body <- xml2::xml_children(impl)[[3]] - dotcall_calls <- xml2::xml_find_all(function_body, ".//SYMBOL_FUNCTION_CALL[contains(text(), '.Call')]") + dotcall_calls <- xml2::xml_find_all( + function_body, + ".//SYMBOL_FUNCTION_CALL[contains(text(), '.Call')]" + ) treat_dotcall_call <- function(dotcall_call) { dotcall_call |> @@ -39,12 +42,22 @@ treat_impl <- function(impl) { impl_df <- purrr::map_df(impl_kiddos, treat_impl) |> tidyr::unnest(rrrigraph) -impl_df <- impl_df[impl_df$rrrigraph != "R_igraph_finalizer",] +impl_df <- impl_df[impl_df$rrrigraph != "R_igraph_finalizer", ] ## Find igraph functions -igraph_yaml <- yaml::read_yaml(file.path("tools", "stimulus", "functions-R.yaml")) +igraph_yaml <- yaml::read_yaml(file.path( + "tools", + "stimulus", + "functions-R.yaml" +)) igraph_functions <- names(igraph_yaml) -igraph_yaml2 <- yaml::read_yaml(file.path("src", "vendor", "cigraph", "interfaces", "functions.yaml")) +igraph_yaml2 <- yaml::read_yaml(file.path( + "src", + "vendor", + "cigraph", + "interfaces", + "functions.yaml" +)) igraph_functions2 <- names(igraph_yaml2) # setdiff(igraph_functions2, igraph_functions) # ??? @@ -57,7 +70,11 @@ find_igraph <- function(rrr_igraph, igraph_functions) { } } -impl_df$igraph <- purrr::map_chr(impl_df$rrrigraph, find_igraph, igraph_functions = igraph_functions) +impl_df$igraph <- purrr::map_chr( + impl_df$rrrigraph, + find_igraph, + igraph_functions = igraph_functions +) ## Now find where to add the cdogs tags yay r_scripts <- fs::dir_ls("R", glob = "*.R") @@ -137,11 +154,14 @@ all_funs <- dplyr::left_join(all_funs, clinks, by = "igraph") all_funs <- dplyr::filter(all_funs, !is.na(url)) for (i in 1:nrow(all_funs)) { - if (all_funs$name[i] %in% getNamespaceExports("igraph")) { + if (all_funs$name[i] %in% getNamespaceExports("igraph")) { cli::cli_alert_info(all_funs$impl[i]) script_lines <- brio::read_lines(all_funs$script[i]) - target_line <- which(startsWith(script_lines, sprintf("%s <- ", all_funs$name[i]))) + target_line <- which(startsWith( + script_lines, + sprintf("%s <- ", all_funs$name[i]) + )) script_lines <- append( script_lines, @@ -151,10 +171,10 @@ for (i in 1:nrow(all_funs)) { brio::write_lines(script_lines, all_funs$script[i]) devtools::document() - gert::git_commit_all(sprintf("docs: add cdocs tag for %s", all_funs$name[i])) + gert::git_commit_all(sprintf( + "docs: add cdocs tag for %s", + all_funs$name[i] + )) gert::git_push() } - } - - diff --git a/tools/deprecate-make.R b/tools/deprecate-make.R index b55463b22ab..42820344850 100644 --- a/tools/deprecate-make.R +++ b/tools/deprecate-make.R @@ -20,7 +20,7 @@ tibblify_call <- function(deprecated_call) { args <- deprecated_call |> xml2::xml_parent() |> xml2::xml_siblings() |> - purrr::keep(~xml2::xml_name(.x) == "expr") + purrr::keep(~ xml2::xml_name(.x) == "expr") old <- xml2::xml_text(args[[1]]) new <- xml2::xml_text(args[[2]]) tibble::tibble(old = gsub('"', '', old), new = new) @@ -32,13 +32,15 @@ deprecated_df <- purrr::map_df(deprecated_calls, tibblify_call) .parse_impl_assignements <- function() { scripts <- fs::dir_ls(here::here("R")) |> - purrr::keep(~(.x != zzz_script)) |> + purrr::keep(~ (.x != zzz_script)) |> purrr::map(parse_script) parse_script_function_call <- function(xml) { kiddos <- xml2::xml_children(xml) candidates <- kiddos[xml2::xml_name(kiddos) == "expr"] - candidates <- candidates[purrr::map_int(candidates, ~length(xml2::xml_children(.x))) == 3] + candidates <- candidates[ + purrr::map_int(candidates, ~ length(xml2::xml_children(.x))) == 3 + ] purrr::map_df( candidates, @@ -55,19 +57,20 @@ parse_impl_assignements <- memoise::memoise(.parse_impl_assignements) parse_package_defs <- function() { scripts <- fs::dir_ls(here::here("R")) |> - purrr::keep(~(.x != zzz_script)) |> + purrr::keep(~ (.x != zzz_script)) |> purrr::map(parse_script) parse_script_function_call <- function(script, script_name) { fns <- xml2::xml_find_all(script, ".//FUNCTION[text()='function']") is_fn_definition <- function(fn) { siblings <- fn |> xml2::xml_parent() |> xml2::xml_siblings() - (length(siblings) == 2) && (xml2::xml_name(siblings[[2]]) == "LEFT_ASSIGN") + (length(siblings) == 2) && + (xml2::xml_name(siblings[[2]]) == "LEFT_ASSIGN") } fns <- purrr::keep(fns, is_fn_definition) parse_function <- function(fn, script_name) { - whole_definition <- fn |> xml2::xml_parent()|> xml2::xml_parent() + whole_definition <- fn |> xml2::xml_parent() |> xml2::xml_parent() line1 <- xml2::xml_attr(whole_definition, "line1") line2 <- xml2::xml_attr(whole_definition, "line2") name <- whole_definition |> xml2::xml_child() |> xml2::xml_text() @@ -75,12 +78,16 @@ parse_package_defs <- function() { xml2::xml_children() body <- body[length(body)] - inline <- brio::read_lines(script_name)[(xml2::xml_attr(body, "line1")):xml2::xml_attr(body, "line2")] - inline <- inline[2:(length(inline)-1)] + inline <- brio::read_lines(script_name)[ + (xml2::xml_attr(body, "line1")):xml2::xml_attr(body, "line2") + ] + inline <- inline[2:(length(inline) - 1)] inline <- paste(inline, collapse = "\n") - args <- xml2::xml_find_all(whole_definition, "./*/SYMBOL_FORMALS") |> xml2::xml_text() - args <- xml2::xml_find_all(whole_definition, "./*/SYMBOL_FORMALS") |> xml2::xml_text() + args <- xml2::xml_find_all(whole_definition, "./*/SYMBOL_FORMALS") |> + xml2::xml_text() + args <- xml2::xml_find_all(whole_definition, "./*/SYMBOL_FORMALS") |> + xml2::xml_text() if (length(args) > 0) { if ("..." %in% args) { if (length(args) == 1) { @@ -92,15 +99,17 @@ parse_package_defs <- function() { args <- toString(glue::glue("{args} = {args}")) } - usage_wrap <- xml2::xml_children(whole_definition)[[3]] |> xml2::xml_children() + usage_wrap <- xml2::xml_children(whole_definition)[[3]] |> + xml2::xml_children() # TODO use XPath not numbers? although this should work? - usage <- usage_wrap[3:(length(usage_wrap)-2)] |> xml2::xml_text() |> paste(collapse = " ") + usage <- usage_wrap[3:(length(usage_wrap) - 2)] |> + xml2::xml_text() |> + paste(collapse = " ") } else { args <- "" usage <- "" } - tibble::tibble( line1 = line1, line2 = line2, @@ -123,7 +132,8 @@ clean_alias <- function(aliases, x) { output <- gsub(sprintf(" %s$", x), "", output) output[!grepl("@aliases", output)] <- sub( - "#' ", "#' @aliases ", + "#' ", + "#' @aliases ", output[!grepl("@aliases", output)] ) @@ -135,16 +145,15 @@ remove_aliases <- function(script, to_be_deprecated) { lines <- brio::read_lines(script) which_aliases <- grepl("@aliases", lines) | - (grepl("@aliases", dplyr::lag(lines, 1)) & + (grepl("@aliases", dplyr::lag(lines, 1)) & grepl("^#' (?!\\@)", lines, perl = TRUE)) aliases_present <- (sum(which_aliases) > 0) if (aliases_present) { - aliases <- lines[which_aliases] aliases <- purrr::reduce( to_be_deprecated, - \(aliases, x) clean_alias(aliases, x ), + \(aliases, x) clean_alias(aliases, x), .init = aliases ) lines[which_aliases] <- aliases @@ -166,10 +175,8 @@ purrr::walk( # parse ALL the package scripts ---- - # get docs from pkgdown ---- get_title <- function(fn_name) { - if (fn_name == "adjacent_triangles") { fn_name <- "count_triangles" } @@ -186,22 +193,27 @@ treat_call <- function(old, new, topics) { } pkg_defs <- parse_package_defs() - template <- paste(readLines(here::here("tools", "deprecate-make-template.txt")), collapse = "\n") + template <- paste( + readLines(here::here("tools", "deprecate-make-template.txt")), + collapse = "\n" + ) - relevant_row <- pkg_defs[pkg_defs[["name"]] == new,] + relevant_row <- pkg_defs[pkg_defs[["name"]] == new, ] if (nrow(relevant_row) == 0) { - relevant_row <- pkg_defs[pkg_defs[["name"]] == sprintf("%s_impl", new),] + relevant_row <- pkg_defs[pkg_defs[["name"]] == sprintf("%s_impl", new), ] } if (nrow(relevant_row) == 0) { assignments <- parse_impl_assignements() actual_def <- assignments[["right"]][assignments[["left"]] == new] - relevant_row <- pkg_defs[pkg_defs[["name"]] == actual_def,] + relevant_row <- pkg_defs[pkg_defs[["name"]] == actual_def, ] } if (nrow(relevant_row) > 1) { - relevant_row <- relevant_row[!grepl("aaa-auto", relevant_row[["script_name"]]),] + relevant_row <- relevant_row[ + !grepl("aaa-auto", relevant_row[["script_name"]]), + ] } if (grepl("_impl$", new)) { @@ -277,4 +289,6 @@ gert::git_add("NAMESPACE") gert::git_commit("refactor: remove the deprecated() function") gert::git_add("tools*") -gert::git_commit("refactor: add script used for refactoring deprecation in make.R") +gert::git_commit( + "refactor: add script used for refactoring deprecation in make.R" +) diff --git a/tools/deprecate-tests.R b/tools/deprecate-tests.R index a3efad52aad..222c01cae79 100644 --- a/tools/deprecate-tests.R +++ b/tools/deprecate-tests.R @@ -24,7 +24,7 @@ tibblify_call <- function(deprecated_call) { args <- deprecated_call |> xml2::xml_parent() |> xml2::xml_siblings() |> - purrr::keep(~xml2::xml_name(.x) == "expr") + purrr::keep(~ xml2::xml_name(.x) == "expr") old <- xml2::xml_text(args[[1]]) new <- xml2::xml_text(args[[2]]) tibble::tibble(old = gsub('"', '', old), new = new) @@ -37,13 +37,12 @@ deprecated_df <- purrr::map_df(deprecated_calls, tibblify_call) test_scripts <- fs::dir_ls(here::here("R"), glob = "*.R") fix_test_script <- function(test_script, deprecated_df) { - test_lines <- brio::read_lines(test_script) look_for_one <- function(test_lines, old_name, new_name) { - old_name <- sub("\\.", "\\\\.", old_name) + old_name <- sub("\\.", "\\\\.", old_name) - test_lines <- gsub( + test_lines <- gsub( sprintf("^%s\\(", old_name), sprintf("%s(", new_name), test_lines, @@ -64,8 +63,11 @@ fix_test_script <- function(test_script, deprecated_df) { } test_lines <- purrr::reduce2( - deprecated_df$old, deprecated_df$new, - \(test_lines, old_name, new_name) look_for_one(test_lines, old_name, new_name), + deprecated_df$old, + deprecated_df$new, + \(test_lines, old_name, new_name) { + look_for_one(test_lines, old_name, new_name) + }, .init = test_lines ) @@ -80,13 +82,12 @@ purrr::walk(test_scripts, fix_test_script, deprecated_df = deprecated_df) test_scripts <- fs::dir_ls(here::here("tests", "testthat"), glob = "*.R") fix_test_script <- function(test_script, deprecated_df) { - test_lines <- brio::read_lines(test_script) look_for_one <- function(test_lines, old_name, new_name) { - old_name <- sub("\\.", "\\\\.", old_name) + old_name <- sub("\\.", "\\\\.", old_name) - test_lines <- gsub( + test_lines <- gsub( sprintf("^%s\\(", old_name), sprintf("%s(", new_name), test_lines, @@ -107,8 +108,11 @@ fix_test_script <- function(test_script, deprecated_df) { } test_lines <- purrr::reduce2( - deprecated_df$old, deprecated_df$new, - \(test_lines, old_name, new_name) look_for_one(test_lines, old_name, new_name), + deprecated_df$old, + deprecated_df$new, + \(test_lines, old_name, new_name) { + look_for_one(test_lines, old_name, new_name) + }, .init = test_lines ) diff --git a/tools/deprecate.R b/tools/deprecate.R index cef5c211e9e..9048de5c698 100644 --- a/tools/deprecate.R +++ b/tools/deprecate.R @@ -20,7 +20,7 @@ tibblify_call <- function(deprecated_call) { args <- deprecated_call |> xml2::xml_parent() |> xml2::xml_siblings() |> - purrr::keep(~xml2::xml_name(.x) == "expr") + purrr::keep(~ xml2::xml_name(.x) == "expr") old <- xml2::xml_text(args[[1]]) new <- xml2::xml_text(args[[2]]) tibble::tibble(old = gsub('"', '', old), new = new) @@ -32,13 +32,15 @@ deprecated_df <- purrr::map_df(deprecated_calls, tibblify_call) .parse_impl_assignements <- function() { scripts <- fs::dir_ls(here::here("R")) |> - purrr::keep(~(.x != zzz_script)) |> + purrr::keep(~ (.x != zzz_script)) |> purrr::map(parse_script) parse_script_function_call <- function(xml) { kiddos <- xml2::xml_children(xml) candidates <- kiddos[xml2::xml_name(kiddos) == "expr"] - candidates <- candidates[purrr::map_int(candidates, ~length(xml2::xml_children(.x))) == 3] + candidates <- candidates[ + purrr::map_int(candidates, ~ length(xml2::xml_children(.x))) == 3 + ] purrr::map_df( candidates, @@ -55,31 +57,35 @@ parse_impl_assignements <- memoise::memoise(.parse_impl_assignements) parse_package_defs <- function() { scripts <- fs::dir_ls(here::here("R")) |> - purrr::keep(~(.x != zzz_script)) |> + purrr::keep(~ (.x != zzz_script)) |> purrr::map(parse_script) parse_script_function_call <- function(script, script_name) { fns <- xml2::xml_find_all(script, ".//FUNCTION[text()='function']") is_fn_definition <- function(fn) { siblings <- fn |> xml2::xml_parent() |> xml2::xml_siblings() - (length(siblings) == 2) && (xml2::xml_name(siblings[[2]]) == "LEFT_ASSIGN") + (length(siblings) == 2) && + (xml2::xml_name(siblings[[2]]) == "LEFT_ASSIGN") } fns <- purrr::keep(fns, is_fn_definition) parse_function <- function(fn) { - whole_definition <- fn |> xml2::xml_parent()|> xml2::xml_parent() + whole_definition <- fn |> xml2::xml_parent() |> xml2::xml_parent() line1 <- xml2::xml_attr(whole_definition, "line1") line2 <- xml2::xml_attr(whole_definition, "line2") name <- whole_definition |> xml2::xml_child() |> xml2::xml_text() - if (name %in% c( + if ( + name %in% + c( "tk_off", "get_all_options", "tkigraph", ".tkigraph.clusters", "show.communities", "sortPopup" - )) { + ) + ) { return( tibble::tibble( line1 = line1, @@ -91,7 +97,8 @@ parse_package_defs <- function() { ) } - args <- xml2::xml_find_all(whole_definition, "./*/SYMBOL_FORMALS") |> xml2::xml_text() + args <- xml2::xml_find_all(whole_definition, "./*/SYMBOL_FORMALS") |> + xml2::xml_text() if (length(args) > 0) { if ("..." %in% args) { if (length(args) == 1) { @@ -103,9 +110,12 @@ parse_package_defs <- function() { args <- toString(glue::glue("{args} = {args}")) } - usage_wrap <- xml2::xml_children(whole_definition)[[3]] |> xml2::xml_children() + usage_wrap <- xml2::xml_children(whole_definition)[[3]] |> + xml2::xml_children() # TODO use XPath not numbers? although this should work? - usage <- usage_wrap[3:(length(usage_wrap)-2)] |> xml2::xml_text() |> paste(collapse = " ") + usage <- usage_wrap[3:(length(usage_wrap) - 2)] |> + xml2::xml_text() |> + paste(collapse = " ") } else { args <- "" usage <- "" @@ -170,7 +180,8 @@ clean_alias <- function(aliases, x) { output <- gsub(sprintf(" %s$", x), "", output) output[!grepl("@aliases", output)] <- sub( - "#' ", "#' @aliases ", + "#' ", + "#' @aliases ", output[!grepl("@aliases", output)] ) @@ -182,16 +193,15 @@ remove_aliases <- function(script, to_be_deprecated) { lines <- brio::read_lines(script) which_aliases <- grepl("@aliases", lines) | - (grepl("@aliases", dplyr::lag(lines, 1)) & + (grepl("@aliases", dplyr::lag(lines, 1)) & grepl("^#' (?!\\@)", lines, perl = TRUE)) aliases_present <- (sum(which_aliases) > 0) if (aliases_present) { - aliases <- lines[which_aliases] aliases <- purrr::reduce( to_be_deprecated, - \(aliases, x) clean_alias(aliases, x ), + \(aliases, x) clean_alias(aliases, x), .init = aliases ) lines[which_aliases] <- aliases @@ -205,7 +215,7 @@ remove_aliases <- function(script, to_be_deprecated) { } purrr::walk( - fs::dir_ls(here::here("R")) , + fs::dir_ls(here::here("R")), remove_aliases, to_be_deprecated = deprecated_df$old, .progress = TRUE @@ -213,10 +223,8 @@ purrr::walk( # parse ALL the package scripts ---- - # get docs from pkgdown ---- get_title <- function(fn_name) { - if (fn_name == "adjacent_triangles") { fn_name <- "count_triangles" } @@ -233,22 +241,27 @@ treat_call <- function(old, new, topics) { } pkg_defs <- parse_package_defs() - template <- paste(readLines(here::here("tools", "deprecate-template.txt")), collapse = "\n") + template <- paste( + readLines(here::here("tools", "deprecate-template.txt")), + collapse = "\n" + ) - relevant_row <- pkg_defs[pkg_defs[["name"]] == new,] + relevant_row <- pkg_defs[pkg_defs[["name"]] == new, ] if (nrow(relevant_row) == 0) { - relevant_row <- pkg_defs[pkg_defs[["name"]] == sprintf("%s_impl", new),] + relevant_row <- pkg_defs[pkg_defs[["name"]] == sprintf("%s_impl", new), ] } if (nrow(relevant_row) == 0) { assignments <- parse_impl_assignements() actual_def <- assignments[["right"]][assignments[["left"]] == new] - relevant_row <- pkg_defs[pkg_defs[["name"]] == actual_def,] + relevant_row <- pkg_defs[pkg_defs[["name"]] == actual_def, ] } if (nrow(relevant_row) > 1) { - relevant_row <- relevant_row[!grepl("aaa-auto", relevant_row[["script_name"]]),] + relevant_row <- relevant_row[ + !grepl("aaa-auto", relevant_row[["script_name"]]), + ] } if (grepl("_impl$", new)) { @@ -327,7 +340,7 @@ pajek_script <- "R/cohesive.blocks.R" pajek_lines <- brio::read_lines(pajek_script) pajek_lines <- purrr::discard( pajek_lines, - ~.x=="#' exportPajek" + ~ .x == "#' exportPajek" ) brio::write_lines(pajek_lines, pajek_script) devtools::document() @@ -413,7 +426,7 @@ build_commit <- function(commit) { message <- trimws(gert::git_commit_info(commit)[["message"]]) gert::git_cherry_pick(commit) - gert::git_reset_soft(gert::git_log(max=2)$commit[2]) + gert::git_reset_soft(gert::git_log(max = 2)$commit[2]) devtools::document() diff --git a/tools/expect_equal.R b/tools/expect_equal.R index 7287bd3682b..893f4103fec 100644 --- a/tools/expect_equal.R +++ b/tools/expect_equal.R @@ -16,12 +16,16 @@ treat_deprecated <- function(xml, path) { true_lack <- xml2::xml_siblings(equal)[length(xml2::xml_siblings(equal)) - 1] xml2::xml_add_child(true_lack, "NUM_CONST", "TRUE", line1 = first_line) xml2::xml_add_sibling(equal, "EQ_FORMALS", "=", line1 = first_line) - xml2::xml_add_sibling(equal, "SYMBOL_FORMALS", "ignore_attr", line1 = first_line) + xml2::xml_add_sibling( + equal, + "SYMBOL_FORMALS", + "ignore_attr", + line1 = first_line + ) xml2::xml_add_sibling(equal, "OP-COMMA", ",", line1 = first_line) } parse_script <- function(path) { - cli::cli_alert_info("Refactoring {path}.") lines <- brio::read_lines(path) @@ -39,7 +43,6 @@ parse_script <- function(path) { purrr::walk(deprecated, treat_deprecated, path = path) for (deprecated_call in deprecated) { - parent <- xml2::xml_parent(xml2::xml_parent(deprecated_call)) line1 <- as.numeric(xml2::xml_attr(parent, "line1")) @@ -56,24 +59,25 @@ parse_script <- function(path) { ) } } - - } brio::write_lines(lines, path) - if (! (path %in% gert::git_status()[["file"]])) { + if (!(path %in% gert::git_status()[["file"]])) { return(invisible(TRUE)) } styler::style_file(path) - if (! (path %in% gert::git_status()[["file"]])) { + if (!(path %in% gert::git_status()[["file"]])) { return(invisible(TRUE)) } gert::git_add(path) gert::git_commit( - sprintf("refactor: remove deprecated expect_that() from %s", fs::path_file(path)) + sprintf( + "refactor: remove deprecated expect_that() from %s", + fs::path_file(path) + ) ) } diff --git a/tools/extract_examples.R b/tools/extract_examples.R index 7ba63064e58..2910ed78437 100755 --- a/tools/extract_examples.R +++ b/tools/extract_examples.R @@ -2,9 +2,8 @@ library(tools) -rdfiles <- list.files("igraph/man", pattern=".*\\.Rd$", full.names=TRUE) -out <- file("igraph-Ex.R", open="w") -cat("### Load the package\nlibrary(igraph)\n\n", file=out) -sapply(rdfiles, Rd2ex, out=out) +rdfiles <- list.files("igraph/man", pattern = ".*\\.Rd$", full.names = TRUE) +out <- file("igraph-Ex.R", open = "w") +cat("### Load the package\nlibrary(igraph)\n\n", file = out) +sapply(rdfiles, Rd2ex, out = out) close(out) - diff --git a/tools/find-duplicate-seealso.R b/tools/find-duplicate-seealso.R index 065197fce88..8a63cd19a1c 100644 --- a/tools/find-duplicate-seealso.R +++ b/tools/find-duplicate-seealso.R @@ -10,10 +10,18 @@ parse <- function(rd_file) { tools::Rd2HTML(rd_file, out = html_file) html <- xml2::read_html(html_file) # remove examples as I could not make the Xpath work with and not(following-sibling::h3) - examples <- xml2::xml_find_first(html, "//p[preceding-sibling::h3[text()='Examples']]") + examples <- xml2::xml_find_first( + html, + "//p[preceding-sibling::h3[text()='Examples']]" + ) xml2::xml_remove(examples) - see_also <- xml2::xml_find_all(html, "//p[preceding-sibling::h3[text()='See Also']]") - if (length(see_also) <= 1) return() + see_also <- xml2::xml_find_all( + html, + "//p[preceding-sibling::h3[text()='See Also']]" + ) + if (length(see_also) <= 1) { + return() + } titles <- purrr::map_chr(see_also, title_from_p) if (any(duplicated(titles))) browser() } diff --git a/tools/rd.R b/tools/rd.R index 910f6b06dd8..049abec8fdd 100644 --- a/tools/rd.R +++ b/tools/rd.R @@ -19,7 +19,9 @@ set_class <- function(x) { tag <- function(x) { tag <- attr(x, "Rd_tag") - if (is.null(tag)) return() + if (is.null(tag)) { + return() + } gsub("\\", "tag_", tag, fixed = TRUE) } @@ -39,7 +41,11 @@ rd_file <- function(path) { return(TRUE) } - describe <- purrr::keep(unlist(return_value, recursive = FALSE), inherits, "tag_describe") + describe <- purrr::keep( + unlist(return_value, recursive = FALSE), + inherits, + "tag_describe" + ) items <- c( purrr::keep(unlist(return_value, recursive = FALSE), inherits, "tag_item"), purrr::keep(unlist(unlist(return_value, recursive = FALSE), recursive = FALSE), inherits, "tag_item") @@ -50,4 +56,4 @@ rd_file <- function(path) { } } -purrr::walk(rd_files, rd_file) \ No newline at end of file +purrr::walk(rd_files, rd_file) diff --git a/tools/sync-yaml.R b/tools/sync-yaml.R index 1cb83cb068c..d1fc7579473 100644 --- a/tools/sync-yaml.R +++ b/tools/sync-yaml.R @@ -3,7 +3,11 @@ library(purrr) lines_r <- brio::read_file("tools/stimulus/functions-R.yaml") -split_r <- strsplit(lines_r, "\n(?=((?:#.*|)\n)+igraph_.*:\n(?:(?:[ #].*|)\n)*\n+)", perl = TRUE)[[1]] +split_r <- strsplit( + lines_r, + "\n(?=((?:#.*|)\n)+igraph_.*:\n(?:(?:[ #].*|)\n)*\n+)", + perl = TRUE +)[[1]] proper_r <- grepl("^\nigraph_", split_r) @@ -19,9 +23,16 @@ map(r$text_r, grep, pattern = "\nigraph") |> lengths() |> unique() -lines_c <- paste0(brio::read_file("src/vendor/cigraph/interfaces/functions.yaml"), "\n") +lines_c <- paste0( + brio::read_file("src/vendor/cigraph/interfaces/functions.yaml"), + "\n" +) -split_c <- strsplit(lines_c, "\n(?=((?:#.*|)\n)+igraph_.*:\n(?:(?:[ #].*|)\n)*\n+)", perl = TRUE)[[1]] +split_c <- strsplit( + lines_c, + "\n(?=((?:#.*|)\n)+igraph_.*:\n(?:(?:[ #].*|)\n)*\n+)", + perl = TRUE +)[[1]] proper_c <- grepl("^\nigraph_", split_c) diff --git a/tools/update-examples.R b/tools/update-examples.R index 28783e737db..2457620d743 100644 --- a/tools/update-examples.R +++ b/tools/update-examples.R @@ -19,7 +19,7 @@ tibblify_call <- function(deprecated_call) { args <- deprecated_call |> xml2::xml_parent() |> xml2::xml_siblings() |> - purrr::keep(~xml2::xml_name(.x) == "expr") + purrr::keep(~ xml2::xml_name(.x) == "expr") old <- xml2::xml_text(args[[1]]) new <- xml2::xml_text(args[[2]]) tibble::tibble(old = gsub('"', '', old), new = new) @@ -31,17 +31,22 @@ detect_fun <- function(fun_name, lines) { file <- withr::local_tempfile() brio::write_lines(lines, file) xml <- parse_script(file) - called_funs <- xml2::xml_find_all(xml, ".//SYMBOL_FUNCTION_CALL") |> xml2::xml_text() + called_funs <- xml2::xml_find_all(xml, ".//SYMBOL_FUNCTION_CALL") |> + xml2::xml_text() any(called_funs == fun_name) - } topics <- pkgdown::as_pkgdown()[["topics"]] treat_topic <- function(topic, deprecated_df) { message(topic) - lines <- example(topic, character.only = TRUE, package = "igraph", give.lines = TRUE) + lines <- example( + topic, + character.only = TRUE, + package = "igraph", + give.lines = TRUE + ) no_example <- is.null(lines) if (no_example) { @@ -62,10 +67,13 @@ treat_topic <- function(topic, deprecated_df) { } NULL - } -df <- purrr::map_df(topics[["name"]], treat_topic, deprecated_df = deprecated_df) +df <- purrr::map_df( + topics[["name"]], + treat_topic, + deprecated_df = deprecated_df +) # Update by hand, document(), R CMD build, re-run script to be sure if (nrow(df) > 0) { View(df) From fff4080e2846663720a12ef8039453ba8a20a055 Mon Sep 17 00:00:00 2001 From: schochastics Date: Thu, 12 Jun 2025 14:27:55 +0200 Subject: [PATCH 54/59] foreign --- R/foreign.R | 26 +++----------------------- 1 file changed, 3 insertions(+), 23 deletions(-) diff --git a/R/foreign.R b/R/foreign.R index a142e7d9504..94dd4632f2e 100644 --- a/R/foreign.R +++ b/R/foreign.R @@ -785,29 +785,9 @@ graph_from_graphdb <- function( } else { "l" } # "l" ???? - typegroups <- c( - "rand", - "rand", - "rand", - "rand", - "m2D", - "m2D", - "m2D", - "m2D", - "m2D", - "m3D", - "m3D", - "m3D", - "m4D", - "m4D", - "m4D", - "m4D", - "bvg", - "bvg", - "bvg", - "bvg", - "bvg", - "bvg" + typegroups <- rep( + c("rand", "m2D", "m3D", "m4D", "bvg"), + c(4L, 5L, 3L, 4L, 6L) ) typegroup <- typegroups[which(types == type)] From 8cd1081e38db9fb2cb280054d27a3737fc9bc742 Mon Sep 17 00:00:00 2001 From: schochastics Date: Thu, 12 Jun 2025 14:34:49 +0200 Subject: [PATCH 55/59] added edge to exclude --- air.toml | 2 +- tests/testthat/test-print.R | 54 +++++++++++++------------------------ 2 files changed, 19 insertions(+), 37 deletions(-) diff --git a/air.toml b/air.toml index 56cfb63f106..162dfa91e14 100644 --- a/air.toml +++ b/air.toml @@ -5,4 +5,4 @@ indent-style = "space" line-ending = "auto" persistent-line-breaks = true default-exclude = true -skip = ["tribble", "graph_from_literal", "matrix", "c", "make_graph"] +skip = ["tribble", "graph_from_literal", "matrix", "c", "make_graph", "edges"] diff --git a/tests/testthat/test-print.R b/tests/testthat/test-print.R index bc1655df5e9..eb880eed5ef 100644 --- a/tests/testthat/test-print.R +++ b/tests/testthat/test-print.R @@ -49,42 +49,24 @@ test_that("print.igraph() works", { kite <- make_empty_graph(directed = FALSE) + LETTERS[1:10] kite <- kite + edges( - "A", - "B", - "A", - "C", - "A", - "D", - "A", - "F", - "B", - "D", - "B", - "E", - "B", - "G", - "C", - "D", - "C", - "F", - "D", - "E", - "D", - "F", - "D", - "G", - "E", - "G", - "F", - "G", - "F", - "H", - "G", - "H", - "H", - "I", - "I", - "J" + "A", "B", + "A", "C", + "A", "D", + "A", "F", + "B", "D", + "B", "E", + "B", "G", + "C", "D", + "C", "F", + "D", "E", + "D", "F", + "D", "G", + "E", "G", + "F", "G", + "F", "H", + "G", "H", + "H", "I", + "I", "J" ) expect_output(print(kite), "A -- ") }) From 8119e168796a018c46eb5b29312f92fc7eb5f138 Mon Sep 17 00:00:00 2001 From: schochastics Date: Thu, 12 Jun 2025 14:43:37 +0200 Subject: [PATCH 56/59] reformat plot with c skipped --- R/plot.R | 211 ++++++------------------------------------------------- 1 file changed, 23 insertions(+), 188 deletions(-) diff --git a/R/plot.R b/R/plot.R index d3cb1c23192..983947d0195 100644 --- a/R/plot.R +++ b/R/plot.R @@ -1485,91 +1485,17 @@ rglplot.igraph <- function(x, ...) { 1 ), c( - 1, - 2, - 3, - 4, - 5, - 6, - 7, - 8, - 1, - 2, - 6, - 5, - 2, - 3, - 7, - 6, - 3, - 4, - 8, - 7, - 1, - 4, - 18, - 17, - 9, - 10, - 11, - 12, - 13, - 14, - 15, - 16, - 9, - 10, - 14, - 13, - 10, - 11, - 15, - 14, - 11, - 12, - 16, - 15, - 9, - 12, - 20, - 19, - 5, - 13, - 19, - 17, - 17, - 18, - 20, - 19, - 8, - 16, - 20, - 18, - 6, - 7, - 15, - 14, + 1, 2, 3, 4, 5, 6, 7, 8, 1, 2, 6, + 5, 2, 3, 7, 6, 3, 4, 8, 7, 1, 4, + 18, 17, 9, 10, 11, 12, 13, 14, 15, + 16, 9, 10, 14, 13, 10, 11, 15, 14, + 11, 12, 16, 15, 9, 12, 20, 19, 5, + 13, 19, 17, 17, 18, 20, 19, 8, 16, + 20, 18, 6, 7, 15, 14, # the arrow - 21, - 22, - 23, - 24, - 21, - 22, - 25, - 25, - 22, - 23, - 25, - 25, - 23, - 24, - 25, - 25, - 21, - 24, - 25, - 25 + 21, 22, 23, 24, 21, 22, 25, 25, + 22, 23, 25, 25, 23, 24, 25, 25, + 21, 24, 25, 25 ) ) } else if (am == 3) { @@ -1698,111 +1624,20 @@ rglplot.igraph <- function(x, ...) { 1 ), c( - 1, - 2, - 3, - 4, - 5, - 6, - 7, - 8, - 1, - 2, - 6, - 5, - 2, - 3, - 7, - 6, - 3, - 4, - 8, - 7, - 1, - 4, - 18, - 17, - 9, - 10, - 11, - 12, - 13, - 14, - 15, - 16, - 9, - 10, - 14, - 13, - 10, - 11, - 15, - 14, - 11, - 12, - 16, - 15, - 9, - 12, - 20, - 19, - 5, - 13, - 19, - 17, - 17, - 18, - 20, - 19, - 8, - 16, - 20, - 18, - 6, - 7, - 15, - 14, + 1, 2, 3, 4, 5, 6, 7, 8, 1, + 2, 6, 5, 2, 3, 7, 6, 3, 4, + 8, 7, 1, 4, 18, 17, 9, 10, + 11, 12, 13, 14, 15, 16, 9, 10, + 14, 13, 10, 11, 15, 14, 11, + 12, 16, 15, 9, 12, 20, 19, 5, + 13, 19, 17, 17, 18, 20, 19, 8, + 16, 20, 18, 6, 7, 15, 14, # the arrows - 21, - 22, - 23, - 24, - 21, - 22, - 25, - 25, - 22, - 23, - 25, - 25, - 23, - 24, - 25, - 25, - 21, - 24, - 25, - 25, - 26, - 27, - 28, - 29, - 26, - 27, - 30, - 30, - 27, - 28, - 30, - 30, - 28, - 29, - 30, - 30, - 26, - 29, - 30, - 30 + 21, 22, 23, 24, 21, 22, 25, 25, 22, + 23, 25, 25, 23, 24, 25, 25, 21, + 24, 25, 25, 26, 27, 28, 29, 26, 27, + 30, 30, 27, 28, 30, 30, 28, 29, 30, + 30, 26, 29, 30, 30 ) ) } From 142f450950f421bcba19d779d9c29a62dfd07a1e Mon Sep 17 00:00:00 2001 From: schochastics Date: Thu, 12 Jun 2025 14:52:25 +0200 Subject: [PATCH 57/59] more c in print --- R/plot.R | 274 +++++++------------------------------------------------ 1 file changed, 34 insertions(+), 240 deletions(-) diff --git a/R/plot.R b/R/plot.R index 983947d0195..43c75141150 100644 --- a/R/plot.R +++ b/R/plot.R @@ -821,30 +821,10 @@ rglplot.igraph <- function(x, ...) { 1 ), c( - 1, - 2, - 3, - 4, - 5, - 6, - 7, - 8, - 1, - 2, - 6, - 5, - 2, - 3, - 7, - 6, - 3, - 4, - 8, - 7, - 4, - 1, - 5, - 8 + 1, 2, 3, 4, 5, 6, 7, + 8, 1, 2, 6, 5, 2, 3, + 7, 6, 3, 4, 8, 7, 4, + 1, 5, 8 ) ) } else if (am == 1) { @@ -904,50 +884,12 @@ rglplot.igraph <- function(x, ...) { 1 ), c( - 1, - 2, - 3, - 4, - 5, - 6, - 7, - 8, - 1, - 2, - 6, - 5, - 2, - 3, - 7, - 6, - 3, - 4, - 8, - 7, - 4, - 1, - 5, - 8, - 9, - 10, - 11, - 12, - 9, - 12, - 13, - 13, - 9, - 10, - 13, - 13, - 10, - 11, - 13, - 13, - 11, - 12, - 13, - 13 + 1, 2, 3, 4, 5, 6, 7, 8, + 1, 2, 6, 5, 2, 3, 7, 6, + 3, 4, 8, 7, 4, 1, 5, 8, + 9, 10, 11, 12, 9, 12, 13, 13, + 9, 10, 13, 13, 10, 11, 13, + 13, 11, 12, 13, 13 ) ) } else if (am == 2) { @@ -1008,50 +950,12 @@ rglplot.igraph <- function(x, ...) { 1 ), c( - 1, - 2, - 3, - 4, - 5, - 6, - 7, - 8, - 1, - 2, - 6, - 5, - 2, - 3, - 7, - 6, - 3, - 4, - 8, - 7, - 4, - 1, - 5, - 8, - 9, - 10, - 11, - 12, - 9, - 12, - 13, - 13, - 9, - 10, - 13, - 13, - 10, - 11, - 13, - 13, - 11, - 12, - 13, - 13 + 1, 2, 3, 4, 5, 6, 7, 8, + 1, 2, 6, 5, 2, 3, 7, 6, + 3, 4, 8, 7, 4, 1, 5, 8, 9, + 10, 11, 12, 9, 12, 13, 13, 9, + 10, 13, 13, 10, 11, 13, 13, 11, + 12, 13, 13 ) ) } else { @@ -1131,70 +1035,15 @@ rglplot.igraph <- function(x, ...) { 1 ), c( - 1, - 2, - 3, - 4, - 5, - 6, - 7, - 8, - 1, - 2, - 6, - 5, - 2, - 3, - 7, - 6, - 3, - 4, - 8, - 7, - 4, - 1, - 5, - 8, - 9, - 10, - 11, - 12, - 9, - 12, - 17, - 17, - 9, - 10, - 17, - 17, - 10, - 11, - 17, - 17, - 11, - 12, - 17, - 17, - 13, - 14, - 15, - 16, - 13, - 16, - 18, - 18, - 13, - 14, - 18, - 18, - 14, - 15, - 18, - 18, - 15, - 16, - 18, - 18 + 1, 2, 3, 4, 5, 6, 7, + 8, 1, 2, 6, 5, 2, 3, + 7, 6, 3, 4, 8, 7, 4, + 1, 5, 8, 9, 10, 11, 12, + 9, 12, 17, 17, 9, 10, 17, + 17, 10, 11, 17, 17, 11, 12, + 17, 17, 13, 14, 15, 16, 13, + 16, 18, 18, 13, 14, 18, 18, + 14, 15, 18, 18, 15, 16, 18, 18 ) ) } @@ -1313,70 +1162,15 @@ rglplot.igraph <- function(x, ...) { 1 ), c( - 1, - 2, - 3, - 4, - 5, - 6, - 7, - 8, - 1, - 2, - 6, - 5, - 2, - 3, - 7, - 6, - 3, - 4, - 8, - 7, - 1, - 4, - 18, - 17, - 9, - 10, - 11, - 12, - 13, - 14, - 15, - 16, - 9, - 10, - 14, - 13, - 10, - 11, - 15, - 14, - 11, - 12, - 16, - 15, - 9, - 12, - 20, - 19, - 5, - 13, - 19, - 17, - 17, - 18, - 20, - 19, - 8, - 16, - 20, - 18, - 6, - 7, - 15, - 14 + 1, 2, 3, 4, 5, 6, 7, + 8, 1, 2, 6, 5, 2, 3, + 7, 6, 3, 4, 8, 7, 1, 4, + 18, 17, 9, 10, 11, 12, 13, 14, + 15, 16, 9, 10, 14, 13, 10, 11, + 15, 14, 11, 12, 16, 15, 9, + 12, 20, 19, 5, 13, 19, 17, + 17, 18, 20, 19, 8, 16, 20, + 18, 6, 7, 15, 14 ) ) } else if (am == 1 || am == 2) { From b8213e910fdbdb89f65177556ece0a2b0c80a43e Mon Sep 17 00:00:00 2001 From: David Schoch Date: Fri, 13 Jun 2025 05:45:03 +0200 Subject: [PATCH 58/59] Discard changes to R/utils-s3.R --- R/utils-s3.R | 27 +++++++++++---------------- 1 file changed, 11 insertions(+), 16 deletions(-) diff --git a/R/utils-s3.R b/R/utils-s3.R index 139c3fab1d4..ac18c529de6 100644 --- a/R/utils-s3.R +++ b/R/utils-s3.R @@ -33,6 +33,7 @@ s3_register <- function(generic, class, method = NULL) { method_fn <- get_method(method) stopifnot(is.function(method_fn)) + # Only register if generic can be accessed if (exists(generic, envir)) { registerS3method(generic, class, method_fn, envir = envir) @@ -46,10 +47,7 @@ s3_register <- function(generic, class, method = NULL) { package ), "i" = "This message is only shown to developers using devtools.", - "i" = sprintf( - "Do you need to update %s to the latest version?", - package - ) + "i" = sprintf("Do you need to update %s to the latest version?", package) )) } } @@ -78,23 +76,21 @@ s3_register <- function(generic, class, method = NULL) { .rlang_s3_register_compat <- function(fn, try_rlang = TRUE) { # Compats that behave the same independently of rlang's presence - out <- switch( - fn, + out <- switch(fn, is_installed = return(function(pkg) requireNamespace(pkg, quietly = TRUE)) ) # Only use rlang if it is fully loaded (#1482) - if ( - try_rlang && - requireNamespace("rlang", quietly = TRUE) && - environmentIsLocked(asNamespace("rlang")) - ) { - switch(fn, is_interactive = return(rlang::is_interactive)) + if (try_rlang && + requireNamespace("rlang", quietly = TRUE) && + environmentIsLocked(asNamespace("rlang"))) { + switch(fn, + is_interactive = return(rlang::is_interactive) + ) # Make sure rlang knows about "x" and "i" bullets if (utils::packageVersion("rlang") >= "0.4.2") { - switch( - fn, + switch(fn, abort = return(rlang::abort), warn = return((rlang::warn)), inform = return(rlang::inform) @@ -114,8 +110,7 @@ s3_register <- function(generic, class, method = NULL) { } format_msg <- function(x) paste(x, collapse = "\n") - switch( - fn, + switch(fn, is_interactive = return(is_interactive_compat), abort = return(function(msg) stop(format_msg(msg), call. = FALSE)), warn = return(function(msg) warning(format_msg(msg), call. = FALSE)), From f1c1f386354e90ba7b70cfc947acba539a82c40e Mon Sep 17 00:00:00 2001 From: schochastics Date: Fri, 13 Jun 2025 05:46:21 +0200 Subject: [PATCH 59/59] added utils-s3.R to exclude --- air.toml | 1 + 1 file changed, 1 insertion(+) diff --git a/air.toml b/air.toml index 162dfa91e14..58d5e7dcd80 100644 --- a/air.toml +++ b/air.toml @@ -5,4 +5,5 @@ indent-style = "space" line-ending = "auto" persistent-line-breaks = true default-exclude = true +exclude = ["R/utils-s3.R"] skip = ["tribble", "graph_from_literal", "matrix", "c", "make_graph", "edges"]