cleaning some internals

nothing of substance changes

Author: jgabry

R/bayesplot-colors.R

@@ -227,15 +227,29 @@ plot_scheme <- function(scheme) {
     )
 }
 
+# Color scheme level names
+scheme_level_names <- function() {
+  c("light",
+    "light_highlight",
+    "mid",
+    "mid_highlight",
+    "dark",
+    "dark_highlight")
+}
 
-# @param scheme A string (length 1) naming a scheme
+#' Return a color scheme based on `scheme` argument specified as a string
+#'
+#' @noRd
+#' @param scheme A string (length 1) naming a scheme
 scheme_from_string <- function(scheme) {
   stopifnot(length(scheme) == 1)
   if (identical(substr(scheme, 1, 4), "mix-")) {
+    # user specified a mixed scheme (e.g., "mix-blue-red")
     to_mix <- unlist(strsplit(scheme, split = "-"))[2:3]
     x <- setNames(mixed_scheme(to_mix[1], to_mix[2]), scheme_level_names())
     return(structure(x, mixed = TRUE, scheme_name = scheme))
   } else if (identical(substr(scheme, 1, 7), "brewer-")) {
+    # user specified a ColorBrewer scheme (e.g., "brewer-Blues")
     if (!requireNamespace("RColorBrewer", quietly = TRUE)) {
       stop("Please install the 'RColorBrewer' package to use a ColorBrewer scheme.",
            call.=FALSE)
@@ -244,23 +258,41 @@ scheme_from_string <- function(scheme) {
     x <- setNames(as.list(clrs), scheme_level_names())
     return(structure(x, mixed = FALSE, scheme_name = scheme))
   } else {
+    # check for scheme in master_color_list
     scheme <- match.arg(scheme, choices = names(master_color_list))
-    x <- prepare_colors(scheme)
+    x <- setNames(master_color_list[[scheme]], scheme_level_names())
     return(structure(x, mixed = FALSE, scheme_name = scheme))
   }
 }
 
-# check if object returned by color_scheme_get is a mixed scheme
-# @param x object returned by color_scheme_get
+# create mixed scheme from two existing schemes
+mixed_scheme <- function(scheme1, scheme2) {
+  scheme1 <- color_scheme_get(scheme1)
+  scheme2 <- color_scheme_get(scheme2)
+  scheme <- unname(list(
+    scheme1$light,
+    scheme2$light_highlight,
+    scheme2$mid,
+    scheme1$mid_highlight,
+    scheme1$dark,
+    scheme2$dark_highlight
+  ))
+  attr(scheme, "mixed") <- TRUE
+  return(scheme)
+}
+
+#' Check if object returned by color_scheme_get() is a mixed scheme
+#' @noRd
+#' @param x object returned by color_scheme_get()
+#' @return T/F
 is_mixed_scheme <- function(x) {
   stopifnot(is.list(x))
   isTRUE(attr(x, "mixed"))
 }
 
-#' Access a subset of the scheme colors
-#'
+#' Access a subset of the current scheme colors
 #' @noRd
-#' @param level A character vector of level names (see `scheme_level_names()`).
+#' @param level A character vector of level names scheme_level_names().
 #'   The abbreviations "l", "lh", "m", "mh", "d", and "dh" can also be used
 #'   instead of the full names.
 #' @return A character vector of color values.
@@ -273,6 +305,7 @@ get_color <- function(levels) {
   color_vals <- color_scheme_get()[levels]
   unlist(color_vals, use.names = FALSE)
 }
+
 full_level_name <- function(x) {
   switch(x,
          l = "light", lh = "light_highlight",
@@ -281,37 +314,28 @@ full_level_name <- function(x) {
          )
 }
 
-
-# Color scheme level names
-scheme_level_names <- function() {
-  c("light",
-    "light_highlight",
-    "mid",
-    "mid_highlight",
-    "dark",
-    "dark_highlight")
-}
-
-prepare_colors <- function(scheme) {
-  setNames(
-    master_color_list[[scheme]],
-    scheme_level_names()
-  )
-}
-
+# Custom color scheme if 6 colors specified
 prepare_custom_colors <- function(scheme) {
-  if (length(scheme) != 6)
+  if (length(scheme) != 6) {
     stop("Custom color schemes must contain exactly 6 colors.",
          call. = FALSE)
+  }
 
   not_found <- character(0)
   for (j in seq_along(scheme)) {
     clr <- scheme[j]
     if (!is_hex_color(clr)  && !clr %in% grDevices::colors())
       not_found <- c(not_found, clr)
   }
-  if (length(not_found))
-    STOP_bad_colors(not_found)
+  if (length(not_found)) {
+    stop(
+      "Each color must specified as either a hexidecimal color value ",
+      "(e.g. '#C79999') or the name of a color (e.g. 'blue'). ",
+      "The following provided colors were not found: ",
+      paste(unlist(not_found), collapse = ", "),
+      call. = FALSE
+    )
+  }
 
   x <- setNames(as.list(scheme), scheme_level_names())
   attr(x, "scheme_name") <- "custom"
@@ -324,34 +348,8 @@ is_hex_color <- function(x) {
   isTRUE(nchar(x) == 7)
 }
 
-# @param x character vector of bad color names
-STOP_bad_colors <- function(x) {
-  stop(
-    "Each color must specified as either a hexidecimal color value ",
-    "(e.g. '#C79999') or the name of a color (e.g. 'blue'). ",
-    "The following provided colors were not found: ",
-    paste(unlist(x), collapse = ", "),
-    call. = FALSE
-  )
-}
 
 # master color list -------------------------------------------------------
-# create mixed scheme
-mixed_scheme <- function(scheme1, scheme2) {
-  scheme1 <- color_scheme_get(scheme1)
-  scheme2 <- color_scheme_get(scheme2)
-  scheme <- unname(list(
-    scheme1$light,
-    scheme2$light_highlight,
-    scheme2$mid,
-    scheme1$mid_highlight,
-    scheme1$dark,
-    scheme2$dark_highlight
-  ))
-  attr(scheme, "mixed") <- TRUE
-  return(scheme)
-}
-
 master_color_list <- list(
   blue =
     list("#d1e1ec", "#b3cde0", "#6497b1", "#005b96", "#03396c", "#011f4b"),

tests/testthat/test-aesthetics.R

@@ -3,14 +3,22 @@ context("Aesthetics")
 
 
 # color scheme stuff ------------------------------------------------------
+
+prepare_colors_for_test <- function(scheme) {
+  setNames(
+    bayesplot:::master_color_list[[scheme]],
+    bayesplot:::scheme_level_names()
+  )
+}
+
 test_that("getting and setting the color scheme works", {
   color_scheme_set("red")
-  expect_equivalent(color_scheme_get(), prepare_colors("red"))
-  expect_named(prepare_colors("blue"), scheme_level_names())
+  expect_equivalent(color_scheme_get(), prepare_colors_for_test("red"))
+  expect_named(prepare_colors_for_test("blue"), scheme_level_names())
   expect_named(color_scheme_get(), scheme_level_names())
   for (clr in names(master_color_list)) {
     color_scheme_set(clr)
-    expect_equivalent(color_scheme_get(), prepare_colors(clr),
+    expect_equivalent(color_scheme_get(), prepare_colors_for_test(clr),
                       info = clr)
     expect_named(color_scheme_get(), scheme_level_names())
   }
@@ -20,7 +28,7 @@ test_that("getting and setting the color scheme works", {
   expect_gg(plot(color_scheme_get("mix-blue-green")))
 
   color_scheme_set("blue")
-  expect_equivalent(color_scheme_get("teal"), prepare_colors("teal"))
+  expect_equivalent(color_scheme_get("teal"), prepare_colors_for_test("teal"))
 })
 
 test_that("color_scheme_get with i argument works", {
@@ -99,7 +107,7 @@ test_that("get_color returns correct color values", {
   scheme <- color_scheme_set("green")
   levs <- scheme_level_names()
 
-  ans <- unlist(prepare_colors("green")[levs], use.names = FALSE)
+  ans <- unlist(prepare_colors_for_test("green")[levs], use.names = FALSE)
   expect_identical(get_color(levs), ans)
   for (lev in levs)
     expect_identical(get_color(lev), scheme[[lev]], info = lev)