R/plotPhyloCoor.R

   1 ## plotPhyloCoor.R (2013-03-30)
   2
   3 ##   Coordinates of a Tree Plot
   4
   5 ## Copyright 2008 Damien de Vienne, 2013 Klaus Schliep
   6
   7 ## This file is part of the R-package `ape'.
   8 ## See the file ../COPYING for licensing issues.
   9
  10 plotPhyloCoor <-
  11     function (x, type = "phylogram", use.edge.length = TRUE, node.pos = NULL,
  12               direction = "rightwards", tip.order = NULL, ...)
  13 {
  14     Ntip <- length(x$tip.label)
  15     if (Ntip == 1)
  16         stop("found only one tip in the tree!")
  17     Nedge <- dim(x$edge)[1]
  18     if (any(tabulate(x$edge[, 1]) == 1))
  19         stop("there are single (non-splitting) nodes in your tree; you may need to use collapse.singles().")
  20     Nnode <- x$Nnode
  21     if (is.null(x$edge.length)) use.edge.length <- FALSE
  22     phyloORclado <- type %in% c("phylogram", "cladogram")
  23     horizontal <- direction %in% c("rightwards", "leftwards")
  24     if (phyloORclado) {
  25         ## changed by KS:
  26         yy <- numeric(Ntip + Nnode)
  27         if (!is.null(tip.order)) {
  28             yy[tip.order] <- 1:length(tip.order)
  29         } else {
  30             x <- reorder(x)
  31             TIPS <- x$edge[x$edge[, 2] <= Ntip, 2]
  32             yy[TIPS] <- 1:Ntip
  33         }
  34     }
  35
  36     xe <- x$edge
  37     ## first reorder the tree in cladewise order to avoid cophyloplot() hanging:
  38     ## x <- reorder(reorder(x), order = "pruningwise") ... maybe not needed anymore (EP)
  39     x <- reorder(x, order = "postorder")
  40     ereorder <- match(x$edge[, 2], xe[, 2])
  41
  42     if (phyloORclado) {
  43         if (is.null(node.pos)) {
  44             node.pos <- 1
  45             if (type == "cladogram" && !use.edge.length)
  46                 node.pos <- 2
  47         }
  48         if (node.pos == 1)
  49             yy <- .C("node_height", as.integer(Ntip), as.integer(Nnode),
  50                 as.integer(x$edge[, 1]), as.integer(x$edge[,
  51                   2]), as.integer(Nedge), as.double(yy), DUP = FALSE,
  52                 PACKAGE = "ape")[[6]]
  53         else {
  54             ans <- .C("node_height_clado", as.integer(Ntip),
  55                 as.integer(Nnode), as.integer(x$edge[, 1]), as.integer(x$edge[,
  56                   2]), as.integer(Nedge), double(Ntip + Nnode),
  57                 as.double(yy), DUP = FALSE, PACKAGE = "ape")
  58             xx <- ans[[6]] - 1
  59             yy <- ans[[7]]
  60         }
  61         if (!use.edge.length) {
  62             if (node.pos != 2)
  63                 xx <- .C("node_depth", as.integer(Ntip), as.integer(Nnode),
  64                   as.integer(x$edge[, 1]), as.integer(x$edge[,
  65                     2]), as.integer(Nedge), double(Ntip + Nnode),
  66                   DUP = FALSE, PACKAGE = "ape")[[6]] - 1
  67             xx <- max(xx) - xx
  68         }
  69         else {
  70             xx <- .C("node_depth_edgelength", as.integer(Ntip),
  71                 as.integer(Nnode), as.integer(x$edge[, 1]), as.integer(x$edge[,
  72                   2]), as.integer(Nedge), as.double(x$edge.length),
  73                 double(Ntip + Nnode), DUP = FALSE, PACKAGE = "ape")[[7]]
  74         }
  75     }
  76     ##if (type == "fan") {
  77     ##    TIPS <- xe[which(xe[, 2] <= Ntip), 2]
  78     ##    xx <- seq(0, 2 * pi * (1 - 1/Ntip), 2 * pi/Ntip)
  79     ##    theta <- double(Ntip)
  80     ##    theta[TIPS] <- xx
  81     ##    theta <- c(theta, numeric(Nnode))
  82     ##    theta <- .C("node_height", as.integer(Ntip), as.integer(Nnode),
  83     ##        as.integer(x$edge[, 1]), as.integer(x$edge[, 2]),
  84     ##        as.integer(Nedge), theta, DUP = FALSE, PACKAGE = "ape")[[6]]
  85     ##    if (use.edge.length) {
  86     ##        r <- .C("node_depth_edgelength", as.integer(Ntip),
  87     ##            as.integer(Nnode), as.integer(x$edge[, 1]), as.integer(x$edge[,
  88     ##              2]), as.integer(Nedge), as.double(x$edge.length),
  89     ##            double(Ntip + Nnode), DUP = FALSE, PACKAGE = "ape")[[7]]
  90     ##    }
  91     ##    else {
  92     ##        r <- .C("node_depth", as.integer(Ntip), as.integer(Nnode),
  93     ##            as.integer(x$edge[, 1]), as.integer(x$edge[,
  94     ##              2]), as.integer(Nedge), double(Ntip + Nnode),
  95     ##            DUP = FALSE, PACKAGE = "ape")[[6]]
  96     ##        r <- 1/r
  97     ##    }
  98     ##    xx <- r * cos(theta)
  99     ##    yy <- r * sin(theta)
 100     ##}
 101     ##if (type == "unrooted") {
 102     ##    XY <- if (use.edge.length)
 103     ##        unrooted.xy(Ntip, Nnode, x$edge, x$edge.length)
 104     ##    else unrooted.xy(Ntip, Nnode, x$edge, rep(1, Nedge))
 105     ##    xx <- XY$M[, 1] - min(XY$M[, 1])
 106     ##    yy <- XY$M[, 2] - min(XY$M[, 2])
 107     ##}
 108     ##if (type == "radial") {
 109     ##    X <- .C("node_depth", as.integer(Ntip), as.integer(Nnode),
 110     ##        as.integer(x$edge[, 1]), as.integer(x$edge[, 2]),
 111     ##        as.integer(Nedge), double(Ntip + Nnode), DUP = FALSE,
 112     ##        PACKAGE = "ape")[[6]]
 113     ##    X[X == 1] <- 0
 114     ##    X <- 1 - X/Ntip
 115     ##    yy <- c((1:Ntip) * 2 * pi/Ntip, rep(0, Nnode))
 116     ##    Y <- .C("node_height", as.integer(Ntip), as.integer(Nnode),
 117     ##        as.integer(x$edge[, 1]), as.integer(x$edge[, 2]),
 118     ##        as.integer(Nedge), as.double(yy), DUP = FALSE, PACKAGE = "ape")[[6]]
 119     ##    xx <- X * cos(Y)
 120     ##    yy <- X * sin(Y)
 121     ##}
 122     if (phyloORclado && direction != "rightwards") {
 123         if (direction == "leftwards") {
 124             xx <- -xx
 125             xx <- xx - min(xx)
 126         }
 127         if (!horizontal) {
 128             tmp <- yy
 129             yy <- xx
 130             xx <- tmp - min(tmp) + 1
 131             if (direction == "downwards") {
 132                 yy <- -yy
 133                 yy <- yy - min(yy)
 134             }
 135         }
 136     }
 137     cbind(xx, yy)
 138 }