From 12d20ae4af23cd305c17eb908e0dc3afa4abee01 Mon Sep 17 00:00:00 2001 From: James Hollway Date: Mon, 23 Jun 2025 22:48:15 +0200 Subject: [PATCH 01/24] Improved scoping manipulations by recording changes to network name --- DESCRIPTION | 4 ++-- NEWS.md | 7 +++++++ R/manip_reformed.R | 10 +++++++--- 3 files changed, 16 insertions(+), 5 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index f42fc33f..389b1ede 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: manynet Title: Many Ways to Make, Modify, Map, Mark, and Measure Myriad Networks -Version: 1.5.1 -Date: 2025-06-23 +Version: 1.5.2 +Date: 2025-06-24 Description: Many tools for making, modifying, mapping, marking, measuring, and motifs and memberships of many different types of networks. All functions operate with matrices, edge lists, and 'igraph', 'network', and 'tidygraph' objects, diff --git a/NEWS.md b/NEWS.md index 8e51f320..eb6a5c92 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,10 @@ +# manynet 1.5.2 + +## Modifying + +- Improved `to_no_missing()` to record missing removal +- Improved `to_no_isolates()` to record isolate removal +- Improved `to_giant()` to record giant component scoping # manynet 1.5.1 ## Package diff --git a/R/manip_reformed.R b/R/manip_reformed.R index e3144dc8..66b0f455 100644 --- a/R/manip_reformed.R +++ b/R/manip_reformed.R @@ -252,7 +252,8 @@ to_no_missing <- function(.data) UseMethod("to_no_missing") #' @export to_no_missing.tbl_graph <- function(.data){ - delete_nodes(.data, !stats::complete.cases(as_nodelist(.data))) + delete_nodes(.data, !stats::complete.cases(as_nodelist(.data))) %>% + add_info(name = paste(net_name(.data), "without nodes with missing data")) } @@ -346,7 +347,8 @@ to_giant.network <- function(.data) { #' @export to_giant.tbl_graph <- function(.data) { - as_tidygraph(to_giant(as_igraph(.data))) + as_tidygraph(to_giant(as_igraph(.data))) %>% + add_info(name = paste(net_name(.data, prefix = "Giant component of"))) } #' @export @@ -374,7 +376,9 @@ to_no_isolates <- function(.data) UseMethod("to_no_isolates") to_no_isolates.tbl_graph <- function(.data) { nodes <- NULL # Delete edges not present vertices - .data %>% tidygraph::activate(nodes) %>% dplyr::filter(!tidygraph::node_is_isolated()) + .data %>% tidygraph::activate(nodes) %>% + dplyr::filter(!tidygraph::node_is_isolated()) %>% + add_info(name = paste(net_name(.data), "without isolates")) } #' @export From 6f5d1c603f4c40cf1a9ad27d65a02fc9aa90a7f2 Mon Sep 17 00:00:00 2001 From: James Hollway Date: Mon, 23 Jun 2025 22:48:48 +0200 Subject: [PATCH 02/24] Improved pathing functions by recording path type to network name --- NEWS.md | 4 ++++ R/manip_reformed.R | 14 +++++++++----- man/manip_paths.Rd | 2 +- 3 files changed, 14 insertions(+), 6 deletions(-) diff --git a/NEWS.md b/NEWS.md index eb6a5c92..0b5e9795 100644 --- a/NEWS.md +++ b/NEWS.md @@ -5,6 +5,10 @@ - Improved `to_no_missing()` to record missing removal - Improved `to_no_isolates()` to record isolate removal - Improved `to_giant()` to record giant component scoping +- Improved `to_matching()` to record matching +- Improved `to_mentoring()` to record mentoring +- Improved `to_eulerian()` to record Eulerian pathing + # manynet 1.5.1 ## Package diff --git a/R/manip_reformed.R b/R/manip_reformed.R index 66b0f455..eb80ba75 100644 --- a/R/manip_reformed.R +++ b/R/manip_reformed.R @@ -575,7 +575,7 @@ NULL #' #' Goldberg, Andrew V., and Robert E. Tarjan. 1986. #' "A new approach to the maximum flow problem". -#' _Proceedings of the eighteenth annual ACM symposium on Theory of computing – STOC '86_. +#' _Proceedings of the 18th Annual ACM Symposium on Theory of Computing_. #' 136-146. #' \doi{10.1145/12130.12144} #' @param mark A logical vector marking two types or modes. @@ -588,7 +588,8 @@ NULL #' to_matching(ison_southern_women) #' #graphr(to_matching(ison_southern_women)) #' @export -to_matching <- function(.data, mark = "type", capacities = NULL) UseMethod("to_matching") +to_matching <- function(.data, mark = "type", + capacities = NULL) UseMethod("to_matching") #' @export to_matching.igraph <- function(.data, mark = "type", capacities = NULL){ @@ -650,7 +651,8 @@ to_matching.igraph <- function(.data, mark = "type", capacities = NULL){ #' @export to_matching.tbl_graph <- function(.data, mark = "type", capacities = NULL){ - as_tidygraph(to_matching.igraph(.data, mark, capacities = capacities)) + as_tidygraph(to_matching.igraph(.data, mark, capacities = capacities)) %>% + add_info(name = paste(net_name(.data, prefix = "Stable matching of"))) } #' @export @@ -695,7 +697,8 @@ to_mentoring <- function(.data, elites = 0.1) UseMethod("to_mentoring") #' @export to_mentoring.tbl_graph <- function(.data, elites = 0.1){ - as_tidygraph(to_mentoring.igraph(.data, elites = elites)) + as_tidygraph(to_mentoring.igraph(.data, elites = elites)) %>% + add_info(name = paste(net_name(.data), "mentorship")) } #' @export @@ -769,7 +772,8 @@ to_eulerian.tbl_graph <- function(.data){ out <- paste(attr(igraph::eulerian_path(.data)$vpath, "names"), collapse = "-+") out <- create_explicit(out) - out + out %>% + add_info(name = paste(net_name(.data, prefix = "Eulerian path of"))) } #' @rdname manip_paths diff --git a/man/manip_paths.Rd b/man/manip_paths.Rd index f62c282e..42c4fca4 100644 --- a/man/manip_paths.Rd +++ b/man/manip_paths.Rd @@ -124,7 +124,7 @@ Gale, David, and Lloyd Stowell Shapley. 1962. Goldberg, Andrew V., and Robert E. Tarjan. 1986. "A new approach to the maximum flow problem". -\emph{Proceedings of the eighteenth annual ACM symposium on Theory of computing – STOC '86}. +\emph{Proceedings of the 18th Annual ACM Symposium on Theory of Computing}. 136-146. \doi{10.1145/12130.12144} } From a7a503f8fa4d4a6805c79bb86fb2782ccb91afa0 Mon Sep 17 00:00:00 2001 From: David Schoch Date: Mon, 30 Jun 2025 08:36:12 +0200 Subject: [PATCH 03/24] better NA handling in data frames --- R/manip_reformed.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/manip_reformed.R b/R/manip_reformed.R index e3144dc8..dd56d2b9 100644 --- a/R/manip_reformed.R +++ b/R/manip_reformed.R @@ -594,8 +594,8 @@ to_matching.igraph <- function(.data, mark = "type", capacities = NULL){ el <- igraph::max_bipartite_match(.data, types = node_attribute(.data, mark))$matching el <- data.frame(from = names(el), to = el) - out <- suppressWarnings(as_igraph(el, twomode = TRUE)) - out <- igraph::delete_vertices(out, "NA") + el <- el[!is.na(el$to) & !is.na(el$from), ] + out <- as_igraph(el, twomode = TRUE) out <- to_twomode(out, node_attribute(.data, mark)) } else { if(length(capacities) == 1) From 7de9fac7430062546b96fe448d20b8367cdd885e Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 30 Jun 2025 12:08:44 +0200 Subject: [PATCH 04/24] only use `+.ggplot` when both sides are ggplot --- R/manynet-utils.R | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/R/manynet-utils.R b/R/manynet-utils.R index 36aa8688..6fb34fe0 100644 --- a/R/manynet-utils.R +++ b/R/manynet-utils.R @@ -42,8 +42,12 @@ thisRequiresBio <- function(pkgname) { #' @export `+.ggplot` <- function(e1, e2, ...) { - thisRequires("patchwork") - patchwork::wrap_plots(e1, e2, ...) + if (inherits(e2, c("ggplot", "ggplot2::ggplot"))) { + thisRequires("patchwork") + patchwork::wrap_plots(e1, e2, ...) + } else { + NextMethod() + } } seq_nodes <- function(.data){ From ef37bd231ace170ad6e535754a3c492a6af27bfe Mon Sep 17 00:00:00 2001 From: schochastics Date: Thu, 3 Jul 2025 13:22:27 +0200 Subject: [PATCH 05/24] added dummy node for NA node --- R/manip_reformed.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/R/manip_reformed.R b/R/manip_reformed.R index dd56d2b9..954d7f7f 100644 --- a/R/manip_reformed.R +++ b/R/manip_reformed.R @@ -594,8 +594,10 @@ to_matching.igraph <- function(.data, mark = "type", capacities = NULL){ el <- igraph::max_bipartite_match(.data, types = node_attribute(.data, mark))$matching el <- data.frame(from = names(el), to = el) - el <- el[!is.na(el$to) & !is.na(el$from), ] + el$from[is.na(el$from)] <- "dummy" + el$to[is.na(el$to)] <- "dummy" out <- as_igraph(el, twomode = TRUE) + out <- igraph::delete_vertices(out, "dummy") out <- to_twomode(out, node_attribute(.data, mark)) } else { if(length(capacities) == 1) From 2c3b05afcd4de15988f5d7f0770533ac15921b43 Mon Sep 17 00:00:00 2001 From: James Hollway Date: Thu, 3 Jul 2025 16:53:36 +0200 Subject: [PATCH 06/24] Added to_matching() testing --- R/manip_reformed.R | 1 - man/manip_paths.Rd | 1 - tests/testthat/test-manip_reformed.R | 12 ++++++++++++ 3 files changed, 12 insertions(+), 2 deletions(-) diff --git a/R/manip_reformed.R b/R/manip_reformed.R index 4f7dc52c..9b463eaf 100644 --- a/R/manip_reformed.R +++ b/R/manip_reformed.R @@ -586,7 +586,6 @@ NULL #' @importFrom igraph max_bipartite_match #' @examples #' to_matching(ison_southern_women) -#' #graphr(to_matching(ison_southern_women)) #' @export to_matching <- function(.data, mark = "type", capacities = NULL) UseMethod("to_matching") diff --git a/man/manip_paths.Rd b/man/manip_paths.Rd index 42c4fca4..0f4f0868 100644 --- a/man/manip_paths.Rd +++ b/man/manip_paths.Rd @@ -109,7 +109,6 @@ This is, however, computationally slower. \examples{ to_matching(ison_southern_women) -#graphr(to_matching(ison_southern_women)) graphr(to_mentoring(ison_adolescents)) to_eulerian(delete_nodes(ison_koenigsberg, "Lomse")) #graphr(to_eulerian(delete_nodes(ison_koenigsberg, "Lomse"))) diff --git a/tests/testthat/test-manip_reformed.R b/tests/testthat/test-manip_reformed.R index 5afe68dd..d0f77e1e 100644 --- a/tests/testthat/test-manip_reformed.R +++ b/tests/testthat/test-manip_reformed.R @@ -1,3 +1,15 @@ +match_net <- to_matching(ison_southern_women) + +test_that("to_matching works with two-mode networks", { + expect_true(net_ties(match_net) == min(net_dims(ison_southern_women))) +}) + +test_that("to_matching is idempotent", { + match_twice <- to_matching(match_net) + expect_equal(as_edgelist(match_net), + as_edgelist(match_twice)) +}) + test_that("to_no_missing.tbl_graph removes nodes with missing values", { # Create a tbl_graph with some missing values graph <- tbl_graph( From 2cec7d83c90d4b07e92dfa7e3e768daceb3b6b4e Mon Sep 17 00:00:00 2001 From: James Hollway Date: Mon, 7 Jul 2025 15:27:21 +0200 Subject: [PATCH 07/24] Renamed node_coreness() to node_kcoreness() --- NAMESPACE | 1 + R/member_core.R | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index d70d1f4e..53cb9d0b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -632,6 +632,7 @@ export(node_is_pendant) export(node_is_random) export(node_is_recovered) export(node_is_universal) +export(node_kcoreness) export(node_kernighanlin) export(node_leading_eigen) export(node_leiden) diff --git a/R/member_core.R b/R/member_core.R index 8139593c..037a7ba2 100644 --- a/R/member_core.R +++ b/R/member_core.R @@ -90,9 +90,9 @@ node_is_core <- function(.data, method = c("degree", "eigenvector")){ #' @rdname mark_core #' @examples -#' node_coreness(ison_adolescents) +#' node_kcoreness(ison_adolescents) #' @export -node_coreness <- function(.data){ +node_kcoreness <- function(.data){ if(missing(.data)) {expect_nodes(); .data <- .G()} if(!manynet::is_graph(.data)) .data <- manynet::as_igraph(.data) out <- igraph::coreness(.data) From 003d7b917d5b98c921750a490b879d2f7a6d4164 Mon Sep 17 00:00:00 2001 From: James Hollway Date: Mon, 7 Jul 2025 15:28:39 +0200 Subject: [PATCH 08/24] node_coreness() now implements Borgatti and Everett's continuous coreness algorithm --- R/member_core.R | 29 +++++++++++++++++++++++++++-- 1 file changed, 27 insertions(+), 2 deletions(-) diff --git a/R/member_core.R b/R/member_core.R index 037a7ba2..f67f0745 100644 --- a/R/member_core.R +++ b/R/member_core.R @@ -2,8 +2,13 @@ #' @description #' These functions identify nodes belonging to (some level of) the core of a network: #' -#' - `node_is_core()` assigns nodes to either the core or periphery. -#' - `node_coreness()` assigns nodes to their level of k-coreness. +#' - `node_is_universal()` identifies whether nodes are adjacent to all other +#' nodes in the network. +#' - `node_is_core()` identifies whether nodes belong to the core of the +#' network, as opposed to the periphery. +#' - `node_coreness()` returns a continuous measure of how closely each node +#' resembles a typical core node. +#' - `node_kcoreness()` assigns nodes to their level of k-coreness. #' #' @inheritParams mark_is #' @param method Which method to use to identify cores and periphery. @@ -99,3 +104,23 @@ node_kcoreness <- function(.data){ make_node_measure(out, .data) } +#' @rdname mark_core +#' @examples +#' node_coreness(ison_adolescents) +#' @export +node_coreness <- function(.data) { + A <- as_matrix(.data) + n <- nrow(A) + obj_fun <- function(c) { + ideal <- outer(c, c) + val <- suppressWarnings(cor(as.vector(A), as.vector(ideal))) + if (!is.finite(val)) return(1e6) # Penalize non-finite values + return(-val) # Negative for maximization + } + # Initial guess: all nodes have coreness 0.5 + init <- rep(0.5, n) + result <- optim(init, obj_fun, method = "L-BFGS-B", lower = 0, upper = 1) + make_node_measure(result$par, .data) +} + + From 3f5387bf2be6422108787ab94e00eae8b3ecace7 Mon Sep 17 00:00:00 2001 From: James Hollway Date: Mon, 7 Jul 2025 15:30:38 +0200 Subject: [PATCH 09/24] net_core() now includes method options for calculating correlation, distance, ndiff, and diff --- R/measure_features.R | 52 ++++++++++++++++++++++++++++++++++++----- man/mark_core.Rd | 13 +++++++++-- man/measure_features.Rd | 28 +++++++++++++++------- 3 files changed, 77 insertions(+), 16 deletions(-) diff --git a/R/measure_features.R b/R/measure_features.R index 54a61794..3c1d60bc 100644 --- a/R/measure_features.R +++ b/R/measure_features.R @@ -33,22 +33,62 @@ NULL #' @rdname measure_features -#' @examples -#' net_core(ison_adolescents) -#' net_core(ison_southern_women) +#' @param method Which method of the following to use to calculate the fit of +#' the core assignment to a core-periphery model. +#' "correlation" calculates the correlation between the empirical network and +#' an ideal typical network, and "ident" calculates the Euclidean distances +#' between the same. +#' "ndiff", however, calculates how distinct the core and periphery groups are +#' based on the difference in coreness scores between the least core-like +#' member of the core and the most core-like member of the periphery. +#' "diff" is similar to "ndiff", but multiplies the raw "ndiff" score by the +#' square root of the size of the core, thus penalising large cores. +#' @section Core-Periphery: +#' `net_core()` calculates the Pearson correlation between the given network, +#' where the nodes in the core are assigned by some given mark, and an ideal +#' typical core-periphery network with the same number of nodes in the core +#' and the periphery. #' @references #' ## On core-periphery #' Borgatti, Stephen P., and Martin G. Everett. 2000. #' “Models of Core/Periphery Structures.” #' _Social Networks_ 21(4):375–95. #' \doi{10.1016/S0378-8733(99)00019-2} +#' @examples +#' net_core(ison_adolescents) +#' net_core(ison_southern_women) #' @export net_core <- function(.data, - mark = NULL){ + mark = NULL, + method = c("correlation","ident","ndiff", "diff")){ if(missing(.data)) {expect_nodes(); .data <- .G()} if(is.null(mark)) mark <- node_is_core(.data) - out <- stats::cor(c(as_matrix(.data)), - c(as_matrix(create_core(.data, mark = mark)))) + + method <- match.arg(method) + if(method == "correlation"){ + out <- stats::cor(c(as_matrix(.data)), + c(as_matrix(create_core(.data, mark = mark)))) + } else if(method == "ident"){ + out <- sqrt(sum((as_matrix(.data) - + as_matrix(create_core(.data, mark = mark)))^2)) + } else if(method %in% c("ndiff","diff")){ + # Sort nodes by coreness + c_scores <- node_coreness(.data) + core <- c_scores[mark] + periphery <- c_scores[!mark] + + min_core <- min(core) + max_periphery <- max(periphery) + + diff1 <- sum(min_core - periphery) + diff2 <- sum(core - max_periphery) + + if(method == "ndiff"){ + out <- (diff1 + diff2) / length(c_scores) # Normalize + } else if(method == "diff"){ + out <- (diff1 + diff2) * sqrt(sum(mark)) + } + } else snet_unavailable(method) make_network_measure(out, .data, call = deparse(sys.call())) } diff --git a/man/mark_core.Rd b/man/mark_core.Rd index 6143dee3..7f3c805e 100644 --- a/man/mark_core.Rd +++ b/man/mark_core.Rd @@ -4,6 +4,7 @@ \alias{mark_core} \alias{node_is_universal} \alias{node_is_core} +\alias{node_kcoreness} \alias{node_coreness} \title{Core-periphery clustering algorithms} \usage{ @@ -11,6 +12,8 @@ node_is_universal(.data) node_is_core(.data, method = c("degree", "eigenvector")) +node_kcoreness(.data) + node_coreness(.data) } \arguments{ @@ -33,8 +36,13 @@ can be added if there is interest.} \description{ These functions identify nodes belonging to (some level of) the core of a network: \itemize{ -\item \code{node_is_core()} assigns nodes to either the core or periphery. -\item \code{node_coreness()} assigns nodes to their level of k-coreness. +\item \code{node_is_universal()} identifies whether nodes are adjacent to all other +nodes in the network. +\item \code{node_is_core()} identifies whether nodes belong to the core of the +network, as opposed to the periphery. +\item \code{node_coreness()} returns a continuous measure of how closely each node +resembles a typical core node. +\item \code{node_kcoreness()} assigns nodes to their level of k-coreness. } } \section{Universal/dominating node}{ @@ -68,6 +76,7 @@ node_is_core(ison_adolescents) #ison_adolescents \%>\% # mutate(corep = node_is_core()) \%>\% # graphr(node_color = "corep") +node_kcoreness(ison_adolescents) node_coreness(ison_adolescents) } \references{ diff --git a/man/measure_features.Rd b/man/measure_features.Rd index f119f997..05666148 100644 --- a/man/measure_features.Rd +++ b/man/measure_features.Rd @@ -14,7 +14,11 @@ \code{{signnet}} by David Schoch } \usage{ -net_core(.data, mark = NULL) +net_core( + .data, + mark = NULL, + method = c("correlation", "ident", "ndiff", "diff") +) net_richclub(.data) @@ -41,13 +45,6 @@ net_balance(.data) \item{mark}{A logical vector the length of the nodes in the network. This can be created by, among other things, any \verb{node_is_*()} function.} -\item{membership}{A vector of partition membership.} - -\item{resolution}{A proportion indicating the resolution scale. -By default 1, which returns the original definition of modularity. -The higher this parameter, the more smaller communities will be privileged. -The lower this parameter, the fewer larger communities are likely to be found.} - \item{method}{There are three small-world measures implemented: \itemize{ \item "sigma" is the original equation from Watts and Strogatz (1998), @@ -72,6 +69,13 @@ with the same dimensions. but where there may not be a network for which \eqn{SWI = 1}. }} +\item{membership}{A vector of partition membership.} + +\item{resolution}{A proportion indicating the resolution scale. +By default 1, which returns the original definition of modularity. +The higher this parameter, the more smaller communities will be privileged. +The lower this parameter, the fewer larger communities are likely to be found.} + \item{times}{Integer of number of simulations.} } \description{ @@ -100,6 +104,14 @@ ranging between \code{0} if all triangles are imbalanced and These \verb{net_*()} functions return a single numeric scalar or value. } +\section{Core-Periphery}{ + +\code{net_core()} calculates the Pearson correlation between the given network, +where the nodes in the core are assigned by some given mark, and an ideal +typical core-periphery network with the same number of nodes in the core +and the periphery. +} + \section{Modularity}{ Modularity measures the difference between the number of ties within each community From 9775e5a52eb619d0df229dc89ee7b92102c8942c Mon Sep 17 00:00:00 2001 From: James Hollway Date: Mon, 7 Jul 2025 15:31:16 +0200 Subject: [PATCH 10/24] Dropped the palettes from manynet --- NAMESPACE | 1 - R/map_autograph.R | 3 +++ R/map_palettes.R | 42 ------------------------------------------ man/map_palettes.Rd | 32 -------------------------------- 4 files changed, 3 insertions(+), 75 deletions(-) delete mode 100644 R/map_palettes.R delete mode 100644 man/map_palettes.Rd diff --git a/NAMESPACE b/NAMESPACE index 53cb9d0b..de734273 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -423,7 +423,6 @@ export(layout_tbl_graph_quad) export(layout_tbl_graph_railway) export(layout_tbl_graph_tetrad) export(layout_tbl_graph_triad) -export(many_palettes) export(mutate) export(mutate_changes) export(mutate_net) diff --git a/R/map_autograph.R b/R/map_autograph.R index 0d4c3ab2..b4f14a4e 100644 --- a/R/map_autograph.R +++ b/R/map_autograph.R @@ -1112,3 +1112,6 @@ remove_isolates <- function(edges_out, nodes_out) { dplyr::mutate(status = ifelse(is.na(status), FALSE, TRUE)) %>% dplyr::distinct() } + +colorsafe_palette <- c("#d73027", "#4575b4", "#1B9E77","#D95F02","#7570B3", + "#E7298A", "#66A61E","#E6AB02","#A6761D","#666666") diff --git a/R/map_palettes.R b/R/map_palettes.R deleted file mode 100644 index d1cf1128..00000000 --- a/R/map_palettes.R +++ /dev/null @@ -1,42 +0,0 @@ -#' Many palettes generator -#' -#' @param palette Name of desired palette. Current choices are: -#' \code{IHEID}, \code{Centres}, \code{SDGs}, \code{ETHZ}, \code{RUG}, -#' and \code{UZH}. -#' @param n Number of colors desired. If omitted, uses all colours. -#' @param type Either "continuous" or "discrete". Use continuous if you want -#' to automatically interpolate between colours. -#' @return A graphic display of colours in palette. -#' @name map_palettes -#' @source Adapted from \url{https://github.com/karthik/wesanderson/blob/master/R/colors.R} -#' @examples -#' many_palettes() -#' #many_palettes("IHEID") -#' @export -many_palettes <- function(palette, n, type = c("discrete", "continuous")) { - type <- match.arg(type) - if (missing(palette)) { - pal <- corp_palette(c("IHEID", "SDGs", "Centres", "ETHZ", "RUG", "UZH")) - } else pal <- corp_palette(palette) - if (is.null(pal)) - snet_abort("Palette not found.") - if (missing(n)) { - n <- length(pal) - } - if (type == "discrete" && n > length(pal)) { - snet_abort("Number of requested colors greater than what palette can offer") - } - x <- switch(type, continuous = grDevices::colorRampPalette(pal)(n), - discrete = pal[1:n]) - old <- graphics::par(mar = c(0.5, 0.5, 0.5, 0.5)) - on.exit(graphics::par(old)) - graphics::image(1:n, 1, as.matrix(1:n), col = x, - ylab = "", xaxt = "n", yaxt = "n", bty = "n") - graphics::rect(0, 0.9, n + 1, 1.1, col = grDevices::rgb(1, 1, 1, 0.8), - border = NA) - graphics::text(c(seq_len(n)), 1, labels = attr(x, "name"), - cex = 0.9, family = "serif", srt = 90) -} - -colorsafe_palette <- c("#d73027", "#4575b4", "#1B9E77","#D95F02","#7570B3", - "#E7298A", "#66A61E","#E6AB02","#A6761D","#666666") diff --git a/man/map_palettes.Rd b/man/map_palettes.Rd deleted file mode 100644 index 8c086ea9..00000000 --- a/man/map_palettes.Rd +++ /dev/null @@ -1,32 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/map_palettes.R -\name{map_palettes} -\alias{map_palettes} -\alias{many_palettes} -\title{Many palettes generator} -\source{ -Adapted from \url{https://github.com/karthik/wesanderson/blob/master/R/colors.R} -} -\usage{ -many_palettes(palette, n, type = c("discrete", "continuous")) -} -\arguments{ -\item{palette}{Name of desired palette. Current choices are: -\code{IHEID}, \code{Centres}, \code{SDGs}, \code{ETHZ}, \code{RUG}, -and \code{UZH}.} - -\item{n}{Number of colors desired. If omitted, uses all colours.} - -\item{type}{Either "continuous" or "discrete". Use continuous if you want -to automatically interpolate between colours.} -} -\value{ -A graphic display of colours in palette. -} -\description{ -Many palettes generator -} -\examples{ -many_palettes() -#many_palettes("IHEID") -} From 541dddfebd740e27249e44e713bdc384cf52451d Mon Sep 17 00:00:00 2001 From: James Hollway Date: Fri, 22 Aug 2025 15:02:37 +0200 Subject: [PATCH 11/24] Dropped remaining layouts --- R/map_layouts.R | 565 -------------------------------- man/map_layout_configuration.Rd | 54 --- man/map_layout_partition.Rd | 130 -------- 3 files changed, 749 deletions(-) delete mode 100644 R/map_layouts.R delete mode 100644 man/map_layout_configuration.Rd delete mode 100644 man/map_layout_partition.Rd diff --git a/R/map_layouts.R b/R/map_layouts.R deleted file mode 100644 index 7e55dfe8..00000000 --- a/R/map_layouts.R +++ /dev/null @@ -1,565 +0,0 @@ -# Configurational #### - -#' Layout algorithms based on configurational positions -#' -#' @description -#' Configurational layouts locate nodes at symmetric coordinates -#' to help illustrate particular configurations. -#' Currently "triad" and "quad" layouts are available. -#' The "configuration" layout will choose the appropriate configurational -#' layout automatically. -#' -#' @name map_layout_configuration -#' @family mapping -#' @inheritParams map_layout_partition -NULL - -#' @rdname map_layout_configuration -#' @export -layout_tbl_graph_configuration <- function(.data, - circular = FALSE, times = 1000){ - if (net_nodes(.data) == 2) { - layout_tbl_graph_dyad(.data, circular = circular, times = times) - } else if (net_nodes(.data) == 3) { - layout_tbl_graph_triad(.data, circular = circular, times = times) - } else if (net_nodes(.data) == 4) { - layout_tbl_graph_tetrad(.data, circular = circular, times = times) - } else if (net_nodes(.data) == 5) { - layout_tbl_graph_pentad(.data, circular = circular, times = times) - } else if (net_nodes(.data) == 6) { - layout_tbl_graph_hexad(.data, circular = circular, times = times) - } -} - -#' @rdname map_layout_configuration -#' @export -layout_tbl_graph_dyad <- function(.data, - circular = FALSE, times = 1000){ - res <- matrix(c(0,0, - 1,0), 2, 2, byrow = TRUE) - .to_lo(res) -} - -#' @rdname map_layout_configuration -#' @export -layout_tbl_graph_triad <- function(.data, - circular = FALSE, times = 1000){ - res <- matrix(c(0,0, - 2,3.5, - 4,0), 3, 2, byrow = TRUE) - .to_lo(res) -} - -#' @rdname map_layout_configuration -#' @export -layout_tbl_graph_tetrad <- function(.data, - circular = FALSE, times = 1000){ - res <- matrix(c(0,0, - 0,1, - 1,0, - 1,1), 4, 2, byrow = TRUE) - .to_lo(res) -} - -#' @rdname map_layout_configuration -#' @export -layout_tbl_graph_pentad <- function(.data, - circular = FALSE, times = 1000){ - res <- matrix(c(0,1, - -0.9511,0.3090, - -0.5878,-0.8090, - 0.5878,-0.8090, - 0.9511,0.3090), 5, 2, byrow = TRUE) - .to_lo(res) -} - -#' @rdname map_layout_configuration -#' @export -layout_tbl_graph_hexad <- function(.data, - circular = FALSE, times = 1000){ - res <- matrix(c(1,0, - 1/2,sqrt(3)/2, - -1/2,sqrt(3)/2, - -1,0, - -1/2,-sqrt(3)/2, - 1/2,-sqrt(3)/2), 6, 2, byrow = TRUE) - .to_lo(res) -} - -# Partitions #### - -#' Layout algorithms based on bi- or other partitions -#' -#' @description -#' These algorithms layout networks based on two or more partitions, -#' and are recommended for use with `graphr()` or `{ggraph}`. -#' Note that these layout algorithms use `{Rgraphviz}`, -#' a package that is only available on Bioconductor. -#' It will first need to be downloaded using `BiocManager::install("Rgraphviz")`. -#' If it has not already been installed, there is a prompt the first time -#' these functions are used though. -#' -#' The "hierarchy" layout layers the first node set along the bottom, -#' and the second node set along the top, -#' sequenced and spaced as necessary to minimise edge overlap. -#' The "alluvial" layout is similar to "hierarchy", -#' but places successive layers horizontally rather than vertically. -#' The "railway" layout is similar to "hierarchy", -#' but nodes are aligned across the layers. -#' The "ladder" layout is similar to "railway", -#' but places successive layers horizontally rather than vertically. -#' The "concentric" layout places a "hierarchy" layout -#' around a circle, with successive layers appearing as concentric circles. -#' The "multilevel" layout places successive layers as multiple levels. -#' The "lineage" layout ranks nodes in Y axis according to values. -#' @name map_layout_partition -#' @inheritParams mark_is -#' @param circular Should the layout be transformed into a radial representation. -#' Only possible for some layouts. Defaults to FALSE. -#' @param times Maximum number of iterations, where appropriate -#' @param radius A vector of radii at which the concentric circles -#' should be located for "concentric" layout. -#' By default this is equal placement around an empty centre, -#' unless one (the core) is a single node, -#' in which case this node occupies the centre of the graph. -#' @param order.by An attribute label indicating the (decreasing) order -#' for the nodes around the circles for "concentric" layout. -#' By default ordering is given by a bipartite placement that reduces -#' the number of edge crossings. -#' @param membership A node attribute or a vector to draw concentric circles -#' for "concentric" layout. -#' @param center Further split "hierarchical" layouts by -#' declaring the "center" argument as the "events", "actors", -#' or by declaring a node name in hierarchy layout. -#' Defaults to NULL. -#' @param level A node attribute or a vector to hierarchically order levels for -#' "multilevel" layout. -#' @param rank A numerical node attribute to place nodes in Y axis -#' according to values for "lineage" layout. -#' @family mapping -#' @source -#' Diego Diez, Andrew P. Hutchins and Diego Miranda-Saavedra. 2014. -#' "Systematic identification of transcriptional regulatory modules from -#' protein-protein interaction networks". -#' _Nucleic Acids Research_, 42 (1) e6. -NULL - -#' @rdname map_layout_partition -#' @examples -#' #graphr(ison_southern_women, layout = "hierarchy", center = "events", -#' # node_color = "type", node_size = 3) -#' @export -layout_tbl_graph_hierarchy <- function(.data, center = NULL, - circular = FALSE, times = 1000) { - if (is.null(center)) { - thisRequiresBio("Rgraphviz") - prep <- as_matrix(.data) - if (anyDuplicated(rownames(prep))) { - rownames(prep) <- seq_len(nrow(prep)) - colnames(prep) <- seq_len(ncol(prep)) + max(nrow(prep)) - } - if (any(prep<0)) prep[prep<0] <- 0 - out <- as_graphAM(prep) - out <- suppressMessages(Rgraphviz::layoutGraph(out, layoutType = 'dot', - attrs = list(graph = list(rankdir = "BT")))) - nodeX <- .rescale(out@renderInfo@nodes$nodeX) - nodeY <- .rescale(out@renderInfo@nodes$nodeY) - if (is_twomode(.data) & "name" %in% igraph::vertex_attr_names(.data)) { - names <- igraph::vertex_attr(.data, "name") - nodeX <- nodeX[order(match(names(nodeX), names))] - nodeY <- nodeY[order(match(names(nodeY), names))] - } - # nodeY <- abs(nodeY - max(nodeY)) - out <- .to_lo(cbind(nodeX, nodeY)) - } else { - if (!is_twomode(.data)) snet_abort("Please declare a two-mode network.") - net <- as_matrix(.data) - nn <- dim(net)[1] - mm <- dim(net)[2] - if (center == "actors") { - Act <- cbind(rep(1, nrow(net)), nrm(rng(nn))) - Evt1 <- cbind(rep(0, ceiling(ncol(net)/2)), nrm(rng(ceiling(mm/2)))) - Evt2 <- cbind(rep(2, floor(ncol(net)/2)), nrm(rng(floor(mm/2)))) - crd <- rbind(Act, Evt1, Evt2) - crd[which(is.nan(crd))] <- 0.5 - rownames(crd) <- c(dimnames(net)[[1]], dimnames(net)[[2]]) - } else if (center == "events") { - Act1 <- cbind(rep(0, ceiling(nrow(net)/2)), nrm(rng(ceiling(nn/2)))) - Act2 <- cbind(rep(2, floor(nrow(net)/2)), nrm(rng(floor(nn/2)))) - Evt <- cbind(rep(1, ncol(net)), nrm(rng(mm))) - crd <- rbind(Act1, Act2, Evt) - crd[which(is.nan(crd))] <- 0.5 - rownames(crd) <- c(dimnames(net)[[1]], dimnames(net)[[2]]) - } else { - if (center %in% node_names(.data)) { - side1 <- suppressWarnings(cbind(rep(0, nrow(net)), nrm(rng(nn)))) - side2 <- suppressWarnings(cbind(rep(2, ncol(net)), nrm(rng(mm)))) - if (any(rownames(net) == center)) { - side1[,1] <- ifelse(rownames(net) == center, 1, side1[,1]) - side1[,2] <- ifelse(rownames(net) == center, 0.5, side1[,2]) - } else { - side2[,1] <- ifelse(rownames(net) == center, 1, side2[,1]) - side2[,2] <- ifelse(rownames(net) == center, 0.5, side2[,2]) - } - crd <- rbind(side1, side2) - crd[which(is.nan(crd))] <- 0.5 - rownames(crd) <- c(dimnames(net)[[1]], dimnames(net)[[2]]) - } else snet_abort("Please declare actors, events, or a node name as center.") - } - out <- .to_lo(crd) - } - out -} - -#' @rdname map_layout_partition -#' @examples -#' #graphr(ison_southern_women, layout = "alluvial") -#' @export -layout_tbl_graph_alluvial <- function(.data, - circular = FALSE, times = 1000){ - thisRequiresBio("Rgraphviz") - prep <- as_matrix(.data, twomode = FALSE) - if(anyDuplicated(rownames(prep))){ - rownames(prep) <- seq_len(nrow(prep)) - colnames(prep) <- seq_len(ncol(prep)) - } - if(any(prep<0)) prep[prep<0] <- 0 - out <- as_graphAM(prep) - out <- suppressMessages(Rgraphviz::layoutGraph(out, layoutType = 'dot', - attrs = list(graph = list(rankdir = "LR")))) - nodeX <- .rescale(out@renderInfo@nodes$nodeX) - nodeY <- .rescale(out@renderInfo@nodes$nodeY) - # nodeY <- abs(nodeY - max(nodeY)) - .to_lo(cbind(nodeX, nodeY)) -} - -#' @rdname map_layout_partition -#' @export -layout_tbl_graph_railway <- function(.data, - circular = FALSE, times = 1000) { - res <- layout_tbl_graph_hierarchy(as_igraph(.data)) - res$x <- c(match(res[res[,2]==0,1], sort(res[res[,2]==0,1])), - match(res[res[,2]==1,1], sort(res[res[,2]==1,1]))) - res -} - -#' @rdname map_layout_partition -#' @export -layout_tbl_graph_ladder <- function(.data, - circular = FALSE, times = 1000){ - res <- layout_tbl_graph_alluvial(as_igraph(.data)) - res$y <- c(match(res[res[,2]==1,1], sort(res[res[,2]==1,1])), - match(res[res[,2]==0,1], sort(res[res[,2]==0,1]))) - res -} - -#' @rdname map_layout_partition -#' @examples -#' #graphr(ison_southern_women, layout = "concentric", membership = "type", -#' # node_color = "type", node_size = 3) -#' @export -layout_tbl_graph_concentric <- function(.data, membership, - radius = NULL, - order.by = NULL, - circular = FALSE, times = 1000) { - if (any(igraph::vertex_attr(.data, "name") == "")) { - ll <- unlist(lapply(seq_len(length(.data)), function(x) { - ifelse(igraph::vertex_attr(.data, "name")[x] == "", - paste0("ramdom", x), igraph::vertex_attr(.data, "name")[x]) - })) - .data <- set_vertex_attr(.data, "name", value = ll) - } - if (missing(membership)) { - if (is_twomode(.data)) membership <- node_is_mode(.data) else - snet_abort("Please pass the function a `membership` node attribute or a vector.") - } else { - if (length(membership) > 1 & length(membership) != length(.data)) { - snet_abort("Please pass the function a `membership` node attribute or a vector.") - } else if (length(membership) != length(.data)) { - membership <- node_attribute(.data, membership) - } - } - names(membership) <- node_names(.data) - membership <- to_list(membership) - all_c <- unlist(membership, use.names = FALSE) - if (any(table(all_c) > 1)) snet_abort("Duplicated nodes in layers!") - if (is_labelled(.data)) all_n <- node_names(.data) else all_n <- 1:net_nodes(.data) - sel_other <- all_n[!all_n %in% all_c] - if (length(sel_other) > 0) membership[[length(membership) + 1]] <- sel_other - if (is.null(radius)) { - radius <- seq(0, 1, 1/(length(membership))) - if (length(membership[[1]]) == 1) - radius <- radius[-length(radius)] else radius <- radius[-1] - } - if (!is.null(order.by)) { - order.values <- lapply(order.by, - function(b) node_attribute(.data, b)) - } else { - if (is_twomode(.data) & length(membership) == 2) { - xnet <- as_matrix(to_multilevel(.data))[membership[[2-1]], - membership[[2]]] - lo <- layout_tbl_graph_hierarchy(as_igraph(xnet, twomode = TRUE)) - lo$names <- node_names(.data) - if (ncol(lo) == 2) lo[,1] <- seq_len(dim(lo)[1]) - order.values <- lapply(1:0, function(x) - if(ncol(lo) >= 3) sort(lo[lo[,2] == x,])[,3] - else sort(lo[lo[,2] == x,1])) - } else order.values <- membership[order(sapply(membership, length))] - # order.values <- getNNvec(.data, members) - } - res <- matrix(NA, nrow = length(all_n), ncol = 2) - for (k in seq_along(membership)) { - r <- radius[k] - l <- order.values[[k]] - if(is_labelled(.data)) - l <- match(l, node_names(.data)) - res[l, ] <- getCoordinates(l, r) - } - .to_lo(res) -} - -#' @rdname map_layout_partition -#' @examples -#' #graphr(ison_lotr, layout = "multilevel", -#' # node_color = "Race", level = "Race", node_size = 3) -#' @export -layout_tbl_graph_multilevel <- function(.data, level, circular = FALSE) { - if (missing(level)) { - if (any(grepl("lvl", names(node_attribute(.data))))) { - message("Level attribute 'lvl' found in data.") - } else { - snet_abort("Please pass the function a `level` node attribute or a vector.") - } - } else { - if (length(level) > 1 & length(level) != length(.data)) { - snet_abort("Please pass the function a `level` node attribute or a vector.") - } else if (length(level) != length(.data)) { - level <- as.factor(node_attribute(.data, level)) - } - } - out <- igraph::set_vertex_attr(.data, "lvl", value = level) - thisRequires("graphlayouts") - out <- graphlayouts::layout_as_multilevel(out, alpha = 25) - .to_lo(out) -} - -#' @rdname map_layout_partition -#' @examples -#' # ison_adolescents %>% -#' # mutate(year = rep(c(1985, 1990, 1995, 2000), times = 2), -#' # cut = node_is_cutpoint(ison_adolescents)) %>% -#' # graphr(layout = "lineage", rank = "year", node_color = "cut", -#' # node_size = migraph::node_degree(ison_adolescents)*10) -#' @export -layout_tbl_graph_lineage <- function(.data, rank, circular = FALSE) { - if (length(rank) > 1 & length(rank) != length(.data)) { - snet_abort("Please pass the function a `rank` node attribute or a vector.") - } else if (length(rank) != length(.data)) { - rank <- as.numeric(node_attribute(.data, rank)) - } - thisRequiresBio("Rgraphviz") - out <- layout_tbl_graph_alluvial( - as_igraph(mutate(.data, type = ifelse( - rank > mean(rank), TRUE, FALSE)), twomode = TRUE)) - out$x <- .rescale(rank) - .check_dup(out) -} - -.rescale <- function(vector){ - (vector - min(vector)) / (max(vector) - min(vector)) -} - -.to_lo <- function(mat) { - res <- as.data.frame(mat) - names(res) <- c("x","y") - res -} - -to_list <- function(members) { - out <- lapply(sort(unique(members)), function(x){ - y <- which(members==x) - if(!is.null(names(y))) names(y) else y - }) - names(out) <- unique(members) - out -} - -.check_dup <- function(mat) { - mat$y <- ifelse(duplicated(mat[c('x','y')]), mat$y*0.95, mat$y) - mat -} - -#' @importFrom igraph degree -getNNvec <- function(.data, members){ - lapply(members, function(circle){ - diss <- 1 - stats::cor(to_multilevel(as_matrix(.data))[, circle]) - diag(diss) <- NA - if(is_labelled(.data)) - starts <- names(sort(igraph::degree(.data)[circle], decreasing = TRUE)[1]) - else starts <- paste0("V",1:net_nodes(.data))[sort(igraph::degree(.data)[circle], - decreasing = TRUE)[1]] - if(length(circle)>1) - starts <- c(starts, names(which.min(diss[starts,]))) - out <- starts - if(length(circle)>2){ - for(i in 1:(length(circle)-2)){ - diss <- diss[,!colnames(diss) %in% starts] - if(is.matrix(diss)){ - side <- names(which.min(apply(diss[starts,], 1, min, na.rm = TRUE))) - new <- names(which.min(diss[side,])) - } else { - side <- names(which.min(diss[starts])) - new <- setdiff(circle,out) - } - if(side == out[1]){ - out <- c(new, out) - starts <- c(new, starts[2]) - } else { - out <- c(out, new) - starts <- c(starts[1], new) - } - } - } - out - }) -} - -getCoordinates <- function(x, r) { - l <- length(x) - d <- 360/l - c1 <- seq(0, 360, d) - c1 <- c1[1:(length(c1) - 1)] - tmp <- t(vapply(c1, - function(cc) c(cos(cc * pi/180) * - r, sin(cc * - pi/180) * r), - FUN.VALUE = numeric(2))) - rownames(tmp) <- x - tmp -} - -rng <- function(r) { - if (r == 1L) return(0) - if (r > 1L) { - x <- vector() - x <- append(x, (-1)) - for (i in 1:(r - 1)) x <- append(x, ((-1) + (2L/(r - 1L)) * i)) - return(x * (r/50L)) - } else snet_abort("no negative values") -} - -nrm <- function(x, digits = 3) { - if (isTRUE(length(x) == 1L) == TRUE) return(x) - if (is.array(x) == TRUE) { - xnorm <- (x[, 1] - min(x[, 1]))/(max(x[, 1]) - min(x[, 1])) - rat <- (max(x[, 1]) - min(x[, 1]))/(max(x[, 2]) - min(x[, 2])) - ynorm <- ((x[, 2] - min(x[, 2]))/(max(x[, 2]) - min(x[, 2]))) * (rat) - ifelse(isTRUE(rat > 0) == FALSE, - ynorm <- ((x[, 2] - min(x[, 2]))/(max(x[, 2]) - - min(x[, 2]))) * (1L/rat), NA) - return(round(data.frame(X = xnorm, Y = ynorm), digits)) - } - else if (is.vector(x) == TRUE) { - return(round((x - min(x))/(max(x) - min(x)), digits)) - } -} - -# Grid #### - -#' Layouts for snapping layouts to a grid -#' -#' @description The function uses approximate pattern matching -#' to redistribute coarse layouts on square grid points, while -#' preserving the topological relationships among the nodes (see Inoue et al. 2012). -#' @references -#' Inoue, Kentaro, Shinichi Shimozono, Hideaki Yoshida, and Hiroyuki Kurata. 2012. -#' “Application of Approximate Pattern Matching in Two Dimensional Spaces to Grid Layout for Biochemical Network Maps” edited by J. Bourdon. -#' _PLoS ONE_ 7(6):e37739. -#' \doi{https://doi.org/10.1371/journal.pone.0037739}. -#' @keywords internal -depth_first_recursive_search <- function(layout) { - if("ggraph" %in% class(layout)) layout <- layout$data[,c("x","y")] - layout <- as.data.frame(layout) - dims <- ceiling(2 * sqrt(nrow(layout))) - # evens <- 0:dims[0:dims %% 2 == 0] - vacant_points <- expand.grid(seq.int(0, dims, 1), seq.int(0, dims, 1)) # create options - vacant_points <- vacant_points - floor(dims / 2) # centre options - names(vacant_points) <- c("x", "y") - gridout <- layout[order(abs(layout[,1]) + abs(layout[,2])), ] # sort centroid distance - nodes <- seq_len(nrow(gridout)) - for (i in nodes) { - dists <- as.matrix(stats::dist(rbind(gridout[i, 1:2], vacant_points), - method = "manhattan"))[, 1] - mindist <- which(dists == min(dists[2:length(dists)]))[1] - 1 - vacpoint <- vacant_points[mindist, ] - changes <- vacpoint - gridout[i, 1:2] - gridout[nodes >= i, 1] <- gridout[nodes >= i, 1] + - changes[[1]] - gridout[nodes >= i, 2] <- gridout[nodes >= i, 2] + - changes[[2]] - vacant_points <- vacant_points[-mindist, ] - } - gridout[order(row.names(gridout)),] # reorder from centroid - # gridout - # plot(gridout[order(row.names(gridout)),]) -} - -# localmin <- function(layout, graph) { -# repeat { -# f0 <- sum(cost_function(layout, graph)) -# L <- get_vacant_points(layout) -# for (a in seq_len(nrow(layout))) { -# out <- t(apply(L, 1, function(y) { -# layout_new <- layout -# layout_new[a, 1:2] <- y -# c(a, y, sum(cost_function(layout_new, graph))) -# })) -# } -# if (out[which.min(out[, 4]), 4] < f0) { -# layout[out[which.min(out[, 4]), 1], 1:2] <- out[which.min(out[, 4]), 2:3] -# } else{ -# break -# } -# } -# layout -# } -# -# get_vacant_points <- function(layout) { -# all_points <- expand.grid(min(layout$x):max(layout$x), -# min(layout$y):max(layout$y)) -# names(all_points) <- c("x", "y") -# vacant_points <- rbind(all_points, -# layout[, c("x", "y")]) -# vacant_points <- subset(vacant_points, -# !(duplicated(vacant_points) | -# duplicated(vacant_points, fromLast = TRUE))) -# vacant_points -# } -# -# cost_function <- function(layout, graph, max_repulse_distance = max(layout[, 1]) * .75) { -# d <- as.matrix(dist(layout[, 1:2], method = "manhattan")) -# a <- as_matrix(graph) -# i <- diag(nrow(a)) -# m <- a + i -# w <- ifelse(m > 0, 3, -# ifelse(m == 0 & m %*% t(m) > 0, 0, -2)) # only three levels here -# # see Li and Kurata (2005: 2037) for more granulated option -# ifelse(w >= 0, w * d, w * min(d, max_repulse_distance)) -# } -# -# plot_gl <- function(x, tmax, tmin, rmin, fmin, ne, rc, p) { -# l <- index <- a <- NULL # initialize variables to avoid CMD check notes -# x <- as_tidygraph(x) -# lo <- ggraph::create_layout(x, layout = "igraph", algorithm = "randomly") -# lo[, 1] <- round(lo[, 1] * 1000) -# lo[, 2] <- round(lo[, 2] * 1000) -# dists <- as.matrix(dist(lo[, 1:2], method = "manhattan")) -# colMax <- function(data) apply(data, MARGIN = 1, FUN = max, na.rm = TRUE) -# diag(dists) <- NA -# rsep <- l * sum(ifelse(colMax(a / dists - 1) > 0, colMax(a / dists - 1), 0)) -# ggraph::ggraph(x, graph = lo) + -# ggraph::geom_edge_link(ggplot2::aes(alpha = ggplot2::stat(index)), -# show.legend = FALSE) + -# ggraph::geom_node_point() -# } - diff --git a/man/map_layout_configuration.Rd b/man/map_layout_configuration.Rd deleted file mode 100644 index 8f8e0f33..00000000 --- a/man/map_layout_configuration.Rd +++ /dev/null @@ -1,54 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/map_layouts.R -\name{map_layout_configuration} -\alias{map_layout_configuration} -\alias{layout_tbl_graph_configuration} -\alias{layout_tbl_graph_dyad} -\alias{layout_tbl_graph_triad} -\alias{layout_tbl_graph_tetrad} -\alias{layout_tbl_graph_pentad} -\alias{layout_tbl_graph_hexad} -\title{Layout algorithms based on configurational positions} -\usage{ -layout_tbl_graph_configuration(.data, circular = FALSE, times = 1000) - -layout_tbl_graph_dyad(.data, circular = FALSE, times = 1000) - -layout_tbl_graph_triad(.data, circular = FALSE, times = 1000) - -layout_tbl_graph_tetrad(.data, circular = FALSE, times = 1000) - -layout_tbl_graph_pentad(.data, circular = FALSE, times = 1000) - -layout_tbl_graph_hexad(.data, circular = FALSE, times = 1000) -} -\arguments{ -\item{.data}{An object of a manynet-consistent class: -\itemize{ -\item matrix (adjacency or incidence) from \code{{base}} R -\item edgelist, a data frame from \code{{base}} R or tibble from \code{{tibble}} -\item igraph, from the \code{{igraph}} package -\item network, from the \code{{network}} package -\item tbl_graph, from the \code{{tidygraph}} package -}} - -\item{circular}{Should the layout be transformed into a radial representation. -Only possible for some layouts. Defaults to FALSE.} - -\item{times}{Maximum number of iterations, where appropriate} -} -\description{ -Configurational layouts locate nodes at symmetric coordinates -to help illustrate particular configurations. -Currently "triad" and "quad" layouts are available. -The "configuration" layout will choose the appropriate configurational -layout automatically. -} -\seealso{ -Other mapping: -\code{\link{map_graphr}}, -\code{\link{map_graphs}}, -\code{\link{map_grapht}}, -\code{\link{map_layout_partition}} -} -\concept{mapping} diff --git a/man/map_layout_partition.Rd b/man/map_layout_partition.Rd deleted file mode 100644 index c30b378a..00000000 --- a/man/map_layout_partition.Rd +++ /dev/null @@ -1,130 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/map_layouts.R -\name{map_layout_partition} -\alias{map_layout_partition} -\alias{layout_tbl_graph_hierarchy} -\alias{layout_tbl_graph_alluvial} -\alias{layout_tbl_graph_railway} -\alias{layout_tbl_graph_ladder} -\alias{layout_tbl_graph_concentric} -\alias{layout_tbl_graph_multilevel} -\alias{layout_tbl_graph_lineage} -\title{Layout algorithms based on bi- or other partitions} -\source{ -Diego Diez, Andrew P. Hutchins and Diego Miranda-Saavedra. 2014. -"Systematic identification of transcriptional regulatory modules from -protein-protein interaction networks". -\emph{Nucleic Acids Research}, 42 (1) e6. -} -\usage{ -layout_tbl_graph_hierarchy( - .data, - center = NULL, - circular = FALSE, - times = 1000 -) - -layout_tbl_graph_alluvial(.data, circular = FALSE, times = 1000) - -layout_tbl_graph_railway(.data, circular = FALSE, times = 1000) - -layout_tbl_graph_ladder(.data, circular = FALSE, times = 1000) - -layout_tbl_graph_concentric( - .data, - membership, - radius = NULL, - order.by = NULL, - circular = FALSE, - times = 1000 -) - -layout_tbl_graph_multilevel(.data, level, circular = FALSE) - -layout_tbl_graph_lineage(.data, rank, circular = FALSE) -} -\arguments{ -\item{.data}{An object of a manynet-consistent class: -\itemize{ -\item matrix (adjacency or incidence) from \code{{base}} R -\item edgelist, a data frame from \code{{base}} R or tibble from \code{{tibble}} -\item igraph, from the \code{{igraph}} package -\item network, from the \code{{network}} package -\item tbl_graph, from the \code{{tidygraph}} package -}} - -\item{center}{Further split "hierarchical" layouts by -declaring the "center" argument as the "events", "actors", -or by declaring a node name in hierarchy layout. -Defaults to NULL.} - -\item{circular}{Should the layout be transformed into a radial representation. -Only possible for some layouts. Defaults to FALSE.} - -\item{times}{Maximum number of iterations, where appropriate} - -\item{membership}{A node attribute or a vector to draw concentric circles -for "concentric" layout.} - -\item{radius}{A vector of radii at which the concentric circles -should be located for "concentric" layout. -By default this is equal placement around an empty centre, -unless one (the core) is a single node, -in which case this node occupies the centre of the graph.} - -\item{order.by}{An attribute label indicating the (decreasing) order -for the nodes around the circles for "concentric" layout. -By default ordering is given by a bipartite placement that reduces -the number of edge crossings.} - -\item{level}{A node attribute or a vector to hierarchically order levels for -"multilevel" layout.} - -\item{rank}{A numerical node attribute to place nodes in Y axis -according to values for "lineage" layout.} -} -\description{ -These algorithms layout networks based on two or more partitions, -and are recommended for use with \code{graphr()} or \code{{ggraph}}. -Note that these layout algorithms use \code{{Rgraphviz}}, -a package that is only available on Bioconductor. -It will first need to be downloaded using \code{BiocManager::install("Rgraphviz")}. -If it has not already been installed, there is a prompt the first time -these functions are used though. - -The "hierarchy" layout layers the first node set along the bottom, -and the second node set along the top, -sequenced and spaced as necessary to minimise edge overlap. -The "alluvial" layout is similar to "hierarchy", -but places successive layers horizontally rather than vertically. -The "railway" layout is similar to "hierarchy", -but nodes are aligned across the layers. -The "ladder" layout is similar to "railway", -but places successive layers horizontally rather than vertically. -The "concentric" layout places a "hierarchy" layout -around a circle, with successive layers appearing as concentric circles. -The "multilevel" layout places successive layers as multiple levels. -The "lineage" layout ranks nodes in Y axis according to values. -} -\examples{ -#graphr(ison_southern_women, layout = "hierarchy", center = "events", -# node_color = "type", node_size = 3) -#graphr(ison_southern_women, layout = "alluvial") -#graphr(ison_southern_women, layout = "concentric", membership = "type", -# node_color = "type", node_size = 3) -#graphr(ison_lotr, layout = "multilevel", -# node_color = "Race", level = "Race", node_size = 3) -# ison_adolescents \%>\% -# mutate(year = rep(c(1985, 1990, 1995, 2000), times = 2), -# cut = node_is_cutpoint(ison_adolescents)) \%>\% -# graphr(layout = "lineage", rank = "year", node_color = "cut", -# node_size = migraph::node_degree(ison_adolescents)*10) -} -\seealso{ -Other mapping: -\code{\link{map_graphr}}, -\code{\link{map_graphs}}, -\code{\link{map_grapht}}, -\code{\link{map_layout_configuration}} -} -\concept{mapping} From 7edd80d5d334c457d0e02f1022e17795ba90d881 Mon Sep 17 00:00:00 2001 From: James Hollway Date: Fri, 22 Aug 2025 15:03:11 +0200 Subject: [PATCH 12/24] Dropped all the autograph*() functions --- NAMESPACE | 18 - R/map_autograph.R | 1117 --------------------------------------------- man/map_graphr.Rd | 141 ------ man/map_graphs.Rd | 60 --- man/map_grapht.Rd | 137 ------ 5 files changed, 1473 deletions(-) delete mode 100644 R/map_autograph.R delete mode 100644 man/map_graphr.Rd delete mode 100644 man/map_graphs.Rd delete mode 100644 man/map_grapht.Rd diff --git a/NAMESPACE b/NAMESPACE index de734273..df2fe101 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -329,9 +329,6 @@ export(as_network) export(as_nodelist) export(as_siena) export(as_tidygraph) -export(autographd) -export(autographr) -export(autographs) export(bind_node_attributes) export(bind_ties) export(clear_glossary) @@ -408,21 +405,6 @@ export(join_ties) export(k_elbow) export(k_silhouette) export(k_strict) -export(labs) -export(layout_tbl_graph_alluvial) -export(layout_tbl_graph_concentric) -export(layout_tbl_graph_configuration) -export(layout_tbl_graph_dyad) -export(layout_tbl_graph_hexad) -export(layout_tbl_graph_hierarchy) -export(layout_tbl_graph_ladder) -export(layout_tbl_graph_lineage) -export(layout_tbl_graph_multilevel) -export(layout_tbl_graph_pentad) -export(layout_tbl_graph_quad) -export(layout_tbl_graph_railway) -export(layout_tbl_graph_tetrad) -export(layout_tbl_graph_triad) export(mutate) export(mutate_changes) export(mutate_net) diff --git a/R/map_autograph.R b/R/map_autograph.R deleted file mode 100644 index b4f14a4e..00000000 --- a/R/map_autograph.R +++ /dev/null @@ -1,1117 +0,0 @@ -# Single graphs #### - -#' Easily graph networks with sensible defaults -#' -#' @description -#' This function provides users with an easy way to graph -#' (m)any network data for exploration, investigation, inspiration, -#' and communication. -#' -#' It builds upon `{ggplot2}` and `{ggraph}` to offer -#' pretty and extensible graphing solutions. -#' However, compared to those solutions, -#' `graphr()` contains various algorithms to provide better looking -#' graphs by default. -#' This means that just passing the function some network data -#' will often be sufficient to return a reasonable-looking graph. -#' -#' The function also makes it easy to modify many of the most -#' commonly adapted aspects of a graph, -#' including node and edge size, colour, and shape, -#' as arguments rather than additional functions that you need to remember. -#' These can be defined outright, e.g. `node_size = 8`, or -#' in reference to an attribute of the network, e.g. `node_size = "wealth"`. -#' -#' Lastly, `graphr()` uses `{ggplot2}`-related theme information, so -#' it is easy to make colour palette and fonts institution-specific and consistent. -#' See e.g. `theme_iheid()` for more. -#' -#' To learn more about what can be done visually, -#' try `run_tute("Visualisation")`. -#' @name map_graphr -#' @family mapping -#' @param .data A manynet-consistent object. -#' @param layout An igraph, ggraph, or manynet layout algorithm. -#' If not declared, defaults to "triad" for networks with 3 nodes, -#' "quad" for networks with 4 nodes, -#' "stress" for all other one mode networks, -#' or "hierarchy" for two mode networks. -#' For "hierarchy" layout, one can further split graph by -#' declaring the "center" argument as the "events", "actors", -#' or by declaring a node name. -#' For "concentric" layout algorithm please declare the "membership" as an -#' extra argument. -#' The "membership" argument expects either a quoted node attribute present -#' in data or vector with the same length as nodes to draw concentric circles. -#' For "multilevel" layout algorithm please declare the "level" -#' as extra argument. -#' The "level" argument expects either a quoted node attribute present -#' in data or vector with the same length as nodes to hierarchically -#' order categories. -#' If "level" is missing, function will look for 'lvl' node attribute in data. -#' The "lineage" layout ranks nodes in Y axis according to values. -#' For "lineage" layout algorithm please declare the "rank" -#' as extra argument. -#' The "rank" argument expects either a quoted node attribute present -#' in data or vector with the same length as nodes. -#' @param labels Logical, whether to print node names -#' as labels if present. -#' @param node_shape Node variable to be used for shaping the nodes. -#' It is easiest if this is added as a node attribute to -#' the graph before plotting. -#' Nodes can also be shaped by declaring a shape instead. -#' @param node_size Node variable to be used for sizing the nodes. -#' This can be any continuous variable on the nodes of the network. -#' Since this function expects this to be an existing variable, -#' it is recommended to calculate all node-related statistics prior -#' to using this function. -#' Nodes can also be sized by declaring a numeric size or vector instead. -#' @param node_color,node_colour Node variable to be used for coloring the nodes. -#' It is easiest if this is added as a node attribute to -#' the graph before plotting. -#' Nodes can also be colored by declaring a color instead. -#' @param node_group Node variable to be used for grouping the nodes. -#' It is easiest if this is added as a hull over -#' groups before plotting. -#' Group variables should have a minimum of 3 nodes, -#' if less, number groups will be reduced by -#' merging categories with lower counts into one called "other". -#' @param edge_color,edge_colour Tie variable to be used for coloring the nodes. -#' It is easiest if this is added as an edge or tie attribute -#' to the graph before plotting. -#' Edges can also be colored by declaring a color instead. -#' @param edge_size Tie variable to be used for sizing the edges. -#' This can be any continuous variable on the nodes of the network. -#' Since this function expects this to be an existing variable, -#' it is recommended to calculate all edge-related statistics prior -#' to using this function. -#' Edges can also be sized by declaring a numeric size or vector instead. -#' @param snap Logical scalar, whether the layout should be snapped to a grid. -#' @param ... Extra arguments to pass on to the layout algorithm, if necessary. -#' @return A `ggplot2::ggplot()` object. -#' The last plot can be saved to the file system using `ggplot2::ggsave()`. -#' @importFrom ggraph geom_edge_link geom_node_text geom_conn_bundle -#' get_con geom_node_point scale_edge_width_continuous geom_node_label -#' @importFrom ggplot2 aes arrow unit scale_color_brewer scale_fill_brewer -#' @examples -#' graphr(ison_adolescents) -#' ison_adolescents %>% -#' mutate(color = rep(c("introvert","extrovert"), times = 4), -#' size = ifelse(node_is_cutpoint(ison_adolescents), 6, 3)) %>% -#' mutate_ties(ecolor = rep(c("friends", "acquaintances"), times = 5)) %>% -#' graphr(node_color = "color", node_size = "size", -#' edge_size = 1.5, edge_color = "ecolor") -#' @export -graphr <- function(.data, layout, labels = TRUE, - node_color, node_shape, node_size, node_group, - edge_color, edge_size, snap = FALSE, ..., - node_colour, edge_colour) { - g <- as_tidygraph(.data) - if (missing(layout)) { - if (net_nodes(g) <= 6) { - layout <- "configuration" - } else if (is_twomode(g)) { - layout <- "hierarchy" - } else layout <- "stress" - } - if (missing(node_color) && missing(node_colour)) { - node_color <- NULL - } else if (missing(node_color)) { - node_color <- as.character(substitute(node_colour)) - } else { - node_color <- as.character(substitute(node_color)) - } - if (missing(node_shape)) node_shape <- NULL else - node_shape <- as.character(substitute(node_shape)) - if (missing(node_size)) node_size <- NULL else if (!is.numeric(node_size)) { - node_size <- as.character(substitute(node_size)) - } - if (missing(node_group)) node_group <- NULL else { - node_group <- as.character(substitute(node_group)) - g <- tidygraph::activate(g, "nodes") %>% - tidygraph::mutate(node_group = reduce_categories(g, node_group)) - } - if (missing(edge_color) && missing(edge_colour)) { - edge_color <- NULL - } else if (missing(edge_color)) { - edge_color <- as.character(substitute(edge_colour)) - } else { - edge_color <- as.character(substitute(edge_color)) - } - if (missing(edge_size)) edge_size <- NULL else if (!is.numeric(edge_size)) { - edge_size <- as.character(substitute(edge_size)) - } - # Add layout ---- - p <- .graph_layout(g, layout, labels, node_group, snap, ...) - # Add background ---- - if(getOption("mnet_background", default = "#FFFFFF")!="#FFFFFF") - p <- p + ggplot2::theme(panel.background = ggplot2::element_rect(fill = getOption("mnet_background", default = "#FFFFFF"))) - # Add edges ---- - p <- .graph_edges(p, g, edge_color, edge_size, node_size) - # Add nodes ---- - p <- .graph_nodes(p, g, node_color, node_shape, node_size) - # Add labels ---- - if (isTRUE(labels) & is_labelled(g)) { - p <- .graph_labels(p, g, layout) - } - # assign("last.warning", NULL, envir = baseenv()) # to avoid persistent ggrepel - p -} - -.graph_layout <- function(g, layout, labels, node_group, snap, ...) { - name <- NULL - dots <- list(...) - if ("x" %in% names(dots) & "y" %in% names(dots)) { - lo <- ggraph::create_layout(g, layout = "manual", - x = dots[["x"]], y = dots[["y"]]) - } else lo <- suppressWarnings(ggraph::create_layout(g, layout, ...)) - if ("graph" %in% names(attributes(lo))) { - if (!setequal(names(as.data.frame(attr(lo, "graph"))), names(lo))) { - for (n in setdiff(names(as.data.frame(attr(lo, "graph"))), names(lo))) { - lo[n] <- igraph::vertex_attr(g, n) - } - } - } - p <- ggraph::ggraph(lo) + ggplot2::theme_void() - if (!is.null(node_group)) { - x <- y <- NULL - thisRequires("ggforce") - thisRequires("concaveman") - p <- p + - ggforce::geom_mark_hull(ggplot2::aes(x, y, fill = node_group, - label = node_group), data = lo) + - ggplot2::scale_fill_manual(values = colorsafe_palette, - guide = ggplot2::guide_legend("Group")) - } - if(snap){ - snet_info("Snapping layout coordinates to grid.") - if(grepl("lattice", - igraph::graph_attr(attr(p$data, "graph"), "grand")$name, - ignore.case = TRUE)) - p$data[,c("x","y")] <- round(p$data[,c("x","y")]) - else p$data[,c("x","y")] <- depth_first_recursive_search(p) - } - p -} - -.graph_edges <- function(p, g, edge_color, edge_size, node_size) { - if (is_directed(g)) { - out <- .infer_directed_edge_mapping(g, edge_color, edge_size, node_size) - p <- map_directed_edges(p, g, out) - } else { - out <- .infer_edge_mapping(g, edge_color, edge_size) - p <- map_edges(p, g, out) - } - if (is_complex(g)) { - p <- p + ggraph::geom_edge_loop0(edge_alpha = 0.4) - } - # Check legends - if (length(unique(out[["esize"]])) == 1) { - p <- p + ggplot2::guides(edge_width = "none") - } else p <- p + ggraph::scale_edge_width_continuous(range = c(0.3, 3), - guide = ggplot2::guide_legend( - ifelse(is.null(edge_size) & - is_weighted(g), - "Edge Weight", "Edge Size"))) - if (length(unique(out[["ecolor"]])) == 1) { - p <- p + ggplot2::guides(edge_colour = "none") - } else if (length(unique(out[["ecolor"]])) == 2){ - p <- p + ggraph::scale_edge_colour_manual(values = getOption("mnet_highlight", default = c("grey","black")), - guide = ggplot2::guide_legend( - ifelse(is.null(edge_color) & - is_signed(g), - "Edge Sign", "Edge Color"))) - } else p <- p + ggraph::scale_edge_colour_manual(values = getOption("mnet_cat", default = colorsafe_palette), - guide = ggplot2::guide_legend( - ifelse(is.null(edge_color) & - is_signed(g), - "Edge Sign", "Edge Color"))) - p -} - -.graph_nodes <- function(p, g, node_color, node_shape, node_size) { - out <- .infer_node_mapping(g, node_color, node_size, node_shape) - if (is.null(node_color) & "Infected" %in% names(node_attribute(g))) { - p <- map_infected_nodes(p, g, out) - } else if (is.null(node_color) & any("diff_model" %in% names(attributes(g)))) { - p <- map_diff_model_nodes(p, g, out) - } else { - p <- map_nodes(p, out) - # Check legends - if (length(unique(out[["nsize"]])) > 1) - p <- p + ggplot2::guides(size = ggplot2::guide_legend(title = "Node Size")) - if (length(unique(out[["nshape"]])) > 1) - p <- p + ggplot2::guides(shape = ggplot2::guide_legend( - title = ifelse(is_twomode(g) & is.null(node_shape), "Node Mode", "Node Shape"))) - if (length(unique(out[["ncolor"]])) > 1){ - if(length(unique(out[["ncolor"]])) == 2){ - p <- p + ggplot2::scale_colour_manual(values = getOption("mnet_highlight", default = c("grey","black")), - guide = ggplot2::guide_legend("Node Color")) - } else { - p <- p + ggplot2::scale_colour_manual(values = getOption("mnet_cat", default = colorsafe_palette), - guide = ggplot2::guide_legend("Node Color")) - } - } - } - # Consider rescaling nodes - p <- p + ggplot2::scale_size(range = c(1/net_nodes(g)*50, 1/net_nodes(g)*100)) - p -} - -.graph_labels <- function(p, g, layout) { - if (layout == "circle" | layout == "concentric") { - angles <- as.data.frame(cart2pol(as.matrix(p[["data"]][,1:2]))) - angles$degree <- angles$phi * 180/pi - angles <- dplyr::case_when(p[["data"]][,2] == 0 & p[["data"]][,1] == 0 ~ 0.1, - p[["data"]][,2] >= 0 & p[["data"]][,1] > 0 ~ angles$degree, - p[["data"]][,2] < 0 & p[["data"]][,1] > 0 ~ angles$degree, - p[["data"]][,1] == 1 ~ angles$degree, - TRUE ~ angles$degree - 180) - if (net_nodes(g) < 10) { - hj <- ifelse(p[["data"]][,1] >= 0, -0.8, 1.8) - } else if (net_nodes(g) < 20) { - hj <- ifelse(p[["data"]][,1] >= 0, -0.4, 1.4) - } else { - hj <- ifelse(p[["data"]][,1] >= 0, -0.2, 1.2) - } - p <- p + ggraph::geom_node_text(ggplot2::aes(label = name), repel = TRUE, - size = 3, hjust = hj, angle = angles) + - ggplot2::coord_cartesian(xlim=c(-1.2,1.2), ylim=c(-1.2,1.2)) - } else if (layout %in% c("bipartite", "railway") | layout == "hierarchy" & - length(unique(p[["data"]][["y"]])) <= 2) { - p <- p + ggraph::geom_node_text(ggplot2::aes(label = name), angle = 90, - size = 3, hjust = "outward", repel = TRUE, - nudge_y = ifelse(p[["data"]][,2] == 1, - 0.05, -0.05)) + - ggplot2::coord_cartesian(ylim=c(-0.2, 1.2)) - } else if (layout == "hierarchy" & length(unique(p[["data"]][["y"]])) > 2) { - p <- p + ggraph::geom_node_text(ggplot2::aes(label = name), - size = 3, hjust = "inward", repel = TRUE) - } else if (layout %in% c("alluvial", "lineage")) { - p <- p + ggraph::geom_node_label(ggplot2::aes(label = name), size = 3, - repel = TRUE, nudge_x = ifelse(p[["data"]][,1] == 1, - 0.02, -0.02)) - } else { - p <- p + ggraph::geom_node_label(ggplot2::aes(label = name), - repel = TRUE, seed = 1234, size = 3) - } -} - -# `graphr()` helper functions -reduce_categories <- function(g, node_group) { - limit <- toCondense <- NULL - if (sum(table(node_attribute(g, node_group)) <= 2) > 2 & - length(unique(node_attribute(g, node_group))) > 2) { - toCondense <- names(which(table(node_attribute(g, node_group)) <= 2)) - out <- ifelse(node_attribute(g, node_group) %in% toCondense, - "Other", node_attribute(g, node_group)) - snet_info("The number of groups was reduced since there were groups with less than 2 nodes.") - } else if (sum(table(node_attribute(g, node_group)) <= 2) == 2 & - length(unique(node_attribute(g, node_group))) > 2) { - limit <- stats::reorder(node_attribute(g, node_group), - node_attribute(g, node_group), - FUN = length, decreasing = TRUE) - if (sum(utils::tail(attr(limit, "scores"), 2))) { - toCondense <- utils::tail(levels(limit), 3) - } else { - toCondense <- utils::tail(levels(limit), 2) - } - out <- ifelse(node_attribute(g, node_group) %in% toCondense, "Other", - node_attribute(g, node_group)) - snet_info("The number of groups was reduced since there were groups with less than 2 nodes.") - } else if (sum(table(node_attribute(g, node_group)) <= 2) == 1 & - length(unique(node_attribute(g, node_group))) > 2) { - limit <- stats::reorder(node_attribute(g, node_group), - node_attribute(g, node_group), - FUN = length, decreasing = TRUE) - toCondense <- utils::tail(levels(limit), 2) - out <- ifelse(node_attribute(g, node_group) %in% toCondense, "Other", - node_attribute(g, node_group)) - snet_info("The number of groups was reduced since there were groups with less than 2 nodes.") - } else if (sum(table(node_attribute(g, node_group)) <= 2) == 1 & - length(unique(node_attribute(g, node_group))) == 2) { - out <- as.factor(node_attribute(g, node_group)) - snet_info("Node groups with 2 nodes or less can be cause issues for plotting ...") - } else out <- as.factor(node_attribute(g, node_group)) - out -} - -.infer_directed_edge_mapping <- function(g, edge_color, edge_size, node_size) { - check_edge_variables(g, edge_color, edge_size) - list("ecolor" = .infer_ecolor(g, edge_color), - "esize" = .infer_esize(g, edge_size), - "line_type" = .infer_line_type(g), - "end_cap" = .infer_end_cap(g, node_size)) -} - -.infer_edge_mapping <- function(g, edge_color, edge_size) { - check_edge_variables(g, edge_color, edge_size) - list("ecolor" = .infer_ecolor(g, edge_color), - "esize" = .infer_esize(g, edge_size), - "line_type" = .infer_line_type(g)) -} - -.infer_ecolor <- function(g, edge_color){ - if (!is.null(edge_color)) { - if (edge_color %in% names(tie_attribute(g))) { - if ("tie_mark" %in% class(tie_attribute(g, edge_color))) { - out <- factor(as.character(tie_attribute(g, edge_color)), - levels = c("FALSE", "TRUE")) - } else out <- as.factor(as.character(tie_attribute(g, edge_color))) - if (length(unique(out)) == 1) { - out <- rep("black", net_ties(g)) - snet_info("Please indicate a variable with more than one value or level when mapping edge colors.") - } - } else { - out <- edge_color - } - } else if (is.null(edge_color) & is_signed(g)) { - out <- factor(ifelse(igraph::E(g)$sign >= 0, "Positive", "Negative"), - levels = c("Positive", "Negative")) - if (length(unique(out)) == 1) { - out <- "black" - } - } else { - out <- "black" - } - out -} - -.infer_esize <- function(g, edge_size){ - if (!is.null(edge_size)) { - if (any(edge_size %in% names(tie_attribute(g)))) { - out <- tie_attribute(g, edge_size) - } else { - out <- edge_size - } - } else if (is.null(edge_size) & is_weighted(g)) { - out <- tie_attribute(g, "weight") - } else { - out <- 0.5 - } - out -} - -.infer_end_cap <- function(g, node_size) { - nsize <- .infer_nsize(g, node_size)/2 - # Accounts for rescaling - if (length(unique(nsize)) == 1) { - out <- rep(unique(nsize), net_ties(g)) - } else { - out <- g %>% - tidygraph::activate("edges") %>% - data.frame() %>% - dplyr::left_join(data.frame(node_id = 1:length(node_names(g)), - nsize = nsize), - by = c("to" = "node_id")) - out <- out$nsize - out <- ((out - min(out)) / (max(out) - min(out))) * - ((1 / net_nodes(g) * 100) - (1 / net_nodes(g)*50)) + (1 / net_nodes(g) * 50) - } - out -} - -.infer_line_type <- function(g) { - if (is_signed(g)) { - out <- ifelse(as.numeric(tie_signs(g)) >= 0, - "solid", "dashed") - # ifelse(length(unique(out)) == 1, unique(out), out) - } else out <- "solid" - out -} - -check_edge_variables <- function(g, edge_color, edge_size) { - if (!is.null(edge_color)) { - if (any(!tolower(edge_color) %in% tolower(igraph::edge_attr_names(g))) & - any(!edge_color %in% grDevices::colors())) { - snet_info("Please make sure you spelled `edge_color` variable correctly.") - } - } - if (!is.null(edge_size)) { - if (!is.numeric(edge_size) & any(!tolower(edge_size) %in% tolower(igraph::edge_attr_names(g)))) { - snet_info("Please make sure you spelled `edge_size` variable correctly.") - } - } -} - -map_directed_edges <- function(p, g, out) { - if (length(out[["ecolor"]]) == 1 & length(out[["esize"]]) == 1) { - p <- p + ggraph::geom_edge_arc(ggplot2::aes(end_cap = ggraph::circle(c(out[["end_cap"]]), 'mm')), - edge_colour = out[["ecolor"]], edge_width = out[["esize"]], - edge_linetype = out[["line_type"]], - edge_alpha = 0.4, strength = ifelse(igraph::which_mutual(g), 0.2, 0), - arrow = ggplot2::arrow(angle = 15, type = "closed", - length = ggplot2::unit(2, 'mm'))) - } else if (length(out[["ecolor"]]) > 1 & length(out[["esize"]]) == 1) { - p <- p + ggraph::geom_edge_arc(ggplot2::aes(edge_colour = out[["ecolor"]], - end_cap = ggraph::circle(c(out[["end_cap"]]), 'mm')), - edge_width = out[["esize"]], edge_linetype = out[["line_type"]], - edge_alpha = 0.4, strength = ifelse(igraph::which_mutual(g), 0.2, 0), - arrow = ggplot2::arrow(angle = 15, type = "closed", - length = ggplot2::unit(2, 'mm'))) - } else if (length(out[["ecolor"]]) == 1 & length(out[["esize"]]) > 1) { - p <- p + ggraph::geom_edge_arc(ggplot2::aes(edge_width = out[["esize"]], - end_cap = ggraph::circle(c(out[["end_cap"]]), 'mm')), - edge_colour = out[["ecolor"]], edge_linetype = out[["line_type"]], - edge_alpha = 0.4, strength = ifelse(igraph::which_mutual(g), 0.2, 0), - arrow = ggplot2::arrow(angle = 15, type = "closed", - length = ggplot2::unit(2, 'mm'))) - } else { - p <- p + ggraph::geom_edge_arc(ggplot2::aes(edge_colour = getOption("mnet_cat")[out[["ecolor"]]], - edge_width = out[["esize"]], - end_cap = ggraph::circle(c(out[["end_cap"]]), 'mm')), - edge_linetype = out[["line_type"]], - edge_alpha = 0.4, strength = ifelse(igraph::which_mutual(g), 0.2, 0), - arrow = ggplot2::arrow(angle = 15, type = "closed", - length = ggplot2::unit(2, 'mm'))) - } - p -} - -map_edges <- function(p, g, out) { - if (length(out[["ecolor"]]) == 1 & length(out[["esize"]]) == 1) { - p <- p + ggraph::geom_edge_link0(edge_width = out[["esize"]], - edge_colour = out[["ecolor"]], - edge_alpha = 0.4, - edge_linetype = out[["line_type"]]) - } else if (length(out[["ecolor"]]) > 1 & length(out[["esize"]]) == 1) { - p <- p + ggraph::geom_edge_link0(ggplot2::aes(edge_colour = out[["ecolor"]]), - edge_width = out[["esize"]], - edge_alpha = 0.4, - edge_linetype = out[["line_type"]]) - } else if (length(out[["ecolor"]]) == 1 & length(out[["esize"]]) > 1) { - p <- p + ggraph::geom_edge_link0(ggplot2::aes(edge_width = out[["esize"]]), - edge_colour = out[["ecolor"]], - edge_alpha = 0.4, - edge_linetype = out[["line_type"]]) - } else { - p <- p + ggraph::geom_edge_link0(ggplot2::aes(edge_width = out[["esize"]], - edge_colour = out[["ecolor"]]), - edge_alpha = 0.4, edge_linetype = out[["line_type"]]) - } -} - -.infer_node_mapping <- function(g, node_color, node_size, node_shape) { - check_node_variables(g, node_color, node_size) - list("nshape" = .infer_nshape(g, node_shape), - "nsize" = .infer_nsize(g, node_size), - "ncolor" = .infer_ncolor(g, node_color)) -} - -.infer_nsize <- function(g, node_size) { - if (!is.null(node_size)) { - if (is.character(node_size)) { - out <- node_attribute(g, node_size) - } else out <- node_size - if (length(node_size > 1) & all(out <= 1 & out >= 0)) out <- out * 10 - } else { - out <- min(20, (250 / net_nodes(g)) / 2) - } - as.numeric(out) -} - -.infer_nshape <- function(g, node_shape) { - if (!is.null(node_shape)) { - if (node_shape %in% names(node_attribute(g))) { - out <- as.factor(as.character(node_attribute(g, node_shape))) - } else out <- node_shape - } else if (is_twomode(g) & is.null(node_shape)) { - out <- ifelse(igraph::V(g)$type, "One", "Two") - } else { - out <- "circle" - } - out -} - -.infer_ncolor <- function(g, node_color) { - if (!is.null(node_color)) { - if (node_color %in% names(node_attribute(g))) { - if ("node_mark" %in% class(node_attribute(g, node_color))) { - out <- factor(as.character(node_attribute(g, node_color)), - levels = c("FALSE", "TRUE")) - } else out <- as.factor(as.character(node_attribute(g, node_color))) - if (length(unique(out)) == 1) { - out <- rep("black", net_nodes(g)) - snet_info("Please indicate a variable with more than one value or level when mapping node colors.") - } - } else out <- node_color - } else { - out <- "black" - } - out -} - -check_node_variables <- function(g, node_color, node_size) { - if (!is.null(node_color)) { - if (any(!tolower(node_color) %in% tolower(igraph::vertex_attr_names(g))) & - any(!node_color %in% grDevices::colors())) { - snet_info("Please make sure you spelled `node_color` variable correctly.") - } - } - if (!is.null(node_size)) { - if (!is.numeric(node_size) & any(!tolower(node_size) %in% tolower(igraph::vertex_attr_names(g)))) { - snet_info("Please make sure you spelled `node_size` variable correctly.") - } - } -} - -map_infected_nodes<- function(p, g, out) { - node_color <- as.factor(ifelse(node_attribute(g, "Exposed"), "Exposed", - ifelse(node_attribute(g, "Infected"),"Infected", - ifelse(node_attribute(g, "Recovered"), "Recovered", - "Susceptible")))) - p + ggraph::geom_node_point(ggplot2::aes(color = node_color), - size = out[["nsize"]], shape = out[["nshape"]]) + - ggplot2::scale_color_manual(name = NULL, guide = ggplot2::guide_legend(""), - values = c("Infected" = "#d73027", - "Susceptible" = "#4575b4", - "Exposed" = "#E6AB02", - "Recovered" = "#66A61E")) -} - -map_diff_model_nodes <- function(p, g, out) { - node_adopts <- node_adoption_time(attr(g,"diff_model")) - nshape <- ifelse(node_adopts == min(node_adopts), "Seed(s)", - ifelse(node_adopts == Inf, "Non-Adopter", "Adopter")) - node_color <- ifelse(is.infinite(node_adopts), - max(node_adopts[!is.infinite(node_adopts)]) + 1, - node_adopts) - p + ggraph::geom_node_point(ggplot2::aes(shape = nshape, color = node_color), - size = out[["nsize"]]) + - ggplot2::scale_color_gradient(low = "#d73027", high = "#4575b4", - breaks=c(min(node_color)+1, - ifelse(any(nshape=="Non-Adopter"), - max(node_color)-1, - max(node_color))), - labels=c("Early\nadoption", "Late\nadoption"), - name = "Time of\nAdoption\n") + - ggplot2::scale_shape_manual(name = "", - breaks = c("Seed(s)", "Adopter", "Non-Adopter"), - values = c("Seed(s)" = "triangle", - "Adopter" = "circle", - "Non-Adopter" = "square")) + - ggplot2::guides(color = ggplot2::guide_colorbar(order = 1, reverse = TRUE), - shape = ggplot2::guide_legend(order = 2)) -} - -map_nodes <- function(p, out) { - if (length(out[["ncolor"]]) == 1 & length(out[["nsize"]]) == 1 & length(out[["nshape"]]) == 1) { - p <- p + ggraph::geom_node_point(colour = out[["ncolor"]], size = out[["nsize"]], - shape = out[["nshape"]]) - } else if (length(out[["ncolor"]]) > 1 & length(out[["nsize"]]) == 1 & length(out[["nshape"]]) == 1) { - p <- p + ggraph::geom_node_point(ggplot2::aes(colour = out[["ncolor"]]), - size = out[["nsize"]], shape = out[["nshape"]]) - } else if (length(out[["ncolor"]]) == 1 & length(out[["nsize"]]) > 1 & length(out[["nshape"]]) == 1) { - p <- p + ggraph::geom_node_point(ggplot2::aes(size = out[["nsize"]]), - colour = out[["ncolor"]], shape = out[["nshape"]]) - } else if (length(out[["ncolor"]]) == 1 & length(out[["nsize"]]) == 1 & length(out[["nshape"]]) > 1) { - p <- p + ggraph::geom_node_point(ggplot2::aes(shape = out[["nshape"]]), - colour = out[["ncolor"]], size = out[["nsize"]]) - } else if (length(out[["ncolor"]]) > 1 & length(out[["nsize"]]) > 1 & length(out[["nshape"]]) == 1) { - p <- p + ggraph::geom_node_point(ggplot2::aes(colour = out[["ncolor"]], size = out[["nsize"]]), - shape = out[["nshape"]]) - } else if (length(out[["ncolor"]]) > 1 & length(out[["nsize"]]) == 1 & length(out[["nshape"]]) > 1) { - p <- p + ggraph::geom_node_point(ggplot2::aes(colour = out[["ncolor"]], shape = out[["nshape"]]), - size = out[["nsize"]]) - } else if (length(out[["ncolor"]]) == 1 & length(out[["nsize"]]) > 1 & length(out[["nshape"]]) > 1) { - p <- p + ggraph::geom_node_point(ggplot2::aes(size = out[["nsize"]], shape = out[["nshape"]]), - colour = out[["ncolor"]]) - } else { - p <- p + ggraph::geom_node_point(ggplot2::aes(colour = out[["ncolor"]], - shape = out[["nshape"]], - size = out[["nsize"]])) - } - p -} - - -cart2pol <- function(xyz){ - stopifnot(is.numeric(xyz)) - if (is.vector(xyz) && (length(xyz) == 2 || length(xyz) == - 3)) { - x <- xyz[1] - y <- xyz[2] - m <- 1 - n <- length(xyz) - } - else if (is.matrix(xyz) && (ncol(xyz) == 2 || ncol(xyz) == - 3)) { - x <- xyz[, 1] - y <- xyz[, 2] - m <- nrow(xyz) - n <- ncol(xyz) - } - else snet_abort("Input must be a vector of length 3 or a matrix with 3 columns.") - phi <- atan2(y, x) - r <- hypot(x, y) - if (n == 2) { - if (m == 1) - prz <- c(phi, r) - else prz <- cbind(phi, r) - } - else { - if (m == 1) { - z <- xyz[3] - prz <- c(phi, r, z) - } - else { - z <- xyz[, 3] - prz <- cbind(phi, r, z) - } - } - return(prz) -} - -hypot <- function (x, y) { - if ((length(x) == 0 && is.numeric(y) && length(y) <= 1) || - (length(y) == 0 && is.numeric(x) && length(x) <= 1)) - return(vector()) - if (!is.numeric(x) && !is.complex(x) || !is.numeric(y) && - !is.complex(y)) - snet_abort("Arguments 'x' and 'y' must be numeric or complex.") - if (length(x) == 1 && length(y) > 1) { - x <- rep(x, length(y)) - dim(x) <- dim(y) - } - else if (length(x) > 1 && length(y) == 1) { - y <- rep(y, length(x)) - dim(y) <- dim(x) - } - if ((is.vector(x) && is.vector(y) && length(x) != length(y)) || - (is.matrix(x) && is.matrix(y) && dim(x) != dim(y)) || - (is.vector(x) && is.matrix(y)) || is.matrix(x) && is.vector(y)) - snet_abort("Arguments 'x' and 'y' must be of the same size.") - x <- abs(x) - y <- abs(y) - m <- pmin(x, y) - M <- pmax(x, y) - ifelse(M == 0, 0, M * sqrt(1 + (m/M)^2)) -} - -# Longitudinal or comparative networks #### - -#' Easily graph a set of networks with sensible defaults -#' -#' @description -#' This function provides users with an easy way to graph -#' lists of network data for comparison. -#' -#' It builds upon this package's `graphr()` function, -#' and inherits all the same features and arguments. -#' See `graphr()` for more. -#' However, it uses the `{patchwork}` package to plot the graphs -#' side by side and, if necessary, in successive rows. -#' This is useful for lists of networks that represent, for example, -#' ego or component subgraphs of a network, -#' or a list of a network's different types of tie or across time. -#' By default just the first and last network will be plotted, -#' but this can be overridden by the "waves" parameter. -#' -#' Where the graphs are of the same network (same nodes), -#' the graphs may share a layout to facilitate comparison. -#' By default, successive graphs will use the layout calculated for -#' the "first" network, but other options include the "last" layout, -#' or a mix, "both", of them. -#' @family mapping -#' @param netlist A list of manynet-compatible networks. -#' @param waves Numeric, the number of plots to be displayed side-by-side. -#' If missing, the number of plots will be reduced to the first and last -#' when there are more than four plots. -#' This argument can also be passed a vector selecting the waves to plot. -#' @param based_on Whether the layout of the joint plots should -#' be based on the "first" or the "last" network, or "both". -#' @param ... Additional arguments passed to `graphr()`. -#' @return Multiple `ggplot2::ggplot()` objects displayed side-by-side. -#' @name map_graphs -#' @examples -#' #graphs(to_egos(ison_adolescents)) -#' #graphs(to_egos(ison_adolescents), waves = 8) -#' #graphs(to_egos(ison_adolescents), waves = c(2, 4, 6)) -#' #graphs(play_diffusion(ison_adolescents)) -#' @export -graphs <- function(netlist, waves, - based_on = c("first", "last", "both"), ...) { - thisRequires("patchwork") - based_on <- match.arg(based_on) - if (any(class(netlist) == "diff_model")){ - if (is_list(attr(netlist, "network"))) netlist <- attr(netlist, "network") else - netlist <- to_waves(netlist) - } - if (missing(waves)) { - if (length(netlist) > 4) { - netlist <- netlist[c(1, length(netlist))] - snet_info("Plotting first and last waves side-by-side. \nTo set the waves plotted use the 'waves = ' argument.") - } - } else if (!missing(waves)) { - if (length(waves) == 1) netlist <- netlist[c(1:waves)] else - netlist <- netlist[waves] - } - if (is.null(names(netlist))) names(netlist) <- rep("", length(netlist)) - if (length(unique(lapply(netlist, length))) == 1) { - if (based_on == "first") { - lay <- graphr(netlist[[1]], ...) - x <- lay$data$x - y <- lay$data$y - } else if (based_on == "last") { - lay <- graphr(netlist[[length(netlist)]], ...) - x <- lay$data$x - y <- lay$data$y - } else if (based_on == "both") { - lay <- graphr(netlist[[1]], ...) - x1 <- lay$data$x - y1 <- lay$data$y - lay1 <- graphr(netlist[[length(netlist)]], ...) - x <- (lay1$data$x + x1)/2 - y <- (lay1$data$y + y1)/2 - } - gs <- lapply(1:length(netlist), function(i) - graphr(netlist[[i]], x = x, y = y, ...) + ggtitle(names(netlist)[i])) - } else { - thisRequires("methods") - if (!methods::hasArg("layout") & is_ego_network(netlist)) { - gs <- lapply(1:length(netlist), function(i) - graphr(netlist[[i]], layout = "star", center = names(netlist)[[i]], ...) + - ggtitle(names(netlist)[i])) - } else { - snet_info("Layouts were not standardised since not all nodes appear across waves.") - gs <- lapply(1:length(netlist), function(i) - graphr(netlist[[i]], ...) + ggtitle(names(netlist)[i])) - } - } - # if (all(c("Infected", "Exposed", "Recovered") %in% names(gs[[1]]$data))) { - # gs <- .collapse_guides(gs) - # } - do.call(patchwork::wrap_plots, c(gs, list(guides = "collect"))) -} - -# `graphs()` helper functions -is_ego_network <- function(nlist) { - if (all(unique(names(nlist)) != "")) { - length(names(nlist)) == length(unique(unlist(unname(lapply(nlist, node_names))))) & - all(order_alphabetically(names(nlist)) == - order_alphabetically(unique(unlist(unname(lapply(nlist, node_names)))))) - } else FALSE -} - -order_alphabetically <- function(v) { - v[order(names(stats::setNames(v, v)))] -} - -# Dynamic networks #### - -#' Easily animate dynamic networks with sensible defaults -#' -#' @description -#' This function provides users with an easy way to graph -#' dynamic network data for exploration and presentation. -#' -#' It builds upon this package's `graphr()` function, -#' and inherits all the same features and arguments. -#' See `graphr()` for more. -#' However, it uses the `{gganimate}` package to animate the changes -#' between successive iterations of a network. -#' This is useful for networks in which the ties and/or the node or tie -#' attributes are changing. -#' -#' A progress bar is shown if it takes some time to encoding all the -#' .png files into a .gif. -#' @name map_grapht -#' @family mapping -#' @param tlist The same migraph-compatible network listed according to -#' a time attribute, waves, or slices. -#' @param keep_isolates Logical, whether to keep isolate nodes in the graph. -#' TRUE by default. -#' If FALSE, removes nodes from each frame they are isolated in. -#' @inheritParams map_graphr -#' @importFrom igraph gsize as_data_frame get.edgelist -#' @importFrom ggplot2 ggplot geom_segment geom_point geom_text -#' scale_alpha_manual theme_void -#' @importFrom ggraph create_layout -#' @importFrom dplyr mutate select distinct left_join %>% -#' @source https://blog.schochastics.net/posts/2021-09-15_animating-network-evolutions-with-gganimate/ -#' @return Shows a .gif image. Assigning the result of the function -#' saves the gif to a temporary folder and the object holds the path to this file. -#' @examples -#' #ison_adolescents %>% -#' # mutate_ties(year = sample(1995:1998, 10, replace = TRUE)) %>% -#' # to_waves(attribute = "year", cumulative = TRUE) %>% -#' # grapht() -#' #ison_adolescents %>% -#' # mutate(gender = rep(c("male", "female"), times = 4), -#' # hair = rep(c("black", "brown"), times = 4), -#' # age = sample(11:16, 8, replace = TRUE)) %>% -#' # mutate_ties(year = sample(1995:1998, 10, replace = TRUE), -#' # links = sample(c("friends", "not_friends"), 10, replace = TRUE), -#' # weekly_meetings = sample(c(3, 5, 7), 10, replace = TRUE)) %>% -#' # to_waves(attribute = "year") %>% -#' # grapht(layout = "concentric", membership = "gender", -#' # node_shape = "gender", node_color = "hair", -#' # node_size = "age", edge_color = "links", -#' # edge_size = "weekly_meetings") -#' #grapht(play_diffusion(ison_adolescents, seeds = 5)) -#' @export -grapht <- function(tlist, keep_isolates = TRUE, - layout, labels = TRUE, - node_color, node_shape, node_size, - edge_color, edge_size, ..., - node_colour, edge_colour) { - thisRequires("gganimate") - thisRequires("gifski") - # thisRequires("png") - x <- y <- name <- status <- frame <- NULL - # Check arguments - if (missing(layout)) { - if (length(tlist[[1]]) == 3) { - layout <- "triad" - } else if (length(tlist[[1]]) == 4) { - layout <- "quad" - } else if (is_twomode(tlist[[1]])) { - layout <- "hierarchy" - } else layout <- "stress" - } - if (missing(node_color) && missing(node_colour)) { - node_color <- NULL - } else if (missing(node_color)) { - node_color <- as.character(substitute(node_colour)) - } else { - node_color <- as.character(substitute(node_color)) - } - if (missing(node_shape)) node_shape <- NULL else - node_shape <- as.character(substitute(node_shape)) - if (missing(node_size)) node_size <- NULL else if (!is.numeric(node_size)) { - node_size <- as.character(substitute(node_size)) - } - if (missing(edge_color) && missing(edge_colour)) { - edge_color <- NULL - } else if (missing(edge_color)) { - edge_color <- as.character(substitute(edge_colour)) - } else { - edge_color <- as.character(substitute(edge_color)) - } - if (missing(edge_size)) edge_size <- NULL else if (!is.numeric(edge_size)) { - edge_size <- as.character(substitute(edge_size)) - } - # Check if diffusion model - if (inherits(tlist, "diff_model")) tlist <- to_waves(tlist) - # Check if object is a list of lists - if (!is.list(tlist[[1]])) { - snet_abort("Please declare a migraph-compatible network listed according - to a time attribute, waves, or slices.") - } - # Remove lists without edges - tlist <- Filter(function(x) igraph::gsize(x) > 0, tlist) - # Check names for groups - if (!"name" %in% names(node_attribute(tlist[[1]]))) { - labels <- FALSE - for (i in seq_len(length(tlist))) { - tlist[[i]] <- add_node_attribute(tlist[[i]], "name", - as.character(seq_len(igraph::vcount(tlist[[i]])))) - } - } - # Create an edge list - edges_lst <- lapply(1:length(tlist), function(i) - cbind(igraph::as_data_frame(tlist[[i]], "edges"), - frame = ifelse(is.null(names(tlist)), i, names(tlist)[i]))) - # Check if all names are present in all lists - if (length(unique(unname(lapply(tlist, length)))) != 1) { - if (any(c(node_shape, node_color, node_size) %in% names(node_attribute(tlist[[1]])))) { - node_info <- dplyr::distinct(do.call(rbind, lapply(1:length(tlist), function(i) - tlist[[i]] %>% activate("nodes") %>% data.frame()))) # keep node info for latter - } else node_info <- NULL - tlist <- to_waves(as_tidygraph(do.call("rbind", edges_lst)), attribute = "frame") - } else node_info <- NULL - # Add separate layouts for each time point - lay <- lapply(1:length(tlist), function(i) - ggraph::create_layout(tlist[[i]], layout, ...)) - # Create a node list for each time point - nodes_lst <- lapply(1:length(tlist), function(i) { - cbind(igraph::as_data_frame(tlist[[i]], "vertices"), - x = lay[[i]][, 1], y = lay[[i]][, 2], - frame = ifelse(is.null(names(tlist)), i, names(tlist)[i])) - }) - # Create an edge list for each time point - edges_lst <- time_edges_lst(tlist, edges_lst, nodes_lst) - # Get edge IDs for all edges - all_edges <- do.call("rbind", lapply(tlist, igraph::get.edgelist)) - all_edges <- all_edges[!duplicated(all_edges), ] - all_edges <- cbind(all_edges, paste0(all_edges[, 1], "-", all_edges[, 2])) - # Add edges level information for edge transitions - edges_lst <- transition_edge_lst(tlist, edges_lst, nodes_lst, all_edges) - # Bind nodes and edges list - edges_out <- do.call("rbind", edges_lst) - nodes_out <- do.call("rbind", nodes_lst) - if (!is.null(node_info)) { - nodes_out <- dplyr::left_join(nodes_out, node_info[!duplicated(node_info$name),], by = "name") - } - # Delete nodes for each frame if isolate - if (isFALSE(keep_isolates)) { - nodes_out <- remove_isolates(edges_out, nodes_out) - } else { - if (nrow(nodes_out)/length(unique(nodes_out$frame)) > 30 & - any(unlist(lapply(tlist, node_is_isolate)) == TRUE)) { - snet_info("Please considering deleting isolates to improve visualisation.") - } - nodes_out$status <- TRUE - } - # Plot with ggplot2/ggraph and animate with gganimate - p <- map_dynamic(edges_out, nodes_out, edge_color, node_shape, - node_color, node_size, edge_size, labels) + - gganimate::transition_states(states = frame, transition_length = 5, - state_length = 10, wrap = FALSE) + - gganimate::enter_fade() + - gganimate::exit_fade() + - ggplot2::labs(title = "{closest_state}") - gganimate::animate(p, duration = 2*length(tlist), start_pause = 5, - end_pause = 10, renderer = gganimate::gifski_renderer()) -} - -map_dynamic <- function(edges_out, nodes_out, edge_color, node_shape, - node_color, node_size, edge_size, labels) { - x <- xend <- y <- yend <- id <- status <- Infected <- name <- NULL - alphad <- ifelse(nodes_out$status == TRUE, 1, 0) - alphae <- ifelse(edges_out$status == TRUE, 1, 0) - if (all(unique(alphae) == 1)) alphae <- 0.8 - # Plot edges - if (!is.null(edge_color)) { - # Remove NAs in edge color, if declared - if (edge_color %in% names(edges_out)) { - edge_color <- .check_color(edges_out[[edge_color]]) - } - } else edge_color <- "black" - if (!is.null(edge_size)) { - if (edge_size %in% names(edges_out)) { - edge_size <- as.numeric(edges_out[[edge_size]]) - edge_size <- ifelse(is.na(edge_size), 0.5, edge_size) - } - } else edge_size <- 0.5 - p <- ggplot2::ggplot() + - ggplot2::geom_segment(aes(x = x, xend = xend, y = y, yend = yend, group = id), - alpha = alphae, data = edges_out, color = edge_color, - linewidth = edge_size, show.legend = FALSE) - # Set node shape, color, and size - if (!is.null(node_shape)) { - if (node_shape %in% names(nodes_out)) { - node_shape <- as.factor(nodes_out[[node_shape]]) - if (!any(grepl("circle|square|triangle", node_shape))) { - node_shape <- c("circle", "square", "triangle")[node_shape] - } - } - } else node_shape <- "circle" - if (!is.null(node_color)) { - if (node_color %in% names(nodes_out)) { - node_color <- .check_color(nodes_out[[node_color]]) - } - } else if (is.null(node_color) & "Infected" %in% names(nodes_out)) { - node_color <- as.factor(ifelse(nodes_out[["Exposed"]], "Exposed", - ifelse(nodes_out[["Infected"]],"Infected", - ifelse(nodes_out[["Recovered"]], "Recovered", - "Susceptible")))) - } else node_color <- "darkgray" - if (!is.null(node_size)) { - if (node_size %in% names(nodes_out)) { - node_size <- nodes_out[[node_size]] - } - } else if (nrow(nodes_out) > 100) { - node_size <- 3 - } else node_size <- nrow(nodes_out)/length(unique(nodes_out$frame)) - # Add labels - if (isTRUE(labels)) { - p <- p + ggplot2::geom_text(aes(x, y, label = name), alpha = alphad, - data = nodes_out, color = "black", - hjust = -0.2, vjust = -0.2, show.legend = FALSE) - } - # Plot nodes - if ("Infected" %in% names(nodes_out)) { - p <- p + ggplot2::geom_point(aes(x, y, group = name, color = node_color), - size = node_size, shape = node_shape, data = nodes_out) + - ggplot2::scale_color_manual(name = NULL, values = c("Infected" = "#d73027", - "Susceptible" = "#4575b4", - "Exposed" = "#E6AB02", - "Recovered" = "#66A61E")) + - ggplot2::theme_void() + - ggplot2::theme(legend.position = "bottom") - } else { - p <- p + ggplot2::geom_point(aes(x, y, group = name), alpha = alphad, - size = node_size, data = nodes_out, - color = node_color, shape = node_shape, - show.legend = FALSE) + - ggplot2::theme_void() - } - p -} - -# `graphd()` helper functions -.check_color <- function(v) { - color <- grDevices::colors() - color <- color[!color %in% "black"] - v <- ifelse(is.na(v), "black", v) - if (!any(grepl(paste(color, collapse = "|"), v)) | any(grepl("^#", v))) { - for(i in unique(v)) { - if (i != "black") { - v[v == i] <- sample(color, 1) - } - } - } - v -} - -time_edges_lst <- function(tlist, edges_lst, nodes_lst, edge_color) { - lapply(1:length(tlist), function(i) { - edges_lst[[i]]$x <- nodes_lst[[i]]$x[match(edges_lst[[i]]$from, - nodes_lst[[i]]$name)] - edges_lst[[i]]$y <- nodes_lst[[i]]$y[match(edges_lst[[i]]$from, - nodes_lst[[i]]$name)] - edges_lst[[i]]$xend <- nodes_lst[[i]]$x[match(edges_lst[[i]]$to, - nodes_lst[[i]]$name)] - edges_lst[[i]]$yend <- nodes_lst[[i]]$y[match(edges_lst[[i]]$to, - nodes_lst[[i]]$name)] - edges_lst[[i]]$id <- paste0(edges_lst[[i]]$from, "-", edges_lst[[i]]$to) - edges_lst[[i]]$status <- TRUE - edges_lst[[i]] - }) -} - -transition_edge_lst <- function(tlist, edges_lst, nodes_lst, all_edges) { - x <- lapply(1:length(tlist), function(i) { - idx <- which(!all_edges[, 3] %in% edges_lst[[i]]$id) - if (length(idx) != 0) { - tmp <- data.frame(from = all_edges[idx, 1], to = all_edges[idx, 2], - id = all_edges[idx, 3]) - tmp$x <- nodes_lst[[i]]$x[match(tmp$from, nodes_lst[[i]]$name)] - tmp$y <- nodes_lst[[i]]$y[match(tmp$from, nodes_lst[[i]]$name)] - tmp$xend <- nodes_lst[[i]]$x[match(tmp$to, nodes_lst[[i]]$name)] - tmp$yend <- nodes_lst[[i]]$y[match(tmp$to, nodes_lst[[i]]$name)] - tmp$frame <- ifelse(is.null(names(tlist)), i, names(tlist)[i]) - tmp$status <- FALSE - edges_lst[[i]] <- dplyr::bind_rows(edges_lst[[i]], tmp) - } - edges_lst[[i]] - }) -} - -remove_isolates <- function(edges_out, nodes_out) { - status <- frame <- from <- to <- framen <- NULL - # Create node metadata for node presence in certain frame - meta <- edges_out %>% - dplyr::filter(status == TRUE) %>% - dplyr::mutate(framen = match(frame, unique(frame)), - meta = ifelse(framen > 1, paste0(from, (framen - 1)), from)) %>% - dplyr::select(meta, status) %>% - dplyr::distinct() - metab <- edges_out %>% - dplyr::filter(status == TRUE) %>% - dplyr::mutate(framen = match(frame, unique(frame)), - meta = ifelse(framen > 1, paste0(to, (framen - 1)), to)) %>% - dplyr::select(meta, status) %>% - rbind(meta) %>% - dplyr::distinct() - # Mark nodes that are isolates - nodes_out$meta <- rownames(nodes_out) - # Join data - nodes_out <- dplyr::left_join(nodes_out, metab, by = "meta") %>% - dplyr::mutate(status = ifelse(is.na(status), FALSE, TRUE)) %>% - dplyr::distinct() -} - -colorsafe_palette <- c("#d73027", "#4575b4", "#1B9E77","#D95F02","#7570B3", - "#E7298A", "#66A61E","#E6AB02","#A6761D","#666666") diff --git a/man/map_graphr.Rd b/man/map_graphr.Rd deleted file mode 100644 index 474f3d4b..00000000 --- a/man/map_graphr.Rd +++ /dev/null @@ -1,141 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/map_autograph.R -\name{map_graphr} -\alias{map_graphr} -\alias{graphr} -\title{Easily graph networks with sensible defaults} -\usage{ -graphr( - .data, - layout, - labels = TRUE, - node_color, - node_shape, - node_size, - node_group, - edge_color, - edge_size, - snap = FALSE, - ..., - node_colour, - edge_colour -) -} -\arguments{ -\item{.data}{A manynet-consistent object.} - -\item{layout}{An igraph, ggraph, or manynet layout algorithm. -If not declared, defaults to "triad" for networks with 3 nodes, -"quad" for networks with 4 nodes, -"stress" for all other one mode networks, -or "hierarchy" for two mode networks. -For "hierarchy" layout, one can further split graph by -declaring the "center" argument as the "events", "actors", -or by declaring a node name. -For "concentric" layout algorithm please declare the "membership" as an -extra argument. -The "membership" argument expects either a quoted node attribute present -in data or vector with the same length as nodes to draw concentric circles. -For "multilevel" layout algorithm please declare the "level" -as extra argument. -The "level" argument expects either a quoted node attribute present -in data or vector with the same length as nodes to hierarchically -order categories. -If "level" is missing, function will look for 'lvl' node attribute in data. -The "lineage" layout ranks nodes in Y axis according to values. -For "lineage" layout algorithm please declare the "rank" -as extra argument. -The "rank" argument expects either a quoted node attribute present -in data or vector with the same length as nodes.} - -\item{labels}{Logical, whether to print node names -as labels if present.} - -\item{node_color, node_colour}{Node variable to be used for coloring the nodes. -It is easiest if this is added as a node attribute to -the graph before plotting. -Nodes can also be colored by declaring a color instead.} - -\item{node_shape}{Node variable to be used for shaping the nodes. -It is easiest if this is added as a node attribute to -the graph before plotting. -Nodes can also be shaped by declaring a shape instead.} - -\item{node_size}{Node variable to be used for sizing the nodes. -This can be any continuous variable on the nodes of the network. -Since this function expects this to be an existing variable, -it is recommended to calculate all node-related statistics prior -to using this function. -Nodes can also be sized by declaring a numeric size or vector instead.} - -\item{node_group}{Node variable to be used for grouping the nodes. -It is easiest if this is added as a hull over -groups before plotting. -Group variables should have a minimum of 3 nodes, -if less, number groups will be reduced by -merging categories with lower counts into one called "other".} - -\item{edge_color, edge_colour}{Tie variable to be used for coloring the nodes. -It is easiest if this is added as an edge or tie attribute -to the graph before plotting. -Edges can also be colored by declaring a color instead.} - -\item{edge_size}{Tie variable to be used for sizing the edges. -This can be any continuous variable on the nodes of the network. -Since this function expects this to be an existing variable, -it is recommended to calculate all edge-related statistics prior -to using this function. -Edges can also be sized by declaring a numeric size or vector instead.} - -\item{snap}{Logical scalar, whether the layout should be snapped to a grid.} - -\item{...}{Extra arguments to pass on to the layout algorithm, if necessary.} -} -\value{ -A \code{ggplot2::ggplot()} object. -The last plot can be saved to the file system using \code{ggplot2::ggsave()}. -} -\description{ -This function provides users with an easy way to graph -(m)any network data for exploration, investigation, inspiration, -and communication. - -It builds upon \code{{ggplot2}} and \code{{ggraph}} to offer -pretty and extensible graphing solutions. -However, compared to those solutions, -\code{graphr()} contains various algorithms to provide better looking -graphs by default. -This means that just passing the function some network data -will often be sufficient to return a reasonable-looking graph. - -The function also makes it easy to modify many of the most -commonly adapted aspects of a graph, -including node and edge size, colour, and shape, -as arguments rather than additional functions that you need to remember. -These can be defined outright, e.g. \code{node_size = 8}, or -in reference to an attribute of the network, e.g. \code{node_size = "wealth"}. - -Lastly, \code{graphr()} uses \code{{ggplot2}}-related theme information, so -it is easy to make colour palette and fonts institution-specific and consistent. -See e.g. \code{theme_iheid()} for more. - -To learn more about what can be done visually, -try \code{run_tute("Visualisation")}. -} -\examples{ -graphr(ison_adolescents) -ison_adolescents \%>\% - mutate(color = rep(c("introvert","extrovert"), times = 4), - size = ifelse(node_is_cutpoint(ison_adolescents), 6, 3)) \%>\% - mutate_ties(ecolor = rep(c("friends", "acquaintances"), times = 5)) \%>\% - graphr(node_color = "color", node_size = "size", - edge_size = 1.5, edge_color = "ecolor") -} -\seealso{ -Other mapping: -\code{\link{map_graphs}}, -\code{\link{map_grapht}}, -\code{\link{map_layout_configuration}}, -\code{\link{map_layout_partition}} -} -\concept{mapping} diff --git a/man/map_graphs.Rd b/man/map_graphs.Rd deleted file mode 100644 index 549d1128..00000000 --- a/man/map_graphs.Rd +++ /dev/null @@ -1,60 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/map_autograph.R -\name{map_graphs} -\alias{map_graphs} -\alias{graphs} -\title{Easily graph a set of networks with sensible defaults} -\usage{ -graphs(netlist, waves, based_on = c("first", "last", "both"), ...) -} -\arguments{ -\item{netlist}{A list of manynet-compatible networks.} - -\item{waves}{Numeric, the number of plots to be displayed side-by-side. -If missing, the number of plots will be reduced to the first and last -when there are more than four plots. -This argument can also be passed a vector selecting the waves to plot.} - -\item{based_on}{Whether the layout of the joint plots should -be based on the "first" or the "last" network, or "both".} - -\item{...}{Additional arguments passed to \code{graphr()}.} -} -\value{ -Multiple \code{ggplot2::ggplot()} objects displayed side-by-side. -} -\description{ -This function provides users with an easy way to graph -lists of network data for comparison. - -It builds upon this package's \code{graphr()} function, -and inherits all the same features and arguments. -See \code{graphr()} for more. -However, it uses the \code{{patchwork}} package to plot the graphs -side by side and, if necessary, in successive rows. -This is useful for lists of networks that represent, for example, -ego or component subgraphs of a network, -or a list of a network's different types of tie or across time. -By default just the first and last network will be plotted, -but this can be overridden by the "waves" parameter. - -Where the graphs are of the same network (same nodes), -the graphs may share a layout to facilitate comparison. -By default, successive graphs will use the layout calculated for -the "first" network, but other options include the "last" layout, -or a mix, "both", of them. -} -\examples{ -#graphs(to_egos(ison_adolescents)) -#graphs(to_egos(ison_adolescents), waves = 8) -#graphs(to_egos(ison_adolescents), waves = c(2, 4, 6)) -#graphs(play_diffusion(ison_adolescents)) -} -\seealso{ -Other mapping: -\code{\link{map_graphr}}, -\code{\link{map_grapht}}, -\code{\link{map_layout_configuration}}, -\code{\link{map_layout_partition}} -} -\concept{mapping} diff --git a/man/map_grapht.Rd b/man/map_grapht.Rd deleted file mode 100644 index ff0cce5a..00000000 --- a/man/map_grapht.Rd +++ /dev/null @@ -1,137 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/map_autograph.R -\name{map_grapht} -\alias{map_grapht} -\alias{grapht} -\title{Easily animate dynamic networks with sensible defaults} -\source{ -https://blog.schochastics.net/posts/2021-09-15_animating-network-evolutions-with-gganimate/ -} -\usage{ -grapht( - tlist, - keep_isolates = TRUE, - layout, - labels = TRUE, - node_color, - node_shape, - node_size, - edge_color, - edge_size, - ..., - node_colour, - edge_colour -) -} -\arguments{ -\item{tlist}{The same migraph-compatible network listed according to -a time attribute, waves, or slices.} - -\item{keep_isolates}{Logical, whether to keep isolate nodes in the graph. -TRUE by default. -If FALSE, removes nodes from each frame they are isolated in.} - -\item{layout}{An igraph, ggraph, or manynet layout algorithm. -If not declared, defaults to "triad" for networks with 3 nodes, -"quad" for networks with 4 nodes, -"stress" for all other one mode networks, -or "hierarchy" for two mode networks. -For "hierarchy" layout, one can further split graph by -declaring the "center" argument as the "events", "actors", -or by declaring a node name. -For "concentric" layout algorithm please declare the "membership" as an -extra argument. -The "membership" argument expects either a quoted node attribute present -in data or vector with the same length as nodes to draw concentric circles. -For "multilevel" layout algorithm please declare the "level" -as extra argument. -The "level" argument expects either a quoted node attribute present -in data or vector with the same length as nodes to hierarchically -order categories. -If "level" is missing, function will look for 'lvl' node attribute in data. -The "lineage" layout ranks nodes in Y axis according to values. -For "lineage" layout algorithm please declare the "rank" -as extra argument. -The "rank" argument expects either a quoted node attribute present -in data or vector with the same length as nodes.} - -\item{labels}{Logical, whether to print node names -as labels if present.} - -\item{node_color, node_colour}{Node variable to be used for coloring the nodes. -It is easiest if this is added as a node attribute to -the graph before plotting. -Nodes can also be colored by declaring a color instead.} - -\item{node_shape}{Node variable to be used for shaping the nodes. -It is easiest if this is added as a node attribute to -the graph before plotting. -Nodes can also be shaped by declaring a shape instead.} - -\item{node_size}{Node variable to be used for sizing the nodes. -This can be any continuous variable on the nodes of the network. -Since this function expects this to be an existing variable, -it is recommended to calculate all node-related statistics prior -to using this function. -Nodes can also be sized by declaring a numeric size or vector instead.} - -\item{edge_color, edge_colour}{Tie variable to be used for coloring the nodes. -It is easiest if this is added as an edge or tie attribute -to the graph before plotting. -Edges can also be colored by declaring a color instead.} - -\item{edge_size}{Tie variable to be used for sizing the edges. -This can be any continuous variable on the nodes of the network. -Since this function expects this to be an existing variable, -it is recommended to calculate all edge-related statistics prior -to using this function. -Edges can also be sized by declaring a numeric size or vector instead.} - -\item{...}{Extra arguments to pass on to the layout algorithm, if necessary.} -} -\value{ -Shows a .gif image. Assigning the result of the function -saves the gif to a temporary folder and the object holds the path to this file. -} -\description{ -This function provides users with an easy way to graph -dynamic network data for exploration and presentation. - -It builds upon this package's \code{graphr()} function, -and inherits all the same features and arguments. -See \code{graphr()} for more. -However, it uses the \code{{gganimate}} package to animate the changes -between successive iterations of a network. -This is useful for networks in which the ties and/or the node or tie -attributes are changing. - -A progress bar is shown if it takes some time to encoding all the -.png files into a .gif. -} -\examples{ -#ison_adolescents \%>\% -# mutate_ties(year = sample(1995:1998, 10, replace = TRUE)) \%>\% -# to_waves(attribute = "year", cumulative = TRUE) \%>\% -# grapht() -#ison_adolescents \%>\% -# mutate(gender = rep(c("male", "female"), times = 4), -# hair = rep(c("black", "brown"), times = 4), -# age = sample(11:16, 8, replace = TRUE)) \%>\% -# mutate_ties(year = sample(1995:1998, 10, replace = TRUE), -# links = sample(c("friends", "not_friends"), 10, replace = TRUE), -# weekly_meetings = sample(c(3, 5, 7), 10, replace = TRUE)) \%>\% -# to_waves(attribute = "year") \%>\% -# grapht(layout = "concentric", membership = "gender", -# node_shape = "gender", node_color = "hair", -# node_size = "age", edge_color = "links", -# edge_size = "weekly_meetings") -#grapht(play_diffusion(ison_adolescents, seeds = 5)) -} -\seealso{ -Other mapping: -\code{\link{map_graphr}}, -\code{\link{map_graphs}}, -\code{\link{map_layout_configuration}}, -\code{\link{map_layout_partition}} -} -\concept{mapping} From 75288d0f878467a9e894627be4acbb9911ed9ce5 Mon Sep 17 00:00:00 2001 From: James Hollway Date: Fri, 22 Aug 2025 15:03:56 +0200 Subject: [PATCH 13/24] Moved themes to autograph --- NAMESPACE | 36 --- R/map_theme.R | 558 ---------------------------------------------- man/map_themes.Rd | 41 ---- 3 files changed, 635 deletions(-) delete mode 100644 R/map_theme.R delete mode 100644 man/map_themes.Rd diff --git a/NAMESPACE b/NAMESPACE index df2fe101..7d76eb31 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -667,42 +667,10 @@ export(rename) export(rename_nodes) export(rename_ties) export(run_tute) -export(scale_color_centres) -export(scale_color_ethz) -export(scale_color_iheid) -export(scale_color_rug) -export(scale_color_sdgs) -export(scale_color_uzh) -export(scale_colour_centres) -export(scale_colour_ethz) -export(scale_colour_iheid) -export(scale_colour_rug) -export(scale_colour_sdgs) -export(scale_colour_uzh) -export(scale_edge_color_centres) -export(scale_edge_color_ethz) -export(scale_edge_color_iheid) -export(scale_edge_color_rug) -export(scale_edge_color_sdgs) -export(scale_edge_color_uzh) -export(scale_edge_colour_centres) -export(scale_edge_colour_ethz) -export(scale_edge_colour_iheid) -export(scale_edge_colour_rug) -export(scale_edge_colour_sdgs) -export(scale_edge_colour_uzh) -export(scale_fill_centres) -export(scale_fill_ethz) -export(scale_fill_iheid) -export(scale_fill_rug) -export(scale_fill_sdgs) -export(scale_fill_uzh) -export(scale_size) export(select) export(select_changes) export(select_nodes) export(select_ties) -export(set_manynet_theme) export(snet_abort) export(snet_info) export(snet_minor_info) @@ -716,10 +684,6 @@ export(snet_unavailable) export(snet_warn) export(summarise_ties) export(table_data) -export(theme_ethz) -export(theme_iheid) -export(theme_rug) -export(theme_uzh) export(tie_attribute) export(tie_betweenness) export(tie_closeness) diff --git a/R/map_theme.R b/R/map_theme.R deleted file mode 100644 index c3d6f895..00000000 --- a/R/map_theme.R +++ /dev/null @@ -1,558 +0,0 @@ -#' Many themes -#' -#' @description -#' These functions enable graphs to be easily and quickly themed, -#' e.g. changing the default colour of the graph's vertices and edges. -#' @name map_themes -#' @param base_size Font size, by default 12. -#' @param base_family Font family, by default "sans". -#' @examples -#' to_mentoring(ison_brandes) %>% -#' mutate(color = c(rep(c(1,2,3), 3), 3)) %>% -#' graphr(node_color = "color") + -#' labs(title = "Who leads and who follows?") + -#' scale_color_iheid() + -#' theme_iheid() -NULL - -#' @rdname map_themes -#' @param theme String naming a theme. -#' By default "default". -#' @export -set_manynet_theme <- function(theme = "default"){ - theme_opts <- c("default", - "iheid", "ethz", "uzh", "rug", - "crisp", "neon", "rainbow") - if(theme %in% theme_opts){ - options(mnet_theme = theme) - set_highlight_theme(theme) - set_background_theme(theme) - set_categorical_theme(theme) - cli::cli_alert_success("Theme set to {.emph {theme}}.") - } else { - cli::cli_alert_warning("Please choose one of the available themes: {.emph {theme_opts}}.") - } -} - -set_highlight_theme <- function(theme){ - if(theme == "iheid"){ - options(mnet_highlight = c("#000010","#E20020")) - } else if(theme == "rug"){ - options(mnet_highlight = c("#000000", "#dc002d")) - } else if(theme == "uzh"){ - options(mnet_highlight = c("#a3adb7", "#dc6027")) - } else if(theme == "ethz"){ - options(mnet_highlight = c("#6F6F6F", "#0028a5")) - } else if(theme == "crisp"){ - options(mnet_highlight = c("#FFFFFA", "#101314")) - } else if(theme == "neon"){ - options(mnet_highlight = c("#5aeafd", "#54fe4b")) - } else if(theme == "rainbow"){ - options(mnet_highlight = c('#1965B0', '#DC050C')) - } else { - options(mnet_highlight = c("#4576B5", "#D83127")) - } -} - -set_background_theme <- function(theme){ - if(theme == "neon"){ - options(mnet_background = "#070f23") - } else { - options(mnet_background = "#FFFFFF") - } -} - -set_categorical_theme <- function(theme){ - if(theme == "iheid"){ - options(mnet_cat = c("#006564","#0094D8","#622550", - "#268D2B","#3E2682","#820C2B", - "#008F92","#006EAA","#A8086E")) - } else if(theme == "ethz"){ - options(mnet_cat = c("#215CAF","#007894","#627313", - "#8E6713","#B7352D","#A7117A","#6F6F6F")) - } else if(theme == "uzh"){ - options(mnet_cat = c("#0028A5","#4AC9E3","#A4D233", - "#FFC845","#FC4C02","#BF0D3E", - "#BDC9E8","#DBF4F9","#ECF6D6", - "#FFF4DA","#FFDBCC","#FBC6D4", - "#7596FF","#B7E9F4","#DBEDAD", - "#FFE9B5","#FEB799","#F78CAA", - "#3062FF","#92DFEE","#C8E485", - "#FFDE8F","#FE9367","#F3537F", - "#001E7C","#1EA7C4","#7CA023", - "#F3AB00","#BD3902","#8F0A2E", - "#001452","#147082","#536B18", - "#A27200","#7E2601","#60061F")) - - } else if(theme == "rainbow"){ - options(mnet_cat = c('#E8ECFB', '#D9CCE3', '#D1BBD7', - '#CAACCB', '#BA8DB4', '#AE76A3', - '#AA6F9E', '#994F88', '#882E72', - '#1965B0', '#437DBF', '#5289C7', - '#6195CF', '#7BAFDE', - '#4EB265', '#90C987', '#CAE0AB', - '#F7F056', '#F7CB45', '#F6C141', - '#F4A736', '#F1932D', '#EE8026', - '#E8601C', '#E65518', '#DC050C', - '#A5170E', '#72190E', '#42150A')) - } else { - options(mnet_cat = c("#1B9E77","#4575b4","#d73027", - "#66A61E","#E6AB02","#D95F02","#7570B3", - "#A6761D","#E7298A","#666666")) - } -} - - - -#' @rdname map_themes -#' @export -theme_iheid <- function(base_size = 12, base_family = "serif") { - colors <- corp_palette("IHEID") - (ggplot2::theme_minimal(base_size = base_size, base_family = base_family) - + ggplot2::theme( - line = ggplot2::element_line(colors["IHEIDBlack"]), - rect = ggplot2::element_rect(fill = "#FFFFFF", linetype = 1, - linewidth = 0.6, colour = colors["IHEIDGrey"]), - title = ggplot2::element_text(colour = colors["IHEIDRed"], - size = base_size, family = base_family, - face = "bold"), - plot.subtitle = ggplot2::element_text(colors["IHEIDGrey"], - size = base_size*0.85, family = base_family, - face = "bold.italic"), - plot.caption = ggplot2::element_text(colors["IHEIDBlack"], - size = base_size*0.75, - family = base_family, - face = "italic"), - axis.title = ggplot2::element_blank(), - axis.text = ggplot2::element_text(), - axis.ticks = ggplot2::element_blank(), - axis.line = ggplot2::element_blank(), - axis.title.x = ggplot2::element_blank(), - axis.text.x = ggplot2::element_blank(), - axis.ticks.x = ggplot2::element_blank(), - axis.title.y = ggplot2::element_blank(), - axis.text.y = ggplot2::element_blank(), - axis.ticks.y = ggplot2::element_blank(), - panel.grid.major = ggplot2::element_blank(), - panel.grid.minor = ggplot2::element_blank(), - legend.background = ggplot2::element_rect(), - legend.position = "bottom", - legend.direction = "horizontal", - legend.box = "vertical", - strip.background = ggplot2::element_rect())) -} - -#' @rdname map_themes -#' @export -theme_ethz <- function(base_size = 12, base_family = "sans") { - colors <- corp_palette("ETHZ") - (ggplot2::theme_minimal(base_size = base_size, base_family = base_family) - + ggplot2::theme( - line = ggplot2::element_line(colors["ETHZ_Green"]), - rect = ggplot2::element_rect(fill = "#FFFFFF", linetype = 1, - linewidth = 0.6, colour = colors["ETHZ_Petrol"]), - title = ggplot2::element_text(colour = "black", - size = base_size, family = base_family, - face = "bold.italic"), - plot.subtitle = ggplot2::element_text("black", - size = base_size*0.85, - family = base_family, - face = "bold.italic"), - plot.caption = ggplot2::element_text("black", - size = base_size*0.75, - family = base_family, - face = "italic"), - axis.title = ggplot2::element_blank(), - axis.text = ggplot2::element_text(), - axis.ticks = ggplot2::element_blank(), - axis.line = ggplot2::element_blank(), - axis.title.x = ggplot2::element_blank(), - axis.text.x = ggplot2::element_blank(), - axis.ticks.x = ggplot2::element_blank(), - axis.title.y = ggplot2::element_blank(), - axis.text.y = ggplot2::element_blank(), - axis.ticks.y = ggplot2::element_blank(), - panel.grid.major = ggplot2::element_blank(), - panel.grid.minor = ggplot2::element_blank(), - legend.background = ggplot2::element_rect(), - legend.position = "bottom", - legend.direction = "horizontal", - legend.box = "vertical", - strip.background = ggplot2::element_rect())) -} - -#' @rdname map_themes -#' @export -theme_uzh <- function(base_size = 12, base_family = "sans") { - colors <- corp_palette("UZH") - (ggplot2::theme_minimal(base_size = base_size, base_family = base_family) - + ggplot2::theme( - line = ggplot2::element_line(colors["UZH_Blue"]), - rect = ggplot2::element_rect(fill = "#FFFFFF", linetype = 1, - linewidth = 0.6, colour = colors["UZH_Grey"]), - title = ggplot2::element_text(colour = colors["UZH_Orange"], - size = base_size, family = base_family, - face = "bold"), - plot.subtitle = ggplot2::element_text(colors["UZH_Blue"], - size = base_size*0.85, - family = base_family, - face = "bold.italic"), - plot.caption = ggplot2::element_text(colors["UZH_Grey"], - size = base_size*0.75, - family = base_family, - face = "italic"), - axis.title = ggplot2::element_blank(), - axis.text = ggplot2::element_text(), - axis.ticks = ggplot2::element_blank(), - axis.line = ggplot2::element_blank(), - axis.title.x = ggplot2::element_blank(), - axis.text.x = ggplot2::element_blank(), - axis.ticks.x = ggplot2::element_blank(), - axis.title.y = ggplot2::element_blank(), - axis.text.y = ggplot2::element_blank(), - axis.ticks.y = ggplot2::element_blank(), - panel.grid.major = ggplot2::element_blank(), - panel.grid.minor = ggplot2::element_blank(), - legend.background = ggplot2::element_rect(), - legend.position = "bottom", - legend.direction = "horizontal", - legend.box = "vertical", - strip.background = ggplot2::element_rect())) -} - -#' @rdname map_themes -#' @export -theme_rug <- function(base_size = 12, base_family = "mono") { - colors <- corp_palette("RUG") - (ggplot2::theme_minimal(base_size = base_size, base_family = base_family) - + ggplot2::theme( - line = ggplot2::element_line(colors["RUG_Red"]), - rect = ggplot2::element_rect(fill = "#FFFFFF", linetype = 1, - linewidth = 0.6, colour = colors["RUG_Black"]), - title = ggplot2::element_text(colour = colors["RUG_Red"], - size = base_size, family = base_family, - face = "bold"), - plot.subtitle = ggplot2::element_text(colors["RUG_Black"], - size = base_size*0.85, - family = base_family, - face = "bold.italic"), - plot.caption = ggplot2::element_text(colors["RUG_Red"], - size = base_size*0.75, - family = base_family, - face = "italic"), - axis.title = ggplot2::element_blank(), - axis.text = ggplot2::element_text(), - axis.ticks = ggplot2::element_blank(), - axis.line = ggplot2::element_blank(), - axis.title.x = ggplot2::element_blank(), - axis.text.x = ggplot2::element_blank(), - axis.ticks.x = ggplot2::element_blank(), - axis.title.y = ggplot2::element_blank(), - axis.text.y = ggplot2::element_blank(), - axis.ticks.y = ggplot2::element_blank(), - panel.grid.major = ggplot2::element_blank(), - panel.grid.minor = ggplot2::element_blank(), - legend.background = ggplot2::element_rect(), - legend.position = "bottom", - legend.direction = "horizontal", - legend.box = "vertical", - strip.background = ggplot2::element_rect())) -} - -#' Many scales -#' -#' @description These functions enable to add color scales to be graphs. -#' @name map_scales -#' @param direction Direction for using palette colors. -#' @param ... Extra arguments passed to `ggplot2::discrete_scale()`. -#' @examples -#' #ison_brandes %>% -#' #mutate(core = migraph::node_is_core(ison_brandes)) %>% -#' #graphr(node_color = "core") + -#' #scale_color_iheid() -#' #graphr(ison_physicians[[1]], edge_color = "type") + -#' #scale_edge_color_ethz() -NULL - -#' @rdname map_scales -#' @export -scale_fill_iheid <- function(direction = 1, ...) { - ggplot2::discrete_scale("fill", - palette = palette_gen(palette = "IHEID", direction), - na.value = "black", name = "", ...) -} - -#' @rdname map_scales -#' @export -scale_colour_iheid <- function(direction = 1, ...) { - ggplot2::discrete_scale("colour", - palette = palette_gen(palette = "IHEID", direction), - na.value = "black", name = "", ...) -} - -#' @rdname map_scales -#' @export -scale_color_iheid <- scale_colour_iheid - -#' @rdname map_scales -#' @export -scale_edge_colour_iheid <- function(direction = 1, ...) { - ggplot2::discrete_scale("edge_colour", - palette = palette_gen(palette = "IHEID", direction), - na.value = "black", name = "", ...) -} - -#' @rdname map_scales -#' @export -scale_edge_color_iheid <- scale_edge_colour_iheid - -#' Centres color scales -#' -#' @rdname map_scales -#' @export -scale_fill_centres <- function(direction = 1, ...) { - ggplot2::discrete_scale("fill", - palette = palette_gen(palette = "Centres", direction), - na.value = "black", name = "", ...) -} - -#' @rdname map_scales -#' @export -scale_colour_centres <- function(direction = 1, ...) { - ggplot2::discrete_scale("colour", - palette = palette_gen(palette = "Centres", direction), - na.value = "black", name = "", ...) -} - -#' @rdname map_scales -#' @export -scale_color_centres <- scale_colour_centres - -#' @rdname map_scales -#' @export -scale_edge_colour_centres <- function(direction = 1, ...) { - ggplot2::discrete_scale("edge_colour", - palette = palette_gen(palette = "Centres", direction), - na.value = "black", name = "", ...) -} - -#' @rdname map_scales -#' @export -scale_edge_color_centres <- scale_edge_colour_centres - -#' SDGs color scales -#' -#' @rdname map_scales -#' @export -scale_fill_sdgs <- function(direction = 1, ...) { - ggplot2::discrete_scale("fill", - palette = palette_gen(palette = "SDGs", direction), - na.value = "black", name = "", ...) -} - -#' @rdname map_scales -#' @export -scale_colour_sdgs <- function(direction = 1, ...) { - ggplot2::discrete_scale("colour", - palette = palette_gen(palette = "SDGs", direction), - na.value = "black", name = "", ...) -} - -#' @rdname map_scales -#' @export -scale_color_sdgs <- scale_colour_sdgs - -#' @rdname map_scales -#' @export -scale_edge_colour_sdgs <- function(direction = 1, ...) { - ggplot2::discrete_scale("edge_colour", - palette = palette_gen(palette = "SDGs", direction), - na.value = "black", name = "", ...) -} - -#' @rdname map_scales -#' @export -scale_edge_color_sdgs <- scale_edge_colour_sdgs - -#' ETHZ color scales -#' -#' @rdname map_scales -#' @export -scale_fill_ethz <- function(direction = 1, ...) { - ggplot2::discrete_scale("fill", - palette = palette_gen(palette = "ETHZ", direction), - na.value = "black", name = "", ...) -} - -#' @rdname map_scales -#' @export -scale_colour_ethz <- function(direction = 1, ...) { - ggplot2::discrete_scale("colour", - palette = palette_gen(palette = "ETHZ", direction), - na.value = "black", name = "", ...) -} - -#' @rdname map_scales -#' @export -scale_color_ethz <- scale_colour_ethz - -#' @rdname map_scales -#' @export -scale_edge_colour_ethz <- function(direction = 1, ...) { - ggplot2::discrete_scale("edge_colour", - palette = palette_gen(palette = "ETHZ", direction), - na.value = "black", name = "", ...) -} - -#' @rdname map_scales -#' @export -scale_edge_color_ethz <- scale_edge_colour_ethz - -#' UZH color scales -#' -#' @rdname map_scales -#' @export -scale_fill_uzh <- function(direction = 1, ...) { - ggplot2::discrete_scale("fill", - palette = palette_gen(palette = "UZH", direction), - na.value = "black", name = "", ...) -} - -#' @rdname map_scales -#' @export -scale_colour_uzh <- function(direction = 1, ...) { - ggplot2::discrete_scale("colour", - palette = palette_gen(palette = "UZH", direction), - na.value = "black", name = "", ...) -} - -#' @rdname map_scales -#' @export -scale_color_uzh <- scale_colour_uzh - -#' @rdname map_scales -#' @export -scale_edge_colour_uzh <- function(direction = 1, ...) { - ggplot2::discrete_scale("edge_colour", - palette = palette_gen(palette = "UZH", direction), - na.value = "black", name = "", ...) -} - -#' @rdname map_scales -#' @export -scale_edge_color_uzh <- scale_edge_colour_uzh - -#' RUG color scales -#' -#' @rdname map_scales -#' @export -scale_fill_rug <- function(direction = 1, ...) { - ggplot2::discrete_scale("fill", - palette = palette_gen(palette = "RUG", direction), - na.value = "grey", name = "", ...) -} - -#' @rdname map_scales -#' @export -scale_colour_rug <- function(direction = 1, ...) { - ggplot2::discrete_scale("colour", - palette = palette_gen(palette = "RUG", direction), - na.value = "grey", name = "", ...) -} - -#' @rdname map_scales -#' @export -scale_color_rug <- scale_colour_rug - -#' @rdname map_scales -#' @export -scale_edge_colour_rug <- function(direction = 1, ...) { - ggplot2::discrete_scale("edge_colour", - palette = palette_gen(palette = "RUG", direction), - na.value = "black", name = "", ...) -} - -#' @rdname map_scales -#' @export -scale_edge_color_rug <- scale_edge_colour_rug - -# Helper functions -corp_color <- function(...) { - corp_colors <- c(`IHEIDRed` = "#E20020", `IHEIDBlack` = "#000010", - `IHEIDGrey` = "#6f7072", `AHCD` = "#622550", - `CFFD` = "#0094D8", `CIES` = "#268D2B", - `CTEI` = "#008F92", `CGEN` = "#820C2B", - `CCDP` = "#3E2682", `GLGC` = "#006564", - `GLHC` = "#A8086E", `GLMC` = "#006EAA", - `NoPoverty` = "#e5243b", `ZeroHunger` = "#DDA63A", - `GoodHealth` = "#4C9F38", - `QualityEducation` = "#C5192D", - `GenderEquality` = "#FF3A21", `CleanWater` = "#26BDE2", - `CleanEnergy` = "#FCC30B", - `EconomicGrowth` = "#A21942", - `Innovation` = "#FD6925", - `ReducedInequalities` = "#DD1367", - `SustainableCities` = "#FD9D24", - `ResponsibleConsumption` = "#BF8B2E", - `ClimateAction` = "#3F7E44", `BelowWater` = "#0A97D9", - `OnLand` = "#56C02B", `StrongInstitutions` = "#00689D", - `GoalPartnerships` = "#19486A", - `ETHZ_Blue` = "#215CAF", `ETHZ_Petrol` = "#007894", - `ETHZ_Green` = "#627313", `ETHZ_Bronze` = "#8E6713", - `ETHZ_Red`= "#B7352D", `ETHZ_Purple` = "#A7117A", - `ETHZ_Grey` = "#6F6F6F", `UZH_Blue` = "#0028a5", - `UZH_Grey` = "#a3adb7", `UZH_Orange` = "#dc6027", - `RUG_Red` = "#dc002d", `RUG_Black` = "#000000") - cols <- c(...) - if (is.null(cols)) - return (corp_colors) - corp_colors[cols] -} - -corp_palette <- function(palette, ...) { - corp_palettes <- list(`IHEID` = corp_color("IHEIDRed", - "IHEIDBlack", - "IHEIDGrey"), - `Centres` = corp_color("AHCD", "CFFD", - "CIES", "CTEI", - "CGEN", "CCDP", - "GLGC", "GLHC", - "GLMC"), - `SDGs` = corp_color("NoPoverty", - "ZeroHunger", - "GoodHealth", - "QualityEducation", - "GenderEquality", - "CleanWater", - "CleanEnergy", - "EconomicGrowth", - "Innovation", - "ReducedInequalities", - "SustainableCities", - "ResponsibleConsumption", - "ClimateAction", - "BelowWater", - "OnLand", - "StrongInstitutions", - "GoalPartnerships"), - `ETHZ` = corp_color("ETHZ_Blue", "ETHZ_Petrol", - "ETHZ_Green", "ETHZ_Bronze", - "ETHZ_Red", "ETHZ_Purple", "ETHZ_Grey"), - `UZH` = corp_color("UZH_Blue", "UZH_Grey", "UZH_Orange"), - `RUG` = corp_color("RUG_Red", "RUG_Black")) - unlist(unname(corp_palettes[c(palette)])) -} - -palette_gen <- function(palette, direction = 1) { - function(n) { - if (n > length(corp_palette(palette))) - warning("Not enough colors in this palette!") - else { - all_colors <- corp_palette(palette) - all_colors <- unname(unlist(all_colors)) - all_colors <- if (direction >= 0) all_colors else rev(all_colors) - color_list <- all_colors[1:n] - } - } -} - diff --git a/man/map_themes.Rd b/man/map_themes.Rd deleted file mode 100644 index 288176ee..00000000 --- a/man/map_themes.Rd +++ /dev/null @@ -1,41 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/map_theme.R -\name{map_themes} -\alias{map_themes} -\alias{set_manynet_theme} -\alias{theme_iheid} -\alias{theme_ethz} -\alias{theme_uzh} -\alias{theme_rug} -\title{Many themes} -\usage{ -set_manynet_theme(theme = "default") - -theme_iheid(base_size = 12, base_family = "serif") - -theme_ethz(base_size = 12, base_family = "sans") - -theme_uzh(base_size = 12, base_family = "sans") - -theme_rug(base_size = 12, base_family = "mono") -} -\arguments{ -\item{theme}{String naming a theme. -By default "default".} - -\item{base_size}{Font size, by default 12.} - -\item{base_family}{Font family, by default "sans".} -} -\description{ -These functions enable graphs to be easily and quickly themed, -e.g. changing the default colour of the graph's vertices and edges. -} -\examples{ -to_mentoring(ison_brandes) \%>\% - mutate(color = c(rep(c(1,2,3), 3), 3)) \%>\% - graphr(node_color = "color") + - labs(title = "Who leads and who follows?") + - scale_color_iheid() + - theme_iheid() -} From e3163dc9d733716b730223a19848906809cd9d87 Mon Sep 17 00:00:00 2001 From: James Hollway Date: Fri, 22 Aug 2025 15:04:21 +0200 Subject: [PATCH 14/24] Dropped remaining plot functions --- R/map_plot.R | 272 --------------------------------------------------- 1 file changed, 272 deletions(-) delete mode 100644 R/map_plot.R diff --git a/R/map_plot.R b/R/map_plot.R deleted file mode 100644 index 51ba1c05..00000000 --- a/R/map_plot.R +++ /dev/null @@ -1,272 +0,0 @@ -#' #' Plot agreements network -#' #' -#' #' @description Facilitates plotting of 'many' data. -#' #' @param dataset A dataset from one of the many packages -#' #' or a "consolidated" database. -#' #' @param actor An actor variable. -#' #' "stateID", by default. -#' #' @param treaty_type The type of treaties to be returned. -#' #' NULL, by default. -#' #' Other options are "bilateral" or "multilateral". -#' #' @param key An ID column to collapse by. -#' #' By default "manyID". -#' #' @param layout How do you want the plot to look like? -#' #' An `{ggraph}` layout algorithm. -#' #' If not declared, reasonable defaults are used. -#' #' @name plot_ -#' NULL -#' -#' #' @rdname plot_ -#' #' @importFrom dplyr %>% select mutate distinct rename -#' #' @return A network of agreements' relations. -#' #' @examples -#' #' \donttest{ -#' #' #agreements <- dplyr::filter(manyenviron::agreements$ECOLEX, -#' #' #Begin > "2000-01-01" & Begin < "2000-12-12") -#' #' #plot_agreements(agreements) -#' #'} -#' #' @export -#' plot_agreements <- function(dataset, treaty_type = NULL, key = "manyID", -#' layout = "circle") { -#' manyID <- treatyID <- name <- NULL -#' if (key == "manyID") { -#' out <- dplyr::select(dataset, manyID) %>% -#' dplyr::rename(key = manyID) %>% -#' dplyr::distinct() -#' } else if (key == "treatyID") { -#' out <- dplyr::select(dataset, treatyID) %>% -#' dplyr::rename(key == treatyID) %>% -#' dplyr::distinct() -#' } else snet_abort("Please declare either 'manyID' or 'treatyID'.") -#' if (!is.null(treaty_type)) { -#' if (treaty_type == "bilateral") { -#' out <- out[grep("-", out$key),] -#' } -#' if (treaty_type == "multilateral") { -#' out <- out[grep("-", out$key, invert = TRUE),] -#' } -#' } -#' dplyr::mutate(out, -#' link = ifelse(grepl(":", key), sapply(strsplit(key, ":"), -#' "[", 2), "NA"), -#' key = gsub("\\:.*", "", key)) %>% -#' as_tidygraph() %>% -#' dplyr::filter(name != "NA") %>% -#' graphr(layout = layout) -#' } -#' -#' #' @rdname plot_ -#' #' @importFrom dplyr %>% select distinct all_of rename -#' #' @return A network of agreements' memberships. -#' #' @examples -#' #' \donttest{ -#' #' #memberships <- dplyr::filter(manyenviron::memberships$ECOLEX_MEM, -#' #' #Begin > "2000-01-01" & Begin < "2000-01-31") -#' #' #plot_memberships(memberships) -#' #'} -#' #' @export -#' plot_memberships <- function(dataset, actor = "stateID", treaty_type = NULL, -#' key = "manyID", layout = "bipartite") { -#' manyID <- treatyID <- name <- NULL -#' if (key == "manyID") { -#' out <- dplyr::select(dataset, manyID, dplyr::all_of(actor)) %>% -#' dplyr::rename(key = manyID) %>% -#' dplyr::distinct() -#' } else if (key == "treatyID") { -#' out <- dplyr::select(dataset, treatyID, dplyr::all_of(actor)) %>% -#' dplyr::rename(key == treatyID) %>% -#' dplyr::distinct() -#' } else snet_abort("Please declare either 'manyID' or 'treatyID'.") -#' if (!is.null(treaty_type)) { -#' if (treaty_type == "bilateral") { -#' out <- out[grep("-", out$key),] -#' } -#' if (treaty_type == "multilateral") { -#' out <- out[grep("-", out$key, invert = TRUE),] -#' } -#' } -#' stats::na.omit(out) %>% -#' as_tidygraph() %>% -#' mutate(type = ifelse(grepl("[0-9][0-9][0-9][0-9][A-Za-z]", -#' name), TRUE, FALSE)) %>% -#' graphr(layout = layout) -#' } -#' -#' #' @rdname plot_ -#' #' @importFrom dplyr %>% select mutate distinct filter rename -#' #' @return A plot of agreements' lineages. -#' #' @examples -#' #' \donttest{ -#' #' #lineage <- dplyr::filter(manyenviron::agreements$HUGGO, -#' #' #Begin > "2000-01-01", Begin < "2001-12-31") -#' #' #plot_lineage(lineage) -#' #' } -#' #' @export -#' plot_lineage <- function(dataset, treaty_type = NULL, key = "manyID", -#' layout = "nicely") { -#' manyID <- treatyID <- name <- NULL -#' if (key == "manyID") { -#' out <- dplyr::select(dataset, manyID) %>% -#' dplyr::rename(key = manyID) %>% -#' dplyr::distinct() -#' } else if (key == "treatyID") { -#' out <- dplyr::select(dataset, treatyID) %>% -#' dplyr::rename(key == treatyID) %>% -#' dplyr::distinct() -#' } else snet_abort("Please declare either 'manyID' or 'treatyID'.") -#' if (!is.null(treaty_type)) { -#' if (treaty_type == "bilateral") { -#' out <- out[grep("-", out$key),] -#' } -#' if (treaty_type == "multilateral") { -#' out <- out[grep("-", out$key, invert = TRUE),] -#' } -#' } -#' out %>% -#' dplyr::filter(grepl(":", key)) %>% -#' dplyr::mutate(key1 = gsub(".*\\:", "", key), -#' key = gsub("\\:.*", "", key)) %>% -#' dplyr::distinct() %>% -#' as_tidygraph() %>% -#' graphr(layout = "nicely") -#' } -#' -#' #' @rdname plot_ -#' #' @param date String date from the network snapshot. -#' #' Used by \code{{cshapes}} to plot the correct map. -#' #' By default, 2019-12-31. -#' #' Date can be between 1886-01-01 and 2019-12-31. -#' #' @param theme Theme you would like to use to plot the graph. -#' #' bey defalt, "light". -#' #' Available themes are "light", "dark", and "earth". -#' #' @details `plot_map()` creates a plot of the a unimodal geographical network -#' #' at a single point in time. -#' #' @importFrom dplyr mutate inner_join rename filter -#' #' @return A map of a country level geographical network. -#' #' @examples -#' #' \donttest{ -#' #' #memberships <- dplyr::filter(manyenviron::memberships$ECOLEX_MEM, -#' #' #Begin > "2000-01-01" & Begin < "2000-12-12") -#' #' #plot_map(memberships, actor = "stateID") + -#' #' #ggplot2::labs(title = "Bilateral International Environmental Treaties Signed in the year 2000", -#' #' #subtitle = "Ecolex data") -#' #'} -#' #' @export -#' plot_map <- function(dataset, actor = "stateID", treaty_type = NULL, -#' date = "2019-12-31", theme = "light") { -#' # check packages -#' thisRequires("cshapes") -#' thisRequires("manydata") -#' # Checks for correct input -#' weight <- .data <- NULL -#' # Step 1: get membership list -#' dataset <- manydata::call_treaties(dataset = dataset, actor = actor, -#' treaty_type = treaty_type) -#' # Step 2: set up empty matrix -#' actor <- unique(unlist(strsplit(dataset$Memberships, ", "))) -#' out <- matrix(0, nrow = length(actor), ncol = length(actor)) -#' rownames(out) <- actor -#' colnames(out) <- actor -#' # Step 3: fill matrix with values -#' for (k in colnames(out)) { -#' m <- data.frame(table(unlist(strsplit(grep(k, dataset$Memberships, -#' value = TRUE), ", ")))) -#' m <- m[!(m$Var1 %in% k),] -#' out[k, ] <- ifelse(names(out[k,]) %in% m$Var1 == TRUE, m$Freq/100, out[k,]) -#' } -#' out <- igraph::get.data.frame(igraph::graph.adjacency(out, weighted = TRUE)) -#' # Step 4 = get theme -#' if (theme == "dark") { -#' maptheme <- maptheme(palette = c("#FFFAFA", "#596673")) -#' countrycolor <- "#FFFAFA" -#' } -#' if (theme == "earth") { -#' maptheme <- maptheme(palette = c("#79B52F", "#4259FD")) -#' countrycolor <- "#79B52F" -#' } -#' if (theme == "light") { -#' maptheme <- maptheme(palette = c("#596673", "#FFFAFA")) -#' countrycolor <- "#596673" -#' } -#' # Step 5: import the historical shapefile data -#' cshapes <- cshapes::cshp(as.Date(date), useGW = FALSE) -#' coment <- vapply(countryregex[, 3], # add stateID abbreviations -#' function(x) grepl(x, cshapes$country_name, -#' ignore.case = TRUE, perl = TRUE) * 1, -#' FUN.VALUE = double(length(cshapes$country_name))) -#' colnames(coment) <- countryregex[, 1] -#' rownames(coment) <- cshapes$country_name -#' ab <- apply(coment, 1, function(x) paste(names(x[x == 1]), -#' collapse = "_")) -#' ab[ab == ""] <- NA -#' cshapes <- dplyr::mutate(cshapes, stateID = unname(ab)) -#' # Step 6: create edges with from/to lat/long -#' edges <- out %>% -#' dplyr::inner_join(cshapes, by = c("from" = "stateID")) %>% -#' dplyr::rename(x = .data$caplong, y = .data$caplat) %>% -#' dplyr::inner_join(cshapes, by = c("to" = "stateID")) %>% -#' dplyr::rename(xend = .data$caplong, yend = .data$caplat) -#' # Step 7: Create plotted network from computed edges -#' g <- as_tidygraph(edges) -#' # Step 8: Get the country shapes from the edges dataframe -#' country_shapes <- ggplot2::geom_sf(data = cshapes$geometry, -#' fill = countrycolor) -#' # Step 9: generate the point coordinates for capitals -#' cshapes_pos <- cshapes %>% -#' dplyr::filter(.data$stateID %in% node_names(g)) %>% -#' dplyr::rename(x = .data$caplong, y = .data$caplat) -#' # Reorder things according to nodes in plotted network g -#' cshapes_pos <- cshapes_pos[match(node_names(g), -#' cshapes_pos[["stateID"]]), ] -#' # Step 10: generate the layout -#' lay <- ggraph::create_layout(g, layout = cshapes_pos) -#' edges$circular <- rep(FALSE, nrow(edges)) -#' edges$edge.id <- rep(1, nrow(edges)) -#' # Step 11: plot -#' ggraph::ggraph(lay) + -#' country_shapes + -#' ggraph::geom_edge_arc(data = edges, ggplot2::aes(edge_width = weight), -#' strength = 0.33, alpha = 0.25) + -#' ggraph::scale_edge_width_continuous(range = c(0.5, 2), # scales edge widths -#' guide = "none") + -#' ggraph::geom_node_point(shape = 21, # draw nodes -#' fill = "white", color = "black", stroke = 0.5) + -#' ggraph::geom_node_text(ggplot2::aes(label = node_names(g)), -#' repel = TRUE, size = 3, color = "white", -#' fontface = "bold") + -#' maptheme -#' } -#' -#' # Helper function providing the network map function with a few map themes. -#' maptheme <- function(palette = c("#FFFAFA", "#596673")) { -#' oceancolor <- palette[2] -#' titlecolor <- ifelse(is_dark(palette[2]), "white", "black") -#' # Create map theme -#' maptheme <- ggplot2::theme(panel.grid = ggplot2::element_blank()) + -#' ggplot2::theme(axis.text = ggplot2::element_blank()) + -#' ggplot2::theme(axis.ticks = ggplot2::element_blank()) + -#' ggplot2::theme(axis.title = ggplot2::element_blank()) + -#' ggplot2::theme(legend.position = "bottom") + -#' ggplot2::theme(panel.grid = ggplot2::element_blank()) + -#' ggplot2::theme(panel.background = ggplot2::element_blank()) + -#' ggplot2::theme(plot.background = ggplot2::element_rect(fill = oceancolor)) + -#' ggplot2::theme(plot.title = ggplot2::element_text(color = titlecolor, -#' hjust = 0.1, vjust = 0.1), -#' plot.subtitle = ggplot2::element_text(color = titlecolor, -#' hjust = 0.065, -#' vjust = 0.1), -#' plot.caption = ggplot2::element_text(color = titlecolor, hjust = 0.96)) + -#' ggplot2::theme(plot.margin = ggplot2::unit(c(0, 0, 0.5, 0), "cm")) -#' # This function returns a map theme for ggplot -#' maptheme -#' } -#' -#' # Helper function to check whether a color is light or dark: -#' is_dark <- function(hex) { -#' # Google luma formula for details. -#' luma <- 0.33 * grDevices::col2rgb(hex)[[1]] + -#' 0.5 * grDevices::col2rgb(hex)[[2]] + -#' 0.16 * grDevices::col2rgb(hex)[[3]] -#' isdark <- ifelse(luma < 186, TRUE, FALSE) -#' isdark -#' } From 41c2287b2b1dadcd5be9968046429767de27da6d Mon Sep 17 00:00:00 2001 From: James Hollway Date: Fri, 22 Aug 2025 15:04:59 +0200 Subject: [PATCH 15/24] Dropped ggplot2 reexports --- NAMESPACE | 28 ---------------------------- R/reexports_ggplot2.R | 36 ------------------------------------ man/reexports.Rd | 13 +------------ 3 files changed, 1 insertion(+), 76 deletions(-) delete mode 100644 R/reexports_ggplot2.R diff --git a/NAMESPACE b/NAMESPACE index 7d76eb31..7d0b8ed8 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -315,7 +315,6 @@ export(add_node_attribute) export(add_nodes) export(add_tie_attribute) export(add_ties) -export(aes) export(apply_changes) export(arrange_ties) export(as_changelist) @@ -369,14 +368,7 @@ export(generate_random) export(generate_scalefree) export(generate_smallworld) export(generate_utilities) -export(ggplot) -export(ggsave) -export(ggtitle) export(gloss) -export(graphr) -export(graphs) -export(grapht) -export(guides) export(is.tbl_graph) export(is_acyclic) export(is_aperiodic) @@ -755,8 +747,6 @@ export(write_matrix) export(write_nodelist) export(write_pajek) export(write_ucinet) -export(xlab) -export(ylab) importFrom(cli,cli_div) importFrom(cli,cli_end) importFrom(cli,cli_inform) @@ -778,24 +768,6 @@ importFrom(dplyr,select) importFrom(dplyr,summarise) importFrom(dplyr,tibble) importFrom(dplyr,ungroup) -importFrom(ggplot2,aes) -importFrom(ggplot2,arrow) -importFrom(ggplot2,geom_point) -importFrom(ggplot2,geom_segment) -importFrom(ggplot2,geom_text) -importFrom(ggplot2,ggplot) -importFrom(ggplot2,ggsave) -importFrom(ggplot2,ggtitle) -importFrom(ggplot2,guides) -importFrom(ggplot2,labs) -importFrom(ggplot2,scale_alpha_manual) -importFrom(ggplot2,scale_color_brewer) -importFrom(ggplot2,scale_fill_brewer) -importFrom(ggplot2,scale_size) -importFrom(ggplot2,theme_void) -importFrom(ggplot2,unit) -importFrom(ggplot2,xlab) -importFrom(ggplot2,ylab) importFrom(ggraph,create_layout) importFrom(ggraph,geom_conn_bundle) importFrom(ggraph,geom_edge_link) diff --git a/R/reexports_ggplot2.R b/R/reexports_ggplot2.R deleted file mode 100644 index c65073a9..00000000 --- a/R/reexports_ggplot2.R +++ /dev/null @@ -1,36 +0,0 @@ -#' @importFrom ggplot2 ggplot -#' @export -ggplot2::ggplot - -#' @importFrom ggplot2 ggtitle -#' @export -ggplot2::ggtitle - -#' @importFrom ggplot2 guides -#' @export -ggplot2::guides - -#' @importFrom ggplot2 labs -#' @export -ggplot2::labs - -#' @importFrom ggplot2 xlab -#' @export -ggplot2::xlab - -#' @importFrom ggplot2 ylab -#' @export -ggplot2::ylab - -#' @importFrom ggplot2 aes -#' @export -ggplot2::aes - -#' @importFrom ggplot2 ggsave -#' @export -ggplot2::ggsave - -#' @importFrom ggplot2 scale_size -#' @export -ggplot2::scale_size - diff --git a/man/reexports.Rd b/man/reexports.Rd index 8efbe88d..7cc10505 100644 --- a/man/reexports.Rd +++ b/man/reexports.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/reexports_classes.R, R/reexports_ggplot2.R +% Please edit documentation in R/reexports_classes.R \docType{import} \name{reexports} \alias{reexports} @@ -10,15 +10,6 @@ \alias{.G} \alias{.N} \alias{.E} -\alias{ggplot} -\alias{ggtitle} -\alias{guides} -\alias{labs} -\alias{xlab} -\alias{ylab} -\alias{aes} -\alias{ggsave} -\alias{scale_size} \title{Objects exported from other packages} \keyword{internal} \description{ @@ -28,8 +19,6 @@ below to see their documentation. \describe{ \item{dplyr}{\code{\link[dplyr:reexports]{\%>\%}}} - \item{ggplot2}{\code{\link[ggplot2]{aes}}, \code{\link[ggplot2]{ggplot}}, \code{\link[ggplot2]{ggsave}}, \code{\link[ggplot2:labs]{ggtitle}}, \code{\link[ggplot2]{guides}}, \code{\link[ggplot2]{labs}}, \code{\link[ggplot2]{scale_size}}, \code{\link[ggplot2:labs]{xlab}}, \code{\link[ggplot2:labs]{ylab}}} - \item{igraph}{\code{\link[igraph]{is_igraph}}} \item{tidygraph}{\code{\link[tidygraph:context_accessors]{.E}}, \code{\link[tidygraph:context_accessors]{.G}}, \code{\link[tidygraph:context_accessors]{.N}}, \code{\link[tidygraph:tbl_graph]{is.tbl_graph}}, \code{\link[tidygraph]{with_graph}}} From 98850ab25804b4ec47695d595bc4f7c09615750d Mon Sep 17 00:00:00 2001 From: James Hollway Date: Fri, 22 Aug 2025 15:06:24 +0200 Subject: [PATCH 16/24] Dropped unnecessary dependencies --- DESCRIPTION | 11 +---- NAMESPACE | 9 ---- R/manynet-defunct.R | 76 +++++++++++++++--------------- man/defunct.Rd | 42 ----------------- man/map_scales.Rd | 112 -------------------------------------------- 5 files changed, 39 insertions(+), 211 deletions(-) delete mode 100644 man/map_scales.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 389b1ede..2493889f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -20,25 +20,16 @@ Depends: R (>= 3.6.0) Imports: cli, dplyr (>= 1.1.0), - ggplot2, - ggraph, igraph (>= 2.1.0), network, pillar, tidygraph Suggests: - BiocManager, - concaveman, - gganimate, - ggdendro, - ggforce, - gifski, - graphlayouts, + autograph, knitr, learnr, methods, netdiffuseR, - patchwork, readxl, rmarkdown, RSiena, diff --git a/NAMESPACE b/NAMESPACE index 7d0b8ed8..36244c48 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,6 +1,5 @@ # Generated by roxygen2: do not edit by hand -S3method("+",ggplot) S3method(add_nodes,igraph) S3method(add_nodes,network) S3method(add_nodes,tbl_graph) @@ -768,14 +767,6 @@ importFrom(dplyr,select) importFrom(dplyr,summarise) importFrom(dplyr,tibble) importFrom(dplyr,ungroup) -importFrom(ggraph,create_layout) -importFrom(ggraph,geom_conn_bundle) -importFrom(ggraph,geom_edge_link) -importFrom(ggraph,geom_node_label) -importFrom(ggraph,geom_node_point) -importFrom(ggraph,geom_node_text) -importFrom(ggraph,get_con) -importFrom(ggraph,scale_edge_width_continuous) importFrom(igraph,E) importFrom(igraph,V) importFrom(igraph,add_edges) diff --git a/R/manynet-defunct.R b/R/manynet-defunct.R index 7073c13a..da5fd5b2 100644 --- a/R/manynet-defunct.R +++ b/R/manynet-defunct.R @@ -27,37 +27,37 @@ node_mode <- function(.data) { node_is_mode(.data) } -#' @describeIn defunct Deprecated on 2024-06-17. -#' @export -autographr <- function(.data, layout, labels = TRUE, - node_color, node_shape, node_size, node_group, - edge_color, edge_size, ...) { - .Deprecated("graphr", package = "migraph", - old = "autographr") - graphr(.data, layout, labels, - node_color, node_shape, node_size, node_group, - edge_color, edge_size, ...) -} - -#' @describeIn defunct Deprecated on 2024-06-17. -#' @export -autographs <- function(netlist, waves, based_on = c("first", "last", "both"), ...) { - .Deprecated("graphs", package = "migraph", - old = "autographs") - graphs(netlist, waves, based_on, ...) -} - -#' @describeIn defunct Deprecated on 2024-06-17. -#' @export -autographd <- function(tlist, layout, labels = TRUE, - node_color, node_shape, node_size, edge_color, edge_size, - keep_isolates = TRUE, ...) { - .Deprecated("grapht", package = "migraph", - old = "autographd") - grapht(tlist, layout, labels, - node_color, node_shape, node_size, edge_color, edge_size, - keep_isolates, ...) -} +#' #' @describeIn defunct Deprecated on 2024-06-17. +#' #' @export +#' autographr <- function(.data, layout, labels = TRUE, +#' node_color, node_shape, node_size, node_group, +#' edge_color, edge_size, ...) { +#' .Deprecated("graphr", package = "migraph", +#' old = "autographr") +#' graphr(.data, layout, labels, +#' node_color, node_shape, node_size, node_group, +#' edge_color, edge_size, ...) +#' } + +#' #' @describeIn defunct Deprecated on 2024-06-17. +#' #' @export +#' autographs <- function(netlist, waves, based_on = c("first", "last", "both"), ...) { +#' .Deprecated("graphs", package = "migraph", +#' old = "autographs") +#' graphs(netlist, waves, based_on, ...) +#' } + +#' #' @describeIn defunct Deprecated on 2024-06-17. +#' #' @export +#' autographd <- function(tlist, layout, labels = TRUE, +#' node_color, node_shape, node_size, edge_color, edge_size, +#' keep_isolates = TRUE, ...) { +#' .Deprecated("grapht", package = "migraph", +#' old = "autographd") +#' grapht(tlist, layout, labels, +#' node_color, node_shape, node_size, edge_color, edge_size, +#' keep_isolates, ...) +#' } #' @describeIn defunct Deprecated on 2024-06-14. #' @export @@ -727,13 +727,13 @@ net_by_quad <- function(.data) { net_by_tetrad(.data) } -#' @describeIn defunct Deprecated on 2024-10-10. -#' @export -layout_tbl_graph_quad <- function(.data, circular = FALSE, times = 1000) { - .Deprecated("layout_tbl_graph_tetrad", package = "manynet", - old = "layout_tbl_graph_quad") - layout_tbl_graph_tetrad(.data, circular = circular, times = times) -} +#' #' @describeIn defunct Deprecated on 2024-10-10. +#' #' @export +#' layout_tbl_graph_quad <- function(.data, circular = FALSE, times = 1000) { +#' .Deprecated("layout_tbl_graph_tetrad", package = "manynet", +#' old = "layout_tbl_graph_quad") +#' layout_tbl_graph_tetrad(.data, circular = circular, times = times) +#' } #' @describeIn defunct Deprecated on 2024-12-30. #' @export diff --git a/man/defunct.Rd b/man/defunct.Rd index 7258166b..1a5285e1 100644 --- a/man/defunct.Rd +++ b/man/defunct.Rd @@ -4,9 +4,6 @@ \alias{defunct} \alias{pkg_data} \alias{node_mode} -\alias{autographr} -\alias{autographs} -\alias{autographd} \alias{node_optimal} \alias{node_kernighanlin} \alias{node_edge_betweenness} @@ -89,7 +86,6 @@ \alias{node_core} \alias{node_by_quad} \alias{net_by_quad} -\alias{layout_tbl_graph_quad} \alias{net_hazard} \title{Functions that have been renamed, superseded, or are no longer working} \usage{ @@ -97,34 +93,6 @@ pkg_data(pkg = "manynet") node_mode(.data) -autographr( - .data, - layout, - labels = TRUE, - node_color, - node_shape, - node_size, - node_group, - edge_color, - edge_size, - ... -) - -autographs(netlist, waves, based_on = c("first", "last", "both"), ...) - -autographd( - tlist, - layout, - labels = TRUE, - node_color, - node_shape, - node_size, - edge_color, - edge_size, - keep_isolates = TRUE, - ... -) - node_optimal(.data) node_kernighanlin(.data) @@ -295,8 +263,6 @@ node_by_quad(.data) net_by_quad(.data) -layout_tbl_graph_quad(.data, circular = FALSE, times = 1000) - net_hazard(.data) } \description{ @@ -314,12 +280,6 @@ wherever possible and update your scripts accordingly. \item \code{node_mode()}: Deprecated on 2024-06-17. -\item \code{autographr()}: Deprecated on 2024-06-17. - -\item \code{autographs()}: Deprecated on 2024-06-17. - -\item \code{autographd()}: Deprecated on 2024-06-17. - \item \code{node_optimal()}: Deprecated on 2024-06-14. \item \code{node_kernighanlin()}: Deprecated on 2024-06-14. @@ -486,8 +446,6 @@ wherever possible and update your scripts accordingly. \item \code{net_by_quad()}: Deprecated on 2024-10-10. -\item \code{layout_tbl_graph_quad()}: Deprecated on 2024-10-10. - \item \code{net_hazard()}: Deprecated on 2024-12-30. }} diff --git a/man/map_scales.Rd b/man/map_scales.Rd deleted file mode 100644 index bdee1bc6..00000000 --- a/man/map_scales.Rd +++ /dev/null @@ -1,112 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/map_theme.R -\name{map_scales} -\alias{map_scales} -\alias{scale_fill_iheid} -\alias{scale_colour_iheid} -\alias{scale_color_iheid} -\alias{scale_edge_colour_iheid} -\alias{scale_edge_color_iheid} -\alias{scale_fill_centres} -\alias{scale_colour_centres} -\alias{scale_color_centres} -\alias{scale_edge_colour_centres} -\alias{scale_edge_color_centres} -\alias{scale_fill_sdgs} -\alias{scale_colour_sdgs} -\alias{scale_color_sdgs} -\alias{scale_edge_colour_sdgs} -\alias{scale_edge_color_sdgs} -\alias{scale_fill_ethz} -\alias{scale_colour_ethz} -\alias{scale_color_ethz} -\alias{scale_edge_colour_ethz} -\alias{scale_edge_color_ethz} -\alias{scale_fill_uzh} -\alias{scale_colour_uzh} -\alias{scale_color_uzh} -\alias{scale_edge_colour_uzh} -\alias{scale_edge_color_uzh} -\alias{scale_fill_rug} -\alias{scale_colour_rug} -\alias{scale_color_rug} -\alias{scale_edge_colour_rug} -\alias{scale_edge_color_rug} -\title{Many scales} -\usage{ -scale_fill_iheid(direction = 1, ...) - -scale_colour_iheid(direction = 1, ...) - -scale_color_iheid(direction = 1, ...) - -scale_edge_colour_iheid(direction = 1, ...) - -scale_edge_color_iheid(direction = 1, ...) - -scale_fill_centres(direction = 1, ...) - -scale_colour_centres(direction = 1, ...) - -scale_color_centres(direction = 1, ...) - -scale_edge_colour_centres(direction = 1, ...) - -scale_edge_color_centres(direction = 1, ...) - -scale_fill_sdgs(direction = 1, ...) - -scale_colour_sdgs(direction = 1, ...) - -scale_color_sdgs(direction = 1, ...) - -scale_edge_colour_sdgs(direction = 1, ...) - -scale_edge_color_sdgs(direction = 1, ...) - -scale_fill_ethz(direction = 1, ...) - -scale_colour_ethz(direction = 1, ...) - -scale_color_ethz(direction = 1, ...) - -scale_edge_colour_ethz(direction = 1, ...) - -scale_edge_color_ethz(direction = 1, ...) - -scale_fill_uzh(direction = 1, ...) - -scale_colour_uzh(direction = 1, ...) - -scale_color_uzh(direction = 1, ...) - -scale_edge_colour_uzh(direction = 1, ...) - -scale_edge_color_uzh(direction = 1, ...) - -scale_fill_rug(direction = 1, ...) - -scale_colour_rug(direction = 1, ...) - -scale_color_rug(direction = 1, ...) - -scale_edge_colour_rug(direction = 1, ...) - -scale_edge_color_rug(direction = 1, ...) -} -\arguments{ -\item{direction}{Direction for using palette colors.} - -\item{...}{Extra arguments passed to \code{ggplot2::discrete_scale()}.} -} -\description{ -These functions enable to add color scales to be graphs. -} -\examples{ -#ison_brandes \%>\% -#mutate(core = migraph::node_is_core(ison_brandes)) \%>\% -#graphr(node_color = "core") + -#scale_color_iheid() -#graphr(ison_physicians[[1]], edge_color = "type") + -#scale_edge_color_ethz() -} From 731ea32a94ea5941905f3d6331bab7551ff30106 Mon Sep 17 00:00:00 2001 From: James Hollway Date: Fri, 22 Aug 2025 15:07:20 +0200 Subject: [PATCH 17/24] Avoided using graph*() in examples --- R/make_generate.R | 12 ++++++------ R/make_play.R | 8 ++++---- R/make_read.R | 2 +- R/manip_correlation.R | 4 ++-- R/manip_format.R | 2 +- R/manip_reformed.R | 10 +++++----- R/manip_ties.R | 2 +- R/mark_ties.R | 28 ++++++++++++++-------------- R/measure_centrality.R | 10 ++++------ R/member_components.R | 3 +-- man/make_cran.Rd | 2 +- man/make_learning.Rd | 4 ++-- man/make_play.Rd | 4 ++-- man/make_random.Rd | 4 ++-- man/make_stochastic.Rd | 8 ++++---- man/manip_paths.Rd | 4 ++-- man/manip_permutation.Rd | 4 ++-- man/manip_project.Rd | 6 +++--- man/manip_reformat.Rd | 2 +- man/manip_ties.Rd | 2 +- man/mark_ties.Rd | 4 ++-- man/mark_triangles.Rd | 24 ++++++++++++------------ man/measure_central_between.Rd | 5 ++--- man/measure_central_close.Rd | 5 ++--- 24 files changed, 77 insertions(+), 82 deletions(-) diff --git a/R/make_generate.R b/R/make_generate.R index 30925f9c..83eeb222 100644 --- a/R/make_generate.R +++ b/R/make_generate.R @@ -53,8 +53,8 @@ NULL #' _Publicationes Mathematicae_. 6: 290–297. #' @importFrom igraph sample_bipartite sample_gnp sample_gnm #' @examples -#' graphr(generate_random(12, 0.4)) -#' # graphr(generate_random(c(6, 6), 0.4)) +#' generate_random(12, 0.4) +#' # generate_random(c(6, 6), 0.4) #' @export generate_random <- function(n, p = 0.5, directed = FALSE, with_attr = TRUE) { if(is_manynet(n)){ @@ -243,8 +243,8 @@ NULL #' \doi{10.1038/30918}. #' @importFrom igraph sample_smallworld #' @examples -#' graphr(generate_smallworld(12, 0.025)) -#' graphr(generate_smallworld(12, 0.25)) +#' generate_smallworld(12, 0.025) +#' generate_smallworld(12, 0.25) #' @export generate_smallworld <- function(n, p = 0.05, directed = FALSE, width = 2) { directed <- infer_directed(n, directed) @@ -270,8 +270,8 @@ generate_smallworld <- function(n, p = 0.05, directed = FALSE, width = 2) { #' _Science_ 286(5439):509–12. #' \doi{10.1126/science.286.5439.509}. #' @examples -#' graphr(generate_scalefree(12, 0.25)) -#' graphr(generate_scalefree(12, 1.25)) +#' generate_scalefree(12, 0.25) +#' generate_scalefree(12, 1.25) #' @export generate_scalefree <- function(n, p = 1, directed = FALSE) { directed <- infer_directed(n, directed) diff --git a/R/make_play.R b/R/make_play.R index 060d50da..71141a95 100644 --- a/R/make_play.R +++ b/R/make_play.R @@ -146,8 +146,8 @@ NULL #' original network. #' @examples #' smeg <- generate_smallworld(15, 0.025) -#' plot(play_diffusion(smeg, recovery = 0.4)) -#' #graphr(play_diffusion(ison_karateka)) +#' # autograph::plot(play_diffusion(smeg, recovery = 0.4)) +#' # autograph::graphr(play_diffusion(ison_karateka)) #' @export play_diffusion <- function(.data, seeds = 1, @@ -406,8 +406,8 @@ play_learning <- function(.data, #' latticeEg <- add_node_attribute(latticeEg, "startValues", startValues) #' latticeEg #' play_segregation(latticeEg, "startValues", 0.5) -#' # graphr(latticeEg, node_color = "startValues", node_size = 5) + -#' # graphr(play_segregation(latticeEg, "startValues", 0.2), +#' # autograph::graphr(latticeEg, node_color = "startValues", node_size = 5) + +#' # autograph::graphr(play_segregation(latticeEg, "startValues", 0.2), #' # node_color = "startValues", node_size = 5) #' @export play_segregation <- function(.data, diff --git a/R/make_read.R b/R/make_read.R index ec60a1c3..f5ed9165 100644 --- a/R/make_read.R +++ b/R/make_read.R @@ -707,7 +707,7 @@ write_graphml <- function(.data, #' @examples #' # mnet <- read_cran() #' # mnet <- to_ego(mnet, "manynet", max_dist = 2) -#' # graphr(mnet, layout = "hierarchy", +#' # autograph::graphr(mnet, layout = "hierarchy", #' # edge_color = "type", node_color = "Compilation") #' @export read_cran <- function(pkg = "all"){ diff --git a/R/manip_correlation.R b/R/manip_correlation.R index 6ae65023..1dadeb08 100644 --- a/R/manip_correlation.R +++ b/R/manip_correlation.R @@ -75,8 +75,8 @@ NULL #' should be retained. #' By default TRUE. #' @examples -#' graphr(ison_adolescents, node_size = 4) -#' graphr(to_permuted(ison_adolescents), node_size = 4) +#' autograph::graphr(ison_adolescents, node_size = 4) +#' autograph::graphr(to_permuted(ison_adolescents), node_size = 4) #' @export to_permuted <- function(.data, with_attr = TRUE) { out <- as_matrix(.data) diff --git a/R/manip_format.R b/R/manip_format.R index 2cf76024..6c49a66c 100644 --- a/R/manip_format.R +++ b/R/manip_format.R @@ -378,7 +378,7 @@ to_acyclic.network <- function(.data) { #' @importFrom igraph complementer #' @examples #' to_anti(ison_southern_women) -#' #graphr(to_anti(ison_southern_women)) +#' # autograph::graphr(to_anti(ison_southern_women)) #' @export to_anti <- function(.data) UseMethod("to_anti") diff --git a/R/manip_reformed.R b/R/manip_reformed.R index 9b463eaf..0b3b6603 100644 --- a/R/manip_reformed.R +++ b/R/manip_reformed.R @@ -55,8 +55,8 @@ NULL #' @examples #' to_mode1(ison_southern_women) #' to_mode2(ison_southern_women) -#' #graphr(to_mode1(ison_southern_women)) -#' #graphr(to_mode2(ison_southern_women)) +#' #autograph::graphr(to_mode1(ison_southern_women)) +#' #autograph::graphr(to_mode2(ison_southern_women)) #' @export to_mode1 <- function(.data, similarity = c("count","jaccard","rand","pearson","yule")) UseMethod("to_mode1") @@ -161,7 +161,7 @@ to_mode2.data.frame <- function(.data, similarity = c("count","jaccard","rand"," #' @importFrom igraph make_line_graph E #' @examples #' to_ties(ison_adolescents) -#' #graphr(to_ties(ison_adolescents)) +#' #autograph::graphr(to_ties(ison_adolescents)) #' @export to_ties <- function(.data) UseMethod("to_ties") @@ -692,7 +692,7 @@ to_matching.matrix <- function(.data, mark = "type", capacities = NULL){ #' _Annals of the American Academy of Political and Social Science_ 566: 56-67. #' \doi{10.1177/000271629956600105} #' @examples -#' graphr(to_mentoring(ison_adolescents)) +#' autograph::graphr(to_mentoring(ison_adolescents)) #' @export to_mentoring <- function(.data, elites = 0.1) UseMethod("to_mentoring") @@ -752,7 +752,7 @@ to_mentoring.igraph <- function(.data, elites = 0.1){ #' \doi{10.1007/BF01442866} #' @examples #' to_eulerian(delete_nodes(ison_koenigsberg, "Lomse")) -#' #graphr(to_eulerian(delete_nodes(ison_koenigsberg, "Lomse"))) +#' #autograph::graphr(to_eulerian(delete_nodes(ison_koenigsberg, "Lomse"))) #' @export to_eulerian <- function(.data) UseMethod("to_eulerian") diff --git a/R/manip_ties.R b/R/manip_ties.R index 0201a1cd..0d1bf1b4 100644 --- a/R/manip_ties.R +++ b/R/manip_ties.R @@ -30,7 +30,7 @@ NULL #' @param ties The number of ties to be added or an even list of ties. #' @importFrom igraph add_edges #' @examples -#' ison_adolescents %>% add_ties(c("Betty","Tina")) %>% graphr() +#' ison_adolescents %>% add_ties(c("Betty","Tina")) #' @export add_ties <- function(.data, ties, attribute = NULL) UseMethod("add_ties") diff --git a/R/mark_ties.R b/R/mark_ties.R index f2f14b28..e7939d41 100644 --- a/R/mark_ties.R +++ b/R/mark_ties.R @@ -86,8 +86,8 @@ tie_is_bridge <- function(.data){ #' @importFrom igraph all_shortest_paths #' @examples #' ison_adolescents %>% -#' mutate_ties(route = tie_is_path(from = "Jane", to = 7)) %>% -#' graphr(edge_colour = "route") +#' mutate_ties(route = tie_is_path(from = "Jane", to = 7)) +#' #graphr(edge_colour = "route") #' @export tie_is_path <- function(.data, from, to, all_paths = FALSE){ if(missing(.data)) {expect_edges(); .data <- .G()} @@ -125,8 +125,8 @@ NULL #' @importFrom igraph triangles #' @examples #' ison_monks %>% to_uniplex("like") %>% -#' mutate_ties(tri = tie_is_triangular()) %>% -#' graphr(edge_color = "tri") +#' mutate_ties(tri = tie_is_triangular()) +#' #graphr(edge_color = "tri") #' @export tie_is_triangular <- function(.data){ if(missing(.data)) {expect_edges(); .data <- .G()} @@ -146,8 +146,8 @@ tie_is_triangular <- function(.data){ #' @rdname mark_triangles #' @examples #' ison_adolescents %>% to_directed() %>% -#' mutate_ties(trans = tie_is_transitive()) %>% -#' graphr(edge_color = "trans") +#' mutate_ties(trans = tie_is_transitive()) +#' #graphr(edge_color = "trans") #' @export tie_is_transitive <- function(.data){ if(missing(.data)) {expect_edges(); .data <- .G()} @@ -163,8 +163,8 @@ tie_is_transitive <- function(.data){ #' @rdname mark_triangles #' @examples #' ison_adolescents %>% to_directed() %>% -#' mutate_ties(trip = tie_is_triplet()) %>% -#' graphr(edge_color = "trip") +#' mutate_ties(trip = tie_is_triplet()) +#' #graphr(edge_color = "trip") #' @export tie_is_triplet <- function(.data){ if(missing(.data)) {expect_edges(); .data <- .G()} @@ -185,8 +185,8 @@ tie_is_triplet <- function(.data){ #' @rdname mark_triangles #' @examples #' ison_adolescents %>% to_directed() %>% -#' mutate_ties(cyc = tie_is_cyclical()) %>% -#' graphr(edge_color = "cyc") +#' mutate_ties(cyc = tie_is_cyclical()) +#' #graphr(edge_color = "cyc") #' @export tie_is_cyclical <- function(.data){ if(missing(.data)) {expect_edges(); .data <- .G()} @@ -202,8 +202,8 @@ tie_is_cyclical <- function(.data){ #' @rdname mark_triangles #' @examples #' ison_monks %>% to_uniplex("like") %>% -#' mutate_ties(simmel = tie_is_simmelian()) %>% -#' graphr(edge_color = "simmel") +#' mutate_ties(simmel = tie_is_simmelian()) +#' #graphr(edge_color = "simmel") #' @export tie_is_simmelian <- function(.data){ if(missing(.data)) {expect_edges(); .data <- .G()} @@ -218,8 +218,8 @@ tie_is_simmelian <- function(.data){ #' @rdname mark_triangles #' @examples #' generate_random(8, directed = TRUE) %>% -#' mutate_ties(forbid = tie_is_forbidden()) %>% -#' graphr(edge_color = "forbid") +#' mutate_ties(forbid = tie_is_forbidden()) +#' #graphr(edge_color = "forbid") #' @export tie_is_forbidden <- function(.data){ if(missing(.data)) {expect_edges(); .data <- .G()} diff --git a/R/measure_centrality.R b/R/measure_centrality.R index a58f0944..4b790c00 100644 --- a/R/measure_centrality.R +++ b/R/measure_centrality.R @@ -444,9 +444,8 @@ node_stress <- function(.data, normalized = TRUE){ #' @importFrom igraph edge_betweenness #' @examples #' (tb <- tie_betweenness(ison_adolescents)) -#' plot(tb) -#' ison_adolescents %>% mutate_ties(weight = tb) %>% -#' graphr() +#' #autograph::plot(tb) +#' ison_adolescents %>% mutate_ties(weight = tb) #' @export tie_betweenness <- function(.data, normalized = TRUE){ if(missing(.data)) {expect_nodes(); .data <- .G()} @@ -783,9 +782,8 @@ node_vitality <- function(.data, normalized = TRUE){ #' @rdname measure_central_close #' @examples #' (ec <- tie_closeness(ison_adolescents)) -#' plot(ec) -#' ison_adolescents %>% mutate_ties(weight = ec) %>% -#' graphr() +#' #autograph::plot(ec) +#' ison_adolescents %>% mutate_ties(weight = ec) #' @export tie_closeness <- function(.data, normalized = TRUE){ if(missing(.data)) {expect_nodes(); .data <- .G()} diff --git a/R/member_components.R b/R/member_components.R index f4eea507..fec09ea6 100644 --- a/R/member_components.R +++ b/R/member_components.R @@ -36,8 +36,7 @@ NULL #' @importFrom igraph components # #' @examples # #' ison_monks %>% to_uniplex("esteem") %>% -# #' mutate_nodes(comp = node_in_component()) %>% -# #' graphr(node_color = "comp") +# #' mutate_nodes(comp = node_in_component()) #' @export node_in_component <- function(.data){ if(missing(.data)) {expect_nodes(); .data <- .G()} diff --git a/man/make_cran.Rd b/man/make_cran.Rd index b49d70b3..adb16ed8 100644 --- a/man/make_cran.Rd +++ b/man/make_cran.Rd @@ -37,7 +37,7 @@ by \href{https://github.com/stocnet/manynet/issues}{raising an issue on Github}. \examples{ # mnet <- read_cran() # mnet <- to_ego(mnet, "manynet", max_dist = 2) -# graphr(mnet, layout = "hierarchy", +# autograph::graphr(mnet, layout = "hierarchy", # edge_color = "type", node_color = "Compilation") } \seealso{ diff --git a/man/make_learning.Rd b/man/make_learning.Rd index b06808d4..ec07a0b6 100644 --- a/man/make_learning.Rd +++ b/man/make_learning.Rd @@ -87,8 +87,8 @@ from other nodes whose beliefs are not too dissimilar from their own. latticeEg <- add_node_attribute(latticeEg, "startValues", startValues) latticeEg play_segregation(latticeEg, "startValues", 0.5) - # graphr(latticeEg, node_color = "startValues", node_size = 5) + - # graphr(play_segregation(latticeEg, "startValues", 0.2), + # autograph::graphr(latticeEg, node_color = "startValues", node_size = 5) + + # autograph::graphr(play_segregation(latticeEg, "startValues", 0.2), # node_color = "startValues", node_size = 5) } \references{ diff --git a/man/make_play.Rd b/man/make_play.Rd index fe1b0621..e8e0333a 100644 --- a/man/make_play.Rd +++ b/man/make_play.Rd @@ -185,8 +185,8 @@ This can be used in in SEI, SEIS, SEIR, and SEIRS models. \examples{ smeg <- generate_smallworld(15, 0.025) - plot(play_diffusion(smeg, recovery = 0.4)) - #graphr(play_diffusion(ison_karateka)) + # autograph::plot(play_diffusion(smeg, recovery = 0.4)) + # autograph::graphr(play_diffusion(ison_karateka)) } \seealso{ Other makes: diff --git a/man/make_random.Rd b/man/make_random.Rd index 0146a541..e8471363 100644 --- a/man/make_random.Rd +++ b/man/make_random.Rd @@ -105,8 +105,8 @@ As an alternative, an existing network can be provided to \code{n} and the number of modes, nodes, and directedness will be inferred. } \examples{ -graphr(generate_random(12, 0.4)) -# graphr(generate_random(c(6, 6), 0.4)) +generate_random(12, 0.4) +# generate_random(c(6, 6), 0.4) } \references{ \subsection{On random networks}{ diff --git a/man/make_stochastic.Rd b/man/make_stochastic.Rd index f2930b77..0a977e6b 100644 --- a/man/make_stochastic.Rd +++ b/man/make_stochastic.Rd @@ -104,10 +104,10 @@ As an alternative, an existing network can be provided to \code{n} and the number of modes, nodes, and directedness will be inferred. } \examples{ -graphr(generate_smallworld(12, 0.025)) -graphr(generate_smallworld(12, 0.25)) -graphr(generate_scalefree(12, 0.25)) -graphr(generate_scalefree(12, 1.25)) +generate_smallworld(12, 0.025) +generate_smallworld(12, 0.25) +generate_scalefree(12, 0.25) +generate_scalefree(12, 1.25) generate_fire(10) generate_islands(10) generate_citations(10) diff --git a/man/manip_paths.Rd b/man/manip_paths.Rd index 0f4f0868..468692ef 100644 --- a/man/manip_paths.Rd +++ b/man/manip_paths.Rd @@ -109,9 +109,9 @@ This is, however, computationally slower. \examples{ to_matching(ison_southern_women) -graphr(to_mentoring(ison_adolescents)) +autograph::graphr(to_mentoring(ison_adolescents)) to_eulerian(delete_nodes(ison_koenigsberg, "Lomse")) - #graphr(to_eulerian(delete_nodes(ison_koenigsberg, "Lomse"))) + #autograph::graphr(to_eulerian(delete_nodes(ison_koenigsberg, "Lomse"))) } \references{ \subsection{On matching}{ diff --git a/man/manip_permutation.Rd b/man/manip_permutation.Rd index 0578c343..f1a21fe6 100644 --- a/man/manip_permutation.Rd +++ b/man/manip_permutation.Rd @@ -27,8 +27,8 @@ on both the rows and columns (for a one-mode network) or on each of the rows and columns (for a two-mode network). } \examples{ -graphr(ison_adolescents, node_size = 4) -graphr(to_permuted(ison_adolescents), node_size = 4) +autograph::graphr(ison_adolescents, node_size = 4) +autograph::graphr(to_permuted(ison_adolescents), node_size = 4) } \seealso{ Other modifications: diff --git a/man/manip_project.Rd b/man/manip_project.Rd index 0b59bb28..42386efe 100644 --- a/man/manip_project.Rd +++ b/man/manip_project.Rd @@ -71,10 +71,10 @@ Below are the currently implemented S3 methods:\tabular{lrrrrr}{ \examples{ to_mode1(ison_southern_women) to_mode2(ison_southern_women) -#graphr(to_mode1(ison_southern_women)) -#graphr(to_mode2(ison_southern_women)) +#autograph::graphr(to_mode1(ison_southern_women)) +#autograph::graphr(to_mode2(ison_southern_women)) to_ties(ison_adolescents) -#graphr(to_ties(ison_adolescents)) +#autograph::graphr(to_ties(ison_adolescents)) } \seealso{ Other modifications: diff --git a/man/manip_reformat.Rd b/man/manip_reformat.Rd index 464f1716..09b47055 100644 --- a/man/manip_reformat.Rd +++ b/man/manip_reformat.Rd @@ -70,7 +70,7 @@ This essentially has no effect on undirected networks or reciprocated ties. }} \examples{ to_anti(ison_southern_women) -#graphr(to_anti(ison_southern_women)) +# autograph::graphr(to_anti(ison_southern_women)) } \seealso{ Other modifications: diff --git a/man/manip_ties.Rd b/man/manip_ties.Rd index 531efcc0..c53695bf 100644 --- a/man/manip_ties.Rd +++ b/man/manip_ties.Rd @@ -83,7 +83,7 @@ Note that while \verb{add_*()}/\verb{delete_*()} functions operate similarly as other <- create_filled(4) \%>\% mutate(name = c("A", "B", "C", "D")) mutate_ties(other, form = 1:6) \%>\% filter_ties(form < 4) add_tie_attribute(other, "weight", c(1, 2, 2, 2, 1, 2)) -ison_adolescents \%>\% add_ties(c("Betty","Tina")) \%>\% graphr() +ison_adolescents \%>\% add_ties(c("Betty","Tina")) delete_ties(ison_adolescents, 3) delete_ties(ison_adolescents, "Alice|Sue") } diff --git a/man/mark_ties.Rd b/man/mark_ties.Rd index 8979a1aa..180bee9f 100644 --- a/man/mark_ties.Rd +++ b/man/mark_ties.Rd @@ -61,8 +61,8 @@ tie_is_reciprocated(ison_algebra) tie_is_feedback(ison_algebra) tie_is_bridge(ison_brandes) ison_adolescents \%>\% - mutate_ties(route = tie_is_path(from = "Jane", to = 7)) \%>\% - graphr(edge_colour = "route") + mutate_ties(route = tie_is_path(from = "Jane", to = 7)) + #graphr(edge_colour = "route") } \seealso{ Other marks: diff --git a/man/mark_triangles.Rd b/man/mark_triangles.Rd index aeb301cb..edb37409 100644 --- a/man/mark_triangles.Rd +++ b/man/mark_triangles.Rd @@ -52,23 +52,23 @@ are cohesively connected. } \examples{ ison_monks \%>\% to_uniplex("like") \%>\% - mutate_ties(tri = tie_is_triangular()) \%>\% - graphr(edge_color = "tri") + mutate_ties(tri = tie_is_triangular()) + #graphr(edge_color = "tri") ison_adolescents \%>\% to_directed() \%>\% - mutate_ties(trans = tie_is_transitive()) \%>\% - graphr(edge_color = "trans") + mutate_ties(trans = tie_is_transitive()) + #graphr(edge_color = "trans") ison_adolescents \%>\% to_directed() \%>\% - mutate_ties(trip = tie_is_triplet()) \%>\% - graphr(edge_color = "trip") + mutate_ties(trip = tie_is_triplet()) + #graphr(edge_color = "trip") ison_adolescents \%>\% to_directed() \%>\% - mutate_ties(cyc = tie_is_cyclical()) \%>\% - graphr(edge_color = "cyc") + mutate_ties(cyc = tie_is_cyclical()) + #graphr(edge_color = "cyc") ison_monks \%>\% to_uniplex("like") \%>\% - mutate_ties(simmel = tie_is_simmelian()) \%>\% - graphr(edge_color = "simmel") + mutate_ties(simmel = tie_is_simmelian()) + #graphr(edge_color = "simmel") generate_random(8, directed = TRUE) \%>\% - mutate_ties(forbid = tie_is_forbidden()) \%>\% - graphr(edge_color = "forbid") + mutate_ties(forbid = tie_is_forbidden()) + #graphr(edge_color = "forbid") tie_is_imbalanced(ison_marvel_relationships) } \seealso{ diff --git a/man/measure_central_between.Rd b/man/measure_central_between.Rd index b50e1b57..cb90d93c 100644 --- a/man/measure_central_between.Rd +++ b/man/measure_central_between.Rd @@ -107,9 +107,8 @@ nodes, and thus associated with bridging or spanning boundaries. node_betweenness(ison_southern_women) node_induced(ison_adolescents) (tb <- tie_betweenness(ison_adolescents)) -plot(tb) -ison_adolescents \%>\% mutate_ties(weight = tb) \%>\% - graphr() +#autograph::plot(tb) +ison_adolescents \%>\% mutate_ties(weight = tb) net_betweenness(ison_southern_women, direction = "in") } \references{ diff --git a/man/measure_central_close.Rd b/man/measure_central_close.Rd index ac2a6e3a..5c22c87e 100644 --- a/man/measure_central_close.Rd +++ b/man/measure_central_close.Rd @@ -176,9 +176,8 @@ removing that node would disconnect the network. node_closeness(ison_southern_women) node_reach(ison_adolescents) (ec <- tie_closeness(ison_adolescents)) -plot(ec) -ison_adolescents \%>\% mutate_ties(weight = ec) \%>\% - graphr() +#autograph::plot(ec) +ison_adolescents \%>\% mutate_ties(weight = ec) net_closeness(ison_southern_women, direction = "in") } \references{ From f147b4a0230339ead09d557a2d73f5815f0fea15 Mon Sep 17 00:00:00 2001 From: James Hollway Date: Fri, 22 Aug 2025 15:07:39 +0200 Subject: [PATCH 18/24] Moved autograph related tests to that package --- tests/testthat/test-map_autograph.R | 187 ---------------------------- tests/testthat/test-map_theme.R | 58 --------- 2 files changed, 245 deletions(-) delete mode 100644 tests/testthat/test-map_autograph.R delete mode 100644 tests/testthat/test-map_theme.R diff --git a/tests/testthat/test-map_autograph.R b/tests/testthat/test-map_autograph.R deleted file mode 100644 index e44590be..00000000 --- a/tests/testthat/test-map_autograph.R +++ /dev/null @@ -1,187 +0,0 @@ -test_that("unweighted, unsigned, undirected networks graph correctly", { - skip_on_cran() - # Unweighted, unsigned, undirected network - test_brandes <- graphr(ison_brandes) - # Node position - expect_equal(round(test_brandes[["data"]][["x"]][[1]]), 3) - expect_equal(round(test_brandes[["data"]][["y"]][[1]]), -1) - # Edge parameters - expect_equal(test_brandes[["layers"]][[1]][["aes_params"]][["edge_alpha"]], 0.4) - expect_equal(test_brandes[["layers"]][[1]][["aes_params"]][["edge_linetype"]], "solid") - # Node parameters - expect_equal(round(test_brandes[["layers"]][[2]][["aes_params"]][["size"]]), 11) - expect_equal(as.character(test_brandes[["layers"]][[2]][["aes_params"]][["shape"]]), "circle") -}) - -test_that("unweighted, signed, undirected networks graph correctly", { - skip_on_cran() - # Unweighted, signed, undirected network - test_marvel <- graphr(to_giant(ison_marvel_relationships)) - # Node position - expect_equal(round(test_marvel[["data"]][["x"]][[1]]), -1) - expect_equal(round(test_marvel[["data"]][["y"]][[1]]), 1) - # Edge parameters - expect_equal(test_marvel[["layers"]][[2]][["aes_params"]][["edge_alpha"]], 0.4) - # Node parameters - expect_equal(test_marvel[["layers"]][[4]][["aes_params"]][["size"]], 3) - #expect_equal(test_marvel[["layers"]][[4]][["aes_params"]][["shape"]], "circle") -}) - -test_that("unweighted, unsigned, directed networks graph correctly", { - skip_on_cran() - # Unweighted, unsigned, directed network - test_algebra <- graphr(ison_algebra) - # Node position - expect_equal(round(test_algebra[["data"]][["x"]][[1]]), 0) - expect_equal(round(test_algebra[["data"]][["y"]][[1]]), 0) - # Edge parameters - expect_equal(test_algebra[["layers"]][[1]][["aes_params"]][["edge_alpha"]], 0.4) - expect_equal(test_algebra[["layers"]][[1]][["aes_params"]][["edge_linetype"]], "solid") - #expect_equal(test_algebra[["layers"]][[1]][["mapping"]][["edge_colour"]], "black") - # Node parameters - expect_equal(round(test_algebra[["layers"]][[2]][["aes_params"]][["size"]]), 8) - expect_equal(test_algebra[["layers"]][[2]][["aes_params"]][["shape"]], "circle") -}) - -test_that("weighted, unsigned, directed networks graph correctly", { - skip_on_cran() - skip_on_ci() - # Weighted, unsigned, directed network - test_networkers <- graphr(ison_networkers) - # Node position - expect_equal(round(test_networkers[["data"]][["x"]][[1]]), 9) - expect_equal(round(test_networkers[["data"]][["y"]][[1]]), -1) - # Edge parameters - #expect_equal(test_networkers[["layers"]][[2]][["aes_params"]][["edge_alpha"]], 0.4) - #expect_equal(test_networkers[["layers"]][[2]][["aes_params"]][["edge_linetype"]], "solid") - #expect_equal(test_networkers[["layers"]][[2]][["aes_params"]][["edge_colour"]], "black") - # Node parameters - expect_equal(round(test_networkers[["layers"]][[3]][["aes_params"]][["size"]]), 3) - #expect_equal(test_networkers[["layers"]][[3]][["aes_params"]][["shape"]], "circle") -}) - -# Testing the node_color, node_size, and node_shape args by specifying a node attribute -test_that("fancy node mods graph correctly", { - skip_on_cran() - skip_on_ci() - # one-mode network - ison_marvel_relationships <- dplyr::mutate(ison_marvel_relationships, - nodesize = Appearances/1000) - testcolnodes <- graphr(ison_marvel_relationships, node_color = "Gender", - node_size = "nodesize", node_shape = "Attractive") - expect_s3_class(testcolnodes, c("ggraph","gg","ggplot")) - expect_equal(round(testcolnodes$data$x[1]), 4) - expect_equal(round(testcolnodes$data$y[1]), 3) - expect_equal(nrow(testcolnodes[["plot_env"]][["lo"]]), - c(net_nodes(ison_marvel_relationships))) - # two-mode network - ison_southern_women <- add_node_attribute(ison_southern_women, "group", - c(sample(c("a", "b"), - length(ison_southern_women), - replace = TRUE))) - test2 <- graphr(ison_southern_women, node_color = "type") - expect_s3_class(test2, c("ggraph","gg","ggplot")) - expect_equal(round(test2$data$x[1]), 0) - expect_equal(round(test2$data$y[1]), 0) - expect_equal(nrow(test2[["plot_env"]][["lo"]]), - c(net_nodes(ison_southern_women))) -}) - -test_that("edge colours and edge size graph correctly", { - skip_on_cran() - ison_brandes2 <- ison_brandes %>% - add_tie_attribute("tiecolour", - c("A", "B", "A", "B", "B", "B", "B", "B", "B", "B", "B", "B")) %>% - add_tie_attribute("weight", c(rep(1:6, 2))) - test_brandes2 <- graphr(ison_brandes2, edge_color = "tiecolour", edge_size = "weight") - expect_false(is.null(test_brandes2$layers[[1]]$mapping$edge_colour)) - expect_false(is.null(test_brandes2$layers[[1]]$mapping$edge_width)) -}) - -# Named networks -test_that("named networks plot correctly", { - skip_on_cran() - skip_on_ci() - onemode <- graphr(ison_adolescents) - twomode <- graphr(ison_southern_women) - expect_equal(onemode[["data"]][["name"]], node_names(ison_adolescents)) - expect_equal(twomode[["data"]][["name"]], node_names(ison_southern_women)) -}) - -# Test that autographr() works with arguments without quotes -test_that("node_group works correctly", { - skip_on_cran() - testthat::skip_if_not_installed("concaveman") - expect_equal(graphr(ison_lawfirm, node_group = gender), - graphr(ison_lawfirm, node_group = "gender")) -}) - -test_that("unquoted arguments plot correctly", { - skip_on_cran() - expect_equal(graphr(ison_lawfirm, node_color = "gender"), - graphr(ison_lawfirm, node_color = gender)) -}) - -# Layouts -test_that("concentric and circular layouts graph correctly", { - skip_on_cran() - test_circle <- graphr(to_giant(ison_marvel_relationships), - layout = "circle") - test_conc <- graphr(to_giant(ison_marvel_relationships), - layout = "concentric", membership = "Gender") - expect_equal(test_circle$plot_env$layout, "circle") - expect_equal(test_conc$plot_env$layout, "concentric") - expect_equal(eval(quote(pairlist(...)), - envir = test_conc$plot_env)$membership, - "Gender") -}) - -test_that("hierarchy and lineage layouts graph correctly", { - skip_on_cran() - skip_on_ci() - test_lin <- ison_adolescents %>% - mutate(year = rep(c(1985, 1990, 1995, 2000), times = 2)) %>% - graphr(layout = "lineage", rank = "year") - test_hie <- graphr(ison_southern_women, - layout = "hierarchy", center = "events") - expect_equal(test_lin$plot_env$layout, "lineage") - expect_equal((eval(quote(pairlist(...)), - envir = test_lin[["plot_env"]])[["rank"]]), - "year") - expect_equal(test_hie$plot_env$layout, "hierarchy") - expect_equal((eval(quote(pairlist(...)), - envir = test_hie[["plot_env"]])[["center"]]), - "events") -}) - -# test_that("graphr works for diff_model objects", { -# skip_on_cran() -# skip_on_ci() -# test_diff <- graphr(play_diffusion(ison_brandes, old_version = TRUE)) -# if (inherits(test_diff$guides, "Guides")) { -# expect_s3_class(test_diff[["guides"]][["guides"]][["shape"]], "GuideLegend") -# expect_s3_class(test_diff[["guides"]][["guides"]][["colour"]], "GuideColourbar") -# } else { -# expect_equal(test_diff[["guides"]][["shape"]][["name"]], "legend") -# expect_equal(test_diff[["guides"]][["colour"]][["name"]], "colorbar") -# } -# }) - -test_that("concentric layout works when node names are missing", { - skip_on_cran() - skip_on_ci() - llabel <- ison_southern_women %>% - mutate(name = ifelse(type == TRUE, "", name)) %>% - graphr(layout = "concentric") - expect_true(any(llabel$data$name == "")) -}) - -test_that("hierarchy layout works for two mode networks", { - skip_on_cran() - skip_on_ci() - tm <- ison_brandes %>% - mutate(type = twomode_type, name = LETTERS[1:11]) %>% - graphr() - expect_length(unique(tm$data[tm$data$type == TRUE, "y"]), 1) - expect_length(unique(tm$data[tm$data$type == FALSE, "y"]), 1) -}) diff --git a/tests/testthat/test-map_theme.R b/tests/testthat/test-map_theme.R deleted file mode 100644 index 6e6ffe6f..00000000 --- a/tests/testthat/test-map_theme.R +++ /dev/null @@ -1,58 +0,0 @@ -##### test themes -test_that("themes graph correctly", { - test_iheid <- graphr(to_mentoring(ison_brandes)) + - labs(title = "Who leads and who follows?", - subtitle = "A mentoring network", - caption = "ison_brandes network") + - theme_iheid() - test_ethz <- graphr(to_mentoring(ison_brandes)) + - labs(title = "Who leads and who follows?", - subtitle = "A mentoring network", - caption = "ison_brandes network") + - theme_ethz() - test_uzh <- graphr(to_mentoring(ison_brandes)) + - labs(title = "Who leads and who follows?", - subtitle = "A mentoring network", - caption = "ison_brandes network") + - theme_uzh() - expect_equal(names(test_iheid[["theme"]][["title"]][["colour"]]), "IHEIDRed") - expect_null(names(test_ethz[["theme"]][["title"]][["colour"]])) - expect_equal(names(test_uzh[["theme"]][["title"]][["colour"]]), "UZH_Orange") - expect_equal(names(test_iheid[["theme"]][["plot.subtitle"]][["colour"]]), - "IHEIDGrey") - expect_null(names(test_ethz[["theme"]][["plot.subtitle"]][["colour"]])) - expect_equal(names(test_uzh[["theme"]][["plot.subtitle"]][["colour"]]), - "UZH_Blue") - expect_equal(test_iheid[["theme"]][["plot.caption"]][["family"]], "serif") - expect_equal(test_ethz[["theme"]][["plot.caption"]][["family"]], "sans") - expect_equal(test_uzh[["theme"]][["plot.caption"]][["family"]], "sans") -}) - -##### test scales -test_that("scales graph correctly", { - test_sdg <- ison_brandes %>% - mutate(color = c(rep(c(1,2,3,4,5), 2), 1)) %>% - graphr(node_color = color) + - scale_color_sdgs() - test_iheid <- ison_brandes %>% - mutate(color = c(rep(c(1,2), 5), 3)) %>% - graphr(node_color = color) + - scale_color_iheid() - test_ethz <- ison_brandes %>% - mutate(color = c(rep(c(1,2,3), 3), 4, 5)) %>% - graphr(node_color = color) + - scale_color_ethz() - test_uzh <- ison_brandes %>% - mutate(color = c(rep(c(1,2,3), 3), 1, 2)) %>% - graphr(node_color = color) + - scale_color_uzh() - test_rug <- ison_brandes %>% - mutate(color = c(rep(c(1,2), 4), 1, 2, 1)) %>% - graphr(node_color = color) + - scale_color_rug() - expect_equal(as.character(test_sdg[["scales"]][["scales"]][[2]][["call"]]), "scale_color_sdgs") - expect_equal(as.character(test_iheid[["scales"]][["scales"]][[2]][["call"]]), "scale_color_iheid") - expect_equal(as.character(test_ethz[["scales"]][["scales"]][[2]][["call"]]), "scale_color_ethz") - expect_equal(as.character(test_uzh[["scales"]][["scales"]][[2]][["call"]]), "scale_color_uzh") - expect_equal(as.character(test_rug[["scales"]][["scales"]][[2]][["call"]]), "scale_color_rug") -}) From df0be5dd9be599f1ffcd2342e243c9dd2cb556a5 Mon Sep 17 00:00:00 2001 From: James Hollway Date: Fri, 22 Aug 2025 15:08:55 +0200 Subject: [PATCH 19/24] Added mdate pillar shaft, moved thisRequiresBio() to autograph, fixed remaining documentation issues --- NAMESPACE | 4 +--- R/manynet-tutorials.R | 6 +++++- R/manynet-utils.R | 19 ------------------- R/member_core.R | 3 ++- man/depth_first_recursive_search.Rd | 20 -------------------- 5 files changed, 8 insertions(+), 44 deletions(-) delete mode 100644 man/depth_first_recursive_search.Rd diff --git a/NAMESPACE b/NAMESPACE index 36244c48..738e8b7c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -139,6 +139,7 @@ S3method(net_dims,igraph) S3method(net_dims,matrix) S3method(net_dims,network) S3method(pillar_shaft,logi) +S3method(pillar_shaft,mdate) S3method(print,diff_model) S3method(print,learn_model) S3method(print,mnet) @@ -760,7 +761,6 @@ importFrom(dplyr,distinct) importFrom(dplyr,everything) importFrom(dplyr,filter) importFrom(dplyr,group_by) -importFrom(dplyr,left_join) importFrom(dplyr,mutate) importFrom(dplyr,rename) importFrom(dplyr,select) @@ -803,12 +803,10 @@ importFrom(igraph,edge_density) importFrom(igraph,eulerian_path) importFrom(igraph,feedback_arc_set) importFrom(igraph,fit_power_law) -importFrom(igraph,get.edgelist) importFrom(igraph,graph_from_adjacency_matrix) importFrom(igraph,graph_from_biadjacency_matrix) importFrom(igraph,graph_from_data_frame) importFrom(igraph,graph_from_incidence_matrix) -importFrom(igraph,gsize) importFrom(igraph,has_eulerian_path) importFrom(igraph,induced_subgraph) importFrom(igraph,is_bipartite) diff --git a/R/manynet-tutorials.R b/R/manynet-tutorials.R index 7b654f98..69bf030d 100644 --- a/R/manynet-tutorials.R +++ b/R/manynet-tutorials.R @@ -186,10 +186,14 @@ pillar_shaft.logi <- function(x, ...) { pillar::style_na(x)), align = "left") } +#' @noRd +#' @export +pillar_shaft.mdate <- function(x, ...) { + pillar::pillar_shaft(as.character(x), width = 11) +} # Glossary #### - #' Adding network glossary items #' #' @description diff --git a/R/manynet-utils.R b/R/manynet-utils.R index 6fb34fe0..218669da 100644 --- a/R/manynet-utils.R +++ b/R/manynet-utils.R @@ -31,25 +31,6 @@ thisRequires <- function(pkgname){ } } -thisRequiresBio <- function(pkgname) { - if (!requireNamespace(pkgname, quietly = TRUE) & interactive()) { - if(utils::askYesNo(msg = paste("The", pkgname, - "package is required to run this function. Would you like to install", pkgname, "from BioConductor?"))) { - thisRequires("BiocManager") - BiocManager::install(pkgname) - }} -} - -#' @export -`+.ggplot` <- function(e1, e2, ...) { - if (inherits(e2, c("ggplot", "ggplot2::ggplot"))) { - thisRequires("patchwork") - patchwork::wrap_plots(e1, e2, ...) - } else { - NextMethod() - } -} - seq_nodes <- function(.data){ seq.int(net_nodes(.data)) } diff --git a/R/member_core.R b/R/member_core.R index f67f0745..8080a14f 100644 --- a/R/member_core.R +++ b/R/member_core.R @@ -119,7 +119,8 @@ node_coreness <- function(.data) { } # Initial guess: all nodes have coreness 0.5 init <- rep(0.5, n) - result <- optim(init, obj_fun, method = "L-BFGS-B", lower = 0, upper = 1) + result <- stats::optim(init, obj_fun, method = "L-BFGS-B", + lower = 0, upper = 1) make_node_measure(result$par, .data) } diff --git a/man/depth_first_recursive_search.Rd b/man/depth_first_recursive_search.Rd deleted file mode 100644 index 9642a068..00000000 --- a/man/depth_first_recursive_search.Rd +++ /dev/null @@ -1,20 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/map_layouts.R -\name{depth_first_recursive_search} -\alias{depth_first_recursive_search} -\title{Layouts for snapping layouts to a grid} -\usage{ -depth_first_recursive_search(layout) -} -\description{ -The function uses approximate pattern matching -to redistribute coarse layouts on square grid points, while -preserving the topological relationships among the nodes (see Inoue et al. 2012). -} -\references{ -Inoue, Kentaro, Shinichi Shimozono, Hideaki Yoshida, and Hiroyuki Kurata. 2012. -“Application of Approximate Pattern Matching in Two Dimensional Spaces to Grid Layout for Biochemical Network Maps” edited by J. Bourdon. -\emph{PLoS ONE} 7(6):e37739. -\doi{https://doi.org/10.1371/journal.pone.0037739}. -} -\keyword{internal} From 6ec3199304f943b2c50008b4ec27f714dd14d28b Mon Sep 17 00:00:00 2001 From: James Hollway Date: Fri, 22 Aug 2025 15:14:44 +0200 Subject: [PATCH 20/24] NEWS and #minor bump --- DESCRIPTION | 4 ++-- NEWS.md | 33 ++++++++++++++++++++++++++++++++- 2 files changed, 34 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 2493889f..1f5af601 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: manynet Title: Many Ways to Make, Modify, Map, Mark, and Measure Myriad Networks -Version: 1.5.2 -Date: 2025-06-24 +Version: 1.6.0 +Date: 2025-08-22 Description: Many tools for making, modifying, mapping, marking, measuring, and motifs and memberships of many different types of networks. All functions operate with matrices, edge lists, and 'igraph', 'network', and 'tidygraph' objects, diff --git a/NEWS.md b/NEWS.md index 0b5e9795..347e9816 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,14 @@ -# manynet 1.5.2 +# manynet 1.6.0 + +## Package + +- Dropped viz-related dependencies: `{ggplot2}`, `{ggraph}`, `{patchwork}`, +`{ggdendro}`, `{concaveman}`, `{gifski}`, `{graphlayouts}`, `{ggforce}`, +and `{BiocManager}` + +## Classes + +- Added mdate pillar shaft for pretty printing of NAs in messydate variables ## Modifying @@ -6,9 +16,30 @@ - Improved `to_no_isolates()` to record isolate removal - Improved `to_giant()` to record giant component scoping - Improved `to_matching()` to record matching +- Fixed `to_matching()` triggering warnings from handling NAs (thanks @schochastics for fixing #109) - Improved `to_mentoring()` to record mentoring - Improved `to_eulerian()` to record Eulerian pathing +## Measuring + +- Improved `net_core()` with method options for calculating correlation, distance, ndiff, and diff + +## Membership + +- Improved `node_coreness()` to implement Borgatti and Everett's continuous coreness algorithm +- Moved previous functionality of `node_coreness()` to `node_kcoreness()` + +## Mapping + +- Moved `graphr()`, `graphs()`, and `grapht()` to `{autograph}` +- Moved palette functionality to `{autograph}` +- Moved remaining layouts to `{autograph}` +- Moved theme functionality to `{autograph}` +- Dropped remaining plot functions +- Dropped or avoided using `{autograph}`-related functions in examples to +make package lighter +- Please see `{autograph}` for continued development of these features + # manynet 1.5.1 ## Package From 66779f8a08695421b33ab64551ea4cc5a8f3e5d2 Mon Sep 17 00:00:00 2001 From: James Hollway Date: Fri, 22 Aug 2025 15:29:33 +0200 Subject: [PATCH 21/24] Dropped autograph --- DESCRIPTION | 2 -- R/make_play.R | 5 ----- R/make_read.R | 2 -- R/manip_correlation.R | 3 --- R/manip_format.R | 1 - R/manip_reformed.R | 6 ------ R/measure_centrality.R | 2 -- man/make_cran.Rd | 2 -- man/make_learning.Rd | 3 --- man/make_play.Rd | 2 -- man/manip_paths.Rd | 2 -- man/manip_permutation.Rd | 4 ---- man/manip_project.Rd | 3 --- man/manip_reformat.Rd | 1 - man/measure_central_between.Rd | 1 - man/measure_central_close.Rd | 1 - 16 files changed, 40 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 1f5af601..effd0266 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -38,8 +38,6 @@ Suggests: tibble, tidyr, xml2 -Enhances: - Rgraphviz Authors@R: c(person(given = "James", family = "Hollway", diff --git a/R/make_play.R b/R/make_play.R index 71141a95..431961c1 100644 --- a/R/make_play.R +++ b/R/make_play.R @@ -146,8 +146,6 @@ NULL #' original network. #' @examples #' smeg <- generate_smallworld(15, 0.025) -#' # autograph::plot(play_diffusion(smeg, recovery = 0.4)) -#' # autograph::graphr(play_diffusion(ison_karateka)) #' @export play_diffusion <- function(.data, seeds = 1, @@ -406,9 +404,6 @@ play_learning <- function(.data, #' latticeEg <- add_node_attribute(latticeEg, "startValues", startValues) #' latticeEg #' play_segregation(latticeEg, "startValues", 0.5) -#' # autograph::graphr(latticeEg, node_color = "startValues", node_size = 5) + -#' # autograph::graphr(play_segregation(latticeEg, "startValues", 0.2), -#' # node_color = "startValues", node_size = 5) #' @export play_segregation <- function(.data, attribute, diff --git a/R/make_read.R b/R/make_read.R index f5ed9165..9b8868c9 100644 --- a/R/make_read.R +++ b/R/make_read.R @@ -707,8 +707,6 @@ write_graphml <- function(.data, #' @examples #' # mnet <- read_cran() #' # mnet <- to_ego(mnet, "manynet", max_dist = 2) -#' # autograph::graphr(mnet, layout = "hierarchy", -#' # edge_color = "type", node_color = "Compilation") #' @export read_cran <- function(pkg = "all"){ snet_progress_step("Downloading data about available packages from CRAN") diff --git a/R/manip_correlation.R b/R/manip_correlation.R index 1dadeb08..1dd39551 100644 --- a/R/manip_correlation.R +++ b/R/manip_correlation.R @@ -74,9 +74,6 @@ NULL #' @param with_attr Logical whether any attributes of the object #' should be retained. #' By default TRUE. -#' @examples -#' autograph::graphr(ison_adolescents, node_size = 4) -#' autograph::graphr(to_permuted(ison_adolescents), node_size = 4) #' @export to_permuted <- function(.data, with_attr = TRUE) { out <- as_matrix(.data) diff --git a/R/manip_format.R b/R/manip_format.R index 6c49a66c..bf173600 100644 --- a/R/manip_format.R +++ b/R/manip_format.R @@ -378,7 +378,6 @@ to_acyclic.network <- function(.data) { #' @importFrom igraph complementer #' @examples #' to_anti(ison_southern_women) -#' # autograph::graphr(to_anti(ison_southern_women)) #' @export to_anti <- function(.data) UseMethod("to_anti") diff --git a/R/manip_reformed.R b/R/manip_reformed.R index 0b3b6603..b8fa8ebc 100644 --- a/R/manip_reformed.R +++ b/R/manip_reformed.R @@ -55,8 +55,6 @@ NULL #' @examples #' to_mode1(ison_southern_women) #' to_mode2(ison_southern_women) -#' #autograph::graphr(to_mode1(ison_southern_women)) -#' #autograph::graphr(to_mode2(ison_southern_women)) #' @export to_mode1 <- function(.data, similarity = c("count","jaccard","rand","pearson","yule")) UseMethod("to_mode1") @@ -161,7 +159,6 @@ to_mode2.data.frame <- function(.data, similarity = c("count","jaccard","rand"," #' @importFrom igraph make_line_graph E #' @examples #' to_ties(ison_adolescents) -#' #autograph::graphr(to_ties(ison_adolescents)) #' @export to_ties <- function(.data) UseMethod("to_ties") @@ -691,8 +688,6 @@ to_matching.matrix <- function(.data, mark = "type", capacities = NULL){ #' "Accelerating the Diffusion of Innovations Using Opinion Leaders", #' _Annals of the American Academy of Political and Social Science_ 566: 56-67. #' \doi{10.1177/000271629956600105} -#' @examples -#' autograph::graphr(to_mentoring(ison_adolescents)) #' @export to_mentoring <- function(.data, elites = 0.1) UseMethod("to_mentoring") @@ -752,7 +747,6 @@ to_mentoring.igraph <- function(.data, elites = 0.1){ #' \doi{10.1007/BF01442866} #' @examples #' to_eulerian(delete_nodes(ison_koenigsberg, "Lomse")) -#' #autograph::graphr(to_eulerian(delete_nodes(ison_koenigsberg, "Lomse"))) #' @export to_eulerian <- function(.data) UseMethod("to_eulerian") diff --git a/R/measure_centrality.R b/R/measure_centrality.R index 4b790c00..88c8dc85 100644 --- a/R/measure_centrality.R +++ b/R/measure_centrality.R @@ -444,7 +444,6 @@ node_stress <- function(.data, normalized = TRUE){ #' @importFrom igraph edge_betweenness #' @examples #' (tb <- tie_betweenness(ison_adolescents)) -#' #autograph::plot(tb) #' ison_adolescents %>% mutate_ties(weight = tb) #' @export tie_betweenness <- function(.data, normalized = TRUE){ @@ -782,7 +781,6 @@ node_vitality <- function(.data, normalized = TRUE){ #' @rdname measure_central_close #' @examples #' (ec <- tie_closeness(ison_adolescents)) -#' #autograph::plot(ec) #' ison_adolescents %>% mutate_ties(weight = ec) #' @export tie_closeness <- function(.data, normalized = TRUE){ diff --git a/man/make_cran.Rd b/man/make_cran.Rd index adb16ed8..16557e6d 100644 --- a/man/make_cran.Rd +++ b/man/make_cran.Rd @@ -37,8 +37,6 @@ by \href{https://github.com/stocnet/manynet/issues}{raising an issue on Github}. \examples{ # mnet <- read_cran() # mnet <- to_ego(mnet, "manynet", max_dist = 2) -# autograph::graphr(mnet, layout = "hierarchy", -# edge_color = "type", node_color = "Compilation") } \seealso{ \link{as} diff --git a/man/make_learning.Rd b/man/make_learning.Rd index ec07a0b6..6f08083a 100644 --- a/man/make_learning.Rd +++ b/man/make_learning.Rd @@ -87,9 +87,6 @@ from other nodes whose beliefs are not too dissimilar from their own. latticeEg <- add_node_attribute(latticeEg, "startValues", startValues) latticeEg play_segregation(latticeEg, "startValues", 0.5) - # autograph::graphr(latticeEg, node_color = "startValues", node_size = 5) + - # autograph::graphr(play_segregation(latticeEg, "startValues", 0.2), - # node_color = "startValues", node_size = 5) } \references{ DeGroot, Morris H. 1974. diff --git a/man/make_play.Rd b/man/make_play.Rd index e8e0333a..7d1aa8c7 100644 --- a/man/make_play.Rd +++ b/man/make_play.Rd @@ -185,8 +185,6 @@ This can be used in in SEI, SEIS, SEIR, and SEIRS models. \examples{ smeg <- generate_smallworld(15, 0.025) - # autograph::plot(play_diffusion(smeg, recovery = 0.4)) - # autograph::graphr(play_diffusion(ison_karateka)) } \seealso{ Other makes: diff --git a/man/manip_paths.Rd b/man/manip_paths.Rd index 468692ef..ca35715c 100644 --- a/man/manip_paths.Rd +++ b/man/manip_paths.Rd @@ -109,9 +109,7 @@ This is, however, computationally slower. \examples{ to_matching(ison_southern_women) -autograph::graphr(to_mentoring(ison_adolescents)) to_eulerian(delete_nodes(ison_koenigsberg, "Lomse")) - #autograph::graphr(to_eulerian(delete_nodes(ison_koenigsberg, "Lomse"))) } \references{ \subsection{On matching}{ diff --git a/man/manip_permutation.Rd b/man/manip_permutation.Rd index f1a21fe6..32a6df8b 100644 --- a/man/manip_permutation.Rd +++ b/man/manip_permutation.Rd @@ -26,10 +26,6 @@ By default TRUE.} on both the rows and columns (for a one-mode network) or on each of the rows and columns (for a two-mode network). } -\examples{ -autograph::graphr(ison_adolescents, node_size = 4) -autograph::graphr(to_permuted(ison_adolescents), node_size = 4) -} \seealso{ Other modifications: \code{\link{manip_as}}, diff --git a/man/manip_project.Rd b/man/manip_project.Rd index 42386efe..04f6e5ec 100644 --- a/man/manip_project.Rd +++ b/man/manip_project.Rd @@ -71,10 +71,7 @@ Below are the currently implemented S3 methods:\tabular{lrrrrr}{ \examples{ to_mode1(ison_southern_women) to_mode2(ison_southern_women) -#autograph::graphr(to_mode1(ison_southern_women)) -#autograph::graphr(to_mode2(ison_southern_women)) to_ties(ison_adolescents) -#autograph::graphr(to_ties(ison_adolescents)) } \seealso{ Other modifications: diff --git a/man/manip_reformat.Rd b/man/manip_reformat.Rd index 09b47055..17185089 100644 --- a/man/manip_reformat.Rd +++ b/man/manip_reformat.Rd @@ -70,7 +70,6 @@ This essentially has no effect on undirected networks or reciprocated ties. }} \examples{ to_anti(ison_southern_women) -# autograph::graphr(to_anti(ison_southern_women)) } \seealso{ Other modifications: diff --git a/man/measure_central_between.Rd b/man/measure_central_between.Rd index cb90d93c..35a86c42 100644 --- a/man/measure_central_between.Rd +++ b/man/measure_central_between.Rd @@ -107,7 +107,6 @@ nodes, and thus associated with bridging or spanning boundaries. node_betweenness(ison_southern_women) node_induced(ison_adolescents) (tb <- tie_betweenness(ison_adolescents)) -#autograph::plot(tb) ison_adolescents \%>\% mutate_ties(weight = tb) net_betweenness(ison_southern_women, direction = "in") } diff --git a/man/measure_central_close.Rd b/man/measure_central_close.Rd index 5c22c87e..1992e688 100644 --- a/man/measure_central_close.Rd +++ b/man/measure_central_close.Rd @@ -176,7 +176,6 @@ removing that node would disconnect the network. node_closeness(ison_southern_women) node_reach(ison_adolescents) (ec <- tie_closeness(ison_adolescents)) -#autograph::plot(ec) ison_adolescents \%>\% mutate_ties(weight = ec) net_closeness(ison_southern_women, direction = "in") } From f23d5f19ac86781c6331d1b0b625886929e28953 Mon Sep 17 00:00:00 2001 From: James Hollway Date: Fri, 22 Aug 2025 15:32:27 +0200 Subject: [PATCH 22/24] Updated package description to be more accurate --- DESCRIPTION | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index effd0266..ad023168 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,14 +1,14 @@ Package: manynet -Title: Many Ways to Make, Modify, Map, Mark, and Measure Myriad Networks +Title: Many Ways to Make, Modify, Mark, and Measure Myriad Networks Version: 1.6.0 Date: 2025-08-22 -Description: Many tools for making, modifying, mapping, marking, measuring, +Description: Many tools for making, modifying, marking, measuring, and motifs and memberships of many different types of networks. All functions operate with matrices, edge lists, and 'igraph', 'network', and 'tidygraph' objects, - and on one-mode, two-mode (bipartite), and sometimes three-mode networks. + on directed, multiplex, multimodal, signed, and other networks. The package includes functions for importing and exporting, creating and generating networks, modifying networks and node and tie attributes, - and describing and visualizing networks with sensible defaults. + and describing networks with sensible defaults. URL: https://stocnet.github.io/manynet/ BugReports: https://github.com/stocnet/manynet/issues License: MIT + file LICENSE From d8be929e348dd1d53c15dd51150e8390a30fa781 Mon Sep 17 00:00:00 2001 From: James Hollway Date: Fri, 22 Aug 2025 15:36:25 +0200 Subject: [PATCH 23/24] Updated the README --- README.Rmd | 152 ++--------------------------------------------------- README.md | 108 ++----------------------------------- 2 files changed, 8 insertions(+), 252 deletions(-) diff --git a/README.Rmd b/README.Rmd index aafa223a..743d0c85 100644 --- a/README.Rmd +++ b/README.Rmd @@ -51,8 +51,9 @@ which can mess up your pretty presentation or paper. This can make learning and using network analysis tools in R challenging. By contrast, `{manynet}` offers _many_ analytic tools that work on _many_ (if not most) types and kinds of networks. -It helps researchers make, modify, map, mark, measure, and identify nodes' motifs and memberships in networks. -For further testing and modelling capabilities, +It helps researchers make, modify, mark, measure, and identify nodes' motifs and memberships in networks. +For graph drawing see [`{autograph}`](https://stocnet.github.io/autograph/), +and for further testing and modelling capabilities see [`{migraph}`](https://stocnet.github.io/migraph/) and the other [stocnet](https://github.com/stocnet) packages. - [Making](#making) @@ -65,13 +66,6 @@ see [`{migraph}`](https://stocnet.github.io/migraph/) and the other [stocnet](ht - [Transforming](#transforming) - [Splitting and Joining](#splitting-and-joining) - [Extracting](#extracting) -- [Mapping](#mapping) - - [Graphing](#graphing) - - [More options](#more-options) - - [More layouts](#more-layouts) - - [More themes and scales](#more-themes-and-scales) - - [graphs](#graphs) - - [grapht](#grapht) - [Marking](#marking) - [Motifs](#motifs) - [Memberships](#memberships) @@ -286,146 +280,6 @@ Split data can be rejoined using the `from_*()` family of functions. See also `r list_functions("^to_")` and `r list_functions("^from_")`. -## Mapping - -`{manynet}` includes three one-line graphing functions with sensible defaults based on -the network's properties. - -### Graphing - -First, `graphr()` is used to graph networks in any of the `{manynet}` formats. -It includes sensible defaults so that researchers can view their network's structure -or distribution quickly with a minimum of fuss. -Compare the output from `{manynet}` with a similar default from `{igraph}`: - -Example illustrating differences in default igraph and manynet graphs - -```{r layout-comparison, echo = FALSE, message=FALSE, dpi = 250, fig.height=4, eval = FALSE} -library(manynet) -library(igraph) -library(gridBase) -library(grid) - -par(mfrow=c(1, 2), mai = c(0,0,0.5,0)) -plot(as_igraph(ison_southern_women), layout = layout_as_bipartite, main = "{igraph} bipartite") -## the last one is the current plot -plot.new() ## suggested by @Josh -vps <- baseViewports() -pushViewport(vps$figure) ## I am in the space of the autocorrelation plot -vp1 <-plotViewport(c(1.8,1,0,1)) ## create new vp with margins, you play with this values -p <- graphr(ison_southern_women) + ggtitle("{manynet} twomode") -print(p,vp = vp1) -``` - -Here the `{manynet}` function recognises that the network is a two-mode network -and uses a bipartite layout by default, -and recognises that the network contains names for the nodes and -prints them vertically so that they are legible in this layout. -Other 'clever' features include automatic node sizing and more. -By contrast, `{igraph}` requires the bipartite layout to be specified, has cumbersome node size defaults for all but the smallest graphs, and labels also very often need resizing and adjustment to avoid overlap. -All of `{manynet}`'s adjustments can be overridden, however... - -#### More options - -Changing the size and colors of nodes and ties is as easy as -specifying the function's relevant argument with a replacement, -or indicating from which attribute it should inherit this information. - -Graph illustrating automatic and manual use of node color and size - -```{r more-options, echo = FALSE, message=FALSE, dpi = 300, fig.height=3, eval=FALSE} -graphr(ison_lawfirm, node_color = "darkblue", node_size = 6) + - ggtitle("Manual options", - subtitle = "graphr(ison_lawfirm, node_color = 'darkblue', node_size = 6)") + -graphr(mutate(ison_lawfirm, Seniority = Seniority/3), node_color = "Office", node_size = "Seniority") + - ggtitle("Automatic options", - subtitle = "graphr(ison_lawfirm, node_color = 'Office', node_size = 'Seniority')") & - theme(plot.subtitle = element_text(size = 8)) -``` - -#### More layouts - -`{manynet}` can use all the layout algorithms offered by packages such as `{igraph}`, `{ggraph}`, and `{graphlayouts}`, -and offers some additional layout algorithms for -snapping layouts to a grid, -visualising partitions horizontally, vertically, or concentrically, -or conforming to configurational coordinates. - -Graphs illustrating different layouts - -```{r more-layouts, echo = FALSE, message=FALSE, dpi = 250, eval=FALSE} -(graphr(ison_southern_women, layout = "concentric") + ggtitle("Concentric layout")) / - ((graphr(to_unnamed(create_explicit(A-+B-+C, A-+C))) + ggtitle("Triad layout")) | - (graphr(to_unnamed(create_explicit(A-+C, A-+D, B-+C, B-+D))) + ggtitle("Quad layout"))) -``` - -#### More themes and scales - -Lastly, `graphr()` is highly extensible in terms of the overall look of your plots. -`{manynet}` uses the excellent `{ggraph}` package (and thus `{ggplot2}`) -as a plotting engine. -This enables alterations such as the application of themes to be applied upon the defaults. -If you want to quickly make sure your plots conform to your institution or taste, -then it is easy to do with themes and scales that update the basic look and color palette -used in your plots. - -Graphs using default, IHEID, and ETHZ themes - -```{r more-themes, echo = FALSE, message=FALSE, dpi = 300, fig.height=3, eval=FALSE} -p <- graphr(ison_lawfirm, node_color = "Practice") + - ggtitle("Original") -p + p + theme_iheid() + scale_color_iheid() + - ggtitle("Graduate Institute", subtitle = "_iheid") + - p + theme_ethz() + scale_color_ethz() + - ggtitle("ETH Zürich", subtitle = "_ethz") & ggplot2::theme(legend.position = "none") -``` - -More themes are on their way, and we're happy to take suggestions. - -### graphs - -Second, `graphs()` is used to graph multiple networks together, -which can be useful for ego networks or network panels. -`{patchwork}` is used to help arrange individual plots together. - -Example of graphs() used on longitudinal data - -```{r autographs, echo = FALSE, dpi = 250, fig.height=3, eval=FALSE} -ison_adolescents %>% - mutate_ties(wave = c(rep(1995, 5), rep(1998, 5))) %>% - to_waves(attribute = "wave", panels = c(1995, 1998)) %>% - graphs() -``` - -### grapht - -Third, `grapht()` is used to visualise dynamic networks. -It uses `{gganimate}` and `{gifski}` to create a gif that -visualises network changes over time. -It really couldn't be easier. - -Example of grapht() on longitudinal data - -```{r autographd, echo = FALSE, dpi = 250, fig.height=3.5, eval=FALSE} -ison_adolescents %>% - mutate_ties(year = sample(1995:1998, 10, replace = TRUE)) %>% - to_waves(attribute = "year") %>% - grapht() -``` - - - - - - - - - - - - - - ## Marking `{manynet}` includes four special groups of functions, diff --git a/README.md b/README.md index a41d6f4a..68a18c7b 100644 --- a/README.md +++ b/README.md @@ -38,9 +38,11 @@ make learning and using network analysis tools in R challenging. By contrast, `{manynet}` offers *many* analytic tools that work on *many* (if not most) types and kinds of networks. It helps researchers -make, modify, map, mark, measure, and identify nodes’ motifs and -memberships in networks. For further testing and modelling capabilities, -see [`{migraph}`](https://stocnet.github.io/migraph/) and the other +make, modify, mark, measure, and identify nodes’ motifs and memberships +in networks. For graph drawing see +[`{autograph}`](https://stocnet.github.io/autograph/), and for further +testing and modelling capabilities see +[`{migraph}`](https://stocnet.github.io/migraph/) and the other [stocnet](https://github.com/stocnet) packages. - [Making](#making) @@ -53,13 +55,6 @@ see [`{migraph}`](https://stocnet.github.io/migraph/) and the other - [Transforming](#transforming) - [Splitting and Joining](#splitting-and-joining) - [Extracting](#extracting) -- [Mapping](#mapping) - - [Graphing](#graphing) - - [More options](#more-options) - - [More layouts](#more-layouts) - - [More themes and scales](#more-themes-and-scales) - - [graphs](#graphs) - - [grapht](#grapht) - [Marking](#marking) - [Motifs](#motifs) - [Memberships](#memberships) @@ -237,99 +232,6 @@ See also `to_acyclic()`, `to_anti()`, `to_blocks()`, `to_components()`, `to_unweighted()`, `to_waves()`, `to_weighted()` and `from_egos()`, `from_slices()`, `from_subgraphs()`, `from_ties()`, `from_waves()`. -## Mapping - -`{manynet}` includes three one-line graphing functions with sensible -defaults based on the network’s properties. - -### Graphing - -First, `graphr()` is used to graph networks in any of the `{manynet}` -formats. It includes sensible defaults so that researchers can view -their network’s structure or distribution quickly with a minimum of -fuss. Compare the output from `{manynet}` with a similar default from -`{igraph}`: - -Example illustrating differences in default igraph and manynet graphs - -Here the `{manynet}` function recognises that the network is a two-mode -network and uses a bipartite layout by default, and recognises that the -network contains names for the nodes and prints them vertically so that -they are legible in this layout. Other ‘clever’ features include -automatic node sizing and more. By contrast, `{igraph}` requires the -bipartite layout to be specified, has cumbersome node size defaults for -all but the smallest graphs, and labels also very often need resizing -and adjustment to avoid overlap. All of `{manynet}`’s adjustments can be -overridden, however… - -#### More options - -Changing the size and colors of nodes and ties is as easy as specifying -the function’s relevant argument with a replacement, or indicating from -which attribute it should inherit this information. - -Graph illustrating automatic and manual use of node color and size - -#### More layouts - -`{manynet}` can use all the layout algorithms offered by packages such -as `{igraph}`, `{ggraph}`, and `{graphlayouts}`, and offers some -additional layout algorithms for snapping layouts to a grid, visualising -partitions horizontally, vertically, or concentrically, or conforming to -configurational coordinates. - -Graphs illustrating different layouts - -#### More themes and scales - -Lastly, `graphr()` is highly extensible in terms of the overall look of -your plots. `{manynet}` uses the excellent `{ggraph}` package (and thus -`{ggplot2}`) as a plotting engine. This enables alterations such as the -application of themes to be applied upon the defaults. If you want to -quickly make sure your plots conform to your institution or taste, then -it is easy to do with themes and scales that update the basic look and -color palette used in your plots. - -Graphs using default, IHEID, and ETHZ themes - -More themes are on their way, and we’re happy to take suggestions. - -### graphs - -Second, `graphs()` is used to graph multiple networks together, which -can be useful for ego networks or network panels. `{patchwork}` is used -to help arrange individual plots together. - -Example of graphs() used on longitudinal data - -### grapht - -Third, `grapht()` is used to visualise dynamic networks. It uses -`{gganimate}` and `{gifski}` to create a gif that visualises network -changes over time. It really couldn’t be easier. - -Example of grapht() on longitudinal data - - - - - - - - - - - - - - - - - - - - - ## Marking `{manynet}` includes four special groups of functions, each with their From 0094c9204811bbf7ebfe418568e598a60c48825f Mon Sep 17 00:00:00 2001 From: James Hollway Date: Fri, 22 Aug 2025 16:11:33 +0200 Subject: [PATCH 24/24] Sent to CRAN --- cran-comments.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cran-comments.md b/cran-comments.md index 2827d039..634afb8c 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -9,4 +9,4 @@ 0 errors | 0 warnings | 0 notes -- Removed failing URLs from previous submission (v1.5.0) \ No newline at end of file +- Required for ggplot2 v4.0.0 \ No newline at end of file