1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
|
### =========================================================================
### Grouping objects implemented with an IntegerList
### -------------------------------------------------------------------------
setClass("SimpleGrouping",
### TODO: contain VIRTUAL after R 3.4 release
contains=c("Grouping", "SimpleIntegerList"))
setClass("SimpleManyToOneGrouping",
contains=c("ManyToOneGrouping", "SimpleGrouping"))
setClass("BaseManyToManyGrouping",
representation(nobj="integer"),
### TODO: contain VIRTUAL after R 3.4 release
contains="ManyToManyGrouping",
validity=function(object) {
if (!isSingleNumber(object@nobj))
"'nobj' must be a single, non-NA number"
})
setClass("SimpleManyToManyGrouping",
contains=c("BaseManyToManyGrouping", "SimpleGrouping"))
### -------------------------------------------------------------------------
### Grouping API implementation
### ----------------------------
###
setMethod("nobj", "BaseManyToManyGrouping", function(x) x@nobj)
### -------------------------------------------------------------------------
### Constructors
### ----------------------------
###
ManyToOneGrouping <- function(..., compress=TRUE) {
CompressedOrSimple <- if (compress) "Compressed" else "Simple"
Class <- paste0(CompressedOrSimple, "ManyToOneGrouping")
new(Class, IntegerList(..., compress=compress))
}
ManyToManyGrouping <- function(..., nobj, compress=TRUE) {
CompressedOrSimple <- if (compress) "Compressed" else "Simple"
Class <- paste0(CompressedOrSimple, "ManyToManyGrouping")
new(Class, IntegerList(..., compress=compress), nobj=nobj)
}
### -------------------------------------------------------------------------
### Coercion
### ----------------------------
###
setOldClass("grouping")
## utils::relist dipatches only on 'skeleton' so this is here instead of in R
setMethod("relist", c("grouping", "missing"), function(flesh, skeleton) {
relist(as.integer(flesh), PartitioningByEnd(attr(flesh, "ends")))
})
setMethod("split", c("ANY", "ManyToOneGrouping"), function(x, f, drop=FALSE) {
stopifnot(isTRUEorFALSE(drop))
ans <- extractList(x, f)
if (drop) {
ans <- ans[lengths(ans) > 0L]
}
ans
})
setAs("grouping", "Grouping", function(from) {
as(from, "ManyToOneGrouping")
})
setAs("grouping", "ManyToOneGrouping", function(from) {
ManyToOneGrouping(relist(from), compress=TRUE)
})
setAs("vector", "Grouping", function(from) {
if (anyNA(from))
as(from, "ManyToManyGrouping")
else as(from, "ManyToOneGrouping")
})
setAs("vector", "ManyToOneGrouping", function(from) {
to <- as(grouping(from), "Grouping")
names(to) <- from[unlist(to)[end(PartitioningByEnd(to))]]
to
})
setAs("factor", "ManyToOneGrouping", function(from) {
ManyToOneGrouping(splitAsList(seq_along(from), from))
})
setAs("vector", "ManyToManyGrouping", function(from) {
g <- as(from, "ManyToOneGrouping")
if (anyNA(from))
g <- g[-length(g)]
ManyToManyGrouping(g, nobj=length(from))
})
setAs("ManyToOneGrouping", "factor", function(from) {
levels <- if (!is.null(names(from))) {
names(from)
} else {
as.character(seq_along(from))
}
structure(togroup(from), levels=levels, class="factor")
})
setMethod("as.factor", "ManyToOneGrouping", function(x) {
as(x, "factor")
})
makeGroupNames <- function(x) {
if (is.null(x)) {
x <- character(length(x))
}
ind <- which(x == "")
x[ind] <- paste("Group", ind, sep = ".")
x
}
levelCols <- function(by) {
DataFrame(expand.grid(lapply(by, levels)))
}
setAs("FactorList", "Grouping", function(from) {
l <- as.list(from)
names(l) <- makeGroupNames(names(from))
as(DataFrame(l), "Grouping")
})
setAs("DataFrame", "Grouping", function(from) {
factors <- lapply(from, as.factor)
l <- splitAsList(seq_len(nrow(from)), factors)
mcols(l) <- levelCols(factors)
if (anyNA(from, recursive=TRUE)) {
ManyToManyGrouping(l, nobj=nrow(from))
} else {
ManyToOneGrouping(l)
}
})
|
