diff --git a/DESCRIPTION b/DESCRIPTION index ab9d683..552bb03 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -28,3 +28,4 @@ Suggests: VignetteBuilder: knitr LazyLoad: yes LazyData: yes +RoxygenNote: 7.3.1 diff --git a/R/get.colours.R b/R/get.colours.R index 007d3ff..ec2a873 100644 --- a/R/get.colours.R +++ b/R/get.colours.R @@ -1,15 +1,24 @@ get.colours <- function( value.list, - return.names = FALSE + return.names = FALSE, + predetermined.colours = NULL ) { colours <- grDevices::colors()[grep('(white|gr(a|e)y)', grDevices::colors(), invert = T)]; - n <- length(unique(value.list)); + unique.values <- unique(value.list); + n <- length(unique.values); col.list <- sample(colours, n); + + if (!is.null(predetermined.colours) && !is.null(value.list)) { + col.list[seq_along(predetermined.colours)] <- predetermined.colours; + } + if (is.null(levels(value.list))) { - value.list <- factor(value.list, levels = unique(value.list)) + value.list <- factor(value.list, levels = unique.values); } + names(col.list) <- levels(value.list); + if (return.names) { return(col.list); } else { @@ -17,6 +26,53 @@ get.colours <- function( } } +#' Generate a named vector of colors for every value specified, +#' ordered by the value in `value.order`. +#' +#' Assigns colors to values and ensures they follow a specified order. +#' Any colors specified in `predetermined.colours` are maintained in the order +#' specified and are used as the first colors for the `value.list`. +#' +#' @param value.list A vector of values. +#' @param value.order An optional vector specifying the order of values. If `NULL`, value order is not gauranteed. +#' @param predetermined.colours A vector of colors assigned to values. If `NULL`, colors will be generated automatically. +#' +#' @return A list containing: +#' \describe{ +#' \item{colours}{A named vector of colors assigned to each value.} +#' \item{value.order}{The ordered values.} +#' } +get.colours.in.order <- function( + value.list, + value.order = NULL, + predetermined.colours = NULL + ) { + + if (is.null(predetermined.colours) && is.null(value.order)) { + value.list <- NULL; + } + + if (is.null(value.order) && !is.null(value.list)) { + value.order <- unique(value.list); + } + + if (is.null(predetermined.colours) || is.null(value.order)) { + predetermined.colours <- NULL; + } else { + sampled.colours <- get.colours(value.list); + sampled.colours[seq_along(predetermined.colours)] <- predetermined.colours; + predetermined.colours <- setNames( + sampled.colours[seq_along(value.order)], + value.order + ); + } + + return(list( + colours = predetermined.colours, + value.order = value.order + )); + } + get.colour.luminance <- function(colour) { # Formulas and values documented in: # https://www.w3.org/WAI/GL/wiki/Relative_luminance diff --git a/tests/testthat/test-get.colours.R b/tests/testthat/test-get.colours.R new file mode 100644 index 0000000..237aae7 --- /dev/null +++ b/tests/testthat/test-get.colours.R @@ -0,0 +1,225 @@ +expect.character.vector <- function(result) { + expect_true(identical(names(result), character(0))); + expect_true(identical(result, setNames(character(0), character(0)))); + expect_equal(length(result), 0); + } + +test_that('get.colours returns a color for each vector element', { + value.list <- c('ABC', 'DEF', 'DEF', 'GHI'); + colors <- get.colours(value.list); + expect_equal(names(colors), c('ABC', 'DEF', 'DEF', 'GHI')); + expect_equal(length(colors), 4); + for (i in seq_along(colors)) { + color.value <- colors[i]; + expect_true(!is.na(color.value) && nzchar(color.value)); + } + }); + +test_that('get.colours returns a color for each vector element when return.names is FALSE', { + value.list <- c('ABC', 'DEF', 'DEF', 'GHI'); + colors <- get.colours(value.list, FALSE); + expect_equal(names(colors), c('ABC', 'DEF', 'DEF', 'GHI')); + expect_equal(length(colors), 4); + for (i in seq_along(colors)) { + color.value <- colors[i]; + expect_true(!is.na(color.value) && nzchar(color.value)); + } + }); + +test_that('get.colours returns a color for unique vector elements when return.names is TRUE', { + value.list <- c('ABC', 'DEF', 'DEF', 'GHI'); + colors <- get.colours(value.list, TRUE); + expect_equal(names(colors), c('ABC', 'DEF', 'GHI')); + expect_equal(length(colors), 3); + unique.colors <- unique(names(colors)); + for (key in unique.colors) { + expect_true(!is.na(colors[key]) && nzchar(colors[key])); + } + }); + +test_that('get.colours returns an empty color vector when value.list is empty', { + value.list <- c(); + colors <- get.colours(value.list); + expect_true(identical(names(colors), character(0))); + expect_true(identical(colors, setNames(character(0), character(0)))); + expect_equal(length(colors), 0); + }); + +test_that('get.colours returns an empty color vector when value.list is empty and return.names is FALSE', { + value.list <- c(); + colors <- get.colours(value.list, FALSE); + expect_true(identical(names(colors), character(0))); + expect_true(identical(colors, setNames(character(0), character(0)))); + expect_equal(length(colors), 0); + }); + +test_that('get.colours returns an empty color vector when value.list is empty and return.names is TRUE', { + value.list <- c(); + colors <- get.colours(value.list, TRUE); + expect_true(identical(names(colors), character(0))); + expect_true(identical(colors, setNames(character(0), character(0)))); + expect_equal(length(colors), 0); + }); + +test_that( + 'get.colours returns expected vectors', { + result <- get.colours(NULL, predetermined.colours = NULL); + expect.character.vector(result); + result <- get.colours(c('ABC', 'DEF'), predetermined.colours = NULL); + expect_equal(names(result), c('ABC', 'DEF')); + expect_true(!is.na(result['ABC']) && nzchar(result['ABC'])); + expect_true(!is.na(result['DEF']) && nzchar(result['DEF'])); + result <- get.colours(NULL, predetermined.colours = c('red','green')); + expect.character.vector(result); + result <- get.colours(c(), predetermined.colours = c()); + expect.character.vector(result); + result <- get.colours(NULL, predetermined.colours = c()); + expect.character.vector(result); + result <- get.colours(c(), predetermined.colours = NULL); + expect.character.vector(result); + result <- get.colours(c('ABC', 'DEF'), predetermined.colours = c()) + expect_equal(names(result), c('ABC', 'DEF')); + expect_true(!is.na(result['ABC']) && nzchar(result['ABC'])); + expect_true(!is.na(result['DEF']) && nzchar(result['DEF'])); + result <- get.colours(c(), predetermined.colours = c('red', 'green')); + expect.character.vector(result); + result <- get.colours(c('ABC','DEF'), predetermined.colours = c('red','green')); + expect_equal(result, c(ABC = 'red', DEF = 'green')); + result <- get.colours(c('ABC','DEF'), predetermined.colours = c('red')); + expect_equal(names(result), c('ABC', 'DEF')); + expect_true(result['ABC'] == 'red'); + expect_true(!is.na(result['DEF']) && nzchar(result['DEF'])); + result <- get.colours(c('ABC','DEF'), predetermined.colours = c(NULL,'red')); + expect_equal(names(result), c('ABC', 'DEF')); + expect_true(result['ABC'] == 'red'); + expect_true(!is.na(result['DEF']) && nzchar(result['DEF'])); + result <- get.colours(c('ABC','DEF'), predetermined.colours = c('red',NULL)); + expect_equal(names(result), c('ABC', 'DEF')); + expect_true(result['ABC'] == 'red'); + expect_true(!is.na(result['DEF']) && nzchar(result['DEF'])); + result <- get.colours(c('ABC'), predetermined.colours = c('red','green')); + expect_equal(result, c(ABC = 'red')); + result <- get.colours(c(NULL,'ABC'), predetermined.colours = c('red','green')); + expect_equal(result, c(ABC = 'red')); + result <- get.colours(c('ABC',NULL), predetermined.colours = c('red','green')); + expect_equal(result, c(ABC = 'red')); + }); + +test_that( + 'get.colours returns expected vectors with minimum colours specified', { + result <- get.colours(NULL, predetermined.colours = NULL) + expect.character.vector(result); + result <- get.colours(NULL, predetermined.colours = c('red', 'green')) + expect.character.vector(result); + result <- get.colours(NULL, predetermined.colours = c('red')) + expect.character.vector(result); + result <- get.colours(c('ABC','DEF'), predetermined.colours = c('red', 'green')) + expect_equal(result, c(ABC = 'red', DEF = 'green')); + result <- get.colours(c('ABC','DEF'), predetermined.colours = c('red')) + expect_equal(names(result), c('ABC', 'DEF')); + expect_true(result['ABC'] == 'red'); + expect_true(!is.na(result['DEF']) && nzchar(result['DEF'])); + result <- get.colours(c('ABC'), predetermined.colours = c('red', 'green')) + expect_equal(result, c(ABC = 'red')); + }); + +test_that( + 'get.colours.in.order returns expected vectors when order is not specified', { + # get.colours.in.order has same result as get.colours + # with the change that a named list is returned with two members + result <- get.colours.in.order(NULL, predetermined.colours = NULL) + expect_true(setequal(result, list(predetermined.colours = NULL, value.order = NULL))) + result <- get.colours.in.order(c('ABC', 'DEF'), predetermined.colours = NULL) + expect_true(setequal(result, list(predetermined.colours = NULL, value.order = NULL))) + result <- get.colours.in.order(NULL, predetermined.colours = c('red','green')) + expect_true(setequal(result, list(predetermined.colours = NULL, value.order = NULL))) + result <- get.colours.in.order(c(), predetermined.colours = c()) + expect_true(setequal(result, list(predetermined.colours = NULL, value.order = NULL))) + result <- get.colours.in.order(c(), predetermined.colours = NULL) + expect_true(setequal(result, list(predetermined.colours = NULL, value.order = NULL))) + result <- get.colours.in.order(NULL, predetermined.colours = c()) + expect_true(setequal(result, list(predetermined.colours = NULL, value.order = NULL))) + result <- get.colours.in.order(c('ABC', 'DEF'), predetermined.colours = c()) + expect_true(setequal(result, list(predetermined.colours = NULL, value.order = NULL))) + result <- get.colours.in.order(c(), predetermined.colours = c('red', 'green')) + expect_true(setequal(result, list(predetermined.colours = NULL, value.order = NULL))) + result <- get.colours.in.order(c('ABC','DEF'), predetermined.colours = c('red','green')) + expect_true(setequal(result,list(predetermined.colours = c(ABC = 'red',DEF = 'green'), value.order = c('ABC','DEF')))) + result <- get.colours.in.order(c('ABC','DEF'), predetermined.colours = c('red')) + expect_equal(names(result), c('colours', 'value.order')) + expect_equal(names(result$colours), c('ABC', 'DEF')) + expect_true(result$colours['ABC'] == 'red') + expect_true(!is.na(result$colours['DEF']) && nzchar(result$colours['DEF'])) + expect_equal(result$value.order, c('ABC','DEF')) + + result <- get.colours.in.order(c('ABC','DEF'), predetermined.colours = c(NULL,'red')) + expect_equal(names(result), c('colours', 'value.order')) + expect_equal(names(result$colours), c('ABC','DEF')) + expect_true(result$colours['ABC'] == 'red') + expect_true(!is.na(result$colours['DEF']) && nzchar(result$colours['DEF'])) + expect_equal(result$value.order, c('ABC','DEF')) + + result <- get.colours.in.order(c('ABC','DEF'), predetermined.colours = c('red',NULL)) + expect_equal(names(result), c('colours', 'value.order')) + expect_equal(names(result$colours), c('ABC','DEF')) + expect_true(result$colours['ABC'] == 'red') + expect_true(!is.na(result$colours['DEF']) && nzchar(result$colours['DEF'])) + expect_equal(result$value.order, c('ABC','DEF')) + + result <- get.colours.in.order(c('ABC'), predetermined.colours = c('red','green')) + expect_true(setequal(result,list(predetermined.colours = c(ABC = 'red'), value.order = c('ABC')))) + result <- get.colours.in.order(c(NULL,'ABC'), predetermined.colours = c('red','green')) + expect_true(setequal(result,list(predetermined.colours = c(ABC = 'red'), value.order = c('ABC')))) + result <- get.colours.in.order(c('ABC',NULL), predetermined.colours = c('red','green')) + expect_true(setequal(result,list(predetermined.colours = c(ABC = 'red'), value.order = c('ABC')))) + }); + +test_that( + 'get.colours.in.order returns expected vectors when order is specified', { + # get.colours.in.order with order specified + result <- get.colours.in.order(NULL, c('DEF','ABC'), NULL) + expect_true(setequal(result, list(predetermined.colours = NULL, value.order = c('DEF','ABC')))) + result <- get.colours.in.order(c('ABC', 'DEF'), c('DEF','ABC'), NULL) + expect_true(setequal(result, list(predetermined.colours = NULL, value.order = c('DEF','ABC')))) + result <- get.colours.in.order(NULL, predetermined.colours = c('red','green')) + expect_true(setequal(result, list(predetermined.colours = NULL, value.order = NULL))) + result <- get.colours.in.order(c(), c('DEF', 'ABC'), c()) + expect_true(setequal(result, list(predetermined.colours = NULL, value.order = c('DEF','ABC')))) + result <- get.colours.in.order(c(), c('DEF','ABC'), NULL) + expect_true(setequal(result, list(predetermined.colours = NULL, value.order = c('DEF','ABC')))) + result <- get.colours.in.order(NULL, c('DEF', 'ABC'), c()) + expect_true(setequal(result, list(predetermined.colours = NULL, value.order = c('DEF','ABC')))) + result <- get.colours.in.order(c('ABC', 'DEF'), c('DEF', 'ABC'), c()) + expect_true(setequal(result, list(predetermined.colours = NULL, value.order = c('DEF','ABC')))) + result <- get.colours.in.order(c(), c('DEF','ABC'), c('red', 'green')) + expect_true(setequal(result, list(predetermined.colours = c(DEF = 'red',ABC = 'green'), value.order = c('DEF','ABC')))) + result <- get.colours.in.order(c('ABC','DEF'), c('DEF','ABC'), c('red','green')) + expect_true(setequal(result,list(predetermined.colours = c(DEF = 'red',ABC = 'green'), value.order = c('DEF','ABC')))) + result <- get.colours.in.order(c('ABC','DEF'), c('DEF','ABC'), c('red')) + expect_equal(names(result), c('colours', 'value.order')) + expect_equal(names(result$colours), c('DEF', 'ABC')) + expect_true(result$colours['DEF'] == 'red') + expect_true(!is.na(result$colours['ABC']) && nzchar(result$colours['ABC'])) + expect_equal(result$value.order, c('DEF','ABC')) + + result <- get.colours.in.order(c('ABC','DEF'), c('DEF','ABC'), c(NULL,'red')) + expect_equal(names(result), c('colours', 'value.order')) + expect_equal(names(result$colours), c('DEF','ABC')) + expect_true(result$colours['DEF'] == 'red') + expect_true(!is.na(result$colours['ABC']) && nzchar(result$colours['ABC'])) + expect_equal(result$value.order, c('DEF','ABC')) + + result <- get.colours.in.order(c('ABC','DEF'), c('DEF','ABC'), c('red',NULL)) + expect_equal(names(result), c('colours', 'value.order')) + expect_equal(names(result$colours), c('DEF','ABC')) + expect_true(result$colours['DEF'] == 'red') + expect_true(!is.na(result$colours['ABC']) && nzchar(result$colours['ABC'])) + expect_equal(result$value.order, c('DEF','ABC')) + + result <- get.colours.in.order(c('ABC'), c('DEF','ABC'), c('red','green')) + expect_true(setequal(result,list(predetermined.colours = c(DEF = 'red',ABC = 'green'), value.order = c('DEF','ABC')))) + result <- get.colours.in.order(c(NULL,'ABC'), c('DEF','ABC'), c('red','green')) + expect_true(setequal(result,list(predetermined.colours = c(DEF = 'red',ABC = 'green'), value.order = c('DEF','ABC')))) + result <- get.colours.in.order(c('ABC',NULL), c('DEF','ABC'), c('red','green')) + expect_true(setequal(result,list(predetermined.colours = c(DEF = 'red',ABC = 'green'), value.order = c('DEF','ABC')))) + });