Merged 1.1.0

Merge branch 'development'

# Conflicts:
#	DESCRIPTION
#	NEWS.md

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: tntpr
 Title: Data Analysis Tools Customized for TNTP
-Version: 1.0.3
+Version: 1.1.0
 Authors@R: c(
       person("Dustin", "Pashouwer", role = c("aut", "cre"), 
              email = "[email protected]"),
@@ -21,10 +21,11 @@ Depends:
     R (>= 3.2)
 Imports: 
     cli,
+    colorspace,
     dplyr (>= 0.8.3),
     extrafont,
     formattable,
-    ggplot2 (>= 3.2.1),
+    ggplot2 (>= 3.5.0),
     grDevices,
     grid,
     janitor,

NAMESPACE

@@ -3,6 +3,7 @@
 export(bar_chart_counts)
 export(check_all_count)
 export(check_all_recode)
+export(choose_text_color)
 export(colors_tntp)
 export(colors_tntp_likert)
 export(colors_tntp_likert_orange_to_green)
@@ -16,6 +17,7 @@ export(labelled_to_factors)
 export(palette_names)
 export(palette_tntp)
 export(palette_tntp_scales)
+export(position_diverge)
 export(recode_to_binary)
 export(scale_color_tntp)
 export(scale_colour_tntp)
@@ -41,3 +43,4 @@ importFrom(formattable,percent)
 importFrom(ggplot2,"%+replace%")
 importFrom(ggplot2,theme_minimal)
 importFrom(magrittr,"%>%")
+importFrom(rlang,`%||%`)

NEWS.md

@@ -1,4 +1,17 @@
+
+# tntpr 1.1.0
+
+* Added choose_text_color() function.
+
+* Added position_diverge() function.
+
+* Adjusted title and legend positioning in tntp_style() to align to the left
+  edge of the image rather than the left edge of the coordinate plane
+
+* Added yb_* and top2b_* palettes to tntp_palette() functions
+
 # tntpr 1.0.3
+
 * Bug fix for tntp_cred_list()
 
 # tntpr 1.0.0

R/position_diverge.R

@@ -0,0 +1,195 @@
+
+
+#' Easy Diverging Bar Charts
+#'
+#' This is a modification of `ggplot2::position_stack()` for creating diverging
+#' bar charts. In order to use this function, you *must* set a fill aesthetic
+#' (and that aesthetic should probably be a factor). This function will
+#' automatically break your chart into negative and positive values and display
+#' them in the same order as your fill levels.
+#'
+#' @md
+#'
+#' @param vjust Vertical adjustment for geoms that have a position (like text or points), not a dimension (like bars or areas). Set to 0 to align with the bottom, 0.5 for the middle, and 1 (the default) for the top.
+#' @param break_after Either an integer index or character value that represents the last positive level. The default, `NULL`, will split the levels halfway (with fewer positive levels if the total number of levels is odd).
+#' @param fill If `TRUE` will automatically scale bars to 100% as with `position_fill()`
+#' @param reverse If `TRUE`, will reverse the default stacking order.
+#'
+#' @importFrom rlang `%||%`
+#' @export
+#'
+#' @examples
+#' library(ggplot2)
+#'
+#' # Example data
+#' test_df <- tibble::tribble(
+#'   ~q,  ~response,  ~prop,
+#'   'a', 'Yes',      0.25,
+#'   'a', 'Mostly',   0.25,
+#'   'a', 'Somewhat', 0.25,
+#'   'a', 'Not Yet',  0.25,
+#'   'b', 'Yes',      0.4,
+#'   'b', 'Mostly',   0.3,
+#'   'b', 'Somewhat', 0.2,
+#'   'b', 'Not Yet',  0.1
+#'   ) |>
+#'   dplyr::mutate(
+#'     response = forcats::fct_inorder(response),
+#'     q = forcats::fct_inorder(q)
+#'   )
+#'
+#' # Default diverging with text
+#' # In interactive use, this can also be run with `position = "diverge"`
+#'
+#' test_df |>
+#'   ggplot(aes(prop, q, fill = response)) +
+#'   geom_col(position = position_diverge()) +
+#'   geom_text(aes(label = scales::percent(prop,)),
+#'             position = position_diverge(vjust = 0.5)) +
+#'   geom_vline(xintercept = 0) +
+#'   tntp_style(family = "sans") +
+#'   # Reverse legend to match horizontal bar order
+#'   guides(fill = guide_legend(reverse = TRUE)) +
+#'   # Adjust axis labels to be positive on both sides
+#'   scale_x_continuous(labels = ~scales::percent(abs(.)))
+#'
+#' # Custom breaks with the break_after parameter
+#' test_df |>
+#'   ggplot(aes(q, prop, fill = response)) +
+#'   geom_col(position = position_diverge(break_after = 'Yes')) +
+#'   geom_hline(yintercept = 0) +
+#'   tntp_style(family = "sans") +
+#'   # Adjust axis labels to be positive on both sides
+#'   scale_y_continuous(labels = ~scales::percent(abs(.)))
+#'
+position_diverge <- function(vjust = 1, break_after = NULL, fill = FALSE,
+                             reverse = FALSE) {
+  ggplot2::ggproto(NULL, PositionDiverge, vjust = vjust,
+                   break_after = break_after, fill = fill, reverse = reverse)
+}
+
+PositionDiverge <- ggplot2::ggproto("PositionDiverge", ggplot2::PositionStack,
+  break_after = NULL,
+
+  # This doesn't seem to work?
+  required_aes = "fill",
+
+  setup_params = function(self, data) {
+    # Copied from PositionStack
+    flipped_aes <- ggplot2::has_flipped_aes(data)
+    data <- ggplot2::flip_data(data, flipped_aes)
+
+    # New
+    # Check lvls
+    if (is.factor(data$fill)) {
+      lvls <- levels(data$fill)
+    } else if(!is.null(data$fill)) {
+      lvls <- sort(unique(data$fill))
+      cli::cli_inform(c(
+        "i" = "For best results, use a factor for the {.var fill} aesthetic with `position_diverge()`"
+      ))
+    } else {
+      cli::cli_abort(c(
+        "x" = "`position_diverge()` requires a provided {.var fill} aesthetic."
+      ))
+    }
+
+    # Use length over 2 if break_after isn't provided
+    break_after <- self$break_after %||% floor(length(lvls) / 2)
+
+    # Parse character provision of break_after
+    if(is.character(break_after)) {
+      char <- break_after
+      break_after <- which(lvls == break_after)
+      # If value isn't found
+      if(length(break_after) == 0) {
+        cli::cli_abort(c("x" = "Provided break_after level {.val {char}} not found in the levels for the fill variable",
+                         "i" = "Fill variable levels are {.val {lvls}}"))
+      }
+    }
+
+    list(
+      # From PositionStack
+      var = self$var %||% ggplot2:::stack_var(data),
+      fill = self$fill,
+      vjust = self$vjust,
+      reverse = self$reverse,
+      flipped_aes = flipped_aes,
+      # New
+      break_after = break_after,
+      lvls = lvls
+    )
+  },
+
+  compute_panel = function(data, params, scales) {
+    data <- ggplot2::flip_data(data, params$flipped_aes)
+
+    # Check/adjust for data positivity
+    y_vals <- intersect(c("y", "ymin", "ymax"), names(data))
+    if (any(unlist(data[y_vals]) < 0)) {
+      cli::cli_warn(c(
+        "!" = "Data contains negative plotting values.",
+        "i" = "Values have been coerced to positive for plotting with `position_diverge()`"
+        ))
+
+      data[y_vals] <- lapply(data[y_vals], abs)
+    }
+
+    # Store original data order
+    data$order <- seq_len(nrow(data))
+
+    # Order data temporarily, reversing if needed
+    if (params$reverse) {
+      data <- dplyr::arrange(data, x, fill)
+      break_lvls <- params$lvls[1:params$break_after]
+    } else {
+      data <- dplyr::arrange(data, x, desc(fill))
+      break_lvls <- params$lvls[(params$break_after + 1):length(params$lvls)]
+    }
+
+    # Stack ymax
+    data$ymax <- data$ymax |>
+      split(data$x) |>
+      lapply(cumsum) |>
+      unlist()
+
+    # Scale (if fill = TRUE)
+    if (params$fill) {
+      data$ymax <- data$ymax |>
+        split(data$x) |>
+        lapply(\(v) v / max(v)) |>
+        unlist()
+    }
+
+    # Set ymin
+    data$ymin <- data$ymax |>
+      split(data$x) |>
+      lapply(\(v) c(0, v[-length(v)])) |>
+      unlist()
+
+    # Set y, adjusting for vjust
+    data$y <- data$ymin + params$vjust * (data$ymax - data$ymin)
+
+    # Break at break_after
+    data <- data |>
+      split(~x) |>
+      lapply(\(df) {
+        if (any(df$fill %in% break_lvls)) {
+          b_max <- max(df$ymax[df$fill %in% break_lvls])
+        } else {
+          b_max <- 0
+        }
+        df[c("ymax", "ymin", "y")] <- df[c("ymax", "ymin", "y")] - b_max
+        df
+      }) |>
+      do.call(rbind, args = _)
+
+    # Restore original order
+    data <- data[order(data$order), ]
+    data$order <- NULL
+
+    # Return data (flipped back if necessary)
+    ggplot2::flip_data(data, params$flipped_aes)
+  }
+
+)

R/tntp_colors.R

@@ -149,15 +149,73 @@ is_color <- function(x) {
   return(!"try-error" %in% class(res))
 }
 
-#' Choose a text color given a background color
+#' Get contrasting text colors for fills
 #'
-#' @param bg_color a color
+#' Get appropriate high-contrast text colors for a vector of background colors.
+#' This function uses the W3C contrast ratio guidance (through the
+#' `colorspace::contrast_ratio()` function) to determine the contrast,
+#' and will raise an error if no high-enough contrast colors can be found.
 #'
-#' @returns "black" or "white"
-choose_text_color <- function(bg_color) {
-  stopifnot(is_color(bg_color))
-  ifelse(colSums(grDevices::col2rgb(bg_color) * c(.299, .587, .114)) > 150,
-     "black", "white")
+#' By default, this function uses black and white as the text color options,
+#' however custom text color options can be set with the `text_colors`
+#' argument.
+#'
+#' @param bg_color a vector of colors to be used as background colors
+#' @param text_colors a vector of options for text colors. Defaults to "black" and "white"
+#' @param min_ratio Minimum contrast ratio. By default this is set to 4.5, the WCAG recommendation for regular text.
+#'
+#' @md
+#'
+#' @returns a vector of text colors the same length as `bg_color`.
+#' @export
+#' @examples
+#'
+#' library(ggplot2)
+#'
+#' fills <- tntp_palette("top2_5")
+#'
+#' diamonds |>
+#'   dplyr::summarize(m = mean(price), .by = cut) |>
+#'   ggplot(aes(cut, m, fill = cut)) +
+#'   geom_col() +
+#'   geom_text(aes(label = scales::dollar(m), color = cut), vjust = 1.5) +
+#'   scale_fill_manual(values = fills, guide = "none") +
+#'   scale_color_manual(values = choose_text_color(fills), guide = "none") +
+#'   tntp_style(family = "sans")
+#'
+choose_text_color <- function(bg_color, text_colors = c("black", "white"),
+                              min_ratio = 4.5) {
+  # Argument validation
+  if (!is_color(bg_color)) {
+    bad_colors <- bg_color[!sapply(bg_color, is_color)]
+    cli::cli_abort(
+      "{.arg bg_color} must be a vector of colors.",
+      "i" = "{.val {bad_colors}} {?is not a valid color/are not valid colors}."
+    )
+  }
+  if (!is_color(text_colors)) {
+    bad_colors <- text_colors[!sapply(text_colors, is_color)]
+    cli::cli_abort(
+      "{.arg text_colors} must be a vector of colors.",
+      "i" = "{.val {bad_colors}} {?is not a valid color/are not valid colors}."
+    )
+  }
+  if (is.null(text_colors) || length(text_colors) == 0) cli::cli_abort("No text colors provided")
+  if (is.null(bg_color)) return(NULL)
+
+  highest_contrast <- function(bg_col, text_colors) {
+    con <- sapply(text_colors, \(x) colorspace::contrast_ratio(bg_col, x))
+    if (max(con) < min_ratio) {
+      cli::cli_abort(c(
+        "No high-contrast text color options found for {.val {bg_col}}",
+        "i" = "Max contrast is {.val {round(max(con), 2)}}, which is less than the {.var min_ratio} value of {.val {min_ratio}}"
+      ))
+    }
+    text_colors[[which.max(con)]]
+  }
+
+  sapply(bg_color, \(bg_col) highest_contrast(bg_col, text_colors),
+         USE.NAMES = FALSE)
 }
 
 
@@ -243,6 +301,10 @@ tntp_palette_list <- list(
   "top2_5" = tntp_colors("medium_gray", "gray_2", "gray", "green", "dark_green"),
   "top2_6" = tntp_colors("gray_4", "medium_gray", "gray_2", "gray", "green", "dark_green"),
   "top2_7" = tntp_colors("charcoal", "gray_4", "medium_gray", "gray_2", "gray", "green", "dark_green"),
+  "yb_4" = tntp_colors("dark_gold", "gold", "cerulean", "navy"),
+  "yb_5" = tntp_colors("dark_gold", "gold", "gray_2", "cerulean", "navy"),
+  "yb_6" = tntp_colors("dark_gold", "gold", "yellow", "sky", "cerulean", "navy"),
+  "yb_7" = tntp_colors("dark_gold", "gold", "yellow", "gray_2", "sky", "cerulean", "navy"),
   "rb_4" = tntp_colors("dark_red", "red", "cerulean", "navy"),
   "rb_5" = tntp_colors("dark_red", "red", "gray_2", "cerulean", "navy"),
   "rb_6" = tntp_colors("dark_red", "red", "salmon", "sky", "cerulean", "navy"),
@@ -251,6 +313,10 @@ tntp_palette_list <- list(
   "bg_5" = tntp_colors("navy", "cerulean", "gray_2", "green", "dark_green"),
   "bg_6" = tntp_colors("navy", "cerulean", "sky", "moss", "green", "dark_green"),
   "bg_7" = tntp_colors("navy", "cerulean", "sky", "gray_2", "moss", "green", "dark_green"),
+  "top2b_4" = tntp_colors("gray_2", "gray", "cerulean", "navy"),
+  "top2b_5" = tntp_colors("medium_gray", "gray_2", "gray", "cerulean", "navy"),
+  "top2b_6" = tntp_colors("gray_4", "medium_gray", "gray_2", "gray", "cerulean", "navy"),
+  "top2b_7" = tntp_colors("charcoal", "gray_4", "medium_gray", "gray_2", "gray", "cerulean", "navy"),
   "greens" = tntp_colors("green", "green_4", "medium_green", "green_2", "light_green"),
   "reds" = tntp_colors("red", "red_4", "medium_red", "red_2", "light_red"),
   "blues" = tntp_colors("blue", "blue_4", "medium_blue", "blue_2", "light_blue"),

R/tntp_style.R

@@ -111,7 +111,7 @@ get_usable_family <- function(family, silent = FALSE, default_family = "sans") {
 #'   ) +
 #'   scale_y_continuous(breaks = seq(0, 20, 4)) +
 #'   tntp_style(
-#'     family = 'sans',
+#'     family = "sans",
 #'     base_size = 20,
 #'     show_axis_titles = "x"
 #'   )
@@ -255,9 +255,11 @@ tntp_style <- function(family = "Halyard Display",
       face = "italic",
       color = caption_color
     ),
+    plot.title.position = "plot",
 
     # Style legend, including alignment
     legend.position = "top",
+    legend.location = "plot",
     legend.justification = legend_align,
     legend.direction = "horizontal",
     legend.text.align = 0,