1#' Polar coordinates
2#'
3#' The polar coordinate system is most commonly used for pie charts, which
4#' are a stacked bar chart in polar coordinates.
5#'
6#' @param theta variable to map angle to (`x` or `y`)
7#' @param start Offset of starting point from 12 o'clock in radians. Offset
8#'   is applied clockwise or anticlockwise depending on value of `direction`.
9#' @param direction 1, clockwise; -1, anticlockwise
10#' @param clip Should drawing be clipped to the extent of the plot panel? A
11#'   setting of `"on"` (the default) means yes, and a setting of `"off"`
12#'   means no. For details, please see [`coord_cartesian()`].
13#' @export
14#' @examples
15#' # NOTE: Use these plots with caution - polar coordinates has
16#' # major perceptual problems.  The main point of these examples is
17#' # to demonstrate how these common plots can be described in the
18#' # grammar.  Use with EXTREME caution.
19#'
20#' #' # A pie chart = stacked bar chart + polar coordinates
21#' pie <- ggplot(mtcars, aes(x = factor(1), fill = factor(cyl))) +
22#'  geom_bar(width = 1)
23#' pie + coord_polar(theta = "y")
24#'
25#' \donttest{
26#'
27#' # A coxcomb plot = bar chart + polar coordinates
28#' cxc <- ggplot(mtcars, aes(x = factor(cyl))) +
29#'   geom_bar(width = 1, colour = "black")
30#' cxc + coord_polar()
31#' # A new type of plot?
32#' cxc + coord_polar(theta = "y")
33#'
34#' # The bullseye chart
35#' pie + coord_polar()
36#'
37#' # Hadley's favourite pie chart
38#' df <- data.frame(
39#'   variable = c("does not resemble", "resembles"),
40#'   value = c(20, 80)
41#' )
42#' ggplot(df, aes(x = "", y = value, fill = variable)) +
43#'   geom_col(width = 1) +
44#'   scale_fill_manual(values = c("red", "yellow")) +
45#'   coord_polar("y", start = pi / 3) +
46#'   labs(title = "Pac man")
47#'
48#' # Windrose + doughnut plot
49#' if (require("ggplot2movies")) {
50#' movies$rrating <- cut_interval(movies$rating, length = 1)
51#' movies$budgetq <- cut_number(movies$budget, 4)
52#'
53#' doh <- ggplot(movies, aes(x = rrating, fill = budgetq))
54#'
55#' # Wind rose
56#' doh + geom_bar(width = 1) + coord_polar()
57#' # Race track plot
58#' doh + geom_bar(width = 0.9, position = "fill") + coord_polar(theta = "y")
59#' }
60#' }
61coord_polar <- function(theta = "x", start = 0, direction = 1, clip = "on") {
62  theta <- match.arg(theta, c("x", "y"))
63  r <- if (theta == "x") "y" else "x"
64
65  ggproto(NULL, CoordPolar,
66    theta = theta,
67    r = r,
68    start = start,
69    direction = sign(direction),
70    clip = clip
71  )
72}
73
74#' @rdname ggplot2-ggproto
75#' @format NULL
76#' @usage NULL
77#' @export
78CoordPolar <- ggproto("CoordPolar", Coord,
79
80  aspect = function(details) 1,
81
82  distance = function(self, x, y, details) {
83    if (self$theta == "x") {
84      r <- rescale(y, from = details$r.range)
85      theta <- theta_rescale_no_clip(self, x, details)
86    } else {
87      r <- rescale(x, from = details$r.range)
88      theta <- theta_rescale_no_clip(self, y, details)
89    }
90
91    dist_polar(r, theta)
92  },
93
94  backtransform_range = function(self, panel_params) {
95    self$range(panel_params)
96  },
97
98  range = function(self, panel_params) {
99    # summarise_layout() expects that the x and y ranges here
100    # match the setting from self$theta and self$r
101    setNames(
102      list(panel_params$theta.range, panel_params$r.range),
103      c(self$theta, self$r)
104    )
105  },
106
107  setup_panel_params = function(self, scale_x, scale_y, params = list()) {
108
109    ret <- list(x = list(), y = list())
110    for (n in c("x", "y")) {
111
112      scale <- get(paste0("scale_", n))
113      limits <- self$limits[[n]]
114
115      if (self$theta == n) {
116        expansion <- default_expansion(scale, c(0, 0.5), c(0, 0))
117      } else {
118        expansion <- default_expansion(scale, c(0, 0),   c(0, 0))
119      }
120      range <- expand_limits_scale(scale, expansion, coord_limits = limits)
121
122      out <- scale$break_info(range)
123      ret[[n]]$range <- out$range
124      ret[[n]]$major <- out$major_source
125      ret[[n]]$minor <- out$minor_source
126      ret[[n]]$labels <- out$labels
127      ret[[n]]$sec.range <- out$sec.range
128      ret[[n]]$sec.major <- out$sec.major_source_user
129      ret[[n]]$sec.minor <- out$sec.minor_source_user
130      ret[[n]]$sec.labels <- out$sec.labels
131    }
132
133    details = list(
134      x.range = ret$x$range, y.range = ret$y$range,
135      x.major = ret$x$major, y.major = ret$y$major,
136      x.minor = ret$x$minor, y.minor = ret$y$minor,
137      x.labels = ret$x$labels, y.labels = ret$y$labels,
138      x.sec.range = ret$x$sec.range, y.sec.range = ret$y$sec.range,
139      x.sec.major = ret$x$sec.major, y.sec.major = ret$y$sec.major,
140      x.sec.minor = ret$x$sec.minor, y.sec.minor = ret$y$sec.minor,
141      x.sec.labels = ret$x$sec.labels, y.sec.labels = ret$y$sec.labels
142    )
143
144    if (self$theta == "y") {
145      names(details) <- gsub("x\\.", "r.", names(details))
146      names(details) <- gsub("y\\.", "theta.", names(details))
147      details$r.arrange <- scale_x$axis_order()
148    } else {
149      names(details) <- gsub("x\\.", "theta.", names(details))
150      names(details) <- gsub("y\\.", "r.", names(details))
151      details$r.arrange <- scale_y$axis_order()
152    }
153
154    details
155  },
156
157  transform = function(self, data, panel_params) {
158    data <- rename_data(self, data)
159
160    data$r  <- r_rescale(self, data$r, panel_params$r.range)
161    data$theta <- theta_rescale(self, data$theta, panel_params)
162    data$x <- data$r * sin(data$theta) + 0.5
163    data$y <- data$r * cos(data$theta) + 0.5
164
165    data
166  },
167
168  render_axis_v = function(self, panel_params, theme) {
169    arrange <- panel_params$r.arrange %||% c("primary", "secondary")
170
171    x <- r_rescale(self, panel_params$r.major, panel_params$r.range) + 0.5
172    panel_params$r.major <- x
173    if (!is.null(panel_params$r.sec.major)) {
174      panel_params$r.sec.major <- r_rescale(
175        self,
176        panel_params$r.sec.major,
177        panel_params$r.sec.range
178      ) + 0.5
179    }
180
181    list(
182      left = render_axis(panel_params, arrange[1], "r", "left", theme),
183      right = render_axis(panel_params, arrange[2], "r", "right", theme)
184    )
185  },
186
187  render_axis_h = function(panel_params, theme) {
188    list(
189      top = zeroGrob(),
190      bottom = draw_axis(NA, "", "bottom", theme)
191    )
192  },
193
194  render_bg = function(self, panel_params, theme) {
195    panel_params <- rename_data(self, panel_params)
196
197    theta <- if (length(panel_params$theta.major) > 0)
198      theta_rescale(self, panel_params$theta.major, panel_params)
199    thetamin <- if (length(panel_params$theta.minor) > 0)
200      theta_rescale(self, panel_params$theta.minor, panel_params)
201    thetafine <- seq(0, 2 * pi, length.out = 100)
202
203    rfine <- c(r_rescale(self, panel_params$r.major, panel_params$r.range), 0.45)
204
205    # This gets the proper theme element for theta and r grid lines:
206    #   panel.grid.major.x or .y
207    majortheta <- paste("panel.grid.major.", self$theta, sep = "")
208    minortheta <- paste("panel.grid.minor.", self$theta, sep = "")
209    majorr     <- paste("panel.grid.major.", self$r,     sep = "")
210
211    ggname("grill", grobTree(
212      element_render(theme, "panel.background"),
213      if (length(theta) > 0) element_render(
214        theme, majortheta, name = "angle",
215        x = c(rbind(0, 0.45 * sin(theta))) + 0.5,
216        y = c(rbind(0, 0.45 * cos(theta))) + 0.5,
217        id.lengths = rep(2, length(theta)),
218        default.units = "native"
219      ),
220      if (length(thetamin) > 0) element_render(
221        theme, minortheta, name = "angle",
222        x = c(rbind(0, 0.45 * sin(thetamin))) + 0.5,
223        y = c(rbind(0, 0.45 * cos(thetamin))) + 0.5,
224        id.lengths = rep(2, length(thetamin)),
225        default.units = "native"
226      ),
227
228      element_render(
229        theme, majorr, name = "radius",
230        x = rep(rfine, each = length(thetafine)) * sin(thetafine) + 0.5,
231        y = rep(rfine, each = length(thetafine)) * cos(thetafine) + 0.5,
232        id.lengths = rep(length(thetafine), length(rfine)),
233        default.units = "native"
234      )
235    ))
236  },
237
238  render_fg = function(self, panel_params, theme) {
239    if (is.null(panel_params$theta.major)) {
240      return(element_render(theme, "panel.border"))
241    }
242
243    theta <- theta_rescale(self, panel_params$theta.major, panel_params)
244    labels <- panel_params$theta.labels
245
246    # Combine the two ends of the scale if they are close
247    theta <- theta[!is.na(theta)]
248    ends_apart <- (theta[length(theta)] - theta[1]) %% (2 * pi)
249    if (length(theta) > 0 && ends_apart < 0.05) {
250      n <- length(labels)
251      if (is.expression(labels)) {
252        combined <- substitute(paste(a, "/", b),
253          list(a = labels[[1]], b = labels[[n]]))
254      } else {
255        combined <- paste(labels[1], labels[n], sep = "/")
256      }
257      labels[[n]] <- combined
258      labels <- labels[-1]
259      theta <- theta[-1]
260    }
261
262    grobTree(
263      if (length(labels) > 0) element_render(
264        theme, "axis.text.x",
265        labels, 0.45 * sin(theta) + 0.5, 0.45 * cos(theta) + 0.5,
266        hjust = 0.5, vjust = 0.5,
267        default.units = "native"
268      ),
269      element_render(theme, "panel.border")
270    )
271  },
272
273  render_fg = function(self, panel_params, theme) {
274    if (is.null(panel_params$theta.major)) {
275      return(element_render(theme, "panel.border"))
276    }
277
278    theta <- theta_rescale(self, panel_params$theta.major, panel_params)
279    labels <- panel_params$theta.labels
280
281    # Combine the two ends of the scale if they are close
282    theta <- theta[!is.na(theta)]
283    ends_apart <- (theta[length(theta)] - theta[1]) %% (2*pi)
284    if (length(theta) > 0 && ends_apart < 0.05 && !is.null(labels)) {
285      n <- length(labels)
286      if (is.expression(labels)) {
287        combined <- substitute(paste(a, "/", b),
288          list(a = labels[[1]], b = labels[[n]]))
289      } else {
290        combined <- paste(labels[1], labels[n], sep = "/")
291      }
292      labels[[n]] <- combined
293      labels <- labels[-1]
294      theta <- theta[-1]
295    }
296
297    grobTree(
298      if (length(labels) > 0) element_render(
299        theme, "axis.text.x",
300        labels,
301        unit(0.45 * sin(theta) + 0.5, "native"),
302        unit(0.45 * cos(theta) + 0.5, "native"),
303        hjust = 0.5, vjust = 0.5
304      ),
305      element_render(theme, "panel.border")
306    )
307  },
308
309  labels = function(self, labels, panel_params) {
310    if (self$theta == "y") {
311      list(x = labels$y, y = labels$x)
312    } else {
313      labels
314    }
315  },
316
317  modify_scales = function(self, scales_x, scales_y) {
318    if (self$theta != "y")
319      return()
320
321    lapply(scales_x, scale_flip_position)
322    lapply(scales_y, scale_flip_position)
323  }
324)
325
326
327rename_data <- function(coord, data) {
328  if (coord$theta == "y") {
329    rename(data, c("y" = "theta", "x" = "r"))
330  } else {
331    rename(data, c("y" = "r", "x" = "theta"))
332  }
333}
334
335theta_rescale_no_clip <- function(coord, x, panel_params) {
336  rotate <- function(x) (x + coord$start) * coord$direction
337  rotate(rescale(x, c(0, 2 * pi), panel_params$theta.range))
338}
339
340theta_rescale <- function(coord, x, panel_params) {
341  x <- squish_infinite(x, panel_params$theta.range)
342  rotate <- function(x) (x + coord$start) %% (2 * pi) * coord$direction
343  rotate(rescale(x, c(0, 2 * pi), panel_params$theta.range))
344}
345
346r_rescale <- function(coord, x, range) {
347  x <- squish_infinite(x, range)
348  rescale(x, c(0, 0.4), range)
349}
350