1#' @inheritParams layer 2#' @inheritParams geom_point 3#' @inheritParams stat_density 4#' @param scale if "area" (default), all violins have the same area (before trimming 5#' the tails). If "count", areas are scaled proportionally to the number of 6#' observations. If "width", all violins have the same maximum width. 7#' @section Computed variables: 8#' \describe{ 9#' \item{density}{density estimate} 10#' \item{scaled}{density estimate, scaled to maximum of 1} 11#' \item{count}{density * number of points - probably useless for violin plots} 12#' \item{violinwidth}{density scaled for the violin plot, according to area, counts 13#' or to a constant maximum width} 14#' \item{n}{number of points} 15#' \item{width}{width of violin bounding box} 16#' } 17#' @seealso [geom_violin()] for examples, and [stat_density()] 18#' for examples with data along the x axis. 19#' @export 20#' @rdname geom_violin 21stat_ydensity <- function(mapping = NULL, data = NULL, 22 geom = "violin", position = "dodge", 23 ..., 24 bw = "nrd0", 25 adjust = 1, 26 kernel = "gaussian", 27 trim = TRUE, 28 scale = "area", 29 na.rm = FALSE, 30 orientation = NA, 31 show.legend = NA, 32 inherit.aes = TRUE) { 33 scale <- match.arg(scale, c("area", "count", "width")) 34 35 layer( 36 data = data, 37 mapping = mapping, 38 stat = StatYdensity, 39 geom = geom, 40 position = position, 41 show.legend = show.legend, 42 inherit.aes = inherit.aes, 43 params = list( 44 bw = bw, 45 adjust = adjust, 46 kernel = kernel, 47 trim = trim, 48 scale = scale, 49 na.rm = na.rm, 50 ... 51 ) 52 ) 53} 54 55 56#' @rdname ggplot2-ggproto 57#' @format NULL 58#' @usage NULL 59#' @export 60StatYdensity <- ggproto("StatYdensity", Stat, 61 required_aes = c("x", "y"), 62 non_missing_aes = "weight", 63 64 setup_params = function(data, params) { 65 params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = TRUE, group_has_equal = TRUE) 66 67 params 68 }, 69 70 extra_params = c("na.rm", "orientation"), 71 72 compute_group = function(data, scales, width = NULL, bw = "nrd0", adjust = 1, 73 kernel = "gaussian", trim = TRUE, na.rm = FALSE, flipped_aes = FALSE) { 74 if (nrow(data) < 2) { 75 warn("Groups with fewer than two data points have been dropped.") 76 return(new_data_frame()) 77 } 78 range <- range(data$y, na.rm = TRUE) 79 modifier <- if (trim) 0 else 3 80 bw <- calc_bw(data$y, bw) 81 dens <- compute_density(data$y, data$w, from = range[1] - modifier*bw, to = range[2] + modifier*bw, 82 bw = bw, adjust = adjust, kernel = kernel) 83 84 dens$y <- dens$x 85 dens$x <- mean(range(data$x)) 86 87 # Compute width if x has multiple values 88 if (length(unique(data$x)) > 1) { 89 width <- diff(range(data$x)) * 0.9 90 } 91 dens$width <- width 92 93 dens 94 }, 95 96 compute_panel = function(self, data, scales, width = NULL, bw = "nrd0", adjust = 1, 97 kernel = "gaussian", trim = TRUE, na.rm = FALSE, 98 scale = "area", flipped_aes = FALSE) { 99 data <- flip_data(data, flipped_aes) 100 data <- ggproto_parent(Stat, self)$compute_panel( 101 data, scales, width = width, bw = bw, adjust = adjust, kernel = kernel, 102 trim = trim, na.rm = na.rm 103 ) 104 105 # choose how violins are scaled relative to each other 106 data$violinwidth <- switch(scale, 107 # area : keep the original densities but scale them to a max width of 1 108 # for plotting purposes only 109 area = data$density / max(data$density), 110 # count: use the original densities scaled to a maximum of 1 (as above) 111 # and then scale them according to the number of observations 112 count = data$density / max(data$density) * data$n / max(data$n), 113 # width: constant width (density scaled to a maximum of 1) 114 width = data$scaled 115 ) 116 data$flipped_aes <- flipped_aes 117 flip_data(data, flipped_aes) 118 } 119 120) 121 122calc_bw <- function(x, bw) { 123 if (is.character(bw)) { 124 if (length(x) < 2) 125 abort("need at least 2 points to select a bandwidth automatically") 126 bw <- switch( 127 to_lower_ascii(bw), 128 nrd0 = stats::bw.nrd0(x), 129 nrd = stats::bw.nrd(x), 130 ucv = stats::bw.ucv(x), 131 bcv = stats::bw.bcv(x), 132 sj = , 133 `sj-ste` = stats::bw.SJ(x, method = "ste"), 134 `sj-dpi` = stats::bw.SJ(x, method = "dpi"), 135 abort("unknown bandwidth rule") 136 ) 137 } 138 bw 139} 140