├── src ├── .gitignore ├── utils.cpp ├── abs-max.cpp ├── resolution.cpp ├── ungroup.cpp ├── heap.cpp ├── geometry.h ├── dp-distance.cpp ├── warp.cpp ├── vw-distance.cpp ├── heap.h ├── stack.cpp └── RcppExports.cpp ├── .gitignore ├── data ├── nz.rda ├── bar_ex.rda ├── scatter_ex.rda └── histogram_ex.rda ├── R ├── gggeom.R ├── data.R ├── skyline.R ├── resolution.R ├── simplify.R ├── flip.R ├── rotate.R ├── RcppExports.R ├── utils.R ├── dodge.R ├── compute-dp-distance.R ├── render-contour.R ├── compute-vw-distance.R ├── coords.R ├── rescale.R ├── reflect.R ├── warp.R ├── jitter.R ├── transform.R ├── pointificate.R ├── stack.R └── render.R ├── .Rbuildignore ├── tests ├── testthat.R └── testthat │ ├── test-stack.R │ ├── test-heap.R │ └── test-skyline.R ├── man ├── pipe.Rd ├── geometry_dodge.Rd ├── gggeom-data.Rd ├── render_arc.Rd ├── render_point.Rd ├── geometry_flip.Rd ├── render_ribbon.Rd ├── geometry_simplify.Rd ├── resolution.Rd ├── geometry_reflect.Rd ├── render_segment.Rd ├── geometry_scale.Rd ├── coords.Rd ├── render_contour.Rd ├── geometry_jitter.Rd ├── render_rect.Rd ├── geometry_pointificate.Rd ├── geometry_rotate.Rd ├── geometry_warp.Rd ├── geometry_transform.Rd ├── compute_dp_distance.Rd ├── render_path.Rd ├── compute_vw_distance.Rd └── geometry_stack.Rd ├── gggeom.Rproj ├── data-raw ├── nz.R └── examples.R ├── DESCRIPTION ├── .travis.yml ├── README.md ├── NAMESPACE └── vignettes └── gggeom.Rmd /src/.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.so 3 | *.dll 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | inst/doc 5 | -------------------------------------------------------------------------------- /data/nz.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rstudio/gggeom/HEAD/data/nz.rda -------------------------------------------------------------------------------- /R/gggeom.R: -------------------------------------------------------------------------------- 1 | #' @useDynLib gggeom 2 | #' @importFrom Rcpp sourceCpp 3 | NULL 4 | -------------------------------------------------------------------------------- /data/bar_ex.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rstudio/gggeom/HEAD/data/bar_ex.rda -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^\.travis\.yml$ 4 | ^data-raw$ 5 | -------------------------------------------------------------------------------- /data/scatter_ex.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rstudio/gggeom/HEAD/data/scatter_ex.rda -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(gggeom) 3 | 4 | test_check("gggeom") 5 | -------------------------------------------------------------------------------- /data/histogram_ex.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rstudio/gggeom/HEAD/data/histogram_ex.rda -------------------------------------------------------------------------------- /man/pipe.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.0.2): do not edit by hand 2 | \name{\%>\%} 3 | \alias{\%>\%} 4 | \title{Pipe operator} 5 | \usage{ 6 | lhs \%>\% rhs 7 | } 8 | \description{ 9 | Pipe operator 10 | } 11 | \keyword{internal} 12 | 13 | -------------------------------------------------------------------------------- /R/data.R: -------------------------------------------------------------------------------- 1 | #' Various dataset to use for exmaples 2 | #' 3 | #' @keywords internal 4 | #' @format Data frames. 5 | #' @name gggeom-data 6 | NULL 7 | 8 | #' @rdname gggeom-data 9 | "bar_ex" 10 | 11 | #' @rdname gggeom-data 12 | "scatter_ex" 13 | 14 | #' @rdname gggeom-data 15 | "histogram_ex" 16 | 17 | #' @rdname gggeom-data 18 | "nz" 19 | -------------------------------------------------------------------------------- /tests/testthat/test-stack.R: -------------------------------------------------------------------------------- 1 | context("stack") 2 | 3 | test_that("uses height of bars", { 4 | rects <- data.frame(x = c(1, 1), y = c(1, 3), width = 1, height = 1) %>% 5 | render_tile(~x, ~y) 6 | 7 | stacked <- rects %>% geometry_stack() 8 | 9 | expect_equal(stacked$y1, c(0, 1)) 10 | expect_equal(stacked$y2, c(1, 2)) 11 | 12 | }) 13 | -------------------------------------------------------------------------------- /src/utils.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | using namespace Rcpp; 3 | 4 | // [[Rcpp::export("`as.data.frame!`")]] 5 | void as_data_frame(List x, int nrow) { 6 | x.attr("class") = "data.frame"; 7 | x.attr("row.names") = IntegerVector::create(NA_INTEGER, -nrow); 8 | if (Rf_isNull(Rf_getAttrib(x, R_NamesSymbol))) { 9 | stop("List must have 'names' attribute set"); 10 | } 11 | } 12 | -------------------------------------------------------------------------------- /R/skyline.R: -------------------------------------------------------------------------------- 1 | skyline <- function(...) { 2 | mat <- do.call(rbind, list(...)) 3 | 4 | sk <- buildSkyline(mat[, 1], mat[, 2], mat[, 3]) 5 | 6 | `as.data.frame!`(sk, length(sk[[1]])) 7 | class(sk) <- c("geom_skyline", "data.frame") 8 | sk 9 | } 10 | 11 | #' @export 12 | plot.geom_skyline <- function(x, y, ...) { 13 | plot_init(x$x, x$h) 14 | lines(x$x, x$h, type = "s", lwd = 2) 15 | points(x$x, x$h, pch = 20, col = "red", cex = 2) 16 | 17 | invisible() 18 | } 19 | -------------------------------------------------------------------------------- /gggeom.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: No 4 | SaveWorkspace: No 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | PackageRoxygenize: rd,collate,namespace 22 | -------------------------------------------------------------------------------- /tests/testthat/test-heap.R: -------------------------------------------------------------------------------- 1 | context("heap") 2 | 3 | test_that("heap sort sorts data", { 4 | x <- runif(1e5) 5 | expect_equal(heap_sort(x), sort(x)) 6 | }) 7 | 8 | test_that("updating heap sorts data", { 9 | x <- runif(1e5) 10 | # Remove duplicates - heap sort is not stable 11 | x <- x[!duplicated(x)] 12 | 13 | expect_equal(heap_update_sort(-x)$sort, sort(-x)) 14 | expect_equal(heap_update_sort(x)$sort, sort(x)) 15 | expect_equal(heap_update_sort(x)$order, order(x)) 16 | }) 17 | -------------------------------------------------------------------------------- /man/geometry_dodge.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.0.2): do not edit by hand 2 | \name{geometry_dodge} 3 | \alias{geometry_dodge} 4 | \title{Dodge objects on next to one another.} 5 | \usage{ 6 | geometry_dodge(geom) 7 | } 8 | \arguments{ 9 | \item{geom}{A geometry data frame.} 10 | } 11 | \description{ 12 | Currently only implemented for rects. 13 | } 14 | \examples{ 15 | bar_ex \%>\% plot() 16 | bar_ex \%>\% geometry_stack() \%>\% plot() 17 | bar_ex \%>\% geometry_dodge() \%>\% plot() 18 | } 19 | 20 | -------------------------------------------------------------------------------- /man/gggeom-data.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.0.2): do not edit by hand 2 | \docType{data} 3 | \name{gggeom-data} 4 | \alias{bar_ex} 5 | \alias{gggeom-data} 6 | \alias{histogram_ex} 7 | \alias{nz} 8 | \alias{scatter_ex} 9 | \title{Various dataset to use for exmaples} 10 | \format{Data frames.} 11 | \usage{ 12 | bar_ex 13 | 14 | scatter_ex 15 | 16 | histogram_ex 17 | 18 | nz 19 | } 20 | \description{ 21 | Various dataset to use for exmaples 22 | } 23 | \keyword{datasets} 24 | \keyword{internal} 25 | 26 | -------------------------------------------------------------------------------- /data-raw/nz.R: -------------------------------------------------------------------------------- 1 | library(maps) 2 | nz_raw <- maps::map("nz", plot = FALSE) 3 | group <- cumsum(is.na(nz_raw$x)) + 1 4 | 5 | x <- nz_raw$x %>% split(group) %>% lapply(function(x) x[!is.na(x)]) %>% unname 6 | y <- nz_raw$y %>% split(group) %>% lapply(function(x) x[!is.na(x)]) %>% unname 7 | island <- gsub(".Island ", "", nz_raw$names) 8 | 9 | nz <- dplyr::data_frame(x_ = coords(x), y_ = coords(y), island) 10 | class(nz) <- c("geom_polygon", "geom_path", "geom", "data.frame") 11 | plot(nz) 12 | devtools::use_data(nz, overwrite = TRUE) 13 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: gggeom 2 | Title: Graphical Geometry 3 | Description: Data structures and operations for the geometric primitives 4 | that underlying all visualisation. 5 | Version: 0.1 6 | Author: RStudio, Inc. 7 | Maintainer: Hadley Wickham 8 | Depends: 9 | R (>= 3.0) 10 | License: GPL-2 11 | LazyData: true 12 | LinkingTo: Rcpp 13 | Imports: 14 | Rcpp, 15 | magrittr, 16 | lazyeval, 17 | methods 18 | Suggests: 19 | testthat, 20 | dplyr, 21 | knitr 22 | VignetteBuilder: knitr 23 | -------------------------------------------------------------------------------- /man/render_arc.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.0.2): do not edit by hand 2 | \name{render_arc} 3 | \alias{render_arc} 4 | \title{Render an arc} 5 | \usage{ 6 | render_arc(data, x, y, r1, r2, theta1, theta2) 7 | } 8 | \arguments{ 9 | \item{data}{A data frame.} 10 | 11 | \item{x,y}{Location of arc} 12 | 13 | \item{r1,r2}{Extent of radius} 14 | 15 | \item{theta1,theta2}{Extent of angle (in radians).} 16 | } 17 | \description{ 18 | Render an arc 19 | } 20 | \examples{ 21 | render_arc(mtcars, ~vs, ~am, 0, 0.1, 0, ~mpg / max(mpg) * 2 * pi) 22 | } 23 | 24 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Sample .travis.yml for R projects from https://github.com/craigcitro/r-travis 2 | 3 | language: c 4 | 5 | before_install: 6 | - curl -OL http://raw.github.com/craigcitro/r-travis/master/scripts/travis-tool.sh 7 | - chmod 755 ./travis-tool.sh 8 | - ./travis-tool.sh bootstrap 9 | 10 | install: 11 | - ./travis-tool.sh install_deps 12 | 13 | script: ./travis-tool.sh run_tests 14 | 15 | after_failure: 16 | - ./travis-tool.sh dump_logs 17 | 18 | notifications: 19 | email: 20 | on_success: change 21 | on_failure: change 22 | -------------------------------------------------------------------------------- /man/render_point.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.0.2): do not edit by hand 2 | \name{render_point} 3 | \alias{render_point} 4 | \alias{render_text} 5 | \title{Render point and text geometries.} 6 | \usage{ 7 | render_point(data, x, y) 8 | 9 | render_text(data, x, y) 10 | } 11 | \arguments{ 12 | \item{data}{A data frame.} 13 | 14 | \item{x,y}{Formulas specifying x and y positions.} 15 | } 16 | \description{ 17 | Render point and text geometries. 18 | } 19 | \examples{ 20 | render_point(mtcars, ~mpg, ~wt) 21 | render_text(mtcars, ~mpg, ~wt) 22 | } 23 | 24 | -------------------------------------------------------------------------------- /src/abs-max.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | using namespace Rcpp; 3 | 4 | // [[Rcpp::export]] 5 | double abs_max_(const NumericVector& x, const bool finite = true) { 6 | double max = -INFINITY; 7 | 8 | int n = x.length(); 9 | for(int i = 0; i < n; ++i) { 10 | double xi = x[i]; 11 | if (!finite) { 12 | if (isnan(xi)) return NA_REAL; 13 | if (xi == INFINITY) return INFINITY; 14 | if (xi == -INFINITY) return INFINITY; 15 | } 16 | 17 | if (xi < 0) xi = -xi; 18 | if (xi > max) max = xi; 19 | } 20 | 21 | return max; 22 | } 23 | -------------------------------------------------------------------------------- /man/geometry_flip.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.0.2): do not edit by hand 2 | \name{geometry_flip} 3 | \alias{geometry_flip} 4 | \title{Flip x and y positions.} 5 | \usage{ 6 | geometry_flip(geom) 7 | } 8 | \arguments{ 9 | \item{geom}{A geometry data frame.} 10 | } 11 | \description{ 12 | Flip x and y positions. 13 | } 14 | \examples{ 15 | scatter_ex \%>\% plot() 16 | scatter_ex \%>\% geometry_flip() \%>\% plot() 17 | 18 | histogram_ex \%>\% plot() 19 | histogram_ex \%>\% geometry_flip() \%>\% plot() 20 | 21 | nz \%>\% plot() 22 | nz \%>\% geometry_flip() \%>\% plot() 23 | } 24 | 25 | -------------------------------------------------------------------------------- /src/resolution.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | using namespace Rcpp; 3 | 4 | // [[Rcpp::export]] 5 | double resolution_numeric(NumericVector x, bool zero = true) { 6 | int n = x.size(); 7 | if (n <= 1) return NAN; 8 | 9 | std::vector y(x.begin(), x.end()); 10 | if (zero) y.push_back(0); 11 | std::sort(y.begin(), y.end()); 12 | 13 | double min = INFINITY; 14 | for (int i = 1; i < n; ++i) { 15 | double dist = y[i] - y[i - 1]; 16 | if (dist == 0) continue; 17 | if (dist < min) { 18 | min = dist; 19 | } 20 | } 21 | 22 | return min; 23 | } 24 | -------------------------------------------------------------------------------- /man/render_ribbon.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.0.2): do not edit by hand 2 | \name{render_ribbon} 3 | \alias{render_area} 4 | \alias{render_ribbon} 5 | \title{Render a ribbon.} 6 | \usage{ 7 | render_ribbon(data, x, y1, y2) 8 | 9 | render_area(data, x, y2) 10 | } 11 | \arguments{ 12 | \item{data}{A data frame.} 13 | 14 | \item{x,y1,y2}{x location and y interval.} 15 | } 16 | \description{ 17 | Render a ribbon. 18 | } 19 | \examples{ 20 | x <- 1:10 21 | y <- runif(10, 0, 2) 22 | df <- data.frame(x = x, y1 = x * 2 - y, y2 = x * 2 + y) 23 | render_ribbon(df, ~x, ~y1, ~y2) 24 | .Last.value \%>\% plot() 25 | } 26 | 27 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # gggeom 2 | 3 | [![Build Status](https://travis-ci.org/rstudio/gggeom.png?branch=master)](https://travis-ci.org/rstudio/gggeom) 4 | 5 | gggeom provides data structures for describing the geometry primitives that underly all visualisations. 6 | 7 | ## Installation 8 | 9 | gggeom is not currently available on CRAN, but you can install it from github with: 10 | 11 | ```R 12 | # install.packages("devtools") 13 | install_github("rstudio/gggeom") 14 | ``` 15 | 16 | Note that since gggeom makes extensive use of Rcpp for high-performance computations, you'll need a development environment with a C++ compiler. 17 | -------------------------------------------------------------------------------- /man/geometry_simplify.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.0.2): do not edit by hand 2 | \name{geometry_simplify} 3 | \alias{geometry_simplify} 4 | \title{Simplify a path geometry with Douglas-Peucker} 5 | \usage{ 6 | geometry_simplify(geom, tol_prop = 0.1, tol_dist = NULL) 7 | } 8 | \arguments{ 9 | \item{geom}{A geometry data frame.} 10 | 11 | \item{tol_prop,tol_dist}{Either specify the proportion of points to keep, 12 | or a distance threshold.} 13 | } 14 | \description{ 15 | Simplify a path geometry with Douglas-Peucker 16 | } 17 | \seealso{ 18 | \code{\link{compute_dp_distance}()} to add the distance as 19 | an explicit column so you can experimenting with different thresholds 20 | more easily. 21 | } 22 | 23 | -------------------------------------------------------------------------------- /src/ungroup.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | using namespace Rcpp; 3 | 4 | // Convert a list of numeric vectors into a single numeric vector where 5 | // each original vector is followed by an NA 6 | // [[Rcpp::export]] 7 | NumericVector ungroupNA(ListOf x) { 8 | int n = x.size(); 9 | 10 | // Figure out total size needed 11 | int n_total = 0; 12 | for (int i = 0; i < n; ++i) { 13 | n_total += x[i].size(); 14 | } 15 | n_total += n; 16 | 17 | NumericVector out(n_total); 18 | int k = 0; 19 | for (int i = 0; i < n; ++i) { 20 | NumericVector xi = x[i]; 21 | int ni = xi.size(); 22 | 23 | for (int j = 0; j < ni; ++j, ++k) { 24 | out[k] = xi[j]; 25 | } 26 | 27 | out[k++] = NA_REAL; 28 | } 29 | 30 | return out; 31 | } 32 | -------------------------------------------------------------------------------- /man/resolution.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.0.2): do not edit by hand 2 | \name{resolution} 3 | \alias{resolution} 4 | \title{Compute the "resolution" of a data vector.} 5 | \usage{ 6 | resolution(x, zero = TRUE) 7 | } 8 | \arguments{ 9 | \item{x}{numeric vector} 10 | 11 | \item{zero}{should a zero value be automatically included in the 12 | computation of resolution} 13 | } 14 | \description{ 15 | The resolution is is the smallest non-zero distance between adjacent 16 | values. If there is only one unique value, then the resolution is defined 17 | to be one. 18 | } 19 | \details{ 20 | If x is an integer vector, then it is assumed to represent a discrete 21 | variable, and the resolution is 1. 22 | } 23 | \examples{ 24 | resolution(1:10) 25 | resolution((1:10) - 0.5) 26 | resolution((1:10) - 0.5, FALSE) 27 | resolution(c(1,2, 10, 20, 50)) 28 | resolution(as.integer(c(1, 10, 20, 50))) # Returns 1 29 | } 30 | 31 | -------------------------------------------------------------------------------- /src/heap.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include "heap.h" 3 | using namespace Rcpp; 4 | 5 | 6 | // [[Rcpp::export]] 7 | List make_heap(NumericVector x) { 8 | return Heap(x).asList(); 9 | } 10 | 11 | // [[Rcpp::export]] 12 | NumericVector heap_sort(NumericVector x) { 13 | Heap h = Heap(x); 14 | 15 | int n = x.size(); 16 | NumericVector out(n); 17 | for (int i = 0; i < n; ++i) { 18 | out[i] = h.pop().second; 19 | } 20 | 21 | return out; 22 | } 23 | 24 | // [[Rcpp::export]] 25 | List heap_update_sort(NumericVector x) { 26 | int n = x.size(); 27 | Heap h = Heap(n); 28 | for (int i = 0; i < n; ++i) { 29 | h.update(i, x[i]); 30 | } 31 | 32 | NumericVector sort(n), order1(n); 33 | for (int i = 0; i < n; ++i) { 34 | std::pair top = h.pop(); 35 | order1[i] = top.first + 1; 36 | sort[i] = top.second; 37 | } 38 | 39 | return List::create( 40 | _["sort"] = sort, 41 | _["order1"] = order1); 42 | } 43 | -------------------------------------------------------------------------------- /R/resolution.R: -------------------------------------------------------------------------------- 1 | #' Compute the "resolution" of a data vector. 2 | #' 3 | #' The resolution is is the smallest non-zero distance between adjacent 4 | #' values. If there is only one unique value, then the resolution is defined 5 | #' to be one. 6 | #' 7 | #' If x is an integer vector, then it is assumed to represent a discrete 8 | #' variable, and the resolution is 1. 9 | #' 10 | #' @param x numeric vector 11 | #' @param zero should a zero value be automatically included in the 12 | #' computation of resolution 13 | #' @export 14 | #' @examples 15 | #' resolution(1:10) 16 | #' resolution((1:10) - 0.5) 17 | #' resolution((1:10) - 0.5, FALSE) 18 | #' resolution(c(1,2, 10, 20, 50)) 19 | #' resolution(as.integer(c(1, 10, 20, 50))) # Returns 1 20 | resolution <- function(x, zero = TRUE) { 21 | if (is.integer(x)) 22 | return(1) 23 | 24 | if (is.list(x)) 25 | return(resolution_numeric(unlist(x), zero = zero)) 26 | 27 | resolution_numeric(x, zero = zero) 28 | } 29 | -------------------------------------------------------------------------------- /src/geometry.h: -------------------------------------------------------------------------------- 1 | // Squared distance between a point (x0, y0) and a line {(x1, y1), (x2, y2)} 2 | // Adapted from http://mathworld.wolfram.com/Point-LineDistance2-Dimensional.html 3 | inline double point_line_dist(double x0, double y0, 4 | double x1, double y1, 5 | double x2, double y2) { 6 | 7 | double x21 = x2 - x1; 8 | double x10 = x1 - x0; 9 | double y21 = y2 - y1; 10 | double y10 = y1 - y0; 11 | 12 | double num = x21 * y10 - x10 * y21; 13 | double den = x21 * x21 + y21 * y21; 14 | 15 | return (num * num) / den; 16 | } 17 | 18 | class Point { 19 | public: 20 | double x, y; 21 | 22 | Point(double x_, double y_) : x(x_), y(y_) {} 23 | 24 | Point combine(Point other, double alpha) { 25 | return Point( 26 | alpha * x + (1 - alpha) * other.x, 27 | alpha * y + (1 - alpha) * other.y 28 | ); 29 | } 30 | 31 | double dist_to_line(Point a, Point b) { 32 | return point_line_dist(x, y, a.x, a.y, b.x, b.y); 33 | } 34 | }; 35 | 36 | -------------------------------------------------------------------------------- /data-raw/examples.R: -------------------------------------------------------------------------------- 1 | library(dplyr) 2 | library(ggstat) 3 | data("mpg", package = "ggplot2") 4 | 5 | scatter_ex <- render_point(mpg, ~cty, ~hwy) %>% select(ends_with("_")) 6 | scatter_ex %>% plot() 7 | scatter_ex %>% geometry_jitter() %>% plot(col = "red") 8 | scatter_ex %>% geometry_flip() %>% plot() 9 | scatter_ex %>% geometry_reflect() %>% plot() 10 | devtools::use_data(scatter_ex, overwrite = TRUE) 11 | 12 | bar_ex <- render_bar(mpg, ~cyl, 1) %>% select(ends_with("_")) 13 | bar_ex %>% plot() 14 | bar_ex %>% geometry_stack() %>% plot() 15 | bar_ex %>% geometry_stack() %>% geometry_flip() %>% plot() 16 | bar_ex %>% geometry_flip() %>% geometry_stack("x") %>% plot() 17 | 18 | devtools::use_data(bar_ex, overwrite = TRUE) 19 | 20 | 21 | histogram_ex <- mpg %>% 22 | compute_bin(~hwy, width = 1) %>% 23 | render_rect(~xmin_, 0, ~xmax_, ~count_) 24 | histogram_ex %>% plot() 25 | histogram_ex %>% geometry_reflect("y") %>% plot() 26 | devtools::use_data(histogram_ex, overwrite = TRUE) 27 | -------------------------------------------------------------------------------- /man/geometry_reflect.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.0.2): do not edit by hand 2 | \name{geometry_reflect} 3 | \alias{geometry_reflect} 4 | \title{Reflect positions around an axis.} 5 | \usage{ 6 | geometry_reflect(geom, dir = c("x", "y")) 7 | } 8 | \arguments{ 9 | \item{geom}{A geometry data frame.} 10 | 11 | \item{dir}{Direction in which to reflect. One of "x" and "y". (Specifying "x" 12 | will flip the x values about the y axis.} 13 | } 14 | \description{ 15 | Reflect positions around an axis. 16 | } 17 | \examples{ 18 | scatter_ex \%>\% plot() 19 | scatter_ex \%>\% geometry_reflect() \%>\% plot() 20 | scatter_ex \%>\% geometry_reflect("y") \%>\% plot() 21 | 22 | histogram_ex \%>\% plot() 23 | histogram_ex \%>\% geometry_reflect() \%>\% plot() 24 | histogram_ex \%>\% geometry_reflect("y") \%>\% plot() 25 | histogram_ex \%>\% geometry_reflect("y") \%>\% geometry_flip() \%>\% plot() 26 | 27 | nz \%>\% plot() 28 | nz \%>\% geometry_reflect() \%>\% plot() 29 | nz \%>\% geometry_reflect("y") \%>\% plot() 30 | } 31 | 32 | -------------------------------------------------------------------------------- /R/simplify.R: -------------------------------------------------------------------------------- 1 | #' Simplify a path geometry with Douglas-Peucker 2 | #' 3 | #' @inheritParams geometry_flip 4 | #' @param tol_prop,tol_dist Either specify the proportion of points to keep, 5 | #' or a distance threshold. 6 | #' @seealso \code{\link{compute_dp_distance}()} to add the distance as 7 | #' an explicit column so you can experimenting with different thresholds 8 | #' more easily. 9 | #' @export 10 | geometry_simplify <- function(geom, tol_prop = 0.1, tol_dist = NULL) { 11 | if (is.null(tol_prop) + is.null(tol_dist) != 1) { 12 | stop("Must supply exactly one of tol_prop and tol_dist") 13 | } 14 | 15 | UseMethod("geometry_simplify") 16 | } 17 | 18 | #' @export 19 | geometry_simplify.geom_path <- function(geom, tol_prop = 0.1, tol_dist = NULL) { 20 | 21 | dist <- compute_dp_distance(geom, ~x, ~y)$dist 22 | 23 | if (is.null(tol_prop)) { 24 | tol_dist <- quantile(dist, tol_prop) 25 | message("Using tol_dist of ", format(tol_dist, digits = 3)) 26 | } 27 | 28 | geom[dist >= tol_dist] 29 | } 30 | -------------------------------------------------------------------------------- /man/render_segment.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.0.2): do not edit by hand 2 | \name{render_segment} 3 | \alias{render_segment} 4 | \alias{render_spoke} 5 | \title{Render a line segment} 6 | \usage{ 7 | render_segment(data, x1, y1, x2, y2) 8 | 9 | render_spoke(data, x, y, theta, r) 10 | } 11 | \arguments{ 12 | \item{data}{A data frame.} 13 | 14 | \item{x1,y1,x2,y2}{Locations of start and end points.} 15 | 16 | \item{x,y,r,theta}{Location of x points, radius and angle.} 17 | } 18 | \description{ 19 | A line segment is a single straight line. \code{render_spoke} is an 20 | alternative parameterisation in terms of start point, angle and distance. 21 | } 22 | \examples{ 23 | df <- expand.grid(x = 1:2, y = 1:2) 24 | a <- render_rect(df, ~x - 0.5, ~y - 0.5, ~x + 0.5, ~y + 0.5) 25 | b <- render_segment(df, ~x - 0.5, ~y - 0.5, ~x + 0.5, ~y + 0.5) 26 | 27 | plot(a) 28 | plot(b, add = TRUE, col = "red", lwd = 2) 29 | 30 | # Spokes are just an alternative parameterisation 31 | df \%>\% render_spoke(~x, ~y, ~runif(4, 0, 2 * pi), ~0.25) \%>\% plot() 32 | } 33 | 34 | -------------------------------------------------------------------------------- /man/geometry_scale.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.0.2): do not edit by hand 2 | \name{geometry_scale} 3 | \alias{geometry_scale} 4 | \title{Scale stacked values.} 5 | \usage{ 6 | geometry_scale(geom, dir = c("y", "x"), max = 1) 7 | } 8 | \arguments{ 9 | \item{geom}{A geometry data frame.} 10 | 11 | \item{dir}{Direction in which to stack. "x" or "y" for rects, 12 | only "y" for smooths, "r" or "theta" for arcs.} 13 | 14 | \item{max}{Maximum value to scale to. Defaults to 1, except when scaling 15 | "theta", where it defaults to 2 * pi.} 16 | } 17 | \description{ 18 | Scale stacked values. 19 | } 20 | \examples{ 21 | bar_ex \%>\% geometry_stack() \%>\% plot() 22 | bar_ex \%>\% geometry_stack() \%>\% geometry_scale() \%>\% plot() 23 | 24 | pies <- render_arc(mtcars, ~vs, ~am, 0, 0.1, 0, ~mpg / max(mpg) * 2 / pi) 25 | pies \%>\% geometry_stack() \%>\% plot() 26 | pies \%>\% geometry_stack() \%>\% geometry_scale() \%>\% plot() 27 | 28 | disks <- render_arc(mtcars, ~vs, ~am, 0, 0.05, 0, 2 * pi) 29 | disks \%>\% geometry_stack("r") \%>\% geometry_scale("r", 0.45) \%>\% plot() 30 | } 31 | 32 | -------------------------------------------------------------------------------- /man/coords.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.0.2): do not edit by hand 2 | \name{coords} 3 | \alias{coords} 4 | \title{A simple class for managing lists of coordinates.} 5 | \usage{ 6 | coords(x) 7 | } 8 | \arguments{ 9 | \item{x}{A list to label as containing coordinates.} 10 | } 11 | \description{ 12 | gggeom assumes that every geometry can be represented with a single row 13 | of a data frame. This poses a challenge for path and polygon geometries 14 | which can be of arbitrary length. To solve this problem, gggeom uses a 15 | list-column, where each component of the list is of the same type. 16 | } 17 | \examples{ 18 | make_spiral <- function(turns, r, n = 200) { 19 | t_grid <- seq(0, turns * 2 * pi, length = n) 20 | r_grid <- seq(0, r, length = n) 21 | df <- data.frame(x = r_grid * sin(t_grid), y = r_grid * cos(t_grid)) 22 | render_path(df, ~x, ~y) 23 | } 24 | s1 <- make_spiral(6, 1) 25 | s2 <- make_spiral(-4, 10) 26 | 27 | s1 28 | str(s1) 29 | s1$x_ 30 | 31 | spirals <- rbind(s1, s2) 32 | range(spirals$x_) 33 | spirals \%>\% plot(col = c("red", "black")) 34 | } 35 | \keyword{internal} 36 | 37 | -------------------------------------------------------------------------------- /man/render_contour.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.0.2): do not edit by hand 2 | \name{render_contour} 3 | \alias{render_contour} 4 | \title{Render 3d observations as contours.} 5 | \usage{ 6 | render_contour(data, x, y, z, nbreaks = 10, breaks = NULL) 7 | } 8 | \arguments{ 9 | \item{data}{A data frame.} 10 | 11 | \item{x,y,z}{3d location of each point} 12 | 13 | \item{nbreaks,breaks}{Either the number of breaks between the smallest and 14 | largest z values, or the positions of the breaks.} 15 | } 16 | \value{ 17 | A path geometry. 18 | } 19 | \description{ 20 | Render 3d observations as contours. 21 | } 22 | \examples{ 23 | n <- 50 24 | waves <- expand.grid( 25 | x = seq(-pi, pi, length = n), 26 | y = seq(-pi, pi, length = n) 27 | ) 28 | r <- sqrt(waves$x ^ 2 + waves$y ^ 2) 29 | waves$ripple <- cos(r ^ 2) * exp(-r / 6) 30 | waves$hill <- exp(1 - r) 31 | 32 | waves \%>\% render_contour(~x, ~y, ~hill) \%>\% plot() 33 | waves \%>\% render_contour(~x, ~y, ~ripple) \%>\% plot() 34 | 35 | # Show only where function crosses 0 36 | waves \%>\% render_contour(~x, ~y, ~ripple, breaks = 0) \%>\% plot() 37 | } 38 | 39 | -------------------------------------------------------------------------------- /R/flip.R: -------------------------------------------------------------------------------- 1 | #' Flip x and y positions. 2 | #' 3 | #' @param geom A geometry data frame. 4 | #' @export 5 | #' @examples 6 | #' scatter_ex %>% plot() 7 | #' scatter_ex %>% geometry_flip() %>% plot() 8 | #' 9 | #' histogram_ex %>% plot() 10 | #' histogram_ex %>% geometry_flip() %>% plot() 11 | #' 12 | #' nz %>% plot() 13 | #' nz %>% geometry_flip() %>% plot() 14 | geometry_flip <- function(geom) UseMethod("geometry_flip") 15 | 16 | #' @export 17 | geometry_flip.geom <- function(geom) { 18 | switch_cols(geom, "x_", "y_") 19 | } 20 | 21 | #' @export 22 | geometry_flip.geom_ribbon <- function(geom) { 23 | stop("Can't flip ribbons", call. = FALSE) 24 | } 25 | 26 | #' @export 27 | geometry_flip.geom_rect <- function(geom) { 28 | geom <- switch_cols(geom, "x1_", "y1_") 29 | geom <- switch_cols(geom, "x2_", "y2_") 30 | geom 31 | } 32 | 33 | switch_cols <- function(df, a, b) { 34 | nms <- names(df) 35 | 36 | pos <- match(c(a, b), nms) 37 | if (any(is.na(pos))) { 38 | stop("Couldn't find column ", c(a, b)[is.na(pos)], call. = FALSE) 39 | } 40 | nms[pos] <- nms[rev(pos)] 41 | 42 | names(df) <- nms 43 | df 44 | } 45 | 46 | -------------------------------------------------------------------------------- /man/geometry_jitter.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.0.2): do not edit by hand 2 | \name{geometry_jitter} 3 | \alias{geometry_jitter} 4 | \title{Jitter geometries to avoid overplotting.} 5 | \usage{ 6 | geometry_jitter(geom, x = NULL, y = NULL) 7 | } 8 | \arguments{ 9 | \item{geom}{A geometry data frame.} 10 | 11 | \item{x,y}{amount to jitter in x and y directions. In most cases, defaults 12 | to 40\% of the resolution of the data.} 13 | } 14 | \description{ 15 | Jitter adds random uniform offsets to avoid overplotting. 16 | } 17 | \details{ 18 | Jittering differs a little depending on the underlying geometry: 19 | \describe{ 20 | \item{point,path,polygon,text}{Jitters both x and y.} 21 | \item{ribbon}{Jitters y1 & y2 by same amount} 22 | \item{rect}{Jitters x1 & x2, and y1 & y2 by same amount - the 23 | height and width stay the same.} 24 | } 25 | } 26 | \examples{ 27 | scatter_ex \%>\% 28 | plot() \%>\% 29 | geometry_jitter() \%>\% 30 | plot(add = TRUE, col = "red") 31 | 32 | # Can override amount of jitter 33 | scatter_ex \%>\% 34 | plot() \%>\% 35 | geometry_jitter(0.2, 0.2) \%>\% 36 | plot(add = TRUE, col = "red") 37 | } 38 | 39 | -------------------------------------------------------------------------------- /man/render_rect.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.0.2): do not edit by hand 2 | \name{render_rect} 3 | \alias{render_bar} 4 | \alias{render_rect} 5 | \alias{render_tile} 6 | \title{Render a rect.} 7 | \usage{ 8 | render_rect(data, x1, y1, x2, y2) 9 | 10 | render_bar(data, x, y, width = resolution(x) * 0.9, halign = 0.5) 11 | 12 | render_tile(data, x, y, width = resolution(x), height = resolution(y), 13 | halign = 0.5, valign = 0.5) 14 | } 15 | \arguments{ 16 | \item{data}{A data frame.} 17 | 18 | \item{x1,y1,x2,y2}{Describe a rectangle by the locations of its sides.} 19 | 20 | \item{x,y,width,height}{Describe a rectangle by location and dimension.} 21 | 22 | \item{halign,valign}{Horizontal and vertical aligned. Defaults to 0.5, 23 | centered.} 24 | } 25 | \description{ 26 | A rect is defined by the coordinates of its sides. Bars and tiles are 27 | convenient parameterisations based on the length of the sides. 28 | } 29 | \examples{ 30 | # Two equivalent specifications 31 | render_rect(mtcars, ~cyl - 0.5, ~gear - 0.5, ~cyl + 0.5, ~gear + 0.5) 32 | render_tile(mtcars, ~cyl, ~gear, 1, 1) 33 | 34 | bar_ex 35 | bar_ex \%>\% plot() 36 | bar_ex \%>\% geometry_stack() \%>\% plot() 37 | } 38 | 39 | -------------------------------------------------------------------------------- /man/geometry_pointificate.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.0.2): do not edit by hand 2 | \name{geometry_pointificate} 3 | \alias{geometry_pointificate} 4 | \title{Convert complex geometries in to points, paths and polygons.} 5 | \usage{ 6 | geometry_pointificate(geom, ...) 7 | } 8 | \arguments{ 9 | \item{geom}{A geometry data frame.} 10 | 11 | \item{...}{Additional arguments passed on to methods. 12 | \itemize{ 13 | \item{\code{geometry_polygon}: use \code{close = TRUE} to "close" the 14 | polygon by putting the first point at the end.} 15 | }} 16 | } 17 | \description{ 18 | Convert complex geometries in to points, paths and polygons. 19 | } 20 | \examples{ 21 | x <- seq(0, 4 * pi, length = 100) 22 | df <- data.frame(x = x, y = sin(x)) 23 | rib <- render_ribbon(df, ~x, ~y - 1, ~ y + 1) 24 | rib \%>\% plot() 25 | rib \%>\% geometry_pointificate() \%>\% plot() 26 | rib \%>\% geometry_pointificate() \%>\% geometry_flip() \%>\% plot() 27 | 28 | df <- expand.grid(x = 1:3, y = 1:3) 29 | df$z <- runif(9, pi, 2 * pi) 30 | arc <- df \%>\% render_arc(~x, ~y, 0, 0.35, 0, ~z) 31 | arc \%>\% plot() 32 | arc \%>\% geometry_pointificate() \%>\% plot() 33 | 34 | histogram_ex \%>\% plot() 35 | histogram_ex \%>\% geometry_pointificate() \%>\% plot() 36 | 37 | nz \%>\% plot() 38 | nz \%>\% geometry_pointificate(close = TRUE) \%>\% plot() 39 | } 40 | 41 | -------------------------------------------------------------------------------- /man/geometry_rotate.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.0.2): do not edit by hand 2 | \name{geometry_rotate} 3 | \alias{geometry_rotate} 4 | \title{Rotate a geometry about a pointclockwise, by a specified angle} 5 | \usage{ 6 | geometry_rotate(geom, angle = NULL, x = 0, y = 0) 7 | } 8 | \arguments{ 9 | \item{geom}{A geometry data frame.} 10 | 11 | \item{angle}{The angle by which to rotate, clockwise.} 12 | 13 | \item{x,y}{The coordinates of the center of rotation.} 14 | } 15 | \description{ 16 | Rotate a geometry about a point clockwise, by a specified angle. 17 | } 18 | \examples{ 19 | scatter_ex \%>\% plot() 20 | # Rotate 5 degrees about the origin 21 | scatter_ex \%>\% plot() \%>\% 22 | geometry_rotate(5) \%>\% plot(add = TRUE, col = "red") 23 | # Rotate 5 degrees about the smallest point 24 | scatter_ex \%>\% plot() \%>\% 25 | geometry_rotate(5, x = 9, y = 12) \%>\% plot(add = TRUE, col = "red") 26 | 27 | # More extreme rotations 28 | scatter_ex \%>\% plot(xlim = c(-35, 35), ylim = c(-44, 44)) \%>\% 29 | geometry_rotate(90) \%>\% plot(add = TRUE, col = "red") 30 | scatter_ex \%>\% geometry_rotate(75, x = 20, y = 20) \%>\% plot() 31 | 32 | # To rotate bars, you need to convert to polygons with pointificate 33 | bar_ex \%>\% unique() \%>\% plot() 34 | bar_ex \%>\% unique() \%>\% geometry_pointificate() \%>\% 35 | geometry_rotate(45, 6, 0.5) \%>\% plot() 36 | } 37 | 38 | -------------------------------------------------------------------------------- /src/dp-distance.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include "geometry.h" 3 | using namespace Rcpp; 4 | 5 | void dp_distance_rec(const NumericVector& x, const NumericVector& y, 6 | int first, int last, double max, NumericVector* pOut) { 7 | // Rcout << first << "-" << last << "\n"; 8 | int n = last - first + 1; 9 | if (n <= 2) 10 | return; 11 | 12 | // Find point furthest from line defined by first, last 13 | double max_dist = -INFINITY; 14 | int furthest = 0; 15 | for (int i = first + 1; i < last; ++i) { 16 | double dist = point_line_dist(x[i], y[i], x[first], y[first], x[last], y[last]); 17 | if (dist > max_dist) { 18 | furthest = i; 19 | max_dist = dist; 20 | } 21 | } 22 | 23 | // Ensure that distance always decreases as you recurse 24 | if (max_dist > max) { 25 | max_dist = max; 26 | } 27 | (*pOut)[furthest] = pow(max_dist, 0.5); 28 | 29 | // Recurse 30 | dp_distance_rec(x, y, first, furthest, max_dist, pOut); 31 | dp_distance_rec(x, y, furthest, last, max_dist, pOut); 32 | 33 | return; 34 | } 35 | 36 | // [[Rcpp::export]] 37 | NumericVector dp_distance(const NumericVector& x, const NumericVector& y) { 38 | int n = x.size(); 39 | NumericVector out(n); 40 | 41 | out[0] = INFINITY; 42 | out[n - 1] = INFINITY; 43 | dp_distance_rec(x, y, 0, n - 1, INFINITY, &out); 44 | 45 | return out; 46 | } 47 | -------------------------------------------------------------------------------- /man/geometry_warp.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.0.2): do not edit by hand 2 | \name{geometry_warp} 3 | \alias{geometry_warp} 4 | \title{Warp a path or polygon with adaptive resampling} 5 | \usage{ 6 | geometry_warp(geom, fun = c("polar", "identity"), tolerance = NULL) 7 | } 8 | \arguments{ 9 | \item{geom}{A geometry data frame.} 10 | 11 | \item{fun}{A warping function to use. Currently these are hard coded 12 | because they much be implemented in C++ for performance reasons.} 13 | 14 | \item{tolerance}{Approximation errors below this threshold will be 15 | ignored. If \code{NULL}, attempts to guess a reasonable value.} 16 | } 17 | \description{ 18 | This recursively split each line segment into pieces until the transformed 19 | point is less that \code{tolerance} away from the transformed line 20 | segment. 21 | } 22 | \examples{ 23 | spiral <- data.frame( 24 | x = seq(0, 6 * pi, length = 10), 25 | y = seq(0, 1, length = 10) 26 | ) 27 | path <- render_path(spiral, ~x, ~y) 28 | path \%>\% plot() \%>\% points() 29 | 30 | path \%>\% geometry_warp("polar") \%>\% plot() 31 | path \%>\% geometry_warp("polar", tolerance = 0.1) \%>\% plot() \%>\% points() 32 | 33 | # Crazy example 34 | expand.grid(x = seq(0, pi, length = 4), y = 0:3) \%>\% 35 | render_tile(~x, ~y, halign = 0, valign = 0) \%>\% 36 | geometry_pointificate() \%>\% 37 | geometry_rotate(15) \%>\% 38 | geometry_warp("polar") \%>\% 39 | plot() 40 | } 41 | 42 | -------------------------------------------------------------------------------- /R/rotate.R: -------------------------------------------------------------------------------- 1 | #' Rotate a geometry about a pointclockwise, by a specified angle 2 | #' 3 | #' Rotate a geometry about a point clockwise, by a specified angle. 4 | #' 5 | #' @param geom A geometry data frame. 6 | #' @param angle The angle by which to rotate, clockwise. 7 | #' @param x,y The coordinates of the center of rotation. 8 | #' @export 9 | #' @examples 10 | #' scatter_ex %>% plot() 11 | #' # Rotate 5 degrees about the origin 12 | #' scatter_ex %>% plot() %>% 13 | #' geometry_rotate(5) %>% plot(add = TRUE, col = "red") 14 | #' # Rotate 5 degrees about the smallest point 15 | #' scatter_ex %>% plot() %>% 16 | #' geometry_rotate(5, x = 9, y = 12) %>% plot(add = TRUE, col = "red") 17 | #' 18 | #' # More extreme rotations 19 | #' scatter_ex %>% plot(xlim = c(-35, 35), ylim = c(-44, 44)) %>% 20 | #' geometry_rotate(90) %>% plot(add = TRUE, col = "red") 21 | #' scatter_ex %>% geometry_rotate(75, x = 20, y = 20) %>% plot() 22 | #' 23 | #' # To rotate bars, you need to convert to polygons with pointificate 24 | #' bar_ex %>% unique() %>% plot() 25 | #' bar_ex %>% unique() %>% geometry_pointificate() %>% 26 | #' geometry_rotate(45, 6, 0.5) %>% plot() 27 | geometry_rotate <- function(geom, angle = NULL, x = 0, y = 0) { 28 | if (missing(angle)) { 29 | stop("angle must be supplied.") 30 | } 31 | 32 | theta <- angle / 180 * pi 33 | m <- matrix(c(cos(theta), -sin(theta), sin(theta), cos(theta)), nrow = 2) 34 | geometry_transform(geom, m, x, y) 35 | } 36 | -------------------------------------------------------------------------------- /man/geometry_transform.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.0.2): do not edit by hand 2 | \name{geometry_transform} 3 | \alias{geometry_transform} 4 | \title{Perform a linear transformation on a geometry.} 5 | \usage{ 6 | geometry_transform(geom, m, x = 0, y = 0) 7 | } 8 | \arguments{ 9 | \item{geom}{A geometry data frame.} 10 | 11 | \item{m}{A 2x2 transformation matrix.} 12 | 13 | \item{x,y}{The coordinates of the center to use for the transformation.} 14 | } 15 | \description{ 16 | Perform a linear transformation on a geometry, using a specified point as the 17 | center. 18 | } 19 | \examples{ 20 | # Some transformation matrices 21 | shear <- matrix(c(1, 0, 0.75, 1), nrow = 2) 22 | reflect_y <- matrix(c(-1, 0, 0, 1), nrow = 2) 23 | t <- 30 * pi / 180 24 | rotate30 <- matrix(c(cos(t), -sin(t), sin(t), cos(t)), nrow = 2) 25 | 26 | scatter_ex \%>\% plot() 27 | scatter_ex \%>\% plot() \%>\% geometry_transform(shear) 28 | scatter_ex \%>\% geometry_transform(reflect_y) \%>\% plot() 29 | scatter_ex \%>\% geometry_transform(rotate30) \%>\% plot() 30 | 31 | bar_ex \%>\% plot() 32 | # Convert to geometry_polygon 33 | bar_ex2 <- bar_ex \%>\% unique() \%>\% geometry_pointificate() 34 | bar_ex2 \%>\% geometry_transform(shear) \%>\% plot() 35 | bar_ex2 \%>\% geometry_transform(reflect_y) \%>\% plot() 36 | bar_ex2 \%>\% geometry_transform(rotate30) \%>\% plot() 37 | 38 | # Rotate about (10, 1) instead of origin 39 | bar_ex2 \%>\% geometry_transform(rotate30, 10, 1) \%>\% plot() 40 | } 41 | 42 | -------------------------------------------------------------------------------- /man/compute_dp_distance.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.0.2): do not edit by hand 2 | \name{compute_dp_distance} 3 | \alias{compute_dp_distance} 4 | \title{Compute the Douglas-Peucker distance for paths.} 5 | \usage{ 6 | compute_dp_distance(data, x_var, y_var) 7 | } 8 | \arguments{ 9 | \item{data}{A data frame like object.} 10 | 11 | \item{x_var,y_var}{Formulas specifying either variable names or 12 | expressions to use as x and y positions.} 13 | } 14 | \value{ 15 | A data frame with columns: 16 | \item{x_,y_}{Position} 17 | \item{distance_}{Distance between point and sub-line} 18 | } 19 | \description{ 20 | Douglas-Peucker is a recursive line simplification algorithm. It starts by 21 | defining a line from the first to the last point, and then finds the 22 | point that is furthest from the line. It then recursively breaks up the 23 | into two pieces around the furthest point, and finds the furthest point 24 | from those sublines. See 25 | \url{http://en.wikipedia.org/wiki/Ramer-Douglas-Peucker_algorithm} for 26 | more details. 27 | } 28 | \details{ 29 | Note that this function does not do any simplification - it just adds an 30 | additional column the measures the distaince between each point and it 31 | subline. Filtering on this column will perform simplification. 32 | } 33 | \examples{ 34 | x <- 1:10 35 | y <- x * 2 36 | df <- data.frame(x, y) 37 | 38 | # For a straight line, can remove all points except first and last 39 | compute_dp_distance(df, ~x, ~y) 40 | } 41 | \seealso{ 42 | \code{\link{geometry_simplify}()} for an function that works on 43 | a geometry and does simplification given tolerance or percentage of 44 | points to keep. 45 | } 46 | 47 | -------------------------------------------------------------------------------- /man/render_path.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.0.2): do not edit by hand 2 | \name{render_path} 3 | \alias{render_line} 4 | \alias{render_path} 5 | \alias{render_polygon} 6 | \alias{render_step} 7 | \title{Render paths and path specialisations (line and polygons).} 8 | \usage{ 9 | render_path(data, x, y) 10 | 11 | render_line(data, x, y) 12 | 13 | render_step(data, x, y, direction = c("hv", "vh")) 14 | 15 | render_polygon(data, x, y) 16 | } 17 | \arguments{ 18 | \item{data}{A data frame.} 19 | 20 | \item{x,y}{Formulas specifying x and y positions.} 21 | 22 | \item{direction}{Direction of steps. Either "hv", horizontal then vertical 23 | or "vh", vertical then horizontal.} 24 | } 25 | \description{ 26 | A polygon is a closed path. A line is path where x values are ordered. 27 | } 28 | \examples{ 29 | # For paths and polygons, the x_ and y_ variables are lists of vectors 30 | # See ?coord for more details 31 | theta <- seq(0, 6*pi, length = 200) 32 | r <- seq(1, 0, length = 200) 33 | df <- data.frame(x = r * sin(theta), y = r * cos(theta)) 34 | spiral <- df \%>\% render_path(~x, ~y) 35 | 36 | spiral 37 | str(spiral) 38 | spiral \%>\% plot() 39 | 40 | # Rendering a spiral as a line doesn't work so well 41 | df \%>\% render_line(~x, ~y) \%>\% plot() 42 | df \%>\% render_step(~x, ~y) \%>\% plot() 43 | 44 | # More reasonable example 45 | x <- runif(20) 46 | y <- x ^ 2 47 | squared <- data.frame(x, y) 48 | 49 | squared \%>\% render_path(~x, ~y) \%>\% plot() 50 | squared \%>\% render_line(~x, ~y) \%>\% plot() 51 | squared \%>\% render_step(~x, ~y) \%>\% plot() 52 | squared \%>\% render_step(~x, ~y, "vh") \%>\% plot() 53 | 54 | nz 55 | nz \%>\% plot() 56 | } 57 | 58 | -------------------------------------------------------------------------------- /tests/testthat/test-skyline.R: -------------------------------------------------------------------------------- 1 | context("Skyline") 2 | 3 | test_that("one building skyline is idempotent", { 4 | out <- skyline(c(1, 2, 1)) 5 | expect_equal(out$x, c(1, 2)) 6 | expect_equal(out$h, c(1, 0)) 7 | }) 8 | 9 | test_that("non-overlapping building adds two edges", { 10 | out1 <- skyline(c(1, 2, 1), c(3, 4, 1)) 11 | expect_equal(out1$x, 1:4) 12 | expect_equal(out1$h, c(1, 0, 1, 0)) 13 | 14 | out2 <- skyline(c(3, 4, 1), c(1, 2, 1)) 15 | expect_equal(out2$x, 1:4) 16 | expect_equal(out2$h, c(1, 0, 1, 0)) 17 | }) 18 | 19 | test_that("small building eclipsed by tall building", { 20 | out1 <- skyline(c(3, 4, 1), c(1, 5, 2)) 21 | out2 <- skyline(c(1, 5, 2), c(3, 4, 1)) 22 | 23 | expect_equal(out1, out2) 24 | expect_equal(out1$x, c(1, 5)) 25 | expect_equal(out1$h, c(2, 0)) 26 | }) 27 | 28 | test_that("narrow-tall building in middle of long-short building", { 29 | out1 <- skyline(c(2, 4, 2), c(1, 5, 1)) 30 | out2 <- skyline(c(1, 5, 1), c(2, 4, 2)) 31 | 32 | expect_equal(out1, out2) 33 | expect_equal(out1$h, c(1, 2, 1, 0)) 34 | expect_equal(out1$x, c(1, 2, 4, 5)) 35 | }) 36 | 37 | test_that("taller builder overlapping start of existing", { 38 | out1 <- skyline(c(1, 3, 1), c(0, 2, 2)) 39 | out2 <- skyline(c(0, 2, 2), c(1, 3, 1)) 40 | 41 | expect_equal(out1, out2) 42 | expect_equal(out1$h, c(2, 1, 0)) 43 | expect_equal(out1$x, c(0, 2, 3)) 44 | }) 45 | 46 | test_that("taller builder overlapping end of existing", { 47 | out1 <- skyline(c(1, 3, 1), c(2, 4, 2)) 48 | out2 <- skyline(c(2, 4, 2), c(1, 3, 1)) 49 | 50 | expect_equal(out1, out2) 51 | expect_equal(out1$h, c(1, 2, 0)) 52 | expect_equal(out1$x, c(1, 2, 4)) 53 | }) 54 | -------------------------------------------------------------------------------- /R/RcppExports.R: -------------------------------------------------------------------------------- 1 | # This file was generated by Rcpp::compileAttributes 2 | # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | abs_max_ <- function(x, finite = TRUE) { 5 | .Call('gggeom_abs_max_', PACKAGE = 'gggeom', x, finite) 6 | } 7 | 8 | dp_distance <- function(x, y) { 9 | .Call('gggeom_dp_distance', PACKAGE = 'gggeom', x, y) 10 | } 11 | 12 | make_heap <- function(x) { 13 | .Call('gggeom_make_heap', PACKAGE = 'gggeom', x) 14 | } 15 | 16 | heap_sort <- function(x) { 17 | .Call('gggeom_heap_sort', PACKAGE = 'gggeom', x) 18 | } 19 | 20 | heap_update_sort <- function(x) { 21 | .Call('gggeom_heap_update_sort', PACKAGE = 'gggeom', x) 22 | } 23 | 24 | resolution_numeric <- function(x, zero = TRUE) { 25 | .Call('gggeom_resolution_numeric', PACKAGE = 'gggeom', x, zero) 26 | } 27 | 28 | buildSkyline <- function(x1, x2, y) { 29 | .Call('gggeom_buildSkyline', PACKAGE = 'gggeom', x1, x2, y) 30 | } 31 | 32 | stack_rects <- function(x1, x2, y1, y2) { 33 | .Call('gggeom_stack_rects', PACKAGE = 'gggeom', x1, x2, y1, y2) 34 | } 35 | 36 | stack_ribbons <- function(x, y1, y2) { 37 | .Call('gggeom_stack_ribbons', PACKAGE = 'gggeom', x, y1, y2) 38 | } 39 | 40 | ungroupNA <- function(x) { 41 | .Call('gggeom_ungroupNA', PACKAGE = 'gggeom', x) 42 | } 43 | 44 | `as.data.frame!` <- function(x, nrow) { 45 | invisible(.Call('gggeom_as_data_frame', PACKAGE = 'gggeom', x, nrow)) 46 | } 47 | 48 | vw_distance <- function(x, y) { 49 | .Call('gggeom_vw_distance', PACKAGE = 'gggeom', x, y) 50 | } 51 | 52 | warp <- function(x, y, f, threshold = 0.01, closed = FALSE) { 53 | .Call('gggeom_warp', PACKAGE = 'gggeom', x, y, f, threshold, closed) 54 | } 55 | 56 | -------------------------------------------------------------------------------- /R/utils.R: -------------------------------------------------------------------------------- 1 | notify_guess <- function(x, explanation = NULL) { 2 | msg <- paste0( 3 | "Guessing ", deparse(substitute(x)), " = ", format(x, digits = 3), 4 | if (!is.null(explanation)) paste0(" # ", explanation) 5 | ) 6 | message(msg) 7 | } 8 | 9 | #' Pipe operator 10 | #' 11 | #' @name %>% 12 | #' @rdname pipe 13 | #' @keywords internal 14 | #' @export 15 | #' @importFrom magrittr %>% 16 | #' @usage lhs \%>\% rhs 17 | NULL 18 | 19 | 20 | is_numeric <- function(x) { 21 | typeof(x) %in% c("double", "integer") && !is.factor(x) 22 | } 23 | 24 | `%||%` <- function(x, y) if (is.null(x)) y else x 25 | 26 | 27 | eval_vector <- function(data, x) { 28 | if (is.atomic(x)) return(rep(x, nrow(data))) 29 | 30 | eval(x[[2]], data, environment(x)) 31 | } 32 | 33 | plot_init <- function(x, y, 34 | xlim = range(x, na.rm = TRUE), 35 | ylim = range(y, na.rm = TRUE), ...) { 36 | old <- par(mar = c(1.5, 1.5, 0, 0), cex = 0.8) 37 | on.exit(par(old)) 38 | 39 | plot.default(xlim, ylim, type = "n", xlab = "", ylab = "", axes = FALSE) 40 | axis(1, lwd = 0, lwd.ticks = 1, col = "grey80", col.axis = "grey60", padj = -1) 41 | axis(2, lwd = 0, lwd.ticks = 1, col = "grey80", col.axis = "grey60", padj = 1) 42 | grid(lty = "solid", col = "grey80") 43 | } 44 | 45 | row_apply <- function(df, f, ...) { 46 | 47 | row_slice <- function(df, i) { 48 | out <- pluck(df, i) 49 | `as.data.frame!`(out, 1) 50 | out 51 | } 52 | 53 | lapply(1:nrow(df), function(i) f(row_slice(df, i), ...)) 54 | } 55 | 56 | pluck <- function(x, name, type) { 57 | if (missing(type)) { 58 | lapply(x, "[[", name) 59 | } else { 60 | vapply(x, "[[", name, FUN.VALUE = type) 61 | } 62 | } 63 | -------------------------------------------------------------------------------- /man/compute_vw_distance.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.0.2): do not edit by hand 2 | \name{compute_vw_distance} 3 | \alias{compute_vw_distance} 4 | \title{Compute the distance for paths with the Visvalingam-Whyatt algorithm.} 5 | \usage{ 6 | compute_vw_distance(data, x_var, y_var) 7 | } 8 | \arguments{ 9 | \item{data}{A data frame like object.} 10 | 11 | \item{x_var,y_var}{Formulas specifying either variable names or expressions 12 | to use as x and y positions.} 13 | } 14 | \value{ 15 | A data frame with columns: \item{x_,y_}{Position} 16 | \item{distance_}{Distance between point and sub-line} 17 | } 18 | \description{ 19 | Visvalingam-Whyatt is a method of simplifying lines. It starts by 20 | computing the area of the triangle formed by each sequence of three points. 21 | (The triangles are overlapping.) Then it removes the middle point of the 22 | triangle with the smallest area, and recomputes the area of the neighbor 23 | triangles that are affected by the removal of that point. This repeats until 24 | all the points are removed except the two endpoints. 25 | } 26 | \details{ 27 | See \url{http://bost.ocks.org/mike/simplify/} for more details. 28 | 29 | Note that this function does not do any simplification - it just adds an 30 | additional column the measures the area of the triangle at each point (where 31 | the point is the middle point of the triangle). Filtering on this column will 32 | perform simplification. 33 | } 34 | \examples{ 35 | df <- data.frame(x = c(1,2,3,4,5), y = c(1,1.2,3.8,3.3,5)) 36 | 37 | # compute_vw_distance(df, ~x, ~y) 38 | } 39 | \seealso{ 40 | \code{\link{geometry_simplify}()} for an function that works on a 41 | geometry and does simplification given tolerance or percentage of points to 42 | keep. 43 | } 44 | 45 | -------------------------------------------------------------------------------- /man/geometry_stack.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.0.2): do not edit by hand 2 | \name{geometry_stack} 3 | \alias{geometry_stack} 4 | \title{Stack objects on top of one another.} 5 | \usage{ 6 | geometry_stack(geom, dir = c("y", "x")) 7 | } 8 | \arguments{ 9 | \item{geom}{A geometry data frame.} 10 | 11 | \item{dir}{Direction in which to stack. "x" or "y" for rects, 12 | only "y" for smooths, "r" or "theta" for arcs.} 13 | } 14 | \description{ 15 | Rects are always stacked upwards from the x-axis, ignoring non-zero 16 | \code{y1_}. 17 | } 18 | \examples{ 19 | bar_ex \%>\% plot() 20 | bar_ex \%>\% geometry_stack() \%>\% plot() 21 | 22 | bar_ex \%>\% geometry_flip() \%>\% plot() 23 | bar_ex \%>\% geometry_flip() \%>\% geometry_stack("x") \%>\% plot() 24 | 25 | # Overlapping bars are stacked on top of each other 26 | df <- data.frame(x = 1:3, y = 1:3) 27 | df \%>\% render_bar(~x, ~y, 2) \%>\% plot() 28 | df \%>\% render_bar(~x, ~y, 2) \%>\% geometry_stack() \%>\% plot() 29 | 30 | # Stacking ribbons 31 | theta <- seq(0, 2 * pi, length = 50) 32 | df <- data.frame(theta) 33 | waves <- rbind( 34 | df \%>\% render_area(~theta, ~abs(sin(theta))), 35 | df \%>\% render_area(~theta, ~abs(cos(theta))) 36 | ) 37 | waves \%>\% plot(col = c("red", "black")) 38 | waves \%>\% geometry_stack() \%>\% plot(col = c("red", "black")) 39 | df \%>\% render_area(~theta, ~abs(sin(theta)) + abs(cos(theta))) \%>\% plot() 40 | 41 | # You can also stack arcs, in either r or theta direction 42 | pies <- render_arc(mtcars, ~vs, ~am, 0, 0.1, 0, ~mpg / max(mpg) * 2 / pi) 43 | pies \%>\% plot() 44 | pies \%>\% geometry_stack() \%>\% plot() 45 | pies \%>\% geometry_stack("r") \%>\% plot() 46 | 47 | disks <- render_arc(mtcars, ~vs, ~am, 0, 0.05, 0, 2 * pi) 48 | disks \%>\% geometry_stack("r") \%>\% plot() 49 | } 50 | 51 | -------------------------------------------------------------------------------- /R/dodge.R: -------------------------------------------------------------------------------- 1 | #' Dodge objects on next to one another. 2 | #' 3 | #' Currently only implemented for rects. 4 | #' 5 | #' @inheritParams geometry_flip 6 | #' @export 7 | #' @examples 8 | #' bar_ex %>% plot() 9 | #' bar_ex %>% geometry_stack() %>% plot() 10 | #' bar_ex %>% geometry_dodge() %>% plot() 11 | geometry_dodge <- function(geom) { 12 | UseMethod("geometry_dodge") 13 | } 14 | 15 | #' @export 16 | geometry_dodge.geom_rect <- function(geom) { 17 | dodged <- geom %>% 18 | dplyr::group_by_(~x1_, ~x2_, add = TRUE) %>% 19 | dplyr::do({ 20 | n <- nrow(.) + 1 21 | breaks <- seq(.$x1_[1], .$x2_[1], length = n) 22 | 23 | data <- . 24 | data$x1_ <- breaks[-n] 25 | data$x2_ <- breaks[-1] 26 | data 27 | }) 28 | 29 | # Restore old grouping 30 | old_groups <- dplyr::groups(geom) 31 | if (!is.null(old_groups)) { 32 | dodged <- dplyr::group_by_(dodged, .dots = old_groups) 33 | } else { 34 | dodged <- dplyr::ungroup(dodged) 35 | } 36 | 37 | class(dodged) <- class(geom) 38 | dodged 39 | } 40 | 41 | dodge <- function(geom, width) { 42 | n <- length(unique(df$group)) 43 | if (n == 1) return(df) 44 | 45 | if (!all(c("xmin", "xmax") %in% names(df))) { 46 | df$xmin <- df$x 47 | df$xmax <- df$x 48 | } 49 | 50 | d_width <- max(df$xmax - df$xmin) 51 | diff <- width - d_width 52 | 53 | # Have a new group index from 1 to number of groups. 54 | # This might be needed if the group numbers in this set don't include all of 1:n 55 | groupidx <- match(df$group, sort(unique(df$group))) 56 | 57 | # Find the center for each group, then use that to calculate xmin and xmax 58 | df$x <- df$x + width * ((groupidx - 0.5) / n - .5) 59 | df$xmin <- df$x - d_width / n / 2 60 | df$xmax <- df$x + d_width / n / 2 61 | 62 | df 63 | } 64 | -------------------------------------------------------------------------------- /R/compute-dp-distance.R: -------------------------------------------------------------------------------- 1 | #' Compute the Douglas-Peucker distance for paths. 2 | #' 3 | #' Douglas-Peucker is a recursive line simplification algorithm. It starts by 4 | #' defining a line from the first to the last point, and then finds the 5 | #' point that is furthest from the line. It then recursively breaks up the 6 | #' into two pieces around the furthest point, and finds the furthest point 7 | #' from those sublines. See 8 | #' \url{http://en.wikipedia.org/wiki/Ramer-Douglas-Peucker_algorithm} for 9 | #' more details. 10 | #' 11 | #' Note that this function does not do any simplification - it just adds an 12 | #' additional column the measures the distaince between each point and it 13 | #' subline. Filtering on this column will perform simplification. 14 | #' 15 | #' @param data A data frame like object. 16 | #' @param x_var,y_var Formulas specifying either variable names or 17 | #' expressions to use as x and y positions. 18 | #' @seealso \code{\link{geometry_simplify}()} for an function that works on 19 | #' a geometry and does simplification given tolerance or percentage of 20 | #' points to keep. 21 | #' @return A data frame with columns: 22 | #' \item{x_,y_}{Position} 23 | #' \item{distance_}{Distance between point and sub-line} 24 | #' @export 25 | #' @examples 26 | #' x <- 1:10 27 | #' y <- x * 2 28 | #' df <- data.frame(x, y) 29 | #' 30 | #' # For a straight line, can remove all points except first and last 31 | #' compute_dp_distance(df, ~x, ~y) 32 | compute_dp_distance <- function(data, x_var, y_var) { 33 | UseMethod("compute_dp_distance") 34 | } 35 | 36 | #' @export 37 | compute_dp_distance.data.frame <- function(data, x_var, y_var) { 38 | x <- eval_vector(data, x_var) 39 | y <- eval_vector(data, y_var) 40 | 41 | data.frame( 42 | x_ = x, 43 | y_ = y, 44 | dist_ = dp_distance(x, y) 45 | ) 46 | } 47 | 48 | #' @export 49 | compute_dp_distance.grouped_df <- function(data, x_var, y_var) { 50 | dplyr::do(data, compute_dp_distance(., x_var, y_var)) 51 | } 52 | 53 | globalVariables(".") 54 | -------------------------------------------------------------------------------- /R/render-contour.R: -------------------------------------------------------------------------------- 1 | #' Render 3d observations as contours. 2 | #' 3 | #' @inheritParams render_point 4 | #' @param x,y,z 3d location of each point 5 | #' @param nbreaks,breaks Either the number of breaks between the smallest and 6 | #' largest z values, or the positions of the breaks. 7 | #' @return A path geometry. 8 | #' @export 9 | #' @examples 10 | #' n <- 50 11 | #' waves <- expand.grid( 12 | #' x = seq(-pi, pi, length = n), 13 | #' y = seq(-pi, pi, length = n) 14 | #' ) 15 | #' r <- sqrt(waves$x ^ 2 + waves$y ^ 2) 16 | #' waves$ripple <- cos(r ^ 2) * exp(-r / 6) 17 | #' waves$hill <- exp(1 - r) 18 | #' 19 | #' waves %>% render_contour(~x, ~y, ~hill) %>% plot() 20 | #' waves %>% render_contour(~x, ~y, ~ripple) %>% plot() 21 | #' 22 | #' # Show only where function crosses 0 23 | #' waves %>% render_contour(~x, ~y, ~ripple, breaks = 0) %>% plot() 24 | render_contour <- function(data, x, y, z, nbreaks = 10, breaks = NULL) { 25 | x <- eval_vector(data, x) 26 | y <- eval_vector(data, y) 27 | z <- eval_vector(data, z) 28 | contour_lines(x, y, z, nbreaks = nbreaks, breaks = breaks) 29 | } 30 | 31 | contour_lines <- function(x, y, z, nbreaks = 10, breaks = NULL) { 32 | if (is.null(breaks)) { 33 | z_rng <- range(z, na.rm = TRUE) 34 | breaks <- seq(z_rng[1], z_rng[2], length = nbreaks) 35 | } 36 | 37 | # Convert x, y, z vectors into matrix of unique values 38 | x0 <- sort(unique(x)) 39 | x_ind <- match(x, x0) 40 | y0 <- sort(unique(y)) 41 | y_ind <- match(y, y0) 42 | 43 | z_grid <- matrix(NA_real_, length(x0), length(y0)) 44 | z_grid[cbind(x_ind, y_ind)] <- z 45 | 46 | cl <- contourLines(x = x0, y = y0, z = z_grid, levels = breaks) 47 | 48 | if (length(cl) == 0) { 49 | stop("Failed to generate contours", call. = FALSE) 50 | } 51 | 52 | out <- list( 53 | x_ = coords(pluck(cl, "x")), 54 | y_ = coords(pluck(cl, "y")), 55 | z_ = pluck(cl, "level", numeric(1)) 56 | ) 57 | `as.data.frame!`(out, length(cl)) 58 | class(out) <- c("geom_path", "geom", "data.frame") 59 | out 60 | } 61 | -------------------------------------------------------------------------------- /R/compute-vw-distance.R: -------------------------------------------------------------------------------- 1 | #' Compute the distance for paths with the Visvalingam-Whyatt algorithm. 2 | #' 3 | #' Visvalingam-Whyatt is a method of simplifying lines. It starts by 4 | #' computing the area of the triangle formed by each sequence of three points. 5 | #' (The triangles are overlapping.) Then it removes the middle point of the 6 | #' triangle with the smallest area, and recomputes the area of the neighbor 7 | #' triangles that are affected by the removal of that point. This repeats until 8 | #' all the points are removed except the two endpoints. 9 | #' 10 | #' See \url{http://bost.ocks.org/mike/simplify/} for more details. 11 | #' 12 | #' Note that this function does not do any simplification - it just adds an 13 | #' additional column the measures the area of the triangle at each point (where 14 | #' the point is the middle point of the triangle). Filtering on this column will 15 | #' perform simplification. 16 | #' 17 | #' @param data A data frame like object. 18 | #' @param x_var,y_var Formulas specifying either variable names or expressions 19 | #' to use as x and y positions. 20 | #' @seealso \code{\link{geometry_simplify}()} for an function that works on a 21 | #' geometry and does simplification given tolerance or percentage of points to 22 | #' keep. 23 | #' @return A data frame with columns: \item{x_,y_}{Position} 24 | #' \item{distance_}{Distance between point and sub-line} 25 | #' @export 26 | #' @examples 27 | #' df <- data.frame(x = c(1,2,3,4,5), y = c(1,1.2,3.8,3.3,5)) 28 | #' 29 | #' # compute_vw_distance(df, ~x, ~y) 30 | compute_vw_distance <- function(data, x_var, y_var) { 31 | UseMethod("compute_vw_distance") 32 | } 33 | 34 | #' @export 35 | compute_vw_distance.data.frame <- function(data, x_var, y_var) { 36 | x <- eval_vector(data, x_var) 37 | y <- eval_vector(data, y_var) 38 | 39 | data.frame( 40 | x_ = x, 41 | y_ = y, 42 | dist_ = vw_distance(x, y) 43 | ) 44 | } 45 | 46 | #' @export 47 | compute_vw_distance.grouped_df <- function(data, x_var, y_var) { 48 | dplyr::do(data, compute_vw_distance(., x_var, y_var)) 49 | } 50 | -------------------------------------------------------------------------------- /src/warp.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include "geometry.h" 3 | using namespace Rcpp; 4 | 5 | void warp(Point next, Point next_t, Point (f)(Point), double threshold, 6 | std::vector* pRaw, std::vector* pTrans) { 7 | 8 | if (pRaw->empty()) 9 | return; 10 | 11 | Point last = pRaw->back(), last_t = pTrans->back(); 12 | Point mid = last.combine(next, 0.5), mid_t = f(mid); 13 | 14 | double dist = mid_t.dist_to_line(last_t, next_t); 15 | if (isnan(dist) || dist < threshold) 16 | return; 17 | 18 | warp(mid, mid_t, f, threshold, pRaw, pTrans); 19 | pRaw->push_back(mid); 20 | pTrans->push_back(mid_t); 21 | warp(next, next_t, f, threshold, pRaw, pTrans); 22 | 23 | } 24 | 25 | List warp(NumericVector x, NumericVector y, Point (f)(Point), 26 | double threshold = 0.01, bool closed = false) { 27 | if (x.size() != y.size()) 28 | stop("x and y must be same length"); 29 | 30 | int n = x.size(); 31 | std::vector raw, trans; 32 | 33 | for (int i = 0; i < n; ++i) { 34 | Point next = Point(x[i], y[i]), next_t = f(next); 35 | warp(next, next_t, f, threshold, &raw, &trans); 36 | 37 | raw.push_back(next); 38 | trans.push_back(next_t); 39 | } 40 | 41 | if (closed) { 42 | Point next = Point(x[0], y[0]), next_t = f(next); 43 | warp(next, next_t, f, threshold, &raw, &trans); 44 | } 45 | 46 | int m = trans.size(); 47 | NumericVector out_x(m), out_y(m); 48 | for (int i = 0; i < m; ++i) { 49 | out_x[i] = trans[i].x; 50 | out_y[i] = trans[i].y; 51 | } 52 | return List::create(_["x"] = out_x, _["y"] = out_y); 53 | } 54 | 55 | Point transform_polar(Point input) { 56 | return Point(input.y * sin(input.x), input.y * cos(input.x)); 57 | } 58 | Point transform_identity(Point input) { 59 | return input; 60 | } 61 | 62 | // [[Rcpp::export]] 63 | List warp(NumericVector x, NumericVector y, std::string f, 64 | double threshold = 0.01, bool closed = false) { 65 | if (f == "polar") { 66 | return warp(x, y, transform_polar, threshold, closed); 67 | } else if (f == "identity") { 68 | return warp(x, y, transform_identity, threshold, closed); 69 | } 70 | 71 | stop("Unknown transformation type"); 72 | return List::create(); 73 | } 74 | -------------------------------------------------------------------------------- /src/vw-distance.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include "heap.h" 3 | using namespace Rcpp; 4 | 5 | inline double compute_area(double x1, double y1, double x2, double y2, 6 | double x3, double y3) { 7 | return fabs((x1 - x3) * (y2 - y1) - (x1 - x2) * (y3 - y1)) / 2; 8 | } 9 | 10 | // [[Rcpp::export]] 11 | NumericVector vw_distance(const NumericVector& x, const NumericVector& y) { 12 | int n = x.size(); 13 | 14 | Heap h(0); 15 | std::vector prev(n), next(n); 16 | 17 | // Fill in data for all the points 18 | for(int i = 0; i < n; i++) { 19 | double area = (i == 0 || i == n - 1) ? INFINITY : 20 | compute_area(x[i - 1], y[i - 1], x[i], y[i], x[i + 1], y[i + 1]); 21 | h.insert(area); 22 | prev[i] = i - 1; 23 | next[i] = i + 1; 24 | } 25 | 26 | NumericVector area(n); 27 | double max_area = -INFINITY; 28 | 29 | // Remove point with minimum area, and recompute neighbors' areas, repeating 30 | // until the heap is empty 31 | while(!h.empty()) { 32 | std::pair top = h.pop(); 33 | 34 | int idx = top.first; 35 | // Forces area to always increase so that points are added in 36 | // correct order 37 | max_area = fmax(max_area, top.second); 38 | area[idx] = max_area; 39 | 40 | // Update neighbouring points 41 | int next_idx = next[idx]; 42 | int prev_idx = prev[idx]; 43 | 44 | // Must be first or last point, so don't need to update area 45 | if (next_idx == n || prev_idx == -1) 46 | continue; 47 | 48 | next[prev_idx] = next_idx; 49 | prev[next_idx] = prev_idx; 50 | prev[idx] = -1; 51 | next[idx] = -1; 52 | 53 | // Recalculate area of neighbors (unless they're first or last) 54 | if (prev_idx != 0 && prev_idx != -1) { 55 | double area = compute_area(x[prev[prev_idx]], y[prev[prev_idx]], 56 | x[prev_idx], y[prev_idx], 57 | x[next_idx], y[next_idx]); 58 | h.update(prev_idx, area); 59 | } 60 | 61 | if (next_idx != n - 1 && next_idx != -1 && prev_idx != -1) { 62 | double area = compute_area(x[prev_idx], y[prev_idx], 63 | x[next_idx], y[next_idx], 64 | x[next[next_idx]], next[next_idx]); 65 | h.update(next_idx, area); 66 | } 67 | } 68 | 69 | return area; 70 | } 71 | -------------------------------------------------------------------------------- /R/coords.R: -------------------------------------------------------------------------------- 1 | #' A simple class for managing lists of coordinates. 2 | #' 3 | #' gggeom assumes that every geometry can be represented with a single row 4 | #' of a data frame. This poses a challenge for path and polygon geometries 5 | #' which can be of arbitrary length. To solve this problem, gggeom uses a 6 | #' list-column, where each component of the list is of the same type. 7 | #' 8 | #' @export 9 | #' @param x A list to label as containing coordinates. 10 | #' @keywords internal 11 | #' @examples 12 | #' make_spiral <- function(turns, r, n = 200) { 13 | #' t_grid <- seq(0, turns * 2 * pi, length = n) 14 | #' r_grid <- seq(0, r, length = n) 15 | #' df <- data.frame(x = r_grid * sin(t_grid), y = r_grid * cos(t_grid)) 16 | #' render_path(df, ~x, ~y) 17 | #' } 18 | #' s1 <- make_spiral(6, 1) 19 | #' s2 <- make_spiral(-4, 10) 20 | #' 21 | #' s1 22 | #' str(s1) 23 | #' s1$x_ 24 | #' 25 | #' spirals <- rbind(s1, s2) 26 | #' range(spirals$x_) 27 | #' spirals %>% plot(col = c("red", "black")) 28 | coords <- function(x) { 29 | stopifnot(is.list(x)) 30 | class(x) <- "coords" 31 | x 32 | } 33 | 34 | #' @export 35 | range.coords <- function(x, ...) { 36 | range(unlist(x), ...) 37 | } 38 | 39 | #' @export 40 | `[.coords` <- function(x, ...) { 41 | structure(NextMethod(), class = "coords") 42 | } 43 | 44 | #' @export 45 | format.coords <- function(x, ...) { 46 | vapply(x, obj_type, character(1)) 47 | } 48 | 49 | #' @export 50 | print.coords <- function(x, ...) { 51 | print(format(x, ...), quote = FALSE) 52 | } 53 | 54 | obj_type <- function(x) { 55 | if (!is.object(x)) { 56 | paste0("<", type_sum(x), if (!is.array(x)) paste0("[", length(x), "]"), ">") 57 | } else if (!isS4(x)) { 58 | paste0("") 59 | } else { 60 | paste0("") 61 | } 62 | } 63 | 64 | type_sum <- function(x) UseMethod("type_sum") 65 | type_sum.numeric <- function(x) "dbl" 66 | type_sum.integer <- function(x) "int" 67 | type_sum.logical <- function(x) "lgl" 68 | type_sum.character <- function(x) "chr" 69 | type_sum.factor <- function(x) "fctr" 70 | type_sum.POSIXt <- function(x) "time" 71 | type_sum.Date <- function(x) "date" 72 | type_sum.matrix <- function(x) { 73 | paste0(NextMethod(), "[", paste0(dim(x), collapse = ","), "]") 74 | } 75 | type_sum.array <- type_sum.matrix 76 | type_sum.default <- function(x) unname(abbreviate(class(x)[1], 4)) 77 | -------------------------------------------------------------------------------- /R/rescale.R: -------------------------------------------------------------------------------- 1 | #' Scale stacked values. 2 | #' 3 | #' @inheritParams geometry_flip 4 | #' @inheritParams geometry_stack 5 | #' @param max Maximum value to scale to. Defaults to 1, except when scaling 6 | #' "theta", where it defaults to 2 * pi. 7 | #' @export 8 | #' @examples 9 | #' bar_ex %>% geometry_stack() %>% plot() 10 | #' bar_ex %>% geometry_stack() %>% geometry_scale() %>% plot() 11 | #' 12 | #' pies <- render_arc(mtcars, ~vs, ~am, 0, 0.1, 0, ~mpg / max(mpg) * 2 / pi) 13 | #' pies %>% geometry_stack() %>% plot() 14 | #' pies %>% geometry_stack() %>% geometry_scale() %>% plot() 15 | #' 16 | #' disks <- render_arc(mtcars, ~vs, ~am, 0, 0.05, 0, 2 * pi) 17 | #' disks %>% geometry_stack("r") %>% geometry_scale("r", 0.45) %>% plot() 18 | geometry_scale <- function(geom, dir = c("y", "x"), max = 1) { 19 | UseMethod("geometry_scale") 20 | } 21 | 22 | #' @export 23 | geometry_scale.geom_rect <- function(geom, dir = c("y", "x"), max = 1) { 24 | dir <- match.arg(dir) 25 | 26 | if (dir == "x") { 27 | scale(geom, "x", "y1_", max_value = max) 28 | } else { 29 | scale(geom, "y", "x1_", max_value = max) 30 | } 31 | } 32 | 33 | #' @export 34 | geometry_scale.geom_ribbon <- function(geom, dir, max = 1) { 35 | geometry_scale.geom_rect(geom, "y", max = max) 36 | } 37 | 38 | #' @export 39 | geometry_scale.geom_arc <- function(geom, dir = c("theta", "r"), max = NULL) { 40 | dir <- match.arg(dir) 41 | 42 | if (dir == "theta") { 43 | scale(geom, "theta", c("x_", "y_"), max %||% 2 * pi) 44 | } else { 45 | scale(geom, "r", c("x_", "y_"), max %||% 1) 46 | } 47 | } 48 | 49 | scale <- function(data, scale_var, group_vars, max_value = 1) { 50 | lower <- paste0(scale_var, "1_") 51 | upper <- paste0(scale_var, "2_") 52 | vals <- list(x1 = as.name(lower), x2 = as.name(upper), y = max_value) 53 | 54 | # This is slightly inefficient because we're calculating the abs_max twice 55 | new_vars <- list( 56 | lazyeval::interp(~ x1 / abs_max_(x2) * y, .values = vals), 57 | lazyeval::interp(~ x2 / abs_max_(x2) * y, .values = vals) 58 | ) 59 | names(new_vars) <- c(lower, upper) 60 | 61 | scaled <- data %>% 62 | dplyr::group_by_(.dots = group_vars, add = TRUE) %>% 63 | dplyr::mutate_(.dots = new_vars) 64 | 65 | # Restore old grouping 66 | old_groups <- dplyr::groups(data) 67 | if (!is.null(old_groups)) { 68 | scaled <- dplyr::group_by_(.dots = old_groups) 69 | } 70 | 71 | class(scaled) <- class(data) 72 | scaled 73 | } 74 | -------------------------------------------------------------------------------- /R/reflect.R: -------------------------------------------------------------------------------- 1 | #' Reflect positions around an axis. 2 | #' 3 | #' @inheritParams geometry_flip 4 | #' @param dir Direction in which to reflect. One of "x" and "y". (Specifying "x" 5 | #' will flip the x values about the y axis. 6 | #' @export 7 | #' @examples 8 | #' scatter_ex %>% plot() 9 | #' scatter_ex %>% geometry_reflect() %>% plot() 10 | #' scatter_ex %>% geometry_reflect("y") %>% plot() 11 | #' 12 | #' histogram_ex %>% plot() 13 | #' histogram_ex %>% geometry_reflect() %>% plot() 14 | #' histogram_ex %>% geometry_reflect("y") %>% plot() 15 | #' histogram_ex %>% geometry_reflect("y") %>% geometry_flip() %>% plot() 16 | #' 17 | #' nz %>% plot() 18 | #' nz %>% geometry_reflect() %>% plot() 19 | #' nz %>% geometry_reflect("y") %>% plot() 20 | geometry_reflect <- function(geom, dir = c("x", "y")) { 21 | UseMethod("geometry_reflect") 22 | } 23 | 24 | #' @export 25 | geometry_reflect.geom <- function(geom, dir = c("x", "y")) { 26 | dir <- match.arg(dir) 27 | 28 | if (dir == "x") { 29 | geom$x_ <- -geom$x_ 30 | } else { 31 | geom$y_ <- -geom$y_ 32 | } 33 | 34 | geom 35 | } 36 | 37 | #' @export 38 | geometry_reflect.geom_path <- function(geom, dir = c("x", "y")) { 39 | dir <- match.arg(dir) 40 | 41 | if (dir == "x") { 42 | geom$x_ <- lapply(geom$x_, `-`) 43 | } else { 44 | geom$y_ <- lapply(geom$y_, `-`) 45 | } 46 | 47 | geom 48 | } 49 | 50 | #' @export 51 | geometry_reflect.geom_ribbon <- function(geom, dir = c("x", "y")) { 52 | dir <- match.arg(dir) 53 | 54 | if (dir == "x") { 55 | geom$y1_ <- -geom$y1_ 56 | geom$y2_ <- -geom$y2_ 57 | geom <- switch_cols(geom, "y1_", "y2_") 58 | } else { 59 | geom$x_ <- -rev(geom$x_) 60 | geom$y1_ <- rev(geom$y1_) 61 | geom$y2_ <- rev(geom$y2_) 62 | } 63 | 64 | geom 65 | } 66 | 67 | #' @export 68 | geometry_reflect.geom_line <- function(geom, dir = c("x", "y")) { 69 | dir <- match.arg(dir) 70 | 71 | if (dir == "x") { 72 | geom$y_ <- -geom$y_ 73 | } else { 74 | geom$x_ <- -rev(geom$x_) 75 | geom$y_ <- rev(geom$y_) 76 | } 77 | 78 | geom 79 | } 80 | 81 | #' @export 82 | geometry_reflect.geom_rect <- function(geom, dir = c("x", "y")) { 83 | dir <- match.arg(dir) 84 | 85 | if (dir == "x") { 86 | geom$x1_ <- -geom$x1_ 87 | geom$x2_ <- -geom$x2_ 88 | geom <- switch_cols(geom, "x1_", "x2_") 89 | } else { 90 | geom$y1_ <- -geom$y1_ 91 | geom$y2_ <- -geom$y2_ 92 | geom <- switch_cols(geom, "y1_", "y2_") 93 | } 94 | 95 | geom 96 | } 97 | -------------------------------------------------------------------------------- /R/warp.R: -------------------------------------------------------------------------------- 1 | #' Warp a path or polygon with adaptive resampling 2 | #' 3 | #' This recursively split each line segment into pieces until the transformed 4 | #' point is less that \code{tolerance} away from the transformed line 5 | #' segment. 6 | #' 7 | #' @inheritParams geometry_flip 8 | #' @param fun A warping function to use. Currently these are hard coded 9 | #' because they much be implemented in C++ for performance reasons. 10 | #' @param tolerance Approximation errors below this threshold will be 11 | #' ignored. If \code{NULL}, attempts to guess a reasonable value. 12 | #' @export 13 | #' @examples 14 | #' spiral <- data.frame( 15 | #' x = seq(0, 6 * pi, length = 10), 16 | #' y = seq(0, 1, length = 10) 17 | #' ) 18 | #' path <- render_path(spiral, ~x, ~y) 19 | #' path %>% plot() %>% points() 20 | #' 21 | #' path %>% geometry_warp("polar") %>% plot() 22 | #' path %>% geometry_warp("polar", tolerance = 0.1) %>% plot() %>% points() 23 | #' 24 | #' # Crazy example 25 | #' expand.grid(x = seq(0, pi, length = 4), y = 0:3) %>% 26 | #' render_tile(~x, ~y, halign = 0, valign = 0) %>% 27 | #' geometry_pointificate() %>% 28 | #' geometry_rotate(15) %>% 29 | #' geometry_warp("polar") %>% 30 | #' plot() 31 | geometry_warp <- function(geom, fun = c("polar", "identity"), tolerance = NULL) { 32 | UseMethod("geometry_warp") 33 | } 34 | 35 | #' @export 36 | geometry_warp.geom_path <- function(geom, fun = c("polar", "identity"), 37 | tolerance = NULL) { 38 | tolerance <- tolerance %||% guess_tolerance(geom$x_, geom$y_) 39 | 40 | warped <- Map(function(x, y) warp(x, y, fun, tolerance ^ 2), geom$x_, geom$y_) 41 | geom$x_ <- coords(pluck(warped, "x")) 42 | geom$y_ <- coords(pluck(warped, "y")) 43 | 44 | geom 45 | } 46 | 47 | #' @export 48 | geometry_warp.geom_polygon <- function(geom, fun = c("polar", "identity"), 49 | tolerance = NULL) { 50 | 51 | tolerance <- tolerance %||% guess_tolerance(geom$x_, geom$y_) 52 | 53 | warped <- Map(function(x, y) warp(x, y, fun, tolerance ^ 2, closed = TRUE), 54 | geom$x_, geom$y_) 55 | geom$x_ <- coords(pluck(warped, "x")) 56 | geom$y_ <- coords(pluck(warped, "y")) 57 | 58 | geom 59 | } 60 | 61 | guess_tolerance <- function(x, y) { 62 | # Need to be doing this on transformed range, not original! 63 | x_rng <- diff(range(x, na.rm = TRUE)) 64 | y_rng <- diff(range(y, na.rm = TRUE)) 65 | 66 | guess <- min(x_rng, y_rng) / 1e3 67 | message("Using tolerance of ", format(guess, digits = 3)) 68 | guess 69 | } 70 | -------------------------------------------------------------------------------- /R/jitter.R: -------------------------------------------------------------------------------- 1 | #' Jitter geometries to avoid overplotting. 2 | #' 3 | #' Jitter adds random uniform offsets to avoid overplotting. 4 | #' 5 | #' Jittering differs a little depending on the underlying geometry: 6 | #' \describe{ 7 | #' \item{point,path,polygon,text}{Jitters both x and y.} 8 | #' \item{ribbon}{Jitters y1 & y2 by same amount} 9 | #' \item{rect}{Jitters x1 & x2, and y1 & y2 by same amount - the 10 | #' height and width stay the same.} 11 | #' } 12 | #' @inheritParams geometry_flip 13 | #' @param x,y amount to jitter in x and y directions. In most cases, defaults 14 | #' to 40\% of the resolution of the data. 15 | #' @export 16 | #' @examples 17 | #' scatter_ex %>% 18 | #' plot() %>% 19 | #' geometry_jitter() %>% 20 | #' plot(add = TRUE, col = "red") 21 | #' 22 | #' # Can override amount of jitter 23 | #' scatter_ex %>% 24 | #' plot() %>% 25 | #' geometry_jitter(0.2, 0.2) %>% 26 | #' plot(add = TRUE, col = "red") 27 | geometry_jitter <- function(geom, x = NULL, y = NULL) { 28 | UseMethod("geometry_jitter") 29 | } 30 | 31 | #' @export 32 | geometry_jitter.geom <- function(geom, 33 | x = resolution(geom$x_) * 0.4, 34 | y = resolution(geom$y_) * 0.4) { 35 | geom$x_ <- geom$x_ + jitter(geom, x) 36 | geom$y_ <- geom$y_ + jitter(geom, y) 37 | geom 38 | } 39 | 40 | #' @export 41 | geometry_jitter.geom_path <- function(geom, 42 | x = resolution(geom$x_) * 0.4, 43 | y = resolution(geom$y_) * 0.4) { 44 | 45 | x_jitter <- jitter(geom, x) 46 | y_jitter <- jitter(geom, y) 47 | 48 | geom$x_ <- Map(`+`, geom$x_, x_jitter) 49 | geom$y_ <- Map(`+`, geom$y_, x_jitter) 50 | 51 | geom 52 | } 53 | 54 | #' @export 55 | geometry_jitter.geom_ribbon <- function(geom, x = 0, y = resolution(geom$y1_) * 0.4) { 56 | geom$x_ <- geom$x_ + jitter(geom, x) 57 | 58 | y_jitter <- jitter(geom, y) 59 | geom$y1_ <- geom$y1_ + y_jitter 60 | geom$y2_ <- geom$y2_ + y_jitter 61 | 62 | geom 63 | } 64 | 65 | #' @export 66 | geometry_jitter.geom_rect <- function(geom, 67 | x = resolution(c(geom$x1_, geom$x2_)) * 0.4, 68 | y = resolution(c(geom$y1_, geom$y2_)) * 0.4) { 69 | x_jitter <- jitter(geom, x) 70 | geom$x1_ <- geom$x1_ + x_jitter 71 | geom$x2_ <- geom$x2_ + x_jitter 72 | 73 | y_jitter <- jitter(geom, y) 74 | geom$y1_ <- geom$y1_ + y_jitter 75 | geom$y2_ <- geom$y2_ + y_jitter 76 | 77 | geom 78 | } 79 | 80 | jitter <- function(geom, amount) { 81 | if (amount == 0) return(0) 82 | runif(nrow(geom), -amount, amount) 83 | } 84 | -------------------------------------------------------------------------------- /R/transform.R: -------------------------------------------------------------------------------- 1 | #' Perform a linear transformation on a geometry. 2 | #' 3 | #' Perform a linear transformation on a geometry, using a specified point as the 4 | #' center. 5 | #' 6 | #' @param geom A geometry data frame. 7 | #' @param m A 2x2 transformation matrix. 8 | #' @param x,y The coordinates of the center to use for the transformation. 9 | #' @export 10 | #' @examples 11 | #' # Some transformation matrices 12 | #' shear <- matrix(c(1, 0, 0.75, 1), nrow = 2) 13 | #' reflect_y <- matrix(c(-1, 0, 0, 1), nrow = 2) 14 | #' t <- 30 * pi / 180 15 | #' rotate30 <- matrix(c(cos(t), -sin(t), sin(t), cos(t)), nrow = 2) 16 | #' 17 | #' scatter_ex %>% plot() 18 | #' scatter_ex %>% plot() %>% geometry_transform(shear) 19 | #' scatter_ex %>% geometry_transform(reflect_y) %>% plot() 20 | #' scatter_ex %>% geometry_transform(rotate30) %>% plot() 21 | #' 22 | #' bar_ex %>% plot() 23 | #' # Convert to geometry_polygon 24 | #' bar_ex2 <- bar_ex %>% unique() %>% geometry_pointificate() 25 | #' bar_ex2 %>% geometry_transform(shear) %>% plot() 26 | #' bar_ex2 %>% geometry_transform(reflect_y) %>% plot() 27 | #' bar_ex2 %>% geometry_transform(rotate30) %>% plot() 28 | #' 29 | #' # Rotate about (10, 1) instead of origin 30 | #' bar_ex2 %>% geometry_transform(rotate30, 10, 1) %>% plot() 31 | geometry_transform <- function(geom, m, x = 0, y = 0) { 32 | UseMethod("geometry_transform") 33 | } 34 | 35 | #' @export 36 | geometry_transform.geom_point <- function(geom, m, x = 0, y = 0) { 37 | trans <- transform(geom$x_, geom$y_, m, x, y) 38 | 39 | geom$x_ <- trans$x 40 | geom$y_ <- trans$y 41 | geom 42 | } 43 | #' @export 44 | geometry_transform.geom_arc <- geometry_transform.geom_point 45 | 46 | 47 | #' @export 48 | geometry_transform.geom_path <- function(geom, m, x = 0, y = 0) { 49 | trans <- Map( 50 | function(x1, y1) transform(x1, y1, m, x_center = x, y_center = 0), 51 | geom$x_, 52 | geom$y_ 53 | ) 54 | 55 | geom$x_ <- pluck(trans, "x") 56 | geom$y_ <- pluck(trans, "y") 57 | geom 58 | } 59 | 60 | #' @export 61 | geometry_transform.geom_line <- function(geom, m, x = 0, y = 0) { 62 | warning("Transforming lines converts to paths", call. = FALSE) 63 | out <- geometry_transform(geom, m, x, y) 64 | class(out) <- setdiff(class(out), "geom_line") 65 | out 66 | } 67 | 68 | #' @export 69 | geometry_transform.geom_ribbon <- function(geom, m, x = 0, y = 0) { 70 | stop("Can't transform ribbons. Perhaps you want to use geometry_pointificate() first?", call. = FALSE) 71 | } 72 | 73 | #' @export 74 | geometry_transform.geom_rect <- function(geom, m, x = 0, y = 0) { 75 | stop("Can't transform rects. Perhaps you want to use geometry_pointificate() first?", call. = FALSE) 76 | } 77 | 78 | transform <- function(x, y, m, x_center, y_center) { 79 | trans <- cbind(x_center, y_center)[rep(1, length(x)), ] 80 | 81 | res <- cbind(x, y) - trans 82 | res <- res %*% m 83 | res <- res + trans 84 | 85 | list(x = res[, 1], y = res[, 2]) 86 | } 87 | -------------------------------------------------------------------------------- /R/pointificate.R: -------------------------------------------------------------------------------- 1 | #' Convert complex geometries in to points, paths and polygons. 2 | #' 3 | #' @inheritParams geometry_flip 4 | #' @param ... Additional arguments passed on to methods. 5 | #' \itemize{ 6 | #' \item{\code{geometry_polygon}: use \code{close = TRUE} to "close" the 7 | #' polygon by putting the first point at the end.} 8 | #' } 9 | #' @export 10 | #' @examples 11 | #' x <- seq(0, 4 * pi, length = 100) 12 | #' df <- data.frame(x = x, y = sin(x)) 13 | #' rib <- render_ribbon(df, ~x, ~y - 1, ~ y + 1) 14 | #' rib %>% plot() 15 | #' rib %>% geometry_pointificate() %>% plot() 16 | #' rib %>% geometry_pointificate() %>% geometry_flip() %>% plot() 17 | #' 18 | #' df <- expand.grid(x = 1:3, y = 1:3) 19 | #' df$z <- runif(9, pi, 2 * pi) 20 | #' arc <- df %>% render_arc(~x, ~y, 0, 0.35, 0, ~z) 21 | #' arc %>% plot() 22 | #' arc %>% geometry_pointificate() %>% plot() 23 | #' 24 | #' histogram_ex %>% plot() 25 | #' histogram_ex %>% geometry_pointificate() %>% plot() 26 | #' 27 | #' nz %>% plot() 28 | #' nz %>% geometry_pointificate(close = TRUE) %>% plot() 29 | geometry_pointificate <- function(geom, ...) { 30 | UseMethod("geometry_pointificate") 31 | } 32 | 33 | #' @export 34 | geometry_pointificate.geom_point <- function(geom, ...) { 35 | geom 36 | } 37 | 38 | #' @export 39 | geometry_pointificate.geom_path <- function(geom, ...) { 40 | geom 41 | } 42 | 43 | #' @export 44 | geometry_pointificate.geom_polygon <- function(geom, ..., close = FALSE) { 45 | if (!close) { 46 | geom 47 | } else { 48 | close <- function(x) x[c(1:length(x), 1)] 49 | 50 | geom$x_ <- coords(lapply(geom$x_, close)) 51 | geom$y_ <- coords(lapply(geom$y_, close)) 52 | geom 53 | } 54 | } 55 | 56 | #' @export 57 | geometry_pointificate.geom_ribbon <- function(geom, ...) { 58 | geom$x_ <- coords(row_apply(geom, function(df) c(df$x_, rev(df$x_)))) 59 | geom$y_ <- coords(row_apply(geom, function(df) c(df$y1_, rev(df$y2_)))) 60 | geom$y1_ <- NULL 61 | geom$y2_ <- NULL 62 | 63 | class(geom) <- c("geom_polygon", "geom_path", "geom", "data.frame") 64 | geom 65 | } 66 | 67 | #' @export 68 | geometry_pointificate.geom_arc <- function(geom, ...) { 69 | 70 | arcs <- row_apply(geom, function(df) { 71 | make_arc(df$x_, df$y_, c(df$r1_, df$r2_), c(df$theta1_, df$theta2_)) 72 | }) 73 | 74 | geom$x_ <- coords(pluck(arcs, "x_")) 75 | geom$y_ <- coords(pluck(arcs, "y_")) 76 | 77 | geom$r1_ <- NULL 78 | geom$r2_ <- NULL 79 | geom$theta1_ <- NULL 80 | geom$theta2_ <- NULL 81 | 82 | class(geom) <- c("geom_polygon", "geom_path", "geom", "data.frame") 83 | geom 84 | } 85 | 86 | 87 | #' @export 88 | geometry_pointificate.geom_rect <- function(geom, ...) { 89 | 90 | geom$x_ <- coords(row_apply(geom, function(df) c(df$x1_, df$x2_, df$x2_, df$x1_))) 91 | geom$y_ <- coords(row_apply(geom, function(df) c(df$y1_, df$y1_, df$y2_, df$y2_))) 92 | 93 | geom$x1_ <- NULL 94 | geom$x2_ <- NULL 95 | geom$y1_ <- NULL 96 | geom$y2_ <- NULL 97 | 98 | class(geom) <- c("geom_polygon", "geom_path", "geom", "data.frame") 99 | geom 100 | } 101 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2 (4.0.2): do not edit by hand 2 | 3 | S3method("[",coords) 4 | S3method(compute_dp_distance,data.frame) 5 | S3method(compute_dp_distance,grouped_df) 6 | S3method(compute_vw_distance,data.frame) 7 | S3method(compute_vw_distance,grouped_df) 8 | S3method(format,coords) 9 | S3method(geometry_dodge,geom_rect) 10 | S3method(geometry_flip,geom) 11 | S3method(geometry_flip,geom_rect) 12 | S3method(geometry_flip,geom_ribbon) 13 | S3method(geometry_jitter,geom) 14 | S3method(geometry_jitter,geom_path) 15 | S3method(geometry_jitter,geom_rect) 16 | S3method(geometry_jitter,geom_ribbon) 17 | S3method(geometry_pointificate,geom_arc) 18 | S3method(geometry_pointificate,geom_path) 19 | S3method(geometry_pointificate,geom_point) 20 | S3method(geometry_pointificate,geom_polygon) 21 | S3method(geometry_pointificate,geom_rect) 22 | S3method(geometry_pointificate,geom_ribbon) 23 | S3method(geometry_reflect,geom) 24 | S3method(geometry_reflect,geom_line) 25 | S3method(geometry_reflect,geom_path) 26 | S3method(geometry_reflect,geom_rect) 27 | S3method(geometry_reflect,geom_ribbon) 28 | S3method(geometry_scale,geom_arc) 29 | S3method(geometry_scale,geom_rect) 30 | S3method(geometry_scale,geom_ribbon) 31 | S3method(geometry_simplify,geom_path) 32 | S3method(geometry_stack,geom) 33 | S3method(geometry_stack,geom_arc) 34 | S3method(geometry_stack,geom_rect) 35 | S3method(geometry_stack,geom_ribbon) 36 | S3method(geometry_transform,geom_arc) 37 | S3method(geometry_transform,geom_line) 38 | S3method(geometry_transform,geom_path) 39 | S3method(geometry_transform,geom_point) 40 | S3method(geometry_transform,geom_rect) 41 | S3method(geometry_transform,geom_ribbon) 42 | S3method(geometry_warp,geom_path) 43 | S3method(geometry_warp,geom_polygon) 44 | S3method(plot,geom_arc) 45 | S3method(plot,geom_path) 46 | S3method(plot,geom_point) 47 | S3method(plot,geom_polygon) 48 | S3method(plot,geom_rect) 49 | S3method(plot,geom_ribbon) 50 | S3method(plot,geom_segment) 51 | S3method(plot,geom_skyline) 52 | S3method(plot,geom_text) 53 | S3method(points,geom_path) 54 | S3method(points,geom_point) 55 | S3method(print,coords) 56 | S3method(print,geom) 57 | S3method(range,coords) 58 | S3method(render_path,data.frame) 59 | S3method(render_path,grouped_df) 60 | S3method(render_ribbon,data.frame) 61 | S3method(render_ribbon,grouped_df) 62 | export("%>%") 63 | export(compute_dp_distance) 64 | export(compute_vw_distance) 65 | export(coords) 66 | export(geometry_dodge) 67 | export(geometry_flip) 68 | export(geometry_jitter) 69 | export(geometry_pointificate) 70 | export(geometry_reflect) 71 | export(geometry_rotate) 72 | export(geometry_scale) 73 | export(geometry_simplify) 74 | export(geometry_stack) 75 | export(geometry_transform) 76 | export(geometry_warp) 77 | export(render_arc) 78 | export(render_area) 79 | export(render_bar) 80 | export(render_contour) 81 | export(render_line) 82 | export(render_path) 83 | export(render_point) 84 | export(render_polygon) 85 | export(render_rect) 86 | export(render_ribbon) 87 | export(render_segment) 88 | export(render_spoke) 89 | export(render_step) 90 | export(render_text) 91 | export(render_tile) 92 | export(resolution) 93 | importFrom(Rcpp,sourceCpp) 94 | importFrom(magrittr,"%>%") 95 | useDynLib(gggeom) 96 | -------------------------------------------------------------------------------- /R/stack.R: -------------------------------------------------------------------------------- 1 | #' Stack objects on top of one another. 2 | #' 3 | #' Rects are always stacked upwards from the x-axis, ignoring non-zero 4 | #' \code{y1_}. 5 | #' 6 | #' @inheritParams geometry_flip 7 | #' @param dir Direction in which to stack. "x" or "y" for rects, 8 | #' only "y" for smooths, "r" or "theta" for arcs. 9 | #' @export 10 | #' @examples 11 | #' bar_ex %>% plot() 12 | #' bar_ex %>% geometry_stack() %>% plot() 13 | #' 14 | #' bar_ex %>% geometry_flip() %>% plot() 15 | #' bar_ex %>% geometry_flip() %>% geometry_stack("x") %>% plot() 16 | #' 17 | #' # Overlapping bars are stacked on top of each other 18 | #' df <- data.frame(x = 1:3, y = 1:3) 19 | #' df %>% render_bar(~x, ~y, 2) %>% plot() 20 | #' df %>% render_bar(~x, ~y, 2) %>% geometry_stack() %>% plot() 21 | #' 22 | #' # Stacking ribbons 23 | #' theta <- seq(0, 2 * pi, length = 50) 24 | #' df <- data.frame(theta) 25 | #' waves <- rbind( 26 | #' df %>% render_area(~theta, ~abs(sin(theta))), 27 | #' df %>% render_area(~theta, ~abs(cos(theta))) 28 | #' ) 29 | #' waves %>% plot(col = c("red", "black")) 30 | #' waves %>% geometry_stack() %>% plot(col = c("red", "black")) 31 | #' df %>% render_area(~theta, ~abs(sin(theta)) + abs(cos(theta))) %>% plot() 32 | #' 33 | #' # You can also stack arcs, in either r or theta direction 34 | #' pies <- render_arc(mtcars, ~vs, ~am, 0, 0.1, 0, ~mpg / max(mpg) * 2 / pi) 35 | #' pies %>% plot() 36 | #' pies %>% geometry_stack() %>% plot() 37 | #' pies %>% geometry_stack("r") %>% plot() 38 | #' 39 | #' disks <- render_arc(mtcars, ~vs, ~am, 0, 0.05, 0, 2 * pi) 40 | #' disks %>% geometry_stack("r") %>% plot() 41 | geometry_stack <- function(geom, dir = c("y", "x")) { 42 | UseMethod("geometry_stack") 43 | } 44 | 45 | #' @export 46 | geometry_stack.geom <- function(geom, dir) { 47 | warning("Stacking ", class(geom)[1], " isn't well defined", call. = FALSE) 48 | geom 49 | } 50 | 51 | #' @export 52 | geometry_stack.geom_rect <- function(geom, dir = c("y", "x")) { 53 | dir <- match.arg(dir) 54 | 55 | if (dir == "x") { 56 | stacked <- stack_rects(geom$y1_, geom$y2_, geom$x1_, geom$x2_) 57 | geom$x1_ <- stacked$y1_ 58 | geom$x2_ <- stacked$y2_ 59 | } else { 60 | stacked <- stack_rects(geom$x1_, geom$x2_, geom$y1_, geom$y2_) 61 | geom$y1_ <- stacked$y1_ 62 | geom$y2_ <- stacked$y2_ 63 | } 64 | 65 | geom 66 | } 67 | 68 | #' @export 69 | geometry_stack.geom_ribbon <- function(geom, dir) { 70 | stacked <- stack_ribbons(geom$x_, geom$y1_, geom$y2_) 71 | geom$y1_ <- coords(stacked$y1_) 72 | geom$y2_ <- coords(stacked$y2_) 73 | geom 74 | } 75 | 76 | #' @export 77 | geometry_stack.geom_arc <- function(geom, dir = c("theta", "r")) { 78 | dir <- match.arg(dir) 79 | old_groups <- dplyr::groups(geom) 80 | 81 | geom <- dplyr::group_by_(geom, .dots = c("x_", "y_"), add = TRUE) 82 | 83 | if (dir == "theta") { 84 | geom <- stack_df(geom, "r1_", "r2_", "theta1_", "theta2_") 85 | } else { 86 | geom <- stack_df(geom, "theta1_", "theta2_", "r1_", "r2_") 87 | } 88 | 89 | # Restore old grouping 90 | if (!is.null(old_groups)) { 91 | geom <- dplyr::group_by_(geom, .dots = old_groups) 92 | } else { 93 | geom <- dplyr::ungroup(geom) 94 | } 95 | 96 | class(geom) <- c("geom_arc", "geom", "data.frame") 97 | geom 98 | 99 | } 100 | 101 | stack_df <- function(data, x1, x2, y1, y2) { 102 | stacked <- data %>% 103 | dplyr::do({ 104 | out <- stack_rects(.[[x1]], .[[x2]], .[[y1]], .[[y2]]) 105 | data <- . 106 | data[[y1]] <- out$y1_ 107 | data[[y2]] <- out$y2_ 108 | data 109 | }) 110 | 111 | class(stacked) <- class(data) 112 | stacked 113 | } 114 | -------------------------------------------------------------------------------- /src/heap.h: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | class Heap { 4 | 5 | public: 6 | std::vector value; 7 | // Need lookup in two directions: 8 | // addition order -> current position (used for updating) 9 | std::vector position; 10 | // current position -> addition order (used when popping) 11 | std::vector original; 12 | 13 | int n; 14 | 15 | Heap(int n_): n(n_) { 16 | value = std::vector(n, INFINITY); 17 | position = std::vector(n); 18 | original = std::vector(n); 19 | for (int i = 0; i < n; ++i) { 20 | position[i] = i; 21 | original[i] = i; 22 | } 23 | } 24 | 25 | template 26 | Heap(Vector x) { 27 | // Inefficient: O(n) algorithm is available 28 | // http://en.wikipedia.org/wiki/Binary_heap#Building_a_heap 29 | 30 | n = 0; 31 | int m = x.size(); 32 | value.reserve(m); 33 | position.reserve(m); 34 | original.reserve(m); 35 | 36 | for (int i = 0; i < m; ++i) { 37 | insert(x[i]); 38 | } 39 | } 40 | 41 | int insert(double x) { 42 | value.resize(n + 1); 43 | position.resize(n + 1); 44 | original.resize(n + 1); 45 | 46 | value[n] = x; 47 | position[n] = n; 48 | original[n] = n; 49 | bubble_up(n); 50 | 51 | return n++; 52 | } 53 | 54 | void update(int i, double new_x) { 55 | double pos = position[i]; 56 | 57 | if (pos >= n) Rcpp::stop("pos >= n"); 58 | 59 | double old = value[pos]; 60 | if (old == new_x) return; 61 | 62 | value[pos] = new_x; 63 | if (new_x > old) { // increase 64 | // Same principle as pop - move to bottom of subheap then bubble up. 65 | sift_down(pos); 66 | } else { // decrease 67 | bubble_up(pos); 68 | } 69 | 70 | } 71 | 72 | std::pair pop() { 73 | std::pair out = std::make_pair(original[0], value[0]); 74 | 75 | n--; 76 | value[0] = NAN; 77 | swap_el(0, n); 78 | sift_down(0); 79 | 80 | return out; 81 | } 82 | 83 | void swap_el(int a, int b) { 84 | std::swap(value[a], value[b]); 85 | 86 | int pos_a = original[a], pos_b = original[b]; 87 | std::swap(original[a], original[b]); 88 | std::swap(position[pos_a], position[pos_b]); 89 | } 90 | 91 | void sift_down(int i) { 92 | int l = left(i), r = right(i); 93 | if (needs_swap(i, l) && needs_swap(i, r)) { 94 | if (value[l] < value[r]) { 95 | swap_el(i, l); 96 | sift_down(l); 97 | } else { 98 | swap_el(i, r); 99 | sift_down(r); 100 | } 101 | } else if (needs_swap(i, l)) { 102 | swap_el(i, l); 103 | sift_down(l); 104 | } else if (needs_swap(i, r)) { 105 | swap_el(i, r); 106 | sift_down(r); 107 | } 108 | } 109 | 110 | bool needs_swap(int parent, int child) { 111 | if (child >= n) return false; 112 | return value[child] < value[parent]; 113 | } 114 | 115 | bool bubble_up(int i) { 116 | if (i == 0) return false; 117 | 118 | int j = parent(i); 119 | if (value[i] < value[j]) { 120 | swap_el(i, j); 121 | } 122 | return bubble_up(j); 123 | } 124 | 125 | // Helpers for navigating around the tree 126 | inline int left(int i) const { 127 | return 2 * i + 1; 128 | } 129 | inline int right(int i) const { 130 | return 2 * i + 2; 131 | } 132 | inline int parent(int i) const { 133 | return floor((i - 1) / 2); 134 | } 135 | 136 | bool empty() const { 137 | return n == 0; 138 | } 139 | 140 | Rcpp::List asList() const { 141 | Rcpp::List out = Rcpp::List::create( 142 | Rcpp::_["value"] = Rcpp::NumericVector(value.begin(), value.end()), 143 | Rcpp::_["position"] = Rcpp::IntegerVector(position.begin(), position.end()), 144 | Rcpp::_["n"] = n 145 | ); 146 | out.attr("class") = "heap"; 147 | 148 | return out; 149 | } 150 | }; 151 | 152 | 153 | inline std::ostream& operator<<(std::ostream& os, Heap h) { 154 | os << "V ["; 155 | int last = h.n - 1; 156 | for (int i = 0; i < h.n; ++i) { 157 | os << h.value[i]; 158 | if (i != last) 159 | os << ", "; 160 | } 161 | os << "]\nO ["; 162 | 163 | last = h.position.size() - 1; 164 | for (int i = 0; i < h.original.size(); ++i) { 165 | os << h.original[i]; 166 | if (i != last) 167 | os << ", "; 168 | } 169 | os << "]\nP ["; 170 | 171 | for (int i = 0; i < h.position.size(); ++i) { 172 | os << h.position[i]; 173 | if (i != last) 174 | os << ", "; 175 | } 176 | os << "]"; 177 | 178 | return os; 179 | } 180 | 181 | -------------------------------------------------------------------------------- /src/stack.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | using namespace Rcpp; 3 | 4 | typedef std::map::iterator itEdge; 5 | 6 | class Skyline { 7 | std::map edges; 8 | 9 | public: 10 | itEdge begin() { 11 | return edges.begin(); 12 | } 13 | itEdge end() { 14 | return edges.end(); 15 | } 16 | 17 | void add_building(double x1, double x2, double h) { 18 | if (x1 >= x2) return; 19 | if (h == 0) return; 20 | 21 | // Rcout << "[" << x1 << "," << x2 << "]\n"; 22 | 23 | // Add right edge - we do this before adding left edge because otherwise 24 | // it interferes with the calculation 25 | // The upper bound finds the first edge >= x1 26 | itEdge right = edges.lower_bound(x2); 27 | if (right == edges.end() || right == edges.begin()) { 28 | // Last edge always goes back down to zero 29 | right = edges.insert(std::make_pair(x2, 0)).first; 30 | } else { 31 | if (right->first == x2) { 32 | // New edge matches existing edge: don't need to do anything 33 | } else { // right->first > x2 34 | // If we're taller than the previous edge, this is where we have to 35 | // come back down 36 | itEdge prev(right); prev--; 37 | 38 | if (h > prev->second) { 39 | right = edges.insert(std::make_pair(x2, prev->second)).first; 40 | } 41 | } 42 | } 43 | // print(); 44 | 45 | // Find or insert the edge at the left of the building. 46 | // The upper bound finds the first edge > x1 47 | itEdge left = edges.upper_bound(x1); 48 | if (left == edges.begin()) { 49 | // Left is the first element, so we need to create a new edge before it. 50 | // Since it's the first edge, it must have height h 51 | left = edges.insert(std::make_pair(x1, h)).first; 52 | } else { 53 | // Find the first edge <= x1 54 | left--; 55 | if (left->first == x1) { 56 | // New edge is matches existing edge, so check height 57 | if (h > left->second) { 58 | left->second = h; 59 | } 60 | } else { // left->first < x1 61 | // Add new edge if it's taller than the previous edge 62 | if (h > left->second) { 63 | left = edges.insert(std::make_pair(x1, h)).first; 64 | } 65 | } 66 | } 67 | 68 | // Iterate from left to right adjusting heights and removing duplicates 69 | double prev_height = -INFINITY; 70 | itEdge cur(left); 71 | while(cur != right) { 72 | // Height can never be lower than the height of this building 73 | if (cur->second < h) { 74 | cur->second = h; 75 | } 76 | // Remove it if it's the same height as the previous 77 | if (cur->second == prev_height) { 78 | itEdge old = cur; 79 | cur++; 80 | edges.erase(old); 81 | } else { 82 | prev_height = cur->second; 83 | cur++; 84 | } 85 | } 86 | // print(); 87 | 88 | } 89 | 90 | double max_h(double x1, double x2) { 91 | // The upper bound finds the first edge > x1 92 | itEdge left = edges.upper_bound(x1); 93 | if (left != edges.begin()) left--; 94 | itEdge right = edges.lower_bound(x2); 95 | 96 | double h = 0; 97 | for(itEdge edge(left); left != right; left++) { 98 | if (edge->second > h) { 99 | h = edge->second; 100 | } 101 | } 102 | 103 | return h; 104 | } 105 | 106 | void print() { 107 | int m = edges.size(); 108 | NumericVector out_x(m), out_h(m); 109 | 110 | for(itEdge it = edges.begin(); it != edges.end(); ++it) { 111 | Rcout << it->first << ": " << it->second << "\n"; 112 | } 113 | 114 | Rcout << "\n"; 115 | } 116 | 117 | List as_list() { 118 | int m = edges.size(); 119 | NumericVector out_x(m), out_h(m); 120 | 121 | itEdge it; int i; 122 | for(it = edges.begin(), i = 0; it != edges.end(); ++it, ++i) { 123 | out_x[i] = it->first; 124 | out_h[i] = it->second; 125 | } 126 | 127 | return List::create( 128 | _["x"] = out_x, 129 | _["h"] = out_h 130 | ); 131 | } 132 | }; 133 | 134 | // [[Rcpp::export]] 135 | List buildSkyline(NumericVector x1, NumericVector x2, NumericVector y) { 136 | if (x1.size() != x2.size() || x1.size() != y.size()) { 137 | stop("x1, x2, and y all must be the same length"); 138 | } 139 | 140 | int n = x1.size(); 141 | 142 | // Sort all endpoints: 143 | Skyline skyline; 144 | for (int i = 0; i < n; ++i) { 145 | skyline.add_building(x1[i], x2[i], y[i]); 146 | } 147 | 148 | return skyline.as_list(); 149 | } 150 | 151 | // [[Rcpp::export]] 152 | List stack_rects(NumericVector x1, NumericVector x2, NumericVector y1, NumericVector y2) { 153 | if (x1.size() != x2.size() || x1.size() != y1.size() || x1.size() != y2.size()) { 154 | stop("x1, x2, y1 and y2 all must be the same length"); 155 | } 156 | int n = x1.size(); 157 | 158 | NumericVector ymin_(n), ymax_(n); 159 | 160 | // Sort all endpoints: 161 | Skyline skyline; 162 | for (int i = 0; i < n; ++i) { 163 | double cur_h = skyline.max_h(x1[i], x2[i]); 164 | double bar_h = (y2[i] - y1[i]); 165 | skyline.add_building(x1[i], x2[i], bar_h + cur_h); 166 | 167 | ymin_[i] = cur_h; 168 | ymax_[i] = bar_h + cur_h; 169 | } 170 | 171 | return List::create( 172 | _["y1_"] = ymin_, 173 | _["y2_"] = ymax_ 174 | ); 175 | } 176 | 177 | // [[Rcpp::export]] 178 | List stack_ribbons(ListOf x, ListOf y1, 179 | ListOf y2) { 180 | if (x.size() != y1.size() || x.size() != y2.size()) { 181 | stop("x, y1 and y2 all must be the same length"); 182 | } 183 | int n = x.size(); 184 | List ymin(n), ymax(n); 185 | 186 | std::map heights; 187 | for (int i = 0; i < n; ++i) { 188 | int m = x[i].size(); 189 | NumericVector ymin_(m), ymax_(m); 190 | NumericVector y1_ = y1[i], y2_ = y2[i], x_ = x[i]; 191 | 192 | for (int j = 0; j < m; ++j) { 193 | ymin_[j] = heights[x_[j]]; 194 | 195 | double h = (y2_[j] - y1_[j]); 196 | ymax_[j] = ymin_[j] + h; 197 | heights[x_[j]] += h; 198 | } 199 | ymin[i] = ymin_; 200 | ymax[i] = ymax_; 201 | } 202 | 203 | return List::create( 204 | _["y1_"] = ymin, 205 | _["y2_"] = ymax 206 | ); 207 | } 208 | -------------------------------------------------------------------------------- /src/RcppExports.cpp: -------------------------------------------------------------------------------- 1 | // This file was generated by Rcpp::compileAttributes 2 | // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | #include 5 | 6 | using namespace Rcpp; 7 | 8 | // abs_max_ 9 | double abs_max_(const NumericVector& x, const bool finite = true); 10 | RcppExport SEXP gggeom_abs_max_(SEXP xSEXP, SEXP finiteSEXP) { 11 | BEGIN_RCPP 12 | SEXP __sexp_result; 13 | { 14 | Rcpp::RNGScope __rngScope; 15 | Rcpp::traits::input_parameter< const NumericVector& >::type x(xSEXP ); 16 | Rcpp::traits::input_parameter< const bool >::type finite(finiteSEXP ); 17 | double __result = abs_max_(x, finite); 18 | PROTECT(__sexp_result = Rcpp::wrap(__result)); 19 | } 20 | UNPROTECT(1); 21 | return __sexp_result; 22 | END_RCPP 23 | } 24 | // dp_distance 25 | NumericVector dp_distance(const NumericVector& x, const NumericVector& y); 26 | RcppExport SEXP gggeom_dp_distance(SEXP xSEXP, SEXP ySEXP) { 27 | BEGIN_RCPP 28 | SEXP __sexp_result; 29 | { 30 | Rcpp::RNGScope __rngScope; 31 | Rcpp::traits::input_parameter< const NumericVector& >::type x(xSEXP ); 32 | Rcpp::traits::input_parameter< const NumericVector& >::type y(ySEXP ); 33 | NumericVector __result = dp_distance(x, y); 34 | PROTECT(__sexp_result = Rcpp::wrap(__result)); 35 | } 36 | UNPROTECT(1); 37 | return __sexp_result; 38 | END_RCPP 39 | } 40 | // make_heap 41 | List make_heap(NumericVector x); 42 | RcppExport SEXP gggeom_make_heap(SEXP xSEXP) { 43 | BEGIN_RCPP 44 | SEXP __sexp_result; 45 | { 46 | Rcpp::RNGScope __rngScope; 47 | Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP ); 48 | List __result = make_heap(x); 49 | PROTECT(__sexp_result = Rcpp::wrap(__result)); 50 | } 51 | UNPROTECT(1); 52 | return __sexp_result; 53 | END_RCPP 54 | } 55 | // heap_sort 56 | NumericVector heap_sort(NumericVector x); 57 | RcppExport SEXP gggeom_heap_sort(SEXP xSEXP) { 58 | BEGIN_RCPP 59 | SEXP __sexp_result; 60 | { 61 | Rcpp::RNGScope __rngScope; 62 | Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP ); 63 | NumericVector __result = heap_sort(x); 64 | PROTECT(__sexp_result = Rcpp::wrap(__result)); 65 | } 66 | UNPROTECT(1); 67 | return __sexp_result; 68 | END_RCPP 69 | } 70 | // heap_update_sort 71 | List heap_update_sort(NumericVector x); 72 | RcppExport SEXP gggeom_heap_update_sort(SEXP xSEXP) { 73 | BEGIN_RCPP 74 | SEXP __sexp_result; 75 | { 76 | Rcpp::RNGScope __rngScope; 77 | Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP ); 78 | List __result = heap_update_sort(x); 79 | PROTECT(__sexp_result = Rcpp::wrap(__result)); 80 | } 81 | UNPROTECT(1); 82 | return __sexp_result; 83 | END_RCPP 84 | } 85 | // resolution_numeric 86 | double resolution_numeric(NumericVector x, bool zero = true); 87 | RcppExport SEXP gggeom_resolution_numeric(SEXP xSEXP, SEXP zeroSEXP) { 88 | BEGIN_RCPP 89 | SEXP __sexp_result; 90 | { 91 | Rcpp::RNGScope __rngScope; 92 | Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP ); 93 | Rcpp::traits::input_parameter< bool >::type zero(zeroSEXP ); 94 | double __result = resolution_numeric(x, zero); 95 | PROTECT(__sexp_result = Rcpp::wrap(__result)); 96 | } 97 | UNPROTECT(1); 98 | return __sexp_result; 99 | END_RCPP 100 | } 101 | // buildSkyline 102 | List buildSkyline(NumericVector x1, NumericVector x2, NumericVector y); 103 | RcppExport SEXP gggeom_buildSkyline(SEXP x1SEXP, SEXP x2SEXP, SEXP ySEXP) { 104 | BEGIN_RCPP 105 | SEXP __sexp_result; 106 | { 107 | Rcpp::RNGScope __rngScope; 108 | Rcpp::traits::input_parameter< NumericVector >::type x1(x1SEXP ); 109 | Rcpp::traits::input_parameter< NumericVector >::type x2(x2SEXP ); 110 | Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP ); 111 | List __result = buildSkyline(x1, x2, y); 112 | PROTECT(__sexp_result = Rcpp::wrap(__result)); 113 | } 114 | UNPROTECT(1); 115 | return __sexp_result; 116 | END_RCPP 117 | } 118 | // stack_rects 119 | List stack_rects(NumericVector x1, NumericVector x2, NumericVector y1, NumericVector y2); 120 | RcppExport SEXP gggeom_stack_rects(SEXP x1SEXP, SEXP x2SEXP, SEXP y1SEXP, SEXP y2SEXP) { 121 | BEGIN_RCPP 122 | SEXP __sexp_result; 123 | { 124 | Rcpp::RNGScope __rngScope; 125 | Rcpp::traits::input_parameter< NumericVector >::type x1(x1SEXP ); 126 | Rcpp::traits::input_parameter< NumericVector >::type x2(x2SEXP ); 127 | Rcpp::traits::input_parameter< NumericVector >::type y1(y1SEXP ); 128 | Rcpp::traits::input_parameter< NumericVector >::type y2(y2SEXP ); 129 | List __result = stack_rects(x1, x2, y1, y2); 130 | PROTECT(__sexp_result = Rcpp::wrap(__result)); 131 | } 132 | UNPROTECT(1); 133 | return __sexp_result; 134 | END_RCPP 135 | } 136 | // stack_ribbons 137 | List stack_ribbons(ListOf x, ListOf y1, ListOf y2); 138 | RcppExport SEXP gggeom_stack_ribbons(SEXP xSEXP, SEXP y1SEXP, SEXP y2SEXP) { 139 | BEGIN_RCPP 140 | SEXP __sexp_result; 141 | { 142 | Rcpp::RNGScope __rngScope; 143 | Rcpp::traits::input_parameter< ListOf >::type x(xSEXP ); 144 | Rcpp::traits::input_parameter< ListOf >::type y1(y1SEXP ); 145 | Rcpp::traits::input_parameter< ListOf >::type y2(y2SEXP ); 146 | List __result = stack_ribbons(x, y1, y2); 147 | PROTECT(__sexp_result = Rcpp::wrap(__result)); 148 | } 149 | UNPROTECT(1); 150 | return __sexp_result; 151 | END_RCPP 152 | } 153 | // ungroupNA 154 | NumericVector ungroupNA(ListOf x); 155 | RcppExport SEXP gggeom_ungroupNA(SEXP xSEXP) { 156 | BEGIN_RCPP 157 | SEXP __sexp_result; 158 | { 159 | Rcpp::RNGScope __rngScope; 160 | Rcpp::traits::input_parameter< ListOf >::type x(xSEXP ); 161 | NumericVector __result = ungroupNA(x); 162 | PROTECT(__sexp_result = Rcpp::wrap(__result)); 163 | } 164 | UNPROTECT(1); 165 | return __sexp_result; 166 | END_RCPP 167 | } 168 | // as_data_frame 169 | void as_data_frame(List x, int nrow); 170 | RcppExport SEXP gggeom_as_data_frame(SEXP xSEXP, SEXP nrowSEXP) { 171 | BEGIN_RCPP 172 | { 173 | Rcpp::RNGScope __rngScope; 174 | Rcpp::traits::input_parameter< List >::type x(xSEXP ); 175 | Rcpp::traits::input_parameter< int >::type nrow(nrowSEXP ); 176 | as_data_frame(x, nrow); 177 | } 178 | return R_NilValue; 179 | END_RCPP 180 | } 181 | // vw_distance 182 | NumericVector vw_distance(const NumericVector& x, const NumericVector& y); 183 | RcppExport SEXP gggeom_vw_distance(SEXP xSEXP, SEXP ySEXP) { 184 | BEGIN_RCPP 185 | SEXP __sexp_result; 186 | { 187 | Rcpp::RNGScope __rngScope; 188 | Rcpp::traits::input_parameter< const NumericVector& >::type x(xSEXP ); 189 | Rcpp::traits::input_parameter< const NumericVector& >::type y(ySEXP ); 190 | NumericVector __result = vw_distance(x, y); 191 | PROTECT(__sexp_result = Rcpp::wrap(__result)); 192 | } 193 | UNPROTECT(1); 194 | return __sexp_result; 195 | END_RCPP 196 | } 197 | // warp 198 | List warp(NumericVector x, NumericVector y, std::string f, double threshold = 0.01, bool closed = false); 199 | RcppExport SEXP gggeom_warp(SEXP xSEXP, SEXP ySEXP, SEXP fSEXP, SEXP thresholdSEXP, SEXP closedSEXP) { 200 | BEGIN_RCPP 201 | SEXP __sexp_result; 202 | { 203 | Rcpp::RNGScope __rngScope; 204 | Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP ); 205 | Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP ); 206 | Rcpp::traits::input_parameter< std::string >::type f(fSEXP ); 207 | Rcpp::traits::input_parameter< double >::type threshold(thresholdSEXP ); 208 | Rcpp::traits::input_parameter< bool >::type closed(closedSEXP ); 209 | List __result = warp(x, y, f, threshold, closed); 210 | PROTECT(__sexp_result = Rcpp::wrap(__result)); 211 | } 212 | UNPROTECT(1); 213 | return __sexp_result; 214 | END_RCPP 215 | } 216 | -------------------------------------------------------------------------------- /vignettes/gggeom.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "gggeom" 3 | output: rmarkdown::html_vignette 4 | vignette: > 5 | %\VignetteIndexEntry{Vignette Title} 6 | %\VignetteEngine{knitr::rmarkdown} 7 | \usepackage[utf8]{inputenc} 8 | --- 9 | 10 | ```{r, echo = FALSE} 11 | library(gggeom) 12 | knitr::opts_chunk$set(comment = "#>", collapse = TRUE) 13 | options(digits = 3) 14 | ``` 15 | 16 | 17 | ## Motivation 18 | 19 | The goal of gggeom is to provide a compact way to represent geometric objects and useful tools to wrok with them. This package is (or soon will be) used to power ggvis: if you want to create a new layer function, you'll need to be somewhat familiar with this package. But gggeom is low-level and is not tightly tied to ggvis so you could use it to implement a new graphics system if you wanted. 20 | 21 | The objects in gggeom are somewhat similar to the geoms of ggplot2, but gggeom has a much purer take on geometric primitives. For example, ggplot2 has the `geom_histogram()` which is really a combination of a statistical transformation (`stat_bin()`) and a bar (`geom_bar()`). gggeom avoids this muddle, sticking purely to geometric objects. It also provides many more tools for manipulating geometries, indepedent of the particular plot they will eventually generate. The data structures in gggeom are all built on top of data frames, which mean that you can use many existing tools. 22 | 23 | All gggeom manipulations should be able to process ~100,000 geometries in less than 0.1. More geometries than that is unlikely to produce a useful plot, and geometry operations should be very cheap because you may need to string multiple together to solve a problem. Very large datasets should summarised (using e.g. the tools [ggstat](https://github.com/rstudio/ggstat)). 24 | 25 | ## Geometric primitives 26 | 27 | There are only three fundamental geometric primitives needed to draw any graphic: 28 | 29 | * points: $(x, y)$ 30 | * text: $(x, y)$ 31 | * paths/polygons: ${(x_1, y_1), (x_2, y_2), ..., (x_n, y_n)}$ 32 | 33 | However, because these primitives are so general, it is hard to define useful operations on them. So gggeoms provide a number of additional geometric objects that restrict the properties of points, paths and polygons in useful ways: 34 | 35 | * arcs: $([x, y, [r_1, r_2], [\theta_1, \theta_2]])$. 36 | * lines: a path where the x values are increasing $x_1 \le x_2$. 37 | * steps: a line drawn with only horizontal and vertical segments. 38 | * segments: a single line segment parameterised by $x_1$, $x_2$, $y_1$, $y_2$. 39 | * rects (and images): $([x_1, x_2], [y_1, y_2])$. 40 | * ribbons: an ordered sequence of intervals: 41 | ${(x_{1}, [y_{11}, y_{12}]), ..., (x_n, [y_{n1}, y_{n2}])}$, 42 | where $x_i < x_{i+1}$ 43 | 44 | Geometries are described in turns of their position. When rendered a geometric object will need other properties (like stroke, fill, stroke width, ...) but gggeom concerns itself only computations that involve position. 45 | 46 | A geometry is represented as a data frame, where each row corresponds to a single object. You turn a data frame into a geometry using the appropriate render function: 47 | 48 | ```{r} 49 | scatter <- iris %>% render_point(~Sepal.Length, ~Sepal.Width) %>% head() 50 | scatter 51 | ``` 52 | 53 | The default behaviour of the render function preserve all existing columms so that they can be later mapped to other properties of the geometry. However, this is mostly incidental to gggeom - it only works with the position columns (which all end in `_` to avoid clashes with other vars). 54 | 55 | All geometries inherit from "geom" and "data.frame". Additional subclassing is based not on the appearance of the geom but on the underlying position data. This means that: 56 | 57 | * Polygons, lines and steps inherit from paths. 58 | * Text inherits from points. 59 | * Segments inherit from rects. 60 | 61 | All geometries have a `plot()` method, implemented with base graphics. This is useful for examples, explanation and debugging, but not serious data visualisation. `...` is passed on to the underlying base graphic method, so if you're familiar with the graphic **par**ameters, you can tweak the appearance. 62 | 63 | ```{r} 64 | plot(scatter) 65 | ``` 66 | 67 | There are a few render functions that generate existing geometries but with a different parameterisation: 68 | 69 | * `render_spoke()` generate segments given x, y, r and theta. 70 | * `render_area()` generates ribbons given x and height. 71 | * `render_bar()` generates rects given x, width and height. 72 | * `render_tile()` generates rects given x, y, width, and height. 73 | * `render_contour()` generates paths given x, y, z and breaks. 74 | 75 | ### Paths (and polygons, lines and steps) 76 | 77 | If each row represents a single object, how are paths, polygons, lines and steps represented? We take advantage of a relatively esoteric R feature - data frame columns can be lists. For example, take a look at the built-in `nz` data set: 78 | 79 | ```{r} 80 | head(nz) 81 | plot(nz) 82 | ``` 83 | 84 | The `x_` and `y_` variables are lists of numeric vectors: 85 | 86 | ```{r} 87 | nz$x_[[5]] 88 | nz$y_[[5]] 89 | ``` 90 | 91 | As well as a `plot()` method, paths also have a `points()` method which makes it easier to see exactly where the data lie: 92 | 93 | ```{r} 94 | class(nz) 95 | nz %>% subset(island == "Stewart") %>% plot() %>% points() 96 | ``` 97 | 98 | (Note that `plot()` invisibly returns the input data to make this sort of chaining easy.) 99 | 100 | ### Converting to primitives 101 | 102 | You can convert any geometry to its equivalent primitive path by using `geom_pointificate()`. For example, imagine we have some rects: 103 | 104 | ```{r} 105 | df <- data.frame(x = c(1:3, 3), y = c(1:3, 2)) 106 | rects <- render_tile(df, ~x, ~y, width = 0.9, height = 0.9) 107 | 108 | rects 109 | plot(rects) 110 | ``` 111 | 112 | We can convert these to four point polygons with `geometry_pointificate()`: 113 | 114 | ```{r} 115 | rects %>% geometry_pointificate() 116 | rects %>% geometry_pointificate() %>% plot() %>% points() 117 | ``` 118 | 119 | The rendering looks similar at first glance, but by using the `points()` command we can see that each rectangle is composed of four points. The main advantage to converting to polygons is that there are a number of transformations that make sense for polygons, but not for rects: 120 | 121 | ```{r} 122 | polys <- rects %>% geometry_pointificate(close = TRUE) 123 | # Rotate each polygon 5 degrees clockwise 124 | polys %>% geometry_rotate(5) %>% plot() 125 | # Transform into polar coordinates 126 | polys %>% geometry_warp("polar", tolerance = 0.0001) %>% plot() 127 | ``` 128 | 129 | These transformations can not be performed on rects because the result is not a rect; the set of rects is not closed under many useful transformations. 130 | 131 | There are also operations that make sense for rects, but not for general polygons. For example, it makes sense to stack rects from the x-axis on up. There's no useful way to stack arbitrary polygons. 132 | 133 | ```{r} 134 | rects %>% geometry_stack() %>% plot() 135 | ``` 136 | 137 | ## Geometric transformations 138 | 139 | You've seen a few geometric transformations above. The following table lists all transformations implemented in gggeom in the rows, and the geometries to which they apply in the columns: 140 | 141 | ```{r, echo = FALSE} 142 | manip <- ls(asNamespace("gggeom")) 143 | manip <- manip[grepl("^geometry_.*?\\.", manip)] 144 | all <- t(simplify2array(strsplit(manip, "\\."))) 145 | all[, 1] <- gsub("geometry_", "", all[, 1]) 146 | all[, 2] <- gsub("geom_", "", all[, 2]) 147 | 148 | tbl <- table(all[, 1], all[, 2]) 149 | tbl[tbl[, "geom"] == 1, ] <- 1 150 | tbl <- tbl[, -2] 151 | 152 | tbl[tbl == 0] <- "" 153 | tbl[tbl == 1] <- "*" 154 | noquote(tbl) 155 | ``` 156 | 157 | The following sections categorise the transformations in to families, and show a few examples. See the documentation for more details of how they operate. 158 | 159 | ### Linear transformations 160 | 161 | ```{r} 162 | # Special cases 163 | polys %>% geometry_reflect() %>% plot() 164 | polys %>% geometry_rotate(15) %>% plot() 165 | polys %>% geometry_flip() %>% plot() 166 | 167 | # Arbitrary 168 | shear <- matrix(c(1, 0, 0.75, 1), nrow = 2) 169 | polys %>% geometry_transform(shear) %>% plot() 170 | ``` 171 | 172 | ### Add random jitter 173 | 174 | ```{r} 175 | scatter_ex %>% plot() 176 | scatter_ex %>% plot() %>% geometry_jitter() %>% points(col = "red") 177 | ``` 178 | 179 | All geometries are jittered as a whole - i.e. all x coordinates are displaced by the same random amount, and as are all y coordinates. This ensures (e.g.) the rects remain as rects: 180 | 181 | ```{r} 182 | rects %>% geometry_jitter() %>% plot() 183 | polys %>% geometry_jitter() %>% plot() 184 | ``` 185 | 186 | ### Stacking, dodging and (re)scaling 187 | 188 | ```{r} 189 | rects %>% geometry_stack() %>% plot() 190 | ``` 191 | -------------------------------------------------------------------------------- /R/render.R: -------------------------------------------------------------------------------- 1 | #' @export 2 | print.geom <- function(x, ...) { 3 | NextMethod() 4 | cat("Geometry: ", class(x)[1], "\n", sep = "") 5 | } 6 | 7 | # Point ----------------------------------------------------------------------- 8 | 9 | #' Render point and text geometries. 10 | #' 11 | #' @param data A data frame. 12 | #' @param x,y Formulas specifying x and y positions. 13 | #' @export 14 | #' @examples 15 | #' render_point(mtcars, ~mpg, ~wt) 16 | #' render_text(mtcars, ~mpg, ~wt) 17 | render_point <- function(data, x, y) { 18 | data$x_ <- eval_vector(data, x) 19 | data$y_ <- eval_vector(data, y) 20 | 21 | class(data) <- c("geom_point", "geom", "data.frame") 22 | data 23 | } 24 | 25 | #' @export 26 | plot.geom_point <- function(x, y, pch = 20, ..., add = FALSE) { 27 | if (!add) plot_init(x$x_, x$y_, ...) 28 | 29 | points(x$x_, x$y_, pch = pch, ...) 30 | invisible(x) 31 | } 32 | 33 | 34 | #' @export 35 | points.geom_point <- function(x, y, pch = 20, ...) { 36 | points(x$x_, x$y_, pch = pch, ...) 37 | invisible(x) 38 | } 39 | 40 | #' @export 41 | #' @rdname render_point 42 | render_text <- function(data, x, y) { 43 | out <- render_point(data, x, y) 44 | class(out) <- c("geom_text", class(out)) 45 | out 46 | } 47 | 48 | #' @export 49 | plot.geom_text <- function(x, y, labels = 1:nrow(x), ..., add = FALSE) { 50 | if (!add) plot_init(x$x_, x$y_, ...) 51 | 52 | text(x$x_, x$y_, labels = labels, ...) 53 | invisible(x) 54 | } 55 | 56 | # Path ------------------------------------------------------------------------- 57 | 58 | #' Render paths and path specialisations (line and polygons). 59 | #' 60 | #' A polygon is a closed path. A line is path where x values are ordered. 61 | #' 62 | #' @param data A data frame. 63 | #' @param x,y Formulas specifying x and y positions. 64 | #' @export 65 | #' @examples 66 | #' # For paths and polygons, the x_ and y_ variables are lists of vectors 67 | #' # See ?coord for more details 68 | #' theta <- seq(0, 6*pi, length = 200) 69 | #' r <- seq(1, 0, length = 200) 70 | #' df <- data.frame(x = r * sin(theta), y = r * cos(theta)) 71 | #' spiral <- df %>% render_path(~x, ~y) 72 | #' 73 | #' spiral 74 | #' str(spiral) 75 | #' spiral %>% plot() 76 | #' 77 | #' # Rendering a spiral as a line doesn't work so well 78 | #' df %>% render_line(~x, ~y) %>% plot() 79 | #' df %>% render_step(~x, ~y) %>% plot() 80 | #' 81 | #' # More reasonable example 82 | #' x <- runif(20) 83 | #' y <- x ^ 2 84 | #' squared <- data.frame(x, y) 85 | #' 86 | #' squared %>% render_path(~x, ~y) %>% plot() 87 | #' squared %>% render_line(~x, ~y) %>% plot() 88 | #' squared %>% render_step(~x, ~y) %>% plot() 89 | #' squared %>% render_step(~x, ~y, "vh") %>% plot() 90 | #' 91 | #' nz 92 | #' nz %>% plot() 93 | render_path <- function(data, x, y) UseMethod("render_path") 94 | 95 | #' @export 96 | render_path.data.frame <- function(data, x, y) { 97 | out <- list( 98 | x_ = coords(list(eval_vector(data, x))), 99 | y_ = coords(list(eval_vector(data, y))) 100 | ) 101 | `as.data.frame!`(out, 1L) 102 | class(out) <- c("geom_path", "geom", "data.frame") 103 | out 104 | } 105 | 106 | #' @export 107 | render_path.grouped_df <- function(data, x, y) { 108 | data <- data %>% 109 | dplyr::do(render_path(., x, y)) 110 | 111 | class(data) <- c("geom_path", "geom", "data.frame") 112 | data 113 | } 114 | 115 | #' @rdname render_path 116 | #' @export 117 | render_line <- function(data, x, y) { 118 | path <- render_path(data, x, y) 119 | class(path) <- c("geom_line", class(path)) 120 | 121 | order_x <- function(x, y) { 122 | ord <- order(x) 123 | list(x = x[ord], y = y[ord]) 124 | } 125 | ordered <- Map(order_x, path$x_, path$y) 126 | path$x_ <- pluck(ordered, "x") 127 | path$y_ <- pluck(ordered, "y") 128 | 129 | path 130 | } 131 | 132 | #' @rdname render_path 133 | #' @export 134 | #' @param direction Direction of steps. Either "hv", horizontal then vertical 135 | #' or "vh", vertical then horizontal. 136 | render_step <- function(data, x, y, direction = c("hv", "vh")) { 137 | direction <- match.arg(direction) 138 | 139 | path <- render_path(data, x, y) 140 | class(path) <- c("geom_step", class(path)) 141 | 142 | stairstep <- function(x, y) { 143 | n <- length(x) 144 | 145 | if (direction == "vh") { 146 | xs <- rep(1:n, each = 2)[-2 * n] 147 | ys <- c(1, rep(2:n, each = 2)) 148 | } else { 149 | xs <- c(1, rep(2:n, each = 2)) 150 | ys <- rep(1:n, each = 2)[-2 * n] 151 | } 152 | ord <- order(x) 153 | list( 154 | x = x[ord][xs], 155 | y = y[ord][ys] 156 | ) 157 | } 158 | 159 | stepped <- Map(stairstep, path$x_, path$y) 160 | path$x_ <- pluck(stepped, "x") 161 | path$y_ <- pluck(stepped, "y") 162 | 163 | path 164 | } 165 | 166 | 167 | #' @export 168 | #' @rdname render_path 169 | render_polygon <- function(data, x, y) { 170 | path <- render_path(data, x, y) 171 | class(path) <- c("geom_polygon", class(path)) 172 | path 173 | } 174 | 175 | #' @export 176 | plot.geom_path <- function(x, y, col = "grey10", ..., add = FALSE) { 177 | if (!add) plot_init(x$x_, x$y_, ...) 178 | 179 | lines(ungroupNA(x$x_), ungroupNA(x$y_), col = col, ...) 180 | invisible(x) 181 | } 182 | 183 | #' @export 184 | plot.geom_polygon <- function(x, y, col = "#7F7F7F7F", ..., add = FALSE) { 185 | if (!add) plot_init(x$x_, x$y_, ...) 186 | 187 | polygon(ungroupNA(x$x_), ungroupNA(x$y_), col = col, ...) 188 | invisible(x) 189 | } 190 | 191 | #' @export 192 | points.geom_path <- function(x, y, pch = 20, ...) { 193 | points(ungroupNA(x$x_), ungroupNA(x$y_), pch = pch, ...) 194 | invisible(x) 195 | } 196 | 197 | # Segment ---------------------------------------------------------------------- 198 | 199 | #' Render a line segment 200 | #' 201 | #' A line segment is a single straight line. \code{render_spoke} is an 202 | #' alternative parameterisation in terms of start point, angle and distance. 203 | #' 204 | #' @inheritParams render_point 205 | #' @param x1,y1,x2,y2 Locations of start and end points. 206 | #' @param x,y,r,theta Location of x points, radius and angle. 207 | #' @export 208 | #' @examples 209 | #' df <- expand.grid(x = 1:2, y = 1:2) 210 | #' a <- render_rect(df, ~x - 0.5, ~y - 0.5, ~x + 0.5, ~y + 0.5) 211 | #' b <- render_segment(df, ~x - 0.5, ~y - 0.5, ~x + 0.5, ~y + 0.5) 212 | #' 213 | #' plot(a) 214 | #' plot(b, add = TRUE, col = "red", lwd = 2) 215 | #' 216 | #' # Spokes are just an alternative parameterisation 217 | #' df %>% render_spoke(~x, ~y, ~runif(4, 0, 2 * pi), ~0.25) %>% plot() 218 | render_segment <- function(data, x1, y1, x2, y2) { 219 | data$x1_ <- eval_vector(data, x1) 220 | data$x2_ <- eval_vector(data, x2) 221 | data$y1_ <- eval_vector(data, y1) 222 | data$y2_ <- eval_vector(data, y2) 223 | 224 | class(data) <- c("geom_segment", "geom_rect", "geom", "data.frame") 225 | data 226 | } 227 | 228 | #' @export 229 | plot.geom_segment <- function(x, y, col = "grey10", ..., add = FALSE) { 230 | if (!add) plot_init(c(x$x1_, x$x2_), c(x$y1_, x$y2_), ...) 231 | segments(x$x1_, x$y1_, x$x2_, x$y2_, col = col, ...) 232 | invisible(x) 233 | } 234 | 235 | #' @export 236 | #' @rdname render_segment 237 | render_spoke <- function(data, x, y, theta, r) { 238 | data$x1_ <- eval_vector(data, x) 239 | data$y1_ <- eval_vector(data, y) 240 | 241 | r <- eval_vector(data, r) 242 | theta <- eval_vector(data, theta) 243 | 244 | data$x2_ <- data$x + cos(theta) * r 245 | data$y2_ <- data$y + sin(theta) * r 246 | 247 | class(data) <- c("geom_segment", "geom", "data.frame") 248 | data 249 | } 250 | 251 | # Rect ------------------------------------------------------------------------- 252 | 253 | #' Render a rect. 254 | #' 255 | #' A rect is defined by the coordinates of its sides. Bars and tiles are 256 | #' convenient parameterisations based on the length of the sides. 257 | #' 258 | #' @inheritParams render_point 259 | #' @param x1,y1,x2,y2 Describe a rectangle by the locations of its sides. 260 | #' @param x,y,width,height Describe a rectangle by location and dimension. 261 | #' @param halign,valign Horizontal and vertical aligned. Defaults to 0.5, 262 | #' centered. 263 | #' @export 264 | #' @examples 265 | #' # Two equivalent specifications 266 | #' render_rect(mtcars, ~cyl - 0.5, ~gear - 0.5, ~cyl + 0.5, ~gear + 0.5) 267 | #' render_tile(mtcars, ~cyl, ~gear, 1, 1) 268 | #' 269 | #' bar_ex 270 | #' bar_ex %>% plot() 271 | #' bar_ex %>% geometry_stack() %>% plot() 272 | render_rect <- function(data, x1, y1, x2, y2) { 273 | data$x1_ <- eval_vector(data, x1) 274 | data$x2_ <- eval_vector(data, x2) 275 | data$y1_ <- eval_vector(data, y2) 276 | data$y2_ <- eval_vector(data, y1) 277 | 278 | class(data) <- c("geom_rect", "geom", "data.frame") 279 | data 280 | } 281 | 282 | #' @export 283 | plot.geom_rect <- function(x, y, col = "#7F7F7F7F", ..., add = FALSE) { 284 | if (!add) plot_init(c(x$x1_, x$x2_), c(x$y1_, x$y2_), ...) 285 | 286 | rect(x$x1_, x$y1_, x$x2_, x$y2_, col = col, ...) 287 | invisible(x) 288 | } 289 | 290 | #' @export 291 | #' @rdname render_rect 292 | render_bar <- function(data, x, y, width = resolution(x) * 0.9, halign = 0.5) { 293 | x <- eval_vector(data, x) 294 | y <- eval_vector(data, y) 295 | width <- eval_vector(data, width) 296 | 297 | data$x1_ <- x - width * halign 298 | data$x2_ <- x + width * (1 - halign) 299 | data$y1_ <- 0 300 | data$y2_ <- y 301 | 302 | class(data) <- c("geom_rect", "geom", "data.frame") 303 | data 304 | } 305 | 306 | #' @export 307 | #' @rdname render_rect 308 | render_tile <- function(data, x, y, width = resolution(x), 309 | height = resolution(y), halign = 0.5, valign = 0.5) { 310 | x <- eval_vector(data, x) 311 | y <- eval_vector(data, y) 312 | width <- eval_vector(data, width) 313 | height <- eval_vector(data, height) 314 | 315 | data$x1_ <- x - width * halign 316 | data$x2_ <- x + width * (1 - halign) 317 | data$y1_ <- y - height * valign 318 | data$y2_ <- y + height * (1 - valign) 319 | 320 | class(data) <- c("geom_rect", "geom", class(data)) 321 | data 322 | } 323 | 324 | # Ribbon ----------------------------------------------------------------------- 325 | 326 | #' Render a ribbon. 327 | #' 328 | #' @inheritParams render_point 329 | #' @param x,y1,y2 x location and y interval. 330 | #' @export 331 | #' @examples 332 | #' x <- 1:10 333 | #' y <- runif(10, 0, 2) 334 | #' df <- data.frame(x = x, y1 = x * 2 - y, y2 = x * 2 + y) 335 | #' render_ribbon(df, ~x, ~y1, ~y2) 336 | #' .Last.value %>% plot() 337 | render_ribbon <- function(data, x, y1, y2) UseMethod("render_ribbon") 338 | 339 | #' @export 340 | render_ribbon.data.frame <- function(data, x, y1, y2) { 341 | out <- list( 342 | x_ = coords(list(eval_vector(data, x))), 343 | y1_ = coords(list(eval_vector(data, y1))), 344 | y2_ = coords(list(eval_vector(data, y2))) 345 | ) 346 | `as.data.frame!`(out, 1) 347 | 348 | class(out) <- c("geom_ribbon", "geom", "data.frame") 349 | out 350 | } 351 | 352 | #' @export 353 | render_ribbon.grouped_df <- function(data, x, y1, y2) { 354 | 355 | data <- data %>% 356 | dplyr::do(render_ribbon(., x, y1, y2)) 357 | 358 | class(data) <- c("geom_ribbon", "geom", "data.frame") 359 | data 360 | } 361 | 362 | #' @export 363 | #' @rdname render_ribbon 364 | render_area <- function(data, x, y2) { 365 | render_ribbon(data, x, 0, y2) 366 | } 367 | 368 | #' @export 369 | plot.geom_ribbon <- function(x, y, col = "#7F7F7F7F", ..., add = FALSE) { 370 | if (!add) plot_init(x$x_, c(x$y1_, x$y2_), ...) 371 | 372 | x <- geometry_pointificate(x) 373 | plot(x, col = col, add = TRUE, ...) 374 | 375 | invisible(x) 376 | } 377 | 378 | # Arc -------------------------------------------------------------------------- 379 | 380 | #' Render an arc 381 | #' 382 | #' @inheritParams render_point 383 | #' @param x,y Location of arc 384 | #' @param r1,r2 Extent of radius 385 | #' @param theta1,theta2 Extent of angle (in radians). 386 | #' @export 387 | #' @examples 388 | #' render_arc(mtcars, ~vs, ~am, 0, 0.1, 0, ~mpg / max(mpg) * 2 * pi) 389 | render_arc <- function(data, x, y, r1, r2, theta1, theta2) { 390 | data$x_ <- eval_vector(data, x) 391 | data$y_ <- eval_vector(data, y) 392 | data$r1_ <- eval_vector(data, r1) 393 | data$r2_ <- eval_vector(data, r2) 394 | data$theta1_ <- eval_vector(data, theta1) 395 | data$theta2_ <- eval_vector(data, theta2) 396 | 397 | class(data) <- c("geom_arc", "geom", "data.frame") 398 | data 399 | } 400 | 401 | #' @export 402 | plot.geom_arc <- function(x, y, ..., col = "#7F7F7F7F", add = FALSE) { 403 | x$id_ <- 1:nrow(x) 404 | polys <- x %>% 405 | dplyr::group_by_(~ id_) %>% 406 | dplyr::do( 407 | make_arc(.$x_, .$y_, c(.$r1_, .$r2_), c(.$theta1_, .$theta2_)) 408 | ) 409 | 410 | if (!add) plot_init(polys$x_, polys$y_, ...) 411 | dplyr::do(polys, `_` = polygon(.$x, .$y, col = col, ...)) 412 | invisible(x) 413 | } 414 | 415 | make_arc <- function(x, y, r, theta) { 416 | inner_theta <- seq(theta[1], theta[2], length = 1 + (r[1] * 2 * pi) / 0.01) 417 | inner_x <- x + r[1] * cos(inner_theta) 418 | inner_y <- y + r[1] * sin(inner_theta) 419 | 420 | outer_theta <- seq(theta[1], theta[2], length = 1 + (r[2] * 2 * pi) / 0.01) 421 | outer_x <- x + r[2] * cos(rev(outer_theta)) 422 | outer_y <- y + r[2] * sin(rev(outer_theta)) 423 | 424 | data.frame(x_ = c(inner_x, outer_x), y_ = c(inner_y, outer_y)) 425 | } 426 | --------------------------------------------------------------------------------