Browse code

fixed R check

guangchuang yu authored on 06/12/2016 12:05:09
Showing 15 changed files

... ...
@@ -15,19 +15,11 @@ setMethod("groupClade", signature(object="codeml"),
15 15
 
16 16
 ##' @rdname groupClade-methods
17 17
 ##' @exportMethod groupClade
18
-setMethod("groupClade", signature(object="gg"),
18
+setMethod("groupClade", signature(object="ggtree"),
19 19
           function(object, node, group_name) {
20
-              groupClade.ggplot(object, node, group_name)
20
+              groupClade.ggtree(object, node, group_name)
21 21
           })
22 22
 
23
-##' @rdname groupClade-methods
24
-##' @exportMethod groupClade
25
-setMethod("groupClade", signature(object="ggplot"),
26
-          function(object, node, group_name) {
27
-              groupClade.ggplot(object, node, group_name)
28
-          })
29
-
30
-
31 23
 ##' @rdname groupClade-methods
32 24
 ##' @exportMethod groupClade
33 25
 setMethod("groupClade", signature(object="jplace"),
... ...
@@ -38,7 +30,7 @@ setMethod("groupClade", signature(object="jplace"),
38 30
 
39 31
 ##' group selected clade
40 32
 ##'
41
-##' 
33
+##'
42 34
 ##' @rdname groupClade-methods
43 35
 ##' @exportMethod groupClade
44 36
 setMethod("groupClade", signature(object="nhx"),
... ...
@@ -73,7 +65,7 @@ groupClade.phylo <- function(object, node, group_name) {
73 65
             clade$tip.label
74 66
         })
75 67
     }
76
-    
68
+
77 69
     groupOTU.phylo(object, tips, group_name)
78 70
 }
79 71
 
... ...
@@ -88,7 +80,7 @@ groupClade_ <- function(object, node, group_name) {
88 80
 }
89 81
 
90 82
 
91
-groupClade.ggplot <- function(object, nodes, group_name) {
83
+groupClade.ggtree <- function(object, nodes, group_name) {
92 84
     df <- object$data
93 85
     df[, group_name] <- 0
94 86
     for (node in nodes) {
... ...
@@ -32,18 +32,12 @@ setMethod("groupOTU", signature(object="codeml_mlc"),
32 32
           }
33 33
           )
34 34
 
35
-##' @rdname groupOTU-methods
36
-##' @exportMethod groupOTU
37
-setMethod("groupOTU", signature(object="gg"),
38
-          function(object, focus, group_name, ...) {
39
-              groupOTU.ggplot(object, focus, group_name, ...)
40
-          })
41 35
 
42 36
 ##' @rdname groupOTU-methods
43 37
 ##' @exportMethod groupOTU
44
-setMethod("groupOTU", signature(object="ggplot"),
38
+setMethod("groupOTU", signature(object="ggtree"),
45 39
           function(object, focus, group_name="group", ...) {
46
-              groupOTU.ggplot(object, focus, group_name, ...)
40
+              groupOTU.ggtree(object, focus, group_name, ...)
47 41
           })
48 42
 
49 43
 
... ...
@@ -185,7 +179,7 @@ groupOTU_ <- function(object, focus, group_name, ...) {
185 179
 }
186 180
 
187 181
 
188
-groupOTU.ggplot <- function(object, focus, group_name, ...) {
182
+groupOTU.ggtree <- function(object, focus, group_name, ...) {
189 183
     df <- object$data
190 184
     df[, group_name] <- 0
191 185
     object$data <- groupOTU.df(df, focus, group_name, ...)
... ...
@@ -38,7 +38,7 @@ gzoom.phylo <- function(phy, focus, subtree=FALSE, widths=c(.3, .7)) {
38 38
     invisible(list(p1=p1, p2=p2))
39 39
 }
40 40
 
41
-gzoom.ggplot <- function(tree_view, focus, widths=c(.3, .7), xmax_adjust=0) {
41
+gzoom.ggtree <- function(tree_view, focus, widths=c(.3, .7), xmax_adjust=0) {
42 42
     node <- MRCA(tree_view, focus)
43 43
     cpos <- get_clade_position(tree_view, node)
44 44
     p2 <- with(cpos, tree_view+
... ...
@@ -51,9 +51,9 @@ gzoom.ggplot <- function(tree_view, focus, widths=c(.3, .7), xmax_adjust=0) {
51 51
 ##' @rdname gzoom-methods
52 52
 ##' @exportMethod gzoom
53 53
 ##' @param xmax_adjust adjust xmax (xlim[2])
54
-setMethod("gzoom", signature(object="gg"),
54
+setMethod("gzoom", signature(object="ggtree"),
55 55
           function(object, focus, widths=c(.3, .7), xmax_adjust=0) {
56
-              gzoom.ggplot(object, focus, widths, xmax_adjust)
56
+              gzoom.ggtree(object, focus, widths, xmax_adjust)
57 57
           })
58 58
 
59 59
 
60 60
deleted file mode 100644
... ...
@@ -1,803 +0,0 @@
1
-##' convert tip or node label(s) to internal node number
2
-##'
3
-##'
4
-##' @title nodeid
5
-##' @param x tree object or graphic object return by ggtree
6
-##' @param label tip or node label(s)
7
-##' @return internal node number
8
-##' @export
9
-##' @author Guangchuang Yu
10
-nodeid <- function(x, label) {
11
-    if (is(x, "gg"))
12
-        return(nodeid.gg(x, label))
13
-
14
-    nodeid.tree(x, label)
15
-}
16
-
17
-nodeid.tree <- function(tree, label) {
18
-    tr <- get.tree(tree)
19
-    lab <- c(tr$tip.label, tr$node.label)
20
-    match(label, lab)
21
-}
22
-
23
-nodeid.gg <- function(p, label) {
24
-    p$data$node[match(label, p$data$label)]
25
-}
26
-
27
-
28
-reroot_node_mapping <- function(tree, tree2) {
29
-    root <- getRoot(tree)
30
-
31
-    node_map <- data.frame(from=1:getNodeNum(tree), to=NA, visited=FALSE)
32
-    node_map[1:Ntip(tree), 2] <- match(tree$tip.label, tree2$tip.label)
33
-    node_map[1:Ntip(tree), 3] <- TRUE
34
-
35
-    node_map[root, 2] <- root
36
-    node_map[root, 3] <- TRUE
37
-
38
-    node <- rev(tree$edge[,2])
39
-    for (k in node) {
40
-        ip <- getParent(tree, k)
41
-        if (node_map[ip, "visited"])
42
-            next
43
-
44
-        cc <- getChild(tree, ip)
45
-        node2 <- node_map[cc,2]
46
-        if (anyNA(node2)) {
47
-            node <- c(node, k)
48
-            next
49
-        }
50
-
51
-        to <- unique(sapply(node2, getParent, tr=tree2))
52
-        to <- to[! to %in% node_map[,2]]
53
-        node_map[ip, 2] <- to
54
-        node_map[ip, 3] <- TRUE
55
-    }
56
-    node_map <- node_map[, -3]
57
-    return(node_map)
58
-}
59
-
60
-
61
-
62
-##' @importFrom ape reorder.phylo
63
-layout.unrooted <- function(tree) {
64
-    N <- getNodeNum(tree)
65
-    root <- getRoot(tree)
66
-
67
-    df <- as.data.frame.phylo_(tree)
68
-    df$x <- NA
69
-    df$y <- NA
70
-    df$start <- NA
71
-    df$end   <- NA
72
-    df$angle <- NA
73
-    df[root, "x"] <- 0
74
-    df[root, "y"] <- 0
75
-    df[root, "start"] <- 0
76
-    df[root, "end"]   <- 2
77
-    df[root, "angle"] <- 0
78
-
79
-    nb.sp <- sapply(1:N, function(i) length(get.offspring.tip(tree, i)))
80
-
81
-    nodes <- getNodes_by_postorder(tree)
82
-
83
-    for(curNode in nodes) {
84
-        curNtip <- nb.sp[curNode]
85
-        children <- getChild(tree, curNode)
86
-
87
-        start <- df[curNode, "start"]
88
-        end <- df[curNode, "end"]
89
-
90
-        if (length(children) == 0) {
91
-            ## is a tip
92
-            next
93
-        }
94
-
95
-        for (i in seq_along(children)) {
96
-            child <- children[i]
97
-            ntip.child <- nb.sp[child]
98
-
99
-            alpha <- (end - start) * ntip.child/curNtip
100
-            beta <- start + alpha / 2
101
-
102
-            length.child <- df[child, "length"]
103
-            df[child, "x"] <- df[curNode, "x"] + cospi(beta) * length.child
104
-            df[child, "y"] <- df[curNode, "y"] + sinpi(beta) * length.child
105
-            df[child, "angle"] <- -90 -180 * beta * sign(beta - 1)
106
-            df[child, "start"] <- start
107
-            df[child, "end"] <- start + alpha
108
-            start <- start + alpha
109
-        }
110
-
111
-    }
112
-
113
-    return(df)
114
-}
115
-
116
-getParent.df <- function(df, node) {
117
-    i <- which(df$node == node)
118
-    res <- df$parent[i]
119
-    if (res == node) {
120
-        ## root node
121
-        return(0)
122
-    }
123
-    return(res)
124
-}
125
-
126
-getAncestor.df <- function(df, node) {
127
-    anc <- getParent.df(df, node)
128
-    anc <- anc[anc != 0]
129
-    if (length(anc) == 0) {
130
-        stop("selected node is root...")
131
-    }
132
-    i <- 1
133
-    while(i<= length(anc)) {
134
-        anc <- c(anc, getParent.df(df, anc[i]))
135
-        anc <- anc[anc != 0]
136
-        i <- i+1
137
-    }
138
-    return(anc)
139
-}
140
-
141
-
142
-getChild.df <- function(df, node) {
143
-    i <- which(df$parent == node)
144
-    if (length(i) == 0) {
145
-        return(0)
146
-    }
147
-    res <- df[i, "node"]
148
-    res <- res[res != node] ## node may root
149
-    return(res)
150
-}
151
-
152
-get.offspring.df <- function(df, node) {
153
-    sp <- getChild.df(df, node)
154
-    sp <- sp[sp != 0]
155
-    if (length(sp) == 0) {
156
-        stop("input node is a tip...")
157
-    }
158
-
159
-    i <- 1
160
-    while(i <= length(sp)) {
161
-        sp <- c(sp, getChild.df(df, sp[i]))
162
-        sp <- sp[sp != 0]
163
-        i <- i + 1
164
-    }
165
-    return(sp)
166
-}
167
-
168
-
169
-##' extract offspring tips
170
-##'
171
-##'
172
-##' @title get.offspring.tip
173
-##' @param tr tree
174
-##' @param node node
175
-##' @return tip label
176
-##' @author ygc
177
-##' @importFrom ape extract.clade
178
-##' @export
179
-get.offspring.tip <- function(tr, node) {
180
-    if ( ! node %in% tr$edge[,1]) {
181
-        ## return itself
182
-        return(tr$tip.label[node])
183
-    }
184
-    clade <- extract.clade(tr, node)
185
-    clade$tip.label
186
-}
187
-
188
-
189
-##' calculate total number of nodes
190
-##'
191
-##'
192
-##' @title getNodeNum
193
-##' @param tr phylo object
194
-##' @return number
195
-##' @author Guangchuang Yu
196
-##' @export
197
-getNodeNum <- function(tr) {
198
-    Ntip <- length(tr[["tip.label"]])
199
-    Nnode <- tr[["Nnode"]]
200
-    ## total nodes
201
-    N <- Ntip + Nnode
202
-    return(N)
203
-}
204
-
205
-getParent <- function(tr, node) {
206
-    if ( node == getRoot(tr) )
207
-        return(0)
208
-    edge <- tr[["edge"]]
209
-    parent <- edge[,1]
210
-    child <- edge[,2]
211
-    res <- parent[child == node]
212
-    if (length(res) == 0) {
213
-        stop("cannot found parent node...")
214
-    }
215
-    if (length(res) > 1) {
216
-        stop("multiple parent found...")
217
-    }
218
-    return(res)
219
-}
220
-
221
-getChild <- function(tr, node) {
222
-    edge <- tr[["edge"]]
223
-    res <- edge[edge[,1] == node, 2]
224
-    ## if (length(res) == 0) {
225
-    ##     ## is a tip
226
-    ##     return(NA)
227
-    ## }
228
-    return(res)
229
-}
230
-
231
-getSibling <- function(tr, node) {
232
-    root <- getRoot(tr)
233
-    if (node == root) {
234
-        return(NA)
235
-    }
236
-
237
-    parent <- getParent(tr, node)
238
-    child <- getChild(tr, parent)
239
-    sib <- child[child != node]
240
-    return(sib)
241
-}
242
-
243
-
244
-getAncestor <- function(tr, node) {
245
-    root <- getRoot(tr)
246
-    if (node == root) {
247
-        return(NA)
248
-    }
249
-    parent <- getParent(tr, node)
250
-    res <- parent
251
-    while(parent != root) {
252
-        parent <- getParent(tr, parent)
253
-        res <- c(res, parent)
254
-    }
255
-    return(res)
256
-}
257
-
258
-isRoot <- function(tr, node) {
259
-    getRoot(tr) == node
260
-}
261
-
262
-getNodeName <- function(tr) {
263
-    if (is.null(tr$node.label)) {
264
-        n <- length(tr$tip.label)
265
-        nl <- (n + 1):(2 * n - 2)
266
-        nl <- as.character(nl)
267
-    }
268
-    else {
269
-        nl <- tr$node.label
270
-    }
271
-    nodeName <- c(tr$tip.label, nl)
272
-    return(nodeName)
273
-}
274
-
275
-##' get the root number
276
-##'
277
-##'
278
-##' @title getRoot
279
-##' @param tr phylo object
280
-##' @return root number
281
-##' @export
282
-##' @author Guangchuang Yu
283
-getRoot <- function(tr) {
284
-    edge <- tr[["edge"]]
285
-    ## 1st col is parent,
286
-    ## 2nd col is child,
287
-    if (!is.null(attr(tr, "order")) && attr(tr, "order") == "postorder")
288
-        return(edge[nrow(edge), 1])
289
-
290
-    parent <- unique(edge[,1])
291
-    child <- unique(edge[,2])
292
-    ## the node that has no parent should be the root
293
-    root <- parent[ ! parent %in% child ]
294
-    if (length(root) > 1) {
295
-        stop("multiple roots founded...")
296
-    }
297
-    return(root)
298
-}
299
-
300
-get.trunk <- function(tr) {
301
-    root <- getRoot(tr)
302
-    path_length <- sapply(1:(root-1), function(x) get.path_length(tr, root, x))
303
-    i <- which.max(path_length)
304
-    return(get.path(tr, root, i))
305
-}
306
-
307
-##' path from start node to end node
308
-##'
309
-##'
310
-##' @title get.path
311
-##' @param phylo phylo object
312
-##' @param from start node
313
-##' @param to end node
314
-##' @return node vectot
315
-##' @export
316
-##' @author Guangchuang Yu
317
-get.path <- function(phylo, from, to) {
318
-    anc_from <- getAncestor(phylo, from)
319
-    anc_from <- c(from, anc_from)
320
-    anc_to <- getAncestor(phylo, to)
321
-    anc_to <- c(to, anc_to)
322
-    mrca <- intersect(anc_from, anc_to)[1]
323
-
324
-    i <- which(anc_from == mrca)
325
-    j <- which(anc_to == mrca)
326
-
327
-    path <- c(anc_from[1:i], rev(anc_to[1:(j-1)]))
328
-    return(path)
329
-}
330
-
331
-get.path_length <- function(phylo, from, to, weight=NULL) {
332
-    path <- get.path(phylo, from, to)
333
-    if (is.null(weight)) {
334
-        return(length(path)-1)
335
-    }
336
-
337
-    df <- fortify(phylo)
338
-    if ( ! (weight %in% colnames(df))) {
339
-        stop("weight should be one of numerical attributes of the tree...")
340
-    }
341
-
342
-    res <- 0
343
-
344
-    get_edge_index <- function(df, from, to) {
345
-        which((df[,1] == from | df[,2] == from) &
346
-                  (df[,1] == to | df[,2] == to))
347
-    }
348
-
349
-    for(i in 1:(length(path)-1)) {
350
-        ee <- get_edge_index(df, path[i], path[i+1])
351
-        res <- res + df[ee, weight]
352
-    }
353
-
354
-    return(res)
355
-}
356
-
357
-getNodes_by_postorder <- function(tree) {
358
-    tree <- reorder.phylo(tree, "postorder")
359
-    unique(rev(as.vector(t(tree$edge[,c(2,1)]))))
360
-}
361
-
362
-getXcoord2 <- function(x, root, parent, child, len, start=0, rev=FALSE) {
363
-    x[root] <- start
364
-    x[-root] <- NA  ## only root is set to start, by default 0
365
-
366
-    currentNode <- root
367
-    direction <- 1
368
-    if (rev == TRUE) {
369
-        direction <- -1
370
-    }
371
-    while(anyNA(x)) {
372
-        idx <- which(parent %in% currentNode)
373
-        newNode <- child[idx]
374
-        x[newNode] <- x[parent[idx]]+len[idx] * direction
375
-        currentNode <- newNode
376
-    }
377
-
378
-    return(x)
379
-}
380
-
381
-getXcoord_no_length <- function(tr) {
382
-    edge <- tr$edge
383
-    parent <- edge[,1]
384
-    child <- edge[,2]
385
-    root <- getRoot(tr)
386
-
387
-    len <- tr$edge.length
388
-
389
-    N <- getNodeNum(tr)
390
-    x <- numeric(N)
391
-    ntip <- Ntip(tr)
392
-    currentNode <- 1:ntip
393
-    x[-currentNode] <- NA
394
-
395
-    cl <- split(child, parent)
396
-    child_list <- list()
397
-    child_list[as.numeric(names(cl))] <- cl
398
-
399
-    while(anyNA(x)) {
400
-        idx <- match(currentNode, child)
401
-        pNode <- parent[idx]
402
-        ## child number table
403
-        p1 <- table(parent[parent %in% pNode])
404
-        p2 <- table(pNode)
405
-        np <- names(p2)
406
-        i <- p1[np] == p2
407
-        newNode <- as.numeric(np[i])
408
-
409
-        exclude <- rep(NA, max(child))
410
-        for (j in newNode) {
411
-            x[j] <- min(x[child_list[[j]]]) - 1
412
-            exclude[child_list[[j]]] <- child_list[[j]]
413
-        }
414
-        exclude <- exclude[!is.na(exclude)]
415
-
416
-        ## currentNode %<>% `[`(!(. %in% exclude))
417
-        ## currentNode %<>% c(., newNode) %>% unique
418
-        currentNode <- currentNode[!currentNode %in% exclude]
419
-        currentNode <- unique(c(currentNode, newNode))
420
-
421
-    }
422
-    x <- x - min(x)
423
-    return(x)
424
-}
425
-
426
-
427
-getXcoord <- function(tr) {
428
-    edge <- tr$edge
429
-    parent <- edge[,1]
430
-    child <- edge[,2]
431
-    root <- getRoot(tr)
432
-
433
-    len <- tr$edge.length
434
-
435
-    N <- getNodeNum(tr)
436
-    x <- numeric(N)
437
-    x <- getXcoord2(x, root, parent, child, len)
438
-    return(x)
439
-}
440
-
441
-getXYcoord_slanted <- function(tr) {
442
-
443
-    edge <- tr$edge
444
-    parent <- edge[,1]
445
-    child <- edge[,2]
446
-    root <- getRoot(tr)
447
-
448
-    N <- getNodeNum(tr)
449
-    len <- tr$edge.length
450
-    y <- getYcoord(tr, step=min(len)/2)
451
-
452
-    len <- sqrt(len^2 - (y[parent]-y[child])^2)
453
-    x <- numeric(N)
454
-    x <- getXcoord2(x, root, parent, child, len)
455
-    res <- data.frame(x=x, y=y)
456
-    return(res)
457
-}
458
-
459
-
460
-## @importFrom magrittr %>%
461
-##' @importFrom magrittr equals
462
-getYcoord <- function(tr, step=1) {
463
-    Ntip <- length(tr[["tip.label"]])
464
-    N <- getNodeNum(tr)
465
-
466
-    edge <- tr[["edge"]]
467
-    parent <- edge[,1]
468
-    child <- edge[,2]
469
-
470
-    cl <- split(child, parent)
471
-    child_list <- list()
472
-    child_list[as.numeric(names(cl))] <- cl
473
-
474
-    y <- numeric(N)
475
-    tip.idx <- child[child <= Ntip]
476
-    y[tip.idx] <- 1:Ntip * step
477
-    y[-tip.idx] <- NA
478
-
479
-    currentNode <- 1:Ntip
480
-    while(anyNA(y)) {
481
-        pNode <- unique(parent[child %in% currentNode])
482
-        ## piping of magrittr is slower than nested function call.
483
-        ## pipeR is fastest, may consider to use pipeR
484
-        ##
485
-        ## child %in% currentNode %>% which %>% parent[.] %>% unique
486
-        ## idx <- sapply(pNode, function(i) all(child[parent == i] %in% currentNode))
487
-        idx <- sapply(pNode, function(i) all(child_list[[i]] %in% currentNode))
488
-        newNode <- pNode[idx]
489
-
490
-        y[newNode] <- sapply(newNode, function(i) {
491
-            mean(y[child_list[[i]]], na.rm=TRUE)
492
-            ##child[parent == i] %>% y[.] %>% mean(na.rm=TRUE)
493
-        })
494
-
495
-        currentNode <- c(currentNode[!currentNode %in% unlist(child_list[newNode])], newNode)
496
-        ## currentNode <- c(currentNode[!currentNode %in% child[parent %in% newNode]], newNode)
497
-        ## parent %in% newNode %>% child[.] %>%
498
-        ##     `%in%`(currentNode, .) %>% `!` %>%
499
-        ##         currentNode[.] %>% c(., newNode)
500
-    }
501
-
502
-    return(y)
503
-}
504
-
505
-
506
-getYcoord_scale <- function(tr, df, yscale) {
507
-
508
-    N <- getNodeNum(tr)
509
-    y <- numeric(N)
510
-
511
-    root <- getRoot(tr)
512
-    y[root] <- 0
513
-    y[-root] <- NA
514
-
515
-    edge <- tr$edge
516
-    parent <- edge[,1]
517
-    child <- edge[,2]
518
-
519
-    currentNodes <- root
520
-    while(anyNA(y)) {
521
-        newNodes <- c()
522
-        for (currentNode in currentNodes) {
523
-            idx <- which(parent %in% currentNode)
524
-            newNode <- child[idx]
525
-            direction <- -1
526
-            for (i in seq_along(newNode)) {
527
-                y[newNode[i]] <- y[currentNode] + df[newNode[i], yscale] * direction
528
-                direction <- -1 * direction
529
-            }
530
-            newNodes <- c(newNodes, newNode)
531
-        }
532
-        currentNodes <- unique(newNodes)
533
-    }
534
-    if (min(y) < 0) {
535
-        y <- y + abs(min(y))
536
-    }
537
-    return(y)
538
-}
539
-
540
-getYcoord_scale2 <- function(tr, df, yscale) {
541
-    root <- getRoot(tr)
542
-
543
-    pathLength <- sapply(1:length(tr$tip.label), function(i) {
544
-        get.path_length(tr, i, root, yscale)
545
-    })
546
-
547
-    ordered_tip <- order(pathLength, decreasing = TRUE)
548
-    ii <- 1
549
-    ntip <- length(ordered_tip)
550
-    while(ii < ntip) {
551
-        sib <- getSibling(tr, ordered_tip[ii])
552
-        if (length(sib) == 0) {
553
-            ii <- ii + 1
554
-            next
555
-        }
556
-        jj <- which(ordered_tip %in% sib)
557
-        if (length(jj) == 0) {
558
-            ii <- ii + 1
559
-            next
560
-        }
561
-        sib <- ordered_tip[jj]
562
-        ordered_tip <- ordered_tip[-jj]
563
-        nn <- length(sib)
564
-        if (ii < length(ordered_tip)) {
565
-            ordered_tip <- c(ordered_tip[1:ii],sib, ordered_tip[(ii+1):length(ordered_tip)])
566
-        } else {
567
-            ordered_tip <- c(ordered_tip[1:ii],sib)
568
-        }
569
-
570
-        ii <- ii + nn + 1
571
-    }
572
-
573
-
574
-    long_branch <- getAncestor(tr, ordered_tip[1]) %>% rev
575
-    long_branch <- c(long_branch, ordered_tip[1])
576
-
577
-    N <- getNodeNum(tr)
578
-    y <- numeric(N)
579
-
580
-    y[root] <- 0
581
-    y[-root] <- NA
582
-
583
-    ## yy <- df[, yscale]
584
-    ## yy[is.na(yy)] <- 0
585
-
586
-    for (i in 2:length(long_branch)) {
587
-        y[long_branch[i]] <- y[long_branch[i-1]] + df[long_branch[i], yscale]
588
-    }
589
-
590
-    parent <- df[, "parent"]
591
-    child <- df[, "node"]
592
-
593
-    currentNodes <- root
594
-    while(anyNA(y)) {
595
-        newNodes <- c()
596
-        for (currentNode in currentNodes) {
597
-            idx <- which(parent %in% currentNode)
598
-            newNode <- child[idx]
599
-            newNode <- c(newNode[! newNode %in% ordered_tip],
600
-                         rev(ordered_tip[ordered_tip %in% newNode]))
601
-            direction <- -1
602
-            for (i in seq_along(newNode)) {
603
-                if (is.na(y[newNode[i]])) {
604
-                    y[newNode[i]] <- y[currentNode] + df[newNode[i], yscale] * direction
605
-                    direction <- -1 * direction
606
-                }
607
-            }
608
-            newNodes <- c(newNodes, newNode)
609
-        }
610
-        currentNodes <- unique(newNodes)
611
-    }
612
-    if (min(y) < 0) {
613
-        y <- y + abs(min(y))
614
-    }
615
-    return(y)
616
-}
617
-
618
-getYcoord_scale_numeric <- function(tr, df, yscale, ...) {
619
-    df <- .assign_parent_status(tr, df, yscale)
620
-    df <- .assign_child_status(tr, df, yscale)
621
-
622
-    y <- df[, yscale]
623
-
624
-    if (anyNA(y)) {
625
-        warning("NA found in y scale mapping, all were setting to 0")
626
-        y[is.na(y)] <- 0
627
-    }
628
-
629
-    return(y)
630
-}
631
-
632
-.assign_parent_status <- function(tr, df, variable) {
633
-    yy <- df[, variable]
634
-    na.idx <- which(is.na(yy))
635
-    if (length(na.idx) > 0) {
636
-        tree <- get.tree(tr)
637
-        nodes <- getNodes_by_postorder(tree)
638
-        for (curNode in nodes) {
639
-            children <- getChild(tree, curNode)
640
-            if (length(children) == 0) {
641
-                next
642
-            }
643
-            idx <- which(is.na(yy[children]))
644
-            if (length(idx) > 0) {
645
-                yy[children[idx]] <- yy[curNode]
646
-            }
647
-        }
648
-    }
649
-    df[, variable] <- yy
650
-    return(df)
651
-}
652
-
653
-.assign_child_status <- function(tr, df, variable, yscale_mapping=NULL) {
654
-    yy <- df[, variable]
655
-    if (!is.null(yscale_mapping)) {
656
-        yy <- yscale_mapping[yy]
657
-    }
658
-
659
-    na.idx <- which(is.na(yy))
660
-    if (length(na.idx) > 0) {
661
-        tree <- get.tree(tr)
662
-        nodes <- rev(getNodes_by_postorder(tree))
663
-        for (curNode in nodes) {
664
-            parent <- getParent(tree, curNode)
665
-            if (parent == 0) { ## already reach root
666
-                next
667
-            }
668
-            idx <- which(is.na(yy[parent]))
669
-            if (length(idx) > 0) {
670
-                child <- getChild(tree, parent)
671
-                yy[parent[idx]] <- mean(yy[child], na.rm=TRUE)
672
-            }
673
-        }
674
-    }
675
-    df[, variable] <- yy
676
-    return(df)
677
-}
678
-
679
-
680
-getYcoord_scale_category <- function(tr, df, yscale, yscale_mapping=NULL, ...) {
681
-    if (is.null(yscale_mapping)) {
682
-        stop("yscale is category variable, user should provide yscale_mapping,
683
-             which is a named vector, to convert yscale to numberical values...")
684
-    }
685
-    if (! is(yscale_mapping, "numeric") ||
686
-        is.null(names(yscale_mapping))) {
687
-        stop("yscale_mapping should be a named numeric vector...")
688
-    }
689
-
690
-    if (yscale == "label") {
691
-        yy <- df[, yscale]
692
-        ii <- which(is.na(yy))
693
-        if (length(ii)) {
694
-            df[ii, yscale] <- df[ii, "node"]
695
-        }
696
-    }
697
-
698
-    ## assign to parent status is more prefer...
699
-    df <- .assign_parent_status(tr, df, yscale)
700
-    df <- .assign_child_status(tr, df, yscale, yscale_mapping)
701
-
702
-    y <- df[, yscale]
703
-
704
-    if (anyNA(y)) {
705
-        warning("NA found in y scale mapping, all were setting to 0")
706
-        y[is.na(y)] <- 0
707
-    }
708
-    return(y)
709
-}
710
-
711
-
712
-add_angle_slanted <- function(res) {
713
-    dy <- (res[, "y"] - res[res$parent, "y"]) / diff(range(res[, "y"]))
714
-    dx <- (res[, "x"] - res[res$parent, "x"]) / diff(range(res[, "x"]))
715
-    theta <- atan(dy/dx)
716
-    theta[is.na(theta)] <- 0 ## root node
717
-    res$angle <- theta/pi * 180
718
-    branch.y <- (res[res$parent, "y"] + res[, "y"])/2
719
-    idx <- is.na(branch.y)
720
-    branch.y[idx] <- res[idx, "y"]
721
-    res[, "branch.y"] <- branch.y
722
-    return(res)
723
-}
724
-
725
-calculate_branch_mid <- function(res) {
726
-    res$branch <- (res[res$parent, "x"] + res[, "x"])/2
727
-    if (!is.null(res$length)) {
728
-        res$length[is.na(res$length)] <- 0
729
-    }
730
-    res$branch[is.na(res$branch)] <- 0
731
-    return(res)
732
-}
733
-
734
-
735
-set_branch_length <- function(tree_object, branch.length) {
736
-    if (is(tree_object, "phylo4d")) {
737
-        phylo <- as.phylo.phylo4(tree_object)
738
-        d <- tree_object@data
739
-        tree_anno <- data.frame(node=rownames(d), d)
740
-    } else {
741
-        phylo <- get.tree(tree_object)
742
-    }
743
-
744
-    if (branch.length %in%  c("branch.length", "none")) {
745
-        return(phylo)
746
-    }
747
-
748
-    ## if (is(tree_object, "codeml")) {
749
-    ##     tree_anno <- tree_object@mlc@dNdS
750
-    ## } else
751
-
752
-    if (is(tree_object, "codeml_mlc")) {
753
-        tree_anno <- tree_object@dNdS
754
-    } else if (is(tree_object, "beast")) {
755
-        tree_anno <- tree_object@stats
756
-    }
757
-
758
-    if (has.extraInfo(tree_object)) {
759
-        tree_anno <- merge(tree_anno, tree_object@extraInfo, by.x="node", by.y="node")
760
-    }
761
-    cn <- colnames(tree_anno)
762
-    cn <- cn[!cn %in% c('node', 'parent')]
763
-
764
-    length <- match.arg(branch.length, cn)
765
-
766
-    if (all(is.na(as.numeric(tree_anno[, length])))) {
767
-        stop("branch.length should be numerical attributes...")
768
-    }
769
-
770
-    edge <- as.data.frame(phylo$edge)
771
-    colnames(edge) <- c("parent", "node")
772
-
773
-    dd <- merge(edge, tree_anno,
774
-                by.x  = "node",
775
-                by.y  = "node",
776
-                all.x = TRUE)
777
-    dd <- dd[match(edge$node, dd$node),]
778
-    len <- unlist(dd[, length])
779
-    len <- as.numeric(len)
780
-    len[is.na(len)] <- 0
781
-
782
-    phylo$edge.length <- len
783
-
784
-    return(phylo)
785
-}
786
-
787
-
788
-re_assign_ycoord_df <- function(df, currentNode) {
789
-    while(anyNA(df$y)) {
790
-        pNode <- with(df, parent[match(currentNode, node)]) %>% unique
791
-        idx <- sapply(pNode, function(i) with(df, all(node[parent == i & parent != node] %in% currentNode)))
792
-        newNode <- pNode[idx]
793
-        ## newNode <- newNode[is.na(df[match(newNode, df$node), "y"])]
794
-
795
-        df[match(newNode, df$node), "y"] <- sapply(newNode, function(i) {
796
-            with(df, mean(y[parent == i], na.rm = TRUE))
797
-        })
798
-        traced_node <- as.vector(sapply(newNode, function(i) with(df, node[parent == i])))
799
-        currentNode <- c(currentNode[! currentNode %in% traced_node], newNode)
800
-    }
801
-    return(df)
802
-}
803
-
... ...
@@ -1,5 +1,5 @@
1 1
 % Generated by roxygen2: do not edit by hand
2
-% Please edit documentation in R/AllGenerics.R, R/NHX.R, R/RAxML.R, R/ape.R, R/beast.R, R/codeml.R, R/codeml_mlc.R, R/hyphy.R, R/jplace.R, R/paml_rst.R, R/phangorn.R, R/r8s.R
2
+% Please edit documentation in R/AllGenerics.R, R/RAxML.R, R/ape.R, R/beast.R, R/codeml.R, R/codeml_mlc.R, R/hyphy.R, R/jplace.R, R/paml_rst.R, R/phangorn.R, R/r8s.R, R/treeio.R
3 3
 \docType{methods}
4 4
 \name{get.fields}
5 5
 \alias{get.fields}
... ...
@@ -18,8 +18,6 @@
18 18
 \usage{
19 19
 get.fields(object, ...)
20 20
 
21
-\S4method{get.fields}{nhx}(object, ...)
22
-
23 21
 \S4method{get.fields}{raxml}(object, ...)
24 22
 
25 23
 \S4method{get.fields}{apeBootstrap}(object, ...)
... ...
@@ -39,6 +37,8 @@ get.fields(object, ...)
39 37
 \S4method{get.fields}{phangorn}(object, ...)
40 38
 
41 39
 \S4method{get.fields}{r8s}(object, ...)
40
+
41
+\S4method{get.fields}{nhx}(object, ...)
42 42
 }
43 43
 \arguments{
44 44
 \item{object}{one of \code{jplace}, \code{beast}, \code{hyphy}, \code{codeml}, \code{codeml_mlc}, \code{paml_rst} object}
... ...
@@ -1,5 +1,5 @@
1 1
 % Generated by roxygen2: do not edit by hand
2
-% Please edit documentation in R/tree-utilities.R
2
+% Please edit documentation in R/tidytree.R
3 3
 \name{get.offspring.tip}
4 4
 \alias{get.offspring.tip}
5 5
 \title{get.offspring.tip}
... ...
@@ -1,5 +1,5 @@
1 1
 % Generated by roxygen2: do not edit by hand
2
-% Please edit documentation in R/tree-utilities.R
2
+% Please edit documentation in R/tidytree.R
3 3
 \name{get.path}
4 4
 \alias{get.path}
5 5
 \title{get.path}
... ...
@@ -1,5 +1,5 @@
1 1
 % Generated by roxygen2: do not edit by hand
2
-% Please edit documentation in R/tree-utilities.R
2
+% Please edit documentation in R/tidytree.R
3 3
 \name{getNodeNum}
4 4
 \alias{getNodeNum}
5 5
 \title{getNodeNum}
... ...
@@ -1,5 +1,5 @@
1 1
 % Generated by roxygen2: do not edit by hand
2
-% Please edit documentation in R/tree-utilities.R
2
+% Please edit documentation in R/tidytree.R
3 3
 \name{getRoot}
4 4
 \alias{getRoot}
5 5
 \title{getRoot}
... ...
@@ -7,8 +7,7 @@
7 7
 \alias{groupClade,beast-method}
8 8
 \alias{groupClade,codeml-method}
9 9
 \alias{groupClade,codeml_mlc-method}
10
-\alias{groupClade,gg-method}
11
-\alias{groupClade,ggplot-method}
10
+\alias{groupClade,ggtree-method}
12 11
 \alias{groupClade,hyphy-method}
13 12
 \alias{groupClade,jplace-method}
14 13
 \alias{groupClade,nhx-method}
... ...
@@ -34,9 +33,7 @@ groupClade(object, node, group_name = "group", ...)
34 33
 
35 34
 \S4method{groupClade}{codeml}(object, node, group_name = "group")
36 35
 
37
-\S4method{groupClade}{gg}(object, node, group_name)
38
-
39
-\S4method{groupClade}{ggplot}(object, node, group_name)
36
+\S4method{groupClade}{ggtree}(object, node, group_name)
40 37
 
41 38
 \S4method{groupClade}{jplace}(object, node, group_name = "group")
42 39
 
... ...
@@ -7,8 +7,7 @@
7 7
 \alias{groupOTU,beast-method}
8 8
 \alias{groupOTU,codeml-method}
9 9
 \alias{groupOTU,codeml_mlc-method}
10
-\alias{groupOTU,gg-method}
11
-\alias{groupOTU,ggplot-method}
10
+\alias{groupOTU,ggtree-method}
12 11
 \alias{groupOTU,hyphy-method}
13 12
 \alias{groupOTU,jplace-method}
14 13
 \alias{groupOTU,nhx-method}
... ...
@@ -34,9 +33,7 @@ groupOTU(object, focus, group_name = "group", ...)
34 33
 
35 34
 \S4method{groupOTU}{codeml_mlc}(object, focus, group_name = "group", ...)
36 35
 
37
-\S4method{groupOTU}{gg}(object, focus, group_name = "group", ...)
38
-
39
-\S4method{groupOTU}{ggplot}(object, focus, group_name = "group", ...)
36
+\S4method{groupOTU}{ggtree}(object, focus, group_name = "group", ...)
40 37
 
41 38
 \S4method{groupOTU}{jplace}(object, focus, group_name = "group", ...)
42 39
 
... ...
@@ -7,7 +7,7 @@
7 7
 \alias{gzoom,beast-method}
8 8
 \alias{gzoom,codeml-method}
9 9
 \alias{gzoom,codeml_mlc-method}
10
-\alias{gzoom,gg-method}
10
+\alias{gzoom,ggtree-method}
11 11
 \alias{gzoom,hyphy-method}
12 12
 \alias{gzoom,nhx-method}
13 13
 \alias{gzoom,paml_rst-method}
... ...
@@ -28,7 +28,8 @@ gzoom(object, focus, subtree = FALSE, widths = c(0.3, 0.7), ...)
28 28
 \S4method{gzoom}{hyphy}(object, focus, subtree = FALSE, widths = c(0.3,
29 29
   0.7))
30 30
 
31
-\S4method{gzoom}{gg}(object, focus, widths = c(0.3, 0.7), xmax_adjust = 0)
31
+\S4method{gzoom}{ggtree}(object, focus, widths = c(0.3, 0.7),
32
+  xmax_adjust = 0)
32 33
 
33 34
 \S4method{gzoom}{apeBootstrap}(object, focus, subtree = FALSE,
34 35
   widths = c(0.3, 0.7))
... ...
@@ -1,5 +1,5 @@
1 1
 % Generated by roxygen2: do not edit by hand
2
-% Please edit documentation in R/ggtree.R
2
+% Please edit documentation in R/tidytree.R
3 3
 \name{is.ggtree}
4 4
 \alias{is.ggtree}
5 5
 \title{is.ggtree}
... ...
@@ -1,5 +1,5 @@
1 1
 % Generated by roxygen2: do not edit by hand
2
-% Please edit documentation in R/tree-utilities.R
2
+% Please edit documentation in R/tidytree.R
3 3
 \name{nodeid}
4 4
 \alias{nodeid}
5 5
 \title{nodeid}
... ...
@@ -1,5 +1,5 @@
1 1
 % Generated by roxygen2: do not edit by hand
2
-% Please edit documentation in R/NHX.R
2
+% Please edit documentation in R/treeio.R
3 3
 \name{read.nhx}
4 4
 \alias{read.nhx}
5 5
 \title{read.nhx}