statnet / network

@@ -1278,12 +1278,14 @@
Loading
1278 1278
# Return TRUE iff network x is bipartite
1279 1279
#
1280 1280
#' @rdname network.indicators
1281 +
#' @param ... other arguments passed to/from other methods
1281 1282
#' @export
1282 -
is.bipartite<-function(x){
1283 -
  if(!is.network(x))
1284 -
    stop("is.bipartite requires an argument of class network.")
1285 -
  else
1286 -
    bip <- get.network.attribute(x,"bipartite")
1283 +
is.bipartite <- function(x, ...) UseMethod("is.bipartite")
1284 +
1285 +
#' @rdname network.indicators
1286 +
#' @export
1287 +
is.bipartite.network<-function(x, ...){
1288 +
  bip <- get.network.attribute(x,"bipartite")
1287 1289
  if(is.null(bip)){
1288 1290
   return(FALSE)
1289 1291
  } else if (is.logical(bip)){
@@ -1298,11 +1300,12 @@
Loading
1298 1300
#
1299 1301
#' @rdname network.indicators
1300 1302
#' @export
1301 -
is.directed<-function(x){
1302 -
  if(!is.network(x))
1303 -
    stop("is.directed requires an argument of class network.\n")
1304 -
  else
1305 -
    get.network.attribute(x,"directed")
1303 +
is.directed <- function(x, ...) UseMethod("is.directed")
1304 +
1305 +
#' @rdname network.indicators
1306 +
#' @export
1307 +
is.directed.network<-function(x, ...){
1308 +
  get.network.attribute(x,"directed")
1306 1309
}
1307 1310
1308 1311

@@ -68,7 +68,7 @@
Loading
68 68
#' each direction) added for every row in the \code{*Edges} block.
69 69
#' 
70 70
#' If the \code{*Vertices}, \code{*Arcs} or \code{*Edges} blocks having timing
71 -
#' information included in the rows (indicated by '[...]' tokens), it will be
71 +
#' information included in the rows (indicated by `...` tokens), it will be
72 72
#' attached to the vertices with behavior determined by the \code{time.format}
73 73
#' option.  If the \code{'networkDynamic'} format is used, times will be
74 74
#' translated to \code{networkDynamic}'s spell model with the assumtion that

@@ -124,7 +124,7 @@
Loading
124 124
#' corresponding to \code{get.vertex.attribute(x,attrname)}.  In assignment,
125 125
#' the respective equivalences are to
126 126
#' \code{set.network.attribute(x,attrname,value)} and
127 -
#' \code{set.vertex.attribute(x,attrname,value)}.  Note that the ``\%\%''
127 +
#' \code{set.vertex.attribute(x,attrname,value)}.  Note that the `%%`
128 128
#' assignment forms are generally slower than the named versions of the
129 129
#' functions beause they will trigger an additional internal copy of the
130 130
#' network object.

@@ -113,9 +113,7 @@
Loading
113 113
#'   matrix is meaningful.
114 114
#' @param ... further arguments passed to or used by methods.
115 115
#' 
116 -
#' 
117 116
#' @rdname mixingmatrix
118 -
#' @include constructors.R
119 117
#' @export
120 118
121 119
mixingmatrix <- function(object, ...) UseMethod("mixingmatrix")
@@ -130,13 +128,26 @@
Loading
130 128
131 129
132 130
#' @rdname mixingmatrix
133 -
#' 
131 +
#'
134 132
#' @param attrname a vertex attribute name.
135 -
#' @param expand.bipartite logical; if `object` is bipartite, should
136 -
#'   we return the square mixing matrix representing every level of
137 -
#'   `attrname` against every other level, or a rectangular matrix
138 -
#'   considering only levels present in each bipartition?
139 -
#' 
133 +
#' @param expand.bipartite logical; if `object` is bipartite, should we return
134 +
#'   the *square* mixing matrix representing every level of `attrname` against
135 +
#'   every other level, or a *rectangular* matrix considering only levels
136 +
#'   present in each bipartition?
137 +
#'
138 +
#' @return Function `mixingmatrix()` returns an object of class "mixingmatrix"
139 +
#'   extending "table" with a cross-tabulation of edges in the `object`
140 +
#'   according to the values of attribute `attrname` for the two incident
141 +
#'   vertices. If `object` is a *directed* network rows correspond to the "tie
142 +
#'   sender" and columns to the "tie receiver". If `object` is an *undirected*
143 +
#'   network there is no such distinction and the matrix is symmetrized. In both
144 +
#'   cases the matrix is square and all the observed values of the attribute
145 +
#'   `attrname` are represented in rows and columns. If `object` is a
146 +
#'   *bipartite* network and `expand.bipartite` is `FALSE` the resulting matrix
147 +
#'   does not have to be square as only the actually observed values of the
148 +
#'   attribute are shown for each partition, if `expand.bipartite` is `TRUE` the
149 +
#'   matrix will be square.
150 +
#'
140 151
#' @export
141 152
#' @examples
142 153
#' # Interaction ties between Lake Pomona SAR organizations by sponsorship type
@@ -150,13 +161,11 @@
Loading
150 161
  }
151 162
  if(network.size(nw)==0L){
152 163
    warning("mixing matrices not well-defined for graphs with no vertices.")
153 -
    type<-"directed"
154 -
    if(is.bipartite(nw))
155 -
      type<-"bipartite"
156 -
    tabu<-matrix(nrow=0L,ncol=0L)
157 -
    ans<-list(type=type,matrix=tabu)
158 -
    class(ans)<-"mixingmatrix"
159 -
    return(ans)
164 +
    return(as.mixingmatrix(
165 +
      matrix(nrow=0L, ncol=0L),
166 +
      directed = is.directed(object),
167 +
      bipartite = is.bipartite(object)
168 +
    ))
160 169
  }
161 170
  nodecov <- unlist(get.vertex.attribute(nw, attrname))
162 171
  u<-sort(unique(nodecov))
@@ -185,13 +194,127 @@
Loading
185 194
    tabu <- tabu + t(tabu)
186 195
    diag(tabu) <- diag(tabu)%/%2L
187 196
  }
188 -
  ans <- list(type=type, matrix=tabu)
189 -
  class(ans) <- "mixingmatrix"
190 -
  ans
197 +
  as.mixingmatrix(
198 +
    tabu,
199 +
    directed = is.directed(object),
200 +
    bipartite = is.bipartite(object)
201 +
  )
191 202
}
192 203
193 204
194 205
206 +
207 +
208 +
#' @rdname mixingmatrix
209 +
#' 
210 +
#' @note The `$` and `[[` methods are included only for backward-compatiblity
211 +
#'   reason and will become defunct in future releases of the package.
212 +
#' 
213 +
#' @export
214 +
"[[.mixingmatrix" <- function(x, ...) {
215 +
  .Deprecated(
216 +
    new = "mixingmatrix",
217 +
    msg = "Mixing matrix objects now extend class \"table\". The `[[` method is deprecated and will be removed from future releases of the package. See ?mixingmatrix for details."
218 +
  )
219 +
  x <- .to_oldmm(x)
220 +
  NextMethod()
221 +
}
222 +
223 +
224 +
#' @rdname mixingmatrix
225 +
#' 
226 +
#' @param name name of the element to extract, one of "matrix" or "type"
227 +
#'
228 +
#' @export
229 +
"$.mixingmatrix" <- function(x, name) {
230 +
  .Deprecated(
231 +
    new = "mixingmatrix",
232 +
    msg = "Mixing matrix objects now extend class \"table\". The `$` method is deprecated and will be removed from future releases of the package. See ?mixingmatrix for details."
233 +
  )
234 +
  x <- .to_oldmm(x)
235 +
  NextMethod()
236 +
}
237 +
238 +
239 +
.to_oldmm <- function(x) {
240 +
  directed <- attr(x, "directed")
241 +
  bipartite <- attr(x, "bipartite")
242 +
  list(
243 +
    matrix = structure(as.integer(x), dimnames=dimnames(x), dim=dim(x)),
244 +
    type = if(bipartite) "bipartite" else if(directed) "directed" else "undirected"
245 +
  )
246 +
}
247 +
248 +
249 +
# A non-exported constructor of mixingmatrix objects
250 +
# 
251 +
# @param mat matrix with the actual cross-tabulation
252 +
# @param directed logical if the network is directed
253 +
# @param bipartite logical if the netwoek is bipartite
254 +
# @param ... other arguments currently ignored
255 +
# 
256 +
# @return The matrix with attributes "directed" and "bipartite" of class
257 +
#   "mixingmatrix" inheriting from "table".
258 +
259 +
as.mixingmatrix <- function(mat, directed, bipartite, ...) {
260 +
  # Test/check/symmetrize here?
261 +
  structure(
262 +
    mat,
263 +
    directed = directed,
264 +
    bipartite = bipartite,
265 +
    class = c("mixingmatrix", "table")
266 +
  )
267 +
}
268 +
269 +
270 +
#' @rdname mixingmatrix
271 +
#' 
272 +
#' @return Functions `is.directed()` and `is.bipartite()` return `TRUE` or
273 +
#'   `FALSE`. The values will be identical for the input network `object`.
274 +
#' 
275 +
#' @export
276 +
is.directed.mixingmatrix <- function(x, ...) attr(x, "directed")
277 +
278 +
#' @rdname mixingmatrix
279 +
#' @export
280 +
is.bipartite.mixingmatrix <- function(x, ...) attr(x, "bipartite")
281 +
282 +
283 +
#' @rdname mixingmatrix
284 +
#' 
285 +
#' @param x mixingmatrix object
286 +
#' 
287 +
#' @export
288 +
print.mixingmatrix <- function(x, ...) {
289 +
  m <- x
290 +
  rn <- rownames(x)
291 +
  cn <- colnames(x)  
292 +
  if (!attr(x, "directed")) {
293 +
    dimnames(m) <- list(rn, cn)
294 +
    on.exit(
295 +
      message("Note:  Marginal totals can be misleading for undirected mixing matrices.")  
296 +
    )
297 +
  } else {
298 +
    dimnames(m) <- if(attr(x, "bipartite")) list(B1 = rn, B2 = cn) else list(From = rn, To = cn)
299 +
    m <- stats::addmargins(m)
300 +
  }
301 +
  m <- structure(
302 +
    m,
303 +
    directed = attr(x, "directed"),
304 +
    bipartite = attr(x, "bipartite"),
305 +
    class = "table"
306 +
  )
307 +
  print(m)
308 +
}
309 +
310 +
311 +
312 +
313 +
314 +
315 +
316 +
317 +
195 318
# network.density ---------------------------------------------------------
196 319
197 320
#' Compute the Density of a Network
@@ -369,36 +492,9 @@
Loading
369 492
370 493
371 494
372 -
# print.mixingmatrix ------------------------------------------------------
373 495
374 496
375 -
#' @rdname mixingmatrix
376 -
#' 
377 -
#' @param x mixingmatrix object
378 -
#' 
379 -
#' @export
380 -
print.mixingmatrix <- function(x, ...) {
381 -
  m <- x$mat
382 -
  rn <- rownames(m)
383 -
  cn <- colnames(m)  
384 -
  if (x$type == "undirected") {
385 -
    dimnames(m) <- list(rn, cn)
386 -
    cat("Note:  Marginal totals can be misleading\n",
387 -
        "for undirected mixing matrices.\n")
388 -
  } else {
389 -
    total <- apply(m,1,sum)
390 -
    m <- cbind(m,total)
391 -
    total <- apply(m,2,sum)
392 -
    m <- rbind(m,total)
393 -
    rn <- c(rn, "Total")
394 -
    cn <- c(cn, "Total")
395 -
    if (x$type == "bipartite")
396 -
      dimnames(m) <- list(B1 = rn,B2 = cn)
397 -
    else
398 -
      dimnames(m) <- list(From = rn,To = cn)
399 -
  }
400 -
  print(m)
401 -
}
497 +
402 498
403 499
404 500
Files Coverage
R 65.11%
src 73.14%
Project Totals (18 files) 67.68%
Notifications are pending CI completion. Waiting for GitHub's status webhook to queue notifications. Push notifications now.
1
comment: false
2

3
coverage:
4
  status:
5
    project:
6
      default:
7
        target: auto
8
        threshold: 1%
9
    patch:
10
      default:
11
        target: auto
12
        threshold: 1%
Sunburst
The inner-most circle is the entire project, moving away from the center are folders then, finally, a single file. The size and color of each slice is representing the number of statements and the coverage, respectively.
Icicle
The top section represents the entire project. Proceeding with folders and finally individual files. The size and color of each slice is representing the number of statements and the coverage, respectively.
Grid
Each block represents a single file in the project. The size and color of each block is represented by the number of statements and the coverage, respectively.
Loading