expanded .component_layouts

R/layout_stress.R

@@ -11,16 +11,86 @@
     }
 }
 
-.layout_with_stress_dim <- function(g, weights = NA, iter = 500, tol = 0.0001, mds = TRUE, bbox = 30, dim = 2) {
-    if (!igraph::is_igraph(g)) {
-        stop("g must be an igraph object")
+.component_mover <- function(lg, p, bbox) {
+    curx <- 0
+    cury <- 0
+    maxy <- 0
+    for (comp in p) {
+        if (curx + max(lg[[comp]][, 1]) > bbox) {
+            curx <- 0
+            cury <- maxy + 1
+        }
+        lg[[comp]][, 1] <- lg[[comp]][, 1] + curx
+        lg[[comp]][, 2] <- lg[[comp]][, 2] + cury
+        curx <- max(lg[[comp]][, 1]) + 1
+        maxy <- max(c(maxy, max(lg[[comp]][, 2])))
+    }
+    return(lg)
+}
+
+.component_layouter <- function(g, weights, comps, dim, mds, bbox, iter, tol, FUN, ...) {
+    # check which ... are arguments of FUN
+    FUN <- match.fun(FUN)
+    params <- list(...)
+    FUN_formals <- formals(FUN)
+    idx <- names(params) %in% names(FUN_formals)
+    params <- params[idx]
+    if ("dim" %in% names(FUN_formals)) {
+        params <- c(params, list(dim = fixdim))
     }
+
+    lg <- list()
+    node_order <- c()
+    if (!is.null(weights) && any(!is.na(weights))) {
+        igraph::edge_attr(g, "_edgename") <- 1:igraph::ecount(g)
+        names(weights) <- 1:igraph::ecount(g)
+    }
+
+    for (i in 1:comps$no) {
+        idx <- comps$membership == i
+        sg <- igraph::induced_subgraph(g, idx)
+        edge_idx <- igraph::edge_attr(g, "_edgename") %in% igraph::edge_attr(sg, "_edgename")
+        n <- igraph::vcount(sg)
+        node_order <- c(node_order, which(idx))
+
+        if (n == 1) {
+            lg[[i]] <- matrix(rep(0, dim), 1, dim, byrow = TRUE)
+        } else if (n == 2) {
+            lg[[i]] <- matrix(c(0, rep(0, dim - 1), 1, rep(0, dim - 1)), 2, dim, byrow = TRUE)
+            next()
+        } else {
+            if (!is.null(weights) && any(!is.na(weights))) {
+                D <- igraph::distances(sg, weights = weights[edge_idx])
+            } else {
+                D <- igraph::distances(sg, weights = weights)
+            }
+            W <- 1 / D^2
+            diag(W) <- 0
+
+            xinit <- .init_layout(sg, D, mds, n, dim)
+            if ("dim" %in% names(params)) {
+                xinit[, params[["dim"]]] <- coord[idx]
+            }
+            params_FUN <- c(params, list(y = xinit, W = W, D = D, iter = iter, tol = tol))
+            lg[[i]] <- do.call(FUN, params_FUN) # FUN(xinit, W, D, iter, tol)
+        }
+    }
+    if (!"dim" %in% names(params)) {
+        lg <- lapply(lg, mv_to_null)
+        p <- order(comps$csize)
+        lg <- .component_mover(lg, p, bbox)
+    }
+    x <- do.call("rbind", lg)
+    x[node_order, , drop = FALSE]
+}
+
+.layout_with_stress_dim <- function(g, weights = NA, iter = 500, tol = 0.0001, mds = TRUE, bbox = 30, dim = 2) {
+    ensure_igraph(g)
     if (!dim %in% c(2, 3)) {
         stop("dim must be either 2 or 3")
     }
 
     oldseed <- get_seed()
-
     set.seed(42) # stress is deterministic and produces the same result up to translation. This keeps the layout fixed
     on.exit(restore_seed(oldseed))
 
@@ -29,9 +99,9 @@
         n <- igraph::vcount(g)
 
         if (n == 1) {
-            x <- matrix(rep(0, dim), 1, dim, byrow = TRUE)
+            return(matrix(rep(0, dim), 1, dim, byrow = TRUE))
         } else if (n == 2) {
-            x <- matrix(c(0, rep(0, dim - 1), 1, rep(0, dim - 2)), 2, dim, byrow = TRUE)
+            return(matrix(c(0, rep(0, dim - 1), 1, rep(0, dim - 2)), 2, dim, byrow = TRUE))
         } else {
             if (!is.null(weights) && any(!is.na(weights))) {
                 D <- igraph::distances(g, weights = weights)
@@ -50,64 +120,11 @@
             }
         }
     } else {
-        lg <- list()
-        node_order <- c()
-        if (!is.null(weights) && any(!is.na(weights))) {
-            igraph::edge_attr(g, "_edgename") <- 1:igraph::ecount(g)
-            names(weights) <- 1:igraph::ecount(g)
-        }
-
-        for (i in 1:comps$no) {
-            idx <- comps$membership == i
-            sg <- igraph::induced_subgraph(g, idx)
-            edge_idx <- igraph::edge_attr(g, "_edgename") %in% igraph::edge_attr(sg, "_edgename")
-            n <- igraph::vcount(sg)
-            node_order <- c(node_order, which(idx))
-
-            if (n == 1) {
-                lg[[i]] <- matrix(rep(0, dim), 1, dim, byrow = TRUE)
-                next()
-            }
-            if (n == 2) {
-                lg[[i]] <- matrix(c(0, rep(0, dim - 1), 1, rep(0, dim - 1)), 2, dim, byrow = TRUE)
-                next()
-            }
-
-            if (!is.null(weights) && any(!is.na(weights))) {
-                D <- igraph::distances(sg, weights = weights[edge_idx])
-            } else {
-                D <- igraph::distances(sg, weights = weights)
-            }
-            W <- 1 / D^2
-            diag(W) <- 0
-
-            xinit <- .init_layout(sg, D, mds, n, dim)
-
-            if (dim == 2) {
-                lg[[i]] <- stress_major(xinit, W, D, iter, tol)
-            } else {
-                lg[[i]] <- stress_major3D(xinit, W, D, iter, tol)
-            }
-        }
-
-        lg <- lapply(lg, mv_to_null)
-        p <- order(comps$csize)
-        curx <- 0
-        cury <- 0
-        maxy <- 0
-        for (comp in p) {
-            if (curx + max(lg[[comp]][, 1]) > bbox) {
-                curx <- 0
-                cury <- maxy + 1
-            }
-            lg[[comp]][, 1] <- lg[[comp]][, 1] + curx
-            lg[[comp]][, 2] <- lg[[comp]][, 2] + cury
-            curx <- max(lg[[comp]][, 1]) + 1
-            maxy <- max(c(maxy, max(lg[[comp]][, 2])))
-        }
-        x <- do.call("rbind", lg)
-        x <- x[node_order, , drop = FALSE]
-        return(x)
+        layouter <- ifelse(dim == 2, stress_major, stress_major3D)
+        return(.component_layouter(
+            g = g, weights = weights, comps = comps, dim = dim, mds = mds,
+            bbox = bbox, iter = iter, tol = tol, FUN = layouter
+        ))
     }
 }
 
@@ -338,7 +355,7 @@ layout_with_centrality <- function(g, cent, scale = TRUE, iter = 500, tol = 0.00
 #' @export
 layout_with_constrained_stress <- function(g, coord, fixdim = "x", weights = NA,
                                            iter = 500, tol = 0.0001, mds = TRUE, bbox = 30) {
-    ensure_connected(g)
+    ensure_igraph(g)
 
     oldseed <- get_seed()
     set.seed(42) # stress is deterministic and produces same result up to translation. This keeps the layout fixed
@@ -351,32 +368,24 @@ layout_with_constrained_stress <- function(g, coord, fixdim = "x", weights = NA,
         stop('"coord" is missing with no default.')
     }
     comps <- igraph::components(g, "weak")
-    if (comps$no > 1) {
-        stop("g must be connected")
-    }
-
-    if (igraph::vcount(g) == 1) {
-        x <- matrix(c(0, 0), 1, 2)
-    } else {
-        D <- igraph::distances(g, weights = weights)
-        W <- 1 / D^2
-        diag(W) <- 0
-        n <- igraph::vcount(g)
-        if (!mds) {
-            xinit <- matrix(stats::runif(n * 2, 0, 1), n, 2)
-            xinit[, fixdim] <- coord
+    if (comps$no == 1) {
+        if (igraph::vcount(g) == 1) {
+            return(matrix(c(0, 0), 1, 2))
         } else {
-            rmat <- matrix(stats::runif(n * 2, -0.1, 0.1), n, 2)
-            if (igraph::vcount(g) <= 100) {
-                xinit <- igraph::layout_with_mds(g) + rmat
-            } else {
-                xinit <- layout_with_pmds(g, D = D[, sample(1:(igraph::vcount(g)), 100)]) + rmat
-            }
+            D <- igraph::distances(g, weights = weights)
+            W <- 1 / D^2
+            diag(W) <- 0
+            n <- igraph::vcount(g)
+            xinit <- .init_layout(g, D, mds, n, dim = 2)
             xinit[, fixdim] <- coord
+            return(constrained_stress_major(xinit, fixdim, W, D, iter, tol))
         }
-        x <- constrained_stress_major(xinit, fixdim, W, D, iter, tol)
+    } else {
+        return(.component_layouter(
+            g = g, weights = weights, comps = comps, dim = 2, mds = mds,
+            bbox = bbox, iter = iter, tol = tol, FUN = constrained_stress_major, fixdim = fixdim, coord = coord
+        ))
     }
-    x
 }
 
 #' constrained stress layout in 3D

R/utils.R

@@ -1,12 +1,12 @@
 ensure_igraph <- function(g) {
     if (!igraph::is_igraph(g)) {
-        stop("g must be an igraph object")
+        stop("g must be an igraph object", call. = FALSE)
     }
 }
 
 ensure_connected <- function(g) {
     if (!igraph::is_connected(g, mode = "weak")) {
-        stop("only connected graphs are supported.")
+        stop("only connected graphs are supported.", call. = FALSE)
     }
 }
 

tests/testthat/test-layout_backbone.R

@@ -1,10 +1,10 @@
 test_that("backbone layout works", {
-  xy <- layout_as_backbone(igraph::graph.full(10))
-  expect_is(xy$xy,"matrix")
-  expect_is(xy$backbone,"numeric")
-  expect_error(layout_as_backbone(5))
-  expect_error(layout_as_backbone(igraph::graph.empty(5)))
-  expect_error(layout_as_backbone(igraph::graph_from_adjacency_matrix(matrix(c(0,2,2,0),2,2),weighted = NULL,mode = "undirected")))
-  expect_error(layout_as_backbone(igraph::graph.full(5,directed=TRUE)))
-  expect_warning(layout_as_backbone(igraph::graph.full(5)+igraph::graph.full(5)))
+    xy <- layout_as_backbone(igraph::graph.full(10))
+    expect_is(xy$xy, "matrix")
+    expect_is(xy$backbone, "numeric")
+    expect_error(layout_as_backbone(5))
+    expect_error(layout_as_backbone(igraph::graph.empty(5)))
+    expect_error(layout_as_backbone(igraph::graph_from_adjacency_matrix(matrix(c(0, 2, 2, 0), 2, 2), weighted = NULL, mode = "undirected")))
+    expect_error(layout_as_backbone(igraph::graph.full(5, directed = TRUE)))
+    expect_warning(layout_as_backbone(igraph::graph.full(5) + igraph::graph.full(5)))
 })

tests/testthat/test-stress_majorization.R

@@ -123,6 +123,13 @@ test_that("it works on undirected connected graph", {
     expect_is(r, "matrix")
 })
 
+test_that("it works on undirected disconnected graph", {
+    g <- igraph::graph.full(5) + igraph::graph.full(5)
+    expect_silent(
+        r <- layout_with_stress(g)
+    )
+    expect_is(r, "matrix")
+})
 
 context("layout_with_stress3D() works on disconnected graphs")
 
@@ -159,6 +166,14 @@ test_that("it works on an undirected graph of two connected dyads with 5 isolate
     expect_is(r, "matrix")
 })
 
+test_that("it works on undirected disconnected graph", {
+    g <- igraph::graph.full(5) + igraph::graph.full(5)
+    expect_silent(
+        r <- layout_with_stress3D(g)
+    )
+    expect_is(r, "matrix")
+})
+
 context("Test layout_with_focus() on connected graphs")
 
 test_that("it works on undirected connected graphs", {
@@ -191,7 +206,7 @@ test_that("it fails for disconnected graphs", {
     expect_error(layout_with_centrality(igraph::graph.empty(n = 10, directed = FALSE)))
 })
 
-context("Test layout_with_constrained_stress() on connected graphs")
+context("Test layout_with_constrained_stress()")
 
 
 test_that("it works on undirected connected graph", {
@@ -203,6 +218,16 @@ test_that("it works on undirected connected graph", {
     expect_is(r, "matrix")
 })
 
+test_that("it works on undirected disconnected graph", {
+    g <- igraph::make_full_graph(5) + igraph::make_full_graph(5)
+    fix <- rep(c(1, 2), each = 5)
+    expect_silent(
+        r <- layout_with_constrained_stress(g, coord = fix)
+    )
+    expect_is(r, "matrix")
+    expect_true(all(r[, 1] == fix))
+})
+
 
 context("Test layout_with_constrained_stress3D() on connected graphs")
 test_that("it works on undirected connected graph", {