Merge pull request #82 from uclahs-cds/danknight-extend-branches

Extend edge style functionality
uclahs-cds · Nov 15, 2023 · 4e03d7d · 4e03d7d
2 parents 62d36ed + f51b0fe
commit 4e03d7d
Show file tree

Hide file tree

Showing 18 changed files with 327 additions and 33 deletions.
diff --git a/NEWS b/NEWS
@@ -1,6 +1,12 @@
-CancerEvolutionVisualization 2.0.0 2023-11-09
+CancerEvolutionVisualization 2.0.0 2023-11-09 (Helena Winata, Dan Knight)
 
 ADDED
+* Option to specify edge colour with "edge.col.1" and "edge.col.2" 
+  columns in tree input dataframe
+* Option to specify edge width using "edge.width.1" and "edge.width.2" 
+  columns in tree input dataframe
+* Option to specify edge linetype with "edge.type.1" and "edge.type.2" 
+  columns in tree input dataframe
 * Support for specifying tree angles in either radians or degrees using
   an optional "angle" column
 * Generic functions to generate accompanying heatmaps
@@ -14,8 +20,9 @@ UPDATE
 * Fixed lopsided radial tree bug
 
 REMOVED
-* "node.col" parameter to SRCGrob. (Node colour only customizable through
-  tree input data.frame.)
+* "seg1.col" and "seg2.col" parameters (replaced by tree input columns).
+* "node.col" parameter to SRCGrob. (Node colour only customizable through tree input data.frame.)
+
 
 --------------------------------------------------------------------------
 CancerEvolutionVisualization 1.0.1 2022-10-03 (Dan Knight)

diff --git a/R/SRCGrob.R b/R/SRCGrob.R
@@ -18,9 +18,6 @@ SRCGrob <- function(
     main.y = NULL,
     main.cex = 1.7,
     node.radius = 0.1,
-    seg1.col = 'black',
-    seg2.col = 'green',
-    line.lwd = 3,
     node.text.line.dist = 0.1,
     colour.scheme = CancerEvolutionVisualization::colours,
     draw.nodes = TRUE,
@@ -85,10 +82,10 @@ SRCGrob <- function(
         scale2 = scale2,
         yat = yat,
         wid = wid,
-        line.lwd = line.lwd,
         length.from.node.edge = length.from.node.edge,
         seg1.col = seg1.col,
         seg2.col = seg2.col,
+        default.branch.width = 4,
         add.polygons = add.polygons,
         sig.shape = sig.shape,
         spread = spread,

diff --git a/R/add.segs.R b/R/add.segs.R
@@ -219,8 +219,9 @@ add.tree.segs <- function(
         y1 = tree.segs1$tipy,
         default.units = 'native',
         gp = gpar(
-            col = seg1.col,
-            lwd = line.lwd
+            col = clone.out$v$edge.colour.1,
+            lwd = clone.out$v$edge.width.1,
+            lty = clone.out$v$edge.type.1
             )
         );
 
@@ -236,8 +237,9 @@ add.tree.segs <- function(
                 y1 = tree.segs2$tipy,
                 default.units = 'native',
                 gp = gpar(
-                    col = seg2.col,
-                    lwd = line.lwd
+                    col = clone.out$v$edge.colour.2,
+                    lwd = clone.out$v$edge.width.2,
+                    lty = clone.out$v$edge.type.2
                     )
                 );
             }

diff --git a/R/make.clone.tree.grobs.R b/R/make.clone.tree.grobs.R
@@ -6,7 +6,7 @@ make.clone.tree.grobs <- function(
     scale2,
     wid,
     yat,
-    line.lwd,
+    default.branch.width,
     length.from.node.edge,
     seg1.col,
     seg2.col,
@@ -121,7 +121,7 @@ make.clone.tree.grobs <- function(
 		get.CP.polygons(clone.out);
 	}
 
-	add.tree.segs(clone.out, node.radius, line.lwd, scale1, seg1.col, seg2.col);
+	add.tree.segs(clone.out, node.radius, default.branch.width, scale1, seg1.col, seg2.col);
 
 	if (!is.null(cluster.list)) {
 	    message(paste(

diff --git a/R/prep.branch.lengths.R b/R/prep.branch.lengths.R
@@ -11,9 +11,9 @@ get.default.branch.length.colnames <- function(num.columns) {
             }
     }
 
-get.default.branch.lengths <- function(num.rows) {
-    lengths <- data.frame(a = rep(1, times = num.rows));
-    colnames(lengths) <- get.default.branch.length.colnames(1);
+get.default.branch.lengths <- function(num.rows, num.cols) {
+    lengths <- data.frame(a = rep(num.cols, times = num.rows));
+    colnames(lengths) <- get.default.branch.length.colnames(num.cols);
 
     return(lengths);
     }
@@ -78,12 +78,16 @@ prep.branch.lengths <- function(tree.df) {
             )
         );
 
+    # TODO: Automatically create length2 if an edge.style.2 column is present.
     if (length(length.cols) > 0) {
         lengths.df <- data.frame(tree.df[, length.cols]);
         colnames(lengths.df) <- get.default.branch.length.colnames(length(length.cols));
 
         return(lengths.df);
     } else {
-        return(get.default.branch.lengths(nrow(tree.df)));
+        return(get.default.branch.lengths(
+            num.rows = nrow(tree.df),
+            num.cols = 1
+            ));
         }
     }
diff --git a/R/prep.tree.R b/R/prep.tree.R
@@ -54,6 +54,34 @@ prep.tree <- function(
             }
         }
 
+    tree.df <- prep.edge.colours(tree.df);
+
+    default.edge.type <- 'solid';
+    if ('edge.type.1' %in% colnames(tree.df)) {
+        tree.df$edge.type.1[is.na(tree.df$edge.type.1)] <- default.edge.type;
+    } else {
+        tree.df$edge.type.1 <- default.edge.type;
+        }
+
+    if ('edge.type.2' %in% colnames(tree.df)) {
+        tree.df$edge.type.2[is.na(tree.df$edge.type.2)] <- default.edge.type;
+    } else {
+        tree.df$edge.type.2 <- default.edge.type;
+        }
+
+    default.edge.width <- 3;
+    if ('edge.width.1' %in% colnames(tree.df)) {
+        tree.df$edge.width.1[is.na(tree.df$edge.width.1)] <- default.edge.width;
+    } else {
+        tree.df$edge.width.1 <- default.edge.width;
+        }
+
+    if ('edge.width.2' %in% colnames(tree.df)) {
+        tree.df$edge.width.2[is.na(tree.df$edge.width.2)] <- default.edge.width;
+    } else {
+        tree.df$edge.width.2 <- default.edge.width;
+        }
+
     tree.df <- reorder.nodes(tree.df);
 
     # Include -1 value for root node.
@@ -133,6 +161,12 @@ prep.tree <- function(
         border.width = c(NA, tree.df$border.width),
         parent = as.numeric(c(NA,tree.df$parent)),
         excluded = c(TRUE, rep(FALSE, nrow(tree.df))),
+        edge.colour.1 = c(NA, tree.df$edge.col.1),
+        edge.colour.2 = c(NA, tree.df$edge.col.2),
+        edge.type.1 = c(NA, tree.df$edge.type.1),
+        edge.type.2 = c(NA, tree.df$edge.type.2),
+        edge.width.1 = c(NA, tree.df$edge.width.1),
+        edge.width.2 = c(NA, tree.df$edge.width.2),
         bell = c(FALSE, rep(bells, nrow(tree.df))),
         alpha = rep(0.5, (nrow(tree.df) + 1)),
         stringsAsFactors = FALSE
@@ -257,6 +291,39 @@ get.y.axis.position <- function(tree.colnames) {
     return(y.axis.position);
     }
 
+prep.edge.colours <- function(tree.df) {
+    edge.colours <- list();
+
+    default.edge.colours <- c('black', 'green');
+    edge.colour.column.names <- sapply(
+        1:2,
+        function(i) paste('edge', 'col', i, sep = '.')
+        );
+
+    for (i in 1:length(edge.colour.column.names)) {
+        column.name <- edge.colour.column.names[i];
+        default.colour <- default.edge.colours[i];
+
+        if (column.name %in% colnames(tree.df)) {
+            tree.df[is.na(tree.df[, column.name]), column.name] <- default.colour;
+        } else {
+            tree.df[, column.name] <- default.colour;
+            }
+        }
+
+    return(tree.df);
+    }
+
+prep.edge.colour.column <- function(tree.df, column.name, default.value) {
+    if (column.name %in% colnames(tree.df)) {
+        values <- tree.df[, column.name];
+        values[is.na(values)] <- default.value;
+        return(values);
+    } else {
+        return(rep(default.value, nrow(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
@@ -26,9 +26,6 @@ SRCGrob(
     main.y = NULL,
     main.cex = 1.7,
     node.radius = 0.1,
-    seg1.col = "black",
-    seg2.col = "green",
-    line.lwd = 3,
     node.text.line.dist = 0.1,
     colour.scheme = CancerEvolutionVisualization::colours,
     draw.nodes = TRUE,
@@ -72,9 +69,6 @@ SRCGrob(
   \item{main.y}{Move the main plot title position up or down}
   \item{main.cex}{Font size for the main plot title}
   \item{node.radius}{Node size}
-  \item{seg1.col}{Colour of the first set of tree branch segments}
-  \item{seg2.col}{Colour of the second set of tree branch segments}
-  \item{line.lwd}{Branch segment thickness}
   \item{node.text.line.dist}{
   Distance between node text and tree branches (as a value between 0 and 1)
   }

diff --git a/tests/testthat/data/branching.fixed.data.Rda b/tests/testthat/data/branching.fixed.data.Rda
diff --git a/tests/testthat/data/branching.fixed.plots.Rda b/tests/testthat/data/branching.fixed.plots.Rda
diff --git a/tests/testthat/data/branching.radial.data.Rda b/tests/testthat/data/branching.radial.data.Rda
diff --git a/tests/testthat/data/branching.radial.plots.Rda b/tests/testthat/data/branching.radial.plots.Rda
diff --git a/tests/testthat/data/linear.data.Rda b/tests/testthat/data/linear.data.Rda
diff --git a/tests/testthat/data/linear.plots.Rda b/tests/testthat/data/linear.plots.Rda
diff --git a/tests/testthat/helper-multitest.R b/tests/testthat/helper-multitest.R
@@ -5,9 +5,6 @@ create.test.tree <- function(tree, node.text, sample, ...) {
         node.radius = 0.1,
         node.text.cex = 0.85,
         scale1 = 0.9,
-        seg1.col = 'navy',
-        seg2.col = 'gold',
-        line.lwd = 4,
         yaxis1.label = 'PGA',
         yaxis2.label = 'SNV',
         xaxis.label = 'CP',

diff --git a/tests/testthat/test-prep.branch.lengths.R b/tests/testthat/test-prep.branch.lengths.R
@@ -69,7 +69,10 @@ test_that(
         expected.length <- 10;
 
         expect_equal(
-            nrow(get.default.branch.lengths(expected.length)),
+            nrow(get.default.branch.lengths(
+                num.rows = expected.length,
+                num.cols = 1
+                )),
             expected.length
             );
     });
@@ -80,7 +83,7 @@ test_that(
 
         expect_true(all(
             apply(
-                get.default.branch.lengths(3),
+                get.default.branch.lengths(num.rows = 3, num.cols = 1),
                 MARGIN = 1,
                 FUN = function(x) {
                     x == expected.value;