Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Convert coord to S3

  • Loading branch information...
commit 6ba21aee4e99f6c1888d7c8732bbf5257749b160 1 parent cb85182
@hadley authored
Showing with 653 additions and 616 deletions.
  1. +2 −2 DESCRIPTION
  2. +30 −0 NAMESPACE
  3. +17 −0 NEWS
  4. +71 −64 R/coord-.r
  5. +54 −71 R/coord-cartesian-.r
  6. +0 −69 R/coord-cartesian-flipped.r
  7. +9 −13 R/{coord-cartesian-equal.r → coord-fixed.r}
  8. +63 −0 R/coord-flip.r
  9. +117 −121 R/coord-map.r
  10. +12 −0 R/coord-munch.r
  11. +164 −161 R/coord-polar.r
  12. +52 −66 R/coord-transform.r
  13. +7 −5 R/facet-grid-.r
  14. +7 −6 R/facet-null.r
  15. +1 −1  R/geom-hex.r
  16. +1 −1  R/geom-linerange.r
  17. +1 −1  R/geom-path-.r
  18. +2 −2 R/geom-point-.r
  19. +1 −1  R/geom-polygon.r
  20. +2 −2 R/geom-rect.r
  21. +1 −1  R/geom-ribbon-.r
  22. +1 −1  R/geom-rug.r
  23. +2 −2 R/geom-segment.r
  24. +3 −10 R/geom-text.r
  25. +2 −2 R/panel.r
  26. +3 −0  R/plot-construction.r
  27. +1 −1  R/plot-render.r
  28. +1 −1  R/plot.r
  29. +2 −2 R/xxx-codegen.r
  30. +0 −6 R/xxx.r
  31. +0 −3  R/zxx.r
  32. +1 −1  inst/tests/test-facet-layout.r
  33. +16 −0 man/coord.Rd
  34. +1 −0  man/coord_cartesian.Rd
  35. +1 −0  man/coord_fixed.Rd
  36. +1 −0  man/coord_flip.Rd
  37. +2 −0  man/coord_map.Rd
  38. +1 −0  man/coord_polar.Rd
  39. +1 −0  man/coord_trans.Rd
View
4 DESCRIPTION
@@ -44,8 +44,8 @@ Collate:
'bench.r'
'coord-.r'
'coord-cartesian-.r'
- 'coord-cartesian-equal.r'
- 'coord-cartesian-flipped.r'
+ 'coord-fixed.r'
+ 'coord-flip.r'
'coord-map.r'
'coord-munch.r'
'coord-polar.r'
View
30 NAMESPACE
@@ -8,12 +8,41 @@ export(aes_string)
export(aes_all)
export(annotate)
export(benchplot)
+export(coord)
+S3method(coord_render_bg, default)
+S3method(coord_render_axis_h, default)
+S3method(coord_render_axis_v, default)
export(coord_cartesian)
+S3method(is.linear, cartesian)
+S3method(coord_transform, cartesian)
+S3method(coord_train, cartesian)
export(coord_fixed, coord_equal)
+S3method(coord_aspect, fixed)
export(coord_flip)
+S3method(coord_transform, flip)
+S3method(coord_train, flip)
+S3method(coord_labels, flip)
export(coord_map)
+S3method(coord_transform, map)
+S3method(coord_distance, map)
+S3method(coord_aspect, map)
+S3method(coord_train, map)
+S3method(coord_render_bg, map)
+S3method(coord_render_axis_h, map)
+S3method(coord_render_axis_v, map)
export(coord_polar)
+S3method(coord_aspect, polar)
+S3method(coord_distance, polar)
+S3method(coord_ranges, polar)
+S3method(coord_transform, polar)
+S3method(coord_render_axis_v, polar)
+S3method(coord_render_axis_h, polar)
+S3method(coord_render_bg, polar)
+S3method(coord_render_fg, polar)
export(coord_trans)
+S3method(coord_distance, trans)
+S3method(coord_transform, trans)
+S3method(coord_train, trans)
export(facet)
export(is.facet)
export(facet_grid)
@@ -150,6 +179,7 @@ export(scale_x_date, scale_y_date)
export(scale_x_datetime, scale_y_datetime)
export(scale_x_discrete, scale_y_discrete)
S3method(scale_train, position_d)
+S3method(scale_limits, position_d)
S3method(scale_reset, position_d)
S3method(scale_map, position_d)
S3method(scale_dimension, position_d)
View
17 NEWS
@@ -83,6 +83,23 @@ SCALES
scale_colour_discrete <- scale_colour_brewer
p
+FACETS
+
+* Converted from proto to S3 objects, and class methods (somewhat) documented
+ in `facet.r`. This should make it easier to develop new types of facetting
+ specifications.
+
+* New `facet_null` used when for no facetting. This special case is
+ implemented more efficiently and results in substantial performance
+ improvements for un-facetted plots.
+
+COORDS
+
+* Converted from proto to S3 objects, and class methods (somewhat) documented
+ in `coord.r`. This should make it easier to develop new types of coordinate
+ systems.
+
+
ggplot2 0.8.9 (2010-12-24) ---------------------------------------------------
A big thanks to Koshke Takahashi, who supplied the majority of improvements in this release!
View
135 R/coord-.r
@@ -1,64 +1,71 @@
-Coord <- proto(TopLevel, expr={
- limits <- list()
- class <- function(.) "coord"
-
- muncher <- function(.) FALSE
-
- # Rescaling at coord level should not be clipped: this is what
- # makes zooming work
- rescale_var <- function(., data, range, clip = FALSE) {
- rescale(data, 0:1, range)
- }
-
- munch <- function(., data, details, segment_length = 0.01) {
- if (!.$muncher()) return(.$transform(data, details))
-
- # Calculate distances using coord distance metric
- dist <- .$distance(data$x, data$y, details)
- dist[data$group[-1] != data$group[-nrow(data)]] <- NA
-
- # Munch and then transform result
- munched <- munch_data(data, dist, segment_length)
- .$transform(munched, details)
- }
-
- distance <- function(., x, y, details) {
- max_dist <- dist_euclidean(details$x.range, details$y.range)
- dist_euclidean(x, y) / max_dist
- }
-
- compute_aspect <- function(., ranges) {
- NULL
- }
-
- labels <- function(., scales) {
- scales
- }
-
- pprint <- function(., newline=TRUE) {
- args <- formals(get("new", .))
- args <- args[!names(args) %in% c(".", "...")]
-
- cat("coord_", .$objname, ": ", clist(args), sep="")
-
- if (newline) cat("\n")
- }
-
- guide_foreground <- function(., scales, theme) {
- theme_render(theme, "panel.border")
- }
- # Html defaults
-
- html_returns <- function(.) {
- ps(
- "<h2>Returns</h2>\n",
- "<p>This function returns a coordinate system object.</p>"
- )
- }
-
- parameters <- function(.) {
- params <- formals(get("new", .))
- params[setdiff(names(params), c("."))]
- }
-
-})
+#' New coordinate system.
+#'
+#' Internal use only.
+#'
+#' @param ... object fields
+#' @keywords internal
+#' @export
+coord <- function(..., subclass = c()) {
+ structure(list(...), class = c(subclass, "coord"))
+}
+
+#' Is this object a coordinate system?
+#'
+#' @export is.coord
+#' @keywords internal
+is.coord <- function(x) inherits(x, "coord")
+
+distance <- function(., x, y, details) {
+ max_dist <- dist_euclidean(details$x.range, details$y.range)
+ dist_euclidean(x, y) / max_dist
+}
+
+coord_aspect <- function(coord, ranges)
+ UseMethod("coord_aspect")
+coord_aspect.default <- function(coord, ranges) NULL
+
+coord_labels <- function(coord, scales) UseMethod("coord_labels")
+coord_labels.default <- function(coord, scales) scales
+
+coord_render_fg <- function(coord, scales, theme)
+ UseMethod("coord_render_fg")
+coord_render_fg.default <- function(coord, scales, theme)
+ theme_render(theme, "panel.border")
+
+coord_render_bg <- function(coord, scales, theme)
+ UseMethod("coord_render_bg")
+#' @S3method coord_render_bg default
+coord_render_bg.default <- function(coord, details, theme) {
+ x.major <- unit(details$x.major, "native")
+ x.minor <- unit(details$x.minor, "native")
+ y.major <- unit(details$y.major, "native")
+ y.minor <- unit(details$y.minor, "native")
+
+ guide_grid(theme, x.minor, x.major, y.minor, y.major)
+}
+
+coord_render_axis_h <- function(coord, scales, theme)
+ UseMethod("coord_render_axis_h")
+#' @S3method coord_render_axis_h default
+coord_render_axis_h.default <- function(coord, details, theme) {
+ guide_axis(details$x.major, details$x.labels, "bottom", theme)
+}
+
+coord_render_axis_v <- function(coord, scales, theme)
+ UseMethod("coord_render_axis_v")
+#' @S3method coord_render_axis_v default
+coord_render_axis_v.default <- function(coord, details, theme) {
+ guide_axis(details$y.major, details$y.labels, "left", theme)
+}
+
+coord_train <- function(coord, scales)
+ UseMethod("coord_train")
+
+coord_transform <- function(coord, data, range)
+ UseMethod("coord_transform")
+
+coord_distance <- function(coord, x, y, details)
+ UseMethod("coord_distance")
+
+is.linear <- function(coord) UseMethod("is.linear")
+is.linear.default <- function(coord) FALSE
View
125 R/coord-cartesian-.r
@@ -5,7 +5,6 @@
#' plot (like you're looking at it with a magnifying class), and will not
#' change the underlying data like setting limits on a scale will.
#'
-#' @name coord_cartesian
#' @param xlim limits for the x axis
#' @param ylim limits for the y axis
#' @param wise If \code{TRUE} will wisely expand the actual range of the plot
@@ -39,82 +38,66 @@
#' # When zooming the coordinate system, we see a subset of original 50 bins,
#' # displayed bigger
#' d + coord_cartesian(xlim = c(0, 2))
-CoordCartesian <- proto(Coord, expr={
- objname <- "cartesian"
- new <- function(., xlim = NULL, ylim = NULL, wise = FALSE) {
- .$proto(limits = list(x = xlim, y = ylim), wise = wise)
- }
-
- transform <- function(., data, details) {
- rescale_x <- function(data) .$rescale_var(data, details$x.range)
- rescale_y <- function(data) .$rescale_var(data, details$y.range)
-
- data <- transform_position(data, rescale_x, rescale_y)
- transform_position(data, trim_infinite_01, trim_infinite_01)
- }
+coord_cartesian <- function(xlim = NULL, ylim = NULL, wise = FALSE) {
+ coord(limits = list(x = xlim, y = ylim), wise = wise,
+ subclass = "cartesian")
+}
+
+#' @S3method is.linear cartesian
+is.linear.cartesian <- function(coord) TRUE
+
+#' @S3method coord_transform cartesian
+coord_transform.cartesian <- function(., data, details) {
+ rescale_x <- function(data) rescale(data, from = details$x.range)
+ rescale_y <- function(data) rescale(data, from = details$y.range)
- compute_ranges <- function(., scales) {
- if (is.null(.$limits$x)) {
- x.range <- scale_dimension(scales$x)
- } else {
- x.range <- range(scale_transform(scales$x, .$limits[["x"]]))
- if (.$wise) {
- scales$x$limits <- x.range
- x.range <- expand_range(x.range,
- scales$x$expand[1], scales$x$expand[2])
- }
- }
-
- x.major <- .$rescale_var(scale_break_positions(scales$x), x.range, TRUE)
- x.minor <- .$rescale_var(scale_breaks_minor(scales$x), x.range, TRUE)
- x.labels <- scale_labels(scales$x)
+ data <- transform_position(data, rescale_x, rescale_y)
+ transform_position(data, trim_infinite_01, trim_infinite_01)
+}
- if (is.null(.$limits$y)) {
- y.range <- scale_dimension(scales$y)
- } else {
- y.range <- range(scale_transform(scales$y, .$limits[["y"]]))
-
- if (.$wise) {
- scales$y$limits <- y.range
- y.range <- expand_range(y.range,
- scales$y$expand[1], scales$y$expand[2])
- }
+#' @S3method coord_train cartesian
+coord_train.cartesian <- function(coord, scales) {
+ if (is.null(coord$limits$x)) {
+ x.range <- scale_dimension(scales$x)
+ } else {
+ x.range <- range(scale_transform(scales$x, coord$limits[["x"]]))
+ if (coord$wise) {
+ scales$x$limits <- x.range
+ x.range <- expand_range(x.range,
+ scales$x$expand[1], scales$x$expand[2])
}
- y.major <- .$rescale_var(scale_break_positions(scales$y), y.range, TRUE)
- y.minor <- .$rescale_var(scale_breaks_minor(scales$y), y.range, TRUE)
- y.labels <- scale_labels(scales$y)
-
- list(
- x.range = x.range, y.range = y.range,
- x.major = x.major, x.minor = x.minor, x.labels = x.labels,
- y.major = y.major, y.minor = y.minor, y.labels = y.labels
- )
}
- guide_axis_h <- function(., details, theme) {
- guide_axis(details$x.major, details$x.labels, "bottom", theme)
- }
-
- guide_axis_v <- function(., details, theme) {
- guide_axis(details$y.major, details$y.labels, "left", theme)
- }
+ x.major <- rescale(scale_break_positions(scales$x), from = x.range)
+ x.minor <- rescale(scale_breaks_minor(scales$x), from = x.range)
+ x.labels <- scale_labels(scales$x)
-
- guide_background <- function(., details, theme) {
- x.major <- unit(details$x.major, "native")
- x.minor <- unit(details$x.minor, "native")
- y.major <- unit(details$y.major, "native")
- y.minor <- unit(details$y.minor, "native")
+ if (is.null(coord$limits$y)) {
+ y.range <- scale_dimension(scales$y)
+ } else {
+ y.range <- range(scale_transform(scales$y, coord$limits$y))
- guide_grid(theme, x.minor, x.major, y.minor, y.major)
- }
-
- icon <- function(.) {
- gTree(children = gList(
- segmentsGrob(c(0, 0.25), c(0.25, 0), c(1, 0.25), c(0.25, 1), gp=gpar(col="grey50", lwd=0.5)),
- segmentsGrob(c(0, 0.75), c(0.75, 0), c(1, 0.75), c(0.75, 1), gp=gpar(col="grey50", lwd=0.5)),
- segmentsGrob(c(0, 0.5), c(0.5, 0), c(1, 0.5), c(0.5, 1))
- ))
+ if (coord$wise) {
+ scales$y$limits <- y.range
+ y.range <- expand_range(y.range,
+ scales$y$expand[1], scales$y$expand[2])
+ }
}
+ y.major <- rescale(scale_break_positions(scales$y), from = y.range)
+ y.minor <- rescale(scale_breaks_minor(scales$y), from = y.range)
+ y.labels <- scale_labels(scales$y)
-})
+ list(
+ x.range = x.range, y.range = y.range,
+ x.major = x.major, x.minor = x.minor, x.labels = x.labels,
+ y.major = y.major, y.minor = y.minor, y.labels = y.labels
+ )
+}
+
+icon.cartesian <- function(.) {
+ gTree(children = gList(
+ segmentsGrob(c(0, 0.25), c(0.25, 0), c(1, 0.25), c(0.25, 1), gp=gpar(col="grey50", lwd=0.5)),
+ segmentsGrob(c(0, 0.75), c(0.75, 0), c(1, 0.75), c(0.75, 1), gp=gpar(col="grey50", lwd=0.5)),
+ segmentsGrob(c(0, 0.5), c(0.5, 0), c(1, 0.5), c(0.5, 1))
+ ))
+}
View
69 R/coord-cartesian-flipped.r
@@ -1,69 +0,0 @@
-#' Flipped cartesian coordinates.
-#'
-#' Flipped cartesian coordinates so that horizontal becomes vertical, and
-#' vertical, horizontal. This is primarily useful for converting geoms and
-#' statistics which display y conditional on x, to x conditional on y.
-#'
-#' @name coord_flip
-#' @export
-#' @examples
-#' # Very useful for creating boxplots, and other interval
-#' # geoms in the horizontal instead of vertical position.
-#' qplot(cut, price, data=diamonds, geom="boxplot")
-#' last_plot() + coord_flip()
-#'
-#' qplot(cut, data=diamonds, geom="bar")
-#' last_plot() + coord_flip()
-#'
-#' qplot(carat, data=diamonds, geom="histogram")
-#' last_plot() + coord_flip()
-#'
-#' # You can also use it to flip lines and area plots:
-#' qplot(1:5, (1:5)^2, geom="line")
-#' last_plot() + coord_flip()
-CoordFlip <- proto(CoordCartesian, expr={
- objname <- "flip"
-
-
- transform <- function(., data, details) {
- rescale_x <- function(data) .$rescale_var(data, details$x.range)
- rescale_y <- function(data) .$rescale_var(data, details$y.range)
-
- data <- transform_position(data, rescale_y, rescale_x)
- data <- transform_position(data, trim_infinite_01, trim_infinite_01)
-
- rename(data, c(
- x = "y", y = "x",
- xend = "yend", yend = "xend",
- xmin = "ymin", ymin = "xmin",
- xmax = "ymax", ymax = "xmax")
- )
- }
-
- compute_ranges <- function(., scales) {
- details <- .super$compute_ranges(., scales)
- with(details, list(
- x.range = y.range, y.range = x.range,
- x.major = y.major, x.minor = y.minor, x.labels = y.labels,
- y.major = x.major, y.minor = x.minor, y.labels = x.labels
- ))
- }
-
- labels <- function(., scales) {
- list(
- x = scales$y,
- y = scales$x
- )
- }
-
-
- icon <- function(.) {
- angles <- seq(0, pi/2, length=20)[-c(1, 20)]
- gTree(children=gList(
- segmentsGrob(0, 0, 0, 1),
- segmentsGrob(0, 0, 1, 0),
- linesGrob(0.9 * sin(angles), 0.9 * cos(angles), arrow=arrow(length=unit(0.05, "npc"))),
- linesGrob(0.5 * sin(angles), 0.5 * cos(angles), arrow=arrow(end="first", length= unit(0.05, "npc")))
- ))
- }
-})
View
22 R/coord-cartesian-equal.r → R/coord-fixed.r
@@ -8,7 +8,6 @@
#' longer than units on the x-axis, and vice versa. This is similar to
#' \code{\link[MASS]{eqscplot}}, but it works for all types of graphics.
#'
-#' @name coord_fixed
#' @aliases coord_fixed coord_equal
#' @export coord_fixed coord_equal
#' @examples
@@ -20,17 +19,14 @@
#' qplot(mpg, wt, data = mtcars) + coord_equal(ratio = 1/5)
#'
#' # Resize the plot to see that the specified aspect ratio is mantained
-CoordFixed <- proto(CoordCartesian, {
- objname <- "fixed"
+coord_fixed <- function(ratio = 1) {
+ coord(ratio = ratio, subclass = c("fixed", "cartesian"))
+}
+coord_equal <- coord_fixed
- new <- function(., ratio = 1) {
- .$proto(ratio = ratio)
- }
+#' @S3method coord_aspect fixed
+coord_aspect.fixed <- function(coord, ranges) {
+ diff(ranges$y.range) / diff(ranges$x.range) * coord$ratio
+}
- compute_aspect <- function(., ranges) {
- diff(ranges$y.range) / diff(ranges$x.range) * .$ratio
- }
-
- icon <- function(.) textGrob("=", gp = gpar(cex=3))
-
-})
+icon.fixed <- function() textGrob("=", gp = gpar(cex=3))
View
63 R/coord-flip.r
@@ -0,0 +1,63 @@
+#' Flipped cartesian coordinates.
+#'
+#' Flipped cartesian coordinates so that horizontal becomes vertical, and
+#' vertical, horizontal. This is primarily useful for converting geoms and
+#' statistics which display y conditional on x, to x conditional on y.
+#'
+#' @export
+#' @examples
+#' # Very useful for creating boxplots, and other interval
+#' # geoms in the horizontal instead of vertical position.
+#' qplot(cut, price, data=diamonds, geom="boxplot")
+#' last_plot() + coord_flip()
+#'
+#' qplot(cut, data=diamonds, geom="bar")
+#' last_plot() + coord_flip()
+#'
+#' qplot(carat, data=diamonds, geom="histogram")
+#' last_plot() + coord_flip()
+#'
+#' # You can also use it to flip lines and area plots:
+#' qplot(1:5, (1:5)^2, geom="line")
+#' last_plot() + coord_flip()
+coord_flip <- function(...) {
+ coord <- coord_cartesian(...)
+ structure(coord, class = c("flip", class(coord)))
+}
+
+flip_labels <- function(x) {
+ old_names <- names(x)
+
+ new_names <- old_names
+ new_names <- gsub("^x", "z", new_names)
+ new_names <- gsub("^y", "x", new_names)
+ new_names <- gsub("^z", "y", new_names)
+
+ setNames(x, new_names)
+}
+
+#' @S3method coord_transform flip
+coord_transform.flip <- function(coord, data, details) {
+ data <- flip_labels(data)
+ flip_labels(NextMethod())
+}
+
+#' @S3method coord_train flip
+coord_train.flip <- function(coord, scales) {
+ flip_labels(NextMethod())
+}
+
+#' @S3method coord_labels flip
+coord_labels.flip <- function(coord, scales) {
+ flip_labels(NextMethod())
+}
+
+icon.flip <- function(.) {
+ angles <- seq(0, pi/2, length=20)[-c(1, 20)]
+ gTree(children=gList(
+ segmentsGrob(0, 0, 0, 1),
+ segmentsGrob(0, 0, 1, 0),
+ linesGrob(0.9 * sin(angles), 0.9 * cos(angles), arrow=arrow(length=unit(0.05, "npc"))),
+ linesGrob(0.5 * sin(angles), 0.5 * cos(angles), arrow=arrow(end="first", length= unit(0.05, "npc")))
+ ))
+}
View
238 R/coord-map.r
@@ -6,7 +6,6 @@
#' This is still experimental, and if you have any advice to offer regarding
#' a better (or more correct) way to do this, please let me know
#'
-#' @name coord_map
#' @export
#' @param projection projection to use, see \code{\link{mapproject}} for
#' list
@@ -42,134 +41,131 @@
#' usamap + coord_map(project="conic", lat0 = 30)
#' usamap + coord_map(project="bonne", lat0 = 50)
#' }
-CoordMap <- proto(Coord, {
- objname <- "map"
+coord_map <- function(projection="mercator", ..., orientation = NULL, xlim = NULL, ylim = NULL) {
+ try_require("mapproj")
+ coord(
+ projection = projection,
+ orientation = orientation,
+ xlim = xlim,
+ ylim = ylim,
+ params = list(...),
+ subclass = "map"
+ )
+}
- new <- function(., projection="mercator", ..., orientation = NULL, xlim = NULL, ylim = NULL) {
- try_require("mapproj")
- .$proto(
- projection = projection,
- orientation = orientation,
- xlim = xlim,
- ylim = ylim,
- params = list(...)
- )
- }
-
- muncher <- function(.) TRUE
+#' @S3method coord_transform map
+coord_transform.map <- function(coord, data, details) {
+ trans <- mproject(coord, data$x, data$y, details$orientation)
+ out <- cunion(trans[c("x", "y")], data)
- transform <- function(., data, details) {
- trans <- .$mproject(data$x, data$y, details$orientation)
- out <- cunion(trans[c("x", "y")], data)
-
- out$x <- rescale(out$x, 0:1, details$x.range)
- out$y <- rescale(out$y, 0:1, details$y.range)
- out
- }
+ out$x <- rescale(out$x, 0:1, details$x.range)
+ out$y <- rescale(out$y, 0:1, details$y.range)
+ out
+}
+mproject <- function(coord, x, y, orientation) {
+ suppressWarnings(mapproject(x, y,
+ projection = coord$projection,
+ parameters = coord$params,
+ orientation = orientation
+ ))
+}
+
+#' @S3method coord_distance map
+coord_distance.map <- function(coord, x, y, details) {
+ max_dist <- dist_central_angle(details$x.raw, details$y.raw)
+ dist_central_angle(x, y) / max_dist
+}
+
+#' @S3method coord_aspect map
+coord_aspect.map <- function(coord, ranges) {
+ diff(ranges$y.range) / diff(ranges$x.range)
+}
+
+#' @S3method coord_train map
+coord_train.map <- function(coord, scales) {
+ x.raw <- coord$xlim %||% scale_dimension(scales$x)
+ y.raw <- coord$ylim %||% scale_dimension(scales$y)
+ orientation <- coord$orientation %||% c(90, 0, mean(x.raw))
- distance <- function(., x, y, details) {
- max_dist <- dist_central_angle(details$x.raw, details$y.raw)
- dist_central_angle(x, y) / max_dist
- }
+ # Increase chances of creating valid boundary region
+ grid <- expand.grid(
+ x = seq(x.raw[1], x.raw[2], length = 50),
+ y = seq(y.raw[1], y.raw[2], length = 50)
+ )
+ range <- mproject(coord, grid$x, grid$y, orientation)$range
- compute_aspect <- function(., ranges) {
- diff(ranges$y.range) / diff(ranges$x.range)
- }
+ x.range <- range[1:2]
+ x.major <- scale_breaks(scales$x)
+ x.minor <- scale_breaks_minor(scales$x)
+ x.labels <- scale_labels(scales$x, x.major)
+
+ y.range <- range[3:4]
+ y.major <- scale_breaks(scales$y)
+ y.minor <- scale_breaks_minor(scales$y)
+ y.labels <- scale_labels(scales$y, y.major)
+ list(
+ x.raw = x.raw, y.raw = y.raw, orientation = orientation,
+ x.range = x.range, y.range = y.range,
+ x.major = x.major, x.minor = x.minor, x.labels = x.labels,
+ y.major = y.major, y.minor = y.minor, y.labels = y.labels
+ )
+}
+
+#' @S3method coord_render_bg map
+coord_render_bg.map <- function(coord, details, theme) {
+ xrange <- expand_range(details$x.raw, 0.2)
+ yrange <- expand_range(details$y.raw, 0.2)
+ xgrid <- with(details, expand.grid(
+ y = c(seq(yrange[1], yrange[2], len = 50), NA),
+ x = x.major
+ ))
+ ygrid <- with(details, expand.grid(
+ x = c(seq(xrange[1], xrange[2], len = 50), NA),
+ y = y.major
+ ))
- mproject <- function(., x, y, orientation) {
- suppressWarnings(do.call("mapproject", list(
- data.frame(x = x, y = y),
- projection = .$projection,
- parameters = .$params,
- orientation = orientation
- )))
- }
+ xlines <- coord_transform(coord, xgrid, details)
+ ylines <- coord_transform(coord, ygrid, details)
- compute_ranges <- function(., scales) {
- x.raw <- .$xlim %||% scale_dimension(scales$x)
- y.raw <- .$ylim %||% scale_dimension(scales$y)
- orientation <- .$orientation %||% c(90, 0, mean(x.raw))
-
- # Increase chances of creating valid boundary region
- grid <- expand.grid(
- x = seq(x.raw[1], x.raw[2], length = 50),
- y = seq(y.raw[1], y.raw[2], length = 50)
+ ggname("grill", grobTree(
+ theme_render(theme, "panel.background"),
+ theme_render(
+ theme, "panel.grid.major", name = "x",
+ xlines$x, xlines$y, default.units = "native"
+ ),
+ theme_render(
+ theme, "panel.grid.major", name = "y",
+ ylines$x, ylines$y, default.units = "native"
)
- range <- .$mproject(grid$x, grid$y, orientation)$range
-
- x.range <- range[1:2]
- x.major <- scale_breaks(scales$x)
- x.minor <- scale_breaks_minor(scales$x)
- x.labels <- scale_labels(scales$x, x.major)
+ ))
+}
- y.range <- range[3:4]
- y.major <- scale_breaks(scales$y)
- y.minor <- scale_breaks_minor(scales$y)
- y.labels <- scale_labels(scales$y, y.major)
-
- list(
- x.raw = x.raw, y.raw = y.raw, orientation = orientation,
- x.range = x.range, y.range = y.range,
- x.major = x.major, x.minor = x.minor, x.labels = x.labels,
- y.major = y.major, y.minor = y.minor, y.labels = y.labels
- )
- }
+#' @S3method coord_render_axis_h map
+coord_render_axis_h.map <- function(coord, details, theme) {
+ x_intercept <- with(details, data.frame(
+ x = x.major,
+ y = y.raw[1]
+ ))
+ pos <- coord_transform(coord, x_intercept, details)
- guide_background <- function(., details, theme) {
- xrange <- expand_range(details$x.raw, 0.2)
- yrange <- expand_range(details$y.raw, 0.2)
- xgrid <- with(details, expand.grid(
- y = c(seq(yrange[1], yrange[2], len = 50), NA),
- x = x.major
- ))
- ygrid <- with(details, expand.grid(
- x = c(seq(xrange[1], xrange[2], len = 50), NA),
- y = y.major
- ))
-
- xlines <- .$transform(xgrid, details)
- ylines <- .$transform(ygrid, details)
-
- ggname("grill", grobTree(
- theme_render(theme, "panel.background"),
- theme_render(
- theme, "panel.grid.major", name = "x",
- xlines$x, xlines$y, default.units = "native"
- ),
- theme_render(
- theme, "panel.grid.major", name = "y",
- ylines$x, ylines$y, default.units = "native"
- )
- ))
- }
-
- guide_axis_h <- function(., details, theme) {
- x_intercept <- with(details, data.frame(
- x = x.major,
- y = y.raw[1]
- ))
- pos <- .$transform(x_intercept, details)
-
- guide_axis(pos$x, details$x.labels, "bottom", theme)
- }
- guide_axis_v <- function(., details, theme) {
- x_intercept <- with(details, data.frame(
- x = x.raw[1],
- y = y.major
- ))
- pos <- .$transform(x_intercept, details)
-
- guide_axis(pos$y, details$y.labels, "left", theme)
- }
-
+ guide_axis(pos$x, details$x.labels, "bottom", theme)
+}
+#' @S3method coord_render_axis_v map
+coord_render_axis_v.map <- function(coord, details, theme) {
+ x_intercept <- with(details, data.frame(
+ x = x.raw[1],
+ y = y.major
+ ))
+ pos <- coord_transform(coord, x_intercept, details)
+
+ guide_axis(pos$y, details$y.labels, "left", theme)
+}
- # Documentation -----------------------------------------------
- icon <- function(.) {
- nz <- data.frame(map("nz", plot=FALSE)[c("x","y")])
- nz$x <- nz$x - min(nz$x, na.rm=TRUE)
- nz$y <- nz$y - min(nz$y, na.rm=TRUE)
- nz <- nz / max(nz, na.rm=TRUE)
- linesGrob(nz$x, nz$y, default.units="npc")
- }
-})
+icon.map <- function(.) {
+ nz <- data.frame(map("nz", plot=FALSE)[c("x","y")])
+ nz$x <- nz$x - min(nz$x, na.rm=TRUE)
+ nz$y <- nz$y - min(nz$y, na.rm=TRUE)
+ nz <- nz / max(nz, na.rm=TRUE)
+ linesGrob(nz$x, nz$y, default.units="npc")
+}
View
12 R/coord-munch.r
@@ -1,3 +1,15 @@
+coord_munch <- function(coord, data, range, segment_length = 0.01) {
+ if (is.linear(coord)) return(coord_transform(coordinates, range))
+
+ # Calculate distances using coord distance metric
+ dist <- coord_distance(coord, data$x, data$y, range)
+ dist[data$group[-1] != data$group[-nrow(data)]] <- NA
+
+ # Munch and then transform result
+ munched <- munch_data(data, dist, segment_length)
+ coord_transform(coord, munched, range)
+}
+
# For munching, only grobs are lines and polygons: everything else is
# transfomed into those special cases by the geom.
#
View
325 R/coord-polar.r
@@ -3,7 +3,6 @@
#' The polar coordinate system is most commonly used for pie charts, which
#' are a stacked bar chart in polar coordinates.
#'
-#' @name coord_polar
#' @param theta variable to map angle to (\code{x} or \code{y})
#' @param start offset of starting point from 12 o'clock in radians
#' @param direction 1, clockwise; -1, anticlockwise
@@ -52,184 +51,188 @@
#' doh + geom_bar(width = 1) + coord_polar()
#' # Race track plot
#' doh + geom_bar(width = 0.9, position = "fill") + coord_polar(theta = "y")
-CoordPolar <- proto(Coord, {
- objname <- "polar"
-
- new <- function(., theta="x", start = 0, direction = 1, expand = FALSE) {
- theta <- match.arg(theta, c("x", "y"))
- r <- if (theta == "x") "y" else "x"
-
- c(
- .$proto(
- theta = theta, r = r,
- start = start, direction = sign(direction),
- expand = expand
- ),
- list(opts(aspect.ratio = 1))
- )
- }
+coord_polar <- function(theta = "x", start = 0, direction = 1, expand = FALSE) {
+ theta <- match.arg(theta, c("x", "y"))
+ r <- if (theta == "x") "y" else "x"
- distance <- function(., x, y, details) {
- max_dist <- 2*pi*abs(diff(details$r.range))
-
- if (.$theta == "x") {
- r <- y
- theta <- .$theta_rescale_no_clip(x, details)
- } else {
- r <- x
- theta <- .$theta_rescale_no_clip(y, details)
- }
- px <- r*cos(theta)
- py <- r*sin(theta)
- pz <- theta*r
+ coord(
+ theta = theta, r = r,
+ start = start, direction = sign(direction),
+ expand = expand,
+ subclass = "polar"
+ )
+}
+
+#' @S3method coord_aspect polar
+coord_aspect.polar <- function(coord, details) 1
- sqrt(diff(px)^2+diff(py)^2+diff(pz)^2) / max_dist
+#' @S3method coord_distance polar
+coord_distance.polar <- function(coord, x, y, details) {
+ max_dist <- 2 * pi * abs(diff(details$r.range))
+
+ if (coord$theta == "x") {
+ r <- y
+ theta <- coord$theta_rescale_no_clip(x, details)
+ } else {
+ r <- x
+ theta <- coord$theta_rescale_no_clip(y, details)
}
+ px <- r * cos(theta)
+ py <- r * sin(theta)
+ pz <- theta * r
- compute_ranges <- function(., scales) {
- if (.$expand) {
- x.range <- scale_dimension(scales$x)
- y.range <- scale_dimension(scales$y)
- } else {
- x.range <- scale_dimension(scales$x, c(0, 0))
- y.range <- scale_dimension(scales$y, c(0, 0))
- }
+ sqrt(diff(px) ^ 2 + diff(py) ^ 2 + diff(pz) ^ 2) / max_dist
+}
- x.major <- scale_break_positions(scales$x)
- x.minor <- scale_breaks_minor(scales$x)
- x.labels <- scale_labels(scales$x, x.major)
+#' @S3method coord_ranges polar
+coord_train.polar <- function(coord, scales) {
+ if (coord$expand) {
+ x.range <- scale_dimension(scales$x)
+ y.range <- scale_dimension(scales$y)
+ } else {
+ x.range <- scale_dimension(scales$x, c(0, 0))
+ y.range <- scale_dimension(scales$y, c(0, 0))
+ }
- y.major <- scale_break_positions(scales$y)
- y.minor <- scale_breaks_minor(scales$y)
- y.labels <- scale_labels(scales$y, y.major)
-
- details <- list(
- x.range = x.range, y.range = y.range,
- x.major = x.major, x.minor = x.minor, x.labels = x.labels,
- y.major = y.major, y.minor = y.minor, y.labels = y.labels
- )
-
- if (.$theta == "y") {
- names(details) <- gsub("x\\.", "r.", names(details))
- names(details) <- gsub("y\\.", "theta.", names(details))
- } else {
- names(details) <- gsub("x\\.", "theta.", names(details))
- names(details) <- gsub("y\\.", "r.", names(details))
- }
+ x.major <- scale_break_positions(scales$x)
+ x.minor <- scale_breaks_minor(scales$x)
+ x.labels <- scale_labels(scales$x, x.major)
- details
+ y.major <- scale_break_positions(scales$y)
+ y.minor <- scale_breaks_minor(scales$y)
+ y.labels <- scale_labels(scales$y, y.major)
+
+ details <- list(
+ x.range = x.range, y.range = y.range,
+ x.major = x.major, x.minor = x.minor, x.labels = x.labels,
+ y.major = y.major, y.minor = y.minor, y.labels = y.labels
+ )
+
+ if (coord$theta == "y") {
+ names(details) <- gsub("x\\.", "r.", names(details))
+ names(details) <- gsub("y\\.", "theta.", names(details))
+ } else {
+ names(details) <- gsub("x\\.", "theta.", names(details))
+ names(details) <- gsub("y\\.", "r.", names(details))
}
- rename_data <- function(., data) {
- if (.$theta == "y") {
- rename(data, c("y" = "theta", "x" = "r"))
- } else {
- rename(data, c("y" = "r", "x" = "theta"))
- }
- }
+ details
+}
- theta_rescale_no_clip <- function(., x, details) {
- rotate <- function(x) (x + .$start) * .$direction
- rotate(rescale(x, c(0, 2 * pi), details$theta.range))
+rename_data <- function(coord, data) {
+ if (coord$theta == "y") {
+ rename(data, c("y" = "theta", "x" = "r"))
+ } else {
+ rename(data, c("y" = "r", "x" = "theta"))
}
+}
- theta_rescale <- function(., x, details) {
- rotate <- function(x) (x + .$start) %% (2 * pi) * .$direction
- rotate(rescale(x, c(0, 2 * pi), details$theta.range))
- }
-
- r_rescale <- function(., x, details) {
- rescale(x, c(0, 0.4), details$r.range)
- }
+theta_rescale_no_clip <- function(coord, x, details) {
+ rotate <- function(x) (x + coord$start) * coord$direction
+ rotate(rescale(x, c(0, 2 * pi), details$theta.range))
+}
- muncher <- function(.) TRUE
- transform <- function(., data, details) {
- data <- .$rename_data(data)
-
- data <- within(data, {
- r <- .$r_rescale(r, details)
- theta <- .$theta_rescale(theta, details)
+theta_rescale <- function(coord, x, details) {
+ rotate <- function(x) (x + coord$start) %% (2 * pi) * coord$direction
+ rotate(rescale(x, c(0, 2 * pi), details$theta.range))
+}
+
+r_rescale <- function(coord, x, details) {
+ rescale(x, c(0, 0.4), details$r.range)
+}
- x <- r * sin(theta) + 0.5
- y <- r * cos(theta) + 0.5
- })
- }
+#' @S3method coord_transform polar
+coord_transform.polar <- function(coord, data, details) {
+ data <- rename_data(coord, data)
- guide_axis_v <- function(., details, theme) {
- guide_axis(.$r_rescale(details$r.major, details) + 0.5, details$r.labels, "left", theme)
- }
- guide_axis_h <- function(., details, theme) {
- guide_axis(NA, "", "bottom", theme)
- }
+ data <- within(data, {
+ r <- r_rescale(coord, r, details)
+ theta <- theta_rescale(coord, theta, details)
+
+ x <- r * sin(theta) + 0.5
+ y <- r * cos(theta) + 0.5
+ })
+}
+
+#' @S3method coord_render_axis_v polar
+coord_render_axis_v.polar <- function(coord, details, theme) {
+ x <- r_rescale(coord,details$r.major, details) + 0.5
+ guide_axis(x, details$r.labels, "left", theme)
+}
+#' @S3method coord_render_axis_h polar
+coord_render_axis_h.polar <- function(coord, details, theme) {
+ guide_axis(NA, "", "bottom", theme)
+}
+
+#' @S3method coord_render_bg polar
+coord_render_bg.polar <- function(coord, details, theme) {
+ details <- rename_data(coord, details)
- guide_background <- function(., details, theme) {
- details <- .$rename_data(details)
-
- theta <- .$theta_rescale(details$theta.major, details)
- thetamin <- .$theta_rescale(details$theta.minor, details)
- thetafine <- seq(0, 2 * pi, length=100)
-
- r <- 0.4
- rfine <- c(.$r_rescale(details$r.major, details), 0.45)
-
- ggname("grill", grobTree(
- theme_render(theme, "panel.background"),
- if (length(labels) > 0) theme_render(
- theme, "panel.grid.major", name = "angle",
- x = c(rbind(0, 0.45 * sin(theta))) + 0.5,
- y = c(rbind(0, 0.45 * cos(theta))) + 0.5,
- id.lengths = rep(2, length(theta)),
- default.units="native"
- ),
- theme_render(
- theme, "panel.grid.minor", name = "angle",
- x = c(rbind(0, 0.45 * sin(thetamin))) + 0.5,
- y = c(rbind(0, 0.45 * cos(thetamin))) + 0.5,
- id.lengths = rep(2, length(thetamin)),
- default.units="native"
- ),
-
- theme_render(
- theme, "panel.grid.major", name = "radius",
- x = rep(rfine, each=length(thetafine)) * sin(thetafine) + 0.5,
- y = rep(rfine, each=length(thetafine)) * cos(thetafine) + 0.5,
- id.lengths = rep(length(thetafine), length(rfine)),
- default.units="native"
- )
- ))
- }
+ theta <- theta_rescale(coord, details$theta.major, details)
+ thetamin <- theta_rescale(coord, details$theta.minor, details)
+ thetafine <- seq(0, 2 * pi, length=100)
+
+ r <- 0.4
+ rfine <- c(r_rescale(coord, details$r.major, details), 0.45)
- guide_foreground <- function(., details, theme) {
- theta <- .$theta_rescale(details$theta.major, details)
- labels <- details$theta.labels
+ ggname("grill", grobTree(
+ theme_render(theme, "panel.background"),
+ if (length(labels) > 0) theme_render(
+ theme, "panel.grid.major", name = "angle",
+ x = c(rbind(0, 0.45 * sin(theta))) + 0.5,
+ y = c(rbind(0, 0.45 * cos(theta))) + 0.5,
+ id.lengths = rep(2, length(theta)),
+ default.units="native"
+ ),
+ theme_render(
+ theme, "panel.grid.minor", name = "angle",
+ x = c(rbind(0, 0.45 * sin(thetamin))) + 0.5,
+ y = c(rbind(0, 0.45 * cos(thetamin))) + 0.5,
+ id.lengths = rep(2, length(thetamin)),
+ default.units="native"
+ ),
- # Combine the two ends of the scale if they are close
- theta <- theta[!is.na(theta)]
- ends_apart <- (theta[length(theta)] - theta[1]) %% (2*pi)
- if (ends_apart < 0.05) {
- n <- length(labels)
- if (is.expression(labels)) {
- combined <- substitute(paste(a, "/", b),
- list(a = labels[[1]], b = labels[[n]]))
- } else {
- combined <- paste(labels[1], labels[n], sep="/")
- }
- labels[[n]] <- combined
- labels <- labels[-1]
- theta <- theta[-1]
- }
-
- grobTree(
- if (length(labels) > 0) theme_render(
- theme, "axis.text.x",
- labels, 0.45 * sin(theta) + 0.5, 0.45 * cos(theta) + 0.5,
- hjust = 0.5, vjust = 0.5,
- default.units="native"
- ),
- theme_render(theme, "panel.border")
+ theme_render(
+ theme, "panel.grid.major", name = "radius",
+ x = rep(rfine, each=length(thetafine)) * sin(thetafine) + 0.5,
+ y = rep(rfine, each=length(thetafine)) * cos(thetafine) + 0.5,
+ id.lengths = rep(length(thetafine), length(rfine)),
+ default.units="native"
)
- }
+ ))
+}
+#' @S3method coord_render_fg polar
+coord_render_fg.polar <- function(coord, details, theme) {
+ theta <- theta_rescale(coord, details$theta.major, details)
+ labels <- details$theta.labels
+
+ # Combine the two ends of the scale if they are close
+ theta <- theta[!is.na(theta)]
+ ends_apart <- (theta[length(theta)] - theta[1]) %% (2*pi)
+ if (ends_apart < 0.05) {
+ n <- length(labels)
+ if (is.expression(labels)) {
+ combined <- substitute(paste(a, "/", b),
+ list(a = labels[[1]], b = labels[[n]]))
+ } else {
+ combined <- paste(labels[1], labels[n], sep="/")
+ }
+ labels[[n]] <- combined
+ labels <- labels[-1]
+ theta <- theta[-1]
+ }
- icon <- function(.) circleGrob(r = c(0.1, 0.25, 0.45), gp=gpar(fill=NA))
-})
+ grobTree(
+ if (length(labels) > 0) theme_render(
+ theme, "axis.text.x",
+ labels, 0.45 * sin(theta) + 0.5, 0.45 * cos(theta) + 0.5,
+ hjust = 0.5, vjust = 0.5,
+ default.units="native"
+ ),
+ theme_render(theme, "panel.border")
+ )
+}
+
+
+icon <- function(.) circleGrob(r = c(0.1, 0.25, 0.45), gp=gpar(fill=NA))
View
118 R/coord-transform.r
@@ -1,6 +1,5 @@
#' Transformed cartesian coordinate system.
#'
-#' @name coord_trans
#' @param ytrans transformer for x axis
#' @param xtrans transformer for y axis
#' @export
@@ -49,76 +48,63 @@
#' plot + coord_trans(x = "log10")
#' plot + coord_trans(x = "sqrt")
#' plot + coord_trans(x = "sqrt", y = "reverse")
-CoordTrans <- proto(CoordCartesian, expr={
- objname <- "trans"
+coord_trans <- function(xtrans = "identity", ytrans = "identity") {
+ if (is.character(xtrans)) xtrans <- as.trans(xtrans)
+ if (is.character(ytrans)) ytrans <- as.trans(ytrans)
-
- new <- function(., xtrans="identity", ytrans="identity") {
- if (is.character(xtrans)) xtrans <- as.trans(xtrans)
- if (is.character(ytrans)) ytrans <- as.trans(ytrans)
- .$proto(xtr = xtrans, ytr = ytrans)
- }
-
- muncher <- function(.) TRUE
-
- distance <- function(., x, y, details) {
- max_dist <- dist_euclidean(details$x.range, details$y.range)
- dist_euclidean(.$xtr$transform(x), .$ytr$transform(y)) / max_dist
- }
+ coord(xtr = xtrans, ytr = ytrans, subclass = "trans")
+}
- transform <- function(., data, details) {
- trans_x <- function(data) .$transform_x(data, details$x.range)
- trans_y <- function(data) .$transform_y(data, details$y.range)
-
- data <- transform_position(data, trans_x, trans_y)
- transform_position(data, trim_infinite_01, trim_infinite_01)
- }
- transform_x <- function(., x, range) {
- rescale(.$xtr$transform(x), 0:1, range)
- }
- transform_y <- function(., x, range) {
- rescale(.$ytr$transform(x), 0:1, range)
- }
+#' @S3method coord_distance trans
+coord_distance.trans <- function(coord, x, y, details) {
+ max_dist <- dist_euclidean(details$x.range, details$y.range)
+ dist_euclidean(coord$xtr$transform(x), coord$ytr$transform(y)) / max_dist
+}
- compute_ranges <- function(., scales) {
- exp_trans_range <- function(trans, scale) {
- range <- trans_range(trans, scale_dimension(scale, c(0, 0)))
- expand_range(range, scale$expand[1], scale$expand[2])
- }
- x.range <- exp_trans_range(.$xtr, scales$x)
- x.major <- .$transform_x(scale_break_positions(scales$x), x.range)
- x.minor <- .$transform_x(scale_breaks_minor(scales$x), x.range)
- x.labels <- scale_labels(scales$x)
+#' @S3method coord_transform trans
+coord_transform.trans <- function(coord, data, details) {
+ trans_x <- function(data) transform_x(coord, data, details$x.range)
+ trans_y <- function(data) transform_y(coord, data, details$y.range)
+
+ data <- transform_position(data, trans_x, trans_y)
+ transform_position(data, trim_infinite_01, trim_infinite_01)
+}
+transform_x <- function(coord, x, range) {
+ rescale(coord$xtr$transform(x), 0:1, range)
+}
+transform_y <- function(coord, x, range) {
+ rescale(coord$ytr$transform(x), 0:1, range)
+}
- y.range <- exp_trans_range(.$ytr, scales$y)
- y.major <- .$transform_y(scale_break_positions(scales$y), y.range)
- y.minor <- .$transform_y(scale_breaks_minor(scales$y), y.range)
- y.labels <- scale_labels(scales$y)
-
- list(
- x.range = x.range, y.range = y.range,
- x.major = x.major, x.minor = x.minor, x.labels = x.labels,
- y.major = y.major, y.minor = y.minor, y.labels = y.labels
- )
+#' @S3method coord_train trans
+coord_train.trans <- function(coord, scales) {
+ exp_trans_range <- function(trans, scale) {
+ range <- trans_range(trans, scale_dimension(scale, c(0, 0)))
+ expand_range(range, scale$expand[1], scale$expand[2])
}
+ x.range <- exp_trans_range(coord$xtr, scales$x)
+ x.major <- transform_x(coord, scale_break_positions(scales$x), x.range)
+ x.minor <- transform_x(coord, scale_breaks_minor(scales$x), x.range)
+ x.labels <- scale_labels(scales$x)
-
- pprint <- function(., newline=TRUE) {
- cat("coord_", .$objname, ": ",
- "x = ", .$xtr$objname, ", ",
- "y = ", .$ytr$objname, sep = ""
- )
-
- if (newline) cat("\n")
- }
+ y.range <- exp_trans_range(coord$ytr, scales$y)
+ y.major <- transform_y(coord, scale_break_positions(scales$y), y.range)
+ y.minor <- transform_y(coord, scale_breaks_minor(scales$y), y.range)
+ y.labels <- scale_labels(scales$y)
+
+ list(
+ x.range = x.range, y.range = y.range,
+ x.major = x.major, x.minor = x.minor, x.labels = x.labels,
+ y.major = y.major, y.minor = y.minor, y.labels = y.labels
+ )
+}
- # Documentation -----------------------------------------------
- icon <- function(.) {
- breaks <- cumsum(1 / 2^(1:5))
- gTree(children=gList(
- segmentsGrob(breaks, 0, breaks, 1),
- segmentsGrob(0, breaks, 1, breaks)
- ))
- }
-})
+# Documentation -----------------------------------------------
+icon <- function(.) {
+ breaks <- cumsum(1 / 2^(1:5))
+ gTree(children=gList(
+ segmentsGrob(breaks, 0, breaks, 1),
+ segmentsGrob(0, breaks, 1, breaks)
+ ))
+}
View
12 R/facet-grid-.r
@@ -223,12 +223,14 @@ facet_axes <- function(facet, panel, coord, theme) {
# Horizontal axes
cols <- which(panel$layout$ROW == 1)
- grobs <- lapply(panel$ranges[cols], coord$guide_axis_h, theme)
+ grobs <- lapply(panel$ranges[cols], coord_render_axis_h,
+ coord = coord, theme = theme)
axes$b <- layout_row("axis-b", grobs)$add_col_space(theme$panel.margin)
# Vertical axes
rows <- which(panel$layout$COL == 1)
- grobs <- lapply(panel$ranges[rows], coord$guide_axis_v, theme)
+ grobs <- lapply(panel$ranges[rows], coord_render_axis_v,
+ coord = coord, theme = theme)
axes$l <- layout_col("axis-l", grobs)$add_row_space(theme$panel.margin)
axes
@@ -240,7 +242,7 @@ facet_panels <- function(facet, panel, coord, theme, geom_grobs) {
# ask the coordinate system if it wants to specify one
aspect_ratio <- theme$aspect.ratio
if (is.null(aspect_ratio) && !facet$free$x && !facet$free$y) {
- aspect_ratio <- coord$compute_aspect(coord_details[[1]])
+ aspect_ratio <- coord_aspect(coord, coord_details[[1]])
}
if (is.null(aspect_ratio)) {
aspect_ratio <- 1
@@ -255,8 +257,8 @@ facet_panels <- function(facet, panel, coord, theme, geom_grobs) {
nrow <- max(panel$layout$ROW)
panel_grobs <- lapply(panels, function(i) {
- fg <- coord$guide_foreground(panel$range[[i]], theme)
- bg <- coord$guide_background(panel$range[[i]], theme)
+ fg <- coord_render_fg(coord, panel$range[[i]], theme)
+ bg <- coord_render_bg(coord, panel$range[[i]], theme)
geom_grobs <- lapply(geom_grobs, "[[", i)
panel_grobs <- c(list(bg), geom_grobs, list(fg))
View
13 R/facet-null.r
@@ -27,7 +27,7 @@ facet_render.null <- function(facet, panel, coord, theme, geom_grobs) {
range <- panel$ranges[[1]]
# Figure out aspect ratio
- aspect_ratio <- theme$aspect.ratio %||% coord$compute_aspect(range)
+ aspect_ratio <- theme$aspect.ratio %||% coord_aspect(coord, range)
if (is.null(aspect_ratio)) {
aspect_ratio <- 1
respect <- FALSE
@@ -35,16 +35,16 @@ facet_render.null <- function(facet, panel, coord, theme, geom_grobs) {
respect <- TRUE
}
- fg <- coord$guide_foreground(range, theme)
- bg <- coord$guide_background(range, theme)
+ fg <- coord_render_fg(coord, range, theme)
+ bg <- coord_render_bg(coord, range, theme)
# Flatten layers - we know there's only one panel
geom_grobs <- lapply(geom_grobs, "[[", 1)
panel_grobs <- c(list(bg), geom_grobs, list(fg))
panel_grob <- gTree(children = do.call("gList", panel_grobs))
- axis_h <- coord$guide_axis_h(range, theme)
- axis_v <- coord$guide_axis_v(range, theme)
+ axis_h <- coord_render_axis_h(coord, range, theme)
+ axis_v <- coord_render_axis_v(coord, range, theme)
all <- matrix(list(
axis_v, panel_grob,
@@ -53,7 +53,8 @@ facet_render.null <- function(facet, panel, coord, theme, geom_grobs) {
layout <- layout_matrix("layout", all,
widths = unit.c(grobWidth(axis_v), unit(1, "null")),
- heights = unit.c(unit(1, "null"), grobHeight(axis_h))
+ heights = unit.c(unit(1, "null"), grobHeight(axis_h)),
+ respect = respect
)
layout
View
2  R/geom-hex.r
@@ -8,7 +8,7 @@ GeomHex <- proto(Geom, {
objname <- "hex"
draw <- function(., data, scales, coordinates, ...) {
- with(coordinates$transform(data, scales),
+ with(coord_transform(coordinates, data, scales),
ggname(.$my_name(), hexGrob(x, y, col=colour,
fill = alpha(fill, alpha)))
)
View
2  R/geom-linerange.r
@@ -37,7 +37,7 @@ GeomLinerange <- proto(Geom, {
required_aes <- c("x", "ymin", "ymax")
draw <- function(., data, scales, coordinates, ...) {
- munched <- coordinates$transform(data, scales)
+ munched <- coord_transform(coordinates, data, scales)
ggname(.$my_name(), GeomSegment$draw(transform(data, xend=x, y=ymin, yend=ymax), scales, coordinates, ...))
}
View
2  R/geom-path-.r
@@ -107,7 +107,7 @@ GeomPath <- proto(Geom, {
" (geom_path).", call. = FALSE)
}
- munched <- coordinates$munch(data, scales)
+ munched <- coord_munch(coordinates, data, scales)
# Silently drop lines with less than two points, preserving order
rows <- ave(seq_len(nrow(munched)), munched$group, FUN = length)
View
4 R/geom-point-.r
@@ -92,8 +92,8 @@ GeomPoint <- proto(Geom, {
data <- remove_missing(data, na.rm,
c("x", "y", "size", "shape"), name = "geom_point")
if (empty(data)) return(zeroGrob())
-
- with(coordinates$transform(data, scales),
+
+ with(coord_transform(coordinates, data, scales),
ggname(.$my_name(), pointsGrob(x, y, size=unit(size, "mm"), pch=shape,
gp=gpar(col=alpha(colour, alpha), fill = fill, fontsize = size * .pt)))
)
View
2  R/geom-polygon.r
@@ -51,7 +51,7 @@ GeomPolygon <- proto(Geom, {
if (n == 1) return()
ggname(.$my_name(), gTree(children=gList(
- with(coordinates$munch(data, scales),
+ with(coord_munch(coordinates,data, scales),
polygonGrob(x, y, default.units="native",
gp=gpar(col=colour, fill=alpha(fill, alpha), lwd=size * .pt,
lty=linetype))
View
4 R/geom-rect.r
@@ -19,7 +19,7 @@ GeomRect <- proto(Geom, {
required_aes <- c("xmin", "xmax", "ymin", "ymax")
draw <- draw_groups <- function(., data, scales, coordinates, ...) {
- if (coordinates$muncher()) {
+ if (!is.linear(coordinates)) {
aesthetics <- setdiff(
names(data), c("x", "y", "xmin","xmax", "ymin", "ymax")
)
@@ -34,7 +34,7 @@ GeomRect <- proto(Geom, {
ggname("bar",do.call("grobTree", polys))
} else {
- with(coordinates$transform(data, scales),
+ with(coord_transform(coordinates, data, scales),
ggname(.$my_name(), rectGrob(
xmin, ymax,
width = xmax - xmin, height = ymax - ymin,
View
2  R/geom-ribbon-.r
@@ -68,7 +68,7 @@ GeomRibbon <- proto(Geom, {
positions <- summarise(data,
x = c(x, rev(x)), y = c(ymax, rev(ymin)), id = c(ids, rev(ids)))
- munched <- coordinates$munch(positions, scales)
+ munched <- coord_munch(coordinates,positions, scales)
ggname(.$my_name(), polygonGrob(
munched$x, munched$y, id = munched$id,
View
2  R/geom-rug.r
@@ -12,7 +12,7 @@ GeomRug <- proto(Geom, {
draw <- function(., data, scales, coordinates, ...) {
rugs <- list()
- data <- coordinates$transform(data, scales)
+ data <- coord_transform(coordinates, data, scales)
if (!is.null(data$x)) {
rugs$x <- with(data, segmentsGrob(
x0 = unit(x, "native"), x1 = unit(x, "native"),
View
4 R/geom-segment.r
@@ -34,8 +34,8 @@ GeomSegment <- proto(Geom, {
objname <- "segment"
draw <- function(., data, scales, coordinates, arrow=NULL, ...) {
- if (!coordinates$muncher()) {
- return(with(coordinates$transform(data, scales),
+ if (is.linear(coordinates)) {
+ return(with(coord_transform(coordinates, data, scales),
segmentsGrob(x, y, xend, yend, default.units="native",
gp = gpar(col=alpha(colour, alpha), lwd=size * .pt,
lty=linetype, lineend = "butt"),
View
13 R/geom-text.r
@@ -33,13 +33,6 @@
#' geom=c("point", "text"))
#' qplot(wt, mpg, data = mtcars, label = rownames(mtcars), size = wt) +
#' geom_text(colour = "red")
-#'
-#' # You can specify fontfamily, fontface and lineheight
-#' p <- ggplot(mtcars, aes(x=wt, y=mpg, label=rownames(mtcars)))
-#' p + geom_text(fontface=3)
-#' p + geom_text(fontface=am+1)
-#' p + geom_text(aes(family=c("serif", "mono")[am+1]))
-
GeomText <- proto(Geom, {
objname <- "text"
@@ -50,9 +43,9 @@ GeomText <- proto(Geom, {
lab <- parse(text = lab)
}
- with(coordinates$transform(data, scales),
+ with(coord_transform(coordinates, data, scales),
textGrob(lab, x, y, default.units="native", hjust=hjust, vjust=vjust, rot=angle,
- gp=gpar(col=alpha(colour, alpha), fontsize=size * .pt, fontfamily=family, fontface=fontface, lineheight=lineheight))
+ gp=gpar(col=alpha(colour, alpha), fontsize=size * .pt))
)
}
@@ -68,7 +61,7 @@ GeomText <- proto(Geom, {
icon <- function(.) textGrob("text", rot=45, gp=gpar(cex=1.2))
default_stat <- function(.) StatIdentity
required_aes <- c("x", "y", "label")
- default_aes <- function(.) aes(colour="black", size=5 , angle=0, hjust=0.5, vjust=0.5, alpha = 1, family="", fontface=1, lineheight=1.2)
+ default_aes <- function(.) aes(colour="black", size=5 , angle=0, hjust=0.5, vjust=0.5, alpha = 1)
guide_geom <- function(x) "text"
})
View
4 R/panel.r
@@ -145,8 +145,8 @@ panel_scales <- function(panel, i) {
# Compute ranges and dimensions of each panel, using the coord.
train_ranges <- function(panel, coord) {
compute_range <- function(ix, iy) {
- # TODO: change compute_ranges method to take individual x and y scales
- coord$compute_ranges(list(x = panel$x_scales[[ix]], y = panel$y_scales[[iy]]))
+ # TODO: change coord_train method to take individual x and y scales
+ coord_train(coord, list(x = panel$x_scales[[ix]], y = panel$y_scales[[iy]]))
}
panel$ranges <- Map(compute_range,
View
3  R/plot-construction.r
@@ -40,6 +40,9 @@
labels <- lapply(object, deparse)
names(labels) <- names(object)
p <- update_labels(p, labels)
+ } else if (is.coord(object)) {
+ p$coordinates <- object
+ p
} else if (is.facet(object)) {
p$facet <- object
p
View
2  R/plot-render.r
@@ -61,7 +61,7 @@ ggplotGrob <- function(plot, data = ggplot_build(plot), drop = plot$options$drop
title <- theme_render(theme, "plot.title", plot$options$title)
- labels <- plot$coordinates$labels(list(
+ labels <- coord_labels(plot$coordinates, list(
x = xlabel(plot$facet, theme),
y = ylabel(plot$facet, theme)
))
View
2  R/plot.r
@@ -31,7 +31,7 @@ ggplot.data.frame <- function(data, mapping=aes(), ..., environment = globalenv(
scales = Scales$new(),
mapping = mapping,
options = list(),
- coordinates = CoordCartesian$new(),
+ coordinates = coord_cartesian(),
facet = facet_null(),
plot_env = environment
), class="ggplot")
View
4 R/xxx-codegen.r
@@ -4,8 +4,8 @@
# @keyword internal
accessors_print <- function(file = "") {
funs <- sort(c(
- Geom$accessors(), Stat$accessors(), Scale$accessors(),
- Coord$accessors(), Position$accessors(), Facet$accessors()
+ Geom$accessors(), Stat$accessors(),
+ Position$accessors(),
))
cat(funs, file=file, sep="")
}
View
6 R/xxx.r
@@ -1,9 +1,3 @@
-coord_cartesian <- CoordCartesian$build_accessor()
-coord_fixed <- CoordFixed$build_accessor()
-coord_flip <- CoordFlip$build_accessor()
-coord_map <- CoordMap$build_accessor()
-coord_polar <- CoordPolar$build_accessor()
-coord_trans <- CoordTrans$build_accessor()
geom_abline <- GeomAbline$build_accessor()
geom_area <- GeomArea$build_accessor()
geom_bar <- GeomBar$build_accessor()
View
3  R/zxx.r
@@ -30,6 +30,3 @@ scale_color_grey <- scale_colour_grey
scale_color_hue <- scale_colour_hue
scale_color_identity <- scale_colour_identity
scale_color_manual <- scale_colour_manual
-
-# Old names
-coord_equal <- coord_fixed
View
2  inst/tests/test-facet-layout.r
@@ -63,7 +63,7 @@ test_that("grid: crossed rows/cols create no more combinations than necessary",
test_that("grid: nested rows/cols create no more combinations than necessary", {
one <- layout_grid(list(mpg), c("drv", "cyl"))
expect_that(one$PANEL, equals(factor(1:9)))
- expect_that(one$ROW, equals(factor(1:9)))
+ expect_that(one$ROW, equals(1:9))
})
test_that("grid: margins add correct combinations", {
View
16 man/coord.Rd
@@ -0,0 +1,16 @@
+\name{coord}
+\alias{coord}
+\title{New coordinate system.}
+\usage{coord(..., subclass=c())}
+
+\description{
+ New coordinate system.
+}
+
+\details{
+ Internal use only.
+}
+\keyword{internal}
+\arguments{
+ \item{...}{object fields}
+}
View
1  man/coord_cartesian.Rd
@@ -1,6 +1,7 @@
\name{coord_cartesian}
\alias{coord_cartesian}
\title{Cartesian coordinates.}
+\usage{coord_cartesian(xlim, ylim, wise=FALSE)}
\description{
Cartesian coordinates.
View
1  man/coord_fixed.Rd
@@ -1,5 +1,6 @@
\name{coord_fixed}
\title{Cartesian coordinates with fixed relationship between x and y scales.}
+\usage{coord_fixed(ratio=1)}
\description{
Cartesian coordinates with fixed relationship between x
View
1  man/coord_flip.Rd
@@ -1,6 +1,7 @@
\name{coord_flip}
\alias{coord_flip}
\title{Flipped cartesian coordinates.}
+\usage{coord_flip(...)}
\description{
Flipped cartesian coordinates.
View
2  man/coord_map.Rd
@@ -1,6 +1,8 @@
\name{coord_map}
\alias{coord_map}
\title{Map projections.}
+\usage{coord_map(projection="mercator", ..., orientation, xlim,
+ ylim)}
\description{
Map projections.
View
1  man/coord_polar.Rd
@@ -1,6 +1,7 @@
\name{coord_polar}
\alias{coord_polar}
\title{Polar coordinates.}
+\usage{coord_polar(theta="x", start=0, direction=1, expand=FALSE)}
\description{
Polar coordinates.
View
1  man/coord_trans.Rd
@@ -1,6 +1,7 @@
\name{coord_trans}
\alias{coord_trans}
\title{Transformed cartesian coordinate system.}
+\usage{coord_trans(xtrans="identity", ytrans="identity")}
\description{
Transformed cartesian coordinate system.
Please sign in to comment.
Something went wrong with that request. Please try again.