1
2#   IGraph R package
3#   Copyright (C) 2012  Gabor Csardi <csardi.gabor@gmail.com>
4#   334 Harvard street, Cambridge, MA 02139 USA
5#
6#   This program is free software; you can redistribute it and/or modify
7#   it under the terms of the GNU General Public License as published by
8#   the Free Software Foundation; either version 2 of the License, or
9#   (at your option) any later version.
10#
11#   This program is distributed in the hope that it will be useful,
12#   but WITHOUT ANY WARRANTY; without even the implied warranty of
13#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14#   GNU General Public License for more details.
15#
16#   You should have received a copy of the GNU General Public License
17#   along with this program; if not, write to the Free Software
18#   Foundation, Inc.,  51 Franklin Street, Fifth Floor, Boston, MA
19#   02110-1301 USA
20#
21###################################################################
22
23# This is a sparse data frame. It is like a regular data frame,
24# but it allows for some columns to be constant, and then it
25# stores that column more economically.
26
27sdf <- function(..., row.names = NULL, NROW = NULL) {
28
29  cols <- list(...)
30
31  if (is.null(names(cols)) || any(names(cols) == "") ||
32      any(duplicated(names(cols)))) {
33    stop("Columns must be have (unique) names")
34  }
35
36  lens <- sapply(cols, length)
37  n1lens <- lens[ lens != 1 ]
38
39  if (length(unique(n1lens)) > 1) {
40    stop("Columns must be constants or have the same length")
41  }
42
43  if (length(n1lens) == 0) {
44    if (is.null(NROW)) {
45      stop("Cannot determine number of rows")
46    }
47    attr(cols, "NROW") <- NROW
48  } else {
49    if (!is.null(NROW) && n1lens[1] != NROW) {
50      stop("NROW does not match column lengths")
51    }
52    attr(cols, "NROW") <- unname(n1lens[1])
53  }
54
55  class(cols) <- "igraphSDF"
56  attr(cols, "row.names") <- row.names
57
58  cols
59}
60
61#' @method as.data.frame igraphSDF
62
63as.data.frame.igraphSDF <- function(x, row.names, optional, ...) {
64  as.data.frame(lapply(x, rep, length.out=attr(x, "NROW")))
65}
66
67#' @method "[" igraphSDF
68
69`[.igraphSDF` <- function(x, i, j, ..., drop=TRUE) {
70  if (!is.character(j)) {
71    stop("The column index must be character")
72  }
73  if (!missing(i) && !is.numeric(i)) {
74    stop("The row index must be numeric")
75  }
76  if (missing(i)) {
77    rep(x[[j]], length.out=attr(x, "NROW"))
78  } else {
79    if (length(x[[j]])==1) {
80      rep(x[[j]], length(i))
81    } else {
82      x[[j]][i]
83    }
84  }
85}
86
87#' @method "[<-" igraphSDF
88
89`[<-.igraphSDF` <- function(x, i, j, value) {
90  if (!is.character(j)) {
91    stop("The column index must be character")
92  }
93  if (!missing(i) && !is.numeric(i)) {
94    stop("Row index must be numeric, if given")
95  }
96  if (missing(i)) {
97    if (length(value) != attr(x, "NROW") && length(value) != 1) {
98      stop("Replacement value has the wrong length")
99    }
100    x[[j]] <- value
101  } else {
102    if (length(value) != length(i) && length(value) != 1) {
103      stop("Replacement value has the wrong length")
104    }
105    tmp <- rep(x[[j]], length=attr(x, "NROW"))
106    tmp[i] <- value
107    if (length(unique(tmp)) == 1) {
108      tmp <- tmp[1]
109    }
110    x[[j]] <- tmp
111  }
112
113  x
114}
115