Merge branch 'main' of github.com:uclahs-cds/public-R-CancerEvolution…

…Visualization into danknight-scalebar

R/add.text.R

@@ -139,7 +139,7 @@ position.node.text <- function(
             label.bottom <- str.heightsum <- 0;
             cex <- orig.cex;
 
-            #centre the height of all the text relative to the line
+            # centre the height of all the text relative to the line
             while (
                 str.heightsum == 0 |
                 (label.bottom + str.heightsum) > (main.y + panel.height) |
@@ -473,7 +473,7 @@ position.node.text <- function(
     return(text.grob.list);
     }
 
-add.text2 <- function(
+add.text3 <- function(
     tree,
     node.text,
     label.nodes = FALSE,
@@ -616,3 +616,190 @@ add.text2 <- function(
 
     return(list(text.tree, tree.max.adjusted));
 	}
+
+
+add.text2 <- function(
+    tree,
+    node.text,
+    label.nodes = FALSE,
+    cex = 1,
+    line.dist = 0.5,
+    v = NULL,
+    main.y = NULL,
+    panel.height = NULL,
+    panel.width = NULL,
+    xlims = NULL,
+    ymax = ymax,
+    axis.type = NULL,
+    scale = NULL,
+    node.radius = NULL,
+    alternating = TRUE,
+    split = TRUE,
+    clone.out = NULL
+    ) {
+
+    # Radius in native units
+    node.radius <- node.radius / scale;
+    node.text <- node.text[node.text$node %in% tree$tip, ];
+    node.list <- alply(
+        seq_len(nrow(tree)),
+        .margins = 1,
+        .fun = function(x) {
+            return(character())
+            }
+        );
+
+    node.text.col <- node.list;
+    node.text.fontface <- node.list;
+
+    a_ply(
+        seq_len(
+            nrow(node.text)),
+        .margins = 1,
+        .fun = function(x) {
+            text.row <- node.text[x, ];
+            pos <- which(tree$tip == text.row$node);
+            text.value <- text.row$name;
+
+            if (length(grep('_', text.value)) > 0) {
+                text.split <- strsplit(text.value, split = '_')[[1]];
+                node.text.value <- text.split[1];
+                amp <- text.split[2];
+                call <- paste0(node.text.value, '^\'A', amp, '\'');
+                text.value <- parse(text = call);
+                }
+
+            node.list[[pos]] <<- c(node.list[[pos]], text.value);
+
+            node.text.col[[pos]] <<- c(
+                node.text.col[[pos]],
+                if (!is.na(text.row$col)) text.row$col else 'black'
+                );
+
+            node.text.fontface[[pos]] <<- c(
+                node.text.fontface[[pos]],
+                if (!is.na(text.row$fontface)) text.row$fontface else 'plain'
+                );
+            }
+        );
+
+    tree.max <- adply(
+        tree,
+        .margins = 1,
+        .fun = function(x) {
+            if (x$parent == -1) {
+                basex <- 0;
+                basey <- 0;
+            } else {
+                basex <- v$x[v$id == x$parent];
+                basey <- v$y[v$id == x$parent];
+                }
+
+            tipx <- v$x[v$id == x$tip];
+            tipy <- v$y[v$id == x$tip];
+
+            return(data.frame(basex, basey, tipx, tipy));
+            }
+        );
+
+    #the length of the visible line segments
+    tree.max.adjusted <- adply(
+        tree.max,
+        .margins = 1,
+        .fun = function(x) {
+            if (x$tipx == x$basex) {
+                #straight line
+                basex <- x$basex;
+                tipx <- x$tipx;
+                basey <- x$basey + node.radius;
+                tipy <- x$tipy - node.radius;
+            } else if (x$tipx > x$basex) {
+                basey <- x$basey + node.radius * cos(x$angle);
+                tipy <- x$tipy - node.radius * cos(x$angle);
+                basex <- x$basex + node.radius * sin(x$angle);
+                tipx <- x$tipx - node.radius * sin(x$angle);
+            } else if (x$tipx < x$basex) {
+                basey <- x$basey + node.radius * cos(x$angle);
+                tipy <- x$tipy - node.radius * cos(x$angle);
+                basex <- x$basex + node.radius * sin(x$angle);
+                tipx <- x$tipx - node.radius * sin(x$angle);
+                }
+            if (x$parent == -1) {
+                basex <- basey <- 0;
+                }
+
+            return(data.frame(basex,basey,tipx,tipy));
+            }
+        );
+
+    #push a viewport the same size as the final panel so we can do calculations based on absolute size units
+    if (!is.null(clone.out)) {
+        pushViewport(clone.out$vp);
+    } else {
+        pushViewport(viewport(
+            height = unit(panel.height, 'inches'),
+            name = 'ref',
+            width = unit(panel.width,'inches'),
+            xscale = xlims,
+            yscale = c(ymax, -2)
+            ));
+        }
+
+    tree.max.adjusted$x0 <- convertX(unit(tree.max.adjusted$basex, 'native'), 'inches', valueOnly = TRUE);
+    tree.max.adjusted$x1 <- convertX(unit(tree.max.adjusted$tipx, 'native'), 'inches', valueOnly = TRUE);
+    tree.max.adjusted$y0 <- convertY(unit(tree.max.adjusted$basey, 'native'), 'inches', valueOnly = TRUE);
+    tree.max.adjusted$y1 <- convertY(unit(tree.max.adjusted$tipy, 'native'), 'inches', valueOnly = TRUE);
+
+    tree.max.adjusted$y <- convertY(unit(tree.max$tipy, 'native'), 'inches', valueOnly = TRUE); # Actual node positions
+    tree.max.adjusted$x <- convertX(unit(tree.max$tipx, 'native'), 'inches', valueOnly = TRUE);
+
+    tree.max.adjusted$slope <- (tree.max.adjusted$y1 - tree.max.adjusted$y0) / (tree.max.adjusted$x1 - tree.max.adjusted$x0);
+    tree.max.adjusted$intercept <- tree.max.adjusted$y1 - tree.max.adjusted$slope * tree.max.adjusted$x1;
+
+    text.grob.list <- position.node.text(
+        tree.max.adjusted = tree.max.adjusted,
+        node.list = node.list,
+        node.text.col = node.text.col,
+        node.text.fontface = node.text.fontface,
+        axis.type = axis.type,
+        panel.height = panel.height,
+        panel.width = panel.width,
+        main.y = main.y,
+        line.dist = line.dist,
+        cex = cex,
+        node.radius = node.radius,
+        alternating = alternating,
+        split = split,
+        label.nodes = label.nodes
+        );
+
+    text.grob.gList <- do.call(gList, text.grob.list);
+
+    grob.name <- 'node.text';
+
+    if (!is.null(clone.out)) {
+        popViewport();
+        text.tree <- gTree(
+            name = grob.name,
+            children = text.grob.gList,
+            vp = make.plot.viewport(clone.out, clip = 'off')
+            );
+
+        return(text.tree);
+        }
+
+    text.tree <- gTree(
+        name = grob.name,
+        children = text.grob.gList,
+        childrenvp = viewport(
+            height = unit(panel.height, 'inches'),
+            name = 'ref',
+            width = unit(panel.width, 'inches'),
+            xscale = xlims,
+            yscale = c(ymax, -2),
+            clip = 'off'
+            )
+        );
+
+    return(list(text.tree, tree.max.adjusted));
+	}