Merge pull request #62 from stocnet/develop

v0.4.2

Author: henriquesposito

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: manynet
 Title: Many Ways to Make, Modify, Mark, and Map Myriad Networks
-Version: 0.4.1
-Date: 2024-01-24
+Version: 0.4.2
+Date: 2024-03-12
 Description: A set of tools for making, modifying, marking, and mapping 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.
@@ -15,7 +15,7 @@ License: MIT + file LICENSE
 Language: en-GB
 Encoding: UTF-8
 LazyData: true
-RoxygenNote: 7.3.0
+RoxygenNote: 7.3.1
 Imports: 
     dplyr (>= 1.1.0),
     ggplot2,

NAMESPACE

@@ -338,6 +338,7 @@ export(join_ties)
 export(labs)
 export(layout_tbl_graph_alluvial)
 export(layout_tbl_graph_concentric)
+export(layout_tbl_graph_configuration)
 export(layout_tbl_graph_hierarchy)
 export(layout_tbl_graph_ladder)
 export(layout_tbl_graph_lineage)

NEWS.md

@@ -1,3 +1,23 @@
+# manynet 0.4.2
+
+2024-03-12
+
+## Making
+
+- Closed #57 by updating `play_diffusions()` to revert future plan on exit
+- Fixed bug with how `generate_random()` works for two-mode networks with specified number of ties
+
+## Mapping
+
+- Closed #6 by updating how "lineage" layout works and places nodes on Y axis
+- Closed #39 by making `autographr()` more flexible and efficient in setting variables to aesthetics
+- Updated themes to be compatible with newer and older versions of `{ggplot2}`
+- Added "configuration" layout for small triad/quad networks
+
+## Modifying
+
+- Updated `to_reciprocated.matrix()` to consistently work with matrices
+
 # manynet 0.4.1
 
 2023-12-24

R/make_generate.R

@@ -79,7 +79,7 @@ generate_random <- function(n, p = 0.5, directed = FALSE, with_attr = TRUE) {
       if(!as.integer(p)==p) stop("`p` must be an integer if above 1.")
       g <- igraph::sample_bipartite(n[1], n[2],
                                     m = p,
-                                    type = "gmp",
+                                    type = "gnm",
                                     directed = directed,
                                     mode = "out")
     } else {

R/make_play.R

@@ -257,8 +257,11 @@ play_diffusions <- function(.data,
                             verbose = FALSE) {
   thisRequires("future")
   thisRequires("furrr")
+  oplan <- future::plan(strategy)
+  on.exit(future::plan(oplan), add = TRUE)
+  
   if(missing(steps)) steps <- network_nodes(.data)
-  future::plan(strategy)
+  
   out <- furrr::future_map_dfr(1:times, function(j){
       data.frame(sim = j,
                  play_diffusion(.data, 

R/manip_reformat.R

@@ -212,7 +212,7 @@ to_reciprocated.tbl_graph <- function(.data) {
 
 #' @export
 to_reciprocated.matrix <- function(.data) {
-  as_matrix(to_reciprocated(as_igraph(.data)))
+  .data + t(.data)
 }
 
 #' @export

R/map_autographr.R

@@ -1,10 +1,27 @@
 #' Layout algorithms based on configurational positions
 #' 
+#' @description
+#'   Configurational layouts locate nodes at symmetric coordinates
+#'   to help illustrate the particular layouts.
+#'   Currently "triad" and "quad" layouts are available.
+#'   The "configuration" layout will choose the appropriate configurational
+#'   layout automatically.
+#' 
 #' @name configuration_layouts
 #' @family mapping
 #' @inheritParams partition_layouts
 NULL
 
+#' @rdname configuration_layouts
+#' @export
+layout_tbl_graph_configuration <- function(.data,
+                                   circular = FALSE, times = 1000){
+  if (network_nodes(.data) == 3) {
+    layout_tbl_graph_triad(.data, circular = circular, times = times)
+  } else if (network_nodes(.data) == 4) {
+    layout_tbl_graph_quad(.data, circular = circular, times = times)
+}}
+
 #' @rdname configuration_layouts
 #' @export
 layout_tbl_graph_triad <- function(.data,

R/map_layout_configurations.R

@@ -61,7 +61,7 @@ layout_tbl_graph_hierarchy <- function(.data, center = NULL,
   if (is.null(center)) {
     thisRequiresBio("Rgraphviz")
     prep <- as_matrix(.data, twomode = FALSE)
-    if(anyDuplicated(rownames(prep))){
+    if(anyDuplicated(rownames(prep))) {
       rownames(prep) <- seq_len(nrow(prep))
       colnames(prep) <- seq_len(ncol(prep))
     }
@@ -84,15 +84,13 @@ layout_tbl_graph_hierarchy <- function(.data, center = NULL,
       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
-      crd[, 2] <- crd[, 2] * cos(pi) - crd[, 1] * sin(pi)
       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
-      crd[, 2] <- crd[, 2] * cos(pi) - crd[, 1] * sin(pi)
       rownames(crd) <- c(dimnames(net)[[1]], dimnames(net)[[2]])
     } else {
       if (center %in% node_names(.data)) {
@@ -107,7 +105,6 @@ layout_tbl_graph_hierarchy <- function(.data, center = NULL,
         }
         crd <- rbind(side1, side2)
         crd[which(is.nan(crd))] <- 0.5
-        crd[, 2] <- crd[, 2] * cos(pi) - crd[, 1] * sin(pi)
         rownames(crd) <- c(dimnames(net)[[1]], dimnames(net)[[2]])
       } else stop("Please declare actors, events, or a node name as center.")
     }
@@ -139,7 +136,7 @@ layout_tbl_graph_alluvial <- function(.data,
 #' @rdname partition_layouts
 #' @export
 layout_tbl_graph_railway <- function(.data,
-                                     circular = FALSE, times = 1000){
+                                     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])))
@@ -239,52 +236,21 @@ layout_tbl_graph_lineage <- function(.data, rank, circular = FALSE) {
   if (length(rank) > 1 & length(rank) != length(.data)) {
     stop("Please pass the function a `rank` node attribute or a vector.")
   } else if (length(rank) != length(.data)) {
-    rank <- node_attribute(.data, rank)
-    if (!is.numeric(rank))
-      stop("Please declare a numeric attribute to `rank` nodes.")
+    rank <- as.numeric(node_attribute(.data, rank))
   }
   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 = "BT"))))
-  nodeX <- .rescale(out@renderInfo@nodes$nodeX)
-  names <- names(nodeX)
-  nodeY <- .rescale(rank*(-1))
-  .to_lo(.adjust(nodeX, nodeY, names))
+  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))
 }
 
-.adjust <- function(x, y, names) {
-  out <- data.frame(cbind(x, y, names))
-  adj <- data.frame()
-  for (k in levels(as.factor(y))) {
-    a <- subset(out, y == k)
-    if (length(a[,1]) == 1) {
-      a[,1] <- ifelse(a[,1] > 0.8, as.numeric(a[,1])*0.8,
-                      ifelse(a[,1] < 0.2, as.numeric(a[,1])*1.2,
-                             as.numeric(a[,1])))
-    } else if (length(a[,1]) > 2) {
-      a[,1] <- seq(min(a[,1]), max(a[,1]), len = length(a[,1]))
-    }
-    adj <- rbind(adj, a)
-  }
-  name <- data.frame(names = out[,3])
-  out <- dplyr::left_join(name, adj, by = "names")
-  out <- apply(out[,2:3], 2, as.numeric)
-  rownames(out) <- name$names
-  out
-}
-
-.to_lo <- function(mat){
+.to_lo <- function(mat) {
   res <- as.data.frame(mat)
   names(res) <- c("x","y")
   res
@@ -299,6 +265,11 @@ to_list <- function(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){