Merge pull request #132 from uclahs-cds/danknight-nodeless

Node-by-node control of node rendering ("nodeless" mode)
uclahs-cds · Aug 6, 2024 · dc0d7c5 · dc0d7c5
2 parents 72a51a9 + 32f356d
commit dc0d7c5
Show file tree

Hide file tree

Showing 10 changed files with 197 additions and 81 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Package: CancerEvolutionVisualization
 Title: Publication Quality Phylogenetic Tree Plots
 Version: 2.1.0
-Date: 2024-07-31
+Date: 2024-08-05
 Authors@R: c(
 	person("Paul Boutros", role = "cre", email = "[email protected]"),
 	person("Adriana Salcedo", role = "aut"),

diff --git a/NEWS.md b/NEWS.md
@@ -1,22 +1,18 @@
-# CancerEvolutionVisualization 2.1.0 (2024-07-31)
+# CancerEvolutionVisualization 2.1.0 (2024-08-05)
 
 ## Added
 * Optional "spread" column to control node/branch spacing
 * Plotting functions to visualize the distribution of clones across the genome.
 * Documentation for heatmaps and clone-genome distirbution plor
+* Option to disable node drawing with node-by-node control 
 
 ## Update
 * Fixed angle calculation bug where child angles do not follow
   their parent angle, instead moving "downward" at 0 degrees.
 * Updated package metadata and README
-<<<<<<< HEAD:NEWS.md
 * Set default parameters for heatmaps, defaulting too BPG defaults unless necessary
 * Updated changelog format to NEWS.md Markdown format
-=======
 * Refactored use of plyr/dplyr and stringr functions to remove dependencies
-* Set default parameters for heatmaps, defaulting to BPG defaults unless necessary
-
->>>>>>> 2424b7934e815dcc02cce5482c1b1c16bf319a09:NEWS
 
 
 # CancerEvolutionVisualization 2.0.1 (2023-11-17)

diff --git a/R/SRCGrob.R b/R/SRCGrob.R
@@ -20,7 +20,6 @@ SRCGrob <- function(
     node.radius = 0.1,
     node.text.line.dist = 0.1,
     colour.scheme = CancerEvolutionVisualization::colours,
-    draw.nodes = TRUE,
     add.normal = FALSE,
     use.radians = FALSE,
     normal.cex = 1,
@@ -99,7 +98,6 @@ SRCGrob <- function(
         axis.cex = axis.cex,
         xaxis.label = xaxis.label,
         min.width = min.width,
-        draw.nodes = draw.nodes,
         label.nodes = label.nodes,
         node.col = node.col,
         label.cex = label.cex,

diff --git a/R/add.nodes.R b/R/add.nodes.R
@@ -29,19 +29,20 @@ add.node.ellipse <- function(
 	    );
 
 	node.grob.name <- 'node.polygons';
+    circle.nodes <- clone.out$v[clone.out$v$draw.node, ];
 
-	#more precise than circleGrob
+	# More precise than circleGrob
 	circle.grobs <- ellipseGrob(
 	    name = node.grob.name,
-	    x = unit(clone.out$v$x, 'native'),
-	    y = unit(clone.out$v$y, 'native'),
-	    size = node.radius * (1 + 0.2 * nchar(clone.out$v$plot.lab)),
-	    ar = 1 - log2(nchar(clone.out$v$plot.lab)) / 10,
+	    x = unit(circle.nodes$x, 'native'),
+	    y = unit(circle.nodes$y, 'native'),
+	    size = node.radius * (1 + 0.2 * nchar(circle.nodes$plot.lab)),
+	    ar = 1 - log2(nchar(circle.nodes$plot.lab)) / 10,
 	    gp = gpar(
-	        fill = clone.out$v$node.colour,
-	        col = clone.out$v$border.colour,
-	        lty = clone.out$v$border.type,
-	        lwd = clone.out$v$border.width
+	        fill = circle.nodes$node.colour,
+	        col = circle.nodes$border.colour,
+	        lty = circle.nodes$border.type,
+	        lwd = circle.nodes$border.width
 	        ),
 	    angle = pi / 2,
 	    position.units = 'native',
@@ -58,11 +59,11 @@ add.node.ellipse <- function(
 
   		node.label.grob <- textGrob(
   		    name = 'node.labels',
-  		    clone.out$v$plot.lab,
-  		    x = unit(clone.out$v$x, 'native'),
-  		    y = unit(clone.out$v$y, 'native'),
+  		    circle.nodes$plot.lab,
+  		    x = unit(circle.nodes$x, 'native'),
+  		    y = unit(circle.nodes$y, 'native'),
   		    just = c('center', 'center'),
-  		    gp = gpar(col = clone.out$v$node.label.colour, cex = label.cex - log2(nchar(clone.out$v$plot.lab)) / 10)
+  		    gp = gpar(col = circle.nodes$node.label.colour, cex = label.cex - log2(nchar(circle.nodes$plot.lab)) / 10)
   		    );
 
 	    clone.out$grobs <- c(clone.out$grobs, list(node.label.grob));

diff --git a/R/adjust.tree.R b/R/adjust.tree.R
@@ -30,6 +30,7 @@ adjust.branch.lengths <- function(node.df, tree, node.radius, scale1) {
         }
 
     node.df$node.radius[node.df$id == -1] <- 0;
+    node.df[!node.df$draw.node, 'node.radius'] <- 0;
     length.cols <- grep('length', colnames(tree));
 
     tree.adj <- apply(

diff --git a/R/make.clone.tree.grobs.R b/R/make.clone.tree.grobs.R
@@ -27,7 +27,6 @@ make.clone.tree.grobs <- function(
     axis.cex,
     xaxis.label,
     min.width,
-    draw.nodes,
     node.radius,
     label.nodes,
     node.col,
@@ -87,7 +86,7 @@ make.clone.tree.grobs <- function(
 	    tree$length <- tree$length1;
 	    }
 
-	if (draw.nodes != 'none' && length.from.node.edge == TRUE) {
+	if (length.from.node.edge == TRUE) {
 	    tree <- adjust.branch.lengths(v, tree, node.radius, scale1);
     	}
 
@@ -119,7 +118,7 @@ make.clone.tree.grobs <- function(
 
 	if (!no.ccf) {
 		get.CP.polygons(clone.out);
-	}
+    	}
 
 	add.tree.segs(clone.out, node.radius, default.branch.width, scale1, seg1.col, seg2.col);
 
@@ -132,9 +131,7 @@ make.clone.tree.grobs <- function(
 		# add.pie.nodes(clone.out, node.radius, cluster.list);
     	}
 
-	if (draw.nodes) {
-	    add.node.ellipse(clone.out,node.radius, label.nodes, label.cex, scale1);
-	    }
+    add.node.ellipse(clone.out,node.radius, label.nodes, label.cex, scale1);
 
 	if (add.normal == TRUE) {
 		add.normal(clone.out,node.radius,label.cex, normal.cex)

diff --git a/R/prep.tree.R b/R/prep.tree.R
@@ -101,60 +101,26 @@ prep.tree <- function(
         if (is.null(tree.df$label)) tree.df$child else tree.df$label
         );
 
-    if (('node.col' %in% colnames(tree.df))) {
-        tree.df$node.col[is.na(tree.df$node.col)] <- default.node.colour;
-    } else {
-        tree.df$node.col <- default.node.colour;
-        }
+    tree.df <- prep.draw.node.setting(tree.df);
 
-    tree.df$node.label.col <- prep.node.label.colours(tree.df);
-
-    tree.df$border.col <- apply(
+    tree.df <- prep.node.colours(
         tree.df,
-        MARGIN = 1,
-        FUN = function(row) {
-            if (is.na(row['border.col'])) row['node.col'] else row['border.col'];
-        }
-    );
-
-    if ('border.type' %in% colnames(tree.df)) {
-        valid.border.types <- c(
-            'blank',
-            'solid',
-            'dashed',
-            'dotted',
-            'dotdash',
-            'longdash',
-            'twodash'
-            );
-
-        border.type.is.valid <- tree.df$border.type %in% valid.border.types | is.na(tree.df$border.type);
-
-        if (!all(border.type.is.valid)) {
-            stop(paste(
-                'Invalid border type specified.',
-                'Must be one of', paste(c(valid.border.types, 'or NA.'), collapse = ', ')
-                ));
-            }
+        default.node.colour = default.node.colour
+        );
 
-        tree.df$border.type[is.na(tree.df$border.type)] <- if (is.numeric(tree.df$border.type)) 1 else 'solid';
-    } else {
-        tree.df$border.type <- 'solid';
-        }
+    tree.df$node.label.col <- prep.node.label.colours(tree.df);
 
-    if ('border.width' %in% colnames(tree.df)) {
-        tree.df$border.width <- as.numeric(tree.df$border.width);
-        tree.df$border.width[is.na(tree.df$border.width)] <- 1;
-    } else {
-        tree.df$border.width <- 1;
-        }
+    tree.df <- prep.node.border.colours(tree.df);
+    tree.df <- prep.node.border.type(tree.df);
+    tree.df <- prep.node.border.width(tree.df);
 
     out.df <- data.frame(
         id = c(-1, tree.df$child),
         label.text = c('', tree.df$label),
         ccf = if (is.null(tree.df$CP)) NA else c(1, tree.df$CP),
         color = colour.scheme[1:(nrow(tree.df) + 1)],
         angle = c(NA, tree.df$angle),
+        draw.node = c(NA, tree.df$draw.node),
         spread = c(NA, tree.df$spread),
         node.colour = c(NA, tree.df$node.col),
         node.label.colour = c(NA, tree.df$node.label.col),
@@ -229,8 +195,6 @@ reset.tree.node.ids <- function(tree.df, value.index) {
     return(tree.df);
     }
 
-
-
 check.parent.values <- function(node.names, parent.col) {
     unique.node.names <- as.list(setNames(
         !vector(length = length(unique(node.names))),
@@ -349,6 +313,85 @@ prep.edge.colour.column <- function(tree.df, column.name, default.value) {
         }
     }
 
+prep.draw.node.setting <- function(tree.df) {
+    if ('draw.node' %in% colnames(tree.df)) {
+        NA.indices <- is.na(tree.df$draw.node);
+        tree.df$draw.node <- as.logical(tree.df$draw.node);
+
+        if (any(is.na(tree.df$draw.node) & !NA.indices)) {
+            warning('Non-logical values found in "draw.node" column.');
+            }
+
+        tree.df$draw.node[is.na(tree.df$draw.node)] <- TRUE;
+    } else {
+        tree.df$draw.node <- TRUE;
+        }
+
+    return(tree.df);
+    }
+
+prep.node.colours <- function(tree.df, default.node.colour) {
+    if ('node.col' %in% colnames(tree.df)) {
+        tree.df$node.col[is.na(tree.df$node.col)] <- default.node.colour;
+    } else {
+        tree.df$node.col <- default.node.colour;
+        }
+
+    return(tree.df);
+    }
+
+prep.node.border.colours <- function(tree.df) {
+    tree.df$border.col <- apply(
+        tree.df,
+        MARGIN = 1,
+        FUN = function(row) {
+            if (is.na(row['border.col'])) row['node.col'] else row['border.col'];
+            }
+        );
+
+    return(tree.df);
+    }
+
+prep.node.border.type <- function(tree.df) {
+    if ('border.type' %in% colnames(tree.df)) {
+        valid.border.types <- c(
+            'blank',
+            'solid',
+            'dashed',
+            'dotted',
+            'dotdash',
+            'longdash',
+            'twodash'
+            );
+
+        border.type.is.valid <- tree.df$border.type %in% valid.border.types | is.na(tree.df$border.type);
+
+        if (!all(border.type.is.valid)) {
+            stop(paste(
+                'Invalid border type specified.',
+                'Must be one of', paste(c(valid.border.types, 'or NA.'), collapse = ', ')
+                ));
+            }
+
+        tree.df$border.type[is.na(tree.df$border.type)] <- if (is.numeric(tree.df$border.type)) 1 else 'solid';
+    } else {
+        tree.df$border.type <- 'solid';
+        }
+
+    return(tree.df);
+    }
+
+prep.node.border.width <- function(tree.df) {
+    if ('border.width' %in% colnames(tree.df)) {
+        tree.df$border.width <- as.numeric(tree.df$border.width);
+        tree.df$border.width[is.na(tree.df$border.width)] <- 1;
+    } else {
+        tree.df$border.width <- 1;
+        }
+
+    return(tree.df);
+    }
+
 prep.node.label.colours <- function(tree.df) {
     node.col.error.message <- 'Cannot prepare node label colour without node colour values.';
 

diff --git a/man/SRCGrob.Rd b/man/SRCGrob.Rd
@@ -28,7 +28,6 @@ SRCGrob(
     node.radius = 0.1,
     node.text.line.dist = 0.1,
     colour.scheme = CancerEvolutionVisualization::colours,
-    draw.nodes = TRUE,
     add.normal = FALSE,
     use.radians = FALSE,
     normal.cex = 1,
@@ -73,7 +72,6 @@ SRCGrob(
   Distance between node text and tree branches (as a value between 0 and 1)
   }
   \item{colour.scheme}{Vector of colour values to be used for CP polygons}
-  \item{draw.nodes}{Enable or disable drawing tree nodes}
   \item{add.normal}{Adds a normal}
   \item{use.radians}{Unit to be used for "angle" column (degrees or radians)}
   \item{normal.cex}{Font size within the normal "box"}
@@ -173,4 +171,13 @@ SRCGrob(
     simple.tree,
     add.normal = TRUE
     );
+
+
+# Nodeless Mode
+nodeless.tree <- data.frame(
+    parent = c(NA, 1, 2, 2),
+    draw.node = c(TRUE, FALSE, TRUE, TRUE)
+    );
+
+SRCGrob(nodeless.tree);
 }
diff --git a/tests/testthat/test-prep.tree.R b/tests/testthat/test-prep.tree.R
@@ -599,7 +599,7 @@ test_that(
     });
 
 test_that(
-    'prep.node.label.colours errors if "node.col" columb contains NAs', {
+    'prep.node.label.colours errors if "node.col" column contains NAs', {
         tree.df <- data.frame(node.col = c(NA, 1:3));
 
         expect_error(
@@ -608,6 +608,47 @@ test_that(
             );
     });
 
+test_that(
+    'prep.draw.node.setting uses valid values', {
+        tree.df <- data.frame(draw.node = c(TRUE, FALSE, TRUE, FALSE, FALSE));
+        result <- prep.draw.node.setting(tree.df);
+        expect_equal(result$draw.node, tree.df$draw.node);
+    });
+
+test_that(
+    'prep.draw.node.setting uses default if no column included', {
+        tree.df <- data.frame(parent = c(NA, 1, 2, 3));
+
+        result <- prep.draw.node.setting(tree.df);
+        expected.result <- rep(TRUE, nrow(tree.df));
+
+        expect_equal(result$draw.node, expected.result);
+    });
+
+test_that(
+    'prep.draw.node.setting fills NA values with default', {
+        tree.df <- data.frame(draw.node = c(TRUE, FALSE, TRUE, FALSE, FALSE));
+        NA.indices <- c(2, 3, 5);
+        tree.df[NA.indices, 'draw.node'] <- NA;
+
+        result <- prep.draw.node.setting(tree.df);
+
+        default.value <- TRUE;
+        expected.result <- tree.df$draw.node;
+        expected.result[NA.indices] <- default.value;
+
+        expect_equal(result$draw.node, expected.result);
+    });
+
+test_that(
+    'prep.draw.node.setting warns on non-logical values', {
+        tree.df <- data.frame(draw.node = c(TRUE, FALSE, 'invalid', TRUE));
+        expect_warning(
+            prep.draw.node.setting(tree.df),
+            regexp = 'draw.node'
+            );
+    });
+
 test_that(
     'prep.tree.spread result is numeric', {
         tree.df <- data.frame(