Merge pull request #76 from uclahs-cds/danknight-node-colours

Extend node style functionality

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: CancerEvolutionVisualization
 Title: Publication Quality Phylogenetic Tree Plots
-Version: 1.1.1
-Date: 2023-03-24
+Version: 2.0.0
+Date: 2023-10=20
 Authors@R: c(
 	person("Paul Boutros", role = "cre", email = "[email protected]"),
 	person("Adriana Salcedo", role = "aut"),

NEWS

@@ -1,8 +1,15 @@
-CancerEvolutionVisualization 1.1.1 2022-11-18 (Helena Winata)
+CancerEvolutionVisualization 2.0.0 2023-10-20 (Helena Winata, Dan Knight)
 
 ADDED
 * Generic functions to generate accompanying heatmaps
+* Option to specify tree node colours with "node.col" column
+* Option to specify tree node border colour, width, and line-type with 
+  "border.col", "border.width", and "border.type" columns
+* Option ot specify tree node label colour with "node.label.col" column
 
+REMOVED
+* "node.col" parameter to SRCGrob. (Node colour only customizable through
+  tree input data.frame.)
 
 --------------------------------------------------------------------------
 CancerEvolutionVisualization 1.0.1 2022-10-03 (Dan Knight)

R/SRCGrob.R

@@ -18,7 +18,6 @@ SRCGrob <- function(
     main.y = NULL,
     main.cex = 1.7,
     node.radius = 0.1,
-    node.col = 'grey29',
     seg1.col = 'black',
     seg2.col = 'green',
     line.lwd = 3,
@@ -42,10 +41,13 @@ SRCGrob <- function(
     yat <- prep.yat(yat);
     yaxis.position <- get.y.axis.position(colnames(tree));
 
+    node.col <- 'grey40';
+
     inputs <- prep.tree(
         tree,
         node.text,
-        colour.scheme = colour.scheme
+        colour.scheme = colour.scheme,
+        default.node.colour = node.col
         );
 
     fixed.angle <- pi / 6;

R/add.nodes.R

@@ -37,7 +37,12 @@ add.node.ellipse <- function(
 	    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,
-	    gp = gpar(fill = clone.out$v$colour, col = clone.out$v$colour),
+	    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
+	        ),
 	    angle = pi / 2,
 	    position.units = 'native',
 	    size.units = 'inches',
@@ -57,7 +62,7 @@ add.node.ellipse <- function(
   		    x = unit(clone.out$v$x, 'native'),
   		    y = unit(clone.out$v$y, 'native'),
   		    just = c('center', 'center'),
-  		    gp = gpar(col = '#FFFFFF', cex = label.cex - log2(nchar(clone.out$v$plot.lab)) / 10)
+  		    gp = gpar(col = clone.out$v$node.label.colour, cex = label.cex - log2(nchar(clone.out$v$plot.lab)) / 10)
   		    );
 
 	    clone.out$grobs <- c(clone.out$grobs, list(node.label.grob));

R/get.colours.R

@@ -16,3 +16,37 @@ get.colours <- function(
         return(col.list[value.list]);
         }
     }
+
+get.colour.luminance <- function(colour) {
+    # Formulas and values documented in:
+    # https://www.w3.org/WAI/GL/wiki/Relative_luminance
+    sRGB.values <- col2rgb(colour) / 255;
+    sRGB.values <- sapply(
+        sRGB.values,
+        FUN = function(sRGB.value) {
+            if (sRGB.value <= 0.03928) {
+                return(sRGB.value / 12.92);
+            } else {
+                return(((sRGB.value + 0.055 ) / 1.055) ** 2.4);
+                }
+            }
+        );
+
+    luminance.modifiers <- c(0.2126, 0.7152, 0.0722);
+    luminance <- sum(sRGB.values * luminance.modifiers);
+
+    return(luminance);
+    }
+
+get.contrast.ratio <- function(luminance1, luminance2) {
+    # Based on WCAG accessibility standards:
+    # https://www.w3.org/TR/2008/REC-WCAG20-20081211/#visual-audio-contrast-contrast
+    luminance <- sort(
+        c(luminance1, luminance2),
+        decreasing = TRUE
+        );
+    luminance <- luminance + 0.05;
+
+    contrast.ratio <- luminance[1] / luminance[2];
+    return(contrast.ratio);
+    }

R/prep.tree.R

@@ -2,7 +2,8 @@ prep.tree <- function(
     tree.df,
     text.df,
     bells = TRUE,
-    colour.scheme
+    colour.scheme,
+    default.node.colour = 'grey29'
     ) {
 
     if (!('parent' %in% colnames(tree.df))) {
@@ -70,11 +71,64 @@ 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$node.label.col <- prep.node.label.colours(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'];
+        }
+    );
+
+    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';
+        }
+
+    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;
+        }
+
     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)],
+        node.colour = c(NA, tree.df$node.col),
+        node.label.colour = c(NA, tree.df$node.label.col),
+        border.colour = c(NA, tree.df$border.col),
+        border.type = c(NA, tree.df$border.type),
+        border.width = c(NA, tree.df$border.width),
         parent = as.numeric(c(NA,tree.df$parent)),
         excluded = c(TRUE, rep(FALSE, nrow(tree.df))),
         bell = c(FALSE, rep(bells, nrow(tree.df))),
@@ -200,3 +254,45 @@ get.y.axis.position <- function(tree.colnames) {
 
     return(y.axis.position);
     }
+
+prep.node.label.colours <- function(tree.df) {
+    node.col.error.message <- 'Cannot prepare node label colour without node colour values.';
+
+    if (!'node.col' %in% colnames(tree.df)) {
+        stop(paste(
+            node.col.error.message,
+            '"node.col" column not found in tree.df'
+            ));
+    } else if (any(is.na(tree.df$node.col))) {
+        stop(paste(
+            node.col.error.message,
+            'NA values found in tree.df "node.col" column.'
+            ));
+        }
+
+    label.colours <- if (!'node.label.col' %in% colnames(tree.df)) {
+        rep(NA, nrow(tree.df));
+    } else {
+        tree.df$node.label.col;
+        }
+
+    NA.indices <- is.na(label.colours);
+    label.colours[NA.indices] <- as.character(sapply(
+        tree.df$node.col[NA.indices],
+        FUN = get.default.node.label.colour
+        ));
+
+    return(label.colours);
+    }
+
+get.default.node.label.colour <- function(node.colour) {
+    white.luminance <- get.colour.luminance('black');
+    node.colour.luminance <- get.colour.luminance(node.colour);
+
+    contrast.ratio <- get.contrast.ratio(white.luminance, node.colour.luminance);
+
+    # WCAG minimum contrast for normal/small text
+    # https://www.w3.org/TR/2008/REC-WCAG20-20081211/#visual-audio-contrast-contrast
+    WCAG.contrast.threshold <- 7;
+    return(if (contrast.ratio < WCAG.contrast.threshold) 'white' else 'black');
+    }

man/SRCGrob.Rd

@@ -26,7 +26,6 @@ SRCGrob(
     main.y = NULL,
     main.cex = 1.7,
     node.radius = 0.1,
-    node.col = "grey29",
     seg1.col = "black",
     seg2.col = "green",
     line.lwd = 3,
@@ -72,7 +71,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{node.col}{Node colour}
   \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}

tests/testthat/helper-compare.R

@@ -19,9 +19,10 @@ compare.trees <- function(example, test) {
     # Grob comparisons
     test.segment.grobs <- function(example, test) {
         get.segment.grobs <- function(x) {
+            tree.segs2 <- getGrob(x, 'tree.segs.2');
             c(
                 list(getGrob(x, 'tree.segs.1')),
-                list(getGrob(x, 'tree.segs.2')),
+                if (!is.null(tree.segs2)) list(tree.segs2) else NULL,
                 sapply(
                     x$children[get.axis.keys(x)],
                     FUN = function(ax) {
@@ -89,15 +90,21 @@ compare.trees <- function(example, test) {
         example.grobs <- get.line.grobs(example);
         test.grobs <- get.line.grobs(test);
 
-        all(sapply(
-            1:(length(example.grobs)),
-            FUN = function(i) {
-                compare.lines(
-                    example.grobs[[i]],
-                    test.grobs[[i]]
-                    );
-                }
-            ));
+        result <- if (length(example.grobs) > 0) {
+            all(sapply(
+                1:(length(example.grobs)),
+                FUN = function(i) {
+                    compare.lines(
+                        example.grobs[[i]],
+                        test.grobs[[i]]
+                        );
+                    }
+                ));
+        } else {
+            TRUE;
+            }
+
+        return(result);
         }
 
     test.text.grobs <- function(example, test) {
@@ -174,7 +181,6 @@ compare.trees <- function(example, test) {
                 ));
 
             gp.equal <- identical(x$gp, y$gp);
-
             all(coords.equal, gp.equal);
             }
 
@@ -192,10 +198,15 @@ compare.trees <- function(example, test) {
             ));
         }
 
+    segs.equal <- test.segment.grobs(example, test);
+    text.equal <- test.text.grobs(example, test);
+    polygons.equal <- test.polygon.grobs(example, test);
+    lines.equal <- test.line.grobs(example, test);
+    print(c(segs.equal, text.equal, polygons.equal, lines.equal))
     all(
-        test.segment.grobs(example, test),
-        test.text.grobs(example, test),
-        test.polygon.grobs(example, test),
-        test.line.grobs(example, test)
+        segs.equal,
+        text.equal,
+        polygons.equal,
+        lines.equal
         );
     }

tests/testthat/helper-multitest.R

@@ -7,7 +7,6 @@ create.test.tree <- function(tree, node.text, sample, ...) {
         scale1 = 0.9,
         seg1.col = 'navy',
         seg2.col = 'gold',
-        node.col = 'grey40',
         line.lwd = 4,
         yaxis1.label = 'PGA',
         yaxis2.label = 'SNV',

tests/testthat/test-branching.R

@@ -0,0 +1,9 @@
+test_that(
+    'Branching tree values', {
+        load('data/branching.plots.Rda');
+        load('data/branching.data.Rda')
+
+        tree <- SRCGrob(branching.test.data$tree);
+        expect_true(compare.trees(branching.example, tree));
+    }
+);

tests/testthat/test-prep.tree.R

@@ -331,3 +331,62 @@ test_that(
 
         expect_equal(yaxis.position, expected.position);
     });
+
+test_that(
+    'prep.node.label.colours returns valid values', {
+        node.label.colours <- c('green', 'white');
+        tree.df <- data.frame(
+            node.label.col = node.label.colours,
+            node.col = 'red'
+            );
+
+        result <- prep.node.label.colours(tree.df);
+        expected.label.colours <- node.label.colours;
+
+        expect_equal(result, expected.label.colours);
+    });
+
+test_that(
+    'prep.node.label.colours replaces NAs with default value', {
+        tree.df <- data.frame(
+            node.label.col = 'black',
+            node.col = rep('red', 10)
+            );
+
+        NA.indices <- 3:(nrow(tree.df));
+        tree.df$node.label.col[NA.indices] <- NA;
+
+        default.label.colour <- 'white';
+
+        local({
+            get.default.node.label.colour <- function(node.colour) {
+                default.label.colour;
+                }
+
+            result <- prep.node.label.colours(tree.df);
+
+            expected.label.colours <- tree.df$node.label.col;
+            expected.label.colours[NA.indices] <- default.label.colour;
+            expect_equal(result, expected.label.colours);
+            });
+    });
+
+test_that(
+    'prep.node.label.colours errors if "node.col" column does not exist', {
+        tree.df <- data.frame(parent = 1:5);
+
+        expect_error(
+            prep.node.label.colours(tree.df),
+            regexp = '"node.col"'
+            );
+    });
+
+test_that(
+    'prep.node.label.colours errors if "node.col" columb contains NAs', {
+        tree.df <- data.frame(node.col = c(NA, 1:3));
+
+        expect_error(
+            prep.node.label.colours(tree.df),
+            regexp = '"node.col"'
+            );
+    });