Merge pull request #156 from uclahs-cds/hwinata-expose-polygon-alpha

Polygon parameters

Author: dan-knight

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: CancerEvolutionVisualization
 Title: Publication Quality Phylogenetic Tree Plots
 Version: 3.0.0
-Date: 2024-10-14
+Date: 2024-12-09
 Authors@R: c(
 	person("Paul Boutros", role = "cre", email = "[email protected]"),
 	person("Adriana Salcedo", role = "aut"),

NAMESPACE

@@ -7,7 +7,16 @@ importFrom("graphics", "par", "strheight", "strwidth")
 importFrom("grDevices", "dev.list", "rainbow")
 importFrom("utils", "read.table", "vi", "head")
 importFrom("stats", "median", "setNames", "aggregate", "reshape")
-importFrom("grDevices", "col2rgb", "dev.off", "pdf", "png", "svg", "tiff")
+importFrom(
+    "grDevices",
+    "col2rgb",
+    "dev.off",
+    "pdf",
+    "png",
+    "svg",
+    "tiff",
+    "colorRampPalette"
+    )
 
 export(SRCGrob)
 export(create.phylogenetic.tree)

NEWS.md

@@ -1,4 +1,4 @@
-# CancerEvolutionVisualization 3.0.0 (2024-10-14)
+# CancerEvolutionVisualization 3.0.0 (2024-12-09)
 
 ## Added
 * Dendrogram mode
@@ -8,7 +8,7 @@
 * Option to disable node drawing with node-by-node control
 * Node-by-node control of node size
 * Aesthetic changes for heatmap and clone-genome distribution plot
-* Add parameters to specify polygon shape and width.
+* Add parameters to specify polygon shape, width, color, and transparency (alpha).
 * Add option to use scale bars instead of y-axes.
 * Wrapper function for `SRCgrob` to automatically save plots to file
 * Add option to annotate the CCF summary heatmap with the cell values.

R/SRCGrob.R

@@ -18,14 +18,13 @@ SRCGrob <- function(
     main.y = NULL,
     main.cex = 1.7,
     node.text.line.dist = 0.1,
-    colour.scheme = 'grey',
+    polygon.colour.scheme = 'grey',
+    polygon.scale = 1,
     add.normal = FALSE,
     use.radians = FALSE,
     normal.cex = 1,
     label.nodes = TRUE,
     disable.polygons = FALSE,
-    polygon.shape = 3,
-    polygon.width = 1.2,
     length.from.node.edge = TRUE,
     size.units = 'npc',
     scale.bar = FALSE,
@@ -43,15 +42,18 @@ SRCGrob <- function(
     yat <- prep.yat(yat);
     yaxis.position <- get.y.axis.position(colnames(tree));
 
-    node.col <- 'white';
-    if (length(colour.scheme) == 1) {
-        colour.scheme <- c(NA, BoutrosLab.plotting.general::colour.gradient(colour.scheme, nrow(tree)));
+    if (polygon.scale < 0) {
+        stop('"polygon.scale" must be positive.');
         }
+    polygon.width <- 1.2 * polygon.scale;
+
+    node.col <- 'white';
+    colour.scheme <- gradient.color.scheme(polygon.colour.scheme, nrow(tree));
 
     inputs <- prep.tree(
         tree,
         node.text,
-        colour.scheme = colour.scheme,
+        polygon.colour.scheme = colour.scheme,
         use.radians = use.radians,
         default.node.colour = node.col
         );
@@ -92,7 +94,6 @@ SRCGrob <- function(
         length.from.node.edge = length.from.node.edge,
         default.branch.width = 4,
         add.polygons = add.polygons,
-        sig.shape = polygon.shape,
         spread = spread,
         fixed.angle = fixed.angle,
         add.node.text = add.node.text,

R/calculate.clone.polygons.R

@@ -24,10 +24,10 @@ make.polygon <- function(
     y0,
     x1,
     x2,
+    sig.shape,
     wid = 1,
     len = 1,
     col = 'gray',
-    sig.shape = 4,
     beta.in = 3
     ) {
 
@@ -62,7 +62,6 @@ position.polygons <- function(
     x,
     y,
     len,
-    sig.shape = 4,
     beta.in = 3,
     branching = TRUE,
     fixed.angle = NULL,
@@ -75,6 +74,7 @@ position.polygons <- function(
 
 	# get the row of v that corresponds to the clone
 	vi <- v[i,];
+	sig.shape <- vi[['polygon.shape']];
 
 	if (!is.na(vi$parent) && vi$parent == -1 && nrow(v[v$parent == -1, ]) == 1) {
 	    # If root the clone extends the full width of the plot
@@ -238,7 +238,6 @@ get.clones <- function(
     y = 0,
     wid = 1.2,
     len = len,
-    sig.shape = 3,
     beta.in = 3,
     branching = FALSE,
     no.ccf = FALSE,
@@ -266,7 +265,6 @@ get.clones <- function(
             x = x,
             y = y,
             len = len,
-            sig.shape = sig.shape,
             beta.in = beta.in,
             branching = branching,
             no.ccf = no.ccf,
@@ -290,7 +288,6 @@ get.clones <- function(
 	                x = x,
 	                y = y,
 	                len = len,
-	                sig.shape = sig.shape,
 	                beta.in = beta.in + beta.add,
 	                branching = branching,
 	                no.ccf = no.ccf,
@@ -319,7 +316,6 @@ compute.clones <- function(
     extra.len = 1,
     tree = NULL,
     fixed.angle = NULL,
-    sig.shape = 3,
     beta.in = 3,
     branching = TRUE,
     no.ccf = FALSE,
@@ -361,7 +357,6 @@ compute.clones <- function(
 	    x = x,
 	    y = y,
 	    len = len,
-	    sig.shape = sig.shape,
 	    beta.in = beta.in,
 	    branching = branching,
 	    no.ccf = no.ccf,
@@ -379,7 +374,6 @@ compute.clones <- function(
              y = y,
              wid = wid,
              len = len,
-             sig.shape = sig.shape,
              beta.in = beta.in,
              branching = branching,
              no.ccf = no.ccf,
@@ -394,7 +388,6 @@ compute.clones <- function(
 	    x = x,
 	    y = y,
 	    len = len,
-	    sig.shape = sig.shape,
 	    beta.in = beta.in,
 	    branching = branching,
 	    no.ccf = no.ccf,

R/create.ccf.summary.heatmap.R

@@ -4,7 +4,7 @@ create.ccf.summary.heatmap <- function(
     median.col = 'median.ccf.per.sample',
     clone.order = NULL,
     sample.order = NULL,
-    hm.col.scheme = c('white', 'blue'),
+    colour.scheme = c('white', 'blue'),
     clone.colours = NULL,
     subplot.xlab.cex = 1.2,
     subplot.xaxis.cex = 1,
@@ -107,7 +107,7 @@ create.ccf.summary.heatmap <- function(
         yaxis.cex = subplot.yaxis.cex,
         yaxis.fontface = subplot.yaxis.fontface,
         print.colour.key = FALSE,
-        colour.scheme = hm.col.scheme
+        colour.scheme = colour.scheme
         );
 
     if (add.median.text) {

R/make.clone.polygons.R

@@ -7,7 +7,6 @@ make.clone.polygons <- function(
     extra.len,
     node.col,
     spread = 1,
-    sig.shape = 3,
     fixed.angle = NULL,
     beta.in = 3,
     add.polygons = TRUE,
@@ -34,7 +33,6 @@ make.clone.polygons <- function(
 	    x = 0,
 	    y = tree$length[tree$parent == -1],
 	    fixed.angle = fixed.angle,
-	    sig.shape = sig.shape,
 	    beta.in = beta.in,
 	    branching = branching,
 	    no.ccf = no.ccf,

R/make.clone.tree.grobs.R

@@ -12,7 +12,6 @@ make.clone.tree.grobs <- function(
     seg2.col,
     cluster.list,
     add.polygons,
-    sig.shape,
     spread,
     fixed.angle,
     add.node.text,
@@ -106,7 +105,6 @@ make.clone.tree.grobs <- function(
         extra.len,
         node.col,
         spread = spread,
-        sig.shape = sig.shape,
         fixed.angle = fixed.angle,
         add.polygons = add.polygons,
         no.ccf = no.ccf

R/polygon.color.R

@@ -0,0 +1,10 @@
+gradient.color.scheme <- function(color.scheme, gradient.length) {
+    if (length(color.scheme) == 1) {
+        palette.ramp <- colorRampPalette(c('white', color.scheme, 'black'))
+        gradient <- palette.ramp(gradient.length + 2)[2:(gradient.length + 1)];
+    } else {
+        palette.ramp <- colorRampPalette(color.scheme);
+        gradient <- palette.ramp(gradient.length);
+        }
+    return(gradient);
+    }

R/prep.tree.R

@@ -2,7 +2,7 @@ prep.tree <- function(
     tree.df,
     text.df,
     bells = TRUE,
-    colour.scheme,
+    polygon.colour.scheme,
     use.radians = FALSE,
     default.node.colour = 'white'
     ) {
@@ -172,6 +172,33 @@ prep.tree <- function(
         conversion.fun = as.character
         );
 
+    if (!('polygon.col' %in% colnames(tree.df))) {
+        tree.df$polygon.col <- NA;
+        }
+    tree.df$polygon.col <- prep.column.values(
+        tree.df$polygon.col,
+        default.values = polygon.colour.scheme[1:nrow(tree.df)],
+        conversion.fun = as.character
+        );
+
+    if (!('polygon.alpha' %in% colnames(tree.df))) {
+        tree.df$polygon.alpha <- NA;
+        }
+    tree.df$polygon.alpha <- prep.column.values(
+        tree.df$polygon.alpha,
+        default.values = 0.5,
+        conversion.fun = as.numeric
+        );
+
+    if (!('polygon.shape' %in% colnames(tree.df))) {
+        tree.df$polygon.shape <- NA;
+        }
+    tree.df$polygon.shape <- prep.column.values(
+        tree.df$polygon.shape,
+        default.values = 3,
+        conversion.fun = as.numeric
+        );
+
     tree.df <- reorder.nodes(tree.df);
 
     # Include -1 value for root node.
@@ -208,7 +235,6 @@ prep.tree <- function(
         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),
         node.size = c(NA, tree.df$node.size),
@@ -229,7 +255,9 @@ prep.tree <- function(
         connector.type = c(NA, tree.df$connector.type),
         mode = c(NA, tree.df$mode),
         bell = c(FALSE, rep(bells, nrow(tree.df))),
-        alpha = rep(0.5, (nrow(tree.df) + 1)),
+        alpha = c(0, tree.df$polygon.alpha),
+        polygon.shape = c(NA, tree.df$polygon.shape),
+        color = c(NA, tree.df$polygon.col),
         stringsAsFactors = FALSE
         );
     if (length(branch.names) > 1) {

man/SRCGrob.Rd

@@ -26,22 +26,20 @@ SRCGrob(
     main.y = NULL,
     main.cex = 1.7,
     node.text.line.dist = 0.1,
-    colour.scheme = 'grey',
+    polygon.colour.scheme = 'grey',
+    polygon.scale = 1,
     add.normal = FALSE,
     use.radians = FALSE,
     normal.cex = 1,
     label.nodes = TRUE,
     disable.polygons = FALSE,
-    polygon.shape = 3,
-    polygon.width = 1.2,
     length.from.node.edge = TRUE,
     size.units = 'npc',
     scale.bar = FALSE,
     scale.bar.coords = c(0.5, 1),
     scale.size.1 = NA,
     scale.size.2 = NA,
     scale.padding = 1
-
     );
 }
 \arguments{
@@ -76,17 +74,13 @@ SRCGrob(
     \item{node.text.line.dist}{
     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 CCF polygons}
     \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'}
     \item{label.nodes}{Enable/disable node labels}
     \item{disable.polygons}{Disables CCF polygon drawing (even when CCF values are provided)}
-    \item{polygon.shape}{
-    Changes the shape of the CCF shading.
-    Lower values are smoother.
-    }
-    \item{polygon.width}{Width of the CCF shading}
+    \item{polygon.colour.scheme}{Vector of colour values to be used for CCF polygons. Creates a gradient color scheme.}
+    \item{polygon.scale}{Multiplier to scale CCF polygons (must be positive).}
     \item{length.from.node.edge}{
     Sets the branch length to be calculated from the edge of the node instead of the centre
     }

man/create.ccf.summary.heatmap.Rd

@@ -12,7 +12,7 @@ create.ccf.summary.heatmap(
     median.col = 'median.ccf.per.sample',
     clone.order = NULL,
     sample.order = NULL,
-    hm.col.scheme = c('white', 'blue'),
+    colour.scheme = c('white', 'blue'),
     clone.colours = NULL,
     subplot.xlab.cex = 1.2,
     subplot.xaxis.cex = 1,
@@ -38,7 +38,7 @@ create.ccf.summary.heatmap(
     \item{median.col}{Defaults to \dQuote{median.ccf.per.sample}}
     \item{clone.order}{Defaults to \code{NULL}}
     \item{sample.order}{Defaults to \code{NULL}}
-    \item{hm.col.scheme}{Heatmap colour scheme. Defaults to \code{c('white', 'blue')}}
+    \item{colour.scheme}{Heatmap colour scheme. Defaults to \code{c('white', 'blue')}}
     \item{clone.colours}{A named vector specifying the color to use for each clone to generate a covariate heatmap. If \code{NULL}, no covariates will be added.}
     \item{subplot.xlab.cex}{Subplot parameter. Defaults to 1.2}
     \item{subplot.xaxis.cex}{Subplot parameter. Defaults to 1}

tests/testthat/data/fish.data.Rda

@@ -0,0 +1,13 @@
+test_that(
+    'Fishplot case', {
+        load('data/fish.plots.Rda');
+        load('data/fish.data.Rda')
+
+        expect_true(compare.trees(
+            fish.example,
+            SRCGrob(
+                fish.test.data$tree,
+                polygon.colour.scheme = fish.test.data$colour.scheme
+                )
+            ));
+        });