Partial polar plots

R/coord-polar.r

@@ -6,6 +6,8 @@
 #' @param theta variable to map angle to (`x` or `y`)
 #' @param start Offset of starting point from 12 o'clock in radians. Offset
 #'   is applied clockwise or anticlockwise depending on value of `direction`.
+#' @param end Offset of end point from 12 o'clock in radians. Can be used to
+#'   make partial polar plots. Defaults to `start + 2 * pi`.
 #' @param direction 1, clockwise; -1, anticlockwise
 #' @param clip Should drawing be clipped to the extent of the plot panel? A
 #'   setting of `"on"` (the default) means yes, and a setting of `"off"`
@@ -22,6 +24,9 @@
 #'  geom_bar(width = 1)
 #' pie + coord_polar(theta = "y")
 #'
+#' # A pie chart, but half of it is already eaten
+#' pie + coord_polar(theta = "y", start = -0.5 * pi, end = 0.5 * pi)
+#'
 #' \donttest{
 #'
 #' # A coxcomb plot = bar chart + polar coordinates
@@ -58,14 +63,21 @@
 #' doh + geom_bar(width = 0.9, position = "fill") + coord_polar(theta = "y")
 #' }
 #' }
-coord_polar <- function(theta = "x", start = 0, direction = 1, clip = "on") {
+coord_polar <- function(theta = "x", start = 0, end = NULL,
+                        direction = 1, clip = "on") {
   theta <- arg_match0(theta, c("x", "y"))
   r <- if (theta == "x") "y" else "x"
 
+  end <- end %||% (start + 2 * pi)
+  if (start > end) {
+    n_rotate <- ((start - end) %/% (2 * pi)) + 1
+    start <- start - n_rotate * 2 * pi
+  }
+
   ggproto(NULL, CoordPolar,
     theta = theta,
     r = r,
-    start = start,
+    arc = c(start, end),
     direction = sign(direction),
     clip = clip
   )
@@ -77,7 +89,9 @@ coord_polar <- function(theta = "x", start = 0, direction = 1, clip = "on") {
 #' @export
 CoordPolar <- ggproto("CoordPolar", Coord,
 
-  aspect = function(details) 1,
+  aspect = function(details) {
+    diff(details$bbox$y) / diff(details$bbox$x)
+  },
 
   distance = function(self, x, y, details) {
     if (self$theta == "x") {
@@ -138,7 +152,9 @@ CoordPolar <- ggproto("CoordPolar", Coord,
       x.sec.range = ret$x$sec.range, y.sec.range = ret$y$sec.range,
       x.sec.major = ret$x$sec.major, y.sec.major = ret$y$sec.major,
       x.sec.minor = ret$x$sec.minor, y.sec.minor = ret$y$sec.minor,
-      x.sec.labels = ret$x$sec.labels, y.sec.labels = ret$y$sec.labels
+      x.sec.labels = ret$x$sec.labels, y.sec.labels = ret$y$sec.labels,
+      bbox = polar_bbox(self$arc),
+      arc  = self$arc
     )
 
     if (self$theta == "y") {
@@ -159,13 +175,29 @@ CoordPolar <- ggproto("CoordPolar", Coord,
 
     data$r  <- r_rescale(self, data$r, panel_params$r.range)
     data$theta <- theta_rescale(self, data$theta, panel_params)
-    data$x <- data$r * sin(data$theta) + 0.5
-    data$y <- data$r * cos(data$theta) + 0.5
+    data$x <- rescale(
+      data$r * sin(data$theta) + 0.5,
+      from = panel_params$bbox$x
+    )
+    data$y <- rescale(
+      data$r * cos(data$theta) + 0.5,
+      from = panel_params$bbox$y
+    )
 
     data
   },
 
   render_axis_v = function(self, panel_params, theme) {
+
+    place_axis <- in_arc(c(0, 1) * pi, panel_params$arc)
+    if (!any(place_axis)) {
+      ans <- list(
+        left  = draw_axis(NA, "", "left", theme),
+        right = zeroGrob()
+      )
+      return(ans)
+    }
+
     arrange <- panel_params$r.arrange %||% c("primary", "secondary")
 
     x <- r_rescale(self, panel_params$r.major, panel_params$r.range) + 0.5
@@ -178,17 +210,77 @@ CoordPolar <- ggproto("CoordPolar", Coord,
       ) + 0.5
     }
 
+    if (!place_axis[1]) {
+      panel_params$r.major <- 1 - panel_params$r.major
+      if (!is.null(panel_params$r.sec.major)) {
+        panel_params$r.sec.major <- 1 - panel_params$r.sec.major
+      }
+    }
+
+    panel_params$r.major <- rescale(panel_params$r.major,
+                                    from = panel_params$bbox$y)
+    panel_params$r.sec.major <- rescale(panel_params$r.sec.major,
+                                        from = panel_params$bbox$y)
+
     list(
-      left = render_axis(panel_params, arrange[1], "r", "left", theme),
+      left  = render_axis(panel_params, arrange[1], "r", "left", theme),
       right = render_axis(panel_params, arrange[2], "r", "right", theme)
     )
   },
 
   render_axis_h = function(panel_params, theme) {
-    list(
+
+    no_axis <- list(
       top = zeroGrob(),
       bottom = draw_axis(NA, "", "bottom", theme)
     )
+
+    # Return no axis if there should already be a left/right axis
+    if (any(in_arc(c(0, 1) * pi, panel_params$arc))) {
+      return(no_axis)
+    }
+
+    place_axis <- in_arc(c(0.5, 1.5) * pi, panel_params$arc)
+    if (!any(place_axis)) {
+      # This should in theory never happen
+      cli::cli_inform(c(paste0(
+        "Could not find appropriate placement for the {.field radius}",
+        " axis."
+      ), i = paste0(
+        "A {.field radius} axis requires the [{.arg start}-{.arg end}] range to ",
+        "include one of: {.code c(0, 0.5, 1, 1.5) * pi}."
+      )))
+      return(no_axis)
+    }
+
+    arrange <- panel_params$r.arrange %||% c("primary", "secondary")
+
+    y <- r_rescale(self, panel_params$r.major, panel_params$r.range) + 0.5
+    panel_params$r.major <- y
+    if (!is.null(panel_params$r.sec.major)) {
+      panel_params$r.sec.major <- r_rescale(
+        self,
+        panel_params$r.sec.major,
+        panel_params$r.sec.range
+      ) + 0.5
+    }
+
+    if (!place_axis[1]) {
+      panel_params$r.major <- 1 - panel_params$r.major
+      if (!is.null(panel_params$r.sec.major)) {
+        panel_params$r.sec.major <- 1 - panel_params$r.sec.major
+      }
+    }
+
+    panel_params$r.major <- rescale(panel_params$r.major,
+                                    from = panel_params$bbox$x)
+    panel_params$r.sec.major <- rescale(panel_params$r.sec.major,
+                                        from = panel_params$bbox$x)
+
+    list(
+      top     = render_axis(panel_params, arrange[2], "r", "top", theme),
+      bottom  = render_axis(panel_params, arrange[1], "r", "bottom", theme)
+    )
   },
 
   render_bg = function(self, panel_params, theme) {
@@ -198,7 +290,7 @@ CoordPolar <- ggproto("CoordPolar", Coord,
       theta_rescale(self, panel_params$theta.major, panel_params)
     thetamin <- if (length(panel_params$theta.minor) > 0)
       theta_rescale(self, panel_params$theta.minor, panel_params)
-    thetafine <- seq(0, 2 * pi, length.out = 100)
+    thetafine <- seq(self$arc[1], self$arc[2], length.out = 100)
 
     rfine <- c(r_rescale(self, panel_params$r.major, panel_params$r.range), 0.45)
 
@@ -212,23 +304,41 @@ CoordPolar <- ggproto("CoordPolar", Coord,
       element_render(theme, "panel.background"),
       if (length(theta) > 0) element_render(
         theme, majortheta, name = "angle",
-        x = vec_interleave(0, 0.45 * sin(theta)) + 0.5,
-        y = vec_interleave(0, 0.45 * cos(theta)) + 0.5,
+        x = rescale(
+          vec_interleave(0, 0.45 * sin(theta)) + 0.5,
+          from = panel_params$bbox$x
+        ),
+        y = rescale(
+          vec_interleave(0, 0.45 * cos(theta)) + 0.5,
+          from = panel_params$bbox$y
+        ),
         id.lengths = rep(2, length(theta)),
         default.units = "native"
       ),
       if (length(thetamin) > 0) element_render(
         theme, minortheta, name = "angle",
-        x = vec_interleave(0, 0.45 * sin(thetamin)) + 0.5,
-        y = vec_interleave(0, 0.45 * cos(thetamin)) + 0.5,
+        x = rescale(
+          vec_interleave(0, 0.45 * sin(thetamin)) + 0.5,
+          from = panel_params$bbox$x
+        ),
+        y = rescale(
+          vec_interleave(0, 0.45 * cos(thetamin)) + 0.5,
+          from = panel_params$bbox$y
+        ),
         id.lengths = rep(2, length(thetamin)),
         default.units = "native"
       ),
 
       element_render(
         theme, majorr, name = "radius",
-        x = rep(rfine, each = length(thetafine)) * rep(sin(thetafine), length(rfine)) + 0.5,
-        y = rep(rfine, each = length(thetafine)) * rep(cos(thetafine), length(rfine)) + 0.5,
+        x = rescale(
+          as.vector(outer(sin(thetafine), rfine)) + 0.5,
+          from = panel_params$bbox$x
+        ),
+        y = rescale(
+          as.vector(outer(cos(thetafine), rfine)) + 0.5,
+          from = panel_params$bbox$y
+        ),
         id.lengths = rep(length(thetafine), length(rfine)),
         default.units = "native"
       )
@@ -259,12 +369,15 @@ CoordPolar <- ggproto("CoordPolar", Coord,
       theta <- theta[-1]
     }
 
+    x <- rescale(0.45 * sin(theta) + 0.5, from = panel_params$bbox$x)
+    y <- rescale(0.45 * cos(theta) + 0.5, from = panel_params$bbox$y)
+
     grobTree(
       if (length(labels) > 0) element_render(
         theme, "axis.text.x",
         labels,
-        unit(0.45 * sin(theta) + 0.5, "native"),
-        unit(0.45 * cos(theta) + 0.5, "native"),
+        unit(x, "native"),
+        unit(y, "native"),
         hjust = 0.5, vjust = 0.5
       ),
       element_render(theme, "panel.border")
@@ -273,10 +386,17 @@ CoordPolar <- ggproto("CoordPolar", Coord,
 
   labels = function(self, labels, panel_params) {
     if (self$theta == "y") {
-      list(x = labels$y, y = labels$x)
+      if (any(in_arc(c(0, 1) * pi, self$arc))) {
+        labels <- list(x = labels$y, y = labels$x)
+      } else {
+        labels <- list(x = rev(labels$x), y = rev(labels$y))
+      }
     } else {
-      labels
+      if (!any(in_arc(c(0, 1) * pi, self$arc))) {
+        labels <- list(x = rev(labels$y), y = rev(labels$x))
+      }
     }
+    labels
   },
 
   modify_scales = function(self, scales_x, scales_y) {
@@ -298,17 +418,51 @@ rename_data <- function(coord, data) {
 }
 
 theta_rescale_no_clip <- function(coord, x, panel_params) {
-  rotate <- function(x) (x + coord$start) * coord$direction
-  rotate(rescale(x, c(0, 2 * pi), panel_params$theta.range))
+  arc <- coord$arc %||% c(0, 2 * pi)
+  rotate <- function(x) x * coord$direction
+  rotate(rescale(x, arc, panel_params$theta.range))
 }
 
 theta_rescale <- function(coord, x, panel_params) {
+  arc <- coord$arc %||% c(0, 2 * pi)
   x <- squish_infinite(x, panel_params$theta.range)
-  rotate <- function(x) (x + coord$start) %% (2 * pi) * coord$direction
-  rotate(rescale(x, c(0, 2 * pi), panel_params$theta.range))
+  rotate <- function(x) x %% (2 * pi) * coord$direction
+  rotate(rescale(x, arc, panel_params$theta.range))
 }
 
 r_rescale <- function(coord, x, range) {
   x <- squish_infinite(x, range)
   rescale(x, c(0, 0.4), range)
 }
+
+# Calculate bounding box for the sector of the circle
+# Takes `arc` as a vector of two angles in radians
+polar_bbox <- function(arc) {
+
+  # X and Y positions of the sector arc ends
+  x <- 0.5 * sin(arc) + 0.5
+  y <- 0.5 * cos(arc) + 0.5
+
+  # Check for top, right, bottom and left if it falls in sector
+  pos_theta <- seq(0, 1.5 * pi, length.out = 4)
+  in_sector <- in_arc(pos_theta, arc)
+
+  # If position is in sector, take extreme bounds
+  # If not, choose center (+/- 0.05 buffer) or sector arc ends
+  bounds <- ifelse(
+    in_sector,
+    c(1, 1, 0, 0),
+    c(max(y, 0.55), max(x, 0.55), min(y, 0.45), min(x, 0.45))
+  )
+  list(x = c(bounds[4], bounds[2]), y = c(bounds[3], bounds[1]))
+}
+
+in_arc <- function(theta, arc) {
+  arc <- arc %% (2 * pi)
+  if (arc[1] < arc[2]) {
+      theta >= arc[1] & theta <= arc[2]
+  } else {
+    !(theta <  arc[1] & theta >  arc[2])
+  }
+}
+