Merge pull request #35 from mccarthy-m-g/print_style

Add new print style options

DESCRIPTION

@@ -33,8 +33,8 @@ Suggests:
     pkgdown,
     testthat (>= 3.0.0),
     dplyr,
-    knitr,
-    rmarkdown,
+    knitr (>= 1.22),
+    rmarkdown (>= 2.20),
     colorspace,
     gt,
     biscale,
@@ -45,7 +45,8 @@ Suggests:
     PNWColors,
     viridisLite,
     covr,
-    grDevices
+    grDevices,
+    withr
 VignetteBuilder:
     knitr
 Config/Needs/website:

NAMESPACE

@@ -42,6 +42,7 @@ export(as_tibble)
 export(is_color)
 export(is_colour)
 export(is_palette)
+export(list_colour_symbols)
 export(pal_bin)
 export(pal_color)
 export(pal_colour)

NEWS.md

@@ -1,6 +1,6 @@
 # palettes (development version)
 
-- Added the `palettes.symbol` option to set the symbol used for colour previews. See `?"palettes-options"` for details.
+- Added a variety of global options to adjust the printing behaviour of colour vectors. See `help("palettes-options")` and `vignette("palettes")` for details and examples.
 
 - Improved error message for invalid colours to support singular and plural grammar (@olivroy, #32)
 

R/options.R

@@ -8,13 +8,56 @@
 #'
 #' \describe{
 #'
-#' \item{\code{palettes.symbol}:}{
+#' \item{\code{palettes.print_symbol}:}{
 #'
 #'   Character string setting the symbol used for colour previews. See
-#'   `cli::list_symbols()` for a list of symbol choices. Defaults to `"bullet"`.
+#'   `list_colour_symbols()` for a list of symbol choices. Defaults to
+#'   `"circle_small"`. Set to `FALSE` to disable printing symbols.
+#'
+#' }
+#' \item{\code{palettes.print_hex}:}{
+#'
+#'   Logical setting whether to print hex codes in colour previews. Defaults to
+#'   `TRUE`.
+#'
+#' }
+#' \item{\code{palettes.print_alpha}:}{
+#'
+#'   Logical setting whether to print the hex code alpha channel in colour
+#'   previews. Defaults to `FALSE`. Colours without an alpha channel will be
+#'   assumed to be full opacity.
+#'
+#' }
+#' \item{\code{palettes.print_sep}:}{
+#'
+#'   Character string to separate colours by in colour previews. Defaults to `""`.
+#'
+#' }
+#' \item{\code{palettes.print_width}:}{
+#'
+#'   Integer setting the maximum number of colours on a line in colour previews.
+#'   Defaults to `1`.
+#'
+#' }
+#' \item{\code{palettes.print_index}:}{
+#'
+#'   Logical setting whether to print the index of the first colour on each line
+#'   in colour previews. Defaults to `FALSE`.
 #'
 #' }
 #'
 #' }
+#' @section Note:
+#' To disable formatting in colour previews set both `palettes.print_symbol` and
+#' `palettes.print_hex` to `FALSE`.
 #' @name palettes-options
+#' @examples
+#' options(
+#'   palettes.print_symbol = "square",
+#'   palettes.print_hex = FALSE,
+#'   palettes.print_sep = " ",
+#'   palettes.print_width = 3,
+#'   palettes.print_index = TRUE
+#' )
+#' met_palettes$Cross
 NULL

R/pillar.R

@@ -1,5 +1,8 @@
 #' @importFrom pillar pillar_shaft
 #' @export
 pillar_shaft.palettes_colour <- function(x, ...) {
+  # Hex codes should always be printed in tibbles.
+  op <- options(palettes.print_hex = TRUE)
+  on.exit(options(op))
   pillar::new_pillar_shaft_simple(colour_format_symbol(x))
 }

R/pretty.R

@@ -1,20 +1,28 @@
 colour_symbol <- function(x) {
   style_box <- cli::make_ansi_style(x)
-  style_box(cli::symbol[getOption("palettes.symbol", default = "bullet")])
+  style_box(pal_symbol[getOption("palettes.print_symbol")])
 }
 
 colour_format_symbol <- function(x, ...) {
-  vapply(
+  print_symbol <- !isFALSE(getOption("palettes.print_symbol"))
+  print_hex    <- isTRUE(getOption("palettes.print_hex"))
+
+  out <- purrr::map_chr(
     x,
-    function(x) {
-      colour_index <- !is.na(x)
-      if (colour_index) {
-        paste(colour_symbol(x), format(x))
+    function(.x) {
+      colour_index <- !is.na(.x)
+      if (print_hex && print_symbol) {
+        ifelse(colour_index, paste(colour_symbol(.x), format(.x)), "<NA>")
+      } else if (!print_hex && print_symbol) {
+        ifelse(colour_index, colour_symbol(.x), "<NA>")
+      } else if (print_hex && !print_symbol) {
+        ifelse(colour_index, format(.x), "<NA>")
       } else {
-        "     <NA>"
+        ifelse(colour_index, paste0("\"", .x, "\""), "NA")
       }
-    },
-    FUN.VALUE = character(1),
-    USE.NAMES = FALSE
+    }
   )
+
+  out_width <- max(cli::ansi_nchar(out, type = "width"))
+  cli::ansi_align(out, width = out_width, align = "right", type = "width")
 }

R/print.R

@@ -1,13 +1,38 @@
 #' @export
 obj_print_data.palettes_colour <- function(x, ...) {
-  if (vec_is_empty(x)) {
-    return(invisible(x))
-  }
+  if (vec_is_empty(x)) return(invisible(x))
+
+  print_sep   <- getOption("palettes.print_sep")
+  print_width <- getOption("palettes.print_width")
+  print_index <- getOption("palettes.print_index")
 
   out <- colour_format_symbol(x)
+  out_nchar <- max(cli::ansi_nchar(out, type = "width")) + nchar(print_sep)
+  out_width <- print_width * out_nchar
+
+  if (print_index) {
+    index <- paste0("[", seq(from = 1, to = vec_size(x), by = print_width), "]")
+    index_nchar <- max(nchar(index))
+    index <- format(index, width = index_nchar, justify = "left")
+    out_width <- out_width + index_nchar + 1
+  } else {
+    index <- NULL
+  }
 
-  cat(out, sep = "\n")
+  # Formatting each row manually ensures that the the maximum number of colours
+  # on a line and their indexes will always be correct; otherwise, when letting
+  # cat() determine what's on a line, there are edge cases when there are NAs in
+  # the colour vector or formatting is disabled where the maximum number of
+  # colours on a line isn't respected. Likewise, although cli::ansi_columns()
+  # performs a similar function to the code below, it has some quirks that make
+  # it unsuitable here (such as putting a separator after the last item).
+  out <- split(out, ceiling(seq_along(out)/print_width))
+  out <- purrr::map_chr(out, paste0, collapse = print_sep)
+  out[1:vec_size(out) - 1] <- purrr::map_chr(
+    out[1:vec_size(out) - 1], function(.x) paste0(.x, print_sep)
+  )
 
+  cat(out, sep = "", fill = out_width, labels = index)
   invisible(x)
 }
 

R/symbol.R

@@ -0,0 +1,104 @@
+#' Symbols to use in colour previews
+#'
+#' List the symbols available to use in colour previews.
+#'
+#' @details
+#' By default, Unicode characters are used for symbols in colour previews in
+#' UTF-8 supported outputs. They automatically fall back to ASCII characters
+#' when the output does not support them.
+#'
+#' To change the symbol used for colour previews, set the `palettes.print_symbol`
+#' option to a symbol name listed in `list_colour_symbols()`.
+#' @return This function is called for its side effects and has no return value.
+#' @seealso `help("palettes-options")`, [cli::is_utf8_output()]
+#' @export
+#'
+#' @examples
+#' list_colour_symbols()
+list_colour_symbols <- function() {
+  width <- 50
+  cat(
+    cli::rule(
+      left = "options(palettes.print_symbol = ...)",
+      width = width + 10
+    ),
+    cli::ansi_columns(
+      paste0(pal_symbol, "\t", names(pal_symbol)),
+      width = width,
+      fill = "cols",
+      max_cols = 2,
+      align = "left"
+    ),
+    sep = "\n"
+  )
+}
+
+symbol_utf8 <- list(
+  "circle_small" = "\u2022",
+  "circle" = "\u25CF",
+  "circle_medium" = "\u26AB",
+  "circle_large" = "\u2B24",
+
+  "ellipse_horizontal" = "\u2B2C",
+  "ellipse_vertical" = "\u2B2E",
+
+  "triangle_up" = "\u25B2",
+  "triangle_down" = "\u25BC",
+  "triangle_left" = "\u25C0",
+  "triangle_right" = "\u25B6",
+
+  "square_small" = "\u25AA",
+  "square" = "\u25A0",
+  "square_medium" = "\u25FC",
+  "square_large" = "\u2B1B",
+
+  "block" = "\u2587",
+  "block_full" = "\u2588",
+
+  "diamond_small" = "\u2B29",
+  "diamond" = "\u25C6",
+  "diamond_medium" = "\u2B25",
+
+  "pentagon" = "\u2B1F",
+  "hexagon" = "\u2B22",
+
+  "star" = "\u2605",
+  "heart" = "\u2665",
+  "smiley" = "\u263A",
+  "moustache" = "\u0DF4"
+)
+
+symbol_ascii <- list(
+  "circle_small" = "*",
+  "circle" = "*",
+  "circle_medium" = "*",
+  "circle_large" = "*",
+
+  "ellipse_horizontal" = "*",
+  "ellipse_vertical" = "*",
+
+  "triangle_up" = "^",
+  "triangle_down" = "v",
+  "triangle_left" = "<",
+  "triangle_right" = ">",
+
+  "square_small" = "[x]",
+  "square" = "[x]",
+  "square_medium" = "[x]",
+  "square_large" = "[x]",
+
+  "block" = "#",
+  "block_full" = "#",
+
+  "diamond_small" = "[+]",
+  "diamond" = "[+]",
+  "diamond_medium" = "[+]",
+
+  "pentagon" = "*",
+  "hexagon" = "*",
+
+  "star" = "*",
+  "heart" = "<3",
+  "smiley" = ":)",
+  "moustache" = "/\\/"
+)

R/utils.R

@@ -1,6 +1,9 @@
 str_to_hex <- function(x) {
-  # TODO: Decide whether to support alpha channel
-  farver::encode_colour(farver::decode_colour(x))
+  print_alpha <- getOption("palettes.print_alpha")
+  alpha <- NULL
+  col_rgb <- farver::decode_colour(x, alpha = print_alpha)
+  if (print_alpha) alpha <- col_rgb[,"alpha"]
+  farver::encode_colour(col_rgb, alpha = alpha)
 }
 
 is_valid_colour <- function(x) {

R/zzz.R

@@ -0,0 +1,33 @@
+## nocov start
+
+package_env <- environment()
+
+.onLoad <- function(libname, pkgname) {
+  op <- options()
+  op.palettes <- list(
+    palettes.print_symbol = "circle_small",
+    palettes.print_hex = TRUE,
+    palettes.print_alpha = FALSE,
+    palettes.print_sep = "",
+    palettes.print_width = 1,
+    palettes.print_index = FALSE
+  )
+  toset <- !(names(op.palettes) %in% names(op))
+  if (any(toset)) options(op.palettes[toset])
+
+  makeActiveBinding(
+    "pal_symbol",
+    function() {
+      if (cli::is_utf8_output()) {
+        symbol_utf8
+      } else {
+        symbol_ascii
+      }
+    },
+    package_env
+  )
+
+  invisible()
+}
+
+## nocov end