/
node_methods_traversal.R
328 lines (291 loc) · 11.3 KB
/
node_methods_traversal.R
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
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
#' Traverse a tree or a sub-tree
#'
#' Traverse takes the root of a tree or a sub-tree, and "walks" the tree in a specific order. It returns a list of
#' \code{\link{Node}} objects, filtered and pruned by \code{filterFun} and \code{pruneFun}.
#'
#' @param node the root of a tree or a sub-tree that should be traversed
#' @param traversal any of 'pre-order' (the default), 'post-order', 'in-order', 'level', 'ancestor', or a custom function (see details)
#' @param filterFun allows providing a a filter, i.e. a function taking a \code{Node} as an input, and returning \code{TRUE} or \code{FALSE}.
#' Note that if filter returns \code{FALSE}, then the node will be excluded from the result (but not the entire subtree).
#'
#' @return a list of \code{Node}s
#'
#' @details
#' The traversal order is as follows. (Note that these descriptions are not precise and complete. They are meant
#' for quick reference only. See the data.tree vignette for a more detailed description).
#' \describe{
#' \item{pre-order}{Go to first child, then to its first child, etc.}
#' \item{post-order}{Go to the first branch's leaf, then to its siblings, and work your way back to the root}
#' \item{in-order}{Go to the first branch's leaf, then to its parent, and only then to the leaf's sibling}
#' \item{level}{Collect root, then level 2, then level 3, etc.}
#' \item{ancestor}{Take a node, then the node's parent, then that node's parent in turn, etc. This ignores the \code{pruneFun} }
#' \item{function}{You can also provide a function, whose sole parameter is a \code{\link{Node}} object. The
#' function is expected to return the node's next node, a list of the node's next nodes, or NULL.}
#' }
#'
#'
#' @seealso \code{\link{Node}}
#' @seealso \code{\link{Get}}
#' @seealso \code{\link{Set}}
#' @seealso \code{\link{Do}}
#'
#' @inheritParams Prune
#'
#' @export
Traverse = function(node,
traversal = c("pre-order", "post-order", "in-order", "level", "ancestor"),
pruneFun = NULL,
filterFun = NULL) {
#traverses in various orders. See http://en.wikipedia.org/wiki/Tree_traversal
nodes <- list()
if(length(traversal) > 1L) {
traversal <- traversal[1L]
}
if(is.function(traversal) || traversal == "pre-order" || traversal == "post-order") {
if (length(pruneFun) == 0 || pruneFun(node)) {
if (is.function(traversal)) {
children <- traversal(node)
if (is(children, "Node")) children <- list(children)
if (is.null(children)) children <- list()
} else children <- node$children
for(child in children) {
nodes <- c(nodes, Traverse(child, traversal = traversal, pruneFun = pruneFun, filterFun = filterFun))
}
if(length(filterFun) == 0 || filterFun(node)) {
if(is.function(traversal) || traversal == "pre-order") nodes <- c(node, nodes)
else nodes <- c(nodes, node)
}
}
} else if(traversal == "in-order") {
if(!node$isBinary) stop("traversal in-order valid only for binary trees")
if(length(pruneFun) == 0 || pruneFun(node)) {
if(!node$isLeaf) {
n1 <- Traverse(node$children[[1]], traversal = traversal, pruneFun = pruneFun, filterFun = filterFun)
if(length(filterFun) == 0 || filterFun(node)) n2 <- node
else n2 <- list()
n3 <- Traverse(node$children[[2]], traversal = traversal, pruneFun = pruneFun, filterFun = filterFun)
nodes <- c(n1, n2, n3)
} else {
if(length(filterFun) == 0 || filterFun(node)) n2 <- node
else n2 <- list()
nodes <- c(nodes, n2)
}
}
} else if (traversal == "ancestor") {
if (!isRoot(node)) {
nodes <- Traverse(node$parent, traversal = traversal, pruneFun = pruneFun, filterFun = filterFun)
}
if(length(filterFun) == 0 || filterFun(node)) {
nodes <- c(node, nodes)
}
} else if (traversal == "level") {
nodes <- Traverse(node, filterFun = filterFun, pruneFun = pruneFun)
if (length(nodes) > 0) nodes <- nodes[order(Get(nodes, function(x) x$level))]
} else {
stop("traversal must be pre-order, post-order, in-order, ancestor, or level")
}
return (nodes)
}
#' Traverse a Tree and Collect Values
#'
#' The \code{Get} method is one of the most important ones of the \code{data.tree} package. It lets you traverse a tree
#' and collect values along the way. Alternatively, you can call a method or a function on each \code{\link{Node}}.
#'
#' @usage
#' # OO-style:
#' #node$Get(attribute,
#' # ...,
#' # traversal = c("pre-order", "post-order", "in-order", "level", "ancestor"),
#' # pruneFun = NULL,
#' # filterFun = NULL,
#' # format = FALSE,
#' # inheritFromAncestors = FALSE)
#'
#' # traditional:
#' Get(nodes,
#' attribute,
#' ...,
#' format = FALSE,
#' inheritFromAncestors = FALSE,
#' simplify = c(TRUE, FALSE, "array", "regular"))
#'
#'
#' @param nodes The nodes on which to perform the Get (typically obtained via \code{\link{Traverse}})
#' @param attribute determines what is collected. The \code{attribute} can be
#' \itemize{
#' \item a.) the name of a \bold{field} or a \bold{property/active} of each \code{Node} in the tree, e.g. \code{acme$Get("p")} or \code{acme$Get("position")}
#' \item b.) the name of a \bold{method} of each \code{Node} in the tree, e.g. \code{acme$Get("levelZeroBased")}, where e.g. \code{acme$levelZeroBased <- function() acme$level - 1}
#' \item c.) a \bold{function}, whose first argument must be a \code{Node} e.g. \code{acme$Get(function(node) node$cost * node$p)}
#' }
#' @param ... in case the \code{attribute} is a function or a method, the ellipsis is passed to it as additional arguments.
#' @param format if \code{FALSE} (the default), no formatting is being used. If \code{TRUE}, then the first formatter (if any) found along the ancestor path is being used for formatting
#' (see \code{\link{SetFormat}}). If \code{format} is a function, then the collected value is passed to that function, and the result is returned.
#' @param inheritFromAncestors if \code{TRUE}, then the path above a \code{Node} is searched to get the \code{attribute} in case it is NULL.
#' @param simplify same as \code{\link{sapply}}, i.e. TRUE, FALSE or "array". Additionally, you can specify "regular" if
#' each returned value is of length > 1, and equally named. See below for an example.
#'
#' @return a vector containing the \code{atrributes} collected during traversal, in traversal order. \code{NULL} is converted
#' to NA, such that \code{length(Node$Get) == Node$totalCount}
#'
#'
#' @examples
#' data(acme)
#' acme$Get("level")
#' acme$Get("totalCount")
#'
#'
#' acme$Get(function(node) node$cost * node$p,
#' filterFun = isLeaf)
#'
#' #This is equivalent:
#' nodes <- Traverse(acme, filterFun = isLeaf)
#' Get(nodes, function(node) node$cost * node$p)
#'
#'
#' #simplify = "regular" will preserve names
#' acme$Get(function(x) c(position = x$position, level = x$level), simplify = "regular")
#'
#' @seealso \code{\link{Node}}
#' @seealso \code{\link{Set}}
#' @seealso \code{\link{Do}}
#' @seealso \code{\link{Traverse}}
#'
#' @import methods
#'
#' @export
Get = function(nodes,
attribute,
...,
format = FALSE,
inheritFromAncestors = FALSE,
simplify = c(TRUE, FALSE, "array", "regular")) {
if (length(nodes) == 0) return(NULL)
if (!is(nodes, "list")) stop("nodes must be a list of Node objects!")
simplify <- simplify[1]
nodes <- unname(nodes)
if (simplify == "regular") {
regular = TRUE
simplify = FALSE
} else regular = FALSE
res <- sapply(nodes,
function(x) GetAttribute(x,
attribute,
...,
format = format,
inheritFromAncestors = inheritFromAncestors),
simplify = simplify
)
if (is.character(attribute) && attribute == "name") {
names(res) <- res
} else {
if(is.null(dim(res))){
names(res) <- Get(nodes, "name")
} else {
if(is.null(dimnames(res)))
dimnames(res) <- list()
dimnames(res)[[length(dim(res))]] <- Get(nodes, "name")
}
}
if (regular) {
res <- do.call(cbind, res)
}
return (res)
}
#' Executes a function on a set of nodes
#'
#' @usage
#' # OO-style:
#' # node$Do(fun,
#' # ...,
#' # traversal = c("pre-order", "post-order", "in-order", "level", "ancestor"),
#' # pruneFun = NULL,
#' # filterFun = NULL)
#'
#' # traditional:
#' Do(nodes, fun, ...)
#'
#' @param fun the function to execute. The function is expected to be either a Method, or to take a
#' Node as its first argument
#' @param ... any additional parameters to be passed on to fun
#'
#' @seealso \code{\link{Node}}
#' @seealso \code{\link{Get}}
#' @seealso \code{\link{Set}}
#' @seealso \code{\link{Traverse}}
#'
#' @inheritParams Get
#'
#' @examples
#' data(acme)
#' traversal <- Traverse(acme)
#' Do(traversal, function(node) node$expectedCost <- node$p * node$cost)
#' print(acme, "expectedCost")
#'
#' @export
Do <- function(nodes,
fun,
...) {
if (length(nodes) == 0) invisible(nodes)
if (!is(nodes, "list")) stop("nodes must be a list of Node objects!")
for (node in nodes) fun(node, ...)
invisible (nodes)
}
#' Traverse a Tree and Assign Values
#'
#' The method takes one or more vectors as an argument. It traverses the tree, whereby the values are picked
#' from the vector. Also available as OO-style method on \code{\link{Node}}.
#'
#' @usage
#' #OO-style:
#' # node$Set(...,
#' # traversal = c("pre-order", "post-order", "in-order", "level", "ancestor"),
#' # pruneFun = NULL,
#' # filterFun = NULL)
#' #traditional:
#' Set(nodes, ...)
#'
#'
#' @param ... each argument can be a vector of values to be assigned. Recycled.
#'
#' @return invisibly returns the nodes (useful for chaining)
#'
#' @examples
#' data(acme)
#' acme$Set(departmentId = 1:acme$totalCount, openingHours = NULL, traversal = "post-order")
#' acme$Set(head = c("Jack Brown",
#' "Mona Moneyhead",
#' "Dr. Frank N. Stein",
#' "Eric Nerdahl"
#' ),
#' filterFun = function(x) !x$isLeaf
#' )
#' print(acme, "departmentId", "head")
#'
#' @seealso \code{\link{Node}}
#' @seealso \code{\link{Get}}
#' @seealso \code{\link{Do}}
#' @seealso \code{\link{Traverse}}
#'
#' @inheritParams Get
#'
#' @export
Set <- function(nodes,
...) {
if (length(nodes) == 0) return(nodes)
if (!is(nodes, "list")) stop("nodes must be a list of Node objects!")
args <- list(...)
argsnames <- sapply(substitute(list(...))[-1], deparse)
gargsnames <- names(args)
if (is.null(gargsnames)) gargsnames <- vector(mode = "character", length = length(args))
gargsnames[nchar(gargsnames) == 0] <- argsnames[nchar(gargsnames) == 0]
names(args) <- gargsnames
appFun <- function(x, arg, name) {
x[[name]] <- arg
}
for(nme in names(args)) {
arg <- args[[nme]]
if (length(arg) == 0) arg <- vector("list", 1)
mapply(appFun, nodes, arg, nme)
}
invisible (nodes)
}