From e6ad86ba07b735721bd8ee0059219dcfcf6da0bc Mon Sep 17 00:00:00 2001 From: schochastics Date: Tue, 7 Nov 2023 22:06:25 +0100 Subject: [PATCH 01/16] =?UTF-8?q?unified=202D=20and=20=C2=A3D=20stress?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- DESCRIPTION | 2 +- NEWS.md | 2 + R/layout_stress.R | 825 ++++++++++++++++++--------------------- man/layout_centrality.Rd | 10 +- man/layout_stress.Rd | 6 +- 5 files changed, 395 insertions(+), 450 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 4cc9037..86d6601 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: graphlayouts Title: Additional Layout Algorithms for Network Visualizations -Version: 1.0.2 +Version: 1.0.2.9000 Authors@R: person("David", "Schoch", email = "david@schochastics.net", role = c("aut", "cre"), comment = c(ORCID = "0000-0003-2952-4812")) Description: Several new layout algorithms to visualize networks are provided which are not part of 'igraph'. diff --git a/NEWS.md b/NEWS.md index 22cd487..89b16eb 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,5 @@ +# graphlayouts 1.0.2.9000 + # graphlayouts 1.0.2 * fixed bug with weighted disconnected graphs (#71) h/t @gi0na diff --git a/R/layout_stress.R b/R/layout_stress.R index 0acd212..f96c8f3 100644 --- a/R/layout_stress.R +++ b/R/layout_stress.R @@ -1,3 +1,128 @@ +.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") + } + if (!dim %in% c(2, 3)) { + stop("dim must be either 2 or 3") + } + + if (exists(".Random.seed", .GlobalEnv)) { + oldseed <- .GlobalEnv$.Random.seed + } else { + oldseed <- NULL + } + + set.seed(42) # stress is deterministic and produces the same result up to translation. This keeps the layout fixed + on.exit(restore_seed(oldseed)) + + comps <- igraph::components(g, "weak") + if (comps$no > 1) { + 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 + + if (!mds) { + xinit <- matrix(stats::runif(n * dim, 0, 1), n, dim) + } else { + rmat <- matrix(stats::runif(n * dim, -0.1, 0.1), n, dim) + if (n <= 100) { + xinit <- igraph::layout_with_mds(sg, dim = dim) + rmat + } else { + xinit <- layout_with_pmds(sg, D = D[, sample(1:n, 100)], dim = dim) + rmat + } + } + + 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] + } else { + n <- igraph::vcount(g) + + if (n == 1) { + x <- 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) + } else { + if (!is.null(weights) && any(!is.na(weights))) { + D <- igraph::distances(g, weights = weights) + } else { + D <- igraph::distances(g) + } + W <- 1 / D^2 + diag(W) <- 0 + + if (!mds) { + xinit <- matrix(stats::runif(n * dim, 0, 1), n, dim) + } else { + rmat <- matrix(stats::runif(n * dim, -0.1, 0.1), n, dim) + if (n <= 100) { + xinit <- igraph::layout_with_mds(g, dim = dim) + rmat + } else { + xinit <- layout_with_pmds(g, D = D[, sample(1:n, 100)], dim = dim) + rmat + } + } + + if (dim == 2) { + x <- stress_major(xinit, W, D, iter, tol) + } else { + x <- stress_major3D(xinit, W, D, iter, tol) + } + } + } + } + return(x) +} + + #' stress majorization layout #' #' @name layout_stress @@ -29,104 +154,13 @@ #' # use it with ggraph #' \dontrun{ #' ggraph(g, layout = "stress") + -#' geom_edge_link0(edge_width = 0.2, colour = "grey") + -#' geom_node_point(col = "black", size = 0.3) + -#' theme_graph() +#' geom_edge_link0(edge_width = 0.2, colour = "grey") + +#' geom_node_point(col = "black", size = 0.3) + +#' theme_graph() #' } #' @export layout_with_stress <- function(g, weights = NA, iter = 500, tol = 0.0001, mds = TRUE, bbox = 30) { - if (!igraph::is_igraph(g)) { - stop("g must be an igraph object") - } - if (exists(".Random.seed", .GlobalEnv)) { - oldseed <- .GlobalEnv$.Random.seed - } else { - oldseed <- NULL - } - set.seed(42) # stress is deterministic and produces same result up to translation. This keeps the layout fixed - on.exit(restore_seed(oldseed)) - - comps <- igraph::components(g, "weak") - if (comps$no > 1) { - 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(c(0, 0), 1, 2, byrow = TRUE) - next() - } - if (n == 2) { - lg[[i]] <- matrix(c(0, 0, 1, 0), 2, 2, 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 - if (!mds) { - xinit <- matrix(stats::runif(n * 2, 0, 1), n, 2) - } else { - rmat <- matrix(stats::runif(n * 2, -0.1, 0.1), n, 2) - if (igraph::vcount(sg) <= 100) { - xinit <- igraph::layout_with_mds(sg) + rmat - } else { - xinit <- layout_with_pmds(sg, D = D[, sample(1:igraph::vcount(sg), 100)]) + rmat - } - } - lg[[i]] <- stress_major(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[order(node_order), ] - } else { - 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) - } 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 - } - } - x <- stress_major(xinit, W, D, iter, tol) - } - } - x + .layout_with_stress_dim(g, weights, iter, tol, mds, bbox, dim = 2) } #------------------------------------------------------------------------------# @@ -150,98 +184,7 @@ layout_with_stress <- function(g, weights = NA, iter = 500, tol = 0.0001, mds = #' @references Gansner, E. R., Koren, Y., & North, S. (2004). Graph drawing by stress majorization. *In International Symposium on Graph Drawing* (pp. 239-250). Springer, Berlin, Heidelberg. #' @export layout_with_stress3D <- function(g, weights = NA, iter = 500, tol = 0.0001, mds = TRUE, bbox = 30) { - if (!igraph::is_igraph(g)) { - stop("Not a graph object") - } - if (exists(".Random.seed", .GlobalEnv)) { - oldseed <- .GlobalEnv$.Random.seed - } else { - oldseed <- NULL - } - set.seed(42) # stress is deterministic and produces same result up to translation. This keeps the layout fixed - on.exit(restore_seed(oldseed)) - - comps <- igraph::components(g, "weak") - if (comps$no > 1) { - 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(c(0, 0, 0), 1, 3, byrow = TRUE) - next() - } - if (n == 2) { - lg[[i]] <- matrix(c(0, 0, 0, 1, 0, 0), 2, 3, 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 - if (!mds) { - xinit <- matrix(stats::runif(n * 3, 0, 1), n, 3) - } else { - rmat <- matrix(stats::runif(n * 3, -0.1, 0.1), n, 3) - if (igraph::vcount(sg) <= 100) { - xinit <- igraph::layout_with_mds(sg, dim = 3) + rmat - } else { - xinit <- layout_with_pmds(sg, D = D[, sample(1:igraph::vcount(sg), 100)], dim = 3) + rmat - } - } - 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[order(node_order), ] - } else { - if (igraph::vcount(g) == 1) { - x <- matrix(c(0, 0, 0), 1, 3) - } 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 * 3, 0, 1), n, 3) - } else { - rmat <- matrix(stats::runif(n * 3, -0.1, 0.1), n, 3) - if (igraph::vcount(g) <= 100) { - xinit <- igraph::layout_with_mds(g, dim = 3) + rmat - } else { - xinit <- layout_with_pmds(g, D = D[, sample(1:(igraph::vcount(g)), 100)], dim = 3) + rmat - } - } - x <- stress_major3D(xinit, W, D, iter, tol) - } - } - x + .layout_with_stress_dim(g, weights, iter, tol, mds, bbox, dim = 3) } @@ -271,43 +214,43 @@ layout_with_stress3D <- function(g, weights = NA, iter = 500, tol = 0.0001, mds #' @export layout_with_focus <- function(g, v, weights = NA, iter = 500, tol = 0.0001) { - if (!igraph::is.igraph(g)) { - stop("g must be an igraph object") - } - if (missing(v)) { - stop('argument "v" is missing with no default.') - } - comps <- igraph::components(g, "weak") - if (comps$no > 1) { - stop("g must be a connected graph.") - } - if (exists(".Random.seed", .GlobalEnv)) { - oldseed <- .GlobalEnv$.Random.seed - } else { - oldseed <- NULL - } - set.seed(42) # stress is deterministic and produces same result up to translation. This keeps the layout fixed - on.exit(restore_seed(oldseed)) - - n <- igraph::vcount(g) - D <- igraph::distances(g, weights = weights) - W <- 1 / D^2 - diag(W) <- 0 - - Z <- matrix(0, n, n) - Z[v, ] <- Z[, v] <- 1 - Z <- W * Z - - - rmat <- matrix(stats::runif(n * 2, -0.1, 0.1), n, 2) - xinit <- igraph::layout_with_mds(g) + rmat - - tseq <- seq(0, 1, 0.1) - x <- stress_focus(xinit, W, D, Z, tseq, iter, tol) - - offset <- x[v, ] - x <- t(apply(x, 1, function(x) x - offset)) - return(list(xy = x, distance = D[, v])) + if (!igraph::is.igraph(g)) { + stop("g must be an igraph object") + } + if (missing(v)) { + stop('argument "v" is missing with no default.') + } + comps <- igraph::components(g, "weak") + if (comps$no > 1) { + stop("g must be a connected graph.") + } + if (exists(".Random.seed", .GlobalEnv)) { + oldseed <- .GlobalEnv$.Random.seed + } else { + oldseed <- NULL + } + set.seed(42) # stress is deterministic and produces same result up to translation. This keeps the layout fixed + on.exit(restore_seed(oldseed)) + + n <- igraph::vcount(g) + D <- igraph::distances(g, weights = weights) + W <- 1 / D^2 + diag(W) <- 0 + + Z <- matrix(0, n, n) + Z[v, ] <- Z[, v] <- 1 + Z <- W * Z + + + rmat <- matrix(stats::runif(n * 2, -0.1, 0.1), n, 2) + xinit <- igraph::layout_with_mds(g) + rmat + + tseq <- seq(0, 1, 0.1) + x <- stress_focus(xinit, W, D, Z, tseq, iter, tol) + + offset <- x[v, ] + x <- t(apply(x, 1, function(x) x - offset)) + return(list(xy = x, distance = D[, v])) } #------------------------------------------------------------------------------# @@ -339,65 +282,65 @@ layout_with_focus <- function(g, v, weights = NA, iter = 500, tol = 0.0001) { #' g <- sample_gnp(10, 0.4) #' \dontrun{ #' ggraph(g, layout = "centrality", centrality = closeness(g)) + -#' draw_circle(use = "cent") + -#' geom_edge_link0() + -#' geom_node_point(shape = 21, fill = "grey25", size = 5) + -#' theme_graph() + -#' coord_fixed() +#' draw_circle(use = "cent") + +#' geom_edge_link0() + +#' geom_node_point(shape = 21, fill = "grey25", size = 5) + +#' theme_graph() + +#' coord_fixed() #' } #' @export #' layout_with_centrality <- function(g, cent, scale = TRUE, iter = 500, tol = 0.0001, tseq = seq(0, 1, 0.2)) { - if (!igraph::is.igraph(g)) { - stop("g must be an igraph object") - } - comps <- igraph::components(g, "weak") - if (comps$no > 1) { - stop("g must be connected") - } - if (missing(cent)) { - stop('argument "cent" is missing with no default.') - } - if (exists(".Random.seed", .GlobalEnv)) { - oldseed <- .GlobalEnv$.Random.seed - } else { - oldseed <- NULL - } - set.seed(42) # stress is deterministic and produces same result up to translation. This keeps the layout fixed - on.exit(restore_seed(oldseed)) - - n <- igraph::vcount(g) - if (scale) { - cent <- scale_to_100(cent) - } - r <- unname(igraph::diameter(g) / 2 * (1 - ((cent - min(cent)) / (max(cent) - min(cent) + 1)))) - - D <- igraph::distances(g, weights = NA) - W <- 1 / D^2 - diag(W) <- 0 - - rmat <- matrix(stats::runif(n * 2, -0.1, 0.1), n, 2) - xinit <- igraph::layout_with_mds(g) + rmat - - x <- stress_major(xinit, W, D, iter, tol) - x <- stress_radii(x, W, D, r, tseq) - - # move highest cent to 0,0 - idx <- which.max(cent)[1] - offset <- x[idx, ] - - x <- t(apply(x, 1, function(x) x - offset)) - if (scale) { - radii_new <- round(100 - cent, 8) - angles <- apply(x, 1, function(y) atan2(y[2], y[1])) - x <- cbind(radii_new * cos(angles), radii_new * sin(angles)) - } else { - radii_new <- round(max(cent) - cent, 8) - angles <- apply(x, 1, function(y) atan2(y[2], y[1])) - x <- cbind(radii_new * cos(angles), radii_new * sin(angles)) - } - x + if (!igraph::is.igraph(g)) { + stop("g must be an igraph object") + } + comps <- igraph::components(g, "weak") + if (comps$no > 1) { + stop("g must be connected") + } + if (missing(cent)) { + stop('argument "cent" is missing with no default.') + } + if (exists(".Random.seed", .GlobalEnv)) { + oldseed <- .GlobalEnv$.Random.seed + } else { + oldseed <- NULL + } + set.seed(42) # stress is deterministic and produces same result up to translation. This keeps the layout fixed + on.exit(restore_seed(oldseed)) + + n <- igraph::vcount(g) + if (scale) { + cent <- scale_to_100(cent) + } + r <- unname(igraph::diameter(g) / 2 * (1 - ((cent - min(cent)) / (max(cent) - min(cent) + 1)))) + + D <- igraph::distances(g, weights = NA) + W <- 1 / D^2 + diag(W) <- 0 + + rmat <- matrix(stats::runif(n * 2, -0.1, 0.1), n, 2) + xinit <- igraph::layout_with_mds(g) + rmat + + x <- stress_major(xinit, W, D, iter, tol) + x <- stress_radii(x, W, D, r, tseq) + + # move highest cent to 0,0 + idx <- which.max(cent)[1] + offset <- x[idx, ] + + x <- t(apply(x, 1, function(x) x - offset)) + if (scale) { + radii_new <- round(100 - cent, 8) + angles <- apply(x, 1, function(y) atan2(y[2], y[1])) + x <- cbind(radii_new * cos(angles), radii_new * sin(angles)) + } else { + radii_new <- round(max(cent) - cent, 8) + angles <- apply(x, 1, function(y) atan2(y[2], y[1])) + x <- cbind(radii_new * cos(angles), radii_new * sin(angles)) + } + x } #------------------------------------------------------------------------------# @@ -424,50 +367,50 @@ 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) { - if (!igraph::is_igraph(g)) { - stop("Not a graph object") - } - if (exists(".Random.seed", .GlobalEnv)) { - oldseed <- .GlobalEnv$.Random.seed - } else { - oldseed <- NULL - } - set.seed(42) # stress is deterministic and produces same result up to translation. This keeps the layout fixed - on.exit(restore_seed(oldseed)) - - fixdim <- match.arg(fixdim, c("x", "y")) - fixdim <- ifelse(fixdim == "x", 1, 2) - - if (missing(coord)) { - 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 (!igraph::is_igraph(g)) { + stop("Not a graph object") + } + if (exists(".Random.seed", .GlobalEnv)) { + oldseed <- .GlobalEnv$.Random.seed + } else { + oldseed <- NULL + } + set.seed(42) # stress is deterministic and produces same result up to translation. This keeps the layout fixed + on.exit(restore_seed(oldseed)) + + fixdim <- match.arg(fixdim, c("x", "y")) + fixdim <- ifelse(fixdim == "x", 1, 2) + + if (missing(coord)) { + 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 { - 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 - } - xinit[, fixdim] <- coord - } - x <- constrained_stress_major(xinit, fixdim, W, D, iter, tol) - } - x + 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 + } 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 + } + xinit[, fixdim] <- coord + } + x <- constrained_stress_major(xinit, fixdim, W, D, iter, tol) + } + x } #' constrained stress layout in 3D @@ -492,54 +435,54 @@ layout_with_constrained_stress <- function(g, coord, fixdim = "x", weights = NA, #' @export layout_with_constrained_stress3D <- function(g, coord, fixdim = "x", weights = NA, iter = 500, tol = 0.0001, mds = TRUE, bbox = 30) { - if (!igraph::is_igraph(g)) { - stop("Not a graph object") - } - if (exists(".Random.seed", .GlobalEnv)) { - oldseed <- .GlobalEnv$.Random.seed - } else { - oldseed <- NULL - } - set.seed(42) - on.exit(restore_seed(oldseed)) - fixdim <- match.arg(fixdim, c("x", "y", "z")) - fixdim <- ifelse(fixdim == "x", 1, ifelse(fixdim == "y", 2, 3)) - - if (missing(coord)) { - 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, 0), 1, 3) - } 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 * 3, 0, 1), n, 3) - xinit[, fixdim] <- coord + if (!igraph::is_igraph(g)) { + stop("Not a graph object") + } + if (exists(".Random.seed", .GlobalEnv)) { + oldseed <- .GlobalEnv$.Random.seed + } else { + oldseed <- NULL + } + set.seed(42) + on.exit(restore_seed(oldseed)) + fixdim <- match.arg(fixdim, c("x", "y", "z")) + fixdim <- ifelse(fixdim == "x", 1, ifelse(fixdim == "y", 2, 3)) + + if (missing(coord)) { + 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, 0), 1, 3) } else { - n <- igraph::vcount(g) - pivs <- sample(1:n, min(c(50, n))) - D1 <- D[, pivs] - cmean <- colMeans(D1^2) - rmean <- rowMeans(D1^2) - Dmat <- D1^2 - outer(rmean, cmean, function(x, y) x + y) + mean(D1^2) - sl2 <- svd(Dmat) - rmat <- matrix(stats::runif(n * 3, -0.1, 0.1), n, 3) - xinit <- (Dmat %*% sl2$v[, 1:3]) + rmat - row.names(xinit) <- NULL - - xinit[, fixdim] <- coord - } - x <- constrained_stress_major3D(xinit, fixdim, W, D, iter, tol) - } - x + D <- igraph::distances(g, weights = weights) + W <- 1 / D^2 + diag(W) <- 0 + n <- igraph::vcount(g) + if (!mds) { + xinit <- matrix(stats::runif(n * 3, 0, 1), n, 3) + xinit[, fixdim] <- coord + } else { + n <- igraph::vcount(g) + pivs <- sample(1:n, min(c(50, n))) + D1 <- D[, pivs] + cmean <- colMeans(D1^2) + rmean <- rowMeans(D1^2) + Dmat <- D1^2 - outer(rmean, cmean, function(x, y) x + y) + mean(D1^2) + sl2 <- svd(Dmat) + rmat <- matrix(stats::runif(n * 3, -0.1, 0.1), n, 3) + xinit <- (Dmat %*% sl2$v[, 1:3]) + rmat + row.names(xinit) <- NULL + + xinit[, fixdim] <- coord + } + x <- constrained_stress_major3D(xinit, fixdim, W, D, iter, tol) + } + x } #' radial focus group layout #' @@ -564,27 +507,27 @@ layout_with_constrained_stress3D <- function(g, coord, fixdim = "x", weights = N #' layout_with_focus_group(g, v = 1, group = grp, shrink = 10) #' @export layout_with_focus_group <- function(g, v, group, shrink = 10, weights = NA, iter = 500, tol = 0.0001) { - if (!igraph::is.igraph(g)) { - stop("g must be an igraph object") - } - if (missing(v)) { - stop('argument "v" is missing with no default.') - } - if (missing(group)) { - stop('argument "group" is missing with no default.') - } - comps <- igraph::components(g, "weak") - if (comps$no > 1) { - stop("g must be a connected graph.") - } - n_grp <- length(unique(group)) - xy <- layout_with_focus(g, v)$xy - ints <- seq(0, 360, length.out = n_grp + 1) - - for (i in seq_len(n_grp)) { - xy[group == i, ] <- map_to_angle_range(xy[group == i, ], c(ints[i] + shrink, ints[i + 1] - shrink)) - } - return(xy) + if (!igraph::is.igraph(g)) { + stop("g must be an igraph object") + } + if (missing(v)) { + stop('argument "v" is missing with no default.') + } + if (missing(group)) { + stop('argument "group" is missing with no default.') + } + comps <- igraph::components(g, "weak") + if (comps$no > 1) { + stop("g must be a connected graph.") + } + n_grp <- length(unique(group)) + xy <- layout_with_focus(g, v)$xy + ints <- seq(0, 360, length.out = n_grp + 1) + + for (i in seq_len(n_grp)) { + xy[group == i, ] <- map_to_angle_range(xy[group == i, ], c(ints[i] + shrink, ints[i + 1] - shrink)) + } + return(xy) } #------------------------------------------------------------------------------# @@ -607,83 +550,83 @@ layout_with_focus_group <- function(g, v, group, shrink = 10, weights = NA, iter #' library(igraph) #' @export layout_with_centrality_group <- function(g, cent, group, shrink = 10, ...) { - if (!igraph::is.igraph(g)) { - stop("g must be an igraph object") - } - comps <- igraph::components(g, "weak") - if (comps$no > 1) { - stop("g must be connected") - } - if (missing(group)) { - stop('argument "group" is missing with no default.') - } - if (missing(cent)) { - stop('argument "group" is missing with no default.') - } - n_grp <- length(unique(group)) - xy <- layout_with_centrality(g, cent, ...) - ints <- seq(0, 360, length.out = n_grp + 1) - - for (i in seq_len(n_grp)) { - xy[group == i, ] <- map_to_angle_range(xy[group == i, ], c(ints[i] + shrink, ints[i + 1] - shrink)) - } - return(xy) + if (!igraph::is.igraph(g)) { + stop("g must be an igraph object") + } + comps <- igraph::components(g, "weak") + if (comps$no > 1) { + stop("g must be connected") + } + if (missing(group)) { + stop('argument "group" is missing with no default.') + } + if (missing(cent)) { + stop('argument "group" is missing with no default.') + } + n_grp <- length(unique(group)) + xy <- layout_with_centrality(g, cent, ...) + ints <- seq(0, 360, length.out = n_grp + 1) + + for (i in seq_len(n_grp)) { + xy[group == i, ] <- map_to_angle_range(xy[group == i, ], c(ints[i] + shrink, ints[i + 1] - shrink)) + } + return(xy) } #-------------------------------------------------------------------------------# # helper functions ---- #-------------------------------------------------------------------------------# get_bbox <- function(xy) { - lbottom <- c(min(xy[, 1]), min(xy[, 2])) - rtop <- c(max(xy[, 1]), max(xy[, 2])) - c(lbottom, rtop) + lbottom <- c(min(xy[, 1]), min(xy[, 2])) + rtop <- c(max(xy[, 1]), max(xy[, 2])) + c(lbottom, rtop) } mv_to_null <- function(xy) { - bbox <- get_bbox(xy) - xy[, 1] <- xy[, 1] - bbox[1] - xy[, 2] <- xy[, 2] - bbox[2] - xy + bbox <- get_bbox(xy) + xy[, 1] <- xy[, 1] - bbox[1] + xy[, 2] <- xy[, 2] - bbox[2] + xy } scale_to_100 <- function(x) { - a <- min(x) - b <- max(x) - 100 / (b - a) * x - 100 / (b - a) * a + a <- min(x) + b <- max(x) + 100 / (b - a) * x - 100 / (b - a) * a } interpolate_cent <- function(cent, x) { - a <- min(cent) - b <- max(cent) - alpha <- 100 / (b - a) - beta <- -100 / (b - a) * a - (x - beta) / alpha + a <- min(cent) + b <- max(cent) + alpha <- 100 / (b - a) + beta <- -100 / (b - a) * a + (x - beta) / alpha } map_to_angle_range <- function(xy, arange) { - angles <- atan2(xy[, 2], xy[, 1]) / pi * 180 - angles[angles < 0] <- abs(angles[angles < 0]) + 180 - radii <- sqrt(rowSums(xy^2)) - angles <- normalise(angles, to = arange) - angles <- angles * pi / 180 - cbind(radii * cos(angles), radii * sin(angles)) + angles <- atan2(xy[, 2], xy[, 1]) / pi * 180 + angles[angles < 0] <- abs(angles[angles < 0]) + 180 + radii <- sqrt(rowSums(xy^2)) + angles <- normalise(angles, to = arange) + angles <- angles * pi / 180 + cbind(radii * cos(angles), radii * sin(angles)) } normalise <- function(x, from = range(x), to = c(0, 1)) { - x <- (x - from[1]) / (from[2] - from[1]) - if (!identical(to, c(0, 1))) { - x <- x * (to[2] - to[1]) + to[1] - } - x + x <- (x - from[1]) / (from[2] - from[1]) + if (!identical(to, c(0, 1))) { + x <- x * (to[2] - to[1]) + to[1] + } + x } restore_seed <- function(oldseed) { - if (!is.null(oldseed)) { - .GlobalEnv$.Random.seed <- oldseed - } else { - rm(".Random.seed", envir = .GlobalEnv) - } + if (!is.null(oldseed)) { + .GlobalEnv$.Random.seed <- oldseed + } else { + rm(".Random.seed", envir = .GlobalEnv) + } } #' @useDynLib graphlayouts, .registration = TRUE diff --git a/man/layout_centrality.Rd b/man/layout_centrality.Rd index 39f1b6a..f7b8620 100644 --- a/man/layout_centrality.Rd +++ b/man/layout_centrality.Rd @@ -61,11 +61,11 @@ library(ggraph) g <- sample_gnp(10, 0.4) \dontrun{ ggraph(g, layout = "centrality", centrality = closeness(g)) + - draw_circle(use = "cent") + - geom_edge_link0() + - geom_node_point(shape = 21, fill = "grey25", size = 5) + - theme_graph() + - coord_fixed() + draw_circle(use = "cent") + + geom_edge_link0() + + geom_node_point(shape = 21, fill = "grey25", size = 5) + + theme_graph() + + coord_fixed() } } \references{ diff --git a/man/layout_stress.Rd b/man/layout_stress.Rd index 1da5ed4..053836a 100644 --- a/man/layout_stress.Rd +++ b/man/layout_stress.Rd @@ -65,9 +65,9 @@ xy <- layout_with_stress(g) # use it with ggraph \dontrun{ ggraph(g, layout = "stress") + - geom_edge_link0(edge_width = 0.2, colour = "grey") + - geom_node_point(col = "black", size = 0.3) + - theme_graph() + geom_edge_link0(edge_width = 0.2, colour = "grey") + + geom_node_point(col = "black", size = 0.3) + + theme_graph() } } \references{ From 1913e2a4eb9c1344c3b26856e9aa84d3dafd6be5 Mon Sep 17 00:00:00 2001 From: schochastics Date: Wed, 8 Nov 2023 09:10:07 +0100 Subject: [PATCH 02/16] added get_seed --- R/layout_stress.R | 37 ++++++++++++------------------------- 1 file changed, 12 insertions(+), 25 deletions(-) diff --git a/R/layout_stress.R b/R/layout_stress.R index f96c8f3..bae51c2 100644 --- a/R/layout_stress.R +++ b/R/layout_stress.R @@ -6,11 +6,7 @@ stop("dim must be either 2 or 3") } - if (exists(".Random.seed", .GlobalEnv)) { - oldseed <- .GlobalEnv$.Random.seed - } else { - oldseed <- NULL - } + 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)) @@ -224,11 +220,7 @@ layout_with_focus <- function(g, v, weights = NA, iter = 500, tol = 0.0001) { if (comps$no > 1) { stop("g must be a connected graph.") } - if (exists(".Random.seed", .GlobalEnv)) { - oldseed <- .GlobalEnv$.Random.seed - } else { - oldseed <- NULL - } + oldseed <- get_seed() set.seed(42) # stress is deterministic and produces same result up to translation. This keeps the layout fixed on.exit(restore_seed(oldseed)) @@ -302,11 +294,7 @@ layout_with_centrality <- function(g, cent, scale = TRUE, iter = 500, tol = 0.00 if (missing(cent)) { stop('argument "cent" is missing with no default.') } - if (exists(".Random.seed", .GlobalEnv)) { - oldseed <- .GlobalEnv$.Random.seed - } else { - oldseed <- NULL - } + oldseed <- get_seed() set.seed(42) # stress is deterministic and produces same result up to translation. This keeps the layout fixed on.exit(restore_seed(oldseed)) @@ -370,11 +358,7 @@ layout_with_constrained_stress <- function(g, coord, fixdim = "x", weights = NA, if (!igraph::is_igraph(g)) { stop("Not a graph object") } - if (exists(".Random.seed", .GlobalEnv)) { - oldseed <- .GlobalEnv$.Random.seed - } else { - oldseed <- NULL - } + oldseed <- get_seed() set.seed(42) # stress is deterministic and produces same result up to translation. This keeps the layout fixed on.exit(restore_seed(oldseed)) @@ -438,11 +422,7 @@ layout_with_constrained_stress3D <- function(g, coord, fixdim = "x", weights = N if (!igraph::is_igraph(g)) { stop("Not a graph object") } - if (exists(".Random.seed", .GlobalEnv)) { - oldseed <- .GlobalEnv$.Random.seed - } else { - oldseed <- NULL - } + oldseed <- get_seed() set.seed(42) on.exit(restore_seed(oldseed)) fixdim <- match.arg(fixdim, c("x", "y", "z")) @@ -620,6 +600,13 @@ normalise <- function(x, from = range(x), to = c(0, 1)) { x } +get_seed <- function() { + if (exists(".Random.seed", .GlobalEnv)) { + return(.GlobalEnv$.Random.seed) + } else { + return(NULL) + } +} restore_seed <- function(oldseed) { if (!is.null(oldseed)) { From ad9d571e4840547d470337aabade4179a35cba76 Mon Sep 17 00:00:00 2001 From: schochastics Date: Wed, 8 Nov 2023 09:29:08 +0100 Subject: [PATCH 03/16] moved helpers to utils.R --- R/layout_dynamic.R | 115 ++++------- R/layout_large_graphs.R | 124 +++++------ R/layout_multilevel.R | 441 ++++++++++++++++------------------------ R/layout_spectral.R | 62 +++--- R/layout_stress.R | 63 ------ R/utils.R | 179 ++++++++++++++++ 6 files changed, 486 insertions(+), 498 deletions(-) create mode 100644 R/utils.R diff --git a/R/layout_dynamic.R b/R/layout_dynamic.R index c866b5c..5b841d1 100644 --- a/R/layout_dynamic.R +++ b/R/layout_dynamic.R @@ -24,89 +24,44 @@ #' xy[[1]] #' @export layout_as_dynamic <- function(gList, weights = NA, alpha = 0.5, iter = 500, tol = 1e-04) { - if (igraph::is_igraph(gList)) { - stop("'gList' must be a list of igraph objects.") - } - check_networks <- vapply(gList, FUN = function(x) igraph::is_igraph(x), FUN.VALUE = FALSE) - if (!all(check_networks)) { - stop("'gList' must be a list of igraph objects.") - } - - # prepare reference layout - g <- Reduce(igraph::union, gList) - check_nodes <- vapply(gList, FUN = function(x) igraph::vcount(x) == igraph::vcount(g), FUN.VALUE = FALSE) - if (!all(check_nodes)) { - stop("all nodes must be present in each network") - } - n <- igraph::vcount(g) - DList <- lapply(gList, igraph::distances, weights = weights) - DList <- adjust_dist(DList) - Dmean <- Reduce("+", DList) / length(DList) - Dvar <- Reduce("+", lapply(DList, function(x) (x - Dmean)^2)) / length(DList) - W <- 1 / Dmean^2 + 1 / (1 + Dvar) - diag(W) <- 0 - - # calculate reference layout - rmat <- matrix(stats::runif(n * 2, -0.1, 0.1), n, 2) - xinit <- igraph::layout_with_mds(g) + rmat - xref <- stress_major(xinit, W, Dmean, iter, tol) + if (igraph::is_igraph(gList)) { + stop("'gList' must be a list of igraph objects.") + } + check_networks <- vapply(gList, FUN = function(x) igraph::is_igraph(x), FUN.VALUE = FALSE) + if (!all(check_networks)) { + stop("'gList' must be a list of igraph objects.") + } - xycoords <- vector("list", length(gList)) - for (i in seq_along(gList)) { - D <- DList[[i]] - W <- 1 / D^2 - diag(W) <- 0 - if (i == 1) { - xycoords[[i]] <- stress_major(xref, W, D, iter, tol) - } else { - xycoords[[i]] <- stress_major(xycoords[[i - 1]], W, D, iter, tol) + # prepare reference layout + g <- Reduce(igraph::union, gList) + check_nodes <- vapply(gList, FUN = function(x) igraph::vcount(x) == igraph::vcount(g), FUN.VALUE = FALSE) + if (!all(check_nodes)) { + stop("all nodes must be present in each network") } - xycoords[[i]] <- (1 - alpha) * xycoords[[i]] + alpha * xref - } - xycoords -} + n <- igraph::vcount(g) + DList <- lapply(gList, igraph::distances, weights = weights) + DList <- adjust_dist(DList) + Dmean <- Reduce("+", DList) / length(DList) + Dvar <- Reduce("+", lapply(DList, function(x) (x - Dmean)^2)) / length(DList) + W <- 1 / Dmean^2 + 1 / (1 + Dvar) + diag(W) <- 0 + + # calculate reference layout + rmat <- matrix(stats::runif(n * 2, -0.1, 0.1), n, 2) + xinit <- igraph::layout_with_mds(g) + rmat + xref <- stress_major(xinit, W, Dmean, iter, tol) -adjust_dist <- function(DList) { - n <- nrow(DList[[1]]) - for (i in 1:n) { - for (j in 1:n) { - for (k in seq_along(DList)) { - if (is.infinite(DList[[k]][i, j])) { - lastD <- Inf - for (l in seq((k - 1), 1)) { - if (l == 0) { - next() - } - if (!is.infinite(DList[[l]][i, j])) { - lastD <- DList[[l]][i, j] - tlast <- l - break() - } - } - nextD <- Inf - for (l in seq((k + 1), length(DList))) { - if (l > length(DList)) { - break() - } - if (!is.infinite(DList[[l]][i, j])) { - nextD <- DList[[l]][i, j] - tnext <- l - break() - } - } - if (!is.infinite(lastD) & !is.infinite(nextD)) { - beta <- (k - tlast) / (tnext - tlast) - DList[[k]][i, j] <- (1 - beta) * lastD + beta * nextD + 1 - } else if (is.infinite(lastD) & !is.infinite(nextD)) { - DList[[k]][i, j] <- nextD + 1 - } else if (!is.infinite(lastD) & is.infinite(nextD)) { - DList[[k]][i, j] <- lastD + 1 - } else { - DList[[k]][i, j] <- sqrt(n) - } + xycoords <- vector("list", length(gList)) + for (i in seq_along(gList)) { + D <- DList[[i]] + W <- 1 / D^2 + diag(W) <- 0 + if (i == 1) { + xycoords[[i]] <- stress_major(xref, W, D, iter, tol) + } else { + xycoords[[i]] <- stress_major(xycoords[[i - 1]], W, D, iter, tol) } - } + xycoords[[i]] <- (1 - alpha) * xycoords[[i]] + alpha * xref } - } - DList + xycoords } diff --git a/R/layout_large_graphs.R b/R/layout_large_graphs.R index 402facb..9ade1d0 100644 --- a/R/layout_large_graphs.R +++ b/R/layout_large_graphs.R @@ -19,37 +19,37 @@ #' library(igraph) #' library(ggraph) #' -#' g <- sample_gnp(1000,0.01) +#' g <- sample_gnp(1000, 0.01) #' -#' xy <- layout_with_pmds(g,pivots = 100) +#' xy <- layout_with_pmds(g, pivots = 100) #' } #' @export -layout_with_pmds <- function(g,pivots,weights=NA,D=NULL,dim = 2){ - if (!igraph::is_igraph(g)) { - stop("Not a graph object") - } - if(!igraph::is_connected(g,mode = "weak")){ - stop("only connected graphs are supported.") - } - if(missing(pivots) & is.null(D)){ - stop('argument "pivots" is missing, with no default.') - } - if(!missing(pivots)){ - if(pivots>igraph::vcount(g)){ - stop('"pivots" must be less than the number of nodes in the graph.') +layout_with_pmds <- function(g, pivots, weights = NA, D = NULL, dim = 2) { + if (!igraph::is_igraph(g)) { + stop("Not a graph object") } - } - if(is.null(D)){ - pivs <- sample(1:igraph::vcount(g),pivots) - D <- t(igraph::distances(g,v=pivs,weights = weights)) - } - cmean <- colMeans(D^2) - rmean <- rowMeans(D^2) - Dmat <- D^2-outer(rmean,cmean, function(x,y) x+y)+mean(D^2) - sl2 <- svd(Dmat) + if (!igraph::is_connected(g, mode = "weak")) { + stop("only connected graphs are supported.") + } + if (missing(pivots) && is.null(D)) { + stop('argument "pivots" is missing, with no default.') + } + if (!missing(pivots)) { + if (pivots > igraph::vcount(g)) { + stop('"pivots" must be less than the number of nodes in the graph.') + } + } + if (is.null(D)) { + pivs <- sample(1:igraph::vcount(g), pivots) + D <- t(igraph::distances(g, v = pivs, weights = weights)) + } + cmean <- colMeans(D^2) + rmean <- rowMeans(D^2) + Dmat <- D^2 - outer(rmean, cmean, function(x, y) x + y) + mean(D^2) + sl2 <- svd(Dmat) - xy <- (Dmat%*%sl2$v[,1:dim]) - xy + xy <- (Dmat %*% sl2$v[, 1:dim]) + xy } @@ -71,47 +71,47 @@ layout_with_pmds <- function(g,pivots,weights=NA,D=NULL,dim = 2){ #' library(igraph) #' library(ggraph) #' -#' g <- sample_gnp(1000,0.005) +#' g <- sample_gnp(1000, 0.005) #' -#' ggraph(g,layout = "sparse_stress",pivots = 100)+ -#' geom_edge_link0(edge_colour = "grey66")+ -#' geom_node_point(shape = 21,fill = "grey25",size = 5)+ -#' theme_graph() -#'} +#' ggraph(g, layout = "sparse_stress", pivots = 100) + +#' geom_edge_link0(edge_colour = "grey66") + +#' geom_node_point(shape = 21, fill = "grey25", size = 5) + +#' theme_graph() +#' } #' @export -layout_with_sparse_stress <- function(g,pivots,weights=NA,iter=500){ - if (!igraph::is_igraph(g)) { - stop("not a graph object") - } - if(!igraph::is_connected(g,mode = "weak")){ - stop("only connected graphs are supported.") - } - if(!all(is.na(weights))){ - warning("weights are not supported. unweighted graph is used instead.") - } - if(is.null(pivots)){ - stop('argument "pivots" is missing, with no default.') - } - if(pivots>igraph::vcount(g)){ - stop('"pivots" must be less than the number of nodes in the graph.') - } - pivs <- sample(1:igraph::vcount(g),pivots) +layout_with_sparse_stress <- function(g, pivots, weights = NA, iter = 500) { + if (!igraph::is_igraph(g)) { + stop("not a graph object") + } + if (!igraph::is_connected(g, mode = "weak")) { + stop("only connected graphs are supported.") + } + if (!all(is.na(weights))) { + warning("weights are not supported. unweighted graph is used instead.") + } + if (is.null(pivots)) { + stop('argument "pivots" is missing, with no default.') + } + if (pivots > igraph::vcount(g)) { + stop('"pivots" must be less than the number of nodes in the graph.') + } + pivs <- sample(1:igraph::vcount(g), pivots) + + D <- t(igraph::distances(g, v = pivs, weights = NA)) + Rp <- apply(D, 1, which.min) + y <- layout_with_pmds(g, pivots, D = D, weights = NA) - D <- t(igraph::distances(g,v=pivs,weights = NA)) - Rp <- apply(D,1,which.min) - y <- layout_with_pmds(g,pivots,D = D,weights = NA) + # rescale + el <- igraph::get.edgelist(g, names = FALSE) + norm1 <- sum(sqrt((y[el[, 1], 1] - y[el[, 2], 1])^2 + (y[el[, 1], 2] - y[el[, 2], 2])^2)) - #rescale - el <- igraph::get.edgelist(g,names = FALSE) - norm1 <- sum(sqrt((y[el[,1],1]-y[el[,2],1])^2+(y[el[,1],2]-y[el[,2],2])^2)) - n <- igraph::vcount(g) - y <- y*(igraph::ecount(g)/norm1) + y <- y * (igraph::ecount(g) / norm1) - RpL <- lapply(seq_along(pivs),function(x) which(Rp==x)-1) - pivs <- pivs-1 + RpL <- lapply(seq_along(pivs), function(x) which(Rp == x) - 1) + pivs <- pivs - 1 - A <- igraph::get.adjacency(g,type = "both",sparse = TRUE) - xy <- sparseStress(y,D,RpL,pivs,A,iter) - xy + A <- igraph::get.adjacency(g, type = "both", sparse = TRUE) + xy <- sparseStress(y, D, RpL, pivs, A, iter) + xy } diff --git a/R/layout_multilevel.R b/R/layout_multilevel.R index f774c9a..0eeff2e 100644 --- a/R/layout_multilevel.R +++ b/R/layout_multilevel.R @@ -38,10 +38,10 @@ #' #' # compute a layout for each level separately and combine them #' xy <- layout_as_multilevel(multilvl_ex, -#' type = "separate", -#' FUN1 = layout_as_backbone, -#' FUN2 = layout_with_stress, -#' alpha = 25, beta = 45 +#' type = "separate", +#' FUN1 = layout_as_backbone, +#' FUN2 = layout_with_stress, +#' alpha = 25, beta = 45 #' ) #' #' @export @@ -50,264 +50,181 @@ layout_as_multilevel <- function(g, type = "all", FUN1, FUN2, ignore_iso = TRUE, project2D = TRUE, alpha = 35, beta = 45) { - type <- match.arg(type, c("all", "separate", "fix1", "fix2")) - - if (!"lvl" %in% igraph::vertex_attr_names(g)) { - stop("level information should be stored in a vertex attribute called 'lvl'") - } - # 3D stress - if (type == "all") { - xyz <- layout_with_constrained_stress3D(g, coord = igraph::V(g)$lvl, fixdim = "y") - xyz <- optim_rotation(g, xyz) - xyz <- optim_isolates(g, xyz) - xyz[, c(1, 3)] <- c(normalise(xyz[, 1], to = c(1, 2)), normalise(xyz[, 3], to = c(1, 2))) - # separate - } else if (type == "separate") { - if (missing(FUN1) | missing(FUN2)) { - stop("FUN1 and FUN2 must both be specified") - } - - lvl1 <- which(igraph::V(g)$lvl == 1) - lvl2 <- which(igraph::V(g)$lvl == 2) - - g1 <- igraph::induced_subgraph(g, lvl1) - g2 <- igraph::induced_subgraph(g, lvl2) - if (ignore_iso) { - iso1 <- which(igraph::degree(g1) == 0) - iso2 <- which(igraph::degree(g2) == 0) - g1 <- igraph::delete.vertices(g1, iso1) - g2 <- igraph::delete.vertices(g2, iso2) - } - - if (is.null(params1)) { - xy1 <- FUN1(g1) - } else { - if (!all(names(params1) %in% names(formals(FUN1)))) { - stop("params1 contains invalid parameters.") - } - formals(FUN1)[names(params1)] <- params1 - xy1 <- FUN1(g1) - } - if (typeof(xy1) == "list") { - xy1 <- xy1$xy - } - - if (is.null(params2)) { - xy2 <- FUN2(g2) - } else { - if (!all(names(params2) %in% names(formals(FUN2)))) { - stop("params2 contains invalid parameters.") - } - formals(FUN2)[names(params2)] <- params2 - xy2 <- FUN2(g2) - } - if (typeof(xy1) == "list") { - xy2 <- xy2$xy - } - xyz <- cbind(0, igraph::V(g)$lvl, 0) - if (ignore_iso) { - if (length(iso1) != 0) { - xy1_tmp <- matrix(0, length(lvl1), 2) - xy1_tmp[-iso1, ] <- xy1 - xy1 <- xy1_tmp - } - if (length(iso2) != 0) { - xy2_tmp <- matrix(0, length(lvl2), 2) - xy2_tmp[-iso2, ] <- xy2 - xy2 <- xy2_tmp - } - } - xy1[, 1] <- normalise(xy1[, 1], to = c(1, 2)) - xy1[, 2] <- normalise(xy1[, 2], to = c(1, 2)) - xy2[, 1] <- normalise(xy2[, 1], to = c(1, 2)) - xy2[, 2] <- normalise(xy2[, 2], to = c(1, 2)) - xyz[lvl1, c(1, 3)] <- xy1 - xyz[lvl2, c(1, 3)] <- xy2 - xyz <- optim_rotation(g, xyz) - xyz <- optim_isolates(g, xyz) - # fix level 1 - } else if (type == "fix1") { - if (missing(FUN1)) { - stop("FUN1 must must be specified") - } - lvl1 <- which(igraph::V(g)$lvl == 1) - lvl2 <- which(igraph::V(g)$lvl == 2) - g1 <- igraph::induced_subgraph(g, lvl1) - - if (ignore_iso) { - iso1 <- which(igraph::degree(g1) == 0) - g1 <- igraph::delete.vertices(g1, iso1) - } - - if (is.null(params1)) { - xy1 <- FUN1(g1) - } else { - if (!all(names(params1 %in% names(formals(FUN1))))) { - stop("params1 contains invalid parameters.") - } - formals(FUN1)[names(params1)] <- params1 - xy1 <- FUN1(g1) - } - if (typeof(xy1) == "list") { - xy1 <- xy1$xy - } - xyz <- cbind(0, igraph::V(g)$lvl, 0) - if (ignore_iso) { - if (length(iso1) != 0) { - xy1_tmp <- matrix(0, length(lvl1), 2) - - mx <- mean(xy1[, 1], na.rm = TRUE) - my <- mean(xy1[, 2], na.rm = TRUE) - r <- max(sqrt((xy1[, 1] - mx)^2 + (xy1[, 2] - my)^2)) - isox <- stats::runif(length(iso1), mx - r, mx + r) - isoy <- sample(c(-1, 1), length(iso1), replace = T) * sqrt(r^2 - (isox - mx)^2) + my - xy1_tmp[-iso1, ] <- xy1 - xy1_tmp[iso1, ] <- cbind(isox, isoy) - xy1 <- xy1_tmp - } - } - xy1[, 1] <- normalise(xy1[, 1], to = c(1, 2)) - xy1[, 2] <- normalise(xy1[, 2], to = c(1, 2)) - xy2 <- optim_level(g, 1, xy1) - xyz[lvl1, c(1, 3)] <- xy1 - xyz[lvl2, c(1, 3)] <- xy2 - # fix level 2 - } else if (type == "fix2") { - if (missing(FUN2)) { - stop("FUN2 must must be specified") - } - lvl1 <- which(igraph::V(g)$lvl == 1) - lvl2 <- which(igraph::V(g)$lvl == 2) - g2 <- igraph::induced_subgraph(g, lvl2) - - if (ignore_iso) { - iso2 <- which(igraph::degree(g2) == 0) - g2 <- igraph::delete.vertices(g2, iso2) - } - - if (is.null(params2)) { - xy2 <- FUN2(g2) + type <- match.arg(type, c("all", "separate", "fix1", "fix2")) + + if (!"lvl" %in% igraph::vertex_attr_names(g)) { + stop("level information should be stored in a vertex attribute called 'lvl'") + } + # 3D stress + if (type == "all") { + xyz <- layout_with_constrained_stress3D(g, coord = igraph::V(g)$lvl, fixdim = "y") + xyz <- optim_rotation(g, xyz) + xyz <- optim_isolates(g, xyz) + xyz[, c(1, 3)] <- c(normalise(xyz[, 1], to = c(1, 2)), normalise(xyz[, 3], to = c(1, 2))) + # separate + } else if (type == "separate") { + if (missing(FUN1) || missing(FUN2)) { + stop("FUN1 and FUN2 must both be specified") + } + + lvl1 <- which(igraph::V(g)$lvl == 1) + lvl2 <- which(igraph::V(g)$lvl == 2) + + g1 <- igraph::induced_subgraph(g, lvl1) + g2 <- igraph::induced_subgraph(g, lvl2) + if (ignore_iso) { + iso1 <- which(igraph::degree(g1) == 0) + iso2 <- which(igraph::degree(g2) == 0) + g1 <- igraph::delete.vertices(g1, iso1) + g2 <- igraph::delete.vertices(g2, iso2) + } + + if (is.null(params1)) { + xy1 <- FUN1(g1) + } else { + if (!all(names(params1) %in% names(formals(FUN1)))) { + stop("params1 contains invalid parameters.") + } + formals(FUN1)[names(params1)] <- params1 + xy1 <- FUN1(g1) + } + if (typeof(xy1) == "list") { + xy1 <- xy1$xy + } + + if (is.null(params2)) { + xy2 <- FUN2(g2) + } else { + if (!all(names(params2) %in% names(formals(FUN2)))) { + stop("params2 contains invalid parameters.") + } + formals(FUN2)[names(params2)] <- params2 + xy2 <- FUN2(g2) + } + if (typeof(xy1) == "list") { + xy2 <- xy2$xy + } + xyz <- cbind(0, igraph::V(g)$lvl, 0) + if (ignore_iso) { + if (length(iso1) != 0) { + xy1_tmp <- matrix(0, length(lvl1), 2) + xy1_tmp[-iso1, ] <- xy1 + xy1 <- xy1_tmp + } + if (length(iso2) != 0) { + xy2_tmp <- matrix(0, length(lvl2), 2) + xy2_tmp[-iso2, ] <- xy2 + xy2 <- xy2_tmp + } + } + xy1[, 1] <- normalise(xy1[, 1], to = c(1, 2)) + xy1[, 2] <- normalise(xy1[, 2], to = c(1, 2)) + xy2[, 1] <- normalise(xy2[, 1], to = c(1, 2)) + xy2[, 2] <- normalise(xy2[, 2], to = c(1, 2)) + xyz[lvl1, c(1, 3)] <- xy1 + xyz[lvl2, c(1, 3)] <- xy2 + xyz <- optim_rotation(g, xyz) + xyz <- optim_isolates(g, xyz) + # fix level 1 + } else if (type == "fix1") { + if (missing(FUN1)) { + stop("FUN1 must must be specified") + } + lvl1 <- which(igraph::V(g)$lvl == 1) + lvl2 <- which(igraph::V(g)$lvl == 2) + g1 <- igraph::induced_subgraph(g, lvl1) + + if (ignore_iso) { + iso1 <- which(igraph::degree(g1) == 0) + g1 <- igraph::delete.vertices(g1, iso1) + } + + if (is.null(params1)) { + xy1 <- FUN1(g1) + } else { + if (!all(names(params1 %in% names(formals(FUN1))))) { + stop("params1 contains invalid parameters.") + } + formals(FUN1)[names(params1)] <- params1 + xy1 <- FUN1(g1) + } + if (typeof(xy1) == "list") { + xy1 <- xy1$xy + } + xyz <- cbind(0, igraph::V(g)$lvl, 0) + if (ignore_iso) { + if (length(iso1) != 0) { + xy1_tmp <- matrix(0, length(lvl1), 2) + + mx <- mean(xy1[, 1], na.rm = TRUE) + my <- mean(xy1[, 2], na.rm = TRUE) + r <- max(sqrt((xy1[, 1] - mx)^2 + (xy1[, 2] - my)^2)) + isox <- stats::runif(length(iso1), mx - r, mx + r) + isoy <- sample(c(-1, 1), length(iso1), replace = T) * sqrt(r^2 - (isox - mx)^2) + my + xy1_tmp[-iso1, ] <- xy1 + xy1_tmp[iso1, ] <- cbind(isox, isoy) + xy1 <- xy1_tmp + } + } + xy1[, 1] <- normalise(xy1[, 1], to = c(1, 2)) + xy1[, 2] <- normalise(xy1[, 2], to = c(1, 2)) + xy2 <- optim_level(g, 1, xy1) + xyz[lvl1, c(1, 3)] <- xy1 + xyz[lvl2, c(1, 3)] <- xy2 + # fix level 2 + } else if (type == "fix2") { + if (missing(FUN2)) { + stop("FUN2 must must be specified") + } + lvl1 <- which(igraph::V(g)$lvl == 1) + lvl2 <- which(igraph::V(g)$lvl == 2) + g2 <- igraph::induced_subgraph(g, lvl2) + + if (ignore_iso) { + iso2 <- which(igraph::degree(g2) == 0) + g2 <- igraph::delete.vertices(g2, iso2) + } + + if (is.null(params2)) { + xy2 <- FUN2(g2) + } else { + if (!all(names(params2 %in% names(formals(FUN2))))) { + stop("params1 contains invalid parameters.") + } + formals(FUN2)[names(params2)] <- params2 + xy2 <- FUN2(g2) + } + if (typeof(xy2) == "list") { + xy2 <- xy2$xy + } + xyz <- cbind(0, igraph::V(g)$lvl, 0) + + if (ignore_iso) { + if (length(iso2) != 0) { + xy2_tmp <- matrix(0, length(lvl2), 2) + + mx <- mean(xy2[, 1], na.rm = TRUE) + my <- mean(xy2[, 2], na.rm = TRUE) + r <- max(sqrt((xy2[, 1] - mx)^2 + (xy2[, 2] - my)^2)) + + isox <- stats::runif(length(iso2), mx - r, mx + r) + isoy <- sample(c(-1, 1), length(iso2), replace = T) * sqrt(r^2 - (isox - mx)^2) + my + xy2_tmp[-iso2, ] <- xy2 + xy2_tmp[iso2, ] <- cbind(isox, isoy) + xy2 <- xy2_tmp + } + } + + xy2[, 1] <- normalise(xy2[, 1], to = c(1, 2)) + xy2[, 2] <- normalise(xy2[, 2], to = c(1, 2)) + xy1 <- optim_level(g, 2, xy2) + xyz[lvl1, c(1, 3)] <- xy1 + xyz[lvl2, c(1, 3)] <- xy2 + } + if (project2D) { + xy <- iso_project(xyz, a = alpha, b = beta) + return(xy) } else { - if (!all(names(params2 %in% names(formals(FUN2))))) { - stop("params1 contains invalid parameters.") - } - formals(FUN2)[names(params2)] <- params2 - xy2 <- FUN2(g2) - } - if (typeof(xy2) == "list") { - xy2 <- xy2$xy - } - xyz <- cbind(0, igraph::V(g)$lvl, 0) - - if (ignore_iso) { - if (length(iso2) != 0) { - xy2_tmp <- matrix(0, length(lvl2), 2) - - mx <- mean(xy2[, 1], na.rm = TRUE) - my <- mean(xy2[, 2], na.rm = TRUE) - r <- max(sqrt((xy2[, 1] - mx)^2 + (xy2[, 2] - my)^2)) - - isox <- stats::runif(length(iso2), mx - r, mx + r) - isoy <- sample(c(-1, 1), length(iso2), replace = T) * sqrt(r^2 - (isox - mx)^2) + my - xy2_tmp[-iso2, ] <- xy2 - xy2_tmp[iso2, ] <- cbind(isox, isoy) - xy2 <- xy2_tmp - } + return(xyz) } - - xy2[, 1] <- normalise(xy2[, 1], to = c(1, 2)) - xy2[, 2] <- normalise(xy2[, 2], to = c(1, 2)) - xy1 <- optim_level(g, 2, xy2) - xyz[lvl1, c(1, 3)] <- xy1 - xyz[lvl2, c(1, 3)] <- xy2 - } - if (project2D) { - xy <- iso_project(xyz, a = alpha, b = beta) - return(xy) - } else { - return(xyz) - } -} - -#------------------------------------------------------------------------------# -#------------------------------------------------------------------------------# -# helper ---- - -iso_project <- function(xyz, a = 35.264, b = 45) { - a <- a * pi / 180 - b <- b * pi / 180 - T1 <- matrix(c(1, 0, 0, 0, cos(a), sin(a), 0, -sin(a), cos(a)), 3, 3, byrow = TRUE) - T2 <- matrix(c(cos(b), 0, -sin(b), 0, 1, 0, sin(b), 0, cos(b)), 3, 3, byrow = TRUE) - trans <- T1 %*% T2 %*% t(xyz) - coords2D <- matrix(c(1, 0, 0, 0, 1, 0, 0, 0, 0), 3, 3, byrow = TRUE) %*% trans - coords2D <- t(coords2D) - return(coords2D[, 1:2]) -} - -degree_lvl <- function(g) { - if (!"lvl" %in% igraph::vertex_attr_names(g)) { - stop("level information should be stored in a vertex attribute called 'lvl'") - } - A <- igraph::as_adj(g, "both", sparse = FALSE) - lvl_mat <- outer(igraph::V(g)$lvl, igraph::V(g)$lvl, function(x, y) x == y) - cent <- rbind(rowSums(A * lvl_mat), rowSums(A * !lvl_mat)) - rownames(cent) <- c("intra", "inter") - cent -} - -normalise <- function(x, from = range(x), to = c(0, 1)) { - x <- (x - from[1]) / (from[2] - from[1]) - if (!identical(to, c(0, 1))) { - x <- x * (to[2] - to[1]) + to[1] - } - x -} - -optim_isolates <- function(g, xyz) { - deg <- degree_lvl(g) - idx <- which(deg[1, ] == 0) - if (length(idx) > 0) { - neigh <- igraph::neighborhood(g, order = 1, nodes = idx, mode = "all", mindist = 1) - xyz[idx, c(1, 3)] <- do.call("rbind", lapply(neigh, function(id) cbind(mean(xyz[id, 1]), mean(xyz[id, 3])))) - } - xyz -} - -optim_rotation <- function(g, xyz) { - D <- igraph::distances(g) - W <- 1 / D^2 - smin <- stress3D(xyz, W, D) - # smin <- stress(xyz[,c(1,3)],W,D) - amax <- 0 - idx <- which(igraph::V(g)$lvl == 2) - for (alpha in seq(0, 360, 5)) { - xyz_new <- xyz - xyz_new[idx, c(1, 3)] <- layout_rotate(xyz_new[idx, c(1, 3)], alpha) - stemp <- stress3D(xyz_new, W, D) - # stemp <- stress(xyz_new[,c(1,3)],W,D) - if (stemp < smin) { - amax <- alpha - } - } - xyz[idx, c(1, 3)] <- layout_rotate(xyz[idx, c(1, 3)], amax) - xyz -} - -optim_level <- function(g, lvl, xy) { - A <- igraph::as_adj(g, "both") - Ainter <- A[igraph::V(g)$lvl != lvl, igraph::V(g)$lvl == lvl] - adjList <- apply(Ainter, 1, function(x) which(x == 1)) - - xy2 <- do.call("rbind", lapply(adjList, function(id) cbind(mean(xy[id, 1]), mean(xy[id, 2])))) - idx <- is.na(xy2[, 1]) - - mx <- mean(xy[, 1], na.rm = TRUE) - my <- mean(xy[, 2], na.rm = TRUE) - r <- max(sqrt((xy[, 1] - mx)^2 + (xy[, 2] - my)^2)) - - if (length(idx) > 0) { - xy2[idx, 1] <- stats::runif(n = sum(idx), min = mx - r, max = mx + r) - xy2[idx, 2] <- sample(c(-1, 1), sum(idx), replace = T) * sqrt(r^2 - (xy2[idx, 1] - mx)^2) + my - } - xy2 } diff --git a/R/layout_spectral.R b/R/layout_spectral.R index dc956e0..079f2d1 100644 --- a/R/layout_spectral.R +++ b/R/layout_spectral.R @@ -23,35 +23,35 @@ #' @export layout_with_eigen <- function(g, type = "laplacian", ev = "smallest") { - if (!igraph::is_igraph(g)) { - stop("g must be an igraph object") - } - if (!igraph::is_connected(g)) { - stop("g must be connected") - } - if (igraph::is_directed(g)) { - warning("g is directed. undirected version is used for the layout.") - g <- igraph::as.undirected(g) - } - if (!type %in% c("laplacian", "adjacency")) { - stop("type must be one of 'laplacian' or 'adjacency'") - } - if (!ev %in% c("largest", "smallest")) { - stop("ev must be one of 'smallest' or 'largest'") - } - n <- igraph::vcount(g) - if (type == "adjacency") { - A <- igraph::get.adjacency(g, type = "both") - } else { - A <- igraph::laplacian_matrix(g) - } - sA <- eigen(A) - if (ev == "largest") { - xy <- sA$vectors[, 1:2] - } else if (ev == "smallest" & type == "adjacency") { - xy <- sA$vectors[, (n - 1):n] - } else { - xy <- sA$vectors[, (n - 2):(n - 1)] - } - xy + if (!igraph::is_igraph(g)) { + stop("g must be an igraph object") + } + if (!igraph::is_connected(g)) { + stop("g must be connected") + } + if (igraph::is_directed(g)) { + warning("g is directed. undirected version is used for the layout.") + g <- igraph::as.undirected(g) + } + if (!type %in% c("laplacian", "adjacency")) { + stop("type must be one of 'laplacian' or 'adjacency'") + } + if (!ev %in% c("largest", "smallest")) { + stop("ev must be one of 'smallest' or 'largest'") + } + n <- igraph::vcount(g) + if (type == "adjacency") { + A <- igraph::get.adjacency(g, type = "both") + } else { + A <- igraph::laplacian_matrix(g) + } + sA <- eigen(A) + if (ev == "largest") { + xy <- sA$vectors[, 1:2] + } else if (ev == "smallest" && type == "adjacency") { + xy <- sA$vectors[, (n - 1):n] + } else { + xy <- sA$vectors[, (n - 2):(n - 1)] + } + xy } diff --git a/R/layout_stress.R b/R/layout_stress.R index bae51c2..72f7590 100644 --- a/R/layout_stress.R +++ b/R/layout_stress.R @@ -552,69 +552,6 @@ layout_with_centrality_group <- function(g, cent, group, shrink = 10, ...) { } return(xy) } -#-------------------------------------------------------------------------------# -# helper functions ---- -#-------------------------------------------------------------------------------# - -get_bbox <- function(xy) { - lbottom <- c(min(xy[, 1]), min(xy[, 2])) - rtop <- c(max(xy[, 1]), max(xy[, 2])) - c(lbottom, rtop) -} - -mv_to_null <- function(xy) { - bbox <- get_bbox(xy) - xy[, 1] <- xy[, 1] - bbox[1] - xy[, 2] <- xy[, 2] - bbox[2] - xy -} - -scale_to_100 <- function(x) { - a <- min(x) - b <- max(x) - 100 / (b - a) * x - 100 / (b - a) * a -} - -interpolate_cent <- function(cent, x) { - a <- min(cent) - b <- max(cent) - alpha <- 100 / (b - a) - beta <- -100 / (b - a) * a - (x - beta) / alpha -} - -map_to_angle_range <- function(xy, arange) { - angles <- atan2(xy[, 2], xy[, 1]) / pi * 180 - angles[angles < 0] <- abs(angles[angles < 0]) + 180 - radii <- sqrt(rowSums(xy^2)) - angles <- normalise(angles, to = arange) - angles <- angles * pi / 180 - cbind(radii * cos(angles), radii * sin(angles)) -} - -normalise <- function(x, from = range(x), to = c(0, 1)) { - x <- (x - from[1]) / (from[2] - from[1]) - if (!identical(to, c(0, 1))) { - x <- x * (to[2] - to[1]) + to[1] - } - x -} - -get_seed <- function() { - if (exists(".Random.seed", .GlobalEnv)) { - return(.GlobalEnv$.Random.seed) - } else { - return(NULL) - } -} - -restore_seed <- function(oldseed) { - if (!is.null(oldseed)) { - .GlobalEnv$.Random.seed <- oldseed - } else { - rm(".Random.seed", envir = .GlobalEnv) - } -} #' @useDynLib graphlayouts, .registration = TRUE #' @importFrom Rcpp sourceCpp diff --git a/R/utils.R b/R/utils.R new file mode 100644 index 0000000..8660c64 --- /dev/null +++ b/R/utils.R @@ -0,0 +1,179 @@ +#-------------------------------------------------------------------------------# +# helper functions ---- +#-------------------------------------------------------------------------------# + +get_bbox <- function(xy) { + lbottom <- c(min(xy[, 1]), min(xy[, 2])) + rtop <- c(max(xy[, 1]), max(xy[, 2])) + c(lbottom, rtop) +} + +mv_to_null <- function(xy) { + bbox <- get_bbox(xy) + xy[, 1] <- xy[, 1] - bbox[1] + xy[, 2] <- xy[, 2] - bbox[2] + xy +} + +scale_to_100 <- function(x) { + a <- min(x) + b <- max(x) + 100 / (b - a) * x - 100 / (b - a) * a +} + +interpolate_cent <- function(cent, x) { + a <- min(cent) + b <- max(cent) + alpha <- 100 / (b - a) + beta <- -100 / (b - a) * a + (x - beta) / alpha +} + +map_to_angle_range <- function(xy, arange) { + angles <- atan2(xy[, 2], xy[, 1]) / pi * 180 + angles[angles < 0] <- abs(angles[angles < 0]) + 180 + radii <- sqrt(rowSums(xy^2)) + angles <- normalise(angles, to = arange) + angles <- angles * pi / 180 + cbind(radii * cos(angles), radii * sin(angles)) +} + +normalise <- function(x, from = range(x), to = c(0, 1)) { + x <- (x - from[1]) / (from[2] - from[1]) + if (!identical(to, c(0, 1))) { + x <- x * (to[2] - to[1]) + to[1] + } + x +} + +get_seed <- function() { + if (exists(".Random.seed", .GlobalEnv)) { + return(.GlobalEnv$.Random.seed) + } else { + return(NULL) + } +} + +restore_seed <- function(oldseed) { + if (!is.null(oldseed)) { + .GlobalEnv$.Random.seed <- oldseed + } else { + rm(".Random.seed", envir = .GlobalEnv) + } +} + +iso_project <- function(xyz, a = 35.264, b = 45) { + a <- a * pi / 180 + b <- b * pi / 180 + T1 <- matrix(c(1, 0, 0, 0, cos(a), sin(a), 0, -sin(a), cos(a)), 3, 3, byrow = TRUE) + T2 <- matrix(c(cos(b), 0, -sin(b), 0, 1, 0, sin(b), 0, cos(b)), 3, 3, byrow = TRUE) + trans <- T1 %*% T2 %*% t(xyz) + coords2D <- matrix(c(1, 0, 0, 0, 1, 0, 0, 0, 0), 3, 3, byrow = TRUE) %*% trans + coords2D <- t(coords2D) + return(coords2D[, 1:2]) +} + +degree_lvl <- function(g) { + if (!"lvl" %in% igraph::vertex_attr_names(g)) { + stop("level information should be stored in a vertex attribute called 'lvl'") + } + A <- igraph::as_adj(g, "both", sparse = FALSE) + lvl_mat <- outer(igraph::V(g)$lvl, igraph::V(g)$lvl, function(x, y) x == y) + cent <- rbind(rowSums(A * lvl_mat), rowSums(A * !lvl_mat)) + rownames(cent) <- c("intra", "inter") + cent +} + +optim_isolates <- function(g, xyz) { + deg <- degree_lvl(g) + idx <- which(deg[1, ] == 0) + if (length(idx) > 0) { + neigh <- igraph::neighborhood(g, order = 1, nodes = idx, mode = "all", mindist = 1) + xyz[idx, c(1, 3)] <- do.call("rbind", lapply(neigh, function(id) cbind(mean(xyz[id, 1]), mean(xyz[id, 3])))) + } + xyz +} + +optim_rotation <- function(g, xyz) { + D <- igraph::distances(g) + W <- 1 / D^2 + smin <- stress3D(xyz, W, D) + # smin <- stress(xyz[,c(1,3)],W,D) + amax <- 0 + idx <- which(igraph::V(g)$lvl == 2) + for (alpha in seq(0, 360, 5)) { + xyz_new <- xyz + xyz_new[idx, c(1, 3)] <- layout_rotate(xyz_new[idx, c(1, 3)], alpha) + stemp <- stress3D(xyz_new, W, D) + # stemp <- stress(xyz_new[,c(1,3)],W,D) + if (stemp < smin) { + amax <- alpha + } + } + xyz[idx, c(1, 3)] <- layout_rotate(xyz[idx, c(1, 3)], amax) + xyz +} + +optim_level <- function(g, lvl, xy) { + A <- igraph::as_adj(g, "both") + Ainter <- A[igraph::V(g)$lvl != lvl, igraph::V(g)$lvl == lvl] + adjList <- apply(Ainter, 1, function(x) which(x == 1)) + + xy2 <- do.call("rbind", lapply(adjList, function(id) cbind(mean(xy[id, 1]), mean(xy[id, 2])))) + idx <- is.na(xy2[, 1]) + + mx <- mean(xy[, 1], na.rm = TRUE) + my <- mean(xy[, 2], na.rm = TRUE) + r <- max(sqrt((xy[, 1] - mx)^2 + (xy[, 2] - my)^2)) + + if (length(idx) > 0) { + xy2[idx, 1] <- stats::runif(n = sum(idx), min = mx - r, max = mx + r) + xy2[idx, 2] <- sample(c(-1, 1), sum(idx), replace = T) * sqrt(r^2 - (xy2[idx, 1] - mx)^2) + my + } + xy2 +} + +adjust_dist <- function(DList) { + n <- nrow(DList[[1]]) + for (i in 1:n) { + for (j in 1:n) { + for (k in seq_along(DList)) { + if (is.infinite(DList[[k]][i, j])) { + lastD <- Inf + for (l in seq((k - 1), 1)) { + if (l == 0) { + next() + } + if (!is.infinite(DList[[l]][i, j])) { + lastD <- DList[[l]][i, j] + tlast <- l + break() + } + } + nextD <- Inf + for (l in seq((k + 1), length(DList))) { + if (l > length(DList)) { + break() + } + if (!is.infinite(DList[[l]][i, j])) { + nextD <- DList[[l]][i, j] + tnext <- l + break() + } + } + if (!is.infinite(lastD) & !is.infinite(nextD)) { + beta <- (k - tlast) / (tnext - tlast) + DList[[k]][i, j] <- (1 - beta) * lastD + beta * nextD + 1 + } else if (is.infinite(lastD) & !is.infinite(nextD)) { + DList[[k]][i, j] <- nextD + 1 + } else if (!is.infinite(lastD) & is.infinite(nextD)) { + DList[[k]][i, j] <- lastD + 1 + } else { + DList[[k]][i, j] <- sqrt(n) + } + } + } + } + } + DList +} From f4ec6513420e378002cc54b2e5d3e97203ab720e Mon Sep 17 00:00:00 2001 From: schochastics Date: Wed, 8 Nov 2023 13:05:41 +0100 Subject: [PATCH 04/16] decomposed adjust_dist --- R/utils.R | 78 +++--- tests/testthat/test-stress_majorization.R | 295 +++++++++++----------- 2 files changed, 194 insertions(+), 179 deletions(-) diff --git a/R/utils.R b/R/utils.R index 8660c64..1bc37a4 100644 --- a/R/utils.R +++ b/R/utils.R @@ -133,44 +133,52 @@ optim_level <- function(g, lvl, xy) { xy2 } +find_lastD <- function(DList, i, j, k) { + for (l in seq((k - 1), 1)) { + if (l == 0) { + next() + } + if (!is.infinite(DList[[l]][i, j])) { + return(list(value = DList[[l]][i, j], index = l)) + } + } + return(list(value = Inf, index = NULL)) +} + +find_nextD <- function(DList, i, j, k) { + for (l in seq((k + 1), length(DList))) { + if (l > length(DList)) { + break() + } + if (!is.infinite(DList[[l]][i, j])) { + return(list(value = DList[[l]][i, j], index = l)) + } + } + return(list(value = Inf, index = NULL)) +} + +adjust_value <- function(lastD, nextD, k, tlast, tnext, n) { + if (!is.infinite(lastD$value) && !is.infinite(nextD$value)) { + beta <- (k - tlast) / (tnext - tlast) + return((1 - beta) * lastD$value + beta * nextD$value + 1) + } else if (is.infinite(lastD$value) && !is.infinite(nextD$value)) { + return(nextD$value + 1) + } else if (!is.infinite(lastD$value) && is.infinite(nextD$value)) { + return(lastD$value + 1) + } else { + return(sqrt(n)) + } +} + adjust_dist <- function(DList) { n <- nrow(DList[[1]]) - for (i in 1:n) { - for (j in 1:n) { - for (k in seq_along(DList)) { + for (k in seq_along(DList)) { + for (i in 1:n) { + for (j in 1:n) { if (is.infinite(DList[[k]][i, j])) { - lastD <- Inf - for (l in seq((k - 1), 1)) { - if (l == 0) { - next() - } - if (!is.infinite(DList[[l]][i, j])) { - lastD <- DList[[l]][i, j] - tlast <- l - break() - } - } - nextD <- Inf - for (l in seq((k + 1), length(DList))) { - if (l > length(DList)) { - break() - } - if (!is.infinite(DList[[l]][i, j])) { - nextD <- DList[[l]][i, j] - tnext <- l - break() - } - } - if (!is.infinite(lastD) & !is.infinite(nextD)) { - beta <- (k - tlast) / (tnext - tlast) - DList[[k]][i, j] <- (1 - beta) * lastD + beta * nextD + 1 - } else if (is.infinite(lastD) & !is.infinite(nextD)) { - DList[[k]][i, j] <- nextD + 1 - } else if (!is.infinite(lastD) & is.infinite(nextD)) { - DList[[k]][i, j] <- lastD + 1 - } else { - DList[[k]][i, j] <- sqrt(n) - } + lastD <- find_lastD(DList, i, j, k) + nextD <- find_nextD(DList, i, j, k) + DList[[k]][i, j] <- adjust_value(lastD, nextD, k, lastD$index, nextD$index, n) } } } diff --git a/tests/testthat/test-stress_majorization.R b/tests/testthat/test-stress_majorization.R index ad40657..cb098b2 100644 --- a/tests/testthat/test-stress_majorization.R +++ b/tests/testthat/test-stress_majorization.R @@ -1,237 +1,244 @@ test_that("it works on directed graph with 2 components, in the presence of weights", { - adj <- matrix(c(0,2,0,0,0, - 0,0,0,0,0, - 0,0,0,3,1, - 0,0,1,0,1, - 0,0,0,0,0), - nrow=5) - g <- igraph::graph_from_adjacency_matrix(adj, weighted = TRUE) - expect_silent( - r <- layout_with_stress(g, weights = igraph::E(g)$weight) - ) - expect_is(r, "matrix") + adj <- matrix( + c( + 0, 2, 0, 0, 0, + 0, 0, 0, 0, 0, + 0, 0, 0, 3, 1, + 0, 0, 1, 0, 1, + 0, 0, 0, 0, 0 + ), + nrow = 5 + ) + g <- igraph::graph_from_adjacency_matrix(adj, weighted = TRUE) + expect_silent( + r <- layout_with_stress(g, weights = igraph::E(g)$weight) + ) + expect_is(r, "matrix") }) test_that("it works on directed connected graph", { - g <- igraph::make_graph( ~ a -+ b +-+ c -+ d:e:f) - expect_silent( - r <- layout_with_stress(g) - ) - expect_is(r, "matrix") + g <- igraph::make_graph(~ a - +b + -+c - +d:e:f) + expect_silent( + r <- layout_with_stress(g) + ) + expect_is(r, "matrix") }) test_that("it works on undirected connected graph", { - g <- igraph::make_graph( ~ a -- b -- c -- d:e:f) - expect_silent( - r <- layout_with_stress(g) - ) - expect_is(r, "matrix") + g <- igraph::make_graph(~ a - -b - -c - -d:e:f) + expect_silent( + r <- layout_with_stress(g) + ) + expect_is(r, "matrix") }) test_that("it works on undirected connected weighted graph", { - g <- igraph::make_graph( ~ a -- b -- c -- d:e:f) - igraph::E(g)$weight <- c(1,2,3,4,5) - expect_silent( - r <- layout_with_stress(g,weights = NULL) - ) - expect_is(r, "matrix") + g <- igraph::make_graph(~ a - -b - -c - -d:e:f) + igraph::E(g)$weight <- c(1, 2, 3, 4, 5) + expect_silent( + r <- layout_with_stress(g, weights = NULL) + ) + expect_is(r, "matrix") }) test_that("it works on an isolates", { - g <- igraph::make_graph( ~ a) - expect_silent( - r <- layout_with_stress(g) - ) - expect_is(r, "matrix") + g <- igraph::make_graph(~a) + expect_silent( + r <- layout_with_stress(g) + ) + expect_is(r, "matrix") }) test_that("it works on a graph of 5 isolates", { - g <- igraph::make_graph( ~ a, b, c, d, e) - expect_silent( - r <- layout_with_stress(g) - ) - expect_is(r, "matrix") + g <- igraph::make_graph(~a, b, c, d, e) + expect_silent( + r <- layout_with_stress(g) + ) + expect_is(r, "matrix") }) test_that("it works on an undirected graph of two connected dyads", { - g <- igraph::make_graph( ~ a -- b, c -- d) - expect_silent( - r <- layout_with_stress(g) - ) - expect_is(r, "matrix") + g <- igraph::make_graph(~ a - -b, c - -d) + expect_silent( + r <- layout_with_stress(g) + ) + expect_is(r, "matrix") }) test_that("it works on an undirected graph of two connected dyads with 5 isolates", { - g <- igraph::make_graph( ~ a -- b, c -- d, e, f, g, h, i) - expect_silent( - r <- layout_with_stress(g) - ) - expect_is(r, "matrix") + g <- igraph::make_graph(~ a - -b, c - -d, e, f, g, h, i) + expect_silent( + r <- layout_with_stress(g) + ) + expect_is(r, "matrix") }) context("Test layout_with_stress3D() on connected graphs") test_that("that works on directed graph with 2 components, in the presence of weights", { - adj <- matrix(c(0,2,0,0,0, - 0,0,0,0,0, - 0,0,0,3,1, - 0,0,1,0,1, - 0,0,0,0,0), - nrow=5) - g <- igraph::graph_from_adjacency_matrix(adj, weighted = TRUE) - expect_silent( - r <- layout_with_stress3D(g, weights = igraph::E(g)$weight) - ) - expect_is(r, "matrix") + adj <- matrix( + c( + 0, 2, 0, 0, 0, + 0, 0, 0, 0, 0, + 0, 0, 0, 3, 1, + 0, 0, 1, 0, 1, + 0, 0, 0, 0, 0 + ), + nrow = 5 + ) + g <- igraph::graph_from_adjacency_matrix(adj, weighted = TRUE) + expect_silent( + r <- layout_with_stress3D(g, weights = igraph::E(g)$weight) + ) + expect_is(r, "matrix") }) test_that("it works on directed connected graph", { - g <- igraph::make_graph( ~ a -+ b +-+ c -+ d:e:f) - expect_silent( - r <- layout_with_stress3D(g) - ) - expect_is(r, "matrix") + g <- igraph::make_graph(~ a - +b + -+c - +d:e:f) + expect_silent( + r <- layout_with_stress3D(g) + ) + expect_is(r, "matrix") }) test_that("it works on undirected connected weighted graph", { - g <- igraph::make_graph( ~ a -- b -- c -- d:e:f) - igraph::E(g)$weight <- c(1,2,3,4,5) - expect_silent( - r <- layout_with_stress3D(g,weights = NULL) - ) - expect_is(r, "matrix") + g <- igraph::make_graph(~ a - -b - -c - -d:e:f) + igraph::E(g)$weight <- c(1, 2, 3, 4, 5) + expect_silent( + r <- layout_with_stress3D(g, weights = NULL) + ) + expect_is(r, "matrix") }) test_that("it works on undirected connected graph", { - g <- igraph::make_graph( ~ a -- b -- c -- d:e:f) - expect_silent( - r <- layout_with_stress3D(g) - ) - expect_is(r, "matrix") + g <- igraph::make_graph(~ a - -b - -c - -d:e:f) + expect_silent( + r <- layout_with_stress3D(g) + ) + expect_is(r, "matrix") }) context("layout_with_stress3D() works on disconnected graphs") test_that("it works on an isolate", { - g <- igraph::make_graph( ~ a) - expect_silent( - r <- layout_with_stress(g) - ) - expect_is(r, "matrix") + g <- igraph::make_graph(~a) + expect_silent( + r <- layout_with_stress(g) + ) + expect_is(r, "matrix") }) test_that("it works on a graph of 5 isolates", { - g <- igraph::make_graph( ~ a, b, c, d, e) - expect_silent( - r <- layout_with_stress3D(g) - ) - expect_is(r, "matrix") + g <- igraph::make_graph(~a, b, c, d, e) + expect_silent( + r <- layout_with_stress3D(g) + ) + expect_is(r, "matrix") }) test_that("it works on an undirected graph of two connected dyads", { - g <- igraph::make_graph( ~ a -- b, c -- d) - expect_silent( - r <- layout_with_stress3D(g) - ) - expect_is(r, "matrix") + g <- igraph::make_graph(~ a - -b, c - -d) + expect_silent( + r <- layout_with_stress3D(g) + ) + expect_is(r, "matrix") }) test_that("it works on an undirected graph of two connected dyads with 5 isolates", { - g <- igraph::make_graph( ~ a -- b, c -- d, e, f, g, h, i) - expect_silent( - r <- layout_with_stress3D(g) - ) - expect_is(r, "matrix") + g <- igraph::make_graph(~ a - -b, c - -d, e, f, g, h, i) + 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",{ - g <- igraph::make_star(5,mode = "undirected",center = 1) - expect_error(layout_with_focus(g)) - expect_silent( - r <- layout_with_focus(g,v = 1)$xy - ) - expect_is(r, "matrix") +test_that("it works on undirected connected graphs", { + g <- igraph::make_star(5, mode = "undirected", center = 1) + expect_error(layout_with_focus(g)) + expect_silent( + r <- layout_with_focus(g, v = 1)$xy + ) + expect_is(r, "matrix") }) -test_that("it fails for disconnected graphs",{ - expect_error(layout_with_focus(igraph::graph.empty(n=10,directed = FALSE))) +test_that("it fails for disconnected graphs", { + expect_error(layout_with_focus(igraph::graph.empty(n = 10, directed = FALSE))) }) context("Test layout_with_centrality() on connected graphs") -test_that("it works on undirected connected graphs",{ - g <- igraph::make_star(5,mode = "undirected",center = 1) - expect_error(layout_with_centrality(g)) - expect_silent( - r <- layout_with_centrality(g,cent = igraph::degree(g)) - ) - expect_is(r, "matrix") +test_that("it works on undirected connected graphs", { + g <- igraph::make_star(5, mode = "undirected", center = 1) + expect_error(layout_with_centrality(g)) + expect_silent( + r <- layout_with_centrality(g, cent = igraph::degree(g)) + ) + expect_is(r, "matrix") }) -test_that("it fails for disconnected graphs",{ - expect_error(layout_with_centrality(igraph::graph.empty(n=10,directed = FALSE))) +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") test_that("it works on undirected connected graph", { - g <- igraph::make_graph( ~ a -- b -- c -- d:e:f) - expect_error(layout_with_constrained_stress(g)) - expect_silent( - r <- layout_with_constrained_stress(g,coord=rep(1,6)) - ) - expect_is(r, "matrix") + g <- igraph::make_graph(~ a - -b - -c - -d:e:f) + expect_error(layout_with_constrained_stress(g)) + expect_silent( + r <- layout_with_constrained_stress(g, coord = rep(1, 6)) + ) + expect_is(r, "matrix") }) context("Test layout_with_constrained_stress3D() on connected graphs") test_that("it works on undirected connected graph", { - g <- igraph::make_graph( ~ a -- b -- c -- d:e:f) - expect_error(layout_with_constrained_stress3D(g)) - expect_silent( - r <- layout_with_constrained_stress3D(g,coord=rep(1,6)) - ) - expect_is(r, "matrix") + g <- igraph::make_graph(~ a - -b - -c - -d:e:f) + expect_error(layout_with_constrained_stress3D(g)) + expect_silent( + r <- layout_with_constrained_stress3D(g, coord = rep(1, 6)) + ) + expect_is(r, "matrix") }) context("Test layout_with_*_grouped()") -test_that("grouped layouts work",{ - g <- igraph::graph.full(10) - grp <- rep(c(1,2),each=5) - expect_is(layout_with_focus_group(g,v=1,grp),"matrix") - - g <- igraph::graph.star(10) - grp <- rep(c(1,2),each = 5) - expect_is(layout_with_centrality_group(g,cent=igraph::degree(g),grp),"matrix") +test_that("grouped layouts work", { + g <- igraph::graph.full(10) + grp <- rep(c(1, 2), each = 5) + expect_is(layout_with_focus_group(g, v = 1, grp), "matrix") + g <- igraph::graph.star(10) + grp <- rep(c(1, 2), each = 5) + expect_is(layout_with_centrality_group(g, cent = igraph::degree(g), grp), "matrix") }) test_that("test errors in stress layouts", { - expect_error(layout_with_stress(5)) - expect_error(layout_with_constrained_stress(5)) - expect_error(layout_with_stress3D(5)) - expect_error(layout_with_focus(5)) + expect_error(layout_with_stress(5)) + expect_error(layout_with_constrained_stress(5)) + expect_error(layout_with_stress3D(5)) + expect_error(layout_with_focus(5)) - expect_error(layout_with_focus(igraph::graph.full(5))) - expect_error(layout_with_centrality(igraph::graph.full(5))) + expect_error(layout_with_focus(igraph::graph.full(5))) + expect_error(layout_with_centrality(igraph::graph.full(5))) - expect_error(layout_with_constrained_stress(igraph::graph.full(5),fixdim = "z")) - expect_error(layout_with_constrained_stress(igraph::graph.full(5),fixdim = "x")) + expect_error(layout_with_constrained_stress(igraph::graph.full(5), fixdim = "z")) + expect_error(layout_with_constrained_stress(igraph::graph.full(5), fixdim = "x")) - expect_error(layout_with_focus_group(igraph::graph.full(5))) - expect_error(layout_with_centrality_group(igraph::graph.full(5))) - expect_error(layout_with_focus_group(igraph::graph.full(5),v=2)) - expect_error(layout_with_centrality_group(igraph::graph.full(5), cent = igraph::degree(g))) + expect_error(layout_with_focus_group(igraph::graph.full(5))) + expect_error(layout_with_centrality_group(igraph::graph.full(5))) + expect_error(layout_with_focus_group(igraph::graph.full(5), v = 2)) + expect_error(layout_with_centrality_group(igraph::graph.full(5), cent = igraph::degree(g))) }) From 3c018f50be27c3e50d8dc3b76a86604aac8a3b73 Mon Sep 17 00:00:00 2001 From: schochastics Date: Wed, 8 Nov 2023 13:15:08 +0100 Subject: [PATCH 05/16] added ensure_igraph --- R/layout_backbone.R | 226 ++++++++++++++++++++-------------------- R/layout_large_graphs.R | 4 +- R/layout_spectral.R | 4 +- R/layout_stress.R | 16 +-- R/layout_umap.R | 24 ++--- R/utils.R | 8 +- 6 files changed, 134 insertions(+), 148 deletions(-) diff --git a/R/layout_backbone.R b/R/layout_backbone.R index 55e937a..bfe4956 100644 --- a/R/layout_backbone.R +++ b/R/layout_backbone.R @@ -25,71 +25,69 @@ #' layout_as_backbone <- function(g, keep = 0.2, backbone = TRUE) { - if (!igraph::is.igraph(g)) { - stop("g is not an igraph object") - } - - if (igraph::ecount(g) == 0) { - stop("graph is empty") - } - - if (!requireNamespace("oaqc", quietly = TRUE)) { - stop("oaqc is needed for this function to work. Please install it.", call. = FALSE) - } - if (igraph::any_multiple(g)) { - stop("backbone layout does not work with multiple edges.") - } - if (igraph::is_directed(g)) { - stop("backbone layout does not work with directed edges.") - } - if (any(igraph::is.loop(g))) { - stop("backbone layout does not work with loops.") - } - - if (any(igraph::components(g)$no > 1)) { - warning("input graph is disconnected. The algorithm works best on connected graphs and may lead to misleading results for graphs with disconnected components. Run the algorithm on each component separately and delete isolated nodes to mitigate this issue.") - } - - # weighting ---- - orbs <- oaqc::oaqc(igraph::get.edgelist(g, names = FALSE) - 1, non_ind_freq = T) - e11 <- orbs$e_orbits_non_ind[, 11] - - qu <- rep(0, igraph::vcount(g)) - el <- igraph::get.edgelist(g, names = FALSE) - el <- cbind(el, e11) - for (e in seq_len(nrow(el))) { - qu[el[e, 1]] <- qu[el[e, 1]] + el[e, 3] - qu[el[e, 2]] <- qu[el[e, 2]] + el[e, 3] - } - w <- apply(el, 1, function(x) x[3] / sqrt(qu[x[1]] * qu[x[2]])) - - w[is.na(w)] <- 0 - w[is.infinite(w)] <- 0 - igraph::E(g)$weight <- w - - # reweighting ----- - w <- max_prexif_jaccard(g) - igraph::E(g)$weight <- w - - # umst ---- - g_umst <- umst(g) - - # filtering ---- - igraph::E(g)$bone <- w >= sort(w, decreasing = TRUE)[ceiling(igraph::ecount(g) * keep)] - g_bone <- igraph::graph_from_edgelist(el[igraph::E(g)$bone, 1:2], directed = F) - g_lay <- igraph::simplify(igraph::graph.union(g_umst, g_bone)) - # if there is an issue with isolates (see #44) - if (igraph::vcount(g_lay) != igraph::vcount(g)) { - n_iso <- igraph::vcount(g) - igraph::vcount(g_lay) - g_lay <- igraph::add_vertices(g_lay, n_iso) - } - if (backbone) { - bb <- backbone_edges(g, g_lay) - } else { - bb <- NULL - } - xy <- layout_with_stress(g_lay) - list(xy = xy, backbone = bb) + ensure_igraph(g) + + if (igraph::ecount(g) == 0) { + stop("graph is empty") + } + + if (!requireNamespace("oaqc", quietly = TRUE)) { + stop("oaqc is needed for this function to work. Please install it.", call. = FALSE) + } + if (igraph::any_multiple(g)) { + stop("backbone layout does not work with multiple edges.") + } + if (igraph::is_directed(g)) { + stop("backbone layout does not work with directed edges.") + } + if (any(igraph::is.loop(g))) { + stop("backbone layout does not work with loops.") + } + + if (any(igraph::components(g)$no > 1)) { + warning("input graph is disconnected. The algorithm works best on connected graphs and may lead to misleading results for graphs with disconnected components. Run the algorithm on each component separately and delete isolated nodes to mitigate this issue.") + } + + # weighting ---- + orbs <- oaqc::oaqc(igraph::get.edgelist(g, names = FALSE) - 1, non_ind_freq = T) + e11 <- orbs$e_orbits_non_ind[, 11] + + qu <- rep(0, igraph::vcount(g)) + el <- igraph::get.edgelist(g, names = FALSE) + el <- cbind(el, e11) + for (e in seq_len(nrow(el))) { + qu[el[e, 1]] <- qu[el[e, 1]] + el[e, 3] + qu[el[e, 2]] <- qu[el[e, 2]] + el[e, 3] + } + w <- apply(el, 1, function(x) x[3] / sqrt(qu[x[1]] * qu[x[2]])) + + w[is.na(w)] <- 0 + w[is.infinite(w)] <- 0 + igraph::E(g)$weight <- w + + # reweighting ----- + w <- max_prexif_jaccard(g) + igraph::E(g)$weight <- w + + # umst ---- + g_umst <- umst(g) + + # filtering ---- + igraph::E(g)$bone <- w >= sort(w, decreasing = TRUE)[ceiling(igraph::ecount(g) * keep)] + g_bone <- igraph::graph_from_edgelist(el[igraph::E(g)$bone, 1:2], directed = F) + g_lay <- igraph::simplify(igraph::graph.union(g_umst, g_bone)) + # if there is an issue with isolates (see #44) + if (igraph::vcount(g_lay) != igraph::vcount(g)) { + n_iso <- igraph::vcount(g) - igraph::vcount(g_lay) + g_lay <- igraph::add_vertices(g_lay, n_iso) + } + if (backbone) { + bb <- backbone_edges(g, g_lay) + } else { + bb <- NULL + } + xy <- layout_with_stress(g_lay) + list(xy = xy, backbone = bb) } #------------------------------------------------------------------------------- @@ -97,64 +95,64 @@ layout_as_backbone <- function(g, keep = 0.2, backbone = TRUE) { #------------------------------------------------------------------------------- umst <- function(g) { - el <- igraph::get.edgelist(g, names = FALSE) - el <- cbind(el, igraph::E(g)$weight) - el <- el[order(el[, 3], decreasing = TRUE), ] - el <- cbind(el, rank(-el[, 3])) - vfind <- 1:igraph::vcount(g) - el_un <- matrix(0, 0, 2) - for (i in unique(el[, 4])) { - el_tmp <- matrix(0, 0, 2) - Bi <- which(el[, 4] == i) - for (e in Bi) { - u <- el[e, 1] - v <- el[e, 2] - if (vfind[u] != vfind[v]) { - el_tmp <- rbind(el_tmp, c(u, v)) - } + el <- igraph::get.edgelist(g, names = FALSE) + el <- cbind(el, igraph::E(g)$weight) + el <- el[order(el[, 3], decreasing = TRUE), ] + el <- cbind(el, rank(-el[, 3])) + vfind <- 1:igraph::vcount(g) + el_un <- matrix(0, 0, 2) + for (i in unique(el[, 4])) { + el_tmp <- matrix(0, 0, 2) + Bi <- which(el[, 4] == i) + for (e in Bi) { + u <- el[e, 1] + v <- el[e, 2] + if (vfind[u] != vfind[v]) { + el_tmp <- rbind(el_tmp, c(u, v)) + } + } + if (nrow(el_tmp) == 0) { + next() + } + for (eb in seq_len(nrow(el_tmp))) { + u <- el_tmp[eb, 1] + v <- el_tmp[eb, 2] + partu <- vfind[u] + partv <- vfind[v] + vfind[v] <- partu + if (any(vfind == partv)) { + vfind[vfind == partv] <- partu + } + } + el_un <- rbind(el_un, el_tmp) } - if (nrow(el_tmp) == 0) { - next() - } - for (eb in seq_len(nrow(el_tmp))) { - u <- el_tmp[eb, 1] - v <- el_tmp[eb, 2] - partu <- vfind[u] - partv <- vfind[v] - vfind[v] <- partu - if (any(vfind == partv)) { - vfind[vfind == partv] <- partu - } - } - el_un <- rbind(el_un, el_tmp) - } - return(igraph::simplify(igraph::graph_from_edgelist(el_un, directed = FALSE))) + return(igraph::simplify(igraph::graph_from_edgelist(el_un, directed = FALSE))) } backbone_edges <- function(g, g_lay) { - tmp <- rbind(igraph::get.edgelist(g_lay), igraph::get.edgelist(g, names = FALSE)) - which(duplicated(tmp)) - igraph::ecount(g_lay) + tmp <- rbind(igraph::get.edgelist(g_lay), igraph::get.edgelist(g, names = FALSE)) + which(duplicated(tmp)) - igraph::ecount(g_lay) } max_prexif_jaccard <- function(g) { - if ("name" %in% igraph::vertex_attr_names(g)) { - g <- igraph::delete_vertex_attr(g, "name") - } - el_tbl <- igraph::as_data_frame(g, "edges") - - N_ranks <- lapply(1:igraph::vcount(g), get_rank, el_tbl = el_tbl) - el <- igraph::get.edgelist(g, names = FALSE) - new_w <- reweighting(el - 1, N_ranks) - new_w + if ("name" %in% igraph::vertex_attr_names(g)) { + g <- igraph::delete_vertex_attr(g, "name") + } + el_tbl <- igraph::as_data_frame(g, "edges") + + N_ranks <- lapply(1:igraph::vcount(g), get_rank, el_tbl = el_tbl) + el <- igraph::get.edgelist(g, names = FALSE) + new_w <- reweighting(el - 1, N_ranks) + new_w } get_rank <- function(el_tbl, u) { - Nu_idx <- el_tbl[["from"]] == u | el_tbl[["to"]] == u - omega <- el_tbl[Nu_idx, "weight"] - Nu <- setdiff(c(el_tbl[Nu_idx, "from"], el_tbl[Nu_idx, "to"]), u) - r <- rank(-omega) - r <- match(r, sort(unique(r))) - 1 - Nru <- cbind(Nu - 1, r) - Nru[order(Nru[, 2]), , drop = FALSE] + Nu_idx <- el_tbl[["from"]] == u | el_tbl[["to"]] == u + omega <- el_tbl[Nu_idx, "weight"] + Nu <- setdiff(c(el_tbl[Nu_idx, "from"], el_tbl[Nu_idx, "to"]), u) + r <- rank(-omega) + r <- match(r, sort(unique(r))) - 1 + Nru <- cbind(Nu - 1, r) + Nru[order(Nru[, 2]), , drop = FALSE] } diff --git a/R/layout_large_graphs.R b/R/layout_large_graphs.R index 9ade1d0..8cbc545 100644 --- a/R/layout_large_graphs.R +++ b/R/layout_large_graphs.R @@ -81,9 +81,7 @@ layout_with_pmds <- function(g, pivots, weights = NA, D = NULL, dim = 2) { #' @export layout_with_sparse_stress <- function(g, pivots, weights = NA, iter = 500) { - if (!igraph::is_igraph(g)) { - stop("not a graph object") - } + ensure_igraph(g) if (!igraph::is_connected(g, mode = "weak")) { stop("only connected graphs are supported.") } diff --git a/R/layout_spectral.R b/R/layout_spectral.R index 079f2d1..539160b 100644 --- a/R/layout_spectral.R +++ b/R/layout_spectral.R @@ -23,9 +23,7 @@ #' @export layout_with_eigen <- function(g, type = "laplacian", ev = "smallest") { - if (!igraph::is_igraph(g)) { - stop("g must be an igraph object") - } + ensure_igraph(g) if (!igraph::is_connected(g)) { stop("g must be connected") } diff --git a/R/layout_stress.R b/R/layout_stress.R index 72f7590..cec6a53 100644 --- a/R/layout_stress.R +++ b/R/layout_stress.R @@ -210,9 +210,7 @@ layout_with_stress3D <- function(g, weights = NA, iter = 500, tol = 0.0001, mds #' @export layout_with_focus <- function(g, v, weights = NA, iter = 500, tol = 0.0001) { - if (!igraph::is.igraph(g)) { - stop("g must be an igraph object") - } + ensure_igraph(g) if (missing(v)) { stop('argument "v" is missing with no default.') } @@ -284,9 +282,7 @@ layout_with_focus <- function(g, v, weights = NA, iter = 500, tol = 0.0001) { #' @export #' layout_with_centrality <- function(g, cent, scale = TRUE, iter = 500, tol = 0.0001, tseq = seq(0, 1, 0.2)) { - if (!igraph::is.igraph(g)) { - stop("g must be an igraph object") - } + ensure_igraph(g) comps <- igraph::components(g, "weak") if (comps$no > 1) { stop("g must be connected") @@ -487,9 +483,7 @@ layout_with_constrained_stress3D <- function(g, coord, fixdim = "x", weights = N #' layout_with_focus_group(g, v = 1, group = grp, shrink = 10) #' @export layout_with_focus_group <- function(g, v, group, shrink = 10, weights = NA, iter = 500, tol = 0.0001) { - if (!igraph::is.igraph(g)) { - stop("g must be an igraph object") - } + ensure_igraph(g) if (missing(v)) { stop('argument "v" is missing with no default.') } @@ -530,9 +524,7 @@ layout_with_focus_group <- function(g, v, group, shrink = 10, weights = NA, iter #' library(igraph) #' @export layout_with_centrality_group <- function(g, cent, group, shrink = 10, ...) { - if (!igraph::is.igraph(g)) { - stop("g must be an igraph object") - } + ensure_igraph(g) comps <- igraph::components(g, "weak") if (comps$no > 1) { stop("g must be connected") diff --git a/R/layout_umap.R b/R/layout_umap.R index 03d9659..eb33454 100644 --- a/R/layout_umap.R +++ b/R/layout_umap.R @@ -17,17 +17,15 @@ #' @export layout_with_umap <- function(g, pivots = NULL, ...) { - if (!requireNamespace("uwot", quietly = TRUE)) { - stop("uwot is needed for this function to work. Please install it.", call. = FALSE) - } - if (!igraph::is_igraph(g)) { - stop("Not a graph object") - } - if (is.null(pivots)) { - D <- igraph::distances(g) - } else { - pivs <- sample(1:igraph::vcount(g), pivots) - D <- t(igraph::distances(g, v = pivs)) - } - uwot::umap(D, ...) + if (!requireNamespace("uwot", quietly = TRUE)) { + stop("uwot is needed for this function to work. Please install it.", call. = FALSE) + } + ensure_igraph(g) + if (is.null(pivots)) { + D <- igraph::distances(g) + } else { + pivs <- sample(1:igraph::vcount(g), pivots) + D <- t(igraph::distances(g, v = pivs)) + } + uwot::umap(D, ...) } diff --git a/R/utils.R b/R/utils.R index 1bc37a4..f52daae 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,6 +1,8 @@ -#-------------------------------------------------------------------------------# -# helper functions ---- -#-------------------------------------------------------------------------------# +ensure_igraph <- function(g) { + if (!igraph::is_igraph(g)) { + stop("g must be an igraph object") + } +} get_bbox <- function(xy) { lbottom <- c(min(xy[, 1]), min(xy[, 2])) From 702eedf803adbf5fb3d3a56102edffeb1c4557d5 Mon Sep 17 00:00:00 2001 From: schochastics Date: Wed, 8 Nov 2023 14:01:34 +0100 Subject: [PATCH 06/16] added init_layout function --- R/layout_stress.R | 138 ++++++++++++++++++---------------------------- R/utils.R | 6 ++ 2 files changed, 59 insertions(+), 85 deletions(-) diff --git a/R/layout_stress.R b/R/layout_stress.R index cec6a53..61195a4 100644 --- a/R/layout_stress.R +++ b/R/layout_stress.R @@ -1,3 +1,16 @@ +.init_layout <- function(g, D, mds, n, dim) { + if (!mds) { + return(matrix(stats::runif(n * dim, 0, 1), n, dim)) + } else { + rmat <- matrix(stats::runif(n * dim, -0.1, 0.1), n, dim) + if (n <= 100) { + return(igraph::layout_with_mds(g, dim = dim) + rmat) + } else { + return(layout_with_pmds(g, D = D[, sample(1:n, 100)], dim = dim) + rmat) + } + } +} + .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") @@ -12,7 +25,31 @@ on.exit(restore_seed(oldseed)) comps <- igraph::components(g, "weak") - if (comps$no > 1) { + if (comps$no == 1) { + n <- igraph::vcount(g) + + if (n == 1) { + x <- 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) + } else { + if (!is.null(weights) && any(!is.na(weights))) { + D <- igraph::distances(g, weights = weights) + } else { + D <- igraph::distances(g) + } + W <- 1 / D^2 + diag(W) <- 0 + + xinit <- .init_layout(g, D, mds, n, dim) + + if (dim == 2) { + return(stress_major(xinit, W, D, iter, tol)) + } else { + return(stress_major3D(xinit, W, D, iter, tol)) + } + } + } else { lg <- list() node_order <- c() if (!is.null(weights) && any(!is.na(weights))) { @@ -44,16 +81,7 @@ W <- 1 / D^2 diag(W) <- 0 - if (!mds) { - xinit <- matrix(stats::runif(n * dim, 0, 1), n, dim) - } else { - rmat <- matrix(stats::runif(n * dim, -0.1, 0.1), n, dim) - if (n <= 100) { - xinit <- igraph::layout_with_mds(sg, dim = dim) + rmat - } else { - xinit <- layout_with_pmds(sg, D = D[, sample(1:n, 100)], dim = dim) + rmat - } - } + xinit <- .init_layout(sg, D, mds, n, dim) if (dim == 2) { lg[[i]] <- stress_major(xinit, W, D, iter, tol) @@ -79,43 +107,8 @@ } x <- do.call("rbind", lg) x <- x[node_order, , drop = FALSE] - } else { - n <- igraph::vcount(g) - - if (n == 1) { - x <- 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) - } else { - if (!is.null(weights) && any(!is.na(weights))) { - D <- igraph::distances(g, weights = weights) - } else { - D <- igraph::distances(g) - } - W <- 1 / D^2 - diag(W) <- 0 - - if (!mds) { - xinit <- matrix(stats::runif(n * dim, 0, 1), n, dim) - } else { - rmat <- matrix(stats::runif(n * dim, -0.1, 0.1), n, dim) - if (n <= 100) { - xinit <- igraph::layout_with_mds(g, dim = dim) + rmat - } else { - xinit <- layout_with_pmds(g, D = D[, sample(1:n, 100)], dim = dim) + rmat - } - } - - if (dim == 2) { - x <- stress_major(xinit, W, D, iter, tol) - } else { - x <- stress_major3D(xinit, W, D, iter, tol) - } - } - } + return(x) } - return(x) } @@ -211,12 +204,9 @@ layout_with_stress3D <- function(g, weights = NA, iter = 500, tol = 0.0001, mds layout_with_focus <- function(g, v, weights = NA, iter = 500, tol = 0.0001) { ensure_igraph(g) + ensure_connected(g) if (missing(v)) { - stop('argument "v" is missing with no default.') - } - comps <- igraph::components(g, "weak") - if (comps$no > 1) { - stop("g must be a connected graph.") + stop("v missing without a default") } oldseed <- get_seed() set.seed(42) # stress is deterministic and produces same result up to translation. This keeps the layout fixed @@ -283,12 +273,9 @@ layout_with_focus <- function(g, v, weights = NA, iter = 500, tol = 0.0001) { #' layout_with_centrality <- function(g, cent, scale = TRUE, iter = 500, tol = 0.0001, tseq = seq(0, 1, 0.2)) { ensure_igraph(g) - comps <- igraph::components(g, "weak") - if (comps$no > 1) { - stop("g must be connected") - } + ensure_connected(g) if (missing(cent)) { - stop('argument "cent" is missing with no default.') + stop("cent missing without a default") } oldseed <- get_seed() set.seed(42) # stress is deterministic and produces same result up to translation. This keeps the layout fixed @@ -351,9 +338,8 @@ 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) { - if (!igraph::is_igraph(g)) { - stop("Not a graph object") - } + ensure_connected(g) + oldseed <- get_seed() set.seed(42) # stress is deterministic and produces same result up to translation. This keeps the layout fixed on.exit(restore_seed(oldseed)) @@ -415,23 +401,16 @@ layout_with_constrained_stress <- function(g, coord, fixdim = "x", weights = NA, #' @export layout_with_constrained_stress3D <- function(g, coord, fixdim = "x", weights = NA, iter = 500, tol = 0.0001, mds = TRUE, bbox = 30) { - if (!igraph::is_igraph(g)) { - stop("Not a graph object") - } + ensure_igraph(g) + ensure_connected(g) + oldseed <- get_seed() set.seed(42) on.exit(restore_seed(oldseed)) + fixdim <- match.arg(fixdim, c("x", "y", "z")) fixdim <- ifelse(fixdim == "x", 1, ifelse(fixdim == "y", 2, 3)) - if (missing(coord)) { - 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, 0), 1, 3) } else { @@ -484,16 +463,8 @@ layout_with_constrained_stress3D <- function(g, coord, fixdim = "x", weights = N #' @export layout_with_focus_group <- function(g, v, group, shrink = 10, weights = NA, iter = 500, tol = 0.0001) { ensure_igraph(g) - if (missing(v)) { - stop('argument "v" is missing with no default.') - } - if (missing(group)) { - stop('argument "group" is missing with no default.') - } - comps <- igraph::components(g, "weak") - if (comps$no > 1) { - stop("g must be a connected graph.") - } + ensure_connected(g) + n_grp <- length(unique(group)) xy <- layout_with_focus(g, v)$xy ints <- seq(0, 360, length.out = n_grp + 1) @@ -525,10 +496,7 @@ layout_with_focus_group <- function(g, v, group, shrink = 10, weights = NA, iter #' @export layout_with_centrality_group <- function(g, cent, group, shrink = 10, ...) { ensure_igraph(g) - comps <- igraph::components(g, "weak") - if (comps$no > 1) { - stop("g must be connected") - } + ensure_connected(g) if (missing(group)) { stop('argument "group" is missing with no default.') } diff --git a/R/utils.R b/R/utils.R index f52daae..1b49a1e 100644 --- a/R/utils.R +++ b/R/utils.R @@ -4,6 +4,12 @@ ensure_igraph <- function(g) { } } +ensure_connected <- function(g) { + if (!igraph::is_connected(g, mode = "weak")) { + stop("only connected graphs are supported.") + } +} + get_bbox <- function(xy) { lbottom <- c(min(xy[, 1]), min(xy[, 2])) rtop <- c(max(xy[, 1]), max(xy[, 2])) From 42db9dee27c09167f66ca1257614b11f720e26d6 Mon Sep 17 00:00:00 2001 From: schochastics Date: Wed, 8 Nov 2023 21:26:18 +0100 Subject: [PATCH 07/16] expanded .component_layouts --- R/layout_stress.R | 183 ++++++++++++---------- R/utils.R | 4 +- tests/testthat/test-layout_backbone.R | 16 +- tests/testthat/test-stress_majorization.R | 27 +++- 4 files changed, 132 insertions(+), 98 deletions(-) diff --git a/R/layout_stress.R b/R/layout_stress.R index 61195a4..b86f574 100644 --- a/R/layout_stress.R +++ b/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 diff --git a/R/utils.R b/R/utils.R index 1b49a1e..7ace280 100644 --- a/R/utils.R +++ b/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) } } diff --git a/tests/testthat/test-layout_backbone.R b/tests/testthat/test-layout_backbone.R index dfb1b59..4619bf2 100644 --- a/tests/testthat/test-layout_backbone.R +++ b/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))) }) diff --git a/tests/testthat/test-stress_majorization.R b/tests/testthat/test-stress_majorization.R index cb098b2..6c9315f 100644 --- a/tests/testthat/test-stress_majorization.R +++ b/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", { From 10f072575c073c897b6b5da4d394a80fc62884e1 Mon Sep 17 00:00:00 2001 From: schochastics Date: Wed, 8 Nov 2023 21:43:02 +0100 Subject: [PATCH 08/16] fixed failing test --- R/layout_stress.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/layout_stress.R b/R/layout_stress.R index b86f574..a1a2f70 100644 --- a/R/layout_stress.R +++ b/R/layout_stress.R @@ -31,12 +31,12 @@ .component_layouter <- function(g, weights, comps, dim, mds, bbox, iter, tol, FUN, ...) { # check which ... are arguments of FUN FUN <- match.fun(FUN) - params <- list(...) + params_in <- list(...) FUN_formals <- formals(FUN) - idx <- names(params) %in% names(FUN_formals) - params <- params[idx] + idx <- names(params_in) %in% names(FUN_formals) + params <- params_in[idx] if ("dim" %in% names(FUN_formals)) { - params <- c(params, list(dim = fixdim)) + params <- c(params, list(dim = params_in[["fixdim"]])) } lg <- list() @@ -69,7 +69,7 @@ xinit <- .init_layout(sg, D, mds, n, dim) if ("dim" %in% names(params)) { - xinit[, params[["dim"]]] <- coord[idx] + xinit[, params[["dim"]]] <- params_in[["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) From eb9b6cd98d1537c1c110cbc0d4dc41d1f7819978 Mon Sep 17 00:00:00 2001 From: schochastics Date: Wed, 8 Nov 2023 22:12:11 +0100 Subject: [PATCH 09/16] large_graph refactor --- NEWS.md | 4 +++ R/layout_large_graphs.R | 31 ++++++++++--------- R/layout_stress.R | 37 +++++++++-------------- tests/testthat/test-layout_large_graphs.R | 36 +++++++++++----------- tests/testthat/test-stress_majorization.R | 10 ++++++ 5 files changed, 63 insertions(+), 55 deletions(-) diff --git a/NEWS.md b/NEWS.md index 89b16eb..0536860 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,9 @@ # graphlayouts 1.0.2.9000 +* `layout_with_constrained_stress()` and `layout_with_constrained_stress3D()` + work for disconnected graphs +* internal code refactoring + # graphlayouts 1.0.2 * fixed bug with weighted disconnected graphs (#71) h/t @gi0na diff --git a/R/layout_large_graphs.R b/R/layout_large_graphs.R index 8cbc545..c420e99 100644 --- a/R/layout_large_graphs.R +++ b/R/layout_large_graphs.R @@ -25,12 +25,9 @@ #' } #' @export layout_with_pmds <- function(g, pivots, weights = NA, D = NULL, dim = 2) { - if (!igraph::is_igraph(g)) { - stop("Not a graph object") - } - if (!igraph::is_connected(g, mode = "weak")) { - stop("only connected graphs are supported.") - } + ensure_igraph(g) + ensure_connected(g) + if (missing(pivots) && is.null(D)) { stop('argument "pivots" is missing, with no default.') } @@ -82,18 +79,27 @@ layout_with_pmds <- function(g, pivots, weights = NA, D = NULL, dim = 2) { layout_with_sparse_stress <- function(g, pivots, weights = NA, iter = 500) { ensure_igraph(g) - if (!igraph::is_connected(g, mode = "weak")) { - stop("only connected graphs are supported.") - } + ensure_connected(g) if (!all(is.na(weights))) { warning("weights are not supported. unweighted graph is used instead.") } - if (is.null(pivots)) { + if (missing(pivots)) { stop('argument "pivots" is missing, with no default.') } if (pivots > igraph::vcount(g)) { stop('"pivots" must be less than the number of nodes in the graph.') } + comps <- igraph::components(g) + if (comps$no == 1) { + prep <- .sparse_prepare(g, pivots) + A <- igraph::get.adjacency(g, type = "both", sparse = TRUE) + return(sparseStress(prep$y, prep$D, prep$RpL, prep$pivs, A, iter)) + } else { + # TBD + } +} + +.sparse_prepare <- function(g, pivots) { pivs <- sample(1:igraph::vcount(g), pivots) D <- t(igraph::distances(g, v = pivs, weights = NA)) @@ -108,8 +114,5 @@ layout_with_sparse_stress <- function(g, pivots, weights = NA, iter = 500) { RpL <- lapply(seq_along(pivs), function(x) which(Rp == x) - 1) pivs <- pivs - 1 - - A <- igraph::get.adjacency(g, type = "both", sparse = TRUE) - xy <- sparseStress(y, D, RpL, pivs, A, iter) - xy + list(RpL = RpL, pivs = pivs, y = y, D = D) } diff --git a/R/layout_stress.R b/R/layout_stress.R index a1a2f70..7881101 100644 --- a/R/layout_stress.R +++ b/R/layout_stress.R @@ -411,7 +411,6 @@ layout_with_constrained_stress <- function(g, coord, fixdim = "x", weights = NA, layout_with_constrained_stress3D <- function(g, coord, fixdim = "x", weights = NA, iter = 500, tol = 0.0001, mds = TRUE, bbox = 30) { ensure_igraph(g) - ensure_connected(g) oldseed <- get_seed() set.seed(42) @@ -420,33 +419,25 @@ layout_with_constrained_stress3D <- function(g, coord, fixdim = "x", weights = N fixdim <- match.arg(fixdim, c("x", "y", "z")) fixdim <- ifelse(fixdim == "x", 1, ifelse(fixdim == "y", 2, 3)) - if (igraph::vcount(g) == 1) { - x <- matrix(c(0, 0, 0), 1, 3) - } 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 * 3, 0, 1), n, 3) - xinit[, fixdim] <- coord + comps <- igraph::components(g, "weak") + if (comps$no == 1) { + if (igraph::vcount(g) == 1) { + return(matrix(c(0, 0, 0), 1, 3)) } else { + D <- igraph::distances(g, weights = weights) + W <- 1 / D^2 + diag(W) <- 0 n <- igraph::vcount(g) - pivs <- sample(1:n, min(c(50, n))) - D1 <- D[, pivs] - cmean <- colMeans(D1^2) - rmean <- rowMeans(D1^2) - Dmat <- D1^2 - outer(rmean, cmean, function(x, y) x + y) + mean(D1^2) - sl2 <- svd(Dmat) - rmat <- matrix(stats::runif(n * 3, -0.1, 0.1), n, 3) - xinit <- (Dmat %*% sl2$v[, 1:3]) + rmat - row.names(xinit) <- NULL - + xinit <- .init_layout(g, D, mds, n, dim = 3) xinit[, fixdim] <- coord + return(constrained_stress_major3D(xinit, fixdim, W, D, iter, tol)) } - x <- constrained_stress_major3D(xinit, fixdim, W, D, iter, tol) + } else { + return(.component_layouter( + g = g, weights = weights, comps = comps, dim = 3, mds = mds, + bbox = bbox, iter = iter, tol = tol, FUN = constrained_stress_major3D, fixdim = fixdim, coord = coord + )) } - x } #' radial focus group layout #' diff --git a/tests/testthat/test-layout_large_graphs.R b/tests/testthat/test-layout_large_graphs.R index 8d9d6a6..aa962c2 100644 --- a/tests/testthat/test-layout_large_graphs.R +++ b/tests/testthat/test-layout_large_graphs.R @@ -1,25 +1,25 @@ test_that("layout_with_pmds works", { - g <- igraph::make_graph( ~ a -- b -- c -- d:e:f) - expect_is(layout_with_pmds(g,5),"matrix") - expect_equal(ncol(layout_with_pmds(g,5,dim = 3)),3) - expect_error(layout_with_pmds(g)) - expect_error(layout_with_pmds(g,10)) - expect_error(layout_with_pmds(1)) - expect_no_error(layout_with_pmds(g,pivots = 5,weights = rep(4,5))) + g <- igraph::make_graph(~ a - -b - -c - -d:e:f) + expect_is(layout_with_pmds(g, 5), "matrix") + expect_equal(ncol(layout_with_pmds(g, 5, dim = 3)), 3) + expect_error(layout_with_pmds(g)) + expect_error(layout_with_pmds(g, 10)) + expect_error(layout_with_pmds(1)) + expect_no_error(layout_with_pmds(g, pivots = 5, weights = rep(4, 5))) - g <- igraph::graph.full(10) + igraph::graph.full(10) - expect_error(layout_with_pmds(g,10)) + g <- igraph::graph.full(10) + igraph::graph.full(10) + expect_error(layout_with_pmds(g, 10)) }) test_that("layout_with_sparse_stress works", { - g <- igraph::make_graph( ~ a -- b -- c -- d:e:f) - expect_is(layout_with_sparse_stress(g,5),"matrix") - expect_error(layout_with_sparse_stress(g)) - expect_error(layout_with_sparse_stress(g,10)) - expect_error(layout_with_sparse_stress(1)) + g <- igraph::make_graph(~ a - -b - -c - -d:e:f) + expect_is(layout_with_sparse_stress(g, 5), "matrix") + expect_error(layout_with_sparse_stress(g)) + expect_error(layout_with_sparse_stress(g, 10)) + expect_error(layout_with_sparse_stress(1)) - g <- igraph::graph.full(10) + igraph::graph.full(10) - expect_error(layout_with_sparse_stress(g,10)) - g <- igraph::graph.full(10) - expect_warning(layout_with_sparse_stress(g,pivots = 5,weights = rep(4,45))) + g <- igraph::graph.full(10) + igraph::graph.full(10) + expect_error(layout_with_sparse_stress(g, 10)) + g <- igraph::graph.full(10) + expect_warning(layout_with_sparse_stress(g, pivots = 5, weights = rep(4, 45))) }) diff --git a/tests/testthat/test-stress_majorization.R b/tests/testthat/test-stress_majorization.R index 6c9315f..4091959 100644 --- a/tests/testthat/test-stress_majorization.R +++ b/tests/testthat/test-stress_majorization.R @@ -239,6 +239,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_stress3D(g, coord = fix) + ) + expect_is(r, "matrix") + expect_true(all(r[, 1] == fix)) +}) + context("Test layout_with_*_grouped()") test_that("grouped layouts work", { g <- igraph::graph.full(10) From 36dc0b930bfcc23215c47b919c3043449e1995fc Mon Sep 17 00:00:00 2001 From: schochastics Date: Thu, 9 Nov 2023 06:45:47 +0100 Subject: [PATCH 10/16] doc update --- R/layout_umap.R | 2 +- man/layout_multilevel.Rd | 8 ++++---- man/layout_pmds.Rd | 4 ++-- man/layout_sparse_stress.Rd | 10 +++++----- man/layout_umap.Rd | 2 +- 5 files changed, 13 insertions(+), 13 deletions(-) diff --git a/R/layout_umap.R b/R/layout_umap.R index eb33454..275edd8 100644 --- a/R/layout_umap.R +++ b/R/layout_umap.R @@ -13,7 +13,7 @@ #' library(igraph) #' #' g <- sample_islands(10, 20, 0.6, 10) -#' xy <- layout_with_umap(g, min_dist = 0.5) +#' # xy <- layout_with_umap(g, min_dist = 0.5) #' @export layout_with_umap <- function(g, pivots = NULL, ...) { diff --git a/man/layout_multilevel.Rd b/man/layout_multilevel.Rd index bc6e4a9..7b48c3c 100644 --- a/man/layout_multilevel.Rd +++ b/man/layout_multilevel.Rd @@ -88,10 +88,10 @@ xy <- layout_as_multilevel(multilvl_ex, type = "all", alpha = 25, beta = 45) # compute a layout for each level separately and combine them xy <- layout_as_multilevel(multilvl_ex, - type = "separate", - FUN1 = layout_as_backbone, - FUN2 = layout_with_stress, - alpha = 25, beta = 45 + type = "separate", + FUN1 = layout_as_backbone, + FUN2 = layout_with_stress, + alpha = 25, beta = 45 ) } diff --git a/man/layout_pmds.Rd b/man/layout_pmds.Rd index 6caf38e..227f778 100644 --- a/man/layout_pmds.Rd +++ b/man/layout_pmds.Rd @@ -40,9 +40,9 @@ The layout_igraph_* function should not be used directly. It is only used as an library(igraph) library(ggraph) -g <- sample_gnp(1000,0.01) +g <- sample_gnp(1000, 0.01) -xy <- layout_with_pmds(g,pivots = 100) +xy <- layout_with_pmds(g, pivots = 100) } } \references{ diff --git a/man/layout_sparse_stress.Rd b/man/layout_sparse_stress.Rd index 75994e9..2e78626 100644 --- a/man/layout_sparse_stress.Rd +++ b/man/layout_sparse_stress.Rd @@ -36,12 +36,12 @@ The layout_igraph_* function should not be used directly. It is only used as an library(igraph) library(ggraph) -g <- sample_gnp(1000,0.005) +g <- sample_gnp(1000, 0.005) -ggraph(g,layout = "sparse_stress",pivots = 100)+ - geom_edge_link0(edge_colour = "grey66")+ - geom_node_point(shape = 21,fill = "grey25",size = 5)+ - theme_graph() +ggraph(g, layout = "sparse_stress", pivots = 100) + + geom_edge_link0(edge_colour = "grey66") + + geom_node_point(shape = 21, fill = "grey25", size = 5) + + theme_graph() } } \references{ diff --git a/man/layout_umap.Rd b/man/layout_umap.Rd index ef04f61..1d66861 100644 --- a/man/layout_umap.Rd +++ b/man/layout_umap.Rd @@ -32,7 +32,7 @@ The layout_igraph_* function should not be used directly. It is only used as an library(igraph) g <- sample_islands(10, 20, 0.6, 10) -xy <- layout_with_umap(g, min_dist = 0.5) +# xy <- layout_with_umap(g, min_dist = 0.5) } \references{ McInnes, Leland, John Healy, and James Melville. "Umap: Uniform manifold approximation and projection for dimension reduction." arXiv preprint arXiv:1802.03426 (2018). From 7e225a0f3053d210c014b05b33e18d61f1456c1c Mon Sep 17 00:00:00 2001 From: schochastics Date: Thu, 9 Nov 2023 06:50:34 +0100 Subject: [PATCH 11/16] render readme [no ci] --- README.md | 34 ++++++++++++++++------------------ 1 file changed, 16 insertions(+), 18 deletions(-) diff --git a/README.md b/README.md index f9556e4..f9710b0 100644 --- a/README.md +++ b/README.md @@ -22,22 +22,22 @@ found [here](https://www.mr.schochastics.net/material/netVizR/).** The package implements the following algorithms: -- Stress majorization - ([Paper](https://graphviz.gitlab.io/_pages/Documentation/GKN04.pdf)) -- Quadrilateral backbone layout - ([Paper](https://jgaa.info/accepted/2015/NocajOrtmannBrandes2015.19.2.pdf)) -- flexible radial layouts - ([Paper](https://jgaa.info/accepted/2011/BrandesPich2011.15.1.pdf)) -- sparse stress ([Paper](https://arxiv.org/abs/1608.08909)) -- pivot MDS - ([Paper](https://kops.uni-konstanz.de/bitstream/handle/123456789/5741/bp_empmdsld_06.pdf?sequence=1&isAllowed=y)) -- dynamic layout for longitudinal data - ([Paper](https://kops.uni-konstanz.de/bitstream/handle/123456789/20924/Brandes_209246.pdf?sequence=2)) -- spectral layouts (adjacency/Laplacian) -- a simple multilevel layout -- a layout algorithm using UMAP -- group based centrality and focus layouts which keeps groups of nodes - close in the same range on the concentric circle +- Stress majorization + ([Paper](https://graphviz.gitlab.io/_pages/Documentation/GKN04.pdf)) +- Quadrilateral backbone layout + ([Paper](https://jgaa.info/accepted/2015/NocajOrtmannBrandes2015.19.2.pdf)) +- flexible radial layouts + ([Paper](https://jgaa.info/accepted/2011/BrandesPich2011.15.1.pdf)) +- sparse stress ([Paper](https://arxiv.org/abs/1608.08909)) +- pivot MDS + ([Paper](https://kops.uni-konstanz.de/bitstream/handle/123456789/5741/bp_empmdsld_06.pdf?sequence=1&isAllowed=y)) +- dynamic layout for longitudinal data + ([Paper](https://kops.uni-konstanz.de/bitstream/handle/123456789/20924/Brandes_209246.pdf?sequence=2)) +- spectral layouts (adjacency/Laplacian) +- a simple multilevel layout +- a layout algorithm using UMAP +- group based centrality and focus layouts which keeps groups of nodes + close in the same range on the concentric circle ## Install @@ -71,7 +71,6 @@ ggraph(pa,layout = "nicely")+ ``` r - ggraph(pa,layout="stress")+ geom_edge_link0(width=0.2,colour="grey")+ geom_node_point(col="black",size=0.3)+ @@ -107,7 +106,6 @@ ggraph(g,layout = "nicely") + ``` r - ggraph(g, layout = "stress",bbox = 40) + geom_edge_link0() + geom_node_point() + From 27c5767ba8e54a47e997385832e28520fc3817eb Mon Sep 17 00:00:00 2001 From: schochastics Date: Thu, 9 Nov 2023 06:56:31 +0100 Subject: [PATCH 12/16] fixed formatting --- README.Rmd | 230 ++++++++++++++++++++++++++--------------------------- README.md | 212 ++++++++++++++++++++++++------------------------ 2 files changed, 222 insertions(+), 220 deletions(-) diff --git a/README.Rmd b/README.Rmd index a6f9275..fa949d0 100644 --- a/README.Rmd +++ b/README.Rmd @@ -6,14 +6,14 @@ output: github_document ```{r, echo = FALSE} knitr::opts_chunk$set( - collapse = TRUE, - fig.align = 'center', - out.width = '80%', - comment = "#>", - fig.path = "man/figures/README-", - echo = TRUE, - warning = FALSE, - message = FALSE + collapse = TRUE, + fig.align = "center", + out.width = "80%", + comment = "#>", + fig.path = "man/figures/README-", + echo = TRUE, + warning = FALSE, + message = FALSE ) ``` @@ -51,7 +51,7 @@ The package implements the following algorithms: # dev version remotes::install_github("schochastics/graphlayouts") -#CRAN +# CRAN install.packages("graphlayouts") ``` @@ -60,22 +60,22 @@ install.packages("graphlayouts") *This example is a bit of a special case since it exploits some weird issues in igraph.* ```{r example} -library(igraph) -library(ggraph) +library(igraph) +library(ggraph) library(graphlayouts) set.seed(666) -pa <- sample_pa(1000,1,1,directed = F) +pa <- sample_pa(1000, 1, 1, directed = F) -ggraph(pa,layout = "nicely")+ - geom_edge_link0(width=0.2,colour="grey")+ - geom_node_point(col="black",size=0.3)+ - theme_graph() +ggraph(pa, layout = "nicely") + + geom_edge_link0(width = 0.2, colour = "grey") + + geom_node_point(col = "black", size = 0.3) + + theme_graph() -ggraph(pa,layout="stress")+ - geom_edge_link0(width=0.2,colour="grey")+ - geom_node_point(col="black",size=0.3)+ - theme_graph() +ggraph(pa, layout = "stress") + + geom_edge_link0(width = 0.2, colour = "grey") + + geom_node_point(col = "black", size = 0.3) + + theme_graph() ``` ## Stress Majorization: Unconnected Network @@ -86,24 +86,24 @@ on a bin packing algorithm to efficiently put the components in a rectangle, rat ```{r example_un} set.seed(666) g <- disjoint_union( - sample_pa(10,directed = F), - sample_pa(20,directed = F), - sample_pa(30,directed = F), - sample_pa(40,directed = F), - sample_pa(50,directed = F), - sample_pa(60,directed = F), - sample_pa(80,directed = F) + sample_pa(10, directed = FALSE), + sample_pa(20, directed = FALSE), + sample_pa(30, directed = FALSE), + sample_pa(40, directed = FALSE), + sample_pa(50, directed = FALSE), + sample_pa(60, directed = FALSE), + sample_pa(80, directed = FALSE) ) -ggraph(g,layout = "nicely") + - geom_edge_link0() + - geom_node_point() + - theme_graph() +ggraph(g, layout = "nicely") + + geom_edge_link0() + + geom_node_point() + + theme_graph() -ggraph(g, layout = "stress",bbox = 40) + - geom_edge_link0() + - geom_node_point() + - theme_graph() +ggraph(g, layout = "stress", bbox = 40) + + geom_edge_link0() + + geom_node_point() + + theme_graph() ``` ## Backbone Layout @@ -112,18 +112,17 @@ Backbone layouts are helpful for drawing hairballs. ```{r hairball,eval = FALSE} set.seed(665) -#create network with a group structure -g <- sample_islands(9,40,0.4,15) +# create network with a group structure +g <- sample_islands(9, 40, 0.4, 15) g <- simplify(g) -V(g)$grp <- as.character(rep(1:9,each=40)) - -ggraph(g,layout = "stress")+ - geom_edge_link0(colour=rgb(0,0,0,0.5),width=0.1)+ - geom_node_point(aes(col=grp))+ - scale_color_brewer(palette = "Set1")+ - theme_graph()+ - theme(legend.position = "none") - +V(g)$grp <- as.character(rep(1:9, each = 40)) + +ggraph(g, layout = "stress") + + geom_edge_link0(colour = rgb(0, 0, 0, 0.5), width = 0.1) + + geom_node_point(aes(col = grp)) + + scale_color_brewer(palette = "Set1") + + theme_graph() + + theme(legend.position = "none") ``` @@ -138,18 +137,17 @@ install.packages("oaqc") ```{r backbone,eval=FALSE} -bb <- layout_as_backbone(g,keep=0.4) +bb <- layout_as_backbone(g, keep = 0.4) E(g)$col <- F E(g)$col[bb$backbone] <- T -ggraph(g,layout="manual",x=bb$xy[,1],y=bb$xy[,2])+ - geom_edge_link0(aes(col=col),width=0.1)+ - geom_node_point(aes(col=grp))+ - scale_color_brewer(palette = "Set1")+ - scale_edge_color_manual(values=c(rgb(0,0,0,0.3),rgb(0,0,0,1)))+ - theme_graph()+ - theme(legend.position = "none") - +ggraph(g, layout = "manual", x = bb$xy[, 1], y = bb$xy[, 2]) + + geom_edge_link0(aes(col = col), width = 0.1) + + geom_node_point(aes(col = grp)) + + scale_color_brewer(palette = "Set1") + + scale_edge_color_manual(values = c(rgb(0, 0, 0, 0.3), rgb(0, 0, 0, 1))) + + theme_graph() + + theme(legend.position = "none") ``` @@ -164,27 +162,27 @@ library(igraphdata) library(patchwork) data("karate") -p1 <- ggraph(karate,layout = "focus",focus = 1) + - draw_circle(use = "focus",max.circle = 3)+ - geom_edge_link0(edge_color="black",edge_width=0.3)+ - geom_node_point(aes(fill=as.factor(Faction)),size=2,shape=21)+ - scale_fill_manual(values=c("#8B2323", "#EEAD0E"))+ - theme_graph()+ - theme(legend.position = "none")+ - coord_fixed()+ - labs(title= "Focus on Mr. Hi") - -p2 <- ggraph(karate,layout = "focus",focus = 34) + - draw_circle(use = "focus",max.circle = 4)+ - geom_edge_link0(edge_color="black",edge_width=0.3)+ - geom_node_point(aes(fill=as.factor(Faction)),size=2,shape=21)+ - scale_fill_manual(values=c("#8B2323", "#EEAD0E"))+ - theme_graph()+ - theme(legend.position = "none")+ - coord_fixed()+ - labs(title= "Focus on John A.") - -p1+p2 +p1 <- ggraph(karate, layout = "focus", focus = 1) + + draw_circle(use = "focus", max.circle = 3) + + geom_edge_link0(edge_color = "black", edge_width = 0.3) + + geom_node_point(aes(fill = as.factor(Faction)), size = 2, shape = 21) + + scale_fill_manual(values = c("#8B2323", "#EEAD0E")) + + theme_graph() + + theme(legend.position = "none") + + coord_fixed() + + labs(title = "Focus on Mr. Hi") + +p2 <- ggraph(karate, layout = "focus", focus = 34) + + draw_circle(use = "focus", max.circle = 4) + + geom_edge_link0(edge_color = "black", edge_width = 0.3) + + geom_node_point(aes(fill = as.factor(Faction)), size = 2, shape = 21) + + scale_fill_manual(values = c("#8B2323", "#EEAD0E")) + + theme_graph() + + theme(legend.position = "none") + + coord_fixed() + + labs(title = "Focus on John A.") + +p1 + p2 ``` @@ -200,31 +198,31 @@ library(patchwork) data("karate") bc <- betweenness(karate) -p1 <- ggraph(karate,layout = "centrality", centrality = bc, tseq = seq(0,1,0.15)) + - draw_circle(use = "cent") + - annotate_circle(bc,format="",pos="bottom") + - geom_edge_link0(edge_color="black",edge_width=0.3)+ - geom_node_point(aes(fill=as.factor(Faction)),size=2,shape=21)+ - scale_fill_manual(values=c("#8B2323", "#EEAD0E"))+ - theme_graph()+ - theme(legend.position = "none")+ - coord_fixed()+ - labs(title="betweenness centrality") +p1 <- ggraph(karate, layout = "centrality", centrality = bc, tseq = seq(0, 1, 0.15)) + + draw_circle(use = "cent") + + annotate_circle(bc, format = "", pos = "bottom") + + geom_edge_link0(edge_color = "black", edge_width = 0.3) + + geom_node_point(aes(fill = as.factor(Faction)), size = 2, shape = 21) + + scale_fill_manual(values = c("#8B2323", "#EEAD0E")) + + theme_graph() + + theme(legend.position = "none") + + coord_fixed() + + labs(title = "betweenness centrality") cc <- closeness(karate) -p2 <- ggraph(karate,layout = "centrality", centrality = cc, tseq = seq(0,1,0.2)) + - draw_circle(use = "cent") + - annotate_circle(cc,format="scientific",pos="bottom") + - geom_edge_link0(edge_color="black",edge_width=0.3)+ - geom_node_point(aes(fill=as.factor(Faction)),size=2,shape=21)+ - scale_fill_manual(values=c("#8B2323", "#EEAD0E"))+ - theme_graph()+ - theme(legend.position = "none")+ - coord_fixed()+ - labs(title="closeness centrality") - -p1+p2 +p2 <- ggraph(karate, layout = "centrality", centrality = cc, tseq = seq(0, 1, 0.2)) + + draw_circle(use = "cent") + + annotate_circle(cc, format = "scientific", pos = "bottom") + + geom_edge_link0(edge_color = "black", edge_width = 0.3) + + geom_node_point(aes(fill = as.factor(Faction)), size = 2, shape = 21) + + scale_fill_manual(values = c("#8B2323", "#EEAD0E")) + + theme_graph() + + theme(legend.position = "none") + + coord_fixed() + + labs(title = "closeness centrality") + +p1 + p2 ``` ## Large graphs @@ -256,26 +254,28 @@ In this way, it is easy to track down specific nodes throughout time. Use `patch individual plots next to each other. ```{r dynamic,eval = FALSE} -#remotes::install_github("schochastics/networkdata") +# remotes::install_github("schochastics/networkdata") library(networkdata) -#longitudinal dataset of friendships in a school class +# longitudinal dataset of friendships in a school class data("s50") -xy <- layout_as_dynamic(s50,alpha = 0.2) -pList <- vector("list",length(s50)) - -for(i in seq_along(s50)){ - pList[[i]] <- ggraph(s50[[i]],layout="manual",x=xy[[i]][,1],y=xy[[i]][,2])+ - geom_edge_link0(edge_width=0.6,edge_colour="grey66")+ - geom_node_point(shape=21,aes(fill=as.factor(smoke)),size=3)+ - geom_node_text(aes(label=1:50),repel = T)+ - scale_fill_manual(values=c("forestgreen","grey25","firebrick"), - labels=c("no","occasional","regular"), - name = "smoking", - guide=ifelse(i!=2,"none","legend"))+ - theme_graph()+ - theme(legend.position="bottom")+ - labs(title=paste0("Wave ",i)) +xy <- layout_as_dynamic(s50, alpha = 0.2) +pList <- vector("list", length(s50)) + +for (i in seq_along(s50)) { + pList[[i]] <- ggraph(s50[[i]], layout = "manual", x = xy[[i]][, 1], y = xy[[i]][, 2]) + + geom_edge_link0(edge_width = 0.6, edge_colour = "grey66") + + geom_node_point(shape = 21, aes(fill = as.factor(smoke)), size = 3) + + geom_node_text(aes(label = 1:50), repel = T) + + scale_fill_manual( + values = c("forestgreen", "grey25", "firebrick"), + labels = c("no", "occasional", "regular"), + name = "smoking", + guide = ifelse(i != 2, "none", "legend") + ) + + theme_graph() + + theme(legend.position = "bottom") + + labs(title = paste0("Wave ", i)) } wrap_plots(pList) ``` diff --git a/README.md b/README.md index f9710b0..ad2eaef 100644 --- a/README.md +++ b/README.md @@ -45,7 +45,7 @@ The package implements the following algorithms: # dev version remotes::install_github("schochastics/graphlayouts") -#CRAN +# CRAN install.packages("graphlayouts") ``` @@ -55,26 +55,26 @@ install.packages("graphlayouts") issues in igraph.* ``` r -library(igraph) -library(ggraph) +library(igraph) +library(ggraph) library(graphlayouts) set.seed(666) -pa <- sample_pa(1000,1,1,directed = F) +pa <- sample_pa(1000, 1, 1, directed = F) -ggraph(pa,layout = "nicely")+ - geom_edge_link0(width=0.2,colour="grey")+ - geom_node_point(col="black",size=0.3)+ - theme_graph() +ggraph(pa, layout = "nicely") + + geom_edge_link0(width = 0.2, colour = "grey") + + geom_node_point(col = "black", size = 0.3) + + theme_graph() ``` ``` r -ggraph(pa,layout="stress")+ - geom_edge_link0(width=0.2,colour="grey")+ - geom_node_point(col="black",size=0.3)+ - theme_graph() +ggraph(pa, layout = "stress") + + geom_edge_link0(width = 0.2, colour = "grey") + + geom_node_point(col = "black", size = 0.3) + + theme_graph() ``` @@ -88,28 +88,28 @@ rectangle, rather than a circle. ``` r set.seed(666) g <- disjoint_union( - sample_pa(10,directed = F), - sample_pa(20,directed = F), - sample_pa(30,directed = F), - sample_pa(40,directed = F), - sample_pa(50,directed = F), - sample_pa(60,directed = F), - sample_pa(80,directed = F) + sample_pa(10, directed = FALSE), + sample_pa(20, directed = FALSE), + sample_pa(30, directed = FALSE), + sample_pa(40, directed = FALSE), + sample_pa(50, directed = FALSE), + sample_pa(60, directed = FALSE), + sample_pa(80, directed = FALSE) ) -ggraph(g,layout = "nicely") + - geom_edge_link0() + - geom_node_point() + - theme_graph() +ggraph(g, layout = "nicely") + + geom_edge_link0() + + geom_node_point() + + theme_graph() ``` ``` r -ggraph(g, layout = "stress",bbox = 40) + - geom_edge_link0() + - geom_node_point() + - theme_graph() +ggraph(g, layout = "stress", bbox = 40) + + geom_edge_link0() + + geom_node_point() + + theme_graph() ``` @@ -120,17 +120,17 @@ Backbone layouts are helpful for drawing hairballs. ``` r set.seed(665) -#create network with a group structure -g <- sample_islands(9,40,0.4,15) +# create network with a group structure +g <- sample_islands(9, 40, 0.4, 15) g <- simplify(g) -V(g)$grp <- as.character(rep(1:9,each=40)) - -ggraph(g,layout = "stress")+ - geom_edge_link0(colour=rgb(0,0,0,0.5),width=0.1)+ - geom_node_point(aes(col=grp))+ - scale_color_brewer(palette = "Set1")+ - theme_graph()+ - theme(legend.position = "none") +V(g)$grp <- as.character(rep(1:9, each = 40)) + +ggraph(g, layout = "stress") + + geom_edge_link0(colour = rgb(0, 0, 0, 0.5), width = 0.1) + + geom_node_point(aes(col = grp)) + + scale_color_brewer(palette = "Set1") + + theme_graph() + + theme(legend.position = "none") ``` @@ -146,17 +146,17 @@ install.packages("oaqc") ``` ``` r -bb <- layout_as_backbone(g,keep=0.4) +bb <- layout_as_backbone(g, keep = 0.4) E(g)$col <- F E(g)$col[bb$backbone] <- T -ggraph(g,layout="manual",x=bb$xy[,1],y=bb$xy[,2])+ - geom_edge_link0(aes(col=col),width=0.1)+ - geom_node_point(aes(col=grp))+ - scale_color_brewer(palette = "Set1")+ - scale_edge_color_manual(values=c(rgb(0,0,0,0.3),rgb(0,0,0,1)))+ - theme_graph()+ - theme(legend.position = "none") +ggraph(g, layout = "manual", x = bb$xy[, 1], y = bb$xy[, 2]) + + geom_edge_link0(aes(col = col), width = 0.1) + + geom_node_point(aes(col = grp)) + + scale_color_brewer(palette = "Set1") + + scale_edge_color_manual(values = c(rgb(0, 0, 0, 0.3), rgb(0, 0, 0, 1))) + + theme_graph() + + theme(legend.position = "none") ``` @@ -172,27 +172,27 @@ library(igraphdata) library(patchwork) data("karate") -p1 <- ggraph(karate,layout = "focus",focus = 1) + - draw_circle(use = "focus",max.circle = 3)+ - geom_edge_link0(edge_color="black",edge_width=0.3)+ - geom_node_point(aes(fill=as.factor(Faction)),size=2,shape=21)+ - scale_fill_manual(values=c("#8B2323", "#EEAD0E"))+ - theme_graph()+ - theme(legend.position = "none")+ - coord_fixed()+ - labs(title= "Focus on Mr. Hi") - -p2 <- ggraph(karate,layout = "focus",focus = 34) + - draw_circle(use = "focus",max.circle = 4)+ - geom_edge_link0(edge_color="black",edge_width=0.3)+ - geom_node_point(aes(fill=as.factor(Faction)),size=2,shape=21)+ - scale_fill_manual(values=c("#8B2323", "#EEAD0E"))+ - theme_graph()+ - theme(legend.position = "none")+ - coord_fixed()+ - labs(title= "Focus on John A.") - -p1+p2 +p1 <- ggraph(karate, layout = "focus", focus = 1) + + draw_circle(use = "focus", max.circle = 3) + + geom_edge_link0(edge_color = "black", edge_width = 0.3) + + geom_node_point(aes(fill = as.factor(Faction)), size = 2, shape = 21) + + scale_fill_manual(values = c("#8B2323", "#EEAD0E")) + + theme_graph() + + theme(legend.position = "none") + + coord_fixed() + + labs(title = "Focus on Mr. Hi") + +p2 <- ggraph(karate, layout = "focus", focus = 34) + + draw_circle(use = "focus", max.circle = 4) + + geom_edge_link0(edge_color = "black", edge_width = 0.3) + + geom_node_point(aes(fill = as.factor(Faction)), size = 2, shape = 21) + + scale_fill_manual(values = c("#8B2323", "#EEAD0E")) + + theme_graph() + + theme(legend.position = "none") + + coord_fixed() + + labs(title = "Focus on John A.") + +p1 + p2 ``` @@ -209,31 +209,31 @@ library(patchwork) data("karate") bc <- betweenness(karate) -p1 <- ggraph(karate,layout = "centrality", centrality = bc, tseq = seq(0,1,0.15)) + - draw_circle(use = "cent") + - annotate_circle(bc,format="",pos="bottom") + - geom_edge_link0(edge_color="black",edge_width=0.3)+ - geom_node_point(aes(fill=as.factor(Faction)),size=2,shape=21)+ - scale_fill_manual(values=c("#8B2323", "#EEAD0E"))+ - theme_graph()+ - theme(legend.position = "none")+ - coord_fixed()+ - labs(title="betweenness centrality") +p1 <- ggraph(karate, layout = "centrality", centrality = bc, tseq = seq(0, 1, 0.15)) + + draw_circle(use = "cent") + + annotate_circle(bc, format = "", pos = "bottom") + + geom_edge_link0(edge_color = "black", edge_width = 0.3) + + geom_node_point(aes(fill = as.factor(Faction)), size = 2, shape = 21) + + scale_fill_manual(values = c("#8B2323", "#EEAD0E")) + + theme_graph() + + theme(legend.position = "none") + + coord_fixed() + + labs(title = "betweenness centrality") cc <- closeness(karate) -p2 <- ggraph(karate,layout = "centrality", centrality = cc, tseq = seq(0,1,0.2)) + - draw_circle(use = "cent") + - annotate_circle(cc,format="scientific",pos="bottom") + - geom_edge_link0(edge_color="black",edge_width=0.3)+ - geom_node_point(aes(fill=as.factor(Faction)),size=2,shape=21)+ - scale_fill_manual(values=c("#8B2323", "#EEAD0E"))+ - theme_graph()+ - theme(legend.position = "none")+ - coord_fixed()+ - labs(title="closeness centrality") - -p1+p2 +p2 <- ggraph(karate, layout = "centrality", centrality = cc, tseq = seq(0, 1, 0.2)) + + draw_circle(use = "cent") + + annotate_circle(cc, format = "scientific", pos = "bottom") + + geom_edge_link0(edge_color = "black", edge_width = 0.3) + + geom_node_point(aes(fill = as.factor(Faction)), size = 2, shape = 21) + + scale_fill_manual(values = c("#8B2323", "#EEAD0E")) + + theme_graph() + + theme(legend.position = "none") + + coord_fixed() + + labs(title = "closeness centrality") + +p1 + p2 ``` @@ -273,26 +273,28 @@ is easy to track down specific nodes throughout time. Use `patchwork` to put the individual plots next to each other. ``` r -#remotes::install_github("schochastics/networkdata") +# remotes::install_github("schochastics/networkdata") library(networkdata) -#longitudinal dataset of friendships in a school class +# longitudinal dataset of friendships in a school class data("s50") -xy <- layout_as_dynamic(s50,alpha = 0.2) -pList <- vector("list",length(s50)) - -for(i in seq_along(s50)){ - pList[[i]] <- ggraph(s50[[i]],layout="manual",x=xy[[i]][,1],y=xy[[i]][,2])+ - geom_edge_link0(edge_width=0.6,edge_colour="grey66")+ - geom_node_point(shape=21,aes(fill=as.factor(smoke)),size=3)+ - geom_node_text(aes(label=1:50),repel = T)+ - scale_fill_manual(values=c("forestgreen","grey25","firebrick"), - labels=c("no","occasional","regular"), - name = "smoking", - guide=ifelse(i!=2,"none","legend"))+ - theme_graph()+ - theme(legend.position="bottom")+ - labs(title=paste0("Wave ",i)) +xy <- layout_as_dynamic(s50, alpha = 0.2) +pList <- vector("list", length(s50)) + +for (i in seq_along(s50)) { + pList[[i]] <- ggraph(s50[[i]], layout = "manual", x = xy[[i]][, 1], y = xy[[i]][, 2]) + + geom_edge_link0(edge_width = 0.6, edge_colour = "grey66") + + geom_node_point(shape = 21, aes(fill = as.factor(smoke)), size = 3) + + geom_node_text(aes(label = 1:50), repel = T) + + scale_fill_manual( + values = c("forestgreen", "grey25", "firebrick"), + labels = c("no", "occasional", "regular"), + name = "smoking", + guide = ifelse(i != 2, "none", "legend") + ) + + theme_graph() + + theme(legend.position = "bottom") + + labs(title = paste0("Wave ", i)) } wrap_plots(pList) ``` From 8fa002deaf2e222dee06c256ca0273c15e49fa7d Mon Sep 17 00:00:00 2001 From: schochastics Date: Thu, 9 Nov 2023 07:01:42 +0100 Subject: [PATCH 13/16] early return --- R/layout_stress.R | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/R/layout_stress.R b/R/layout_stress.R index 7881101..3bbb72a 100644 --- a/R/layout_stress.R +++ b/R/layout_stress.R @@ -322,13 +322,12 @@ layout_with_centrality <- function(g, cent, scale = TRUE, iter = 500, tol = 0.00 if (scale) { radii_new <- round(100 - cent, 8) angles <- apply(x, 1, function(y) atan2(y[2], y[1])) - x <- cbind(radii_new * cos(angles), radii_new * sin(angles)) + return(cbind(radii_new * cos(angles), radii_new * sin(angles))) } else { radii_new <- round(max(cent) - cent, 8) angles <- apply(x, 1, function(y) atan2(y[2], y[1])) - x <- cbind(radii_new * cos(angles), radii_new * sin(angles)) + return(cbind(radii_new * cos(angles), radii_new * sin(angles))) } - x } #------------------------------------------------------------------------------# From 387c921f3edfec22f95f762cc77c55c65eef7396 Mon Sep 17 00:00:00 2001 From: schochastics Date: Thu, 9 Nov 2023 07:14:49 +0100 Subject: [PATCH 14/16] update news [no ci] --- NEWS.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NEWS.md b/NEWS.md index 0536860..a6dc94c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,8 @@ * `layout_with_constrained_stress()` and `layout_with_constrained_stress3D()` work for disconnected graphs +* `layout_with_constrained_stress()` and `layout_with_constrained_stress3D()` + work with disconnected graphs * internal code refactoring # graphlayouts 1.0.2 From 9797ef2d4d53c802b11a6e31ae8ba402338bbb57 Mon Sep 17 00:00:00 2001 From: schochastics Date: Thu, 9 Nov 2023 07:16:28 +0100 Subject: [PATCH 15/16] revert wrong changes [no ci] --- NEWS.md | 2 -- 1 file changed, 2 deletions(-) diff --git a/NEWS.md b/NEWS.md index a6dc94c..0536860 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,8 +2,6 @@ * `layout_with_constrained_stress()` and `layout_with_constrained_stress3D()` work for disconnected graphs -* `layout_with_constrained_stress()` and `layout_with_constrained_stress3D()` - work with disconnected graphs * internal code refactoring # graphlayouts 1.0.2 From 9c2d41f6639cc476e6209a6fae6ed9adf6535424 Mon Sep 17 00:00:00 2001 From: schochastics Date: Thu, 9 Nov 2023 09:57:22 +0100 Subject: [PATCH 16/16] did revdep check [no ci] --- .gitignore | 3 ++- cran-comments.md | 9 +++++---- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/.gitignore b/.gitignore index 9f636bb..3572033 100644 --- a/.gitignore +++ b/.gitignore @@ -3,4 +3,5 @@ inst/doc .Rhistory .RData docs -CRAN-SUBMISSION \ No newline at end of file +CRAN-SUBMISSION +revdep/ \ No newline at end of file diff --git a/cran-comments.md b/cran-comments.md index 51f8f5e..e20c429 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -1,10 +1,11 @@ -# Update from 1.0.1 to 1.0.2 +## Update from 1.0.2 to 1.1.0 -minor bug fixes +## revdepcheck results -## Downstream dependencies +We checked 6 reverse dependencies (1 from CRAN + 5 from Bioconductor), comparing R CMD check results across CRAN and dev versions of this package. -All dependencies passed R CMD check + * We saw 0 new problems + * We failed to check 0 packages ## Test environments * ubuntu 22.04, R 4.3.1