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));
+ }