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