├── .Rbuildignore ├── .gitignore ├── .travis.yml ├── DESCRIPTION ├── NAMESPACE ├── R ├── bmgraph.R ├── bzrc.R ├── ccbnd.R ├── ccgraph.R ├── conc.R ├── frcd.R ├── hc.R ├── lz.R ├── mbnd.R ├── mlgraph.R ├── multigraph.R ├── nrm.R ├── popl.R ├── rng.R ├── sts.R ├── stsm.R ├── xyrt.R └── xyrtb.R ├── README.md ├── figs ├── floflies-bmgraph.pdf ├── floflies-bmgraph.png ├── floflies-force.pdf ├── floflies-force.png ├── floflies-force2.pdf ├── floflies-force2.png ├── floflies.pdf ├── floflies.png ├── flofliesatt-force.pdf ├── flofliesatt-force.png ├── flofliesatt-force2.pdf ├── flofliesatt-force2.png ├── shipwrecks-animation.gif ├── swomen-force.pdf ├── swomen-force.png ├── swomen.pdf ├── swomen.png ├── swomen2.pdf ├── swomen2.png ├── swomen3.pdf ├── swomen3.png ├── swomenc.pdf └── swomenc.png ├── inst └── CITATION └── man ├── bmgraph.Rd ├── bzrc.Rd ├── ccbnd.Rd ├── ccgraph.Rd ├── conc.Rd ├── frcd.Rd ├── hc.Rd ├── lz.Rd ├── mbnd.Rd ├── mlgraph.Rd ├── multigraph-package.Rd ├── multigraph.Rd ├── nrm.Rd ├── popl.Rd ├── rng.Rd ├── sts.Rd ├── stsm.Rd ├── xyrt.Rd └── xyrtb.Rd /.Rbuildignore: -------------------------------------------------------------------------------- 1 | figs 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | .Rproj.user 3 | .Rhistory 4 | .RData 5 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: r 2 | cache: packages 3 | 4 | # Do not be strict when checking our package 5 | warnings_are_errors: false 6 | 7 | # r_check_args: --as-cran --run-donttest 8 | 9 | notifications: 10 | email: false 11 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: multigraph 2 | Type: Package 3 | Title: Plot and Manipulate Multigraphs 4 | Version: 0.99-4 5 | Depends: R (>= 3.6.0), multiplex (>= 3.0.0) 6 | Imports: methods 7 | Date: 2024-05-14 8 | Authors@R: person(given = "Antonio", family = "Rivero Ostoic", role = c("aut", "cre"), email = "multiplex@post.com") 9 | Author: Antonio Rivero Ostoic [aut, cre] 10 | Maintainer: Antonio Rivero Ostoic 11 | Description: Functions to plot and manipulate multigraphs, signed and valued graphs, bipartite graphs, multilevel graphs, and Cayley graphs with various layout options. 12 | URL: https://github.com/mplex/multigraph/ 13 | BugReports: https://github.com/mplex/multigraph/issues/ 14 | Repository: CRAN 15 | License: GPL-3 16 | NeedsCompilation: no 17 | Packaged: 2024-05-14 13:48:57 UTC; aost 18 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | exportPattern("^[[:alpha:]]+") 2 | import(multiplex) 3 | importFrom("graphics", "par") 4 | -------------------------------------------------------------------------------- /R/bzrc.R: -------------------------------------------------------------------------------- 1 | bzrc <- 2 | function (pair, cex, elv = 0.25, lng, ...) 3 | { 4 | ifelse(missing(cex) == TRUE, cex <- 1L, NA) 5 | ifelse(missing(lng) == TRUE, lng <- 50, NA) 6 | ifelse(isTRUE(lng <= 2) == TRUE, lng <- 3L, NA) 7 | if (isTRUE(max(round(pair[, 1], 3)) < 0.5) == TRUE) { 8 | p <- rbind(pair[1, ], c(elv * -1, mean(c(pair[1, 2], 9 | pair[2, 2]))), pair[2, ]) 10 | } 11 | else { 12 | p <- rbind(pair[1, ], c(1L + elv, mean(c(pair[1, 2], 13 | pair[2, 2]))), pair[2, ]) 14 | } 15 | attr(p, "dimnames")[[2]] <- NULL 16 | d <- (cex/100) 17 | if (isTRUE(as.numeric(p[1, 2] - p[3, 2]) > d) == TRUE) { 18 | d <- d * (0.1/as.numeric(p[1, 2] - p[3, 2])) 19 | } 20 | else { 21 | NA 22 | } 23 | sqq <- seq(0, 1, length = lng) - d 24 | sq <- sqq[which(sqq > d)] 25 | deg <- nrow(p) - 1 26 | num_s <- (nrow(p) - 1)/deg 27 | if (isTRUE(num_s - floor(num_s) > 0) == TRUE) 28 | stop("Number of rows in parameter matrix do not match input degree.") 29 | b <- matrix(0, nrow = length(sq), ncol = ncol(p)) 30 | seg <- matrix(1, nrow = num_s, ncol = 2) 31 | for (i in 1:num_s) seg[i, ] <- c((i - 1) * deg + 1, (i - 32 | 1) * deg + 1 + deg) 33 | for (j in 1:length(sq)) { 34 | if (sq[j] == 0) { 35 | s <- 1 36 | } 37 | else { 38 | s <- ceiling(sq[j]) 39 | } 40 | if (s > num_s) 41 | s <- num_s 42 | p_sub <- matrix(p[seg[s, 1]:seg[s, 2], ], nrow = deg + 43 | 1, ncol = ncol(p)) 44 | b[j, ] <- colSums(choose(deg, 0:deg) * ((1 - (sq[j] - 45 | s + 1))^(deg - 0:deg)) * (sq[j] - s + 1)^(0:deg) * 46 | p_sub) 47 | } 48 | rm(j) 49 | graphics::lines(b[, 1], b[, 2], ...) 50 | graphics::par(new = FALSE) 51 | } 52 | -------------------------------------------------------------------------------- /R/ccbnd.R: -------------------------------------------------------------------------------- 1 | ccbnd <- 2 | function (pares, r, b, vlt, cx, lwd, ecol, bw, alfa, fds, flgcx, 3 | flgcr, hds, n) 4 | { 5 | ifelse(isTRUE(nrow(pares) > 2L) == TRUE, pares <- pares[c(1, 6 | nrow(pares)), ], NA) 7 | ifelse(isTRUE(ncol(pares) > 2L) == TRUE, pares <- pares[, 8 | 1:2], NA) 9 | angp <- atan2((pares[2, 2] - pares[1, 2]), (pares[2, 1] - 10 | pares[1, 1])) * (180L/pi) 11 | if (isTRUE(pares[1, 1] != 0L | pares[1, 2] != 0L) == TRUE) { 12 | xo <- 0L - pares[1, 1] 13 | yo <- 0L - pares[1, 2] 14 | orig <- pares 15 | orig[, 1] <- pares[, 1] + xo 16 | orig[, 2] <- pares[, 2] + yo 17 | orot <- xyrtb(orig, (0L - angp)) 18 | } 19 | else if (isTRUE(pares[1, 1] != 0L | pares[1, 2] != 0L) == 20 | FALSE) { 21 | orot <- xyrtb(pares, (0L - angp)) 22 | } 23 | angx <- abs(angp) 24 | if (isTRUE(angx >= 360L) == TRUE) { 25 | agx <- angx%%360L 26 | } 27 | else { 28 | if (isTRUE(angx >= 270L) == TRUE) { 29 | gx <- abs(90L + (angx%%270L)) 30 | } 31 | else if (isTRUE(angx > 180L) == TRUE) { 32 | ifelse(isTRUE(angx > 180L) == TRUE, lx <- abs(180L - 33 | (angx%%180L)), lx <- angx%%180L) 34 | gx <- abs(90L - (lx%%90L)) 35 | } 36 | else { 37 | ifelse(isTRUE(angx > 180L) == TRUE, gx <- abs(180L - 38 | (x%%180L)), gx <- angx%%180L) 39 | } 40 | ifelse(isTRUE(gx >= 90L) == TRUE, agx <- abs(90L - (gx%%90L)), 41 | agx <- gx%%90L) 42 | } 43 | if (isTRUE(mean(lwd) < 6L) == TRUE) { 44 | fds <- fds - (mean(lwd) * 4) 45 | } 46 | else if (isTRUE(mean(lwd) > 15L) == TRUE) { 47 | fds <- fds - (mean(lwd) * 2) 48 | } 49 | else { 50 | fds <- fds - (mean(lwd) * 2.5) 51 | } 52 | d <- (rng(r) * ((bw * 1000L) * ((2L^(abs(sin(angp * (pi/180L)))))/1200L)) * 53 | (mean(cx)/2L)) * ((30L + (agx * (6L/45L) * -1L))/100L) 54 | orott <- orot 55 | if (isTRUE(flgcx == TRUE) == TRUE) { 56 | orott[1, 1] <- (cx[1]/(fds - 0)) - orot[1, 1] 57 | orott[2, 1] <- orot[2, 1] - (cx[2]/(fds)) 58 | } 59 | else if (isTRUE(flgcx == FALSE) == TRUE) { 60 | ifelse(isTRUE(mean(lwd) > 2L) == TRUE, lc <- (max(lwd) * 61 | 0.1), lc <- 0) 62 | orott[1, 1] <- ((cx[1] + lc)/(fds - 0)) - orot[1, 1] 63 | orott[2, 1] <- orot[2, 1] - ((cx[1] + lc)/fds) 64 | } 65 | lst <- array(0L, dim = c(2, 2, r)) 66 | dat <- data.frame(matrix(nrow = 0L, ncol = 2L)) 67 | for (j in 1:r) { 68 | lst[, 1, j] <- orott[, 1] 69 | lst[, 2, j] <- d[j] 70 | dat[(nrow(dat) + 1L):(nrow(dat) + 2L), ] <- lst[, , j] 71 | } 72 | rm(j) 73 | rrot <- xyrt(dat, as.numeric(angp)) 74 | if (isTRUE(pares[1, 1] != 0L | pares[1, 2] != 0L) == TRUE) { 75 | rrot[, 1] <- rrot[, 1] - xo 76 | rrot[, 2] <- rrot[, 2] - yo 77 | } 78 | for (i in 1:r) { 79 | if (isTRUE(b[i] %in% multiplex::men(b)[1]) == TRUE) { 80 | graphics::arrows(rrot[which(seq_len(nrow(dat))%%2L == 81 | 1L)[i], 1], rrot[which(seq_len(nrow(dat))%%2L == 82 | 1L)[i], 2], rrot[which(seq_len(nrow(dat))%%2L == 83 | 0L)[i], 1], rrot[which(seq_len(nrow(dat))%%2L == 84 | 0L)[i], 2], code = 2, length = 0, angle = 0, 85 | lty = vlt[i], lwd = lwd[i], col = grDevices::adjustcolor(ecol[i], 86 | alpha = alfa)) 87 | } 88 | else if (isTRUE(b[i] %in% multiplex::men(b)[1]) == FALSE) { 89 | graphics::arrows(rrot[which(seq_len(nrow(dat))%%2L == 90 | 1L)[i], 1], rrot[which(seq_len(nrow(dat))%%2L == 91 | 1L)[i], 2], rrot[which(seq_len(nrow(dat))%%2L == 92 | 0L)[i], 1], rrot[which(seq_len(nrow(dat))%%2L == 93 | 0L)[i], 2], code = 1, length = 0, angle = 0, 94 | lty = vlt[i], lwd = lwd[i], col = grDevices::adjustcolor(ecol[i], 95 | alpha = alfa)) 96 | } 97 | if (isTRUE(n < 15) == TRUE) { 98 | Hd <- data.frame(x = c((-0.6 - (0.01538462 * n)), 99 | (-0.35 - (0.01538462 * n)), (-0.6 - (0.01538462 * 100 | n)), (0.4 - (0.01538462 * n))), y = c(-0.5, 101 | 0, 0.5, 0)) * (hds) 102 | } 103 | else { 104 | Hd <- data.frame(x = c(-0.7, -0.45, -0.7, 0.3), y = c(-0.5, 105 | 0, 0.5, 0)) * (hds) 106 | } 107 | if (isTRUE(as.numeric(lwd[i]) < 7L) == TRUE) { 108 | ifelse(isTRUE(as.numeric(lwd[i]) <= 1L) == TRUE, 109 | Hd <- Hd * (as.numeric(lwd[i]))/((as.numeric(lwd[i]) * 110 | 8.571) + 30), Hd <- Hd * (as.numeric(lwd[i]))/((as.numeric(lwd[i]) * 111 | 8.571) + 40)) 112 | } 113 | else if (isTRUE(as.numeric(lwd[i]) >= 15L) == TRUE) { 114 | Hd <- Hd * (as.numeric(lwd[i]))/(as.numeric(lwd[i]) + 115 | 120L) 116 | } 117 | else { 118 | Hd <- Hd * (as.numeric(lwd[i]))/((as.numeric(lwd[i]) * 119 | 8.571) + 40) 120 | } 121 | if (isTRUE(i %in% flgcr) == TRUE) { 122 | prx1 <- rrot[which(seq_len(nrow(dat))%%2L == 1L)[i], 123 | 1] 124 | pry1 <- rrot[which(seq_len(nrow(dat))%%2L == 1L)[i], 125 | 2] 126 | hd1 <- xyrt((Hd), (as.numeric(angp) - 180L)) 127 | hd1[, 1] <- hd1[, 1] + prx1 128 | hd1[, 2] <- hd1[, 2] + pry1 129 | graphics::polygon((hd1), col = grDevices::adjustcolor(ecol[i], 130 | alpha = alfa), border = NA) 131 | prx2 <- rrot[which(seq_len(nrow(dat))%%2L == 0L)[i], 132 | 1] 133 | pry2 <- rrot[which(seq_len(nrow(dat))%%2L == 0L)[i], 134 | 2] 135 | hd2 <- xyrt(Hd, (as.numeric(angp) - 0L)) 136 | hd2[, 1] <- hd2[, 1] + prx2 137 | hd2[, 2] <- hd2[, 2] + pry2 138 | graphics::polygon((hd2), col = grDevices::adjustcolor(ecol[i], 139 | alpha = alfa), border = NA) 140 | } 141 | else { 142 | if (isTRUE(b[i] %in% multiplex::men(b)[1]) == FALSE) { 143 | prx <- rrot[which(seq_len(nrow(dat))%%2L == 1L)[i], 144 | 1] 145 | pry <- rrot[which(seq_len(nrow(dat))%%2L == 1L)[i], 146 | 2] 147 | hd <- xyrt((Hd), (as.numeric(angp) - 180L)) 148 | } 149 | else if (isTRUE(b[i] %in% multiplex::men(b)[1]) == 150 | TRUE) { 151 | prx <- rrot[which(seq_len(nrow(dat))%%2L == 0L)[i], 152 | 1] 153 | pry <- rrot[which(seq_len(nrow(dat))%%2L == 0L)[i], 154 | 2] 155 | hd <- xyrt(Hd, (as.numeric(angp) - 0L)) 156 | } 157 | hd[, 1] <- hd[, 1] + prx 158 | hd[, 2] <- hd[, 2] + pry 159 | graphics::polygon((hd), col = grDevices::adjustcolor(ecol[i], 160 | alpha = alfa), border = NA) 161 | } 162 | } 163 | rm(i) 164 | x <- NULL 165 | rm(x) 166 | graphics::par(new = FALSE) 167 | } 168 | -------------------------------------------------------------------------------- /R/ccgraph.R: -------------------------------------------------------------------------------- 1 | ccgraph <- 2 | function (x, main = NULL, seed = 0, maxiter = 100, alpha = c(1, 3 | 1, 1), scope, loops, collRecip, undRecip, showLbs, cex.main, 4 | conc, coord, clu, cex, lwd, pch, lty, bwd, bwd2, att, bg, 5 | mar, pos, asp, ecol, vcol, vcol0, lbs, col, lbat, swp, swp2, 6 | scl, mirrorX, mirrorY, mirrorD, mirrorL, mirrorV, mirrorH, 7 | rot, hds, vedist, ffamily, fstyle, fsize, fcol, nr, gens, 8 | ...) 9 | { 10 | pclu <- NULL 11 | if (is.matrix(x) == TRUE && missing(gens) == TRUE) 12 | stop("If matrix \"x\" is a semigroup, generators are not provided.") 13 | ifelse(is.matrix(x) == TRUE && missing(gens) == FALSE, x <- multiplex::as.semigroup(x, 14 | gens = gens), NA) 15 | if (isTRUE(tolower(class(x)[1]) == "semigroup") == TRUE) { 16 | ifelse(is.null(x$ord) == FALSE, n <- x$ord, n <- dim(x$S)[1]) 17 | if (all(x$st %in% dimnames(x$S)[[1]]) == TRUE) { 18 | Lbs <- x$st 19 | } 20 | else { 21 | Lbs <- dimnames(x$S)[[1]] 22 | } 23 | if (missing(gens) == FALSE) { 24 | x$gens <- gens 25 | } 26 | else if (any(is.na(x$gens)) == TRUE || is.null(x$gens) == 27 | TRUE) { 28 | message("Generators are not provided, and first element of 'x' is taken.") 29 | x$gens <- 1 30 | } 31 | else { 32 | NA 33 | } 34 | if (is.array(x$gens) == TRUE) { 35 | cgm <- array(0, dim = c(n, n, dim(x$gens)[3]), dimnames = c(list(Lbs, 36 | Lbs), list(attr(x$gens, "dimnames")[[3]]))) 37 | } 38 | else if (is.vector(x$gens) == TRUE) { 39 | if (identical(which(Lbs %in% x$gens), seq_len(length(x$gens))) == 40 | FALSE) { 41 | pclu <- rep(1, n) 42 | pclu[which(Lbs %in% x$gens)] <- 0 43 | Sp <- as.data.frame(multiplex::perm(as.matrix(x$S), 44 | clu = pclu)) 45 | cgm <- array(0, dim = c(n, n, length(x$gens)), 46 | dimnames = c(dimnames(Sp), list(x$gens))) 47 | } 48 | else { 49 | cgm <- array(0, dim = c(n, n, length(x$gens)), 50 | dimnames = c(list(Lbs, Lbs), list(x$gens))) 51 | } 52 | } 53 | else if (is.numeric(x$gens) == TRUE) { 54 | cgm <- array(0, dim = c(n, n, x$gens), dimnames = c(list(Lbs, 55 | Lbs), list(seq_len(x$gens)))) 56 | } 57 | if (is.null(pclu) == TRUE) { 58 | for (k in seq_len(dim(cgm)[3])) { 59 | for (i in seq_len(n)) { 60 | cgm[i, which(x$S[i, k] == Lbs), k] <- 1 61 | } 62 | rm(i) 63 | } 64 | rm(k) 65 | } 66 | else if (is.null(pclu) == FALSE) { 67 | for (k in seq_len(dim(cgm)[3])) { 68 | for (i in seq_len(n)) { 69 | cgm[i, which(Sp[i, k] == colnames(Sp)), k] <- 1 70 | } 71 | rm(i) 72 | } 73 | rm(k) 74 | } 75 | } 76 | else if (isTRUE(attr(x, "class") == "EdgeTable") == TRUE) { 77 | if (is.null(x$ET) == FALSE) { 78 | xet <- x$ET 79 | } 80 | else { 81 | ifelse(is.list(x) == TRUE, xet <- x[[1]], stop("'x' must be a data frame in a list.")) 82 | } 83 | ifelse(is.null(x$ord) == FALSE, n <- x$ord, n <- nrow(xet)) 84 | lb <- rownames(xet) 85 | if (missing(gens) == TRUE) { 86 | ifelse(is.null(x$gens) == FALSE, gens <- x$gens, 87 | gens <- colnames(xet)) 88 | } 89 | else { 90 | invisible(NA) 91 | } 92 | ifelse(identical(as.numeric(gens), as.numeric(colnames(xet))) == 93 | TRUE, cgm <- array(0, dim = c(n, n, length(gens)), 94 | dimnames = list(lb, lb, gens)), cgm <- array(0, dim = c(n, 95 | n, dim(gens)[3]), dimnames = list(lb, lb, attr(gens, 96 | "dimnames")[[3]]))) 97 | for (k in seq_len(dim(cgm)[3])) { 98 | for (i in seq_len(n)) { 99 | cgm[i, which(xet[i, k] == lb), k] <- 1 100 | } 101 | rm(i) 102 | } 103 | rm(k) 104 | } 105 | else { 106 | if (is.array(x) == FALSE) 107 | stop("Data must be at least a stacked array of square matrices.") 108 | x <- multiplex::semigroup(x, type = "symbolic") 109 | cgm <- array(0, dim = c(x$ord, x$ord, dim(x$gens)[3]), 110 | dimnames = c(list(x$st, x$st), list(attr(x$gens, 111 | "dimnames")[[3]]))) 112 | for (k in seq_len(dim(cgm)[3])) { 113 | for (i in seq_len(x$ord)) { 114 | cgm[i, which(x$S[i, k] == x$st), k] <- 1 115 | } 116 | rm(i) 117 | } 118 | rm(k) 119 | } 120 | net <- cgm 121 | ifelse(is.null(pclu) == TRUE, NA, net <- multiplex::perm(net, 122 | clu = c(which(pclu == 0), which(pclu == 1)))) 123 | ifelse(isTRUE(dim(net)[3] == 1) == TRUE, net <- net[, , 1], 124 | NA) 125 | if (isTRUE(n == 1L) == TRUE) 126 | stop("1-element semigroup detected, and not yet supported") 127 | ifelse(missing(undRecip) == FALSE && isTRUE(undRecip == TRUE) == 128 | TRUE, undRecip <- TRUE, undRecip <- FALSE) 129 | ifelse(missing(loops) == FALSE && isTRUE(loops == FALSE) == 130 | TRUE, loops <- FALSE, loops <- TRUE) 131 | ifelse(missing(collRecip) == FALSE && isTRUE(collRecip == 132 | FALSE) == TRUE, collRecip <- FALSE, collRecip <- TRUE) 133 | ifelse(missing(conc) == FALSE && isTRUE(conc == TRUE) == 134 | TRUE, conc <- TRUE, conc <- FALSE) 135 | ifelse(missing(mirrorH) == FALSE && isTRUE(mirrorH == TRUE) == 136 | TRUE, mirrorY <- TRUE, NA) 137 | ifelse(missing(mirrorV) == FALSE && isTRUE(mirrorV == TRUE) == 138 | TRUE, mirrorX <- TRUE, NA) 139 | if (missing(showLbs) == FALSE && isTRUE(showLbs == TRUE) == 140 | TRUE) { 141 | showLbs <- TRUE 142 | } 143 | else if (missing(showLbs) == FALSE && isTRUE(showLbs == FALSE) == 144 | TRUE) { 145 | showLbs <- FALSE 146 | } 147 | else { 148 | ifelse(is.null(dimnames(net)[[1]]) == FALSE, showLbs <- TRUE, 149 | showLbs <- FALSE) 150 | } 151 | ifelse(missing(swp) == FALSE && isTRUE(swp == TRUE) == TRUE, 152 | swp <- TRUE, swp <- FALSE) 153 | ifelse(missing(swp2) == FALSE && isTRUE(swp2 == TRUE) == 154 | TRUE, swp2 <- TRUE, swp2 <- FALSE) 155 | if (missing(scope) == FALSE) { 156 | if (isTRUE(is.list(scope) == TRUE) == FALSE) 157 | stop("\"scope\" should be a list or a vector of lists.") 158 | scope <- list(scope) 159 | ifelse(is.null(scope[[1]]) == TRUE, scope <- scope[2:length(scope)], 160 | NA) 161 | if (isTRUE(length(scope) > 1L) == TRUE && isTRUE(names(scope[1]) == 162 | "coord") == TRUE) { 163 | scope <- scope[rev(seq_len(length(scope)))] 164 | flgrev <- TRUE 165 | } 166 | else { 167 | flgrev <- FALSE 168 | } 169 | tmp <- scope[[1]] 170 | if (isTRUE(length(scope) > 1L) == TRUE && isTRUE(length(scope[[1]]) > 171 | 1L) == TRUE) { 172 | for (k in 2:length(scope)) { 173 | tmp[length(tmp) + 1L] <- as.list(scope[k]) 174 | names(tmp)[length(tmp)] <- attr(scope[k], "names") 175 | } 176 | rm(k) 177 | } 178 | else if (isTRUE(length(scope) > 1L) == TRUE) { 179 | names(tmp) <- attr(scope[1], "names") 180 | for (k in 2:length(scope)) { 181 | if (is.list(scope[[k]]) == TRUE && is.data.frame(scope[[k]]) == 182 | FALSE) { 183 | for (j in seq_len(length(scope[[k]]))) { 184 | tmp[length(tmp) + 1L] <- as.list(scope[[k]][j]) 185 | names(tmp)[length(tmp)] <- attr(scope[[k]][j], 186 | "names") 187 | } 188 | rm(j) 189 | } 190 | else if (is.data.frame(scope[[k]]) == FALSE) { 191 | tmp[length(tmp) + 1L] <- as.list(scope[k]) 192 | names(tmp)[length(tmp)] <- attr(scope[k], "names") 193 | } 194 | else if (is.data.frame(scope[[k]]) == TRUE) { 195 | tmp[length(tmp) + 1L] <- as.vector(scope[k]) 196 | names(tmp)[length(tmp)] <- attr(scope[k], "names") 197 | } 198 | else { 199 | NA 200 | } 201 | } 202 | rm(k) 203 | } 204 | else { 205 | tmp <- scope[[1]] 206 | } 207 | ifelse(isTRUE(flgrev == TRUE) == TRUE, scope <- tmp[rev(seq_len(length(tmp)))], 208 | scope <- tmp) 209 | for (i in seq_len(length(scope))) { 210 | if (isTRUE(names(scope)[i] %in% c("seed", "main")) == 211 | TRUE) { 212 | tmpi <- as.vector(scope[[i]]) 213 | assign(names(scope)[i], get("tmpi")) 214 | } 215 | else { 216 | if (is.null((scope[[i]])) == FALSE) { 217 | tmpi <- as.vector(scope[[i]]) 218 | ifelse(isTRUE(names(scope)[i] != "") == TRUE, 219 | assign(names(scope)[i], get("tmpi")), NA) 220 | } 221 | } 222 | } 223 | rm(i) 224 | } 225 | else { 226 | NA 227 | } 228 | ifelse(missing(asp) == TRUE, asp <- 1, NA) 229 | ifelse(missing(lwd) == TRUE, lwd <- 1, NA) 230 | ifelse(missing(pch) == TRUE, pch <- 21, NA) 231 | ifelse(missing(fcol) == TRUE, fcol <- 1, NA) 232 | ifelse(missing(bwd) == TRUE, bwd <- 1, NA) 233 | ifelse(isTRUE(bwd < 0L) == TRUE, bwd <- 0L, NA) 234 | ifelse(missing(bg) == TRUE, bg <- graphics::par()$bg, NA) 235 | ifelse(missing(cex.main) == TRUE, cex.main <- graphics::par()$cex.main, 236 | NA) 237 | ifelse(missing(rot) == TRUE, NA, rot <- rot[1] * -1) 238 | if (isTRUE(length(alpha) < 2) == TRUE) { 239 | alfa <- 1 240 | alpha <- rep(alpha, 3) 241 | } 242 | else { 243 | alfa <- alpha[2] 244 | } 245 | if (isTRUE(length(alpha) < 3) == TRUE) 246 | alpha <- append(alpha, 0.1) 247 | if (!(missing(hds)) && missing(scl) == TRUE) { 248 | if (isTRUE(hds > 1L) == TRUE) { 249 | hds <- (hds/1.5) 250 | } 251 | else if (isTRUE(hds < 1L) == TRUE) { 252 | hds <- (hds/(hds + 0.15)) 253 | } 254 | else if (isTRUE(hds == 0L) == TRUE) { 255 | hds <- 0.01 256 | } 257 | else { 258 | NA 259 | } 260 | } 261 | else { 262 | ifelse(missing(scl) == TRUE, hds <- 1L, hds <- 1L * scl) 263 | } 264 | ifelse(isTRUE(dim(net)[1] > 8) == TRUE || isTRUE(lwd >= 3) == 265 | TRUE, hds <- hds * 0.75, NA) 266 | ifelse(missing(scl) == TRUE, scl <- rep(1, 2), NA) 267 | ifelse(isTRUE(length(scl) == 1) == TRUE, scl <- rep(scl, 268 | 2), scl <- scl[1:2]) 269 | ifelse(missing(vedist) == TRUE, vedist <- 0, NA) 270 | if (isTRUE(vedist > 10L) == TRUE) { 271 | vedist <- 10L 272 | } 273 | else if (isTRUE(vedist < (-10L)) == TRUE) { 274 | vedist <- -10L 275 | } 276 | if (missing(lbs) == TRUE) { 277 | ifelse(is.null(dimnames(net)[[1]]) == TRUE, lbs <- as.character(seq_len(dim(net)[1])), 278 | lbs <- dimnames(net)[[1]]) 279 | } 280 | else { 281 | NA 282 | } 283 | n <- dim(net)[1] 284 | ifelse(isTRUE(is.na(dim(net)[3]) == TRUE) == TRUE, z <- 1L, 285 | z <- dim(net)[3]) 286 | ifelse(isTRUE(swp == TRUE) == TRUE && isTRUE(z > 1L) == TRUE, 287 | net <- net[, , rev(seq_len(z))], NA) 288 | netd <- multiplex::dichot(net, c = 1L) 289 | if (isTRUE(collRecip == TRUE) == TRUE) { 290 | if (isTRUE(z == 1L) == TRUE) { 291 | nt <- netd + t(netd) 292 | rcp <- multiplex::dichot(nt, c = 2L) 293 | rcp[lower.tri(rcp, diag = TRUE)] <- 0L 294 | } 295 | else { 296 | nt <- array(0L, dim = c(n, n, z)) 297 | dimnames(nt)[[1]] <- dimnames(nt)[[2]] <- lbs 298 | dimnames(nt)[[3]] <- dimnames(net)[[3]] 299 | for (i in seq_len(z)) { 300 | nt[, , i] <- netd[, , i] + t(netd[, , i]) 301 | } 302 | rm(i) 303 | rcp <- multiplex::dichot(nt, c = 2L) 304 | for (i in seq_len(z)) { 305 | rcp[, , i][lower.tri(rcp[, , i], diag = TRUE)] <- 0L 306 | } 307 | rm(i) 308 | } 309 | ucnet <- netd - rcp 310 | } 311 | else { 312 | ucnet <- netd 313 | } 314 | bd <- multiplex::bundles(netd, loops = loops, lb2lb = FALSE, 315 | collapse = FALSE) 316 | ifelse(isTRUE(z == 1L) == TRUE, r <- 1L, r <- length(bd[[1]])) 317 | ifelse(isTRUE(sum(net) == 0) == TRUE && isTRUE(loops == TRUE) == 318 | TRUE, bd$loop <- character(0), NA) 319 | bds <- multiplex::summaryBundles(bd, byties = TRUE) 320 | ifelse(missing(ecol) == TRUE, ecol <- grDevices::gray.colors(r, 321 | start = 0.1, end = 0.5), NA) 322 | ifelse(missing(lty) == TRUE, lty <- seq_len(r), NA) 323 | if (isTRUE(z == 1L) == TRUE) { 324 | Lt <- lty[1] 325 | vecol <- ecol[1] 326 | } 327 | else { 328 | ifelse(isTRUE(length(ecol) == 1L) == TRUE, vecol <- rep(ecol, 329 | z), vecol <- rep(ecol, z)[seq_len(z)]) 330 | ifelse(isTRUE(length(lty) == 1L) == TRUE, Lt <- seq_len(r), 331 | Lt <- rep(lty, r)[seq_len(r)]) 332 | if (isTRUE(length(lty) == length(Lt)) == FALSE) { 333 | Ltc <- seq_along(vecol) 334 | } 335 | else { 336 | if (isTRUE(seq(lty) == lty) == TRUE) { 337 | Ltc <- Lt 338 | } 339 | else { 340 | ifelse(isTRUE(swp == TRUE) == TRUE, Ltc <- rev(seq_len(r)), 341 | Ltc <- seq_len(r)) 342 | } 343 | } 344 | } 345 | vltz <- Lt 346 | if (missing(clu) == FALSE) { 347 | if (is.vector(as.vector(clu)) == FALSE) 348 | stop("'clu' must be a vector") 349 | if (is.factor(clu) == TRUE) { 350 | tmpclu <- clu 351 | for (i in seq_len(nlevels(factor(clu)))) { 352 | levels(clu) <- c(levels(clu), i) 353 | clu[which(levels(factor(tmpclu))[i] == clu)] <- i 354 | } 355 | rm(i) 356 | clu <- methods::as(as.vector(clu), "numeric") 357 | rm(tmpclu) 358 | } 359 | else if (is.character(clu) == TRUE) { 360 | tmpclu <- clu 361 | clu[which(clu == clu[1])] <- 1 362 | for (i in seq_len(nlevels(factor(tmpclu)) - 1L)) { 363 | clu[which(clu == clu[which((clu %in% tmpclu) == 364 | TRUE)[(i - 0)]])] <- (i + 1L) 365 | } 366 | rm(i) 367 | clu[which((clu %in% tmpclu) == TRUE)] <- nlevels(factor(tmpclu)) 368 | clu <- methods::as(as.vector(clu), "numeric") 369 | rm(tmpclu) 370 | } 371 | else { 372 | NA 373 | } 374 | clu[which(is.na(clu))] <- 0 375 | nclu <- nlevels(factor(clu)) 376 | } 377 | else { 378 | nclu <- 1L 379 | } 380 | flgcx <- FALSE 381 | if (missing(cex) == TRUE && isTRUE(loops == FALSE) == TRUE) { 382 | if (isTRUE(length(bds) == 0) == TRUE) { 383 | cex <- 1L 384 | } 385 | else { 386 | cex <- length(bds[[1]])/2L 387 | if (isTRUE(length(bds) > 1L) == TRUE) { 388 | for (i in 2:length(bds)) ifelse(isTRUE(cex < 389 | (length(bds[[i]])/2L)) == TRUE, cex <- (length(bds[[i]])/2L), 390 | NA) 391 | } 392 | cex <- ceiling(cex) 393 | } 394 | } 395 | else if (missing(cex) == TRUE) { 396 | cex <- 1L 397 | } 398 | if (isTRUE(length(cex) == 1L) == TRUE) { 399 | cex <- rep(cex, n) 400 | } 401 | else { 402 | if (is.vector(cex) == FALSE) 403 | stop("'cex' must be a vector") 404 | cex[which(is.na(cex))] <- 0 405 | cex <- cex[seq_len(n)] 406 | flgcx <- TRUE 407 | } 408 | if (isTRUE(flgcx == TRUE) == TRUE && isTRUE(max(cex) > 10L) == 409 | TRUE) { 410 | if (isTRUE(mean(cex) > 20L) == TRUE) { 411 | cex <- (((cex - min(cex))/(max(cex) - min(cex))) * 412 | 10L) 413 | } 414 | else { 415 | cex <- (cex/(norm(as.matrix(cex), type = "M"))) * 416 | 10L 417 | } 418 | ifelse(isTRUE(min(cex) == 0) == TRUE, cex <- cex + 1L + 419 | (2L/n), NA) 420 | } 421 | else if (isTRUE(flgcx == FALSE) == TRUE) { 422 | ifelse(isTRUE(max(cex) >= 21L) == TRUE, cex <- 20L, NA) 423 | } 424 | else { 425 | NA 426 | } 427 | if (missing(fsize) == TRUE) { 428 | ifelse(isTRUE(max(cex) < 2) == TRUE, fsize <- cex * 0.66, 429 | fsize <- cex * 0.33) 430 | } 431 | else { 432 | fsize <- fsize/10 433 | } 434 | ifelse(isTRUE(bwd > 1L) == TRUE, bwd <- 1L, NA) 435 | ifelse(isTRUE(max(cex) < 2) == TRUE, NA, bwd <- bwd * 0.75) 436 | if (isTRUE(length(pch) == 1L) == TRUE) { 437 | pch <- rep(pch, n) 438 | } 439 | else if (isTRUE(length(pch) == nclu) == TRUE) { 440 | if (identical(pch, clu) == FALSE) { 441 | tmppch <- rep(0, n) 442 | for (i in seq_len(nclu)) { 443 | tmppch[which(clu == (levels(factor(clu))[i]))] <- pch[i] 444 | } 445 | rm(i) 446 | pch <- tmppch 447 | rm(tmppch) 448 | } 449 | } 450 | else if (isTRUE(length(pch) != n) == TRUE) { 451 | pch <- rep(pch[1], n) 452 | } 453 | if (missing(vcol) == TRUE) { 454 | vcol <- grDevices::gray.colors(nclu) 455 | ifelse(missing(col) == TRUE, NA, vcol <- col) 456 | } 457 | else { 458 | if (isTRUE(length(vcol) == 1L) == TRUE) { 459 | vcol <- rep(vcol, n) 460 | } 461 | else if (isTRUE(length(vcol) == nclu) == TRUE) { 462 | if (identical(vcol, clu) == FALSE) { 463 | tmpvcol <- rep(0, n) 464 | for (i in seq_len(nclu)) { 465 | tmpvcol[which(clu == (levels(factor(clu))[i]))] <- vcol[i] 466 | } 467 | rm(i) 468 | vcol <- tmpvcol 469 | rm(tmpvcol) 470 | } 471 | } 472 | else if (isTRUE(length(vcol) != n) == TRUE & isTRUE(nclu == 473 | 1) == TRUE) { 474 | vcol <- rep(vcol[1], n) 475 | } 476 | vcol[which(is.na(vcol))] <- graphics::par()$bg 477 | vcol[which(vcol == 0)] <- graphics::par()$bg 478 | } 479 | if (isTRUE(any(pch %in% 21:25)) == TRUE) { 480 | if (missing(vcol0) == TRUE) { 481 | vcol0 <- vcol 482 | } 483 | else { 484 | ifelse(missing(vcol0) == TRUE, NA, vcol0[which(is.na(vcol0))] <- 1) 485 | } 486 | if (isTRUE(length(vcol0) == 1L) == TRUE) { 487 | vcol0 <- rep(vcol0, n) 488 | } 489 | else if (isTRUE(length(vcol0) == nclu) == TRUE) { 490 | if (identical(vcol0, clu) == FALSE) { 491 | tmpvcol0 <- rep(0, n) 492 | for (i in seq_len(nclu)) { 493 | tmpvcol0[which(clu == (levels(factor(clu))[i]))] <- vcol0[i] 494 | } 495 | rm(i) 496 | vcol0 <- tmpvcol0 497 | rm(tmpvcol0) 498 | } 499 | } 500 | else if (isTRUE(length(vcol0) != n) == TRUE | isTRUE(nclu == 501 | 1) == TRUE) { 502 | vcol0 <- rep(vcol0[1], n) 503 | } 504 | } 505 | else { 506 | vcol0 <- vcol 507 | } 508 | ifelse(isTRUE(n > 20) == TRUE, ffds <- 0.2, ffds <- 0) 509 | fds <- 130L - (n * ffds) 510 | if (isTRUE(flgcx == TRUE) == TRUE) { 511 | fds <- fds - 10L 512 | } 513 | else if (isTRUE(flgcx == FALSE) == TRUE) { 514 | NA 515 | } 516 | if (isTRUE(max(scl) < 1) == TRUE) { 517 | fds <- fds - (1/(mean(scl)/30L)) 518 | } 519 | else if (isTRUE(max(scl) > 1) == TRUE) { 520 | fds <- fds + (mean(scl) * 20L) 521 | } 522 | else { 523 | NA 524 | } 525 | if (missing(coord) == FALSE) { 526 | if (isTRUE(nrow(coord) == n) == FALSE) 527 | stop("Length of 'coord' does not match network order.") 528 | flgcrd <- TRUE 529 | crd <- coord 530 | } 531 | else if (missing(coord) == TRUE) { 532 | flgcrd <- FALSE 533 | ifelse(isTRUE(conc == TRUE) == FALSE, crd <- frcd(netd, 534 | seed = seed, maxiter = maxiter), crd <- conc(netd, 535 | nr, ...)) 536 | } 537 | if (missing(rot) == FALSE) { 538 | crd[, 1:2] <- xyrt(crd[, 1:2], as.numeric(rot)) 539 | crd[, 1:2] <- crd[, 1:2] - min(crd[, 1:2]) 540 | cnt <- 1L 541 | ifelse(isTRUE(n == 2) == TRUE && isTRUE(rot == -90) == 542 | TRUE, rot <- -89.9, NA) 543 | } 544 | else { 545 | cnt <- 0 546 | } 547 | if (missing(pos) == TRUE) { 548 | pos <- 4 549 | } 550 | else { 551 | if (isTRUE(pos < 0L) == TRUE | isTRUE(pos > 4L) == TRUE) 552 | stop("Invalid \"pos\" value.") 553 | } 554 | ifelse(missing(mirrorX) == FALSE && isTRUE(mirrorX == TRUE) == 555 | TRUE, crd[, 1] <- crd[, 1] * cos(pi) - crd[, 2] * sin(pi), 556 | mirrorX <- FALSE) 557 | ifelse(missing(mirrorY) == FALSE && isTRUE(mirrorY == TRUE) == 558 | TRUE, crd[, 2] <- crd[, 2] * cos(pi) - crd[, 1] * sin(pi), 559 | mirrorY <- FALSE) 560 | if (missing(mirrorL) == FALSE && isTRUE(mirrorL == TRUE) == 561 | TRUE) { 562 | crd[, 1:2] <- xyrt(crd[, 1:2], as.numeric(45)) 563 | crd[, 1:2] <- crd[, 1:2] - min(crd[, 1:2]) 564 | crd[, 2] <- crd[, 2] * cos(pi) - crd[, 1] * sin(pi) 565 | crd[, 1:2] <- xyrt(crd[, 1:2], as.numeric(-45)) 566 | crd[, 1:2] <- crd[, 1:2] - min(crd[, 1:2]) 567 | } 568 | else if (missing(mirrorD) == FALSE && isTRUE(mirrorD == TRUE) == 569 | TRUE) { 570 | crd[, 1:2] <- xyrt(crd[, 1:2], as.numeric(-45)) 571 | crd[, 1:2] <- crd[, 1:2] - min(crd[, 1:2]) 572 | crd[, 2] <- crd[, 2] * cos(pi) - crd[, 1] * sin(pi) 573 | crd[, 1:2] <- xyrt(crd[, 1:2], as.numeric(45)) 574 | crd[, 1:2] <- crd[, 1:2] - min(crd[, 1:2]) 575 | } 576 | else { 577 | NA 578 | } 579 | if (isTRUE(n > 1) == TRUE) { 580 | rat <- (max(crd[, 1]) - min(crd[, 1]))/(max(crd[, 2]) - 581 | min(crd[, 2])) 582 | crd[, 1] <- (crd[, 1] - min(crd[, 1]))/(max(crd[, 1]) - 583 | min(crd[, 1])) 584 | ifelse(isTRUE(rat > 0) == TRUE, crd[, 2] <- ((crd[, 2] - 585 | min(crd[, 2]))/(max(crd[, 2]) - min(crd[, 2]))) * 586 | (1L/rat), crd[, 2] <- ((crd[, 2] - min(crd[, 2]))/(max(crd[, 587 | 2]) - min(crd[, 2]))) * (rat)) 588 | } 589 | else { 590 | NA 591 | } 592 | fds <- fds + (vedist * -10) 593 | if (isTRUE(flgcrd == TRUE) == TRUE && isTRUE(ncol(crd) > 594 | 2) == TRUE) { 595 | lbgml <- tolower(as.vector(crd[, 3])) 596 | lbnet <- tolower(as.vector(lbs)) 597 | lbp <- vector() 598 | for (i in seq_len(nrow(crd))) { 599 | lbp <- append(lbp, which(lbnet[i] == lbgml)) 600 | } 601 | rm(i) 602 | if (isTRUE(ncol(crd) > 3) == TRUE) { 603 | atgml <- as.vector(crd[, 4]) 604 | atgml[which(is.na(atgml))] <- "" 605 | atts <- atgml[lbp] 606 | } 607 | nds <- data.frame(X = as.numeric(as.vector(crd[lbp, 1])), 608 | Y = as.numeric(as.vector(crd[lbp, 2]))) 609 | } 610 | else { 611 | nds <- data.frame(X = as.numeric(as.vector(crd[, 1])), 612 | Y = as.numeric(as.vector(crd[, 2]))) 613 | } 614 | nds <- ((2L/max(nds * (0.75))) * (nds * 0.75)) * (0.5) 615 | mscl <- mean(scl) 616 | cex <- cex * mscl 617 | fsize <- fsize * mscl 618 | omr <- graphics::par()$mar 619 | omi <- graphics::par()$mai 620 | if (missing(mar) == TRUE) { 621 | mar <- c(0, 0, 0, 0) 622 | } 623 | else { 624 | mar <- omr 625 | } 626 | ifelse(is.null(main) == TRUE, graphics::par(mar = mar), graphics::par(mar = mar + 627 | c(0, 0, cex.main, 0))) 628 | obg <- graphics::par()$bg 629 | graphics::par(bg = grDevices::adjustcolor(bg, alpha = alpha[3])) 630 | if (isTRUE(loops == TRUE) == TRUE) { 631 | ylim <- c(min(nds[, 2]) - (max(cex)/100L), max(nds[, 632 | 2]) + (max(cex)/70L)) 633 | xlim <- c(min(nds[, 1]) - (max(cex)/100L), max(nds[, 634 | 1]) + (max(cex)/100L)) 635 | } 636 | else if (isTRUE(flgcx == TRUE) == TRUE) { 637 | ylim <- c(min(nds[, 2]) - (max(cex)/500L), max(nds[, 638 | 2]) + (max(cex)/500L)) 639 | xlim <- c(min(nds[, 1]) - (max(cex)/500L), max(nds[, 640 | 1]) + (max(cex)/500L)) 641 | } 642 | else { 643 | ylim <- c(min(nds[, 2]) - ((cex[1])/200L), max(nds[, 644 | 2]) + ((cex[1])/200L)) 645 | xlim <- c(min(nds[, 1]) - ((cex[1])/200L), max(nds[, 646 | 1]) + ((cex[1])/200L)) 647 | } 648 | suppressWarnings(graphics::plot(nds, type = "n", axes = FALSE, 649 | xlab = "", ylab = "", ylim = ylim, xlim = xlim, asp = asp, 650 | main = main, cex.main = cex.main, ...)) 651 | tlbs <- vector() 652 | if (isTRUE(length(bds) > 0) == TRUE) { 653 | for (i in seq_len(length(attr(bds, "names")))) { 654 | ifelse(isTRUE(length(multiplex::dhc(attr(bds, "names")[i], 655 | sep = "")) > 4L) == TRUE, tlbs <- append(tlbs, 656 | tolower(paste(multiplex::dhc(attr(bds, "names")[i], 657 | sep = "")[1:4], collapse = ""))), tlbs <- append(tlbs, 658 | tolower(attr(bds, "names"))[i])) 659 | } 660 | rm(i) 661 | } 662 | if (isTRUE(loops == TRUE) == TRUE) { 663 | tlbslp <- tlbs 664 | tlbs <- tlbs[which(tlbs != "loop")] 665 | } 666 | else { 667 | NA 668 | } 669 | if (isTRUE(swp == TRUE) == TRUE) { 670 | Lt <- Lt[rev(seq_len(length(Lt)))] 671 | lwd <- lwd[length(lwd):1] 672 | alfa <- alfa[rev(seq_len(length(alfa)))] 673 | } 674 | if (isTRUE(collRecip == TRUE) == TRUE) { 675 | trcp <- multiplex::transf(rcp, type = "tolist") 676 | } 677 | else { 678 | NA 679 | } 680 | if (isTRUE(length(tlbs) > 0) == TRUE) { 681 | for (k in seq_len(length(tlbs))) { 682 | prs <- as.numeric(multiplex::dhc(bds[[k]])) 683 | pars <- as.matrix(nds[as.numeric(levels(factor(multiplex::dhc(bds[[k]])))), 684 | ]) 685 | rbds <- length(bds[[k]]) 686 | if (isTRUE(rbds > 0L) == TRUE) { 687 | q <- which(tlbs[k] == attr(bd, "names")) 688 | if (isTRUE(z == 1L) == TRUE) { 689 | vlt <- rep(Lt, rbds) 690 | vecol <- rep(ecol[1], rbds) 691 | tbnd <- as.vector(unlist(bd[q])) 692 | if (isTRUE(length(tbnd) > 0L) == TRUE) { 693 | ifelse(isTRUE(any(tbnd %in% bds[[k]])) == 694 | TRUE, vlt <- append(vlt, rep(Lt, q)), NA) 695 | ifelse(isTRUE(any(tbnd %in% bds[[k]])) == 696 | TRUE, vltz <- append(vltz, rep(Lt, q)), 697 | NA) 698 | } 699 | vltc <- vlt[1] 700 | } 701 | else { 702 | vlt <- vector() 703 | for (i in seq_along(Lt)) { 704 | tbnd <- as.vector(unlist(bd[[q]][i])) 705 | if (isTRUE(length(tbnd) > 0L) == TRUE) { 706 | ifelse(isTRUE(any(tbnd %in% bds[[k]])) == 707 | TRUE, vlt <- append(vlt, rep(Lt[i], length(which(tbnd %in% 708 | bds[[k]])))), NA) 709 | ifelse(isTRUE(any(tbnd %in% bds[[k]])) == 710 | TRUE, vltz <- append(vltz, rep(Lt[i], 711 | length(which(tbnd %in% bds[[k]])))), 712 | NA) 713 | } 714 | } 715 | rm(i) 716 | if (isTRUE(length(lty) == 1L) == TRUE) { 717 | vlt1 <- rep(lty, length(vlt)) 718 | vltc <- vlt 719 | } 720 | else { 721 | vltc <- vector() 722 | if (isTRUE(Lt == Ltc) == FALSE) { 723 | for (i in seq_along(Ltc)) { 724 | tbnd <- as.vector(unlist(bd[[q]][i])) 725 | if (isTRUE(length(tbnd) > 0L) == TRUE) { 726 | ifelse(isTRUE(any(tbnd %in% bds[[k]])) == 727 | TRUE, vltc <- append(vltc, rep(Ltc[i], 728 | length(which(tbnd %in% bds[[k]])))), 729 | NA) 730 | } 731 | } 732 | rm(i) 733 | } 734 | else { 735 | if (isTRUE(seq(lty) == lty) == TRUE) { 736 | vltc <- vlt 737 | } 738 | else { 739 | for (i in seq_along(lty)) { 740 | vltc <- append(vltc, replace(vlt[which(vlt == 741 | lty[i])], vlt[which(vlt == lty[i])] != 742 | i, i)) 743 | } 744 | rm(i) 745 | } 746 | } 747 | } 748 | } 749 | cx <- cex 750 | lw <- rep(lwd[1], rbds) 751 | ifelse(isTRUE(swp2 == TRUE) == TRUE && isTRUE(tlbs[k] %in% 752 | c("recp")) == TRUE, bds[[k]] <- multiplex::swp(bds[[k]]), 753 | NA) 754 | if (isTRUE(collRecip == TRUE) == TRUE && isTRUE(tlbs[k] %in% 755 | c("recp")) == TRUE) { 756 | bw <- 0L 757 | ifelse(isTRUE(undRecip == TRUE) == TRUE, hd <- 0L, 758 | hd <- hds) 759 | lw <- (lw + (3L/lw)) * mscl 760 | } 761 | else if (isTRUE(collRecip == TRUE) == FALSE && 762 | isTRUE(tlbs[k] %in% c("recp")) == TRUE) { 763 | ifelse(isTRUE(undRecip == TRUE) == TRUE, hd <- 0L, 764 | hd <- hds) 765 | } 766 | else { 767 | bw <- bwd 768 | hd <- hds 769 | lw <- lw * mscl 770 | } 771 | if (isTRUE(collRecip == TRUE) == TRUE && isTRUE(tlbs[k] %in% 772 | c("recp")) == FALSE) { 773 | flgcr <- numeric() 774 | sbds <- multiplex::swp(bds[[k]]) 775 | if (any(sbds %in% unlist(trcp)) == TRUE) { 776 | for (i in seq_len(z)) { 777 | ifelse(any(sbds %in% trcp[[i]]) == TRUE, 778 | flgcr <- append(flgcr, as.numeric(i)), 779 | NA) 780 | } 781 | rm(i) 782 | } 783 | } 784 | else { 785 | flgcr <- rep(0L, z) 786 | } 787 | pars[, 1] <- pars[, 1] * scl[1] 788 | pars[, 2] <- pars[, 2] * scl[2] 789 | if (isTRUE(z == 1L) == TRUE) { 790 | ccbnd(pars, rbds, bds[[k]], vlt, cx * mscl, 791 | lw, vecol, bw, alfa, fds, flgcx, flgcr, hd, 792 | n) 793 | } 794 | else { 795 | ifelse(isTRUE(length(lty) == 1L) == TRUE, ccbnd(pars, 796 | rbds, bds[[k]], vlt1, cx * mscl, lw, vecol[vltc], 797 | bw, alfa, fds, flgcx, flgcr, hd, n), ccbnd(pars, 798 | rbds, bds[[k]], vlt, cx * mscl, lw, vecol[vltc], 799 | bw, alfa, fds, flgcx, flgcr, hd, n)) 800 | } 801 | } 802 | else { 803 | NA 804 | } 805 | } 806 | rm(k) 807 | } 808 | else { 809 | NA 810 | } 811 | if (isTRUE(loops == TRUE) == TRUE) { 812 | ifelse(isTRUE(swp == TRUE) == TRUE && isTRUE(z == 2L) == 813 | TRUE, Lt <- rev(Lt), NA) 814 | bdlp <- bd$loop 815 | ndss <- nds 816 | ndss[, 1] <- ndss[, 1] * scl[1] 817 | ndss[, 2] <- ndss[, 2] * scl[2] 818 | dz <- (rng(z) + abs(min(rng(z))))/(10L) 819 | if (isTRUE(z == 1L) == TRUE) { 820 | lp <- as.vector(which(diag(net) > 0)) 821 | if (isTRUE(length(lp) > 0) == TRUE) { 822 | for (i in seq_len(length(lp))) { 823 | if (isTRUE(n < 3) == TRUE) { 824 | dcx <- (cex[lp[i]] * 0.0075) 825 | lpsz <- (cex[lp[i]] * 0.005) - (dz) 826 | } 827 | else { 828 | dcx <- (cex[lp[i]] * 0.01) 829 | lpsz <- (cex[lp[i]] * 0.0075) - (dz) 830 | } 831 | hc(ndss[lp[i], 1], ndss[lp[i], 2] + (dcx), 832 | lpsz, col = vecol, lty = Lt, lwd = lwd) 833 | } 834 | rm(i) 835 | } 836 | else { 837 | NA 838 | } 839 | } 840 | else if (isTRUE(z > 1) == TRUE) { 841 | if (missing(bwd2) == TRUE) { 842 | NA 843 | } 844 | else { 845 | ifelse(isTRUE(bwd2 < 1L) == TRUE && isTRUE(bwd2 == 846 | 0) == FALSE, bwd2 <- 1L, NA) 847 | ifelse(isTRUE(bwd2 > 2L) == TRUE, bwd2 <- 2L, 848 | NA) 849 | if (isTRUE(bwd2 == 0) == TRUE || (any(duplicated(unlist(bdlp))) == 850 | FALSE && isTRUE(bwd2 == 1L) == TRUE)) { 851 | dz <- rep(0, z) 852 | } 853 | else { 854 | ifelse(missing(bwd2) == TRUE, dz <- (rng(z) + 855 | abs(min(rng(z))))/(10L), dz <- (bwd2) * (rng(z) + 856 | abs(min(rng(z))))/(4)) 857 | } 858 | } 859 | ifelse(isTRUE(cx > 3L) == TRUE, fcex <- 3L, fcex <- floor(cx)) 860 | for (k in seq_len(length(bdlp))) { 861 | lp <- as.numeric(unique(multiplex::dhc(bdlp)[k][[1]])) 862 | if (isTRUE(length(lp) > 0) == TRUE) { 863 | for (i in seq_len(length(lp))) { 864 | ifelse(isTRUE(fcex[lp[i]] <= 3L) == TRUE | 865 | isTRUE(n < 3L) == TRUE, dz <- dz * 0.75, 866 | NA) 867 | if (isTRUE(n < 3L) == TRUE) { 868 | dcx <- fcex[lp[i]]/110L 869 | lpsz <- abs((fcex[lp[i]] * 0.007) - dz[k]) 870 | } 871 | else { 872 | dcx <- fcex[lp[i]]/100L 873 | lpsz <- abs((fcex[lp[i]] * 0.0075) - dz[k]) 874 | } 875 | ifelse(isTRUE(length(lty) == 1) == TRUE, 876 | hc(ndss[lp[i], 1], ndss[lp[i], 2] + (dcx), 877 | lpsz, col = grDevices::adjustcolor(vecol[k], 878 | alpha = alfa), lty = lty, lwd = lwd[k]), 879 | hc(ndss[lp[i], 1], ndss[lp[i], 2] + (dcx), 880 | lpsz, col = grDevices::adjustcolor(vecol[k], 881 | alpha = alfa), lty = Lt[k], lwd = lwd[k])) 882 | } 883 | rm(i) 884 | } 885 | else { 886 | dz <- append(0, dz) 887 | } 888 | } 889 | rm(k) 890 | } 891 | } 892 | else { 893 | NA 894 | } 895 | if (all(pch %in% 21:25) == TRUE) { 896 | graphics::points(nds[, 1] * scl[1], nds[, 2] * scl[2], 897 | pch = pch, cex = cex, col = grDevices::adjustcolor(vcol0, 898 | alpha = alpha[1]), bg = grDevices::adjustcolor(vcol, 899 | alpha = alpha[1])) 900 | } 901 | else { 902 | graphics::points(nds[, 1] * scl[1], nds[, 2] * scl[2], 903 | pch = pch, cex = cex, col = grDevices::adjustcolor(vcol, 904 | alpha = alpha[1]), bg = grDevices::adjustcolor(vcol, 905 | alpha = alpha[1])) 906 | } 907 | if (isTRUE(showLbs == TRUE) == TRUE) { 908 | ndss <- nds 909 | ndss[, 1] <- ndss[, 1] * scl[1] 910 | ndss[, 2] <- ndss[, 2] * scl[2] 911 | ifelse(missing(ffamily) == FALSE && isTRUE(ffamily %in% 912 | names(grDevices::postscriptFonts())) == TRUE, graphics::par(family = ffamily), 913 | NA) 914 | if (isTRUE(length(pos) == 1) == TRUE) { 915 | if (isTRUE(pos == 0) == TRUE) { 916 | if (missing(fstyle) == TRUE || (missing(fstyle) == 917 | FALSE && isTRUE(fstyle %in% c("italic", "bold", 918 | "bolditalic") == FALSE))) { 919 | graphics::text(ndss, labels = lbs, cex = fsize, 920 | adj = 0.5, col = fcol) 921 | } 922 | else if (missing(fstyle) == FALSE) { 923 | if (isTRUE(fstyle == "italic") == TRUE) { 924 | graphics::text(ndss, labels = as.expression(lapply(lbs, 925 | function(x) bquote(italic(.(x))))), cex = fsize, 926 | adj = 0.5, col = fcol) 927 | } 928 | else if (isTRUE(fstyle == "bold") == TRUE) { 929 | graphics::text(ndss, labels = as.expression(lapply(lbs, 930 | function(x) bquote(bold(.(x))))), cex = fsize, 931 | adj = 0.5, col = fcol) 932 | } 933 | else if (isTRUE(fstyle == "bolditalic") == 934 | TRUE) { 935 | graphics::text(ndss, labels = as.expression(lapply(lbs, 936 | function(x) bquote(bolditalic(.(x))))), 937 | cex = fsize, adj = 0.5, col = fcol) 938 | } 939 | } 940 | } 941 | else { 942 | if (missing(fstyle) == TRUE || (missing(fstyle) == 943 | FALSE && isTRUE(fstyle %in% c("italic", "bold", 944 | "bolditalic") == FALSE))) { 945 | graphics::text(ndss, lbs, cex = fsize, pos = pos, 946 | col = fcol, offset = (cex/4L), adj = c(0.5, 947 | 1)) 948 | } 949 | else if (missing(fstyle) == FALSE) { 950 | if (isTRUE(fstyle == "italic") == TRUE) { 951 | graphics::text(ndss, as.expression(lapply(lbs, 952 | function(x) bquote(italic(.(x))))), cex = fsize, 953 | pos = pos, col = fcol, offset = (cex/4L), 954 | adj = c(0.5, 1)) 955 | } 956 | else if (isTRUE(fstyle == "bold") == TRUE) { 957 | graphics::text(ndss, as.expression(lapply(lbs, 958 | function(x) bquote(bold(.(x))))), cex = fsize, 959 | pos = pos, col = fcol, offset = (cex/4L), 960 | adj = c(0.5, 1)) 961 | } 962 | else if (isTRUE(fstyle == "bolditalic") == 963 | TRUE) { 964 | graphics::text(ndss, as.expression(lapply(lbs, 965 | function(x) bquote(bolditalic(.(x))))), 966 | cex = fsize, pos = pos, col = fcol, offset = (cex/4L), 967 | adj = c(0.5, 1)) 968 | } 969 | } 970 | } 971 | } 972 | else if (isTRUE(length(pos) == n) == TRUE) { 973 | if (missing(fstyle) == TRUE || (missing(fstyle) == 974 | FALSE && isTRUE(fstyle %in% c("italic", "bold", 975 | "bolditalic") == FALSE))) { 976 | graphics::text(ndss, lbs, cex = fsize, pos = pos, 977 | col = fcol[1], offset = (cex/4L), adj = c(0.5, 978 | 1)) 979 | } 980 | else if (missing(fstyle) == FALSE) { 981 | if (isTRUE(fstyle == "italic") == TRUE) { 982 | graphics::text(ndss, as.expression(lapply(lbs, 983 | function(x) bquote(italic(.(x))))), cex = fsize, 984 | pos = pos, col = fcol[1], offset = (cex/4L), 985 | adj = c(0.5, 1)) 986 | } 987 | else if (isTRUE(fstyle == "bold") == TRUE) { 988 | graphics::text(ndss, as.expression(lapply(lbs, 989 | function(x) bquote(bold(.(x))))), cex = fsize, 990 | pos = pos, col = fcol[1], offset = (cex/4L), 991 | adj = c(0.5, 1)) 992 | } 993 | else if (isTRUE(fstyle == "bolditalic") == TRUE) { 994 | graphics::text(ndss, as.expression(lapply(lbs, 995 | function(x) bquote(bolditalic(.(x))))), cex = fsize, 996 | pos = pos, col = fcol[1], offset = (cex/4L), 997 | adj = c(0.5, 1)) 998 | } 999 | } 1000 | } 1001 | else { 1002 | if (isTRUE(pos[1] == 0) == TRUE) { 1003 | if (missing(fstyle) == TRUE || (missing(fstyle) == 1004 | FALSE && isTRUE(fstyle %in% c("italic", "bold", 1005 | "bolditalic") == FALSE))) { 1006 | graphics::text(ndss, labels = lbs, cex = fsize, 1007 | adj = 0.5, col = fcol) 1008 | } 1009 | else if (missing(fstyle) == FALSE) { 1010 | if (isTRUE(fstyle == "italic") == TRUE) { 1011 | graphics::text(ndss, labels = as.expression(lapply(lbs, 1012 | function(x) bquote(italic(.(x))))), cex = fsize, 1013 | adj = 0.5, col = fcol) 1014 | } 1015 | else if (isTRUE(fstyle == "bold") == TRUE) { 1016 | graphics::text(ndss, labels = as.expression(lapply(lbs, 1017 | function(x) bquote(bold(.(x))))), cex = fsize, 1018 | adj = 0.5, col = fcol) 1019 | } 1020 | else if (isTRUE(fstyle == "bolditalic") == 1021 | TRUE) { 1022 | graphics::text(ndss, labels = as.expression(lapply(lbs, 1023 | function(x) bquote(bolditalic(.(x))))), 1024 | cex = fsize, adj = 0.5, col = fcol) 1025 | } 1026 | } 1027 | } 1028 | else { 1029 | if (missing(fstyle) == TRUE || (missing(fstyle) == 1030 | FALSE && isTRUE(fstyle %in% c("italic", "bold", 1031 | "bolditalic") == FALSE))) { 1032 | graphics::text(ndss, lbs, cex = fsize, pos = pos[1], 1033 | col = fcol, offset = (cex/4L), adj = c(0.5, 1034 | 1)) 1035 | } 1036 | else if (missing(fstyle) == FALSE) { 1037 | if (isTRUE(fstyle == "italic") == TRUE) { 1038 | graphics::text(ndss, as.expression(lapply(lbs, 1039 | function(x) bquote(italic(.(x))))), cex = fsize, 1040 | pos = pos[1], col = fcol, offset = (cex/4L), 1041 | adj = c(0.5, 1)) 1042 | } 1043 | else if (isTRUE(fstyle == "bold") == TRUE) { 1044 | graphics::text(ndss, as.expression(lapply(lbs, 1045 | function(x) bquote(bold(.(x))))), cex = fsize, 1046 | pos = pos[1], col = fcol, offset = (cex/4L), 1047 | adj = c(0.5, 1)) 1048 | } 1049 | else if (isTRUE(fstyle == "bolditalic") == 1050 | TRUE) { 1051 | graphics::text(ndss, as.expression(lapply(lbs, 1052 | function(x) bquote(bolditalic(.(x))))), 1053 | cex = fsize, pos = pos[1], col = fcol, 1054 | offset = (cex/4L), adj = c(0.5, 1)) 1055 | } 1056 | } 1057 | } 1058 | } 1059 | } 1060 | graphics::par(mar = omr) 1061 | graphics::par(bg = obg) 1062 | graphics::par(lend = 0) 1063 | graphics::par(mai = omi) 1064 | } 1065 | -------------------------------------------------------------------------------- /R/conc.R: -------------------------------------------------------------------------------- 1 | conc <- 2 | function (net, nr, irot, inv, flip, mirror = c("N", "X", "Y", 3 | "D", "L"), ...) 4 | { 5 | n <- dim(net)[1] 6 | if (isTRUE(is.null(dimnames(net)[1]) == TRUE | is.null(dimnames(net)[1][[1]])) == 7 | FALSE) { 8 | lbs <- dimnames(net)[[1]] 9 | } 10 | else { 11 | lbs <- seq_len(n) 12 | } 13 | if (missing(nr) == TRUE) { 14 | clu <- rep(1, n) 15 | } 16 | else if (is.numeric(nr) == TRUE) { 17 | if (isTRUE(nr >= n) == TRUE | isTRUE(nr <= 0) == TRUE) { 18 | message("Value of 'nr' must be greater than zero and lower than network order.") 19 | nr <- 1L 20 | } 21 | else if (isTRUE(is.integer(nr) == FALSE) == TRUE) { 22 | nr <- round(nr) 23 | } 24 | else { 25 | NA 26 | } 27 | clu <- vector() 28 | for (i in seq_len(nr)) { 29 | clu <- append(clu, rep(i, ceiling(n/nr))) 30 | } 31 | rm(i) 32 | clu <- clu[seq_len(n)] 33 | } 34 | else if (is.factor(nr) == TRUE) { 35 | tmpnr <- nr[seq_len(n)] 36 | if (any(is.na(tmpnr)) == TRUE) 37 | stop("Insufficient length of 'nr'.") 38 | for (i in seq_len(nlevels(factor(nr)))) { 39 | levels(nr) <- c(levels(nr), i) 40 | nr[which(levels(factor(tmpnr))[i] == nr)] <- i 41 | } 42 | rm(i) 43 | clu <- methods::as(as.vector(nr), "numeric") 44 | rm(tmpnr) 45 | } 46 | else if (is.character(nr) == TRUE) { 47 | tmpnr <- nr[seq_len(n)] 48 | if (any(is.na(tmpnr)) == TRUE) 49 | stop("Insufficient length of 'nr'.") 50 | nr[which(nr == nr[1])] <- 1 51 | for (i in seq_len(nlevels(factor(tmpnr)) - 1L)) { 52 | nr[which(nr == nr[which((nr %in% tmpnr) == TRUE)[(i - 53 | 0)]])] <- (i + 1L) 54 | } 55 | rm(i) 56 | nr[which((nr %in% tmpnr) == TRUE)] <- nlevels(factor(tmpnr)) 57 | clu <- methods::as(as.vector(nr), "numeric") 58 | rm(tmpnr) 59 | } 60 | else { 61 | NA 62 | } 63 | r <- nlevels(factor(clu)) 64 | if (missing(irot) == FALSE && is.numeric(irot) == TRUE) { 65 | flgirot <- TRUE 66 | irot <- irot[seq_len(r)] 67 | irot[which(is.na(irot))] <- 0L 68 | } 69 | else { 70 | flgirot <- FALSE 71 | } 72 | if (missing(inv) == FALSE && isTRUE(inv == TRUE) == TRUE) { 73 | oclu <- clu 74 | k <- 1L 75 | for (i in rev(seq_len(nlevels(factor(oclu))))) { 76 | clu[which(levels(factor(oclu))[i] == oclu)] <- as.numeric(levels(factor(oclu))[k]) 77 | k <- k + 1L 78 | } 79 | rm(i) 80 | } 81 | else { 82 | inv <- FALSE 83 | } 84 | nlst <- list() 85 | length(nlst) <- r 86 | for (i in seq_len(r)) { 87 | nlst[[i]] <- lbs[which(clu == i)] 88 | } 89 | rm(i) 90 | rad <- 1L 91 | nds <- data.frame(matrix(ncol = 2, nrow = 0)) 92 | for (i in seq_len(length(nlst))) { 93 | nl <- length(nlst[[i]]) 94 | if (isTRUE(i == 1L) == TRUE && isTRUE(nl == 1L) == TRUE) { 95 | x <- data.frame(X = 0L, Y = 0L) 96 | rad <- rad - 1L 97 | } 98 | else { 99 | x <- data.frame(X = cos(2L * pi * ((0:((nl) - 1L))/nl)) * 100 | rad, Y = sin(2L * pi * ((0:(nl - 1L))/nl)) * 101 | rad) 102 | } 103 | ifelse(isTRUE(flgirot == TRUE) == TRUE, x[, 2:1] <- xyrt(x[, 104 | 2:1], (irot[i] * -1L)), NA) 105 | if (missing(flip) == FALSE && isTRUE(flip == TRUE) == 106 | TRUE) { 107 | ifelse(isTRUE((i%%2L) == 0L) == TRUE, x[, 1] <- x[, 108 | 1] * cos(pi) - x[, 2] * sin(pi), NA) 109 | } 110 | else { 111 | NA 112 | } 113 | nds <- rbind(nds, x[, 2:1]) 114 | rad <- rad + 1L 115 | } 116 | rm(i) 117 | switch(match.arg(mirror), N = { 118 | NA 119 | }, X = { 120 | nds[, 1] <- nds[, 1] * cos(pi) - nds[, 2] * sin(pi) 121 | }, Y = { 122 | nds[, 2] <- nds[, 2] * cos(pi) - nds[, 1] * sin(pi) 123 | }, D = { 124 | nds[, 1:2] <- xyrt(nds[, 1:2], as.numeric(-45)) 125 | nds[, 1:2] <- nds[, 1:2] - min(nds[, 1:2]) 126 | nds[, 2] <- nds[, 2] * cos(pi) - nds[, 1] * sin(pi) 127 | nds[, 1:2] <- xyrt(nds[, 1:2], as.numeric(45)) 128 | nds[, 1:2] <- nds[, 1:2] - min(nds[, 1:2]) 129 | }, L = { 130 | nds[, 1:2] <- xyrt(nds[, 1:2], as.numeric(45)) 131 | nds[, 1:2] <- nds[, 1:2] - min(nds[, 1:2]) 132 | nds[, 2] <- nds[, 2] * cos(pi) - nds[, 1] * sin(pi) 133 | nds[, 1:2] <- xyrt(nds[, 1:2], as.numeric(-45)) 134 | nds[, 1:2] <- nds[, 1:2] - min(nds[, 1:2]) 135 | }) 136 | nds 137 | } 138 | -------------------------------------------------------------------------------- /R/frcd.R: -------------------------------------------------------------------------------- 1 | frcd <- 2 | function (net, seed = seed, maxiter, drp, scl, mov, ...) 3 | { 4 | if (isTRUE(is.data.frame(net) == TRUE) == TRUE) { 5 | net <- as.matrix(net) 6 | } 7 | net <- replace(net, net == Inf, 0L) 8 | n <- dim(net)[1] 9 | ifelse(missing(maxiter) == TRUE, maxiter <- (60L + n), NA) 10 | if (missing(drp) == FALSE && is.numeric(drp) == TRUE) { 11 | netdrp <- replace(net, net <= drp, 0) 12 | netd <- multiplex::dichot(netdrp, c = 1L) 13 | } 14 | else { 15 | netd <- multiplex::dichot(net, c = 1L) 16 | netdrp <- net 17 | } 18 | mat <- multiplex::mnplx(netd, directed = FALSE) 19 | nds <- matrix(0, nrow = n, ncol = 2) 20 | if (is.null(rownames(mat)) == TRUE) { 21 | lbs <- seq_len(n) 22 | rownames(nds) <- lbs 23 | } 24 | else { 25 | lbs <- rownames(mat) 26 | rownames(nds) <- make.unique(lbs) 27 | } 28 | cmps <- multiplex::comps(netd) 29 | set.seed(seed) 30 | for (k in 1:length(cmps$com)) { 31 | if (is.null(cmps$com[[k]]) == FALSE) { 32 | com <- which(lbs %in% cmps$com[[k]]) 33 | if (isTRUE(length(cmps$com[[k]]) == 2L) == TRUE) { 34 | tmp <- rbind(stats::rcauchy(2L, location = -20, 35 | scale = 2), stats::rcauchy(2L, location = 20, 36 | scale = 2))/(n * (length(cmps$com[[k]])^4)) 37 | locx <- tmp[, 1] + (stats::rcauchy(1L, location = 1, 38 | scale = 2) * 1L) 39 | locy <- tmp[, 2] 40 | K <- 1 41 | } 42 | else if (isTRUE(length(cmps$com[[k]]) > 2L) == TRUE) { 43 | mt <- mat[com, com] 44 | ndc <- data.frame(X = round(stats::runif(dim(mt)[1]) * 45 | 2L, 5), Y = round(stats::runif(dim(mt)[2]) * 46 | 2L, 5)) 47 | locx <- ndc[, 1] 48 | locy <- ndc[, 2] 49 | K <- 0.75 * sqrt(((max(locx) - min(locx)) * (max(locy) - 50 | min(locy)))/dim(mt)[1]) 51 | forcex <- rep(0, dim(mt)[1]) 52 | forcey <- rep(0, dim(mt)[1]) 53 | for (niter in seq_len(maxiter)) { 54 | for (i in seq_len(dim(mt)[1])) { 55 | forcevx <- 0 56 | forcevy <- 0 57 | for (j in which(!(seq_len(dim(mt)[1]) %in% 58 | i))) { 59 | dx <- locx[j] - locx[i] 60 | dy <- locy[j] - locy[i] 61 | d <- sqrt(dx^2 + dy^2) 62 | ifelse(isTRUE(mt[i, j] == 0) == FALSE, 63 | Fd <- (d/K) - K^2/d^2, Fd <- (-K^2/d^2)) 64 | forcevx <- forcevx + Fd * dx 65 | forcevy <- forcevy + Fd * dy 66 | } 67 | rm(j) 68 | forcex[i] <- forcevx 69 | forcey[i] <- forcevy 70 | } 71 | rm(i) 72 | TEMP <- 2L/niter 73 | for (l in seq_len(dim(mt)[1])) { 74 | forcemag <- sqrt(forcex[l]^2 + forcey[l]^2) 75 | scala <- min(forcemag, TEMP)/forcemag 76 | locx[l] <- locx[l] + (forcex[l] * scala) 77 | locy[l] <- locy[l] + (forcey[l] * scala) 78 | } 79 | rm(l) 80 | } 81 | rm(niter) 82 | } 83 | else { 84 | NA 85 | } 86 | if (all(nds == 0) == FALSE && isTRUE(length(cmps$com) > 87 | 1) == TRUE) { 88 | ndsc <- nds[which(nds[, 1] != 0 | nds[, 2] != 89 | 0), ] 90 | if (isTRUE(length(which(ndsc[, 1] < mean(ndsc[, 91 | 1]))) > length(which(ndsc[, 1] > mean(ndsc[, 92 | 1])))) == TRUE) { 93 | dirx <- +1L 94 | locx <- max(ndsc[, 1]) + (max(locx) - locx) 95 | } 96 | else { 97 | dirx <- -1L 98 | locx <- min(ndsc[, 1]) - (max(locx) - locx) 99 | } 100 | if (isTRUE(length(which(ndsc[, 2] < mean(ndsc[, 101 | 2]))) > length(which(ndsc[, 2] > mean(ndsc[, 102 | 2])))) == TRUE) { 103 | diry <- +1L 104 | locy <- max(ndsc[, 2]) + (max(locy) - locy) 105 | } 106 | else { 107 | diry <- -1L 108 | locy <- min(ndsc[, 2]) - (min(locy) - locy) 109 | } 110 | if (isTRUE(any(duplicated(rbind(ndsc, cbind(locx, 111 | locy))))) == TRUE) { 112 | locx <- locx + (dirx * 0.25) 113 | locy <- locy + (diry * 0.25) 114 | } 115 | else { 116 | NA 117 | } 118 | } 119 | nds[com, ] <- (cbind(locx, locy)) 120 | } 121 | else { 122 | K <- 2 123 | } 124 | } 125 | rm(k) 126 | ifelse(isTRUE(sum(nds) == 0) == TRUE, rat <- 1L, rat <- (max(nds[, 127 | 1]) - min(nds[, 1]))/(max(nds[, 2]) - min(nds[, 2]))) 128 | ni <- length(cmps$isol) 129 | if (isTRUE(ni > 1) == TRUE) { 130 | nds[, 1] <- (nds[, 1] - min(nds[, 1]))/(max(nds[, 1]) - 131 | min(nds[, 1])) 132 | ifelse(isTRUE(rat > 0) == TRUE, nds[, 2] <- ((nds[, 2] - 133 | min(nds[, 2]))/(max(nds[, 2]) - min(nds[, 2]))) * 134 | (1L/rat), nds[, 2] <- ((nds[, 2] - min(nds[, 2]))/(max(nds[, 135 | 2]) - min(nds[, 2]))) * (rat)) 136 | nds <- as.matrix((nds)) 137 | ndst <- nds[which(nds[, 1] != 0), ] 138 | tmpi <- popl(ni, seed = seed) * (ni/10L) 139 | if (is.null(cmps$com) == FALSE) { 140 | lcx <- ((tmpi[, 1]) - (min(ndst[, 1]))) 141 | ifelse(isTRUE(rat > 0) == TRUE, lcy <- ((min(ndst[, 142 | 2])) - abs(tmpi[, 2]) - 0), lcy <- ((max(ndst[, 143 | 2])) + abs(tmpi[, 2]) + 0)) 144 | ndst.chull <- grDevices::chull(ndst) 145 | ndst.chull <- ndst[ndst.chull, ] 146 | ifelse(isTRUE(length(which(ndst.chull[, 1] < mean(ndst.chull[, 147 | 1]))) > length(which(ndst.chull[, 1] > mean(ndst.chull[, 148 | 1])))) == TRUE, lcx <- lcx + abs(K * 0.5), lcx <- lcx * 149 | -1) 150 | ifelse(isTRUE(length(which(ndst.chull[, 2] < mean(ndst.chull[, 151 | 2]))) > length(which(ndst.chull[, 2] > mean(ndst.chull[, 152 | 2])))) == TRUE, lcy <- lcy - abs(K * 0.5), lcy <- lcy * 153 | -1) 154 | } 155 | else { 156 | lcx <- (tmpi[, 1]) 157 | lcy <- (tmpi[, 2]) 158 | } 159 | nds[which(lbs %in% cmps$isol), ] <- cbind(lcx, lcy) 160 | } 161 | else if (isTRUE(ni == 1L) == TRUE) { 162 | ndst <- nds[which(nds[, 1] != 0), ] 163 | lcx <- max(ndst[, 1]) + (K/(n - 1L)) 164 | ifelse(isTRUE(rat < 0) == TRUE, lcy <- max(ndst[, 2]) + 165 | (K/(n - 1L)), lcy <- min(ndst[, 2]) - (K/(n - 1L))) 166 | nds[which(lbs %in% cmps$isol), ] <- (cbind(lcx, lcy)) * 167 | K 168 | } 169 | nds[, 2] <- nds[, 2] * -1 170 | if (missing(scl) == FALSE) { 171 | nds[, 1] <- nds[, 1] * scl[1] 172 | nds[, 2] <- nds[, 2] * scl[2] 173 | } 174 | if (missing(mov) == FALSE) { 175 | nds[, 1] <- nds[, 1] + mov[1] 176 | nds[, 2] <- nds[, 2] + mov[2] 177 | } 178 | as.data.frame(nds) 179 | } 180 | -------------------------------------------------------------------------------- /R/hc.R: -------------------------------------------------------------------------------- 1 | hc <- 2 | function (x, y, r, nsteps = 900, ...) 3 | { 4 | rs <- seq(-0.75, pi * 1.25, len = nsteps) 5 | xc <- x + r * cos(rs) 6 | yc <- y + r * sin(rs) 7 | hcr <- data.frame(x = xc, y = yc) 8 | graphics::lines(hcr[, 1], hcr[, 2], ...) 9 | graphics::par(new = FALSE) 10 | } 11 | -------------------------------------------------------------------------------- /R/lz.R: -------------------------------------------------------------------------------- 1 | lz <- 2 | function (x, delta, w) 3 | { 4 | ifelse(missing(delta) == TRUE, delta <- matrix(1, nrow(x), 5 | nrow(x)), NA) 6 | L <- matrix(0, nrow = attr(w, "Size"), ncol = attr(w, "Size")) 7 | for (i in 1:nrow(x)) { 8 | D <- 0 9 | for (j in 1:nrow(x)) { 10 | if (isTRUE(i != j) == TRUE) { 11 | nrmz <- norm(x[i, ] - x[j, ], type = "2") 12 | delt <- as.matrix(w)[i, j] * as.matrix(delta)[i, 13 | j] 14 | L[i, j] <- ((-delt)/nrmz) 15 | D <- D - ((-delt)/nrmz) 16 | } 17 | else { 18 | nrmz <- 0 19 | } 20 | } 21 | rm(j) 22 | L[i, i] <- D 23 | } 24 | rm(i) 25 | L[which(L == Inf)] <- 0 26 | L 27 | } 28 | -------------------------------------------------------------------------------- /R/mbnd.R: -------------------------------------------------------------------------------- 1 | mbnd <- 2 | function (pares, r, b, vlt, cx, lwd, ecol, directed, bw, alfa, 3 | fds, flgcx, weighted, flgcr, hds, n) 4 | { 5 | ifelse(isTRUE(nrow(pares) > 2L) == TRUE, pares <- pares[c(1, 6 | nrow(pares)), ], NA) 7 | ifelse(isTRUE(ncol(pares) > 2L) == TRUE, pares <- pares[, 8 | 1:2], NA) 9 | angp <- atan2((pares[2, 2] - pares[1, 2]), (pares[2, 1] - 10 | pares[1, 1])) * (180L/pi) 11 | if (isTRUE(pares[1, 1] != 0L | pares[1, 2] != 0L) == TRUE) { 12 | xo <- 0L - pares[1, 1] 13 | yo <- 0L - pares[1, 2] 14 | orig <- pares 15 | orig[, 1] <- pares[, 1] + xo 16 | orig[, 2] <- pares[, 2] + yo 17 | orot <- xyrtb(orig, (0L - angp)) 18 | } 19 | else if (isTRUE(pares[1, 1] != 0L | pares[1, 2] != 0L) == 20 | FALSE) { 21 | orot <- xyrtb(pares, (0L - angp)) 22 | } 23 | angx <- abs(angp) 24 | if (isTRUE(angx >= 360L) == TRUE) { 25 | agx <- angx%%360L 26 | } 27 | else { 28 | if (isTRUE(angx >= 270L) == TRUE) { 29 | gx <- abs(90L + (angx%%270L)) 30 | } 31 | else if (isTRUE(angx > 180L) == TRUE) { 32 | ifelse(isTRUE(angx > 180L) == TRUE, lx <- abs(180L - 33 | (angx%%180L)), lx <- angx%%180L) 34 | gx <- abs(90L - (lx%%90L)) 35 | } 36 | else { 37 | ifelse(isTRUE(angx > 180L) == TRUE, gx <- abs(180L - 38 | (x%%180L)), gx <- angx%%180L) 39 | } 40 | ifelse(isTRUE(gx >= 90L) == TRUE, agx <- abs(90L - (gx%%90L)), 41 | agx <- gx%%90L) 42 | } 43 | if (isTRUE(weighted == FALSE) == TRUE) { 44 | if (isTRUE(mean(lwd) < 6L) == TRUE) { 45 | fds <- fds - (mean(lwd) * 4) 46 | } 47 | else if (isTRUE(mean(lwd) > 15L) == TRUE) { 48 | fds <- fds - (mean(lwd) * 2) 49 | } 50 | else { 51 | fds <- fds - (mean(lwd) * 2.5) 52 | } 53 | } 54 | ifelse(isTRUE(weighted == TRUE) == TRUE && isTRUE(mean(cx) < 55 | 2L) == TRUE, cx <- cx + (2L - mean(cx)), NA) 56 | d <- (rng(r) * ((bw * 1000L) * ((2L^(abs(sin(angp * (pi/180L)))))/1200L)) * 57 | (mean(cx)/2L)) * ((30L + (agx * (6L/45L) * -1L))/100L) 58 | orott <- orot 59 | if (isTRUE(flgcx == TRUE) == TRUE) { 60 | orott[1, 1] <- (cx[1]/(fds - 0)) - orot[1, 1] 61 | orott[2, 1] <- orot[2, 1] - (cx[2]/(fds)) 62 | } 63 | else if (isTRUE(flgcx == FALSE) == TRUE) { 64 | ifelse(isTRUE(weighted == TRUE) == TRUE && isTRUE(mean(lwd) > 65 | 2L) == TRUE, lc <- (max(lwd) * 0.1), lc <- 0) 66 | orott[1, 1] <- ((cx[1] + lc)/(fds - 0)) - orot[1, 1] 67 | orott[2, 1] <- orot[2, 1] - ((cx[1] + lc)/fds) 68 | } 69 | lst <- array(0L, dim = c(2, 2, r)) 70 | dat <- data.frame(matrix(nrow = 0L, ncol = 2L)) 71 | for (j in 1:r) { 72 | lst[, 1, j] <- orott[, 1] 73 | lst[, 2, j] <- d[j] 74 | dat[(nrow(dat) + 1L):(nrow(dat) + 2L), ] <- lst[, , j] 75 | } 76 | rm(j) 77 | rrot <- xyrt(dat, as.numeric(angp)) 78 | if (isTRUE(pares[1, 1] != 0L | pares[1, 2] != 0L) == TRUE) { 79 | rrot[, 1] <- rrot[, 1] - xo 80 | rrot[, 2] <- rrot[, 2] - yo 81 | } 82 | for (i in 1:r) { 83 | if (isTRUE(weighted == TRUE) == TRUE && isTRUE(directed == 84 | TRUE) == TRUE) { 85 | if (isTRUE(b[i] %in% multiplex::men(b)[1]) == TRUE) { 86 | graphics::arrows(rrot[which(seq_len(nrow(dat))%%2L == 87 | 1L)[i], 1], rrot[which(seq_len(nrow(dat))%%2L == 88 | 1L)[i], 2], rrot[which(seq_len(nrow(dat))%%2L == 89 | 0L)[i], 1], rrot[which(seq_len(nrow(dat))%%2L == 90 | 0L)[i], 2], code = 2, length = 0, angle = 0, 91 | lty = vlt[i], lwd = lwd[i], col = grDevices::adjustcolor(ecol[i], 92 | alpha = alfa)) 93 | } 94 | else if (isTRUE(b[i] %in% multiplex::men(b)[1]) == 95 | FALSE) { 96 | graphics::arrows(rrot[which(seq_len(nrow(dat))%%2L == 97 | 1L)[i], 1], rrot[which(seq_len(nrow(dat))%%2L == 98 | 1L)[i], 2], rrot[which(seq_len(nrow(dat))%%2L == 99 | 0L)[i], 1], rrot[which(seq_len(nrow(dat))%%2L == 100 | 0L)[i], 2], code = 1, length = 0, angle = 0, 101 | lty = vlt[i], lwd = lwd[i], col = grDevices::adjustcolor(ecol[i], 102 | alpha = alfa)) 103 | } 104 | } 105 | else { 106 | graphics::segments(rrot[which(seq_len(nrow(dat))%%2L == 107 | 1L)[i], 1], rrot[which(seq_len(nrow(dat))%%2L == 108 | 1L)[i], 2], rrot[which(seq_len(nrow(dat))%%2L == 109 | 0L)[i], 1], rrot[which(seq_len(nrow(dat))%%2L == 110 | 0L)[i], 2], lty = vlt[i], lwd = lwd[i], col = grDevices::adjustcolor(ecol[i], 111 | alpha = alfa)) 112 | } 113 | if (isTRUE(directed == TRUE) == TRUE) { 114 | if (isTRUE(n < 15) == TRUE) { 115 | Hd <- data.frame(x = c((-0.6 - (0.01538462 * 116 | n)), (-0.35 - (0.01538462 * n)), (-0.6 - (0.01538462 * 117 | n)), (0.4 - (0.01538462 * n))), y = c(-0.5, 118 | 0, 0.5, 0)) * (hds) 119 | } 120 | else { 121 | Hd <- data.frame(x = c(-0.7, -0.45, -0.7, 0.3), 122 | y = c(-0.5, 0, 0.5, 0)) * (hds) 123 | } 124 | if (isTRUE(as.numeric(lwd[i]) < 7L) == TRUE) { 125 | ifelse(isTRUE(as.numeric(lwd[i]) <= 1L) == TRUE, 126 | Hd <- Hd * (as.numeric(lwd[i]))/((as.numeric(lwd[i]) * 127 | 8.571) + 30), Hd <- Hd * (as.numeric(lwd[i]))/((as.numeric(lwd[i]) * 128 | 8.571) + 40)) 129 | } 130 | else if (isTRUE(as.numeric(lwd[i]) >= 15L) == TRUE) { 131 | Hd <- Hd * (as.numeric(lwd[i]))/(as.numeric(lwd[i]) + 132 | 120L) 133 | } 134 | else { 135 | Hd <- Hd * (as.numeric(lwd[i]))/((as.numeric(lwd[i]) * 136 | 8.571) + 40) 137 | } 138 | if (isTRUE(i %in% flgcr) == TRUE) { 139 | prx1 <- rrot[which(seq_len(nrow(dat))%%2L == 140 | 1L)[i], 1] 141 | pry1 <- rrot[which(seq_len(nrow(dat))%%2L == 142 | 1L)[i], 2] 143 | hd1 <- xyrt((Hd), (as.numeric(angp) - 180L)) 144 | hd1[, 1] <- hd1[, 1] + prx1 145 | hd1[, 2] <- hd1[, 2] + pry1 146 | graphics::polygon((hd1), col = grDevices::adjustcolor(ecol[i], 147 | alpha = alfa), border = NA) 148 | prx2 <- rrot[which(seq_len(nrow(dat))%%2L == 149 | 0L)[i], 1] 150 | pry2 <- rrot[which(seq_len(nrow(dat))%%2L == 151 | 0L)[i], 2] 152 | hd2 <- xyrt(Hd, (as.numeric(angp) - 0L)) 153 | hd2[, 1] <- hd2[, 1] + prx2 154 | hd2[, 2] <- hd2[, 2] + pry2 155 | graphics::polygon((hd2), col = grDevices::adjustcolor(ecol[i], 156 | alpha = alfa), border = NA) 157 | } 158 | else { 159 | if (isTRUE(b[i] %in% multiplex::men(b)[1]) == 160 | FALSE) { 161 | prx <- rrot[which(seq_len(nrow(dat))%%2L == 162 | 1L)[i], 1] 163 | pry <- rrot[which(seq_len(nrow(dat))%%2L == 164 | 1L)[i], 2] 165 | hd <- xyrt((Hd), (as.numeric(angp) - 180L)) 166 | } 167 | else if (isTRUE(b[i] %in% multiplex::men(b)[1]) == 168 | TRUE) { 169 | prx <- rrot[which(seq_len(nrow(dat))%%2L == 170 | 0L)[i], 1] 171 | pry <- rrot[which(seq_len(nrow(dat))%%2L == 172 | 0L)[i], 2] 173 | hd <- xyrt(Hd, (as.numeric(angp) - 0L)) 174 | } 175 | hd[, 1] <- hd[, 1] + prx 176 | hd[, 2] <- hd[, 2] + pry 177 | graphics::polygon((hd), col = grDevices::adjustcolor(ecol[i], 178 | alpha = alfa), border = NA) 179 | } 180 | } 181 | else { 182 | NA 183 | } 184 | } 185 | rm(i) 186 | x <- NULL 187 | rm(x) 188 | graphics::par(new = FALSE) 189 | } 190 | -------------------------------------------------------------------------------- /R/mlgraph.R: -------------------------------------------------------------------------------- 1 | mlgraph <- 2 | function (net, layout = c("circ", "force", "stress", "rand", 3 | "conc", "bip"), main = NULL, seed = NULL, maxiter = 100, 4 | directed = TRUE, alpha = c(1, 1, 1), scope, collRecip, undRecip, 5 | showLbs, showAtts, cex.main, coord, clu, cex, lwd, pch, lty, 6 | bwd, bwd2, att, bg, mar, pos, asp, ecol, vcol, vcol0, col, 7 | lbat, swp, loops, swp2, mirrorX, mirrorY, mirrorD, mirrorL, 8 | lbs, mirrorV, mirrorH, rot, hds, scl, vedist, ffamily, fstyle, 9 | fsize, fcol, valued, modes, elv, lng, nr, ...) 10 | { 11 | mlv <- net 12 | if (isTRUE("Multilevel" %in% attr(net, "class")) == TRUE) { 13 | if ("bpn" %in% attr(mlv, "class") || "cn2" %in% attr(mlv, 14 | "class")) { 15 | net <- mlv$mlnet[, , which(mlv$modes == "1M")] 16 | met <- mlv$mlnet[, , which(mlv$modes == "2M")] 17 | } 18 | else if ("cn" %in% attr(mlv, "class")) { 19 | met <- multiplex::dichot(mlv$mlnet, c = max(mlv$mlnet) + 20 | 1L) 21 | net <- mlv$mlnet 22 | } 23 | else { 24 | vcn <- vector() 25 | for (i in seq_len(length(mlv$mlnet))) { 26 | vcn <- append(vcn, dimnames(mlv$mlnet[[i]])[[1]]) 27 | vcn <- append(vcn, dimnames(mlv$mlnet[[i]])[[2]]) 28 | } 29 | rm(i) 30 | bmlbs <- unique(vcn) 31 | bmat <- multiplex::transf(mlv$mlnet[[1]], type = "toarray2", 32 | lbs = bmlbs) 33 | for (k in seq(from = 2, to = length(mlv$mlnet))) { 34 | bmat <- multiplex::zbnd(bmat, multiplex::transf(mlv$mlnet[[k]], 35 | type = "toarray2", lbs = bmlbs)) 36 | } 37 | rm(k) 38 | dimnames(bmat)[[1]] <- dimnames(bmat)[[2]] <- bmlbs 39 | dimnames(bmat)[[3]] <- attr(mlv$mlnet, "names") 40 | for (i in which(mlv$modes == "2M")) { 41 | bmat[, , i] <- bmat[, , i] + t(bmat[, , i]) 42 | } 43 | rm(i) 44 | net <- bmat[, , which(mlv$modes == "1M")] 45 | met <- bmat[, , which(mlv$modes == "2M")] 46 | } 47 | } 48 | else { 49 | if ((missing(modes) == FALSE && is.vector(modes) == TRUE) && 50 | (missing(clu) == FALSE && is.vector(clu) == TRUE)) { 51 | ifelse(is.numeric(modes) == TRUE, modes <- paste(modes, 52 | "M", sep = ""), NA) 53 | mlv <- list(mlnet = net, lbs = list(dm = dimnames(net)[[1]][which(clu == 54 | 1)], cdm = dimnames(net)[[1]][which(clu == 2)]), 55 | modes = modes) 56 | net <- mlv$mlnet[, , which(mlv$modes == "1M")] 57 | met <- mlv$mlnet[, , which(mlv$modes == "2M")] 58 | } 59 | else { 60 | stop("\"net\" should be of a \"Multilevel\" class object or at least a 3D array with clustering info.") 61 | } 62 | } 63 | ifelse(isTRUE(dim(net)[3] == 1) == TRUE, net <- net[, , 1], 64 | NA) 65 | ifelse(missing(valued) == FALSE && isTRUE(valued == TRUE) == 66 | TRUE, valued <- TRUE, valued <- FALSE) 67 | ifelse(missing(loops) == FALSE && isTRUE(loops == FALSE) == 68 | TRUE, loops <- FALSE, loops <- TRUE) 69 | ifelse(missing(collRecip) == FALSE && isTRUE(collRecip == 70 | FALSE) == TRUE, collRecip <- FALSE, collRecip <- TRUE) 71 | ifelse(missing(undRecip) == FALSE && isTRUE(undRecip == FALSE) == 72 | TRUE, undRecip <- FALSE, undRecip <- TRUE) 73 | ifelse(missing(mirrorH) == FALSE && isTRUE(mirrorH == TRUE) == 74 | TRUE, mirrorY <- TRUE, NA) 75 | ifelse(missing(mirrorV) == FALSE && isTRUE(mirrorV == TRUE) == 76 | TRUE, mirrorX <- TRUE, NA) 77 | if (missing(showLbs) == FALSE && isTRUE(showLbs == TRUE) == 78 | TRUE) { 79 | showLbs <- TRUE 80 | } 81 | else if (missing(showLbs) == FALSE && isTRUE(showLbs == FALSE) == 82 | TRUE) { 83 | showLbs <- FALSE 84 | } 85 | else { 86 | ifelse(is.null(dimnames(net)[[1]]) == FALSE, showLbs <- TRUE, 87 | showLbs <- FALSE) 88 | } 89 | ifelse(missing(showAtts) == FALSE && isTRUE(showAtts == FALSE) == 90 | TRUE, showAtts <- FALSE, showAtts <- TRUE) 91 | ifelse(missing(swp) == FALSE && isTRUE(swp == TRUE) == TRUE, 92 | swp <- TRUE, swp <- FALSE) 93 | ifelse(missing(swp2) == FALSE && isTRUE(swp2 == TRUE) == 94 | TRUE, swp2 <- TRUE, swp2 <- FALSE) 95 | ifelse(isTRUE(directed == FALSE) == TRUE, directed <- FALSE, 96 | NA) 97 | if (missing(scope) == FALSE) { 98 | if (isTRUE(is.list(scope) == TRUE) == FALSE) 99 | stop("\"scope\" should be a list or a vector of lists.") 100 | scope <- list(scope) 101 | ifelse(is.null(scope[[1]]) == TRUE, scope <- scope[2:length(scope)], 102 | NA) 103 | if (isTRUE(length(scope) > 1L) == TRUE && isTRUE(names(scope[1]) == 104 | "coord") == TRUE) { 105 | scope <- scope[rev(seq_len(length(scope)))] 106 | flgrev <- TRUE 107 | } 108 | else { 109 | flgrev <- FALSE 110 | } 111 | tmp <- scope[[1]] 112 | if (isTRUE(length(scope) > 1L) == TRUE && isTRUE(length(scope[[1]]) > 113 | 1L) == TRUE) { 114 | for (k in 2:length(scope)) { 115 | tmp[length(tmp) + 1L] <- as.list(scope[k]) 116 | names(tmp)[length(tmp)] <- attr(scope[k], "names") 117 | } 118 | rm(k) 119 | } 120 | else if (isTRUE(length(scope) > 1L) == TRUE) { 121 | names(tmp) <- attr(scope[1], "names") 122 | for (k in 2:length(scope)) { 123 | if (is.list(scope[[k]]) == TRUE && is.data.frame(scope[[k]]) == 124 | FALSE) { 125 | for (j in seq_len(length(scope[[k]]))) { 126 | tmp[length(tmp) + 1L] <- as.list(scope[[k]][j]) 127 | names(tmp)[length(tmp)] <- attr(scope[[k]][j], 128 | "names") 129 | } 130 | rm(j) 131 | } 132 | else if (is.data.frame(scope[[k]]) == FALSE) { 133 | tmp[length(tmp) + 1L] <- as.list(scope[k]) 134 | names(tmp)[length(tmp)] <- attr(scope[k], "names") 135 | } 136 | else if (is.data.frame(scope[[k]]) == TRUE) { 137 | tmp[length(tmp) + 1L] <- as.vector(scope[k]) 138 | names(tmp)[length(tmp)] <- attr(scope[k], "names") 139 | } 140 | else { 141 | NA 142 | } 143 | } 144 | rm(k) 145 | } 146 | else { 147 | tmp <- scope[[1]] 148 | } 149 | ifelse(isTRUE(flgrev == TRUE) == TRUE, scope <- tmp[rev(seq_len(length(tmp)))], 150 | scope <- tmp) 151 | for (i in seq_len(length(scope))) { 152 | if (isTRUE(names(scope)[i] %in% c("seed", "main")) == 153 | TRUE) { 154 | tmpi <- as.vector(scope[[i]]) 155 | assign(names(scope)[i], get("tmpi")) 156 | } 157 | else { 158 | if (is.null((scope[[i]])) == FALSE) { 159 | tmpi <- as.vector(scope[[i]]) 160 | ifelse(isTRUE(names(scope)[i] != "") == TRUE, 161 | assign(names(scope)[i], get("tmpi")), NA) 162 | } 163 | } 164 | } 165 | rm(i) 166 | } 167 | else { 168 | NA 169 | } 170 | ifelse(missing(lng) == TRUE, lng <- 50, NA) 171 | ifelse(isTRUE(lng <= 2) == TRUE, lng <- 3L, NA) 172 | if (missing(lwd) == TRUE) { 173 | flglwd <- FALSE 174 | lwd <- 1 175 | } 176 | else { 177 | flglwd <- TRUE 178 | } 179 | ifelse(missing(fcol) == TRUE, fcol <- 1, NA) 180 | if (missing(pch) == TRUE) { 181 | pch <- c(rep(21, length(mlv$lbs$dm)), rep(22, length(mlv$lbs$cdm))) 182 | ifelse(missing(vcol) == TRUE, vcol <- c("#FFFFFF", "#FFFFFF"), 183 | NA) 184 | ifelse(missing(vcol0) == TRUE, vcol0 <- c("#000000", 185 | "#000000"), NA) 186 | } 187 | else { 188 | ifelse(isTRUE(length(pch) == 2) == TRUE, pch <- c(rep(pch[1], 189 | length(mlv$lbs$dm)), rep(pch[2], length(mlv$lbs$cdm))), 190 | pch <- pch[seq_len(length(mlv$lbs$dm) + length(mlv$lbs$cdm))]) 191 | } 192 | ifelse(missing(bwd) == TRUE, bwd <- 1, NA) 193 | ifelse(isTRUE(bwd < 0L) == TRUE, bwd <- 0L, NA) 194 | ifelse(missing(bg) == TRUE, bg <- graphics::par()$bg, NA) 195 | ifelse(missing(cex.main) == TRUE, cex.main <- graphics::par()$cex.main, 196 | NA) 197 | ifelse(missing(rot) == TRUE, NA, rot <- rot[1] * -1) 198 | if (isTRUE(length(alpha) < 2) == TRUE) { 199 | alfa <- 1 200 | alpha <- rep(alpha, 3) 201 | } 202 | else { 203 | alfa <- alpha[2] 204 | } 205 | if (isTRUE(length(alpha) < 3) == TRUE) 206 | alpha <- append(alpha, 0.1) 207 | if (!(missing(hds)) && missing(scl) == TRUE) { 208 | if (isTRUE(hds > 1L) == TRUE) { 209 | hds <- (hds/1.5) 210 | } 211 | else if (isTRUE(hds < 1L) == TRUE) { 212 | hds <- (hds/(hds + 0.15)) 213 | } 214 | else if (isTRUE(hds == 0L) == TRUE) { 215 | hds <- 0.01 216 | } 217 | else { 218 | NA 219 | } 220 | } 221 | else { 222 | ifelse(missing(scl) == TRUE, hds <- 1L, hds <- 1L * scl) 223 | } 224 | ifelse(isTRUE(dim(net)[1] > 8) == TRUE || isTRUE(valued == 225 | TRUE) == TRUE || isTRUE(min(lwd) >= 4) == TRUE, hds <- hds * 226 | 0.75, NA) 227 | ifelse(missing(scl) == TRUE, scl <- rep(1, 2), NA) 228 | ifelse(isTRUE(length(scl) == 1) == TRUE, scl <- rep(scl, 229 | 2), scl <- scl[1:2]) 230 | ifelse(missing(vedist) == TRUE, vedist <- 0, NA) 231 | ifelse(isTRUE(vedist > 1L) == TRUE, vedist <- 1L, NA) 232 | n <- dim(net)[1] 233 | ifelse(isTRUE(is.na(dim(net)[3]) == TRUE) == TRUE, z <- 1L, 234 | z <- dim(net)[3]) 235 | if (missing(lbs) == TRUE) { 236 | ifelse(is.null(dimnames(net)[[1]]) == TRUE, lbs <- as.character(seq_len(dim(net)[1])), 237 | lbs <- dimnames(net)[[1]]) 238 | } 239 | else { 240 | NA 241 | } 242 | ifelse(isTRUE(swp == TRUE) == TRUE && isTRUE(z > 1L) == TRUE, 243 | net <- net[, , rev(seq_len(z))], NA) 244 | if (missing(att) == FALSE && is.array(att) == TRUE) { 245 | if (isTRUE(n != dim(att)[1]) == TRUE) { 246 | warning("Dimensions in \"net\" and \"att\" differ. No attributes are shown.") 247 | showAtts <- FALSE 248 | } 249 | } 250 | netd <- multiplex::dichot(net, c = 1L) 251 | if (isTRUE(directed == FALSE) == TRUE && isTRUE(collRecip == 252 | TRUE) == TRUE && isTRUE(valued == TRUE) == TRUE) { 253 | if (isTRUE(z == 1L) == TRUE) { 254 | net <- net + t(net) 255 | } 256 | else { 257 | for (i in seq_len(z)) { 258 | net[, , i] <- net[, , i] + t(net[, , i]) 259 | } 260 | rm(i) 261 | } 262 | } 263 | else { 264 | NA 265 | } 266 | if (isTRUE(collRecip == TRUE) == TRUE && isTRUE(valued == 267 | TRUE) == FALSE) { 268 | if (isTRUE(z == 1L) == TRUE) { 269 | nt <- netd + t(netd) 270 | rcp <- multiplex::dichot(nt, c = 2L) 271 | rcp[lower.tri(rcp, diag = TRUE)] <- 0L 272 | } 273 | else { 274 | nt <- array(0L, dim = c(n, n, z)) 275 | dimnames(nt)[[1]] <- dimnames(nt)[[2]] <- lbs 276 | dimnames(nt)[[3]] <- dimnames(net)[[3]] 277 | for (i in seq_len(z)) { 278 | nt[, , i] <- netd[, , i] + t(netd[, , i]) 279 | } 280 | rm(i) 281 | rcp <- multiplex::dichot(nt, c = 2L) 282 | for (i in seq_len(z)) { 283 | rcp[, , i][lower.tri(rcp[, , i], diag = TRUE)] <- 0L 284 | } 285 | rm(i) 286 | } 287 | ucnet <- netd - rcp 288 | } 289 | else { 290 | ucnet <- netd 291 | } 292 | if (isTRUE(collRecip == TRUE) == TRUE) { 293 | bd <- multiplex::bundles(ucnet, loops = loops, lb2lb = FALSE, 294 | collapse = FALSE) 295 | ifelse(isTRUE(directed == TRUE) == FALSE, NA, bd$recp <- multiplex::bundles(netd, 296 | loops = loops, lb2lb = FALSE, collapse = FALSE)$recp) 297 | } 298 | else { 299 | bd <- multiplex::bundles(netd, loops = loops, lb2lb = FALSE, 300 | collapse = FALSE) 301 | } 302 | ifelse(isTRUE(z == 1L) == TRUE, r <- 1L, r <- length(bd[[1]])) 303 | ifelse(isTRUE(sum(net) == 0) == TRUE && isTRUE(loops == TRUE) == 304 | TRUE, bd$loop <- character(0), NA) 305 | bds <- multiplex::summaryBundles(bd, byties = TRUE) 306 | m <- dim(met)[1] 307 | ifelse(is.na(dim(met)[3]) == TRUE, zz <- 1L, zz <- dim(met)[3]) 308 | if (isTRUE(zz == 1L) == TRUE) { 309 | mt <- met + t(met) 310 | rcpm <- multiplex::dichot(mt, c = 1L) 311 | rcpm[lower.tri(rcpm, diag = TRUE)] <- 0L 312 | } 313 | else { 314 | mt <- array(0L, dim = c(m, m, zz)) 315 | dimnames(mt)[[1]] <- dimnames(mt)[[2]] <- lbs 316 | dimnames(mt)[[3]] <- dimnames(met)[[3]] 317 | for (i in seq_len(zz)) { 318 | mt[, , i] <- met[, , i] + t(met[, , i]) 319 | } 320 | rm(i) 321 | rcpm <- multiplex::dichot(mt, c = 2L) 322 | for (i in seq_len(zz)) { 323 | rcpm[, , i][lower.tri(rcpm[, , i], diag = TRUE)] <- 0L 324 | } 325 | rm(i) 326 | } 327 | bdm <- multiplex::bundles(met, loops = FALSE, lb2lb = FALSE, 328 | collapse = FALSE) 329 | bdsm <- multiplex::summaryBundles(bdm, byties = TRUE) 330 | ifelse(isTRUE(zz == 1L) == TRUE, rr <- 1L, rr <- length(bdm[[1]])) 331 | ifelse(missing(ecol) == TRUE, ecol <- grDevices::gray.colors(r, 332 | start = 0.1, end = 0.5), NA) 333 | ifelse(missing(ecol) == FALSE && isTRUE(length(ecol) == 2) == 334 | TRUE, ecol <- c(rep(ecol[1], length(which(mlv$modes == 335 | "1M"))), rep(ecol[2], length(which(mlv$modes == "2M")))), 336 | NA) 337 | ifelse(isTRUE(ecol == 0) == TRUE, ecol <- "#FFFFFF", NA) 338 | if (isTRUE(valued == TRUE) == TRUE) { 339 | ifelse(missing(lty) == TRUE, lty <- rep(1, r + rr), NA) 340 | } 341 | else { 342 | ifelse(missing(lty) == TRUE, lty <- seq_len(r + rr), 343 | NA) 344 | } 345 | if (isTRUE((z + zz) == 1L) == TRUE) { 346 | Lt <- lty[1] 347 | vecol <- ecol[1] 348 | } 349 | else { 350 | ifelse(isTRUE(length(ecol) == 1L) == TRUE, vecol <- rep(ecol, 351 | z + zz), vecol <- rep(ecol, z + zz)[seq_len(z + zz)]) 352 | ifelse(isTRUE(length(lty) == 1L) == TRUE, Lt <- rep(lty, 353 | r + rr), Lt <- rep(lty, r + rr)[seq_len(r + rr)]) 354 | if (isTRUE(length(lty) == length(Lt)) == FALSE) { 355 | Ltc <- seq_along(vecol) 356 | } 357 | else { 358 | if (isTRUE(seq(lty) == lty) == TRUE) { 359 | Ltc <- Lt 360 | } 361 | else { 362 | ifelse(isTRUE(swp == TRUE) == TRUE && isTRUE(valued == 363 | TRUE) == FALSE, Ltc <- rev(seq_len(r + rr)), 364 | Ltc <- seq_len(r + rr)) 365 | } 366 | } 367 | } 368 | vltz <- Lt 369 | if (missing(clu) == FALSE) { 370 | if (any(unlist(lapply(clu, is.null))) == TRUE) { 371 | ifelse(unlist(lapply(clu, is.null))[1] == TRUE, clu[[1]] <- rep(1L, 372 | nrow(net)), NA) 373 | ifelse(unlist(lapply(clu, is.null))[2] == TRUE, clu[[2]] <- rep(1L, 374 | ncol(net)), NA) 375 | } 376 | else { 377 | NA 378 | } 379 | if ("cn2" %in% attr(mlv, "class")) { 380 | clu <- clu[[1]] 381 | } 382 | else { 383 | NA 384 | } 385 | if (is.list(clu) == TRUE) { 386 | ifelse(is.factor(clu[[1]]) == TRUE, uact <- levels(clu[[1]]), 387 | uact <- unique(clu[[1]])) 388 | ifelse(is.factor(clu[[2]]) == TRUE, uevt <- levels(clu[[2]]), 389 | uevt <- unique(clu[[2]])) 390 | clutmp <- clu 391 | if (is.character(uact) == TRUE) { 392 | tmpa <- as.vector(clu[[1]]) 393 | for (i in seq_len(length(uact))) { 394 | tmpa[which(tmpa == uact[i])] <- i 395 | } 396 | rm(i) 397 | clu[[1]] <- as.numeric(tmpa) 398 | rm(tmpa) 399 | } 400 | if (is.character(uevt) == TRUE) { 401 | tmpe <- as.vector(clu[[2]]) 402 | for (i in seq_len(length(uevt))) { 403 | tmpe[which(tmpe == uevt[i])] <- i 404 | } 405 | rm(i) 406 | clu[[2]] <- as.numeric(tmpe) 407 | rm(tmpe) 408 | } 409 | if (any(clutmp[[2]] %in% clutmp[[1]]) == TRUE) { 410 | k <- 0L 411 | tmp2 <- clutmp[[2]] 412 | while (any(tmp2 %in% clutmp[[1]]) == TRUE) { 413 | tmp2 <- replace(tmp2, which(tmp2 == min(tmp2)), 414 | (max(clutmp[[1]]) + k)) 415 | k <- k + 1L 416 | } 417 | clutmp[[2]] <- tmp2 418 | rm(tmp2) 419 | clu <- as.vector(unlist(clutmp)) 420 | } 421 | else if (any(clu[[2]] %in% clu[[1]]) == TRUE) { 422 | k <- 0L 423 | tmp2 <- clu[[2]] 424 | while (any(tmp2 %in% clu[[1]]) == TRUE) { 425 | tmp2 <- replace(tmp2, which(tmp2 == min(tmp2)), 426 | (max(clu[[1]]) + k)) 427 | k <- k + 1L 428 | } 429 | clu[[2]] <- tmp2 430 | rm(tmp2) 431 | clu <- as.vector(unlist(clu)) 432 | } 433 | } 434 | else { 435 | NA 436 | } 437 | nclu <- nlevels(factor(clu)) 438 | } 439 | else { 440 | nclu <- 1L 441 | } 442 | flgcx <- FALSE 443 | if (missing(cex) == TRUE && isTRUE(loops == FALSE) == TRUE) { 444 | if (isTRUE(length(bds) == 0) == TRUE) { 445 | cex <- 1L 446 | } 447 | else { 448 | cex <- length(bds[[1]])/2L 449 | if (isTRUE(length(bds) > 1L) == TRUE) { 450 | for (i in 2:length(bds)) ifelse(isTRUE(cex < 451 | (length(bds[[i]])/2L)) == TRUE, cex <- (length(bds[[i]])/2L), 452 | NA) 453 | } 454 | cex <- ceiling(cex) 455 | } 456 | } 457 | else if (missing(cex) == TRUE) { 458 | cex <- 1L 459 | } 460 | if (isTRUE(length(cex) == 1L) == TRUE) { 461 | cex <- rep(cex, n) 462 | } 463 | else { 464 | if (is.vector(cex) == FALSE) 465 | stop("\"cex\" must be a vector") 466 | cex[which(is.na(cex))] <- 0 467 | cex <- cex[seq_len(n)] 468 | flgcx <- TRUE 469 | } 470 | if (isTRUE(flgcx == TRUE) == TRUE && isTRUE(max(cex) > 10L) == 471 | TRUE) { 472 | if (isTRUE(mean(cex) > 20L) == TRUE) { 473 | cex <- (((cex - min(cex))/(max(cex) - min(cex))) * 474 | 10L) 475 | } 476 | else { 477 | cex <- (cex/(norm(as.matrix(cex), type = "M"))) * 478 | 10L 479 | } 480 | ifelse(isTRUE(min(cex) == 0) == TRUE, cex <- cex + 1L + 481 | (2L/n), NA) 482 | } 483 | else if (isTRUE(flgcx == FALSE) == TRUE && isTRUE(valued == 484 | TRUE) == TRUE) { 485 | ifelse(isTRUE(max(cex) >= 21L) == TRUE, cex <- 20L, NA) 486 | } 487 | else { 488 | NA 489 | } 490 | if (missing(fsize) == TRUE) { 491 | ifelse(isTRUE(max(cex) < 2) == TRUE, fsize <- cex * 0.66, 492 | fsize <- cex * 0.33) 493 | } 494 | else { 495 | fsize <- fsize/10 496 | } 497 | ifelse(isTRUE(valued == FALSE) == TRUE && isTRUE(bwd > 1L) == 498 | TRUE, bwd <- 1L, NA) 499 | ifelse(isTRUE(max(cex) < 2) == TRUE, NA, bwd <- bwd * 0.75) 500 | if (isTRUE(length(pch) == 1L) == TRUE) { 501 | pch <- rep(pch, n) 502 | } 503 | else if (isTRUE(length(pch) == nclu) == TRUE) { 504 | if (identical(pch, clu) == FALSE) { 505 | tmppch <- rep(0, n) 506 | for (i in seq_len(nclu)) { 507 | tmppch[which(clu == (levels(factor(clu))[i]))] <- pch[i] 508 | } 509 | rm(i) 510 | pch <- tmppch 511 | rm(tmppch) 512 | } 513 | } 514 | else if (isTRUE(length(pch) != n) == TRUE) { 515 | pch <- rep(pch[1], n) 516 | } 517 | if (missing(vcol) == TRUE) { 518 | vcol <- grDevices::gray.colors(nclu) 519 | ifelse(missing(col) == TRUE, NA, vcol <- col) 520 | } 521 | else { 522 | if (isTRUE(length(vcol) == 1L) == TRUE) { 523 | vcol <- rep(vcol, n) 524 | } 525 | else if (isTRUE(length(vcol) == nclu) == TRUE) { 526 | if (identical(vcol, clu) == FALSE) { 527 | tmpvcol <- rep(0, n) 528 | for (i in seq_len(nclu)) { 529 | tmpvcol[which(clu == (levels(factor(clu))[i]))] <- vcol[i] 530 | } 531 | rm(i) 532 | vcol <- tmpvcol 533 | rm(tmpvcol) 534 | } 535 | } 536 | else if (isTRUE(length(vcol) != n) == TRUE & isTRUE(nclu == 537 | 1) == TRUE) { 538 | vcol <- rep(vcol[1], n) 539 | } 540 | vcol[which(is.na(vcol))] <- graphics::par()$bg 541 | vcol[which(vcol == 0)] <- graphics::par()$bg 542 | } 543 | if (isTRUE(any(pch %in% 21:25)) == TRUE) { 544 | if (missing(vcol0) == TRUE) { 545 | vcol0 <- vcol 546 | } 547 | else { 548 | ifelse(missing(vcol0) == TRUE, NA, vcol0[which(is.na(vcol0))] <- 1) 549 | } 550 | if (isTRUE(length(vcol0) == 1L) == TRUE) { 551 | vcol0 <- rep(vcol0, n) 552 | } 553 | else if (isTRUE(length(vcol0) == nclu) == TRUE) { 554 | if (identical(vcol0, clu) == FALSE) { 555 | tmpvcol0 <- rep(0, n) 556 | for (i in seq_len(nclu)) { 557 | tmpvcol0[which(clu == (levels(factor(clu))[i]))] <- vcol0[i] 558 | } 559 | rm(i) 560 | vcol0 <- tmpvcol0 561 | rm(tmpvcol0) 562 | } 563 | } 564 | else if (isTRUE(length(vcol0) != n) == TRUE | isTRUE(nclu == 565 | 1) == TRUE) { 566 | vcol0 <- rep(vcol0[1], n) 567 | } 568 | } 569 | else { 570 | vcol0 <- vcol 571 | } 572 | ifelse(isTRUE(n > 20) == TRUE, ffds <- 0.2, ffds <- 0) 573 | fds <- 180L - (n * ffds) 574 | if (isTRUE(flgcx == TRUE) == TRUE) { 575 | fds <- fds - 10L 576 | } 577 | else if (isTRUE(flgcx == FALSE) == TRUE) { 578 | NA 579 | } 580 | if (isTRUE(max(scl) < 1) == TRUE) { 581 | fds <- fds - (1/(mean(scl)/30L)) 582 | } 583 | else if (isTRUE(max(scl) > 1) == TRUE) { 584 | fds <- fds + (mean(scl) * 20L) 585 | } 586 | else { 587 | NA 588 | } 589 | if (missing(coord) == FALSE) { 590 | if (isTRUE(nrow(coord) == n) == FALSE) 591 | stop("Length of \"coord\" does not match network order.") 592 | flgcrd <- TRUE 593 | crd <- coord 594 | } 595 | else if (missing(coord) == TRUE) { 596 | flgcrd <- FALSE 597 | switch(match.arg(layout), force = { 598 | crd <- frcd(zbnd(netd, met), seed = seed, maxiter = maxiter) 599 | }, circ = { 600 | crd <- data.frame(X = sin(2L * pi * ((0:(n - 1L))/n)), 601 | Y = cos(2L * pi * ((0:(n - 1L))/n))) 602 | }, stress = { 603 | crd <- stsm(zbnd(netd, met), seed = seed, maxiter = maxiter, 604 | ...) 605 | }, rand = { 606 | set.seed(seed) 607 | crd <- data.frame(X = round(stats::runif(n) * 1L, 608 | 5), Y = round(stats::runif(n) * 1L, 5)) 609 | }, conc = { 610 | ifelse(is.null(nr) == TRUE, nr <- c(rep(1L, length(mlv$lbs$dm)), 611 | rep(2L, length(mlv$lbs$cdm))), NA) 612 | crd <- conc(netd, nr, ...) 613 | }, bip = { 614 | act <- nrm(rng(length(mlv$lbs$dm))) 615 | evt <- nrm(rng(length(mlv$lbs$cdm))) 616 | Act <- cbind(rep(0, length(mlv$lbs$dm)), act) 617 | Evt <- cbind(rep(1, length(mlv$lbs$cdm)), evt) 618 | crd <- rbind(Act, Evt) 619 | crd[which(is.nan(crd))] <- 0.5 620 | crd[, 2] <- crd[, 2] * cos(pi) - crd[, 1] * sin(pi) 621 | rownames(crd) <- lbs 622 | fds <- fds - 30L 623 | }) 624 | } 625 | if (match.arg(layout) == "bip") { 626 | ifelse(missing(asp) == TRUE, asp <- 2L, asp <- asp[1] * 627 | 2L) 628 | } 629 | else { 630 | ifelse(missing(asp) == TRUE, asp <- 1, NA) 631 | } 632 | if (missing(rot) == FALSE) { 633 | crd[, 1:2] <- xyrt(crd[, 1:2], as.numeric(rot)) 634 | crd[, 1:2] <- crd[, 1:2] - min(crd[, 1:2]) 635 | cnt <- 1L 636 | ifelse(isTRUE(n == 2) == TRUE && isTRUE(rot == -90) == 637 | TRUE, rot <- -89.9, NA) 638 | } 639 | else { 640 | cnt <- 0 641 | } 642 | if (isTRUE(flgcrd == FALSE) == TRUE) { 643 | if (match.arg(layout) == "circ" && missing(pos) == TRUE) { 644 | angl <- vector() 645 | length(angl) <- n 646 | for (i in seq_len(n)) { 647 | ifelse((atan2((crd[i, 2] - cnt), (crd[i, 1] - 648 | cnt)) * (180L/pi)) >= 0, angl[i] <- atan2((crd[i, 649 | 2] - cnt), (crd[i, 1] - cnt)) * (180L/pi), 650 | angl[i] <- ((atan2((crd[i, 2] - cnt), (crd[i, 651 | 1] - cnt)) * (180L/pi))%%180L) + 180L) 652 | } 653 | rm(i) 654 | pos <- vector() 655 | for (i in seq_len(length(angl))) { 656 | if (isTRUE(65 < angl[i]) == TRUE && isTRUE(115 > 657 | angl[i]) == TRUE) { 658 | pos <- append(pos, 3) 659 | } 660 | else if (isTRUE(115 <= angl[i]) == TRUE && isTRUE(245 >= 661 | angl[i]) == TRUE) { 662 | pos <- append(pos, 2) 663 | } 664 | else if (isTRUE(245 < angl[i]) == TRUE && isTRUE(295 > 665 | angl[i]) == TRUE) { 666 | pos <- append(pos, 1) 667 | } 668 | else { 669 | pos <- append(pos, 4) 670 | } 671 | } 672 | rm(i) 673 | } 674 | } 675 | if (missing(pos) == TRUE) { 676 | pos <- 4 677 | } 678 | else { 679 | if (isTRUE(pos < 0L) == TRUE | isTRUE(pos > 4L) == TRUE) 680 | stop("Invalid \"pos\" value.") 681 | } 682 | ifelse(missing(mirrorX) == FALSE && isTRUE(mirrorX == TRUE) == 683 | TRUE || missing(mirrorV) == FALSE && isTRUE(mirrorV == 684 | TRUE) == TRUE, crd[, 1] <- crd[, 1] * cos(pi) - crd[, 685 | 2] * sin(pi), mirrorX <- FALSE) 686 | ifelse(missing(mirrorY) == FALSE && isTRUE(mirrorY == TRUE) == 687 | TRUE || missing(mirrorH) == FALSE && isTRUE(mirrorH == 688 | TRUE) == TRUE, crd[, 2] <- crd[, 2] * cos(pi) - crd[, 689 | 1] * sin(pi), mirrorY <- FALSE) 690 | if (match.arg(layout) == "circ" && isTRUE(flgcrd == FALSE) == 691 | TRUE) { 692 | if (isTRUE(mirrorX == TRUE) == TRUE && isTRUE(length(pos) == 693 | n) == TRUE) { 694 | pos[which(pos == 2)] <- 0 695 | pos[which(pos == 4)] <- 2 696 | pos[which(pos == 0)] <- 4 697 | } 698 | else if (isTRUE(mirrorY == TRUE) == TRUE && isTRUE(length(pos) == 699 | n) == TRUE) { 700 | pos[which(pos == 1)] <- 0 701 | pos[which(pos == 3)] <- 1 702 | pos[which(pos == 0)] <- 3 703 | } 704 | else { 705 | NA 706 | } 707 | } 708 | if (missing(mirrorL) == FALSE && isTRUE(mirrorL == TRUE) == 709 | TRUE) { 710 | crd[, 1:2] <- xyrt(crd[, 1:2], as.numeric(45)) 711 | crd[, 1:2] <- crd[, 1:2] - min(crd[, 1:2]) 712 | crd[, 2] <- crd[, 2] * cos(pi) - crd[, 1] * sin(pi) 713 | crd[, 1:2] <- xyrt(crd[, 1:2], as.numeric(-45)) 714 | crd[, 1:2] <- crd[, 1:2] - min(crd[, 1:2]) 715 | } 716 | else if (missing(mirrorD) == FALSE && isTRUE(mirrorD == TRUE) == 717 | TRUE) { 718 | crd[, 1:2] <- xyrt(crd[, 1:2], as.numeric(-45)) 719 | crd[, 1:2] <- crd[, 1:2] - min(crd[, 1:2]) 720 | crd[, 2] <- crd[, 2] * cos(pi) - crd[, 1] * sin(pi) 721 | crd[, 1:2] <- xyrt(crd[, 1:2], as.numeric(45)) 722 | crd[, 1:2] <- crd[, 1:2] - min(crd[, 1:2]) 723 | } 724 | else { 725 | NA 726 | } 727 | if (isTRUE(n > 1) == TRUE) { 728 | rat <- (max(crd[, 1]) - min(crd[, 1]))/(max(crd[, 2]) - 729 | min(crd[, 2])) 730 | crd[, 1] <- (crd[, 1] - min(crd[, 1]))/(max(crd[, 1]) - 731 | min(crd[, 1])) 732 | ifelse(isTRUE(rat > 0) == TRUE, crd[, 2] <- ((crd[, 2] - 733 | min(crd[, 2]))/(max(crd[, 2]) - min(crd[, 2]))) * 734 | (1L/rat), crd[, 2] <- ((crd[, 2] - min(crd[, 2]))/(max(crd[, 735 | 2]) - min(crd[, 2]))) * (rat)) 736 | } 737 | else { 738 | NA 739 | } 740 | fds <- fds + (vedist * -10) 741 | if (isTRUE(flgcrd == TRUE) == TRUE && isTRUE(ncol(crd) > 742 | 2) == TRUE) { 743 | lbgml <- tolower(as.vector(crd[, 3])) 744 | lbnet <- tolower(as.vector(lbs)) 745 | lbp <- vector() 746 | for (i in seq_len(nrow(crd))) { 747 | lbp <- append(lbp, which(lbnet[i] == lbgml)) 748 | } 749 | rm(i) 750 | if (isTRUE(ncol(crd) > 3) == TRUE) { 751 | atgml <- as.vector(crd[, 4]) 752 | atgml[which(is.na(atgml))] <- "" 753 | atts <- atgml[lbp] 754 | } 755 | nds <- data.frame(X = as.numeric(as.vector(crd[lbp, 1])), 756 | Y = as.numeric(as.vector(crd[lbp, 2]))) 757 | } 758 | else { 759 | nds <- data.frame(X = as.numeric(as.vector(crd[, 1])), 760 | Y = as.numeric(as.vector(crd[, 2]))) 761 | } 762 | nds <- ((2L/max(nds * (0.75))) * (nds * 0.75)) * (0.5) 763 | mscl <- mean(scl) 764 | cex <- cex * mscl 765 | fsize <- fsize * mscl 766 | omr <- graphics::par()$mar 767 | omi <- graphics::par()$mai 768 | if (missing(mar) == TRUE) { 769 | mar <- c(0, 0, 0, 0) 770 | } 771 | else { 772 | mar <- omr 773 | } 774 | ifelse(is.null(main) == TRUE, graphics::par(mar = mar), graphics::par(mar = mar + 775 | c(0, 0, cex.main, 0))) 776 | obg <- graphics::par()$bg 777 | graphics::par(bg = grDevices::adjustcolor(bg, alpha = alpha[3])) 778 | if (isTRUE(loops == TRUE) == TRUE) { 779 | ylim <- c(min(nds[, 2]) - ((cex[1])/200L), max(nds[, 780 | 2]) + ((cex[1])/200L)) 781 | xlim <- c(min(nds[, 1]) - ((cex[1])/200L), max(nds[, 782 | 1]) + ((cex[1])/200L)) 783 | } 784 | else if (isTRUE(flgcx == TRUE) == TRUE) { 785 | ylim <- c(min(nds[, 2]) - (max(cex)/500L), max(nds[, 786 | 2]) + (max(cex)/500L)) 787 | xlim <- c(min(nds[, 1]) - (max(cex)/500L), max(nds[, 788 | 1]) + (max(cex)/500L)) 789 | } 790 | else { 791 | ylim <- c(min(nds[, 2]) - ((cex[1])/200L), max(nds[, 792 | 2]) + ((cex[1])/200L)) 793 | xlim <- c(min(nds[, 1]) - ((cex[1])/200L), max(nds[, 794 | 1]) + ((cex[1])/200L)) 795 | } 796 | suppressWarnings(graphics::plot(nds, type = "n", axes = FALSE, 797 | xlab = "", ylab = "", ylim = ylim, xlim = xlim, asp = asp, 798 | main = main, cex.main = cex.main, ...)) 799 | tlbs <- vector() 800 | if (isTRUE(length(bds) > 0) == TRUE) { 801 | for (i in seq_len(length(attr(bds, "names")))) { 802 | ifelse(isTRUE(length(multiplex::dhc(attr(bds, "names")[i], 803 | sep = "")) > 4L) == TRUE, tlbs <- append(tlbs, 804 | tolower(paste(multiplex::dhc(attr(bds, "names")[i], 805 | sep = "")[1:4], collapse = ""))), tlbs <- append(tlbs, 806 | tolower(attr(bds, "names"))[i])) 807 | } 808 | rm(i) 809 | } 810 | tlbsm <- vector() 811 | if (isTRUE(length(bdsm) > 0) == TRUE) { 812 | for (i in seq_len(length(attr(bdsm, "names")))) { 813 | ifelse(isTRUE(length(multiplex::dhc(attr(bdsm, "names")[i], 814 | sep = "")) > 4L) == TRUE, tlbsm <- append(tlbsm, 815 | tolower(paste(multiplex::dhc(attr(bdsm, "names")[i], 816 | sep = "")[1:4], collapse = ""))), tlbsm <- append(tlbsm, 817 | tolower(attr(bdsm, "names"))[i])) 818 | } 819 | rm(i) 820 | } 821 | trcpm <- multiplex::transf(rcpm, type = "tolist") 822 | netdrp <- net 823 | ifelse(isTRUE(valued == TRUE) == TRUE && isTRUE(max(net) > 824 | 10L) == TRUE, fnnetdrp <- (norm(as.matrix(netdrp), type = "F")), 825 | NA) 826 | cx <- cex 827 | if (isTRUE(swp == TRUE) == TRUE) { 828 | Lt <- Lt[rev(seq_len(length(Lt)))] 829 | lwd <- lwd[length(lwd):1] 830 | ifelse(isTRUE(valued == TRUE) == TRUE, vecol <- vecol[rev(seq_len(length(vecol[seq_len(z)])))], 831 | NA) 832 | alfa <- alfa[rev(seq_len(length(alfa)))] 833 | } 834 | if (isTRUE(loops == TRUE) == TRUE && isTRUE(valued == TRUE) == 835 | TRUE && isTRUE(max(netdrp) > 10L) == TRUE) { 836 | if (isTRUE(z == 1L) == TRUE) { 837 | diag(netdrp) <- (diag(netdrp)/fnnetdrp) * (15L) 838 | } 839 | else { 840 | for (i in seq_len(z)) { 841 | diag(netdrp[, , i]) <- as.vector((diag(netdrp[, 842 | , i])/fnnetdrp) * (15L)) 843 | } 844 | } 845 | } 846 | else { 847 | NA 848 | } 849 | if (isTRUE(loops == TRUE) == TRUE) { 850 | tlbslp <- tlbs 851 | tlbs <- tlbs[which(tlbs != "loop")] 852 | } 853 | else { 854 | NA 855 | } 856 | if ((isTRUE(collRecip == TRUE) == TRUE && isTRUE(c("recp") %in% 857 | attr(bds, "names")) == TRUE) && isTRUE(valued == TRUE) == 858 | FALSE) { 859 | trcp <- multiplex::transf(rcp, type = "tolist") 860 | } 861 | else { 862 | NA 863 | } 864 | if (isTRUE(length(c(tlbs, tlbsm)) > 0) == TRUE) { 865 | for (k in seq_len(length(tlbsm))) { 866 | prs <- as.numeric(multiplex::dhc(bdsm[[k]])) 867 | pars <- as.matrix(nds[as.numeric(levels(factor(multiplex::dhc(bdsm[[k]])))), 868 | ]) 869 | rbdsm <- length(bdsm[[k]]) 870 | if (isTRUE(rbdsm > 0L) == TRUE) { 871 | qn <- which(tlbsm[k] == attr(bdm, "names")) 872 | if (isTRUE(zz == 1L) == TRUE) { 873 | ifelse(isTRUE(length(lty) == 1) == TRUE, vlt <- rep(Lt, 874 | rbdsm), vlt <- rep(Lt[zz + 1], rbdsm)) 875 | ifelse(isTRUE(length(ecol) == 1L) == TRUE, 876 | vecolm <- rep(ecol[1], rbdsm), vecolm <- rep(ecol[z + 877 | 1], rbdsm)) 878 | tbnd <- as.vector(unlist(bdm[qn])) 879 | if (isTRUE(length(tbnd) > 0L) == TRUE) { 880 | ifelse(isTRUE(any(tbnd %in% bdsm[[k]])) == 881 | TRUE, vlt <- append(vlt, rep(Lt, qn)), 882 | NA) 883 | ifelse(isTRUE(any(tbnd %in% bdsm[[k]])) == 884 | TRUE, vltz <- append(vltz, rep(Lt, qn)), 885 | NA) 886 | } 887 | vltc <- vlt[1] 888 | } 889 | else if (isTRUE(zz > 1L) == TRUE) { 890 | vlt <- vector() 891 | for (i in seq_along(Lt)) { 892 | tbnd <- as.vector(unlist(bdm[[qn]][i])) 893 | if (isTRUE(length(tbnd) > 0L) == TRUE) { 894 | ifelse(isTRUE(any(tbnd %in% bdsm[[k]])) == 895 | TRUE, vlt <- append(vlt, rep(Lt[(z + 896 | 1):length(Lt)][i], length(which(tbnd %in% 897 | bdsm[[k]])))), NA) 898 | ifelse(isTRUE(any(tbnd %in% bdsm[[k]])) == 899 | TRUE, vltz <- append(vltz, rep(Lt[(z + 900 | 1):length(Lt)][i], length(which(tbnd %in% 901 | bdsm[[k]])))), NA) 902 | } 903 | } 904 | rm(i) 905 | if (isTRUE(length(lty) == 1L) == TRUE) { 906 | vlt1 <- rep(lty, length(vlt)) 907 | vltc <- vlt 908 | } 909 | else { 910 | vltc <- vector() 911 | if (isTRUE(Lt == Ltc) == FALSE) { 912 | for (i in seq_along(Ltc)) { 913 | tbnd <- as.vector(unlist(bdm[[qn]][i])) 914 | if (isTRUE(length(tbnd) > 0L) == TRUE) { 915 | ifelse(isTRUE(any(tbnd %in% bdsm[[k]])) == 916 | TRUE, vltc <- append(vltc, rep(Ltc[(z + 917 | 1):length(Ltc)][i], length(which(tbnd %in% 918 | bdsm[[k]])))), NA) 919 | } 920 | } 921 | rm(i) 922 | } 923 | else { 924 | if (isTRUE(seq(lty) == lty) == TRUE) { 925 | vltc <- vlt 926 | } 927 | else { 928 | for (i in seq_along(lty)) { 929 | vltc <- append(vltc, replace(vlt[which(vlt == 930 | Lt[i])], vlt[which(vlt == Lt[i])] != 931 | i, i)) 932 | } 933 | rm(i) 934 | } 935 | } 936 | } 937 | } 938 | ifelse(isTRUE(swp2 == TRUE) == TRUE && isTRUE(tlbsm[k] %in% 939 | c("recp")) == TRUE, bdsm[[k]] <- multiplex::swp(bdsm[[k]]), 940 | NA) 941 | if (isTRUE(valued == TRUE) == TRUE) { 942 | Lw <- vector() 943 | i <- 1 944 | for (j in seq_len(length(bdsm[[k]]))) { 945 | qn <- c(prs[i], prs[(i + 1)]) 946 | ifelse(isTRUE(z == 1L) == TRUE, Lw <- append(Lw, 947 | met[qn[1], qn[2]]), Lw <- append(Lw, met[qn[1], 948 | qn[2]] + t(met[qn[1], qn[2]]))) 949 | i <- i + 2L 950 | } 951 | rm(j) 952 | rm(i) 953 | if (isTRUE(max(met) > 10L) == TRUE) { 954 | lw <- (Lw/fnnetdrp) * (10L * 5L) 955 | } 956 | else { 957 | lw <- Lw 958 | } 959 | } 960 | else if (isTRUE(valued == TRUE) == FALSE) { 961 | ifelse(isTRUE(length(bdsm) == 0) == TRUE, NA, 962 | lw <- rep(lwd[1], rbdsm)) 963 | } 964 | lwdfct <- (lw + (1L/lw)) * mscl 965 | if (isTRUE(collRecip == TRUE) == TRUE && isTRUE(tlbsm[k] %in% 966 | c("recp")) == TRUE) { 967 | bw <- 0L 968 | hd <- 0L 969 | ifelse(isTRUE(valued == TRUE) == TRUE, lw <- lwdfct * 970 | 1L, lw <- lwdfct * 2L) 971 | } 972 | else if (isTRUE(collRecip == TRUE) == FALSE && 973 | isTRUE(tlbsm[k] %in% c("recp")) == TRUE) { 974 | bw <- bwd 975 | hd <- hds 976 | } 977 | else { 978 | bw <- bwd 979 | hd <- 0 980 | lw <- lwdfct 981 | } 982 | ifelse(isTRUE(directed == FALSE) == TRUE, hd <- 0L, 983 | NA) 984 | ifelse(isTRUE(flglwd == TRUE) == TRUE, lw <- rep(lwd[1], 985 | rbdsm), NA) 986 | if (isTRUE(collRecip == TRUE) == TRUE && isTRUE(tlbsm[k] %in% 987 | c("recp")) == FALSE) { 988 | flgcr <- numeric() 989 | sbdsm <- multiplex::swp(bdsm[[k]]) 990 | if (any(sbdsm %in% unlist(trcpm)) == TRUE) { 991 | for (i in seq_len(zz)) { 992 | ifelse(any(sbdsm %in% trcpm[[i]]) == TRUE, 993 | flgcr <- append(flgcr, as.numeric(i)), 994 | NA) 995 | } 996 | rm(i) 997 | } 998 | } 999 | else { 1000 | flgcr <- rep(0L, zz) 1001 | } 1002 | pars[, 1] <- pars[, 1] * scl[1] 1003 | pars[, 2] <- pars[, 2] * scl[2] 1004 | if (isTRUE(zz == 1L) == TRUE) { 1005 | ccbnd(pars, rbdsm, bdsm[[k]], vlt, cx * mscl, 1006 | lw, vecolm, bw, alfa, fds, flgcx, flgcr, 1007 | hd, m) 1008 | } 1009 | else { 1010 | ifelse(isTRUE(length(lty) == 1L) == TRUE, ccbnd(pars, 1011 | rbdsm, bdsm[[k]], vlt1, cx * mscl, lw, vecol[vltc], 1012 | bw, alfa, fds, flgcx, flgcr, hd, m), ccbnd(pars, 1013 | rbdsm, bdsm[[k]], vlt, cx * mscl, lw, vecol[vltc], 1014 | bw, alfa, fds, flgcx, flgcr, hd, m)) 1015 | } 1016 | } 1017 | else { 1018 | NA 1019 | } 1020 | } 1021 | rm(k) 1022 | for (k in seq_len(length(tlbs))) { 1023 | prs <- as.numeric(multiplex::dhc(bds[[k]])) 1024 | pars <- as.matrix(nds[as.numeric(levels(factor(multiplex::dhc(bds[[k]])))), 1025 | ]) 1026 | rbds <- length(bds[[k]]) 1027 | if (isTRUE(rbds > 0L) == TRUE) { 1028 | qn <- which(tlbs[k] == attr(bd, "names")) 1029 | if (isTRUE(z == 1L) == TRUE) { 1030 | vlt <- rep(Lt, rbds) 1031 | vecol <- rep(ecol[1], rbds) 1032 | tbnd <- as.vector(unlist(bd[qn])) 1033 | if (isTRUE(length(tbnd) > 0L) == TRUE) { 1034 | ifelse(isTRUE(any(tbnd %in% bds[[k]])) == 1035 | TRUE, vlt <- append(vlt, rep(Lt, qn)), 1036 | NA) 1037 | ifelse(isTRUE(any(tbnd %in% bds[[k]])) == 1038 | TRUE, vltz <- append(vltz, rep(Lt, qn)), 1039 | NA) 1040 | } 1041 | vltc <- vlt[1] 1042 | } 1043 | else if (isTRUE(z > 1L) == TRUE) { 1044 | vlt <- vector() 1045 | for (i in seq_along(Lt)) { 1046 | tbnd <- as.vector(unlist(bd[[qn]][i])) 1047 | if (isTRUE(length(tbnd) > 0L) == TRUE) { 1048 | ifelse(isTRUE(any(tbnd %in% bds[[k]])) == 1049 | TRUE, vlt <- append(vlt, rep(Lt[i], length(which(tbnd %in% 1050 | bds[[k]])))), NA) 1051 | ifelse(isTRUE(any(tbnd %in% bds[[k]])) == 1052 | TRUE, vltz <- append(vltz, rep(Lt[i], 1053 | length(which(tbnd %in% bds[[k]])))), 1054 | NA) 1055 | } 1056 | } 1057 | rm(i) 1058 | if (isTRUE(length(lty) == 1L) == TRUE) { 1059 | vlt1 <- rep(Lt, length(vlt)) 1060 | vltc <- vlt 1061 | } 1062 | else { 1063 | vltc <- vector() 1064 | if (isTRUE(Lt == Ltc) == FALSE) { 1065 | for (i in seq_along(Ltc)) { 1066 | tbnd <- as.vector(unlist(bd[[qn]][i])) 1067 | if (isTRUE(length(tbnd) > 0L) == TRUE) { 1068 | ifelse(isTRUE(any(tbnd %in% bds[[k]])) == 1069 | TRUE, vltc <- append(vltc, rep(Ltc[i], 1070 | length(which(tbnd %in% bds[[k]])))), 1071 | NA) 1072 | } 1073 | } 1074 | rm(i) 1075 | } 1076 | else { 1077 | if (isTRUE(seq(lty) == lty) == TRUE) { 1078 | vltc <- vlt 1079 | } 1080 | else { 1081 | for (i in seq_along(lty)) { 1082 | vltc <- append(vltc, replace(vlt[which(vlt == 1083 | Lt[i])], vlt[which(vlt == Lt[i])] != 1084 | i, i)) 1085 | } 1086 | rm(i) 1087 | } 1088 | } 1089 | } 1090 | } 1091 | if (isTRUE(flgcx == TRUE) == FALSE) { 1092 | cx <- rep(cex[1], 2) 1093 | } 1094 | if (isTRUE(valued == TRUE) == TRUE) { 1095 | Lw <- vector() 1096 | i <- 1 1097 | for (j in seq_len(length(bds[[k]]))) { 1098 | qn <- c(prs[i], prs[(i + 1)]) 1099 | if (isTRUE(collRecip == TRUE) == TRUE) { 1100 | ifelse(isTRUE(z == 1L) == TRUE, Lw <- append(Lw, 1101 | netdrp[qn[1], qn[2]]), Lw <- append(Lw, 1102 | netdrp[qn[1], qn[2], vltc[j]] + t(netdrp[qn[1], 1103 | qn[2], vltc[j]]))) 1104 | } 1105 | else if (isTRUE(collRecip == FALSE) == TRUE) { 1106 | ifelse(isTRUE(z == 1L) == TRUE, Lw <- append(Lw, 1107 | netdrp[qn[1], qn[2]]), Lw <- append(Lw, 1108 | netdrp[qn[1], qn[2], vltc[j]])) 1109 | } 1110 | i <- i + 2L 1111 | } 1112 | if (isTRUE(max(netdrp) > 10L) == TRUE) { 1113 | lw <- (Lw/fnnetdrp) * (10L * 3L) 1114 | } 1115 | else { 1116 | lw <- Lw 1117 | } 1118 | } 1119 | else if (isTRUE(valued == TRUE) == FALSE) { 1120 | ifelse(isTRUE(length(bds) == 0) == TRUE, NA, 1121 | lw <- rep(lwd[1], rbds)) 1122 | } 1123 | ifelse(isTRUE(swp2 == TRUE) == TRUE && isTRUE(tlbs[k] %in% 1124 | c("recp")) == TRUE, bds[[k]] <- multiplex::swp(bds[[k]]), 1125 | NA) 1126 | ifelse(isTRUE(flglwd == TRUE) == TRUE, lw <- rep(lwd[1], 1127 | rbds), NA) 1128 | if (isTRUE(collRecip == TRUE) == TRUE && isTRUE(tlbs[k] %in% 1129 | c("recp")) == TRUE) { 1130 | bw <- 0L 1131 | hd <- hds 1132 | lw <- lw * mscl 1133 | } 1134 | else if (isTRUE(collRecip == TRUE) == FALSE && 1135 | isTRUE(tlbs[k] %in% c("recp")) == TRUE) { 1136 | hd <- hds 1137 | } 1138 | else { 1139 | bw <- bwd 1140 | hd <- hds 1141 | lw <- lw * mscl 1142 | } 1143 | ifelse("cn" %in% attr(mlv, "class") && isTRUE(undRecip == 1144 | TRUE) == TRUE, hd <- 0L, NA) 1145 | ifelse(isTRUE(directed == FALSE) == TRUE, hd <- 0L, 1146 | NA) 1147 | if (isTRUE(collRecip == TRUE) == TRUE && isTRUE(tlbs[k] %in% 1148 | c("recp")) == FALSE && isTRUE(valued == TRUE) == 1149 | FALSE && isTRUE(c("recp") %in% attr(bds, "names")) == 1150 | TRUE) { 1151 | flgcr <- numeric() 1152 | sbds <- multiplex::swp(bds[[k]]) 1153 | if (any(sbds %in% unlist(trcp)) == TRUE) { 1154 | for (i in seq_len(z)) { 1155 | ifelse(any(sbds %in% trcp[[i]]) == TRUE, 1156 | flgcr <- append(flgcr, as.numeric(i)), 1157 | NA) 1158 | } 1159 | rm(i) 1160 | } 1161 | } 1162 | else { 1163 | flgcr <- rep(0L, z) 1164 | } 1165 | pars[, 1] <- pars[, 1] * scl[1] 1166 | pars[, 2] <- pars[, 2] * scl[2] 1167 | if (match.arg(layout) == "bip") { 1168 | if (missing(elv) == TRUE) { 1169 | elv <- 0.25 1170 | } 1171 | else { 1172 | ifelse(isTRUE(elv > 1L) == TRUE, elv <- 1L, 1173 | NA) 1174 | } 1175 | bzrc((pars), cex = cx, lty = vlt, col = vecol[vltc], 1176 | lwd = lw, elv = elv, ...) 1177 | } 1178 | else { 1179 | if (isTRUE(z == 1L) == TRUE) { 1180 | ccbnd(pars, rbds, bds[[k]], vlt, cx * mscl, 1181 | lw, vecol, bw, alfa, fds, flgcx, flgcr, 1182 | hd, n) 1183 | } 1184 | else { 1185 | ifelse(isTRUE(length(lty) == 1L) == TRUE, 1186 | ccbnd(pars, rbds, bds[[k]], vlt1, cx * 1187 | mscl, lw, vecol[vltc], bw, alfa, fds, 1188 | flgcx, flgcr, hd, n), ccbnd(pars, rbds, 1189 | bds[[k]], vlt, cx * mscl, lw, vecol[vltc], 1190 | bw, alfa, fds, flgcx, flgcr, hd, n)) 1191 | } 1192 | } 1193 | } 1194 | else { 1195 | NA 1196 | } 1197 | } 1198 | rm(k) 1199 | } 1200 | else { 1201 | NA 1202 | } 1203 | if (isTRUE(loops == TRUE) == TRUE) { 1204 | if (isTRUE(swp == TRUE) == TRUE) { 1205 | bdlp <- bd$loop[rev(seq_len(length(bd$loop)))] 1206 | if (isTRUE(valued == TRUE) == FALSE) { 1207 | NA 1208 | } 1209 | else { 1210 | vecol <- vecol[rev(seq_len(length(vecol)))] 1211 | netdrpl <- netdrp[, , rev(seq_len(dim(netdrp)[3]))] 1212 | } 1213 | } 1214 | else { 1215 | bdlp <- bd$loop 1216 | ifelse(isTRUE(valued == TRUE) == TRUE, netdrpl <- netdrp, 1217 | NA) 1218 | } 1219 | dz <- (rng(z) + abs(min(rng(z))))/(10L) 1220 | ndss <- nds 1221 | ndss[, 1] <- ndss[, 1] * scl[1] 1222 | ndss[, 2] <- ndss[, 2] * scl[2] 1223 | if (isTRUE(z == 1L) == TRUE) { 1224 | lp <- as.vector(which(diag(net) > 0)) 1225 | if (isTRUE(length(lp) > 0) == TRUE) { 1226 | for (i in seq_len(length(lp))) { 1227 | if (isTRUE(n < 3) == TRUE) { 1228 | dcx <- (cex[lp[i]] * 0.0075) 1229 | lpsz <- (cex[lp[i]] * 0.005) - (dz) 1230 | } 1231 | else { 1232 | dcx <- (cex[lp[i]] * 0.01) 1233 | lpsz <- (cex[lp[i]] * 0.0075) - (dz) 1234 | } 1235 | hc(ndss[lp[i], 1], ndss[lp[i], 2] + (dcx), 1236 | lpsz, col = vecol, lty = Lt, lwd = lwd) 1237 | } 1238 | rm(i) 1239 | } 1240 | else { 1241 | NA 1242 | } 1243 | } 1244 | else if (isTRUE(z > 1) == TRUE) { 1245 | if (missing(bwd2) == TRUE) { 1246 | bwd2 <- 1L 1247 | } 1248 | else if (missing(bwd2) == FALSE) { 1249 | if (isTRUE(bwd2 < 1L) == TRUE && isTRUE(bwd2 == 1250 | 0) == FALSE) { 1251 | bwd2 <- 1L 1252 | } 1253 | else if (isTRUE(bwd2 > 10L) == TRUE) { 1254 | bwd2 <- 10L 1255 | } 1256 | if (isTRUE(bwd2 == 0) == TRUE) { 1257 | dz <- rep(0, z) 1258 | } 1259 | else { 1260 | ifelse(isTRUE(valued == TRUE) == TRUE && isTRUE(max(net) > 1261 | 1L) == TRUE, dz <- (bwd2 * 1L) * (rng(z) + 1262 | abs(min(rng(z))))/(5L), dz <- (bwd2 * 1L) * 1263 | (rng(z) + abs(min(rng(z))))/(10L)) 1264 | } 1265 | } 1266 | ifelse(isTRUE(length(lwd) == 1) == TRUE, lwd <- rep(lwd, 1267 | z), NA) 1268 | for (k in seq_len(length(bdlp))) { 1269 | lp <- as.numeric(unique(multiplex::dhc(bdlp)[k][[1]])) 1270 | if (isTRUE(length(lp) > 0) == TRUE) { 1271 | for (i in seq_len(length(lp))) { 1272 | ifelse(isTRUE(cex[lp[i]] <= 3L) == TRUE | 1273 | isTRUE(n < 3) == TRUE, dz <- dz * 0.75, 1274 | NA) 1275 | if (isTRUE(n < 3) == TRUE) { 1276 | dcx <- cex[lp[i]]/110L 1277 | lpsz <- abs((cex[lp[i]] * 0.007) - dz[k]) 1278 | } 1279 | else { 1280 | dcx <- cex[lp[i]]/100L 1281 | lpsz <- abs((cex[lp[i]] * 0.0075) - dz[k]) 1282 | } 1283 | ifelse(isTRUE(length(lty) == 1) == TRUE, 1284 | Ltl <- rep(lty, length(bdlp)), Ltl <- Lt) 1285 | ifelse(isTRUE(valued == TRUE) == TRUE, hc(ndss[lp[i], 1286 | 1], ndss[lp[i], 2] + (dcx), lpsz, col = grDevices::adjustcolor(vecol[k], 1287 | alpha = alfa), lty = Ltl[k], lwd = netdrpl[i, 1288 | i, k]), hc(ndss[lp[i], 1], ndss[lp[i], 1289 | 2] + (dcx), lpsz, col = grDevices::adjustcolor(vecol[k], 1290 | alpha = alfa), lty = Ltl[k], lwd = lwd[k])) 1291 | hc(ndss[lp[i], 1], ndss[lp[i], 2] + (dcx), 1292 | lpsz, col = grDevices::adjustcolor(vecol[k], 1293 | alpha = alfa), lty = Lt[k], lwd = lwd[k]) 1294 | } 1295 | rm(i) 1296 | } 1297 | else { 1298 | dz <- append(0, dz) 1299 | } 1300 | } 1301 | rm(k) 1302 | } 1303 | } 1304 | else { 1305 | NA 1306 | } 1307 | if (all(pch %in% 21:25) == TRUE) { 1308 | graphics::points(nds[, 1] * scl[1], nds[, 2] * scl[2], 1309 | pch = pch, cex = cex, col = grDevices::adjustcolor(vcol0, 1310 | alpha = alpha[1]), bg = grDevices::adjustcolor(vcol, 1311 | alpha = alpha[1])) 1312 | } 1313 | else { 1314 | graphics::points(nds[, 1] * scl[1], nds[, 2] * scl[2], 1315 | pch = pch, cex = cex, col = grDevices::adjustcolor(vcol, 1316 | alpha = alpha[1]), bg = grDevices::adjustcolor(vcol, 1317 | alpha = alpha[1])) 1318 | } 1319 | if (isTRUE(showLbs == TRUE) == TRUE) { 1320 | ndss <- nds 1321 | ndss[, 1] <- ndss[, 1] * scl[1] 1322 | ndss[, 2] <- ndss[, 2] * scl[2] 1323 | ifelse(missing(ffamily) == FALSE && isTRUE(ffamily %in% 1324 | names(grDevices::postscriptFonts())) == TRUE, graphics::par(family = ffamily), 1325 | NA) 1326 | if (isTRUE(length(pos) == 1) == TRUE) { 1327 | if (isTRUE(pos == 0) == TRUE) { 1328 | if (missing(fstyle) == TRUE || (missing(fstyle) == 1329 | FALSE && isTRUE(fstyle %in% c("italic", "bold", 1330 | "bolditalic") == FALSE))) { 1331 | graphics::text(ndss, labels = lbs, cex = fsize, 1332 | adj = 0.5, col = fcol) 1333 | } 1334 | else if (missing(fstyle) == FALSE) { 1335 | if (isTRUE(fstyle == "italic") == TRUE) { 1336 | graphics::text(ndss, labels = as.expression(lapply(lbs, 1337 | function(x) bquote(italic(.(x))))), cex = fsize, 1338 | adj = 0.5, col = fcol) 1339 | } 1340 | else if (isTRUE(fstyle == "bold") == TRUE) { 1341 | graphics::text(ndss, labels = as.expression(lapply(lbs, 1342 | function(x) bquote(bold(.(x))))), cex = fsize, 1343 | adj = 0.5, col = fcol) 1344 | } 1345 | else if (isTRUE(fstyle == "bolditalic") == 1346 | TRUE) { 1347 | graphics::text(ndss, labels = as.expression(lapply(lbs, 1348 | function(x) bquote(bolditalic(.(x))))), 1349 | cex = fsize, adj = 0.5, col = fcol) 1350 | } 1351 | } 1352 | } 1353 | else { 1354 | if (missing(fstyle) == TRUE || (missing(fstyle) == 1355 | FALSE && isTRUE(fstyle %in% c("italic", "bold", 1356 | "bolditalic") == FALSE))) { 1357 | graphics::text(ndss, lbs, cex = fsize, pos = pos, 1358 | col = fcol, offset = (cex/4L), adj = c(0.5, 1359 | 1)) 1360 | } 1361 | else if (missing(fstyle) == FALSE) { 1362 | if (isTRUE(fstyle == "italic") == TRUE) { 1363 | graphics::text(ndss, as.expression(lapply(lbs, 1364 | function(x) bquote(italic(.(x))))), cex = fsize, 1365 | pos = pos, col = fcol, offset = (cex/4L), 1366 | adj = c(0.5, 1)) 1367 | } 1368 | else if (isTRUE(fstyle == "bold") == TRUE) { 1369 | graphics::text(ndss, as.expression(lapply(lbs, 1370 | function(x) bquote(bold(.(x))))), cex = fsize, 1371 | pos = pos, col = fcol, offset = (cex/4L), 1372 | adj = c(0.5, 1)) 1373 | } 1374 | else if (isTRUE(fstyle == "bolditalic") == 1375 | TRUE) { 1376 | graphics::text(ndss, as.expression(lapply(lbs, 1377 | function(x) bquote(bolditalic(.(x))))), 1378 | cex = fsize, pos = pos, col = fcol, offset = (cex/4L), 1379 | adj = c(0.5, 1)) 1380 | } 1381 | } 1382 | } 1383 | } 1384 | else if (isTRUE(length(pos) == n) == TRUE) { 1385 | if (missing(fstyle) == TRUE || (missing(fstyle) == 1386 | FALSE && isTRUE(fstyle %in% c("italic", "bold", 1387 | "bolditalic") == FALSE))) { 1388 | graphics::text(ndss, lbs, cex = fsize, pos = pos, 1389 | col = fcol[1], offset = (cex/4L), adj = c(0.5, 1390 | 1)) 1391 | } 1392 | else if (missing(fstyle) == FALSE) { 1393 | if (isTRUE(fstyle == "italic") == TRUE) { 1394 | graphics::text(ndss, as.expression(lapply(lbs, 1395 | function(x) bquote(italic(.(x))))), cex = fsize, 1396 | pos = pos, col = fcol[1], offset = (cex/4L), 1397 | adj = c(0.5, 1)) 1398 | } 1399 | else if (isTRUE(fstyle == "bold") == TRUE) { 1400 | graphics::text(ndss, as.expression(lapply(lbs, 1401 | function(x) bquote(bold(.(x))))), cex = fsize, 1402 | pos = pos, col = fcol[1], offset = (cex/4L), 1403 | adj = c(0.5, 1)) 1404 | } 1405 | else if (isTRUE(fstyle == "bolditalic") == TRUE) { 1406 | graphics::text(ndss, as.expression(lapply(lbs, 1407 | function(x) bquote(bolditalic(.(x))))), cex = fsize, 1408 | pos = pos, col = fcol[1], offset = (cex/4L), 1409 | adj = c(0.5, 1)) 1410 | } 1411 | } 1412 | } 1413 | else { 1414 | if (isTRUE(pos[1] == 0) == TRUE) { 1415 | if (missing(fstyle) == TRUE || (missing(fstyle) == 1416 | FALSE && isTRUE(fstyle %in% c("italic", "bold", 1417 | "bolditalic") == FALSE))) { 1418 | graphics::text(ndss, labels = lbs, cex = fsize, 1419 | adj = 0.5, col = fcol) 1420 | } 1421 | else if (missing(fstyle) == FALSE) { 1422 | if (isTRUE(fstyle == "italic") == TRUE) { 1423 | graphics::text(ndss, labels = as.expression(lapply(lbs, 1424 | function(x) bquote(italic(.(x))))), cex = fsize, 1425 | adj = 0.5, col = fcol) 1426 | } 1427 | else if (isTRUE(fstyle == "bold") == TRUE) { 1428 | graphics::text(ndss, labels = as.expression(lapply(lbs, 1429 | function(x) bquote(bold(.(x))))), cex = fsize, 1430 | adj = 0.5, col = fcol) 1431 | } 1432 | else if (isTRUE(fstyle == "bolditalic") == 1433 | TRUE) { 1434 | graphics::text(ndss, labels = as.expression(lapply(lbs, 1435 | function(x) bquote(bolditalic(.(x))))), 1436 | cex = fsize, adj = 0.5, col = fcol) 1437 | } 1438 | } 1439 | } 1440 | else { 1441 | if (missing(fstyle) == TRUE || (missing(fstyle) == 1442 | FALSE && isTRUE(fstyle %in% c("italic", "bold", 1443 | "bolditalic") == FALSE))) { 1444 | graphics::text(ndss, lbs, cex = fsize, pos = pos[1], 1445 | col = fcol, offset = (cex/4L), adj = c(0.5, 1446 | 1)) 1447 | } 1448 | else if (missing(fstyle) == FALSE) { 1449 | if (isTRUE(fstyle == "italic") == TRUE) { 1450 | graphics::text(ndss, as.expression(lapply(lbs, 1451 | function(x) bquote(italic(.(x))))), cex = fsize, 1452 | pos = pos[1], col = fcol, offset = (cex/4L), 1453 | adj = c(0.5, 1)) 1454 | } 1455 | else if (isTRUE(fstyle == "bold") == TRUE) { 1456 | graphics::text(ndss, as.expression(lapply(lbs, 1457 | function(x) bquote(bold(.(x))))), cex = fsize, 1458 | pos = pos[1], col = fcol, offset = (cex/4L), 1459 | adj = c(0.5, 1)) 1460 | } 1461 | else if (isTRUE(fstyle == "bolditalic") == 1462 | TRUE) { 1463 | graphics::text(ndss, as.expression(lapply(lbs, 1464 | function(x) bquote(bolditalic(.(x))))), 1465 | cex = fsize, pos = pos[1], col = fcol, 1466 | offset = (cex/4L), adj = c(0.5, 1)) 1467 | } 1468 | } 1469 | } 1470 | } 1471 | } 1472 | if (isTRUE(showAtts == TRUE) == TRUE) { 1473 | ndss <- nds 1474 | ndss[, 1] <- ndss[, 1] * scl[1] 1475 | ndss[, 2] <- ndss[, 2] * scl[2] 1476 | if (isTRUE(flgcrd == TRUE) == TRUE && isTRUE(ncol(coord) > 1477 | 3L) == TRUE) { 1478 | NA 1479 | } 1480 | else { 1481 | atts <- rep("", nrow(nds)) 1482 | if (missing(att) == FALSE) { 1483 | if (is.array(att) == TRUE) { 1484 | if (is.na(dim(att)[3]) == TRUE | isTRUE(dim(att)[3] == 1485 | 1) == TRUE) { 1486 | ifelse(missing(lbat) == FALSE, atts[which((att) != 1487 | 0)] <- lbat, atts[which((att) != 0)] <- "1") 1488 | } 1489 | else { 1490 | if (missing(lbat) == FALSE) { 1491 | atts[which(diag(multiplex::mnplx(netd, 1492 | diag.incl = TRUE)) != 0)] <- lbat 1493 | } 1494 | else { 1495 | dimnames(netd)[[3]] <- NULL 1496 | neta <- multiplex::zbind(netd, att) 1497 | clss <- multiplex::expos(multiplex::rel.sys(neta, 1498 | att = (z + 1L):dim(neta)[3]), classes = TRUE)$Classes 1499 | attr(clss, "names")[which(attr(clss, "names") == 1500 | "ALL")] <- multiplex::jnt(dimnames(att)[[3]], 1501 | sep = "") 1502 | for (i in 2:length(clss)) { 1503 | atts[which(lbs %in% clss[[i]])] <- attr(clss, 1504 | "names")[i] 1505 | } 1506 | rm(i) 1507 | } 1508 | } 1509 | } 1510 | else if (is.vector(att) == TRUE | is.factor(att) == 1511 | TRUE) { 1512 | ifelse(isTRUE(length(att) == n) == TRUE, atts <- as.vector(att), 1513 | atts <- rep("", length(lbs))) 1514 | } 1515 | else { 1516 | atts <- rep("", length(lbs)) 1517 | } 1518 | } 1519 | else { 1520 | NA 1521 | } 1522 | } 1523 | if (isTRUE(flgcx == FALSE) == TRUE) { 1524 | graphics::text(ndss, labels = atts, cex = fsize, 1525 | pos = pos%%4 + 1L, col = fcol, offset = (cex/4L), 1526 | adj = c(0.5, 1)) 1527 | } 1528 | else if (isTRUE(flgcx == TRUE) == TRUE) { 1529 | graphics::text(ndss, labels = atts, cex = fsize, 1530 | pos = pos%%4 + 1L, col = fcol, offset = (min(cex)/4L), 1531 | adj = c(0.5, 1)) 1532 | } 1533 | } 1534 | graphics::par(mar = omr) 1535 | graphics::par(bg = obg) 1536 | graphics::par(lend = 0) 1537 | graphics::par(mai = omi) 1538 | } 1539 | -------------------------------------------------------------------------------- /R/nrm.R: -------------------------------------------------------------------------------- 1 | nrm <- 2 | function (x, digits = 3) 3 | { 4 | if (isTRUE(length(x) == 1L) == TRUE) 5 | return(x) 6 | if (is.array(x) == TRUE) { 7 | xnorm <- (x[, 1] - min(x[, 1]))/(max(x[, 1]) - min(x[, 8 | 1])) 9 | rat <- (max(x[, 1]) - min(x[, 1]))/(max(x[, 2]) - min(x[, 10 | 2])) 11 | ynorm <- ((x[, 2] - min(x[, 2]))/(max(x[, 2]) - min(x[, 12 | 2]))) * (rat) 13 | ifelse(isTRUE(rat > 0) == FALSE, ynorm <- ((x[, 2] - 14 | min(x[, 2]))/(max(x[, 2]) - min(x[, 2]))) * (1L/rat), 15 | NA) 16 | return(round(data.frame(X = xnorm, Y = ynorm), digits)) 17 | } 18 | else if (is.vector(x) == TRUE) { 19 | return(round((x - min(x))/(max(x) - min(x)), digits)) 20 | } 21 | } 22 | -------------------------------------------------------------------------------- /R/popl.R: -------------------------------------------------------------------------------- 1 | popl <- 2 | function (n, seed = seed) 3 | { 4 | alpha <- pi * (3L - sqrt(5L)) 5 | set.seed(seed) 6 | phase <- stats::runif(1) * 2L * pi 7 | ptsx <- vector() 8 | ptsy <- vector() 9 | for (k in 1:n) { 10 | theta <- k * alpha + phase 11 | rr <- sqrt(k/n) 12 | ptsx <- append(ptsx, (rr * cos(theta))) 13 | ptsy <- append(ptsy, (rr * sin(theta))) 14 | } 15 | rm(k) 16 | return(cbind(ptsx, ptsy) - min(cbind(ptsx, ptsy))) 17 | } 18 | -------------------------------------------------------------------------------- /R/rng.R: -------------------------------------------------------------------------------- 1 | rng <- 2 | function (r) 3 | { 4 | if (r == 1L) 5 | return(0) 6 | if (r > 1L) { 7 | x <- vector() 8 | x <- append(x, (-1)) 9 | for (i in 1:(r - 1)) x <- append(x, ((-1) + (2L/(r - 10 | 1L)) * i)) 11 | return(x * (r/50L)) 12 | } 13 | else stop("no negative values") 14 | } 15 | -------------------------------------------------------------------------------- /R/sts.R: -------------------------------------------------------------------------------- 1 | sts <- 2 | function (nds, delta = NULL, mwd = NULL) 3 | { 4 | ifelse(is.null(delta) == TRUE, delta <- matrix(1, nrow(nds), 5 | nrow(nds)), NA) 6 | strss <- 0 7 | mnds <- as.matrix(nds) 8 | if (is.null(mwd)) { 9 | mwd <- delta^(-2) 10 | mwd[which(mwd == Inf)] <- 0 11 | } 12 | for (j in 1:nrow(nds)) { 13 | for (i in 1:(j - 1)) { 14 | if (isTRUE(i > 0 && j > 1) == TRUE) { 15 | strss <- strss + as.matrix(mwd)[i, j] %*% (norm(mnds[i, 16 | ] - mnds[j, ], type = "2") - as.matrix(delta)[i, 17 | j])^2 18 | } 19 | else { 20 | NA 21 | } 22 | } 23 | rm(i) 24 | } 25 | rm(j) 26 | as.vector(strss) 27 | } 28 | -------------------------------------------------------------------------------- /R/stsm.R: -------------------------------------------------------------------------------- 1 | stsm <- 2 | function (net, seed = seed, maxiter = 40, drp, jitter, method, 3 | ...) 4 | { 5 | n <- dim(net)[1] 6 | ifelse(missing(drp) == FALSE && is.numeric(drp) == TRUE, 7 | NA, drp <- 0) 8 | netd <- multiplex::mnplx(replace(net, net <= drp, 0), directed = FALSE, 9 | dichot = TRUE) 10 | ifelse(is.null(rownames(netd)) == TRUE, lbs <- seq_len(n), 11 | lbs <- rownames(netd)) 12 | ifelse(missing(method) == TRUE, delta <- stats::dist(netd, 13 | upper = TRUE, diag = TRUE, method = "binary"), delta <- stats::dist(netd, 14 | upper = TRUE, diag = TRUE, method = method)) 15 | ifelse(isTRUE(sum(delta) == 0) == TRUE, return(popl(dim(net)[1], 16 | seed = seed)), NA) 17 | mwd <- delta^(-2) 18 | mwd[which(mwd == Inf)] <- 0 19 | lpmwd <- as.matrix(mwd) 20 | for (i in seq_len(n)) { 21 | for (j in seq_len(n)) { 22 | ifelse(isTRUE(as.matrix(mwd)[i, j] != 0) == TRUE, 23 | lpmwd[i, j] <- -1 * as.matrix(mwd)[i, j], NA) 24 | } 25 | rm(j) 26 | } 27 | rm(i) 28 | diag(lpmwd) <- apply(as.matrix(mwd), 1, sum) 29 | s <- svd(lpmwd) 30 | p <- (s$d > max(.Machine$double.eps^(2/3) * s$d[1], 0)) 31 | if (all(p)) { 32 | pilpmwd <- s$v %*% (1/s$d * t(s$u)) 33 | } 34 | else if (any(p)) { 35 | pilpmwd <- s$v[, p, drop = FALSE] %*% (1/s$d[p] * t(s$u[, 36 | p, drop = FALSE])) 37 | } 38 | else { 39 | pilpmwd <- matrix(0, nrow = ncol(lpmwd), ncol = nrow(lpmwd)) 40 | } 41 | set.seed(seed) 42 | vec <- stats::rnorm(n * 2L) 43 | X0 <- cbind(vec[seq_len(n)], vec[(n + 1):length(vec)]) 44 | Xs <- as.matrix(X0) 45 | newstss <- sts(X0, delta = delta, mwd = mwd) 46 | for (iter in seq_len(maxiter)) { 47 | lzx0 <- lz(X0, delta, mwd) 48 | if (any(is.nan(lzx0)) == FALSE) { 49 | X <- pilpmwd %*% (lzx0 %*% X0) 50 | X[which(X == Inf)] <- 0 51 | oldstss <- newstss 52 | newstss <- sts(X, delta = delta, mwd = mwd) 53 | Xs <- X 54 | abstols <- abstolx <- reltols <- sqrt(.Machine$double.eps) 55 | ifelse(isTRUE(abs(newstss - oldstss) < (reltols * 56 | newstss)) == TRUE, break, NA) 57 | ifelse(isTRUE(abs(newstss - oldstss) < abstols) == 58 | TRUE, break, NA) 59 | ifelse(isTRUE(norm(X - X0, type = "F") < abstolx) == 60 | TRUE, break, NA) 61 | X0 <- X 62 | } 63 | } 64 | rm(iter) 65 | cmps <- multiplex::comps(netd) 66 | nds <- Xs 67 | rownames(nds) <- lbs 68 | ifelse(isTRUE(sum(nds) == 0) == TRUE, rat <- 1, rat <- (max(nds[, 69 | 1]) - min(nds[, 1]))/(max(nds[, 2]) - min(nds[, 2]))) 70 | if (isTRUE(length(cmps$isol) > 1) == TRUE) { 71 | nds[, 1] <- (nds[, 1] - min(nds[, 1]))/(max(nds[, 1]) - 72 | min(nds[, 1])) 73 | ifelse(isTRUE(rat > 0) == TRUE, nds[, 2] <- ((nds[, 2] - 74 | min(nds[, 2]))/(max(nds[, 2]) - min(nds[, 2]))) * 75 | (1L/rat), nds[, 2] <- ((nds[, 2] - min(nds[, 2]))/(max(nds[, 76 | 2]) - min(nds[, 2]))) * (rat)) 77 | nds <- as.matrix((nds)) 78 | ndst <- nds[which(nds[, 1] != 0), ] 79 | tmpi <- popl(length(cmps$isol), seed = seed)/(length(cmps$isol) * 80 | 2) * length(cmps$isol) 81 | if (is.null(cmps$com) == FALSE) { 82 | locx <- ((tmpi[, 1]/3L) - (min(ndst[, 1])) - 0) 83 | ifelse(isTRUE(rat > 0) == TRUE, locy <- ((min(ndst[, 84 | 2])) - (tmpi[, 2]/3L) - 0), locy <- ((max(ndst[, 85 | 2])) + (tmpi[, 2]/3L) + 0)) 86 | ndst.chull <- grDevices::chull(ndst) 87 | ndst.chull <- ndst[ndst.chull, ] 88 | ifelse(isTRUE(length(which(ndst.chull[, 1] < mean(ndst.chull[, 89 | 1]))) > length(which(ndst.chull[, 1] > mean(ndst.chull[, 90 | 1])))) == TRUE, locx <- locx + (1/n), locx <- locx + 91 | ((1/n) * -1)) 92 | ifelse(isTRUE(length(which(ndst.chull[, 2] < mean(ndst.chull[, 93 | 2]))) > length(which(ndst.chull[, 2] > mean(ndst.chull[, 94 | 2])))) == TRUE, locy <- locy - (1/n), locy <- locy - 95 | ((1/n) * -1)) 96 | } 97 | else { 98 | locx <- (tmpi[, 1]) 99 | locy <- (tmpi[, 2]) 100 | } 101 | nds[which(lbs %in% cmps$isol), ] <- (cbind(locx, locy)) 102 | } 103 | else if (isTRUE(length(cmps$isol) == 1L) == TRUE) { 104 | ndst <- nds[which(nds[, 1] != 0), ] 105 | locx <- max(ndst[, 1]) + (1/n) 106 | ifelse(isTRUE(rat < 0) == TRUE, locy <- max(ndst[, 2]) + 107 | (1/n), locy <- min(ndst[, 2]) - (1/n)) 108 | nds[which(lbs %in% cmps$isol), ] <- (cbind(locx, locy)) 109 | } 110 | nds[, 1] <- (nds[, 1] - min(nds[, 1]))/(max(nds[, 1]) - min(nds[, 111 | 1])) + (1/n) 112 | ifelse(isTRUE(rat > 0) == TRUE, nds[, 2] <- ((nds[, 2] - 113 | min(nds[, 2]))/(max(nds[, 2]) - min(nds[, 2]))) * (1L/rat), 114 | nds[, 2] <- ((nds[, 2] - min(nds[, 2]))/(max(nds[, 2]) - 115 | min(nds[, 2]))) * (rat) + (1/n)) 116 | nds[, 2] <- nds[, 2] * -1 117 | Xs <- as.data.frame(nds) 118 | if (missing(jitter) == FALSE && isTRUE(jitter) == TRUE) { 119 | jitter(Xs, amount = (n/100)) 120 | } 121 | else { 122 | return(as.data.frame(Xs)) 123 | } 124 | } 125 | -------------------------------------------------------------------------------- /R/xyrt.R: -------------------------------------------------------------------------------- 1 | xyrt <- 2 | function (pares, ang) 3 | { 4 | xr <- pares[, 1] * cos(ang * (pi/180L)) - pares[, 2] * sin(ang * 5 | (pi/180L)) 6 | yr <- pares[, 2] * cos(ang * (pi/180L)) + pares[, 1] * sin(ang * 7 | (pi/180L)) 8 | return(invisible(cbind(xr, yr))) 9 | } 10 | -------------------------------------------------------------------------------- /R/xyrtb.R: -------------------------------------------------------------------------------- 1 | xyrtb <- 2 | function (pares, ang) 3 | { 4 | if (isTRUE(pares[1, 1] != 0 | pares[2, 1] != 0) == TRUE) { 5 | temp <- pares 6 | tpares <- c(0, 0) - pares[1, ] 7 | for (i in 1:nrow(temp)) { 8 | temp[i, ] <- pares[i, ] + tpares 9 | } 10 | rm(i) 11 | txrot <- temp[, 1] * cos(ang * (pi/180L)) - temp[, 2] * 12 | sin(ang * (pi/180L)) 13 | tyrot <- temp[, 2] * cos(ang * (pi/180L)) + temp[, 1] * 14 | sin(ang * (pi/180L)) 15 | xrot <- txrot 16 | yrot <- tyrot 17 | tm <- as.data.frame(cbind(xrot, yrot)) 18 | tm[1, ] <- tm[1, ] - (c(0, 0) - pares[1, ]) 19 | tm[2, ] <- tm[2, ] - (c(0, 0) - pares[1, ]) 20 | } 21 | else { 22 | xrot <- pares[, 1] * cos(ang * (pi/180L)) - pares[, 2] * 23 | sin(ang * (pi/180L)) 24 | yrot <- pares[, 2] * cos(ang * (pi/180L)) + pares[, 1] * 25 | sin(ang * (pi/180L)) 26 | tm <- cbind(xrot, yrot) 27 | } 28 | attr(tm, "dimnames") <- NULL 29 | return(invisible(tm)) 30 | } 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | [![CRAN version](https://www.r-pkg.org/badges/version/multigraph?color=green)](https://cran.r-project.org/package=multigraph) 4 | [![CRAN downloads](https://cranlogs.r-pkg.org/badges/grand-total/multigraph?color=blue)](https://r-pkg.org/pkg/multigraph) 5 | 6 | 7 |
8 | 9 | ### **`multigraph`**: Plot and Manipulate Multigraphs in R 10 | #### Antonio Rivero Ostoic (@mplex) 11 | 12 |
13 | 14 | 15 |
16 | 17 | To install **`multigraph`** with the **R** console, 18 | **R** IDE, or Notebook with **R** kernel in. 19 | 20 | ```r 21 | # from CRAN 22 | install.packages("multigraph") 23 | ``` 24 | 25 | or 26 | 27 | ```r 28 | # from Github 29 | devtools::install_github("mplex/multigraph") 30 | ``` 31 | 32 |
33 | 34 | 35 | When you load the package then **`multiplex`** is automatically invoked. 36 | 37 | ```r 38 | library("multigraph") 39 | # Loading required package: multiplex 40 | ``` 41 | 42 |
43 | 44 | ### Multigraph: Florentine Families dataset 45 | 46 | Padgett's Florentine Families dataset is publicly available as a Ucinet DL file format. 47 | Use function `read.dl` of the **`multiplex`** package to retrieve this data. 48 | 49 |
50 | 51 | 52 | ```r 53 | # read the Padgett Florentine Families dataset as a Ucinet DL file 54 | # from a public repository and storage it as an object 55 | 56 | floflies <- multiplex::read.dl(file = "http://moreno.ss.uci.edu/padgett.dat") 57 | # or mirror 58 | floflies <- multiplex::read.dl(file = "http://vlado.fmf.uni-lj.si/pub/networks/data/ucinet/padgett.dat") 59 | 60 | 61 | # adjacency matrices 62 | floflies 63 | 64 | , , PADGM 65 | 66 | ACCIAIUOL ALBIZZI BARBADORI BISCHERI CASTELLAN GINORI GUADAGNI LAMBERTES MEDICI PAZZI PERUZZI PUCCI RIDOLFI SALVIATI STROZZI TORNABUON 67 | ACCIAIUOL 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 68 | ALBIZZI 0 0 0 0 0 1 1 0 1 0 0 0 0 0 0 0 69 | BARBADORI 0 0 0 0 1 0 0 0 1 0 0 0 0 0 0 0 70 | BISCHERI 0 0 0 0 0 0 1 0 0 0 1 0 0 0 1 0 71 | CASTELLAN 0 0 1 0 0 0 0 0 0 0 1 0 0 0 1 0 72 | GINORI 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 73 | GUADAGNI 0 1 0 1 0 0 0 1 0 0 0 0 0 0 0 1 74 | LAMBERTES 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 75 | MEDICI 1 1 1 0 0 0 0 0 0 0 0 0 1 1 0 1 76 | PAZZI 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 77 | PERUZZI 0 0 0 1 1 0 0 0 0 0 0 0 0 0 1 0 78 | PUCCI 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 79 | RIDOLFI 0 0 0 0 0 0 0 0 1 0 0 0 0 0 1 1 80 | SALVIATI 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 81 | STROZZI 0 0 0 1 1 0 0 0 0 0 1 0 1 0 0 0 82 | TORNABUON 0 0 0 0 0 0 1 0 1 0 0 0 1 0 0 0 83 | 84 | , , PADGB 85 | 86 | ACCIAIUOL ALBIZZI BARBADORI BISCHERI CASTELLAN GINORI GUADAGNI LAMBERTES MEDICI PAZZI PERUZZI PUCCI RIDOLFI SALVIATI STROZZI TORNABUON 87 | ACCIAIUOL 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 88 | ALBIZZI 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 89 | BARBADORI 0 0 0 0 1 1 0 0 1 0 1 0 0 0 0 0 90 | BISCHERI 0 0 0 0 0 0 1 1 0 0 1 0 0 0 0 0 91 | CASTELLAN 0 0 1 0 0 0 0 1 0 0 1 0 0 0 0 0 92 | GINORI 0 0 1 0 0 0 0 0 1 0 0 0 0 0 0 0 93 | GUADAGNI 0 0 0 1 0 0 0 1 0 0 0 0 0 0 0 0 94 | LAMBERTES 0 0 0 1 1 0 1 0 0 0 1 0 0 0 0 0 95 | MEDICI 0 0 1 0 0 1 0 0 0 1 0 0 0 1 0 1 96 | PAZZI 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 97 | PERUZZI 0 0 1 1 1 0 0 1 0 0 0 0 0 0 0 0 98 | PUCCI 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 99 | RIDOLFI 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 100 | SALVIATI 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 101 | STROZZI 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 102 | TORNABUON 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 103 | ``` 104 | 105 |
106 | 107 | Object `floflies` represents the Florentine families network where `"PADGM"` are marriage relations and `"PADGB"` correspond to business ties among the 16 actors. 108 | 109 |
110 | 111 | 112 | ### Plotting multigraphs 113 | 114 | Graph of the Florentine families network using `multigraph` function with the default circular layout: 115 | 116 | ```r 117 | multigraph(floflies) 118 | ``` 119 | ![Default layout of `multigraph`](figs/floflies.png) 120 | 121 | 122 |
123 | 124 | Check also out the [vector image](figs/floflies.pdf) of this multigraph, and *note that with vector graphics the rendering may vary according to the device used.* 125 | 126 |
127 | 128 | 129 | #### Force-directed layout 130 | 131 | Besides a circular layout, another possibility is to apply a *force-directed* layout for the visualization of the multiplex network. 132 | Function `multigraph` provides a number of arguments for graph, edges, and nodes levels, which can be recorded in an object list 133 | named `scp` to be used in the `scope` argument of the function. 134 | 135 | 136 | 137 |
138 | 139 | 140 | ```r 141 | # define scope of node / edge / graph characteristics as list object 142 | scp <- list(directed = FALSE, cex = 6, fsize = 7, pos = 0, vcol = 8, ecol = 1, lwd = 2, bwd = .5) 143 | 144 | # plot graph with customized format 145 | multigraph(floflies, layout = "force", seed = 2, scope = scp) 146 | ``` 147 | ![Force directed layout of `multigraph`](figs/floflies-force.png) 148 | [vector image](figs/floflies-force.pdf) 149 | 150 |
151 |
152 | 153 | 154 | ```r 155 | # plot graph with customized format 156 | multigraph(floflies, layout = "force", seed = 2, scope = scp, lty = 2:1, pch = 13) 157 | ``` 158 | ![Force directed layout of `multigraph` different shapes](figs/floflies-force2.png) 159 | [vector image](figs/floflies-force2.pdf) 160 | 161 |
162 | 163 | Note that when the graph is depicted as *undirected*, then the reciprocal ties by default are collapsed. 164 | You can prevent this to happen by setting the argument `collRecip` to `FALSE`. 165 | Some arguments such as `cex`, `lwd`, `lty`, `pch` are graphical parameters of the **`graphics`** package 166 | to set the shape of both the vertices and the edges. 167 | Other arguments like `bwd` to specify the width of the bundle type, `fsize` for the size of the font used in node labels, 168 | or `ecol` and `vcol` for the color of respectively edges and vertices are complementary in **`multigraph`**. 169 | Moreover, by setting the `pos` argument to `0`, the actor labels are placed in the middle of the nodes. 170 | 171 | 172 |
173 |
174 | 175 | 176 | ## Multigraphs with Actor Attributes 177 | 178 | 179 | Some actor attributes of the Florentine Families network. 180 | 181 | ```r 182 | flofliesatt <- multiplex::read.dl(file = "http://moreno.ss.uci.edu/padgw.dat") 183 | # or mirror 184 | flofliesatt <- multiplex::read.dl(file = "http://vlado.fmf.uni-lj.si/pub/networks/data/ucinet/padgw.dat") 185 | 186 | ``` 187 | 188 | Look at `flofliesatt` that storages attribute information 189 | 190 | 191 | ```r 192 | flofliesatt 193 | 194 | WEALTH #PRIORS #TIES 195 | ACCIAIUOL 10 53 2 196 | ALBIZZI 36 65 3 197 | RIDOLFI 27 38 4 198 | STROZZI 146 74 29 199 | BARBADORI 55 0 14 200 | BISCHERI 44 12 9 201 | CASTELLAN 20 22 18 202 | GUADAGNI 8 21 14 203 | LAMBERTES 42 0 14 204 | MEDICI 103 53 54 205 | PAZZI 48 0 7 206 | PERUZZI 49 42 32 207 | SALVIATI 10 35 5 208 | TORNABUON 48 0 7 209 | GINORI 32 0 9 210 | PUCCI 3 0 1 211 | ``` 212 | 213 |
214 | 215 | 216 | However, in order to depict the multigraph of `floflies` with the information contained in `flofliesatt`, be sure that the order of the actors matches in both objects. 217 | 218 | 219 | ```r 220 | flofliesatt <- flofliesatt[order(rownames(flofliesatt)), ] 221 | 222 | flofliesatt 223 | 224 | WEALTH #PRIORS #TIES 225 | ACCIAIUOL 10 53 2 226 | ALBIZZI 36 65 3 227 | BARBADORI 55 0 14 228 | BISCHERI 44 12 9 229 | CASTELLAN 20 22 18 230 | GINORI 32 0 9 231 | GUADAGNI 8 21 14 232 | LAMBERTES 42 0 14 233 | MEDICI 103 53 54 234 | PAZZI 48 0 7 235 | PERUZZI 49 42 32 236 | PUCCI 3 0 1 237 | RIDOLFI 27 38 4 238 | SALVIATI 10 35 5 239 | STROZZI 146 74 29 240 | TORNABUON 48 0 7 241 | ``` 242 | 243 | Now ` flofliesatt` matches ` floflies` for the plotting. 244 | 245 | 246 |
247 |
248 | 249 | Redefine the scope in `scp` to depict this network in a way that the size of the vertices reflects the wealth of the actors. 250 | 251 | ```r 252 | # redefine scope of node / edge / graph characteristics 253 | scp <- list(directed = FALSE, fsize = 8, pos = 0, lwd = 2, ecol = 1, vcol = 5) 254 | 255 | # plot graph with customized format and actor attributes 256 | multigraph(floflies, layout = "force", seed = 1, scope = scp, cex = flofliesatt[,1]) 257 | ``` 258 | ![Force directed layout layout of `multigraph` with attributes](figs/flofliesatt-force.png) 259 | [vector image](figs/flofliesatt-force.pdf) 260 | 261 | 262 |
263 | 264 | The `clu` argument serves to establish the clustering of the network with three classes of actors differentiated by the colors of the vertices. 265 | 266 | 267 | ```r 268 | # define scope of node / edge / graph characteristics 269 | scp2 <- list(directed = FALSE, fsize = 8, pos = 0, lwd = 2, ecol = "white", 270 | + vcol = c("orange","blue","white"), clu = c(1,1,1,2,2,1,2,2,1,1,2,3,1,1,2,1), alpha = c(.5, 1, .2)) 271 | 272 | # plot graph with customized format and actor attributes 273 | multigraph(floflies, layout = "force", seed = 1, scope = scp2, cex = flofliesatt[,1], bg = 1) 274 | ``` 275 | ![Force directed layout of `multigraph` with clustering](figs/flofliesatt-force2.png) 276 | [vector image](figs/flofliesatt-force2.pdf) 277 | 278 | As a result, there are different ways to set the colors, and the `alpha` vector argument serves to set the transparency of colors in vertices, 279 | edges, and the graph background. 280 | 281 | 282 | 283 |
284 | 285 | ___ 286 | 287 |
288 | 289 | 290 | ### Bipartite Graph: Southern Women dataset 291 | 292 | Support for the visualization of two-mode networks is also given by **`multigraph`**, and for the Southern Women classic dataset 293 | to illustrate some of the layout options with this package. 294 | 295 | ```r 296 | # read the Ucinet DL file of Davis, Gardner, Gardner Southern Women 297 | # dataset from a public repository and storage it as an object 298 | 299 | swomen <- multiplex::read.dl(file = "http://moreno.ss.uci.edu/davis.dat") 300 | # or mirror 301 | swomen <- multiplex::read.dl(file = "http://vlado.fmf.uni-lj.si/pub/networks/data/ucinet/davis.dat") 302 | 303 | 304 | ### take a look 305 | swomen 306 | 307 | E1 E2 E3 E4 E5 E6 E7 E8 E9 E10 E11 E12 E13 E14 308 | EVELYN 1 1 1 1 1 1 0 1 1 0 0 0 0 0 309 | LAURA 1 1 1 0 1 1 1 1 0 0 0 0 0 0 310 | THERESA 0 1 1 1 1 1 1 1 1 0 0 0 0 0 311 | BRENDA 1 0 1 1 1 1 1 1 0 0 0 0 0 0 312 | CHARLOTTE 0 0 1 1 1 0 1 0 0 0 0 0 0 0 313 | FRANCES 0 0 1 0 1 1 0 1 0 0 0 0 0 0 314 | ELEANOR 0 0 0 0 1 1 1 1 0 0 0 0 0 0 315 | PEARL 0 0 0 0 0 1 0 1 1 0 0 0 0 0 316 | RUTH 0 0 0 0 1 0 1 1 1 0 0 0 0 0 317 | VERNE 0 0 0 0 0 0 1 1 1 0 0 1 0 0 318 | MYRA 0 0 0 0 0 0 0 1 1 1 0 1 0 0 319 | KATHERINE 0 0 0 0 0 0 0 1 1 1 0 1 1 1 320 | SYLVIA 0 0 0 0 0 0 1 1 1 1 0 1 1 1 321 | NORA 0 0 0 0 0 1 1 0 1 1 1 1 1 1 322 | HELEN 0 0 0 0 0 0 1 1 0 1 1 1 1 1 323 | DOROTHY 0 0 0 0 0 0 0 1 1 1 0 1 0 0 324 | OLIVIA 0 0 0 0 0 0 0 0 1 0 1 0 0 0 325 | FLORA 0 0 0 0 0 0 0 0 1 0 1 0 0 0 326 | ``` 327 | 328 | In this case, the information can be contained in a data frame or an array as before. 329 | 330 | 331 |
332 | 333 | 334 | #### Plotting two-mode data 335 | 336 | Function `bmgraph` serves to plot two-mode data or an affiliation network as a bipartite graph. 337 | 338 | ```r 339 | bmgraph(swomen) 340 | ``` 341 | ![Default layout of `bmgraph`](figs/swomen.png) 342 | [vector image](figs/swomen.pdf) 343 | 344 | 345 | In this case, actor and events have different shape by default. 346 | 347 | 348 |
349 | 350 | Similarly to `multigraph` the color and shape of edges and vertices can be modified by equal arguments, and we can mirror the *X* axis of the plot. 351 | 352 | ```r 353 | # define scope of node / edge / graph characteristics as list object 354 | scp3 <- list(cex = 3, fsize = 8, pch = c(19, 15), lwd = 1.5, vcol = 2:3, fsize = 7) 355 | 356 | # Plot bipartite graph with customized format and horizontal reflection 357 | bmgraph(swomen, scope = scp3, mirrorX = TRUE) 358 | ``` 359 | ![Mirror X of `bmgraph`](figs/swomen2.png) 360 | [vector image](figs/swomen2.pdf) 361 | 362 | 363 |
364 | 365 | Option `bip3` splits the actors in two columns, whereas `bip3e` will split the events. 366 | 367 | 368 | ```r 369 | bmgraph(swomen, layout = "bip3", scope = scp3) 370 | ``` 371 | ![Mirror X of `bmgraph`](figs/swomen3.png) 372 | [vector image](figs/swomen3.pdf) 373 | 374 | 375 |
376 | 377 | Bipartite graph with clustering information of Southern Women network as in Batagelj et al, 2014 (p. 29). 378 | 379 | ```r 380 | # clustering of network members for permutation 381 | clup <- list(c(8,9,7,6,1,4,2,3,5,17,18,13,16,11,10,15,14,12), 382 | c(5,1,4,2,3,9,8,7,6,11,12,10,13,14)) 383 | 384 | # clustering of network members for layout 385 | clunm <- list(c(rep(1,9),rep(2,9)),c(rep(1,5),rep(2,4),rep(3,5))) 386 | 387 | # bipartite graph with clustering 388 | bmgraph(swomen, layout = "bipc", scope = scp3, clu = clunm, perm = clup) 389 | ``` 390 | ![clustering `bmgraph`](figs/swomenc.png) 391 | [vector image](figs/swomenc.pdf) 392 | 393 | 394 | 395 |
396 | 397 | The binomial projection of a two-mode dataset allows obtaining a force directed layout that in this case the image is clockwise rotated 65 degrees. 398 | 399 | ```r 400 | bmgraph(swomen, layout = "force", seed = 1, scope = scp3, rot = 65) 401 | ``` 402 | ![Force directed layout of `bmgraph`](figs/swomen-force.png) 403 | [vector image](figs/swomen-force.pdf) 404 | 405 | 406 |
407 |
408 | 409 | Function `bmgraph` stands for a bipartite *multigraph* because the actors can be affiliated by different means. 410 | 411 | ```r 412 | bmgraph(floflies, ecol = 1) 413 | ``` 414 | ![bipartite graph of `floflies`](figs/floflies-bmgraph.png) 415 | [vector image](figs/floflies-bmgraph.pdf) 416 | 417 | 418 |
419 | 420 |
421 | 422 | ### Cayley graph 423 | 424 | See [Plot partially ordered semigroup](https://htmlpreview.github.io/?https://github.com/mplex/sunbelt2023/blob/main/pres/Multilevel%20Structure%20of%20G20%20Trade%20Network.html#plot-partially-ordered-semigroup) 425 | 426 | or 427 | 428 | ```r 429 | ?ccgraph 430 | ``` 431 | 432 | 433 | 434 |
435 | 436 |
437 | 438 | ### Multilevel graph 439 | 440 | See [Multilevel Structure of G20 Trade Network](https://htmlpreview.github.io/?https://github.com/mplex/sunbelt2023/blob/main/pres/Multilevel%20Structure%20of%20G20%20Trade%20Network.html#multilevel-structures) 441 | 442 | 443 | or 444 | 445 | ```r 446 | ?mlgraph 447 | ``` 448 | 449 |
450 | 451 |
452 | 453 | 454 | ### Miscellaneous: Time and geography 455 | 456 | Function `multigraph` with argument `"new"` allows superimposing graphs over a cartographical map, for example, as with the animated plot below produced together with packages [`gifski`](https://CRAN.R-project.org/package=gifski) and [`sdam`](https://CRAN.R-project.org/package=sdam) that represents a network dynamic in ancient Mediterranean Sea (cf. [Shipwrecks network in the Mediterranean Basin](https://htmlpreview.github.io/?https://github.com/sdam-au/R_code/blob/master/HTML/Shipwrecks%20Network%20in%20the%20Mediterranean%20Basin.html) ). 457 | 458 | 459 |
460 | 461 | 462 | ```r 463 | # pseudo-code 464 | sdam::plot.map(type="med", new=TRUE) 465 | multigraph(net, ..., new=TRUE) 466 | ``` 467 | 468 |
469 | 470 | 471 | ![Time and geography network animated](figs/shipwrecks-animation.gif) 472 | 473 | 474 | 475 |
476 | 477 | 478 | 479 | 480 | ##### **Notice** for **R** (>4.0.0), use **`multiplex`** version 3 or higher. 481 | 482 |
483 | 484 | 485 | 486 | -------------------------------------------------------------------------------- /figs/floflies-bmgraph.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mplex/multigraph/4a640a9c8a8b3a615d1cc486181e6b99047f214b/figs/floflies-bmgraph.pdf -------------------------------------------------------------------------------- /figs/floflies-bmgraph.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mplex/multigraph/4a640a9c8a8b3a615d1cc486181e6b99047f214b/figs/floflies-bmgraph.png -------------------------------------------------------------------------------- /figs/floflies-force.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mplex/multigraph/4a640a9c8a8b3a615d1cc486181e6b99047f214b/figs/floflies-force.pdf -------------------------------------------------------------------------------- /figs/floflies-force.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mplex/multigraph/4a640a9c8a8b3a615d1cc486181e6b99047f214b/figs/floflies-force.png -------------------------------------------------------------------------------- /figs/floflies-force2.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mplex/multigraph/4a640a9c8a8b3a615d1cc486181e6b99047f214b/figs/floflies-force2.pdf -------------------------------------------------------------------------------- /figs/floflies-force2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mplex/multigraph/4a640a9c8a8b3a615d1cc486181e6b99047f214b/figs/floflies-force2.png -------------------------------------------------------------------------------- /figs/floflies.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mplex/multigraph/4a640a9c8a8b3a615d1cc486181e6b99047f214b/figs/floflies.pdf -------------------------------------------------------------------------------- /figs/floflies.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mplex/multigraph/4a640a9c8a8b3a615d1cc486181e6b99047f214b/figs/floflies.png -------------------------------------------------------------------------------- /figs/flofliesatt-force.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mplex/multigraph/4a640a9c8a8b3a615d1cc486181e6b99047f214b/figs/flofliesatt-force.pdf -------------------------------------------------------------------------------- /figs/flofliesatt-force.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mplex/multigraph/4a640a9c8a8b3a615d1cc486181e6b99047f214b/figs/flofliesatt-force.png -------------------------------------------------------------------------------- /figs/flofliesatt-force2.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mplex/multigraph/4a640a9c8a8b3a615d1cc486181e6b99047f214b/figs/flofliesatt-force2.pdf -------------------------------------------------------------------------------- /figs/flofliesatt-force2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mplex/multigraph/4a640a9c8a8b3a615d1cc486181e6b99047f214b/figs/flofliesatt-force2.png -------------------------------------------------------------------------------- /figs/shipwrecks-animation.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mplex/multigraph/4a640a9c8a8b3a615d1cc486181e6b99047f214b/figs/shipwrecks-animation.gif -------------------------------------------------------------------------------- /figs/swomen-force.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mplex/multigraph/4a640a9c8a8b3a615d1cc486181e6b99047f214b/figs/swomen-force.pdf -------------------------------------------------------------------------------- /figs/swomen-force.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mplex/multigraph/4a640a9c8a8b3a615d1cc486181e6b99047f214b/figs/swomen-force.png -------------------------------------------------------------------------------- /figs/swomen.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mplex/multigraph/4a640a9c8a8b3a615d1cc486181e6b99047f214b/figs/swomen.pdf -------------------------------------------------------------------------------- /figs/swomen.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mplex/multigraph/4a640a9c8a8b3a615d1cc486181e6b99047f214b/figs/swomen.png -------------------------------------------------------------------------------- /figs/swomen2.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mplex/multigraph/4a640a9c8a8b3a615d1cc486181e6b99047f214b/figs/swomen2.pdf -------------------------------------------------------------------------------- /figs/swomen2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mplex/multigraph/4a640a9c8a8b3a615d1cc486181e6b99047f214b/figs/swomen2.png -------------------------------------------------------------------------------- /figs/swomen3.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mplex/multigraph/4a640a9c8a8b3a615d1cc486181e6b99047f214b/figs/swomen3.pdf -------------------------------------------------------------------------------- /figs/swomen3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mplex/multigraph/4a640a9c8a8b3a615d1cc486181e6b99047f214b/figs/swomen3.png -------------------------------------------------------------------------------- /figs/swomenc.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mplex/multigraph/4a640a9c8a8b3a615d1cc486181e6b99047f214b/figs/swomenc.pdf -------------------------------------------------------------------------------- /figs/swomenc.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mplex/multigraph/4a640a9c8a8b3a615d1cc486181e6b99047f214b/figs/swomenc.png -------------------------------------------------------------------------------- /inst/CITATION: -------------------------------------------------------------------------------- 1 | bibentry(bibtype = "book", 2 | title = "Algebraic Analysis of Social Networks: Models, Methods and Applications Using R", 3 | author = person(given = c("J.A.R."), 4 | family = "Ostoic", 5 | email = "multiplex@post.com"), 6 | publisher = "Wiley", 7 | year = "2021", 8 | series = "Wiley Series in Computational and Quantitative Social Science", 9 | isbn = "9781119250326", 10 | lccn = "2020025444", 11 | header = "To cite multigraph in publications use:" 12 | ) 13 | -------------------------------------------------------------------------------- /man/bmgraph.Rd: -------------------------------------------------------------------------------- 1 | \name{bmgraph} 2 | \alias{bmgraph} 3 | \title{ 4 | Bipartite multigraph 5 | } 6 | \description{ 7 | A function to create and manipulate bipartite multigraphs 8 | } 9 | \usage{ 10 | bmgraph(net, layout = c("bip", "bip3", "bip3e", "bipc", "force", "rand", "circ", 11 | "stress", "CA", "circ2"), scope, coord, alpha = c(1, 1, 1), showLbs, showAtts, 12 | att = NULL, lbat = "1", main = NULL, cex.main, bg, mar, directed, valued, 13 | collRecip, cex, pos, lwd, lty, col, ecol, vcol, vcol0, asp, seed = NULL, 14 | maxiter = 100, bwd, clu, pch, rot, mirrorX, mirrorY, mirrorV, mirrorH, hds, 15 | vedist, jitter, sort, add, adc, perm, ffamily, fstyle, fsize, fcol, vclu, ...) 16 | } 17 | \arguments{ 18 | \item{net}{ 19 | data frame or array representing the two-mode network (see \emph{details}) 20 | } 21 | \item{layout}{ 22 | the visualization layout: 23 | 24 | \itemize{ 25 | \item \code{bip} (default) bipartite graph 26 | \item \code{bip3} bipartite graph with three columns 27 | \item \code{bip3e} bipartite graph with three columns for events 28 | \item \code{bipc} ``clustered'' bipartite graph 29 | \item \code{force} force-directed algorithm 30 | \item \code{rand} random 31 | \item \code{circ} circular 32 | \item \code{stress} stress-majorization algorithm 33 | \item \code{CA} correspondence analysis 34 | \item \code{circ2} two semi-circles 35 | } 36 | } 37 | \item{scope}{ 38 | (optional) scope of the graph (see \emph{details}) 39 | } 40 | \item{coord}{ 41 | (optional) data frame with the coordinates of the vertices; if coordinates are given then the \code{layout} option is ignored 42 | } 43 | \item{alpha}{ 44 | vector (vertex, edge, \code{bg}) with the alpha color transparency 45 | } 46 | \item{showLbs}{ 47 | (optional and logical) whether or not to show the vertex labels when dimnames available 48 | } 49 | \item{showAtts}{ 50 | (optional and logical) whether or not to show the vertex attribute labels 51 | } 52 | \item{att}{ 53 | (optional) a vector or an array representing the vertex attributes 54 | } 55 | \item{lbat}{ 56 | (optional) labels for the vertex attributes 57 | } 58 | \item{main}{ 59 | (optional) title of the plot 60 | } 61 | \item{cex.main}{ 62 | (optional) size of the plot's title 63 | } 64 | \item{bg}{ 65 | (optional) background color of the plot 66 | } 67 | \item{mar}{ 68 | (optional) margins of the plot 69 | } 70 | \item{directed}{ 71 | (optional and logical) whether or not the graph is directed or undirected 72 | } 73 | \item{valued}{ 74 | (optional and logical) whether or not the graph is valued or with dichotomous data 75 | } 76 | \item{collRecip}{ 77 | (optional and logical) whether or not collapse reciprocated edges in the undirected graph 78 | } 79 | \item{cex}{ 80 | (optional) size of the vertices 81 | } 82 | \item{pos}{ 83 | (optional) position of the vertices' labels (\code{0} means ``at the center of the vertex'') 84 | } 85 | \item{lwd}{ 86 | (optional) width of the edges; ignored if \code{valued} is set to \code{TRUE} 87 | } 88 | \item{lty}{ 89 | (optional) shape of the edges 90 | } 91 | \item{col}{ 92 | (optional) alias for \code{vcol} 93 | } 94 | \item{ecol}{ 95 | (optional) color of the edges 96 | } 97 | \item{vcol}{ 98 | (optional) color of the vertices 99 | } 100 | \item{vcol0}{ 101 | (optional) color of the vertices' contour (only works for \code{pch 21} through \code{25} 102 | } 103 | \item{asp}{ 104 | (optional) aspect ratio of the plot 105 | } 106 | \item{seed}{ 107 | (optional) random seed number for the vertices' initial coordinates. Ignored except for \code{force}, \code{stress} and \code{rand} 108 | } 109 | \item{maxiter}{ 110 | (optional) maximum number of iterations in layout algorithms. Ignored except for \code{force}, \code{stress} and \code{rand} 111 | } 112 | \item{bwd}{ 113 | (optional) width of the bundle edges: ranges from \code{0} (edges collapsed) to the default \code{1} (depending on the vertices' size), and 114 | for \code{valued} a value greater than one is possible 115 | } 116 | \item{clu}{ 117 | (optional) clustering of the vertices (see \emph{details}) 118 | } 119 | \item{pch}{ 120 | (optional) symbol representing the vertices 121 | } 122 | \item{rot}{ 123 | (optional) clockwise rotation of the graph in degrees 124 | } 125 | \item{mirrorX}{ 126 | (optional) mirror of the \eqn{X} axis 127 | } 128 | \item{mirrorY}{ 129 | (optional) mirror of the \eqn{Y} axis 130 | } 131 | \item{mirrorV}{ 132 | \emph{same as \code{mirrorX}} 133 | } 134 | \item{mirrorH}{ 135 | \emph{same as \code{mirrorY}} 136 | } 137 | \item{hds}{ 138 | (optional and experimental) arcs' head scale 139 | } 140 | \item{vedist}{ 141 | (optional and experimental) a real number with vertex - edge distance 142 | } 143 | \item{jitter}{ 144 | (optional) jitter in \code{stress} or \code{CA} 145 | } 146 | \item{sort}{ 147 | (optional and logical) sort the vertex labels 148 | } 149 | \item{add}{ 150 | (optional) add nodes to the graph's domain 151 | } 152 | \item{adc}{ 153 | (optional) add nodes to the graph's codomain 154 | } 155 | \item{perm}{ 156 | (optional) a list of vectors for the permutation of network members in both the domain and codomain 157 | } 158 | \item{ffamily}{ 159 | (optional) font family 160 | } 161 | \item{fstyle}{ 162 | (optional) font style 163 | } 164 | \item{fsize}{ 165 | (optional) font size 166 | } 167 | \item{fcol}{ 168 | (optional) font color 169 | } 170 | \item{vclu}{ 171 | (optional) clustering information in both the domain and the codomain in a list of vectors with integers or \code{NULL} (see \emph{details}) 172 | } 173 | \item{\dots}{ 174 | Additional argument items (see e.g. \code{\link[graphics:par]{par}}) 175 | } 176 | } 177 | \details{ 178 | Bipartite graphs serve as visual aids for two-mode networks. While these networks are typically represented as data frames, they can also be visualized using three-dimensional arrays, where each level corresponds to a specific type of connection, resulting in parallel edges within the bipartite graph. Additionally, a bipartite network can be generated using a force-directed algorithm to create a visual representation. 179 | 180 | With bipartite graphs consisting of two sets of vertices, clustering information, such as vertex colors, can be stored in a list \code{vclu} with two vectors, one for each vertex set. It is possible to group all members of a vertex set into a single class by setting the corresponding vector to \code{NULL}. 181 | } 182 | \value{ 183 | A plot of the two-mode network as a bipartite graph or multigraph with a projection 184 | } 185 | %\references{ 186 | %% ~put references to the literature/web site here ~ 187 | %} 188 | \author{ 189 | Antonio Rivero Ostoic 190 | } 191 | %\note{ 192 | %% ~~further notes~~ 193 | %} 194 | 195 | %% ~Make other sections like Warning with \section{Warning }{....} ~ 196 | 197 | \seealso{ 198 | \code{\link{multigraph}}, \code{\link{frcd}}, \code{\link{stsm}}, \code{\link{conc}} 199 | } 200 | \examples{ 201 | ## two binary relations among three elements 202 | arr <- round( replace( array(runif(18), c(3,3,2)), array(runif(18), 203 | c(3,3,2))>.5, 3 ) ) 204 | 205 | ## network as bipartite graph 206 | bmgraph(arr) 207 | 208 | ## with a force directed algorithm 209 | bmgraph(arr, layout = "force") 210 | 211 | ## with a Correspondence Analysis method 212 | bmgraph(arr, layout = "CA", asp = NA) 213 | 214 | } 215 | \keyword{ graphics } 216 | -------------------------------------------------------------------------------- /man/bzrc.Rd: -------------------------------------------------------------------------------- 1 | \name{bzrc} 2 | \alias{bzrc} 3 | %- Also NEED an '\alias' for EACH other topic documented here. 4 | \title{ 5 | internal function 6 | } 7 | \description{ 8 | internal function 9 | } 10 | %\usage{ 11 | %bzrc(pair, cex, elv = 0.25, lng, ...) 12 | %} 13 | % 14 | \keyword{internal} 15 | -------------------------------------------------------------------------------- /man/ccbnd.Rd: -------------------------------------------------------------------------------- 1 | \name{ccbnd} 2 | \alias{ccbnd} 3 | %- Also NEED an '\alias' for EACH other topic documented here. 4 | \title{ 5 | internal function 6 | } 7 | \description{ 8 | internal function 9 | } 10 | %\usage{ 11 | %ccbnd(pares, r, b, vlt, cx, lwd, ecol, bw, alfa, fds, flgcx, flgcr, hds, n) 12 | %} 13 | % 14 | \keyword{internal} 15 | -------------------------------------------------------------------------------- /man/ccgraph.Rd: -------------------------------------------------------------------------------- 1 | \name{ccgraph} 2 | \alias{ccgraph} 3 | 4 | \title{ 5 | Cayley colour graph 6 | } 7 | \description{ 8 | A function to create and manipulate bipartite Cayley colour graphs 9 | } 10 | \usage{ 11 | ccgraph(x, main=NULL, seed=0, maxiter=100, alpha=c(1, 1, 1), scope, loops, 12 | collRecip, undRecip, showLbs, cex.main, conc, coord, clu, cex, lwd, 13 | pch, lty, bwd, bwd2, att, bg, mar, pos, asp, ecol, vcol, vcol0, lbs, 14 | col, lbat, swp, swp2, scl, mirrorX, mirrorY, mirrorD, mirrorL, mirrorV, 15 | mirrorH, rot, hds, vedist, ffamily, fstyle, fsize, fcol, nr, gens, ...) 16 | } 17 | 18 | \arguments{ 19 | \item{x}{ 20 | an algebraic structure, typically a \code{"Semigroup"} object class 21 | } 22 | \item{main}{ 23 | (optional) title of the plot 24 | } 25 | \item{seed}{ 26 | (optional) random seed number for the vertices' initial coordinates; ignored except for \code{force}, \code{stress} and \code{rand} 27 | } 28 | \item{maxiter}{ 29 | (optional) maximum number of iterations in layout algorithms; ignored except for \code{force}, \code{stress} and \code{rand} 30 | } 31 | \item{alpha}{ 32 | vector (vertex, edge, \code{bg}) with the alpha color transparency 33 | } 34 | \item{scope}{ 35 | (optional) scope of the graph (see details) 36 | } 37 | \item{loops}{ 38 | (optional, logical, and experimental) plot graph loops? 39 | } 40 | \item{collRecip}{ 41 | (optional and logical) whether or not collapse reciprocated edges in the undirected graph 42 | } 43 | \item{undRecip}{ 44 | (optional and logical) whether or not plot reciprocated edges as undirected 45 | } 46 | \item{showLbs}{ 47 | (optional and logical) whether or not show the vertex labels when dimnames available 48 | } 49 | \item{cex.main}{ 50 | (optional) size of the plot's title 51 | } 52 | \item{conc}{ 53 | (optional and logical) whether the layout is concentric or not 54 | } 55 | \item{coord}{ 56 | (optional) data frame with the coordinates of the vertices; if coordinates are given then the \code{layout} option is ignored 57 | } 58 | \item{clu}{ 59 | (optional) clustering of the vertices (see \emph{details}) 60 | } 61 | \item{cex}{ 62 | (optional) size of the vertices 63 | } 64 | \item{lwd}{ 65 | (optional) width of the edges; ignored if \code{valued} is set to \code{TRUE} 66 | } 67 | \item{pch}{ 68 | (optional) symbol representing the vertices 69 | } 70 | \item{lty}{ 71 | (optional) shape of the edges 72 | } 73 | \item{bwd}{ 74 | (optional) width of the bundle edges. Ranges from \code{0} (edges collapsed) to the default \code{1} (depending on the vertices' size), and 75 | for \code{valued} a value greater than one is possible 76 | } 77 | \item{bwd2}{ 78 | (optional) width of the bundle loop edges. 79 | } 80 | \item{att}{ 81 | (optional) a vector or an array representing the vertex attributes 82 | } 83 | \item{bg}{ 84 | (optional) background color of the plot 85 | } 86 | \item{mar}{ 87 | (optional) margins of the plot 88 | } 89 | \item{pos}{ 90 | (optional) position of the vertices' labels (\code{0} means ``at the center of the vertex'') 91 | } 92 | \item{asp}{ 93 | (optional) aspect ratio of the plot 94 | } 95 | \item{ecol}{ 96 | (optional) color of the edges 97 | } 98 | \item{vcol}{ 99 | (optional) color of the vertices 100 | } 101 | \item{vcol0}{ 102 | (optional) color of the vertices' contour (only works for \code{pch 21} through \code{25} 103 | } 104 | \item{lbs}{ 105 | (optional) vertex labels 106 | } 107 | \item{col}{ 108 | (optional) alias for \code{vcol} 109 | } 110 | \item{lbat}{ 111 | (optional) labels for the vertex attributes 112 | } 113 | \item{swp}{ 114 | (optional and logical) whether or not to swap the bundle patterns 115 | } 116 | \item{swp2}{ 117 | (optional and logical) whether or not to swap reciprocals 118 | } 119 | \item{scl}{ 120 | (optional and experimental) numerical scalar (\eqn{x} and \eqn{y}) or vector (\eqn{x}, \eqn{y}) of the graph's scale 121 | } 122 | \item{mirrorX}{ 123 | (optional) mirror of the \eqn{X} axis 124 | } 125 | \item{mirrorY}{ 126 | (optional) mirror of the \eqn{Y} axis 127 | } 128 | \item{mirrorD}{ 129 | (optional) mirror reflection across diagonal \eqn{Y=X} 130 | } 131 | \item{mirrorL}{ 132 | (optional) mirror reflection across diagonal \eqn{Y=-X} 133 | } 134 | \item{mirrorV}{ 135 | same as \code{mirrorX} 136 | } 137 | \item{mirrorH}{ 138 | same as \code{mirrorY} 139 | } 140 | \item{rot}{ 141 | (optional) clockwise rotation of the graph in degrees 142 | } 143 | \item{hds}{ 144 | (optional and experimental) arcs' head scale 145 | } 146 | \item{vedist}{ 147 | (optional and experimental) a real number with vertex - edge distance 148 | } 149 | \item{ffamily}{ 150 | the font family 151 | } 152 | \item{fstyle}{ 153 | the font style 154 | } 155 | \item{fsize}{ 156 | the font size 157 | } 158 | \item{fcol}{ 159 | the font color 160 | } 161 | \item{nr}{ 162 | for \code{conc} layout, number of radii 163 | } 164 | \item{gens}{ 165 | (optional when absent) semigroup generators in \code{x} 166 | } 167 | \item{\dots}{ 168 | Additional argument items (see e.g. \code{\link[graphics:par]{par}}) 169 | } 170 | } 171 | \details{ 172 | The Cayley colour graph is a graphical representation of the relationships among relations in the relational structure of a given multiplex network. 173 | Both nodes and directed edges represent string relations, and each shape (and color) corresponds to a specific generator relation of the semigroup structure. 174 | 175 | } 176 | \value{ 177 | A plot of the semigroup or group structure. 178 | } 179 | %\references{ 180 | %% ~put references to the literature/web site here ~ 181 | %} 182 | \author{ 183 | Antonio Rivero Ostoic 184 | } 185 | %\note{ 186 | %% ~~further notes~~ 187 | %} 188 | 189 | %% ~Make other sections like Warning with \section{Warning }{....} ~ 190 | 191 | \seealso{ 192 | \code{\link[multiplex:semigroup]{semigroup}}, \code{\link{multigraph}}, \code{\link{frcd}}, \code{\link{conc}} 193 | } 194 | 195 | 196 | \examples{ 197 | ## Create an abstract semigroup from random data 198 | arr <- round( replace( array(runif(18), c(3,3,2)), array(runif(18), 199 | c(3,3,2))>.5, 1 ) ) 200 | 201 | S <- semigroup(arr) 202 | 203 | ## plot semigroup's Cayley graph 204 | ccgraph(S) 205 | } 206 | \keyword{ graphics } 207 | \keyword{ math } 208 | -------------------------------------------------------------------------------- /man/conc.Rd: -------------------------------------------------------------------------------- 1 | \name{conc} 2 | \alias{conc} 3 | \title{ 4 | Concentric layout 5 | } 6 | \description{ 7 | A function to compute the graph coordinated system with a concentric layout 8 | } 9 | \usage{ 10 | conc(net, nr, irot, inv, flip, mirror=c("N","X","Y","D","L"), ...) 11 | } 12 | %- maybe also 'usage' for other objects documented here. 13 | \arguments{ 14 | \item{net}{ 15 | an array representing the network relations 16 | } 17 | \item{nr}{ 18 | a scalar with the number of radii, or a vector with the clustering of the actors. 19 | } 20 | \item{irot}{ 21 | a scalar or vector with the ``internal rotation'' for each circle from closer to the center point to further away 22 | } 23 | \item{inv}{ 24 | (optional and logical) should the circles be with an inverted ordering? 25 | } 26 | \item{flip}{ 27 | (optional and logical) should the alternating circles be flipped? 28 | } 29 | \item{mirror}{ 30 | mirror transformation 31 | 32 | \itemize{ 33 | \item \code{N} identity (default) 34 | \item \code{X} reflection through the vertical center line 35 | \item \code{Y} reflection through the horizontal center line 36 | \item \code{D} reflection across diagonal \eqn{Y=X} 37 | \item \code{L} reflection across diagonal \eqn{Y=-X} 38 | } 39 | } 40 | \item{\dots}{ 41 | Additional argument items 42 | } 43 | } 44 | \details{ 45 | In a Euclidean plane computes the coordinated system with a concentric layout with at least two radii (unless \eqn{n = 1}). 46 | In case that the number of radii is not specified in \code{nr}, approx. half of the vertices are located at one radius and half in another one. 47 | 48 | The clustering of the actors may be used to establish the location of the vertices in different radii as a numerical, character, or factor vector. 49 | } 50 | \value{ 51 | A data frame with a coordinated system with two columns representing the abscissa and the ordinate in a two-dimensional rectangular Cartesian coordinate system. 52 | } 53 | %\references{ 54 | %% ~put references to the literature/web site here ~ 55 | %} 56 | \author{ 57 | Antonio Rivero Ostoic 58 | } 59 | %\note{ 60 | %% ~~further notes~~ 61 | %} 62 | 63 | \seealso{ 64 | \code{\link{multigraph}}, \code{\link{bmgraph}}, \code{\link{frcd}}, \code{\link{stsm}} 65 | } 66 | \examples{ 67 | ## Create the data: two binary relations among three elements 68 | arr <- round( replace( array(runif(18), c(3,3,2)), array(runif(18), 69 | c(3,3,2))>.5, 3 ) ) 70 | 71 | ## Coordinates for the concentric layout with two radii 72 | coord <- conc(arr, nr = 2) 73 | 74 | ## Plot multigraph with customized coordinates 75 | multigraph(arr, coord = coord) 76 | 77 | } 78 | \keyword{ graphics } 79 | \keyword{ manip } 80 | -------------------------------------------------------------------------------- /man/frcd.Rd: -------------------------------------------------------------------------------- 1 | \name{frcd} 2 | \alias{frcd} 3 | \title{ 4 | Force directed layout 5 | } 6 | \description{ 7 | A function to compute the graph coordinated system with a force directed layout algorithm 8 | } 9 | \usage{ 10 | frcd(net, seed = seed, maxiter, drp, scl, mov, ...) 11 | } 12 | %- maybe also 'usage' for other objects documented here. 13 | \arguments{ 14 | \item{net}{ 15 | an array representing the network relations 16 | } 17 | \item{seed}{ 18 | (mandatory) the seed of the initial layout (see \emph{details}) 19 | } 20 | \item{maxiter}{ 21 | (optional) the maximum number of iterations 22 | } 23 | \item{\dots}{ 24 | Additional argument items 25 | } 26 | \item{scl}{ 27 | (optional and experimental) numerical scalar (\eqn{x} and \eqn{y}) or vector (\eqn{x}, \eqn{y}) of the graph's scale 28 | } 29 | \item{mov}{ 30 | (optional and experimental) numerical scalar (\eqn{x} and \eqn{y}) or vector (\eqn{x}, \eqn{y}) to move the graph 31 | } 32 | \item{drp}{ 33 | (optional) for \code{valued} networks, drop values less than specified 34 | } 35 | } 36 | \details{ 37 | This function is meant as an internal routine for graph visualization with a force-directed layout procedure. 38 | However, it can be used to set the coordinate system with the \code{coord} option in functions \code{\link{multigraph}} and in \code{\link{bmgraph}}. 39 | In such case, the coordinate system of the graph starts with a random displacement of nodes where \code{NULL} in the \code{seed} argument implies 40 | an initial seed based on the computer clock watch, and the number of iterations in \code{maxiter} is \eqn{60+n}. 41 | } 42 | \value{ 43 | A data frame with a coordinated system with two columns representing the abscissa and the ordinate in a two-dimensional rectangular Cartesian coordinate system. 44 | } 45 | \references{ 46 | Fruchterman, T.M.J., & Reingold, E.M. Graph drawing by force-directed placement. \emph{Software-Practice & Experience}, 21(11), 1129-1164. 1991. 47 | } 48 | \author{ 49 | Antonio Rivero Ostoic 50 | } 51 | %\note{ 52 | %% ~~further notes~~ 53 | %} 54 | 55 | %% ~Make other sections like Warning with \section{Warning }{....} ~ 56 | 57 | \seealso{ 58 | \code{\link{multigraph}}, \code{\link{bmgraph}}, \code{\link{stsm}}, \code{\link{conc}} 59 | } 60 | \examples{ 61 | ## Create the data: two binary relations among three elements 62 | arr <- round( replace( array(runif(18), c(3,3,2)), array(runif(18), 63 | c(3,3,2))>.5, 3 ) ) 64 | 65 | ## Coordinates for the force directed layout with random start 66 | coord <- frcd(arr, seed = NULL) 67 | 68 | ## Plot multigraph with customized coordinates 69 | multigraph(arr, coord = coord) 70 | 71 | } 72 | \keyword{ graphics } 73 | \keyword{ manip } 74 | -------------------------------------------------------------------------------- /man/hc.Rd: -------------------------------------------------------------------------------- 1 | \name{hc} 2 | \alias{hc} 3 | \title{ 4 | internal function 5 | } 6 | \description{ 7 | internal function 8 | } 9 | %\usage{ 10 | %hc(x, y, r, nsteps = 900, ...) 11 | %} 12 | % 13 | \keyword{internal} 14 | -------------------------------------------------------------------------------- /man/lz.Rd: -------------------------------------------------------------------------------- 1 | \name{lz} 2 | \alias{lz} 3 | \title{ 4 | internal function 5 | } 6 | \description{ 7 | internal function 8 | } 9 | %\usage{ 10 | %lz(x, delta, w) 11 | %} 12 | % 13 | \keyword{internal} 14 | -------------------------------------------------------------------------------- /man/mbnd.Rd: -------------------------------------------------------------------------------- 1 | \name{mbnd} 2 | \alias{mbnd} 3 | \title{ 4 | internal function 5 | } 6 | \description{ 7 | internal function 8 | } 9 | %\usage{ 10 | %mbnd(pares, r, b, vlt, cx, lwd, ecol, directed, asp, bwd, alfa, fds, flgcx, valued) 11 | %} 12 | % 13 | \keyword{internal} 14 | -------------------------------------------------------------------------------- /man/mlgraph.Rd: -------------------------------------------------------------------------------- 1 | \name{mlgraph} 2 | \alias{mlgraph} 3 | %- Also NEED an '\alias' for EACH other topic documented here. 4 | \title{ 5 | Multilevel graph 6 | } 7 | \description{ 8 | A function to create and manipulate multilevel graphs 9 | } 10 | \usage{ 11 | mlgraph(net, layout = c("circ", "force", "stress", "rand", "conc", "bip"), main = NULL, 12 | seed = NULL, maxiter = 100, directed = TRUE, alpha = c(1, 1, 1), scope, collRecip, 13 | undRecip, showLbs, showAtts, cex.main, coord, clu, cex, lwd, pch, lty, bwd, bwd2, 14 | att, bg, mar, pos, asp, ecol, vcol, vcol0, col, lbat, swp, loops, swp2, mirrorX, 15 | mirrorY, mirrorD, mirrorL, lbs, mirrorV, mirrorH, rot, hds, scl, vedist, ffamily, 16 | fstyle, fsize, fcol, valued, modes, elv, lng, nr, ...) 17 | } 18 | %- maybe also 'usage' for other objects documented here. 19 | \arguments{ 20 | \item{net}{ 21 | a \code{"Multilevel"} class object or a three dimensional array with clustering information 22 | } 23 | \item{layout}{ 24 | the visualization layout: 25 | 26 | \itemize{ 27 | \item \code{circ} circular 28 | \item \code{force} force-directed 29 | \item \code{stress} stress-majorization 30 | \item \code{rand} random 31 | \item \code{conc} concentric 32 | \item \code{bip} as bipartite graph 33 | } 34 | } 35 | \item{main}{ 36 | (optional) title of the plot 37 | } 38 | \item{seed}{ 39 | (optional) random seed number for the vertices' initial coordinates. Ignored except for \code{force}, \code{stress} and \code{rand} 40 | } 41 | \item{maxiter}{ 42 | (optional) maximum number of iterations in layout algorithms. Ignored except for \code{force}, \code{stress} and \code{rand} 43 | } 44 | \item{directed}{ 45 | (logical) whether or not the graph is directed or undirected 46 | } 47 | \item{alpha}{ 48 | vector (vertex, edge, \code{bg}) with the alpha color transparency 49 | } 50 | \item{scope}{ 51 | (optional) scope of the graph (see details) 52 | } 53 | \item{collRecip}{ 54 | (optional and logical) whether or not collapse reciprocated edges in the undirected graph 55 | } 56 | \item{undRecip}{ 57 | (optional and logical) whether or not plot reciprocated edges as undirected 58 | } 59 | \item{showLbs}{ 60 | (optional and logical) whether or not to show the vertex labels 61 | } 62 | \item{showAtts}{ 63 | (optional and logical) whether or not to show the vertex attribute labels 64 | } 65 | \item{cex.main}{ 66 | (optional) size of the plot's title 67 | } 68 | \item{coord}{ 69 | (optional) data frame with the coordinates of the vertices. If coordinates are given then the \code{layout} option is ignored 70 | } 71 | \item{clu}{ 72 | (optional) clustering of the vertices as a list of vectors with integers or NULL (see \emph{details}) 73 | } 74 | \item{cex}{ 75 | (optional) size of the vertices 76 | } 77 | \item{lwd}{ 78 | (optional) width of the edges; ignored if \code{valued} is set to \code{TRUE} 79 | } 80 | \item{pch}{ 81 | (optional) symbol representing the vertices 82 | } 83 | \item{lty}{ 84 | (optional) shape of the edges 85 | } 86 | \item{bwd}{ 87 | (optional) width of the bundle edges. Ranges from \code{0} (edges collapsed) to the default \code{1} (depending on the vertices' size), and 88 | for \code{valued} a value greater than one is possible 89 | } 90 | \item{bwd2}{ 91 | (optional) width of the bundle loop edges. 92 | } 93 | \item{att}{ 94 | (optional) a vector or an array representing the vertex attributes 95 | } 96 | \item{bg}{ 97 | (optional) background color of the plot 98 | } 99 | \item{mar}{ 100 | (optional) margins of the plot 101 | } 102 | \item{pos}{ 103 | (optional) position of the vertices' labels (\code{0} means ``at the center of the vertex'') 104 | } 105 | \item{asp}{ 106 | (optional) aspect ratio of the plot 107 | } 108 | \item{ecol}{ 109 | (optional) color of the edges 110 | } 111 | \item{vcol}{ 112 | (optional) color of the vertices 113 | } 114 | \item{vcol0}{ 115 | (optional) color of the vertices' contour (only works for \code{pch 21} through \code{25} 116 | } 117 | \item{col}{ 118 | (optional) alias for \code{vcol} 119 | } 120 | \item{lbat}{ 121 | (optional) labels for the vertex attributes 122 | } 123 | \item{swp}{ 124 | (optional and logical) whether or not to swap the bundle patterns 125 | } 126 | \item{loops}{ 127 | (optional, logical, and experimental) plot graph loops? 128 | } 129 | \item{swp2}{ 130 | (optional and logical) whether or not to swap reciprocals 131 | } 132 | \item{mirrorX}{ 133 | (optional) mirror of the \eqn{X} axis 134 | } 135 | \item{mirrorY}{ 136 | (optional) mirror of the \eqn{Y} axis 137 | } 138 | \item{mirrorD}{ 139 | (optional) mirror reflection across diagonal \eqn{Y=X} 140 | } 141 | \item{mirrorL}{ 142 | (optional) mirror reflection across diagonal \eqn{Y=-X} 143 | } 144 | \item{lbs}{ 145 | (optional) vertex labels 146 | } 147 | \item{mirrorV}{ 148 | same as \code{mirrorX} 149 | } 150 | \item{mirrorH}{ 151 | same as \code{mirrorY} 152 | } 153 | \item{rot}{ 154 | (optional) clockwise rotation of the graph in degrees 155 | } 156 | \item{hds}{ 157 | (optional and experimental) arcs' head scale 158 | } 159 | \item{scl}{ 160 | (optional and experimental) numerical scalar (\eqn{x} and \eqn{y}) or vector (\eqn{x}, \eqn{y}) of the graph's scale 161 | } 162 | \item{vedist}{ 163 | (optional and experimental) a real number with vertex - edge distance 164 | } 165 | \item{ffamily}{ 166 | the font family 167 | } 168 | \item{fstyle}{ 169 | the font style 170 | } 171 | \item{fsize}{ 172 | the font size 173 | } 174 | \item{fcol}{ 175 | the font color 176 | } 177 | \item{valued}{ 178 | (optional and logical) whether the graph is depicyed as valued or not 179 | } 180 | \item{modes}{ 181 | (optional) a vector indicating which matrices are domains and which codomains (works only with a \code{"Multilevel"} class object) 182 | } 183 | \item{elv}{ 184 | (experimental) control loops 1 185 | } 186 | \item{lng}{ 187 | (experimental) control loops 2 188 | } 189 | \item{nr}{ 190 | integer or \code{NULL} with the number of radii for \code{conc} layout (see \emph{details}) 191 | } 192 | \item{\dots}{ 193 | Additional argument items (see e.g. \code{\link[graphics:par]{par}}) 194 | } 195 | } 196 | \details{ 197 | Multilevel graphs serve to represent networks with different ``levels'' such as different domains in the network structure. 198 | A characteristic of multilevel networks is the existence of ties within and across domains. 199 | 200 | Since this function can handle a large number of arguments, these can be stored as a list object that is passed through the \code{scope} option. 201 | In this case, a vector made of lists and scalars or combinations of these is accepted. 202 | 203 | The bundle width specified by \code{bwd} and \code{bwd2} ranges from \code{0} (edges collapsed) to the default \code{1} (depending on the vertices' size). 204 | For the \code{valued} option, a number greater than one is possible. 205 | 206 | In a multilevel structure, argument \code{clu} is to class network members 207 | and it is possible to class all members of the domain or co-domain into a single class by setting the vector to \code{NULL}. 208 | Similarly, \code{NULL} in argument \code{nr} for the \code{conc} layout implies the use of two radii, one for each domain. 209 | } 210 | \value{ 211 | A plot of the multilevel graph structure for the network 212 | } 213 | %\references{ 214 | %% ~put references to the literature/web site here ~ 215 | %} 216 | \author{ 217 | Antonio Rivero Ostoic 218 | } 219 | \note{ 220 | Multilevel graphs depend on multilevel class objects 221 | } 222 | 223 | %% ~Make other sections like Warning with \section{Warning }{....} ~ 224 | 225 | \seealso{ 226 | \code{\link[multiplex:mlvl]{mlvl}}, \code{\link{multigraph}}, \code{\link{bmgraph}}, \code{\link{frcd}}, \code{\link{stsm}}, \code{\link{conc}} 227 | } 228 | \examples{ 229 | ## Not run: 230 | # create network data as arrays 231 | arr <- round( replace( array(runif(18), c(3,3,2)), array(runif(18), 232 | c(3,3,2))>.5, 3 ) ) 233 | arr2 <- round( replace( array(runif(18), c(3,3,2)), array(runif(18), 234 | c(3,3,2))>.5, 3 ) ) 235 | 236 | # create multilevel class object and plot multilevel graph 237 | require(multiplex) 238 | mlvl(arr, arr2) |> 239 | mlgraph() 240 | ## End(**Not run**) 241 | } 242 | \keyword{ graphics } 243 | -------------------------------------------------------------------------------- /man/multigraph-package.Rd: -------------------------------------------------------------------------------- 1 | \name{multigraph-package} 2 | \alias{multigraph-package} 3 | %\alias{multigraph} 4 | \docType{package} 5 | \title{ 6 | Plot and Manipulate Multigraphs 7 | } 8 | \description{ 9 | Functions to create and manipulate multigraphs, bipartite graphs, Cayley graphs, and valued multilevel graphs. 10 | } 11 | \details{ 12 | \tabular{ll}{ 13 | Package: \tab multigraph \cr 14 | Type: \tab Package \cr 15 | Version: \tab 0.99-4 (devel) \cr 16 | Depends: \tab \CRANpkg{multiplex} (>= 3.0.0) \cr 17 | Date: \tab 14 May 2024 \cr 18 | License: \tab GPL-3 \cr 19 | } 20 | This package contains functions to plot diverse types of graphs representing complex network structures. 21 | For one-mode data, it is possible to depict signed and valued multigraphs and bipartite graphs for two-mode data as well. 22 | Moreover, multilevel graphs that \emph{combine} one- and two-mode network data are represented with the latest function. 23 | Finally, Cayley graphs serve to depict relations among the ties in multiplex networks recorded in the algebraic object semigroup. 24 | 25 | Note that this package is still under development. 26 | } 27 | \author{ 28 | J. Antonio Rivero Ostoic 29 | 30 | Maintainer: Antonio Rivero Ostoic 31 | } 32 | \references{ 33 | Ostoic, J.A.R. \emph{Algebraic Analysis of Social Networks: Models, Methods and Applications Using R}, Wiley, 2021 34 | 35 | Ostoic, J.A.R. ``Algebraic Analysis of Multiple Social Networks with \code{multiplex}.'' \emph{Journal of Statistical Software}, 91(11), 1-41. 36 | } 37 | 38 | \seealso{ 39 | \code{\link[multiplex:multiplex-package]{multiplex-package}}, \code{\link[multiplex:incubs]{incubs}}, \code{\link[multiplex:zbind]{zbind}}, \code{\link[multiplex:transf]{transf}} 40 | } 41 | 42 | \keyword{ graphs} 43 | \keyword{ manip } 44 | \keyword{ IO } 45 | \keyword{ data } 46 | \keyword{ file } 47 | -------------------------------------------------------------------------------- /man/multigraph.Rd: -------------------------------------------------------------------------------- 1 | \name{multigraph} 2 | \alias{multigraph} 3 | \title{ 4 | Multigraphs and valued multigraphs 5 | } 6 | \description{ 7 | A function to create and manipulate multigraphs and valued multigraphs with different layout options 8 | } 9 | \usage{ 10 | multigraph(net, layout = c("circ", "force", "stress", "conc", "rand"), scope, 11 | directed=TRUE, loops, signed, valued, values, lbs, showLbs, att, lbat, 12 | showAtts, main=NULL, cex.main, col.main, font.main, coord, collRecip, undRecip, 13 | seed=NULL, maxiter=100, clu, cex, cex2, pch, lwd, lty, vcol, vcol0, col, ecol, 14 | bwd, bwd2, pos, bg, bg2, asp, drp, add, swp, swp2, alpha=c(1, 1, 1, 1), rot, 15 | mirrorX, mirrorY, mirrorD, mirrorL, mirrorV, mirrorH, scl, hds, vedist, mar, 16 | ffamily, fstyle, fsize, fsize2, fcol, fcol2, lclu, sel, new, mai, lscl, 17 | rm.isol, ...) 18 | } 19 | \arguments{ 20 | \item{net}{ 21 | an array; usually with three dimensions of stacked matrices where the multiple relations are placed. 22 | } 23 | \item{layout}{ 24 | the visualization layout: 25 | 26 | \itemize{ 27 | \item \code{circ} circular 28 | \item \code{force} force-directed 29 | \item \code{stress} stress-majorization 30 | \item \code{conc} concentric 31 | \item \code{rand} random 32 | } 33 | 34 | } 35 | \item{scope}{ 36 | (optional) the scope of the graph (see \emph{details}) 37 | } 38 | \item{directed}{ 39 | (logical) whether or not the graph is directed or unidrected 40 | } 41 | \item{loops}{ 42 | (optional, logical, and experimental) plot graph loops? 43 | } 44 | \item{signed}{ 45 | (optional and logical) whether or not the graph is a signed structure 46 | } 47 | \item{valued}{ 48 | (optional and logical) whether the graph is depicyed as valued or not 49 | } 50 | \item{values}{ 51 | (optional and logical) print the values of the bonds in edges? 52 | } 53 | \item{lbs}{ 54 | (optional) the vertices labels 55 | } 56 | \item{showLbs}{ 57 | (optional and logical) whether or not show the vertex labels 58 | } 59 | \item{att}{ 60 | (optional) a vector or an array representing the vertex attributes 61 | } 62 | \item{lbat}{ 63 | (optional) the labels for the vertices' attributes 64 | } 65 | \item{showAtts}{ 66 | (optional and logical) whether or not show the vertex attribute labels 67 | } 68 | \item{main}{ 69 | (optional) title of the plot 70 | } 71 | \item{cex.main}{ 72 | (optional) the size of the plot's title 73 | } 74 | \item{col.main}{ 75 | (optional) the color of the plot's title 76 | } 77 | \item{font.main}{ 78 | (optional) the font of the plot's title 79 | } 80 | \item{coord}{ 81 | (optional) data frame with the coordinates of the vertices. If coordinates are given then the \code{layout} option is ignored 82 | } 83 | \item{collRecip}{ 84 | (optional and logical) whether or not collapse reciprocated edges in the unidrected graph 85 | } 86 | \item{undRecip}{ 87 | (optional and logical) whether or not plot reciprocated edges as undirected 88 | } 89 | \item{seed}{ 90 | (optional) the random seed number for the vertices' initial coordinates. Ignored for \code{circ} and \code{conc} 91 | } 92 | \item{maxiter}{ 93 | (optional) the maximum number of iterations in layout algorithms. Only for \code{force}, \code{stress}, and \code{rand} 94 | } 95 | \item{clu}{ 96 | (optional) the clustering of the vertices (see \emph{details}) 97 | } 98 | \item{cex}{ 99 | (optional) the size of the vertices 100 | } 101 | \item{cex2}{ 102 | the size of the background for the values with the \code{valued} option 103 | } 104 | \item{pch}{ 105 | (optional) the symbol representing the vertices 106 | } 107 | \item{lwd}{ 108 | (optional) the width of the edges; ignored if \code{valued} is set to \code{TRUE} 109 | } 110 | \item{lty}{ 111 | (optional) the shape of the edges 112 | } 113 | \item{vcol}{ 114 | (optional) the color of the vertices 115 | } 116 | \item{vcol0}{ 117 | (optional) the color of the vertices' contour (only works for \code{pch 21} through \code{25} 118 | } 119 | \item{col}{ 120 | (optional) alias for \code{vcol} 121 | } 122 | \item{ecol}{ 123 | (optional) the color of the edges 124 | } 125 | \item{bwd}{ 126 | (optional) the width of the bundle edges. 127 | } 128 | \item{bwd2}{ 129 | (optional) the width of the bundle loop edges. 130 | } 131 | \item{pos}{ 132 | (optional) the position of the vertices' labels (\code{0} means ``in middle of vertex'') 133 | } 134 | \item{bg}{ 135 | (optional) the background color of the plot 136 | } 137 | \item{bg2}{ 138 | (optional) the background color for \code{values} 139 | } 140 | \item{asp}{ 141 | (optional) the aspect ratio of the plot 142 | } 143 | \item{drp}{ 144 | (optional) for \code{valued} networks, drop values less than the specified 145 | } 146 | \item{add}{ 147 | (optional) nodes to add to the graph 148 | } 149 | \item{swp}{ 150 | (optional and logical) whether or not swap the bundle patterns 151 | } 152 | \item{swp2}{ 153 | (optional and logical) whether or not swap reciprocals 154 | } 155 | \item{alpha}{ 156 | vector (vertex, edge, \code{bg}) with the alpha color transparecy 157 | } 158 | \item{rot}{ 159 | (optional) clockwise rotation of the graph in degrees 160 | } 161 | \item{mirrorX}{ 162 | (optional) mirror of the \eqn{X} axis 163 | } 164 | \item{mirrorY}{ 165 | (optional) mirror of the \eqn{Y} axis 166 | } 167 | \item{mirrorD}{ 168 | (optional) mirror reflection across diagonal \eqn{Y=X} 169 | } 170 | \item{mirrorL}{ 171 | (optional) mirror reflection across diagonal \eqn{Y=-X} 172 | } 173 | \item{mirrorV}{ 174 | same as \code{mirrorX} 175 | } 176 | \item{mirrorH}{ 177 | same as \code{mirrorY} 178 | } 179 | \item{scl}{ 180 | (optional and experimental) numerical scalar (\eqn{x} and \eqn{y}) or vector (\eqn{x}, \eqn{y}) of the graph's scale 181 | } 182 | \item{hds}{ 183 | (optional and experimental) arcs' head scale 184 | } 185 | \item{vedist}{ 186 | (optional and experimental) a real number with vertex - edge distance 187 | } 188 | \item{mar}{ 189 | (optional) the margins of the plot 190 | } 191 | \item{ffamily}{ 192 | the font family 193 | } 194 | \item{fstyle}{ 195 | the font style 196 | } 197 | \item{fsize}{ 198 | the font size 199 | } 200 | \item{fsize2}{ 201 | the font size for \code{values} 202 | } 203 | \item{fcol}{ 204 | the font color 205 | } 206 | \item{fcol2}{ 207 | the font color for \code{values} 208 | } 209 | \item{lclu}{ 210 | (optional, vector) ``levels'' in \code{clu} (see \emph{details}) 211 | } 212 | \item{sel}{ 213 | (optional, vector) selection of node's labels to plot 214 | } 215 | \item{new}{ 216 | (optional, logical) new graph on an existing plot? 217 | } 218 | \item{mai}{ 219 | (optional, vector) plot inner margins 220 | } 221 | \item{lscl}{ 222 | (optional for valued graphs) loop scale 223 | } 224 | \item{rm.isol}{ 225 | (optional) remove isolated vertices? 226 | } 227 | \item{\dots}{ 228 | Additional argument items (see e.g. \code{\link[graphics:par]{par}}) 229 | } 230 | } 231 | \details{ 232 | Multigraphs are graphs having parallel edges depicting different types of relations in a network. By default, a circular layout is applied where each type of tie has a distinctive shape and gray color scale. 233 | For better visualization, undirected multigraphs automatically collapse the reciprocal relations, and there is an argument to prevent this from happening. It is possible to combine the symbols and colors of vertices by assigning a class to each network member in the clustering option. Vertices can also have different sizes by specifying the argument with a vector with a length size similar to the network order. 234 | 235 | Since this function can handle a large number of arguments, these can be stored as a list object that is passed through the \code{scope} option. In this case, a vector made of lists and scalars or combinations of these is accepted for describing characteristics. 236 | 237 | The bundle width specified by \code{bwd} (and \code{bwd2} for loops) ranges from \code{0} (edges collapsed) to the default \code{1} (depending on the vertices' size). For the \code{valued} option, numbers higher than one are possible. 238 | Use \code{vedist} to adjust vertex--edge distance for large and dense networks. 239 | 240 | In some cases, such as when working with dynamic networks, it is needed to specify the ordering of the ``levels'' of the clustering information given in \code{clu}, and this is done in argument \code{lclu}. 241 | 242 | When using \code{new} for plotting the graph with a background image, the previous plot(s), however, can require having an equivalent command to \code{\link[graphics:plot.new]{graphics::plot.new()}} 243 | (cf. e.g. \code{\link[sdam:plot.map]{sdam::plot.map()}} function). 244 | } 245 | \value{ 246 | A plot of the network as a multigraph or a valued multigraph. 247 | } 248 | %\references{ 249 | %% ~put references to the literature/web site here ~ 250 | %} 251 | \author{ 252 | Antonio Rivero Ostoic 253 | } 254 | %\note{ 255 | %% ~~further notes~~ 256 | %} 257 | 258 | %% ~Make other sections like Warning with \section{Warning }{....} ~ 259 | 260 | \seealso{ 261 | \code{\link{bmgraph}}, \code{\link{ccgraph}}, \code{\link{frcd}}, \code{\link{stsm}}, \code{\link{conc}} 262 | } 263 | \examples{ 264 | ## Create the data: two binary relations among three elements 265 | arr <- round( replace( array(runif(18), c(3,3,2)), array(runif(18), 266 | c(3,3,2))>.5, 3 ) ) 267 | 268 | ## Plot the multigraph of this network 269 | multigraph(arr) 270 | 271 | ## Now with a force directed algorithm 272 | multigraph(arr, layout = "force") 273 | 274 | ## As weighted graph 275 | multigraph(arr, weighted = TRUE) 276 | 277 | ## As signed graph 278 | multigraph(arr, signed = TRUE) 279 | 280 | ## With loops and a costumized vertex size 281 | multigraph(arr, cex = 3, loops = TRUE) 282 | 283 | } 284 | 285 | \keyword{ graphics } 286 | -------------------------------------------------------------------------------- /man/nrm.Rd: -------------------------------------------------------------------------------- 1 | \name{nrm} 2 | \alias{nrm} 3 | \title{ 4 | internal function 5 | } 6 | \description{ 7 | internal function 8 | } 9 | % 10 | \keyword{internal} 11 | -------------------------------------------------------------------------------- /man/popl.Rd: -------------------------------------------------------------------------------- 1 | \name{popl} 2 | \alias{popl} 3 | \title{ 4 | internal function 5 | } 6 | \description{ 7 | internal function 8 | } 9 | % 10 | \keyword{internal} 11 | -------------------------------------------------------------------------------- /man/rng.Rd: -------------------------------------------------------------------------------- 1 | \name{rng} 2 | \alias{rng} 3 | \title{ 4 | internal function 5 | } 6 | \description{ 7 | internal function 8 | } 9 | % 10 | \keyword{internal} 11 | -------------------------------------------------------------------------------- /man/sts.Rd: -------------------------------------------------------------------------------- 1 | \name{sts} 2 | \alias{sts} 3 | \title{ 4 | internal function 5 | } 6 | \description{ 7 | internal function 8 | } 9 | %\usage{ 10 | %sts(nds, delta = NULL, mwd = NULL) 11 | %} 12 | % 13 | \keyword{internal} 14 | -------------------------------------------------------------------------------- /man/stsm.Rd: -------------------------------------------------------------------------------- 1 | \name{stsm} 2 | \alias{stsm} 3 | \title{ 4 | Stress majorization layout 5 | } 6 | \description{ 7 | A function to compute the graph coordinated system with a stress majorization layout algorithm 8 | } 9 | \usage{ 10 | stsm(net, seed = seed, maxiter = 40, drp, jitter, method, ...) 11 | } 12 | %- maybe also 'usage' for other objects documented here. 13 | \arguments{ 14 | \item{net}{ 15 | an array representing the network relations 16 | } 17 | \item{seed}{ 18 | (mandatory) the seed of the initial layout (see \emph{details}) 19 | } 20 | \item{maxiter}{ 21 | (optional) the maximum number of iterations 22 | } 23 | \item{drp}{ 24 | (optional) for \code{valued} networks, drop values less than specified 25 | } 26 | \item{jitter}{ 27 | (optional) jitter in the layout 28 | } 29 | \item{method}{ 30 | (optional) initial distance method (default \code{binary}) 31 | } 32 | \item{\dots}{ 33 | Additional argument items 34 | } 35 | } 36 | \details{ 37 | Like the function \code{\link{frcd}}, this routine serves as an internal tool for graph visualization. It is also designed to establish the coordinate system using the \code{coord} option within the \code{\link{multigraph}} and \code{\link{bmgraph}} functions. 38 | In this scenario, the graph's coordinate system commences with nodes randomly positioned, and if \code{NULL} is entered in the \code{seed} argument, an initial seed will be generated based on the computer clock watch where the number of iterations in \code{maxiter} is \eqn{40}. 39 | } 40 | \value{ 41 | A data frame with a coordinated system with two columns representing the abscissa and the ordinate in a two-dimensional rectangular Cartesian coordinate system. 42 | } 43 | \references{ 44 | Gansner, E.R., Koren, Y., & North, S. \emph{Graph drawing by stress majorization}. In Graph Drawing: 12th International Symposium, gd 2004, New York, NY, USA, September 29 - October 2, 2004, revised selected papers. Berlin Heidelberg: Springer. pp. 239-250. 2005. 45 | } 46 | \author{ 47 | Antonio Rivero Ostoic 48 | } 49 | %\note{ 50 | %% ~~further notes~~ 51 | %} 52 | 53 | %% ~Make other sections like Warning with \section{Warning }{....} ~ 54 | 55 | \seealso{ 56 | \code{\link{multigraph}}, \code{\link{bmgraph}}, \code{\link{frcd}}, \code{\link{conc}} 57 | } 58 | \examples{ 59 | ## Create the data: two binary relations among three elements 60 | arr <- round( replace( array(runif(18), c(3,3,2)), array(runif(18), 61 | c(3,3,2))>.5, 3 ) ) 62 | 63 | ## Coordinates for the stress majorization layout with random start 64 | coord <- stsm(arr, seed = NULL) 65 | 66 | ## Plot multigraph with customized coordinates 67 | multigraph(arr, coord = coord) 68 | 69 | } 70 | \keyword{ graphics } 71 | \keyword{ manip } 72 | -------------------------------------------------------------------------------- /man/xyrt.Rd: -------------------------------------------------------------------------------- 1 | \name{xyrt} 2 | \alias{xyrt} 3 | \title{ 4 | internal function 5 | } 6 | \description{ 7 | internal function 8 | } 9 | % 10 | \keyword{internal} 11 | -------------------------------------------------------------------------------- /man/xyrtb.Rd: -------------------------------------------------------------------------------- 1 | \name{xyrtb} 2 | \alias{xyrtb} 3 | \title{ 4 | internal function 5 | } 6 | \description{ 7 | internal function 8 | } 9 | % 10 | \keyword{internal} 11 | --------------------------------------------------------------------------------