Merge pull request #49 from xiangpin/master

supporting add label for each slice of pie

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)

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)
       }
    )

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)
+}
+