Initial commit

R/cols_agora.R

@@ -0,0 +1,32 @@
+#' @title Function to extract AGORA colors as hex codes
+#'
+#' @param ... Character names of reach colors. If NULL returns all colors
+#' @param unnamed Should the output vector be unnamed? Default to `TRUE`
+#'
+#' @return An hex code or hex codes named or unnamed
+#'
+#' @details This function needs to be modified to add colors
+#'
+#' @export
+cols_agora <- function(..., unnamed = TRUE) {
+  cols <- c(...)
+
+  colors_agora <- c(white         = "#FFFFFF",
+                    black         = "#000000",
+                    main_bordeaux = "#581522",
+                    main_lt_beige = "#DDD8C4",
+                    main_dk_beige = "#B7AD99",
+                    main_lt_grey  = "#BCB8B1")
+
+  if (is.null(cols)) {
+    cols_to_return <- colors_agora
+  } else {
+    cols_to_return <- colors_agora[cols]
+  }
+
+  if(unnamed){
+    cols_to_return <- unname(cols_to_return)
+  }
+
+  return(cols_to_return)
+}

R/cols_reach.R

@@ -0,0 +1,69 @@
+#' @title Function to extract REACH colors as hex codes
+#'
+#' @param ... Character names of reach colors. If NULL returns all colors
+#' @param unnamed Should the output vector be unnamed? Default to `TRUE`
+#'
+#' @return An hex code or hex codes named or unnamed
+#'
+#' @details This function needs to be modified to add colors
+#'
+#' @export
+cols_reach <- function(..., unnamed = TRUE) {
+  cols <- c(...)
+
+  colors_reach <- c(white        = "#FFFFFF",
+                    black        = "#000000",
+                    main_grey    = "#58585A",
+                    main_red     = "#EE5859",
+                    main_lt_grey = "#C7C8CA",
+                    main_beige   = "#D2CBB8",
+                    iroise_1     = "#DFECEF",
+                    iroise_2     = "#B1D7E0",
+                    iroise_3     = "#699DA3",
+                    iroise_4     = "#236A7A",
+                    iroise_5     = "#0C3842",
+                    red_main_1   = "#AE2829",
+                    red_main_2   = "#D05E5F",
+                    red_main_3   = "#DB9797",
+                    red_main_4   = "#EBC7C8",
+                    red_main_5   = "#FAF2F2",
+                    red_alt_1    = "#792a2e",
+                    red_alt_2    = "#c0474a",
+                    red_alt_3    = "#ee5859",
+                    red_alt_4    = "#f49695",
+                    red_alt_5    = "#f8d6d6",
+                    red_alt_na   = "#f8f4f4",
+                    lt_grey_1    = "#C6C6C6",
+                    lt_grey_2    = "#818183",
+                    grey3        = "#E3E3E3",
+                    dk_grey      = "#464647",
+                    two_dots_1   = "#706441",
+                    two_dots_2   = "#56b4e9",
+                    two_dots_flashy_1 = "gold1",
+                    two_dots_flashy_2 = "blue2",
+                    three_dots_1 = "aquamarine2",
+                    three_dots_2 = "cornflowerbluer",
+                    three_dots_3 = "brown1",
+                    orpink       = "#f8aa9b",
+                    pink         = "#f5a6a7",
+                    lt_pink      = "#F9C6C7",
+                    hot_pink     = "#ef6d6f",
+                    mddk_red     = "#bf4749",
+                    dk_red       = "#782c2e",
+                    orange       = "#F69E61",
+                    lt_green     = "#B0CFAC",
+                    green        = "#84A181",
+                    dk_green     = "#526450")
+
+  if (is.null(cols)) {
+    cols_to_return <- colors_reach
+  } else {
+    cols_to_return <- colors_reach[cols]
+  }
+
+  if(unnamed){
+    cols_to_return <- unname(cols_to_return)
+  }
+
+  return(cols_to_return)
+}

R/pal_agora.R

@@ -0,0 +1,40 @@
+#' @title Return function to interpolate an AGORA color palette
+#'
+#' @param palette Character name of a palette in AGORA palettes
+#' @param reverse Boolean indicating whether the palette should be reversed
+#' @param color_ramp_palette Should the output be a `grDevices::colorRampPalette` function or a vector of hex codes? Default to the former with `TRUE`
+#' @param show_palettes Should the ouput be the set of palettes names to pick from? Default to `FALSE`
+#' @param ... Additional arguments to pass to colorRampPalette()
+#'
+#' @return A color palette
+#'
+#' @export
+pal_agora <- function(palette = "main", reverse = FALSE, color_ramp_palette = FALSE, show_palettes = FALSE, ...) {
+
+
+  palettes_agora <- list(
+    `main`            = cols_agora("main_grey", "main_red", "main_lt_grey", "main_beige"),
+    `primary`         = cols_agora("main_grey", "main_red"),
+    `secondary`       = cols_agora("main_lt_grey", "main_beige"),
+    `two_dots`        = cols_agora("two_dots_1", "two_dots_2"),
+    `two_dots_flashy` = cols_agora("two_dots_flashy_1", "two_dots_flashy_2"),
+    `red_main`        = cols_agora("red_main_1", "red_main_2", "red_main_3", "red_main_4", "red_main_5"),
+    `red_alt`         = cols_agora("red_alt_1", "red_alt_2", "red_alt_3", "red_alt_4", "red_alt_5"),
+    `iroise`          = cols_agora("iroise_1", "iroise_2", "iroise_3", "iroise_4", "iroise_5"),
+    `discrete_6`      = cols_agora("dk_grey", "red_main_1", "main_beige", "red_main_2", "lt_grey_2", "red_4")
+  )
+
+  if (show_palettes) return(names(palettes_agora))
+
+  pal <- palettes_agora[[palette]]
+
+  if (reverse) pal <- rev(pal)
+
+  if (color_ramp_palette) {
+    rlang::check_installed("grDevices", reason = "Package \"grDevices\" needed for `pal_agora()` woth 'color_ramp_palette' set to `TRUE` to work. Please install it.")
+
+    pal <- grDevices::colorRampPalette(pal, ...)
+  }
+
+  return(pal)
+}

R/pal_reach.R

@@ -0,0 +1,40 @@
+#' @title Return function to interpolate a REACH color palette
+#'
+#' @param palette Character name of a palette in REACH palettes
+#' @param reverse Boolean indicating whether the palette should be reversed
+#' @param color_ramp_palette Should the output be a `grDevices::colorRampPalette` function or a vector of hex codes? Default to the former with `TRUE`
+#' @param show_palettes Should the ouput be the set of palettes names to pick from? Default to `FALSE`
+#' @param ... Additional arguments to pass to colorRampPalette()
+#'
+#' @return A color palette
+#'
+#' @export
+pal_reach <- function(palette = "main", reverse = FALSE, color_ramp_palette = FALSE, show_palettes = FALSE, ...) {
+
+
+  palettes_reach <- list(
+    `main`            = cols_reach("main_grey", "main_red", "main_lt_grey", "main_beige"),
+    `primary`         = cols_reach("main_grey", "main_red"),
+    `secondary`       = cols_reach("main_lt_grey", "main_beige"),
+    `two_dots`        = cols_reach("two_dots_1", "two_dots_2"),
+    `two_dots_flashy` = cols_reach("two_dots_flashy_1", "two_dots_flashy_2"),
+    `red_main`        = cols_reach("red_main_1", "red_main_2", "red_main_3", "red_main_4", "red_main_5"),
+    `red_alt`         = cols_reach("red_alt_1", "red_alt_2", "red_alt_3", "red_alt_4", "red_alt_5"),
+    `iroise`          = cols_reach("iroise_1", "iroise_2", "iroise_3", "iroise_4", "iroise_5"),
+    `discrete_6`      = cols_reach("dk_grey", "red_main_1", "main_beige", "red_main_2", "lt_grey_2", "red_4")
+  )
+
+  if (show_palettes) return(names(palettes_reach))
+
+  pal <- palettes_reach[[palette]]
+
+  if (reverse) pal <- rev(pal)
+
+  if (color_ramp_palette) {
+    rlang::check_installed("grDevices", reason = "Package \"grDevices\" needed for `pal_reach()` woth 'color_ramp_palette' set to `TRUE` to work. Please install it.")
+
+    pal <- grDevices::colorRampPalette(pal, ...)
+  }
+
+  return(pal)
+}

R/scale.R

@@ -0,0 +1,77 @@
+#' Color scale constructor for REACH or AGORA colors
+#'
+#' @param initiative Either "reach" or "agora
+#' @param palette Character name of palette in drsimonj_palettes
+#' @param discrete Boolean indicating whether color aesthetic is discrete or not
+#' @param reverse Boolean indicating whether the palette should be reversed
+#' @param ... Additional arguments passed to discrete_scale() or
+#'            scale_color_gradientn(), used respectively when discrete is TRUE or FALSE
+#' @return A color scale for ggplot
+#'
+#' @export
+scale_color  <- function(initiative = "reach", palette = "main", discrete = TRUE, reverse = FALSE, ...) {
+
+  if (initiative == "reach") {
+    pal <- pal_reach(
+      palette = palette,
+      reverse = reverse,
+      color_ramp_palette = TRUE,
+      show_palettes = FALSE
+      )
+  } else if (initiative == "agora") {
+    pal <- pal_agora(
+      palette = palette,
+      reverse = reverse,
+      color_ramp_palette = TRUE,
+      show_palettes = FALSE
+    )
+  } else {
+    rlang::abort(c("Wrong initiative parameter input", "*" = paste0(initiative, "is not an option"), "i" = "Parameter 'initiative' should be one of 'reach' or 'agora'"))
+  }
+
+  if (discrete) {
+    ggplot2::discrete_scale("colour", paste0(initiative, "_", palette), palette = pal, ...)
+  } else {
+    ggplot2::scale_color_gradientn(colours = pal(256), ...)
+  }
+}
+
+
+
+#' Fill scale constructor for REACH or AGORA colors
+#'
+#' @param initiative Either "reach" or "agora
+#' @param palette Character name of palette in drsimonj_palettes
+#' @param discrete Boolean indicating whether color aesthetic is discrete or not
+#' @param reverse Boolean indicating whether the palette should be reversed
+#' @param ... Additional arguments passed to discrete_scale() or
+#'            scale_fill_gradientn(), used respectively when discrete is TRUE or FALSE
+#' @return A fill scale for ggplot
+#'
+#' @export
+scale_color  <- function(initiative = "reach", palette = "main", discrete = TRUE, reverse = FALSE, ...) {
+
+  if (initiative == "reach") {
+    pal <- pal_reach(
+      palette = palette,
+      reverse = reverse,
+      color_ramp_palette = TRUE,
+      show_palettes = FALSE
+    )
+  } else if (initiative == "agora") {
+    pal <- pal_agora(
+      palette = palette,
+      reverse = reverse,
+      color_ramp_palette = TRUE,
+      show_palettes = FALSE
+    )
+  } else {
+    rlang::abort(c("Wrong initiative parameter input", "*" = paste0(initiative, "is not an option"), "i" = "Parameter 'initiative' should be one of 'reach' or 'agora'"))
+  }
+
+  if (discrete) {
+    ggplot2::discrete_scale("fill", paste0(initiative, "_", palette), palette = pal, ...)
+  } else {
+    ggplot2::scale_fill_gradientn(colours = pal(256), ...)
+  }
+}

R/theme_reach.R

@@ -0,0 +1,91 @@
+#' @title Base REACH ggplot2 theme
+#'
+#' @param family The font family. Default to "Leelawadee"
+#'
+#' @description Give some reach colors and fonts to a ggplot. Based on theme_bw()
+#'
+#' @return The base REACH theme
+#'
+theme_reach <- function(family = "Leelawadee") {
+
+  rlang::check_installed("ggplot2", reason = "Package \"ggplot2\" needed for `theme_reach_*()` to work. Please install it.")
+
+  ggplot2::theme_bw() +
+    ggplot2::theme(
+      title = ggplot2::element_text(family = family,
+                                    size = 12,
+                                    colour = "#58585A",
+                                    hjust = 0.5,
+                                    vjust = 0.5),
+      text = ggplot2::element_text(family = family,
+                                   colour = "#58585A"),
+      axis.title = ggplot2::element_text(size = 11),
+      axis.text = ggplot2::element_text(size = 10),
+      legend.text = ggplot2::element_text(size = 11),
+      strip.text = ggplot2::element_text(size = 11),
+      legend.title = ggplot2::element_text(size = 11)
+    )
+}
+
+
+
+#' @title Some REACH theme for ggplot
+#'
+#' @param family The font family. Default to "Leelawadee"
+#'
+#' @return A theme to be added to the "+" ggplot grammar
+#'
+#' @export
+theme_reach_borders <- function(family = "Leelawadee") {
+
+  theme_reach() +
+    ggplot2::theme(
+      panel.background = ggplot2::element_rect(colour = "white", fill = "white", size = 0.5),
+      strip.background = ggplot2::element_rect(linetype = "solid", colour = "#58585A", fill = "white")
+    )
+}
+
+
+
+#' @title Some reach more minimal theme for ggplot
+#'
+#' @param family The font family. Default to "Leelawadee"
+#'
+#' @description Give some REACH colors and fonts to a ggplot. Based on theme_bw(). To be used for vertical bar charts.
+#'
+#' @return A theme to be added to the "+" ggplot grammar
+#'
+#' @export
+theme_reach_hist <- function(family = "Leelawadee") {
+
+  theme_reach() +
+    ggplot2::theme(
+      panel.background = ggplot2::element_blank(),
+      strip.background = ggplot2::element_blank(),
+      panel.border = ggplot2::element_blank()
+    )
+}
+
+
+#' @title Some reach more minimal theme for ggplot
+#'
+#' @param family The font family. Default to "Leelawadee"
+#'
+#' @description Give some REACH colors and fonts to a ggplot. Based on theme_bw(). To be used for horizontal bar charts.
+#'
+#' @return A theme to be added to the "+" ggplot grammar
+#'
+#' @export
+theme_reach_flip_hist <- function(family = "Leelawadee") {
+
+  theme_reach() +
+    ggplot2::theme(
+      panel.background = ggplot2::element_blank(),
+      strip.background = ggplot2::element_blank(),
+      panel.border = ggplot2::element_blank(),
+      axis.ticks.y = ggplot2::element_blank()
+    )
+}
+
+
+