diff --git a/DESCRIPTION b/DESCRIPTION index c58c736..6b53661 100644 --- a/DESCRIPTION +++ b/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 = "PBoutros@mednet.ucla.edu"), person("Adriana Salcedo", role = "aut"), diff --git a/NEWS b/NEWS index ebaca32..99cca4a 100644 --- a/NEWS +++ b/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) diff --git a/R/SRCGrob.R b/R/SRCGrob.R index ccfa165..c893f45 100644 --- a/R/SRCGrob.R +++ b/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; diff --git a/R/add.nodes.R b/R/add.nodes.R index a15000d..49e8b53 100644 --- a/R/add.nodes.R +++ b/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)); diff --git a/R/get.colours.R b/R/get.colours.R index 7206f5c..c867690 100644 --- a/R/get.colours.R +++ b/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); + } diff --git a/R/prep.tree.R b/R/prep.tree.R index c51b74a..dea55e9 100644 --- a/R/prep.tree.R +++ b/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'); + } diff --git a/man/SRCGrob.Rd b/man/SRCGrob.Rd index 0164650..c7afc7f 100644 --- a/man/SRCGrob.Rd +++ b/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} diff --git a/tests/testthat/data/branching.data.Rda b/tests/testthat/data/branching.data.Rda new file mode 100644 index 0000000..ad26edb Binary files /dev/null and b/tests/testthat/data/branching.data.Rda differ diff --git a/tests/testthat/data/branching.plots.Rda b/tests/testthat/data/branching.plots.Rda new file mode 100644 index 0000000..d10750c Binary files /dev/null and b/tests/testthat/data/branching.plots.Rda differ diff --git a/tests/testthat/data/linear.data.Rda b/tests/testthat/data/linear.data.Rda index 2b33df8..9ced492 100644 Binary files a/tests/testthat/data/linear.data.Rda and b/tests/testthat/data/linear.data.Rda differ diff --git a/tests/testthat/data/linear.plots.Rda b/tests/testthat/data/linear.plots.Rda index 601e04c..44bc67a 100644 Binary files a/tests/testthat/data/linear.plots.Rda and b/tests/testthat/data/linear.plots.Rda differ diff --git a/tests/testthat/helper-compare.R b/tests/testthat/helper-compare.R index 7ba2d20..8162989 100644 --- a/tests/testthat/helper-compare.R +++ b/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 ); } diff --git a/tests/testthat/helper-multitest.R b/tests/testthat/helper-multitest.R index f40ae25..0d2a35e 100644 --- a/tests/testthat/helper-multitest.R +++ b/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', diff --git a/tests/testthat/test-branching.R b/tests/testthat/test-branching.R new file mode 100644 index 0000000..5baf7f0 --- /dev/null +++ b/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)); + } +); diff --git a/tests/testthat/test-prep.tree.R b/tests/testthat/test-prep.tree.R index d77453f..559006a 100644 --- a/tests/testthat/test-prep.tree.R +++ b/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"' + ); + }); diff --git a/vignettes/UserGuide.Rmd b/vignettes/UserGuide.Rmd index 14092f7..0007efa 100644 --- a/vignettes/UserGuide.Rmd +++ b/vignettes/UserGuide.Rmd @@ -94,7 +94,59 @@ branch.lengths.tree <- SRCGrob(branch.lengths); grid.draw(branch.lengths.tree); ``` -### Ex. 3: Showing Cellular Prevalence +### Ex. 3 Styling the Tree + +CEV gives the user control over numerous visual aspects of the tree. By specifying optional columns and values in the tree input data.frame, the user has individual control of edge colour, width, and line type. + +#### Optional Style Columns +| Style | Column | +| --- | --- | +| Node Colour | `node.col` | +| Node Label Colour | `node.label.col` | +| Node Border Colour | `border.col` | +| Node Border Width | `border.width` | +| Node Border Line Type | `border.type` | + +Default values replace missing columns and `NA` values, allowing node-by-node, and edge-by-edge control as needed. For sparsely defined values (for example, only specifying a single edge), it can be convenient to initialize a column with `NA`s, then manually assign specific nodes as needed. + +#### Line Types +Valid values for line type columns are based on lattice's values (with some additions and differences). + +| Line Type | +| --- | +| `NA` | +| `'none'` | +| `'solid'` | +| `'dashed'` | +| `'dotted'` | +| `'dotdash'` | +| `'longdash'` | +| `'twodash'` | + +#### Styled Nodes + +```{r echo=F} +node.style <- tree.input[, c( + 'parent', + 'node.col', 'node.label.col', + 'border.col', 'border.width', 'border.type' + )]; + +knitr::kable( + node.style, + row.names = TRUE + ); +``` + +```{r, fig.show='hide'} +node.style.tree <- SRCGrob(node.style); +``` + +```{r, fig.dim=c(5, 3.5), echo=F} +grid.draw(node.style.tree); +``` + +### Ex. 4: Showing Cellular Prevalence A `cellular.prevalence` column can also be added. These values must range between 0 and 1, and the sum of all child nodes must not be larger than their parent node's value. @@ -119,7 +171,7 @@ grid.draw(CP.tree); This secondary dataframe can be used to specify additional text corresponding to each node. -### Ex. 4: Node Text +### Ex. 5: Node Text Each row must include a node ID for the text. Text will be stacked next to the specified node. @@ -141,7 +193,7 @@ simple.text.tree <- SRCGrob(parent.only, simple.text.data); grid.draw(simple.text.tree); ``` -### Ex. 5: Specifying Colour and Style +### Ex. 6: Specifying Colour and Style - An optional `col` column can be included to specify the colour of each text. - A `fontface` column can be included to bold, italicize, etc. These values correspond to the standard R `fontface` values. - `NA` values in each column will default to `black` and `plain` respectively. @@ -167,7 +219,7 @@ common parameters in `SRCGRob`. ## Plot Size -### Ex. 6: Plot Width with Horizontal Padding +### Ex. 7: Plot Width with Horizontal Padding Some plots require more or less horizontal padding between the x-axes and the tree itself. The `horizontal.padding` parameter scales the default padding proportionally. For example, `horizontal.padding = -0.2` would reduce the padding by 20%. @@ -183,7 +235,7 @@ padding.tree <- SRCGrob( grid.draw(padding.tree); ``` -### Ex. 7: Branch Scaling +### Ex. 8: Branch Scaling Branches are scaled automatically, but users can further scale each branch with the `scale1` and `scale2` parameters. These values scale each branch proportionally, so `scale1 = 1.1` would make the first set of branch lengths 10% longer. @@ -201,7 +253,7 @@ grid.draw(scaled.tree); ``` -### Ex. 8: Plot Title +### Ex. 9: Plot Title The main title of the plot is referred to as `main` in plot parameters. `main` sets the title text, `main.cex` sets the font size, and `main.y` is used to move the main title up if more space is required for the plot. @@ -226,10 +278,10 @@ A y-axis will be added automatically for each branch length column (the left-sided axis corresponding to the first branch length column, and the right with the second length column). -### Ex. 9: Y-Axis +### Ex. 10: Y-Axis Ticks are placed automatically based on the plot size and the branch lengths. -### Ex. 10: Axis Title +### Ex. 11: Axis Title Axis titles are specified with the `yaxis1.label` and `yaxis2.label` parameters. ```{r, fig.show='hide'} @@ -248,7 +300,7 @@ axis.title.tree$vp$x <- unit(0.75, 'npc'); grid.draw(axis.title.tree); ``` -### Ex. 11: Axis Tick Placement +### Ex. 12: Axis Tick Placement The default axis tick positions can be overridden with the `yat` parameter. This expects a list of vectors, each corresponding to the ticks on an x-axis. @@ -270,7 +322,7 @@ yat.tree <- SRCGrob( grid.draw(yat.tree); ``` -### Ex. 12: Normal +### Ex. 13: Normal ```{r, fig.show='hide'} normal.tree <- SRCGrob( parent.only, diff --git a/vignettes/data/input.examples.Rda b/vignettes/data/input.examples.Rda index 6876c10..a2546c1 100644 Binary files a/vignettes/data/input.examples.Rda and b/vignettes/data/input.examples.Rda differ