Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Add methods for generating colors for clone IDs. #172

Open
wants to merge 2 commits into
base: main
Choose a base branch
from
Open

Add methods for generating colors for clone IDs. #172

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
0cedb62
Add methods for generating colors for clone IDs.
aholmes Mar 6, 2025
438447a
Correct errors in clone color methods. Add tests.
aholmes Mar 6, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions DESCRIPTION
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -28,3 +28,4 @@ Suggests:
VignetteBuilder: knitr
LazyLoad: yes
LazyData: yes
RoxygenNote: 7.3.1
81 changes: 81 additions & 0 deletions R/utility.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -62,3 +62,84 @@ get.encoded.distance <- function(points) {

return(encoded.distances);
}

#' Generate a named vector of colors for every clone ID specified.
#'
#' Assigns colors to clones, ensuring a minimum number of colors are used.
#' Any colors specified in `clone.colours` are maintained in the order
#' specified and are used as the first colors for the `clone.ids`.
#'
#' if `clone.colours` is NULL or an empty vector, _and_
#' `minimum.number.of.colours` is 0, `NULL` is returned
#' so BPG's default color selection can be used without needing to
#' check for `NULL`.
#'
#' @param clone.colours A vector of colors assigned to clones. If `NULL`, colors will be generated automatically.
#' @param clone.ids A vector of clone identifiers.
#' @param minimum.number.of.colours An integer specifying the minimum number of colors required.
#'
#' @return A named vector of colors assigned to each clone.
get.clone.colours <- function(clone.colours, clone.ids, minimum.number.of.colours = 0) {
if (is.null(clone.colours) && minimum.number.of.colours == 0) {
return(NULL);
}

if (length(clone.colours) < minimum.number.of.colours) {
clone.colours <- c(
clone.colours,
sample(
colors(),
size = abs(minimum.number.of.colours - length(clone.colours))
)
);
}

if (!is.null(clone.colours) && !is.null(clone.ids)) {
unique.clone.ids <- unique(clone.ids);
sampled.colors <- sample(colors(), size = length(unique.clone.ids));
sampled.colors[seq_along(clone.colours)] <- clone.colours;
return(setNames(
sampled.colors[seq_along(unique.clone.ids)],
unique.clone.ids
));
}

return(NULL);
}

#' Generate a named vector of colors for every clone ID specified,
#' ordered by the clone IDs in `clone.order`.
#'
#' Assigns colors to clones and ensures they follow a specified order.
#' Any colors specified in `clone.colours` are maintained in the order
#' specified and are used as the first colors for the `clone.ids`.
#'
#' if `clone.colours` is NULL or an empty vector, _and_
#' `minimum.number.of.colours` is 0, `NULL` is returned
#' so BPG's default color selection can be used without needing to
#' check for `NULL`.
#'
#' @param clone.colours A vector of colors assigned to clones. If `NULL`, colors will be generated automatically.
#' @param clone.ids A vector of clone identifiers.
#' @param clone.order An optional vector specifying the order of clones. If `NULL`, clone order is not gauranteed.
#' @param minimum.number.of.colours An integer specifying the minimum number of colors required.
#'
#' @return A list containing:
#' \describe{
#' \item{clone.colours}{A named vector of colors assigned to each clone.}
#' \item{clone.order}{The ordered clones.}
#' }
get.clone.colours.in.order <- function(clone.colours, clone.ids, clone.order = NULL, minimum.number.of.colours = 0) {
if (is.null(clone.colours) && is.null(clone.order)) {
clone.ids <- NULL;
}

if (is.null(clone.order) && !is.null(clone.ids)) {
unique.clone.ids <- unique(clone.ids);
clone.order <- c(clone.order, unique.clone.ids[!unique.clone.ids %in% clone.order]);
}

clone.colours <- get.clone.colours(clone.colours, clone.order, minimum.number.of.colours);

return(list(clone.colours = clone.colours, clone.order = clone.order));
}
29 changes: 29 additions & 0 deletions man/get.clone.colours.Rd
View file
Open in desktop

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

41 changes: 41 additions & 0 deletions man/get.clone.colours.in.order.Rd
View file
Open in desktop

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

159 changes: 159 additions & 0 deletions tests/testthat/test-utility.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -76,3 +76,162 @@ test_that(

expect_equal(order(result), expected.order);
});

test_that(
'get.clone.colours returns expected vectors', {
result <- get.clone.colours(NULL, NULL);
expect_null(result);
result <- get.clone.colours(NULL, c('ABC', 'DEF'));
expect_null(result);
result <- get.clone.colours(c('red','green'), NULL);
expect_null(result);
result <- get.clone.colours(c(), c());
expect_null(result);
result <- get.clone.colours(NULL, c());
expect_null(result);
result <- get.clone.colours(c(), NULL);
expect_null(result);
result <- get.clone.colours(c(), c('ABC', 'DEF'));
expect_null(result);
result <- get.clone.colours(c('red', 'green'), c());
expect_null(result);
result <- get.clone.colours(c('red','green'), c('ABC','DEF'));
expect_equal(result, c(ABC = 'red', DEF = 'green'));
result <- get.clone.colours(c('red'), c('ABC','DEF'));
expect_equal(names(result), c('ABC', 'DEF'));
expect_true(result['ABC'] == 'red');
expect_true(!is.na(result['DEF']) && nzchar(result['DEF']));
result <- get.clone.colours(c(NULL,'red'), c('ABC','DEF'));
expect_equal(names(result), c('ABC', 'DEF'));
expect_true(result['ABC'] == 'red');
expect_true(!is.na(result['DEF']) && nzchar(result['DEF']));
result <- get.clone.colours(c('red',NULL), c('ABC','DEF'));
expect_equal(names(result), c('ABC', 'DEF'));
expect_true(result['ABC'] == 'red');
expect_true(!is.na(result['DEF']) && nzchar(result['DEF']));
result <- get.clone.colours(c('red','green'), c('ABC'));
expect_equal(result, c(ABC = 'red'));
result <- get.clone.colours(c('red','green'), c(NULL,'ABC'));
expect_equal(result, c(ABC = 'red'));
result <- get.clone.colours(c('red','green'), c('ABC',NULL));
expect_equal(result, c(ABC = 'red'));
});

test_that(
'get.clone.colours returns expected vectors with minimum colours specified', {
result <- get.clone.colours(NULL, NULL, 3)
expect_null(result);
result <- get.clone.colours(c('red', 'green'), NULL, 3)
expect_null(result);
result <- get.clone.colours(c('red'), NULL, 3)
expect_null(result);
result <- get.clone.colours(c('red', 'green'), c('ABC','DEF'), 3)
expect_equal(result, c(ABC = 'red', DEF = 'green'));
result <- get.clone.colours(c('red'), c('ABC','DEF'), 3)
expect_equal(names(result), c('ABC', 'DEF'));
expect_true(result['ABC'] == 'red');
expect_true(!is.na(result['DEF']) && nzchar(result['DEF']));
result <- get.clone.colours(c('red', 'green'), c('ABC'), 3)
expect_equal(result, c(ABC = 'red'));
});

test_that(
'get.clone.colours.in.order returns expected vectors when order is not specified', {
# get.clone.colours.in.order has same result as get.clone.colours
# with the change that a named list is returned with two members
result <- get.clone.colours.in.order(NULL, NULL)
expect_true(setequal(result, list(clone.colours = NULL, clone.order = NULL)))
result <- get.clone.colours.in.order(NULL, c('ABC', 'DEF'))
expect_true(setequal(result, list(clone.colours = NULL, clone.order = NULL)))
result <- get.clone.colours.in.order(c('red','green'), NULL)
expect_true(setequal(result, list(clone.colours = NULL, clone.order = NULL)))
result <- get.clone.colours.in.order(c(), c())
expect_true(setequal(result, list(clone.colours = NULL, clone.order = NULL)))
result <- get.clone.colours.in.order(NULL, c())
expect_true(setequal(result, list(clone.colours = NULL, clone.order = NULL)))
result <- get.clone.colours.in.order(c(), NULL)
expect_true(setequal(result, list(clone.colours = NULL, clone.order = NULL)))
result <- get.clone.colours.in.order(c(), c('ABC', 'DEF'))
expect_true(setequal(result, list(clone.colours = NULL, clone.order = NULL)))
result <- get.clone.colours.in.order(c('red', 'green'), c())
expect_true(setequal(result, list(clone.colours = NULL, clone.order = NULL)))
result <- get.clone.colours.in.order(c('red','green'), c('ABC','DEF'))
expect_true(setequal(result,list(clone.colours = c(ABC = 'red',DEF = 'green'), clone.order = c('ABC','DEF'))))
result <- get.clone.colours.in.order(c('red'), c('ABC','DEF'))
expect_equal(names(result), c('clone.colours', 'clone.order'))
expect_equal(names(result$clone.colours), c('ABC', 'DEF'))
expect_true(result$clone.colours['ABC'] == 'red')
expect_true(!is.na(result$clone.colours['DEF']) && nzchar(result$clone.colours['DEF']))
expect_equal(result$clone.order, c('ABC','DEF'))

result <- get.clone.colours.in.order(c(NULL,'red'), c('ABC','DEF'))
expect_equal(names(result), c('clone.colours', 'clone.order'))
expect_equal(names(result$clone.colours), c('ABC','DEF'))
expect_true(result$clone.colours['ABC'] == 'red')
expect_true(!is.na(result$clone.colours['DEF']) && nzchar(result$clone.colours['DEF']))
expect_equal(result$clone.order, c('ABC','DEF'))

result <- get.clone.colours.in.order(c('red',NULL), c('ABC','DEF'))
expect_equal(names(result), c('clone.colours', 'clone.order'))
expect_equal(names(result$clone.colours), c('ABC','DEF'))
expect_true(result$clone.colours['ABC'] == 'red')
expect_true(!is.na(result$clone.colours['DEF']) && nzchar(result$clone.colours['DEF']))
expect_equal(result$clone.order, c('ABC','DEF'))

result <- get.clone.colours.in.order(c('red','green'), c('ABC'))
expect_true(setequal(result,list(clone.colours = c(ABC = 'red'), clone.order = c('ABC'))))
result <- get.clone.colours.in.order(c('red','green'), c(NULL,'ABC'))
expect_true(setequal(result,list(clone.colours = c(ABC = 'red'), clone.order = c('ABC'))))
result <- get.clone.colours.in.order(c('red','green'), c('ABC',NULL))
expect_true(setequal(result,list(clone.colours = c(ABC = 'red'), clone.order = c('ABC'))))
});

test_that(
'get.clone.colours.in.order returns expected vectors when order is specified', {
# get.clone.colours.in.order with order specified
result <- get.clone.colours.in.order(NULL, NULL, c('DEF','ABC'))
expect_true(setequal(result, list(clone.colours = NULL, clone.order = c('DEF','ABC'))))
result <- get.clone.colours.in.order(NULL, c('ABC', 'DEF'), c('DEF','ABC'))
expect_true(setequal(result, list(clone.colours = NULL, clone.order = c('DEF','ABC'))))
result <- get.clone.colours.in.order(c('red','green'), NULL)
expect_true(setequal(result, list(clone.colours = NULL, clone.order = NULL)))
result <- get.clone.colours.in.order(c(), c(), c('DEF','ABC'))
expect_true(setequal(result, list(clone.colours = NULL, clone.order = c('DEF','ABC'))))
result <- get.clone.colours.in.order(NULL, c(), c('DEF','ABC'))
expect_true(setequal(result, list(clone.colours = NULL, clone.order = c('DEF','ABC'))))
result <- get.clone.colours.in.order(c(), NULL, c('DEF','ABC'))
expect_true(setequal(result, list(clone.colours = NULL, clone.order = c('DEF','ABC'))))
result <- get.clone.colours.in.order(c(), c('ABC', 'DEF'), c('DEF','ABC'))
expect_true(setequal(result, list(clone.colours = NULL, clone.order = c('DEF','ABC'))))
result <- get.clone.colours.in.order(c('red', 'green'), c(), c('DEF','ABC'))
expect_true(setequal(result, list(clone.colours = c(DEF = 'red',ABC = 'green'), clone.order = c('DEF','ABC'))))
result <- get.clone.colours.in.order(c('red','green'), c('ABC','DEF'), c('DEF','ABC'))
expect_true(setequal(result,list(clone.colours = c(DEF = 'red',ABC = 'green'), clone.order = c('DEF','ABC'))))
result <- get.clone.colours.in.order(c('red'), c('ABC','DEF'), c('DEF','ABC'))
expect_equal(names(result), c('clone.colours', 'clone.order'))
expect_equal(names(result$clone.colours), c('DEF', 'ABC'))
expect_true(result$clone.colours['DEF'] == 'red')
expect_true(!is.na(result$clone.colours['ABC']) && nzchar(result$clone.colours['ABC']))
expect_equal(result$clone.order, c('DEF','ABC'))

result <- get.clone.colours.in.order(c(NULL,'red'), c('ABC','DEF'), c('DEF','ABC'))
expect_equal(names(result), c('clone.colours', 'clone.order'))
expect_equal(names(result$clone.colours), c('DEF','ABC'))
expect_true(result$clone.colours['DEF'] == 'red')
expect_true(!is.na(result$clone.colours['ABC']) && nzchar(result$clone.colours['ABC']))
expect_equal(result$clone.order, c('DEF','ABC'))

result <- get.clone.colours.in.order(c('red',NULL), c('ABC','DEF'), c('DEF','ABC'))
expect_equal(names(result), c('clone.colours', 'clone.order'))
expect_equal(names(result$clone.colours), c('DEF','ABC'))
expect_true(result$clone.colours['DEF'] == 'red')
expect_true(!is.na(result$clone.colours['ABC']) && nzchar(result$clone.colours['ABC']))
expect_equal(result$clone.order, c('DEF','ABC'))

result <- get.clone.colours.in.order(c('red','green'), c('ABC'), c('DEF','ABC'))
expect_true(setequal(result,list(clone.colours = c(DEF = 'red',ABC = 'green'), clone.order = c('DEF','ABC'))))
result <- get.clone.colours.in.order(c('red','green'), c(NULL,'ABC'), c('DEF','ABC'))
expect_true(setequal(result,list(clone.colours = c(DEF = 'red',ABC = 'green'), clone.order = c('DEF','ABC'))))
result <- get.clone.colours.in.order(c('red','green'), c('ABC',NULL), c('DEF','ABC'))
expect_true(setequal(result,list(clone.colours = c(DEF = 'red',ABC = 'green'), clone.order = c('DEF','ABC'))))
});