diff --git a/NAMESPACE b/NAMESPACE index c1c0207..0909257 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -15,6 +15,7 @@ importFrom(ggplot2,geom_segment) importFrom(ggplot2,geom_text) importFrom(rlang,"!!") importFrom(rlang,enquo) +importFrom(rlang,sym) importFrom(stats,as.formula) importFrom(tidyr,gather) importFrom(utils,modifyList) diff --git a/R/geom_scatterpie.R b/R/geom_scatterpie.R index adae9c8..3e038e5 100644 --- a/R/geom_scatterpie.R +++ b/R/geom_scatterpie.R @@ -9,6 +9,12 @@ ##' @param sorted_by_radius whether plotting large pie first ##' @param legend_name name of fill legend ##' @param long_format logical whether use long format of input data +##' @param label_radius numeric the radius of label position (relative the radius of pie), +##' default is NULL, when it is provided, the ratio or value label will be displayed. +##' @param label_show_ratio logical only work when \code{label_radius} is not NULL, +##' default is TRUE, meaning the ratio of label will be displayed. +##' @param label_threshold numeric the threshold is to control display the label, the ratio of +##' slice pie smaller than the threshold will not be displayed. default is 0. ##' @param donut_radius numeric the radius of donut chart (relative the radius of circle), default is NULL. ##' it should be between 0 and 1, if it is provided, the donut chart will be displayed instead of pie chart. ##' @param bg_circle_radius numeric the radius of background circle, default is FALSE, we suggest setting it @@ -25,13 +31,27 @@ ##' @importFrom dplyr bind_rows group_by group_split ##' @export ##' @return layer +##' @author Guangchuang Yu ##' @examples ##' library(ggplot2) ##' d <- data.frame(x=rnorm(5), y=rnorm(5)) ##' d$A <- abs(rnorm(5, sd=1)) ##' d$B <- abs(rnorm(5, sd=2)) ##' d$C <- abs(rnorm(5, sd=3)) -##' ggplot() + geom_scatterpie(aes(x=x, y=y), data=d, cols=c("A", "B", "C")) + coord_fixed() +##' +##' ggplot() + +##' geom_scatterpie( +##' aes(x=x, y=y), data=d, cols=c("A", "B", "C") +##' ) + +##' coord_fixed() +##' +##' ggplot() + +##' geom_scatterpie( +##' aes(x=x, y=y), data = d, cols=c("A", "B", "C"), +##' label_radius=1.05 +##' ) + +##' coord_fixed() +##' ##' d <- tidyr::gather(d, key="letters", value="value", -x:-y) ##' ggplot() + geom_scatterpie(aes(x=x, y=y), data=d, cols="letters", long_format=TRUE) + coord_fixed() ##' p1 <- ggplot() + @@ -61,11 +81,24 @@ ##' long_format=TRUE, donut_radius=.5, color = NA, linewidth=2, ##' bg_circle_radius=1.2) + coord_fixed() ##' p3 -##' -##' @author Guangchuang Yu -geom_scatterpie <- function(mapping=NULL, data, cols, pie_scale = 1, +##' +##' p4 <- ggplot() + +##' geom_scatterpie(data = d3, +##' mapping = aes(x, y = y, r = r_size), +##' cols = 'letters', +##' long_format = TRUE, +##' label_radius = 1.1, +##' label_show_ratio = FALSE, +##' label_threshold = 0.06, +##' fontsize = 3 +##' ) + +##' coord_fixed() +##' p4 +geom_scatterpie <- function(mapping = NULL, data, cols, pie_scale = 1, sorted_by_radius = FALSE, legend_name = "type", - long_format=FALSE, donut_radius=NULL, bg_circle_radius=NULL, ...) { + long_format = FALSE, label_radius = NULL, + label_show_ratio = TRUE, label_threshold = 0, + donut_radius = NULL, bg_circle_radius = NULL, ...){ if (is.null(mapping)) mapping <- aes_(x = ~x, y = ~y) mapping <- modifyList(mapping, @@ -106,12 +139,7 @@ geom_scatterpie <- function(mapping=NULL, data, cols, pie_scale = 1, df$type <- factor(df$type, levels = cols) # set legend order based on order of "cols" names(df)[which(names(df) == "type")] = legend_name } - ## df <- gather_(data, "type", "value", cols) - # cols2 <- enquo(cols) - # df <- gather(data, "type", "value", !!cols2) - # names(df)[which(names(df) == "type")] = legend_name - - ## df$type <- factor(df$type, levels=cols) + if (!"group" %in% names(mapping)){ xvar <- get_aes_var(mapping, 'x0') yvar <- get_aes_var(mapping, 'y0') @@ -129,24 +157,29 @@ geom_scatterpie <- function(mapping=NULL, data, cols, pie_scale = 1, } if (!sorted_by_radius) { - pie.layer <- geom_arc_bar(mapping, data=df, stat='pie', inherit.aes=FALSE, ...) + pie.layer <- .build_pie_layer(df, mapping, ...) if (!is.null(bg_circle_radius)){ circle.layer <- .add_circle_layer(data = df, mapping = mapping, rvar = rvar, bg_circle_radius = bg_circle_radius, ...) pie.layer <- list(circle.layer, pie.layer) } + pie.layer <- .add_label_layer(pie.layer, df, mapping, label_radius, + label_show_ratio, label_threshold, + bg_circle_radius, ...) return(pie.layer) } lapply(split(df, df[,rvar, drop=TRUE])[as.character(sort(unique(df[,rvar, drop=TRUE]), decreasing=TRUE))], function(d) { - pie.layer <- geom_arc_bar(mapping, data=d, stat='pie', inherit.aes=FALSE, ...) + pie.layer <- .build_pie_layer(d, mapping, ...) if (!is.null(bg_circle_radius)){ circle.layer <- .add_circle_layer(data = d, mapping = mapping, rvar = rvar, bg_circle_radius = bg_circle_radius, ...) pie.layer <- list(circle.layer, pie.layer) } + pie.layer <- .add_label_layer(pie.layer, d, mapping, label_radius, + label_show_ratio, label_threshold, bg_circle_radius, ...) return(pie.layer) } ) diff --git a/R/utilities.R b/R/utilities.R index ae4a955..6d81b69 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -17,6 +17,21 @@ is_fixed_radius <- function(rvar) { return(TRUE) } + +.build_pie_layer <- function(data, mapping, ...){ + params <- list(...) + if ("label" %in% names(mapping)){ + mapping[['label']] <- NULL + } + params <- params[!names(params) %in% c("fontsize", "fontface", "fontfamily")] + params$data <- data + params$mapping <- mapping + params$stat <- "pie" + params$inherit.aes <- FALSE + x <- do.call(geom_arc_bar, params) + return(x) +} + .add_circle_layer <- function(data, mapping, rvar, bg_circle_radius, ...){ mapping.circle <- mapping[names(mapping) %in% c('x0', 'y0', 'r', 'color', 'colour')] dt <- .extract_mapping_df(data, mapping, extract_aes = c('x0', 'y0', 'color', 'colour'), col_var = rvar) @@ -54,3 +69,93 @@ is_fixed_radius <- function(rvar) { } return(params) } + +.build_data_for_label <- function(x, threshold, var = 'value', r = "r", rlabel = 1.05){ + end_angle <- 2 * pi * cumsum(x[[var]])/sum(x[[var]]) + start_angle <- dplyr::lag(end_angle, default = 0) + mid_angle <- 0.5 * (start_angle + end_angle) + x[[".RATIO"]] <- round(x[[var]]/sum(x[[var]]), 2) + x[[var]] <- round(x[[var]], 2) + x[['.RATIO']] <- ifelse(x[['.RATIO']] < threshold, NA, x[[".RATIO"]]) + x[[var]] <- ifelse(x[['.RATIO']] < threshold, NA, x[[var]]) + x[['hjust']] <- ifelse(mid_angle > pi, 1, 0) + x[['vjust']] <- ifelse(mid_angle < pi/2 | mid_angle > 3 * pi/2, 0, 1) + x[['x']] <- rlabel * x[[r]] * sin(mid_angle) + x[['x']] + x[['y']] <- rlabel * x[[r]] * cos(mid_angle) + x[['y']] + return(x) +} + +#' @importFrom rlang sym +.set_lab_mapping <- function(mapping, label_radius, label_show_ratio, bg_circle_radius){ + lab.default <- aes(x=!!sym("x"), y=!!sym("y"), hjust=!!sym("hjust"), vjust=!!sym("vjust")) + lab.mapping <- NULL + if (!is.null(label_radius)){ + if (!label_show_ratio){ + lab.mapping = aes(label = !!sym("value")) + }else{ + lab.mapping <- aes(label = !!sym(".RATIO")) + } + lab.mapping <- modifyList(lab.default, lab.mapping) + } + + if ("label" %in% names(mapping)){ + if (is.null(label_radius)) label_radius <- 1.06 + lab.mapping <- mapping['label'] + lab.mapping <- modifyList(lab.default, lab.mapping) + } + + if (any(c('color', 'colour') %in% names(mapping)) && is.null(bg_circle_radius) && !is.null(lab.mapping)){ + lab.mapping <- modifyList(lab.mapping, mapping['color'] %|aes|% mapping['colour']) + } + return(list(mapping=lab.mapping, rlabel=label_radius)) +} + +.add_label_layer <- function(pie, data, mapping, label_radius, + label_show_ratio, label_threshold, + bg_circle_radius, ...){ + val <- get_aes_var(mapping, 'amount') + r.aes <- get_aes_var(mapping, 'r') + dot.params <- list(...) + params <- list() + res1 <- .set_lab_mapping(mapping, label_radius, label_show_ratio, bg_circle_radius) + + if (is.null(res1$mapping)){ + return(pie) + } + group.var <- get_aes_var(mapping, 'group') + params$data <- split(data, data[[group.var]]) |> + lapply(function(x).build_data_for_label(x, threshold=label_threshold, + var=val, r=r.aes, rlabel = res1$rlabel)) |> + dplyr::bind_rows() + params$mapping <- res1$mapping + params$inherit.aes <- FALSE + if (!is.null(bg_circle_radius)){ + params$show.legend <- FALSE + } + dot.params <- .extract_label_dot_params(dot.params) + text.layer <- do.call('geom_text', c(params, dot.params)) + return(list(pie, text.layer)) +} + + + +`%|aes|%` <- function(a, b){ + if (!is.null(a[[1]])) + a + else b +} + +.extract_label_dot_params <- function(x){ + nm1 <- c("size", "family", "fontface") + nm2 <- c("fontsize", "fontfamily", "fontface") + indx <- match(nm2, names(x)) + indx <- indx[!is.na(indx)] + if (length(indx)==0){ + return(NULL) + } + x <- x[indx] + indx <- match(names(x), nm2) + names(x) <- nm1[indx] + return(x) +} + diff --git a/man/geom_scatterpie.Rd b/man/geom_scatterpie.Rd index 76f0a32..e263842 100644 --- a/man/geom_scatterpie.Rd +++ b/man/geom_scatterpie.Rd @@ -12,6 +12,9 @@ geom_scatterpie( sorted_by_radius = FALSE, legend_name = "type", long_format = FALSE, + label_radius = NULL, + label_show_ratio = TRUE, + label_threshold = 0, donut_radius = NULL, bg_circle_radius = NULL, ... @@ -32,6 +35,15 @@ geom_scatterpie( \item{long_format}{logical whether use long format of input data} +\item{label_radius}{numeric the radius of label position (relative the radius of pie), +default is NULL, when it is provided, the ratio or value label will be displayed.} + +\item{label_show_ratio}{logical only work when \code{label_radius} is not NULL, +default is TRUE, meaning the ratio of label will be displayed.} + +\item{label_threshold}{numeric the threshold is to control display the label, the ratio of +slice pie smaller than the threshold will not be displayed. default is 0.} + \item{donut_radius}{numeric the radius of donut chart (relative the radius of circle), default is NULL. it should be between 0 and 1, if it is provided, the donut chart will be displayed instead of pie chart.} @@ -52,7 +64,20 @@ d <- data.frame(x=rnorm(5), y=rnorm(5)) d$A <- abs(rnorm(5, sd=1)) d$B <- abs(rnorm(5, sd=2)) d$C <- abs(rnorm(5, sd=3)) -ggplot() + geom_scatterpie(aes(x=x, y=y), data=d, cols=c("A", "B", "C")) + coord_fixed() + +ggplot() + +geom_scatterpie( + aes(x=x, y=y), data=d, cols=c("A", "B", "C") +) + +coord_fixed() + +ggplot() + +geom_scatterpie( + aes(x=x, y=y), data = d, cols=c("A", "B", "C"), + label_radius=1.05 +) + +coord_fixed() + d <- tidyr::gather(d, key="letters", value="value", -x:-y) ggplot() + geom_scatterpie(aes(x=x, y=y), data=d, cols="letters", long_format=TRUE) + coord_fixed() p1 <- ggplot() + @@ -83,6 +108,18 @@ p3 <- ggplot() + bg_circle_radius=1.2) + coord_fixed() p3 +p4 <- ggplot() + + geom_scatterpie(data = d3, + mapping = aes(x, y = y, r = r_size), + cols = 'letters', + long_format = TRUE, + label_radius = 1.1, + label_show_ratio = FALSE, + label_threshold = 0.06, + fontsize = 3 + ) + + coord_fixed() +p4 } \author{ Guangchuang Yu