R/gg_tabular_comparison.R

In sarid-ins/saridr: An R package for common tasks related to market research analysis via R

#' Generates a ggplot with tiles and tables according to averages (i.e., conditional formatting)
#'
#' @description Inspired by Excel's conditional formatting, the function generates a ggplot object similar to what an excel conditional formatted table would produce when comparing averages.
#' This is particularly useful when comparing a lot of measures between a number of organizational units or services.
#' The measures would appear in rows, organizational units in columns, values in cells.
#' Coloring of cells can be specified (either within the row or within the column).
#'
#' @param x a tbl() with raw data
#' @param grouping_var grouping variable by which averages are computed
#' @param scaling_by by which variable should scaling be performed (either grouping or measure)
#' @param color_gradient the minimum and maximum colors in the gradient
#' @param overall_average_title The title used to described the overall average
#' @param small_sample_warning no coloring applies for cells with sample under specified number (use 0 to disable)
#' @param top_down_mark How many top/bottom observations should be indicated. Use 0 for none, 1 for first and last.
#' @param top_down_emoji What emoji should be used to indicate top/bottom observations. Defaults to c("V", "X") but can also be used as emojis
#' @param top_down_color What colors should be used to indiate top/bottom observations.
#' @param top_down_nudge What should the text/emoji be nudged by (nudge_x of the geom_text function).
#' @param top_down_size The text/emoji's size.
#'
#' @return A ggplot2 object
#'
#' @examples
#' tib <- tibble::tribble(~department, ~quality, ~quantity, ~performance,
#'                        "HR", 5, 3, 3,
#'                        "HR", NA, 2, 5,
#'                        "HR", 5, 5, 4,
#'                        "Marketing", 4, 2, 2,
#'                        "Marketing", 5, NA, 4,
#'                        "Marketing", 3, 4, 4,
#'                        "Financials", 2, 2, 4,
#'                        "Financials", 4, 2, 5,
#'                        "Sales", 5, 4, 4
#'                        )
#' gg_tabular_comparison(tib, grouping_var = department, small_sample_warning = 0)
#' gg_tabular_comparison(tib, grouping_var = department, small_sample_warning = 2) +
#'   scale_fill_gradient(low = "red", high = "blue", na.value = "gray")
#'
#' @export
gg_tabular_comparison <- function(x, grouping_var,
                                  scaling_by = c("grouping", "measure"),
                                  color_gradient = c("#FEE08B", "#1A9850"),
                                  overall_average_title = "Average",
                                  small_sample_warning = 15,
                                  top_down_mark = 1,
                                  top_down_emoji = c("V", "X"),
                                  top_down_color = c("blue", "red"),
                                  top_down_nudge = 0.5,
                                  top_down_size = 5){

  if (top_down_mark == 0){
    warning('Top down emojis are disabled (top_down_mark == 0).')
  }

  # create overall averages
  overall_averages <- x %>%
    dplyr::ungroup() %>%
    dplyr::select(-{{grouping_var}}) %>%
    tidyr::pivot_longer(cols = dplyr::everything(), names_to = "measure", values_to = "rank") %>%
    dplyr::group_by(measure) %>%
    dplyr::summarize(average = mean(rank, na.rm = T),
              sample_size = sum(!is.na(rank))) %>%
    dplyr::arrange(average) %>%
    dplyr::mutate(measure = forcats::fct_inorder(measure)) %>%
    dplyr::mutate(scaled_avgs = NA) %>%
    dplyr::mutate({{grouping_var}} := overall_average_title)

  # specific averages

  specific_averages <- x %>%
    tidyr::pivot_longer(cols = -{{grouping_var}}, names_to = "measure", values_to = "rank") %>%
    dplyr::group_by({{grouping_var}}, measure) %>%
    dplyr::summarize(average = mean(rank, na.rm = T),
              sample_size = sum(!is.na(rank)))

  # scaling (used for coloring)

  if (scaling_by[1] == "measure"){
    specific_averages <- specific_averages %>%
      dplyr::group_by({{grouping_var}})
    } else if (scaling_by[1] == "grouping"){

    specific_averages <- specific_averages %>%
      dplyr::group_by(measure)

  } else {
    stop('Error: scaling_by invalid. Choose "grouping" or "measure".')
  }

  specific_averages <- specific_averages %>%
    dplyr::mutate(scaled_avgs = scale(average)[, 1]) %>%
    dplyr::mutate(scaled_avgs = ifelse(sample_size <= small_sample_warning,
                                       NA,
                                       scaled_avgs))

  # add overall averages and invalidate coloring according to sample_size_warning

  averages_with_total <- specific_averages %>%
    dplyr::ungroup() %>%
    dplyr::mutate(measure = factor(measure, levels = overall_averages$measure)) %>%
    dplyr::bind_rows(overall_averages) %>%
    dplyr::mutate({{grouping_var}} :=
                    forcats::fct_relevel({{grouping_var}},
                                         overall_average_title,
                                         after = Inf))

  # create the chart

  final_plot <- ggplot2::ggplot(averages_with_total, ggplot2::aes(x = {{grouping_var}}, y = measure,
                                  fill = scaled_avgs, label = round(average, 2))) +
    ggplot2::geom_tile() +
    ggplot2::geom_text() +
    ggplot2::scale_fill_gradient(low = color_gradient[1],
                        high = color_gradient[2],
                        na.value = "white") +
    saridr::theme_sarid() +
    ggplot2::xlab("") +
    ggplot2::ylab("") +
    ggplot2::theme(legend.position = "none")


  # add text indications on top/bottom if required by user
  if (top_down_mark > 0){
    specific_averages_top <- specific_averages %>%
      dplyr::top_n(n = top_down_mark, wt = scaled_avgs) %>%
      dplyr::mutate(top_down_label = top_down_emoji[1]) %>%
      dplyr::mutate(top_down_label_type = "top")
    specific_averages_bottom <- specific_averages %>%
      dplyr::top_n(n = -top_down_mark, wt = scaled_avgs) %>%
      dplyr::mutate(top_down_label = top_down_emoji[2]) %>%
      dplyr::mutate(top_down_label_type = "down")

    top_bottom_indication <- dplyr::bind_rows(specific_averages_top,
                                       specific_averages_bottom)

    final_plot <- final_plot +
      ggplot2::geom_text(data = top_bottom_indication, ggplot2::aes(label = top_down_label, color = top_down_label_type),
                nudge_x = top_down_nudge, size = top_down_size) +
      ggplot2::scale_color_manual(values = c("top" = top_down_color[1], "down" = top_down_color[2]))
  }



  return(final_plot)

}