From 31cfbe3bbeb7ff636d3519eefc7450360b1df164 Mon Sep 17 00:00:00 2001 From: larmarange Date: Sat, 14 May 2016 21:53:06 +0200 Subject: [PATCH] stat_fill_labels and stat_stack_labels --- DESCRIPTION | 2 ++ R/stat_fill_labels.R | 78 +++++++++++++++++++++++++++++++++++++++++++++++++++ R/stat_stack_labels.R | 66 +++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 146 insertions(+) create mode 100644 R/stat_fill_labels.R create mode 100644 R/stat_stack_labels.R diff --git a/DESCRIPTION b/DESCRIPTION index 7579be2..544ad93 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -66,5 +66,7 @@ Collate: 'guide_axis.r' 'pokemon.r' 'stateface.r' + 'stat_fill_labels.R' + 'stat_stack_labels.R' 'utils.r' 'zzz.r' diff --git a/R/stat_fill_labels.R b/R/stat_fill_labels.R new file mode 100644 index 0000000..47060ef --- /dev/null +++ b/R/stat_fill_labels.R @@ -0,0 +1,78 @@ +#' Labels position for fill position. +#' +#' Computes position of labels when using \code{position = "fill"} +#' +#' @inheritParams ggplot2::stat_count +#' @param geom Use to override the default connection between +#' \code{geom_text} and \code{stat_stack_labels}. +#' @section Computed variables: +#' \describe{ +#' \item{count}{the number of observations} +#' \item{prop}{proportion on \code{x}} +#' \item{cumprop}{the cumulative proportion on \code{x}} +#' \item{ylabel}{the y position of labels, i.e. \eqn{cumprop - prop / 2}} +#' } +#' @seealso \code{\link{stat_stack_labels}} for \code{position = "stack"}. +#' @examples +#' ggplot(as.data.frame(Titanic)) + +#' aes(x = Class, fill = Survived, weight = Freq) + +#' geom_bar(position = "fill") + stat_fill_labels() +#' ggplot(as.data.frame(Titanic)) + +#' aes(x = Class, fill = Survived, weight = Freq) + +#' geom_bar(position = "fill") + geom_label(stat = "fill_labels") +#' ggplot(as.data.frame(Titanic)) + +#' aes(x = Class, fill = Survived, weight = Freq) + +#' geom_bar(position = "fill") + geom_text(stat = "fill_labels") + facet_grid(~Sex) +#' ggplot(as.data.frame(Titanic)) + +#' aes(x = as.integer(Class), fill = Survived, weight = Freq) + +#' geom_area(position = "fill", stat = "count") + geom_text(stat = "fill_labels") +#' +#' # Cumulative percentages with dodge position +#' ggplot(as.data.frame(Titanic)) + +#' aes(x = Class, fill = Survived, weight = Freq) + +#' geom_bar(aes(y = ..prop..), stat="fill_labels", position="dodge", width = .8) + +#' geom_text( +#' aes(label = scales::percent(..prop..), y = ..prop../2), +#' stat = "fill_labels", position = position_dodge(width = .8) +#' ) +#' @export +stat_fill_labels <- function(mapping = NULL, data = NULL, geom = "text", + position = "identity", width = NULL, na.rm = FALSE, show.legend = NA, + inherit.aes = TRUE, ...) { + layer( + stat = StatFillLabels, data = data, mapping = mapping, geom = geom, + position = position, show.legend = show.legend, inherit.aes = inherit.aes, + params = list(na.rm = na.rm, ...) + ) +} + + +#' @export +StatFillLabels <- ggproto( + "StatFillLabels", + StatCount, + compute_panel = function (self, data, scales, ...) { + if (ggplot2:::empty(data)) + return(data.frame()) + groups <- split(data, data$group) + stats <- lapply(groups, function(group) { + self$compute_group(data = group, scales = scales, ...) + }) + stats <- mapply(function(new, old) { + if (ggplot2:::empty(new)) + return(data.frame()) + unique <- ggplot2:::uniquecols(old) + missing <- !(names(unique) %in% names(new)) + cbind(new, unique[rep(1, nrow(new)), missing, drop = FALSE]) + }, stats, groups, SIMPLIFY = FALSE) + data <- do.call(plyr::rbind.fill, stats) + plyr::ddply( + data, "x", plyr::mutate, + prop = count/sum(count), + cumprop = cumsum(count)/sum(count), + ylabel = (cumsum(count) - count / 2)/sum(count), + na.rm = TRUE + ) + }, + default_aes = aes(y = ..ylabel.., label = paste0(round(100 * ..prop.., digits =1), "%")) +) diff --git a/R/stat_stack_labels.R b/R/stat_stack_labels.R new file mode 100644 index 0000000..a1815fa --- /dev/null +++ b/R/stat_stack_labels.R @@ -0,0 +1,66 @@ +#' Labels position for stack position. +#' +#' Computes position of labels when using \code{position = "stack"} +#' +#' @inheritParams ggplot2::stat_count +#' @param geom Use to override the default connection between +#' \code{geom_text} and \code{stat_stack_labels}. +#' @section Computed variables: +#' \describe{ +#' \item{count}{the number of observations} +#' \item{cumcount}{the cumulative number of observations} +#' \item{ylabel}{the y position of labels, i.e. \eqn{cumcount - count / 2}} +#' } +#' @seealso \code{\link{stat_fill_labels}} for \code{position = "fill"}. +#' @examples +#' ggplot(as.data.frame(Titanic)) + +#' aes(x = Class, fill = Survived, weight = Freq) + +#' geom_bar() + stat_stack_labels() +#' ggplot(as.data.frame(Titanic)) + +#' aes(x = Class, fill = Survived, weight = Freq) + +#' geom_bar() + geom_label(stat = "stack_labels") +#' ggplot(as.data.frame(Titanic)) + +#' aes(x = Class, fill = Survived, weight = Freq) + +#' geom_bar() + stat_stack_labels() + facet_grid(~Sex) +#' ggplot(as.data.frame(Titanic)) + +#' aes(x = as.integer(Class), fill = Survived, weight = Freq) + +#' geom_area(stat = "count") + stat_stack_labels() +#' @export +stat_stack_labels <- function(mapping = NULL, data = NULL, geom = "text", + position = "identity", width = NULL, na.rm = FALSE, show.legend = NA, + inherit.aes = TRUE, ...) { + layer( + stat = StatStackLabels, data = data, mapping = mapping, geom = geom, + position = position, show.legend = show.legend, inherit.aes = inherit.aes, + params = list(na.rm = na.rm, ...) + ) +} + +#' @export +StatStackLabels <- ggproto( + "StatStackLabels", + StatCount, + compute_panel = function (self, data, scales, ...) { + if (ggplot2:::empty(data)) + return(data.frame()) + groups <- split(data, data$group) + stats <- lapply(groups, function(group) { + self$compute_group(data = group, scales = scales, ...) + }) + stats <- mapply(function(new, old) { + if (ggplot2:::empty(new)) + return(data.frame()) + unique <- ggplot2:::uniquecols(old) + missing <- !(names(unique) %in% names(new)) + cbind(new, unique[rep(1, nrow(new)), missing, drop = FALSE]) + }, stats, groups, SIMPLIFY = FALSE) + data <- do.call(plyr::rbind.fill, stats) + plyr::ddply( + data, "x", plyr::mutate, + cumcount = cumsum(count), + ylabel = cumsum(count) - count / 2, + na.rm = TRUE + ) + }, + default_aes = aes(y = ..ylabel.., label = ..count..) +)