diff --git a/R/fuzz.R b/R/fuzz.R new file mode 100644 index 0000000..6aedfb2 --- /dev/null +++ b/R/fuzz.R @@ -0,0 +1,324 @@ +randomize.tree <- function( + tree.df, + randomize.angles = TRUE, + randomize.node.color = TRUE, + randomize.border.color = TRUE, + randomize.border.width = TRUE, + randomize.border.type = TRUE, + randomize.edge.col = TRUE, + randomize.edge.width = TRUE, + randomize.edge.type = TRUE, + randomize.edge.length = TRUE, + randomize.plotting.direction = TRUE, + plotting.direction = NULL, + ... + ) { + node.ids <- c(get.root.node(tree.df)); + + default.line.type <- 'solid'; + line.types <- c(default.line.type, 'dotted', 'dashed'); + + if (check.randomization.value(randomize.angles, randomization.name = 'randomize.angles')) { + spread.randomization.sd <- if (is.numeric(randomize.angles)) { + if (randomize.angles <= 0) { + stop('"randomize.angles" standard deviation value must be positive.'); + } + randomize.angles; + } else { + 0.5; + } + default.spread <- 1; + if (!('spread' %in% colnames(tree.df))) { + tree.df$spread <- default.spread; + } else { + tree.df[is.na(tree.df$spread), 'spread'] <- 1; + } + tree.df$spread <- tree.df$spread + rnorm( + mean = 0, + sd = spread.randomization.sd, + n = nrow(tree.df) + ); + tree.df[tree.df$spread < 0, 'spread'] <- 0; + } + + if (check.randomization.value(randomize.plotting.direction, randomization.name = 'plotting.direction')) { + if (is.null(plotting.direction)) { + plotting.direction <- sample(c('down', 'right', 'left', 'up'), size = 1); + } + plotting.direction <- radians.to.degrees( + prep.plotting.direction(plotting.direction, radians = FALSE) + ); + angle.randomization.sd <- if (is.numeric(randomize.plotting.direction)) { + if (randomize.plotting.direction <= 0) { + stop('"randomize.plotting.direction" standard deviation value must be positive.'); + } + randomize.plotting.direction; + } else { + 30; + }; + plotting.direction <- plotting.direction + rnorm(sd = angle.randomization.sd, n = 1); + } + + if (check.randomization.value(randomize.node.color, randomization.name = 'randomize.node.color')) { + node.color.randomization.prob <- if (is.numeric(randomize.node.color)) { + if (randomize.node.color < 0 || randomize.node.color > 1) { + stop('"randomize.node.color" probability must be between 0 and 1.') + } + randomize.node.color; + } else { + 0.5; + } + node.color.scheme <- if (runif(1) <= node.color.randomization.prob) { + generate.random.color(); + } else { + NA; + } + + if (!('node.col' %in% colnames(tree.df))) { + tree.df$node.col <- node.color.scheme; + } else { + tree.df[is.na(tree.df$node.col), 'node.col'] <- node.color.scheme; + } + override.node.col.i <- sapply( + 1:nrow(tree.df), + function(i) runif(1) <= node.color.randomization.prob + ); + tree.df[override.node.col.i, 'node.col'] <- sapply( + 1:sum(override.node.col.i), + function(i) generate.random.color() + ); + } + + if (check.randomization.value(randomize.border.color, randomization.name = 'randomize.border.color')) { + border.color.randomization.prob <- if (is.numeric(randomize.border.color)) { + if (randomize.border.color < 0 || randomize.border.color > 1) { + stop('"randomize.border.color" probability must be between 0 and 1.') + } + randomize.border.color; + } else { + 0.3; + } + border.color.scheme <- if (runif(1) <= border.color.randomization.prob) { + generate.random.color(); + } else { + NA; + } + + if (!('border.col' %in% colnames(tree.df))) { + tree.df$border.col <- border.color.scheme; + } else { + tree.df[is.na(tree.df$border.col), 'border.col'] <- node.color.scheme; + } + override.border.col.i <- sapply( + 1:nrow(tree.df), + function(i) runif(1) <= border.color.randomization.prob + ); + tree.df[override.border.col.i, 'border.col'] <- sapply( + 1:sum(override.border.col.i), + function(i) generate.random.color() + ); + } + + if (check.randomization.value(randomize.border.width, randomization.name = 'randomize.border.width')) { + border.width.randomization.sd <- if (is.numeric(randomize.border.width)) { + if (randomize.border.width <= 0) { + stop('"randomize.border.width" standard deviation value must be positive.'); + } + randomize.border.width; + } else { + 1; + }; + default.border.width <- 1; + + if (!('border.width' %in% colnames(tree.df))) { + tree.df$border.width <- default.border.width; + } else { + tree.df[is.na(tree.df$border.width), 'border.width'] <- default.border.width; + } + tree.df[, 'border.width'] <- tree.df$border.width + rnorm( + mean = 0, + sd = border.width.randomization.sd, + n = nrow(tree.df) + ); + tree.df[tree.df$border.width <= 0, 'border.width'] <- 0; + } + + if (check.randomization.value(randomize.border.type, randomization.name = 'randomize.border.type')) { + default.border.type <- sample(line.types, size = 1); + + border.type.randomization.prob <- if (is.numeric(randomize.border.type)) { + if (randomize.border.type < 0 || randomize.border.type > 1) { + stop('"randomize.border.type" probability must be between 0 and 1.') + } + randomize.border.type; + } else { + 0.3; + } + + if (!('border.type' %in% colnames(tree.df))) { + tree.df$border.type <- default.border.type; + } else { + tree.df[is.na(tree.df$border.type), 'border.type'] <- default.border.type; + } + override.border.type.i <- runif(nrow(tree.df)) <= border.type.randomization.prob; + tree.df[override.border.type.i, 'border.type'] <- sample( + line.types, + size = sum(override.border.type.i), + replace = TRUE + ); + } + + edge.names <- sort(get.branch.names(tree.df)); + if (length(edge.names) < 1) { + edge.names <- 1; + } + + edge.color.randomization.prob <- 0; + if (check.randomization.value(randomize.edge.col, randomization.name = 'randomize.edge.col')) { + edge.color.randomization.prob <- if (is.numeric(randomize.edge.col)) { + if (randomize.edge.col < 0 || randomize.edge.col > 1) { + stop('"randomize.edge.col" probability must be between 0 and 1.') + } + randomize.edge.col; + } else { + 0.3; + } + } + + if (check.randomization.value(randomize.edge.width, randomization.name = 'randomize.edge.width')) { + edge.width.randomization.sd <- if (is.numeric(randomize.edge.width)) { + if (randomize.edge.width <= 0) { + stop('"randomize.edge.width" standard deviation value must be positive.'); + } + randomize.edge.width; + } else { + 1; + }; + } + + edge.type.randomization.prob <- 0; + if (check.randomization.value(randomize.edge.type, randomization.name = 'randomize.edge.type')) { + edge.type.randomization.prob <- if (is.numeric(randomize.edge.type)) { + if (randomize.edge.type < 0 || randomize.edge.type > 1) { + stop('"randomize.edge.type" probability must be between 0 and 1.') + } + randomize.edge.type; + } else { + 0.3; + } + } + + for (edge.name in edge.names) { + if (check.randomization.value(randomize.edge.col)) { + edge.color.scheme <- generate.random.color(); + + edge.col.column.name <- paste('edge.col', edge.name, sep = '.'); + if (!(edge.col.column.name %in% colnames(tree.df))) { + tree.df[, edge.col.column.name] <- edge.color.scheme; + } else { + tree.df[is.na(tree.df[, edge.col.column.name]), edge.col.column.name] <- edge.color.scheme; + } + override.edge.col.i <- runif(n = nrow(tree.df), max = 1) <= edge.color.randomization.prob; + tree.df[override.edge.col.i, edge.col.column.name] <- sapply( + 1:sum(override.edge.col.i), + function(i) generate.random.color() + ); + } + + if (check.randomization.value(randomize.edge.width)) { + base.edge.width.randomization.prob <- 0.5; + default.edge.width <- if (runif(1) <= base.edge.width.randomization.prob) { + max(0, rnorm(1, mean = 3)); + } else { + 3; + } + + edge.width.column.name <- paste('edge.width', edge.name, sep = '.'); + if (!(edge.width.column.name %in% colnames(tree.df))) { + tree.df[, edge.width.column.name] <- default.edge.width; + } else { + tree.df[is.na(tree.df[, edge.width.column.name]), edge.col.column.name] <- default.edge.width; + } + tree.df[, edge.width.column.name] <- tree.df[, edge.width.column.name] + rnorm( + sd = edge.width.randomization.sd, + n = nrow(tree.df) + ); + tree.df[, edge.width.column.name] <- sapply( + tree.df[, edge.width.column.name], + function(x) max(0, x) + ); + } + + if (check.randomization.value(randomize.edge.type)) { + default.edge.type <- sample(line.types, size = 1); + + edge.type.column.name <- paste('edge.type', edge.name, sep = '.'); + if (!(edge.type.column.name %in% colnames(tree.df))) { + tree.df[, edge.type.column.name] <- default.edge.type; + } else { + tree.df[is.na(tree.df[, edge.type.column.name]), edge.col.column.name] <- default.edge.type; + } + override.edge.type.i <- runif(n = nrow(tree.df), max = 1) <= edge.type.randomization.prob; + tree.df[override.edge.type.i, edge.type.column.name] <- sample( + line.types, + size = sum(override.edge.type.i), + replace = TRUE + ); + } + + if (check.randomization.value(randomize.edge.length, randomization.name = 'randomize.edge.length')) { + edge.length.column.name <- paste('length', edge.name, sep = '.'); + base.edge.length <- 10 ** runif(n = 1, min = 0, max = 6); + + edge.length.randomization.proportion <- if (is.numeric(randomize.edge.length)) { + if (randomize.edge.length <= 0) { + stop('"randomize.edge.length" proportion must be positive.'); + } + randomize.edge.length; + } else { + 0.2; + } + + if (!(edge.length.column.name %in% colnames(tree.df))) { + tree.df[, edge.length.column.name] <- base.edge.length; + } else { + tree.df[is.na(tree.df[, edge.length.column.name]), edge.length.column.name] <- base.edge.length; + } + edge.length.randomization.sd <- median(tree.df[, edge.length.column.name]) * edge.length.randomization.proportion; + tree.df[, edge.length.column.name] <- tree.df[, edge.length.column.name] + rnorm( + sd = edge.length.randomization.sd, + n = nrow(tree.df) + ); + tree.df[tree.df[, edge.length.column.name] < 0, edge.length.column.name] + } + } + + result <- create.phylogenetic.tree( + tree.df, + plotting.direction = plotting.direction, + ... + ); + return(result); + } + +check.randomization.value <- function( + randomization, + randomization.name = NULL + ) { + if (is.null(randomization.name)) { + randomization.name <- 'Randomization value'; + } + if (length(randomization) != 1) { + stop(paste(randomization.name, 'must be length 1.')); + } + + randomize.result <- FALSE; + if (is.numeric(randomization)) { + randomize.result <- TRUE; + } else if (is.logical(randomization)) { + randomize.result <- randomization; + } else { + stop(paste(randomization.name, 'must be numeric or TRUE/FALSE.')); + } + return(randomize.result); + } diff --git a/R/utility.R b/R/utility.R index 695d290..f9708db 100644 --- a/R/utility.R +++ b/R/utility.R @@ -34,6 +34,10 @@ degrees.to.radians <- function(degrees) { return(degrees * pi / 180); } +radians.to.degrees <- function(radians) { + return(radians * 180 / pi); + } + get.encoded.distance <- function(points) { if (!is.data.frame(points)) { stop(paste( @@ -63,6 +67,9 @@ get.encoded.distance <- function(points) { return(encoded.distances); } +generate.random.color <- function() { + rgb(runif(1), runif(1), runif(1)); + } oxford.comma.vector.concat <- function(vec, empty.value = '', flatten.empty.value = TRUE) { if (length(vec) == 0) { diff --git a/tests/testthat/test-fuzz.R b/tests/testthat/test-fuzz.R new file mode 100644 index 0000000..a1ddc87 --- /dev/null +++ b/tests/testthat/test-fuzz.R @@ -0,0 +1,120 @@ +test_that( + 'randomize.tree errors on invalid angle randomization type', { + expect_error( + randomize.tree( + data.frame(parent = c(NA, 1)), + randomize.angle = 'test' + ), + regexp = 'randomize.angle' + ); + } + ); + +test_that( + 'randomize.tree errors on invalid plotting direction randomization type', { + expect_error( + randomize.tree( + data.frame(parent = c(NA, 1)), + randomize.plotting.direction = 'test' + ), + regexp = 'plotting.direction' + ); + } + ); + +test_that( + 'randomize.tree errors on invalid node color randomization type', { + expect_error( + randomize.tree( + data.frame(parent = c(NA, 1)), + randomize.node.color = 'test' + ), + regexp = 'randomize.node.color' + ); + } + ); + +test_that( + 'randomize.tree errors on invalid border color randomization type', { + expect_error( + randomize.tree( + data.frame(parent = c(NA, 1)), + randomize.border.color = 'test' + ), + regexp = 'randomize.border.color' + ); + } + ); + +test_that( + 'randomize.tree errors on invalid border width randomization type', { + expect_error( + randomize.tree( + data.frame(parent = c(NA, 1)), + randomize.border.width = 'test' + ), + regexp = 'randomize.border.width' + ); + } + ); + +test_that( + 'randomize.tree errors on invalid border type randomization type', { + expect_error( + randomize.tree( + data.frame(parent = c(NA, 1)), + randomize.border.type = 'test' + ), + regexp = 'randomize.border.type' + ); + } + ); + +test_that( + 'randomize.tree errors on invalid edge color randomization type', { + expect_error( + randomize.tree( + data.frame(parent = c(NA, 1)), + randomize.edge.col = 'test' + ), + regexp = 'randomize.edge.col' + ); + } + ); + +test_that( + 'randomize.tree errors on invalid edge width randomization type', { + expect_error( + randomize.tree( + data.frame(parent = c(NA, 1)), + randomize.edge.width = 'test' + ), + regexp = 'randomize.edge.width' + ); + } + ); + + +test_that( + 'randomize.tree errors on invalid edge length randomization type', { + expect_error( + randomize.tree( + data.frame(parent = c(NA, 1)), + randomize.edge.length = 'test' + ), + regexp = 'randomize.edge.length' + ); + } + ); + +test_that( + 'randomize.tree errors on invalid edge type randomization type', { + expect_error( + randomize.tree( + data.frame(parent = c(NA, 1)), + randomize.edge.type = 'test' + ), + regexp = 'randomize.edge.type' + ); + } + );