slanted layout when branch.length is none
Guangchuang Yu authored on 29/04/2022 07:45:30
• GitHub committed on 29/04/2022 07:45:30
| ... | ... |
@@ -32,14 +32,20 @@ fortify.phylo <- function(model, data, |
| 32 | 32 |
if (layout %in% c("equal_angle", "daylight", "ape")) {
|
| 33 | 33 |
res <- layout.unrooted(model, layout.method = layout, branch.length = branch.length, ...) |
| 34 | 34 |
} else {
|
| 35 |
+ ypos <- getYcoord(x) |
|
| 36 |
+ N <- Nnode(x, internal.only=FALSE) |
|
| 35 | 37 |
if (is.null(x$edge.length) || branch.length == "none") {
|
| 36 |
- xpos <- getXcoord_no_length(x) |
|
| 38 |
+ if (layout == 'slanted'){
|
|
| 39 |
+ sbp <- .convert_tips2ancestors_sbp(x, include.root = TRUE) |
|
| 40 |
+ xpos <- getXcoord_no_length_slanted(sbp) |
|
| 41 |
+ ypos <- getYcoord_no_length_slanted(sbp) |
|
| 42 |
+ }else{
|
|
| 43 |
+ xpos <- getXcoord_no_length(x) |
|
| 44 |
+ } |
|
| 37 | 45 |
} else {
|
| 38 | 46 |
xpos <- getXcoord(x) |
| 39 | 47 |
} |
| 40 | 48 |
|
| 41 |
- ypos <- getYcoord(x) |
|
| 42 |
- N <- Nnode(x, internal.only=FALSE) |
|
| 43 | 49 |
xypos <- tibble::tibble(node=1:N, x=xpos + root.position, y=ypos) |
| 44 | 50 |
|
| 45 | 51 |
df <- as_tibble(model) %>% |
| ... | ... |
@@ -1244,3 +1244,54 @@ layoutApe <- function(model, branch.length="branch.length") {
|
| 1244 | 1244 |
class(tree_df) <- c("tbl_tree", class(tree_df))
|
| 1245 | 1245 |
tree_df |
| 1246 | 1246 |
} |
| 1247 |
+ |
|
| 1248 |
+.nodeId <- function (tree, type = "all"){
|
|
| 1249 |
+ type <- match.arg(type, c("all", "tips", "internal"))
|
|
| 1250 |
+ if (inherits(tree, "treedata")) {
|
|
| 1251 |
+ tree <- tree@phylo |
|
| 1252 |
+ } |
|
| 1253 |
+ nodes <- unique(as.vector(tree$edge)) |
|
| 1254 |
+ if (type == "all") {
|
|
| 1255 |
+ return(nodes) |
|
| 1256 |
+ } |
|
| 1257 |
+ edge <- tree$edge |
|
| 1258 |
+ tips <- edge[!edge[, 2] %in% edge[, 1], 2] |
|
| 1259 |
+ if (type == "tips"){
|
|
| 1260 |
+ return(tips) |
|
| 1261 |
+ } |
|
| 1262 |
+ else if (type == "internal") {
|
|
| 1263 |
+ return(setdiff(nodes, tips)) |
|
| 1264 |
+ } |
|
| 1265 |
+} |
|
| 1266 |
+ |
|
| 1267 |
+.convert_tips2ancestors_sbp <- function (tree, include.root = FALSE, type = "all", include.self = TRUE){
|
|
| 1268 |
+ all.nodes <- .nodeId(tree) |
|
| 1269 |
+ if (!include.root) {
|
|
| 1270 |
+ all.nodes <- setdiff(all.nodes, treeio::rootnode(tree)) |
|
| 1271 |
+ } |
|
| 1272 |
+ tip.nodes <- .nodeId(tree, type = "tips") |
|
| 1273 |
+ .internal_anc <- switch(type, all = treeio::ancestor, parent = treeio::parent) |
|
| 1274 |
+ ancestor <- lapply(tip.nodes, .internal_anc, .data = tree) |
|
| 1275 |
+ if (include.self) {
|
|
| 1276 |
+ ancestor <- mapply(append, tip.nodes, ancestor, SIMPLIFY = FALSE) |
|
| 1277 |
+ } |
|
| 1278 |
+ sbp <- lapply(ancestor, function(i) all.nodes %in% i) %>% |
|
| 1279 |
+ stats::setNames(tip.nodes) %>% do.call(rbind, .) |
|
| 1280 |
+ colnames(sbp) <- all.nodes |
|
| 1281 |
+ return(sbp) |
|
| 1282 |
+} |
|
| 1283 |
+ |
|
| 1284 |
+getXcoord_no_length_slanted <- function(x){
|
|
| 1285 |
+ x <- -colSums(x) |
|
| 1286 |
+ x <- unname(x[order(as.numeric(names(x)))]) |
|
| 1287 |
+ x <- x + max(abs(x)) |
|
| 1288 |
+ return(x) |
|
| 1289 |
+} |
|
| 1290 |
+ |
|
| 1291 |
+getYcoord_no_length_slanted <- function(y){
|
|
| 1292 |
+ y <- seq_len(nrow(y)) * y |
|
| 1293 |
+ y[y==0] <- NA |
|
| 1294 |
+ y <- colMeans(y, na.rm = TRUE) |
|
| 1295 |
+ y <- unname(y[order(as.numeric(names(y)))]) |
|
| 1296 |
+ return(y) |
|
| 1297 |
+} |