Merge pull request #103 from katilingban:dev

fix tint and shade functions (fix #97); create brewer functions; fix #99; fix #100; fix #101; fix #102

Author: ernestguevarra

DESCRIPTION

@@ -16,6 +16,7 @@ License: GPL (>= 3)
 Depends: 
     R (>= 4.1.0)
 Imports: 
+    cli,
     ggplot2,
     stringr,
     systemfonts,

NAMESPACE

@@ -4,6 +4,7 @@ S3method(print,palette)
 export(acdc_amber)
 export(acdc_blue)
 export(acdc_blue_grey)
+export(acdc_brewer_palettes)
 export(acdc_corporate_green)
 export(acdc_cyan)
 export(acdc_deep_orange)
@@ -46,6 +47,10 @@ export(nhs_purple)
 export(nhs_warm_yellow)
 export(nhs_white)
 export(nhs_yellow)
+export(paleta_create_brewer)
+export(paleta_create_divergent)
+export(paleta_create_qualitative)
+export(paleta_create_sequential)
 export(paleta_fonts)
 export(set_acdc_font)
 export(set_nhs_font)
@@ -97,6 +102,9 @@ export(wb_light_aqua)
 export(wb_light_orange)
 export(wb_palettes)
 export(wb_white)
+importFrom(cli,cli_abort)
+importFrom(cli,cli_alert_success)
+importFrom(cli,cli_bullets)
 importFrom(ggplot2,element_blank)
 importFrom(ggplot2,element_line)
 importFrom(ggplot2,element_rect)

NEWS.md

@@ -4,12 +4,17 @@
 
 * Changed Africa CDC colour palettes based on updated communication style guidelines
 
+* Created sequential and divergent Africa CDC colour palettes
+
 ## General updates
 
-* refresh `pkgdown` website
-* refresh GitHub Actions workflows to include Netlify pull request deployment
+* refreshed `pkgdown` website
+* refreshed GitHub Actions workflows to include Netlify pull request deployment
 * added appropriate `fig.alt` specifications in all package documentation
 
+## Bug fixes
+
+* fixed issue with `tint_colour*()` and `shade_colour*()` functions in which they return the opposite percentage tint or shade of a colour or a set of colours
 
 # paleta (version 0.0.0.9001)
 

R/paleta.R

@@ -17,5 +17,6 @@
 #' @importFrom grid unit
 #' @importFrom grDevices col2rgb rgb
 #' @importFrom graphics rect par image text
+#' @importFrom cli cli_abort  cli_alert_success cli_bullets
 #'
 "_PACKAGE"

R/paleta_brewer.R

@@ -0,0 +1,234 @@
+#'
+#' Create new palettes based on organisational palettes
+#'
+#' These functions apply a similar approach used and demonstrated by
+#' [ColorBrewer](https://colorbrewer2.org) and has been patterned after the
+#' syntax of the `RColorBrewer` package
+#'
+#' @param org Name of organisation. Currently supports only *"acdc"* for the
+#'   Africa CDC colour palettes.
+#' @param name Name of the organisational palette to use
+#' @param n Number of colours desired/required. Organisational palettes should
+#'   have at least 3 colours and up to 9 colours maximum. All colour schemes are
+#'   derived from an organisation's brand/style guidelines.
+#' @param type A character value for type of palette to use. Can be either
+#'   *"sequential"*, *"divergent"*, or *"qualitative"*.
+#'
+#' @returns A character vector of desired/required colours with length
+#'   equivalent to `n`
+#'
+#' @examples
+#' paleta_create_sequential(n = 5, org = "acdc", name = "blues")
+#'
+#' @rdname create_paleta
+#' @export
+#'
+
+paleta_create_sequential <- function(n, org, name) {
+  ## Check if specified palette is found in specified org palette ----
+  paleta_check_colour(name = name, org = org)
+
+  ## Check if specified palette is sequential ----
+  paleta_check_type(name = name, pal_type = "sequential")
+
+  ## Check if number of colours is compatible with sequential ----
+  if (n < 3) {
+    cli::cli_bullets(
+      "!" = "Sequential palettes have minimum 3 colours",
+      "i" = "Returning 3 colours"
+    )
+
+    n <- 3
+  }
+
+  if (n > 9) {
+    cli::cli_bullets(
+      "!" = "Sequential palettes have maximum 9 colours",
+      "i" = "Returning 9 colours"
+    )
+
+    n <- 9
+  }
+
+  ## Get base palette ----
+  pal <- get(paste0(org, "_brewer_palettes"))[[name]]
+
+  ## Update palette to n ----
+  pal <- grDevices::colorRampPalette(pal)(n)
+
+  ## Create palette class ----
+  class(pal) <- "palette"
+
+  ## Return palette ----
+  pal
+}
+
+
+#'
+#' @rdname create_paleta
+#' @export
+#'
+paleta_create_divergent <- function(n, name, org) {
+  ## Check if specified palette is found in specified org palette ----
+  paleta_check_colour(name = name, org = org)
+
+  ## Check if specified palette is divergent ----
+  paleta_check_type(name = name, pal_type = "divergent")
+
+  ## Check if number of colours is compatible with divergent ----
+  if (n < 3) {
+    cli::cli_bullets(
+      "!" = "Divergent palettes have minimum 3 colours",
+      "i" = "Returning 3 colours"
+    )
+
+    n <- 3
+  }
+
+  if (n > 11) {
+    cli::cli_bullets(
+      "!" = "Divergent palettes have maximum 11 colours",
+      "i" = "Returning 11 colours"
+    )
+
+    n <- 11
+  }
+
+  ## Get base palette ----
+  pal <- get(paste0(org, "_brewer_palettes"))[[name]]
+
+  ## Update palette to n ----
+  pal <- grDevices::colorRampPalette(pal)(n)
+
+  ## Create palette class ----
+  class(pal) <- "palette"
+
+  ## Return palette ----
+  pal
+}
+
+#'
+#' @rdname create_paleta
+#' @export
+#'
+paleta_create_qualitative <- function(n, name, org) {
+  ## Check if specified palette is found in specified org palette ----
+  paleta_check_colour(name = name, org = org)
+
+  ## Check if specified palette is divergent ----
+  paleta_check_type(name = name, pal_type = "qualitative")
+
+  ## Get base palette ----
+  pal <- get(paste0(org, "_brewer_palettes"))[[name]]
+
+  ## Check that n is not more than length(pal) ----
+  if (n > length(pal)) {
+    cli::cli_bullets(
+      "!" = "{.code n = {n}} is greater than available colours in {name} palette",
+      "i" = "Returning all colours in {name} colour palette"
+    )
+
+    n <- length(pal)
+  }
+
+  ## Update palette to n ----
+  pal <- pal[seq_len(n)]
+
+  ## Create palette class ----
+  class(pal) <- "palette"
+
+  ## Return palette ----
+  pal
+}
+
+
+#'
+#' @rdname create_paleta
+#' @export
+#'
+paleta_create_brewer <- function(n, name, org,
+                                 type = c("sequential", 
+                                          "divergent", 
+                                          "qualitative")) {
+  ## Determine type of palette ----
+  type <- match.arg(type)
+
+  pal <- parse(
+    text = paste0("paleta_create_", type, "(n = n, name = name, org = org)")
+  ) |>
+    eval()
+
+  ## Return palette ----
+  pal
+}
+
+#'
+#' Palette types
+#' 
+#' @keywords internal
+#' 
+
+paleta_brewer_types <- list(
+  sequential = c(
+    "blues", "bugn", "bupu", "gnbu", "greens", "greys", "pubu", "pubugn", 
+    "purd", "rdpu", "reds", "ylgn", "ylgnbu", "ylorbr", "ylorrd"
+  ),
+  divergent = c(
+    "brbg", "piylgn", "prgn", "puor", "rdbu", "rdgy","rdylbu", "rdylgn"
+  ),
+  qualitative = c(
+    "pastel1", "pastel2", "pastel3", "dark", "light", "bright"
+  )
+)
+
+#'
+#' Check if a colour palette name is from a specified organisation
+#' 
+#' @keywords internal
+#' 
+
+paleta_check_colour <- function(name, org) {
+  x <- get(paste0(org, "_brewer_palettes"))[[name]]
+
+  if (is.null(x)) {
+    cli::cli_abort(
+      "Colour palette {.val {name}} is not a {org} colour palette"
+    )
+  } else {
+    cli::cli_alert_success(
+      "Colour palette {.val {name}} is a {org} colour palette"
+    )
+  }
+
+  ## Return colour palette ----
+  x
+}
+
+#'
+#' Check if a colour palette is divergent, sequential, or qualitative
+#' 
+#' @keywords internal
+#' 
+
+paleta_check_type <- function(name, 
+                              pal_type = c("sequential", 
+                                           "divergent", 
+                                           "qualitative")) {
+  pal_type <- match.arg(pal_type)
+  
+  type_check <- name %in% paleta_brewer_types[[pal_type]]
+
+  if (!type_check) {
+    cli::cli_abort(
+      "{name} is not a {pal_type} colour palette"
+    )
+
+    FALSE
+  } else {
+    cli::cli_alert_success(
+      "{name} is a {pal_type} colour palette"
+    )
+
+    TRUE
+  }
+}