1
2## ----------------------------------------------------------------
3##
4##   IGraph R package
5##   Copyright (C) 2005-2014  Gabor Csardi <csardi.gabor@gmail.com>
6##   334 Harvard street, Cambridge, MA 02139 USA
7##
8##   This program is free software; you can redistribute it and/or modify
9##   it under the terms of the GNU General Public License as published by
10##   the Free Software Foundation; either version 2 of the License, or
11##   (at your option) any later version.
12##
13##   This program is distributed in the hope that it will be useful,
14##   but WITHOUT ANY WARRANTY; without even the implied warranty of
15##   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16##   GNU General Public License for more details.
17##
18##   You should have received a copy of the GNU General Public License
19##   along with this program; if not, write to the Free Software
20##   Foundation, Inc.,  51 Franklin Street, Fifth Floor, Boston, MA
21##   02110-1301 USA
22##
23## -----------------------------------------------------------------
24
25graph.adjacency.dense <- function(adjmatrix, mode=c("directed", "undirected", "max",
26                                               "min", "upper", "lower", "plus"),
27                                  weighted=NULL, diag=TRUE) {
28
29  mode <- igraph.match.arg(mode)
30  mode <- switch(mode,
31                 "directed"=0,
32                 "undirected"=1,
33                 "max"=1,
34                 "upper"=2,
35                 "lower"=3,
36                 "min"=4,
37                 "plus"=5)
38
39  mode(adjmatrix) <- "double"
40
41  if (!is.null(weighted)) {
42    if (is.logical(weighted) && weighted) {
43      weighted <- "weight"
44    }
45    if (!is.character(weighted)) {
46      stop("invalid value supplied for `weighted' argument, please see docs.")
47    }
48
49    if (nrow(adjmatrix) != ncol(adjmatrix)) {
50      stop("not a square matrix")
51    }
52
53    on.exit( .Call(C_R_igraph_finalizer) )
54    res <- .Call(C_R_igraph_weighted_adjacency, adjmatrix,
55                 as.numeric(mode), weighted, diag)
56  } else {
57
58    adjmatrix <- as.matrix(adjmatrix)
59    attrs <- attributes(adjmatrix)
60    adjmatrix <- as.numeric(adjmatrix)
61    attributes(adjmatrix) <- attrs
62
63    if (!diag) { diag(adjmatrix) <- 0 }
64
65    on.exit( .Call(C_R_igraph_finalizer) )
66    res <- .Call(C_R_igraph_graph_adjacency, adjmatrix, as.numeric(mode))
67  }
68
69  res
70}
71
72m2triplet <- get0("mat2triplet", asNamespace("Matrix"), inherits=FALSE)
73if(!is.function(m2triplet)) ## <==> (packageVersion("Matrix") < "1.3")
74    m2triplet <- function(x) {  ## a simplified version of new Matrix' mat2triplet()
75        T <- as(x, "TsparseMatrix")
76        if(is(T, "nsparseMatrix"))
77             list(i = T@i + 1L, j = T@j + 1L)
78        else list(i = T@i + 1L, j = T@j + 1L, x = T@x)
79    }
80
81mysummary <- function(x) do.call(cbind, m2triplet(x))
82
83graph.adjacency.sparse <- function(adjmatrix, mode=c("directed", "undirected", "max",
84                                                "min", "upper", "lower", "plus"),
85                                   weighted=NULL, diag=TRUE) {
86
87  mode <- igraph.match.arg(mode)
88
89  if (!is.null(weighted)) {
90    if (is.logical(weighted) && weighted) {
91      weighted <- "weight"
92    }
93    if (!is.character(weighted)) {
94      stop("invalid value supplied for `weighted' argument, please see docs.")
95    }
96  }
97
98  mysummary <- Matrix::summary
99
100  if (nrow(adjmatrix) != ncol(adjmatrix)) {
101    stop("not a square matrix")
102  }
103
104  vc <- nrow(adjmatrix)
105
106  ## to remove non-redundancies that can persist in a dgtMatrix
107  if(inherits(adjmatrix, "dgTMatrix")) {
108    adjmatrix = as(adjmatrix, "CsparseMatrix")
109  } else if (inherits(adjmatrix, "ddiMatrix")) {
110    adjmatrix = as(adjmatrix, "CsparseMatrix")
111  }
112
113  if (is.null(weighted) && mode=="undirected") { mode <- "max" }
114
115  if (mode == "directed") {
116    ## DIRECTED
117    el <- mysummary(adjmatrix)
118    if (!diag) { el <- el[ el[,1] != el[,2], ] }
119  } else if (mode == "undirected") {
120    ## UNDIRECTED, must be symmetric if weighted
121    if (!is.null(weighted) && !Matrix::isSymmetric(adjmatrix)) {
122      stop("Please supply a symmetric matrix if you want to create a weighted graph with mode=UNDIRECTED.")
123    }
124    if (diag) {
125      adjmatrix <- Matrix::tril(adjmatrix)
126    } else {
127      adjmatrix <- Matrix::tril(adjmatrix, -1)
128    }
129    el <- mysummary(adjmatrix)
130  } else if (mode=="max") {
131    ## MAXIMUM
132    el <- mysummary(adjmatrix)
133    rm(adjmatrix)
134    if (!diag) { el <- el[ el[,1] != el[,2], ] }
135    el <- el[ el[,3] != 0, ]
136    w <- el[,3]
137    el <- el[,1:2]
138    el <- cbind( pmin(el[,1],el[,2]), pmax(el[,1], el[,2]) )
139    o <- order(el[,1], el[,2])
140    el <- el[o,,drop=FALSE]
141    w <- w[o]
142    if (nrow(el) > 1) {
143      dd <- el[2:nrow(el),1] == el[1:(nrow(el)-1),1] &
144        el[2:nrow(el),2] == el[1:(nrow(el)-1),2]
145      dd <- which(dd)
146      if (length(dd)>0) {
147        mw <- pmax(w[dd], w[dd+1])
148        w[dd] <- mw
149        w[dd+1] <- mw
150        el <- el[-dd,,drop=FALSE]
151        w <- w[-dd]
152      }
153    }
154    el <- cbind(el, w)
155  } else if (mode=="upper") {
156    ## UPPER
157    if (diag) {
158      adjmatrix <- Matrix::triu(adjmatrix)
159    } else {
160      adjmatrix <- Matrix::triu(adjmatrix, 1)
161    }
162    el <- mysummary(adjmatrix)
163    rm(adjmatrix)
164    if (!diag) { el <- el[ el[,1] != el[,2], ] }
165  } else if (mode=="lower") {
166    ## LOWER
167    if (diag) {
168      adjmatrix <- Matrix::tril(adjmatrix)
169    } else {
170      adjmatrix <- Matrix::tril(adjmatrix, -1)
171    }
172    el <- mysummary(adjmatrix)
173    rm(adjmatrix)
174    if (!diag) { el <- el[ el[,1] != el[,2], ] }
175  } else if (mode=="min") {
176    ## MINIMUM
177    adjmatrix <- sign(adjmatrix) * sign(Matrix::t(adjmatrix)) * adjmatrix
178    el <- mysummary(adjmatrix)
179    if (!diag) { el <- el[ el[,1] != el[,2], ] }
180    el <- el[ el[,3] != 0, ]
181    w <- el[,3]
182    el <- el[,1:2]
183    el <- cbind( pmin(el[,1],el[,2]), pmax(el[,1], el[,2]) )
184    o <- order(el[,1], el[,2])
185    el <- el[o,]
186    w <- w[o]
187    if (nrow(el) > 1) {
188      dd <- el[2:nrow(el),1] == el[1:(nrow(el)-1),1] &
189        el[2:nrow(el),2] == el[1:(nrow(el)-1),2]
190      dd <- which(dd)
191      if (length(dd)>0) {
192        mw <- pmin(w[dd], w[dd+1])
193        w[dd] <- mw
194        w[dd+1] <- mw
195        el <- el[-dd,]
196        w <- w[-dd]
197      }
198    }
199    el <- cbind(el, w)
200  } else if (mode=="plus") {
201    ## PLUS
202    adjmatrix <- adjmatrix + Matrix::t(adjmatrix)
203    if (diag) {
204      adjmatrix <- Matrix::tril(adjmatrix)
205    } else {
206      adjmatrix <- Matrix::tril(adjmatrix, -1)
207    }
208    el <- mysummary(adjmatrix)
209    if (diag) {
210      loop <- el[,1] == el[,2]
211      el[loop,3] <- el[loop,3] / 2
212    }
213    el <- el[ el[,3] != 0, ]
214    rm(adjmatrix)
215  }
216
217  if (!is.null(weighted)) {
218    res <- make_empty_graph(n=vc, directed=(mode=="directed"))
219    weight <- list(el[,3])
220    names(weight) <- weighted
221    res <- add_edges(res, edges=t(as.matrix(el[,1:2])), attr=weight)
222  } else {
223    edges <- unlist(apply(el, 1, function(x) rep(unname(x[1:2]), x[3])))
224    res <- graph(n=vc, edges, directed=(mode=="directed"))
225  }
226  res
227}
228
229
230
231#' Create graphs from adjacency matrices
232#'
233#' \code{graph_from_adjacency_matrix} is a flexible function for creating \code{igraph}
234#' graphs from adjacency matrices.
235#'
236#' The order of the vertices are preserved, i.e. the vertex corresponding to
237#' the first row will be vertex 0 in the graph, etc.
238#'
239#' \code{graph_from_adjacency_matrix} operates in two main modes, depending on the
240#' \code{weighted} argument.
241#'
242#' If this argument is \code{NULL} then an unweighted graph is created and an
243#' element of the adjacency matrix gives the number of edges to create between
244#' the two corresponding vertices.  The details depend on the value of the
245#' \code{mode} argument: \describe{ \item{"directed"}{The graph will be
246#' directed and a matrix element gives the number of edges between two
247#' vertices.} \item{"undirected"}{This is exactly the same as \code{max},
248#' for convenience. Note that it is \emph{not} checked whether the matrix is
249#' symmetric.} \item{"max"}{An undirected graph will be created and
250#' \code{max(A(i,j), A(j,i))} gives the number of edges.}
251#' \item{"upper"}{An undirected graph will be created, only the upper
252#' right triangle (including the diagonal) is used for the number of edges.}
253#' \item{"lower"}{An undirected graph will be created, only the lower
254#' left triangle (including the diagonal) is used for creating the edges.}
255#' \item{"min"}{undirected graph will be created with \code{min(A(i,j),
256#' A(j,i))} edges between vertex \code{i} and \code{j}.} \item{"plus"}{
257#' undirected graph will be created with \code{A(i,j)+A(j,i)} edges between
258#' vertex \code{i} and \code{j}.} }
259#'
260#' If the \code{weighted} argument is not \code{NULL} then the elements of the
261#' matrix give the weights of the edges (if they are not zero).  The details
262#' depend on the value of the \code{mode} argument: \describe{
263#' \item{"directed"}{The graph will be directed and a matrix element
264#' gives the edge weights.} \item{"undirected"}{First we check that the
265#' matrix is symmetric. It is an error if not. Then only the upper triangle is
266#' used to create a weighted undirected graph.} \item{"max"}{An
267#' undirected graph will be created and \code{max(A(i,j), A(j,i))} gives the
268#' edge weights.} \item{"upper"}{An undirected graph will be created,
269#' only the upper right triangle (including the diagonal) is used (for the edge
270#' weights).} \item{"lower"}{An undirected graph will be created, only
271#' the lower left triangle (including the diagonal) is used for creating the
272#' edges.} \item{"min"}{An undirected graph will be created,
273#' \code{min(A(i,j), A(j,i))} gives the edge weights.} \item{"plus"}{An
274#' undirected graph will be created, \code{A(i,j)+A(j,i)} gives the edge
275#' weights.} }
276#'
277#' @aliases graph.adjacency
278#' @param adjmatrix A square adjacency matrix. From igraph version 0.5.1 this
279#' can be a sparse matrix created with the \code{Matrix} package.
280#' @param mode Character scalar, specifies how igraph should interpret the
281#' supplied matrix. See also the \code{weighted} argument, the interpretation
282#' depends on that too. Possible values are: \code{directed},
283#' \code{undirected}, \code{upper}, \code{lower}, \code{max}, \code{min},
284#' \code{plus}. See details below.
285#' @param weighted This argument specifies whether to create a weighted graph
286#' from an adjacency matrix. If it is \code{NULL} then an unweighted graph is
287#' created and the elements of the adjacency matrix gives the number of edges
288#' between the vertices. If it is a character constant then for every non-zero
289#' matrix entry an edge is created and the value of the entry is added as an
290#' edge attribute named by the \code{weighted} argument. If it is \code{TRUE}
291#' then a weighted graph is created and the name of the edge attribute will be
292#' \code{weight}. See also details below.
293#' @param diag Logical scalar, whether to include the diagonal of the matrix in
294#' the calculation. If this is \code{FALSE} then the diagonal is zerod out
295#' first.
296#' @param add.colnames Character scalar, whether to add the column names as
297#' vertex attributes. If it is \sQuote{\code{NULL}} (the default) then, if
298#' present, column names are added as vertex attribute \sQuote{name}. If
299#' \sQuote{\code{NA}} then they will not be added.  If a character constant,
300#' then it gives the name of the vertex attribute to add.
301#' @param add.rownames Character scalar, whether to add the row names as vertex
302#' attributes. Possible values the same as the previous argument. By default
303#' row names are not added. If \sQuote{\code{add.rownames}} and
304#' \sQuote{\code{add.colnames}} specify the same vertex attribute, then the
305#' former is ignored.
306#' @return An igraph graph object.
307#' @author Gabor Csardi \email{csardi.gabor@@gmail.com}
308#' @seealso \link{graph} and \code{\link{graph_from_literal}} for other ways to
309#' create graphs.
310#' @keywords graphs
311#' @examples
312#'
313#' adjm <- matrix(sample(0:1, 100, replace=TRUE, prob=c(0.9,0.1)), nc=10)
314#' g1 <- graph_from_adjacency_matrix( adjm )
315#' adjm <- matrix(sample(0:5, 100, replace=TRUE,
316#'                       prob=c(0.9,0.02,0.02,0.02,0.02,0.02)), nc=10)
317#' g2 <- graph_from_adjacency_matrix(adjm, weighted=TRUE)
318#' E(g2)$weight
319#'
320#' ## various modes for weighted graphs, with some tests
321#' nzs <- function(x) sort(x [x!=0])
322#' adjm <- matrix(runif(100), 10)
323#' adjm[ adjm<0.5 ] <- 0
324#' g3 <- graph_from_adjacency_matrix((adjm + t(adjm))/2, weighted=TRUE,
325#'                       mode="undirected")
326#'
327#' g4 <- graph_from_adjacency_matrix(adjm, weighted=TRUE, mode="max")
328#' all(nzs(pmax(adjm, t(adjm))[upper.tri(adjm)]) == sort(E(g4)$weight))
329#'
330#' g5 <- graph_from_adjacency_matrix(adjm, weighted=TRUE, mode="min")
331#' all(nzs(pmin(adjm, t(adjm))[upper.tri(adjm)]) == sort(E(g5)$weight))
332#'
333#' g6 <- graph_from_adjacency_matrix(adjm, weighted=TRUE, mode="upper")
334#' all(nzs(adjm[upper.tri(adjm)]) == sort(E(g6)$weight))
335#'
336#' g7 <- graph_from_adjacency_matrix(adjm, weighted=TRUE, mode="lower")
337#' all(nzs(adjm[lower.tri(adjm)]) == sort(E(g7)$weight))
338#'
339#' g8 <- graph_from_adjacency_matrix(adjm, weighted=TRUE, mode="plus")
340#' d2 <- function(x) { diag(x) <- diag(x)/2; x }
341#' all(nzs((d2(adjm+t(adjm)))[lower.tri(adjm)]) == sort(E(g8)$weight))
342#'
343#' g9 <- graph_from_adjacency_matrix(adjm, weighted=TRUE, mode="plus", diag=FALSE)
344#' d0 <- function(x) { diag(x) <- 0 }
345#' all(nzs((d0(adjm+t(adjm)))[lower.tri(adjm)]) == sort(E(g9)$weight))
346#'
347#' ## row/column names
348#' rownames(adjm) <- sample(letters, nrow(adjm))
349#' colnames(adjm) <- seq(ncol(adjm))
350#' g10 <- graph_from_adjacency_matrix(adjm, weighted=TRUE, add.rownames="code")
351#' summary(g10)
352#'
353graph_from_adjacency_matrix <- function(adjmatrix, mode=c("directed", "undirected", "max",
354                                         "min", "upper", "lower", "plus"),
355                            weighted=NULL, diag=TRUE,
356                            add.colnames=NULL, add.rownames=NA) {
357
358  if (inherits(adjmatrix, "Matrix")) {
359    res <- graph.adjacency.sparse(adjmatrix, mode=mode, weighted=weighted, diag=diag)
360  } else {
361    res <- graph.adjacency.dense(adjmatrix, mode=mode, weighted=weighted, diag=diag)
362  }
363
364  ## Add columns and row names as attributes
365  if (is.null(add.colnames)) {
366    if (!is.null(colnames(adjmatrix))) {
367      add.colnames <- "name"
368    } else {
369      add.colnames <- NA
370    }
371  } else if (!is.na(add.colnames)) {
372    if (is.null(colnames(adjmatrix))) {
373      warning("No column names to add")
374      add.colnames <- NA
375    }
376  }
377
378  if (is.null(add.rownames)) {
379    if (!is.null(rownames(adjmatrix))) {
380      add.rownames <- "name"
381    } else {
382      add.colnames <- NA
383    }
384  } else if (!is.na(add.rownames)) {
385    if (is.null(rownames(adjmatrix))) {
386      warning("No row names to add")
387      add.rownames <- NA
388    }
389  }
390
391  if (!is.na(add.rownames) && !is.na(add.colnames) &&
392      add.rownames == add.colnames ) {
393    warning("Same attribute for columns and rows, row names are ignored")
394    add.rownames <- NA
395  }
396
397  if (!is.na(add.colnames)) {
398    res <- set_vertex_attr(res, add.colnames, value=colnames(adjmatrix))
399  }
400  if (!is.na(add.rownames)) {
401    res <- set_vertex_attr(res, add.rownames, value=rownames(adjmatrix))
402  }
403
404  res
405}
406
407#' @rdname graph_from_adjacency_matrix
408#' @param ... Passed to \code{graph_from_adjacency_matrix}.
409#' @export
410
411from_adjacency <- function(...) constructor_spec(graph_from_adjacency_matrix, ...)
412