Clean up apply_node_color.R, extract color-related code.

* Add `get_color_variants()`, `get_palette()`, and `get_colors()` functions

Signed-off-by: Tao Wang <twang2218@gmail.com>

Author: twang2218

R/apply_node_color.R

@@ -10,46 +10,19 @@
 #' @importFrom grDevices    col2rgb
 #' @importFrom grDevices    rgb
 apply_node_color <- function(p) {
-  # define material design palette base colors
-  material_colors <- c(
-    "blue",         "red",          "green",        "yellow",   "brown",
-    "indigo",       "pink",         "teal",         "amber",    "orange",
-    "purple",       "deep-orange",  "light-green",  "lime",     "grey",
-    "deep-purple",  "cyan",         "blue-grey",    "light-blue"
-  )
-
   # Make `R CMD check` happy
   type <- NULL
 
   types <- get_node_df(p) %>%
     distinct(type) %>%
     arrange(type)
 
-  types <- types$"type"
+  types <- types$type
 
-  # print(paste(types, ":", material_colors[1:length(types)]))
-  pal <- lapply(
-    sapply(
-      sapply(
-        material_colors[1:length(types)],
-        pal_material,
-        reverse = TRUE
-      ),
-      function(x) { x(1) }
-    ),
-    function(name, alpha = 1) {
-      color <- col2rgb(name, alpha = TRUE) / 255
-      arg <- split(color, rownames(color))
-      arg$alpha <- alpha
-      do.call(rgb, arg)
-    },
-    # Get 3 transparency level for the given color
-    c(0.3, 0.5, 1)
-  )
-  names(pal) <- types
+  colors <- get_colors(types)
 
   for (t in types) {
-    color <- pal[[t]]
+    color <- colors[[t]]
     p <- select_nodes(p, conditions = type == t)
     if (!any(is.na(get_selection(p)))) {
       # print(paste("type:", t))
@@ -62,4 +35,4 @@ apply_node_color <- function(p) {
   }
 
   return(p)
-}
+}

R/utils.R

@@ -10,3 +10,53 @@ projection <- function(x, min = 0, max = 1) {
 
   ((x - x_min)/(x_max - x_min)) * (max - min) + min
 }
+
+#' @importFrom grDevices    col2rgb
+#' @importFrom grDevices    rgb
+get_color_variants <- function(name) {
+  color <- col2rgb(name, alpha = TRUE) / 255
+  arg <- split(color, rownames(color))
+
+  alphas <- c(0.3, 0.5, 1)
+  result <- c()
+  for (alpha in alphas) {
+    arg$alpha <- alpha
+    result[length(result)+1] <- do.call(rgb, arg)
+  }
+  return(result)
+}
+
+# define material design palette base colors
+material_colors <- c(
+  "blue",         "red",          "green",        "yellow",   "brown",
+  "indigo",       "pink",         "teal",         "amber",    "orange",
+  "purple",       "deep-orange",  "light-green",  "lime",     "grey",
+  "deep-purple",  "cyan",         "blue-grey",    "light-blue"
+)
+
+#' @importFrom ggsci        pal_material
+get_palette <- function(size) {
+  # limit the size to the length of `material_colors`
+  if (size > length(material_colors)) {
+    size <- length(material_colors)
+  } else if (size < 1) {
+    return()
+  }
+
+  # calculate the colors
+  sapply(
+    sapply(material_colors[1:size], pal_material, reverse = TRUE),
+    function(x) { x(1) }
+  )
+}
+
+get_colors <- function(types) {
+  if (length(types) < 1) {
+    return(list())
+  }
+
+  colors <- lapply(get_palette(length(types)), get_color_variants)
+  names(colors) <- types
+
+  return(colors)
+}

tests/testthat/test_utils.R

@@ -1,10 +1,52 @@
 context("utils.R")
 
-test_that("projection() should be working correctly", {
+test_that("projection()", {
   expect_equal(projection(1, 10, 20), 15)
   expect_equal(projection(c(0, 0, 0), 10, 20), 15)
   # expect_equal(projection(NULL, 10, 20), 15)
   # expect_equal(projection(NA, 10, 20), 15)
   expect_equal(projection(c(1, 2), 10, 20), c(10, 20))
   expect_equal(projection(c(0, 5, 10), 10, 20), c(10, 15, 20))
-})
+})
+
+test_that("get_palette()", {
+  expect_equal(length(get_palette(1)), 1)
+  expect_equal(length(get_palette(5)), 5)
+  expect_equal(length(get_palette(19)), 19)
+  # only can get 19 colors, no more
+  expect_equal(length(get_palette(50)), 19)
+
+  expect_equal(names(get_palette(4)), c("blue", "red", "green", "yellow"))
+  expect_equal(
+    get_palette(4),
+    c(
+      blue = "#0C46A0FF",
+      red = "#B71B1BFF",
+      green = "#1A5E1FFF",
+      yellow = "#F47F17FF"
+    )
+  )
+})
+
+test_that("get_color_variants()", {
+  expect_equal(get_color_variants("#123456"), c("#1234564D", "#12345680", "#123456FF"))
+})
+
+test_that("get_colors()", {
+  expect_equal(
+    get_colors(c("type1")),
+    list(type1 = c("#0C46A04D", "#0C46A080", "#0C46A0FF"))
+  )
+  expect_equal(
+    get_colors(c("a", "b", "c")),
+    list(
+      a = c("#0C46A04D", "#0C46A080", "#0C46A0FF"),
+      b = c("#B71B1B4D", "#B71B1B80", "#B71B1BFF"),
+      c = c("#1A5E1F4D", "#1A5E1F80", "#1A5E1FFF")
+    )
+  )
+
+  # return empty list for invalid input
+  expect_equal(get_colors(c()), list())
+  expect_equal(get_colors(NULL), list())
+})