Root node prep

NEWS

@@ -2,6 +2,7 @@ CancerEvolutionVisualization 1.0.0 2022-09-01 (Dan Knight)
 
 ADDED
 * Documentation for default colour scheme
+* Checks for valid tree structure (root node)
 
 UPDATE
 * Fixed discrepancies between documentation and code

R/prep.tree.R

@@ -9,6 +9,9 @@ prep.tree <- function(
         stop('No parent column provided');
         }
 
+    # Error on invalid tree structure
+    get.root.node(tree.df);
+
     if ('angle' %in% colnames(tree.df)) {
         message(paste(
             'Overriding branch angles will be supported in a future version.',
@@ -143,6 +146,19 @@ check.parent.values <- function(node.names, parent.col) {
         ));
     }
 
+get.root.node <- function(tree) {
+    valid.values <- as.character(c(-1, 0));
+    candidates <- which(is.na(tree$parent) | tree$parent %in% valid.values);
+
+    if (length(candidates) > 1) {
+        stop('More than one root node detected.');
+    } else if (length(candidates) == 0) {
+        stop('No root node provided.');
+        }
+
+    return(candidates);
+    }
+
 get.y.axis.position <- function(tree.colnames) {
     num.branch.length.cols <- length(get.branch.length.colnames(tree.colnames));
 

tests/testthat/test-prep.tree.R

@@ -206,6 +206,54 @@ test_that(
         expect_true(check.parent.values(node.names, parents));
     });
 
+test_that(
+    'get.root.node handles valid NA root', {
+        parent <- c(2, NA, 1);
+        expected.root <- which(is.na(parent));
+
+        tree <- data.frame(parent = parent);
+        root <- get.root.node(tree);
+
+        expect_equal(root, expected.root);
+    });
+
+test_that(
+    'get.root.node handles valid -1 root', {
+        parent <- c(2, -1, 1);
+        expected.root <- which(parent == -1);
+
+        tree <- data.frame(parent = parent);
+        root <- get.root.node(tree);
+
+        expect_equal(root, expected.root);
+    });
+
+test_that(
+    'get.root.node handles valid 0 root', {
+        parent <- c(2, 0, 1);
+        expected.root <- which(parent == 0);
+
+        tree <- data.frame(parent = parent);
+        root <- get.root.node(tree);
+
+        expect_equal(root, expected.root);
+    });
+
+test_that(
+    'get.root.node handles multiple root nodes', {
+        root.parent <- -1;
+        tree <- data.frame(parent = rep(root.parent, 2));
+
+        expect_error(get.root.node(tree), regexp = 'root')
+    });
+
+test_that(
+    'get.root.node handles a missing root node', {
+        tree <- data.frame(parent = 1:3);
+
+        expect_error(get.root.node(tree), regexp = 'root');
+    });
+
 test_that(
     'get.y.axis.position handles a single branch length column', {
         valid.colname <- 'length1';