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