ggforce/ 0000755 0001762 0000144 00000000000 14564632262 011700 5 ustar ligges users ggforce/NAMESPACE 0000644 0001762 0000144 00000013511 14564603246 013120 0 ustar ligges users # Generated by roxygen2: do not edit by hand
S3method(heightDetails,mark_label)
S3method(makeContent,circ_enc)
S3method(makeContent,ellip_enc)
S3method(makeContent,hull_enc)
S3method(makeContent,rect_enc)
S3method(makeContent,shape)
S3method(single_val,default)
S3method(single_val,factor)
S3method(widthDetails,mark_label)
export(FacetCol)
export(FacetGridPaginate)
export(FacetMatrix)
export(FacetRow)
export(FacetStereo)
export(FacetWrapPaginate)
export(FacetZoom)
export(GeomArc)
export(GeomArc0)
export(GeomArcBar)
export(GeomAutoarea)
export(GeomAutorect)
export(GeomBezier0)
export(GeomBspline0)
export(GeomBsplineClosed0)
export(GeomCircle)
export(GeomMarkCircle)
export(GeomMarkEllipse)
export(GeomMarkHull)
export(GeomMarkRect)
export(GeomParallelSetsAxes)
export(GeomShape)
export(PositionAuto)
export(PositionFloatstack)
export(PositionJitterNormal)
export(StatArc)
export(StatArc0)
export(StatArc2)
export(StatArcBar)
export(StatAutobin)
export(StatAutodensity)
export(StatBezier)
export(StatBezier0)
export(StatBezier2)
export(StatBspline)
export(StatBspline2)
export(StatCircle)
export(StatDelaunaySegment)
export(StatDelaunaySegment2)
export(StatDelaunayTile)
export(StatDelvorSummary)
export(StatDiagonal)
export(StatDiagonal0)
export(StatDiagonal2)
export(StatDiagonalWide)
export(StatEllip)
export(StatErr)
export(StatLink)
export(StatLink2)
export(StatParallelSets)
export(StatParallelSetsAxes)
export(StatPie)
export(StatRegon)
export(StatSina)
export(StatSpiro)
export(StatVoronoiSegment)
export(StatVoronoiTile)
export(facet_col)
export(facet_grid_paginate)
export(facet_matrix)
export(facet_row)
export(facet_stereo)
export(facet_wrap_paginate)
export(facet_zoom)
export(gather_set_data)
export(geom_arc)
export(geom_arc0)
export(geom_arc2)
export(geom_arc_bar)
export(geom_autodensity)
export(geom_autohistogram)
export(geom_autopoint)
export(geom_bezier)
export(geom_bezier0)
export(geom_bezier2)
export(geom_bspline)
export(geom_bspline0)
export(geom_bspline2)
export(geom_bspline_closed)
export(geom_bspline_closed0)
export(geom_circle)
export(geom_delaunay_segment)
export(geom_delaunay_segment2)
export(geom_delaunay_tile)
export(geom_diagonal)
export(geom_diagonal0)
export(geom_diagonal2)
export(geom_diagonal_wide)
export(geom_ellipse)
export(geom_link)
export(geom_link0)
export(geom_link2)
export(geom_mark_circle)
export(geom_mark_ellipse)
export(geom_mark_hull)
export(geom_mark_rect)
export(geom_parallel_sets)
export(geom_parallel_sets_axes)
export(geom_parallel_sets_labels)
export(geom_regon)
export(geom_shape)
export(geom_sina)
export(geom_spiro)
export(geom_voronoi_segment)
export(geom_voronoi_tile)
export(interpolateDataFrame)
export(label_tex)
export(linear_trans)
export(n_pages)
export(position_auto)
export(position_jitternormal)
export(power_trans)
export(radial_trans)
export(scale_depth)
export(scale_depth_continuous)
export(scale_depth_discrete)
export(scale_x_unit)
export(scale_y_unit)
export(stat_arc)
export(stat_arc0)
export(stat_arc2)
export(stat_arc_bar)
export(stat_bezier)
export(stat_bezier0)
export(stat_bezier2)
export(stat_bspline)
export(stat_bspline0)
export(stat_bspline2)
export(stat_bspline_closed)
export(stat_circle)
export(stat_delvor_summary)
export(stat_diagonal)
export(stat_diagonal0)
export(stat_diagonal2)
export(stat_diagonal_wide)
export(stat_ellip)
export(stat_err)
export(stat_link)
export(stat_link2)
export(stat_parallel_sets)
export(stat_parallel_sets_axes)
export(stat_pie)
export(stat_regon)
export(stat_sina)
export(stat_spiro)
export(theme_no_axes)
export(trans_reverser)
import(ggplot2)
import(rlang)
import(vctrs)
importFrom(MASS,fractions)
importFrom(Rcpp,sourceCpp)
importFrom(ggplot2,label_parsed)
importFrom(ggplot2,layer)
importFrom(grDevices,chull)
importFrom(grid,addGrob)
importFrom(grid,arcCurvature)
importFrom(grid,bezierGrob)
importFrom(grid,childNames)
importFrom(grid,convertHeight)
importFrom(grid,convertUnit)
importFrom(grid,convertWidth)
importFrom(grid,convertX)
importFrom(grid,convertY)
importFrom(grid,curveGrob)
importFrom(grid,gList)
importFrom(grid,gTree)
importFrom(grid,gpar)
importFrom(grid,grid.layout)
importFrom(grid,grob)
importFrom(grid,grobDescent)
importFrom(grid,grobHeight)
importFrom(grid,grobTree)
importFrom(grid,grobWidth)
importFrom(grid,heightDetails)
importFrom(grid,is.unit)
importFrom(grid,makeContent)
importFrom(grid,nullGrob)
importFrom(grid,polygonGrob)
importFrom(grid,polylineGrob)
importFrom(grid,rectGrob)
importFrom(grid,segmentsGrob)
importFrom(grid,setChildren)
importFrom(grid,textGrob)
importFrom(grid,unit)
importFrom(grid,unit.c)
importFrom(grid,valid.just)
importFrom(grid,viewport)
importFrom(grid,widthDetails)
importFrom(grid,xsplineGrob)
importFrom(gtable,gtable)
importFrom(gtable,gtable_add_cols)
importFrom(gtable,gtable_add_grob)
importFrom(gtable,gtable_add_rows)
importFrom(lifecycle,deprecated)
importFrom(polyclip,polyclip)
importFrom(polyclip,polylineoffset)
importFrom(polyclip,polyminkowski)
importFrom(polyclip,polyoffset)
importFrom(scales,as.trans)
importFrom(scales,asn_trans)
importFrom(scales,atanh_trans)
importFrom(scales,boxcox_trans)
importFrom(scales,censor)
importFrom(scales,date_trans)
importFrom(scales,exp_trans)
importFrom(scales,extended_breaks)
importFrom(scales,format_format)
importFrom(scales,identity_trans)
importFrom(scales,log10_trans)
importFrom(scales,log1p_trans)
importFrom(scales,log2_trans)
importFrom(scales,log_trans)
importFrom(scales,logit_trans)
importFrom(scales,probability_trans)
importFrom(scales,probit_trans)
importFrom(scales,reciprocal_trans)
importFrom(scales,rescale)
importFrom(scales,rescale_pal)
importFrom(scales,reverse_trans)
importFrom(scales,sqrt_trans)
importFrom(scales,time_trans)
importFrom(scales,trans_new)
importFrom(stats,na.omit)
importFrom(stats,runif)
importFrom(stats,setNames)
importFrom(tidyselect,eval_select)
importFrom(tweenr,tween_t)
importFrom(utils,packageVersion)
importFrom(withr,with_seed)
useDynLib(ggforce)
ggforce/LICENSE 0000644 0001762 0000144 00000000061 13437570076 012704 0 ustar ligges users YEAR: 2019
COPYRIGHT HOLDER: Thomas Lin Pedersen
ggforce/README.md 0000644 0001762 0000144 00000004743 14556450144 013165 0 ustar ligges users
# ggforce 
[](https://github.com/thomasp85/ggforce/actions/workflows/R-CMD-check.yaml)
[](https://CRAN.R-project.org/package=ggforce)
[](https://CRAN.R-project.org/package=ggforce)
*Accelerating ggplot2*
`ggforce` is a package aimed at providing missing functionality to
`ggplot2` through the extension system introduced with `ggplot2` v2.0.0.
Broadly speaking `ggplot2` has been aimed primarily at explorative data
visualization in order to investigate the data at hand, and less at
providing utilities for composing custom plots a la
[D3.js](https://d3js.org). `ggforce` is mainly an attempt to address
these “shortcomings” (design choices might be a better description). The
goal is to provide a repository of geoms, stats, etc. that are as well
documented and implemented as the official ones found in `ggplot2`.
## Installation
You can install the released version of ggforce from
[CRAN](https://CRAN.R-project.org) with:
``` r
install.packages("ggforce")
```
And the development version from [GitHub](https://github.com/) with:
``` r
# install.packages("devtools")
devtools::install_github("thomasp85/ggforce")
```
## Features
`ggforce` is by design a collection of features with the only
commonality being their tie to the `ggplot2` API. Because of this an
overview of all features would get too long for a README. The package
has a [website](https://ggforce.data-imaginist.com) where every feature
is described and justified with examples and plots. There should be a
plot in the README of a visualization package though, so without further
ado:
``` r
library(ggforce)
#> Loading required package: ggplot2
ggplot(iris, aes(Petal.Length, Petal.Width, colour = Species)) +
geom_point() +
facet_zoom(x = Species == "versicolor")
```
## Code of Conduct
Please note that the ‘ggforce’ project is released with a [Contributor
Code of
Conduct](https://ggforce.data-imaginist.com/CODE_OF_CONDUCT.html). By
contributing to this project, you agree to abide by its terms.
ggforce/man/ 0000755 0001762 0000144 00000000000 14564603713 012452 5 ustar ligges users ggforce/man/radial_trans.Rd 0000644 0001762 0000144 00000005031 13674074434 015406 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/trans.R
\name{radial_trans}
\alias{radial_trans}
\title{Create radial data in a cartesian coordinate system}
\usage{
radial_trans(r.range, a.range, offset = pi/2, pad = 0.5, clip = FALSE)
}
\arguments{
\item{r.range}{The range in radius that correspond to 0 - 1 in the unit
circle.}
\item{a.range}{The range in angles that correspond to 2*pi - 0. As radians
are normally measured counterclockwise while radial displays are read
clockwise it's an inverse mapping}
\item{offset}{The offset in angles to apply. Determines that start position
on the circle. pi/2 (the default) corresponds to 12 o'clock.}
\item{pad}{Adds to the end points of the angle range in order to separate the
start and end point. Defaults to 0.5}
\item{clip}{Should input data be clipped to r.range and a.range or be allowed
to extend beyond. Defaults to FALSE (no clipping)}
}
\value{
A trans object. The transform method for the object takes an r
(radius) and a (angle) argument and returns a data.frame with x and y columns
with rows for each element in r/a. The inverse method takes an x and y
argument and returns a data.frame with r and a columns and rows for each
element in x/y.
}
\description{
This function creates a trans object that converts radial data to their
corresponding coordinates in cartesian space. The trans object is created for
a specific radius and angle range that will be mapped to the unit circle so
data doesn't have to be normalized to 0-1 and 0-2*pi in advance. While there
exists a clear mapping from radial to cartesian, the inverse is not true as
radial representation is periodic. It is impossible to know how many
revolutions around the unit circle a point has taken from reading its
coordinates. The inverse function will always assume that coordinates are in
their first revolution i.e. map them back within the range of a.range.
}
\note{
While trans objects are often used to modify scales in ggplot2, radial
transformation is different as it is a coordinate transformation and takes
two arguments. Consider it a trans version of coord_polar and use it to
transform your data prior to plotting.
}
\examples{
# Some data in radial form
rad <- data.frame(r = seq(1, 10, by = 0.1), a = seq(1, 10, by = 0.1))
# Create a transformation
radial <- radial_trans(c(0, 1), c(0, 5))
# Get data in x, y
cart <- radial$transform(rad$r, rad$a)
# Have a look
ggplot() +
geom_path(aes(x = x, y = y), data = cart, color = 'forestgreen') +
geom_path(aes(x = r, y = a), data = rad, color = 'firebrick')
}
ggforce/man/stat_err.Rd 0000644 0001762 0000144 00000006740 14303120026 014551 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/errorbar.R
\name{stat_err}
\alias{stat_err}
\title{Intervals in vertical and horizontal directions}
\usage{
stat_err(
mapping = NULL,
data = NULL,
geom = "segment",
position = "identity",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
...
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and
\code{inherit.aes = TRUE} (the default), it is combined with the default mapping
at the top level of the plot. You must supply \code{mapping} if there is no plot
mapping.}
\item{data}{The data to be displayed in this layer. There are three
options:
If \code{NULL}, the default, the data is inherited from the plot
data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}.
A \code{data.frame}, or other object, will override the plot
data. All objects will be fortified to produce a data frame. See
\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created.
A \code{function} will be called with a single argument,
the plot data. The return value must be a \code{data.frame}, and
will be used as the layer data. A \code{function} can be created
from a \code{formula} (e.g. \code{~ head(.x, 10)}).}
\item{geom}{The geometric object to use to display the data, either as a
\code{ggproto} \code{Geom} subclass or as a string naming the geom stripped of the
\code{geom_} prefix (e.g. \code{"point"} rather than \code{"geom_point"})}
\item{position}{Position adjustment, either as a string naming the adjustment
(e.g. \code{"jitter"} to use \code{position_jitter}), or the result of a call to a
position adjustment function. Use the latter if you need to change the
settings of the adjustment.}
\item{na.rm}{If \code{FALSE}, the default, missing values are removed with
a warning. If \code{TRUE}, missing values are silently removed.}
\item{show.legend}{logical. Should this layer be included in the legends?
\code{NA}, the default, includes if any aesthetics are mapped.
\code{FALSE} never includes, and \code{TRUE} always includes.
It can also be a named logical vector to finely select the aesthetics to
display.}
\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics,
rather than combining with them. This is most useful for helper functions
that define both data and aesthetics and shouldn't inherit behaviour from
the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.}
\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}. These are
often aesthetics, used to set an aesthetic to a fixed value, like
\code{colour = "red"} or \code{size = 3}. They may also be parameters
to the paired geom/stat.}
}
\description{
\code{stat_err} draws intervals of points (\code{x}, \code{y}) in vertical (\code{ymin}, \code{ymax})
and horizontal (\code{xmin}, \code{xmax}) directions.
}
\section{Aesthetics}{
\code{stat_err()} understands the following aesthetics (required aesthetics are in
bold):
\itemize{
\item \strong{x}
\item \strong{xmin}
\item \strong{xmax}
\item \strong{y}
\item \strong{ymin}
\item \strong{ymax}
\item alpha
\item color
\item group
\item linetype
\item linewidth
}
}
\examples{
library(ggplot2)
x <- 1:3
xmin <- x - 2.5
xmax <- x + 2.5
d <- data.frame(
x = x, y = x, xmin = xmin, ymin = xmin, xmax = xmax, ymax = xmax,
color = as.factor(x)
)
ggplot(
d,
aes(x = x, y = y, xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax, color = color)
) +
stat_err(size = 2)
}
ggforce/man/label_tex.Rd 0000644 0001762 0000144 00000002111 14277137746 014704 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/labeller.R
\name{label_tex}
\alias{label_tex}
\title{A labeller function to parse TeX syntax}
\usage{
label_tex(labels, ...)
}
\arguments{
\item{labels}{Data frame of labels. Usually contains only one
element, but faceting over multiple factors entails multiple
label variables.}
\item{...}{
Arguments passed on to \code{\link[ggplot2:labellers]{ggplot2::label_parsed}}
\describe{
\item{\code{multi_line}}{Whether to display the labels of multiple factors
on separate lines.}
}}
}
\description{
This function formats the strip labels of facet grids and wraps that contains
TeX expressions. The latex2exp package must be installed.
}
\examples{
# requires latex2exp package be installed
if (requireNamespace("latex2exp", quietly = TRUE)) {
library(ggplot2)
d <- data.frame(x = 1, y = 1, facet = "$\\\\beta$")
ggplot(d, aes(x, y)) +
geom_point() +
facet_wrap(~ facet, labeller = label_tex)
}
}
\seealso{
\link[ggplot2:labeller]{ggplot2::labeller}, \code{\link[latex2exp:TeX]{latex2exp::TeX()}}
}
ggforce/man/geom_mark_hull.Rd 0000644 0001762 0000144 00000023777 14564603246 015747 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/mark_hull.R
\name{geom_mark_hull}
\alias{geom_mark_hull}
\title{Annotate areas with hulls}
\usage{
geom_mark_hull(
mapping = NULL,
data = NULL,
stat = "identity",
position = "identity",
expand = unit(5, "mm"),
radius = unit(2.5, "mm"),
concavity = 2,
label.margin = margin(2, 2, 2, 2, "mm"),
label.width = NULL,
label.minwidth = unit(50, "mm"),
label.hjust = 0,
label.fontsize = 12,
label.family = "",
label.lineheight = 1,
label.fontface = c("bold", "plain"),
label.fill = "white",
label.colour = "black",
label.buffer = unit(10, "mm"),
con.colour = "black",
con.size = 0.5,
con.type = "elbow",
con.linetype = 1,
con.border = "one",
con.cap = unit(3, "mm"),
con.arrow = NULL,
...,
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and
\code{inherit.aes = TRUE} (the default), it is combined with the default mapping
at the top level of the plot. You must supply \code{mapping} if there is no plot
mapping.}
\item{data}{The data to be displayed in this layer. There are three
options:
If \code{NULL}, the default, the data is inherited from the plot
data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}.
A \code{data.frame}, or other object, will override the plot
data. All objects will be fortified to produce a data frame. See
\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created.
A \code{function} will be called with a single argument,
the plot data. The return value must be a \code{data.frame}, and
will be used as the layer data. A \code{function} can be created
from a \code{formula} (e.g. \code{~ head(.x, 10)}).}
\item{stat}{The statistical transformation to use on the data for this
layer, either as a \code{ggproto} \code{Geom} subclass or as a string naming the
stat stripped of the \code{stat_} prefix (e.g. \code{"count"} rather than
\code{"stat_count"})}
\item{position}{Position adjustment, either as a string naming the adjustment
(e.g. \code{"jitter"} to use \code{position_jitter}), or the result of a call to a
position adjustment function. Use the latter if you need to change the
settings of the adjustment.}
\item{expand}{A numeric or unit vector of length one, specifying the
expansion amount. Negative values will result in contraction instead. If the
value is given as a numeric it will be understood as a proportion of the
plot area width.}
\item{radius}{As \code{expand} but specifying the corner radius.}
\item{concavity}{A measure of the concavity of the hull. \code{1} is very concave
while it approaches convex as it grows. Defaults to \code{2}.}
\item{label.margin}{The margin around the annotation boxes, given by a call
to \code{\link[ggplot2:element]{ggplot2::margin()}}.}
\item{label.width}{A fixed width for the label. Set to \code{NULL} to let the text
or \code{label.minwidth} decide.}
\item{label.minwidth}{The minimum width to provide for the description. If
the size of the label exceeds this, the description is allowed to fill as
much as the label.}
\item{label.hjust}{The horizontal justification for the annotation. If it
contains two elements the first will be used for the label and the second for
the description.}
\item{label.fontsize}{The size of the text for the annotation. If it contains
two elements the first will be used for the label and the second for the
description.}
\item{label.family}{The font family used for the annotation. If it contains
two elements the first will be used for the label and the second for the
description.}
\item{label.lineheight}{The height of a line as a multipler of the fontsize.
If it contains two elements the first will be used for the label and the
second for the description.}
\item{label.fontface}{The font face used for the annotation. If it contains
two elements the first will be used for the label and the second for the
description.}
\item{label.fill}{The fill colour for the annotation box.}
\item{label.colour}{The text colour for the annotation. If it contains
two elements the first will be used for the label and the second for the
description.}
\item{label.buffer}{The size of the region around the mark where labels
cannot be placed.}
\item{con.colour}{The colour for the line connecting the annotation to the
mark.}
\item{con.size}{The width of the connector.}
\item{con.type}{The type of the connector. Either \code{"elbow"}, \code{"straight"}, or
\code{"none"}.}
\item{con.linetype}{The linetype of the connector.}
\item{con.border}{The bordertype of the connector. Either \code{"one"} (to draw a
line on the horizontal side closest to the mark), \code{"all"} (to draw a border
on all sides), or \code{"none"} (not going to explain that one).}
\item{con.cap}{The distance before the mark that the line should stop at.}
\item{con.arrow}{An arrow specification for the connection using
\code{\link[grid:arrow]{grid::arrow()}} for the end pointing towards the mark.}
\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}. These are
often aesthetics, used to set an aesthetic to a fixed value, like
\code{colour = "red"} or \code{size = 3}. They may also be parameters
to the paired geom/stat.}
\item{na.rm}{If \code{FALSE}, the default, missing values are removed with
a warning. If \code{TRUE}, missing values are silently removed.}
\item{show.legend}{logical. Should this layer be included in the legends?
\code{NA}, the default, includes if any aesthetics are mapped.
\code{FALSE} never includes, and \code{TRUE} always includes.
It can also be a named logical vector to finely select the aesthetics to
display.}
\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics,
rather than combining with them. This is most useful for helper functions
that define both data and aesthetics and shouldn't inherit behaviour from
the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.}
}
\description{
This geom lets you annotate sets of points via hulls. While convex hulls are
most common due to their clear definition, they can lead to large areas
covered that does not contain points. Due to this \code{geom_mark_hull} uses
concaveman which lets you adjust concavity of the resulting hull. The hull is
calculated at draw time, and can thus change as you resize the plot. In order
to clearly contain all points, and for aesthetic purpose the resulting hull
is expanded 5mm and rounded on the corners. This can be adjusted with the
\code{expand} and \code{radius} parameters.
}
\section{Aesthetics}{
\code{geom_mark_hull} understand the following aesthetics (required aesthetics are
in bold):
\itemize{
\item \strong{x}
\item \strong{y}
\item x0 \emph{(used to anchor the label)}
\item y0 \emph{(used to anchor the label)}
\item filter
\item label
\item description
\item color
\item fill
\item group
\item size
\item linetype
\item alpha
}
}
\section{Annotation}{
All \verb{geom_mark_*} allow you to put descriptive textboxes connected to the
mark on the plot, using the \code{label} and \code{description} aesthetics. The
textboxes are automatically placed close to the mark, but without obscuring
any of the datapoints in the layer. The placement is dynamic so if you resize
the plot you'll see that the annotation might move around as areas become big
enough or too small to fit the annotation. If there's not enough space for
the annotation without overlapping data it will not get drawn. In these cases
try resizing the plot, change the size of the annotation, or decrease the
buffer region around the marks.
}
\section{Filtering}{
Often marks are used to draw attention to, or annotate specific features of
the plot and it is thus not desirable to have marks around everything. While
it is possible to simply pre-filter the data used for the mark layer, the
\verb{geom_mark_*} geoms also comes with a dedicated \code{filter} aesthetic that, if
set, will remove all rows where it evalutates to \code{FALSE}. There are
multiple benefits of using this instead of prefiltering. First, you don't
have to change your data source, making your code more adaptable for
exploration. Second, the data removed by the filter aesthetic is remembered
by the geom, and any annotation will take care not to overlap with the
removed data.
}
\examples{
## requires the concaveman packages
ggplot(iris, aes(Petal.Length, Petal.Width)) +
geom_mark_hull(aes(fill = Species, filter = Species != 'versicolor')) +
geom_point()
# Adjusting the concavity lets you change the shape of the hull
ggplot(iris, aes(Petal.Length, Petal.Width)) +
geom_mark_hull(aes(fill = Species, filter = Species != 'versicolor'),
concavity = 1
) +
geom_point()
ggplot(iris, aes(Petal.Length, Petal.Width)) +
geom_mark_hull(aes(fill = Species, filter = Species != 'versicolor'),
concavity = 10
) +
geom_point()
# Add annotation
ggplot(iris, aes(Petal.Length, Petal.Width)) +
geom_mark_hull(aes(fill = Species, label = Species)) +
geom_point()
# Long descriptions are automatically wrapped to fit into the width
iris$desc <- c(
'A super Iris - and it knows it',
'Pretty mediocre Iris, but give it a couple of years and it might surprise you',
"You'll never guess what this Iris does every Sunday"
)[iris$Species]
ggplot(iris, aes(Petal.Length, Petal.Width)) +
geom_mark_hull(aes(fill = Species, label = Species, description = desc,
filter = Species == 'setosa')) +
geom_point()
# Change the buffer size to move labels farther away (or closer) from the
# marks
ggplot(iris, aes(Petal.Length, Petal.Width)) +
geom_mark_hull(aes(fill = Species, label = Species),
label.buffer = unit(40, 'mm')) +
geom_point()
# The connector is capped a bit before it reaches the mark, but this can be
# controlled
ggplot(iris, aes(Petal.Length, Petal.Width)) +
geom_mark_hull(aes(fill = Species, label = Species),
con.cap = 0) +
geom_point()
}
\seealso{
Other mark geoms:
\code{\link{geom_mark_circle}()},
\code{\link{geom_mark_ellipse}()},
\code{\link{geom_mark_rect}()}
}
\concept{mark geoms}
ggforce/man/geom_bspline.Rd 0000644 0001762 0000144 00000015637 14303120026 015376 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/bspline.R
\name{geom_bspline}
\alias{geom_bspline}
\alias{stat_bspline}
\alias{stat_bspline2}
\alias{geom_bspline2}
\alias{stat_bspline0}
\alias{geom_bspline0}
\title{B-splines based on control points}
\usage{
stat_bspline(
mapping = NULL,
data = NULL,
geom = "path",
position = "identity",
na.rm = FALSE,
n = 100,
type = "clamped",
show.legend = NA,
inherit.aes = TRUE,
...
)
geom_bspline(
mapping = NULL,
data = NULL,
stat = "bspline",
position = "identity",
arrow = NULL,
n = 100,
type = "clamped",
lineend = "butt",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
...
)
stat_bspline2(
mapping = NULL,
data = NULL,
geom = "path_interpolate",
position = "identity",
na.rm = FALSE,
n = 100,
type = "clamped",
show.legend = NA,
inherit.aes = TRUE,
...
)
geom_bspline2(
mapping = NULL,
data = NULL,
stat = "bspline2",
position = "identity",
arrow = NULL,
n = 100,
type = "clamped",
lineend = "butt",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
...
)
stat_bspline0(
mapping = NULL,
data = NULL,
geom = "bspline0",
position = "identity",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
type = "clamped",
...
)
geom_bspline0(
mapping = NULL,
data = NULL,
stat = "identity",
position = "identity",
arrow = NULL,
lineend = "butt",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
type = "clamped",
...
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and
\code{inherit.aes = TRUE} (the default), it is combined with the default mapping
at the top level of the plot. You must supply \code{mapping} if there is no plot
mapping.}
\item{data}{The data to be displayed in this layer. There are three
options:
If \code{NULL}, the default, the data is inherited from the plot
data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}.
A \code{data.frame}, or other object, will override the plot
data. All objects will be fortified to produce a data frame. See
\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created.
A \code{function} will be called with a single argument,
the plot data. The return value must be a \code{data.frame}, and
will be used as the layer data. A \code{function} can be created
from a \code{formula} (e.g. \code{~ head(.x, 10)}).}
\item{geom}{The geometric object to use to display the data, either as a
\code{ggproto} \code{Geom} subclass or as a string naming the geom stripped of the
\code{geom_} prefix (e.g. \code{"point"} rather than \code{"geom_point"})}
\item{position}{Position adjustment, either as a string naming the adjustment
(e.g. \code{"jitter"} to use \code{position_jitter}), or the result of a call to a
position adjustment function. Use the latter if you need to change the
settings of the adjustment.}
\item{na.rm}{If \code{FALSE}, the default, missing values are removed with
a warning. If \code{TRUE}, missing values are silently removed.}
\item{n}{The number of points generated for each spline}
\item{type}{Either \code{'clamped'} (default) or \code{'open'}. The former creates a
knot sequence that ensures the splines starts and ends at the terminal
control points.}
\item{show.legend}{logical. Should this layer be included in the legends?
\code{NA}, the default, includes if any aesthetics are mapped.
\code{FALSE} never includes, and \code{TRUE} always includes.
It can also be a named logical vector to finely select the aesthetics to
display.}
\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics,
rather than combining with them. This is most useful for helper functions
that define both data and aesthetics and shouldn't inherit behaviour from
the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.}
\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}. These are
often aesthetics, used to set an aesthetic to a fixed value, like
\code{colour = "red"} or \code{size = 3}. They may also be parameters
to the paired geom/stat.}
\item{stat}{The statistical transformation to use on the data for this
layer, either as a \code{ggproto} \code{Geom} subclass or as a string naming the
stat stripped of the \code{stat_} prefix (e.g. \code{"count"} rather than
\code{"stat_count"})}
\item{arrow}{Arrow specification, as created by \code{\link[grid:arrow]{grid::arrow()}}.}
\item{lineend}{Line end style (round, butt, square).}
}
\description{
This set of stats and geoms makes it possible to draw b-splines based on a
set of control points. As with \code{\link[=geom_bezier]{geom_bezier()}} there exists several
versions each having there own strengths. The base version calculates the
b-spline as a number of points along the spline and connects these with a
path. The *2 version does the same but in addition interpolates aesthetics
between each control point. This makes the *2 version considerably slower
so it shouldn't be used unless needed. The *0 version uses
\code{\link[grid:grid.xspline]{grid::xsplineGrob()}} with \code{shape = 1} to approximate a b-spline.
}
\section{Aesthetics}{
geom_bspline understand the following aesthetics (required aesthetics are in
bold):
\itemize{
\item \strong{x}
\item \strong{y}
\item color
\item linewidth
\item linetype
\item alpha
\item lineend
}
}
\section{Computed variables}{
\describe{
\item{x, y}{The coordinates for the path describing the spline}
\item{index}{The progression along the interpolation mapped between 0 and 1}
}
}
\examples{
# Define some control points
cp <- data.frame(
x = c(
0, -5, -5, 5, 5, 2.5, 5, 7.5, 5, 2.5, 5, 7.5, 5, -2.5, -5, -7.5, -5,
-2.5, -5, -7.5, -5
),
y = c(
0, -5, 5, -5, 5, 5, 7.5, 5, 2.5, -5, -7.5, -5, -2.5, 5, 7.5, 5, 2.5,
-5, -7.5, -5, -2.5
),
class = sample(letters[1:3], 21, replace = TRUE)
)
# Now create some paths between them
paths <- data.frame(
ind = c(
7, 5, 8, 8, 5, 9, 9, 5, 6, 6, 5, 7, 7, 5, 1, 3, 15, 8, 5, 1, 3, 17, 9, 5,
1, 2, 19, 6, 5, 1, 4, 12, 7, 5, 1, 4, 10, 6, 5, 1, 2, 20
),
group = c(
1, 1, 1, 2, 2, 2, 3, 3, 3, 4, 4, 4, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 7, 7,
7, 7, 7, 8, 8, 8, 8, 8, 9, 9, 9, 9, 9, 10, 10, 10, 10, 10
)
)
paths$x <- cp$x[paths$ind]
paths$y <- cp$y[paths$ind]
paths$class <- cp$class[paths$ind]
ggplot(paths) +
geom_bspline(aes(x = x, y = y, group = group, colour = after_stat(index))) +
geom_point(aes(x = x, y = y), data = cp, color = 'steelblue')
ggplot(paths) +
geom_bspline2(aes(x = x, y = y, group = group, colour = class)) +
geom_point(aes(x = x, y = y), data = cp, color = 'steelblue')
ggplot(paths) +
geom_bspline0(aes(x = x, y = y, group = group)) +
geom_point(aes(x = x, y = y), data = cp, color = 'steelblue')
}
\author{
Thomas Lin Pedersen. The C++ code for De Boor's algorithm has been
adapted from
\href{https://chi3x10.wordpress.com/2009/10/18/de-boor-algorithm-in-c/}{Jason Yu-Tseh Chi implementation}
}
ggforce/man/gather_set_data.Rd 0000644 0001762 0000144 00000001304 14564603246 016056 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/parallel_sets.R
\name{gather_set_data}
\alias{gather_set_data}
\title{Tidy data for use with geom_parallel_sets}
\usage{
gather_set_data(data, x, id_name = "id")
}
\arguments{
\item{data}{A tidy dataframe with some categorical columns}
\item{x}{The columns to use for axes in the parallel sets diagram}
\item{id_name}{The name of the column that will contain the original index of
the row.}
}
\value{
A data.frame
}
\description{
This helper function makes it easy to change tidy data into a tidy(er) format
that can be used by geom_parallel_sets.
}
\examples{
data <- reshape2::melt(Titanic)
head(gather_set_data(data, 1:4))
}
ggforce/man/facet_grid_paginate.Rd 0000644 0001762 0000144 00000010432 14564603706 016702 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/facet_grid_paginate.R
\name{facet_grid_paginate}
\alias{facet_grid_paginate}
\title{Split facet_grid over multiple plots}
\usage{
facet_grid_paginate(
facets,
margins = FALSE,
scales = "fixed",
space = "fixed",
shrink = TRUE,
labeller = "label_value",
as.table = TRUE,
switch = NULL,
drop = TRUE,
ncol = NULL,
nrow = NULL,
page = 1,
byrow = TRUE
)
}
\arguments{
\item{facets}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Please use \code{rows}
and \code{cols} instead.}
\item{margins}{Either a logical value or a character
vector. Margins are additional facets which contain all the data
for each of the possible values of the faceting variables. If
\code{FALSE}, no additional facets are included (the
default). If \code{TRUE}, margins are included for all faceting
variables. If specified as a character vector, it is the names of
variables for which margins are to be created.}
\item{scales}{Are scales shared across all facets (the default,
\code{"fixed"}), or do they vary across rows (\code{"free_x"}),
columns (\code{"free_y"}), or both rows and columns (\code{"free"})?}
\item{space}{If \code{"fixed"}, the default, all panels have the same size.
If \code{"free_y"} their height will be proportional to the length of the
y scale; if \code{"free_x"} their width will be proportional to the
length of the x scale; or if \code{"free"} both height and width will
vary. This setting has no effect unless the appropriate scales also vary.}
\item{shrink}{If \code{TRUE}, will shrink scales to fit output of
statistics, not raw data. If \code{FALSE}, will be range of raw data
before statistical summary.}
\item{labeller}{A function that takes one data frame of labels and
returns a list or data frame of character vectors. Each input
column corresponds to one factor. Thus there will be more than
one with \code{vars(cyl, am)}. Each output
column gets displayed as one separate line in the strip
label. This function should inherit from the "labeller" S3 class
for compatibility with \code{\link[ggplot2:labeller]{labeller()}}. You can use different labeling
functions for different kind of labels, for example use \code{\link[ggplot2:label_parsed]{label_parsed()}} for
formatting facet labels. \code{\link[ggplot2:label_value]{label_value()}} is used by default,
check it for more details and pointers to other options.}
\item{as.table}{If \code{TRUE}, the default, the facets are laid out like
a table with highest values at the bottom-right. If \code{FALSE}, the
facets are laid out like a plot with the highest value at the top-right.}
\item{switch}{By default, the labels are displayed on the top and
right of the plot. If \code{"x"}, the top labels will be
displayed to the bottom. If \code{"y"}, the right-hand side
labels will be displayed to the left. Can also be set to
\code{"both"}.}
\item{drop}{If \code{TRUE}, the default, all factor levels not used in the
data will automatically be dropped. If \code{FALSE}, all factor levels
will be shown, regardless of whether or not they appear in the data.}
\item{ncol}{Number of columns per page}
\item{nrow}{Number of rows per page}
\item{page}{The page to draw}
\item{byrow}{Should the pages be created row-wise or column wise}
}
\description{
This extension to \code{\link[ggplot2:facet_grid]{ggplot2::facet_grid()}} will allow you to split
a facetted plot over multiple pages. You define a number of rows and columns
per page as well as the page number to plot, and the function will
automatically only plot the correct panels. Usually this will be put in a
loop to render all pages one by one.
}
\note{
If either \code{ncol} or \code{nrow} is \code{NULL} this function will
fall back to the standard \code{facet_grid} functionality.
}
\examples{
# Draw a small section of the grid
ggplot(diamonds) +
geom_point(aes(carat, price), alpha = 0.1) +
facet_grid_paginate(color ~ cut:clarity, ncol = 3, nrow = 3, page = 4)
}
\seealso{
\code{\link[=n_pages]{n_pages()}} to compute the total number of pages in a paginated
faceted plot
Other ggforce facets:
\code{\link{facet_stereo}()},
\code{\link{facet_wrap_paginate}()},
\code{\link{facet_zoom}()}
}
\concept{ggforce facets}
ggforce/man/geom_arc.Rd 0000644 0001762 0000144 00000015025 14553466074 014525 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/arc.R
\name{geom_arc}
\alias{geom_arc}
\alias{stat_arc}
\alias{stat_arc2}
\alias{geom_arc2}
\alias{stat_arc0}
\alias{geom_arc0}
\title{Arcs based on radius and radians}
\usage{
stat_arc(
mapping = NULL,
data = NULL,
geom = "arc",
position = "identity",
na.rm = FALSE,
show.legend = NA,
n = 360,
inherit.aes = TRUE,
...
)
geom_arc(
mapping = NULL,
data = NULL,
stat = "arc",
position = "identity",
n = 360,
arrow = NULL,
lineend = "butt",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
...
)
stat_arc2(
mapping = NULL,
data = NULL,
geom = "path_interpolate",
position = "identity",
na.rm = FALSE,
show.legend = NA,
n = 360,
inherit.aes = TRUE,
...
)
geom_arc2(
mapping = NULL,
data = NULL,
stat = "arc2",
position = "identity",
n = 360,
arrow = NULL,
lineend = "butt",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
...
)
stat_arc0(
mapping = NULL,
data = NULL,
geom = "arc0",
position = "identity",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
...
)
geom_arc0(
mapping = NULL,
data = NULL,
stat = "arc0",
position = "identity",
ncp = 5,
arrow = NULL,
lineend = "butt",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
...
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and
\code{inherit.aes = TRUE} (the default), it is combined with the default mapping
at the top level of the plot. You must supply \code{mapping} if there is no plot
mapping.}
\item{data}{The data to be displayed in this layer. There are three
options:
If \code{NULL}, the default, the data is inherited from the plot
data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}.
A \code{data.frame}, or other object, will override the plot
data. All objects will be fortified to produce a data frame. See
\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created.
A \code{function} will be called with a single argument,
the plot data. The return value must be a \code{data.frame}, and
will be used as the layer data. A \code{function} can be created
from a \code{formula} (e.g. \code{~ head(.x, 10)}).}
\item{geom}{The geometric object to use to display the data, either as a
\code{ggproto} \code{Geom} subclass or as a string naming the geom stripped of the
\code{geom_} prefix (e.g. \code{"point"} rather than \code{"geom_point"})}
\item{position}{Position adjustment, either as a string naming the adjustment
(e.g. \code{"jitter"} to use \code{position_jitter}), or the result of a call to a
position adjustment function. Use the latter if you need to change the
settings of the adjustment.}
\item{na.rm}{If \code{FALSE}, the default, missing values are removed with
a warning. If \code{TRUE}, missing values are silently removed.}
\item{show.legend}{logical. Should this layer be included in the legends?
\code{NA}, the default, includes if any aesthetics are mapped.
\code{FALSE} never includes, and \code{TRUE} always includes.
It can also be a named logical vector to finely select the aesthetics to
display.}
\item{n}{the smoothness of the arc. Sets the number of points to use if the
arc would cover a full circle}
\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics,
rather than combining with them. This is most useful for helper functions
that define both data and aesthetics and shouldn't inherit behaviour from
the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.}
\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}. These are
often aesthetics, used to set an aesthetic to a fixed value, like
\code{colour = "red"} or \code{size = 3}. They may also be parameters
to the paired geom/stat.}
\item{stat}{The statistical transformation to use on the data for this
layer, either as a \code{ggproto} \code{Geom} subclass or as a string naming the
stat stripped of the \code{stat_} prefix (e.g. \code{"count"} rather than
\code{"stat_count"})}
\item{arrow}{Arrow specification, as created by \code{\link[grid:arrow]{grid::arrow()}}.}
\item{lineend}{Line end style (round, butt, square).}
\item{ncp}{the number of control points used to draw the arc with curveGrob.
Determines how well the arc approximates a circle section}
}
\description{
This set of stats and geoms makes it possible to draw circle segments based
on a center point, a radius and a start and end angle (in radians). These
functions are intended for cartesian coordinate systems and makes it possible
to create circular plot types without using the
\code{\link[ggplot2:coord_polar]{ggplot2::coord_polar()}} coordinate system.
}
\details{
An arc is a segment of a line describing a circle. It is the
fundamental visual element in donut charts where the length of the segment
(and conversely the angular span of the segment) describes the proportion of
an entety.
}
\section{Aesthetics}{
geom_arc understand the following aesthetics (required aesthetics are in
bold):
\itemize{
\item \strong{x0}
\item \strong{y0}
\item \strong{r}
\item \strong{start}
\item \strong{end}
\item color
\item linewidth
\item linetype
\item alpha
\item lineend
}
}
\section{Computed variables}{
\describe{
\item{x, y}{The start coordinates for the segment}
\item{xend, yend}{The end coordinates for the segment}
\item{curvature}{The curvature of the curveGrob to match a circle}
}
}
\examples{
# Lets make some data
arcs <- data.frame(
start = seq(0, 2 * pi, length.out = 11)[-11],
end = seq(0, 2 * pi, length.out = 11)[-1],
r = rep(1:2, 5)
)
# Behold the arcs
ggplot(arcs) +
geom_arc(aes(x0 = 0, y0 = 0, r = r, start = start, end = end,
linetype = factor(r)))
# Use the calculated index to map values to position on the arc
ggplot(arcs) +
geom_arc(aes(x0 = 0, y0 = 0, r = r, start = start, end = end,
size = after_stat(index)), lineend = 'round')
# The 0 version maps directly to curveGrob instead of calculating the points
# itself
ggplot(arcs) +
geom_arc0(aes(x0 = 0, y0 = 0, r = r, start = start, end = end,
linetype = factor(r)))
# The 2 version allows interpolation of aesthetics between the start and end
# points
arcs2 <- data.frame(
angle = c(arcs$start, arcs$end),
r = rep(arcs$r, 2),
group = rep(1:10, 2),
colour = sample(letters[1:5], 20, TRUE)
)
ggplot(arcs2) +
geom_arc2(aes(x0 = 0, y0 = 0, r = r, end = angle, group = group,
colour = colour), size = 2)
}
\seealso{
\code{\link[=geom_arc_bar]{geom_arc_bar()}} for drawing arcs with fill
}
ggforce/man/geom_spiro.Rd 0000644 0001762 0000144 00000011406 14303120026 015064 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/spiro.R
\name{geom_spiro}
\alias{geom_spiro}
\alias{stat_spiro}
\title{Draw spirograms based on the radii of the different "wheels" involved}
\usage{
stat_spiro(
mapping = NULL,
data = NULL,
geom = "path",
position = "identity",
na.rm = FALSE,
n = 500,
revolutions = NULL,
show.legend = NA,
inherit.aes = TRUE,
...
)
geom_spiro(
mapping = NULL,
data = NULL,
stat = "spiro",
position = "identity",
arrow = NULL,
n = 500,
lineend = "butt",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
...
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and
\code{inherit.aes = TRUE} (the default), it is combined with the default mapping
at the top level of the plot. You must supply \code{mapping} if there is no plot
mapping.}
\item{data}{The data to be displayed in this layer. There are three
options:
If \code{NULL}, the default, the data is inherited from the plot
data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}.
A \code{data.frame}, or other object, will override the plot
data. All objects will be fortified to produce a data frame. See
\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created.
A \code{function} will be called with a single argument,
the plot data. The return value must be a \code{data.frame}, and
will be used as the layer data. A \code{function} can be created
from a \code{formula} (e.g. \code{~ head(.x, 10)}).}
\item{geom}{The geometric object to use to display the data, either as a
\code{ggproto} \code{Geom} subclass or as a string naming the geom stripped of the
\code{geom_} prefix (e.g. \code{"point"} rather than \code{"geom_point"})}
\item{position}{Position adjustment, either as a string naming the adjustment
(e.g. \code{"jitter"} to use \code{position_jitter}), or the result of a call to a
position adjustment function. Use the latter if you need to change the
settings of the adjustment.}
\item{na.rm}{If \code{FALSE}, the default, missing values are removed with
a warning. If \code{TRUE}, missing values are silently removed.}
\item{n}{The number of points that should be used to draw a fully closed
spirogram. If \code{revolutions < 1} the actual number of points will be less
than this.}
\item{revolutions}{The number of times the inner gear should revolve around
inside the outer gear. If \code{NULL} the number of revolutions to reach the
starting position is calculated and used.}
\item{show.legend}{logical. Should this layer be included in the legends?
\code{NA}, the default, includes if any aesthetics are mapped.
\code{FALSE} never includes, and \code{TRUE} always includes.
It can also be a named logical vector to finely select the aesthetics to
display.}
\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics,
rather than combining with them. This is most useful for helper functions
that define both data and aesthetics and shouldn't inherit behaviour from
the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.}
\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}. These are
often aesthetics, used to set an aesthetic to a fixed value, like
\code{colour = "red"} or \code{size = 3}. They may also be parameters
to the paired geom/stat.}
\item{stat}{The statistical transformation to use on the data for this
layer, either as a \code{ggproto} \code{Geom} subclass or as a string naming the
stat stripped of the \code{stat_} prefix (e.g. \code{"count"} rather than
\code{"stat_count"})}
\item{arrow}{Arrow specification, as created by \code{\link[grid:arrow]{grid::arrow()}}.}
\item{lineend}{Line end style (round, butt, square).}
}
\description{
This, rather pointless, geom allows you to draw spirograms, as known from the
popular drawing toy where lines were traced by inserting a pencil into a hole
in a small gear that would then trace around inside another gear. The
potential practicality of this geom is slim and it excists mainly for fun and
art.
}
\section{Aesthetics}{
stat_spiro and geom_spiro understand the following aesthetics (required
aesthetics are in bold):
\itemize{
\item \strong{R}
\item \strong{r}
\item \strong{d}
\item x0
\item y0
\item outer
\item color
\item size
\item linetype
\item alpha
}
}
\section{Computed variables}{
\describe{
\item{x, y}{The coordinates for the path describing the spirogram}
\item{index}{The progression along the spirogram mapped between 0 and 1}
}
}
\examples{
# Basic usage
ggplot() +
geom_spiro(aes(R = 10, r = 3, d = 5))
# Only draw a portion
ggplot() +
geom_spiro(aes(R = 10, r = 3, d = 5), revolutions = 1.2)
# Let the inner gear circle the outside of the outer gear
ggplot() +
geom_spiro(aes(R = 10, r = 3, d = 5, outer = TRUE))
}
ggforce/man/geom_shape.Rd 0000644 0001762 0000144 00000011236 14303120026 015031 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/shape.R
\name{geom_shape}
\alias{geom_shape}
\title{Draw polygons with expansion/contraction and/or rounded corners}
\usage{
geom_shape(
mapping = NULL,
data = NULL,
stat = "identity",
position = "identity",
expand = 0,
radius = 0,
...,
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and
\code{inherit.aes = TRUE} (the default), it is combined with the default mapping
at the top level of the plot. You must supply \code{mapping} if there is no plot
mapping.}
\item{data}{The data to be displayed in this layer. There are three
options:
If \code{NULL}, the default, the data is inherited from the plot
data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}.
A \code{data.frame}, or other object, will override the plot
data. All objects will be fortified to produce a data frame. See
\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created.
A \code{function} will be called with a single argument,
the plot data. The return value must be a \code{data.frame}, and
will be used as the layer data. A \code{function} can be created
from a \code{formula} (e.g. \code{~ head(.x, 10)}).}
\item{stat}{The statistical transformation to use on the data for this
layer, either as a \code{ggproto} \code{Geom} subclass or as a string naming the
stat stripped of the \code{stat_} prefix (e.g. \code{"count"} rather than
\code{"stat_count"})}
\item{position}{Position adjustment, either as a string naming the adjustment
(e.g. \code{"jitter"} to use \code{position_jitter}), or the result of a call to a
position adjustment function. Use the latter if you need to change the
settings of the adjustment.}
\item{expand}{A numeric or unit vector of length one, specifying the
expansion amount. Negative values will result in contraction instead. If the
value is given as a numeric it will be understood as a proportion of the
plot area width.}
\item{radius}{As \code{expand} but specifying the corner radius.}
\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}. These are
often aesthetics, used to set an aesthetic to a fixed value, like
\code{colour = "red"} or \code{size = 3}. They may also be parameters
to the paired geom/stat.}
\item{na.rm}{If \code{FALSE}, the default, missing values are removed with
a warning. If \code{TRUE}, missing values are silently removed.}
\item{show.legend}{logical. Should this layer be included in the legends?
\code{NA}, the default, includes if any aesthetics are mapped.
\code{FALSE} never includes, and \code{TRUE} always includes.
It can also be a named logical vector to finely select the aesthetics to
display.}
\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics,
rather than combining with them. This is most useful for helper functions
that define both data and aesthetics and shouldn't inherit behaviour from
the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.}
}
\description{
This geom is a cousin of \code{\link[ggplot2:geom_polygon]{ggplot2::geom_polygon()}} with the added
possibility of expanding or contracting the polygon by an absolute amount
(e.g. 1 cm). Furthermore, it is possible to round the corners of the polygon,
again by an absolute amount. The resulting geom reacts to resizing of the
plot, so the expansion/contraction and corner radius will not get distorted.
If no expansion/contraction or corner radius is specified, the geom falls
back to \code{geom_polygon} so there is no performance penality in using this
instead of \code{geom_polygon}.
}
\note{
Some settings can result in the dissappearance of polygons,
specifically when contracting or rounding corners with a relatively large
amount. Also note that x and y scale limits does not take expansion into
account and the resulting polygon might thus not fit into the plot.
}
\section{Aesthetics}{
geom_shape understand the following aesthetics (required aesthetics are in
bold):
\itemize{
\item \strong{x}
\item \strong{y}
\item color
\item fill
\item group
\item size
\item linetype
\item alpha
}
}
\examples{
shape <- data.frame(
x = c(0.5, 1, 0.75, 0.25, 0),
y = c(0, 0.5, 1, 0.75, 0.25)
)
# Expand and round
ggplot(shape, aes(x = x, y = y)) +
geom_shape(expand = unit(1, 'cm'), radius = unit(0.5, 'cm')) +
geom_polygon(fill = 'red')
# Contract
ggplot(shape, aes(x = x, y = y)) +
geom_polygon(fill = 'red') +
geom_shape(expand = unit(-1, 'cm'))
# Only round corners
ggplot(shape, aes(x = x, y = y)) +
geom_polygon(fill = 'red') +
geom_shape(radius = unit(1, 'cm'))
}
\author{
Thomas Lin Pedersen
}
ggforce/man/ggforce-package.Rd 0000644 0001762 0000144 00000005050 14303103037 015727 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/ggforce-package.R
\docType{package}
\name{ggforce-package}
\alias{ggforce}
\alias{ggforce-package}
\title{ggforce: Accelerating 'ggplot2'}
\description{
\if{html}{\figure{logo.png}{options: style='float: right' alt='logo' width='120'}}
The aim of 'ggplot2' is to aid in visual data investigations. This focus has led to a lack of facilities for composing specialised plots. 'ggforce' aims to be a collection of mainly new stats and geoms that fills this gap. All additional functionality is aimed to come through the official extension system so using 'ggforce' should be a stable experience.
}
\examples{
rocketData <- data.frame(
x = c(1, 1, 2, 2),
y = c(1, 2, 2, 3)
)
rocketData <- do.call(rbind, lapply(seq_len(500) - 1, function(i) {
rocketData$y <- rocketData$y - c(0, i / 500)
rocketData$group <- i + 1
rocketData
}))
rocketData2 <- data.frame(
x = c(2, 2.25, 2),
y = c(2, 2.5, 3)
)
rocketData2 <- do.call(rbind, lapply(seq_len(500) - 1, function(i) {
rocketData2$x[2] <- rocketData2$x[2] - i * 0.25 / 500
rocketData2$group <- i + 1 + 500
rocketData2
}))
ggplot() + geom_link(aes(
x = 2, y = 2, xend = 3, yend = 3, alpha = after_stat(index),
size = after_stat(index)
), colour = 'goldenrod', n = 500) +
geom_bezier(aes(x = x, y = y, group = group, colour = after_stat(index)),
data = rocketData
) +
geom_bezier(aes(x = y, y = x, group = group, colour = after_stat(index)),
data = rocketData
) +
geom_bezier(aes(x = x, y = y, group = group, colour = 1),
data = rocketData2
) +
geom_bezier(aes(x = y, y = x, group = group, colour = 1),
data = rocketData2
) +
geom_text(aes(x = 1.65, y = 1.65, label = 'ggplot2', angle = 45),
colour = 'white', size = 15
) +
coord_fixed() +
scale_x_reverse() +
scale_y_reverse() +
scale_alpha(range = c(1, 0), guide = 'none') +
scale_size_continuous(
range = c(20, 0.1), trans = 'exp',
guide = 'none'
) +
scale_color_continuous(guide = 'none') +
xlab('') + ylab('') +
ggtitle('ggforce: Accelerating ggplot2') +
theme(plot.title = element_text(size = 20))
}
\seealso{
Useful links:
\itemize{
\item \url{https://ggforce.data-imaginist.com}
\item \url{https://github.com/thomasp85/ggforce}
\item Report bugs at \url{https://github.com/thomasp85/ggforce/issues}
}
}
\author{
\strong{Maintainer}: Thomas Lin Pedersen \email{thomasp85@gmail.com} (\href{https://orcid.org/0000-0002-5147-4711}{ORCID})
Other contributors:
\itemize{
\item RStudio [copyright holder]
}
}
\keyword{internal}
ggforce/man/ggforce-extensions.Rd 0000644 0001762 0000144 00000004366 14277137746 016574 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/shape.R, R/arc_bar.R, R/arc.R, R/autodensity.R,
% R/autohistogram.R, R/bezier.R, R/bspline.R, R/bspline_closed.R,
% R/circle.R, R/diagonal.R, R/diagonal_wide.R, R/ellipse.R, R/errorbar.R,
% R/facet_grid_paginate.R, R/facet_matrix.R, R/facet_row.R, R/facet_stereo.R,
% R/facet_wrap_paginate.R, R/facet_zoom.R, R/ggproto-classes.R,
% R/interpolate.R, R/link.R, R/mark_circle.R, R/mark_ellipse.R,
% R/mark_hull.R, R/mark_rect.R, R/parallel_sets.R, R/position-jitternormal.R,
% R/position_auto.R, R/position_floatstack.R, R/regon.R, R/sina.R, R/spiro.R,
% R/voronoi.R
\docType{data}
\name{GeomShape}
\alias{GeomShape}
\alias{StatArcBar}
\alias{StatPie}
\alias{GeomArcBar}
\alias{StatArc}
\alias{GeomArc}
\alias{StatArc2}
\alias{StatArc0}
\alias{GeomArc0}
\alias{StatAutodensity}
\alias{GeomAutoarea}
\alias{StatAutobin}
\alias{GeomAutorect}
\alias{StatBezier}
\alias{StatBezier2}
\alias{StatBezier0}
\alias{GeomBezier0}
\alias{StatBspline}
\alias{StatBspline2}
\alias{GeomBspline0}
\alias{GeomBsplineClosed0}
\alias{StatCircle}
\alias{GeomCircle}
\alias{StatDiagonal}
\alias{StatDiagonal2}
\alias{StatDiagonal0}
\alias{StatDiagonalWide}
\alias{StatEllip}
\alias{StatErr}
\alias{FacetGridPaginate}
\alias{FacetMatrix}
\alias{FacetRow}
\alias{FacetCol}
\alias{FacetStereo}
\alias{FacetWrapPaginate}
\alias{FacetZoom}
\alias{ggforce-extensions}
\alias{GeomPathInterpolate}
\alias{StatLink}
\alias{StatLink2}
\alias{GeomMarkCircle}
\alias{GeomMarkEllipse}
\alias{GeomMarkHull}
\alias{GeomMarkRect}
\alias{StatParallelSets}
\alias{StatParallelSetsAxes}
\alias{GeomParallelSetsAxes}
\alias{PositionJitterNormal}
\alias{PositionAuto}
\alias{PositionFloatstack}
\alias{StatRegon}
\alias{StatSina}
\alias{StatSpiro}
\alias{StatVoronoiTile}
\alias{StatVoronoiSegment}
\alias{StatDelaunayTile}
\alias{StatDelaunaySegment}
\alias{StatDelaunaySegment2}
\alias{StatDelvorSummary}
\title{ggforce extensions to ggplot2}
\description{
ggforce makes heavy use of the ggproto class system to extend the
functionality of ggplot2. In general the actual classes should be of little
interest to users as the standard ggplot2 api of using geom_* and stat_*
functions for building up the plot is encouraged.
}
\keyword{datasets}
ggforce/man/geom_arc_bar.Rd 0000644 0001762 0000144 00000014675 14303413453 015345 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/arc_bar.R
\name{geom_arc_bar}
\alias{geom_arc_bar}
\alias{stat_arc_bar}
\alias{stat_pie}
\title{Arcs and wedges as polygons}
\usage{
stat_arc_bar(
mapping = NULL,
data = NULL,
geom = "arc_bar",
position = "identity",
n = 360,
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
...
)
stat_pie(
mapping = NULL,
data = NULL,
geom = "arc_bar",
position = "identity",
n = 360,
sep = 0,
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
...
)
geom_arc_bar(
mapping = NULL,
data = NULL,
stat = "arc_bar",
position = "identity",
n = 360,
expand = 0,
radius = 0,
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
...
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and
\code{inherit.aes = TRUE} (the default), it is combined with the default mapping
at the top level of the plot. You must supply \code{mapping} if there is no plot
mapping.}
\item{data}{The data to be displayed in this layer. There are three
options:
If \code{NULL}, the default, the data is inherited from the plot
data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}.
A \code{data.frame}, or other object, will override the plot
data. All objects will be fortified to produce a data frame. See
\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created.
A \code{function} will be called with a single argument,
the plot data. The return value must be a \code{data.frame}, and
will be used as the layer data. A \code{function} can be created
from a \code{formula} (e.g. \code{~ head(.x, 10)}).}
\item{geom}{The geometric object to use to display the data, either as a
\code{ggproto} \code{Geom} subclass or as a string naming the geom stripped of the
\code{geom_} prefix (e.g. \code{"point"} rather than \code{"geom_point"})}
\item{position}{Position adjustment, either as a string naming the adjustment
(e.g. \code{"jitter"} to use \code{position_jitter}), or the result of a call to a
position adjustment function. Use the latter if you need to change the
settings of the adjustment.}
\item{n}{The number of points used to draw a full circle. The number of
points on each arc will then be calculated as n / span-of-arc}
\item{na.rm}{If \code{FALSE}, the default, missing values are removed with
a warning. If \code{TRUE}, missing values are silently removed.}
\item{show.legend}{logical. Should this layer be included in the legends?
\code{NA}, the default, includes if any aesthetics are mapped.
\code{FALSE} never includes, and \code{TRUE} always includes.
It can also be a named logical vector to finely select the aesthetics to
display.}
\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics,
rather than combining with them. This is most useful for helper functions
that define both data and aesthetics and shouldn't inherit behaviour from
the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.}
\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}. These are
often aesthetics, used to set an aesthetic to a fixed value, like
\code{colour = "red"} or \code{size = 3}. They may also be parameters
to the paired geom/stat.}
\item{sep}{The separation between arcs in pie/donut charts}
\item{stat}{The statistical transformation to use on the data for this
layer, either as a \code{ggproto} \code{Geom} subclass or as a string naming the
stat stripped of the \code{stat_} prefix (e.g. \code{"count"} rather than
\code{"stat_count"})}
\item{expand}{A numeric or unit vector of length one, specifying the
expansion amount. Negative values will result in contraction instead. If the
value is given as a numeric it will be understood as a proportion of the
plot area width.}
\item{radius}{As \code{expand} but specifying the corner radius.}
}
\description{
This set of stats and geoms makes it possible to draw arcs and wedges as
known from pie and donut charts as well as more specialized plottypes such as
sunburst plots.
}
\details{
An arc bar is the thick version of an arc; that is, a circle segment
drawn as a polygon in the same way as a rectangle is a thick version of a
line. A wedge is a special case of an arc where the inner radius is 0. As
opposed to applying coord_polar to a stacked bar chart, these layers are
drawn in cartesian space, which allows for transformations not possible with
the native ggplot2 approach. Most notable of these are the option to explode
arcs and wedgets away from their center point, thus detaching it from the
main pie/donut.
}
\section{Aesthetics}{
geom_arc_bar understand the following aesthetics (required aesthetics are in
bold):
\itemize{
\item \strong{x0}
\item \strong{y0}
\item \strong{r0}
\item \strong{r}
\item \strong{start} - when using stat_arc_bar
\item \strong{end} - when using stat_arc_bar
\item \strong{amount} - when using stat_pie
\item explode
\item color
\item fill
\item linewidth
\item linetype
\item alpha
}
}
\section{Computed variables}{
\describe{
\item{x, y}{x and y coordinates for the polygon}
}
\describe{
\item{x, y}{The start coordinates for the segment}
}
}
\examples{
# If you know the angle spans to plot it is easy
arcs <- data.frame(
start = seq(0, 2 * pi, length.out = 11)[-11],
end = seq(0, 2 * pi, length.out = 11)[-1],
r = rep(1:2, 5)
)
# Behold the arcs
ggplot(arcs) +
geom_arc_bar(aes(x0 = 0, y0 = 0, r0 = r - 1, r = r, start = start,
end = end, fill = r))
# geom_arc_bar uses geom_shape to draw the arcs, so you have all the
# possibilities of that as well, e.g. rounding of corners
ggplot(arcs) +
geom_arc_bar(aes(x0 = 0, y0 = 0, r0 = r - 1, r = r, start = start,
end = end, fill = r), radius = unit(4, 'mm'))
# If you got values for a pie chart, use stat_pie
states <- c(
'eaten', "eaten but said you didn\'t", 'cat took it', 'for tonight',
'will decompose slowly'
)
pie <- data.frame(
state = factor(rep(states, 2), levels = states),
type = rep(c('Pie', 'Donut'), each = 5),
r0 = rep(c(0, 0.8), each = 5),
focus = rep(c(0.2, 0, 0, 0, 0), 2),
amount = c(4, 3, 1, 1.5, 6, 6, 1, 2, 3, 2)
)
# Look at the cakes
ggplot() + geom_arc_bar(aes(
x0 = 0, y0 = 0, r0 = r0, r = 1, amount = amount,
fill = state, explode = focus
),
data = pie, stat = 'pie'
) +
facet_wrap(~type, ncol = 1) +
coord_fixed() +
theme_no_axes() +
scale_fill_brewer('', type = 'qual')
}
\seealso{
\code{\link[=geom_arc]{geom_arc()}} for drawing arcs as lines
}
ggforce/man/theme_no_axes.Rd 0000644 0001762 0000144 00000001324 13674074434 015562 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/themes.R
\name{theme_no_axes}
\alias{theme_no_axes}
\title{Theme without axes and gridlines}
\usage{
theme_no_axes(base.theme = theme_bw())
}
\arguments{
\item{base.theme}{The theme to use as a base for the new theme. Defaults to
\code{\link[ggplot2:ggtheme]{ggplot2::theme_bw()}}.}
}
\value{
A modified version of base.theme
}
\description{
This theme is a simple wrapper around any complete theme that removes the
axis text, title and ticks as well as the grid lines for plots where these
have little meaning.
}
\examples{
p <- ggplot() + geom_point(aes(x = wt, y = qsec), data = mtcars)
p + theme_no_axes()
p + theme_no_axes(theme_grey())
}
ggforce/man/geom_ellipse.Rd 0000644 0001762 0000144 00000010752 14303120026 015370 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/ellipse.R
\name{geom_ellipse}
\alias{geom_ellipse}
\alias{stat_ellip}
\title{Draw (super)ellipses based on the coordinate system scale}
\usage{
stat_ellip(
mapping = NULL,
data = NULL,
geom = "circle",
position = "identity",
n = 360,
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
...
)
geom_ellipse(
mapping = NULL,
data = NULL,
stat = "ellip",
position = "identity",
n = 360,
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
...
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and
\code{inherit.aes = TRUE} (the default), it is combined with the default mapping
at the top level of the plot. You must supply \code{mapping} if there is no plot
mapping.}
\item{data}{The data to be displayed in this layer. There are three
options:
If \code{NULL}, the default, the data is inherited from the plot
data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}.
A \code{data.frame}, or other object, will override the plot
data. All objects will be fortified to produce a data frame. See
\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created.
A \code{function} will be called with a single argument,
the plot data. The return value must be a \code{data.frame}, and
will be used as the layer data. A \code{function} can be created
from a \code{formula} (e.g. \code{~ head(.x, 10)}).}
\item{geom}{The geometric object to use to display the data, either as a
\code{ggproto} \code{Geom} subclass or as a string naming the geom stripped of the
\code{geom_} prefix (e.g. \code{"point"} rather than \code{"geom_point"})}
\item{position}{Position adjustment, either as a string naming the adjustment
(e.g. \code{"jitter"} to use \code{position_jitter}), or the result of a call to a
position adjustment function. Use the latter if you need to change the
settings of the adjustment.}
\item{n}{The number of points to sample along the ellipse.}
\item{na.rm}{If \code{FALSE}, the default, missing values are removed with
a warning. If \code{TRUE}, missing values are silently removed.}
\item{show.legend}{logical. Should this layer be included in the legends?
\code{NA}, the default, includes if any aesthetics are mapped.
\code{FALSE} never includes, and \code{TRUE} always includes.
It can also be a named logical vector to finely select the aesthetics to
display.}
\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics,
rather than combining with them. This is most useful for helper functions
that define both data and aesthetics and shouldn't inherit behaviour from
the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.}
\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}. These are
often aesthetics, used to set an aesthetic to a fixed value, like
\code{colour = "red"} or \code{size = 3}. They may also be parameters
to the paired geom/stat.}
\item{stat}{The statistical transformation to use on the data for this
layer, either as a \code{ggproto} \code{Geom} subclass or as a string naming the
stat stripped of the \code{stat_} prefix (e.g. \code{"count"} rather than
\code{"stat_count"})}
}
\description{
This is a generalisation of \code{\link[=geom_circle]{geom_circle()}} that allows you to draw
ellipses at a specified angle and center relative to the coordinate system.
Apart from letting you draw regular ellipsis, the stat is using the
generalised formula for superellipses which can be utilised by setting the
\code{m1} and \code{m2} aesthetics. If you only set the m1 the m2 value will follow
that to ensure a symmetric appearance.
}
\section{Aesthetics}{
geom_arc understand the following aesthetics (required aesthetics are in
bold):
\itemize{
\item \strong{x0}
\item \strong{y0}
\item \strong{a}
\item \strong{b}
\item \strong{angle}
\item m1
\item m2
\item color
\item fill
\item linewidth
\item linetype
\item alpha
\item lineend
}
}
\section{Computed variables}{
\describe{
\item{x, y}{The coordinates for the points along the ellipse}
}
}
\examples{
# Basic usage
ggplot() +
geom_ellipse(aes(x0 = 0, y0 = 0, a = 10, b = 3, angle = 0)) +
coord_fixed()
# Rotation
# Note that it expects radians and rotates the ellipse counter-clockwise
ggplot() +
geom_ellipse(aes(x0 = 0, y0 = 0, a = 10, b = 3, angle = pi / 4)) +
coord_fixed()
# Draw a super ellipse
ggplot() +
geom_ellipse(aes(x0 = 0, y0 = 0, a = 6, b = 3, angle = -pi / 3, m1 = 3)) +
coord_fixed()
}
ggforce/man/geom_parallel_sets.Rd 0000644 0001762 0000144 00000017013 14303413453 016573 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/parallel_sets.R
\name{geom_parallel_sets}
\alias{geom_parallel_sets}
\alias{stat_parallel_sets}
\alias{stat_parallel_sets_axes}
\alias{geom_parallel_sets_axes}
\alias{geom_parallel_sets_labels}
\title{Create Parallel Sets diagrams}
\usage{
stat_parallel_sets(
mapping = NULL,
data = NULL,
geom = "shape",
position = "identity",
n = 100,
strength = 0.5,
sep = 0.05,
axis.width = 0,
na.rm = FALSE,
orientation = NA,
show.legend = NA,
inherit.aes = TRUE,
...
)
geom_parallel_sets(
mapping = NULL,
data = NULL,
stat = "parallel_sets",
position = "identity",
n = 100,
na.rm = FALSE,
orientation = NA,
sep = 0.05,
strength = 0.5,
axis.width = 0,
show.legend = NA,
inherit.aes = TRUE,
...
)
stat_parallel_sets_axes(
mapping = NULL,
data = NULL,
geom = "parallel_sets_axes",
position = "identity",
sep = 0.05,
axis.width = 0,
na.rm = FALSE,
orientation = NA,
show.legend = NA,
inherit.aes = TRUE,
...
)
geom_parallel_sets_axes(
mapping = NULL,
data = NULL,
stat = "parallel_sets_axes",
position = "identity",
na.rm = FALSE,
orientation = NA,
show.legend = NA,
inherit.aes = TRUE,
...
)
geom_parallel_sets_labels(
mapping = NULL,
data = NULL,
stat = "parallel_sets_axes",
angle = -90,
nudge_x = 0,
nudge_y = 0,
position = "identity",
na.rm = FALSE,
orientation = NA,
show.legend = NA,
inherit.aes = TRUE,
...
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and
\code{inherit.aes = TRUE} (the default), it is combined with the default mapping
at the top level of the plot. You must supply \code{mapping} if there is no plot
mapping.}
\item{data}{The data to be displayed in this layer. There are three
options:
If \code{NULL}, the default, the data is inherited from the plot
data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}.
A \code{data.frame}, or other object, will override the plot
data. All objects will be fortified to produce a data frame. See
\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created.
A \code{function} will be called with a single argument,
the plot data. The return value must be a \code{data.frame}, and
will be used as the layer data. A \code{function} can be created
from a \code{formula} (e.g. \code{~ head(.x, 10)}).}
\item{geom}{The geometric object to use to display the data, either as a
\code{ggproto} \code{Geom} subclass or as a string naming the geom stripped of the
\code{geom_} prefix (e.g. \code{"point"} rather than \code{"geom_point"})}
\item{position}{Position adjustment, either as a string naming the adjustment
(e.g. \code{"jitter"} to use \code{position_jitter}), or the result of a call to a
position adjustment function. Use the latter if you need to change the
settings of the adjustment.}
\item{n}{The number of points to create for each of the bounding diagonals}
\item{strength}{The proportion to move the control point along the x-axis
towards the other end of the bezier curve}
\item{sep}{The proportional separation between categories within a variable}
\item{axis.width}{The width of the area around each variable axis}
\item{na.rm}{If \code{FALSE}, the default, missing values are removed with
a warning. If \code{TRUE}, missing values are silently removed.}
\item{orientation}{The orientation of the layer. The default (\code{NA})
automatically determines the orientation from the aesthetic mapping. In the
rare event that this fails it can be given explicitly by setting \code{orientation}
to either \code{"x"} or \code{"y"}. See the \emph{Orientation} section for more detail.}
\item{show.legend}{logical. Should this layer be included in the legends?
\code{NA}, the default, includes if any aesthetics are mapped.
\code{FALSE} never includes, and \code{TRUE} always includes.
It can also be a named logical vector to finely select the aesthetics to
display.}
\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics,
rather than combining with them. This is most useful for helper functions
that define both data and aesthetics and shouldn't inherit behaviour from
the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.}
\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}. These are
often aesthetics, used to set an aesthetic to a fixed value, like
\code{colour = "red"} or \code{size = 3}. They may also be parameters
to the paired geom/stat.}
\item{stat}{The statistical transformation to use on the data for this
layer, either as a \code{ggproto} \code{Geom} subclass or as a string naming the
stat stripped of the \code{stat_} prefix (e.g. \code{"count"} rather than
\code{"stat_count"})}
\item{angle}{The angle of the axis label text}
\item{nudge_x, nudge_y}{Horizontal and vertical adjustment to nudge labels by.
Useful for offsetting text from the category segments.}
}
\description{
A parallel sets diagram is a type of visualisation showing the interaction
between multiple categorical variables. If the variables has an intrinsic
order the representation can be thought of as a Sankey Diagram. If each
variable is a point in time it will resemble an alluvial diagram.
}
\details{
In a parallel sets visualization each categorical variable will be assigned
a position on the x-axis. The size of the intersection of categories from
neighboring variables are then shown as thick diagonals, scaled by the sum of
elements shared between the two categories. The natural data representation
for such as plot is to have each categorical variable in a separate column
and then have a column giving the amount/magnitude of the combination of
levels in the row. This representation is unfortunately not fitting for the
\code{ggplot2} API which needs every position encoding in the same column. To make
it easier to work with \code{ggforce} provides a helper \code{\link[=gather_set_data]{gather_set_data()}}, which
takes care of the transformation.
}
\section{Aesthetics}{
geom_parallel_sets understand the following aesthetics
(required aesthetics are in bold):
\itemize{
\item \strong{x|y}
\item \strong{id}
\item \strong{split}
\item \strong{value}
\item color
\item fill
\item size
\item linetype
\item alpha
\item lineend
}
}
\section{Orientation}{
This geom treats each axis differently and, thus, can thus have two orientations. Often the orientation is easy to deduce from a combination of the given mappings and the types of positional scales in use. Thus, ggplot2 will by default try to guess which orientation the layer should have. Under rare circumstances, the orientation is ambiguous and guessing may fail. In that case the orientation can be specified directly using the \code{orientation} parameter, which can be either \code{"x"} or \code{"y"}. The value gives the axis that the geom should run along, \code{"x"} being the default orientation you would expect for the geom.
}
\examples{
data <- reshape2::melt(Titanic)
data <- gather_set_data(data, 1:4)
ggplot(data, aes(x, id = id, split = y, value = value)) +
geom_parallel_sets(aes(fill = Sex), alpha = 0.3, axis.width = 0.1) +
geom_parallel_sets_axes(axis.width = 0.1) +
geom_parallel_sets_labels(colour = 'white')
# Use nudge_x to offset and hjust = 0 to left-justify label
ggplot(data, aes(x, id = id, split = y, value = value)) +
geom_parallel_sets(aes(fill = Sex), alpha = 0.3, axis.width = 0.1) +
geom_parallel_sets_axes(axis.width = 0.1) +
geom_parallel_sets_labels(colour = 'red', angle = 0, nudge_x = 0.1, hjust = 0)
}
\author{
Thomas Lin Pedersen
}
ggforce/man/facet_zoom.Rd 0000644 0001762 0000144 00000006206 13674074434 015076 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/facet_zoom.R
\name{facet_zoom}
\alias{facet_zoom}
\title{Facet data for zoom with context}
\usage{
facet_zoom(
x,
y,
xy,
zoom.data,
xlim = NULL,
ylim = NULL,
split = FALSE,
horizontal = TRUE,
zoom.size = 2,
show.area = TRUE,
shrink = TRUE
)
}
\arguments{
\item{x, y, xy}{An expression evaluating to a logical vector that determines
the subset of data to zoom in on}
\item{zoom.data}{An expression evaluating to a logical vector. If \code{TRUE}
the data only shows in the zoom panels. If \code{FALSE} the data only show in
the context panel. If \code{NA} the data will show in all panels.}
\item{xlim, ylim}{Specific zoom ranges for each axis. If present they will
override \code{x}, \code{y}, and/or \code{xy}.}
\item{split}{If both \code{x} and \code{y} is given, should each axis zoom
be shown separately as well? Defaults to \code{FALSE}}
\item{horizontal}{If both \code{x} and \code{y} is given and
\code{split = FALSE} How should the zoom panel be positioned relative to the
full data panel? Defaults to \code{TRUE}}
\item{zoom.size}{Sets the relative size of the zoom panel to the full data
panel. The default (\code{2}) makes the zoom panel twice the size of the full
data panel.}
\item{show.area}{Should the zoom area be drawn below the data points on the
full data panel? Defaults to \code{TRUE}.}
\item{shrink}{If \code{TRUE}, will shrink scales to fit output of
statistics, not raw data. If \code{FALSE}, will be range of raw data
before statistical summary.}
}
\description{
This facetting provides the means to zoom in on a subset of the data, while
keeping the view of the full dataset as a separate panel. The zoomed-in area
will be indicated on the full dataset panel for reference. It is possible to
zoom in on both the x and y axis at the same time. If this is done it is
possible to both get each zoom separately and combined or just combined.
}
\examples{
# Zoom in on the versicolor species on the x-axis
ggplot(iris, aes(Petal.Length, Petal.Width, colour = Species)) +
geom_point() +
facet_zoom(x = Species == 'versicolor')
# Zoom in on versicolor on both axes
ggplot(iris, aes(Petal.Length, Petal.Width, colour = Species)) +
geom_point() +
facet_zoom(xy = Species == 'versicolor')
# Use different zoom criteria on each axis
ggplot(iris, aes(Petal.Length, Petal.Width, colour = Species)) +
geom_point() +
facet_zoom(x = Species != 'setosa', y = Species == 'versicolor')
# Get each axis zoom separately as well
ggplot(iris, aes(Petal.Length, Petal.Width, colour = Species)) +
geom_point() +
facet_zoom(xy = Species == 'versicolor', split = TRUE)
# Define the zoom area directly
ggplot(iris, aes(Petal.Length, Petal.Width, colour = Species)) +
geom_point() +
facet_zoom(xlim = c(2, 4))
# Selectively show data in the zoom panel
ggplot(iris, aes(Petal.Length, Petal.Width, colour = Species)) +
geom_point() +
facet_zoom(x = Species == 'versicolor', zoom.data = Species == 'versicolor')
}
\seealso{
Other ggforce facets:
\code{\link{facet_grid_paginate}()},
\code{\link{facet_stereo}()},
\code{\link{facet_wrap_paginate}()}
}
\concept{ggforce facets}
ggforce/man/facet_row.Rd 0000644 0001762 0000144 00000007407 14276646344 014731 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/facet_row.R
\name{facet_row}
\alias{facet_row}
\alias{facet_col}
\title{One-dimensional facets}
\usage{
facet_row(
facets,
scales = "fixed",
space = "fixed",
shrink = TRUE,
labeller = "label_value",
drop = TRUE,
strip.position = "top"
)
facet_col(
facets,
scales = "fixed",
space = "fixed",
shrink = TRUE,
labeller = "label_value",
drop = TRUE,
strip.position = "top"
)
}
\arguments{
\item{facets}{A set of variables or expressions quoted by \code{\link[ggplot2:vars]{vars()}}
and defining faceting groups on the rows or columns dimension.
The variables can be named (the names are passed to \code{labeller}).
For compatibility with the classic interface, can also be a
formula or character vector. Use either a one sided formula, \code{~a + b},
or a character vector, \code{c("a", "b")}.}
\item{scales}{Should scales be fixed (\code{"fixed"}, the default),
free (\code{"free"}), or free in one dimension (\code{"free_x"},
\code{"free_y"})?}
\item{space}{Should the size of the panels be fixed or relative to the range
of the respective position scales}
\item{shrink}{If \code{TRUE}, will shrink scales to fit output of
statistics, not raw data. If \code{FALSE}, will be range of raw data
before statistical summary.}
\item{labeller}{A function that takes one data frame of labels and
returns a list or data frame of character vectors. Each input
column corresponds to one factor. Thus there will be more than
one with \code{vars(cyl, am)}. Each output
column gets displayed as one separate line in the strip
label. This function should inherit from the "labeller" S3 class
for compatibility with \code{\link[ggplot2:labeller]{labeller()}}. You can use different labeling
functions for different kind of labels, for example use \code{\link[ggplot2:label_parsed]{label_parsed()}} for
formatting facet labels. \code{\link[ggplot2:label_value]{label_value()}} is used by default,
check it for more details and pointers to other options.}
\item{drop}{If \code{TRUE}, the default, all factor levels not used in the
data will automatically be dropped. If \code{FALSE}, all factor levels
will be shown, regardless of whether or not they appear in the data.}
\item{strip.position}{By default, the labels are displayed on the top of
the plot. Using \code{strip.position} it is possible to place the labels on
either of the four sides by setting \code{strip.position = c("top",
"bottom", "left", "right")}}
}
\description{
These facets are one-dimensional versions of \code{\link[ggplot2:facet_wrap]{ggplot2::facet_wrap()}},
arranging the panels in either a single row or a single column. This
restriction makes it possible to support a \code{space} argument as seen in
\code{\link[ggplot2:facet_grid]{ggplot2::facet_grid()}} which, if set to \code{"free"} will allow the panels to be
sized based on the relative range of their scales. Another way of thinking
about them are one-dimensional versions of \code{\link[ggplot2:facet_grid]{ggplot2::facet_grid()}} (ie.
\code{. ~ {var}} or \code{{var} ~ .}), but with the ability to position the strip at
either side of the panel. However you look at it it is the best of both world
if you just need one dimension.
}
\examples{
# Standard use
ggplot(mtcars) +
geom_point(aes(disp, mpg)) +
facet_col(~gear)
# It retains the ability to have unique scales for each panel
ggplot(mtcars) +
geom_point(aes(disp, mpg)) +
facet_col(~gear, scales = 'free')
# But can have free sizing along the stacking dimension
ggplot(mtcars) +
geom_point(aes(disp, mpg)) +
facet_col(~gear, scales = 'free', space = 'free')
# And you can position the strip where-ever you like
ggplot(mtcars) +
geom_point(aes(disp, mpg)) +
facet_col(~gear, scales = 'free', space = 'free', strip.position = 'bottom')
}
ggforce/man/trans_reverser.Rd 0000644 0001762 0000144 00000001663 14564603706 016015 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/trans.R
\name{trans_reverser}
\alias{trans_reverser}
\title{Reverse a transformation}
\usage{
trans_reverser(trans)
}
\arguments{
\item{trans}{A trans object or an object that can be converted to one using
\code{\link[scales:new_transform]{scales::as.trans()}}}
}
\value{
A trans object
}
\description{
While the scales package export a reverse_trans object it does not allow for
reversing of already transformed ranged - e.g. a reverse exp transformation
is not possible. trans_reverser takes a trans object or something coercible
to one and creates a reverse version of it.
}
\examples{
# Lets make a plot
p <- ggplot() +
geom_line(aes(x = 1:10, y = 1:10))
# scales already have a reverse trans
p + scale_x_continuous(trans = 'reverse')
# But what if you wanted to reverse an already log transformed scale?
p + scale_x_continuous(trans = trans_reverser('log'))
}
ggforce/man/position_jitternormal.Rd 0000644 0001762 0000144 00000004522 14304373432 017374 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/position-jitternormal.R
\name{position_jitternormal}
\alias{position_jitternormal}
\title{Jitter points with normally distributed random noise}
\usage{
position_jitternormal(sd_x = NULL, sd_y = NULL, seed = NA)
}
\arguments{
\item{sd_x, sd_y}{Standard deviation to add along the x and y axes. The
function uses \code{\link[stats:Normal]{stats::rnorm()}} with \code{mean = 0} behind the scenes.
If omitted, defaults to 0.15. As with \code{\link[ggplot2:geom_jitter]{ggplot2::geom_jitter()}}, categorical
data is aligned on the integers, so a standard deviation of more than 0.2
will spread the data so it's not possible to see the distinction between
the categories.}
\item{seed}{A random seed to make the jitter reproducible.
Useful if you need to apply the same jitter twice, e.g., for a point and
a corresponding label.
The random seed is reset after jittering.
If \code{NA} (the default value), the seed is initialised with a random value;
this makes sure that two subsequent calls start with a different seed.
Use \code{NULL} to use the current random seed and also avoid resetting
(the behaviour of \pkg{ggplot} 2.2.1 and earlier).}
}
\description{
\code{\link[ggplot2:geom_jitter]{ggplot2::geom_jitter()}} adds random noise to points using a uniform
distribution. When many points are plotted, they appear in a rectangle. This
position jitters points using a normal distribution instead, resulting in
more circular clusters.
}
\examples{
# Example data
df <- data.frame(
x = sample(1:3, 1500, TRUE),
y = sample(1:3, 1500, TRUE)
)
# position_jitter results in rectangular clusters
ggplot(df, aes(x = x, y = y)) +
geom_point(position = position_jitter())
# geom_jitternormal results in more circular clusters
ggplot(df, aes(x = x, y = y)) +
geom_point(position = position_jitternormal())
# You can adjust the standard deviations along both axes
# Tighter circles
ggplot(df, aes(x = x, y = y)) +
geom_point(position = position_jitternormal(sd_x = 0.08, sd_y = 0.08))
# Oblong shapes
ggplot(df, aes(x = x, y = y)) +
geom_point(position = position_jitternormal(sd_x = 0.2, sd_y = 0.08))
# Only add random noise to one dimension
ggplot(df, aes(x = x, y = y)) +
geom_point(
position = position_jitternormal(sd_x = 0.15, sd_y = 0),
alpha = 0.1
)
}
\concept{position adjustments}
ggforce/man/geom_delvor.Rd 0000644 0001762 0000144 00000023220 14564603246 015243 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/voronoi.R
\name{geom_voronoi}
\alias{geom_voronoi}
\alias{geom_delaunay}
\alias{geom_voronoi_tile}
\alias{geom_voronoi_segment}
\alias{geom_delaunay_tile}
\alias{geom_delaunay_segment}
\alias{geom_delaunay_segment2}
\alias{stat_delvor_summary}
\title{Voronoi tesselation and delaunay triangulation}
\usage{
geom_voronoi_tile(
mapping = NULL,
data = NULL,
stat = "voronoi_tile",
position = "identity",
na.rm = FALSE,
bound = NULL,
eps = 1e-09,
max.radius = NULL,
normalize = FALSE,
asp.ratio = 1,
expand = 0,
radius = 0,
show.legend = NA,
inherit.aes = TRUE,
...
)
geom_voronoi_segment(
mapping = NULL,
data = NULL,
stat = "voronoi_segment",
position = "identity",
na.rm = FALSE,
bound = NULL,
eps = 1e-09,
normalize = FALSE,
asp.ratio = 1,
show.legend = NA,
inherit.aes = TRUE,
...
)
geom_delaunay_tile(
mapping = NULL,
data = NULL,
stat = "delaunay_tile",
position = "identity",
na.rm = FALSE,
bound = NULL,
eps = 1e-09,
normalize = FALSE,
asp.ratio = 1,
expand = 0,
radius = 0,
show.legend = NA,
inherit.aes = TRUE,
...
)
geom_delaunay_segment(
mapping = NULL,
data = NULL,
stat = "delaunay_segment",
position = "identity",
na.rm = FALSE,
bound = NULL,
eps = 1e-09,
normalize = FALSE,
asp.ratio = 1,
show.legend = NA,
inherit.aes = TRUE,
...
)
geom_delaunay_segment2(
mapping = NULL,
data = NULL,
stat = "delaunay_segment2",
position = "identity",
na.rm = FALSE,
bound = NULL,
eps = 1e-09,
normalize = FALSE,
asp.ratio = 1,
n = 100,
show.legend = NA,
inherit.aes = TRUE,
...
)
stat_delvor_summary(
mapping = NULL,
data = NULL,
geom = "point",
position = "identity",
na.rm = FALSE,
bound = NULL,
eps = 1e-09,
normalize = FALSE,
asp.ratio = 1,
show.legend = NA,
inherit.aes = TRUE,
...
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and
\code{inherit.aes = TRUE} (the default), it is combined with the default mapping
at the top level of the plot. You must supply \code{mapping} if there is no plot
mapping.}
\item{data}{The data to be displayed in this layer. There are three
options:
If \code{NULL}, the default, the data is inherited from the plot
data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}.
A \code{data.frame}, or other object, will override the plot
data. All objects will be fortified to produce a data frame. See
\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created.
A \code{function} will be called with a single argument,
the plot data. The return value must be a \code{data.frame}, and
will be used as the layer data. A \code{function} can be created
from a \code{formula} (e.g. \code{~ head(.x, 10)}).}
\item{stat}{The statistical transformation to use on the data for this
layer, either as a \code{ggproto} \code{Geom} subclass or as a string naming the
stat stripped of the \code{stat_} prefix (e.g. \code{"count"} rather than
\code{"stat_count"})}
\item{position}{Position adjustment, either as a string naming the adjustment
(e.g. \code{"jitter"} to use \code{position_jitter}), or the result of a call to a
position adjustment function. Use the latter if you need to change the
settings of the adjustment.}
\item{na.rm}{If \code{FALSE}, the default, missing values are removed with
a warning. If \code{TRUE}, missing values are silently removed.}
\item{bound}{The bounding rectangle for the tesselation or a custom polygon
to clip the tesselation to. Defaults to \code{NULL} which creates a rectangle
expanded 10\\% in all directions. If supplied as a bounding box it should be a
vector giving the bounds in the following order: xmin, xmax, ymin, ymax. If
supplied as a polygon it should either be a 2-column matrix or a data.frame
containing an \code{x} and \code{y} column.}
\item{eps}{A value of epsilon used in testing whether a quantity is zero,
mainly in the context of whether points are collinear. If anomalous errors
arise, it is possible that these may averted by adjusting the value of eps
upward or downward.}
\item{max.radius}{The maximum distance a tile can extend from the point of
origin. Will in effect clip each tile to a circle centered at the point with
the given radius. If \code{normalize = TRUE} the radius will be given relative to
the normalized values}
\item{normalize}{Should coordinates be normalized prior to calculations. If
\code{x} and \code{y} are in wildly different ranges it can lead to
tesselation and triangulation that seems off when plotted without
\code{\link[ggplot2:coord_fixed]{ggplot2::coord_fixed()}}. Normalization of coordinates solves this.
The coordinates are transformed back after calculations.}
\item{asp.ratio}{If \code{normalize = TRUE} the x values will be multiplied by this
amount after normalization.}
\item{expand}{A numeric or unit vector of length one, specifying the
expansion amount. Negative values will result in contraction instead. If the
value is given as a numeric it will be understood as a proportion of the
plot area width.}
\item{radius}{As \code{expand} but specifying the corner radius.}
\item{show.legend}{logical. Should this layer be included in the legends?
\code{NA}, the default, includes if any aesthetics are mapped.
\code{FALSE} never includes, and \code{TRUE} always includes.
It can also be a named logical vector to finely select the aesthetics to
display.}
\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics,
rather than combining with them. This is most useful for helper functions
that define both data and aesthetics and shouldn't inherit behaviour from
the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.}
\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}. These are
often aesthetics, used to set an aesthetic to a fixed value, like
\code{colour = "red"} or \code{size = 3}. They may also be parameters
to the paired geom/stat.}
\item{n}{The number of points to create for each segment}
\item{geom}{The geometric object to use to display the data, either as a
\code{ggproto} \code{Geom} subclass or as a string naming the geom stripped of the
\code{geom_} prefix (e.g. \code{"point"} rather than \code{"geom_point"})}
}
\description{
This set of geoms and stats allows you to display voronoi tesselation and
delaunay triangulation, both as polygons and as line segments. Furthermore
it lets you augment your point data with related summary statistics. The
computations are based on the \code{\link[deldir:deldir]{deldir::deldir()}} package.
}
\section{Aesthetics}{
geom_voronoi_tile and geom_delaunay_tile understand the following aesthetics
(required aesthetics are in bold):
\itemize{
\item \strong{x}
\item \strong{y}
\item alpha
\item color
\item fill
\item linetype
\item size
}
geom_voronoi_segment, geom_delaunay_segment, and geom_delaunay_segment2
understand the following aesthetics (required aesthetics are in bold):
\itemize{
\item \strong{x}
\item \strong{y}
\item alpha
\item color
\item linetype
\item size
}
}
\section{Computed variables}{
stat_delvor_summary computes the following variables:
\describe{
\item{x, y}{If \code{switch.centroid = TRUE} this will be the coordinates for
the voronoi tile centroid, otherwise it is the original point}
\item{xcent, ycent}{If \code{switch.centroid = FALSE} this will be the
coordinates for the voronoi tile centroid, otherwise it will be \code{NULL}}
\item{xorig, yorig}{If \code{switch.centroid = TRUE} this will be the
coordinates for the original point, otherwise it will be \code{NULL}}
\item{ntri}{Number of triangles emanating from the point}
\item{triarea}{The total area of triangles emanating from the point divided
by 3}
\item{triprop}{\code{triarea} divided by the sum of the area of all
triangles}
\item{nsides}{Number of sides on the voronoi tile associated with the point}
\item{nedges}{Number of sides of the associated voronoi tile that is part of
the bounding box}
\item{vorarea}{The area of the voronoi tile associated with the point}
\item{vorprop}{\code{vorarea} divided by the sum of all voronoi tiles}
}
}
\examples{
# Voronoi
# You usually wants all points to take part in the same tesselation so set
# the group aesthetic to a constant (-1L is just a convention)
ggplot(iris, aes(Sepal.Length, Sepal.Width, group = -1L)) +
geom_voronoi_tile(aes(fill = Species)) +
geom_voronoi_segment() +
geom_text(aes(label = after_stat(nsides), size = after_stat(vorarea)),
stat = 'delvor_summary', switch.centroid = TRUE
)
# Difference of normalize = TRUE (segment layer is calculated without
# normalisation)
ggplot(iris, aes(Sepal.Length, Sepal.Width, group = -1L)) +
geom_voronoi_tile(aes(fill = Species), normalize = TRUE) +
geom_voronoi_segment()
# Set a max radius
ggplot(iris, aes(Sepal.Length, Sepal.Width, group = -1L)) +
geom_voronoi_tile(aes(fill = Species), colour = 'black', max.radius = 0.25)
# Set custom bounding polygon
triangle <- cbind(c(3, 9, 6), c(1, 1, 6))
ggplot(iris, aes(Sepal.Length, Sepal.Width, group = -1L)) +
geom_voronoi_tile(aes(fill = Species), colour = 'black', bound = triangle)
# Use geom_shape functionality to round corners etc
ggplot(iris, aes(Sepal.Length, Sepal.Width, group = -1L)) +
geom_voronoi_tile(aes(fill = Species), colour = 'black',
expand = unit(-.5, 'mm'), radius = unit(2, 'mm'))
# Delaunay triangles
ggplot(iris, aes(Sepal.Length, Sepal.Width)) +
geom_delaunay_tile(alpha = 0.3, colour = 'black')
# Use geom_delauney_segment2 to interpolate aestetics between end points
ggplot(iris, aes(Sepal.Length, Sepal.Width)) +
geom_delaunay_segment2(aes(colour = Species, group = -1), size = 2,
lineend = 'round')
}
ggforce/man/geom_sina.Rd 0000644 0001762 0000144 00000022331 14564603706 014705 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/sina.R
\name{geom_sina}
\alias{geom_sina}
\alias{stat_sina}
\title{Sina plot}
\usage{
stat_sina(
mapping = NULL,
data = NULL,
geom = "point",
position = "dodge",
scale = "area",
method = "density",
bw = "nrd0",
kernel = "gaussian",
maxwidth = NULL,
adjust = 1,
bin_limit = 1,
binwidth = NULL,
bins = NULL,
seed = NA,
jitter_y = TRUE,
...,
na.rm = FALSE,
orientation = NA,
show.legend = NA,
inherit.aes = TRUE
)
geom_sina(
mapping = NULL,
data = NULL,
stat = "sina",
position = "dodge",
...,
na.rm = FALSE,
orientation = NA,
show.legend = NA,
inherit.aes = TRUE
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and
\code{inherit.aes = TRUE} (the default), it is combined with the default mapping
at the top level of the plot. You must supply \code{mapping} if there is no plot
mapping.}
\item{data}{The data to be displayed in this layer. There are three
options:
If \code{NULL}, the default, the data is inherited from the plot
data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}.
A \code{data.frame}, or other object, will override the plot
data. All objects will be fortified to produce a data frame. See
\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created.
A \code{function} will be called with a single argument,
the plot data. The return value must be a \code{data.frame}, and
will be used as the layer data. A \code{function} can be created
from a \code{formula} (e.g. \code{~ head(.x, 10)}).}
\item{geom}{The geometric object to use to display the data, either as a
\code{ggproto} \code{Geom} subclass or as a string naming the geom stripped of the
\code{geom_} prefix (e.g. \code{"point"} rather than \code{"geom_point"})}
\item{position}{Position adjustment, either as a string naming the adjustment
(e.g. \code{"jitter"} to use \code{position_jitter}), or the result of a call to a
position adjustment function. Use the latter if you need to change the
settings of the adjustment.}
\item{scale}{How should each sina be scaled. Corresponds to the \code{scale}
parameter in \code{\link[ggplot2:geom_violin]{ggplot2::geom_violin()}}? Available are:
\itemize{
\item \code{'area'} for scaling by the largest density/bin among the different sinas
\item \code{'count'} as above, but in addition scales by the maximum number of points
in the different sinas.
\item \code{'width'} Only scale according to the \code{maxwidth} parameter
}
For backwards compatibility it can also be a logical with \code{TRUE} meaning
\code{area} and \code{FALSE} meaning \code{width}}
\item{method}{Choose the method to spread the samples within the same
bin along the x-axis. Available methods: "density", "counts" (can be
abbreviated, e.g. "d"). See \code{Details}.}
\item{bw}{The smoothing bandwidth to be used.
If numeric, the standard deviation of the smoothing kernel.
If character, a rule to choose the bandwidth, as listed in
\code{\link[stats:bandwidth]{stats::bw.nrd()}}. Note that automatic calculation of the bandwidth does
not take weights into account.}
\item{kernel}{Kernel. See list of available kernels in \code{\link[=density]{density()}}.}
\item{maxwidth}{Control the maximum width the points can spread into. Values
between 0 and 1.}
\item{adjust}{A multiplicate bandwidth adjustment. This makes it possible
to adjust the bandwidth while still using the a bandwidth estimator.
For example, \code{adjust = 1/2} means use half of the default bandwidth.}
\item{bin_limit}{If the samples within the same y-axis bin are more
than \code{bin_limit}, the samples's X coordinates will be adjusted.}
\item{binwidth}{The width of the bins. The default is to use \code{bins}
bins that cover the range of the data. You should always override
this value, exploring multiple widths to find the best to illustrate the
stories in your data.}
\item{bins}{Number of bins. Overridden by binwidth. Defaults to 50.}
\item{seed}{A seed to set for the jitter to ensure a reproducible plot}
\item{jitter_y}{If y is integerish banding can occur and the default is to
jitter the values slightly to make them better distributed. Setting
\code{jitter_y = FALSE} turns off this behaviour}
\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}. These are
often aesthetics, used to set an aesthetic to a fixed value, like
\code{colour = "red"} or \code{size = 3}. They may also be parameters
to the paired geom/stat.}
\item{na.rm}{If \code{FALSE}, the default, missing values are removed with
a warning. If \code{TRUE}, missing values are silently removed.}
\item{orientation}{The orientation of the layer. The default (\code{NA})
automatically determines the orientation from the aesthetic mapping. In the
rare event that this fails it can be given explicitly by setting \code{orientation}
to either \code{"x"} or \code{"y"}. See the \emph{Orientation} section for more detail.}
\item{show.legend}{logical. Should this layer be included in the legends?
\code{NA}, the default, includes if any aesthetics are mapped.
\code{FALSE} never includes, and \code{TRUE} always includes.
It can also be a named logical vector to finely select the aesthetics to
display.}
\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics,
rather than combining with them. This is most useful for helper functions
that define both data and aesthetics and shouldn't inherit behaviour from
the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.}
\item{stat}{The statistical transformation to use on the data for this
layer, either as a \code{ggproto} \code{Geom} subclass or as a string naming the
stat stripped of the \code{stat_} prefix (e.g. \code{"count"} rather than
\code{"stat_count"})}
}
\description{
The sina plot is a data visualization chart suitable for plotting any single
variable in a multiclass dataset. It is an enhanced jitter strip chart,
where the width of the jitter is controlled by the density distribution of
the data within each class.
}
\details{
There are two available ways to define the x-axis borders for the
samples to spread within:
\itemize{
\item{\code{method == "density"}
A density kernel is estimated along the y-axis for every sample group, and
the samples are spread within that curve. In effect this means that points
will be positioned randomly within a violin plot with the same parameters.
}
\item{\code{method == "counts"}:
The borders are defined by the number of samples that occupy the same bin.
}
}
}
\section{Aesthetics}{
geom_sina understand the following aesthetics (required aesthetics are in
bold):
\itemize{
\item \strong{x}
\item \strong{y}
\item color
\item group
\item size
\item alpha
}
}
\section{Computed variables}{
\describe{
\item{density}{The density or sample counts per bin for each point}
\item{scaled}{\code{density} scaled by the maximum density in each group}
\item{n}{The number of points in the group the point belong to}
}
}
\section{Orientation}{
This geom treats each axis differently and, thus, can thus have two orientations. Often the orientation is easy to deduce from a combination of the given mappings and the types of positional scales in use. Thus, ggplot2 will by default try to guess which orientation the layer should have. Under rare circumstances, the orientation is ambiguous and guessing may fail. In that case the orientation can be specified directly using the \code{orientation} parameter, which can be either \code{"x"} or \code{"y"}. The value gives the axis that the geom should run along, \code{"x"} being the default orientation you would expect for the geom.
}
\examples{
ggplot(midwest, aes(state, area)) + geom_point()
# Boxplot and Violin plots convey information on the distribution but not the
# number of samples, while Jitter does the opposite.
ggplot(midwest, aes(state, area)) +
geom_violin()
ggplot(midwest, aes(state, area)) +
geom_jitter()
# Sina does both!
ggplot(midwest, aes(state, area)) +
geom_violin() +
geom_sina()
p <- ggplot(midwest, aes(state, popdensity)) +
scale_y_log10()
p + geom_sina()
# Colour the points based on the data set's columns
p + geom_sina(aes(colour = inmetro))
# Or any other way
cols <- midwest$popdensity > 10000
p + geom_sina(colour = cols + 1L)
# Sina plots with continuous x:
ggplot(midwest, aes(cut_width(area, 0.02), popdensity)) +
geom_sina() +
scale_y_log10()
### Sample gaussian distributions
# Unimodal
a <- rnorm(500, 6, 1)
b <- rnorm(400, 5, 1.5)
# Bimodal
c <- c(rnorm(200, 3, .7), rnorm(50, 7, 0.4))
# Trimodal
d <- c(rnorm(200, 2, 0.7), rnorm(300, 5.5, 0.4), rnorm(100, 8, 0.4))
df <- data.frame(
'Distribution' = c(
rep('Unimodal 1', length(a)),
rep('Unimodal 2', length(b)),
rep('Bimodal', length(c)),
rep('Trimodal', length(d))
),
'Value' = c(a, b, c, d)
)
# Reorder levels
df$Distribution <- factor(
df$Distribution,
levels(df$Distribution)[c(3, 4, 1, 2)]
)
p <- ggplot(df, aes(Distribution, Value))
p + geom_boxplot()
p + geom_violin() +
geom_sina()
# By default, Sina plot scales the width of the class according to the width
# of the class with the highest density. Turn group-wise scaling off with:
p +
geom_violin() +
geom_sina(scale = FALSE)
}
\author{
Nikos Sidiropoulos, Claus Wilke, and Thomas Lin Pedersen
}
ggforce/man/scale_unit.Rd 0000644 0001762 0000144 00000001251 14564603246 015067 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/scale-unit.R
\name{scale_unit}
\alias{scale_x_unit}
\alias{scale_y_unit}
\title{Position scales for units data}
\usage{
scale_x_unit(...)
scale_y_unit(...)
}
\arguments{
\item{...}{Passed on to \code{units::scale_x_unit()} or \code{units::scale_y_unit()}}
}
\description{
\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} These are the default scales for the units
class. These will usually be added automatically. To override manually, use
\verb{scale_*_unit}.
}
\keyword{internal}
ggforce/man/geom_bspline_closed.Rd 0000644 0001762 0000144 00000012134 14303120026 016714 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/bspline_closed.R
\name{geom_bspline_closed}
\alias{geom_bspline_closed}
\alias{stat_bspline_closed}
\alias{geom_bspline_closed0}
\title{Create closed b-spline shapes}
\usage{
stat_bspline_closed(
mapping = NULL,
data = NULL,
geom = "shape",
position = "identity",
na.rm = FALSE,
n = 100,
show.legend = NA,
inherit.aes = TRUE,
...
)
geom_bspline_closed(
mapping = NULL,
data = NULL,
stat = "bspline",
position = "identity",
n = 100,
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
...
)
geom_bspline_closed0(
mapping = NULL,
data = NULL,
stat = "identity",
position = "identity",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
...
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and
\code{inherit.aes = TRUE} (the default), it is combined with the default mapping
at the top level of the plot. You must supply \code{mapping} if there is no plot
mapping.}
\item{data}{The data to be displayed in this layer. There are three
options:
If \code{NULL}, the default, the data is inherited from the plot
data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}.
A \code{data.frame}, or other object, will override the plot
data. All objects will be fortified to produce a data frame. See
\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created.
A \code{function} will be called with a single argument,
the plot data. The return value must be a \code{data.frame}, and
will be used as the layer data. A \code{function} can be created
from a \code{formula} (e.g. \code{~ head(.x, 10)}).}
\item{geom}{The geometric object to use to display the data, either as a
\code{ggproto} \code{Geom} subclass or as a string naming the geom stripped of the
\code{geom_} prefix (e.g. \code{"point"} rather than \code{"geom_point"})}
\item{position}{Position adjustment, either as a string naming the adjustment
(e.g. \code{"jitter"} to use \code{position_jitter}), or the result of a call to a
position adjustment function. Use the latter if you need to change the
settings of the adjustment.}
\item{na.rm}{If \code{FALSE}, the default, missing values are removed with
a warning. If \code{TRUE}, missing values are silently removed.}
\item{n}{The number of points generated for each spline}
\item{show.legend}{logical. Should this layer be included in the legends?
\code{NA}, the default, includes if any aesthetics are mapped.
\code{FALSE} never includes, and \code{TRUE} always includes.
It can also be a named logical vector to finely select the aesthetics to
display.}
\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics,
rather than combining with them. This is most useful for helper functions
that define both data and aesthetics and shouldn't inherit behaviour from
the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.}
\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}. These are
often aesthetics, used to set an aesthetic to a fixed value, like
\code{colour = "red"} or \code{size = 3}. They may also be parameters
to the paired geom/stat.}
\item{stat}{The statistical transformation to use on the data for this
layer, either as a \code{ggproto} \code{Geom} subclass or as a string naming the
stat stripped of the \code{stat_} prefix (e.g. \code{"count"} rather than
\code{"stat_count"})}
}
\description{
This geom creates closed b-spline curves and draws them as shapes. The
closed b-spline is achieved by wrapping the control points rather than the
knots. The *0 version uses the \code{\link[grid:grid.xspline]{grid::xsplineGrob()}} function with
\code{open = FALSE} and can thus not be manipulated as a shape geom in the same
way as the base version (expand, contract, etc).
}
\section{Aesthetics}{
geom_bspline_closed understand the following aesthetics (required aesthetics
are in bold):
\itemize{
\item \strong{x}
\item \strong{y}
\item color
\item fill
\item linewidth
\item linetype
\item alpha
}
}
\section{Computed variables}{
\describe{
\item{x, y}{The coordinates for the path describing the spline}
\item{index}{The progression along the interpolation mapped between 0 and 1}
}
}
\examples{
# Create 6 random control points
controls <- data.frame(
x = runif(6),
y = runif(6)
)
ggplot(controls, aes(x, y)) +
geom_polygon(fill = NA, colour = 'grey') +
geom_point(colour = 'red') +
geom_bspline_closed(alpha = 0.5)
# The 0 version approximates the correct shape
ggplot(controls, aes(x, y)) +
geom_polygon(fill = NA, colour = 'grey') +
geom_point(colour = 'red') +
geom_bspline_closed0(alpha = 0.5)
# But only the standard version supports geom_shape operations
# Be aware of self-intersections though
ggplot(controls, aes(x, y)) +
geom_polygon(fill = NA, colour = 'grey') +
geom_point(colour = 'red') +
geom_bspline_closed(alpha = 0.5, expand = unit(2, 'cm'))
}
\author{
Thomas Lin Pedersen. The C++ code for De Boor's algorithm has been
adapted from
\href{https://chi3x10.wordpress.com/2009/10/18/de-boor-algorithm-in-c/}{Jason Yu-Tseh Chi implementation}
}
ggforce/man/geom_circle.Rd 0000644 0001762 0000144 00000011657 14303120026 015201 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/circle.R
\name{geom_circle}
\alias{geom_circle}
\alias{stat_circle}
\title{Circles based on center and radius}
\usage{
stat_circle(
mapping = NULL,
data = NULL,
geom = "circle",
position = "identity",
n = 360,
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
...
)
geom_circle(
mapping = NULL,
data = NULL,
stat = "circle",
position = "identity",
n = 360,
expand = 0,
radius = 0,
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
...
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and
\code{inherit.aes = TRUE} (the default), it is combined with the default mapping
at the top level of the plot. You must supply \code{mapping} if there is no plot
mapping.}
\item{data}{The data to be displayed in this layer. There are three
options:
If \code{NULL}, the default, the data is inherited from the plot
data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}.
A \code{data.frame}, or other object, will override the plot
data. All objects will be fortified to produce a data frame. See
\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created.
A \code{function} will be called with a single argument,
the plot data. The return value must be a \code{data.frame}, and
will be used as the layer data. A \code{function} can be created
from a \code{formula} (e.g. \code{~ head(.x, 10)}).}
\item{geom}{The geometric object to use to display the data, either as a
\code{ggproto} \code{Geom} subclass or as a string naming the geom stripped of the
\code{geom_} prefix (e.g. \code{"point"} rather than \code{"geom_point"})}
\item{position}{Position adjustment, either as a string naming the adjustment
(e.g. \code{"jitter"} to use \code{position_jitter}), or the result of a call to a
position adjustment function. Use the latter if you need to change the
settings of the adjustment.}
\item{n}{The number of points on the generated path per full circle.}
\item{na.rm}{If \code{FALSE}, the default, missing values are removed with
a warning. If \code{TRUE}, missing values are silently removed.}
\item{show.legend}{logical. Should this layer be included in the legends?
\code{NA}, the default, includes if any aesthetics are mapped.
\code{FALSE} never includes, and \code{TRUE} always includes.
It can also be a named logical vector to finely select the aesthetics to
display.}
\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics,
rather than combining with them. This is most useful for helper functions
that define both data and aesthetics and shouldn't inherit behaviour from
the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.}
\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}. These are
often aesthetics, used to set an aesthetic to a fixed value, like
\code{colour = "red"} or \code{size = 3}. They may also be parameters
to the paired geom/stat.}
\item{stat}{The statistical transformation to use on the data for this
layer, either as a \code{ggproto} \code{Geom} subclass or as a string naming the
stat stripped of the \code{stat_} prefix (e.g. \code{"count"} rather than
\code{"stat_count"})}
\item{expand}{A numeric or unit vector of length one, specifying the
expansion amount. Negative values will result in contraction instead. If the
value is given as a numeric it will be understood as a proportion of the
plot area width.}
\item{radius}{As \code{expand} but specifying the corner radius.}
}
\description{
This set of stats and geoms makes it possible to draw circles based on a
center point and a radius. In contrast to using
\code{\link[ggplot2:geom_point]{ggplot2::geom_point()}}, the size of the circles are related to the
coordinate system and not to a separate scale. These functions are intended
for cartesian coordinate systems and will only produce a true circle if
\code{\link[ggplot2:coord_fixed]{ggplot2::coord_fixed()}} is used.
}
\note{
If the intend is to draw a bubble chart then use
\code{\link[ggplot2:geom_point]{ggplot2::geom_point()}} and map a variable to the size scale
}
\section{Aesthetics}{
geom_circle understand the following aesthetics (required aesthetics are in
bold):
\itemize{
\item \strong{x0}
\item \strong{y0}
\item \strong{r}
\item color
\item fill
\item linewidth
\item linetype
\item alpha
\item lineend
}
}
\section{Computed variables}{
\describe{
\item{x, y}{The start coordinates for the segment}
}
}
\examples{
# Lets make some data
circles <- data.frame(
x0 = rep(1:3, 3),
y0 = rep(1:3, each = 3),
r = seq(0.1, 1, length.out = 9)
)
# Behold some circles
ggplot() +
geom_circle(aes(x0 = x0, y0 = y0, r = r, fill = r), data = circles)
# Use coord_fixed to ensure true circularity
ggplot() +
geom_circle(aes(x0 = x0, y0 = y0, r = r, fill = r), data = circles) +
coord_fixed()
}
\seealso{
\code{\link[=geom_arc_bar]{geom_arc_bar()}} for drawing arcs with fill
}
ggforce/man/geom_diagonal_wide.Rd 0000644 0001762 0000144 00000013027 14303373174 016535 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/diagonal_wide.R
\name{geom_diagonal_wide}
\alias{geom_diagonal_wide}
\alias{stat_diagonal_wide}
\title{Draw an area defined by an upper and lower diagonal}
\usage{
stat_diagonal_wide(
mapping = NULL,
data = NULL,
geom = "shape",
position = "identity",
n = 100,
strength = 0.5,
na.rm = FALSE,
orientation = NA,
show.legend = NA,
inherit.aes = TRUE,
...
)
geom_diagonal_wide(
mapping = NULL,
data = NULL,
stat = "diagonal_wide",
position = "identity",
n = 100,
na.rm = FALSE,
orientation = NA,
strength = 0.5,
show.legend = NA,
inherit.aes = TRUE,
...
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and
\code{inherit.aes = TRUE} (the default), it is combined with the default mapping
at the top level of the plot. You must supply \code{mapping} if there is no plot
mapping.}
\item{data}{The data to be displayed in this layer. There are three
options:
If \code{NULL}, the default, the data is inherited from the plot
data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}.
A \code{data.frame}, or other object, will override the plot
data. All objects will be fortified to produce a data frame. See
\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created.
A \code{function} will be called with a single argument,
the plot data. The return value must be a \code{data.frame}, and
will be used as the layer data. A \code{function} can be created
from a \code{formula} (e.g. \code{~ head(.x, 10)}).}
\item{geom}{The geometric object to use to display the data, either as a
\code{ggproto} \code{Geom} subclass or as a string naming the geom stripped of the
\code{geom_} prefix (e.g. \code{"point"} rather than \code{"geom_point"})}
\item{position}{Position adjustment, either as a string naming the adjustment
(e.g. \code{"jitter"} to use \code{position_jitter}), or the result of a call to a
position adjustment function. Use the latter if you need to change the
settings of the adjustment.}
\item{n}{The number of points to create for each of the bounding diagonals}
\item{strength}{The proportion to move the control point along the x-axis
towards the other end of the bezier curve}
\item{na.rm}{If \code{FALSE}, the default, missing values are removed with
a warning. If \code{TRUE}, missing values are silently removed.}
\item{orientation}{The orientation of the layer. The default (\code{NA})
automatically determines the orientation from the aesthetic mapping. In the
rare event that this fails it can be given explicitly by setting \code{orientation}
to either \code{"x"} or \code{"y"}. See the \emph{Orientation} section for more detail.}
\item{show.legend}{logical. Should this layer be included in the legends?
\code{NA}, the default, includes if any aesthetics are mapped.
\code{FALSE} never includes, and \code{TRUE} always includes.
It can also be a named logical vector to finely select the aesthetics to
display.}
\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics,
rather than combining with them. This is most useful for helper functions
that define both data and aesthetics and shouldn't inherit behaviour from
the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.}
\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}. These are
often aesthetics, used to set an aesthetic to a fixed value, like
\code{colour = "red"} or \code{size = 3}. They may also be parameters
to the paired geom/stat.}
\item{stat}{The statistical transformation to use on the data for this
layer, either as a \code{ggproto} \code{Geom} subclass or as a string naming the
stat stripped of the \code{stat_} prefix (e.g. \code{"count"} rather than
\code{"stat_count"})}
}
\description{
The \code{geom_diagonal_wide()} function draws a \emph{thick} diagonal, that is, a
polygon confined between a lower and upper \link[=geom_diagonal]{diagonal}. This
geom is bidirectional and the direction can be controlled with the
\code{orientation} argument.
}
\section{Aesthetics}{
geom_diagonal_wide understand the following aesthetics
(required aesthetics are in bold):
\itemize{
\item \strong{x}
\item \strong{y}
\item \strong{group}
\item color
\item linewidth
\item linetype
\item alpha
\item lineend
}
}
\section{Orientation}{
This geom treats each axis differently and, thus, can thus have two orientations. Often the orientation is easy to deduce from a combination of the given mappings and the types of positional scales in use. Thus, ggplot2 will by default try to guess which orientation the layer should have. Under rare circumstances, the orientation is ambiguous and guessing may fail. In that case the orientation can be specified directly using the \code{orientation} parameter, which can be either \code{"x"} or \code{"y"}. The value gives the axis that the geom should run along, \code{"x"} being the default orientation you would expect for the geom.
}
\examples{
data <- data.frame(
x = c(1, 2, 2, 1, 2, 3, 3, 2),
y = c(1, 2, 3, 2, 3, 1, 2, 5),
group = c(1, 1, 1, 1, 2, 2, 2, 2)
)
ggplot(data) +
geom_diagonal_wide(aes(x, y, group = group))
# The strength control the steepness
ggplot(data, aes(x, y, group = group)) +
geom_diagonal_wide(strength = 0.75, alpha = 0.5, fill = 'red') +
geom_diagonal_wide(strength = 0.25, alpha = 0.5, fill = 'blue')
# The diagonal_wide geom uses geom_shape under the hood, so corner rounding
# etc are all there
ggplot(data) +
geom_diagonal_wide(aes(x, y, group = group), radius = unit(5, 'mm'))
}
ggforce/man/figures/ 0000755 0001762 0000144 00000000000 14564603262 014115 5 ustar ligges users ggforce/man/figures/lifecycle-defunct.svg 0000644 0001762 0000144 00000001704 14276652144 020230 0 ustar ligges users ggforce/man/figures/README-example-1.png 0000644 0001762 0000144 00000145261 14564603246 017362 0 ustar ligges users PNG
IHDR z4 iCCPkCGColorSpaceGenericRGB 8U]h U>+$Ԧ5lRфem,lAݝi&3i)>A['!j-P(G 3k~s ,[%,-:t}
}-+*&¿ gPG݅ج8"e Ų]A b ;l õ Wϙ2_E,(ۈ#Zsێ<5)"E6N#ӽEkۃO0}*rUt.iei # ]r
>cU{ t7+ԙg߃xuWB_-%=^ t0uvW9 %/VBW'_tMۓP \>@y0`D i|[`
hh) Tj0B#ЪhU# ~yhu fp#1I/I "0! 'Sdd:J5ǖ"sdy#R7wAgdJ7kʕn^:}nWFVst$gj-tԝr_װ_7Z ~V54V
}o[G=Nd>-UlaY5V }xg[?k &>srq߀].r_r_q sGjy4k
iQܟBZ-<(d=dKO a/zv7]ǰod}sn?TF'|3Nn#I?"mzv~K=گsl<b|_|4>?pߋQrib
2* ( Ѧh {28oIyes8';Z9h6g >xRx'b8ՃWOϫ [xn% |^z} %x c 8eXIfMM * i _ @ IDATxElΑ%%I D*'0SD=Ax)*F̙C:unFEwy'%$$o>={6o^'L 0&2P>2
κ<{ *C_&WM[ 3*qm37gPDWbu&<.BO>(:G1uFnn.eeeiȐ!Զm[ փK/]{4tPܝ1 ] (s0kK ̆
Z( C7 """ UnX&"PMvc|A(.5+xR ȌJ%Ħ1{ aG A@u-Vz[ᢹiQH0,ͥ\(]N-.ShR+V[l+έ]#@MPiEuWfq3YX"B2e
iӆ&MDwӧUz0H*'`7 φ 0$P!,_
F2%E7UXO^* |Lڿ 4//R(H!Za TAㇺgCr%;4>k&\/%$ VJYj[kDz\ͷ9GxE }g{ZL;==Zl)}G>cxbªƊ+/fӂg0&):FZϸ!KXCޕ~i]LeŹd$P~̀"W1 9. b͌?"v7Ғ%K&b߶m$ &О={#GӭJ[n~t `MF¨>1
a\q:Ƥ\TTוF8[
6lj* ƌ#ccŧ`L x@ʫ3KPV0=f4ɉ 0#qY$dYj\ 0&:dӗ[SZ݂n%SpX^m="t Ã钞% G;I}()˾2))Q찅>EͶh1Ie Vb]rMTs~ϥ:JyC B01vgV2at(**3mʩτnhMQT( &W +@C̾L 0&\ "@t 7lidQ$>gЏ?NV1{0Azay2e
c 4
?7O9$]+t,MݱV4 /;BNʼnj1WPf7e%}zS6 h[#4SK[yU7.^LwZ[- AK6@=#f̤uZ9i[x\-N `L^]^~B UG01H$aNmHv+ZGD"8k_I``a:BPW ~)rU/DU"#֭.\ /v mG";i =O%v h bCIսwjizTO pS& г4O!KLQ\A1UhnO䛄0|+ f\7ʅypd HBxn(e[XC@FhOGR`UG~ "XjkXy=dzs4|-& h21QqE0!?:nK?' p{sΜ]d+[IaJƾ J5YƏ<+>٨D`!{N Y,+t"VEw8L£3NWT+,Rlr0&2D94ǍOB L M>h}e
)`=te %ƛ4~I4nh)uN5ۃhu$L a㯨uǦ|>#""de.K!! i_EҰ*WS9aZTD;VҘ 3hn8d2@gTbta]k|Z=57_*+3}LL fWRRtЫ:V
[x"89N )k!% Մ B~黝R8 ةZ"
)ҳh ʨu~oPښ *W> P*5pvP ѿB \9LU!lSI>ov:()c{Xw*Xb.pEV&iY"UWBFRm_IwCFzqykVU\1?{iu_(ҕĽ sg "( 螊9Jz87Ă}qn4U HfPـ $%3P[ st4\"y/MO ϩQ
/˥.B J(GeZʀОLYYYTUꀭx3Bhzyԭc +TLMMu2\ǏhRLRb j%Px
a
ͥxW[XpE_F"u@mfͦ%8rM
>AtUpd?kbaob?{C
!QՖY<Ը*zl)du#X6wvet%*|1';ZLC!V= Zwh j[oL:_ّYjU"Cp/ Iuwr: o}Q0& bo]&7I+Z5as>$@f2?$Bq*'J.!lµwnZ)
X/| ׀MpÄ
WtW g
&_Oΐ^@hڵtI3ٳgYF6B& y0 WDSS1OQ6XC=j'$[ɑ|ؘ' k x/|rzСCҫj"sΥ9sЖ-[#GXǙL 0&`Ps*
;A? Nۏz;B+W y{3"iPYYJ
=,M.azնGlw!
V-ǵb@]ZTZuFT+V5k):R05+~<- 2yKc%w0Թ uUgu튱fWj<
GeNQFG }D QRzz:=ctRXzR`6mRՓ&]Wh3` P7u@mil Z[=~9'K*4w6
푧V\S+Jv8\ QT0߷| >Fv!fd-^ E[^
յ*Dw)a!s"I. >IwtvG$8Y , / 2;|xN 1-7n¥beTimx^05,"AlpԷo_)|j +W6ܒ 0&l;M?I I>LD4*[fNWrϭiÔYEWuJNt a`-o^\Cu6N ?so;%!( +ts%RG+0ͅG+r5!拣3E)3I+6 U4HPʩzq ҜY9EF!M V4WKSso~@~D3o ]7! S a͛GÇ$n(B))66rrrSc{Լ xnܝբE wvlB5oGI*^ ǨpSc}}__'ioV<$,3`EDmnG mJ)HCZUT2NZÅ') 2B]зmUOL " $Z @#Qզ\4=`f%ޕm]y/X{3%p|̙;}t ^X)վ,"BBoYm۹sgĵKK:2&/]YYmfr3+ 7bsCֹ vXpQ+K
${p%*><}Vkݠ @ #B,>>\>wLgtXu58.\U%2JQ/+[P2BX=5cSID3BDƁ4OhM(El X]C?` 0Z%|nb Kq43YDt$#n*NFD]R]>1˥VTX}=K)ᖱs'L [ڵƏ /Ǡkd+YfQ~hŊ_ӡCz [l["tlou^^ [ۣcYϭ{ujW
{1)N^&oߛzъHXU;XM#;>'ǖ :4 8\!8GP JGVֹ4\ҝٓ6l`UVeW_}5
6Ln 0&E ;_X Yu3N:X+ 2q'ݴr驂`@H )Ԭ=/L> ՙ L R/T;ra nZݬsƠ-A*^pdn S4
U-cxω 0<j `!_&u~GUe7A8[ uQB 6Q^c)Ƴ2_wR-b3-DX?mIG5mhUDmlС RI+7 4v*?xy;Bo} \?\-?7<( )*2fsV2kGѯ"y
dyߥK~\ Cw\Gu_@O~ZUx HKH=Yyom)]v!um0s=q. $$:m6-in:"pe]%./MoA#]D"@ʟX4D
a^RB=ZҠNUۏEѢ_[I?Ȅy]j NE 5
)Aمzsk`_pvY-DXjjSF /&v S]Tan0qZBȩ|JZP2eP0A%8- ;_ciݮ(zt~7Piai~[6(L 0& yt!|")K o#^Tޥ tv$G'|G[ !lm:'V ,;k)!kߐر/&MЍ
aCw
cD*|>'X9F>QXQU6&\/"7iOwK aZe ~sxL 4w%θ!TI4l׳5AGpZoԯy{MLe 1!:ЩU ~9$n
ܴaU%0[dg[)3ERί Qi^1X&fyB1Z
0ѓ_WQQn'!)Uѿn7 oʧ$Sy !qmi`g@hgaRg#D|9ws;4EҶƺtNj_M6 '7{LřlW{UO&(<i۸R=y_=#$ R30SK9|nO ޑ$O!FFx1)89ܑ+S#'Mh~VnWeSrkϧ7S_§Ip @MS?mv,Z
X9
ܺƵl!iј/~b#h]Nu5~*@'R0!]X R5@0bt,s:L辌H*X4S̯yP5~4LA4R||<7. ~d@S p\Gg#^r{꾸6mG4,|݉ Zp_,D\u-#"iDzj>G#>ROdb 7űzl_ѶW3VR#;*;seCH~9/Vlm* YYb]4o%VdMkƾgQ}q^<` qVL 0[h`@ F%#xNL 0o`ԛZL <:`[/V㫟%ե{d[y]E5%tN 5 T Z չD( puS L|o4] `͎ޙd,CՆBΦd}Cl8 8IOVTRSF1h
rZ%nL keAa4Lql2𨨩?I'*Nb 磋ZzB tN`,,`oܾP3^B{[ɽ1& ,+u*+BORiARx7;K6Hmc Ѻzrt'K((6!gwDBpΉWr;r8qB-KJJ]| uQH*[TZ[&=KwI:8[=zRm;
bۿ}9KZyؙ? ZVVF3f̐>l edd!ۗPz7X
}cyЍ r})chTƎ6DQȞ* )9$QAi
LDԶ kQMĖtM*s㩢&:$QW=Telhz7{jC)'n
uцN)A8ߟ*b1:z 6' /wm'8g}hԾ}{[U8 0&23Ѣe72?U>:c W.J!:}iz)=@ҟb) P4yb.%C쭞7t0d
B5Et;lhCVu
uaB貞9tE/a7} !M
" /ϥ}HY!2е
{jOWP
M>rrr믿
urssriȐ!Զm[]]x
pO$8TOOחdvޯ5T^\ B 0g Q˧ޤ&=xMsktKߤ
'͢%]ߤz9M]{D+yb..ɔ/§Rmr_ZbCQI&P66 q idSz 3 J;~Q[鱫
L?95u5ܕr
<^@{6z_nM rڴi!#Qʣ{T0 =Jkb(%Jמּ9?&&T&<ҿl_KWPGٓ-[FpՀF . ;w !8VM=bĞ O\3sqq1q +qYHu8v@ (A7?*##GUKH{2w@V
(X81حD% [rp"eTfY !E EJ:-V4+eLGVSAP\n.JDyk&\S߽ |N㺠]9y_\}$p?iӧUznY^/VG/OtꡦY/PkQ)DA O%}]r(_u223>Z ZF콃`U9uc I.RDBE]|\i-Jitz*;?AS˛Xn02
bk41)fLq|t 4k,ׯ 9Ə /Ybkܬ`~M`ґ2
Sv6msR]z x4>}EJaRъ e']I3O9/]]vr_ V4~.$ ?F']G[jHŻ弌ihaW!dRXXo^!)n;yv&QZYmI'&W!² ڴj*;1cHK6bQhvJ͜+ ,3[ڕV+6_j3adbaeM)>A!MY^+g6|mX'*,k`5eH v]@<|apD
Tji% %,81&w' MVp~tKUVҠS X
++x|m\{LԘ+ŇRNKn>F
~[tfd )) ]vSo?LVXD6 2=hӄ;((9Em1@a^6)z.]A٬zHFaŞމt| Az $B* ]"U ) j1bcuGnUj*:Ӗ}SG(N=ZSxk(Onew+T쌦:wA4xL 8DҝN$XPIWU (au o!||[.лYKVHQ3ޗ[c?ɹ/+'*",Ɋ Qu ( S
tPt[Č_sKFg7[Jws?ϗ ނsa^" gp dl9V7TSkZ1U+:hUN^? 5`Ll.3y2&h#z'z[6Ok
Ӗ d 2T?ZKW]NoOhG[:H7$ԇՖcTn5Өkd5kc|aCj<+0 5P4]ɤ(4~HK gN#sbL "N "x"AקJ'(}KnIO ;;[9vcgVdU;nQxxQܹ\u5kChCÝ"=S4۩Lz O7@ -;AZ}>:\t4ɰbUrCe_9}%t\% :MEUn!Ԍ26!BuyݾJ3
KG}R~rP;^:G!,ٵ V> WPq+LԿ|ʩ|E(k/'ZMrRBFH ڱRIRjKނ;b^ [+x?n [xvUNDy~U °
hܘgSV2WSצvaih:2}%<Α XݚkOP '&@ `4&υ sӂOxP5 Bg*P6D Z7O I5en e;}i^c3w)ogL 0#3 q8R~>d/9SiZ7hQ2Z_|B1;f~72ipֺûPVJ D i,'_9:>v][\n;G
h [ڹcwb8Gs &!@@zsj{z>zn2JVΉ@/Y"g!
'ߓ|7 w-j!Kc#-uFMuK? - 9`z#ڙ хk3-+k f}S`*ASnՑr &/`#$wi]6l6B}͍`=bޒkNg (A CrZ hґw-ޕD4. x]57GR(9FHq2FHD ?wʑ O5y ޟ5q_H^~<+ηi'_t'a@y 3& og Zf
觬yL@G !8Nz5ZX8 fdD-( & +^@onƌ|rΝKs̡-[wMG Y HB-IMB|_W^o 9¬%tPjpof|H B8it=f(t(1ӕhCSZ= {ppѓΎ'֒=Są0}:=~d& ,;d+`L Kf~w-t0NBz=}Zbi f|:8nh:g-bӧSNN}VYBH۷>QarJ]ݼ<_Լ :P6v, N@xTfgVԙK/a-.a] h~{N2ϒB+ hr. luPSRHEڌr*NC̅BSHKzfq.O9|yP}]_6
yn.|"siHj| 2nqWXXK{۟W{Q[hN<)WG
R`UzaJM4ƍ54anh tE'L-ouj)""BeqRipy틂^@7!4:͇oLs]Y8/$bqWXA&64ompT+VkLpW xE udF]
g qFJ:uzxwg͢-[T#JKK|-x=~j?mnEљ}X *Q67 *] D{
hw A>Cq-
ۼM cϕ Ee&%%I#YSlms BW5"еWҼ2V,#tOlJ7W愓zlyIm6S#OJZl v~-1$;+7W,`9U9aˬ71&@a|UҼyѣRꫯhРAM/@2ub>T9gҍW;KP5<0& `L &ނ[¬Ķw/ɐG :RaBܔ 0& `'6MUU3i2AB7x = sͦ_ 0& `Vdb?f}*|bA¢ZiRȯ `L 0 &h\C^\MG *,e `L 0&ೳiԱcGy 9rN8%%%Q]s>MSg $Ϛ6mS~eL 0&O ez+7x.- ;Ao߾,ZPQ1d(OSn Tգ'U6˨F%=Jlj 0& `$W_GFqш#ηi߾}4{lj߾6 ! AFӅTݲ%UKmiܽ.jgʢa!ʉ `L 0 hǎ #f" ?~:usrss)KFׯ!CP۶cy6\p};166֝]zYNeDu'*HKs(cMc39! @ IDATur D."}CqDd ̔>V+pM`J(N~Iñ0CBT 3+TfP W %
8)ljPyy9mڴ"""G cʕRӧ ~PN)--ͥ/P#+~9[I`o%Hj85 $$yTZZ*"WXA_|qb13"cTZBA(E nV|`? ea?|G4wUB6ZF3Ps RnǓTL|5)|*Y?|niAm?8я>eޣujR8w}]OVZ ' `
5{l
\ ? #CKs,x>/"Ic3,:_j nȈSݮt V>
e:QEQ1MuP"ٸ+;upHA"VD N~('&2Jė/ ><'& `L 8K4Ī&Su+j} !R tDU=fR(LLvھ jCqrNXP:R@O >2aTBnz1U^+ĒN 0& `uX ռ*APAV(W(@瘢 QlGz.#Q
#JG]T(p
O R8GBWvP3ʅyREqH%3O[^,|"ONERʔגɦGCUllUɖ+HX5B/~qۍ 0& `6CjH駩Jww`a)K""jYjL|eu^
c"fHn5PliG| YyyTL=3Y- Tu ,Uf 'I}QmT6$ұjʪ:o0<|Vf)%Np G) )+}NxsJ+F&Ą `L 0&
+]["R f62$+אjžn9 0& `>GkhSzjc Y#Zf4igY *`Tq@. gQت*zU 0& `~A+L}رw^jZ!X+UGT-"F{UPT~(io<_Oa491& `Lx\ cǨo_V1,"ǩSN*:Jăʕ+r ۷Os-HAVWM'$_ZKu6}Zmzz03JXGaNz5V (5`ęVa?|prl~?:7
fHdgj#@S.a @3"$,^c:@O<)VW+JBH4WB)X{x=շJ 7x'` ^(WG \[}/89N os R("? +T^t x!>m2:h :t_~Ỵqg^z)=t&xWX.|6gs^u kȵ%ޓ0AM|Fn6Z|9#Ч3HC ئ)x +bXlݺ\0ٶM89K朘?Љ:N@ AةjhW[9C_~ |
8vAG &+4>J1 $_u">}O O<$0ZZZ*#3hh[c=3'`!'ѭ[77ot SO=3$lCe|~8q߹K-[t_> >Ma>MoM6tg͘}|@ v *&cΓ
~/y~L >??_Zڛ bca{\i ࡪdai_@ =t]= Fp U2B'o'q( vxL=X uGEˣ͛7S^րLk:laΝ;ǀy:ƪ(R_ү5; !
l -?L n_Nqb@5^; _|[? @
>ok&CD# ~lsbL<CB G }Ds̑'!WN]%C4a0? @(@TNA '`e|8q;z}YgE;w$rbLqX m 7n! >@
`DTkCE&gXv>_88 QF(V;#wH~'|8%''kjxPy'aFF+))aWDիW wC"1~4B <{[E9Y=k, (vw6n[x4L
0_ .
3gΔӧOoB 8b#& (T>ϟOs4\>C (tD%Œ +L^~.WcNL 4 ƭ`eqʔ))ItV4cǎ瞓3Stx! ?>fӱE B!waTDq*0H@ xvRCg_>&s: EDM[d:aA<>h^ F }ɭt%:ɉ 0& bU, 94%@~\B&M94 Im^ @ `4 o7TNo\ EZN111O`ԓtor lD`7[(7>F݂; P,u״ hbB'tU 0@ ,91&POz|$@S\ɖ`L F@1
a ƒ[@^6z&:]NzQrC&]ؖWVFʉ 4W,6;ϖ 0
N0dmz5</` }bD|8 h b^F;`41 cL (!D,]z ``͆ PX e 7 Y1":Mi0&4'
a,j_`/o]Vd}N?FͭvDY WNL 0&}Ѱ02joSzz:u֍ JwW 矧;:ukE 0__Snn.eeeӧ c10& uѢ"0ʝ1c]ve_? .fϞ z!\W.ҬW@a ʉ 0& p/uQ_sxE-Z[oEw}:^xy:u%''|>{&,וu `L x x?_sxq,н{w zJJJ(??_
ϗ{zMwuSmӗ^z~wJII^zZMԫW/馛謳"0a=ԣGY֭Ç3Πɓ'S֭վ>ZliG&MD ~ B'V9
z^^|SoO #`L <1V !5Ggy&5}Yڸqccc iiiի@diǎ t%X$ @\j]wur+ĈG W^y< >|\~0[XT9溏xxL 0&h}l+>FaNX\`M6-~[hB8V:W\qmYoԲeKЩ$t1ڲe\T%a 2 ԪU+:uM0}$B@ |UWW_MPЎMmN Xv6iFcE7U{2`L 0&xJ9<ϱ*
233V7qʿ'R>}?X&\b }vѴid Ѷmj[=j,vqu}]~唐 ` :އ>VEB
xbʕ+n>1)(|^ nGܝ$
7( b\wa j_`%m! 0G @K.TyHYz|~TTmnxaOHD>KMMpw%W^ V4 rM~5kH
:wL۷o6W^yE000RbQG2$l{:Ad>tB%9l:lذA @qVSel xn~B j 0l¢1fڷo\l .]Xt 7V/1& `I .:Xcn
v%
2D8w}r:4p@Zh\ j,amy 1,: ^'Vf HhUOɚ0+[#<'|Tv$o;BJ_< _0wJ?Fނ3ނ;?Omkg
խGJ&XC7ސ r"WNp;l[G5P<[hOwj"
KvW@aե.a)2@ǯNL 0& Gڷo Wk8bA@βW9bMvP,I_ϔyj*#$q9`L 0&M Fw>vPrĚS7M 0& `#D4j\kne]+x(, ++\y]xjfJ aґ#Gd, ,81& `L +?
?WHp 0k,)*}/]*YV_`ҥtE =zHK1ʈ
[ő*b6Էy | `L 0&
pcƂ3zv;d'9KX3g LFW1V<%`
2& `L hRR)]{
k >P# g[A0&SBD,!ߖ +w Y!Ulh+懐a{*`8x0/XY ѥl 7ρYox
0TAM6U@#J S"DC=D7|,ꫯhر4b r-?.Ǫn<1 nD]}bL 4 S`+b
;↩fΜ)3fX8hʶ?L .w}%e ;n;' j} V9]D>YȎ}S=6YGe mkM
=P$ao>NL 0& `A ڽ{w9KlE#) ECse}=XẌ́:aKŊtiA3 `L 0& ZZ,--5HXk.+päm۶M60aٳG 9r$ ?nVںuCEm] `L 0&|PeȰNj'{=#֭A }QkϞ=iÆ
JƪUC)p3FZƪ| `L 0&8 Zta?-ZΝ;Sbb"]uU v{6`L 0()GhP^;,b]t~Ma B3,"<& `L!Fzie2a5B Wn;EK]+ o^zя?UNu @`L 0&<UѳZ&TKoxν: e%ujq ?JwM'u]'
,h GZkyL 0&8B5TRQ/_sB6F w2|BS=9=#HCnlB+nٲED333mΗtDL 0&@xH
ZNZe-?9z 5z,j~c*@{nB֭[@$J]ݺuQsN߿?!OXX:8oo<(?6e$@@ (D fAOFSϿz* T̘QP$ 9WLO=>TWVOϛ
TWW哎Q_ p&C=$zN:BK,HH@Z9M-IjOH|M.<:D 91_s:ל7[nCjq˖-z#Cnfq/>+{J;w־ # ~;:ϸqdڰE@@cƌ͛7%K/,ÇoNM Ŧ3fQc9FN=TG 4 HH"
Yj{`D%rdʈkGVa
Σv[5HnN
uT_]Tr-%F:̙#6mңGSO?/\zr'j0Pa~'zs )\h>쳲}v i.4-[ȋ/o+3g0H6B$@$@$]bԐ'Xgӵ(뜒cԶO_澁t}6gu`4&11Q&OU 6?NE|w=&1>zhyW]]taÆȑ# w3Io~C) G@Q1[:3 #;*W__-t )u;wHܢĦF M**"_̓ir [HD >\q o^0rPțo)B9w\
\ _\uUqyH^4@ kK mb
bHHHF6, |+5Dw
fy=}tRzMdb#l+|饗dڨLNNQ(QرcT=TVVj#vzaaZ?!!A%^+j
}ݧ6ZItʕz,acH $4IP.2/Ktnae/OHFJ?!l 0 1eo_m@bwi&02a$b 8! L2E
OĨ)\x2` =C3l9眣u`!C,C)1j^ ' bâ)**K̮ ײeK,ԿneggKaaa TT'feeΝ;4FH+crxey څ-Rیg sKj˂5Mߏ%mpS\\lJӞ([Z $V9tb ϑ
ճ]oC@ x&PV+iI
U8DFٲaIXGV5b
TBYӊB$@$@$=g7\)TG8Wcx2J[ uemp
?VЏ !d+ONS ϛG BFrL z@/Z4 M^nv fyl~x D.j侱F8 ѹRB9fّ( % +)Nt;'6$Zn̖8h
W}.'TЦ@p U{rhnA'R_q㾴b],qOh^xc%ϒ<5m2;R.kވ6y4@?*pƘa,ٍNLx C]̬qZgV7 b~=?+$̧&#pQG^nzd" oP+ 7f ~/4 +"ÇfW䥗^QFIZZZm
Ќc~ OkgIqm$&ʇ_9a۾^{M?x 뮻N Y_q֭qF~zYl,Z(l;# _- SW$5֦U*cuk
WUUIQQ{~>[|}͆
$?txtv5矗moeNreWwyM$zmҪU+رtU! t&i (˩6I2D)oe _6c yoY;0٠n*Q;αf {ebXxΝr=СCHhVV\uU:V}BHHH6TJnxA!hb00ܭ[7;wߋ | o=4l9ӥK.cuzӱ?1B'a8tkN b@ϣGN? 2zc {܄d(CXT>99Y'Kkٳ }тb
X6gokoJV|ĨO iƯf X #bٴ1zW՟nO7eժUh.~G{MM=sss}R]]mO 58T z5P};CJJJ x
ݰ ,IHHH }|zԛ EGOcJ1#O?6b4Sks1Ⱥu ԣڵKOwIn:u}0T4vX=aZQG&c~_'|R/dE.r0;R6! 'OG=]M0 jĨ%6(!$0EϺ^*yyy`Aeee<װl6L: =#iPf&Ĩ^`h~SNΝ;{|XZ^^nN(È/n,u 6)ڑ bSRRk^u*dXMC
wen5$11Q9Xmᾄ; Gl m Hg0! Z_q'w >ZoLF3mM#B$@$@$@$ |6e|%d|" aWHd|z|SضG i95k,F$$b}yz;/ # źE4sъ\ `,HHHH! Ű.-AK
|z5穎!\+f퀵z y' +QAi6M8HKntmsָjk| +RvjwDILIշ&F6)d hNXt(_v^ 0@̟ؓ?_R Q#$u<\RO?:L֚RHHH T rR_5u1R :$) W +(5uqR]YswIV Jcߤ2jb%%^nIpb{K䡅R[ #u" !3OE$ϖCwq*""m&Ä]Ǎ ։KrwkMup7n(;3ȍ7(wv И^ кy_/eU0cUq,^J+c^ O/F>g't}a,Uʜ[-0oU@oiU^ 0^˴ҧ~Z+ /C8]s5n+5>*++Sx}bdkN F7{& Bj
#֭Z2]ob7 nF&hڱYDjb|Y_viDTTCّ "iI6e9m[_zWmm#+(i곰bc%*cz2@k1EaH!˅Ol E^*K] ;vH~5|(peBE5[` B&n> +0>F5Ί+6B3[p?t ( 3.F l
`*/jg-A1^[ FhUKuvWN#AFxW(>xӾ`ͦK{|qb [o>ƃ'p(ڵnɞpj`w?F,`x[nfCs~"B{䢹umn~|H؊f8Hb۬0orDCǪ$s
8|h6aB
Fvo +'5?Dmnld+TU3$^wb 1mU6-$w&H`D1BqꩧQ%K0ΰ+ yz:sLӈqcO=s$@$@$.=a ھJ%#NW,g4L Z(Vl"^F Y, iɅҵc|7>
N/5JMғ7i3_ L 9R:( Oԣ{\} q ҳgO|ԦM8p߲e6<}]]$@$@$`uj qI懇R鿑P3rc /?PV¹}^NիWQ#8BIq_g7 M2EGX۷L4Iw?|{~ X@Z+פs1֭ۤ[( Eqx57[n k5/lЇu[\ `^֡ek@q[M}{n5M5ܗKҁZ ~n?Z L)6=B3٨U=PW^y4߂ loƮg: @C_M[?&Ɏ}^O6T?^Γ_\Nm3o+Dxo_6>dh'~^wuz~bg F };/! +dʜodݎXY%^fk%mo HN˫cE4Ն+u/eʤgZȵ/f:S50Ν,\MfjBf(oNׁ#>$@$@H-j74\7 Ƕ ),dߜ܆aNlp9ʑ|8^E:P?8j_1Y.:( u뿈nȟ?pX5l @Zx0G@G^ܗ>oR J!4r4uϓ @t6]bT n=ZRv< -=+,t4Dmҹex8ܲF:H\&@8oV\ W8u}hgG 1p V 4 dYYچ#ܗV7o Gb}9>h hqD 5;j$M-y \k c4QE4|Շ/ `sA3tc$56Y2ß ڲJBhiHL עN 8o3GEpZބDGF^T/8[ M$&@U$<4@NjIH %䔾uhAH!vi@#Z=RͪU{" 0%0VHMbSrE8WS
6VnؘX:_@oȆM֗vK ҊhZW& *FXEjmuRZ[&͓ ڲrzl)5V-)q))՚ޚt5R\:֕IÞ8"8O 88sKj٧|KL]{c:>nٲ|Ky})uwU #2K 8oUKUR˄FZ3X9@`$@$@MDzМ] \pσg()1A(i-i&IHHHH$RY| 4m6oV;)o͕ =zHHHH ;SO4f>쳲k.dC41,C`Mms?JL32mkNC._5]/92Osyy/%ma=ۜ/7vV)ƩgYg)wtVe eJumL_Ib\ '-3iZ
)`K$7 ևE6l[nEZhCn:={tԩ,L' tLX=ME[TX&($ Ug<^6lCtȏo|9x?Se?~\XfvA<Ş{ޗ _Q2 95{Z8 L^}PJ[w\2{/KWd7F~L;-_n[m/˗ϐWyM~ޔ"ןWE "A1@[o|Yp[SPP {ŋː!CCNyeҥmJ^^Yqq]J$$$[XIJJ
Vsb1)"l}i~CоpoۥK7dT3Cr;#$½mNf]'ZT_,?$s1Z ;ų6KNosťIz--u2>gnzDN;AH;A!~|euZ'(_۞)]/164}ly}g\(tԇQt,$--MܻwoX7r +'ɲs( $*frjCD
PW-m2StWA Rr=YP S:ֵm8jb&16g{- uR[ z^>xjժ|h Qۧ\
@Ocj]S]0`7^(Vlohql~
{na+.QuU,Z[<Ɋlƽms##sϐ;]́rPrF98evF-T[]9EL9jl52'+Du#Vm!,jTޏHqZ&zJ\ Sz=h]26&UJp|y mBwEo9k_zi-F ƍM6zDk^{MޓN8n|Z;C$a%W˛ߓ*[BmqliU+w5h!V:8/0g=1j>zMIfe˖5i55s%eM፸ؼ ;w<@eddXr.څ] %X:TVVfK3
pE^㻭:֓> Ǜ`fp\9x *( E`[Y[Aa9ۢ½[+wpdj1~rlH
|
>
$!8J>s " L7\\q P**jGzQ~oIJ TY\W Aқ,b9b
EUqi˒k=?Ğ8 J F@}m# 6[o P' 9)%01N'j:Kvw?G(J"N]6]>2x9[Z)+ћ
jW-'!@4j
%|XuZM==餟o"PITT1]υ= c;aתw-=վr!p@~³i[L$4@]- 3T7SGd JHM:ĺ0
WDJb~C/ QWT<H;4@\$&=W;_7 Ĩ`ej=Q$dWJ7N{SWxD:DY$6% B| ?3;Gc崜!k;y D"k3 Vgȕ13 ,7WG b5XT3 P a}^3/ ]3*56EF&6r
k[_ ~L=H:_[tg}@mNhsh K?XDFJO9ד~@yD;
jPHR WhzHHHH"f Kȯ)ǷGɸ-P5j 8Bi ů mz\;?#$4oO*GrN3dj`<ȥ5E者u2g:z]5C~-]-s~ uY3f奿պ.-n2 *!9uJ$ և4ZmRAfgL\V\
sN(r~;5͗Wg8]vdz_Oo6,*\n\A_ foր{ޡɃpJk&ݸvFi20O_)~6
3([l/em{SZ0p
h0({_׀z*rr
>zu
*ߣGx TaP'j|Bc~m_]O([Z\3 _/%gq5>¯1'TS_#uoyZ .)&A~ c(zQ" Jmp9F?[%6Lo$lE|FẺݱ;OwV·lP H"oo[@~i4 j2d[7<ޣᆣ ]\V)~tP"
JC w7vBq1}to0"p;uxA'sw#MP#vGg8g{=$)nBz7IEnz:;5a^_ Hz Mr(d&$4V-)-;g V܄*vo*!rMISWfl_G$[n핻? RGș-z&$(RMfZ[Y#-Cs{5>oz)9 BS!{k
/VmrtN`Z٭ rN"9RJ KPAMHA b" 6 Y||тjkۛ^XfffJqBPeLJJmba:#RR:p*RPPU^0@]U,+5Y~جVWx(/Q.+pL
cL+)b|nTV:065n~@UI|%!"I 𤘎GEG÷?qmJ\m0H6@Nw31 |n^Wh>6PHBGhسd$8KTG<2yu 2Cz jDbGjװ'*G#Zڠ߲zնIî _$}$9ad@ՃzIڐ SH py:_}z7F:@9\?_l~,7WbUp) .3sꪁñ±N7tRg FĬAnöج3GJW=b´9;PQ/ "}0- [
d{$buJVVܹӲnBӷ n*ڟ$15QR$?2#z3njoT=NW Y+aw0ER0gyy<
\B$aܭ)4 IqIڨ-0@ t ~;EL7ɔH?9_x5 @K`ۥc\[w.wK0%:_Мk1gR|)3XNJ^O$@$h:t>7epXJWN< O5E2lEj&$˧z_F(dzV\bqbs\i_zy1 @C߿uyETΦ5 ;] ('0uM*w6>
XϱknPk)_oW hTnS_u)0Fdsv4!p$ ߜ_PG4?RV?줣8W> D#r4α{vsCOݒ;ztZ)_QiuSTW" D/o[>.od'dڿ*mbkwva# ]U+?a^LWzjŏ.R: D/nBr{LW_푶1dDi9xHK ' _
@x|eey+
rKG +WJ =' \:u6/K
˻ tTp;jUj=N91}fW^+wFe岠.)/5
Mѳ7KPG+W>208OYc*ے^^L$@$` nذAƏ /%%%|ƍ_3<#7xwy2gΜFD{
]B/;Puw~h
ܥv R)-
\aO= HE}rTk#exVjz&F9w~^G$@$?˭*pBڧO =B 8]~̜9Ӟ6j(94wyixɱst=
+o]?ΓG:\( Rr $֯a9';&; 7oN#@UP 6ncr8&7ۣɶ/p#)(x`')ٿpP
p! >Oϒ W!`g*qqq,HH* A;0]?ѪرCZha?@HHH< .WgF )7U3Iąe}bT;_t0OHV~v]Dz{w MUlZojیϙf+ GZY p/ӆTLJJJӥ]vkCĢ"),,4ޚ
#X2PSScpQEyO6.x] 0yzK
J;6<;B֖w+Qj!"cZhy]m MG垩}VOq>"BK7e$11Q"cck=ңx{*7݃Q*癊` 2bZ#cs)xh4 d\ תU+)((m$協 KH.v/a?= vṩgX˓uog.
hmVg&#ءif80Ln;T@hݾ~r
$@$@>QCAQ)x6m_d^x 9{lر\|/j
RVvDnjKU|Ƈϊ85ZHRLin]Z6Tj$3.IȊ#F?ĥK\RTVIo^2C/F@ L0P0*
a3 |tʔ)ߟX9i$8q\tEzofsLY Na|9Y-UL4CtĥG\*8$z]'o(Owub ~A]:dÇڱ&==ݞ
6LYB$@$@$@$`M!&VHHHH14@#t TJ$@$@$@$a: @@
V*% h
0HHHH h+ 4FhcdN$@$@$@$4@JIHHH#@12L' J$@$@$@$@
Ѐ`R m IHHHBh@R) @ch6F$@$@$@$@! AR+47][8 uuUR~BB%
튉d,)BgfLѸ #X@D0M<|RRRZZ!WZZj^~rr(++_ B0`XC_Vl49Q>=?_BaTD
Yzz,0" @PrƙUeF Yl`d{mj]Vm3OZ߬Gf;IHHH L
`5HHHH Z f;IHHH L
`5HHHH Z f;IHHH L
`5HHHH Z f;IHHH L
`5HHHH Z f;IHHH L
`5HHHH Z f;IHHH L
`5HHHH Z f;IHHH L
`5HHHH Z f;IHHH L
`5HHHH Z f;IHHH L { Qt"={t[͛esңG{ D>?~rꩧʓO>)Ǐ#G6ʮ]$++Kӧ
@$@$@$@M (裏>*sWƎ +'NaÆIbbuٳSNN|C$@$@$@$` 7@kkke֭LH^^ʶmۤkvRPP {ŋː!CC8-[Ӓ$%%ެ8
6,a'&&FAool%h
}f~C V' }iŶ]V'6Yݓ3"_*,0n[hI-h_^dɒ%ڨ6mL0A^ZƍgӧT{&k uZ
ʘ\-[1|Wdzzz`6 V7aB g (#p# uuuNp3%'';[Ν+{wy PI)??ެ|8a$۷A*#z222$UHXҁa$݊#9(++ P*!F@ƳHZqq՚&]˵
mg )"p7
ntnC
Ю];'0 3 Pņ$<wGۯ+**Lݛ- @`Z]]m63NmF R&U /+ޓh6+
~pObP(ͰLzRMo2wѥ`}'Lܸq 1y5HEE2zN"U @G@іS
7ܠK. 2e̚5K 5jL4IOdff̙3l|% 5 mޘf7||6 ) |BB`# [q
V\ovi)xo=o5Awذh5k#m7jEX:f5w#i.3xСX@ q5e|"/n4oOG<& A5@# kJ$@$@$@$(4@EzIHHH IHHHEhR/ [4@ba" @
Y% pK[,L$ "K$@$@$@$@n u$@$@$@$@"@4PdHHHH-n0HHHH Ph, %@-&
@^ hD @(K$@$@$@$
PXH$@$@$@$(16%R h oz1111$UUUx咐 555(ƽ^[[1O$D-xྫྷ-"9#7*g$I755Sx. o %%%+ P5;;[
Mj))) ݷo~8ȐPc6| }g{|ᗕ-
qm~V-[JuuGL1uE95*f$ 0
P3(R hzIHHH @ A$@$@$@$5^bF 3 5"u xMרHHHH 4@͠H $@$@$@$@^5*f$ 0
P3(R hzIHHH @ A$@$@$@$5^bF 3 5"u xMרHHHH 4@͠H $@$@$@$@^5*f$ 0
P3(R fݻW>CYfE)$@$@$@$@#~ &ڵkns%#< e͛c" @F }Q{o߾2vX8q 6LoܸQKy7%66V^{53g|<< |7@kkke֭ҧO M+//ORSSe۶mҵkW;
6<0>! `˖-ON:$9c:0ꐞ.f
=ҢEYӪ233RVz͊tZmx9 -&&ƒ$%6MmEڳĊÖ|hPw42/'tǎ N2%L/_nOÈ* f |i!d5b oVlZ.
iohV|~gI]]>9lA (~m<ueyRRRz^zɻkO+**
f%|lR'555r-Vi _}q ###Cp[M.7 Y&xೆ VuZw[uuGLp SyVQ7@sss 䤤$]<ڵkTVZɊ+iӶm[{wI
Ĵ 1x`ywWtħ56;ȍ7(K,,`k~mYx՚foL6MHA1b^vweYCK?&b裏|`l>ʯyb#G ujh2g\+L~3c`fuv+u`y'>sx>*O:~ C~%SLYf &M;srrsrHHHHbknQ}Çi݄r
~^Oh @uYqq={O<
4gɵ`2[n,e[1jzۼ6$@$@$@$@@ k@á @|4aMtٲei@G9~ӦMz \4QBK`ʕsN0`@K%э ,X_L -Yti3BlNoҝJҼ? K.mZL Nb
Զ{O;{9g F FyӞx 4hP@? \zj'|R=XqusO
\r D⢄ 6 ~g2rAN0A-u> 1J D+{#8AEyk$ T D{,[ЊU,+Q;o 4!B0Zޛ.* w wT_.3BWbc FC/B|| K~pժU[h~#dр5Dw Хy 5}Θh+9jG@_'p^ՎQx=%i\c7.KldiW4N: F)!pB? jZ>Aea֮]xXG \sx
yXX~ i؛՛ D
.O=a` (n1lXyM7Ieeݻwǎm/|駍љ_@ ̙3Go Z^6@4X (-E7|#C >|>s{/X6[S?,B8l `/($ Qkb;m~iĉK;1QЫJ.k
>2``'kv )ıeYZZ`'6~yyuN>d.Kbƌ?o&zjoW{)SgN*o;go9X CqTyTES,}Q㰩5U
X디X!l úCP" ?oW<(Ih0i, )x= @h
wJ$@$@$@QKhv=N$@$@$@!@44Y* D-n1ڮgI!8;G:3% *01k,Kcǎ ut'нpfD KK.A" k.xk#[A #:rLX^ڶmdYrj' |pZ4߅xdɒ炕xmڴ3fh`p rHFSVQL QO>D!dw}^i_A#dWD@& s 5# D-F4/_no'1x ``Ԉ }N4/riF[~g=Er){C`D{=a IDATz. z!3Ȇ
o/{d@^0D k0r{
7\{sN9 4NhlxHO0*a ~:ng#
6L^z%}ܷo_} Fk&C38CO_tIzpȈj}֭G }TXcz1-ܢRcyĈ_Yg%oS^t! b'ր"JpS
l ZgiS
ۤIlj4vmƎ kkٲM=xSMljiyyy6ȦF 5
ݻצ CofϿpBGj=(Ww<+ljmcq~l#GlvW_|Qb
{ o&[֭uݍ д)x˟9s~_QQ:CԨW FpF:@T;!e 6uAzdq:z۶mk.ٺu_nni^xA]x9v;s<>Q SF6
aDN: 'ez=FR
0S)O! h
D-~Zitw]JlUS;
A} ys)xGcYYY ;jt{IH4HM{h"{FnZje_{icӛ0jDƣ?`kN w~ ^>CeٲeNy?C|C$@$` & ]+pпmb7ژwO8im*IUlifecyclelifecyclematuringmaturing ggforce/man/figures/logo.png 0000644 0001762 0000144 00000266621 13476154650 015603 0 ustar ligges users PNG
IHDR iCCPsRGB IEC61966-2.1 (uKA?#`D!FmKK`+
BmkAPAllmTι$ f;,XBi%7
A&ׂ~s1䴾B31WDɹ u=
f 0k?huZ'U O ;% 5Gjr&k,d
GkXIiay9LTc.KA' /Nfa{`AYQ'?KNr*E4VI"[ԂTKL ho_H φm2#9'Vs0!VUs }ίZt.6Qh(fI$:umU9yк|5Ceg{K. pHYs IDATxyeUy]kOguk&
QfdP ШLN4&v:IOy6oLvM $PPDu3^chzs{a˲, K. yS˲,KV}cccReYE(x t\.S7L7Uک=22 p
ݶ/=/˳(/C !ժRs<+`vC= 8$%fI o v,?,+K[F
P* ecïֆT!{0Vn$ (ʲ24#0 #x)wWJ4@H:s}
;s=I@<ٲ|߲/-eg((JLVo<-NZ"oUF/ WS=| -襂VE$
MWg[ P#Ogj50䉘qM-+BNX 5Jc\
Zv49: ]Y/5ρw !}ё!k|
P ) M-[Xx]xJ/ \[X3w4vE# Yl4A``}9eeY_?!(JJkF|8^l; B~ u~>gV\{\C@ףﻏ[ }wY~@YV <0>äiU'
*|@hg}t֠0ח9x0)%}>ۏI `nnQ?}8 ]Ȳ2d
&DtyAQ&|IWo)7&2x )J`!3ņB{(y)
AHh oj+8rl~ہ,˿#2/ !T*AOּ+3;|įj\%6Wf`pb 'N9h90[`v}&'0dٲin@RgI)2KF 箏8G v M"IMb,b9Ȳe~E o>RJ&'':.skG=c .f(mI/7IN=̓f B+6\֥2aU`_Vmn FS?rp?9CSj `XϹXFS0~&)!j]vvםVa"H
, e%>g,5iqP
kG%f><2~B٥z*cX.Y,m
1n
DoGk~ߑdO`ӏ<,7!ϊw]PU'X3[ȂZprW2lvJG X$aE5=}-uC! !hR&L%en
ie]1K2PP4٘; lyiJpy@,ώ,Ϯc-BVZEړ4 |(/1RYG"PFiRgfP` Z{o+1O3!A(Ac6]1`xM̆>& KJܒ~lFN/5Oj7=Z8}MU'G { C#z=[ {Ye=kl UZTU*>w j|S _L-dsNd\Bn_Fhɮ#K*1ދ4^٧<)+3V* {g~ϪbOhR7 `kj{*5Y4fQ:J3B0H4Wwv121 LƏ7Olp9*pjj
8y"\ lκ vJ)IBD<)D`,KAI~Ah4ZlL@jz | uC+AdhM_1% I'J,೧*ƿ6j6 xՄ v>q 0ӳeeeSTELLL0;{970i#j%ASm닅h-aCOD-Ku. "
lnHVy캥DD:RH) W
aYBVIZB_lYV8B͓R(9yeț,Q|bxlVz
%xRgeZ2ދI& C0dp˦c}a3F&|)@dӌi,a#ln5z J/̭y6>pᐃ(IeJPL<-*œfBPh[RġcB^Ţ
?)m=k˅ 7w4xxR ˭'YVM.tR2<7G}_N VaHZeb8ⴱ& nמR%D;mRfMI)1i;I7&L&V! [щu+iʄƋ`tfM$E+_gx}b.I[23` &+Yh-sK. !2wk(fS֯DfKA N[3*mں*iziwC#EzNrZ w0Gak V,p~8n T@wV2urB*{ш
yGc}C YAsO ?dvOڷMAPLߦSI.8b p`A 0T8cĩ+4es _2U_iz6nz?M8$| qjJRu5
iJ JXjBFLACV0a ~5oTОL<(c) FiF AX-AgU
0,vڇ OqlOWhiH[
J0!sl 10Ekl߷#N^i>'f."&uqi1Dz=)|r,̹_,Y5tC/ be ֥YQ(! w?;\E
v#$8/S HO3v KS) Q%1"#2q[d Z֍Wx ~00ngDpH1qJ
dԦK̎'EvYfgS3e iz=]fem8v_q zVVK\-3?\륔 3^tC/^ֳk"SL?`
AOg [J
}̧uVhV+*+a+g&W*gA6H~1c '-HDb+NIPY.ϔ=i-,}&Sy+`c&>/9}MC07.r IR}&G4G2| xBa7Go ct`C0ϳKUc+P|e-T.2މ`I~K'5PTV6=2y q%3=b0ѝ<9FbC9X z牓bOKPxmKĩ ǝgx6-q霐*6I>C.* 7Ar/ġ䪭%6jvoP "QJ7?a?["?j< aHZebU~
o:jN+Qg#a76yC:[" ǪTxڣ+ '&Fs {n+1N 41eMV53+`ɄS+~Ɍ .{XxiD>/\j&=;f5
43ᬻ\>W\sZqa=?"! SSSkpmkO+cB:rfiS(dn9"Șj4J q ;}Z|EXuV(AgV>♐K Ҩ.t1E=
@PьOL- 1>2Ƭ=/:+[(A . ܩΞ2ع)(K&q
U8tLh_#&&<C|MЗ{gzl{҂1Ji E?> >\O:7xy8F52(U/\0؊ !A\\.V5J1X9-`qoқ3lYi)H O=2I6aHEoh 06^ńƲ#1hǤ$a=Sxm}_l\Wd3{K i헖s<s韞`
X䱘
x'Fe>0zN0??Ozۀ/.y?d7 ɘS' T*0d
ocgMpT`OkzU/#.qZc]-Iw.
l8%tH_+SpHѝ hFi;G|vLo?Uw0Tי5ĩmӂoX*byswFBg AWds1ߎ$:Wm6Sr/SOz$i Kirw ^5V$灝~lۿU" F=ie!`\J8Is 2?ªߦ\ZfX()2+5Ӑ
>r辐'n>(Ru9T]! ) ~u0Ϭ ."]Rt>O"lY_ #a!lrV
y} }
{
.3R>8Ta j5|ߧ7 h f/cbH)j+~C\F Ts t
g
o:}4Kҝ&Qk6'V)345tu~'\ۣ2fxdLwNZ4J_⌘p;Tܜ`?$ ezL8|6h9YkW
.\ohgjWr^a4g@ nh 2(/k־O밤B i8pbѬet#]7"Xz&Lͺ }8yCQWNo/Qt٦Y/im΅ur2M^.-V%
F֧xuqSJ03˅۱'v1 ٳȻ
1Ӷ{X"{~:IJvc{OoYok1|[8:DYRJ
`ErFJ * nGdcz{^/y*s Ӯ#zZե&z0?q^F9l4ؓf{⠱g!%X'Ov-Hjӆ=v5Is ֘Ҩwʄ*)*yַuw[~F7eX{рJcY1yf;eYx5둥$ء3{ eVYK^!g2Ts=fx)ͻ+6)2q-g .m]# 7&|~aOxYv[pg✙)6pOX{,K qŦj*cݘZ s;:t`ǕV i i>0
o5g<.U-6 |CG*Z ѵ%P5bq4:|s{ʫ+UQXiB1 oVM6xo R)`wk&$ <l>o
5}N+̸) w|2 G}>LU˦zգl
d |i
2Nu$#X#3% IuݘeˋY+ aE#'Թ%.R!Kr!U2#Ft qV-MfrDBw4~gȬU LV4i,wWSN}[N /ԌO^RTLEIKȭ0q~% Ib 贸ՠJWk,IXp TkH9t} c;bTfa?bR9םZfŐGq^/r?0M
X TXx {|<4}kdj|2+5qsZD4`/6> 2ҜpU#?ʉ0/
+קkKYyZ8< B IDATN(fEalx3QK7 ; .9+`\ooөsn &垯(lb}KZӄm,v,S31 'R.
FyYư[H-2tpUp1JN[ԕrUdZYv!<%F<8"O2U%\]cppcYÐjpˡ6=2`l
Y hJG1Ɔݘx %?c]L:f =RvW꼥WJ&mKv%{|=
)=էT
ϳ a')@h#w7 8j@Ο ۨlkƐZN[ k$rq¸g
FV0b\%)ӄ[:- w^ƹeTBisYލ3YEX\M[̦ YQeOc qw< U|(s^STy~.\BR:* d,n7i9`@{VBb4*O_J{ufɍnJYiߌM;)Ò]_Ѭ8-ayɁ 1ub
aw⸄W6sJ8 Mc!Ng f:majSTC-YVY;jbΥqD ! n oOqANI !̺Lbm|m!h)3{ݝ.44+"k { BPoɿtXRUcOulx1N@"pݿo}ݭܳg6 x)U^b 饚?' S ho`JsӣuKe5쭊CK6h~!=XtJ)L[څ|ސ#6A#h`Ԅ5>~DQVHaNup%#ySۜ^NY 35<0yӿӎ}R3?ͷ.J1 /Ew ~O簱Xg\|A؍dW+c\uJ5#%Y2֚}kz3m
Z9nđNr7"֊I̶Vov\ygm1؞!P&]Nsvoմ͊8̹,1Fi, ̉.<0G{).&NzsVD6nP :/kh3{mOw 9+e>G}2PSR"3D6|.#\bU\X=fpeL1u
a`o 7AؒizF3~by{.{ mzp֠`Y&[8e40[i_Ek\QCa}߲$WjeѪi6ά*UlGIRמmm<Ύ]Sy*`o[$ssWkV s riz?0i,Z[(]0٩C= dstN (*uRVK<-v4{ /[rcX(np$[v ?ҧ:ގSYg[1dbbb)wosd@52UvQ eJyUj/OR ZŊbDa[SL*S<?UA%Kc~ QYf~7O!aYV1ȎpZ"w֒$Wmwϭifn^G1]Sg8xBd~pas01)RI{O/ :F4p7ͧNrnT5e1bWU$$1hj!MQvTM!d^)Xʔ\y2y`CYQ[ SV};?9n vB}6哻|kǛO%6Bߺ~Kya,2.4=Ovmm⠎R97 dXgK}?CnJ%FisJ*C%/۽\\g"E 0LGuΐ!`4)kΉMV ZЃ ^;¦(x&p衐ck/5_ˎV=_[D yh4 ]=z|&Eȯn gu%XF; +>\s.ɠg 7^ (>kO=M;\gCM~ܟ5lk xW}^`'9V P4ᑸWm[_
kXx~ο7`$uc
o擪s\ e3 ) \Oy UXXX`0yOYh]l( #`ZϦq'
=q~{ {,y^Jo|gw96l u
8Wkź b<`: _w^0D 1Đ[MxaMS_e;h+PIYxrJbd.0 ǺmktJw06b24*w9߰tp (n>w3D\=v)+C~eLV$@2Uܼڢ+A쬫 ٞ_|?\t4Y0r:SaEǁBzǼ`}F7%Yh ЩC`LNLy<::5Fs "Ds1q 0d`['XW
yR:/ tdfYda\r6D+H7-~"E542T,!Ԁ ܧJ@&)ﮍ50nxMiM*`5Ҙ[m>7hu"6RD6 F-J^ΫWֲgN{Gp_.0U9
!H"jf) nsAE!(2B
LnL44No[Tr
e)L]mNn,5}y4nf%天KPB̽qC =0erHraII1}͍'aQ 0R6ԕ!'OԢ|>g嵛Ga~}OO=!8jKLwպU 1)S`ZTU{_Q5'8n,xFI2%!3k6٬n9{:g;M>0~u:K`C ylؽ |so v0L|Vot]83O]C-|SӧBjd:p[̐E+/8N{ 6\QDX_.5$ΌJ{yp?rʑ#G> eEoʼsN+x82r|U~ +Iu(.-NJߚU8MޯF4˜3Z>шɝg1Ji&W3|Dž: Wx٭/Av'uvn 4O|r{{: 3*\1Vrw3/sJF47lXxşzGkSjR߉i]tRK LESZz9=
2Pf8F<& -lNrvv!Lkڙ>#ǥ ;;#32EQHtGP_>~ {1]ToqW'{**6'lJjya`Uƥ [1[d4nN5 /u[8cMK 3n:\Y>^skr-qFF9!*gyZ@+vlk5.\R2yYH}eng݇z %
NWXY =KD
wb1."aݨUW8a,~(wWaδ$
4ydY֘S$ _~u#\Y %y tô8 1l}חT9_xz9i;ӊTN
N]Q='rb=ʔAҚTarf۵c ?uF7X
[ wmiF6/[;H4)vv@N3+ ;'2uͳ|i2S=)Q)Mk_O> RHX k ϶ ppã]J 9}$:
(R@!۔9XnGz 7 h=M&Tĵ#cl r-ƈFrW`Q*5&j}kU#>w<4r:gX?r IDAT:^O8 mˎv"זh]HIb|a;5bylf +78o]DdNtqXnσr'fb ?g.*VzlYsښWE ?
v ]n~,a1$ fӭw.q(I לU8yeHX[ "J?qrd*
/O=jSn'&fIi 5j8H@kVʦV!G YpI .2E`rR'YB wЭ
*=8_fV)[ np W̓o\UEw C OB] 3 wY,!n ;:4RfØ!pwe~r&pMWkxǍw9a +}acaΣ^J|Bp6}aQRޘm;QB;[zʮwnx9YdUIeɒZ
%Kv zږt۫^#gYjٲLJ)RD#P@!?;v/I/ma
=CQ8IYAy(ƺ*;^wu5 xB *\\Q+>A:ϊɛ6f}ګ
_i)C)
6o#1
p5M4=H"R# 4Cü^t2 0&'5Aԩzdn$X$U4C~Bi#lB 6olX}325R8 F 6J(E >YMt/5s=7Y;U ]k[cՂH0V ݼ
%QZmc>?wW?P)9ބlF7Ԉ"[Mfc&fxb 5kMg8iv6 NLn99iGѽivu&?lcX'kҰ "TKeh9Łޢ .^ +ʼnϮ9P*)82QeDjP^gfޕ^LՄ(_{({le":Z&0JL.%̮&^9L${Fq2\4[eY ֠mǠ0 JdbG?o!t$efW!K., Yk4:O#fDkO5pPQ(N|e,
(HPmF 곾aMŀ@ X]1~$BYH|B{6L8w qH3D2k+9>9#jW5hKg6#/ MrCM}l 6QpL5XTNG[
Ou[W
YRכeŽ;
|r N;疝G}x[uYu tvȗ#2+)/F0qu%Ex05#p
zo 6 fͭUVGb|`&h>$bxAߥ>iHu >bs]|gr u7շ=eeEg]
IJLJ~sw_?yG 4dY<3_PfJ1* Q q5Ƣ+k1u;? ᑉ
&kUNy=f3:SBKL 8]G9FR#QKXgռA;s6|RF0 eYVdsTH^Y}0xTj 8lUz^\+WܻȇpDɐUrf;kH&3 O(
f`ye4x Kj"T2}m=K|M }g_~S$ gߌ\MReAۈ%xJբs},+ RbN{ WYfO" +tzIna10H҆}!gBƂ Y:Ԟ?r!!rBA?gsRҶGjbv8fRBgמ-P MIB6·4e(H>2!Ӵ04Y3yYR|dorzEK!(fK"}H믚`*C}fv&(-S.t;wsavGAUAnFvEl}U a amgT茛/L Sۖ⅊Ku1Sֲ`"w z&]YlV>Yd:&RۖrFhk#)=㒠@FeN-kp47 Ɗ/ m͗E~{pM+0LMͣ,S3bk6W&*\\[W" gO Fv R oxbsrxTށz=)dn],]Lc m5x105 P}r iX&|JCwx ߐ4:z-SHxr'g YnXH%J_!Xg5w%ǮEv_ pD )Ki$|7V;V8Ğjb9Hʜqe[$|~y2|O)̢Z/ݜHxJ~is?Xᓯo4dy*ZnBm uJ&2tJ(t҇)oJ2TJC`jM$zڪ)q%)\"}EkaE0Xr]{l {^',WZ5p"EֽSk7|$-+JCx_2P,+ڛ[n?;GmW`*S J 3Kʈ.kD"+IMR[O6yo 僻u^l G#٭qd8Dn*+kSg_7/8Ro&(xr䢏
q M^n6xM MHåJq%y>jdG9aWzz,G g7"\nr_y(re%֟sFS[r| ^oCN`ɢgk_:$Vb/ļ!=; |ׇ |(ء:645D&* = d.4sn1f- x2G}B?p5S2O
7ڢ~" !2y34MiGlQqavnu!(8ggCs LdP!LoG#ҼAa@wC0q[L@e=Cg{Xj[\o|fPӇƸsofCswa]r4c@r{݉=pG,wR8cW6/OTv':Xq+ #N#8?G +FwJsR®2:ȑ39"P]=\36 8;C#LF"X,*K%LmT_+ߟ0SOC~>%߬'8[ؾz 02m"z1S s}XypNa* R)TN"YNyRĩV yez d2<ϳBXR+cĭ̻0{0^)Zh5d廍mJ9qc %괹P"r Ֆo<SƤ.m(MTGRVg| K&TG$^o%:
ڨkP NE _]c0l"kր$n:Ueҩ||dp "EsЕ
%Qmf*0 k^Ok}^9(ն([1)yn ʻ0\(^-s{#rhHA''.wo/5'7Xh62}L2\<e:^F Hc
're8U]ӛT;ר-Va!`)eOi
G\:)]MDXWJNw:/-Dw Q69TO^n7? elAB.qc=)ͱ6vS [ۥNѵ6Xdm+э)q*Hܘ,j&RQJf O_\rQkҖ:fȧ0TI$sDDܔ\YOx| z
34&ɢ -Lx$YMRCrn!\ɹHJ{+w0T0M ?8Icm^lnP|>8;-2sDڡFe6T!P4TQl^ؘ*z8mGBN_ !iEk_ .ߠ#Ov,Dvv 3f/lS
gVb|bW
3]
\=Ж2FNrl:`BלmS` 0Ў<9f_w uDpFC*qvnO:)/|~/䗪l7=!+$JB/kC} ,3X]n7ng :עU&j> +c9Z b?lr|UU&z}z? =t1麳uGG$M>x:K.,`nNG "(#f!En`ڂ K0qXb+3Vxy)͵a 97lK85$SAn,tfzD%`U& wRwf%CGyX9BM(=z/4m5^f4*1uH&%4̈́o]h|JI+ܷHeXeFLTe,S3և_N63;v/ IDATowAĉ$5e`IJZ _In+oVyeVWh+ ӧលOR1;o;Cn?%+?89#shhl=-kDD-j`P5i. Ox^}SAJ l6X weϥ=Zy_zgZk "ӓ
Zqj.|L G=>HV+UEat]+eT ~rzLj g\uq#z|rGc 5(Wo4NRR )c¬V"ƕAxzޘcˈŗCVx> K$jC(Ay@2yޫ~Aѷ=!,+0P-T|hI)[Lo m ӕN~A54~E2˟C!Z$R=X$Zc]%H*|y:a `<גM|?/1<~ޠ@Ռu.i?67xR6u/d{U -5 Qp^)o_=;zzQBdS;qT37 n"yr c
nf*5=+Tv& OęT"OK$]>sj jMGT"=&IXIbBͿpO dJtb!Mx:?UOne :']F,9߈:KIoJAk9OGvXj`:Ӥ@bhʋQle{JAr3BOXjܿȟL?G7j2
\?.癈 QhtWR9 ę.7RxH`~vq!w.䖽jɰu71 U*agڎFv3r? oӾښXGܫ7{\yH @nwD. ]1~)j7SqL_⏛\Nxx;1*t'TY ̴ҿh ~-i nqh{(H*֣VY ˊO%] Tz2ŵ>]v |G n ͛sƣ9t&S}ͷζ /@sC,T IV7%SfW$
ކ`
q"I ILR!< TYY2%M"b JQ+HgnLǭ}viiuЁr=6(U4c }ϥ}
eUk#J
Fer|_M:)Bcn/IxI-Z[*f M%GrXO?! mD'-l6cl$-;)N?-*1˫*[˺ b+*d9m R6|r#kN ˛db**#$.G|LFʾ ; v$djPCm"9d!B%Ait=22C 7ZG3d]._NJ~Me BZj u[X~=F&ȧ k$Ac?pa!!c cۈ@o@_USb9݂;A dc}T&UHX i{
%mi֔=MR
| W'Y,Rt2
A+kӬk)U=!Q2֕hH2+= + ]n$NJ&tNFOigƮ*ŹF9◆ ڶRj% KQ&Bñ5vl)E$20z]ﻕ(֙M[xdf`~*& z/"wz@n%ImKspOG*6 c~p@sWB$ϟ%܋mAs(
u @{ qs A'aD
cre&o(ꛒ I R{}^{/'dvBhJVJ < N"%_6ZIq(IbZ)1"e]q']v]%I`}V@~dE{|2 fۮS$}RI쉌̼rW -N*[cG *H5X0{{b@XOջ|&/VToI;MrDs!OF9X(P &u;<(=6 =NE@ @Kz(uD,eݯ~' KA
^3g2zJJL6t֗9+eګi]Nj+5yaa 2XJ8k l
{)q[ꬠ?i g=XW^ Nuȸ˅gC}kŪ^-!/>_+{ LlZڄEۢʓ\vImeg?9OiIzWu&֙(ɳ77L=%'F˔m o79$]7 S
Pqh"ȡ55 uԵ r>3%oe!
t"<0BepTC7K$]&W[VٺB2B\y;\? (
1FzƦ eGRV9y$ ҎEiSf%ƀ$s <+{As]_
;oȞw!#9
3OC}n16 #<晗K0 + ,h5B2 +M -r{_Zo5ə+W$IB_16 Cdg, J݁7- scND agX@W_lnhEm/ ~/7KexfY)LͿ+IL7H҄ Ȣ硔D&yfY|cHR?,D72KN ݬx(x?W2=#SL syj|]e>_-_`i}($)RQBx4/tw?AGO+ |PQLmcAƼ}Sd/=NQd(S-GLmy:ZF xY@)8fIϦ8ҟUߔQR$v uT8궽vBg'vZ7lf!M9NUx; CyM|NmR ԟaE:Bz \ry&$W(R e=o`ݯG)Iwi.ͱ~ YV. C L+VFTC"bXD Y$ bgqk#GA&T# aeQ11s¶*,Fe)GƶAe>_dP9hR9XjauCh?뒵MJCbl+>ӂaR6)/ۻԹxm\]B/*ioLdw;Ax&xH蚽NfZXeS)A
&Qg-2ǣ$?a6kϞ]J ^0C v\?W-Xg xPai^_ܶп}?; eGV/ɍ2y>"H8@
LS=I]OGfAPP "Ogc M7~N eP%f(J AL R4!jm5Vi./tsh4H"bpA
7 *qUKqUBLs[&2t:7p_շ.sW1p;O5yd
ʜنFV[qҜ5%E S)azP/ BOA9! :Zbځ YAOwM4EE`B=vC\TmՔ}\:mU.a,&Δ;{,+".?^oV螘\ M]W)yvB]>f [}V*To/rXaocobȔ L7cw1nzczޜJ96i ]Dj TNLh.0_(v* b}Bf^vo=%5A*~+k-{xt[[[r_e#V :n bwNuJť
֣.wLϥ WXd·=xaJ~ vY_4`,e
D!|xG͝2A#F͵ڼ3gz1sorL4"avT愇ĕ^:G>l_bu4+\Fo ʕ \{
\AկCN v2{˻_#~k cd\4&oJ75LW\YlhX<{]2 Scg[ҍ ZHʌ%U:zCI 't+dh$IST QemǑEZ ?2φ gG2T^PɌ
K德Fق}(Zg Mꬬ=^&]Ƃ3QmԑIv/yan>ʷȾ K t䐹&r\7ǰۙAe j g҂l{ں"pD\R|
JoO}|՛ly
W~9V/Gx;#&!( P>y]] ! (:Yo>-Epq{//J_.(.KZ E==8tH1>#S kõN.I* 0K
=Adɬ td6Eg{h5zRdCԨZmF{<$|AkR*?2D6A=Im-XOGٚ>RS{+L䈬UScw:om}pR)yu\=ա[ppx& U8AX<@fe"nlDRHd/Jd#ՑV:fHqS)/MyTJ ;7#ᵯmjՌj= IDAT1eaA z2QYxOؔɾggJ ߝ9ڝyOt f!$I5ՊoGvJnz0QKTylZ*㉌ȱa
MۙIh%z
duB;{˒p4FM9QMჽDnQ_^^ Asylap?Hux0eڵ՜|R5&Ee+{j9H IyBxx ,50 6\*qivlz4xLMy "}{8JQ+WJs0:688.35{Jڒ1\[ 2cJ*
5B Է)Yƒ:rMR} Gѻh-y=ME^*S TXkEdIeGd7ˀ "Mi4)$Րqmٟ-eEv 330t 49gL>c¨lnƭ_,az){jUYh>{w:zH[JW)[hٳk076&y#|h
zYubn) !*MEuH:-vFJ"Dm}OO Az(Ka#7Uaے|DKyq=g,z>溕sUVGu[9[V-˲
σm 3
` 8GYHd圻A r ιm|lꞰ
oy {-EDqD٤U47,k,̱0sX(Kdҷ22[Gƍ}.CB1`=,]q *NLˎȸL(g^nܷ{jmNe #҇yDyT
ݓhnMkUM\Y
-*,ϭ@*:˂ͣ ƠF`tHq>V{6[JI,͡d`{['f]NUR\'&ppvUz{YŌ nQC~ k|*O;Z:
0ڳjK5!M"ο83YL@sV:{ dEl
/I:rB'kXuV*v x~@P
; fF^c}y/>ˉDit C(Ltpvcà a5 4׆t6# \UʐHD` 'On=t%<ݶ-{hYO O°=#s\wP:[Hy6a0LHP< j
Mgan)V*0 !̚Y>M P.Ar:QEy
zk01G*3h,ٰ%2 TF"Hq&[oX؊%y+>SxhBϰ;t6gsm13 "E #;W 0 5*,LS_]H}i[6w| <04 vϬ藰,bI^%'?:fJV)(NY mk2 9ǑNA <'d(tt7-웝fQ&O>W$tl[RYIVDZHJU`)LJŧLy.Ƕw9 Zď&ז:un MJq2
y֧N/M1<6F._^ՊJY?DBG'~R*\ASL i%ڼ0t6?IHr
e6%.5}h
':0$%-|?H~#%Yaif&0?; (n#(2yLxaF??2 &"yN҉n-HkJ
N #?ziy2waXъaiNN&afQǫsЌ"l
c Fa|:;?˧~%s1 &3o&%< DUN˘ium9mqRc tI]._RR:/>U,~2 n fjOUU"gҷгy^&^:*X=*|Hz mdsf|UźʰFhZDJusA.Ƅ nXJӘ$ڲMNx3X
iz$b[?}mM__]3l
'Lx^Yc}e*յWV"jVL#" ,ɖ))u C!mk2I-QDY װmھ|dt'_1*b Kt r l۬h]e^ܡk~$ $Od/dۮe v?h5ߖgyhR a`KSV8X # (=Aܼ-rB^ɃڰZntd|;` ^Ynb+e
lj%2_~CO266ʁK`dv mX8"1uS>PgǻPgL&dm+{oa
)%*V)hR zځVD:z ܱe !,z:a 7hJDm^I ŠJڤEQ`/( 1elԩW։ZM*KMMxYgfiy!lK8mԷE?RG+ڌyc\ w~zY[4'~GƾsG9 _G og :̝1:Ed
k$ { ^e8wЍVs$Sk$=5
<+p`vІZ'V;"/ӞANDMT]fzM緮5BylCL'̲kMyrEO=jeI}u'+l2p/0w'q'W̶{شc7nrRMK z 3xiFU"ME sJ'D'F10:leZLAE
Jj0(V
X |6] ˢc,Mz}iI!B I7DIeQQ[[emy*s?{E+5
(l?FX0Xk&bw^
}w#h2X=wW i*eOjӈ8~4g5>owбlw_>]xV|A[]䙡5&VGf.!I#T"AR+hIA²왺B%3ìq&z_>Ʒd|q7!QfmSX|)zoft.0LMZO`Kfa2 BMJ9RCCaͬ*\8'HXm;<[* ;}Yxx5
>BsCJf ĭk]L'QDqt]^)96JJ:h6]zF.
~bٶYbGk!V((Qvq "l*0}i {avQ LG/y82s,.N&gXMd;eR֑RFf
Kfw7KxMKmTUZ FUI\[' D܄A._ &_ke
g
CƦ88$d?JL~@Gw ݨ +V
ˬr~4O>,A
tm40=vpIـ0N,,j}Z]݂g&AL0Ux^ ||30Y]k"\qE ؿwRgoE Cܓؕ%
Em l#H OU +L:"-s$U~˭BO|\?}~~.G6T4 ~O ã]fÖ4 fm*T+pV s}L,e̫=H-?ж ȥݕ- a
ukLLOP=$ٳ4 oxvO0%hOUti%&>kí2ACTs
h)p2 +5IMMܮ +"~rx4[V:',ÿS7no"uWbT{6wy^9{0]r5==& &fK ,vN10
*,lLy(iO m+Cr fR5\RWT:NRZLZS-{O*ؽJ'y,.Ou}/}O3\P$n l|Q7*k #2N ': h/SY0CܨRQ;s{?BP p)6 |뼶Y+\ l i?*s }'xw4uڭ
ￌ
b:GDxn"_.QP e P
2xɛEb_[_tdx{Acq |?'3g(a'4BkO5@?suhm."!h]jw7gwB +'X:$6/uqDXN#:IB$ML(G>!P8o'HV*Ψ&/'6Ji 6f* /6A&kj5*אJRVu'jҬVF&q 98;qm:~gψe 7 g %%['~
LIto"3|_~tk"l46Sy *P YfC)H&ȁ5ht
[x70q _#j6 twwt*ݲ^8CwGQꡉ" Șn,u@QiFٳ51=8擋l 3EZc27-z,T$AgnR$kYAK&wmsR eQ^镩&_x|7_ f8zWV&x~QT F[JiwMv+4U]˖sm/v=M6L6 L8 Fbц]A,8 멓5O1uC7.h YV
7D,I)!"Am GGSC֩\{9y)>\~)]k&)AJ
"l#?v~ofHYO(E I8:kXhc^3VVcVAQ'ZZ{K\qhD3(Fң1V86za(~QB.|# C tfsZ& IDATdsz`^.b綘٘4:}j Q("x!*@e@ap{ :!:*m!RۮFl yaaH-ý*=#:[dry07cw#,M}
\d >P
ߒKy&as
aLp3!v 1223g8Uc ]F['&1ME~/~Ty2+2a 5_7sض'W, -/*ܢppi(
Y$tPo }K} )3k1~*? \}Ul& FQ
\25U]TB+gutiI yoW"&F*ks,NO8O2(ъb2 A?[=ڞ9ESS<+! ?LXpC OuXX]v`FwT"Ihc@c-Ć )҄a$a .Oh$)^mQ5* A)Ii^u<
dB6kK
}Ʈz*f%B
T%SYG!͈O1g PJ8«K|Mqd}esgYbYΟ;"ge7ӵ"#[(_I'zA1"m7baKHBZ >)[NqU}\xڄ2%,WTTҼ.lW:xm
տNl8
%d 'W(m5N[FdO=Sy a.vA rxRRp+2
֗[{c 4gVM ~v M20tr?х_q 344 /|/-cXKHyo z^4uHEhthӠ'ڿI<-DJSh)"aVO pkM#bl23mL Jz҂1YFF*z]VRo^avf+DY|/A=4ƫFyd4<t\P"{^H2:1ܶ$vU-fc
p7E6$ 5L dcC' #ѥ:YgXJJi ]fx&n:4P3[vM c"GK(?fe8<Ӡ9g+~@A>P>uejkkkҪ1hIbU7 cxQ|XŬ$g tTr3JJo&gڱCƥ.^xfί֦Xk,b,UWNydΐo(c k+DWvqf,/RT^+l8iJZfу\" FKQ奄SNRL;QG7#$ Y lǑH kULLLf7J'DY.'`f0Ί笇nﱂLb0I9H+i!t}5^zlL6k y `%ϐ' )lل. TV:Km
MM2"X(y:G" ѥs EA&f蚕U2QlCTgofvvcO{u]sOUSI8{݇\2./ёMDN'w|g+T|*Xurp{+ +lvߘS3] U L^wBjKO
CWv a,+; >~>T,؎
^Wq^(NŞj@ܨF9=6l$ l6E(1{]M<. .2s_~g?^wp`4K9'4^g2xaQIePƢ A[D2GFveE͜#Gemm2S@yb$gL;}TRM4v$= fO1v_{3g_Y؊ۄPpwc }$ C&㹬}igV&K.⚕+"5\I(Vlwm10fZEsumAZ7ڮb2
bsk!R]Y kJ;>sfeͻ67 Sfi# rD2f\:T 8oc6InVc ~œ,L^!馋 Wd %\/L+V
i~ZHш@0g+P^nO ; ڀ/}݅ n >pSȶј[B|Q!J1A
JSi L zf=}vsҟY/f=E_<{O?yqV+\T0 oo2X'%) 'i* ?3?a`d
O,y>MOm]7C=Ⱦkx>V&S 䌄l5Q°P`ua2
`=>2naNw7I2nok;'K;
Ȇ F!\ʨ1 iy bKSmfmA͠!| ѷHNFL'0=:ǶQ BıB$SKp)xK1<[%%ū3sf߄> BO3k.rO3J C/wڔB(gG^W x}=ol14
#WuB ԣ?du,;/q-Ex.>5Jȉ+k2?EuyRŁQLqV'O|8]cO'~+gt[39t-vbw ,9ƎNƝZi}ߕTgV1J*uL
!&ݤ;2JxA j7xO;2
7F ĶCQ]C '=elm)r: :2D\U6KZ!wOF&˟WF[ 4^ۢ8jQ_]ٳ yYY5Uksl0B ۵92㧖Ͻ8i-˷uGH!'(
YC=>W5wj
ҊTJұ>A) Z7bl/-N Kfwx<>H2 @g_8`Gݲ?KJ)lSbnuigY*[2[߇(oCc"7Lgw78}5R <;M+nԣwstts d&rOK]IB^G$:Qg8e2#t $Jk~Ye< RN-j& ԛLRRxA=qsBe5K=wO ){5+k;ʙĬϞeIVf'qLV+е"^Lmߏ'8jQbVNQ?Y֦곾.qL ǬS lmH S %;GS4k?0*kbbϭYiDĨU)
zRyD\)xVt3(vpnC{s6=AƋ;L 3,i( !kRfN=ֵ%]}to sw㜞ǻC4֙; O ٲ<Ι' זY:P:p8gwFN Qt;nj(r/(y]&%#7o& [mXknRNSq#
i*X#8e`v{###tww3??OhR'.1H6g[cmĮ +fC4P#]8)$,[D&`zRm9%oG
q1(n~NSq;?gܹ W
|/ fГ LG''^z^(t#w|~z=uwһb*s9Ŀp6{Bϻ)=;G Z>/6qL?XBOd;s4aKl%^QQ.7)颋\*5/<
pծ.l
Y IPH5,UK3}9{4[xG2&̗(3>J.$uZu+Ϝc 1*q' C"}}}lݺ
6w.欬뵴»haJ$֡t̚7g#yω~>HҊf'chhfXKoQ$ʜ`D
Rހ]cWf
5w˙ӱRE{j65]A3R=vWcLsQ c
|ШU;}k( .pv ON,Wh 0E0DRWF$UC3K&i3 v5wY LFnl3Y+Tg.Z_E- X7\b-CfX[CMwT2QR~\g
m/l&QՊ˒IpF{T,-He6X;IIk2-o7YaS1
q0M
_k0!Զvy ӿeaDM&Q^cQz])lCAK ' ,3}>C^{)(dy4-XQiIME3,Q@o_/.F{Yy~l %wQ G;:
ZQaV&?U"Y['W0[-ȖčB)V uG>dsD:|%uSIz ڋ^E^JO jEn0}Fܨ]|
;.Knt"&=ͷdy0pufЋ t`2vT-/?TVy>ozx>^|WdDZrIMT<>>~~6$&!\Ӌ6g&$ifW=Gj;MZRS?v/Qz~momEp$+6(d]V C\%WJ3^Ď{J*3KL !#}CX7o%̋k*,R&` 1JIאohjZ6" _^׆)Ҷ0`iԫDͦ;ZB(I6_gy꾻Y~q0Gy &Qmo:{,wa8ZҬ4 ☟`1fΞ8{e'JƼ&SDI=wg2oB:::룫\.G6%aF) ?Ni4y9^: 7F.5 g84{ E#g+]짭4K&f=psq= X3rT\CظH
vggvܨQfynE{ڸѭ;s
tt D(!Ȃ6 6Y;6bus<83ʭ8ov@6/x|4HS 2y
=U4Mm p#dQJ z@qM >s? 4
FRg_gr$66J9()O03IeezsJʟ{{ַRK-Mk9w kkkn kCJI1o݆
-o U'mXds]v!R/'9?Vv.ړ38_JDmӽb~`2ԉUJj4R!ZS< , Ot$q+ּm)OZ*RK;2&20@=Pĭ$}Ȇ Bvl&i2$@h ڱ ""U0iP=P"'[9C#͜*a@^C( DL̫UU@; fewPvw.%*?w JOq IDATɐg®J27ıÜxy^{[=B01Jctn4q dSvYhݻyF!=H:ٻTYEĆ jʖB(<~bC'] V*i⚽>=e"AhlO dJ1 :( nA?Sg0[
"6B "-`CROI$ ]3o*\1vE0~EHsujY1w4sN C ݽt
;4ʎWueK -r8) tSCWc㖁6> ;cîeX҅J;x_3EJ
t[Bx)(Ev0F ϔb`2m&|{{?-⩘%jr[@@{Ze ̑Yfҟ| nkynCwO`қȖ{yarW2;;捭" !4bY~ P((
T*w8YZZⲝYޱR'o/5<,x\l&]@$ZŰnB)jx ŝ>p[W<<(X"d
* TV,1}u d96elw ÛS&fq]W& ?L
Y< 7T ?^w0E+dz;4G 5Ar[^w{ΝsA0t;<\ni+Oy ^Yͷ Y䎫%[FtהgopoMք[zz> [q;} Sl6N$M֦.~zowU'D hI kG >Lvdu f_"=<#<.=_+f&N 4u&O a~/Swxݶ
Oجrl:ϧ4 x;
BvG=kb!YZ]p {Ie2µX+= {M Ƅ `v%9wț:Wb + b<$1Bp zܫ|Y;nȕYo8O͝wɞ={.Cg*sb}y%μ2A&KEo-ٸk vwd h%ױ1j*ө/6
&pG2_f?'(7h/>J&bd;\.](gp\dе{PXz@$9z \Gj2ym ˳YYQns>v1#sl
]^VL{P]a ' 6" !(JaʊSt8 3MRJVWW]R l_ iQLifPyܸ9ϗP~L1ZKr MD!~QoS6<qn>PB[6;vT("c]s}ؒ: %%֔$,T/M' ÝNn~x7,#qfvVUatETWʢ~5,ϰ skjY2( :cxu-Y\\СCtttPיw 1xBˎ;-) xS ,ai$+[x(Fs::[?~ RVY_mc8 7WE% - }#;[ ٖ;am. ן[/G1?_6P(u6\e }o}+. (3QGPKҿ֒+)}=fIRaaa(0 jZe߯"d2VWWR|צ[e{ _&|e4%3ѽQbЭ&!eB̲cȤx)G0 .Kdn⇝
41%Ϡ@ xl;GlWO'/S;uW"{d9{(9sOLO 20 s&%eSA% ~^ϲ^ɲW%+ے,ZEQ) H 1`&瞞U^U%Y{~uf_9tPD
!gM} CHRa (VfۑU(igR1- tv3O?F"@Cc\{};yz$Hb!
O|-);b Vhj$O DPX`u:I8aBoC"h ʥ7,"jb=ȋ==|7vSmkZ%|e0yafgX nݺ&nfBPV o&N9w #O~Ŗު="A܅Cϳ#}H2CyySO& oii!NǙY ٰbp&!H\.G.<\%S.:r%&V\Oj@V?l9E
U35b@ODG0Wk<{L2j@O, RanRɀ& ! ֨,REZں4'q sWRۄdAϦ[#~Wi K :p [nea2ŵҍMd G|R9-cYZt Cȕ0&DTÑ_}>,K#7U>**WpBsN$[_5w4CC-ie
R a.ͅo~/>E4'uqe;BN sCVOK5fA(u֛ueaG y7_in g)Y[^O/&&OQ+d$:rNX' ?
7@CCq3>>Λt<8Mmލ#y!V\穿MNH};\. 5TTb``L&" g3``jj/| q8jd2뺬y ;XuI KXTi~0R枝I-UΞX -ɯ#JWy9)%}9sƩ, {Dx0@CC} LjA0r)ϺmB D"|}`/{Ꞽb#B]|{xH
D8y/ʼn؛Ad۱zC2r9?؍[nL*&ZDUZenv &F G4@EN< yDaqZDi=@'r{ |dϼʶ*++Ό|U^j {ei@zz3uԽv>)dfTq uDټm;DYiFF26_ =` r9>ٳg9x`KKK,..24445z:y'i7L5.ʓ\ 'l J=@ }$ SOqȑ l1(dY v͛innl6K*bmmEސiuͱ:U)i ]Z`_' ߧ[:Y0?G6\nL$8CV# Pqb={#Gg g;S:u*LJ'sر} :DžWgؽHu.?hKj>И#", +#iczW
+("-/qKHe/d &Cc7 :ئ">Q}ʥvl
Μb4OٗnɍږбͶדnvO%Z;３t:}C}>v :ʩY-ᏞD,*N@42܇,_9?"R,s
}zmaYRG=z Js>k3c39ҲHd[^**ȶmK:楗^A0wyg^r% yb ˜z˯ ī).b;1N|c}~2̃~Ξ=(!J ?d BEZZZx{,>U<G_!bHd2A&EoX
S+,.1-5UBQJSm| o}WJFjU ?%NxRlkgֈE8PuCqePFTyb#t$pZ gh{cLuT,}2tLXBܗpql&3b7 >xwh Tybqn~ rym f/!RMXF+ل:de xqKl][!k *a6\ L >jm;*Me+ci7RM;ml+=J4#3xB?=:* ұqrh
sjvfORY]ODYʙLY]]e۶mX:= &.wXd]H)Vm6:,L&juKTK&
64S*.Cy bjMMMtuuqQ"gΜ ֣s^m/SXBJK%
'|wŦ !_ v"6 `gyӀ
&ƽ,,<aZ7Iowx]$%bq~c*Eas-p5HAx jmsF,!B ֮wM9LiYb"1%H{","Bf;9IXqO|泬rws[_%@%ܕX}}ع^p+g= ?ݶ)]бRKO喟°q/[AӅB %,lf^^ n"˲m̹tC^8-Kmi Be sP i*WwBg4(j;ikgIYL!Bx< gΜaΝJ1^\ԩSڵJ/\wVuťY]ÇA:::=J癜矧۷A4Ŷm"='Od@[uiCV/'x
2oEOdW,}5fD5G6{W?pͧyS*@BHsnG Y^
6B 6|6Bjj_" )| ,1b Ӟ N7X?7bE"$
˿w xa/ѾMa8֦#/M_@4"ro@ 1pce.RDi sB2̔ }DXCW_x=͎'K=X^] ]< uGKYU |pb9PAR)+=Z1pR߭t^~܌뺁0۶mq?|>ÇYZZ矧. |A=em;P J\cC+ZFR{Z ǎ WrxO AK ב0)%d35ו
7WLJm
v(ˌ]-
,-<<-ɥ 6fS?hl~;r||uW\\rH.h *}h!KԶ$tŰ]bJؔg[!(wRϸ
2k Fl8i>F;i1 ok | 6ں=86di
voq j߂p[Wu=X ݇xsNKO?CoUMfYuzL=5B1zɉ}D5V]|XR) G RzG[`7j1QL0|uzܦJi7V*ZqG,cyy|>O,'%Q4W\-4. IDATaii[n^}U
?:?&
~g_ժ:QHTו6bse~&xU!9.nGDsc<+j'͈ΝXM݈v(88QH6*4N.D8gڷ!NYw j
1 sr}O@grL S+<}PYAۉP\!l'^B`ֳ۬nRG tPaX6* ibѯ{vx*8faj WAe444f)sX^^kaii'N)FQ.bݻ[*K˱buR8۷oZƹ3puyp-2|iX._?cccJc|w4?pZM3d#
ѱ 9Yu.KbulC ^DZ whLn|qvs͠DS #OOjCoVѸf],r3NXjj{RKN F17A^R2q.~, cZjJPRٳg뮻(J>}-[066ɓ'ioogqqH$? G Z288 諫u G4jʹ3^ 43q4
- MeU\k;!,U2Nn9dV
!GgKσah_iR^#y7
g1f= >י%Ͳȕ+WHH)crrq|2W^套^RFehBΝ;Y__T*XZZbӦM\z[vDpa/UkPH,3rU9 3g]N(x0XT*X tSwyۡU[[?X`U*/
֭')ck0곶
@l(BK0X7F3CiYeAjn $ 31GPu.t{Рao+&]O*>hC`bn|
M ʣ| "ZK x4GV BoyƇ_aj$Ρ"+xgVeY2?Mbm:*';e=ij
aĭ!m;H-IcжU7hIU4!Q ȌXv0FuL0ɔu$Eר|j랟Lw ﱾ8ں sNPSC.333,//.ht: @-JA.ـ]l۶T*}}}E'm9 l t
=]]xL-ñƶRTiHiXkZ~m 2Ų}3| -f1j*w(f j]C
z :w,%SE
UTeU,K*.ڼkS- >uqXf%ҴG\s+g|}y'OD X
KAr&/j-4р5K 6bSԊk$rڕ:w\ǹDK\¹-s
hK_"p +p*2@ݠ4GێCMxRqv X|]?*喗J%J?RC"`mm~UO ;SN3 m@y@c$1bB R[68(PXy˗aj f$:;EeSBT8ǡ{X89IG;@ڡ9WGH]n-=]7 \C_ľcj5TaZ/꼲 Y7Q"X`K(k=6 c ERǶKƶ$c<7_cgyv}_jnq9ű
$IJ/!+߂,,bo"qqv3Vvm[U"J+Z2볬M݊^`z ǥ,oB9Z7aj9c\]a_M2itRmb,XY`q ;
cS0#imvAI_`nIsrRE&zsPBn8
j-Ņ GyMшZ Ukr-ACiȳ:`~B2:!Bk
VddP1 K+{8瓯.!H{2 el3YVNDz~Nլݒ/ *!e~7v pQg:C[
M"U* \ӯ¹ J r{;u MM\dRaf@]l5 4tL]}̬
F¼aGgLT&0$ ,}/>/(r,ب! W9_ soC-Y[y>Rd4͇;9W,M5ȓUgh߁w t k 7sQYLy }Ds 5?Ml ZxRPȅ`=>Jh J@X;cmvܦuHֻPԻꙅ3BK>l-0AUY-h*C!T,\:SnHM+7W_`ebc[Ň\)jMpR)4333 :t/efgg!gS\V'*Q]6
进f!:`IGS]x_{$ `}0rƧ$+~W2TDcB*)h\6CkNkTVHU"#F J5_pu$=RCF 5ڦ#T*Y @iyL-^` -)!U(C3?`nlK) %4ڲ Mlq,7f؛Ha m[܈hhşb x
t?նET6q/p7|*N *e)%vv bq:#-[ժuͪF
) [zK_V*zt+BZ&V1~< \VY SYt# Bϖ/Odb->1n;,2|uc|btttUvtx=˅>IKvn m.ܫr0[DBnQyc5^8,TNPʀY~X ,(ں@sdhq%BIR,)}nfg_\A(Ŕ 4e!%ke_*DlͰ)MPiOrMz69_}N۫ba"F-I?YH1 =qCq/!=Iut D#6d} ha(Wf.8
~.#څcX{:~W ǿ ; ل^f c*Eb-!U-3S趝Gsb
0Ѥa|"d;) H)]YfM* }
ִ`UhdMUI>s,`Ivw]zy ' cTcGAX&w*yQ\LBZz Ts," 2i` ~u
Ƨ/_LgHg0fv)@q5XL_I!0, V/
ԟT42q/æ
G( v lpKskܒrmpwM8_[}!ބճaG_D8 CGbVAԢiU =H$zl f_9Iѻ&iH "XS8 14u K&1
XڲK5]c B%4UmiV
s*<ťYJZ@C͌R\ѩx~gcyaK c pxGT?Km V6%ػmux#UĜU'|c9XLHZKժ*: Ri@(H՞o-
ldzdeCD7 W˄ J:2PDg%w*;6 %̞T| vD U(,XrI
l(
fcEu
"|A*JEPmT":fWqq531·G9T/96-%' Op\e ?0r ڶBs3+j{-Z._+yJ {h#hr v숙 ՋCky}B
{C}4W]<,f V#'O7A%"&V)-ϓn '$u.
e.=5,&R-ҍ&W$ʺIJ$ -SJ wEp%U"fF$I+ >'=*
vl=[T|.LL\߀$~6zxRaX#ZE*qKVWb TIp eʽiD[8T]WĖUOhhF=0ڱL]G_CI?e`mQFLJT|?lɔ꽦9\ =ɑM?_D7;dG,
E4ϫ cpY]879gP-eHPXd}*+TVXy88.:iF Ӕ ʞOcvZ!?=쫧 @zzx|;5,n?h#{ 1혨.fs3R'2)Ȧ,=nQ ]^G#HemS$ "GLfMXU{ e'Ya&nӶ0ls`̮Ҍ"T
[V= R;䡄T~7,"*l9|/ Z.-APZū5"Q&/)J2n $ O!!6:;-}Ύ|a5TRҖu@_EEG 0yWilUiA6y(IH4ij z^#[9A{6뒑)،Iߞ)$I&#imtIڛU5YkjFдDqC`1iWA!fzkTvaaRRX$Pgԇn`-dpꋚ0I4wXBߕ>*"Vϸ OkOZ=x f!vW**7&nlȐmvjZůuU.UDc'.d:Y eeD7 &ҳhW?1NdX<IMYMtV'!ʥPn5cܰ"#Pd"@fU\Զ|nVDj'K"HIQOܯG js%y__} 4 DG|se\L)NDG &0?1bΝ |,X?<,ijn"9@,et h!VQ WIW)VN=u
-$\hr@-^y| } 0p~;,2iNbR Eb<5W-Q dW tZ+^_*%g{C }#û ێB` h[JpyuO>A9Ρ/u,P3yrF=ɗoWVUZ)MfFiv"7e9^\㹓_f4b-]!{ H*k,]yiJUrMR5 b*c1V^m"H.j1SVݘ2I`}_apCq- h2'cjkFFq[74HR/< IDAT_2{y,eIV'\=ܗQi媫ֶ]7x1U =[㫏4)wwKEoYvd' "p5,җx+R-:C& ist}[R'|Ώ\'|\O-
\鐴4AW+4e 2hԸ@7S{9xP| [?$u ""&"|
dp3h[#dFޕ`B q$XݸXunG{6u
zw$ ~kW3=Uu$NNr8MlH{9nHeX^Yg?XC#]{oy"^L\ĭ*C,]>Sв B(WZiחA^Zd0H DJI$TDD-Pn v$F+)^1¼2y
FTB!̖R B EYHᅋZJ
" HDC}79UEy< >>= 2m@045-} $:ゞ&d Q=ޭX(}~E2$^rP)>]m-}cdvHa2AQ@Qݔylu ̦IY%
Cg`7
k4 Po Oc XT}l >
q7%&J{kCŁ* ]]7ں؛H!qh!ï [J ˉ{˲m"4N"E" o[L~xDXQ7fhZU]s32O~j\D.yo} ^۴lݯ\q
[t.\adz%i@S"3g%ۓR+L-{dm6{7dR&Tca .PiQ1/<)yis.gG]fV=rYt
ښY(ȤBp_{9i᳑aYɾ VQ.y3$U=./ tCG
-2i_&\\Zn̅2:]cv q0__'C_U. L X0^)>鈅H˸H ,>(<Y/*7i:$!dK@&jK[#ͷ&,[$o9*oS&N7ұZ76]eXG-z Xߧma\ϒ$$RD
Rh DXaYNH<D|'amj"MJTY_b}*R[VJ¢Bu=Oie
T~2@۶%]-]j*Y ϙ7zs6o9`qcr˹58R}lI1FXhv D40luɮ
-~=6o!zY233̪rsYm7 vTӂ',c,c8_XB3ֹ1 $b̲! vZQY|Q29/yiH
% !kLV((
&` ;k2Q3yA)mRlK0Sљtkh]#WZ_ eGR APnΤ.჻s\g
E"ٱyбH hv!Dд*( {e63A2Wv,@V.N, ת2~
L,ײ7SXdynDq+Eʫ цFRvv0}L'O5ku4h ] ,[PE|kN4-k`7$$%gFe@5-thCcD!$|#6V2{=dI
iFge
<)qD4.
CA+U;N/}ΐLpC<%֦YfKI: P)WZų|Sx \%J&Q0{M Ég{&g KK5g]N5|KҖa&&r T#7Uww1KdP_*:6{u U~=uzoi4 $Ytl8v봛878N16B&PEuHMgfN^;'ќs*O=użSO弼;VNIMֵ1ش*8Xљ48\R PY͖/t666\/ov42"6-2C
E\bSő>y`'vxˊ!bHf
Æ1a*#mzkK*`
oCdΦ3g"Pw}]sMǴL<$voU"/M.z/Yץ-Ü_Ġ%~h^kw?y$YCfP_\,q/l̍H*sͳo( ʆ%0 6\hxiH5&Ihښ ^8g풘+'"<7~
9K=}FpR)y-ܴ[<ۗcr`j :4 |7ʼ|`^ybb2n Ibॄis>`۾d){|yDE>~%Jwّx)b طB(B{_n|LG
)sy[yob}9Ļ-L+L3G?XijBmBFR*<#)UPIB GIaXCۃإ<ۘeAff~:g_ebbNu|)oy+.iC|#C7{wwwX(a+7X131RqU1k-!V9[|6wfX9C
,p`*\/Ap }bs߉x`:&6lB<[Ә<©]O_cc(e+4I0w B<ˈ EbE2=Bʆo(q0[J B|KEIM¢1<@\(&o[|z ״grjc ~Fz'yê *cفXF@ӳ-Ml^*\H J~ "! 9P1kݜ9/ OY$yG1kfC6dh2g 2Хg14VWji G8|&gś.O%ʵ ߓ4>H9 "5_
G
4?YIhܮLYj>fb&xk:)%-yͦ$_:7cn
~nW/0Z6& _X&άL4Rm恶>Gspo|OV6'L1a"E{fҞj!1j{2-\wNé$"Z1aJCGƩ/84;"3☢%4iϜaz3?C~>(Ϳ8ۖXR|b:xfnf$&K7NO3L:|}gmvI VFJFCE>s(mEbDNP#\`t3燯vƳm^:h8▋
pAՋ#FxһKI,;恊oXGS~B sl*cdH1 cjfnyll\˷!WJ#rUl\{HGIUs =>Z0"U+ llxO5?Oi0?,⭫FG Fjser2
"sGkvvʡ9yl_3QX !^ʣ(T
26^m iEg YkharM9O5x3^y[WոkFKT1d:3MNz,qm˗F9S, Kme 9 so332/;&É%K QX
Hb<6ƒU 5iA&g F
gj #L kt39?5\o #BxkJ,'`$AFj3oBA&,̧[楹ye]g>b4T.~Yq8Źfgc7k|>D SU(E8ew`5u> I#|\f4Iyq}
f}ޱʭ* K] "MTswϣǺ ^sŚQeX$P$\3 >ϝrt>eoVN kWB' $Z(OBR=T[/)Ƌ, l", *b 4
S^w>2_O@OeS9N7aEx߅=~'ƌKh~CM D YG e%bK oaZtdED6i@du>4^h#ܵv$v옃\U&$S@}af )ܳ0/^b;GY$qH?tg ) 1V'*6+SĎn[UQ.(3RI.FE} },{:ܱ۷T/GW]q6 k86W|cO>xyה"
1wt\WBʃvZt2ta[/iYB(' {K"(ĞVsp-`.}V.x5%R`hD Ei̙p]?ACq0.QRx{ϱ3m4̼l2Ϳ}lׄܤtx>6+HV1U6ؐq8rG(?yb֎0
vMGyyT<)oY\5VT 12ufL *l+wOCM G IDATs<;e-U Pv=+h9O5XI2TTs2TkvOqt:k
\:fݒzV
.XcQxe,2Wg|w4G&yҥ|'~ @ S4= ^bV@A6{_]㽨' @ N3y z) ^7ƍK+nn!%
>el><QB#՚C> ]#m.+cdjYu5sw<՜g !/L[c;Ƙ,~UnaP|Ni/#9=n&.-m56 ׳\8qdéFƱyt %.5W@X\V9qx:=^9m
5\MʬYR8#ar &#l) ܑ>, (rye庆H>08zeo2_:OٙsF/^/+w2/'
23 )k E$wHltaa4HH')l
Ǹ/geɘD O Pc;=3l)G['4\$-bOs%yb8;Xm1MG;/vOss˹\$+l6;ntNOM-* q 蓻6R Ԛ{[
>3?+|l8 $%WsIs͟ g8i^R缉j+MfÔRyBb}-j|^ZD`ͳ`ݍiei ㇺ|qy~ik7Z(zٽp(Ƞ ptp(eWN|6\U[nu$"E-0ark߉lE=~q,;X %Ѡ
H~RaxF.>K
iTsNg0\赁YL]yhk|?r;WYY-8 Bh*`Ex`Eh<i=G&FP,m\`+NQ(:@b($$LYbSa@Y
0F4
:)lUy8mめB |JvB?]:+~ b /:<59UJqywDNxhn:(|]qyUZUr9Zg
BГBOvyyG \H g2 ssD!`NO||"^Td)pPڗƃzav!! _1EBx]gyD-"e46nW-I.KJB}Ilb\@SgyF[xaF8rcn>y_6v3m>w~ ܺB%|iЇC4Zi =wD+UCLT;WI-n E ᕂ3>O7ir~*?yuS]#OO2у 9A|(5{'Sdvui\{+qM@+R>;pt ͼl2ů9$8 @)Gb
OCĮ fPy-$%j.~i,J&7ls"HOKHsMGxV ly+}{_j',zU(i"n`@[*8d
WbƤl/ P:ʎjx
{Zxk]G+UؔL:A_4|h϶%n\ZeˈI@lܮa m.9`e1W(q"0 =YBLͮ3}Ů3}/I|Mmˊ,"o9!Aaоϟ虞k \ Fb{ȝ9m7!-} 3?~{B})>͜J_c]º1 ӯo;'1 C[f6M vypL4CRcwfh;/m&rO<{3A#HO&{9'cҜmy2
|d(;KX( G5$"_ͯv EʕY<2-w"=6R9䞢e>G#n:$V0*Q>$$]vi frh43yǣ{{n!sƸuCz!hE+Ħ\C 9R*Xv=Ǝ#, )^7$6 % A˩&mܖ!W/c<2eq4*4&礝h佳ɓ->qebH<3-S 2 ZE )r`,= q7{3BVϟMi~>jÌqzM
4tƽbbb> \S*V/ 3M?|jQYgefm*i _?9L̥\gz 5T̵[)-d"2r/M24Jzo;u ӎ1 L%Ox-g._-8wGiNO%UƋw|
6i-j $8.ß%@Xw#9\T1&Y} tPbIr4 ^LkR )nY=Ď2K^^+ d|ON7ٺ,5%-.0\i9q6OR))*p"'L@رпeζs~CJs;(r,RQ!c
5zRƠ$sОr]R 3s3-2M '8HHۓ^q?D
{tR> 0 G#vv}&j |pcJ ǢbātFnI՜TȄ#yD<4ʍXJ Sw5 "79# ̄%K5ax qpc_k :2K\̴f\o Y`dʥ:7
Sc.? _,ZuxhȻjìIF0ae X ~gm%=Ê+Vaqj ++PRvvٽdcׯ-sbт֮/V#T NxL~ƚ[6jmb#@bSFH |:}C)/TR *pÖH2w?g9_ͷvi)nj)Bp)u`uEԇime1Ԟ7Wa+
0D"DJ~KK˽WIF;DHQ);"d$9oiVckڙ摽m~y^ G+`5HrC۶Y2{c̱ȍ(vPp>$ZzNVmV.V'\{PkђS>qvV 2tNͼoK֖ Jkbfs6(T3O6 - Uu61g;Gj]B} ^ܙ^X)8Y753lV5nPWv"pSYoN3r{y E]E\6kR XWEb87<#3m,47m(q Wzd_]S4 9 /59ʸfC7n.q"a[OAql`Z$/iJw^iARiYE6I/t9q<~ >|O|
3U~ zb}E-syq%TX)~dq.)'uD&-0T ѴP9TUb;"ӞTWK] 7Y%l 4r|`NB@(p![H
x1fgvϠ1ocSB% t)] ^S};ZRqlm'iiʗs_b
<_:MX][K&Zi|Ǵ:xvxtÎĭ!V&
Hm0ezUw_:D%9i/2G#Ѐ>M_| (+m ؞iJ %-XCm~4<0Brҽ-Gȓw?EU~iGЎ8bO.ck! qhp;I&m,[x Be> ޓt o7T=:E9/|>\H\q(ǝ9C9 2%claD0%; "rv2}rlO!.XT cێ&gs n}mi TˆX1;'eg< +0/p4y = M fk e`r9-Ml^RT!z c@#b?K'CJ,hn 6`0EO6E֑h|a;-_ IDATY|
awI|l9m8v2e=>Y ueERlB5w`%QPǍo/Z>r+parYC ,>3<=#Ze(i0?(T19
(ϣ._9BǸPf4UQ kMxsY&#aʌc Cp2LN7w{qyvlǼ{[u4(Ae H.DL+ILsn./*\DxpO=`6rӧ߸*,׀B@Vc #V`ʢ AS ^["i"^9N2AA,$V;
$v.k
u+mG FV
uJBdА$إ7B舖A{\{t
,4ŕ(rEX5z ~Ԙ'2ΏPz7 ,%DiPKK\ZZ.iuk:W2LYgim*3hțf^9 |ʊ
{c}M 2Y]ݙUlCo3yvirϖxho>4vZ^v)yQdR0q+=ƄppHGH98GHr_ܽu]cKi@79Oh@!bؼU ~rjK!_ wU0og:)=+*߷pކ??6Ιe*i"7azZ'LK mP`Mt@3I
\TX9> 6ZGn/y{h8T䲱
k%mݯ6Da,1=̐0rtB +B1DБ>-4C/?W:4sx BgddJx4ǯ>Kʑ-G ˼i M!+i{^ۣVO{.xky1&]b G]~?9v_s]h,8|4fx$kMu\]gP cRRqhAϘ=5wp Tmcu@(\8 ;_3O)ֆK/ _沿ff6w( S;ncQ!
7 Uao.Y)"L.-
R>n,]
VFV8T\pHܦcbHe^#/t@k}͋x:Łz:D%"u=Oϳ/+jmGRAԇAT?+TCQpFǴBz QqC-=6l'jnJa7/qxr $wxe JD(LK᧧;|z}V\eKUA5b]dog
=??/{2N`/3˽ D)U-
eVWjEzKe#taP]n$~f P1a~\aoA Rpu ?#Q+dL
h2-io@
6t^f&
`@cxyp2>awSRjIrnMcKʌ5՚/ '~{^6Ěąؼї*QǛ=6r{px!$!H֚Cߝ6m!7Fa8e4R鵹?mhvkWw[MmMykNS l6g>mUXT1) '839פ]8}],W(Sfۇy2Bd w ;#s2!-Ʈ- U%2/x k?&=zҵvR(e^!E6c HYVN_ 5g^&T/9vFVD I1xϿuwo e2A@.^*8_Y,|:wO0 'ԁ/
Ps u$y?_.bRn/,,qr@z#]~[>sXR,6_sM 04YWxL;TЎ!ƫ1>ARbrr2_~7v8Y L q 3<{^{s'Mak8vs7WZ4H%# M
Jcbsņ2Jx+fQ,/(*pkbm*([ל EI Js\
Pl(TceV tb] 6ԋ$6\vZd]n[L U3mZT5 >="I=5pcփ-}LNޒl+bKI`4r++6op( ~S {,5/4wF[綺Lο'Z(bfGh3m,|e+`O>LY<δdI_H(^pV iLW,7 t_aUcXv.+^Pb &G|$+(+&ߒa"\ ;vSYgyMu~fcXȬp_ (Ԕz?o. ][,W 7*J)?ui/l8vlLws">d0Ĝ]OuHB~d sP%6ap?q!P{[ܘt\rMk`D:ڟ2F$έ>o]62ĪBeɚD3p|fZI|1NjEnh^4+<ϟ6٧z_R+jl-3^44 X6_>lZ off_(%6y%w 608wopy CV&nxem K6}E|_m}b'_1'hsw^Zc҂,2m2
EO
{NϦ|&?xF]厑q&kotPx%Z[|!8Z{/tXQdhi﨔=)
6TsL?\QS\EsHU̶\Ã90]bi=CW/
3?? :cJ{]cf00T*144D%Dܱi0DF'*Q6qc447PjMq& ]~y[)Gؔ>Vc0~`VMk吃2,c>p"Wm(1 Y=͊b2bPZ3\s.WvޱRԢUK|5^eIH;}SޜLf)_8Y@<3[7kUju6wqQB5 jmfH{ӌw dZFj oGnkhڭiIQYbT
r LA=C%]Mp'ay4#+
zyemݡ&B'3s|`t WVce&< Z~?q**rъ ~ɧ G9},*=8?ֿfz=T*166F&ﻤĝش$1& n!TРTHEj &;Los9A Q zlLGI|# umݲ(3~ )!|h5 [`Bˣl)V́qi V
k]$Ka4n8RTR(9/:|5r_IR,,&ץȿcI ,2ZFTd∛fC RKA'P9%2=GޡĆhA%_9"ۋ2 J8,c&L
H :dY)) ! 8 !
pl;/m&Zegu䄓ʹE]/,8Z': .LBĩ~n:~#?4{~Il#g`ٴTk^}
U KɇT,3閾Oݹ %rSF}KJDeBܴĉC=86ExV h%@;f8e] 2[L9U)E:SC
c%ZGM<Ȳs}K̂ 30 e#!BHB4 &jR VPZHYTiE+ԤpIYD
R !Ę0`2l 3ݯ{9 `}<8a.)rCvl }˓L{|mv07?/\qh e 8q O^P+TJA8p!t\Νd&^FB d,|bY\
ZOw- ?!|>V⋋m
2V"~gu=|{E.J!uyE0đʥ3}?hwi\jP0ns-d1[cgvZ<牬c+z$pѮ`RWUJk'*g]ƕgVY+ce ,X 1r %3vܡ "r4JeS\Z(}S;B@A(0Fb.6p*'%<7 O\E兦L^cws- q|W&"=Cy茙~V%?N9O^K{ zhsyڝ *SN:Za b[+X&}
cv(ڂ:$G Ѷm-5L)q8 ,4Պn^H,M:%FE %-n< l
NٕHJs5,L*. ^ d] ied +\tj{mmfZ"7VH!Ҕ'wqwÏfѠHJ<,B$.~02]{ \[aYOJ]iQPgIıwbwڷ`n3
^U\B6{Z>f#tA@&LƁD - Fy?Gg66PT' ^# wtӴ_qN֨1,cKWhTmfgge|Chd1*i) ''I CՄ*<=HdS?˂5J6p2dC00CkCea Z "*a昒נI9ȻyXZǮ\>AG)e̓iw(
o{gb $='cUgpi~RlXg^Q }3/$ ?=: ' {veFOD9N1k!da"3D7
:PHi}!بcvWӵ7mJ(_ųx*ݍ+;x"ڏ.20+W۳L´"Rԩe^dl[3<{ 3Ӥiֺ?3
M,nl;7OQMؑZ@é(Kߛxw}4S{8,ty5bc߁_ *Bk0?F I _UJ:@+gjG x5xnsQ.p/\̝#Yw,ap'@JY t3㿞rǓ zQvNN27?' n
|EjCYyL `řǕi6 0>;kia5H3G/LlbKO%1hy75_XE
ށeX],gM 1FAi*W7g̤v%Ǵ!}RVf*`*2'+.?UѳY>,CFK_n^(Q*oW0O zɈ/]CO^}AMm\GܝYSQz!WyùXl7P 6|L=Z_Iv{4MB°+"J+GY?fS)bRg5
?\IƲf XYe.L.ۍ˦ %RQ5^ `FX#\d>- Ӝٍ
#ls-(|_|
;'z}q ~py)KFL}zIZ5}>Κԧ~Spl"v2ښ>M+\Ib;V O8'@L'B0fFށ+puI37 弅v W%& L2cH#tL155%nL\/)%dB 2CCT4WYSJl85$o5C:|ꬒuI T(ў 1IDAT|:Tr92 "nMBaQ9G=J"ǒxֽށ ~_h]kٌ͞{j/싘 SXqIo,vk *
ǎ\rba8WLCD^%P¤s]Z n}t_5dZD-=5L|lTg\y2MCBC_O7}f5B̛1yFs3v2VÜL5 -)Kk0w6zR~'N#En̉<)iP" gC>/8Vʩ^{d?z-"GkܲxDhn{lٶ;1צt bʞ#A
e~2 |T\.311Lc7 =K+TdcCse(㥅0k `!t< 0PJ` ڻJ94WզėSjK sYP v@y鎴\WڣLN
y07)2}Y `dd$8y<+ICnt*2T X>i"aەe5/;fs
m-!Dqu(SzvOt ,azzZ[0q YR(\ %IBVcbʆ&8o
14
Ni\ mɀKr̍Uƺ05neǨKMja%(ϴ5_ nSquҖJGXb%ݾZy{6 AvC9ʞcE\|PC'FFFFн&zV+ϪvDy|! &s-VWb!?gR>-l+һa\ҫA ᘙfW=n`6!Ax,B,"\1TJ%֍k.;Ew1V3ayG2 p({=e~\9k_)lj6mї;;Zmr?ڡy@̇Sӫ(bpp:k|a8cjY2uCYfґ|YK).j/}ض@fiҀ`v?vT2hH3K
_
e> DJ)V\I{mI$kB(i[~g Zu-p&Vwrӷ`jzZ[}LM
e>2d steU*&˯7ĆUe
U"BZ@0 [_~s@3my&{;`c~~^[_ZrXP#K~
"$a|lC:(t_~O
ӭE217: ؟K1?_<0ssuvM,Pr S!'2 r>&^bٲedY_RUʑKEL{z] ,(O~̥֮X۷j:Ty{0 RJGo PVM9k 欕]>|F O^q i_r @֎RxL;hsv3vv:|W5d[њxJG 7W+H1.q˘2|2BYOV^i(tpy65웡 KG3ZZRIgn b2}\lO:z_=4ˣDLNNot5j!oE
e>D0|dRAqjUgyi5G,vwkK~gRZ >~8/B
yr:-grp *}A IENDB` ggforce/man/figures/lifecycle-archived.svg 0000644 0001762 0000144 00000001707 14276652144 020370 0 ustar ligges users ggforce/man/figures/logo.svg 0000644 0001762 0000144 00002756266 13476153736 015635 0 ustar ligges users
ggforce/man/figures/lifecycle-questioning.svg 0000644 0001762 0000144 00000001714 14276652144 021146 0 ustar ligges users ggforce/man/figures/lifecycle-superseded.svg 0000644 0001762 0000144 00000001713 14276652144 020743 0 ustar ligges users ggforce/man/figures/lifecycle-stable.svg 0000644 0001762 0000144 00000001674 14276652144 020060 0 ustar ligges users ggforce/man/figures/lifecycle-experimental.svg 0000644 0001762 0000144 00000001716 14276652144 021300 0 ustar ligges users ggforce/man/figures/lifecycle-deprecated.svg 0000644 0001762 0000144 00000001712 14276652144 020677 0 ustar ligges users ggforce/man/facet_matrix.Rd 0000644 0001762 0000144 00000013726 14304371731 015412 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/facet_matrix.R
\name{facet_matrix}
\alias{facet_matrix}
\title{Facet by different data columns}
\usage{
facet_matrix(
rows,
cols = rows,
shrink = TRUE,
switch = NULL,
labeller = "label_value",
flip.rows = FALSE,
alternate.axes = FALSE,
layer.lower = NULL,
layer.diag = NULL,
layer.upper = NULL,
layer.continuous = NULL,
layer.discrete = NULL,
layer.mixed = NULL,
grid.y.diag = TRUE
)
}
\arguments{
\item{rows, cols}{A specification of the data columns to put in the rows and
columns of the facet grid. They are specified using the \code{\link[ggplot2:vars]{ggplot2::vars()}}
function wherein you can use standard tidyselect syntax as known from e.g.
\code{dplyr::select()}. These data values will be made available to the different
layers through the \code{.panel_x} and \code{.panel_y} variables.}
\item{shrink}{If \code{TRUE}, will shrink scales to fit output of
statistics, not raw data. If \code{FALSE}, will be range of raw data
before statistical summary.}
\item{switch}{By default, the labels are displayed on the top and
right of the plot. If \code{"x"}, the top labels will be
displayed to the bottom. If \code{"y"}, the right-hand side
labels will be displayed to the left. Can also be set to
\code{"both"}.}
\item{labeller}{A function that takes one data frame of labels and
returns a list or data frame of character vectors. Each input
column corresponds to one factor. Thus there will be more than
one with \code{vars(cyl, am)}. Each output
column gets displayed as one separate line in the strip
label. This function should inherit from the "labeller" S3 class
for compatibility with \code{\link[ggplot2:labeller]{labeller()}}. You can use different labeling
functions for different kind of labels, for example use \code{\link[ggplot2:label_parsed]{label_parsed()}} for
formatting facet labels. \code{\link[ggplot2:label_value]{label_value()}} is used by default,
check it for more details and pointers to other options.}
\item{flip.rows}{Should the order of the rows be reversed so that, if the
rows and columns are equal, the diagonal goes from bottom-left to top-right
instead of top-left to bottom-right.}
\item{alternate.axes}{Should axes be drawn at alternating positions.}
\item{layer.lower, layer.diag, layer.upper}{Specification for where each layer
should appear. The default (\code{NULL}) will allow any layer that has not been
specified directly to appear at that position. Putting e.g. \code{layer.diag = 2}
will make the second layer appear on the diagonal as well as remove that
layer from any position that has \code{NULL}. Using \code{TRUE} will put all layers at
that position, and using \code{FALSE} will conversely remove all layers. These
settings will only have an effect if the grid is symmetric.}
\item{layer.continuous, layer.discrete, layer.mixed}{As above, but instead of
referencing panel positions it references the combination of position scales
in the panel. Continuous panels have both a continuous x and y axis, discrete
panels have both a discrete x and y axis, and mixed panels have one of each.
Unlike the position based specifications above these also have an effect in
non-symmetric grids.}
\item{grid.y.diag}{Should the y grid be removed from the diagonal? In certain
situations the diagonal are used to plot the distribution of the column data
and will thus not use the y-scale. Removing the y gridlines can indicate
this.}
}
\description{
The \code{facet_matrix()} facet allows you to put different data columns into
different rows and columns in a grid of panels. If the same data columns are
present in both the rows and the columns of the grid, and used together with
\code{\link[ggplot2:geom_point]{ggplot2::geom_point()}} it is also known as a scatterplot matrix, and if
other geoms are used it is sometimes referred to as a pairs plot.
\code{facet_matrix} is so flexible that these types are simply a subset of its
capabilities, as any combination of data columns can be plotted against each
other using any type of geom. Layers should use the \code{.panel_x} and \code{.panel_y}
placeholders to map aesthetics to, in order to access the row and column
data.
}
\note{
Due to the special nature of this faceting it slightly breaks the
ggplot2 API, in that any positional scale settings are ignored. This is
because each row and column in the grid will potentially have very different
scale types and it is not currently possible to have multiple different scale
specifications in the same plot object.
}
\examples{
# Standard use:
ggplot(mpg) +
geom_point(aes(x = .panel_x, y = .panel_y)) +
facet_matrix(vars(displ, cty, hwy))
# Switch the diagonal, alternate the axes and style strips as axis labels
ggplot(mpg) +
geom_point(aes(x = .panel_x, y = .panel_y)) +
facet_matrix(vars(displ, cty, hwy), flip.rows = TRUE,
alternate.axes = TRUE, switch = 'both') +
theme(strip.background = element_blank(),
strip.placement = 'outside',
strip.text = element_text(size = 12))
# Mix discrete and continuous columns. Use geom_autopoint for scale-based jitter
ggplot(mpg) +
geom_autopoint() +
facet_matrix(vars(drv:fl))
# Have a special diagonal layer
ggplot(mpg) +
geom_autopoint() +
geom_autodensity() +
facet_matrix(vars(drv:fl), layer.diag = 2)
\donttest{
# Show continuous panels in upper triangle as contours and rest as binned
ggplot(mpg) +
geom_autopoint() +
geom_autodensity() +
geom_density2d(aes(x = .panel_x, y = .panel_y)) +
geom_bin2d(aes(x = .panel_x, y = .panel_y)) +
facet_matrix(vars(drv:fl), layer.lower = 1, layer.diag = 2,
layer.continuous = -4, layer.discrete = -3, layer.mixed = -3)
}
# Make asymmetric grid
ggplot(mpg) +
geom_boxplot(aes(x = .panel_x, y = .panel_y, group = .panel_x)) +
facet_matrix(rows = vars(cty, hwy), cols = vars(drv, fl))
}
\seealso{
\link{geom_autopoint}, \link{geom_autohistogram}, \link{geom_autodensity}, and
\link{position_auto} for geoms and positions that adapts to different positional
scale types
}
ggforce/man/geom_bezier.Rd 0000644 0001762 0000144 00000016156 14553466074 015246 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/bezier.R
\name{geom_bezier}
\alias{geom_bezier}
\alias{stat_bezier}
\alias{stat_bezier2}
\alias{geom_bezier2}
\alias{stat_bezier0}
\alias{geom_bezier0}
\title{Create quadratic or cubic bezier curves}
\usage{
stat_bezier(
mapping = NULL,
data = NULL,
geom = "path",
position = "identity",
na.rm = FALSE,
show.legend = NA,
n = 100,
inherit.aes = TRUE,
...
)
geom_bezier(
mapping = NULL,
data = NULL,
stat = "bezier",
position = "identity",
arrow = NULL,
lineend = "butt",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
n = 100,
...
)
stat_bezier2(
mapping = NULL,
data = NULL,
geom = "path_interpolate",
position = "identity",
na.rm = FALSE,
show.legend = NA,
n = 100,
inherit.aes = TRUE,
...
)
geom_bezier2(
mapping = NULL,
data = NULL,
stat = "bezier2",
position = "identity",
arrow = NULL,
lineend = "butt",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
n = 100,
...
)
stat_bezier0(
mapping = NULL,
data = NULL,
geom = "bezier0",
position = "identity",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
...
)
geom_bezier0(
mapping = NULL,
data = NULL,
stat = "bezier0",
position = "identity",
arrow = NULL,
lineend = "butt",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
...
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and
\code{inherit.aes = TRUE} (the default), it is combined with the default mapping
at the top level of the plot. You must supply \code{mapping} if there is no plot
mapping.}
\item{data}{The data to be displayed in this layer. There are three
options:
If \code{NULL}, the default, the data is inherited from the plot
data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}.
A \code{data.frame}, or other object, will override the plot
data. All objects will be fortified to produce a data frame. See
\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created.
A \code{function} will be called with a single argument,
the plot data. The return value must be a \code{data.frame}, and
will be used as the layer data. A \code{function} can be created
from a \code{formula} (e.g. \code{~ head(.x, 10)}).}
\item{geom}{The geometric object to use to display the data, either as a
\code{ggproto} \code{Geom} subclass or as a string naming the geom stripped of the
\code{geom_} prefix (e.g. \code{"point"} rather than \code{"geom_point"})}
\item{position}{Position adjustment, either as a string naming the adjustment
(e.g. \code{"jitter"} to use \code{position_jitter}), or the result of a call to a
position adjustment function. Use the latter if you need to change the
settings of the adjustment.}
\item{na.rm}{If \code{FALSE}, the default, missing values are removed with
a warning. If \code{TRUE}, missing values are silently removed.}
\item{show.legend}{logical. Should this layer be included in the legends?
\code{NA}, the default, includes if any aesthetics are mapped.
\code{FALSE} never includes, and \code{TRUE} always includes.
It can also be a named logical vector to finely select the aesthetics to
display.}
\item{n}{The number of points to create for each segment}
\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics,
rather than combining with them. This is most useful for helper functions
that define both data and aesthetics and shouldn't inherit behaviour from
the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.}
\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}. These are
often aesthetics, used to set an aesthetic to a fixed value, like
\code{colour = "red"} or \code{size = 3}. They may also be parameters
to the paired geom/stat.}
\item{stat}{The statistical transformation to use on the data for this
layer, either as a \code{ggproto} \code{Geom} subclass or as a string naming the
stat stripped of the \code{stat_} prefix (e.g. \code{"count"} rather than
\code{"stat_count"})}
\item{arrow}{Arrow specification, as created by \code{\link[grid:arrow]{grid::arrow()}}.}
\item{lineend}{Line end style (round, butt, square).}
}
\description{
This set of geoms makes it possible to connect points creating either
quadratic or cubic beziers. bezier and bezier2 both work by calculating
points along the bezier and connecting these to draw the curve. bezier0
directly draws the bezier using bezierGrob. In line with the \code{\link[=geom_link]{geom_link()}} and
\code{\link[=geom_link2]{geom_link2()}} differences geom_bezier creates the points, assign
an index to each interpolated point and repeat the aesthetics for the start
point, while geom_bezier2 interpolates the aesthetics between the start and
end points.
}
\details{
Input data is understood as a sequence of data points the first being the
start point, then followed by one or two control points and then the end
point. More than 4 and less than 3 points per group will throw an error.
\code{\link[grid:grid.bezier]{grid::bezierGrob()}} only takes cubic beziers so if three points are
supplied the middle one as duplicated. This, along with the fact that
\code{\link[grid:grid.bezier]{grid::bezierGrob()}} estimates the curve using an x-spline means
that the curves produced by geom_bezier and geom_bezier2 deviates from those
produced by geom_bezier0. If you want true bezier paths use geom_bezier or
geom_bezier2.
}
\section{Aesthetics}{
geom_bezier, geom_bezier2 and geom_bezier0 understand the following aesthetics
(required aesthetics are in bold):
\itemize{
\item \strong{x}
\item \strong{y}
\item color
\item linewidth
\item linetype
\item alpha
\item lineend
}
}
\section{Computed variables}{
\describe{
\item{x, y}{The interpolated point coordinates}
\item{index}{The progression along the interpolation mapped between 0 and 1}
}
}
\examples{
beziers <- data.frame(
x = c(1, 2, 3, 4, 4, 6, 6),
y = c(0, 2, 0, 0, 2, 2, 0),
type = rep(c('cubic', 'quadratic'), c(3, 4)),
point = c('end', 'control', 'end', 'end', 'control', 'control', 'end'),
colour = letters[1:7]
)
help_lines <- data.frame(
x = c(1, 3, 4, 6),
xend = c(2, 2, 4, 6),
y = 0,
yend = 2
)
# See how control points affect the bezier
ggplot() +
geom_segment(aes(x = x, xend = xend, y = y, yend = yend),
data = help_lines,
arrow = arrow(length = unit(c(0, 0, 0.5, 0.5), 'cm')),
colour = 'grey') +
geom_bezier(aes(x = x, y = y, group = type, linetype = type),
data = beziers) +
geom_point(aes(x = x, y = y, colour = point),
data = beziers)
# geom_bezier0 is less exact
ggplot() +
geom_segment(aes(x = x, xend = xend, y = y, yend = yend),
data = help_lines,
arrow = arrow(length = unit(c(0, 0, 0.5, 0.5), 'cm')),
colour = 'grey') +
geom_bezier0(aes(x = x, y = y, group = type, linetype = type),
data = beziers) +
geom_point(aes(x = x, y = y, colour = point),
data = beziers)
# Use geom_bezier2 to interpolate between endpoint aesthetics
ggplot(beziers) +
geom_bezier2(aes(x = x, y = y, group = type, colour = colour))
}
ggforce/man/geom_diagonal.Rd 0000644 0001762 0000144 00000017142 14303413453 015522 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/diagonal.R
\name{geom_diagonal}
\alias{geom_diagonal}
\alias{stat_diagonal}
\alias{stat_diagonal2}
\alias{geom_diagonal2}
\alias{stat_diagonal0}
\alias{geom_diagonal0}
\title{Draw horizontal diagonals}
\usage{
stat_diagonal(
mapping = NULL,
data = NULL,
geom = "path",
position = "identity",
n = 100,
strength = 0.5,
na.rm = FALSE,
orientation = NA,
show.legend = NA,
inherit.aes = TRUE,
...
)
geom_diagonal(
mapping = NULL,
data = NULL,
stat = "diagonal",
position = "identity",
n = 100,
na.rm = FALSE,
orientation = NA,
strength = 0.5,
show.legend = NA,
inherit.aes = TRUE,
...
)
stat_diagonal2(
mapping = NULL,
data = NULL,
geom = "path_interpolate",
position = "identity",
na.rm = FALSE,
orientation = NA,
show.legend = NA,
n = 100,
strength = 0.5,
inherit.aes = TRUE,
...
)
geom_diagonal2(
mapping = NULL,
data = NULL,
stat = "diagonal2",
position = "identity",
arrow = NULL,
lineend = "butt",
na.rm = FALSE,
orientation = NA,
show.legend = NA,
inherit.aes = TRUE,
n = 100,
strength = 0.5,
...
)
stat_diagonal0(
mapping = NULL,
data = NULL,
geom = "bezier0",
position = "identity",
na.rm = FALSE,
orientation = NA,
show.legend = NA,
inherit.aes = TRUE,
strength = 0.5,
...
)
geom_diagonal0(
mapping = NULL,
data = NULL,
stat = "diagonal0",
position = "identity",
arrow = NULL,
lineend = "butt",
na.rm = FALSE,
orientation = NA,
show.legend = NA,
inherit.aes = TRUE,
strength = 0.5,
...
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and
\code{inherit.aes = TRUE} (the default), it is combined with the default mapping
at the top level of the plot. You must supply \code{mapping} if there is no plot
mapping.}
\item{data}{The data to be displayed in this layer. There are three
options:
If \code{NULL}, the default, the data is inherited from the plot
data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}.
A \code{data.frame}, or other object, will override the plot
data. All objects will be fortified to produce a data frame. See
\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created.
A \code{function} will be called with a single argument,
the plot data. The return value must be a \code{data.frame}, and
will be used as the layer data. A \code{function} can be created
from a \code{formula} (e.g. \code{~ head(.x, 10)}).}
\item{geom}{The geometric object to use to display the data, either as a
\code{ggproto} \code{Geom} subclass or as a string naming the geom stripped of the
\code{geom_} prefix (e.g. \code{"point"} rather than \code{"geom_point"})}
\item{position}{Position adjustment, either as a string naming the adjustment
(e.g. \code{"jitter"} to use \code{position_jitter}), or the result of a call to a
position adjustment function. Use the latter if you need to change the
settings of the adjustment.}
\item{n}{The number of points to create for each segment}
\item{strength}{The proportion to move the control point along the x-axis
towards the other end of the bezier curve}
\item{na.rm}{If \code{FALSE}, the default, missing values are removed with
a warning. If \code{TRUE}, missing values are silently removed.}
\item{orientation}{The orientation of the layer. The default (\code{NA})
automatically determines the orientation from the aesthetic mapping. In the
rare event that this fails it can be given explicitly by setting \code{orientation}
to either \code{"x"} or \code{"y"}. See the \emph{Orientation} section for more detail.}
\item{show.legend}{logical. Should this layer be included in the legends?
\code{NA}, the default, includes if any aesthetics are mapped.
\code{FALSE} never includes, and \code{TRUE} always includes.
It can also be a named logical vector to finely select the aesthetics to
display.}
\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics,
rather than combining with them. This is most useful for helper functions
that define both data and aesthetics and shouldn't inherit behaviour from
the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.}
\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}. These are
often aesthetics, used to set an aesthetic to a fixed value, like
\code{colour = "red"} or \code{size = 3}. They may also be parameters
to the paired geom/stat.}
\item{stat}{The statistical transformation to use on the data for this
layer, either as a \code{ggproto} \code{Geom} subclass or as a string naming the
stat stripped of the \code{stat_} prefix (e.g. \code{"count"} rather than
\code{"stat_count"})}
\item{arrow}{Arrow specification, as created by \code{\link[grid:arrow]{grid::arrow()}}.}
\item{lineend}{Line end style (round, butt, square).}
}
\description{
A diagonal is a bezier curve where the control points are moved
perpendicularly towards the center in either the x or y direction a fixed
amount. The versions provided here calculates horizontal diagonals meaning
that the x coordinate is moved to achieve the control point. The
\code{geom_diagonal()} and \code{stat_diagonal()} functions are simply helpers that
takes care of calculating the position of the control points and then
forwards the actual bezier calculations to \code{\link[=geom_bezier]{geom_bezier()}}.
}
\section{Aesthetics}{
geom_diagonal and geom_diagonal0 understand the following aesthetics
(required aesthetics are in bold):
\itemize{
\item \strong{x}
\item \strong{y}
\item \strong{xend}
\item \strong{yend}
\item color
\item linewidth
\item linetype
\item alpha
\item lineend
}
geom_diagonal2 understand the following aesthetics
(required aesthetics are in bold):
\itemize{
\item \strong{x}
\item \strong{y}
\item \strong{group}
\item color
\item linewidth
\item linetype
\item alpha
\item lineend
}
}
\section{Computed variables}{
\describe{
\item{x, y}{The interpolated point coordinates}
\item{index}{The progression along the interpolation mapped between 0 and 1}
}
}
\section{Orientation}{
This geom treats each axis differently and, thus, can thus have two orientations. Often the orientation is easy to deduce from a combination of the given mappings and the types of positional scales in use. Thus, ggplot2 will by default try to guess which orientation the layer should have. Under rare circumstances, the orientation is ambiguous and guessing may fail. In that case the orientation can be specified directly using the \code{orientation} parameter, which can be either \code{"x"} or \code{"y"}. The value gives the axis that the geom should run along, \code{"x"} being the default orientation you would expect for the geom.
}
\examples{
data <- data.frame(
x = rep(0, 10),
y = 1:10,
xend = 1:10,
yend = 2:11
)
ggplot(data) +
geom_diagonal(aes(x, y, xend = xend, yend = yend))
# The standard version provides an index to create gradients
ggplot(data) +
geom_diagonal(aes(x, y, xend = xend, yend = yend, alpha = after_stat(index)))
# The 0 version uses bezierGrob under the hood for an approximation
ggplot(data) +
geom_diagonal0(aes(x, y, xend = xend, yend = yend))
# The 2 version allows you to interpolate between endpoint aesthetics
data2 <- data.frame(
x = c(data$x, data$xend),
y = c(data$y, data$yend),
group = rep(1:10, 2),
colour = sample(letters[1:5], 20, TRUE)
)
ggplot(data2) +
geom_diagonal2(aes(x, y, group = group, colour = colour))
# Use strength to control the steepness of the central region
ggplot(data, aes(x, y, xend = xend, yend = yend)) +
geom_diagonal(strength = 0.75, colour = 'red') +
geom_diagonal(strength = 0.25, colour = 'blue')
}
ggforce/man/geom_mark_rect.Rd 0000644 0001762 0000144 00000022110 14564603246 015714 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/mark_rect.R
\name{geom_mark_rect}
\alias{geom_mark_rect}
\title{Annotate areas with rectangles}
\usage{
geom_mark_rect(
mapping = NULL,
data = NULL,
stat = "identity",
position = "identity",
expand = unit(5, "mm"),
radius = unit(2.5, "mm"),
label.margin = margin(2, 2, 2, 2, "mm"),
label.width = NULL,
label.minwidth = unit(50, "mm"),
label.hjust = 0,
label.fontsize = 12,
label.family = "",
label.lineheight = 1,
label.fontface = c("bold", "plain"),
label.fill = "white",
label.colour = "black",
label.buffer = unit(10, "mm"),
con.colour = "black",
con.size = 0.5,
con.type = "elbow",
con.linetype = 1,
con.border = "one",
con.cap = unit(3, "mm"),
con.arrow = NULL,
...,
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and
\code{inherit.aes = TRUE} (the default), it is combined with the default mapping
at the top level of the plot. You must supply \code{mapping} if there is no plot
mapping.}
\item{data}{The data to be displayed in this layer. There are three
options:
If \code{NULL}, the default, the data is inherited from the plot
data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}.
A \code{data.frame}, or other object, will override the plot
data. All objects will be fortified to produce a data frame. See
\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created.
A \code{function} will be called with a single argument,
the plot data. The return value must be a \code{data.frame}, and
will be used as the layer data. A \code{function} can be created
from a \code{formula} (e.g. \code{~ head(.x, 10)}).}
\item{stat}{The statistical transformation to use on the data for this
layer, either as a \code{ggproto} \code{Geom} subclass or as a string naming the
stat stripped of the \code{stat_} prefix (e.g. \code{"count"} rather than
\code{"stat_count"})}
\item{position}{Position adjustment, either as a string naming the adjustment
(e.g. \code{"jitter"} to use \code{position_jitter}), or the result of a call to a
position adjustment function. Use the latter if you need to change the
settings of the adjustment.}
\item{expand}{A numeric or unit vector of length one, specifying the
expansion amount. Negative values will result in contraction instead. If the
value is given as a numeric it will be understood as a proportion of the
plot area width.}
\item{radius}{As \code{expand} but specifying the corner radius.}
\item{label.margin}{The margin around the annotation boxes, given by a call
to \code{\link[ggplot2:element]{ggplot2::margin()}}.}
\item{label.width}{A fixed width for the label. Set to \code{NULL} to let the text
or \code{label.minwidth} decide.}
\item{label.minwidth}{The minimum width to provide for the description. If
the size of the label exceeds this, the description is allowed to fill as
much as the label.}
\item{label.hjust}{The horizontal justification for the annotation. If it
contains two elements the first will be used for the label and the second for
the description.}
\item{label.fontsize}{The size of the text for the annotation. If it contains
two elements the first will be used for the label and the second for the
description.}
\item{label.family}{The font family used for the annotation. If it contains
two elements the first will be used for the label and the second for the
description.}
\item{label.lineheight}{The height of a line as a multipler of the fontsize.
If it contains two elements the first will be used for the label and the
second for the description.}
\item{label.fontface}{The font face used for the annotation. If it contains
two elements the first will be used for the label and the second for the
description.}
\item{label.fill}{The fill colour for the annotation box.}
\item{label.colour}{The text colour for the annotation. If it contains
two elements the first will be used for the label and the second for the
description.}
\item{label.buffer}{The size of the region around the mark where labels
cannot be placed.}
\item{con.colour}{The colour for the line connecting the annotation to the
mark.}
\item{con.size}{The width of the connector.}
\item{con.type}{The type of the connector. Either \code{"elbow"}, \code{"straight"}, or
\code{"none"}.}
\item{con.linetype}{The linetype of the connector.}
\item{con.border}{The bordertype of the connector. Either \code{"one"} (to draw a
line on the horizontal side closest to the mark), \code{"all"} (to draw a border
on all sides), or \code{"none"} (not going to explain that one).}
\item{con.cap}{The distance before the mark that the line should stop at.}
\item{con.arrow}{An arrow specification for the connection using
\code{\link[grid:arrow]{grid::arrow()}} for the end pointing towards the mark.}
\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}. These are
often aesthetics, used to set an aesthetic to a fixed value, like
\code{colour = "red"} or \code{size = 3}. They may also be parameters
to the paired geom/stat.}
\item{na.rm}{If \code{FALSE}, the default, missing values are removed with
a warning. If \code{TRUE}, missing values are silently removed.}
\item{show.legend}{logical. Should this layer be included in the legends?
\code{NA}, the default, includes if any aesthetics are mapped.
\code{FALSE} never includes, and \code{TRUE} always includes.
It can also be a named logical vector to finely select the aesthetics to
display.}
\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics,
rather than combining with them. This is most useful for helper functions
that define both data and aesthetics and shouldn't inherit behaviour from
the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.}
}
\description{
This geom lets you annotate sets of points via rectangles. The rectangles are
simply scaled to the range of the data and as with the other
\verb{geom_mark_*()} geoms expanded and have rounded corners.
}
\section{Aesthetics}{
\code{geom_mark_rect} understands the following aesthetics (required aesthetics are
in bold):
\itemize{
\item \strong{x}
\item \strong{y}
\item x0 \emph{(used to anchor the label)}
\item y0 \emph{(used to anchor the label)}
\item filter
\item label
\item description
\item color
\item fill
\item group
\item size
\item linetype
\item alpha
}
}
\section{Annotation}{
All \verb{geom_mark_*} allow you to put descriptive textboxes connected to the
mark on the plot, using the \code{label} and \code{description} aesthetics. The
textboxes are automatically placed close to the mark, but without obscuring
any of the datapoints in the layer. The placement is dynamic so if you resize
the plot you'll see that the annotation might move around as areas become big
enough or too small to fit the annotation. If there's not enough space for
the annotation without overlapping data it will not get drawn. In these cases
try resizing the plot, change the size of the annotation, or decrease the
buffer region around the marks.
}
\section{Filtering}{
Often marks are used to draw attention to, or annotate specific features of
the plot and it is thus not desirable to have marks around everything. While
it is possible to simply pre-filter the data used for the mark layer, the
\verb{geom_mark_*} geoms also comes with a dedicated \code{filter} aesthetic that, if
set, will remove all rows where it evalutates to \code{FALSE}. There are
multiple benefits of using this instead of prefiltering. First, you don't
have to change your data source, making your code more adaptable for
exploration. Second, the data removed by the filter aesthetic is remembered
by the geom, and any annotation will take care not to overlap with the
removed data.
}
\examples{
ggplot(iris, aes(Petal.Length, Petal.Width)) +
geom_mark_rect(aes(fill = Species, filter = Species != 'versicolor')) +
geom_point()
# Add annotation
ggplot(iris, aes(Petal.Length, Petal.Width)) +
geom_mark_rect(aes(fill = Species, label = Species)) +
geom_point()
# Long descriptions are automatically wrapped to fit into the width
iris$desc <- c(
'A super Iris - and it knows it',
'Pretty mediocre Iris, but give it a couple of years and it might surprise you',
"You'll never guess what this Iris does every Sunday"
)[iris$Species]
ggplot(iris, aes(Petal.Length, Petal.Width)) +
geom_mark_rect(aes(fill = Species, label = Species, description = desc,
filter = Species == 'setosa')) +
geom_point()
# Change the buffer size to move labels farther away (or closer) from the
# marks
ggplot(iris, aes(Petal.Length, Petal.Width)) +
geom_mark_rect(aes(fill = Species, label = Species),
label.buffer = unit(30, 'mm')) +
geom_point()
# The connector is capped a bit before it reaches the mark, but this can be
# controlled
ggplot(iris, aes(Petal.Length, Petal.Width)) +
geom_mark_rect(aes(fill = Species, label = Species),
con.cap = 0) +
geom_point()
}
\seealso{
Other mark geoms:
\code{\link{geom_mark_circle}()},
\code{\link{geom_mark_ellipse}()},
\code{\link{geom_mark_hull}()}
}
\concept{mark geoms}
ggforce/man/position_auto.Rd 0000644 0001762 0000144 00000003305 13674074434 015641 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/position_auto.R
\name{position_auto}
\alias{position_auto}
\title{Jitter based on scale types}
\usage{
position_auto(jitter.width = 0.75, bw = "nrd0", scale = TRUE, seed = NA)
}
\arguments{
\item{jitter.width}{The maximal width of the jitter}
\item{bw}{The smoothing bandwidth to use in the case of sina jittering. See
the \code{bw} argument in \link[stats:density]{stats::density}}
\item{scale}{Should the width of jittering be scaled based on the number of
points in the group}
\item{seed}{A seed to supply to make the jittering reproducible across layers}
}
\description{
This position adjustment is able to select a meaningful jitter of the data
based on the combination of positional scale types. IT behaves differently
depending on if none, one, or both the x and y scales are discrete. If both
are discrete it will jitter the datapoints evenly inside a disc, if one of
them is discrete it will jitter the discrete dimension to follow the density
along the other dimension (like a sina plot). If neither are discrete it will
not do any jittering.
}
\examples{
# Continuous vs continuous: No jitter
ggplot(mpg) + geom_point(aes(cty, hwy), position = 'auto')
# Continuous vs discrete: sina jitter
ggplot(mpg) + geom_point(aes(cty, drv), position = 'auto')
# Discrete vs discrete: disc-jitter
ggplot(mpg) + geom_point(aes(fl, drv), position = 'auto')
# Don't scale the jitter based on group size
ggplot(mpg) + geom_point(aes(cty, drv), position = position_auto(scale = FALSE))
ggplot(mpg) + geom_point(aes(fl, drv), position = position_auto(scale = FALSE))
}
\seealso{
\link{geom_autopoint} for a point geom that uses auto-position by default
}
ggforce/man/geom_regon.Rd 0000644 0001762 0000144 00000010716 14303120026 015045 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/regon.R
\name{geom_regon}
\alias{geom_regon}
\alias{stat_regon}
\title{Draw regular polygons by specifying number of sides}
\usage{
stat_regon(
mapping = NULL,
data = NULL,
geom = "shape",
position = "identity",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
...
)
geom_regon(
mapping = NULL,
data = NULL,
stat = "regon",
position = "identity",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
...
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and
\code{inherit.aes = TRUE} (the default), it is combined with the default mapping
at the top level of the plot. You must supply \code{mapping} if there is no plot
mapping.}
\item{data}{The data to be displayed in this layer. There are three
options:
If \code{NULL}, the default, the data is inherited from the plot
data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}.
A \code{data.frame}, or other object, will override the plot
data. All objects will be fortified to produce a data frame. See
\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created.
A \code{function} will be called with a single argument,
the plot data. The return value must be a \code{data.frame}, and
will be used as the layer data. A \code{function} can be created
from a \code{formula} (e.g. \code{~ head(.x, 10)}).}
\item{geom}{The geometric object to use to display the data, either as a
\code{ggproto} \code{Geom} subclass or as a string naming the geom stripped of the
\code{geom_} prefix (e.g. \code{"point"} rather than \code{"geom_point"})}
\item{position}{Position adjustment, either as a string naming the adjustment
(e.g. \code{"jitter"} to use \code{position_jitter}), or the result of a call to a
position adjustment function. Use the latter if you need to change the
settings of the adjustment.}
\item{na.rm}{If \code{FALSE}, the default, missing values are removed with
a warning. If \code{TRUE}, missing values are silently removed.}
\item{show.legend}{logical. Should this layer be included in the legends?
\code{NA}, the default, includes if any aesthetics are mapped.
\code{FALSE} never includes, and \code{TRUE} always includes.
It can also be a named logical vector to finely select the aesthetics to
display.}
\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics,
rather than combining with them. This is most useful for helper functions
that define both data and aesthetics and shouldn't inherit behaviour from
the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.}
\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}. These are
often aesthetics, used to set an aesthetic to a fixed value, like
\code{colour = "red"} or \code{size = 3}. They may also be parameters
to the paired geom/stat.}
\item{stat}{The statistical transformation to use on the data for this
layer, either as a \code{ggproto} \code{Geom} subclass or as a string naming the
stat stripped of the \code{stat_} prefix (e.g. \code{"count"} rather than
\code{"stat_count"})}
}
\description{
This geom makes it easy to construct regular polygons (polygons where all
sides and angles are equal) by specifying the number of sides, position, and
size. The polygons are always rotated so that they "rest" on a flat side, but
this can be changed with the angle aesthetic. The size is based on the radius
of their circumcircle and is thus not proportional to their area.
}
\section{Aesthetics}{
geom_regon understand the following aesthetics (required aesthetics are in
bold):
\itemize{
\item \strong{x0} x coordinate
\item \strong{y0} y coordinate
\item \strong{sides} the number of sides for regon
\item \strong{r} the ratio of regon with respect to plot
\item \strong{angle} regon rotation angle (unit is radian)
\item color
\item fill
\item size
\item linetype
\item alpha
\item lineend
}
}
\section{Computed variables}{
\describe{
\item{x, y}{The coordinates for the corners of the polygon}
}
}
\examples{
ggplot() +
geom_regon(aes(x0 = runif(8), y0 = runif(8), sides = sample(3:10, 8),
angle = 0, r = runif(8) / 10)) +
coord_fixed()
# The polygons are drawn with geom_shape, so can be manipulated as such
ggplot() +
geom_regon(aes(x0 = runif(8), y0 = runif(8), sides = sample(3:10, 8),
angle = 0, r = runif(8) / 10),
expand = unit(1, 'cm'), radius = unit(1, 'cm')) +
coord_fixed()
}
ggforce/man/geom_mark_ellipse.Rd 0000644 0001762 0000144 00000023253 14564603246 016425 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/mark_ellipse.R
\name{geom_mark_ellipse}
\alias{geom_mark_ellipse}
\title{Annotate areas with ellipses}
\usage{
geom_mark_ellipse(
mapping = NULL,
data = NULL,
stat = "identity",
position = "identity",
expand = unit(5, "mm"),
radius = expand,
n = 100,
tol = 0.01,
label.margin = margin(2, 2, 2, 2, "mm"),
label.width = NULL,
label.minwidth = unit(50, "mm"),
label.hjust = 0,
label.fontsize = 12,
label.family = "",
label.lineheight = 1,
label.fontface = c("bold", "plain"),
label.fill = "white",
label.colour = "black",
label.buffer = unit(10, "mm"),
con.colour = "black",
con.size = 0.5,
con.type = "elbow",
con.linetype = 1,
con.border = "one",
con.cap = unit(3, "mm"),
con.arrow = NULL,
...,
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and
\code{inherit.aes = TRUE} (the default), it is combined with the default mapping
at the top level of the plot. You must supply \code{mapping} if there is no plot
mapping.}
\item{data}{The data to be displayed in this layer. There are three
options:
If \code{NULL}, the default, the data is inherited from the plot
data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}.
A \code{data.frame}, or other object, will override the plot
data. All objects will be fortified to produce a data frame. See
\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created.
A \code{function} will be called with a single argument,
the plot data. The return value must be a \code{data.frame}, and
will be used as the layer data. A \code{function} can be created
from a \code{formula} (e.g. \code{~ head(.x, 10)}).}
\item{stat}{The statistical transformation to use on the data for this
layer, either as a \code{ggproto} \code{Geom} subclass or as a string naming the
stat stripped of the \code{stat_} prefix (e.g. \code{"count"} rather than
\code{"stat_count"})}
\item{position}{Position adjustment, either as a string naming the adjustment
(e.g. \code{"jitter"} to use \code{position_jitter}), or the result of a call to a
position adjustment function. Use the latter if you need to change the
settings of the adjustment.}
\item{expand}{A numeric or unit vector of length one, specifying the
expansion amount. Negative values will result in contraction instead. If the
value is given as a numeric it will be understood as a proportion of the
plot area width.}
\item{radius}{As \code{expand} but specifying the corner radius.}
\item{n}{The number of points used to draw each ellipse. Defaults to \code{100}.}
\item{tol}{The tolerance cutoff. Lower values will result in ellipses closer
to the optimal solution. Defaults to \code{0.01}.}
\item{label.margin}{The margin around the annotation boxes, given by a call
to \code{\link[ggplot2:element]{ggplot2::margin()}}.}
\item{label.width}{A fixed width for the label. Set to \code{NULL} to let the text
or \code{label.minwidth} decide.}
\item{label.minwidth}{The minimum width to provide for the description. If
the size of the label exceeds this, the description is allowed to fill as
much as the label.}
\item{label.hjust}{The horizontal justification for the annotation. If it
contains two elements the first will be used for the label and the second for
the description.}
\item{label.fontsize}{The size of the text for the annotation. If it contains
two elements the first will be used for the label and the second for the
description.}
\item{label.family}{The font family used for the annotation. If it contains
two elements the first will be used for the label and the second for the
description.}
\item{label.lineheight}{The height of a line as a multipler of the fontsize.
If it contains two elements the first will be used for the label and the
second for the description.}
\item{label.fontface}{The font face used for the annotation. If it contains
two elements the first will be used for the label and the second for the
description.}
\item{label.fill}{The fill colour for the annotation box.}
\item{label.colour}{The text colour for the annotation. If it contains
two elements the first will be used for the label and the second for the
description.}
\item{label.buffer}{The size of the region around the mark where labels
cannot be placed.}
\item{con.colour}{The colour for the line connecting the annotation to the
mark.}
\item{con.size}{The width of the connector.}
\item{con.type}{The type of the connector. Either \code{"elbow"}, \code{"straight"}, or
\code{"none"}.}
\item{con.linetype}{The linetype of the connector.}
\item{con.border}{The bordertype of the connector. Either \code{"one"} (to draw a
line on the horizontal side closest to the mark), \code{"all"} (to draw a border
on all sides), or \code{"none"} (not going to explain that one).}
\item{con.cap}{The distance before the mark that the line should stop at.}
\item{con.arrow}{An arrow specification for the connection using
\code{\link[grid:arrow]{grid::arrow()}} for the end pointing towards the mark.}
\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}. These are
often aesthetics, used to set an aesthetic to a fixed value, like
\code{colour = "red"} or \code{size = 3}. They may also be parameters
to the paired geom/stat.}
\item{na.rm}{If \code{FALSE}, the default, missing values are removed with
a warning. If \code{TRUE}, missing values are silently removed.}
\item{show.legend}{logical. Should this layer be included in the legends?
\code{NA}, the default, includes if any aesthetics are mapped.
\code{FALSE} never includes, and \code{TRUE} always includes.
It can also be a named logical vector to finely select the aesthetics to
display.}
\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics,
rather than combining with them. This is most useful for helper functions
that define both data and aesthetics and shouldn't inherit behaviour from
the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.}
}
\description{
This geom lets you annotate sets of points via ellipses. The enclosing
ellipses are estimated using the Khachiyan algorithm which guarantees an
optimal solution within the given tolerance level. As this geom is often
expanded it is of lesser concern that some points are slightly outside the
ellipsis. The Khachiyan algorithm has polynomial complexity and can thus
suffer from scaling issues. Still, it is only calculated on the convex hull
of the groups, so performance issues should be rare (it can easily handle a
hull consisting of 1000 points).
}
\section{Aesthetics}{
\code{geom_mark_ellipse} understands the following aesthetics (required aesthetics are
in bold):
\itemize{
\item \strong{x}
\item \strong{y}
\item x0 \emph{(used to anchor the label)}
\item y0 \emph{(used to anchor the label)}
\item filter
\item label
\item description
\item color
\item fill
\item group
\item size
\item linetype
\item alpha
}
}
\section{Annotation}{
All \verb{geom_mark_*} allow you to put descriptive textboxes connected to the
mark on the plot, using the \code{label} and \code{description} aesthetics. The
textboxes are automatically placed close to the mark, but without obscuring
any of the datapoints in the layer. The placement is dynamic so if you resize
the plot you'll see that the annotation might move around as areas become big
enough or too small to fit the annotation. If there's not enough space for
the annotation without overlapping data it will not get drawn. In these cases
try resizing the plot, change the size of the annotation, or decrease the
buffer region around the marks.
}
\section{Filtering}{
Often marks are used to draw attention to, or annotate specific features of
the plot and it is thus not desirable to have marks around everything. While
it is possible to simply pre-filter the data used for the mark layer, the
\verb{geom_mark_*} geoms also comes with a dedicated \code{filter} aesthetic that, if
set, will remove all rows where it evalutates to \code{FALSE}. There are
multiple benefits of using this instead of prefiltering. First, you don't
have to change your data source, making your code more adaptable for
exploration. Second, the data removed by the filter aesthetic is remembered
by the geom, and any annotation will take care not to overlap with the
removed data.
}
\examples{
ggplot(iris, aes(Petal.Length, Petal.Width)) +
geom_mark_ellipse(aes(fill = Species, filter = Species != 'versicolor')) +
geom_point()
# Add annotation
ggplot(iris, aes(Petal.Length, Petal.Width)) +
geom_mark_ellipse(aes(fill = Species, label = Species)) +
geom_point()
# Long descriptions are automatically wrapped to fit into the width
iris$desc <- c(
'A super Iris - and it knows it',
'Pretty mediocre Iris, but give it a couple of years and it might surprise you',
"You'll never guess what this Iris does every Sunday"
)[iris$Species]
ggplot(iris, aes(Petal.Length, Petal.Width)) +
geom_mark_ellipse(aes(fill = Species, label = Species, description = desc,
filter = Species == 'setosa')) +
geom_point()
# Change the buffer size to move labels farther away (or closer) from the
# marks
ggplot(iris, aes(Petal.Length, Petal.Width)) +
geom_mark_ellipse(aes(fill = Species, label = Species),
label.buffer = unit(40, 'mm')) +
geom_point()
# The connector is capped a bit before it reaches the mark, but this can be
# controlled
ggplot(iris, aes(Petal.Length, Petal.Width)) +
geom_mark_ellipse(aes(fill = Species, label = Species),
con.cap = 0) +
geom_point()
}
\seealso{
Other mark geoms:
\code{\link{geom_mark_circle}()},
\code{\link{geom_mark_hull}()},
\code{\link{geom_mark_rect}()}
}
\concept{mark geoms}
ggforce/man/n_pages.Rd 0000644 0001762 0000144 00000001716 13435737063 014364 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/facet_wrap_paginate.R
\name{n_pages}
\alias{n_pages}
\title{Determine the number of pages in a paginated facet plot}
\usage{
n_pages(plot)
}
\arguments{
\item{plot}{A ggplot object using either facet_wrap_paginate or
facet_grid_paginate}
}
\value{
If the plot uses using either facet_wrap_paginate or
facet_grid_paginate it returns the total number of pages. Otherwise it
returns NULL
}
\description{
This is a simple helper that returns the number of pages it takes to plot all
panels when using \code{\link[=facet_wrap_paginate]{facet_wrap_paginate()}} and
\code{\link[=facet_grid_paginate]{facet_grid_paginate()}}. It partially builds the plot so depending
on the complexity of your plot it might take some time to calculate...
}
\examples{
p <- ggplot(diamonds) +
geom_point(aes(carat, price), alpha = 0.1) +
facet_wrap_paginate(~ cut:clarity, ncol = 3, nrow = 3, page = 1)
n_pages(p)
}
ggforce/man/facet_stereo.Rd 0000644 0001762 0000144 00000004365 13674074434 015417 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/facet_stereo.R
\name{facet_stereo}
\alias{facet_stereo}
\title{Create a stereogram plot}
\usage{
facet_stereo(IPD = 63.5, panel.size = 200, shrink = TRUE)
}
\arguments{
\item{IPD}{The interpupillary distance (in mm) used for calculating point
displacement. The default value is an average of both genders}
\item{panel.size}{The final plot size in mm. As IPD this is used to calculate
point displacement. Don't take this value too literal but experiment until
you get a nice effect. Lower values gives higher displacement and thus
require the plots to be observed from a closer distance}
\item{shrink}{If \code{TRUE}, will shrink scales to fit output of
statistics, not raw data. If \code{FALSE}, will be range of raw data
before statistical summary.}
}
\description{
This, arguably pretty useless function, lets you create plots with a sense of
depth by creating two slightly different versions of the plot that
corresponds to how the eyes would see it if the plot was 3 dimensional. To
experience the effect look at the plots through 3D hardware such as Google
Cardboard or by relaxing the eyes and focusing into the distance. The
depth of a point is calculated for layers having a depth aesthetic supplied.
The scaling of the depth can be controlled with \code{\link[=scale_depth]{scale_depth()}} as
you would control any aesthetic. Negative values will result in features
placed behind the paper plane, while positive values will result in
features hovering in front of the paper. While features within each layer is
sorted so those closest to you are plotted on top of those more distant, this
cannot be done between layers. Thus, layers are always plotted on top of
each others, even if the features in one layer lies behind features in a
layer behind it. The depth experience is inaccurate and should not be used
for conveying important data. Regard this more as a party-trick...
}
\examples{
# You'll have to accept a warning about depth being an unknown aesthetic
ggplot(mtcars) +
geom_point(aes(mpg, disp, depth = cyl)) +
facet_stereo()
}
\seealso{
Other ggforce facets:
\code{\link{facet_grid_paginate}()},
\code{\link{facet_wrap_paginate}()},
\code{\link{facet_zoom}()}
}
\concept{ggforce facets}
ggforce/man/geom_autohistogram.Rd 0000644 0001762 0000144 00000013107 14564603706 016642 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/autodensity.R, R/autohistogram.R
\name{geom_autodensity}
\alias{geom_autodensity}
\alias{geom_autohistogram}
\title{A distribution geoms that fills the panel and works with discrete and continuous data}
\usage{
geom_autodensity(
mapping = NULL,
data = NULL,
stat = "autodensity",
position = "floatstack",
...,
bw = "nrd0",
adjust = 1,
kernel = "gaussian",
n = 512,
trim = FALSE,
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
outline.type = "upper"
)
geom_autohistogram(
mapping = NULL,
data = NULL,
stat = "autobin",
position = "floatstack",
...,
bins = NULL,
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and
\code{inherit.aes = TRUE} (the default), it is combined with the default mapping
at the top level of the plot. You must supply \code{mapping} if there is no plot
mapping.}
\item{data}{The data to be displayed in this layer. There are three
options:
If \code{NULL}, the default, the data is inherited from the plot
data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}.
A \code{data.frame}, or other object, will override the plot
data. All objects will be fortified to produce a data frame. See
\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created.
A \code{function} will be called with a single argument,
the plot data. The return value must be a \code{data.frame}, and
will be used as the layer data. A \code{function} can be created
from a \code{formula} (e.g. \code{~ head(.x, 10)}).}
\item{stat}{The statistical transformation to use on the data for this
layer, either as a \code{ggproto} \code{Geom} subclass or as a string naming the
stat stripped of the \code{stat_} prefix (e.g. \code{"count"} rather than
\code{"stat_count"})}
\item{position}{Position adjustment, either as a string naming the adjustment
(e.g. \code{"jitter"} to use \code{position_jitter}), or the result of a call to a
position adjustment function. Use the latter if you need to change the
settings of the adjustment.}
\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}. These are
often aesthetics, used to set an aesthetic to a fixed value, like
\code{colour = "red"} or \code{size = 3}. They may also be parameters
to the paired geom/stat.}
\item{bw}{The smoothing bandwidth to be used.
If numeric, the standard deviation of the smoothing kernel.
If character, a rule to choose the bandwidth, as listed in
\code{\link[stats:bandwidth]{stats::bw.nrd()}}. Note that automatic calculation of the bandwidth does
not take weights into account.}
\item{adjust}{A multiplicate bandwidth adjustment. This makes it possible
to adjust the bandwidth while still using the a bandwidth estimator.
For example, \code{adjust = 1/2} means use half of the default bandwidth.}
\item{kernel}{Kernel. See list of available kernels in \code{\link[=density]{density()}}.}
\item{n}{number of equally spaced points at which the density is to be
estimated, should be a power of two, see \code{\link[=density]{density()}} for
details}
\item{trim}{If \code{FALSE}, the default, each density is computed on the
full range of the data. If \code{TRUE}, each density is computed over the
range of that group: this typically means the estimated x values will
not line-up, and hence you won't be able to stack density values.
This parameter only matters if you are displaying multiple densities in
one plot or if you are manually adjusting the scale limits.}
\item{na.rm}{If \code{FALSE}, the default, missing values are removed with
a warning. If \code{TRUE}, missing values are silently removed.}
\item{show.legend}{logical. Should this layer be included in the legends?
\code{NA}, the default, includes if any aesthetics are mapped.
\code{FALSE} never includes, and \code{TRUE} always includes.
It can also be a named logical vector to finely select the aesthetics to
display.}
\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics,
rather than combining with them. This is most useful for helper functions
that define both data and aesthetics and shouldn't inherit behaviour from
the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.}
\item{outline.type}{Type of the outline of the area; \code{"both"} draws both the
upper and lower lines, \code{"upper"}/\code{"lower"} draws the respective lines only.
\code{"full"} draws a closed polygon around the area.}
\item{bins}{Number of bins. Overridden by \code{binwidth}. Defaults to 30.}
}
\description{
These versions of the histogram and density geoms have been designed
specifically for diagonal plotting with \code{\link[=facet_matrix]{facet_matrix()}}. They differ from
\code{\link[ggplot2:geom_histogram]{ggplot2::geom_histogram()}} and \code{\link[ggplot2:geom_density]{ggplot2::geom_density()}} in that they
defaults to mapping \code{x} and \code{y} to \code{.panel_x} and \code{.panel_y} respectively,
they ignore the y scale of the panel and fills it out, and they work for both
continuous and discrete x scales.
}
\examples{
# A matrix plot with a mix of discrete and continuous variables
p <- ggplot(mpg) +
geom_autopoint() +
facet_matrix(vars(drv:fl), layer.diag = 2, grid.y.diag = FALSE)
p
# Diagonal histograms
p + geom_autohistogram()
# Diagonal density distributions
p + geom_autodensity()
# You can use them like regular layers with groupings etc
p + geom_autodensity(aes(colour = drv, fill = drv),
alpha = 0.4)
}
\seealso{
\link{facet_matrix} for creating matrix grids
}
ggforce/man/geom_mark_circle.Rd 0000644 0001762 0000144 00000022511 14564603246 016225 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/mark_circle.R
\name{geom_mark_circle}
\alias{geom_mark_circle}
\title{Annotate areas with circles}
\usage{
geom_mark_circle(
mapping = NULL,
data = NULL,
stat = "identity",
position = "identity",
expand = unit(5, "mm"),
radius = expand,
n = 100,
label.margin = margin(2, 2, 2, 2, "mm"),
label.width = NULL,
label.minwidth = unit(50, "mm"),
label.hjust = 0,
label.fontsize = 12,
label.family = "",
label.lineheight = 1,
label.fontface = c("bold", "plain"),
label.fill = "white",
label.colour = "black",
label.buffer = unit(10, "mm"),
con.colour = "black",
con.size = 0.5,
con.type = "elbow",
con.linetype = 1,
con.border = "one",
con.cap = unit(3, "mm"),
con.arrow = NULL,
...,
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and
\code{inherit.aes = TRUE} (the default), it is combined with the default mapping
at the top level of the plot. You must supply \code{mapping} if there is no plot
mapping.}
\item{data}{The data to be displayed in this layer. There are three
options:
If \code{NULL}, the default, the data is inherited from the plot
data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}.
A \code{data.frame}, or other object, will override the plot
data. All objects will be fortified to produce a data frame. See
\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created.
A \code{function} will be called with a single argument,
the plot data. The return value must be a \code{data.frame}, and
will be used as the layer data. A \code{function} can be created
from a \code{formula} (e.g. \code{~ head(.x, 10)}).}
\item{stat}{The statistical transformation to use on the data for this
layer, either as a \code{ggproto} \code{Geom} subclass or as a string naming the
stat stripped of the \code{stat_} prefix (e.g. \code{"count"} rather than
\code{"stat_count"})}
\item{position}{Position adjustment, either as a string naming the adjustment
(e.g. \code{"jitter"} to use \code{position_jitter}), or the result of a call to a
position adjustment function. Use the latter if you need to change the
settings of the adjustment.}
\item{expand}{A numeric or unit vector of length one, specifying the
expansion amount. Negative values will result in contraction instead. If the
value is given as a numeric it will be understood as a proportion of the
plot area width.}
\item{radius}{As \code{expand} but specifying the corner radius.}
\item{n}{The number of points used to draw each circle. Defaults to \code{100}.}
\item{label.margin}{The margin around the annotation boxes, given by a call
to \code{\link[ggplot2:element]{ggplot2::margin()}}.}
\item{label.width}{A fixed width for the label. Set to \code{NULL} to let the text
or \code{label.minwidth} decide.}
\item{label.minwidth}{The minimum width to provide for the description. If
the size of the label exceeds this, the description is allowed to fill as
much as the label.}
\item{label.hjust}{The horizontal justification for the annotation. If it
contains two elements the first will be used for the label and the second for
the description.}
\item{label.fontsize}{The size of the text for the annotation. If it contains
two elements the first will be used for the label and the second for the
description.}
\item{label.family}{The font family used for the annotation. If it contains
two elements the first will be used for the label and the second for the
description.}
\item{label.lineheight}{The height of a line as a multipler of the fontsize.
If it contains two elements the first will be used for the label and the
second for the description.}
\item{label.fontface}{The font face used for the annotation. If it contains
two elements the first will be used for the label and the second for the
description.}
\item{label.fill}{The fill colour for the annotation box.}
\item{label.colour}{The text colour for the annotation. If it contains
two elements the first will be used for the label and the second for the
description.}
\item{label.buffer}{The size of the region around the mark where labels
cannot be placed.}
\item{con.colour}{The colour for the line connecting the annotation to the
mark.}
\item{con.size}{The width of the connector.}
\item{con.type}{The type of the connector. Either \code{"elbow"}, \code{"straight"}, or
\code{"none"}.}
\item{con.linetype}{The linetype of the connector.}
\item{con.border}{The bordertype of the connector. Either \code{"one"} (to draw a
line on the horizontal side closest to the mark), \code{"all"} (to draw a border
on all sides), or \code{"none"} (not going to explain that one).}
\item{con.cap}{The distance before the mark that the line should stop at.}
\item{con.arrow}{An arrow specification for the connection using
\code{\link[grid:arrow]{grid::arrow()}} for the end pointing towards the mark.}
\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}. These are
often aesthetics, used to set an aesthetic to a fixed value, like
\code{colour = "red"} or \code{size = 3}. They may also be parameters
to the paired geom/stat.}
\item{na.rm}{If \code{FALSE}, the default, missing values are removed with
a warning. If \code{TRUE}, missing values are silently removed.}
\item{show.legend}{logical. Should this layer be included in the legends?
\code{NA}, the default, includes if any aesthetics are mapped.
\code{FALSE} never includes, and \code{TRUE} always includes.
It can also be a named logical vector to finely select the aesthetics to
display.}
\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics,
rather than combining with them. This is most useful for helper functions
that define both data and aesthetics and shouldn't inherit behaviour from
the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.}
}
\description{
This geom lets you annotate sets of points via circles. The enclosing circles
are calculated at draw time and the most optimal enclosure at the given
aspect ratio is thus guaranteed. As with the other \verb{geom_mark_*} geoms the
enclosure inherits from \code{\link[=geom_shape]{geom_shape()}} and defaults to be expanded slightly
to better enclose the points.
}
\section{Annotation}{
All \verb{geom_mark_*} allow you to put descriptive textboxes connected to the
mark on the plot, using the \code{label} and \code{description} aesthetics. The
textboxes are automatically placed close to the mark, but without obscuring
any of the datapoints in the layer. The placement is dynamic so if you resize
the plot you'll see that the annotation might move around as areas become big
enough or too small to fit the annotation. If there's not enough space for
the annotation without overlapping data it will not get drawn. In these cases
try resizing the plot, change the size of the annotation, or decrease the
buffer region around the marks.
}
\section{Filtering}{
Often marks are used to draw attention to, or annotate specific features of
the plot and it is thus not desirable to have marks around everything. While
it is possible to simply pre-filter the data used for the mark layer, the
\verb{geom_mark_*} geoms also comes with a dedicated \code{filter} aesthetic that, if
set, will remove all rows where it evalutates to \code{FALSE}. There are
multiple benefits of using this instead of prefiltering. First, you don't
have to change your data source, making your code more adaptable for
exploration. Second, the data removed by the filter aesthetic is remembered
by the geom, and any annotation will take care not to overlap with the
removed data.
}
\section{Aesthetics}{
geom_mark_circle understand the following aesthetics (required aesthetics are
in bold):
\itemize{
\item \strong{x}
\item \strong{y}
\item x0 \emph{(used to anchor the label)}
\item y0 \emph{(used to anchor the label)}
\item filter
\item label
\item description
\item color
\item fill
\item group
\item size
\item linetype
\item alpha
}
}
\examples{
ggplot(iris, aes(Petal.Length, Petal.Width)) +
geom_mark_circle(aes(fill = Species, filter = Species != 'versicolor')) +
geom_point()
# Add annotation
ggplot(iris, aes(Petal.Length, Petal.Width)) +
geom_mark_circle(aes(fill = Species, label = Species)) +
geom_point()
# Long descriptions are automatically wrapped to fit into the width
iris$desc <- c(
'A super Iris - and it knows it',
'Pretty mediocre Iris, but give it a couple of years and it might surprise you',
"You'll never guess what this Iris does every Sunday"
)[iris$Species]
ggplot(iris, aes(Petal.Length, Petal.Width)) +
geom_mark_circle(aes(fill = Species, label = Species, description = desc,
filter = Species == 'setosa')) +
geom_point()
# Change the buffer size to move labels farther away (or closer) from the
# marks
ggplot(iris, aes(Petal.Length, Petal.Width)) +
geom_mark_circle(aes(fill = Species, label = Species),
label.buffer = unit(30, 'mm')) +
geom_point()
# The connector is capped a bit before it reaches the mark, but this can be
# controlled
ggplot(iris, aes(Petal.Length, Petal.Width)) +
geom_mark_circle(aes(fill = Species, label = Species),
con.cap = 0) +
geom_point()
}
\seealso{
Other mark geoms:
\code{\link{geom_mark_ellipse}()},
\code{\link{geom_mark_hull}()},
\code{\link{geom_mark_rect}()}
}
\concept{mark geoms}
ggforce/man/interpolateDataFrame.Rd 0000644 0001762 0000144 00000000614 14564603706 017037 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/interpolate.R
\name{interpolateDataFrame}
\alias{interpolateDataFrame}
\title{Interpolate layer data}
\usage{
interpolateDataFrame(data)
}
\arguments{
\item{data}{A data.frame with data for a layer}
}
\value{
A similar data.frame with NA values interpolated
}
\description{
Interpolate layer data
}
\keyword{internal}
ggforce/man/scale_depth.Rd 0000644 0001762 0000144 00000002317 13435737063 015221 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/scale-depth.R
\name{scale_depth}
\alias{scale_depth}
\alias{scale_depth_continuous}
\alias{scale_depth_discrete}
\title{Scales for depth perception}
\usage{
scale_depth(..., range = c(0, 0.3))
scale_depth_continuous(..., range = c(0, 0.3))
scale_depth_discrete(..., range = c(0, 0.3))
}
\arguments{
\item{...}{arguments passed on to continuous_scale or discrete_scale}
\item{range}{The relative range as related to the distance between the eyes
and the paper plane.}
}
\description{
These scales serve to scale the depth aesthetic when creating stereographic
plots. The range specifies the relative distance between the points and the
paper plane in relation to the distance between the eyes and the paper plane
i.e. a range of c(-0.5, 0.5) would put the highest values midways between
the eyes and the image plane and the lowest values the same distance behind
the image plane. To ensure a nice viewing experience these values should not
exceed ~0.3 as it would get hard for the eyes to consolidate the two
pictures.
}
\examples{
ggplot(mtcars) +
geom_point(aes(mpg, disp, depth = cyl)) +
scale_depth(range = c(-0.1, 0.25)) +
facet_stereo()
}
ggforce/man/facet_wrap_paginate.Rd 0000644 0001762 0000144 00000007541 14303101256 016715 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/facet_wrap_paginate.R
\name{facet_wrap_paginate}
\alias{facet_wrap_paginate}
\title{Split facet_wrap over multiple plots}
\usage{
facet_wrap_paginate(
facets,
nrow = NULL,
ncol = NULL,
scales = "fixed",
shrink = TRUE,
labeller = "label_value",
as.table = TRUE,
switch = deprecated(),
drop = TRUE,
dir = "h",
strip.position = "top",
page = 1
)
}
\arguments{
\item{facets}{A set of variables or expressions quoted by \code{\link[ggplot2:vars]{vars()}}
and defining faceting groups on the rows or columns dimension.
The variables can be named (the names are passed to \code{labeller}).
For compatibility with the classic interface, can also be a
formula or character vector. Use either a one sided formula, \code{~a + b},
or a character vector, \code{c("a", "b")}.}
\item{nrow, ncol}{Number of rows and columns}
\item{scales}{Should scales be fixed (\code{"fixed"}, the default),
free (\code{"free"}), or free in one dimension (\code{"free_x"},
\code{"free_y"})?}
\item{shrink}{If \code{TRUE}, will shrink scales to fit output of
statistics, not raw data. If \code{FALSE}, will be range of raw data
before statistical summary.}
\item{labeller}{A function that takes one data frame of labels and
returns a list or data frame of character vectors. Each input
column corresponds to one factor. Thus there will be more than
one with \code{vars(cyl, am)}. Each output
column gets displayed as one separate line in the strip
label. This function should inherit from the "labeller" S3 class
for compatibility with \code{\link[ggplot2:labeller]{labeller()}}. You can use different labeling
functions for different kind of labels, for example use \code{\link[ggplot2:label_parsed]{label_parsed()}} for
formatting facet labels. \code{\link[ggplot2:label_value]{label_value()}} is used by default,
check it for more details and pointers to other options.}
\item{as.table}{If \code{TRUE}, the default, the facets are laid out like
a table with highest values at the bottom-right. If \code{FALSE}, the
facets are laid out like a plot with the highest value at the top-right.}
\item{switch}{By default, the labels are displayed on the top and
right of the plot. If \code{"x"}, the top labels will be
displayed to the bottom. If \code{"y"}, the right-hand side
labels will be displayed to the left. Can also be set to
\code{"both"}.}
\item{drop}{If \code{TRUE}, the default, all factor levels not used in the
data will automatically be dropped. If \code{FALSE}, all factor levels
will be shown, regardless of whether or not they appear in the data.}
\item{dir}{Direction: either \code{"h"} for horizontal, the default, or \code{"v"},
for vertical.}
\item{strip.position}{By default, the labels are displayed on the top of
the plot. Using \code{strip.position} it is possible to place the labels on
either of the four sides by setting \code{strip.position = c("top",
"bottom", "left", "right")}}
\item{page}{The page to draw}
}
\description{
This extension to \code{\link[ggplot2:facet_wrap]{ggplot2::facet_wrap()}} will allow you to split
a facetted plot over multiple pages. You define a number of rows and columns
per page as well as the page number to plot, and the function will
automatically only plot the correct panels. Usually this will be put in a
loop to render all pages one by one.
}
\note{
If either \code{ncol} or \code{nrow} is \code{NULL} this function will
fall back to the standard \code{facet_wrap} functionality.
}
\examples{
ggplot(diamonds) +
geom_point(aes(carat, price), alpha = 0.1) +
facet_wrap_paginate(~ cut:clarity, ncol = 3, nrow = 3, page = 4)
}
\seealso{
\code{\link[=n_pages]{n_pages()}} to compute the total number of pages in a paginated
faceted plot
Other ggforce facets:
\code{\link{facet_grid_paginate}()},
\code{\link{facet_stereo}()},
\code{\link{facet_zoom}()}
}
\concept{ggforce facets}
ggforce/man/geom_link.Rd 0000644 0001762 0000144 00000014472 14303120026 014673 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/link.R
\name{geom_link}
\alias{geom_link}
\alias{stat_link}
\alias{stat_link2}
\alias{geom_link2}
\alias{geom_link0}
\title{Link points with paths}
\usage{
stat_link(
mapping = NULL,
data = NULL,
geom = "path",
position = "identity",
na.rm = FALSE,
show.legend = NA,
n = 100,
inherit.aes = TRUE,
...
)
stat_link2(
mapping = NULL,
data = NULL,
geom = "path_interpolate",
position = "identity",
na.rm = FALSE,
show.legend = NA,
n = 100,
inherit.aes = TRUE,
...
)
geom_link(
mapping = NULL,
data = NULL,
stat = "link",
position = "identity",
arrow = NULL,
lineend = "butt",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
n = 100,
...
)
geom_link2(
mapping = NULL,
data = NULL,
stat = "link2",
position = "identity",
arrow = NULL,
lineend = "butt",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
n = 100,
...
)
geom_link0(
mapping = NULL,
data = NULL,
stat = "identity",
position = "identity",
...,
arrow = NULL,
arrow.fill = NULL,
lineend = "butt",
linejoin = "round",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and
\code{inherit.aes = TRUE} (the default), it is combined with the default mapping
at the top level of the plot. You must supply \code{mapping} if there is no plot
mapping.}
\item{data}{The data to be displayed in this layer. There are three
options:
If \code{NULL}, the default, the data is inherited from the plot
data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}.
A \code{data.frame}, or other object, will override the plot
data. All objects will be fortified to produce a data frame. See
\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created.
A \code{function} will be called with a single argument,
the plot data. The return value must be a \code{data.frame}, and
will be used as the layer data. A \code{function} can be created
from a \code{formula} (e.g. \code{~ head(.x, 10)}).}
\item{geom}{The geometric object to use to display the data, either as a
\code{ggproto} \code{Geom} subclass or as a string naming the geom stripped of the
\code{geom_} prefix (e.g. \code{"point"} rather than \code{"geom_point"})}
\item{position}{Position adjustment, either as a string naming the adjustment
(e.g. \code{"jitter"} to use \code{position_jitter}), or the result of a call to a
position adjustment function. Use the latter if you need to change the
settings of the adjustment.}
\item{na.rm}{If \code{FALSE}, the default, missing values are removed with
a warning. If \code{TRUE}, missing values are silently removed.}
\item{show.legend}{logical. Should this layer be included in the legends?
\code{NA}, the default, includes if any aesthetics are mapped.
\code{FALSE} never includes, and \code{TRUE} always includes.
It can also be a named logical vector to finely select the aesthetics to
display.}
\item{n}{The number of points to create for each segment}
\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics,
rather than combining with them. This is most useful for helper functions
that define both data and aesthetics and shouldn't inherit behaviour from
the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.}
\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}. These are
often aesthetics, used to set an aesthetic to a fixed value, like
\code{colour = "red"} or \code{size = 3}. They may also be parameters
to the paired geom/stat.}
\item{stat}{The statistical transformation to use on the data for this
layer, either as a \code{ggproto} \code{Geom} subclass or as a string naming the
stat stripped of the \code{stat_} prefix (e.g. \code{"count"} rather than
\code{"stat_count"})}
\item{arrow}{Arrow specification, as created by \code{\link[grid:arrow]{grid::arrow()}}.}
\item{lineend}{Line end style (round, butt, square).}
\item{arrow.fill}{fill colour to use for the arrow head (if closed). \code{NULL}
means use \code{colour} aesthetic.}
\item{linejoin}{Line join style (round, mitre, bevel).}
}
\description{
This set of geoms makes it possible to connect points using straight lines.
Before you think \code{\link[ggplot2:geom_segment]{ggplot2::geom_segment()}} and
\code{\link[ggplot2:geom_path]{ggplot2::geom_path()}}, these functions have some additional tricks
up their sleeves. geom_link connects two points in the same way as
\code{\link[ggplot2:geom_segment]{ggplot2::geom_segment()}} but does so by interpolating multiple
points between the two. An additional column called index is added to the
data with a sequential progression of the interpolated points. This can be
used to map color or size to the direction of the link. geom_link2 uses the
same syntax as \code{\link[ggplot2:geom_path]{ggplot2::geom_path()}} but interpolates between the
aesthetics given by each row in the data.
}
\section{Aesthetics}{
geom_link understand the following aesthetics (required aesthetics are in
bold):
\itemize{
\item \strong{x}
\item \strong{y}
\item \strong{xend}
\item \strong{yend}
\item color
\item size
\item linetype
\item alpha
\item lineend
}
geom_link2 understand the following aesthetics (required aesthetics are in
bold):
\itemize{
\item \strong{x}
\item \strong{y}
\item color
\item size
\item linetype
\item alpha
\item lineend
}
}
\section{Computed variables}{
\describe{
\item{x, y}{The interpolated point coordinates}
\item{index}{The progression along the interpolation mapped between 0 and 1}
}
}
\examples{
# Lets make some data
lines <- data.frame(
x = c(5, 12, 15, 9, 6),
y = c(17, 20, 4, 15, 5),
xend = c(19, 17, 2, 9, 5),
yend = c(10, 18, 7, 12, 1),
width = c(1, 10, 6, 2, 3),
colour = letters[1:5]
)
ggplot(lines) +
geom_link(aes(x = x, y = y, xend = xend, yend = yend, colour = colour,
alpha = stat(index), size = after_stat(index)))
ggplot(lines) +
geom_link2(aes(x = x, y = y, colour = colour, size = width, group = 1),
lineend = 'round', n = 500)
# geom_link0 is simply an alias for geom_segment to put the link geoms in
# line with the other line geoms with multiple versions. `index` is not
# available here
ggplot(lines) +
geom_link0(aes(x = x, y = y, xend = xend, yend = yend, colour = colour))
}
ggforce/man/linear_trans.Rd 0000644 0001762 0000144 00000002725 13435737063 015432 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/trans_linear.R
\name{linear_trans}
\alias{linear_trans}
\alias{rotate}
\alias{stretch}
\alias{shear}
\alias{translate}
\alias{reflect}
\title{Create a custom linear transformation}
\usage{
linear_trans(...)
rotate(angle)
stretch(x, y)
shear(x, y)
translate(x, y)
reflect(x, y)
}
\arguments{
\item{...}{A number of transformation functions.}
\item{angle}{An angle in radians}
\item{x}{the transformation magnitude in the x-direction}
\item{y}{the transformation magnitude in the x-direction}
}
\value{
\code{linear_trans} creates a trans object. The other functions
return a 3x3 transformation matrix.
}
\description{
This function lets you compose transformations based on a sequence of linear
transformations. If the transformations are parameterised the parameters will
become arguments in the transformation function. The transformations are
one of \code{rotate}, \code{shear}, \code{stretch}, \code{translate}, and
\code{reflect}.
}
\examples{
trans <- linear_trans(rotate(a), shear(1, 0), translate(x1, y1))
square <- data.frame(x = c(0, 0, 1, 1), y = c(0, 1, 1, 0))
square2 <- trans$transform(square$x, square$y, a = pi / 3, x1 = 4, y1 = 8)
square3 <- trans$transform(square$x, square$y, a = pi / 1.5, x1 = 2, y1 = -6)
square <- rbind(square, square2, square3)
square$group <- rep(1:3, each = 4)
ggplot(square, aes(x, y, group = group)) +
geom_polygon(aes(fill = factor(group)), colour = 'black')
}
ggforce/man/geom_autopoint.Rd 0000644 0001762 0000144 00000007151 14303120026 015754 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/autopoint.R
\name{geom_autopoint}
\alias{geom_autopoint}
\title{A point geom specialised for scatterplot matrices}
\usage{
geom_autopoint(
mapping = NULL,
data = NULL,
stat = "identity",
position = "auto",
...,
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and
\code{inherit.aes = TRUE} (the default), it is combined with the default mapping
at the top level of the plot. You must supply \code{mapping} if there is no plot
mapping.}
\item{data}{The data to be displayed in this layer. There are three
options:
If \code{NULL}, the default, the data is inherited from the plot
data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}.
A \code{data.frame}, or other object, will override the plot
data. All objects will be fortified to produce a data frame. See
\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created.
A \code{function} will be called with a single argument,
the plot data. The return value must be a \code{data.frame}, and
will be used as the layer data. A \code{function} can be created
from a \code{formula} (e.g. \code{~ head(.x, 10)}).}
\item{stat}{The statistical transformation to use on the data for this
layer, either as a \code{ggproto} \code{Geom} subclass or as a string naming the
stat stripped of the \code{stat_} prefix (e.g. \code{"count"} rather than
\code{"stat_count"})}
\item{position}{Position adjustment, either as a string naming the adjustment
(e.g. \code{"jitter"} to use \code{position_jitter}), or the result of a call to a
position adjustment function. Use the latter if you need to change the
settings of the adjustment.}
\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}. These are
often aesthetics, used to set an aesthetic to a fixed value, like
\code{colour = "red"} or \code{size = 3}. They may also be parameters
to the paired geom/stat.}
\item{na.rm}{If \code{FALSE}, the default, missing values are removed with
a warning. If \code{TRUE}, missing values are silently removed.}
\item{show.legend}{logical. Should this layer be included in the legends?
\code{NA}, the default, includes if any aesthetics are mapped.
\code{FALSE} never includes, and \code{TRUE} always includes.
It can also be a named logical vector to finely select the aesthetics to
display.}
\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics,
rather than combining with them. This is most useful for helper functions
that define both data and aesthetics and shouldn't inherit behaviour from
the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.}
}
\description{
This geom is a specialisation of \code{\link[ggplot2:geom_point]{ggplot2::geom_point()}} with two changes. It
defaults to mapping \code{x} and \code{y} to \code{.panel_x} and \code{.panel_y} respectively,
and it defaults to using \code{\link[=position_auto]{position_auto()}} to jitter the points based on the
combination of position scale types.
}
\examples{
# Continuous vs continuous: No jitter
ggplot(mpg) + geom_autopoint(aes(cty, hwy))
# Continuous vs discrete: sina jitter
ggplot(mpg) + geom_autopoint(aes(cty, drv))
# Discrete vs discrete: disc-jitter
ggplot(mpg) + geom_autopoint(aes(fl, drv))
# Used with facet_matrix (x and y are automatically mapped)
ggplot(mpg) +
geom_autopoint() +
facet_matrix(vars(drv:fl))
}
\seealso{
\link{facet_matrix} for how to lay out scatterplot matrices and
\link{position_auto} for information about the position adjustments
}
ggforce/man/power_trans.Rd 0000644 0001762 0000144 00000001326 14276646344 015315 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/trans.R
\name{power_trans}
\alias{power_trans}
\title{Create a power transformation object}
\usage{
power_trans(n)
}
\arguments{
\item{n}{The degree of the power transformation}
}
\value{
A trans object
}
\description{
This function can be used to create a proper trans object that encapsulates
a power transformation (x^n).
}
\examples{
# Power of 2 transformations
trans <- power_trans(2)
trans$transform(1:10)
# Cubic root transformation
trans <- power_trans(1 / 3)
trans$transform(1:10)
# Use it in a plot
ggplot() +
geom_line(aes(x = 1:10, y = 1:10)) +
scale_x_continuous(trans = power_trans(2),
expand = c(0, 1))
}
ggforce/DESCRIPTION 0000644 0001762 0000144 00000004477 14564632262 013422 0 ustar ligges users Package: ggforce
Type: Package
Title: Accelerating 'ggplot2'
Version: 0.4.2
Authors@R:
c(person(given = "Thomas Lin",
family = "Pedersen",
role = c("cre", "aut"),
email = "thomasp85@gmail.com",
comment = c(ORCID = "0000-0002-5147-4711")),
person("RStudio",
role = "cph"))
Maintainer: Thomas Lin Pedersen
Description: The aim of 'ggplot2' is to aid in visual data investigations. This
focus has led to a lack of facilities for composing specialised plots.
'ggforce' aims to be a collection of mainly new stats and geoms that fills
this gap. All additional functionality is aimed to come through the official
extension system so using 'ggforce' should be a stable experience.
URL: https://ggforce.data-imaginist.com,
https://github.com/thomasp85/ggforce
BugReports: https://github.com/thomasp85/ggforce/issues
License: MIT + file LICENSE
Encoding: UTF-8
Depends: ggplot2 (>= 3.3.6), R (>= 3.3.0)
Imports: Rcpp (>= 0.12.2), grid, scales, MASS, tweenr (>= 0.1.5),
gtable, rlang, polyclip, stats, grDevices, tidyselect, withr,
utils, lifecycle, cli, vctrs, systemfonts
LinkingTo: Rcpp, RcppEigen
RoxygenNote: 7.3.1
Suggests: sessioninfo, concaveman, deldir, latex2exp, reshape2, units
(>= 0.4-6), covr
Collate: 'RcppExports.R' 'aaa.R' 'shape.R' 'arc_bar.R' 'arc.R'
'autodensity.R' 'autohistogram.R' 'autopoint.R' 'bezier.R'
'bspline.R' 'bspline_closed.R' 'circle.R' 'diagonal.R'
'diagonal_wide.R' 'ellipse.R' 'errorbar.R'
'facet_grid_paginate.R' 'facet_matrix.R' 'facet_row.R'
'facet_stereo.R' 'facet_wrap_paginate.R' 'facet_zoom.R'
'ggforce-package.R' 'ggproto-classes.R' 'interpolate.R'
'labeller.R' 'link.R' 'mark_circle.R' 'mark_ellipse.R'
'mark_hull.R' 'mark_label.R' 'mark_rect.R' 'parallel_sets.R'
'position-jitternormal.R' 'position_auto.R'
'position_floatstack.R' 'regon.R' 'scale-depth.R'
'scale-unit.R' 'sina.R' 'spiro.R' 'themes.R' 'trans.R'
'trans_linear.R' 'utilities.R' 'voronoi.R' 'zzz.R'
NeedsCompilation: yes
Packaged: 2024-02-19 08:06:23 UTC; thomas
Author: Thomas Lin Pedersen [cre, aut]
(),
RStudio [cph]
Repository: CRAN
Date/Publication: 2024-02-19 11:00:02 UTC
ggforce/src/ 0000755 0001762 0000144 00000000000 14564605777 012502 5 ustar ligges users ggforce/src/deBoor.h 0000644 0001762 0000144 00000001715 13436332334 014050 0 ustar ligges users // Taken from https://chi3x10.wordpress.com/2009/10/18/de-boor-algorithm-in-c/
#include
// Class for dealing with points/vectors in a 2-dimensional space
class Point {
public:
double x;
double y;
Point();
Point(double xInit, double yInit);
// copy assignment operator
Point operator=(const Point pt);
// Arithmatic operators
Point operator+(const Point pt) const;
Point operator*(double m) const;
Point operator/(double m) const;
};
// Find the interval in knots where x resides
int whichInterval(double x, std::vector knots);
// Calculate the position along the B-spline given by x
// The spline is defined by the degree, knots and ctrlPoints. When calling k
// should equal degree but due to the recursive nature k will decrease to
// zero during recursion. i gives the interval in knots that x resides in
Point deBoor(int k, int degree, int i, double x, std::vector knots,
std::vector ctrlPoints);
ggforce/src/enclose.cpp 0000644 0001762 0000144 00000014047 14564603246 014631 0 ustar ligges users #include
using namespace Rcpp;
inline int randWrapper(const int n) {
return std::floor(float(unif_rand()*n));
}
struct Circle {
double x;
double y;
double r;
};
struct Point {
double x;
double y;
};
bool equalPoints(Point &p1, Point &p2) {
return std::abs(float(p2.x - p1.x)) < 1e-9 && std::abs(float(p2.y - p1.y)) < 1e-9;
}
bool perpendicularPoints(Point &p1, Point &p2) {
return std::abs(float(p2.x - p1.x)) < 1e-9 || std::abs(float(p2.y - p1.y)) < 1e-9;
}
bool horizontalPoints(Point &p1, Point &p2) {
return std::abs(float(p2.y - p1.y)) < 1e-9;
}
bool verticalPoints(Point &p1, Point &p2) {
return std::abs(float(p2.x - p1.x)) < 1e-9;
}
Circle circleByPoints(Point &p1, Point &p2, Point &p3) {
Circle results;
double X1, Y1, X2, Y2, A1, A2;
X1 = p2.x - p1.x;
Y1 = p2.y - p1.y;
X2 = p3.x - p2.x;
Y2 = p3.y - p2.y;
A1 = Y1/X1;
A2 = Y2/X2;
if (std::abs(float(A2 - A1)) < 1e-9) stop("Error in circleByPoints: The 3 points are colinear");
results.x = ( A1*A2*(p1.y - p3.y) + A2*(p1.x + p2.x) - A1*(p2.x+p3.x) )/( 2* (A2 - A1) );
results.y = -1*( results.x - (p1.x + p2.x)/2 )/A1 + (p1.y + p2.y)/2;
return results;
}
Circle encloseOne(Point &p1) {
Circle results;
results.x = p1.x;
results.y = p1.y;
results.r = 0;
return results;
}
Circle encloseTwo(Point &p1, Point &p2) {
if (equalPoints(p1, p2)) return encloseOne(p1);
Circle results;
double dx = p2.x - p1.x;
double dy = p2.y - p1.y;
results.x = p1.x + dx/2;
results.y = p1.y + dy/2;
results.r = std::sqrt(float(dx*dx + dy*dy))/2;
return results;
}
Circle encloseThree(Point &p1, Point &p2, Point &p3) {
if (equalPoints(p1, p2)) return encloseTwo(p1, p3);
if (equalPoints(p1, p3)) return encloseTwo(p1, p2);
if (equalPoints(p2, p3)) return encloseTwo(p1, p2);
bool perp12 = perpendicularPoints(p1, p2);
bool perp23 = perpendicularPoints(p2, p3);
bool perp13 = perpendicularPoints(p1, p3);
Circle results;
if (perp12 + perp23 + perp13 == 3) {
stop("Error in encloseThree: The 3 points are colinear");
} else if (perp12 + perp23 + perp13 == 2) {
if (perp12) {
if (horizontalPoints(p1, p2)) {
results.y = p1.y + (p2.y - p1.y)/2;
} else {
results.x = p1.x + (p2.x - p1.x)/2;
}
}
if (perp23) {
if (horizontalPoints(p2, p3)) {
results.y = p2.y + (p3.y - p2.y)/2;
} else {
results.x = p2.x + (p3.x - p2.x)/2;
}
}
if (perp13) {
if (horizontalPoints(p1, p3)) {
results.y = p1.y + (p3.y -p1.y)/2;
} else {
results.x = p1.x + (p3.x -p1.x)/2;
}
}
} else {
if (!perp12 && !perp23) {
results = circleByPoints(p1, p2, p3);
} else if (!perp12 && !perp13) {
results = circleByPoints(p2, p1, p3);
} else {
results = circleByPoints(p1, p3, p2);
}
}
double dx, dy;
dx = p1.x - results.x;
dy = p1.y - results.y;
results.r = std::sqrt(float(dx*dx + dy*dy));
return results;
}
Circle encloseDefault(std::vector points) {
switch(points.size()) {
case 1: return encloseOne(points[0]);
case 2: return encloseTwo(points[0], points[1]);
case 3: return encloseThree(points[0], points[1], points[2]);
default: stop("Error in encloseDefault - expecting less than 4 points");
}
}
bool inCircle(Circle c, Point p) {
double dx = p.x - c.x;
double dy = p.y - c.y;
return (dx*dx + dy*dy) - c.r*c.r <= 1e-3;
}
bool allInCircle(Circle c, std::vector points) {
std::vector::iterator it;
for (it = points.begin(); it != points.end(); ++it) {
if (!inCircle(c, *it)) return false;
}
return true;
}
std::vector extendPerimeter(std::vector perimeter, Point p) {
std::vector::iterator it, jt;
for (it = perimeter.begin(); it != perimeter.end(); ++it) {
if (equalPoints(*it, p)) return perimeter;
}
if (perimeter.size() < 2) {
perimeter.push_back(p);
return perimeter;
}
if (inCircle(encloseDefault(perimeter), p)) {
return perimeter;
}
std::vector new_per;
for (it = perimeter.begin(); it != perimeter.end(); ++it) {
if (allInCircle(encloseTwo(*it, p), perimeter)) {
new_per.push_back(p);
new_per.push_back(*it);
return new_per;
}
}
for (it = perimeter.begin(); it != perimeter.end(); ++it) {
for (jt = it + 1; jt != perimeter.end(); ++jt) {
if (!inCircle(encloseTwo(*it, *jt), p) &&
!inCircle(encloseTwo(*it, p), *jt) &&
!inCircle(encloseTwo(*jt, p), *it) &&
allInCircle(encloseThree(*it, *jt, p), perimeter)) {
new_per.push_back(*it);
new_per.push_back(*jt);
new_per.push_back(p);
return new_per;
}
}
}
stop("Error in extendPerimeter: Could not enclose points");
}
Circle enclosePoints(std::vector points) {
//std::random_shuffle(points.begin(), points.end(), randWrapper);
std::vector::iterator it = points.begin();
Circle center = {0.0, 0.0, 0.0};
std::vector perimeter;
while (it != points.end()) {
if (inCircle(center, *it)) {
++it;
} else {
perimeter = extendPerimeter(perimeter, *it);
center = encloseDefault(perimeter);
it = points.begin();
}
}
return center;
}
// [[Rcpp::export]]
DataFrame enclose_points(NumericVector x, NumericVector y, IntegerVector id) {
if (x.size() != y.size() || x.size() != id.size()) {
stop("x, y, and id must have same dimensions");
}
std::vector< double > x0, y0, r;
std::vector< std::vector > all_points;
std::vector points;
all_points.push_back(points);
int currentId = id[0];
int i;
for (i = 0; i < id.size(); ++i) {
Point p_tmp = {x[i], y[i]};
if (id[i] != currentId) {
currentId = id[i];
std::vector points;
all_points.push_back(points);
}
all_points.back().push_back(p_tmp);
}
for (i = 0; i < all_points.size(); ++i) {
Circle center = enclosePoints(all_points[i]);
x0.push_back(center.x);
y0.push_back(center.y);
r.push_back(center.r);
}
return DataFrame::create(
Named("x0") = wrap(x0),
Named("y0") = wrap(y0),
Named("r") = wrap(r)
);
}
ggforce/src/deBoor.cpp 0000644 0001762 0000144 00000002602 13440440225 014371 0 ustar ligges users // Taken from https://chi3x10.wordpress.com/2009/10/18/de-boor-algorithm-in-c/
#include "deBoor.h"
Point::Point() {
x = 0.0;
y = 0.0;
}
Point::Point(double xInit, double yInit) {
x = xInit;
y = yInit;
}
Point Point::operator=(const Point pt) {
x = pt.x;
y = pt.y;
return *this;
}
Point Point::operator+(const Point pt) const {
Point temp;
temp.x = x + pt.x;
temp.y = y + pt.y;
return temp;
}
Point Point::operator*(double m) const {
Point temp;
temp.x = x*m;
temp.y = y*m;
return temp;
}
Point Point::operator/(double m) const {
Point temp;
temp.x = x/m;
temp.y = y/m;
return temp;
}
Point deBoor(int k, int degree, int i, double x, std::vector knots,
std::vector ctrlPoints) {
// Please see wikipedia page for detail
// note that the algorithm here kind of traverses in reverse order
// comapred to that in the wikipedia page
if(k == 0) {
return ctrlPoints[i];
} else {
double alpha = (x - knots[i])/(knots[i+degree + 1 - k] - knots[i]);
return (deBoor(k - 1, degree, i - 1, x, knots, ctrlPoints)*(1 - alpha) +
deBoor(k - 1, degree, i, x, knots, ctrlPoints)*alpha);
}
}
int whichInterval(double x, std::vector knots) {
int ti = knots.size();
for(int i = 1; i < ti - 1; i++) {
if(x < knots[i])
return(i - 1);
else if(x == knots[ti - 1])
return(ti - 1);
}
return -1;
}
ggforce/src/bezier.cpp 0000644 0001762 0000144 00000004513 14564603246 014456 0 ustar ligges users #include
using namespace Rcpp;
double Bezier2(double t, NumericVector w) {
double t2 = t * t;
double mt = 1-t;
double mt2 = mt * mt;
return w[0]*mt2 + w[1]*2*mt*t + w[2]*t2;
}
double Bezier3(double t, NumericVector w) {
double t2 = t * t;
double t3 = t2 * t;
double mt = 1-t;
double mt2 = mt * mt;
double mt3 = mt2 * mt;
return w[0]*mt3 + 3*w[1]*mt2*t + 3*w[2]*mt*t2 + w[3]*t3;
}
// [[Rcpp::export]]
NumericMatrix bezierPath(NumericVector x, NumericVector y, int detail) {
NumericMatrix res(detail, 2);
detail = detail - 1;
double step = 1.0/detail;
double t;
if (x.size() == 3) {
for (int i = 0; i < detail; i++) {
t = i * step;
res(i, 0) = Bezier2(t, x);
res(i, 1) = Bezier2(t, y);
}
} else if (x.size() == 4) {
for (int i = 0; i < detail; i++) {
t = i * step;
res(i, 0) = Bezier3(t, x);
res(i, 1) = Bezier3(t, y);
}
} else {
stop("Only support for quadratic and cubic beziers");
}
res(detail, 0) = x[x.size() - 1];
res(detail, 1) = y[y.size() - 1];
return res;
}
// [[Rcpp::export]]
List getBeziers(NumericVector x, NumericVector y, IntegerVector id,
int detail) {
std::vector nControls;
std::vector pathID;
nControls.push_back(1);
pathID.push_back(id[0]);
for (int i = 1; i < id.size(); i++) {
if (id[i] == pathID.back()) {
nControls.back()++;
} else {
nControls.push_back(1);
pathID.push_back(id[i]);
}
}
int nPaths = nControls.size();
NumericMatrix paths(nPaths * detail, 2);
IntegerVector pathsID(nPaths * detail);
int controlsStart = 0;
IntegerVector controlInd;
int pathStart = 0;
IntegerVector pathInd;
IntegerVector::iterator pathIter;
NumericMatrix path;
for (int i = 0; i < nPaths; i++) {
controlInd = Range(controlsStart, controlsStart + nControls[i] - 1);
pathInd = Range(pathStart, pathStart + detail - 1);
path = bezierPath(x[controlInd], y[controlInd], detail);
int j = 0;
for (pathIter = pathInd.begin(); pathIter != pathInd.end(); pathIter++) {
pathsID[*pathIter] = pathID[i];
paths(*pathIter, 0) = path(j, 0);
paths(*pathIter, 1) = path(j, 1);
j++;
}
controlsStart += nControls[i];
pathStart += detail;
}
return List::create(Named("paths") = paths,
Named("pathID") = pathsID);
}
ggforce/src/ellipseEnclose.cpp 0000644 0001762 0000144 00000010571 14564603246 016145 0 ustar ligges users #include
#include
// [[Rcpp::depends(RcppEigen)]]
using namespace Rcpp;
struct Ellipse {
double x;
double y;
double a;
double b;
double rad;
};
bool points_on_line(Eigen::MatrixXd points, Ellipse &enc) {
double xmin, ymin, xmax, ymax;
int n = points.rows();
if (n == 1) {
enc.x = points.coeff(0, 0);
enc.y = points.coeff(0, 1);
enc.a = 0;
enc.b = 0;
enc.rad = 0;
return true;
}
if (n == 2) {
xmin = points.coeff(0, 0);
xmax = points.coeff(1, 0);
ymin = points.coeff(0, 1);
ymax = points.coeff(1, 1);
} else {
double x0 = xmin = xmax = points.coeff(0, 0);
double y0 = ymin = ymax = points.coeff(0, 1);
double xdiff = points.coeff(1, 0) - x0;
bool vert = xdiff == 0;
double slope;
if (!vert) {
slope = (points.coeff(1, 1) - y0) / xdiff;
}
for (int i = 2; i < n; i++) {
xdiff = points(i, 0) - x0;
if (vert && xdiff == 0) {
ymin = std::min(ymin, points(i, 1));
ymax = std::max(ymax, points(i, 1));
continue;
}
if (slope == (points.coeff(i, 1) - y0) / xdiff) {
if (points(i, 0) < xmin) {
xmin = points(i, 0);
ymin = points(i, 1);
} else if (points(i, 0) > xmin) {
xmax = points(i, 0);
ymax = points(i, 1);
}
continue;
}
return false;
}
}
if (xmin == xmax && ymin == ymax) {
enc.x = xmin;
enc.y = ymin;
enc.a = 0;
enc.b = 0;
enc.rad = 0;
} else {
enc.x = (xmin + xmax) / 2;
enc.y = (ymin + ymax) / 2;
double diff_x = xmax - xmin;
double diff_y = ymax - ymin;
enc.a = std::sqrt(diff_x * diff_x + diff_y * diff_y) / 2;
enc.b = enc.a * 0.1;
enc.rad = std::atan(diff_y / diff_x);
}
return true;
}
Ellipse khachiyan(Eigen::MatrixXd points, double tol) {
Ellipse enc;
if (points_on_line(points, enc)) {
return enc;
}
points.adjointInPlace();
int N = points.cols();
int d = points.rows();
Eigen::MatrixXd Q;
Q = points;
Q.conservativeResize(d + 1, Eigen::NoChange);
Q.row(d).setOnes();
Eigen::MatrixXd Qadj = Q.adjoint();
double error = 1;
double max, step;
Eigen::MatrixXd X, A, V;
Eigen::VectorXd M, u_tmp, c;
Eigen::VectorXd::Index max_i;
Eigen::VectorXd u(N);
u.fill(1/double(N));
while (error > tol) {
X = Q * u.asDiagonal() * Qadj;
M = (Qadj * X.inverse() * Q).diagonal();
max = M.maxCoeff(&max_i);
step = (max - d - 1)/((d + 1)*(max - 1));
u_tmp = (1 - step)*u;
u_tmp[max_i] = u_tmp[max_i] + step;
error = (u_tmp - u).norm();
u = u_tmp;
}
A = (1.0/d) * (points * u.asDiagonal() * points.adjoint() - (points * u)*(points * u).adjoint() ).inverse();
c = points * u;
enc.x = c[0];
enc.y = c[1];
Eigen::JacobiSVD svd_A(A, Eigen::ComputeThinV);
enc.a = 1.0/std::sqrt(float(svd_A.singularValues()[1]));
enc.b = 1.0/std::sqrt(float(svd_A.singularValues()[0]));
V = svd_A.matrixV();
if (V(0, 1) == V(1, 0)) {
enc.rad = std::asin(float(V(1, 1)));
} else if (V(0, 1) < V(1, 0)) {
enc.rad = std::asin(-float(V(0, 0)));
} else {
enc.rad = std::asin(float(V(0, 0)));
}
return enc;
}
// [[Rcpp::export]]
DataFrame enclose_ellip_points(NumericVector x, NumericVector y, IntegerVector id, double tol) {
if (x.size() != y.size() || x.size() != id.size()) {
stop("x, y, and id must have same dimensions");
}
const Eigen::Map X(as< Eigen::Map >(x));
const Eigen::Map Y(as< Eigen::Map >(y));
std::vector< double > x0, y0, a, b, rad;
std::vector< int > splits;
splits.push_back(0);
int currentId = id[0];
int i, size;
for (i = 0; i < id.size(); ++i) {
if (id[i] != currentId) {
currentId = id[i];
splits.push_back(i);
}
}
splits.push_back(id.size());
for (i = 0; i < splits.size() - 1; ++i) {
size = splits[i+1] - splits[i];
Eigen::MatrixXd points(size, 2);
points.col(0) = X.segment(splits[i], size);
points.col(1) = Y.segment(splits[i], size);
Ellipse center = khachiyan(points, tol);
x0.push_back(center.x);
y0.push_back(center.y);
a.push_back(center.a);
b.push_back(center.b);
rad.push_back(center.rad);
}
return DataFrame::create(
Named("x0") = wrap(x0),
Named("y0") = wrap(y0),
Named("a") = wrap(a),
Named("b") = wrap(b),
Named("angle") = wrap(rad)
);
}
ggforce/src/bSpline.cpp 0000644 0001762 0000144 00000007320 14564603246 014571 0 ustar ligges users #include
#include "deBoor.h"
using namespace Rcpp;
std::vector createKnots(int nControl, int degree) {
int nKnots = nControl + degree + 1;
std::vector knots (nKnots, 0);
for (int i = 0; i < nKnots; i++) {
if (i < degree + 1) {
knots[i] = 0;
} else if (i < nKnots - degree) {
knots[i] = knots[i-1] + 1;
} else {
knots[i] = knots[i-1];
}
}
return knots;
}
std::vector createOpenKnots(int nControl, int degree) {
int nKnots = nControl + degree + 1;
std::vector knots (nKnots, 0);
for (int i = 0; i < nKnots; i++) {
if (i < 1) knots[i] = 0;
else knots[i] = knots[i-1] + 1;
}
return knots;
}
std::vector createControls(NumericVector x, NumericVector y) {
int nControls = x.size();
std::vector controls(nControls, Point());
for (int i = 0; i < nControls; i++) {
controls[i] = Point(x[i], y[i]);
}
return controls;
}
// [[Rcpp::export]]
NumericMatrix splinePath(NumericVector x, NumericVector y, int degree, std::vector knots, int detail, std::string type) {
std::vector controls = createControls(x, y);
if (type == "closed") {
controls.push_back(controls[0]);
controls.push_back(controls[1]);
controls.push_back(controls[2]);
}
NumericMatrix res(detail, 2);
double zJump = (knots[knots.size()-1-degree] - knots[degree]);
if (type == "clamped") {
zJump /= double(detail-1);
} else {
zJump /= double(detail);
}
double z;
Point point;
for (int i = 0; i < detail; i++) {
if (i == detail-1 && type == "clamped") {
point = controls[controls.size()-1];
} else {
z = knots[degree] + i * zJump;
int zInt = whichInterval(z, knots);
point = deBoor(degree, degree, zInt, z, knots, controls);
}
res(i, 0) = point.x;
res(i, 1) = point.y;
}
return res;
}
// [[Rcpp::export]]
List getSplines(NumericVector x, NumericVector y, IntegerVector id,
int detail, std::string type = "clamped") {
std::vector nControls;
std::vector pathID;
nControls.push_back(1);
pathID.push_back(id[0]);
for (int i = 1; i < id.size(); i++) {
if (id[i] == pathID.back()) {
nControls.back()++;
} else {
nControls.push_back(1);
pathID.push_back(id[i]);
}
}
int nPaths = nControls.size();
NumericMatrix paths(nPaths * detail, 2);
IntegerVector pathsID(nPaths * detail);
int controlsStart = 0;
IntegerVector controlInd;
int pathStart = 0;
IntegerVector pathInd;
IntegerVector::iterator pathIter;
int degree;
std::vector knots;
NumericMatrix path;
for (int i = 0; i < nPaths; i++) {
degree = nControls[i] <= 3 ? nControls[i] - 1 : 3;
if (type == "clamped") {
knots = createKnots(nControls[i], degree);
} else if (type == "open") {
knots = createOpenKnots(nControls[i], degree);
} else if (type == "closed") {
if (nControls[i] < 3) stop("At least 3 control points must be provided for closed b-splines");
degree = 3;
knots = createOpenKnots(nControls[i] + 3, degree);
} else {
stop("type must be either \"open\", \"closed\", or \"clamped\"");
}
controlInd = Range(controlsStart, controlsStart + nControls[i] - 1);
pathInd = Range(pathStart, pathStart + detail - 1);
path = splinePath(x[controlInd], y[controlInd], degree, knots, detail, type);
int j = 0;
for (pathIter = pathInd.begin(); pathIter != pathInd.end(); pathIter++) {
pathsID[*pathIter] = pathID[i];
paths(*pathIter, 0) = path(j, 0);
paths(*pathIter, 1) = path(j, 1);
j++;
}
controlsStart += nControls[i];
pathStart += detail;
}
return List::create(Named("paths") = paths,
Named("pathID") = pathsID);
}
ggforce/src/pointPath.cpp 0000644 0001762 0000144 00000004327 14564603246 015147 0 ustar ligges users #include
#include
using namespace Rcpp;
double distSquared(std::pair p, std::pair p1) {
double x = p1.first - p.first;
double y = p1.second - p.second;
return x * x + y * y;
}
std::pair projection(std::pair a, std::pair b, std::pair p, bool clamp) {
if (a.first == b.first && a.second == b.second) return a;
double length2 = distSquared(a, b);
std::pair norm(b.first - a.first, b.second - a.second);
std::pair pa(p.first - a.first, p.second - a.second);
double t = (norm.first * pa.first + norm.second * pa.second) / length2;
if (clamp) {
t = std::max(0.0, std::min(1.0, t));
}
norm.first = t * norm.first + a.first;
norm.second = t * norm.second + a.second;
return norm;
}
void dist_to_path(double x, double y, ListOf path, std::vector &res, bool closed_poly) {
int i, j, k;
double dist, shortest_dist = -1;
std::pair point, a, b, close, closest;
point.first = x;
point.second = y;
for (i = 0; i < path.size(); ++i) {
for (j = 0; j < path[i].nrow(); ++j) {
if (j == path[i].nrow() && !closed_poly) break;
a.first = path[i](j, 0);
a.second = path[i](j, 1);
k = j == path[i].nrow() - 1 ? 0 : j + 1;
b.first = path[i](k, 0);
b.second = path[i](k, 1);
close = projection(a, b, point, true);
dist = std::sqrt(distSquared(point, close));
if (shortest_dist < 0 || dist < shortest_dist) {
shortest_dist = dist;
closest = close;
}
}
}
res.clear();
res.push_back(closest.first);
res.push_back(closest.second);
res.push_back(shortest_dist);
}
//[[Rcpp::export]]
List points_to_path(NumericMatrix pos, ListOf path, bool close) {
std::vector res_container;
NumericMatrix proj(pos.nrow(), 2);
NumericVector dist(pos.nrow());
for (int i = 0; i < pos.nrow(); ++i) {
dist_to_path(pos(i, 0), pos(i, 1), path, res_container, close);
proj(i, 0) = res_container[0];
proj(i, 1) = res_container[1];
dist[i] = res_container[2];
}
return List::create(
_["projection"] = proj,
_["distance"] = dist
);
}
ggforce/src/RcppExports.cpp 0000644 0001762 0000144 00000013144 14564603670 015470 0 ustar ligges users // Generated by using Rcpp::compileAttributes() -> do not edit by hand
// Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
#include
#include
using namespace Rcpp;
#ifdef RCPP_USE_GLOBAL_ROSTREAM
Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get();
Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get();
#endif
// splinePath
NumericMatrix splinePath(NumericVector x, NumericVector y, int degree, std::vector knots, int detail, std::string type);
RcppExport SEXP _ggforce_splinePath(SEXP xSEXP, SEXP ySEXP, SEXP degreeSEXP, SEXP knotsSEXP, SEXP detailSEXP, SEXP typeSEXP) {
BEGIN_RCPP
Rcpp::RObject rcpp_result_gen;
Rcpp::RNGScope rcpp_rngScope_gen;
Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP);
Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP);
Rcpp::traits::input_parameter< int >::type degree(degreeSEXP);
Rcpp::traits::input_parameter< std::vector >::type knots(knotsSEXP);
Rcpp::traits::input_parameter< int >::type detail(detailSEXP);
Rcpp::traits::input_parameter< std::string >::type type(typeSEXP);
rcpp_result_gen = Rcpp::wrap(splinePath(x, y, degree, knots, detail, type));
return rcpp_result_gen;
END_RCPP
}
// getSplines
List getSplines(NumericVector x, NumericVector y, IntegerVector id, int detail, std::string type);
RcppExport SEXP _ggforce_getSplines(SEXP xSEXP, SEXP ySEXP, SEXP idSEXP, SEXP detailSEXP, SEXP typeSEXP) {
BEGIN_RCPP
Rcpp::RObject rcpp_result_gen;
Rcpp::RNGScope rcpp_rngScope_gen;
Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP);
Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP);
Rcpp::traits::input_parameter< IntegerVector >::type id(idSEXP);
Rcpp::traits::input_parameter< int >::type detail(detailSEXP);
Rcpp::traits::input_parameter< std::string >::type type(typeSEXP);
rcpp_result_gen = Rcpp::wrap(getSplines(x, y, id, detail, type));
return rcpp_result_gen;
END_RCPP
}
// bezierPath
NumericMatrix bezierPath(NumericVector x, NumericVector y, int detail);
RcppExport SEXP _ggforce_bezierPath(SEXP xSEXP, SEXP ySEXP, SEXP detailSEXP) {
BEGIN_RCPP
Rcpp::RObject rcpp_result_gen;
Rcpp::RNGScope rcpp_rngScope_gen;
Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP);
Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP);
Rcpp::traits::input_parameter< int >::type detail(detailSEXP);
rcpp_result_gen = Rcpp::wrap(bezierPath(x, y, detail));
return rcpp_result_gen;
END_RCPP
}
// getBeziers
List getBeziers(NumericVector x, NumericVector y, IntegerVector id, int detail);
RcppExport SEXP _ggforce_getBeziers(SEXP xSEXP, SEXP ySEXP, SEXP idSEXP, SEXP detailSEXP) {
BEGIN_RCPP
Rcpp::RObject rcpp_result_gen;
Rcpp::RNGScope rcpp_rngScope_gen;
Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP);
Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP);
Rcpp::traits::input_parameter< IntegerVector >::type id(idSEXP);
Rcpp::traits::input_parameter< int >::type detail(detailSEXP);
rcpp_result_gen = Rcpp::wrap(getBeziers(x, y, id, detail));
return rcpp_result_gen;
END_RCPP
}
// enclose_ellip_points
DataFrame enclose_ellip_points(NumericVector x, NumericVector y, IntegerVector id, double tol);
RcppExport SEXP _ggforce_enclose_ellip_points(SEXP xSEXP, SEXP ySEXP, SEXP idSEXP, SEXP tolSEXP) {
BEGIN_RCPP
Rcpp::RObject rcpp_result_gen;
Rcpp::RNGScope rcpp_rngScope_gen;
Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP);
Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP);
Rcpp::traits::input_parameter< IntegerVector >::type id(idSEXP);
Rcpp::traits::input_parameter< double >::type tol(tolSEXP);
rcpp_result_gen = Rcpp::wrap(enclose_ellip_points(x, y, id, tol));
return rcpp_result_gen;
END_RCPP
}
// enclose_points
DataFrame enclose_points(NumericVector x, NumericVector y, IntegerVector id);
RcppExport SEXP _ggforce_enclose_points(SEXP xSEXP, SEXP ySEXP, SEXP idSEXP) {
BEGIN_RCPP
Rcpp::RObject rcpp_result_gen;
Rcpp::RNGScope rcpp_rngScope_gen;
Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP);
Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP);
Rcpp::traits::input_parameter< IntegerVector >::type id(idSEXP);
rcpp_result_gen = Rcpp::wrap(enclose_points(x, y, id));
return rcpp_result_gen;
END_RCPP
}
// points_to_path
List points_to_path(NumericMatrix pos, ListOf path, bool close);
RcppExport SEXP _ggforce_points_to_path(SEXP posSEXP, SEXP pathSEXP, SEXP closeSEXP) {
BEGIN_RCPP
Rcpp::RObject rcpp_result_gen;
Rcpp::RNGScope rcpp_rngScope_gen;
Rcpp::traits::input_parameter< NumericMatrix >::type pos(posSEXP);
Rcpp::traits::input_parameter< ListOf >::type path(pathSEXP);
Rcpp::traits::input_parameter< bool >::type close(closeSEXP);
rcpp_result_gen = Rcpp::wrap(points_to_path(pos, path, close));
return rcpp_result_gen;
END_RCPP
}
static const R_CallMethodDef CallEntries[] = {
{"_ggforce_splinePath", (DL_FUNC) &_ggforce_splinePath, 6},
{"_ggforce_getSplines", (DL_FUNC) &_ggforce_getSplines, 5},
{"_ggforce_bezierPath", (DL_FUNC) &_ggforce_bezierPath, 3},
{"_ggforce_getBeziers", (DL_FUNC) &_ggforce_getBeziers, 4},
{"_ggforce_enclose_ellip_points", (DL_FUNC) &_ggforce_enclose_ellip_points, 4},
{"_ggforce_enclose_points", (DL_FUNC) &_ggforce_enclose_points, 3},
{"_ggforce_points_to_path", (DL_FUNC) &_ggforce_points_to_path, 3},
{NULL, NULL, 0}
};
RcppExport void R_init_ggforce(DllInfo *dll) {
R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
R_useDynamicSymbols(dll, FALSE);
}
ggforce/R/ 0000755 0001762 0000144 00000000000 14564603702 012076 5 ustar ligges users ggforce/R/position_floatstack.R 0000644 0001762 0000144 00000002107 13545071422 016274 0 ustar ligges users # Only for use with autohistogram and autodensity
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
PositionFloatstack <- ggproto('PositionFloatstack', PositionStack,
setup_params = function(self, data) {
flipped_aes <- has_flipped_aes(data)
data <- flip_data(data, flipped_aes)
list(
var = self$var %||% if (flipped_aes) 'xmax' else 'ymax',
fill = self$fill,
vjust = self$vjust,
reverse = self$reverse,
flipped_aes = flipped_aes
)
},
compute_panel = function(self, data, params, scales) {
data <- flip_data(data, params$flipped_aes)
panel_min <- data$ymin[1]
data$y <- data$y - panel_min
data$ymin <- data$ymin - panel_min
data$ymax <- data$ymax - panel_min
data <- flip_data(data, params$flipped_aes)
data <- ggproto_parent(PositionStack, self)$compute_panel(data, params, scales)
data <- flip_data(data, params$flipped_aes)
data$y <- data$y + panel_min
data$ymin <- data$ymin + panel_min
data$ymax <- data$ymax + panel_min
flip_data(data, params$flipped_aes)
}
)
ggforce/R/facet_matrix.R 0000644 0001762 0000144 00000031274 14552443417 014700 0 ustar ligges users #' Facet by different data columns
#'
#' The `facet_matrix()` facet allows you to put different data columns into
#' different rows and columns in a grid of panels. If the same data columns are
#' present in both the rows and the columns of the grid, and used together with
#' [ggplot2::geom_point()] it is also known as a scatterplot matrix, and if
#' other geoms are used it is sometimes referred to as a pairs plot.
#' `facet_matrix` is so flexible that these types are simply a subset of its
#' capabilities, as any combination of data columns can be plotted against each
#' other using any type of geom. Layers should use the `.panel_x` and `.panel_y`
#' placeholders to map aesthetics to, in order to access the row and column
#' data.
#'
#' @param rows,cols A specification of the data columns to put in the rows and
#' columns of the facet grid. They are specified using the [ggplot2::vars()]
#' function wherein you can use standard tidyselect syntax as known from e.g.
#' `dplyr::select()`. These data values will be made available to the different
#' layers through the `.panel_x` and `.panel_y` variables.
#' @inheritParams ggplot2::facet_grid
#' @param flip.rows Should the order of the rows be reversed so that, if the
#' rows and columns are equal, the diagonal goes from bottom-left to top-right
#' instead of top-left to bottom-right.
#' @param alternate.axes Should axes be drawn at alternating positions.
#' @param layer.lower,layer.diag,layer.upper Specification for where each layer
#' should appear. The default (`NULL`) will allow any layer that has not been
#' specified directly to appear at that position. Putting e.g. `layer.diag = 2`
#' will make the second layer appear on the diagonal as well as remove that
#' layer from any position that has `NULL`. Using `TRUE` will put all layers at
#' that position, and using `FALSE` will conversely remove all layers. These
#' settings will only have an effect if the grid is symmetric.
#' @param layer.continuous,layer.discrete,layer.mixed As above, but instead of
#' referencing panel positions it references the combination of position scales
#' in the panel. Continuous panels have both a continuous x and y axis, discrete
#' panels have both a discrete x and y axis, and mixed panels have one of each.
#' Unlike the position based specifications above these also have an effect in
#' non-symmetric grids.
#' @param grid.y.diag Should the y grid be removed from the diagonal? In certain
#' situations the diagonal are used to plot the distribution of the column data
#' and will thus not use the y-scale. Removing the y gridlines can indicate
#' this.
#'
#' @note Due to the special nature of this faceting it slightly breaks the
#' ggplot2 API, in that any positional scale settings are ignored. This is
#' because each row and column in the grid will potentially have very different
#' scale types and it is not currently possible to have multiple different scale
#' specifications in the same plot object.
#'
#' @seealso [geom_autopoint], [geom_autohistogram], [geom_autodensity], and
#' [position_auto] for geoms and positions that adapts to different positional
#' scale types
#'
#' @export
#'
#' @examples
#' # Standard use:
#' ggplot(mpg) +
#' geom_point(aes(x = .panel_x, y = .panel_y)) +
#' facet_matrix(vars(displ, cty, hwy))
#'
#' # Switch the diagonal, alternate the axes and style strips as axis labels
#' ggplot(mpg) +
#' geom_point(aes(x = .panel_x, y = .panel_y)) +
#' facet_matrix(vars(displ, cty, hwy), flip.rows = TRUE,
#' alternate.axes = TRUE, switch = 'both') +
#' theme(strip.background = element_blank(),
#' strip.placement = 'outside',
#' strip.text = element_text(size = 12))
#'
#' # Mix discrete and continuous columns. Use geom_autopoint for scale-based jitter
#' ggplot(mpg) +
#' geom_autopoint() +
#' facet_matrix(vars(drv:fl))
#'
#' # Have a special diagonal layer
#' ggplot(mpg) +
#' geom_autopoint() +
#' geom_autodensity() +
#' facet_matrix(vars(drv:fl), layer.diag = 2)
#'
#' \donttest{
#' # Show continuous panels in upper triangle as contours and rest as binned
#' ggplot(mpg) +
#' geom_autopoint() +
#' geom_autodensity() +
#' geom_density2d(aes(x = .panel_x, y = .panel_y)) +
#' geom_bin2d(aes(x = .panel_x, y = .panel_y)) +
#' facet_matrix(vars(drv:fl), layer.lower = 1, layer.diag = 2,
#' layer.continuous = -4, layer.discrete = -3, layer.mixed = -3)
#' }
#'
#' # Make asymmetric grid
#' ggplot(mpg) +
#' geom_boxplot(aes(x = .panel_x, y = .panel_y, group = .panel_x)) +
#' facet_matrix(rows = vars(cty, hwy), cols = vars(drv, fl))
#'
facet_matrix <- function(rows, cols = rows, shrink = TRUE, switch = NULL,
labeller = "label_value", flip.rows = FALSE,
alternate.axes = FALSE, layer.lower = NULL,
layer.diag = NULL, layer.upper = NULL,
layer.continuous = NULL, layer.discrete = NULL,
layer.mixed = NULL, grid.y.diag = TRUE) {
if (!is_quosures(rows)) rows <- quos(rows)
if (!is_quosures(cols)) cols <- quos(cols)
labeller <- utils::getFromNamespace('check_labeller', 'ggplot2')(labeller)
ggproto(NULL, FacetMatrix,
shrink = shrink,
params = list(rows = quos(row_data = row_data), cols = quos(col_data = col_data),
row_vars = rows, col_vars = cols, switch = switch,
labeller = labeller, free = list(x = TRUE, y = TRUE),
space_free = list(x = FALSE, y = FALSE), margins = FALSE,
as.table = !flip.rows, drop = TRUE, labeller = label_value,
alternate.axes = alternate.axes,
layer.lower = layer.lower, layer.diag = layer.diag,
layer.upper = layer.upper, layer.continuous = layer.continuous,
layer.discrete = layer.discrete, layer.mixed = layer.mixed,
grid.y.diag = grid.y.diag)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @importFrom tidyselect eval_select
#' @export
FacetMatrix <- ggproto('FacetMatrix', FacetGrid,
setup_data = function(data, params) {
lapply(seq_along(data), function(i) {
d <- data[[i]]
d$.layer_index <- i - 1
d
})
},
setup_params = function(data, params) {
rows <- lapply(data, function(d) {
names(eval_select(quo(c(!!!params$row_vars)), d))
})
rows <- unique0(unlist(rows))
cols <- lapply(data, function(d) {
names(eval_select(quo(c(!!!params$col_vars)), d))
})
cols <- unique0(unlist(cols))
if (length(rows) == 0 || length(cols) == 0) {
cli::cli_abort('{.arg rows} and {.arg cols} must select valid data columns')
}
params$pairs <- all(rows == cols)
if (!params$as.table) rows <- rev(rows)
params$row_vars <- rows
params$col_vars <- cols
plot_env <- get('plot_env', caller_env(2)) # Horrible hack - don't judge
params$row_scales <- create_pos_scales(rows, data, plot_env, 'y', params$alternate.axes)
params$col_scales <- create_pos_scales(cols, data, plot_env, 'x', params$alternate.axes)
check_layer_pos_params(params$pairs, params$lower, params$upper, params$diag)
n_layers <- length(data) - 1
params$layer_pos <- assign_layers(
n_layers,
lower = params$layer.lower,
diagonal = params$layer.diag,
upper = params$layer.upper
)
params$layer_type <- assign_layers(
n_layers,
continuous = params$layer.continuous,
discrete = params$layer.discrete,
mixed = params$layer.mixed
)
params
},
compute_layout = function(data, params) {
layout <- expand.grid(col_data = params$col_vars, row_data = params$row_vars, stringsAsFactors = FALSE)
layout$ROW <- match(layout$row_data, params$row_vars)
layout$COL <- match(layout$col_data, params$col_vars)
layout$PANEL <- factor(seq_len(nrow(layout)))
layout$SCALE_X <- layout$COL
layout$SCALE_Y <- layout$ROW
if (params$pairs) {
mat_ind <- matrix(seq_len(nrow(layout)), length(params$row_vars), length(params$col_vars), byrow = TRUE)
if (!params$as.table) mat_ind <- mat_ind[rev(seq_along(params$row_vars)), ]
layout$panel_pos <- 'lower'
layout$panel_pos[diag(mat_ind)] <- 'diagonal'
layout$panel_pos[mat_ind[upper.tri(mat_ind)]] <- 'upper'
}
layout
},
map_data = function(data, layout, params) {
layer_pos <- params$layer_pos[[data$.layer_index[1]]]
layer_type <- params$layer_type[[data$.layer_index[1]]]
data <- lapply(seq_len(nrow(layout)), function(i) {
row <- layout$row_data[i]
col <- layout$col_data[i]
col_discrete <- params$col_scales[[layout$SCALE_X[i]]]$is_discrete()
row_discrete <- params$row_scales[[layout$SCALE_Y[i]]]$is_discrete()
panel_type <- c('continuous', 'mixed', 'discrete')[col_discrete + row_discrete + 1]
placeholder <- cbind(data[0, ], PANEL = layout$PANEL[0],
.panel_x = numeric(), .panel_y = numeric())
if (!all(c(row, col) %in% names(data))) return(placeholder)
if (params$pairs && !layout$panel_pos[i] %in% layer_pos) return(placeholder)
if (!panel_type %in% layer_type) return(placeholder)
data$PANEL <- layout$PANEL[i]
data$.panel_x <- params$col_scales[[col]]$map(data[[col]])
data$.panel_y <- params$row_scales[[row]]$map(data[[row]])
if (packageVersion('ggplot2') <= '3.3.6') {
if (inherits(data$.panel_x, 'mapped_discrete')) {
data$.panel_x <- unclass(data$.panel_x)
}
if (inherits(data$.panel_y, 'mapped_discrete')) {
data$.panel_y <- unclass(data$.panel_y)
}
}
data
})
vec_rbind(!!!data)
},
init_scales = function(layout, x_scale = NULL, y_scale = NULL, params) {
scales <- list()
if (!is.null(x_scale)) {
scales$x <- params$col_scales
}
if (!is.null(y_scale)) {
scales$y <- params$row_scales
}
scales
},
draw_panels = function(self, panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) {
if (params$pairs && !params$grid.y.diag) {
panels[layout$panel_pos == 'diagonal'] <- lapply(
panels[layout$panel_pos == 'diagonal'],
function(panel) {
grill <- grep('^grill', names(panel$children))
y_grid <- grep('^panel\\.grid\\.(major\\.y)|(minor\\.y)', names(panel$children[[grill]]$children))
panel$children[[grill]]$children[y_grid] <- rep(list(zeroGrob()), length(y_grid))
panel
}
)
}
ggproto_parent(FacetGrid, self)$draw_panels(panels, layout, x_scales, y_scales, ranges, coord, data, theme, params)
}
)
create_pos_scales <- function(vars, data, env, dim = 'x', alternate = FALSE) {
positions <- if (dim == 'x') c('bottom', 'top') else c('left', 'right')
scales <- lapply(seq_along(vars), function(i) {
var <- vars[i]
pos <- if (alternate) positions[((i - 1) %% 2) + 1] else positions[1]
d <- lapply(data, .subset2, var)
d <- d[lengths(d) != 0]
type <- paste0('scale_', dim, '_', scale_type(d[[1]]))
scales <- lapply(type, function(t) {
if (exists(t, env, mode = 'function')) {
scale <- get(t, env, mode = 'function')
} else if (exists(t, asNamespace('ggplot2'), mode = 'function')) {
scale <- get(t, asNamespace('ggplot2'), mode = 'function')
} else if (exists(t, env, mode = 'function')) {
scale <- get(t, env, mode = 'function')
} else if (exists(t, asNamespace('ggforce'), mode = 'function')) {
scale <- get(t, asNamespace('ggforce'), mode = 'function')
} else {
NULL
}
})
scales <- scales[lengths(scales) != 0]
if (length(scales) == 0) {
cli::cli_abort('Unable to pick a scale for {.col {var}}')
}
scale <- scales[[1]](name = NULL, position = pos)
lapply(d, scale$train)
scale
})
names(scales) <- vars
scales
}
assign_layers <- function(n_layers, ...) {
specs <- list(...)
layers <- seq_len(n_layers)
specs <- lapply(specs, function(spec) {
if (is.null(spec)) return(spec)
if (is.logical(spec)) {
if (spec) layers else integer()
} else {
layers[spec]
}
})
specified_layers <- sort(unique0(unlist(specs)))
specified_layers <- layers %in% specified_layers
specs <- lapply(specs, function(spec) {
if (is.null(spec)) {
layers[!specified_layers]
} else {
spec
}
})
split(
unlist(lapply(names(specs), function(name) rep_along(specs[[name]], name))),
factor(unlist(specs), levels = layers)
)
}
check_layer_pos_params <- function(pairs = TRUE, lower = NULL, upper = NULL, diag = NULL) {
if (pairs) return()
if (!all(is.null(lower), is.null(upper), is.null(diag))) {
cli::cli_warn('layer positions are ignored when the matrix is not symmetrical')
}
}
utils::globalVariables(c('.panel_x', '.panel_y', 'col_data', 'row_data'))
ggforce/R/labeller.R 0000644 0001762 0000144 00000001560 14303405641 013776 0 ustar ligges users #' A labeller function to parse TeX syntax
#'
#' This function formats the strip labels of facet grids and wraps that contains
#' TeX expressions. The latex2exp package must be installed.
#'
#' @seealso [ggplot2::labeller], [latex2exp::TeX()]
#'
#' @inheritParams ggplot2::label_parsed
#' @inheritDotParams ggplot2::label_parsed -labels
#'
#' @examples
#' # requires latex2exp package be installed
#' if (requireNamespace("latex2exp", quietly = TRUE)) {
#' library(ggplot2)
#' d <- data.frame(x = 1, y = 1, facet = "$\\beta$")
#' ggplot(d, aes(x, y)) +
#' geom_point() +
#' facet_wrap(~ facet, labeller = label_tex)
#' }
#' @importFrom ggplot2 label_parsed
#' @export
label_tex <- function(labels, ...) {
check_installed('latex2exp', 'to parse tex equations')
label_parsed(
data_frame0(!!!lapply(labels, latex2exp::TeX, output = "character")),
...
)
}
ggforce/R/bspline.R 0000644 0001762 0000144 00000022507 14564603246 013666 0 ustar ligges users #' B-splines based on control points
#'
#' This set of stats and geoms makes it possible to draw b-splines based on a
#' set of control points. As with [geom_bezier()] there exists several
#' versions each having there own strengths. The base version calculates the
#' b-spline as a number of points along the spline and connects these with a
#' path. The *2 version does the same but in addition interpolates aesthetics
#' between each control point. This makes the *2 version considerably slower
#' so it shouldn't be used unless needed. The *0 version uses
#' [grid::xsplineGrob()] with `shape = 1` to approximate a b-spline.
#'
#' @section Aesthetics:
#' geom_bspline understand the following aesthetics (required aesthetics are in
#' bold):
#'
#' - **x**
#' - **y**
#' - color
#' - linewidth
#' - linetype
#' - alpha
#' - lineend
#'
#'
#' @section Computed variables:
#'
#' \describe{
#' \item{x, y}{The coordinates for the path describing the spline}
#' \item{index}{The progression along the interpolation mapped between 0 and 1}
#' }
#'
#' @inheritParams ggplot2::geom_path
#' @inheritParams ggplot2::stat_identity
#'
#' @param n The number of points generated for each spline
#' @param type Either `'clamped'` (default) or `'open'`. The former creates a
#' knot sequence that ensures the splines starts and ends at the terminal
#' control points.
#'
#' @author Thomas Lin Pedersen. The C++ code for De Boor's algorithm has been
#' adapted from
#' \href{https://chi3x10.wordpress.com/2009/10/18/de-boor-algorithm-in-c/}{Jason Yu-Tseh Chi implementation}
#'
#' @name geom_bspline
#' @rdname geom_bspline
#'
#' @examples
#' # Define some control points
#' cp <- data.frame(
#' x = c(
#' 0, -5, -5, 5, 5, 2.5, 5, 7.5, 5, 2.5, 5, 7.5, 5, -2.5, -5, -7.5, -5,
#' -2.5, -5, -7.5, -5
#' ),
#' y = c(
#' 0, -5, 5, -5, 5, 5, 7.5, 5, 2.5, -5, -7.5, -5, -2.5, 5, 7.5, 5, 2.5,
#' -5, -7.5, -5, -2.5
#' ),
#' class = sample(letters[1:3], 21, replace = TRUE)
#' )
#'
#' # Now create some paths between them
#' paths <- data.frame(
#' ind = c(
#' 7, 5, 8, 8, 5, 9, 9, 5, 6, 6, 5, 7, 7, 5, 1, 3, 15, 8, 5, 1, 3, 17, 9, 5,
#' 1, 2, 19, 6, 5, 1, 4, 12, 7, 5, 1, 4, 10, 6, 5, 1, 2, 20
#' ),
#' group = c(
#' 1, 1, 1, 2, 2, 2, 3, 3, 3, 4, 4, 4, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 7, 7,
#' 7, 7, 7, 8, 8, 8, 8, 8, 9, 9, 9, 9, 9, 10, 10, 10, 10, 10
#' )
#' )
#' paths$x <- cp$x[paths$ind]
#' paths$y <- cp$y[paths$ind]
#' paths$class <- cp$class[paths$ind]
#'
#' ggplot(paths) +
#' geom_bspline(aes(x = x, y = y, group = group, colour = after_stat(index))) +
#' geom_point(aes(x = x, y = y), data = cp, color = 'steelblue')
#'
#' ggplot(paths) +
#' geom_bspline2(aes(x = x, y = y, group = group, colour = class)) +
#' geom_point(aes(x = x, y = y), data = cp, color = 'steelblue')
#'
#' ggplot(paths) +
#' geom_bspline0(aes(x = x, y = y, group = group)) +
#' geom_point(aes(x = x, y = y), data = cp, color = 'steelblue')
#'
NULL
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatBspline <- ggproto('StatBspline', Stat,
compute_layer = function(self, data, params, panels) {
if (empty_data(data)) return(data)
data <- data[order(data$group), ]
groups <- unique0(data$group)
paths <- getSplines(data$x, data$y, match(data$group, groups), params$n,
params$type %||% 'clamped')
paths <- data_frame0(
x = paths$paths[, 1], y = paths$paths[, 2],
group = groups[paths$pathID]
)
paths$index <- rep(
seq(0, 1, length.out = params$n),
length(unique0(data$group))
)
dataIndex <- rep(match(unique0(data$group), data$group), each = params$n)
cbind(
paths,
data[dataIndex, !names(data) %in% c('x', 'y', 'group'), drop = FALSE]
)
},
required_aes = c('x', 'y'),
extra_params = c('na.rm', 'n', 'type')
)
#' @rdname geom_bspline
#' @export
stat_bspline <- function(mapping = NULL, data = NULL, geom = 'path',
position = 'identity', na.rm = FALSE, n = 100,
type = 'clamped', show.legend = NA, inherit.aes = TRUE,
...) {
layer(
stat = StatBspline, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, n = n, type = type, ...)
)
}
#' @rdname geom_bspline
#' @export
geom_bspline <- function(mapping = NULL, data = NULL, stat = 'bspline',
position = 'identity', arrow = NULL, n = 100,
type = 'clamped', lineend = 'butt', na.rm = FALSE,
show.legend = NA, inherit.aes = TRUE, ...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomPath,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(
arrow = arrow, lineend = lineend, na.rm = na.rm, n = n,
type = type, ...
)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatBspline2 <- ggproto('StatBspline2', Stat,
compute_layer = function(self, data, params, panels) {
if (empty_data(data)) return(data)
data <- data[order(data$group), ]
nControls <- table(data$group)
groups <- unique0(data$group)
paths <- getSplines(data$x, data$y, match(data$group, groups), params$n,
params$type %||% 'clamped')
paths <- data_frame0(
x = paths$paths[, 1], y = paths$paths[, 2],
group = groups[paths$pathID]
)
paths$index <- rep(
seq(0, 1, length.out = params$n),
length(unique0(data$group))
)
dataIndex <- rep(match(unique0(data$group), data$group), each = params$n)
paths <- cbind(paths, data[dataIndex, 'PANEL', drop = FALSE])
extraCols <- !names(data) %in% c('x', 'y', 'group', 'PANEL')
pathIndex <- match(unique0(data$group), paths$group)
pathIndex <- unlist(Map(seq, from = pathIndex, length.out = nControls))
paths$.interp <- TRUE
paths$.interp[pathIndex] <- FALSE
if (any(extraCols)) {
for (i in names(data)[extraCols]) {
paths[[i]] <- data[[i]][1]
paths[[i]][pathIndex] <- data[, i]
}
}
paths
},
required_aes = c('x', 'y'),
extra_params = c('na.rm', 'n', 'type')
)
#' @rdname geom_bspline
#' @export
stat_bspline2 <- function(mapping = NULL, data = NULL, geom = 'path_interpolate',
position = 'identity', na.rm = FALSE, n = 100,
type = 'clamped', show.legend = NA, inherit.aes = TRUE,
...) {
layer(
stat = StatBspline2, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, n = n, type = type, ...)
)
}
#' @rdname geom_bspline
#' @export
geom_bspline2 <- function(mapping = NULL, data = NULL, stat = 'bspline2',
position = 'identity', arrow = NULL, n = 100,
type = 'clamped', lineend = 'butt', na.rm = FALSE,
show.legend = NA, inherit.aes = TRUE, ...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomPathInterpolate,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(
arrow = arrow, lineend = lineend, na.rm = na.rm, n = n,
type = type, ...
)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @importFrom grid xsplineGrob gpar
#' @export
GeomBspline0 <- ggproto('GeomBspline0', GeomPath,
draw_panel = function(data, panel_scales, coord, arrow = NULL,
type = 'clamped', lineend = 'butt', linejoin = 'round',
linemitre = 1, na.rm = FALSE) {
coords <- coord$transform(data, panel_scales)
if (!is.integer(coords$group)) {
coords$group <- match(coords$group, unique0(coords$group))
}
startPoint <- match(unique0(coords$group), coords$group)
xsplineGrob(coords$x, coords$y,
id = coords$group, default.units = 'native',
shape = 1, arrow = arrow, repEnds = type == 'clamped',
gp = gpar(
col = alpha(coords$colour[startPoint], coords$alpha[startPoint]),
lwd = (coords$linewidth[startPoint] %||% coords$size[startPoint]) * .pt,
lty = coords$linetype[startPoint], lineend = lineend,
linejoin = linejoin, linemitre = linemitre
)
)
}
)
#' @rdname geom_bspline
#' @export
stat_bspline0 <- function(mapping = NULL, data = NULL, geom = 'bspline0',
position = 'identity', na.rm = FALSE, show.legend = NA,
inherit.aes = TRUE, type = 'clamped', ...) {
layer(
stat = StatIdentity, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, type = type, ...)
)
}
#' @rdname geom_bspline
#' @export
geom_bspline0 <- function(mapping = NULL, data = NULL, stat = 'identity',
position = 'identity', arrow = NULL, lineend = 'butt',
na.rm = FALSE, show.legend = NA, inherit.aes = TRUE,
type = 'clamped', ...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomBspline0,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(
arrow = arrow, lineend = lineend, na.rm = na.rm, type = type,
...
)
)
}
ggforce/R/ellipse.R 0000644 0001762 0000144 00000006701 14564603246 013665 0 ustar ligges users #' Draw (super)ellipses based on the coordinate system scale
#'
#' This is a generalisation of [geom_circle()] that allows you to draw
#' ellipses at a specified angle and center relative to the coordinate system.
#' Apart from letting you draw regular ellipsis, the stat is using the
#' generalised formula for superellipses which can be utilised by setting the
#' `m1` and `m2` aesthetics. If you only set the m1 the m2 value will follow
#' that to ensure a symmetric appearance.
#'
#' @section Aesthetics:
#' geom_arc understand the following aesthetics (required aesthetics are in
#' bold):
#'
#' - **x0**
#' - **y0**
#' - **a**
#' - **b**
#' - **angle**
#' - m1
#' - m2
#' - color
#' - fill
#' - linewidth
#' - linetype
#' - alpha
#' - lineend
#'
#' @section Computed variables:
#'
#' \describe{
#' \item{x, y}{The coordinates for the points along the ellipse}
#' }
#'
#' @inheritParams ggplot2::geom_path
#' @inheritParams ggplot2::stat_identity
#'
#' @param n The number of points to sample along the ellipse.
#'
#' @name geom_ellipse
#' @rdname geom_ellipse
#'
#' @examples
#' # Basic usage
#' ggplot() +
#' geom_ellipse(aes(x0 = 0, y0 = 0, a = 10, b = 3, angle = 0)) +
#' coord_fixed()
#'
#' # Rotation
#' # Note that it expects radians and rotates the ellipse counter-clockwise
#' ggplot() +
#' geom_ellipse(aes(x0 = 0, y0 = 0, a = 10, b = 3, angle = pi / 4)) +
#' coord_fixed()
#'
#' # Draw a super ellipse
#' ggplot() +
#' geom_ellipse(aes(x0 = 0, y0 = 0, a = 6, b = 3, angle = -pi / 3, m1 = 3)) +
#' coord_fixed()
NULL
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatEllip <- ggproto('StatEllip', Stat,
setup_data = function(data, params) {
data$m1 <- if (is.null(data$m1)) 2 else data$m1
data$m2 <- if (is.null(data$m2)) data$m1 else data$m2
data
},
compute_panel = function(self, data, scales, n = 360) {
if (empty_data(data)) return(data)
data$group <- make_unique(as.character(data$group))
n_ellipses <- nrow(data)
data <- data[rep(seq_len(n_ellipses), each = n), ]
points <- rep(seq(0, 2 * pi, length.out = n + 1)[seq_len(n)],
n_ellipses)
cos_p <- cos(points)
sin_p <- sin(points)
x_tmp <- abs(cos_p)^(2 / data$m1) * data$a * sign(cos_p)
y_tmp <- abs(sin_p)^(2 / data$m2) * data$b * sign(sin_p)
data$x <- data$x0 + x_tmp * cos(data$angle) - y_tmp * sin(data$angle)
data$y <- data$y0 + x_tmp * sin(data$angle) + y_tmp * cos(data$angle)
data
},
required_aes = c('x0', 'y0', 'a', 'b', 'angle'),
default_aes = aes(m1 = NA, m2 = NA),
extra_params = c('n', 'na.rm')
)
#' @rdname geom_ellipse
#' @export
stat_ellip <- function(mapping = NULL, data = NULL, geom = 'circle',
position = 'identity', n = 360, na.rm = FALSE,
show.legend = NA, inherit.aes = TRUE, ...) {
layer(
stat = StatEllip, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, n = n, ...)
)
}
#' @rdname geom_ellipse
#' @export
geom_ellipse <- function(mapping = NULL, data = NULL, stat = 'ellip',
position = 'identity', n = 360, na.rm = FALSE,
show.legend = NA, inherit.aes = TRUE, ...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomCircle,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(n = n, na.rm = na.rm, ...)
)
}
ggforce/R/mark_rect.R 0000644 0001762 0000144 00000025237 14564603246 014204 0 ustar ligges users #' Annotate areas with rectangles
#'
#' This geom lets you annotate sets of points via rectangles. The rectangles are
#' simply scaled to the range of the data and as with the other
#' `geom_mark_*()` geoms expanded and have rounded corners.
#'
#' @inheritSection geom_mark_circle Annotation
#' @inheritSection geom_mark_circle Filtering
#' @section Aesthetics:
#' `geom_mark_rect` understands the following aesthetics (required aesthetics are
#' in bold):
#'
#' - **x**
#' - **y**
#' - x0 *(used to anchor the label)*
#' - y0 *(used to anchor the label)*
#' - filter
#' - label
#' - description
#' - color
#' - fill
#' - group
#' - size
#' - linetype
#' - alpha
#'
#' @inheritParams geom_mark_circle
#'
#' @family mark geoms
#'
#' @name geom_mark_rect
#' @rdname geom_mark_rect
#'
#' @examples
#' ggplot(iris, aes(Petal.Length, Petal.Width)) +
#' geom_mark_rect(aes(fill = Species, filter = Species != 'versicolor')) +
#' geom_point()
#'
#' # Add annotation
#' ggplot(iris, aes(Petal.Length, Petal.Width)) +
#' geom_mark_rect(aes(fill = Species, label = Species)) +
#' geom_point()
#'
#' # Long descriptions are automatically wrapped to fit into the width
#' iris$desc <- c(
#' 'A super Iris - and it knows it',
#' 'Pretty mediocre Iris, but give it a couple of years and it might surprise you',
#' "You'll never guess what this Iris does every Sunday"
#' )[iris$Species]
#'
#' ggplot(iris, aes(Petal.Length, Petal.Width)) +
#' geom_mark_rect(aes(fill = Species, label = Species, description = desc,
#' filter = Species == 'setosa')) +
#' geom_point()
#'
#' # Change the buffer size to move labels farther away (or closer) from the
#' # marks
#' ggplot(iris, aes(Petal.Length, Petal.Width)) +
#' geom_mark_rect(aes(fill = Species, label = Species),
#' label.buffer = unit(30, 'mm')) +
#' geom_point()
#'
#' # The connector is capped a bit before it reaches the mark, but this can be
#' # controlled
#' ggplot(iris, aes(Petal.Length, Petal.Width)) +
#' geom_mark_rect(aes(fill = Species, label = Species),
#' con.cap = 0) +
#' geom_point()
NULL
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
GeomMarkRect <- ggproto('GeomMarkRect', GeomMarkCircle,
setup_data = function(self, data, params) {
if (!is.null(data$filter)) {
self$removed <- data[!data$filter, c('x', 'y', 'PANEL')]
data <- data[data$filter, ]
}
if (nrow(data) == 0) return(data)
vec_rbind(!!!lapply(split(data, data$group), function(d) {
if (nrow(d) == 1) return(d)
x_range <- range(d$x, na.rm = TRUE)
y_range <- range(d$y, na.rm = TRUE)
d_new <- data_frame0(
x = x_range[c(1, 1, 2, 2)],
y = y_range[c(1, 2, 2, 1)]
)
d$x <- NULL
d$y <- NULL
unique0(cbind(d_new, d[rep(1, 4), ]))
}))
},
draw_panel = function(self, data, panel_params, coord, expand = unit(5, 'mm'),
radius = unit(2.5, 'mm'),
label.margin = margin(2, 2, 2, 2, 'mm'),
label.width = NULL, label.minwidth = unit(50, 'mm'),
label.hjust = 0, label.buffer = unit(10, 'mm'),
label.fontsize = 12, label.family = '',
label.fontface = c('bold', 'plain'),
label.lineheight = 1,
label.fill = 'white', label.colour = 'black',
con.colour = 'black', con.size = 0.5, con.type = 'elbow',
con.linetype = 1, con.border = 'one',
con.cap = unit(3, 'mm'), con.arrow = NULL) {
if (nrow(data) == 0) return(zeroGrob())
# As long as coord$transform() doesn't recognise x0/y0
data$xmin <- data$x0
data$ymin <- data$y0
coords <- coord$transform(data, panel_params)
if (!is.integer(coords$group)) {
coords$group <- match(coords$group, unique0(coords$group))
}
coords <- coords[order(coords$group), ]
# For gpar(), there is one entry per polygon (not one entry per point).
# We'll pull the first value from each group, and assume all these values
# are the same within each group.
first_idx <- !duplicated(coords$group)
first_rows <- coords[first_idx, ]
label <- NULL
ghosts <- NULL
if (!is.null(coords$label) || !is.null(coords$description)) {
label <- first_rows
is_ghost <- which(self$removed$PANEL == coords$PANEL[1])
if (length(is_ghost) > 0) {
ghosts <- self$removed[is_ghost, ]
ghosts <- coord$transform(ghosts, panel_params)
ghosts <- list(x = ghosts$x, y = ghosts$y)
}
}
rectEncGrob(coords$x, coords$y,
default.units = 'native',
id = coords$group, expand = expand, radius = radius,
label = label, ghosts = ghosts,
mark.gp = gpar(
col = first_rows$colour,
fill = alpha(first_rows$fill, first_rows$alpha),
lwd = (first_rows$linewidth %||% first_rows$size) * .pt,
lty = first_rows$linetype
),
label.gp = gpar(
col = label.colour,
fill = label.fill,
fontface = label.fontface,
fontfamily = label.family,
fontsize = label.fontsize,
lineheight = label.lineheight
),
con.gp = gpar(
col = con.colour,
fill = con.colour,
lwd = con.size * .pt,
lty = con.linetype
),
label.margin = label.margin,
label.width = label.width,
label.minwidth = label.minwidth,
label.hjust = label.hjust,
label.buffer = label.buffer,
con.type = con.type,
con.border = con.border,
con.cap = con.cap,
con.arrow = con.arrow,
anchor.x = first_rows$xmin,
anchor.y = first_rows$ymin
)
}
)
#' @rdname geom_mark_rect
#' @export
geom_mark_rect <- function(mapping = NULL, data = NULL, stat = 'identity',
position = 'identity', expand = unit(5, 'mm'),
radius = unit(2.5, 'mm'),
label.margin = margin(2, 2, 2, 2, 'mm'),
label.width = NULL, label.minwidth = unit(50, 'mm'),
label.hjust = 0, label.fontsize = 12,
label.family = '', label.lineheight = 1,
label.fontface = c('bold', 'plain'),
label.fill = 'white', label.colour = 'black',
label.buffer = unit(10, 'mm'), con.colour = 'black',
con.size = 0.5, con.type = 'elbow', con.linetype = 1,
con.border = 'one', con.cap = unit(3, 'mm'),
con.arrow = NULL, ..., na.rm = FALSE,
show.legend = NA, inherit.aes = TRUE) {
layer(
data = data,
mapping = mapping,
stat = stat,
geom = GeomMarkRect,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
na.rm = na.rm,
expand = expand,
radius = radius,
label.margin = label.margin,
label.width = label.width,
label.minwidth = label.minwidth,
label.fontsize = label.fontsize,
label.family = label.family,
label.lineheight = label.lineheight,
label.fontface = label.fontface,
label.hjust = label.hjust,
label.fill = label.fill,
label.colour = label.colour,
label.buffer = label.buffer,
con.colour = con.colour,
con.size = con.size,
con.type = con.type,
con.linetype = con.linetype,
con.border = con.border,
con.cap = con.cap,
con.arrow = con.arrow,
...
)
)
}
# Helpers -----------------------------------------------------------------
rectEncGrob <- function(x = c(0, 0.5, 1, 0.5), y = c(0.5, 1, 0.5, 0), id = NULL,
id.lengths = NULL, expand = 0, radius = 0, label = NULL,
ghosts = NULL, default.units = 'npc', name = NULL,
mark.gp = gpar(), label.gp = gpar(), con.gp = gpar(),
label.margin = margin(), label.width = NULL,
label.minwidth = unit(50, 'mm'), label.hjust = 0,
label.buffer = unit(10, 'mm'), con.type = 'elbow',
con.border = 'one', con.cap = unit(3, 'mm'),
con.arrow = NULL, anchor.x = NULL, anchor.y = NULL,
vp = NULL) {
mark <- shapeGrob(
x = x, y = y, id = id, id.lengths = id.lengths,
expand = expand, radius = radius,
default.units = default.units, name = name, gp = mark.gp,
vp = vp
)
if (!is.null(label)) {
label <- lapply(seq_len(nrow(label)), function(i) {
grob <- labelboxGrob(label$label[i], 0, 0, label$description[i],
gp = label.gp, pad = label.margin, width = label.width,
min.width = label.minwidth, hjust = label.hjust
)
if (con.border == 'all') {
grob$children[[1]]$gp$col <- con.gp$col
grob$children[[1]]$gp$lwd <- con.gp$lwd
grob$children[[1]]$gp$lty <- con.gp$lty
}
grob
})
labeldim <- lapply(label, function(l) {
c(
convertWidth(grobWidth(l), 'mm', TRUE),
convertHeight(grobHeight(l), 'mm', TRUE)
)
})
ghosts <- lapply(ghosts, unit, default.units)
} else {
labeldim <- NULL
}
if (!is.null(anchor.x) && !is.unit(anchor.x)) {
anchor.x <- unit(anchor.x, default.units)
}
if (!is.null(anchor.y) && !is.unit(anchor.y)) {
anchor.y <- unit(anchor.y, default.units)
}
gTree(
mark = mark, label = label, labeldim = labeldim,
buffer = label.buffer, ghosts = ghosts, con.gp = con.gp, con.type = con.type,
con.cap = as_mm(con.cap, default.units), con.border = con.border,
con.arrow = con.arrow, anchor.x = anchor.x, anchor.y = anchor.y, name = name,
vp = vp, cl = 'rect_enc'
)
}
#' @importFrom grid makeContent setChildren gList
#' @export
makeContent.rect_enc <- function(x) {
mark <- x$mark
if (inherits(mark, 'shape')) mark <- makeContent(mark)
if (!is.null(x$label)) {
polygons <- Map(function(x, y) list(x = x, y = y),
x = split(as.numeric(mark$x), mark$id),
y = split(as.numeric(mark$y), mark$id)
)
anchor_x <- if (is.null(x$anchor.x)) NULL else convertX(x$anchor.x, 'mm', TRUE)
anchor_y <- if (is.null(x$anchor.y)) NULL else convertY(x$anchor.y, 'mm', TRUE)
labels <- make_label(
labels = x$label, dims = x$labeldim, polygons = polygons,
ghosts = x$ghosts, buffer = x$buffer, con_type = x$con.type,
con_border = x$con.border, con_cap = x$con.cap,
con_gp = x$con.gp, anchor_mod = 3, anchor_x = anchor_x,
anchor_y = anchor_y, arrow = x$con.arrow
)
setChildren(x, inject(gList(!!!c(list(mark), labels))))
} else {
setChildren(x, gList(mark))
}
}
ggforce/R/zzz.R 0000644 0001762 0000144 00000001027 14303104061 013037 0 ustar ligges users default_axis_guide <- NULL
.onLoad <- function(...) {
if (utils::packageVersion("ggplot2") > "3.2.1") {
default_axis_guide <<- ggplot2::waiver()
} else {
default_axis_guide <<- "none"
}
ggplot2::register_theme_elements(
zoom = element_rect(),
zoom.x = element_rect(),
zoom.y = element_rect(),
element_tree = list(
zoom = ggplot2::el_def('element_rect', 'strip.background'),
zoom.x = ggplot2::el_def('element_rect', 'zoom'),
zoom.y = ggplot2::el_def('element_rect', 'zoom')
)
)
}
ggforce/R/scale-unit.R 0000644 0001762 0000144 00000001551 14564603246 014272 0 ustar ligges users #' Position scales for units data
#'
#' `r lifecycle::badge('deprecated')` These are the default scales for the units
#' class. These will usually be added automatically. To override manually, use
#' `scale_*_unit`.
#'
#' @param ... Passed on to `units::scale_x_unit()` or `units::scale_y_unit()`
#'
#' @name scale_unit
#' @aliases NULL
#' @keywords internal
NULL
#' @rdname scale_unit
#' @export
#' @importFrom scales censor
scale_x_unit <- function(...) {
lifecycle::deprecate_soft('0.3.4', "scale_x_unit()", "units::scale_x_unit()")
check_installed('units', 'to use scale_x_unit')
units::scale_x_units(...)
}
#' @rdname scale_unit
#' @export
#' @importFrom scales censor
scale_y_unit <- function(...) {
lifecycle::deprecate_soft('0.3.4', "scale_y_unit()", "units::scale_y_unit()")
check_installed('units', 'to use scale_y_unit')
units::scale_y_units(...)
}
ggforce/R/interpolate.R 0000644 0001762 0000144 00000006721 14564603653 014562 0 ustar ligges users #' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @importFrom grid segmentsGrob polylineGrob gpar
GeomPathInterpolate <- ggproto('GeomPathInterpolate', GeomPath,
draw_panel = function(self, data, panel_scales, coord, arrow = NULL,
lineend = 'butt', linejoin = 'round', linemitre = 1,
na.rm = FALSE) {
if (!anyDuplicated(data$group)) {
cli::cli_inform(c(
"{.fn {snake_class(self)}}: Each group consists of only one observation.",
i = "Do you need to adjust the {.field group} aesthetic?"
))
}
data <- data[order(data$group), , drop = FALSE]
data <- interpolateDataFrame(data)
munched <- coord_munch(coord, data, panel_scales)
rows <- stats::ave(seq_len(nrow(munched)), munched$group,
FUN = length
)
munched <- munched[rows >= 2, ]
if (nrow(munched) < 2) {
return(zeroGrob())
}
attr <- dapply(data, 'group', function(df) {
data_frame0(
solid = identical(unique0(df$linetype), 1),
constant = nrow(unique0(df[, names(df) %in% c(
'alpha', 'colour',
'linewidth', 'size', 'linetype'
)])) == 1
)
})
solid_lines <- all(attr$solid)
constant <- all(attr$constant)
if (!solid_lines && !constant) {
cli::cli_abort("{.fn {snake_class(self)}} can't have varying {.field colour}, {.field linewidth}, and/or {.field alpha} along the line when {.field linetype} isn't solid")
}
n <- nrow(munched)
group_diff <- munched$group[-1] != munched$group[-n]
start <- c(TRUE, group_diff)
end <- c(group_diff, TRUE)
if (!constant) {
segmentsGrob(munched$x[!end], munched$y[!end], munched$x[!start],
munched$y[!start],
default.units = 'native', arrow = arrow,
gp = gpar(
col = alpha(munched$colour, munched$alpha)[!end],
fill = alpha(munched$colour, munched$alpha)[!end],
lwd = (munched$linewidth[!end] %||% munched$size[!end]) * .pt,
lty = munched$linetype[!end],
lineend = lineend, linejoin = linejoin, linemitre = linemitre
)
)
}
else {
id <- match(munched$group, unique0(munched$group))
polylineGrob(munched$x, munched$y,
id = id, default.units = 'native',
arrow = arrow, gp = gpar(
col = alpha(munched$colour, munched$alpha)[start],
fill = alpha(munched$colour, munched$alpha)[start],
lwd = (munched$linewidth[start] %||% munched$size[start]) * .pt,
lty = munched$linetype[start], lineend = lineend,
linejoin = linejoin, linemitre = linemitre
)
)
}
},
handle_na = function(data, params) {
data
}
)
#' Interpolate layer data
#'
#' @param data A data.frame with data for a layer
#'
#' @return A similar data.frame with NA values interpolated
#'
#' @importFrom tweenr tween_t
#' @keywords internal
#' @export
interpolateDataFrame <- function(data) {
if (is.null(data$group)) {
cli::cli_abort('data must have a group column')
}
interpLengths <- lengths(split(data$group, data$group))
for (i in seq_len(ncol(data))) {
if (names(data)[i] %in% c('x', 'y', 'index', 'group', '.interp') ||
all(is.na(data[[i]]))) {
next
}
if (length(unique0(data[[i]][data$.interp])) > 1) {
next
}
interpValues <- split(data[[i]][!data$.interp], data$group[!data$.interp])
data[[i]] <- unlist(tween_t(interpValues, interpLengths))
}
data[, names(data) != '.interp']
}
ggforce/R/trans_linear.R 0000644 0001762 0000144 00000006413 14306101561 014674 0 ustar ligges users #' Create a custom linear transformation
#'
#' This function lets you compose transformations based on a sequence of linear
#' transformations. If the transformations are parameterised the parameters will
#' become arguments in the transformation function. The transformations are
#' one of `rotate`, `shear`, `stretch`, `translate`, and
#' `reflect`.
#'
#' @param ... A number of transformation functions.
#'
#' @return `linear_trans` creates a trans object. The other functions
#' return a 3x3 transformation matrix.
#'
#' @export
#' @importFrom scales trans_new
#'
#' @examples
#' trans <- linear_trans(rotate(a), shear(1, 0), translate(x1, y1))
#' square <- data.frame(x = c(0, 0, 1, 1), y = c(0, 1, 1, 0))
#' square2 <- trans$transform(square$x, square$y, a = pi / 3, x1 = 4, y1 = 8)
#' square3 <- trans$transform(square$x, square$y, a = pi / 1.5, x1 = 2, y1 = -6)
#' square <- rbind(square, square2, square3)
#' square$group <- rep(1:3, each = 4)
#' ggplot(square, aes(x, y, group = group)) +
#' geom_polygon(aes(fill = factor(group)), colour = 'black')
linear_trans <- function(...) {
calls <- as.list(substitute(list2(...)))[-1]
transformations <- sapply(calls, deparse)
args <- unlist(lapply(calls, function(call) {
args <- as.list(call)[-1]
as.character(args[sapply(args, 'class') == 'name'])
}))
args <- unique0(args)
if (any(c('x', 'y') %in% args)) {
cli::cli_abort('{.arg x} and {.arg y} are preserved argument names')
}
args <- c('x', 'y', args)
trans_fun <- function() {
env <- environment()
trans_mat <- Reduce(function(l, r) r %*% l,
lapply(calls, eval, envir = env))
trans <- trans_mat %*% rbind(x, y, z = 1)
data_frame0(x = trans[1, ], y = trans[2, ])
}
formals(trans_fun) <- structure(rep(list(quote(expr = )), length(args)),
names = args)
inv_fun <- function() {
env <- environment()
trans_mat <- Reduce(function(l, r) r %*% l,
lapply(calls, eval, envir = env))
trans_mat <- solve(trans_mat)
trans <- trans_mat %*% rbind(x, y, z = 1)
data_frame0(x = trans[1, ], y = trans[2, ])
}
formals(inv_fun) <- structure(rep(list(quote(expr = )), length(args)),
names = args)
trans_new(
name = paste0('linear: ', paste(transformations, collapse = ', ')),
transform = trans_fun,
inverse = inv_fun,
breaks = extended_breaks(),
format = format_format()
)
}
#' @rdname linear_trans
#' @param angle An angle in radians
rotate <- function(angle) {
matrix(c(cos(angle), -sin(angle), 0, sin(angle), cos(angle), 0, 0, 0, 1),
ncol = 3)
}
#' @rdname linear_trans
#' @param x the transformation magnitude in the x-direction
#' @param y the transformation magnitude in the x-direction
stretch <- function(x, y) {
matrix(c(x, 0, 0, 0, y, 0, 0, 0, 1), ncol = 3)
}
#' @rdname linear_trans
shear <- function(x, y) {
matrix(c(1, y, 0, x, 1, 0, 0, 0, 1), ncol = 3)
}
#' @rdname linear_trans
translate <- function(x, y) {
matrix(c(1, 0, 0, 0, 1, 0, x, y, 1), ncol = 3)
}
#' @rdname linear_trans
reflect <- function(x, y) {
l <- x^2 + y^2
matrix(
c(
(x^2 - y^2) / l,
2 * x * y / l,
0,
2 * x * y / l,
(y^2 - x^2) / l,
0,
0,
0,
1
),
ncol = 3
)
}
ggforce/R/autodensity.R 0000644 0001762 0000144 00000007366 14564603246 014610 0 ustar ligges users #' @rdname geom_autohistogram
#' @inheritParams ggplot2::geom_point
#' @inheritParams ggplot2::geom_density
#' @export
geom_autodensity <- function(mapping = NULL, data = NULL,
stat = "autodensity", position = "floatstack",
...,
bw = "nrd0",
adjust = 1,
kernel = "gaussian",
n = 512,
trim = FALSE,
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
outline.type = "upper") {
extra_mapping <- aes(x = .panel_x, y = .panel_y)
if (is.null(mapping$x)) mapping$x <- extra_mapping$x
if (is.null(mapping$y)) mapping$y <- extra_mapping$y
class(mapping) <- 'uneval'
layer(
data = data,
mapping = mapping,
stat = stat,
geom = GeomAutoarea,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
bw = bw,
adjust = adjust,
kernel = kernel,
n = n,
trim = trim,
na.rm = na.rm,
...,
outline.type = outline.type
)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatAutodensity <- ggproto('StatAutodensity', StatDensity,
setup_params = function(data, params) {
params$panel_range <- lapply(split(data$y, data$PANEL), function(y) {
if (length(y) == 0) return()
range(y, na.rm=TRUE)
})
params$panel_count <- lapply(split(data$y, data$PANEL), function(y)length(y[is.finite(y)]))
params
},
compute_group = function(self, data, scales, bw = "nrd0", adjust = 1, kernel = "gaussian",
n = 512, trim = FALSE, na.rm = FALSE, panel_range = list(), panel_count = list()) {
if (scales$x$is_discrete()) {
bins <- split(data, factor(data$x, levels = seq_len(scales$x$range_c$range[2])))
binned <- lapply(as.integer(names(bins)), function(x) {
count <- nrow(bins[[x]])
pad <- if (count == 0) 0.5 else 0.3
pad <- pad * c(-1, 1)
data_frame0(
x = x + pad,
density = count / nrow(data)
)
})
binned <- vec_rbind(!!!binned)
binned$scaled <- binned$density / max(binned$density)
binned$ndensity <- binned$density / max(binned$density)
binned$count <- binned$density * nrow(data)
binned$n <- nrow(data)
} else {
binned <- ggproto_parent(StatDensity, self)$compute_group(
data, scales, bw = bw, adjust = adjust, kernel = kernel,
n = n, trim = trim, na.rm = na.rm
)
}
panel_range <- panel_range[[data$PANEL[1]]]
panel_count <- panel_count[[data$PANEL[1]]]
ymin <- panel_range[1]
binned$y <- ymin + binned$ndensity * (panel_range[2] - panel_range[1]) * nrow(data) / panel_count
binned$ymin <- ymin
binned$ymax <- binned$y
binned
},
default_aes = aes(weight = 1),
required_aes = c("x", "y")
)
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
GeomAutoarea <- ggproto('GeomAutoarea', GeomArea,
setup_data = function(data, params) {
data[order(data$PANEL, data$group, data$x), ]
},
draw_panel = function(self, data, panel_params, coord, na.rm = FALSE, ...) {
y_range <- coord$range(panel_params)$y
y_span <- y_range[2] - y_range[1]
panel_min <- min(data$ymin)
panel_span <- max(data$ymax) - panel_min
data$ymin <- ((data$ymin - panel_min) / panel_span) * y_span * 0.9 + y_range[1]
data$ymax <- ((data$ymax - panel_min) / panel_span) * y_span * 0.9 + y_range[1]
ggproto_parent(GeomArea, self)$draw_panel(
data = data,
panel_params = panel_params,
coord = coord,
na.rm = na.rm,
...
)
}
)
ggforce/R/ggforce-package.R 0000644 0001762 0000144 00000003526 14564603246 015237 0 ustar ligges users #' @useDynLib ggforce
#' @import ggplot2
#' @importFrom Rcpp sourceCpp
#'
#' @examples
#' rocketData <- data.frame(
#' x = c(1, 1, 2, 2),
#' y = c(1, 2, 2, 3)
#' )
#' rocketData <- do.call(rbind, lapply(seq_len(500) - 1, function(i) {
#' rocketData$y <- rocketData$y - c(0, i / 500)
#' rocketData$group <- i + 1
#' rocketData
#' }))
#' rocketData2 <- data.frame(
#' x = c(2, 2.25, 2),
#' y = c(2, 2.5, 3)
#' )
#' rocketData2 <- do.call(rbind, lapply(seq_len(500) - 1, function(i) {
#' rocketData2$x[2] <- rocketData2$x[2] - i * 0.25 / 500
#' rocketData2$group <- i + 1 + 500
#' rocketData2
#' }))
#'
#' ggplot() + geom_link(aes(
#' x = 2, y = 2, xend = 3, yend = 3, alpha = after_stat(index),
#' size = after_stat(index)
#' ), colour = 'goldenrod', n = 500) +
#' geom_bezier(aes(x = x, y = y, group = group, colour = after_stat(index)),
#' data = rocketData
#' ) +
#' geom_bezier(aes(x = y, y = x, group = group, colour = after_stat(index)),
#' data = rocketData
#' ) +
#' geom_bezier(aes(x = x, y = y, group = group, colour = 1),
#' data = rocketData2
#' ) +
#' geom_bezier(aes(x = y, y = x, group = group, colour = 1),
#' data = rocketData2
#' ) +
#' geom_text(aes(x = 1.65, y = 1.65, label = 'ggplot2', angle = 45),
#' colour = 'white', size = 15
#' ) +
#' coord_fixed() +
#' scale_x_reverse() +
#' scale_y_reverse() +
#' scale_alpha(range = c(1, 0), guide = 'none') +
#' scale_size_continuous(
#' range = c(20, 0.1), trans = 'exp',
#' guide = 'none'
#' ) +
#' scale_color_continuous(guide = 'none') +
#' xlab('') + ylab('') +
#' ggtitle('ggforce: Accelerating ggplot2') +
#' theme(plot.title = element_text(size = 20))
#' @keywords internal
"_PACKAGE"
## usethis namespace: start
#' @importFrom lifecycle deprecated
#' @import rlang
#' @import vctrs
## usethis namespace: end
NULL
ggforce/R/regon.R 0000644 0001762 0000144 00000006206 14564603246 013342 0 ustar ligges users #' Draw regular polygons by specifying number of sides
#'
#' This geom makes it easy to construct regular polygons (polygons where all
#' sides and angles are equal) by specifying the number of sides, position, and
#' size. The polygons are always rotated so that they "rest" on a flat side, but
#' this can be changed with the angle aesthetic. The size is based on the radius
#' of their circumcircle and is thus not proportional to their area.
#'
#' @section Aesthetics:
#' geom_regon understand the following aesthetics (required aesthetics are in
#' bold):
#'
#' - **x0** x coordinate
#' - **y0** y coordinate
#' - **sides** the number of sides for regon
#' - **r** the ratio of regon with respect to plot
#' - **angle** regon rotation angle (unit is radian)
#' - color
#' - fill
#' - size
#' - linetype
#' - alpha
#' - lineend
#'
#' @section Computed variables:
#'
#' \describe{
#' \item{x, y}{The coordinates for the corners of the polygon}
#' }
#'
#' @inheritParams ggplot2::geom_polygon
#' @inheritParams ggplot2::stat_identity
#'
#' @name geom_regon
#' @rdname geom_regon
#'
#' @examples
#' ggplot() +
#' geom_regon(aes(x0 = runif(8), y0 = runif(8), sides = sample(3:10, 8),
#' angle = 0, r = runif(8) / 10)) +
#' coord_fixed()
#'
#' # The polygons are drawn with geom_shape, so can be manipulated as such
#' ggplot() +
#' geom_regon(aes(x0 = runif(8), y0 = runif(8), sides = sample(3:10, 8),
#' angle = 0, r = runif(8) / 10),
#' expand = unit(1, 'cm'), radius = unit(1, 'cm')) +
#' coord_fixed()
NULL
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatRegon <- ggproto('StatRegon', Stat,
compute_layer = function(self, data, params, panels) {
if (empty_data(data)) return(data)
pos <- unlist(lapply(data$sides, function(n) {
p <- (seq_len(n) - 1) / n
if (n %% 2 == 0) p <- p + p[2] / 2
p * 2 * pi
}))
data$group <- make_unique(as.character(data$group))
data <- data[rep(seq_len(nrow(data)), data$sides), ]
x_tmp <- sin(pos) * data$r
y_tmp <- cos(pos) * data$r
data$x <- data$x0 + x_tmp * cos(data$angle) - y_tmp * sin(data$angle)
data$y <- data$y0 + x_tmp * sin(data$angle) + y_tmp * cos(data$angle)
data
},
required_aes = c('x0', 'y0', 'sides', 'angle', 'r'),
extra_params = c('na.rm')
)
#' @rdname geom_regon
#' @export
stat_regon <- function(mapping = NULL, data = NULL, geom = 'shape',
position = 'identity', na.rm = FALSE, show.legend = NA,
inherit.aes = TRUE, ...) {
layer(
stat = StatRegon, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, ...)
)
}
#' @rdname geom_regon
#' @export
geom_regon <- function(mapping = NULL, data = NULL, stat = 'regon',
position = 'identity', na.rm = FALSE,
show.legend = NA, inherit.aes = TRUE, ...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomShape,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, ...)
)
}
ggforce/R/diagonal_wide.R 0000644 0001762 0000144 00000010044 14564603246 015011 0 ustar ligges users #' Draw an area defined by an upper and lower diagonal
#'
#' The `geom_diagonal_wide()` function draws a *thick* diagonal, that is, a
#' polygon confined between a lower and upper [diagonal][geom_diagonal]. This
#' geom is bidirectional and the direction can be controlled with the
#' `orientation` argument.
#'
#' @section Aesthetics:
#' geom_diagonal_wide understand the following aesthetics
#' (required aesthetics are in bold):
#'
#' - **x**
#' - **y**
#' - **group**
#' - color
#' - linewidth
#' - linetype
#' - alpha
#' - lineend
#'
#' @inheritParams geom_shape
#' @inheritParams ggplot2::stat_identity
#' @inheritParams ggplot2::geom_line
#'
#' @param n The number of points to create for each of the bounding diagonals
#'
#' @param strength The proportion to move the control point along the x-axis
#' towards the other end of the bezier curve
#'
#' @inheritSection ggplot2::geom_line Orientation
#'
#' @name geom_diagonal_wide
#' @rdname geom_diagonal_wide
#'
#' @examples
#' data <- data.frame(
#' x = c(1, 2, 2, 1, 2, 3, 3, 2),
#' y = c(1, 2, 3, 2, 3, 1, 2, 5),
#' group = c(1, 1, 1, 1, 2, 2, 2, 2)
#' )
#'
#' ggplot(data) +
#' geom_diagonal_wide(aes(x, y, group = group))
#'
#' # The strength control the steepness
#' ggplot(data, aes(x, y, group = group)) +
#' geom_diagonal_wide(strength = 0.75, alpha = 0.5, fill = 'red') +
#' geom_diagonal_wide(strength = 0.25, alpha = 0.5, fill = 'blue')
#'
#' # The diagonal_wide geom uses geom_shape under the hood, so corner rounding
#' # etc are all there
#' ggplot(data) +
#' geom_diagonal_wide(aes(x, y, group = group), radius = unit(5, 'mm'))
#'
NULL
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatDiagonalWide <- ggproto('StatDiagonalWide', Stat,
setup_params = function(data, params) {
params$flipped_aes <- has_flipped_aes(data, params, ambiguous = TRUE)
params
},
setup_data = function(data, params) {
data$flipped_aes <- params$flipped_aes
if (any(table(data$group) != 4)) {
cli::cli_abort('Each group must consist of 4 points')
}
data
},
compute_panel = function(data, scales, strength = 0.5, n = 100, flipped_aes = FALSE) {
data <- flip_data(data, flipped_aes)
data <- data[order(data$group, data$x, data$y), ]
lower <- data[rep_len(c(TRUE, FALSE, TRUE, FALSE), nrow(data)), ]
upper <- data[rep_len(c(FALSE, TRUE, FALSE, TRUE), nrow(data)), ]
lower <- add_controls(lower, strength)
upper <- add_controls(upper[rev(seq_len(nrow(upper))), ], strength)
lower <- StatBezier$compute_panel(lower, scales, n)
upper <- StatBezier$compute_panel(upper, scales, n)
diagonals <- vec_rbind(lower, upper)
diagonals$index <- NULL
diagonals <- diagonals[order(diagonals$group), ]
flip_data(diagonals, flipped_aes)
},
required_aes = c('x', 'y', 'group'),
extra_params = c('na.rm', 'n', 'strength', 'orientation')
)
#' @rdname geom_diagonal_wide
#' @export
stat_diagonal_wide <- function(mapping = NULL, data = NULL, geom = 'shape',
position = 'identity', n = 100, strength = 0.5,
na.rm = FALSE, orientation = NA, show.legend = NA,
inherit.aes = TRUE, ...) {
layer(
stat = StatDiagonalWide, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, orientation = orientation, n = n,
strength = strength, ...)
)
}
#' @rdname geom_diagonal_wide
#' @export
geom_diagonal_wide <- function(mapping = NULL, data = NULL, stat = 'diagonal_wide',
position = 'identity', n = 100, na.rm = FALSE,
orientation = NA, strength = 0.5,
show.legend = NA, inherit.aes = TRUE, ...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomShape,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, orientation = orientation, n = n,
strength = strength, ...)
)
}
ggforce/R/mark_circle.R 0000644 0001762 0000144 00000037264 14564603246 014513 0 ustar ligges users #' Annotate areas with circles
#'
#' This geom lets you annotate sets of points via circles. The enclosing circles
#' are calculated at draw time and the most optimal enclosure at the given
#' aspect ratio is thus guaranteed. As with the other `geom_mark_*` geoms the
#' enclosure inherits from [geom_shape()] and defaults to be expanded slightly
#' to better enclose the points.
#'
#' @section Annotation:
#' All `geom_mark_*` allow you to put descriptive textboxes connected to the
#' mark on the plot, using the `label` and `description` aesthetics. The
#' textboxes are automatically placed close to the mark, but without obscuring
#' any of the datapoints in the layer. The placement is dynamic so if you resize
#' the plot you'll see that the annotation might move around as areas become big
#' enough or too small to fit the annotation. If there's not enough space for
#' the annotation without overlapping data it will not get drawn. In these cases
#' try resizing the plot, change the size of the annotation, or decrease the
#' buffer region around the marks.
#'
#' @section Filtering:
#' Often marks are used to draw attention to, or annotate specific features of
#' the plot and it is thus not desirable to have marks around everything. While
#' it is possible to simply pre-filter the data used for the mark layer, the
#' `geom_mark_*` geoms also comes with a dedicated `filter` aesthetic that, if
#' set, will remove all rows where it evalutates to `FALSE`. There are
#' multiple benefits of using this instead of prefiltering. First, you don't
#' have to change your data source, making your code more adaptable for
#' exploration. Second, the data removed by the filter aesthetic is remembered
#' by the geom, and any annotation will take care not to overlap with the
#' removed data.
#'
#' @section Aesthetics:
#' geom_mark_circle understand the following aesthetics (required aesthetics are
#' in bold):
#'
#' - **x**
#' - **y**
#' - x0 *(used to anchor the label)*
#' - y0 *(used to anchor the label)*
#' - filter
#' - label
#' - description
#' - color
#' - fill
#' - group
#' - size
#' - linetype
#' - alpha
#'
#' @inheritParams geom_shape
#'
#' @param n The number of points used to draw each circle. Defaults to `100`.
#' @param label.margin The margin around the annotation boxes, given by a call
#' to [ggplot2::margin()].
#' @param label.width A fixed width for the label. Set to `NULL` to let the text
#' or `label.minwidth` decide.
#' @param label.minwidth The minimum width to provide for the description. If
#' the size of the label exceeds this, the description is allowed to fill as
#' much as the label.
#' @param label.fontsize The size of the text for the annotation. If it contains
#' two elements the first will be used for the label and the second for the
#' description.
#' @param label.family The font family used for the annotation. If it contains
#' two elements the first will be used for the label and the second for the
#' description.
#' @param label.fontface The font face used for the annotation. If it contains
#' two elements the first will be used for the label and the second for the
#' description.
#' @param label.lineheight The height of a line as a multipler of the fontsize.
#' If it contains two elements the first will be used for the label and the
#' second for the description.
#' @param label.hjust The horizontal justification for the annotation. If it
#' contains two elements the first will be used for the label and the second for
#' the description.
#' @param label.fill The fill colour for the annotation box.
#' @param label.colour The text colour for the annotation. If it contains
#' two elements the first will be used for the label and the second for the
#' description.
#' @param label.buffer The size of the region around the mark where labels
#' cannot be placed.
#' @param con.colour The colour for the line connecting the annotation to the
#' mark.
#' @param con.size The width of the connector.
#' @param con.type The type of the connector. Either `"elbow"`, `"straight"`, or
#' `"none"`.
#' @param con.linetype The linetype of the connector.
#' @param con.border The bordertype of the connector. Either `"one"` (to draw a
#' line on the horizontal side closest to the mark), `"all"` (to draw a border
#' on all sides), or `"none"` (not going to explain that one).
#' @param con.cap The distance before the mark that the line should stop at.
#' @param con.arrow An arrow specification for the connection using
#' [grid::arrow()] for the end pointing towards the mark.
#'
#' @family mark geoms
#'
#' @name geom_mark_circle
#' @rdname geom_mark_circle
#'
#' @examples
#' ggplot(iris, aes(Petal.Length, Petal.Width)) +
#' geom_mark_circle(aes(fill = Species, filter = Species != 'versicolor')) +
#' geom_point()
#'
#' # Add annotation
#' ggplot(iris, aes(Petal.Length, Petal.Width)) +
#' geom_mark_circle(aes(fill = Species, label = Species)) +
#' geom_point()
#'
#' # Long descriptions are automatically wrapped to fit into the width
#' iris$desc <- c(
#' 'A super Iris - and it knows it',
#' 'Pretty mediocre Iris, but give it a couple of years and it might surprise you',
#' "You'll never guess what this Iris does every Sunday"
#' )[iris$Species]
#'
#' ggplot(iris, aes(Petal.Length, Petal.Width)) +
#' geom_mark_circle(aes(fill = Species, label = Species, description = desc,
#' filter = Species == 'setosa')) +
#' geom_point()
#'
#' # Change the buffer size to move labels farther away (or closer) from the
#' # marks
#' ggplot(iris, aes(Petal.Length, Petal.Width)) +
#' geom_mark_circle(aes(fill = Species, label = Species),
#' label.buffer = unit(30, 'mm')) +
#' geom_point()
#'
#' # The connector is capped a bit before it reaches the mark, but this can be
#' # controlled
#' ggplot(iris, aes(Petal.Length, Petal.Width)) +
#' geom_mark_circle(aes(fill = Species, label = Species),
#' con.cap = 0) +
#' geom_point()
NULL
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
GeomMarkCircle <- ggproto('GeomMarkCircle', GeomShape,
setup_data = function(self, data, params) {
if (!is.null(data$filter)) {
self$removed <- data[!data$filter, c('x', 'y', 'PANEL')]
data <- data[data$filter, ]
}
data
},
draw_panel = function(self, data, panel_params, coord, expand = unit(5, 'mm'),
radius = expand, n = 100,
label.margin = margin(2, 2, 2, 2, 'mm'),
label.width = NULL, label.minwidth = unit(50, 'mm'),
label.hjust = 0, label.buffer = unit(10, 'mm'),
label.fontsize = 12, label.family = '',
label.fontface = c('bold', 'plain'),
label.fill = 'white', label.colour = 'black',
label.lineheight = 1,
con.colour = 'black', con.size = 0.5, con.type = 'elbow',
con.linetype = 1, con.border = 'one',
con.cap = unit(3, 'mm'), con.arrow = NULL) {
if (nrow(data) == 0) return(zeroGrob())
# As long as coord$transform() doesn't recognise x0/y0
data$xmin <- data$x0
data$ymin <- data$y0
coords <- coord$transform(data, panel_params)
if (!is.integer(coords$group)) {
coords$group <- match(coords$group, unique0(coords$group))
}
coords <- coords[order(coords$group), ]
# For gpar(), there is one entry per polygon (not one entry per point).
# We'll pull the first value from each group, and assume all these values
# are the same within each group.
first_idx <- !duplicated(coords$group)
first_rows <- coords[first_idx, ]
label <- NULL
ghosts <- NULL
if (!is.null(coords$label) || !is.null(coords$description)) {
label <- first_rows
is_ghost <- which(self$removed$PANEL == coords$PANEL[1])
if (length(is_ghost) > 0) {
ghosts <- self$removed[is_ghost, ]
ghosts <- coord$transform(ghosts, panel_params)
ghosts <- list(x = ghosts$x, y = ghosts$y)
}
}
circEncGrob(coords$x, coords$y,
default.units = 'native',
id = coords$group, expand = expand, radius = radius, n = n,
label = label, ghosts = ghosts,
mark.gp = gpar(
col = first_rows$colour,
fill = alpha(first_rows$fill, first_rows$alpha),
lwd = (first_rows$linewidth %||% first_rows$size) * .pt,
lty = first_rows$linetype
),
label.gp = gpar(
col = label.colour,
fill = label.fill,
fontface = label.fontface,
fontfamily = label.family,
fontsize = label.fontsize,
lineheight = label.lineheight
),
con.gp = gpar(
col = con.colour,
fill = con.colour,
lwd = con.size * .pt,
lty = con.linetype
),
label.margin = label.margin,
label.width = label.width,
label.minwidth = label.minwidth,
label.hjust = label.hjust,
label.buffer = label.buffer,
con.type = con.type,
con.border = con.border,
con.cap = con.cap,
con.arrow = con.arrow,
anchor.x = first_rows$xmin,
anchor.y = first_rows$ymin
)
},
default_aes = combine_aes(
GeomShape$default_aes,
aes(fill = NA, colour = 'black', alpha = 0.3, filter = NULL, label = NULL,
description = NULL, x0 = NULL, y0 = NULL)
),
handle_na = function(self, data, params) {
remove_missing(data, params$na.rm,
c(self$required_aes, self$non_missing_aes),
snake_class(self)
)
},
extra_params = 'na.rm'
)
#' @rdname geom_mark_circle
#' @export
geom_mark_circle <- function(mapping = NULL, data = NULL, stat = 'identity',
position = 'identity', expand = unit(5, 'mm'),
radius = expand, n = 100,
label.margin = margin(2, 2, 2, 2, 'mm'),
label.width = NULL, label.minwidth = unit(50, 'mm'),
label.hjust = 0, label.fontsize = 12,
label.family = '', label.lineheight = 1,
label.fontface = c('bold', 'plain'),
label.fill = 'white', label.colour = 'black',
label.buffer = unit(10, 'mm'), con.colour = 'black',
con.size = 0.5, con.type = 'elbow',
con.linetype = 1, con.border = 'one',
con.cap = unit(3, 'mm'), con.arrow = NULL, ...,
na.rm = FALSE, show.legend = NA,
inherit.aes = TRUE) {
layer(
data = data,
mapping = mapping,
stat = stat,
geom = GeomMarkCircle,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
na.rm = na.rm,
expand = expand,
radius = radius,
n = n,
label.margin = label.margin,
label.width = label.width,
label.minwidth = label.minwidth,
label.fontsize = label.fontsize,
label.family = label.family,
label.lineheight = label.lineheight,
label.fontface = label.fontface,
label.hjust = label.hjust,
label.fill = label.fill,
label.colour = label.colour,
label.buffer = label.buffer,
con.colour = con.colour,
con.size = con.size,
con.type = con.type,
con.linetype = con.linetype,
con.border = con.border,
con.cap = con.cap,
con.arrow = con.arrow,
...
)
)
}
# Helpers -----------------------------------------------------------------
#' @importFrom grDevices chull
circEncGrob <- function(x = c(0, 0.5, 1, 0.5), y = c(0.5, 1, 0.5, 0), id = NULL,
id.lengths = NULL, expand = 0, radius = 0, n = 100,
label = NULL, ghosts = NULL, default.units = 'npc',
name = NULL, mark.gp = gpar(), label.gp = gpar(),
con.gp = gpar(), label.margin = margin(),
label.width = NULL, label.minwidth = unit(50, 'mm'),
label.hjust = 0, label.buffer = unit(10, 'mm'),
con.type = 'elbow', con.border = 'one',
con.cap = unit(3, 'mm'), con.arrow = NULL,
anchor.x = NULL, anchor.y = NULL, vp = NULL) {
if (is.null(id)) {
if (is.null(id.lengths)) {
id <- rep(1, length(x))
} else {
id <- rep(seq_along(id.lengths), id.lengths)
if (length(id) != length(x)) {
cli::cli_abort('{.arg id.lengths} must sum up to the number of points')
}
}
}
include <- unlist(lapply(split(seq_along(x), id), function(i) {
xi <- x[i]
yi <- y[i]
if (length(unique0(xi)) == 1) {
return(i[c(which.min(yi), which.max(yi))])
}
if (length(unique0(yi)) == 1) {
return(i[c(which.min(xi), which.max(xi))])
}
i[chull(xi, yi)]
}))
mark <- shapeGrob(
x = x[include], y = y[include], id = id[include],
id.lengths = NULL, expand = expand, radius = radius,
default.units = default.units, name = name, gp = mark.gp,
vp = vp
)
if (!is.null(label)) {
label <- lapply(seq_len(nrow(label)), function(i) {
grob <- labelboxGrob(label$label[i], 0, 0, label$description[i],
gp = label.gp, pad = label.margin, width = label.width,
min.width = label.minwidth, hjust = label.hjust
)
if (con.border == 'all') {
grob$children[[1]]$gp$col <- con.gp$col
grob$children[[1]]$gp$lwd <- con.gp$lwd
grob$children[[1]]$gp$lty <- con.gp$lty
}
grob
})
labeldim <- lapply(label, function(l) {
c(
convertWidth(grobWidth(l), 'mm', TRUE),
convertHeight(grobHeight(l), 'mm', TRUE)
)
})
ghosts <- lapply(ghosts, unit, default.units)
} else {
labeldim <- NULL
}
if (!is.null(anchor.x) && !is.unit(anchor.x)) {
anchor.x <- unit(anchor.x, default.units)
}
if (!is.null(anchor.y) && !is.unit(anchor.y)) {
anchor.y <- unit(anchor.y, default.units)
}
gTree(
mark = mark, n = n, label = label, labeldim = labeldim,
buffer = label.buffer, ghosts = ghosts, con.gp = con.gp, con.type = con.type,
con.cap = as_mm(con.cap, default.units), con.border = con.border,
con.arrow = con.arrow, anchor.x = anchor.x, anchor.y = anchor.y,
name = name, vp = vp, cl = 'circ_enc'
)
}
#' @importFrom grid convertX convertY unit makeContent setChildren gList
#' @export
makeContent.circ_enc <- function(x) {
mark <- x$mark
x_new <- convertX(mark$x, 'mm', TRUE)
y_new <- convertY(mark$y, 'mm', TRUE)
circles <- enclose_points(round(x_new, 2), round(y_new, 2), mark$id)
circles$id <- seq_len(nrow(circles))
circles <- circles[rep(circles$id, each = x$n), ]
points <- 2 * pi * (seq_len(x$n) - 1) / x$n
circles$x <- circles$x0 + cos(points) * circles$r
circles$y <- circles$y0 + sin(points) * circles$r
circles <- unique0(circles)
mark$x <- unit(circles$x, 'mm')
mark$y <- unit(circles$y, 'mm')
mark$id <- circles$id
if (inherits(mark, 'shape')) mark <- makeContent(mark)
if (!is.null(x$label)) {
polygons <- Map(function(x, y) list(x = x, y = y),
x = split(as.numeric(mark$x), mark$id),
y = split(as.numeric(mark$y), mark$id)
)
anchor_x <- if (is.null(x$anchor.x)) NULL else convertX(x$anchor.x, 'mm', TRUE)
anchor_y <- if (is.null(x$anchor.y)) NULL else convertY(x$anchor.y, 'mm', TRUE)
labels <- make_label(
labels = x$label, dims = x$labeldim, polygons = polygons,
ghosts = x$ghosts, buffer = x$buffer, con_type = x$con.type,
con_border = x$con.border, con_cap = x$con.cap,
con_gp = x$con.gp, anchor_mod = 2, anchor_x = anchor_x,
anchor_y = anchor_y, arrow = x$con.arrow
)
setChildren(x, inject(gList(!!!c(list(mark), labels))))
} else {
setChildren(x, gList(mark))
}
}
ggforce/R/utilities.R 0000644 0001762 0000144 00000013757 14564603246 014254 0 ustar ligges users # Wrapping vctrs data_frame constructor with no name repair
data_frame0 <- function(...) data_frame(..., .name_repair = "minimal")
# Wrapping unique0() to accept NULL
unique0 <- function(x, ...) if (is.null(x)) x else vec_unique(x, ...)
df_rows <- function(x, i) {
cols <- lapply(x, `[`, i = i)
data_frame0(!!!cols, .size = length(i))
}
split_matrix <- function(x, col_names = colnames(x)) {
force(col_names)
x <- lapply(seq_len(ncol(x)), function(i) x[, i])
if (!is.null(col_names)) names(x) <- col_names
x
}
# More performant modifyList without recursion
modify_list <- function(old, new) {
for (i in names(new)) old[[i]] <- new[[i]]
old
}
empty <- function(df) {
is.null(df) || nrow(df) == 0 || ncol(df) == 0
}
split_indices <- function(group) {
split(seq_along(group), group)
}
# Adapted from plyr:::id_vars
# Create a unique id for elements in a single vector
id_var <- function(x, drop = FALSE) {
if (length(x) == 0) {
id <- integer()
n <- 0L
} else if (!is.null(attr(x, 'n')) && !drop) {
return(x)
} else if (is.factor(x) && !drop) {
x <- addNA(x, ifany = TRUE)
id <- as.integer(x)
n <- length(levels(x))
} else {
levels <- sort(unique0(x), na.last = TRUE)
id <- match(x, levels)
n <- max(id)
}
attr(id, 'n') <- n
id
}
#' Create an unique integer id for each unique row in a data.frame
#'
#' Properties:
#' - `order(id)` is equivalent to `do.call(order, df)`
#' - rows containing the same data have the same value
#' - if `drop = FALSE` then room for all possibilites
#'
#' @param .variables list of variables
#' @param drop Should unused factor levels be dropped?
#'
#' @return An integer vector with attribute `n` giving the total number of
#' possible unique rows
#'
#' @keywords internal
#' @noRd
#'
id <- function(.variables, drop = FALSE) {
nrows <- NULL
if (is.data.frame(.variables)) {
nrows <- nrow(.variables)
.variables <- unclass(.variables)
}
lengths <- vapply(.variables, length, integer(1))
.variables <- .variables[lengths != 0]
if (length(.variables) == 0) {
n <- nrows %||% 0L
id <- seq_len(n)
attr(id, 'n') <- n
return(id)
}
if (length(.variables) == 1) {
return(id_var(.variables[[1]], drop = drop))
}
ids <- rev(lapply(.variables, id_var, drop = drop))
p <- length(ids)
ndistinct <- vapply(ids, attr, 'n', FUN.VALUE = numeric(1), USE.NAMES = FALSE)
n <- prod(ndistinct)
if (n > 2^31) {
char_id <- inject(paste(!!!ids, sep = '\r'))
res <- match(char_id, unique0(char_id))
}
else {
combs <- c(1, cumprod(ndistinct[-p]))
mat <- inject(cbind(!!!ids))
res <- c((mat - 1L) %*% combs + 1L)
}
if (drop) {
id_var(res, drop = TRUE)
}
else {
res <- as.integer(res)
attr(res, 'n') <- n
res
}
}
#' Apply function to unique subsets of a data.frame
#'
#' This function is akin to `plyr::ddply`. It takes a single data.frame,
#' splits it by the unique combinations of the columns given in `by`, apply a
#' function to each split, and then reassembles the results into a sigle
#' data.frame again.
#'
#' @param df A data.frame
#' @param by A character vector of column names to split by
#' @param fun A function to apply to each split
#' @param ... Further arguments to `fun`
#' @param drop Should unused factor levels in the columns given in `by` be
#' dropped.
#'
#' @return A data.frame if the result of `fun` does not include the columns
#' given in `by` these will be prepended to the result.
#'
#' @keywords internal
#' @importFrom stats setNames
#' @noRd
dapply <- function(df, by, fun, ..., drop = TRUE) {
grouping_cols <- .subset(df, by)
fallback_order <- unique0(c(by, names(df)))
apply_fun <- function(x) {
res <- fun(x, ...)
if (is.null(res)) return(res)
if (length(res) == 0) return(data_frame0())
vars <- lapply(setNames(by, by), function(col) .subset2(x, col)[1])
if (is.matrix(res)) res <- split_matrix(res)
if (is.null(names(res))) names(res) <- paste0("V", seq_along(res))
if (all(by %in% names(res))) return(data_frame0(!!!unclass(res)))
res <- modify_list(unclass(vars), unclass(res))
res <- res[intersect(c(fallback_order, names(res)), names(res))]
data_frame0(!!!res)
}
# Shortcut when only one group
if (all(vapply(grouping_cols, single_val, logical(1)))) {
return(apply_fun(df))
}
ids <- id(grouping_cols, drop = drop)
group_rows <- split_with_index(seq_len(nrow(df)), ids)
result <- lapply(seq_along(group_rows), function(i) {
cur_data <- df_rows(df, group_rows[[i]])
apply_fun(cur_data)
})
vec_rbind(!!!result)
}
# Use chartr() for safety since toupper() fails to convert i to I in Turkish locale
lower_ascii <- "abcdefghijklmnopqrstuvwxyz"
upper_ascii <- "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
to_lower_ascii <- function(x) chartr(upper_ascii, lower_ascii, x)
to_upper_ascii <- function(x) chartr(lower_ascii, upper_ascii, x)
tolower <- function(x) {
cli::cli_abort("Please use {.fn to_lower_ascii}, which works fine in all locales.")
}
toupper <- function(x) {
cli::cli_abort("Please use {.fn to_upper_ascii}, which works fine in all locales.")
}
# Convert a snake_case string to camelCase
camelize <- function(x, first = FALSE) {
x <- gsub("_(.)", "\\U\\1", x, perl = TRUE)
if (first) x <- firstUpper(x)
x
}
snakeize <- function(x) {
x <- gsub("([A-Za-z])([A-Z])([a-z])", "\\1_\\2\\3", x)
x <- gsub(".", "_", x, fixed = TRUE)
x <- gsub("([a-z])([A-Z])", "\\1_\\2", x)
to_lower_ascii(x)
}
firstUpper <- function(s) {
paste0(to_upper_ascii(substring(s, 1, 1)), substring(s, 2))
}
snake_class <- function(x) {
snakeize(class(x)[1])
}
single_val <- function(x, ...) {
UseMethod("single_val")
}
#' @export
single_val.default <- function(x, ...) {
# This is set by id() used in creating the grouping var
identical(attr(x, "n"), 1L)
}
#' @export
single_val.factor <- function(x, ...) {
# Panels are encoded as factor numbers and can never be missing (NA)
identical(levels(x), "1")
}
with_seed_null <- function(seed, code) {
if (is.null(seed)) {
code
} else {
withr::with_seed(seed, code)
}
}
ggforce/R/shape.R 0000644 0001762 0000144 00000021311 14564603246 013322 0 ustar ligges users #' Draw polygons with expansion/contraction and/or rounded corners
#'
#' This geom is a cousin of [ggplot2::geom_polygon()] with the added
#' possibility of expanding or contracting the polygon by an absolute amount
#' (e.g. 1 cm). Furthermore, it is possible to round the corners of the polygon,
#' again by an absolute amount. The resulting geom reacts to resizing of the
#' plot, so the expansion/contraction and corner radius will not get distorted.
#' If no expansion/contraction or corner radius is specified, the geom falls
#' back to `geom_polygon` so there is no performance penality in using this
#' instead of `geom_polygon`.
#'
#' @note Some settings can result in the dissappearance of polygons,
#' specifically when contracting or rounding corners with a relatively large
#' amount. Also note that x and y scale limits does not take expansion into
#' account and the resulting polygon might thus not fit into the plot.
#'
#' @section Aesthetics:
#' geom_shape understand the following aesthetics (required aesthetics are in
#' bold):
#'
#' - **x**
#' - **y**
#' - color
#' - fill
#' - group
#' - size
#' - linetype
#' - alpha
#'
#' @inheritParams ggplot2::geom_polygon
#'
#' @param expand A numeric or unit vector of length one, specifying the
#' expansion amount. Negative values will result in contraction instead. If the
#' value is given as a numeric it will be understood as a proportion of the
#' plot area width.
#'
#' @param radius As `expand` but specifying the corner radius.
#'
#' @author Thomas Lin Pedersen
#'
#' @name geom_shape
#' @rdname geom_shape
#'
#' @examples
#' shape <- data.frame(
#' x = c(0.5, 1, 0.75, 0.25, 0),
#' y = c(0, 0.5, 1, 0.75, 0.25)
#' )
#' # Expand and round
#' ggplot(shape, aes(x = x, y = y)) +
#' geom_shape(expand = unit(1, 'cm'), radius = unit(0.5, 'cm')) +
#' geom_polygon(fill = 'red')
#'
#' # Contract
#' ggplot(shape, aes(x = x, y = y)) +
#' geom_polygon(fill = 'red') +
#' geom_shape(expand = unit(-1, 'cm'))
#'
#' # Only round corners
#' ggplot(shape, aes(x = x, y = y)) +
#' geom_polygon(fill = 'red') +
#' geom_shape(radius = unit(1, 'cm'))
NULL
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
GeomShape <- ggproto('GeomShape', GeomPolygon,
draw_panel = function(data, panel_params, coord, expand = 0, radius = 0) {
n <- nrow(data)
if (n == 1 && expand == 0) {
return(zeroGrob())
}
munched <- coord_munch(coord, data, panel_params)
munched <- munched[order(munched$group), ]
if (!is.integer(munched$group)) {
munched$group <- match(munched$group, unique0(munched$group))
}
# For gpar(), there is one entry per polygon (not one entry per point).
# We'll pull the first value from each group, and assume all these values
# are the same within each group.
first_idx <- !duplicated(munched$group)
first_rows <- munched[first_idx, ]
shapeGrob(munched$x, munched$y,
default.units = 'native',
id = munched$group, expand = expand, radius = radius,
gp = gpar(
col = first_rows$colour,
fill = alpha(first_rows$fill, first_rows$alpha),
lwd = (first_rows$linewidth %||% first_rows$size) * .pt,
lty = first_rows$linetype
)
)
},
extra_params = c('expand', 'radius')
)
#' @rdname geom_shape
#' @export
geom_shape <- function(mapping = NULL, data = NULL, stat = 'identity',
position = 'identity', expand = 0, radius = 0, ...,
na.rm = FALSE, show.legend = NA, inherit.aes = TRUE) {
layer(
data = data,
mapping = mapping,
stat = stat,
geom = GeomShape,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
na.rm = na.rm,
expand = expand,
radius = radius,
...
)
)
}
#' @importFrom grid is.unit grob
shapeGrob <- function(x = c(0, 0.5, 1, 0.5), y = c(0.5, 1, 0.5, 0), id = NULL,
id.lengths = NULL, expand = 0, radius = 0,
default.units = 'npc', name = NULL, gp = gpar(),
vp = NULL) {
if (as.numeric(expand) == 0 && as.numeric(radius) == 0) {
grob <- polygonGrob(
x = x, y = y, id = id, id.lengths = id.lengths,
default.units = default.units, name = name, gp = gp, vp = vp
)
return(grob)
}
if (!is.unit(x)) {
x <- unit(x, default.units)
}
if (!is.unit(y)) {
y <- unit(y, default.units)
}
if (!is.unit(expand)) {
expand <- unit(expand, default.units)
}
if (!is.unit(radius)) {
radius <- unit(radius, default.units)
}
if (as.numeric(radius) < 0) {
cli::cli_abort('{.arg radius} must be positive')
}
if (is.null(id)) {
if (is.null(id.lengths)) {
id <- rep(1, length(x))
} else {
id <- rep(seq_along(id.lengths), id.lengths)
if (length(id) != length(x)) {
cli::cli_abort('{.arg id.lengths} must sum up to the number of points', call. = FALSE)
}
}
}
x <- x[order(id)]
y <- y[order(id)]
grob(
x = x, y = y, id = id, expand = expand, radius = radius, name = name,
gp = gp, vp = vp, cl = 'shape'
)
}
#' @importFrom grid convertX convertY convertWidth
#' @importFrom polyclip polyoffset polylineoffset
#' @export
makeContent.shape <- function(x) {
id.length <- lengths(split(seq_along(x$id), x$id))
type <- ifelse(id.length == 1, 'point',
ifelse(id.length == 2, 'line', 'polygon'))
x_new <- convertX(x$x, 'mm', TRUE)
x_new <- split(x_new, x$id)
y_new <- convertY(x$y, 'mm', TRUE)
y_new <- split(y_new, x$id)
polygons <- Map(list, x = x_new, y = y_new)
poly <- split(polygons, type)
expand <- convertWidth(x$expand, 'mm', TRUE)
radius <- convertWidth(x$radius, 'mm', TRUE)
expand <- expand - radius
if (expand != 0) {
if (!is.null(poly$polygon)) {
poly$polygon <- lapply(poly$polygon, polyoffset, delta = expand,
jointype = 'miter', miterlim = 1000)
}
if (expand > 0) {
if (!is.null(poly$line)) {
poly$line <- lapply(poly$line, polylineoffset, delta = expand,
jointype = 'square', endtype = 'opensquare')
}
poly$point <- pointoffset(poly$point, expand, type = 'square')
}
}
if (radius != 0) {
if (!is.null(poly$polygon)) {
not_empty <- lengths(poly$polygon) != 0
poly$polygon[not_empty] <- lapply(poly$polygon[not_empty], polyoffset,
delta = radius, jointype = 'round')
}
if (expand > 0) {
if (!is.null(poly$line)) {
not_empty <- lengths(poly$line) != 0
poly$line[not_empty] <- lapply(poly$line[not_empty], polyoffset,
delta = radius, jointype = 'round')
}
if (!is.null(poly$point)) {
not_empty <- lengths(poly$point) != 0
poly$point[not_empty] <- lapply(poly$point[not_empty], polyoffset,
delta = radius, jointype = 'round')
}
} else {
if (!is.null(poly$line)) {
poly$line <- lapply(poly$line, polylineoffset, delta = radius,
jointype = 'round', endtype = 'openround')
}
poly$point <- pointoffset(poly$point, radius, type = 'circle')
}
}
polygons[type == 'polygon'] <- lapply(poly$polygon, function(d) if (length(d) == 0) list() else d[[1]])
polygons[type == 'line'] <- lapply(poly$line, function(d) if (length(d) == 0) list() else d[[1]])
polygons[type == 'point'] <- lapply(poly$point, function(d) if (length(d) == 0) list() else d[[1]])
x$id <- rep(seq_along(polygons), sapply(polygons, function(p) length(p$x)))
x_new <- unlist(lapply(polygons, `[[`, 'x'))
y_new <- unlist(lapply(polygons, `[[`, 'y'))
if (length(x_new) == 0) return(nullGrob())
x$x <- unit(x_new, 'mm')
x$y <- unit(y_new, 'mm')
x$cl <- 'polygon'
class(x)[1] <- 'polygon'
x
}
pointoffset <- function(A, delta, type) {
if (length(A) == 0) return(A)
switch(
type,
square = {
square <- list(x = c(-delta, -delta, delta, delta),
y = c(-delta, delta, delta, -delta))
x <- split(rep(sapply(A, `[[`, 'x'), each = 4) + square$x,
rep(seq_along(A), each = 4))
y <- split(rep(sapply(A, `[[`, 'y'), each = 4) + square$y,
rep(seq_along(A), each = 4))
lapply(Map(list, x = x, y = y), list)
},
circle = {
detail <- 100
radi <- seq(0, 2 * pi, length.out = detail + 1)[-(detail + 1)]
circle <- list(x = cos(radi) * delta, y = sin(radi) * delta)
x <- split(rep(sapply(A, `[[`, 'x'), each = detail) + circle$x,
rep(seq_along(A), each = detail))
y <- split(rep(sapply(A, `[[`, 'y'), each = detail) + circle$y,
rep(seq_along(A), each = detail))
lapply(Map(list, x = x, y = y), list)
}
)
}
ggforce/R/circle.R 0000644 0001762 0000144 00000006273 14564603246 013475 0 ustar ligges users #' @include arc_bar.R
#' @include shape.R
NULL
#' Circles based on center and radius
#'
#' This set of stats and geoms makes it possible to draw circles based on a
#' center point and a radius. In contrast to using
#' [ggplot2::geom_point()], the size of the circles are related to the
#' coordinate system and not to a separate scale. These functions are intended
#' for cartesian coordinate systems and will only produce a true circle if
#' [ggplot2::coord_fixed()] is used.
#'
#' @note If the intend is to draw a bubble chart then use
#' [ggplot2::geom_point()] and map a variable to the size scale
#'
#' @section Aesthetics:
#' geom_circle understand the following aesthetics (required aesthetics are in
#' bold):
#'
#' - **x0**
#' - **y0**
#' - **r**
#' - color
#' - fill
#' - linewidth
#' - linetype
#' - alpha
#' - lineend
#'
#' @section Computed variables:
#'
#' \describe{
#' \item{x, y}{The start coordinates for the segment}
#' }
#'
#' @inheritParams ggplot2::geom_path
#' @inheritParams ggplot2::stat_identity
#'
#' @param n The number of points on the generated path per full circle.
#'
#' @name geom_circle
#' @rdname geom_circle
#' @seealso [geom_arc_bar()] for drawing arcs with fill
#'
#' @examples
#' # Lets make some data
#' circles <- data.frame(
#' x0 = rep(1:3, 3),
#' y0 = rep(1:3, each = 3),
#' r = seq(0.1, 1, length.out = 9)
#' )
#'
#' # Behold some circles
#' ggplot() +
#' geom_circle(aes(x0 = x0, y0 = y0, r = r, fill = r), data = circles)
#'
#' # Use coord_fixed to ensure true circularity
#' ggplot() +
#' geom_circle(aes(x0 = x0, y0 = y0, r = r, fill = r), data = circles) +
#' coord_fixed()
#'
NULL
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @importFrom grid arcCurvature
#' @export
StatCircle <- ggproto('StatCircle', Stat,
compute_panel = function(data, scales, n = 360) {
# Avoid some weird interaction if x and y are mapped at the global level
data$x <- NULL
data$y <- NULL
data$start <- 0
data$end <- 2 * pi
arcPaths(data, n + 1)
},
required_aes = c('x0', 'y0', 'r')
)
#' @rdname geom_circle
#' @export
stat_circle <- function(mapping = NULL, data = NULL, geom = 'circle',
position = 'identity', n = 360, na.rm = FALSE,
show.legend = NA, inherit.aes = TRUE, ...) {
layer(
stat = StatCircle, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, n = n, ...)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
GeomCircle <- ggproto('GeomCircle', GeomShape,
default_aes = combine_aes(GeomShape$default_aes, aes(colour = 'black', fill = NA))
)
#' @rdname geom_circle
#' @inheritParams geom_shape
#' @export
geom_circle <- function(mapping = NULL, data = NULL, stat = 'circle',
position = 'identity', n = 360, expand = 0, radius = 0,
na.rm = FALSE, show.legend = NA, inherit.aes = TRUE,
...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomCircle,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(n = n, na.rm = na.rm, ...)
)
}
ggforce/R/facet_zoom.R 0000644 0001762 0000144 00000044074 14564603246 014363 0 ustar ligges users #' Facet data for zoom with context
#'
#' This facetting provides the means to zoom in on a subset of the data, while
#' keeping the view of the full dataset as a separate panel. The zoomed-in area
#' will be indicated on the full dataset panel for reference. It is possible to
#' zoom in on both the x and y axis at the same time. If this is done it is
#' possible to both get each zoom separately and combined or just combined.
#'
#' @param x,y,xy An expression evaluating to a logical vector that determines
#' the subset of data to zoom in on
#'
#' @param zoom.data An expression evaluating to a logical vector. If `TRUE`
#' the data only shows in the zoom panels. If `FALSE` the data only show in
#' the context panel. If `NA` the data will show in all panels.
#'
#' @param xlim,ylim Specific zoom ranges for each axis. If present they will
#' override `x`, `y`, and/or `xy`.
#'
#' @param split If both `x` and `y` is given, should each axis zoom
#' be shown separately as well? Defaults to `FALSE`
#'
#' @param horizontal If both `x` and `y` is given and
#' `split = FALSE` How should the zoom panel be positioned relative to the
#' full data panel? Defaults to `TRUE`
#'
#' @param zoom.size Sets the relative size of the zoom panel to the full data
#' panel. The default (`2`) makes the zoom panel twice the size of the full
#' data panel.
#'
#' @param show.area Should the zoom area be drawn below the data points on the
#' full data panel? Defaults to `TRUE`.
#'
#' @inheritParams ggplot2::facet_wrap
#'
#' @family ggforce facets
#'
#' @export
#'
#' @examples
#' # Zoom in on the versicolor species on the x-axis
#' ggplot(iris, aes(Petal.Length, Petal.Width, colour = Species)) +
#' geom_point() +
#' facet_zoom(x = Species == 'versicolor')
#'
#' # Zoom in on versicolor on both axes
#' ggplot(iris, aes(Petal.Length, Petal.Width, colour = Species)) +
#' geom_point() +
#' facet_zoom(xy = Species == 'versicolor')
#'
#' # Use different zoom criteria on each axis
#' ggplot(iris, aes(Petal.Length, Petal.Width, colour = Species)) +
#' geom_point() +
#' facet_zoom(x = Species != 'setosa', y = Species == 'versicolor')
#'
#' # Get each axis zoom separately as well
#' ggplot(iris, aes(Petal.Length, Petal.Width, colour = Species)) +
#' geom_point() +
#' facet_zoom(xy = Species == 'versicolor', split = TRUE)
#'
#' # Define the zoom area directly
#' ggplot(iris, aes(Petal.Length, Petal.Width, colour = Species)) +
#' geom_point() +
#' facet_zoom(xlim = c(2, 4))
#'
#' # Selectively show data in the zoom panel
#' ggplot(iris, aes(Petal.Length, Petal.Width, colour = Species)) +
#' geom_point() +
#' facet_zoom(x = Species == 'versicolor', zoom.data = Species == 'versicolor')
facet_zoom <- function(x, y, xy, zoom.data, xlim = NULL, ylim = NULL,
split = FALSE, horizontal = TRUE, zoom.size = 2,
show.area = TRUE, shrink = TRUE) {
x <- if (missing(x)) if (missing(xy)) NULL else enquo(xy) else enquo(x)
y <- if (missing(y)) if (missing(xy)) NULL else enquo(xy) else enquo(y)
zoom.data <- if (missing(zoom.data)) NULL else enquo(zoom.data)
if (is.null(x) && is.null(y) && is.null(xlim) && is.null(ylim)) {
cli::cli_abort('Either x- or y-zoom must be given')
}
if (!is.null(xlim)) x <- NULL
if (!is.null(ylim)) y <- NULL
ggproto(NULL, FacetZoom,
shrink = shrink,
params = list(
x = x, y = y, xlim = xlim, ylim = ylim, split = split,
zoom.data = zoom.data, zoom.size = zoom.size, show.area = show.area,
horizontal = horizontal
)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @importFrom grid convertUnit unit unit.c polygonGrob segmentsGrob gpar
#' grobTree rectGrob
#' @importFrom gtable gtable_add_cols gtable_add_rows gtable_add_grob
#' @importFrom scales rescale
#' @export
FacetZoom <- ggproto('FacetZoom', Facet,
compute_layout = function(data, params) {
layout <- data_frame0(
name = c('orig', 'x', 'y', 'full', 'orig_true', 'zoom_true'),
SCALE_X = c(1L, 2L, 1L, 2L, 1L, 1L),
SCALE_Y = c(1L, 1L, 2L, 2L, 1L, 1L)
)
if (is.null(params$y) && is.null(params$ylim)) {
layout <- layout[c(1, 2, 5:6), ]
} else if (is.null(params$x) && is.null(params$xlim)) {
layout <- layout[c(1, 3, 5:6), ]
}
layout$PANEL <- seq_len(nrow(layout))
layout
},
map_data = function(data, layout, params) {
if (empty(data)) {
return(cbind(data, PANEL = integer(0)))
}
vec_rbind(
cbind(data, PANEL = 1L),
if (!is.null(params$x)) {
index_x <- try_fetch(eval_tidy(params$x, data),
error = function(e) FALSE)
if (sum(index_x, na.rm = TRUE) != 0) {
cbind(data[index_x, ], PANEL = layout$PANEL[layout$name == 'x'])
}
},
if (!is.null(params$y)) {
index_y <- try_fetch(eval_tidy(params$y, data),
error = function(e) FALSE)
if (sum(index_y, na.rm = TRUE) != 0) {
cbind(data[index_y, ], PANEL = layout$PANEL[layout$name == 'y'])
}
},
if (!is.null(params$zoom.data)) {
zoom_data <- try_fetch(eval_tidy(params$zoom.data, data),
error = function(e) NA)
zoom_data <- rep(zoom_data, length.out = nrow(data))
zoom_ind <- zoom_data | is.na(zoom_data)
orig_ind <- !zoom_data | is.na(zoom_data)
vec_rbind(
cbind(data[zoom_ind, ], PANEL = if (any(zoom_ind)) layout$PANEL[layout$name == 'zoom_true'] else integer(0)),
cbind(data[orig_ind, ], PANEL = if (any(orig_ind)) layout$PANEL[layout$name == 'orig_true'] else integer(0))
)
}
)
},
train_scales = function(self, x_scales, y_scales, layout, data, params) {
# Remove any limits settings on the zoom panels
if (length(x_scales) > 1) x_scales[[2]]$limits <- NULL
if (length(y_scales) > 1) y_scales[[2]]$limits <- NULL
# loop over each layer, training x and y scales in turn
for (layer_data in data) {
match_id <- match(layer_data$PANEL, layout$PANEL)
if (!is.null(x_scales)) {
if ('x' %in% layout$name && x_scales[[1]]$is_discrete()) {
cli::cli_abort('facet_zoom doesn\'t support zooming in discrete scales')
}
x_vars <- intersect(x_scales[[1]]$aesthetics, names(layer_data))
SCALE_X <- layout$SCALE_X[match_id]
if (!is.null(params$xlim)) {
x_scales[[2]]$train(x_scales[[2]]$transform(params$xlim))
scale_apply(layer_data, x_vars, 'train', SCALE_X, x_scales[-2])
} else {
scale_apply(layer_data, x_vars, 'train', SCALE_X, x_scales)
}
}
if (!is.null(y_scales)) {
if ('y' %in% layout$name && y_scales[[1]]$is_discrete()) {
cli::cli_abort('facet_zoom doesn\'t support zooming in discrete scales')
}
y_vars <- intersect(y_scales[[1]]$aesthetics, names(layer_data))
SCALE_Y <- layout$SCALE_Y[match_id]
if (!is.null(params$ylim)) {
y_scales[[2]]$train(y_scales[[2]]$transform(params$ylim))
scale_apply(layer_data, y_vars, 'train', SCALE_Y, y_scales[-2])
} else {
scale_apply(layer_data, y_vars, 'train', SCALE_Y, y_scales)
}
}
}
},
finish_data = function(data, layout, x_scales, y_scales, params) {
plot_panels <- which(!grepl('_true', layout$name))
data <- if (is.null(params$zoom.data)) {
vec_rbind(!!!lapply(layout$PANEL[plot_panels], function(panel) {
d <- data[data$PANEL == 1, ]
d$PANEL <- panel
d
}))
} else {
orig_pan <- layout$PANEL[layout$name == 'orig_true']
zoom_pan <- layout$PANEL[layout$name == 'zoom_true']
orig_data <- data[data$PANEL == orig_pan, ]
orig_data$PANEL <- if (nrow(orig_data) != 0) 1L else integer(0)
zoom_data <- data[data$PANEL == zoom_pan, ]
vec_rbind(orig_data, vec_rbind(!!!lapply(plot_panels[-1], function(panel) {
zoom_data$PANEL <- if (nrow(zoom_data) != 0) panel else integer(0)
zoom_data
})))
}
data$PANEL <- factor(data$PANEL, layout$PANEL)
data
},
draw_panels = function(self, panels, layout, x_scales, y_scales, ranges, coord,
data, theme, params) {
if (inherits(coord, 'CoordFlip')) {
cli::cli_abort('facet_zoom doesn\'t work with flipped scales')
}
if (is.null(params$x) && is.null(params$xlim)) {
params$horizontal <- TRUE
} else if (is.null(params$y) && is.null(params$ylim)) {
params$horizontal <- FALSE
}
zoom_x <- calc_element('zoom.x', theme)
zoom_y <- calc_element('zoom.y', theme)
# Construct the panels
axes <- render_axes(ranges, ranges, coord, theme, FALSE)
panelGrobs <- create_panels(panels, axes$x, axes$y)
panelGrobs <- panelGrobs[seq_len(length(panelGrobs) - 2)]
if ('full' %in% layout$name && !params$split) {
panelGrobs <- panelGrobs[c(1, 4)]
}
if ('y' %in% layout$name) {
if (!inherits(zoom_y, 'element_blank')) {
zoom_prop <- rescale(y_scales[[2]]$dimension(expansion(y_scales[[2]])),
from = y_scales[[1]]$dimension(expansion(y_scales[[1]]))
)
indicator <- polygonGrob(
c(1, 1, 0, 0),
c(zoom_prop, 1, 0),
gp = gpar(col = NA, fill = alpha(zoom_y$fill, 0.5))
)
lines <- segmentsGrob(
y0 = c(0, 1),
x0 = c(0, 0),
y1 = zoom_prop,
x1 = c(1, 1),
gp = gpar(
col = zoom_y$colour,
lty = zoom_y$linetype,
lwd = (zoom_y$linewidth %||% zoom_y$size) * .pt,
lineend = 'round'
)
)
indicator_h <- grobTree(indicator, lines)
} else {
indicator_h <- zeroGrob()
}
}
if ('x' %in% layout$name) {
if (!inherits(zoom_x, 'element_blank')) {
zoom_prop <- rescale(x_scales[[2]]$dimension(expansion(x_scales[[2]])),
from = x_scales[[1]]$dimension(expansion(x_scales[[1]]))
)
indicator <- polygonGrob(
c(zoom_prop, 1, 0),
c(1, 1, 0, 0),
gp = gpar(col = NA, fill = alpha(zoom_x$fill, 0.5))
)
lines <- segmentsGrob(
x0 = c(0, 1),
y0 = c(0, 0),
x1 = zoom_prop,
y1 = c(1, 1),
gp = gpar(
col = zoom_x$colour,
lty = zoom_x$linetype,
lwd = (zoom_x$linewidth %||% zoom_x$size) * .pt,
lineend = 'round'
)
)
indicator_v <- grobTree(indicator, lines)
} else {
indicator_v <- zeroGrob()
}
}
if ('full' %in% layout$name && params$split) {
space.x <- theme$panel.spacing.x
if (is.null(space.x)) space.x <- theme$panel.spacing
space.x <- unit(5 * as.numeric(convertUnit(space.x, 'cm')), 'cm')
space.y <- theme$panel.spacing.y
if (is.null(space.y)) space.y <- theme$panel.spacing
space.y <- unit(5 * as.numeric(convertUnit(space.y, 'cm')), 'cm')
final <- gtable_add_cols(panelGrobs[[3]], space.x)
final <- cbind(final, panelGrobs[[1]], size = 'first')
final_tmp <- gtable_add_cols(panelGrobs[[4]], space.x)
final_tmp <- cbind(final_tmp, panelGrobs[[2]], size = 'first')
final <- gtable_add_rows(final, space.y)
final <- rbind(final, final_tmp, size = 'first')
final <- gtable_add_grob(final, list(indicator_h, indicator_h), c(2, 6), 3,
c(2, 6), 5, z = -Inf, name = 'zoom-indicator')
final <- gtable_add_grob(final, list(indicator_v, indicator_v), 3, c(2, 6),
5, z = -Inf, name = 'zoom-indicator')
heights <- unit.c(
unit(max_height(list(axes$x[[1]]$top, axes$x[[3]]$top)), 'cm'),
unit(1, 'null'),
unit(max_height(list(axes$x[[1]]$bottom, axes$x[[3]]$bottom)), 'cm'),
space.y,
unit(max_height(list(axes$x[[2]]$top, axes$x[[4]]$top)), 'cm'),
unit(params$zoom.size, 'null'),
unit(max_height(list(axes$x[[2]]$bottom, axes$x[[4]]$bottom)), 'cm')
)
widths <- unit.c(
unit(max_width(list(axes$y[[3]]$left, axes$y[[4]]$left)), 'cm'),
unit(params$zoom.size, 'null'),
unit(max_width(list(axes$y[[3]]$right, axes$y[[4]]$right)), 'cm'),
space.x,
unit(max_width(list(axes$y[[1]]$left, axes$y[[2]]$left)), 'cm'),
unit(1, 'null'),
unit(max_width(list(axes$y[[1]]$right, axes$y[[2]]$right)), 'cm')
)
final$heights <- heights
final$widths <- widths
} else {
if (params$horizontal) {
space <- theme$panel.spacing.x
if (is.null(space)) space <- theme$panel.spacing
space <- unit(5 * as.numeric(convertUnit(space, 'cm')), 'cm')
heights <- unit.c(
unit(max_height(list(axes$x[[1]]$top, axes$x[[2]]$top)), 'cm'),
unit(1, 'null'),
unit(max_height(list(axes$x[[1]]$bottom, axes$x[[2]]$bottom)), 'cm')
)
final <- gtable_add_cols(panelGrobs[[2]], space)
final <- cbind(final, panelGrobs[[1]], size = 'first')
final$heights <- heights
final$widths[panel_cols(final)$l] <- unit(c(params$zoom.size, 1), 'null')
final <- gtable_add_grob(final, indicator_h, 2, 3, 2, 5, z = -Inf,
name = 'zoom-indicator')
} else {
space <- theme$panel.spacing.y
if (is.null(space)) space <- theme$panel.spacing
space <- unit(5 * as.numeric(convertUnit(space, 'cm')), 'cm')
widths <- unit.c(
unit(max_width(list(axes$y[[1]]$left, axes$y[[2]]$left)), 'cm'),
unit(1, 'null'),
unit(max_width(list(axes$y[[1]]$right, axes$y[[2]]$right)), 'cm')
)
final <- gtable_add_rows(panelGrobs[[1]], space)
final <- rbind(final, panelGrobs[[2]], size = 'first')
final$widths <- widths
final$heights[panel_rows(final)$t] <- unit(c(1, params$zoom.size), 'null')
final <- gtable_add_grob(final, indicator_v, 3, 2, 5, z = -Inf,
name = 'zoom-indicator')
}
}
final
},
draw_back = function(data, layout, x_scales, y_scales, theme, params) {
zoom_x <- calc_element('zoom.x', theme)
zoom_y <- calc_element('zoom.y', theme)
if (!(is.null(params$x) && is.null(params$xlim)) &&
params$show.area && !inherits(zoom_x, 'element_blank')) {
zoom_prop <- rescale(x_scales[[2]]$dimension(expansion(x_scales[[2]])),
from = x_scales[[1]]$dimension(expansion(x_scales[[1]]))
)
x_back <- grobTree(
rectGrob(x = mean(zoom_prop), y = 0.5, width = diff(zoom_prop),
height = 1,
gp = gpar(col = NA, fill = alpha(zoom_x$fill, 0.5))),
segmentsGrob(zoom_prop, c(0, 0), zoom_prop, c(1, 1), gp = gpar(
col = zoom_x$colour,
lty = zoom_x$linetype,
lwd = (zoom_x$linewidth %||% zoom_x$size) * .pt,
lineend = 'round'
))
)
} else {
x_back <- zeroGrob()
}
if (!(is.null(params$y) && is.null(params$ylim)) &&
params$show.area && !inherits(zoom_y, 'element_blank')) {
zoom_prop <- rescale(y_scales[[2]]$dimension(expansion(y_scales[[2]])),
from = y_scales[[1]]$dimension(expansion(y_scales[[1]]))
)
y_back <- grobTree(
rectGrob(y = mean(zoom_prop), x = 0.5, height = diff(zoom_prop),
width = 1,
gp = gpar(col = NA, fill = alpha(zoom_y$fill, 0.5))),
segmentsGrob(y0 = zoom_prop, x0 = c(0, 0), y1 = zoom_prop, x1 = c(1, 1),
gp = gpar(col = zoom_y$colour,
lty = zoom_y$linetype,
lwd = (zoom_y$linewidth %||% zoom_y$size) * .pt,
lineend = 'round'
)
)
)
} else {
y_back <- zeroGrob()
}
if ('full' %in% layout$name && params$split) {
list(grobTree(x_back, y_back), y_back, x_back, zeroGrob(), zeroGrob(),
zeroGrob())
} else {
list(grobTree(x_back, y_back), zeroGrob(), zeroGrob(), zeroGrob())
}
}
)
#' @importFrom grid grobHeight grobWidth unit unit.c
#' @importFrom gtable gtable gtable_add_grob
create_panels <- function(panels, x.axis, y.axis) {
Map(function(panel, x, y, i) {
heights <- unit.c(grobHeight(x$top), unit(1, 'null'), grobHeight(x$bottom))
widths <- unit.c(grobWidth(y$left), unit(1, 'null'), grobWidth(y$right))
table <- gtable(widths, heights)
table <- gtable_add_grob(table, panel, t = 2, l = 2, z = 2, clip = 'on',
name = paste0('panel-', i))
table <- gtable_add_grob(table, x, t = c(1, 3), l = 2, z = 4, clip = 'off',
name = paste0(c('axis-t-', 'axis-b-'), i))
table <- gtable_add_grob(table, y, t = 2, l = c(1, 3), z = 4, clip = 'off',
name = paste0(c('axis-l-', 'axis-r-'), i))
}, panel = panels, x = x.axis, y = y.axis, i = seq_along(panels))
}
expansion <- function(scale, discrete = c(0, 0.6), continuous = c(0.05, 0)) {
if (inherits(scale$expand, 'waiver')) {
if (scale$is_discrete()) {
discrete
} else {
continuous
}
} else {
scale$expand
}
}
# Helpers -----------------------------------------------------------------
split_with_index <- function(x, f, n = max(f)) {
if (n == 1) return(list(x))
f <- as.integer(f)
attributes(f) <- list(levels = as.character(seq_len(n)), class = "factor")
unname(split(x, f))
}
# Function for applying scale method to multiple variables in a given
# data set. Implement in such a way to minimize copying and hence maximise
# speed
scale_apply <- function(data, vars, method, scale_id, scales) {
if (length(vars) == 0) return()
if (nrow(data) == 0) return()
if (any(is.na(scale_id))) {
cli::cli_abort("{.arg scale_id} must not contain any {.val NA}")
}
scale_index <- split_with_index(seq_along(scale_id), scale_id, length(scales))
lapply(vars, function(var) {
pieces <- lapply(seq_along(scales), function(i) {
scales[[i]][[method]](data[[var]][scale_index[[i]]])
})
# Remove empty vectors to avoid coercion issues with vctrs
pieces[lengths(pieces) == 0] <- NULL
o <- order(unlist(scale_index))[seq_len(sum(lengths(pieces)))]
vec_c(!!!pieces)[o]
})
}
ggforce/R/mark_label.R 0000644 0001762 0000144 00000031150 14564603246 014315 0 ustar ligges users #' @importFrom polyclip polyoffset polyminkowski polyclip
#' @importFrom grid convertX convertY
place_labels <- function(rects, polygons, bounds, anchors, ghosts) {
res <- vector('list', length(rects))
bbox <- list(
x = c(0, bounds[1], bounds[1], 0),
y = c(0, 0, bounds[2], bounds[2])
)
if (!is.null(ghosts) && length(ghosts$x) > 0) {
ghosts$x <- convertX(ghosts$x, 'mm', TRUE)
ghosts$y <- convertY(ghosts$y, 'mm', TRUE)
ghosts <- Map(
function(xmin, xmax, ymin, ymax) {
list(x = c(xmin, xmax, xmax, xmin), y = c(ymin, ymin, ymax, ymax))
},
xmin = ghosts$x - 2,
xmax = ghosts$x + 2,
ymin = ghosts$y - 2,
ymax = ghosts$y + 2
)
ghosts <- polyoffset(ghosts, 0)
polygons <- c(polygons, ghosts)
}
for (i in seq_along(rects)) {
if (all(rects[[i]] == 0)) next()
r <- rects[[i]] / 2 + 2
rect <- list(x = c(-r[1], r[1], r[1], -r[1]),
y = c(-r[2], -r[2], r[2], r[2]))
b <- polyminkowski(bbox, rect)
for (p in polygons) {
b <- polyclip(b, polyminkowski(p, rect)[1], 'union')
}
if (length(b) == 1) next()
b <- lapply(b[-1], function(p) cbind(p$x, p$y))
closest <- points_to_path(matrix(anchors[[i]], ncol = 2), b, TRUE)
res[[i]] <- closest$proj
rect$x <- rect$x + closest$proj[1]
rect$y <- rect$y + closest$proj[2]
polygons[[length(polygons) + 1]] <- polyoffset(rect, 10)
}
res
}
#' @importFrom polyclip polyoffset
#' @importFrom grid convertWidth convertHeight nullGrob polylineGrob
#' @importFrom stats runif
make_label <- function(labels, dims, polygons, ghosts, buffer, con_type,
con_border, con_cap, con_gp, anchor_mod, anchor_x,
anchor_y, arrow) {
polygons <- lapply(polygons, function(p) {
if (length(p$x) == 1 & length(p$y) == 1) {
list(
x = runif(200, p$x-0.00005, p$x+0.00005),
y = runif(200, p$y-0.00005, p$y+0.00005)
)
} else {
list(
x = p$x,
y = p$y
)
}
})
anchors <- lapply(seq_along(polygons), function(i) {
x <- mean(range(polygons[[i]]$x))
if (length(anchor_x) == length(polygons) && !is.na(anchor_x[i])) x <- anchor_x[i]
y <- mean(range(polygons[[i]]$y))
if (length(anchor_y) == length(polygons) && !is.na(anchor_y[i])) y <- anchor_y[i]
c(x, y)
})
p_big <- polyoffset(polygons, convertWidth(buffer, 'mm', TRUE))
area <- c(
convertWidth(unit(1, 'npc'), 'mm', TRUE),
convertHeight(unit(1, 'npc'), 'mm', TRUE)
)
labelpos <- place_labels(dims, p_big, area, anchors, ghosts)
if (all(lengths(labelpos) == 0)) {
return(list(nullGrob()))
}
labels <- Map(function(lab, pos) {
if (is.null(pos) || inherits(lab, 'null')) return(nullGrob())
lab$vp$x <- unit(pos[1], 'mm')
lab$vp$y <- unit(pos[2], 'mm')
lab
}, lab = labels, pos = labelpos)
connect <- inject(rbind(!!!Map(function(pol, pos, dim) {
if (is.null(pos)) return(NULL)
dim <- dim / anchor_mod
pos <- cbind(
c(pos[1] - dim[1], pos[1] + dim[1], pos[1] + dim[1], pos[1] - dim[1]),
c(pos[2] - dim[2], pos[2] - dim[2], pos[2] + dim[2], pos[2] + dim[2])
)
pos <- points_to_path(pos, list(cbind(pol$x, pol$y)), TRUE)
pos$projection[which.min(pos$distance), ]
}, pol = polygons, pos = labelpos, dim = dims)))
labeldims <- inject(rbind(!!!dims[lengths(labelpos) != 0])) / 2
labelpos <- inject(rbind(!!!labelpos))
if (con_type == 'none' || !con_type %in% c('elbow', 'straight')) {
connect <- nullGrob()
} else {
con_fun <- switch(con_type, elbow = elbow, straight = straight)
connect <- con_fun(
labelpos[, 1] - labeldims[, 1], labelpos[, 1] + labeldims[, 1],
labelpos[, 2] - labeldims[, 2], labelpos[, 2] + labeldims[, 2],
connect[, 1], connect[, 2]
)
if (con_border == 'one') {
connect <- with_borderline(
labelpos[, 1] - labeldims[, 1],
labelpos[, 1] + labeldims[, 1], connect
)
}
connect <- end_cap(connect, con_cap)
connect <- zip_points(connect)
if (!is.null(arrow)) arrow$ends <- 2L
connect <- polylineGrob(connect$x, connect$y,
id = connect$id,
default.units = 'mm', gp = con_gp, arrow = arrow
)
}
c(labels, list(connect))
}
#' @importFrom grid valid.just textGrob nullGrob viewport grobWidth grobHeight
#' rectGrob gpar grid.layout unit gTree gList grobDescent
labelboxGrob <- function(label, x = unit(0.5, 'npc'), y = unit(0.5, 'npc'),
description = NULL, width = NULL, min.width = 50,
default.units = 'mm', hjust = 0,
pad = margin(2, 2, 2, 2, 'mm'), gp = gpar(),
vp = NULL) {
gps <- split_label_gp(gp)
width <- as_mm(width, default.units)
min.width <- as_mm(min.width, default.units)
pad <- as_mm(pad, default.units)
pad[c(1, 3)] <- as_mm(pad[c(1, 3)], default.units, FALSE)
if (!is.null(label) && !is.na(label)) {
if (!is.null(width)) {
label <- wrap_text(label, gps$lab, width - pad[2] - pad[4])
}
just <- c(hjust[1], 0.5)
lab_grob <- textGrob(label, x = just[1], y = just[2], just = just,
gp = gps$lab)
} else {
lab_grob <- nullGrob()
}
if (!is.null(width)) {
final_width <- max(width, min.width) - pad[2] - pad[4]
} else {
if (as_mm(grobWidth(lab_grob)) > (min.width - pad[2] - pad[4])) {
final_width <- as_mm(grobWidth(lab_grob)) + pad[2] + pad[4]
} else {
final_width <- max(as_mm(grobWidth(lab_grob)), min.width) - pad[2] - pad[4]
}
}
if (!is.null(description) && !is.na(description)) {
description <- wrap_text(description, gps$desc, final_width)
just <- c(rep_len(hjust, 2)[2], 0.5)
desc_grob <- textGrob(description, x = just[1], y = just[2], just = just,
gp = gps$desc)
if (is.null(width)) {
final_width_desc <- min(final_width, as_mm(grobWidth(desc_grob)))
final_width <- as_mm(grobWidth(lab_grob))
if (final_width < final_width_desc) {
final_width <- final_width_desc
}
}
} else {
desc_grob <- nullGrob()
if (is.null(width)) final_width <- as_mm(grobWidth(lab_grob))
}
bg_grob <- rectGrob(gp = gps$rect)
lab_height <- as_mm(grobHeight(lab_grob), width = FALSE)
desc_height <- as_mm(grobHeight(desc_grob), width = FALSE)
sep_height <- if (lab_height > 0 && desc_height > 0) {
pad[1]
} else if (lab_height > 0) {
font_descent(gps$lab$fontfamily, gps$lab$fontface, gps$lab$fontsize, gps$lab$cex)
} else {
0
}
vp <- viewport(
x = x,
y = y,
width = unit(final_width + pad[2] + pad[4], 'mm'),
height = unit(pad[1] + pad[3] + lab_height + desc_height + sep_height,
'mm'),
layout = grid.layout(
5, 3,
widths = unit(c(pad[2], final_width, pad[4]), 'mm'),
heights = unit(c(pad[1], lab_height, sep_height, desc_height, pad[3]),
'mm')
)
)
lab_grob$vp <- viewport(layout.pos.col = 2, layout.pos.row = 2)
desc_grob$vp <- viewport(layout.pos.col = 2, layout.pos.row = 4)
gTree(children = gList(bg_grob, lab_grob, desc_grob), vp = vp,
cl = 'mark_label')
}
#' @export
#' @importFrom grid widthDetails
widthDetails.mark_label <- function(x) {
x$vp$width
}
#' @export
#' @importFrom grid heightDetails
heightDetails.mark_label <- function(x) {
x$vp$height
}
#' @importFrom grid textGrob grobWidth
wrap_text <- function(text, gp, width) {
text <- gsub('-', '- ', text)
text <- strsplit(text, split = ' ', fixed = TRUE)[[1]]
text <- paste0(text, ' ')
text <- sub('- ', '-', text)
txt <- ''
for (i in text) {
oldlab <- txt
txt <- paste0(txt, i)
tmpGrob <- textGrob(txt, gp = gp)
if (as_mm(grobWidth(tmpGrob)) > width) {
txt <- paste(trimws(oldlab), i, sep = '\n')
}
}
trimws(txt)
}
#' @importFrom grid unit is.unit convertWidth convertHeight
as_mm <- function(x, def, width = TRUE) {
if (is.null(x)) return(x)
if (!is.unit(x)) x <- unit(x, def)
if (width) {
convertWidth(x, 'mm', TRUE)
} else {
convertHeight(x, 'mm', TRUE)
}
}
#' @importFrom grid gpar
split_label_gp <- function(gp) {
rect_gp <- gpar(col = NA)
lab_gp <- gpar()
desc_gp <- gpar()
if (!is.null(gp$fill)) rect_gp$fill <- gp$fill
if (!is.null(gp$col)) {
col <- rep(gp$col, length.out = 2)
lab_gp$col <- col[1]
desc_gp$col <- col[2]
}
if (!is.null(gp$font)) {
font <- rep(gp$font, length.out = 2)
lab_gp$font <- font[1]
desc_gp$font <- font[2]
}
if (!is.null(gp$fontsize)) {
fontsize <- rep(gp$fontsize, length.out = 2)
lab_gp$fontsize <- fontsize[1]
desc_gp$fontsize <- fontsize[2]
}
if (!is.null(gp$fontfamily)) {
fontfamily <- rep(gp$fontfamily, length.out = 2)
lab_gp$fontfamily <- fontfamily[1]
desc_gp$fontfamily <- fontfamily[2]
}
if (!is.null(gp$fontface)) {
fontface <- rep(gp$fontface, length.out = 2)
lab_gp$fontface <- fontface[1]
desc_gp$fontface <- fontface[2]
}
if (!is.null(gp$lineheight)) {
lineheight <- rep(gp$lineheight, length.out = 2)
lab_gp$lineheight <- lineheight[1]
desc_gp$lineheight <- lineheight[2]
}
if (!is.null(gp$cex)) {
cex <- rep(gp$cex, length.out = 2)
lab_gp$cex <- cex[1]
desc_gp$cex <- cex[2]
}
list(rect = rect_gp, lab = lab_gp, desc = desc_gp)
}
straight <- function(xmin, xmax, ymin, ymax, x, y) {
conn_point <- get_end_points(xmin, xmax, ymin, ymax, x, y)
list(
as.matrix(conn_point),
cbind(x = x, y = y)
)
}
elbow <- function(xmin, xmax, ymin, ymax, x, y) {
lines <- straight(xmin, xmax, ymin, ymax, x, y)
end_pos <- lines[[1]] - lines[[2]]
end_angle <- atan2(end_pos[, 2], end_pos[, 1]) %% (2 * pi)
angle_bin <- end_angle %/% (pi / 4)
angle_lower <- end_angle %% (pi / 4) < 0.5
elbow <- lapply(seq_along(angle_bin), function(i) {
a_bin <- angle_bin[i]
a_lower <- angle_lower[i]
if (a_bin == 0 || a_bin == 4) {
if (a_lower) {
c(end_pos[i, 1] - end_pos[i, 2], 0)
} else {
c(end_pos[i, 2], end_pos[i, 2])
}
} else if (a_bin == 1 || a_bin == 5) {
if (a_lower) {
c(end_pos[i, 1], end_pos[i, 1])
} else {
c(0, end_pos[i, 2] - end_pos[i, 1])
}
} else if (a_bin == 2 || a_bin == 6) {
if (a_lower) {
c(0, end_pos[i, 2] + end_pos[i, 1])
} else {
c(end_pos[i, 1], -end_pos[i, 1])
}
} else if (a_bin == 3 || a_bin == 7) {
if (a_lower) {
c(-end_pos[i, 2], end_pos[i, 2])
} else {
c(end_pos[i, 1] + end_pos[i, 2], 0)
}
}
})
elbow <- inject(rbind(!!!elbow))
elbow <- elbow + lines[[2]]
colnames(elbow) <- c('x', 'y')
list(lines[[1]], elbow, lines[[2]])
}
with_borderline <- function(xmin, xmax, lines) {
new_start <- lines[[1]]
new_start[, 1] <- ifelse(new_start[, 1] == xmin, xmax, xmin)
c(list(new_start), lines)
}
end_cap <- function(lines, cap) {
from <- lines[[length(lines) - 1]]
to <- lines[[length(lines)]]
d <- to - from
l <- sqrt(rowSums((d)^2))
to <- from + d * (l - cap) / l
lines[[length(lines)]] <- to
lines
}
zip_points <- function(points) {
n_lines <- nrow(points[[1]])
n_joints <- length(points)
points <- as.data.frame(inject(rbind(!!!points)))
points$id <- rep(seq_len(n_lines), n_joints)
points[order(points$id), ]
}
get_end_points <- function(xmin, xmax, ymin, ymax, x, y) {
xmin_tmp <- xmin - x
xmax_tmp <- xmax - x
ymin_tmp <- ymin - y
ymax_tmp <- ymax - y
pos <- ifelse(
xmin_tmp < 0,
ifelse(ymin_tmp < 0, 'bottomleft', 'topleft'),
ifelse(ymin_tmp < 0, 'bottomright', 'topright')
)
pos <- ifelse(
ymin_tmp < 0 & ymax_tmp > 0,
ifelse(xmin_tmp < 0, 'left', 'right'),
ifelse(
xmin_tmp < 0 & xmax_tmp > 0,
ifelse(ymin_tmp < 0, 'bottom', 'top'),
pos
)
)
x_new <- vswitch(
pos,
left = xmax,
bottomleft = xmax,
topleft = xmax,
right = xmin,
bottomright = xmin,
topright = xmin,
top = ifelse(abs(xmin_tmp) < abs(xmax_tmp), xmin, xmax),
bottom = ifelse(abs(xmin_tmp) < abs(xmax_tmp), xmin, xmax)
)
y_new <- vswitch(
pos,
bottom = ymax,
bottomleft = ymax,
bottomright = ymax,
top = ymin,
topleft = ymin,
topright = ymin,
left = ifelse(abs(ymin_tmp) < abs(ymax_tmp), ymin, ymax),
right = ifelse(abs(ymin_tmp) < abs(ymax_tmp), ymin, ymax)
)
data_frame0(x = x_new, y = y_new)
}
vswitch <- function(x, ...) {
cases <- cbind(...)
cases[cbind(seq_along(x), match(x, colnames(cases)))]
}
font_descent <- function(fontfamily, fontface, fontsize, cex) {
italic <- fontface >= 3
bold <- fontface == 2 | fontface == 4
info <- systemfonts::font_info(fontfamily, italic, bold, fontsize * (cex %||% 1), res = 300)
as_mm(abs(info$max_descend)*72/300, 'pt', FALSE)
}
ggforce/R/voronoi.R 0000644 0001762 0000144 00000060662 14564603246 013731 0 ustar ligges users #' @include shape.R
NULL
#' Voronoi tesselation and delaunay triangulation
#'
#' This set of geoms and stats allows you to display voronoi tesselation and
#' delaunay triangulation, both as polygons and as line segments. Furthermore
#' it lets you augment your point data with related summary statistics. The
#' computations are based on the [deldir::deldir()] package.
#'
#' @section Aesthetics:
#' geom_voronoi_tile and geom_delaunay_tile understand the following aesthetics
#' (required aesthetics are in bold):
#'
#' - **x**
#' - **y**
#' - alpha
#' - color
#' - fill
#' - linetype
#' - size
#'
#' geom_voronoi_segment, geom_delaunay_segment, and geom_delaunay_segment2
#' understand the following aesthetics (required aesthetics are in bold):
#'
#' - **x**
#' - **y**
#' - alpha
#' - color
#' - linetype
#' - size
#'
#' @section Computed variables:
#' stat_delvor_summary computes the following variables:
#' \describe{
#' \item{x, y}{If `switch.centroid = TRUE` this will be the coordinates for
#' the voronoi tile centroid, otherwise it is the original point}
#' \item{xcent, ycent}{If `switch.centroid = FALSE` this will be the
#' coordinates for the voronoi tile centroid, otherwise it will be `NULL`}
#' \item{xorig, yorig}{If `switch.centroid = TRUE` this will be the
#' coordinates for the original point, otherwise it will be `NULL`}
#' \item{ntri}{Number of triangles emanating from the point}
#' \item{triarea}{The total area of triangles emanating from the point divided
#' by 3}
#' \item{triprop}{`triarea` divided by the sum of the area of all
#' triangles}
#' \item{nsides}{Number of sides on the voronoi tile associated with the point}
#' \item{nedges}{Number of sides of the associated voronoi tile that is part of
#' the bounding box}
#' \item{vorarea}{The area of the voronoi tile associated with the point}
#' \item{vorprop}{`vorarea` divided by the sum of all voronoi tiles}
#' }
#'
#' @inheritParams ggplot2::geom_polygon
#' @inheritParams ggplot2::geom_segment
#' @inheritParams ggplot2::stat_identity
#' @inheritParams geom_link
#'
#' @param bound The bounding rectangle for the tesselation or a custom polygon
#' to clip the tesselation to. Defaults to `NULL` which creates a rectangle
#' expanded 10\% in all directions. If supplied as a bounding box it should be a
#' vector giving the bounds in the following order: xmin, xmax, ymin, ymax. If
#' supplied as a polygon it should either be a 2-column matrix or a data.frame
#' containing an `x` and `y` column.
#'
#' @param eps A value of epsilon used in testing whether a quantity is zero,
#' mainly in the context of whether points are collinear. If anomalous errors
#' arise, it is possible that these may averted by adjusting the value of eps
#' upward or downward.
#'
#' @param max.radius The maximum distance a tile can extend from the point of
#' origin. Will in effect clip each tile to a circle centered at the point with
#' the given radius. If `normalize = TRUE` the radius will be given relative to
#' the normalized values
#'
#' @param normalize Should coordinates be normalized prior to calculations. If
#' `x` and `y` are in wildly different ranges it can lead to
#' tesselation and triangulation that seems off when plotted without
#' [ggplot2::coord_fixed()]. Normalization of coordinates solves this.
#' The coordinates are transformed back after calculations.
#'
#' @param asp.ratio If `normalize = TRUE` the x values will be multiplied by this
#' amount after normalization.
#'
#' @name geom_voronoi
#' @aliases geom_delaunay
#' @rdname geom_delvor
#'
#' @examples
#' # Voronoi
#' # You usually wants all points to take part in the same tesselation so set
#' # the group aesthetic to a constant (-1L is just a convention)
#' ggplot(iris, aes(Sepal.Length, Sepal.Width, group = -1L)) +
#' geom_voronoi_tile(aes(fill = Species)) +
#' geom_voronoi_segment() +
#' geom_text(aes(label = after_stat(nsides), size = after_stat(vorarea)),
#' stat = 'delvor_summary', switch.centroid = TRUE
#' )
#'
#' # Difference of normalize = TRUE (segment layer is calculated without
#' # normalisation)
#' ggplot(iris, aes(Sepal.Length, Sepal.Width, group = -1L)) +
#' geom_voronoi_tile(aes(fill = Species), normalize = TRUE) +
#' geom_voronoi_segment()
#'
#' # Set a max radius
#' ggplot(iris, aes(Sepal.Length, Sepal.Width, group = -1L)) +
#' geom_voronoi_tile(aes(fill = Species), colour = 'black', max.radius = 0.25)
#'
#' # Set custom bounding polygon
#' triangle <- cbind(c(3, 9, 6), c(1, 1, 6))
#' ggplot(iris, aes(Sepal.Length, Sepal.Width, group = -1L)) +
#' geom_voronoi_tile(aes(fill = Species), colour = 'black', bound = triangle)
#'
#' # Use geom_shape functionality to round corners etc
#' ggplot(iris, aes(Sepal.Length, Sepal.Width, group = -1L)) +
#' geom_voronoi_tile(aes(fill = Species), colour = 'black',
#' expand = unit(-.5, 'mm'), radius = unit(2, 'mm'))
#'
#' # Delaunay triangles
#' ggplot(iris, aes(Sepal.Length, Sepal.Width)) +
#' geom_delaunay_tile(alpha = 0.3, colour = 'black')
#'
#' # Use geom_delauney_segment2 to interpolate aestetics between end points
#' ggplot(iris, aes(Sepal.Length, Sepal.Width)) +
#' geom_delaunay_segment2(aes(colour = Species, group = -1), size = 2,
#' lineend = 'round')
NULL
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @importFrom scales rescale
#' @export
StatVoronoiTile <- ggproto('StatVoronoiTile', Stat,
setup_params = function(self, data, params) {
check_installed('deldir', 'to calculate voronoi tesselation')
params
},
compute_group = function(self, data, scales, bound = NULL, eps = 1e-9,
max.radius = NULL, normalize = FALSE, asp.ratio = 1) {
data$group <- paste0(seq_len(nrow(data)), ':', data$group)
if (any(duplicated(data[, c('x', 'y')]))) {
cli::cli_warn('{.fn {snake_class(self)}} is dropping duplicated points')
}
polybound <- NULL
if (is.null(bound)) {
if (!is.null(max.radius)) {
bound <- c(range(data$x), range(data$y))
bound[c(1, 3)] <- bound[c(1, 3)] - max.radius * 1.5
bound[c(2, 4)] <- bound[c(2, 4)] + max.radius * 1.5
}
} else if (is.matrix(bound) || is.data.frame(bound)) {
if (is.matrix(bound) && is.null(colnames(bound))) {
colnames(bound) <- c('x', 'y')
}
polybound <- as.data.frame(bound)
bound <- c(range(polybound$x), range(polybound$y))
}
if (normalize) {
x_range <- range(data$x, na.rm = TRUE, finite = TRUE)
y_range <- range(data$y, na.rm = TRUE, finite = TRUE)
data$x <- rescale(data$x, from = x_range) * asp.ratio
data$y <- rescale(data$y, from = y_range)
if (!is.null(bound)) {
bound[1:2] <- rescale(bound[1:2], from = x_range) * asp.ratio
bound[3:4] <- rescale(bound[3:4], from = y_range)
}
if (!is.null(polybound)) {
polybound$x <- rescale(polybound$x, from = x_range) * asp.ratio
polybound$y <- rescale(polybound$y, from = y_range)
}
}
vor <- deldir::deldir(data$x, data$y, rw = bound, eps = eps,
suppressMsge = TRUE)
tiles <- to_tile(vor)
tiles$orig_x <- data$x[vor$ind.orig[tiles$group]]
tiles$orig_y <- data$y[vor$ind.orig[tiles$group]]
tiles$group <- data$group[vor$ind.orig[tiles$group]]
tiles <- clip_tiles(tiles, max.radius, polybound)
data$x <- NULL
data$y <- NULL
data <- merge(tiles, data, sort = FALSE, all.x = TRUE)
if (normalize) {
data$x <- rescale(data$x / asp.ratio, to = x_range, from = c(0, 1))
data$y <- rescale(data$y, to = y_range, from = c(0, 1))
}
data
},
required_aes = c('x', 'y')
)
#' @rdname geom_delvor
#' @inheritParams geom_shape
#' @export
geom_voronoi_tile <- function(mapping = NULL, data = NULL, stat = 'voronoi_tile',
position = 'identity', na.rm = FALSE, bound = NULL,
eps = 1e-9, max.radius = NULL, normalize = FALSE,
asp.ratio = 1, expand = 0, radius = 0,
show.legend = NA, inherit.aes = TRUE, ...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomShape,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(bound = bound, eps = eps, max.radius = max.radius,
normalize = normalize, asp.ratio = asp.ratio, na.rm = na.rm,
expand = expand, radius = radius, ...)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @importFrom scales rescale
#' @export
StatVoronoiSegment <- ggproto('StatVoronoiSegment', Stat,
setup_params = function(self, data, params) {
check_installed('deldir', 'to calculate voronoi tesselation')
params
},
compute_group = function(self, data, scales, bound = NULL, eps = 1e-9,
normalize = FALSE, asp.ratio = 1) {
if (any(duplicated(data[, c('x', 'y')]))) {
cli::cli_warn('{.fn {snake_class(self)}} is dropping duplicated points')
}
if (normalize) {
x_range <- range(data$x, na.rm = TRUE, finite = TRUE)
y_range <- range(data$y, na.rm = TRUE, finite = TRUE)
data$x <- rescale(data$x, from = x_range) * asp.ratio
data$y <- rescale(data$y, from = y_range)
if (!is.null(bound)) {
bound[1:2] <- rescale(bound[1:2], from = x_range) * asp.ratio
bound[3:4] <- rescale(bound[3:4], from = x_range)
}
}
vor <- deldir::deldir(data$x, data$y, rw = bound, eps = eps,
suppressMsge = TRUE)
segments <- vor$dirsgs[, 1:5]
names(segments) <- c('x', 'y', 'xend', 'yend', 'group')
segments$group <- vor$ind.orig[segments$group]
data <- cbind(
segments[, 1:4],
data[segments$group, !names(data) %in% c('x', 'y'), drop = FALSE]
)
if (normalize) {
data$x <- rescale(data$x / asp.ratio, to = x_range, from = c(0, 1))
data$xend <- rescale(data$xend / asp.ratio, to = x_range, from = c(0, 1))
data$y <- rescale(data$y, to = y_range, from = c(0, 1))
data$yend <- rescale(data$yend, to = y_range, from = c(0, 1))
}
data
},
required_aes = c('x', 'y')
)
#' @rdname geom_delvor
#' @export
geom_voronoi_segment <- function(mapping = NULL, data = NULL,
stat = 'voronoi_segment', position = 'identity',
na.rm = FALSE, bound = NULL, eps = 1e-9,
normalize = FALSE, asp.ratio = 1,
show.legend = NA, inherit.aes = TRUE, ...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomSegment,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(bound = bound, eps = eps, normalize = normalize,
asp.ratio = asp.ratio, na.rm = na.rm, ...)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @importFrom scales rescale
#' @export
StatDelaunayTile <- ggproto('StatDelaunayTile', Stat,
setup_params = function(self, data, params) {
check_installed('deldir', 'to calculate delaunay triangulation')
params
},
compute_group = function(self, data, scales, bound = NULL, eps = 1e-9,
normalize = FALSE, asp.ratio = 1) {
if (normalize) {
x_range <- range(data$x, na.rm = TRUE, finite = TRUE)
y_range <- range(data$y, na.rm = TRUE, finite = TRUE)
data$x <- rescale(data$x, from = x_range) * asp.ratio
data$y <- rescale(data$y, from = y_range)
if (!is.null(bound)) {
bound[1:2] <- rescale(bound[1:2], from = x_range) * asp.ratio
bound[3:4] <- rescale(bound[3:4], from = x_range)
}
}
data <- lapply(split(data, data$group), function(d) {
if (any(duplicated(d[, c('x', 'y')]))) {
cli::cli_warn('{.fn {snake_class(self)}} is dropping duplicated points')
}
vor <- deldir::deldir(d$x, d$y, rw = bound, eps = eps,
suppressMsge = TRUE)
d <- to_triangle(vor)
d$group <- paste(data$group[1], '_', match(d$group, unique0(d$group)))
d
})
for (i in seq_len(length(data) - 1) + 1) {
max_group <- max(data[[i - 1]]$group)
data[[i]]$group <- data[[i]]$group + max_group
}
data <- vec_rbind(!!!data)
if (normalize) {
data$x <- rescale(data$x / asp.ratio, to = x_range, from = c(0, 1))
data$y <- rescale(data$y, to = y_range, from = c(0, 1))
}
data
},
required_aes = c('x', 'y')
)
#' @rdname geom_delvor
#' @inheritParams geom_shape
#' @export
geom_delaunay_tile <- function(mapping = NULL, data = NULL,
stat = 'delaunay_tile', position = 'identity',
na.rm = FALSE, bound = NULL, eps = 1e-9,
normalize = FALSE, asp.ratio = 1, expand = 0,
radius = 0, show.legend = NA, inherit.aes = TRUE,
...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomShape,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(bound = bound, eps = eps, normalize = normalize,
asp.ratio = asp.ratio, expand = expand, radius = radius,
na.rm = na.rm, ...)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @importFrom scales rescale
#' @export
StatDelaunaySegment <- ggproto('StatDelaunaySegment', Stat,
setup_params = function(self, data, params) {
check_installed('deldir', 'to calculate delaunay triangulation')
params
},
compute_group = function(self, data, scales, bound = NULL, eps = 1e-9,
normalize = FALSE, asp.ratio = 1) {
if (any(duplicated(data[, c('x', 'y')]))) {
cli::cli_warn('{.fn {snake_class(self)}} is dropping duplicated points')
}
if (normalize) {
x_range <- range(data$x, na.rm = TRUE, finite = TRUE)
y_range <- range(data$y, na.rm = TRUE, finite = TRUE)
data$x <- rescale(data$x, from = x_range) * asp.ratio
data$y <- rescale(data$y, from = y_range)
if (!is.null(bound)) {
bound[1:2] <- rescale(bound[1:2], from = x_range) * asp.ratio
bound[3:4] <- rescale(bound[3:4], from = x_range)
}
}
vor <- deldir::deldir(data$x, data$y, rw = bound, eps = eps,
suppressMsge = TRUE)
segments <- vor$delsgs[, 1:5]
names(segments) <- c('x', 'y', 'xend', 'yend', 'group')
segments$group <- vor$ind.orig[segments$group]
data <- cbind(
segments[, 1:4],
data[segments$group, !names(data) %in% c('x', 'y'), drop = FALSE]
)
if (normalize) {
data$x <- rescale(data$x / asp.ratio, to = x_range, from = c(0, 1))
data$xend <- rescale(data$xend / asp.ratio, to = x_range, from = c(0, 1))
data$y <- rescale(data$y, to = y_range, from = c(0, 1))
data$yend <- rescale(data$yend, to = y_range, from = c(0, 1))
}
data
},
required_aes = c('x', 'y')
)
#' @rdname geom_delvor
#' @export
geom_delaunay_segment <- function(mapping = NULL, data = NULL,
stat = 'delaunay_segment',
position = 'identity', na.rm = FALSE,
bound = NULL, eps = 1e-9, normalize = FALSE,
asp.ratio = 1, show.legend = NA,
inherit.aes = TRUE, ...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomSegment,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(bound = bound, eps = eps, normalize = normalize, na.rm = na.rm,
asp.ratio = asp.ratio, ...)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @importFrom scales rescale
#' @export
StatDelaunaySegment2 <- ggproto('StatDelaunaySegment2', Stat,
setup_params = function(self, data, params) {
check_installed('deldir', 'to calculate delaunay triangulation')
params
},
compute_group = function(self, data, scales, bound = NULL, eps = 1e-9, n = 100,
normalize = FALSE, asp.ratio = 1) {
if (any(duplicated(data[, c('x', 'y')]))) {
cli::cli_warn('{.fn {snake_class(self)}} is dropping duplicated points')
}
if (normalize) {
x_range <- range(data$x, na.rm = TRUE, finite = TRUE)
y_range <- range(data$y, na.rm = TRUE, finite = TRUE)
data$x <- rescale(data$x, from = x_range) * asp.ratio
data$y <- rescale(data$y, from = y_range)
if (!is.null(bound)) {
bound[1:2] <- rescale(bound[1:2], from = x_range) * asp.ratio
bound[3:4] <- rescale(bound[3:4], from = x_range)
}
}
vor <- deldir::deldir(data$x, data$y, rw = bound, eps = eps,
suppressMsge = TRUE)
segments <- vec_rbind(
structure(vor$delsgs[, c(1:2, 5)], names = c('x', 'y', 'group')),
structure(vor$delsgs[, c(3:4, 6)], names = c('x', 'y', 'group'))
)
segments$group <- vor$ind.orig[segments$group]
segments <- cbind(
segments[, 1:2],
data[segments$group, !names(data) %in% c('x', 'y'), drop = FALSE]
)
segments$group <- rep(seq_len(nrow(vor$delsgs)), 2)
segments <- segments[order(segments$group), ]
if (normalize) {
segments$x <- rescale(segments$x / asp.ratio, to = x_range, from = c(0, 1))
segments$y <- rescale(segments$y, to = y_range, from = c(0, 1))
}
StatLink2$compute_panel(segments, scales, n)
},
required_aes = c('x', 'y')
)
#' @rdname geom_delvor
#' @export
geom_delaunay_segment2 <- function(mapping = NULL, data = NULL,
stat = 'delaunay_segment2',
position = 'identity', na.rm = FALSE,
bound = NULL, eps = 1e-9, normalize = FALSE,
asp.ratio = 1, n = 100, show.legend = NA,
inherit.aes = TRUE, ...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomPathInterpolate,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(bound = bound, eps = eps, normalize = normalize,
asp.ratio = asp.ratio, n = n, na.rm = na.rm, ...)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @importFrom scales rescale
#' @export
StatDelvorSummary <- ggproto('StatDelvorSummary', Stat,
setup_params = function(self, data, params) {
check_installed('deldir', 'to calculate delaunay triangulation')
params
},
compute_group = function(self, data, scales, bound = NULL, eps = 1e-9,
switch.centroid = FALSE, normalize = FALSE,
asp.ratio = 1) {
if (any(duplicated(data[, c('x', 'y')]))) {
cli::cli_warn('{.fn {snake_class(self)}} is dropping duplicated points')
}
if (normalize) {
x_range <- range(data$x, na.rm = TRUE, finite = TRUE)
y_range <- range(data$y, na.rm = TRUE, finite = TRUE)
data$x <- rescale(data$x, from = x_range) * asp.ratio
data$y <- rescale(data$y, from = y_range)
if (!is.null(bound)) {
bound[1:2] <- rescale(bound[1:2], from = x_range) * asp.ratio
bound[3:4] <- rescale(bound[3:4], from = x_range)
}
}
vor <- deldir::deldir(data$x, data$y, rw = bound, eps = eps,
suppressMsge = TRUE)
names(vor$summary) <- c('x', 'y', 'ntri', 'triarea', 'triprop', 'nsides',
'nedges', 'vorarea', 'vorprop')
tiles <- to_tile(vor)
vor$summary$xcent <- sapply(split(tiles$x, tiles$group), mean)
vor$summary$ycent <- sapply(split(tiles$y, tiles$group), mean)
data <- cbind(
data[vor$ind.orig, , drop = FALSE],
vor$summary[, !names(vor$summary) %in% c('x', 'y'), drop = FALSE]
)
if (normalize) {
data$x <- rescale(data$x / asp.ratio, to = x_range, from = c(0, 1))
data$xcent <- rescale(data$xcent / asp.ratio, to = x_range, from = c(0, 1))
data$y <- rescale(data$y, to = y_range, from = c(0, 1))
data$ycent <- rescale(data$ycent, to = y_range, from = c(0, 1))
}
if (switch.centroid) {
name_ind <- match(c('xcent', 'ycent', 'x', 'y'), names(data))
names(data)[name_ind] <- c('x', 'y', 'xorig', 'yorig')
}
data
},
required_aes = c('x', 'y')
)
#' @rdname geom_delvor
#' @export
stat_delvor_summary <- function(mapping = NULL, data = NULL, geom = 'point',
position = 'identity', na.rm = FALSE,
bound = NULL, eps = 1e-9, normalize = FALSE,
asp.ratio = 1, show.legend = NA,
inherit.aes = TRUE, ...) {
layer(
data = data, mapping = mapping, stat = StatDelvorSummary, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(bound = bound, eps = eps, normalize = normalize, na.rm = na.rm,
asp.ratio = asp.ratio, ...)
)
}
# HELPERS -----------------------------------------------------------------
to_tile <- function(object) {
check_installed('deldir', 'to calculate voronoi tesselation')
tiles <- vec_rbind(
structure(object$dirsgs[, c(1:2, 5)], names = c('x', 'y', 'group')),
structure(object$dirsgs[, c(1:2, 6)], names = c('x', 'y', 'group')),
structure(object$dirsgs[, c(3:5)], names = c('x', 'y', 'group')),
structure(object$dirsgs[, c(3:4, 6)], names = c('x', 'y', 'group'))
)
tiles <- unique0(tiles)
tiles <- vec_rbind(
tiles,
data_frame0(
x = object$rw[c(1, 2, 2, 1)],
y = object$rw[c(3, 3, 4, 4)],
group = deldir::get.cnrind(
object$summary$x,
object$summary$y,
object$rw
)
)
)
tiles$theta <- atan2(
tiles$y - object$summary$y[tiles$group],
tiles$x - object$summary$x[tiles$group]
)
tiles$theta <- ifelse(tiles$theta > 0, tiles$theta, tiles$theta + 2 * pi)
tiles[order(tiles$group, tiles$theta), ]
}
to_triangle <- function(object) {
tiles <- vec_rbind(
structure(object$dirsgs[, c(1:2, 5)], names = c('x', 'y', 'point')),
structure(object$dirsgs[, c(3:4, 6)], names = c('x', 'y', 'point'))
)
tiles$group <- as.integer(
factor(paste0(signif(tiles$x, 5), '_', signif(tiles$y, 5)))
)
# tiles <- tiles[tiles$tri %in% unique(tiles$tri[duplicated(tiles$tri)]),]
unconform <- table(tiles$group)
unconform <- as.integer(names(unconform[unconform != 3]))
unconform_point <- tiles$point[tiles$group %in% unconform]
tiles <- tiles[!tiles$group %in% unconform, , drop = FALSE]
unconform_seg <- object$delsgs$ind1 %in% unconform_point &
object$delsgs$ind2 %in% unconform_point
object$delsgs <- object$delsgs[unconform_seg, , drop = FALSE]
last_points <- tri_mat(object)
last_points <- data_frame0(
point = as.vector(last_points),
group = rep(seq(max(tiles$group) + 1, length.out = ncol(last_points)),
each = 3)
)
triangles <- vec_rbind(tiles[, c('point', 'group'), drop = FALSE], last_points)
triangles$x <- object$summary$x[triangles$point]
triangles$y <- object$summary$y[triangles$point]
triangles <- triangles[order(triangles$group, triangles$point), ]
triangles$group <- match(triangles$group, unique0(triangles$group))
dup_tri <- which(duplicated(matrix(triangles$point, ncol = 3, byrow = TRUE)))
triangles <- triangles[!triangles$group %in% dup_tri, , drop = FALSE]
triangles
}
tri_mat <- function(object) {
a <- object$delsgs[, 5]
b <- object$delsgs[, 6]
tlist <- matrix(integer(0), 3, 0)
for (i in union(a, b)) {
jj <- c(b[a == i], a[b == i])
jj <- sort(unique0(jj))
jj <- jj[jj > i]
if (length(jj) > 0) {
for (j in jj) {
kk <- c(b[a == j], a[b == j])
kk <- kk[(kk %in% jj) & (kk > j)]
if (length(kk) > 0) {
for (k in kk) tlist <- cbind(tlist, c(
i, j,
k
))
}
}
}
}
tlist
}
#' @importFrom polyclip polyclip
clip_tiles <- function(tiles, radius, bound) {
if (is.null(radius) && is.null(bound)) return(tiles)
p <- seq(0, 2 * pi, length.out = 361)[-361]
circ <- list(
x = cos(p) * radius,
y = sin(p) * radius
)
dapply(tiles, 'group', function(tile) {
final_tile <- list(x = tile$x, y = tile$y)
if (!is.null(radius)) {
circ_temp <- list(x = circ$x + tile$orig_x[1],
y = circ$y + tile$orig_y[1])
final_tile <- polyclip(final_tile, circ_temp, 'intersection')
}
if (!is.null(bound)) {
final_tile <- polyclip(final_tile, bound, 'intersection')
}
if (length(final_tile) == 0) return(NULL)
data_frame0(
x = final_tile[[1]]$x,
y = final_tile[[1]]$y,
group = tile$group[1]
)
})
}
ggforce/R/autohistogram.R 0000644 0001762 0000144 00000011202 14564603246 015106 0 ustar ligges users #' A distribution geoms that fills the panel and works with discrete and continuous data
#'
#' These versions of the histogram and density geoms have been designed
#' specifically for diagonal plotting with [facet_matrix()]. They differ from
#' [ggplot2::geom_histogram()] and [ggplot2::geom_density()] in that they
#' defaults to mapping `x` and `y` to `.panel_x` and `.panel_y` respectively,
#' they ignore the y scale of the panel and fills it out, and they work for both
#' continuous and discrete x scales.
#'
#' @inheritParams ggplot2::geom_histogram
#'
#' @seealso [facet_matrix] for creating matrix grids
#'
#' @export
#'
#' @examples
#' # A matrix plot with a mix of discrete and continuous variables
#' p <- ggplot(mpg) +
#' geom_autopoint() +
#' facet_matrix(vars(drv:fl), layer.diag = 2, grid.y.diag = FALSE)
#' p
#'
#' # Diagonal histograms
#' p + geom_autohistogram()
#'
#' # Diagonal density distributions
#' p + geom_autodensity()
#'
#' # You can use them like regular layers with groupings etc
#' p + geom_autodensity(aes(colour = drv, fill = drv),
#' alpha = 0.4)
geom_autohistogram <- function(mapping = NULL, data = NULL,
stat = "autobin", position = "floatstack",
...,
bins = NULL,
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE) {
extra_mapping <- aes(x = .panel_x, y = .panel_y)
if (is.null(mapping$x)) mapping$x <- extra_mapping$x
if (is.null(mapping$y)) mapping$y <- extra_mapping$y
class(mapping) <- 'uneval'
layer(
data = data,
mapping = mapping,
stat = stat,
geom = GeomAutorect,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
bins = bins,
na.rm = na.rm,
...
)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatAutobin <- ggproto('StatAutobin', StatBin,
setup_params = function(data, params) {
if (is.null(params$bins)) params$bins <- 30
params$panel_range <- lapply(split(data$y, data$PANEL), function(y) {
if (length(y) == 0) return()
range(y, na.rm=TRUE)
})
params$panel_count <- lapply(split(data$y, data$PANEL), function(y)length(y[is.finite(y)]))
params
},
compute_group = function(self, data, scales, binwidth = NULL, bins = NULL,
center = NULL, boundary = NULL,
closed = c("right", "left"), pad = FALSE,
breaks = NULL, panel_range = list(), panel_count = list(),
# The following arguments are not used, but must
# be listed so parameters are computed correctly
origin = NULL, right = NULL, drop = NULL,
width = NULL) {
if (scales$x$is_discrete()) {
binned <- lapply(split(data, data$x), function(d) {
data_frame0(
count = nrow(d),
x = d$x[1],
xmin = d$x[1] - 0.5,
xmax = d$x[1] + 0.5,
width = 1
)
})
binned <- vec_rbind(!!!binned)
binned$density <- binned$count / sum(binned$count)
binned$ncount <- binned$count / max(binned$count)
binned$ndensity <- binned$density / max(binned$density)
} else {
binned <- ggproto_parent(StatBin, self)$compute_group(
data, scales, binwidth = binwidth, bins = bins, center = center,
boundary = boundary, closed = closed, pad = pad, breaks = breaks,
origin = origin, right = right, drop = drop, width = width
)
}
panel_range <- panel_range[[data$PANEL[1]]]
panel_count <- panel_count[[data$PANEL[1]]]
binned$ymin <- panel_range[1]
binned$ymax <- binned$ymin + binned$ncount * (panel_range[2] - panel_range[1]) * nrow(data) / panel_count
binned$y <- (binned$ymin + binned$ymax) / 2
binned
},
default_aes = aes(weight = 1),
required_aes = c("x", "y")
)
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
GeomAutorect <- ggproto('PositionAutorect', GeomRect,
draw_panel = function(self, data, panel_params, coord, ...) {
y_range <- coord$range(panel_params)$y
y_span <- y_range[2] - y_range[1]
panel_min <- min(data$ymin)
panel_span <- max(data$ymax) - panel_min
data$ymin <- ((data$ymin - panel_min) / panel_span) * y_span * 0.9 + y_range[1]
data$ymax <- ((data$ymax - panel_min) / panel_span) * y_span * 0.9 + y_range[1]
ggproto_parent(GeomRect, self)$draw_panel(data, panel_params, coord, ...)
},
extra_params = c('na.rm', 'lineend', 'linejoin')
)
ggforce/R/aaa.R 0000644 0001762 0000144 00000001124 14564603246 012744 0 ustar ligges users utils::globalVariables(c(
'x', 'y'
))
`%||%` <- function(x, y) {
if (is.null(x)) y else x
}
is.waive <- function(x) inherits(x, 'waiver')
`%|W|%` <- function(x, y) {
if (is.waive(x)) y else x
}
expand_default <- function(scale, discrete = c(0, 0.6),
continuous = c(0.05, 0)) {
scale$expand %|W|% if (scale$is_discrete()) discrete else continuous
}
combine_aes <- function(aes1, aes2) {
aes_all <- c(aes1[setdiff(names(aes1), names(aes2))], aes2)
class(aes_all) <- class(aes1)
aes_all
}
empty_data <- function(x) {
length(x) == 0 || nrow(x) == 0
}
ggforce/R/bspline_closed.R 0000644 0001762 0000144 00000010334 14564603246 015212 0 ustar ligges users #' Create closed b-spline shapes
#'
#' This geom creates closed b-spline curves and draws them as shapes. The
#' closed b-spline is achieved by wrapping the control points rather than the
#' knots. The *0 version uses the [grid::xsplineGrob()] function with
#' `open = FALSE` and can thus not be manipulated as a shape geom in the same
#' way as the base version (expand, contract, etc).
#'
#' @section Aesthetics:
#' geom_bspline_closed understand the following aesthetics (required aesthetics
#' are in bold):
#'
#' - **x**
#' - **y**
#' - color
#' - fill
#' - linewidth
#' - linetype
#' - alpha
#'
#' @section Computed variables:
#'
#' \describe{
#' \item{x, y}{The coordinates for the path describing the spline}
#' \item{index}{The progression along the interpolation mapped between 0 and 1}
#' }
#'
#' @inheritParams ggplot2::geom_polygon
#' @inheritParams ggplot2::stat_identity
#'
#' @param n The number of points generated for each spline
#'
#' @author Thomas Lin Pedersen. The C++ code for De Boor's algorithm has been
#' adapted from
#' \href{https://chi3x10.wordpress.com/2009/10/18/de-boor-algorithm-in-c/}{Jason Yu-Tseh Chi implementation}
#'
#' @name geom_bspline_closed
#' @rdname geom_bspline_closed
#'
#' @examples
#' # Create 6 random control points
#' controls <- data.frame(
#' x = runif(6),
#' y = runif(6)
#' )
#'
#' ggplot(controls, aes(x, y)) +
#' geom_polygon(fill = NA, colour = 'grey') +
#' geom_point(colour = 'red') +
#' geom_bspline_closed(alpha = 0.5)
#'
#' # The 0 version approximates the correct shape
#' ggplot(controls, aes(x, y)) +
#' geom_polygon(fill = NA, colour = 'grey') +
#' geom_point(colour = 'red') +
#' geom_bspline_closed0(alpha = 0.5)
#'
#' # But only the standard version supports geom_shape operations
#' # Be aware of self-intersections though
#' ggplot(controls, aes(x, y)) +
#' geom_polygon(fill = NA, colour = 'grey') +
#' geom_point(colour = 'red') +
#' geom_bspline_closed(alpha = 0.5, expand = unit(2, 'cm'))
NULL
#' @rdname geom_bspline_closed
#' @export
stat_bspline_closed <- function(mapping = NULL, data = NULL, geom = 'shape',
position = 'identity', na.rm = FALSE, n = 100,
show.legend = NA, inherit.aes = TRUE, ...) {
layer(
stat = StatBspline, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, n = n, ...)
)
}
#' @rdname geom_bspline_closed
#' @export
geom_bspline_closed <- function(mapping = NULL, data = NULL, stat = 'bspline',
position = 'identity', n = 100, na.rm = FALSE,
show.legend = NA, inherit.aes = TRUE, ...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomShape,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, n = n, type = 'closed', ...)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @importFrom grid xsplineGrob gpar
#' @export
GeomBsplineClosed0 <- ggproto('GeomBspline0', GeomPolygon,
draw_panel = function(data, panel_scales, coord, na.rm = FALSE) {
coords <- coord$transform(data, panel_scales)
if (!is.integer(coords$group)) {
coords$group <- match(coords$group, unique0(coords$group))
}
startPoint <- match(unique0(coords$group), coords$group)
xsplineGrob(coords$x, coords$y,
id = coords$group, default.units = 'native',
shape = 1, open = FALSE,
gp = gpar(
col = coords$colour[startPoint],
fill = alpha(coords$fill[startPoint], coords$alpha[startPoint]),
lwd = (coords$linewidth[startPoint] %||% coords$size[startPoint]) * .pt,
lty = coords$linetype[startPoint]
)
)
}
)
#' @rdname geom_bspline_closed
#' @export
geom_bspline_closed0 <- function(mapping = NULL, data = NULL, stat = 'identity',
position = 'identity', na.rm = FALSE,
show.legend = NA, inherit.aes = TRUE, ...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomBsplineClosed0,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, ...)
)
}
ggforce/R/diagonal.R 0000644 0001762 0000144 00000022057 14564603246 014010 0 ustar ligges users #' Draw horizontal diagonals
#'
#' A diagonal is a bezier curve where the control points are moved
#' perpendicularly towards the center in either the x or y direction a fixed
#' amount. The versions provided here calculates horizontal diagonals meaning
#' that the x coordinate is moved to achieve the control point. The
#' `geom_diagonal()` and `stat_diagonal()` functions are simply helpers that
#' takes care of calculating the position of the control points and then
#' forwards the actual bezier calculations to [geom_bezier()].
#'
#' @section Aesthetics:
#' geom_diagonal and geom_diagonal0 understand the following aesthetics
#' (required aesthetics are in bold):
#'
#' - **x**
#' - **y**
#' - **xend**
#' - **yend**
#' - color
#' - linewidth
#' - linetype
#' - alpha
#' - lineend
#'
#' geom_diagonal2 understand the following aesthetics
#' (required aesthetics are in bold):
#'
#' - **x**
#' - **y**
#' - **group**
#' - color
#' - linewidth
#' - linetype
#' - alpha
#' - lineend
#'
#' @section Computed variables:
#'
#' \describe{
#' \item{x, y}{The interpolated point coordinates}
#' \item{index}{The progression along the interpolation mapped between 0 and 1}
#' }
#'
#' @inheritParams ggplot2::geom_line
#' @inheritParams ggplot2::stat_identity
#'
#' @param n The number of points to create for each segment
#'
#' @param strength The proportion to move the control point along the x-axis
#' towards the other end of the bezier curve
#'
#' @inheritSection ggplot2::geom_line Orientation
#'
#' @name geom_diagonal
#' @rdname geom_diagonal
#'
#' @examples
#' data <- data.frame(
#' x = rep(0, 10),
#' y = 1:10,
#' xend = 1:10,
#' yend = 2:11
#' )
#'
#' ggplot(data) +
#' geom_diagonal(aes(x, y, xend = xend, yend = yend))
#'
#' # The standard version provides an index to create gradients
#' ggplot(data) +
#' geom_diagonal(aes(x, y, xend = xend, yend = yend, alpha = after_stat(index)))
#'
#' # The 0 version uses bezierGrob under the hood for an approximation
#' ggplot(data) +
#' geom_diagonal0(aes(x, y, xend = xend, yend = yend))
#'
#' # The 2 version allows you to interpolate between endpoint aesthetics
#' data2 <- data.frame(
#' x = c(data$x, data$xend),
#' y = c(data$y, data$yend),
#' group = rep(1:10, 2),
#' colour = sample(letters[1:5], 20, TRUE)
#' )
#' ggplot(data2) +
#' geom_diagonal2(aes(x, y, group = group, colour = colour))
#'
#' # Use strength to control the steepness of the central region
#' ggplot(data, aes(x, y, xend = xend, yend = yend)) +
#' geom_diagonal(strength = 0.75, colour = 'red') +
#' geom_diagonal(strength = 0.25, colour = 'blue')
#'
NULL
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatDiagonal <- ggproto('StatDiagonal', Stat,
setup_params = function(data, params) {
params$flipped_aes <- has_flipped_aes(data, params, ambiguous = TRUE)
params
},
setup_data = function(data, params) {
data$flipped_aes <- params$flipped_aes
data
},
compute_panel = function(data, scales, n = 100, strength = 0.5, flipped_aes = FALSE) {
if (empty_data(data)) return(data)
data <- flip_data(data, flipped_aes)
data$group <- make_unique(as.character(data$group))
end <- data
end$x <- end$xend
end$y <- end$yend
data <- vec_rbind(data, end)
data$xend <- NULL
data$yend <- NULL
data <- data[order(data$group), ]
data <- add_controls(data, strength)
data <- StatBezier$compute_panel(data, scales, n)
flip_data(data, flipped_aes)
},
required_aes = c('x', 'y', 'xend', 'yend'),
extra_params = c('na.rm', 'n', 'strength', 'orientation')
)
#' @rdname geom_diagonal
#' @export
stat_diagonal <- function(mapping = NULL, data = NULL, geom = 'path',
position = 'identity', n = 100, strength = 0.5,
na.rm = FALSE, orientation = NA, show.legend = NA,
inherit.aes = TRUE, ...) {
layer(
stat = StatDiagonal, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, orientation = orientation, n = n, strength = strength, ...)
)
}
#' @rdname geom_diagonal
#' @export
geom_diagonal <- function(mapping = NULL, data = NULL, stat = 'diagonal',
position = 'identity', n = 100,
na.rm = FALSE, orientation = NA, strength = 0.5,
show.legend = NA, inherit.aes = TRUE, ...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomPath,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, orientation = orientation, n = n, strength = strength, ...)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatDiagonal2 <- ggproto('StatDiagonal2', Stat,
setup_params = function(data, params) {
params$flipped_aes <- has_flipped_aes(data, params, ambiguous = TRUE)
params
},
setup_data = function(data, params) {
data$flipped_aes <- params$flipped_aes
data
},
compute_layer = function(self, data, params, panels) {
if (empty_data(data)) return(data)
data <- flip_data(data, params$flipped_aes)
data <- data[order(data$group), ]
data <- add_controls(data, params$strength)
data <- flip_data(data, params$flipped_aes)
StatBezier2$compute_layer(data, params, panels)
},
required_aes = c('x', 'y'),
extra_params = c('na.rm', 'n', 'strength', 'orientation')
)
#' @rdname geom_diagonal
#' @export
stat_diagonal2 <- function(mapping = NULL, data = NULL,
geom = 'path_interpolate', position = 'identity',
na.rm = FALSE, orientation = NA, show.legend = NA,
n = 100, strength = 0.5, inherit.aes = TRUE, ...) {
layer(
stat = StatDiagonal2, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, orientation = orientation, n = n, strength = strength, ...)
)
}
#' @rdname geom_diagonal
#' @export
geom_diagonal2 <- function(mapping = NULL, data = NULL, stat = 'diagonal2',
position = 'identity', arrow = NULL, lineend = 'butt',
na.rm = FALSE, orientation = NA, show.legend = NA,
inherit.aes = TRUE, n = 100, strength = 0.5, ...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomPathInterpolate,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(
arrow = arrow, lineend = lineend, na.rm = na.rm, orientation = orientation,
n = n, strength = strength, ...
)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatDiagonal0 <- ggproto('StatDiagonal0', Stat,
setup_params = function(data, params) {
params$flipped_aes <- has_flipped_aes(data, params, ambiguous = TRUE)
params
},
setup_data = function(data, params) {
data$flipped_aes <- params$flipped_aes
data
},
compute_panel = function(data, scales, strength = 0.5, flipped_aes = FALSE) {
if (empty_data(data)) return(data)
data <- flip_data(data, flipped_aes)
data$group <- make_unique(as.character(data$group))
end <- data
end$x <- end$xend
end$y <- end$yend
data <- vec_rbind(data, end)
data$xend <- NULL
data$yend <- NULL
data <- data[order(data$group), ]
data <- add_controls(data, strength)
data <- flip_data(data, flipped_aes)
StatBezier0$compute_panel(data, scales)
},
required_aes = c('x', 'y', 'xend', 'yend'),
extra_params = c('na.rm', 'strength', 'orientation')
)
#' @rdname geom_diagonal
#' @export
stat_diagonal0 <- function(mapping = NULL, data = NULL, geom = 'bezier0',
position = 'identity', na.rm = FALSE, orientation = NA,
show.legend = NA, inherit.aes = TRUE, strength = 0.5,
...) {
layer(
stat = StatDiagonal0, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, orientation = orientation, strength = strength, ...)
)
}
#' @rdname geom_diagonal
#' @export
geom_diagonal0 <- function(mapping = NULL, data = NULL, stat = 'diagonal0',
position = 'identity', arrow = NULL, lineend = 'butt',
na.rm = FALSE, orientation = NA, show.legend = NA,
inherit.aes = TRUE, strength = 0.5, ...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomBezier0,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(
arrow = arrow, lineend = lineend, na.rm = na.rm, orientation = orientation,
strength = strength, ...
)
)
}
add_controls <- function(data, strength) {
start <- data[rep_len(c(TRUE, FALSE), nrow(data)), ]
end <- data[rep_len(c(FALSE, TRUE), nrow(data)), ]
x_diff <- (end$x - start$x) * strength
mid1 <- start
mid1$x <- mid1$x + x_diff
mid2 <- end
mid2$x <- mid2$x - x_diff
vec_rbind(start, mid1, mid2, end)
}
ggforce/R/scale-depth.R 0000644 0001762 0000144 00000002525 13674335764 014431 0 ustar ligges users #' Scales for depth perception
#'
#' These scales serve to scale the depth aesthetic when creating stereographic
#' plots. The range specifies the relative distance between the points and the
#' paper plane in relation to the distance between the eyes and the paper plane
#' i.e. a range of c(-0.5, 0.5) would put the highest values midways between
#' the eyes and the image plane and the lowest values the same distance behind
#' the image plane. To ensure a nice viewing experience these values should not
#' exceed ~0.3 as it would get hard for the eyes to consolidate the two
#' pictures.
#'
#' @param ... arguments passed on to continuous_scale or discrete_scale
#'
#' @param range The relative range as related to the distance between the eyes
#' and the paper plane.
#'
#' @export
#' @importFrom scales rescale_pal
#'
#' @examples
#' ggplot(mtcars) +
#' geom_point(aes(mpg, disp, depth = cyl)) +
#' scale_depth(range = c(-0.1, 0.25)) +
#' facet_stereo()
scale_depth <- function(..., range = c(0, 0.3)) {
continuous_scale('depth', 'depth_c', rescale_pal(range), ...)
}
#' @rdname scale_depth
#'
#' @export
scale_depth_continuous <- scale_depth
#' @rdname scale_depth
#'
#' @export
scale_depth_discrete <- function(..., range = c(0, 0.3)) {
discrete_scale(
'depth', 'depth_d',
function(n) seq(range[1], range[2], length.out = n), ...
)
}
ggforce/R/facet_grid_paginate.R 0000644 0001762 0000144 00000007450 14303357512 016162 0 ustar ligges users #' Split facet_grid over multiple plots
#'
#' This extension to [ggplot2::facet_grid()] will allow you to split
#' a facetted plot over multiple pages. You define a number of rows and columns
#' per page as well as the page number to plot, and the function will
#' automatically only plot the correct panels. Usually this will be put in a
#' loop to render all pages one by one.
#'
#' @inheritParams ggplot2::facet_grid
#' @param ncol Number of columns per page
#' @param nrow Number of rows per page
#' @param page The page to draw
#' @param byrow Should the pages be created row-wise or column wise
#'
#' @note If either `ncol` or `nrow` is `NULL` this function will
#' fall back to the standard `facet_grid` functionality.
#'
#' @family ggforce facets
#' @seealso [n_pages()] to compute the total number of pages in a paginated
#' faceted plot
#'
#' @export
#'
#' @examples
#' # Draw a small section of the grid
#' ggplot(diamonds) +
#' geom_point(aes(carat, price), alpha = 0.1) +
#' facet_grid_paginate(color ~ cut:clarity, ncol = 3, nrow = 3, page = 4)
facet_grid_paginate <- function(facets, margins = FALSE, scales = 'fixed',
space = 'fixed', shrink = TRUE,
labeller = 'label_value', as.table = TRUE,
switch = NULL, drop = TRUE, ncol = NULL,
nrow = NULL, page = 1, byrow = TRUE) {
facet <- facet_grid(facets,
margins = margins, scales = scales,
space = space, shrink = shrink, labeller = labeller,
as.table = as.table, switch = switch, drop = drop
)
if (is.null(nrow) || is.null(ncol)) {
facet
} else {
ggproto(NULL, FacetGridPaginate,
shrink = shrink,
params = c(
facet$params,
list(ncol = ncol, nrow = nrow, page = page, byrow = byrow)
)
)
}
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @importFrom gtable gtable_add_rows gtable_add_cols
#' @export
FacetGridPaginate <- ggproto('FacetGridPaginate', FacetGrid,
compute_layout = function(data, params) {
layout <- FacetGrid$compute_layout(data, params)
row_bin <- ceiling(layout$ROW / params$nrow)
col_bin <- ceiling(layout$COL / params$ncol)
bin_layout <- matrix(seq_len(max(row_bin) * max(col_bin)),
nrow = max(row_bin), byrow = params$byrow
)
layout$page <- bin_layout[(col_bin - 1) * nrow(bin_layout) + row_bin]
layout
},
draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord, data,
theme, params) {
include <- which(layout$page == params$page)
panels <- panels[include]
ranges <- ranges[include]
layout <- layout[include, , drop = FALSE]
layout$ROW <- layout$ROW - min(layout$ROW) + 1
layout$COL <- layout$COL - min(layout$COL) + 1
layout$PANEL <- 1:dim(layout)[1]
x_scale_ind <- unique0(layout$SCALE_X)
x_scales <- x_scales[x_scale_ind]
layout$SCALE_X <- match(layout$SCALE_X, x_scale_ind)
y_scale_ind <- unique0(layout$SCALE_Y)
y_scales <- y_scales[y_scale_ind]
layout$SCALE_Y <- match(layout$SCALE_Y, y_scale_ind)
table <- FacetGrid$draw_panels(panels, layout, x_scales, y_scales, ranges,
coord, data, theme, params)
if (max(layout$ROW) != params$nrow) {
spacing <- theme$panel.spacing.y %||% theme$panel.spacing
missing_rows <- params$nrow - max(layout$ROW)
table <- gtable_add_rows(table, unit(missing_rows, 'null'))
table <- gtable_add_rows(table, spacing * missing_rows)
}
if (max(layout$COL) != params$ncol) {
spacing <- theme$panel.spacing.x %||% theme$panel.spacing
missing_cols <- params$ncol - max(layout$COL)
table <- gtable_add_cols(table, unit(missing_cols, 'null'))
table <- gtable_add_cols(table, spacing * missing_cols)
}
table
}
)
ggforce/R/RcppExports.R 0000644 0001762 0000144 00000001771 14564603670 014524 0 ustar ligges users # Generated by using Rcpp::compileAttributes() -> do not edit by hand
# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
splinePath <- function(x, y, degree, knots, detail, type) {
.Call('_ggforce_splinePath', PACKAGE = 'ggforce', x, y, degree, knots, detail, type)
}
getSplines <- function(x, y, id, detail, type = "clamped") {
.Call('_ggforce_getSplines', PACKAGE = 'ggforce', x, y, id, detail, type)
}
bezierPath <- function(x, y, detail) {
.Call('_ggforce_bezierPath', PACKAGE = 'ggforce', x, y, detail)
}
getBeziers <- function(x, y, id, detail) {
.Call('_ggforce_getBeziers', PACKAGE = 'ggforce', x, y, id, detail)
}
enclose_ellip_points <- function(x, y, id, tol) {
.Call('_ggforce_enclose_ellip_points', PACKAGE = 'ggforce', x, y, id, tol)
}
enclose_points <- function(x, y, id) {
.Call('_ggforce_enclose_points', PACKAGE = 'ggforce', x, y, id)
}
points_to_path <- function(pos, path, close) {
.Call('_ggforce_points_to_path', PACKAGE = 'ggforce', pos, path, close)
}
ggforce/R/autopoint.R 0000644 0001762 0000144 00000003207 14564603246 014250 0 ustar ligges users #' A point geom specialised for scatterplot matrices
#'
#' This geom is a specialisation of [ggplot2::geom_point()] with two changes. It
#' defaults to mapping `x` and `y` to `.panel_x` and `.panel_y` respectively,
#' and it defaults to using [position_auto()] to jitter the points based on the
#' combination of position scale types.
#'
#' @inheritParams ggplot2::geom_point
#'
#' @seealso [facet_matrix] for how to lay out scatterplot matrices and
#' [position_auto] for information about the position adjustments
#'
#' @export
#'
#' @examples
#' # Continuous vs continuous: No jitter
#' ggplot(mpg) + geom_autopoint(aes(cty, hwy))
#'
#' # Continuous vs discrete: sina jitter
#' ggplot(mpg) + geom_autopoint(aes(cty, drv))
#'
#' # Discrete vs discrete: disc-jitter
#' ggplot(mpg) + geom_autopoint(aes(fl, drv))
#'
#' # Used with facet_matrix (x and y are automatically mapped)
#' ggplot(mpg) +
#' geom_autopoint() +
#' facet_matrix(vars(drv:fl))
#'
geom_autopoint <- function(mapping = NULL, data = NULL,
stat = "identity", position = "auto",
...,
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE) {
extra_mapping <- aes(x = .panel_x, y = .panel_y)
if (is.null(mapping$x)) mapping$x <- extra_mapping$x
if (is.null(mapping$y)) mapping$y <- extra_mapping$y
class(mapping) <- 'uneval'
layer(
data = data,
mapping = mapping,
stat = stat,
geom = GeomPoint,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
na.rm = na.rm,
...
)
)
}
ggforce/R/position-jitternormal.R 0000644 0001762 0000144 00000007107 14304373426 016601 0 ustar ligges users #' Jitter points with normally distributed random noise
#'
#' [ggplot2::geom_jitter()] adds random noise to points using a uniform
#' distribution. When many points are plotted, they appear in a rectangle. This
#' position jitters points using a normal distribution instead, resulting in
#' more circular clusters.
#'
#' @family position adjustments
#' @param sd_x,sd_y Standard deviation to add along the x and y axes. The
#' function uses [stats::rnorm()] with `mean = 0` behind the scenes.
#'
#' If omitted, defaults to 0.15. As with [ggplot2::geom_jitter()], categorical
#' data is aligned on the integers, so a standard deviation of more than 0.2
#' will spread the data so it's not possible to see the distinction between
#' the categories.
#' @inheritParams ggplot2::position_jitter
#' @export
#' @examples
#' # Example data
#' df <- data.frame(
#' x = sample(1:3, 1500, TRUE),
#' y = sample(1:3, 1500, TRUE)
#' )
#'
#' # position_jitter results in rectangular clusters
#' ggplot(df, aes(x = x, y = y)) +
#' geom_point(position = position_jitter())
#'
#' # geom_jitternormal results in more circular clusters
#' ggplot(df, aes(x = x, y = y)) +
#' geom_point(position = position_jitternormal())
#'
#' # You can adjust the standard deviations along both axes
#' # Tighter circles
#' ggplot(df, aes(x = x, y = y)) +
#' geom_point(position = position_jitternormal(sd_x = 0.08, sd_y = 0.08))
#'
#' # Oblong shapes
#' ggplot(df, aes(x = x, y = y)) +
#' geom_point(position = position_jitternormal(sd_x = 0.2, sd_y = 0.08))
#'
#' # Only add random noise to one dimension
#' ggplot(df, aes(x = x, y = y)) +
#' geom_point(
#' position = position_jitternormal(sd_x = 0.15, sd_y = 0),
#' alpha = 0.1
#' )
position_jitternormal <- function(sd_x = NULL, sd_y = NULL, seed = NA) {
ggproto(NULL, PositionJitterNormal,
sd_x = sd_x,
sd_y = sd_y,
seed = seed
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
PositionJitterNormal <- ggproto('PositionJitterNormal',
Position,
seed = NA,
required_aes = c('x', 'y'),
setup_params = function(self, data) {
if (!is.null(self$seed) && is.na(self$seed)) {
seed <- sample.int(.Machine$integer.max, 1L)
} else {
seed <- self$seed
}
list(
sd_x = self$sd_x %||% 0.15,
sd_y = self$sd_y %||% 0.15,
seed = seed
)
},
compute_layer = function(data, params, panel) {
trans_x <- if (params$sd_x > 0) {
function(x) x + rnorm(length(x), sd = params$sd_x)
}
trans_y <- if (params$sd_y > 0) {
function(x) x + rnorm(length(x), sd = params$sd_y)
}
# Make sure x and y jitter is only calculated once for all position aesthetics
# Takes aesthetic names from ggplot_global
x_aes <- intersect(c("x", "xmin", "xmax", "xend", "xintercept", "xmin_final", "xmax_final",
"xlower", "xmiddle", "xupper", "x0"), names(data))
x <- if (length(x_aes) == 0) 0 else data[[x_aes[1]]]
y_aes <- intersect(c("y", "ymin", "ymax", "yend", "yintercept", "ymin_final", "ymax_final",
"lower", "middle", "upper", "y0"), names(data))
y <- if (length(y_aes) == 0) 0 else data[[y_aes[1]]]
dummy_data <- data_frame0(x = x, y = y, .size = nrow(data))
fixed_jitter <- with_seed_null(params$seed, transform_position(dummy_data, trans_x, trans_y))
x_jit <- fixed_jitter$x - x
y_jit <- fixed_jitter$y - y
# Avoid nan values, if x or y has Inf values
x_jit[is.infinite(x)] <- 0
y_jit[is.infinite(y)] <- 0
# Apply jitter
transform_position(data, function(x) x + x_jit, function(x) x + y_jit)
}
)
ggforce/R/arc_bar.R 0000644 0001762 0000144 00000023421 14564603246 013617 0 ustar ligges users #' @include shape.R
NULL
#' Arcs and wedges as polygons
#'
#' This set of stats and geoms makes it possible to draw arcs and wedges as
#' known from pie and donut charts as well as more specialized plottypes such as
#' sunburst plots.
#'
#' @details An arc bar is the thick version of an arc; that is, a circle segment
#' drawn as a polygon in the same way as a rectangle is a thick version of a
#' line. A wedge is a special case of an arc where the inner radius is 0. As
#' opposed to applying coord_polar to a stacked bar chart, these layers are
#' drawn in cartesian space, which allows for transformations not possible with
#' the native ggplot2 approach. Most notable of these are the option to explode
#' arcs and wedgets away from their center point, thus detaching it from the
#' main pie/donut.
#'
#' @section Aesthetics:
#' geom_arc_bar understand the following aesthetics (required aesthetics are in
#' bold):
#'
#' - **x0**
#' - **y0**
#' - **r0**
#' - **r**
#' - **start** - when using stat_arc_bar
#' - **end** - when using stat_arc_bar
#' - **amount** - when using stat_pie
#' - explode
#' - color
#' - fill
#' - linewidth
#' - linetype
#' - alpha
#'
#'
#' @section Computed variables:
#' \describe{
#' \item{x, y}{x and y coordinates for the polygon}
#' }
#'
#' \describe{
#' \item{x, y}{The start coordinates for the segment}
#' }
#'
#' @inheritParams ggplot2::geom_polygon
#' @inheritParams ggplot2::stat_identity
#'
#' @param n The number of points used to draw a full circle. The number of
#' points on each arc will then be calculated as n / span-of-arc
#'
#' @param sep The separation between arcs in pie/donut charts
#'
#' @name geom_arc_bar
#' @rdname geom_arc_bar
#' @seealso [geom_arc()] for drawing arcs as lines
#'
#' @examples
#' # If you know the angle spans to plot it is easy
#' arcs <- data.frame(
#' start = seq(0, 2 * pi, length.out = 11)[-11],
#' end = seq(0, 2 * pi, length.out = 11)[-1],
#' r = rep(1:2, 5)
#' )
#'
#' # Behold the arcs
#' ggplot(arcs) +
#' geom_arc_bar(aes(x0 = 0, y0 = 0, r0 = r - 1, r = r, start = start,
#' end = end, fill = r))
#'
#' # geom_arc_bar uses geom_shape to draw the arcs, so you have all the
#' # possibilities of that as well, e.g. rounding of corners
#' ggplot(arcs) +
#' geom_arc_bar(aes(x0 = 0, y0 = 0, r0 = r - 1, r = r, start = start,
#' end = end, fill = r), radius = unit(4, 'mm'))
#'
#' # If you got values for a pie chart, use stat_pie
#' states <- c(
#' 'eaten', "eaten but said you didn\'t", 'cat took it', 'for tonight',
#' 'will decompose slowly'
#' )
#' pie <- data.frame(
#' state = factor(rep(states, 2), levels = states),
#' type = rep(c('Pie', 'Donut'), each = 5),
#' r0 = rep(c(0, 0.8), each = 5),
#' focus = rep(c(0.2, 0, 0, 0, 0), 2),
#' amount = c(4, 3, 1, 1.5, 6, 6, 1, 2, 3, 2)
#' )
#'
#' # Look at the cakes
#' ggplot() + geom_arc_bar(aes(
#' x0 = 0, y0 = 0, r0 = r0, r = 1, amount = amount,
#' fill = state, explode = focus
#' ),
#' data = pie, stat = 'pie'
#' ) +
#' facet_wrap(~type, ncol = 1) +
#' coord_fixed() +
#' theme_no_axes() +
#' scale_fill_brewer('', type = 'qual')
#'
NULL
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatArcBar <- ggproto('StatArcBar', Stat,
compute_panel = function(data, scales, n = 360) {
arcPaths(data, n)
},
required_aes = c('x0', 'y0', 'r0', 'r', 'start', 'end')
)
#' @rdname geom_arc_bar
#' @export
stat_arc_bar <- function(mapping = NULL, data = NULL, geom = 'arc_bar',
position = 'identity', n = 360, na.rm = FALSE,
show.legend = NA, inherit.aes = TRUE, ...) {
layer(
stat = StatArcBar, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, n = n, ...)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatPie <- ggproto('StatPie', Stat,
compute_panel = function(data, scales, n = 360, sep = 0) {
data <- dapply(data, c('x0', 'y0'), function(df) {
angles <- cumsum(df$amount)
seps <- cumsum(sep * seq_along(angles))
if (max(seps) >= 2 * pi) {
cli::cli_abort(c(
'Total separation exceeds circle circumference',
i = 'Try lowering {.arg sep}.'
))
}
angles <- angles / max(angles) * (2 * pi - max(seps))
data_frame0(
df,
start = c(0, angles[-length(angles)]) + c(0, seps[-length(seps)]) + sep / 2,
end = angles + seps - sep / 2
)
})
arcPaths(as.data.frame(data), n)
},
required_aes = c('x0', 'y0', 'r0', 'r', 'amount'),
default_aes = aes(explode = NULL)
)
#' @rdname geom_arc_bar
#' @export
stat_pie <- function(mapping = NULL, data = NULL, geom = 'arc_bar',
position = 'identity', n = 360, sep = 0, na.rm = FALSE,
show.legend = NA, inherit.aes = TRUE, ...) {
layer(
stat = StatPie, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, n = n, sep = sep, ...)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
GeomArcBar <- ggproto('GeomArcBar', GeomShape,
default_aes = combine_aes(GeomShape$default_aes, aes(colour = 'black', fill = NA))
)
#' @rdname geom_arc_bar
#' @inheritParams geom_shape
#' @export
geom_arc_bar <- function(mapping = NULL, data = NULL, stat = 'arc_bar',
position = 'identity', n = 360, expand = 0, radius = 0,
na.rm = FALSE, show.legend = NA, inherit.aes = TRUE,
...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomArcBar,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, n = n, expand = expand, radius = radius, ...)
)
}
# This function is like base::make.unique, but it
# maintains the ordering of the original names if the values
# are sorted.
make_unique <- function(x, sep = '.') {
if (!anyDuplicated(x)) return(x)
groups <- match(x, unique(x))
suffix <- unsplit(lapply(split(x, groups), seq_along), groups)
max_chars <- nchar(max(suffix))
suffix_format <- paste0('%0', max_chars, 'd')
paste0(x, sep, sprintf(suffix_format, suffix))
}
arcPaths <- function(data, n) {
trans <- radial_trans(c(0, 1), c(0, 2 * pi), pad = 0)
data <- data[data$start != data$end, ]
data$nControl <- ceiling(n / (2 * pi) * abs(data$end - data$start))
data$nControl[data$nControl < 3] <- 3
extraData <- !names(data) %in% c('r0', 'r', 'start', 'end', 'group')
data$group <- make_unique(as.character(data$group))
paths <- lapply(seq_len(nrow(data)), function(i) {
path <- data_frame0(
a = seq(data$start[i], data$end[i], length.out = data$nControl[i]),
r = data$r[i]
)
if ('r0' %in% names(data)) {
if (data$r0[i] != 0) {
path <- vec_rbind(
path,
data_frame0(a = rev(path$a), r = data$r0[i])
)
} else {
path <- vec_rbind(
path,
data_frame0(a = data$start[i], r = 0)
)
}
}
path$group <- data$group[i]
path$index <- seq(0, 1, length.out = nrow(path))
path <- cbind(path, data[rep(i, nrow(path)), extraData, drop = FALSE])
})
paths <- vec_rbind(!!!paths)
paths <- cbind(
paths[, !names(paths) %in% c('r', 'a')],
trans$transform(paths$r, paths$a)
)
paths$x <- paths$x + paths$x0
paths$y <- paths$y + paths$y0
if ('explode' %in% names(data)) {
exploded <- data$explode != 0
if (any(exploded)) {
exploder <- trans$transform(
data$explode[exploded],
data$start[exploded] + (data$end[exploded] - data$start[exploded]) / 2
)
explodedPaths <- paths$group %in% which(exploded)
exploderInd <- as.integer(factor(paths$group[explodedPaths]))
paths$x[explodedPaths] <-
paths$x[explodedPaths] + exploder$x[exploderInd]
paths$y[explodedPaths] <-
paths$y[explodedPaths] + exploder$y[exploderInd]
}
}
paths[, !names(paths) %in% c('x0', 'y0', 'exploded')]
}
arcPaths2 <- function(data, n) {
trans <- radial_trans(c(0, 1), c(0, 2 * pi), pad = 0)
fullCirc <- n / (2 * pi)
extraData <- setdiff(names(data), c('r', 'x0', 'y0', 'end', 'group', 'PANEL'))
hasExtra <- length(extraData) != 0
extraTemplate <- data[1, extraData, drop = FALSE]
paths <- lapply(split(seq_len(nrow(data)), data$group), function(i) {
if (length(i) != 2) {
cli::cli_abort(c(
'Arcs must be defined by two end points',
i = 'Make sure each group consists of two rows'
))
}
if (data$r[i[1]] != data$r[i[2]] ||
data$x0[i[1]] != data$x0[i[2]] ||
data$y0[i[1]] != data$y0[i[2]]) {
cli::cli_abort(
'Both end points in each arc must be at same radius ({.arg r}) and with same center ({.arg {c("x0", "y0")}})'
)
}
if (data$end[i[1]] == data$end[i[2]]) return()
nControl <- ceiling(fullCirc * abs(diff(data$end[i])))
if (nControl < 3) nControl <- 3
path <- data_frame0(
a = seq(data$end[i[1]], data$end[i[2]], length.out = nControl),
r = data$r[i[1]],
x0 = data$x0[i[1]],
y0 = data$y0[i[1]],
group = data$group[i[1]],
index = seq(0, 1, length.out = nControl),
.interp = c(FALSE, rep(TRUE, nControl - 2), FALSE),
PANEL = data$PANEL[i[1]]
)
if (hasExtra) {
path <- cbind(path, extraTemplate[rep(1, nControl), , drop = FALSE])
path[1, extraData] <- data[i[1], extraData, drop = FALSE]
path[nControl, extraData] <- data[i[2], extraData, drop = FALSE]
}
path
})
paths <- vec_rbind(!!!paths)
paths <- cbind(
paths[, !names(paths) %in% c('r', 'a')],
trans$transform(paths$r, paths$a)
)
paths$x <- paths$x + paths$x0
paths$y <- paths$y + paths$y0
paths[, !names(paths) %in% c('x0', 'y0')]
}
ggforce/R/facet_stereo.R 0000644 0001762 0000144 00000012543 14303357536 014673 0 ustar ligges users #' Create a stereogram plot
#'
#' This, arguably pretty useless function, lets you create plots with a sense of
#' depth by creating two slightly different versions of the plot that
#' corresponds to how the eyes would see it if the plot was 3 dimensional. To
#' experience the effect look at the plots through 3D hardware such as Google
#' Cardboard or by relaxing the eyes and focusing into the distance. The
#' depth of a point is calculated for layers having a depth aesthetic supplied.
#' The scaling of the depth can be controlled with [scale_depth()] as
#' you would control any aesthetic. Negative values will result in features
#' placed behind the paper plane, while positive values will result in
#' features hovering in front of the paper. While features within each layer is
#' sorted so those closest to you are plotted on top of those more distant, this
#' cannot be done between layers. Thus, layers are always plotted on top of
#' each others, even if the features in one layer lies behind features in a
#' layer behind it. The depth experience is inaccurate and should not be used
#' for conveying important data. Regard this more as a party-trick...
#'
#' @param IPD The interpupillary distance (in mm) used for calculating point
#' displacement. The default value is an average of both genders
#'
#' @param panel.size The final plot size in mm. As IPD this is used to calculate
#' point displacement. Don't take this value too literal but experiment until
#' you get a nice effect. Lower values gives higher displacement and thus
#' require the plots to be observed from a closer distance
#'
#' @inheritParams ggplot2::facet_wrap
#'
#' @family ggforce facets
#'
#' @export
#'
#' @examples
#' # You'll have to accept a warning about depth being an unknown aesthetic
#' ggplot(mtcars) +
#' geom_point(aes(mpg, disp, depth = cyl)) +
#' facet_stereo()
facet_stereo <- function(IPD = 63.5, panel.size = 200, shrink = TRUE) {
ggproto(NULL, FacetStereo,
shrink = shrink,
params = list(
IPD = IPD, panel.size = panel.size
)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @importFrom scales rescale
#' @importFrom gtable gtable_add_cols
#' @export
FacetStereo <- ggproto('FacetStereo', Facet,
compute_layout = function(data, params) {
data_frame0(PANEL = c(1L, 2L), SCALE_X = 1L, SCALE_Y = 1L)
},
map_data = function(data, layout, params) {
if (empty(data)) {
return(cbind(data, PANEL = integer(0)))
}
vec_rbind(
cbind(data, PANEL = 1L),
cbind(data, PANEL = 2L)
)
},
finish_data = function(data, layout, x_scales, y_scales, params) {
if ('depth' %in% names(data)) {
if ('.interp' %in% names(data)) {
data$depth2 <- vec_rbind(!!!lapply(split(data, data$PANEL), interpolateDataFrame))$depth
} else {
data$depth2 <- data$depth
}
group_order <- order(
sapply(split(data$depth2, data$group), quantile, probs = 0.9,
na.rm = TRUE)
)
data <- vec_rbind(!!!split(data, data$group)[group_order])
data[data$group == -1, ] <- data[data$group == -1, ][order(data$depth2[data$group == -1]), ]
data$group[data$group != -1] <- match(data$group[data$group != -1],
unique0(data$group[data$group != -1]))
x_range <- x_scales[[1]]$dimension(expand_default(x_scales[[1]]))
k <- ifelse(data$PANEL == 1, -1, 1) * params$IPD / 2
x_transform <- function(d) {
h <- rescale(d, to = c(-1, 1) * params$panel.size / 2, from = x_range)
new_pos <- h + (h - k) * data$depth2
rescale(new_pos, to = x_range, from = c(-1, 1) * params$panel.size / 2)
}
data <- transform_position(data, x_transform)
data$depth2 <- NULL
}
data
},
draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord,
data, theme, params) {
axes <- render_axes(ranges, ranges, coord, theme, FALSE)
panelGrobs <- create_panels(panels, axes$x, axes$y)
spacing <- theme$panel.spacing.x %||% theme$panel.spacing
panel <- gtable_add_cols(panelGrobs[[1]], spacing)
cbind(panel, panelGrobs[[2]], size = 'first')
},
draw_labels = function(panels, layout, x_scales, y_scales, ranges, coord, data,
theme, labels, params) {
panel_dim <- find_panel(panels)
xlab_height_top <- grobHeight(labels$x[[1]])
panels <- gtable_add_rows(panels, xlab_height_top, pos = 0)
panels <- gtable_add_grob(panels, labels$x[[1]],
name = 'xlab-t',
l = panel_dim$l, r = panel_dim$r, t = 1, clip = 'off'
)
xlab_height_bottom <- grobHeight(labels$x[[2]])
panels <- gtable_add_rows(panels, xlab_height_bottom, pos = -1)
panels <- gtable_add_grob(panels, labels$x[[2]],
name = 'xlab-b',
l = panel_dim$l, r = panel_dim$r, t = -1, clip = 'off'
)
panel_dim <- find_panel(panels)
ylab_width_left <- grobWidth(labels$y[[1]])
panels <- gtable_add_cols(panels, ylab_width_left, pos = 0)
panels <- gtable_add_grob(panels, labels$y[[1]],
name = 'ylab-l',
l = 1, b = panel_dim$b, t = panel_dim$t, clip = 'off'
)
ylab_width_right <- grobWidth(labels$y[[2]])
panels <- gtable_add_cols(panels, ylab_width_right, pos = -1)
panels <- gtable_add_grob(panels, labels$y[[2]],
name = 'ylab-r',
l = -1, b = panel_dim$b, t = panel_dim$t, clip = 'off'
)
panels
}
)
ggforce/R/facet_wrap_paginate.R 0000644 0001762 0000144 00000015762 14312041550 016203 0 ustar ligges users #' Split facet_wrap over multiple plots
#'
#' This extension to [ggplot2::facet_wrap()] will allow you to split
#' a facetted plot over multiple pages. You define a number of rows and columns
#' per page as well as the page number to plot, and the function will
#' automatically only plot the correct panels. Usually this will be put in a
#' loop to render all pages one by one.
#'
#' @inheritParams ggplot2::facet_wrap
#' @param nrow,ncol Number of rows and columns
#' @param page The page to draw
#'
#' @note If either `ncol` or `nrow` is `NULL` this function will
#' fall back to the standard `facet_wrap` functionality.
#'
#' @family ggforce facets
#' @seealso [n_pages()] to compute the total number of pages in a paginated
#' faceted plot
#'
#' @export
#' @importFrom utils packageVersion
#'
#' @examples
#' ggplot(diamonds) +
#' geom_point(aes(carat, price), alpha = 0.1) +
#' facet_wrap_paginate(~ cut:clarity, ncol = 3, nrow = 3, page = 4)
#'
facet_wrap_paginate <- function(facets, nrow = NULL, ncol = NULL,
scales = 'fixed', shrink = TRUE,
labeller = 'label_value', as.table = TRUE,
switch = deprecated(), drop = TRUE, dir = 'h',
strip.position = 'top', page = 1) {
# Work around non-lifecycle deprecation
if (!lifecycle::is_present(switch) && packageVersion('ggplot2') <= '3.3.6') {
switch <- NULL
}
real_dir <- 'h'
if (identical(dir, 'v')) {
tmp <- ncol
ncol <- nrow
nrow <- tmp
real_dir <- 'v'
dir <- 'h'
}
facet <- facet_wrap(facets,
nrow = nrow, ncol = ncol, scales = scales,
shrink = shrink, labeller = labeller, as.table = as.table,
switch = switch, drop = drop, dir = dir,
strip.position = strip.position
)
if (is.null(nrow) || is.null(ncol)) {
facet
} else {
ggproto(NULL, FacetWrapPaginate,
shrink = shrink,
params = c(facet$params, list(page = page, real_dir = real_dir))
)
}
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @importFrom gtable gtable_add_rows gtable_add_cols
#' @export
FacetWrapPaginate <- ggproto('FacetWrapPaginate', FacetWrap,
setup_params = function(data, params) {
modify_list(
params,
list(
max_rows = params$nrow,
max_cols = params$ncol,
nrow = NULL
)
)
},
compute_layout = function(data, params) {
layout <- FacetWrap$compute_layout(data, params)
layout$page <- ceiling(layout$ROW / params$max_rows)
layout
},
draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord, data,
theme, params) {
include <- which(layout$page == params$page)
panels <- panels[include]
ranges <- ranges[include]
layout <- layout[include, , drop = FALSE]
layout$ROW <- layout$ROW - min(layout$ROW) + 1
x_scale_ind <- unique0(layout$SCALE_X)
x_scales <- x_scales[x_scale_ind]
layout$SCALE_X <- match(layout$SCALE_X, x_scale_ind)
y_scale_ind <- unique0(layout$SCALE_Y)
y_scales <- y_scales[y_scale_ind]
layout$SCALE_Y <- match(layout$SCALE_Y, y_scale_ind)
if (identical(params$real_dir, "v")) {
layout[c("ROW", "COL")] <- layout[c("COL", "ROW")]
params[c('max_cols', 'max_rows')] <- params[c('max_rows', 'max_cols')]
}
table <- FacetWrap$draw_panels(panels, layout, x_scales, y_scales, ranges,
coord, data, theme, params)
if (max(layout$ROW) != params$max_rows) {
spacing <- theme$panel.spacing.y %||% theme$panel.spacing
missing_rows <- params$max_rows - max(layout$ROW)
strip_rows <- unique0(table$layout$t[grepl('strip', table$layout$name) & table$layout$l %in% panel_cols(table)$l])
if (length(strip_rows) != 0)
strip_rows <- strip_rows[as.numeric(table$heights[strip_rows]) != 0]
axis_b_rows <- unique0(table$layout$t[grepl('axis-b', table$layout$name)])
axis_b_rows <- axis_b_rows[as.numeric(table$heights[axis_b_rows]) != 0]
axis_t_rows <- unique0(table$layout$t[grepl('axis-t', table$layout$name)])
axis_t_rows <- axis_t_rows[as.numeric(table$heights[axis_t_rows]) != 0]
table <- gtable_add_rows(table, unit(missing_rows, 'null'))
table <- gtable_add_rows(table, spacing * missing_rows)
if (length(strip_rows) != 0) {
table <- gtable_add_rows(table, min(table$heights[strip_rows]) * missing_rows)
}
if (params$free$x) {
if (length(axis_b_rows) != 0) {
table <- gtable_add_rows(table, min(table$heights[axis_b_rows]) * missing_rows)
}
if (length(axis_t_rows) != 0) {
table <- gtable_add_rows(table, min(table$heights[axis_t_rows]) * missing_rows)
}
}
}
if (max(layout$COL) != params$max_cols) {
spacing <- theme$panel.spacing.x %||% theme$panel.spacing
missing_cols <- params$max_cols - max(layout$COL)
strip_cols <- unique0(table$layout$t[grepl('strip', table$layout$name) & table$layout$t %in% panel_rows(table)$t])
if (length(strip_cols) != 0)
strip_cols <- strip_cols[as.numeric(table$widths[strip_cols]) != 0]
axis_l_cols <- unique0(table$layout$l[grepl('axis-l', table$layout$name)])
axis_l_cols <- axis_l_cols[as.numeric(table$widths[axis_l_cols]) != 0]
axis_r_cols <- unique0(table$layout$l[grepl('axis-r', table$layout$name)])
axis_r_cols <- axis_r_cols[as.numeric(table$widths[axis_r_cols]) != 0]
table <- gtable_add_cols(table, unit(missing_cols, 'null'))
table <- gtable_add_cols(table, spacing * missing_cols)
if (length(strip_cols) != 0) {
table <- gtable_add_cols(table, min(table$widths[strip_cols]) * missing_cols)
}
if (params$free$y) {
if (length(axis_l_cols) != 0) {
table <- gtable_add_cols(table, min(table$widths[axis_l_cols]) * missing_cols)
}
if (length(axis_r_cols) != 0) {
table <- gtable_add_cols(table, min(table$widths[axis_r_cols]) * missing_cols)
}
}
}
table
}
)
#' Determine the number of pages in a paginated facet plot
#'
#' This is a simple helper that returns the number of pages it takes to plot all
#' panels when using [facet_wrap_paginate()] and
#' [facet_grid_paginate()]. It partially builds the plot so depending
#' on the complexity of your plot it might take some time to calculate...
#'
#' @param plot A ggplot object using either facet_wrap_paginate or
#' facet_grid_paginate
#'
#' @return If the plot uses using either facet_wrap_paginate or
#' facet_grid_paginate it returns the total number of pages. Otherwise it
#' returns NULL
#'
#' @export
#'
#' @examples
#' p <- ggplot(diamonds) +
#' geom_point(aes(carat, price), alpha = 0.1) +
#' facet_wrap_paginate(~ cut:clarity, ncol = 3, nrow = 3, page = 1)
#' n_pages(p)
n_pages <- function(plot) {
if (utils::packageVersion('ggplot2') <= '2.2.1') {
page <- ggplot_build(plot)$layout$panel_layout$page
} else {
page <- ggplot_build(plot)$layout$layout$page
}
if (!is.null(page)) {
max(page)
} else {
NULL
}
}
ggforce/R/parallel_sets.R 0000644 0001762 0000144 00000035674 14564603246 015075 0 ustar ligges users #' Create Parallel Sets diagrams
#'
#' A parallel sets diagram is a type of visualisation showing the interaction
#' between multiple categorical variables. If the variables has an intrinsic
#' order the representation can be thought of as a Sankey Diagram. If each
#' variable is a point in time it will resemble an alluvial diagram.
#'
#' In a parallel sets visualization each categorical variable will be assigned
#' a position on the x-axis. The size of the intersection of categories from
#' neighboring variables are then shown as thick diagonals, scaled by the sum of
#' elements shared between the two categories. The natural data representation
#' for such as plot is to have each categorical variable in a separate column
#' and then have a column giving the amount/magnitude of the combination of
#' levels in the row. This representation is unfortunately not fitting for the
#' `ggplot2` API which needs every position encoding in the same column. To make
#' it easier to work with `ggforce` provides a helper [gather_set_data()], which
#' takes care of the transformation.
#'
#' @section Aesthetics:
#' geom_parallel_sets understand the following aesthetics
#' (required aesthetics are in bold):
#'
#' - **x|y**
#' - **id**
#' - **split**
#' - **value**
#' - color
#' - fill
#' - size
#' - linetype
#' - alpha
#' - lineend
#'
#' @inheritParams geom_diagonal_wide
#' @param sep The proportional separation between categories within a variable
#' @param axis.width The width of the area around each variable axis
#' @param angle The angle of the axis label text
#' @param nudge_x,nudge_y Horizontal and vertical adjustment to nudge labels by.
#' Useful for offsetting text from the category segments.
#'
#' @inheritSection ggplot2::geom_line Orientation
#'
#' @name geom_parallel_sets
#' @rdname geom_parallel_sets
#'
#' @author Thomas Lin Pedersen
#'
#' @examples
#' data <- reshape2::melt(Titanic)
#' data <- gather_set_data(data, 1:4)
#'
#' ggplot(data, aes(x, id = id, split = y, value = value)) +
#' geom_parallel_sets(aes(fill = Sex), alpha = 0.3, axis.width = 0.1) +
#' geom_parallel_sets_axes(axis.width = 0.1) +
#' geom_parallel_sets_labels(colour = 'white')
#'
#' # Use nudge_x to offset and hjust = 0 to left-justify label
#' ggplot(data, aes(x, id = id, split = y, value = value)) +
#' geom_parallel_sets(aes(fill = Sex), alpha = 0.3, axis.width = 0.1) +
#' geom_parallel_sets_axes(axis.width = 0.1) +
#' geom_parallel_sets_labels(colour = 'red', angle = 0, nudge_x = 0.1, hjust = 0)
NULL
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatParallelSets <- ggproto('StatParallelSets', Stat,
setup_params = function(data, params) {
params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = FALSE)
params
},
setup_data = function(data, params) {
value_check <- lapply(split(data$value, data$id), unique0)
if (any(lengths(value_check) != 1)) {
cli::cli_abort('{.field value} must be kept constant across {.field id}')
}
data$split <- as.factor(data$split)
data$flipped_aes <- params$flipped_aes
data
},
compute_panel = function(data, scales, sep = 0.05, strength = 0.5, n = 100,
axis.width = 0, flipped_aes = FALSE) {
data <- flip_data(data, flipped_aes)
data <- remove_group(data)
data <- complete_data(data)
cols <- c('group', 'colour', 'color', 'fill', 'size', 'linewidth', 'alpha', 'linetype')
data_groups <- vec_rbind(
!!!lapply(split(data[, names(data) %in% cols, drop = FALSE], data$group),
function(d) {
data_frame0(!!!lapply(d, function(x) na.omit(x)[1]))
}
)
)
# Calculate axis sizes
data_axes <- sankey_axis_data(data, sep)
# Calculate diagonals
diagonals <- sankey_diag_data(data, data_axes, data_groups, axis.width)
diagonals <- flip_data(diagonals, flipped_aes)
StatDiagonalWide$compute_panel(diagonals, scales, strength, n, flipped_aes)
},
required_aes = c('x|y', 'id', 'split', 'value'),
extra_params = c('na.rm', 'n', 'sep', 'strength', 'axis.width', 'orientation')
)
#' @rdname geom_parallel_sets
#' @export
stat_parallel_sets <- function(mapping = NULL, data = NULL, geom = 'shape',
position = 'identity', n = 100, strength = 0.5,
sep = 0.05, axis.width = 0, na.rm = FALSE,
orientation = NA, show.legend = NA,
inherit.aes = TRUE, ...) {
layer(
stat = StatParallelSets, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(
na.rm = na.rm, orientation = orientation, n = n, strength = strength,
sep = sep, axis.width = axis.width, ...
)
)
}
#' @rdname geom_parallel_sets
#' @export
geom_parallel_sets <- function(mapping = NULL, data = NULL,
stat = 'parallel_sets', position = 'identity',
n = 100, na.rm = FALSE, orientation = NA,
sep = 0.05, strength = 0.5, axis.width = 0,
show.legend = NA, inherit.aes = TRUE, ...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomShape,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(
na.rm = na.rm, orientation = orientation, n = n, strength = strength,
sep = sep, axis.width = axis.width, ...
)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatParallelSetsAxes <- ggproto('StatParallelSetsAxes', Stat,
setup_params = function(data, params) {
params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = FALSE)
params
},
setup_data = function(data, params) {
value_check <- lapply(split(data$value, data$id), unique0)
if (any(lengths(value_check) != 1)) {
cli::cli_abort('{.field value} must be kept constant across {.field id}')
}
data$split <- as.factor(data$split)
data$flipped_aes <- params$flipped_aes
data
},
compute_panel = function(data, scales, sep = 0.05, axis.width = 0, flipped_aes = FALSE) {
data <- flip_data(data, flipped_aes)
split_levels <- levels(data$split)
data <- remove_group(data)
data <- complete_data(data, FALSE)
# Calculate axis sizes
data_axes <- sankey_axis_data(data, sep)
data_axes <- data_axes[data_axes$split != '.ggforce_missing', ]
cols <- c('x', 'split', 'colour', 'color', 'fill', 'size', 'linewidth',
'alpha', 'linetype')
aes <- data[, names(data) %in% cols]
aes <- unique0(aes)
if (nrow(aes) != nrow(data_axes)) {
cli::cli_abort('Axis aesthetics must be constant in each split')
}
data_axes$split <- factor(as.character(data_axes$split),
levels = split_levels)
aes$split <- factor(as.character(aes$split), levels = split_levels)
data <- merge(data_axes, aes, by = c('x', 'split'), all.x = TRUE,
sort = FALSE)
names(data)[names(data) == 'split'] <- 'label'
data$y <- data$ymin + data$value / 2
data$xmin <- data$x - axis.width / 2
data$xmax <- data$x + axis.width / 2
flip_data(data, flipped_aes)
},
required_aes = c('x|y', 'id', 'split', 'value'),
extra_params = c('na.rm', 'sep', 'orientation')
)
#' @rdname geom_parallel_sets
#' @export
stat_parallel_sets_axes <- function(mapping = NULL, data = NULL,
geom = 'parallel_sets_axes',
position = 'identity', sep = 0.05,
axis.width = 0, na.rm = FALSE,
orientation = NA, show.legend = NA,
inherit.aes = TRUE, ...) {
layer(
stat = StatParallelSetsAxes, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, orientation = orientation, sep = sep,
axis.width = axis.width, ...)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
GeomParallelSetsAxes <- ggproto('GeomParallelSetsAxes', GeomShape,
setup_data = function(data, params) {
flipped_aes <- has_flipped_aes(data, params)
data <- flip_data(data, flipped_aes)
data$group <- seq_len(nrow(data))
lb <- data
lb$x <- lb$xmin
lb$y <- lb$ymin
rb <- data
rb$x <- rb$xmax
rb$y <- rb$ymin
lt <- data
lt$x <- lt$xmin
lt$y <- lt$ymax
rt <- data
rt$x <- rt$xmax
rt$y <- rt$ymax
data <- vec_rbind(lb, rb, rt, lt)
flip_data(data[order(data$group), ], flipped_aes)
},
required_aes = c('xmin', 'ymin', 'xmax', 'ymax')
)
#' @rdname geom_parallel_sets
#' @export
geom_parallel_sets_axes <- function(mapping = NULL, data = NULL,
stat = 'parallel_sets_axes',
position = 'identity', na.rm = FALSE,
orientation = NA, show.legend = NA,
inherit.aes = TRUE, ...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomParallelSetsAxes,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, orientation = orientation, ...)
)
}
#' @rdname geom_parallel_sets
#' @export
geom_parallel_sets_labels <- function(mapping = NULL, data = NULL,
stat = 'parallel_sets_axes', angle = -90,
nudge_x = 0, nudge_y = 0,
position = 'identity', na.rm = FALSE,
orientation = NA, show.legend = NA,
inherit.aes = TRUE, ...) {
if (!missing(nudge_x) || !missing(nudge_y)) {
if (!missing(position)) {
cli::cli_abort(c(
"both {.arg position} and {.arg nudge_x}/{.arg nudge_y} are supplied",
"i" = "Only use one approach to alter the position"
))
}
position <- position_nudge(nudge_x, nudge_y)
}
layer(
data = data, mapping = mapping, stat = stat, geom = GeomText,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, orientation = orientation, angle = angle, ...)
)
}
#' Tidy data for use with geom_parallel_sets
#'
#' This helper function makes it easy to change tidy data into a tidy(er) format
#' that can be used by geom_parallel_sets.
#'
#' @param data A tidy dataframe with some categorical columns
#' @param x The columns to use for axes in the parallel sets diagram
#' @param id_name The name of the column that will contain the original index of
#' the row.
#'
#' @return A data.frame
#'
#' @export
#'
#' @examples
#' data <- reshape2::melt(Titanic)
#' head(gather_set_data(data, 1:4))
gather_set_data <- function(data, x, id_name = 'id') {
columns <- tidyselect::eval_select(enquo(x), data)
data[[id_name]] <- seq_len(nrow(data))
vec_rbind(!!!lapply(columns, function(n) {
data$x <- n
data$y <- data[[n]]
data
}))
}
#' @importFrom stats na.omit
complete_data <- function(data, check_id = TRUE) {
levels(data$split) <- c(levels(data$split), '.ggforce_missing')
all_obs <- unique0(data[, c('id', 'value')])
data <- vec_rbind(!!!lapply(split(data, data$x), function(d) {
if (anyDuplicated(d$id) != 0) {
cli::cli_abort('{.field id} must be unique within axes')
}
x <- d$x[1]
if (length(d$id) != nrow(all_obs)) {
n_miss <- nrow(all_obs) - length(d$id)
fill <- d[seq_len(n_miss), ][NA, ]
fill$x <- x
fill[, c('id', 'value')] <- all_obs[!d$id %in% all_obs$id, ]
fill$split <- '.ggforce_missing'
d <- vec_rbind(d, fill)
}
d
}))
if (check_id) {
# Ensure id grouping
id_groups <- lapply(split(data$group, data$id),
function(x) unique0(na.omit(x)))
if (any(lengths(id_groups) != 1)) {
cli::cli_abort('{.field id} must keep grouping across data')
}
id_match <- match(as.character(data$id), names(id_groups))
data$group <- unlist(id_groups)[id_match]
}
data[order(data$x, data$id), ]
}
sankey_axis_data <- function(data, sep) {
vec_rbind(!!!lapply(split(data, data$x), function(d) {
splits <- split(d$value, as.character(d$split))
splits <- splits[rev(order(match(names(splits), levels(d$split))))]
d <- data_frame0(
split = factor(names(splits)),
value = sapply(splits, sum),
x = d$x[1]
)
sep <- sum(d$value) * sep
d$ymax <- (seq_len(nrow(d)) - 1) * sep + cumsum(d$value)
d$ymin <- d$ymax - d$value
d
}))
}
sankey_diag_data <- function(data, axes_data, groups, axis.width) {
axes <- sort(unique0(data$x))
diagonals <- lapply(seq_len(length(axes) - 1), function(i) {
from <- data[data$x == axes[i], , drop = FALSE]
to <- data[data$x == axes[i + 1], , drop = FALSE]
diagonals <- split(
seq_len(nrow(from)),
list(from$group, from$split, to$split)
)
diagonals <- diagonals[lengths(diagonals) != 0]
diag_rep <- sapply(diagonals, `[`, 1)
diag_from <- data_frame0(
group = from$group[diag_rep],
split = from$split[diag_rep],
value = sapply(diagonals, function(ii) sum(from$value[ii])),
x = from$x[1] + axis.width / 2
)
diag_to <- diag_from
diag_to$split <- to$split[diag_rep]
diag_to$x <- to$x[1] - axis.width / 2
diag_from <- add_y_pos(diag_from, axes_data[axes_data$x == axes[i], ])
diag_to <- add_y_pos(diag_to, axes_data[axes_data$x == axes[i + 1], ])
diagonals <- vec_rbind(diag_from, diag_to)
main_groups <- diagonals$group
diagonals$group <- rep(seq_len(nrow(diag_from) / 2), 4)
if (length(setdiff(names(groups), 'group')) > 0) {
diagonals <- cbind(
diagonals,
groups[match(main_groups, groups$group), names(groups) != 'group', drop = FALSE]
)
}
diagonals
})
n_groups <- sapply(diagonals, nrow) / 4
group_offset <- c(0, cumsum(n_groups)[-length(n_groups)])
vec_rbind(!!!Map(function(d, i) {
d$group <- d$group + i
d
}, d = diagonals, i = group_offset))
}
add_y_pos <- function(data, axes_data) {
splits <- split(seq_len(nrow(data)), as.character(data$split))
ymin <- lapply(splits, function(i) {
split <- as.character(data$split[i[1]])
sizes <- data$value[i]
ymin <- axes_data$ymax[axes_data$split == split] -
cumsum(sizes[order(data$group[i])])
ymin[order(data$group[i])] <- ymin
ymin
})
data$y[unlist(splits)] <- unlist(ymin)
data_tmp <- data
data_tmp$y <- data$y + data$value
vec_rbind(data_tmp, data)
}
remove_group <- function(data) {
split_groups <- lapply(split(data$group, data$split), unique0)
if (length(Reduce(intersect, split_groups)) == 0) {
disc <- vapply(data, is.discrete, logical(1))
disc[names(disc) %in% c('split', 'label', 'PANEL')] <- FALSE
if (any(disc)) {
data$group <- id(data[disc], drop = TRUE)
} else {
data$group <- -1
}
}
data
}
is.discrete <- function(x) {
is.factor(x) || is.character(x) || is.logical(x)
}
ggforce/R/facet_row.R 0000644 0001762 0000144 00000007223 13523007673 014175 0 ustar ligges users #' One-dimensional facets
#'
#' These facets are one-dimensional versions of [ggplot2::facet_wrap()],
#' arranging the panels in either a single row or a single column. This
#' restriction makes it possible to support a `space` argument as seen in
#' [ggplot2::facet_grid()] which, if set to `"free"` will allow the panels to be
#' sized based on the relative range of their scales. Another way of thinking
#' about them are one-dimensional versions of [ggplot2::facet_grid()] (ie.
#' `. ~ {var}` or `{var} ~ .`), but with the ability to position the strip at
#' either side of the panel. However you look at it it is the best of both world
#' if you just need one dimension.
#'
#' @inheritParams ggplot2::facet_wrap
#' @param space Should the size of the panels be fixed or relative to the range
#' of the respective position scales
#'
#' @export
#'
#' @examples
#' # Standard use
#' ggplot(mtcars) +
#' geom_point(aes(disp, mpg)) +
#' facet_col(~gear)
#' # It retains the ability to have unique scales for each panel
#' ggplot(mtcars) +
#' geom_point(aes(disp, mpg)) +
#' facet_col(~gear, scales = 'free')
#'
#' # But can have free sizing along the stacking dimension
#' ggplot(mtcars) +
#' geom_point(aes(disp, mpg)) +
#' facet_col(~gear, scales = 'free', space = 'free')
#'
#' # And you can position the strip where-ever you like
#' ggplot(mtcars) +
#' geom_point(aes(disp, mpg)) +
#' facet_col(~gear, scales = 'free', space = 'free', strip.position = 'bottom')
#'
facet_row <- function(facets, scales = "fixed", space = "fixed",
shrink = TRUE, labeller = "label_value",
drop = TRUE, strip.position = 'top') {
space <- match.arg(space, c('free', 'fixed'))
facet <- facet_wrap(facets, nrow = 1, scales = scales, shrink = shrink, labeller = labeller, drop = drop, strip.position = strip.position)
params <- facet$params
params$space_free <- space == 'free'
ggproto(NULL, FacetRow, shrink = shrink, params = params)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
FacetRow <- ggproto('FacetRow', FacetWrap,
draw_panels = function(self, panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) {
combined <- ggproto_parent(FacetWrap, self)$draw_panels(panels, layout, x_scales, y_scales, ranges, coord, data, theme, params)
if (params$space_free) {
widths <- vapply(layout$PANEL, function(i) diff(ranges[[i]]$x.range), numeric(1))
panel_widths <- unit(widths, "null")
combined$widths[panel_cols(combined)$l] <- panel_widths
}
combined
}
)
#' @rdname facet_row
#' @export
facet_col <- function(facets, scales = "fixed", space = "fixed",
shrink = TRUE, labeller = "label_value",
drop = TRUE, strip.position = 'top') {
space <- match.arg(space, c('free', 'fixed'))
facet <- facet_wrap(facets, ncol = 1, scales = scales, shrink = shrink, labeller = labeller, drop = drop, strip.position = strip.position)
params <- facet$params
params$space_free <- space == 'free'
ggproto(NULL, FacetCol, shrink = shrink, params = params)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
FacetCol <- ggproto('FacetCol', FacetWrap,
draw_panels = function(self, panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) {
combined <- ggproto_parent(FacetWrap, self)$draw_panels(panels, layout, x_scales, y_scales, ranges, coord, data, theme, params)
if (params$space_free) {
heights <- vapply(layout$PANEL, function(i) diff(ranges[[i]]$y.range), numeric(1))
panel_heights <- unit(heights, "null")
combined$heights[panel_rows(combined)$t] <- panel_heights
}
combined
}
)
ggforce/R/errorbar.R 0000644 0001762 0000144 00000003346 14564603246 014050 0 ustar ligges users #' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatErr <- ggproto(
"StatErr",
Stat,
required_aes = c('xmin', 'x', 'xmax', 'ymin', 'y', 'ymax'),
compute_group = function(data, scales) {
data_frame0(
x = c(data$xmin, data$x),
xend = c(data$xmax, data$x),
y = c(data$y, data$ymin),
yend = c(data$y, data$ymax)
)[c(matrix(seq_len(2 * nrow(data)), nrow = 2, byrow = TRUE)), ]
}
)
#' Intervals in vertical and horizontal directions
#'
#' `stat_err` draws intervals of points (`x`, `y`) in vertical (`ymin`, `ymax`)
#' and horizontal (`xmin`, `xmax`) directions.
#'
#' @section Aesthetics:
#' `stat_err()` understands the following aesthetics (required aesthetics are in
#' bold):
#'
#' - **x**
#' - **xmin**
#' - **xmax**
#' - **y**
#' - **ymin**
#' - **ymax**
#' - alpha
#' - color
#' - group
#' - linetype
#' - linewidth
#'
#' @examples
#' library(ggplot2)
#'
#' x <- 1:3
#' xmin <- x - 2.5
#' xmax <- x + 2.5
#' d <- data.frame(
#' x = x, y = x, xmin = xmin, ymin = xmin, xmax = xmax, ymax = xmax,
#' color = as.factor(x)
#' )
#' ggplot(
#' d,
#' aes(x = x, y = y, xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax, color = color)
#' ) +
#' stat_err(size = 2)
#'
#' @inheritParams ggplot2::layer
#' @inheritParams ggplot2::geom_errorbar
#' @inheritParams ggplot2::stat_identity
#'
#' @importFrom ggplot2 layer
#'
#' @export
stat_err <- function(
mapping = NULL, data = NULL, geom = "segment", position = "identity",
na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, ...
) {
layer(
stat = StatErr, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, ...)
)
}
ggforce/R/bezier.R 0000644 0001762 0000144 00000025077 14564603246 013517 0 ustar ligges users #' Create quadratic or cubic bezier curves
#'
#' This set of geoms makes it possible to connect points creating either
#' quadratic or cubic beziers. bezier and bezier2 both work by calculating
#' points along the bezier and connecting these to draw the curve. bezier0
#' directly draws the bezier using bezierGrob. In line with the [geom_link()] and
#' [geom_link2()] differences geom_bezier creates the points, assign
#' an index to each interpolated point and repeat the aesthetics for the start
#' point, while geom_bezier2 interpolates the aesthetics between the start and
#' end points.
#'
#' @details
#' Input data is understood as a sequence of data points the first being the
#' start point, then followed by one or two control points and then the end
#' point. More than 4 and less than 3 points per group will throw an error.
#' [grid::bezierGrob()] only takes cubic beziers so if three points are
#' supplied the middle one as duplicated. This, along with the fact that
#' [grid::bezierGrob()] estimates the curve using an x-spline means
#' that the curves produced by geom_bezier and geom_bezier2 deviates from those
#' produced by geom_bezier0. If you want true bezier paths use geom_bezier or
#' geom_bezier2.
#'
#' @section Aesthetics:
#' geom_bezier, geom_bezier2 and geom_bezier0 understand the following aesthetics
#' (required aesthetics are in bold):
#'
#' - **x**
#' - **y**
#' - color
#' - linewidth
#' - linetype
#' - alpha
#' - lineend
#'
#'
#' @section Computed variables:
#'
#' \describe{
#' \item{x, y}{The interpolated point coordinates}
#' \item{index}{The progression along the interpolation mapped between 0 and 1}
#' }
#'
#' @inheritParams ggplot2::geom_path
#' @inheritParams ggplot2::stat_identity
#'
#' @param n The number of points to create for each segment
#'
#' @name geom_bezier
#' @rdname geom_bezier
#'
#' @examples
#' beziers <- data.frame(
#' x = c(1, 2, 3, 4, 4, 6, 6),
#' y = c(0, 2, 0, 0, 2, 2, 0),
#' type = rep(c('cubic', 'quadratic'), c(3, 4)),
#' point = c('end', 'control', 'end', 'end', 'control', 'control', 'end'),
#' colour = letters[1:7]
#' )
#' help_lines <- data.frame(
#' x = c(1, 3, 4, 6),
#' xend = c(2, 2, 4, 6),
#' y = 0,
#' yend = 2
#' )
#'
#' # See how control points affect the bezier
#' ggplot() +
#' geom_segment(aes(x = x, xend = xend, y = y, yend = yend),
#' data = help_lines,
#' arrow = arrow(length = unit(c(0, 0, 0.5, 0.5), 'cm')),
#' colour = 'grey') +
#' geom_bezier(aes(x = x, y = y, group = type, linetype = type),
#' data = beziers) +
#' geom_point(aes(x = x, y = y, colour = point),
#' data = beziers)
#'
#' # geom_bezier0 is less exact
#' ggplot() +
#' geom_segment(aes(x = x, xend = xend, y = y, yend = yend),
#' data = help_lines,
#' arrow = arrow(length = unit(c(0, 0, 0.5, 0.5), 'cm')),
#' colour = 'grey') +
#' geom_bezier0(aes(x = x, y = y, group = type, linetype = type),
#' data = beziers) +
#' geom_point(aes(x = x, y = y, colour = point),
#' data = beziers)
#'
#' # Use geom_bezier2 to interpolate between endpoint aesthetics
#' ggplot(beziers) +
#' geom_bezier2(aes(x = x, y = y, group = type, colour = colour))
#'
NULL
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatBezier <- ggproto('StatBezier', Stat,
compute_panel = function(data, scales, n = 100) {
if (empty_data(data)) return(data)
nControls <- table(data$group)
controlRange <- range(nControls)
if (min(controlRange) < 3 || max(controlRange) > 4) {
cli::cli_abort(c(
'Only support for quadratic and cubic beziers',
i = 'Make sure each group consists of 3 or 4 rows'
))
}
data <- data[order(data$group), ]
groups <- unique0(data$group)
paths <- getBeziers(data$x, data$y, match(data$group, groups), n)
paths <- data_frame0(
x = paths$paths[, 1], y = paths$paths[, 2],
group = groups[paths$pathID]
)
paths$index <- rep(seq(0, 1, length.out = n), length(nControls))
dataIndex <- rep(match(unique0(data$group), data$group), each = n)
cbind(
paths,
data[dataIndex, !names(data) %in% c('x', 'y', 'group'), drop = FALSE]
)
},
required_aes = c('x', 'y'),
extra_params = c('na.rm', 'n')
)
#' @rdname geom_bezier
#' @export
stat_bezier <- function(mapping = NULL, data = NULL, geom = 'path',
position = 'identity', na.rm = FALSE, show.legend = NA,
n = 100, inherit.aes = TRUE, ...) {
layer(
stat = StatBezier, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, n = n, ...)
)
}
#' @rdname geom_bezier
#' @export
geom_bezier <- function(mapping = NULL, data = NULL, stat = 'bezier',
position = 'identity', arrow = NULL, lineend = 'butt',
na.rm = FALSE, show.legend = NA, inherit.aes = TRUE,
n = 100, ...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomPath,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(
arrow = arrow, lineend = lineend, na.rm = na.rm, n = n,
...
)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatBezier2 <- ggproto('StatBezier2', Stat,
compute_layer = function(self, data, params, panels) {
if (empty_data(data)) return(data)
data <- data[order(data$group), ]
nControls <- table(data$group)
controlRange <- range(nControls)
if (min(controlRange) < 3 || max(controlRange) > 4) {
cli::cli_abort(c(
'Only support for quadratic and cubic beziers',
i = 'Make sure each group consists of 3 or 4 rows'
))
}
groups <- unique0(data$group)
paths <- getBeziers(data$x, data$y, match(data$group, groups), params$n)
paths <- data_frame0(
x = paths$paths[, 1], y = paths$paths[, 2],
group = groups[paths$pathID]
)
paths$index <- rep(seq(0, 1, length.out = params$n), length(nControls))
dataIndex <- rep(match(unique0(data$group), data$group), each = params$n)
paths <- cbind(paths, data[dataIndex, 'PANEL', drop = FALSE])
extraCols <- !names(data) %in% c('x', 'y', 'group', 'PANEL')
startIndex <- c(1, cumsum(nControls) + 1)[-(length(nControls) + 1)]
endIndex <- c(startIndex[-1] - 1, nrow(data))
dataIndex <- c(startIndex, endIndex)
pathIndex <- match(unique0(data$group), paths$group)
pathIndex <- c(pathIndex, pathIndex + 1)
paths$.interp <- TRUE
paths$.interp[pathIndex] <- FALSE
if (any(extraCols)) {
for (i in names(data)[extraCols]) {
paths[[i]] <- data[[i]][1]
paths[[i]][pathIndex] <- data[dataIndex, i]
}
}
paths
},
required_aes = c('x', 'y'),
extra_params = c('na.rm', 'n')
)
#' @rdname geom_bezier
#' @export
stat_bezier2 <- function(mapping = NULL, data = NULL, geom = 'path_interpolate',
position = 'identity', na.rm = FALSE, show.legend = NA,
n = 100, inherit.aes = TRUE, ...) {
layer(
stat = StatBezier2, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, n = n, ...)
)
}
#' @rdname geom_bezier
#' @export
geom_bezier2 <- function(mapping = NULL, data = NULL, stat = 'bezier2',
position = 'identity', arrow = NULL, lineend = 'butt',
na.rm = FALSE, show.legend = NA, inherit.aes = TRUE,
n = 100, ...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomPathInterpolate,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(
arrow = arrow, lineend = lineend, na.rm = na.rm, n = n,
...
)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatBezier0 <- ggproto('StatBezier0', Stat,
compute_panel = function(data, scales) {
if (empty_data(data)) return(data)
data <- data[order(data$group), ]
nControls <- table(data$group)
controlRange <- range(nControls)
if (min(controlRange) < 3 || max(controlRange) > 4) {
cli::cli_abort(c(
'Only support for quadratic and cubic beziers',
i = 'Make sure each group consists of 3 or 4 rows'
))
}
quadratic <- nControls == 3
if (any(quadratic)) {
controlIndex <- c(1, cumsum(nControls) + 1)[-(length(nControls) + 1)]
extraRows <- controlIndex[quadratic] + 1
extraRows <- sort(c(seq_len(nrow(data)), extraRows))
data <- data[extraRows, ]
}
data
},
required_aes = c('x', 'y')
)
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @importFrom grid bezierGrob gpar
#' @export
GeomBezier0 <- ggproto('GeomBezier0', GeomPath,
draw_panel = function(data, panel_scales, coord, arrow = NULL,
lineend = 'butt', linejoin = 'round', linemitre = 1,
na.rm = FALSE) {
coords <- coord$transform(data, panel_scales)
if (!is.integer(coords$group)) {
coords$group <- match(coords$group, unique0(coords$group))
}
startPoint <- match(unique0(coords$group), coords$group)
bezierGrob(coords$x, coords$y,
id = coords$group, default.units = 'native',
arrow = arrow,
gp = gpar(
col = alpha(coords$colour[startPoint], coords$alpha[startPoint]),
lwd = (coords$linewidth[startPoint] %||% coords$size[startPoint]) * .pt,
lty = coords$linetype[startPoint], lineend = lineend,
linejoin = linejoin, linemitre = linemitre
)
)
}
)
#' @rdname geom_bezier
#' @export
stat_bezier0 <- function(mapping = NULL, data = NULL, geom = 'bezier0',
position = 'identity', na.rm = FALSE, show.legend = NA,
inherit.aes = TRUE, ...) {
layer(
stat = StatBezier0, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, ...)
)
}
#' @rdname geom_bezier
#' @export
geom_bezier0 <- function(mapping = NULL, data = NULL, stat = 'bezier0',
position = 'identity', arrow = NULL, lineend = 'butt',
na.rm = FALSE, show.legend = NA, inherit.aes = TRUE,
...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomBezier0,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(arrow = arrow, lineend = lineend, na.rm = na.rm, ...)
)
}
ggforce/R/trans.R 0000644 0001762 0000144 00000014144 14303354474 013354 0 ustar ligges users #' Create a power transformation object
#'
#' This function can be used to create a proper trans object that encapsulates
#' a power transformation (x^n).
#'
#' @param n The degree of the power transformation
#'
#' @return A trans object
#'
#' @importFrom scales trans_new extended_breaks format_format
#' @importFrom MASS fractions
#'
#' @export
#'
#' @examples
#' # Power of 2 transformations
#' trans <- power_trans(2)
#' trans$transform(1:10)
#'
#' # Cubic root transformation
#' trans <- power_trans(1 / 3)
#' trans$transform(1:10)
#'
#' # Use it in a plot
#' ggplot() +
#' geom_line(aes(x = 1:10, y = 1:10)) +
#' scale_x_continuous(trans = power_trans(2),
#' expand = c(0, 1))
power_trans <- function(n) {
trans_new(
name = paste0('power of ', fractions(n)),
transform = function(x) {
x^n
},
inverse = function(x) {
x^(1 / n)
},
breaks = extended_breaks(),
format = format_format(),
domain = c(0, Inf)
)
}
#' Create radial data in a cartesian coordinate system
#'
#' This function creates a trans object that converts radial data to their
#' corresponding coordinates in cartesian space. The trans object is created for
#' a specific radius and angle range that will be mapped to the unit circle so
#' data doesn't have to be normalized to 0-1 and 0-2*pi in advance. While there
#' exists a clear mapping from radial to cartesian, the inverse is not true as
#' radial representation is periodic. It is impossible to know how many
#' revolutions around the unit circle a point has taken from reading its
#' coordinates. The inverse function will always assume that coordinates are in
#' their first revolution i.e. map them back within the range of a.range.
#'
#' @param r.range The range in radius that correspond to 0 - 1 in the unit
#' circle.
#'
#' @param a.range The range in angles that correspond to 2*pi - 0. As radians
#' are normally measured counterclockwise while radial displays are read
#' clockwise it's an inverse mapping
#'
#' @param offset The offset in angles to apply. Determines that start position
#' on the circle. pi/2 (the default) corresponds to 12 o'clock.
#'
#' @param pad Adds to the end points of the angle range in order to separate the
#' start and end point. Defaults to 0.5
#'
#' @param clip Should input data be clipped to r.range and a.range or be allowed
#' to extend beyond. Defaults to FALSE (no clipping)
#'
#' @return A trans object. The transform method for the object takes an r
#' (radius) and a (angle) argument and returns a data.frame with x and y columns
#' with rows for each element in r/a. The inverse method takes an x and y
#' argument and returns a data.frame with r and a columns and rows for each
#' element in x/y.
#'
#' @note While trans objects are often used to modify scales in ggplot2, radial
#' transformation is different as it is a coordinate transformation and takes
#' two arguments. Consider it a trans version of coord_polar and use it to
#' transform your data prior to plotting.
#'
#' @importFrom scales trans_new extended_breaks format_format
#'
#' @export
#'
#' @examples
#' # Some data in radial form
#' rad <- data.frame(r = seq(1, 10, by = 0.1), a = seq(1, 10, by = 0.1))
#'
#' # Create a transformation
#' radial <- radial_trans(c(0, 1), c(0, 5))
#'
#' # Get data in x, y
#' cart <- radial$transform(rad$r, rad$a)
#'
#' # Have a look
#' ggplot() +
#' geom_path(aes(x = x, y = y), data = cart, color = 'forestgreen') +
#' geom_path(aes(x = r, y = a), data = rad, color = 'firebrick')
radial_trans <- function(r.range, a.range, offset = pi / 2, pad = 0.5,
clip = FALSE) {
a.range[which.min(a.range)] <- min(a.range) - pad
a.range[which.max(a.range)] <- max(a.range) + pad
trans_new(
name = paste0(
'radial-to-cartesian: ',
r.range[1], '-', r.range[2], ' -> 0-1; ',
a.range[1], '-', a.range[2], ' -> 2pi-0'
),
transform = function(r, a) {
if (clip) {
r[r < min(r.range)] <- min(r.range)
r[r > max(r.range)] <- max(r.range)
a[a < min(a.range)] <- min(a.range)
a[a > max(a.range)] <- max(a.range)
}
if (diff(r.range) == 0) {
r <- 1
} else {
r <- (r - r.range[1]) / diff(r.range)
}
if (diff(a.range) == 0) {
a <- offset
} else {
a <- offset + (a - a.range[1]) / diff(a.range) * -2 * pi
}
data_frame0(x = r * cos(a), y = r * sin(a))
},
inverse = function(x, y) {
r <- sqrt(x^2 + y^2) * diff(r.range) + r.range[1]
angle <- -(atan2(y, x) - offset)
angle[angle < 0] <- 2 * pi + angle[angle < 0]
a <- angle / (2 * pi) * diff(a.range) + a.range[1]
data_frame0(r = r, a = a)
},
breaks = extended_breaks(),
format = format_format()
)
}
#' Reverse a transformation
#'
#' While the scales package export a reverse_trans object it does not allow for
#' reversing of already transformed ranged - e.g. a reverse exp transformation
#' is not possible. trans_reverser takes a trans object or something coercible
#' to one and creates a reverse version of it.
#'
#' @param trans A trans object or an object that can be converted to one using
#' [scales::as.trans()]
#'
#' @return A trans object
#'
#' @importFrom scales as.trans trans_new asn_trans atanh_trans boxcox_trans
#' date_trans exp_trans identity_trans log10_trans log1p_trans log2_trans
#' logit_trans log_trans probability_trans probit_trans reciprocal_trans
#' reverse_trans sqrt_trans time_trans
#'
#' @export
#'
#' @examples
#' # Lets make a plot
#' p <- ggplot() +
#' geom_line(aes(x = 1:10, y = 1:10))
#'
#' # scales already have a reverse trans
#' p + scale_x_continuous(trans = 'reverse')
#'
#' # But what if you wanted to reverse an already log transformed scale?
#' p + scale_x_continuous(trans = trans_reverser('log'))
trans_reverser <- function(trans) {
transformOrig <- as.trans(trans)
trans_new(
name = paste0('reverse-', transformOrig$name),
transform = function(x) {
-transformOrig$transform(x)
},
inverse = function(x) {
transformOrig$inverse(-x)
},
breaks = transformOrig$breaks,
format = transformOrig$format,
domain = transformOrig$domain
)
}
ggforce/R/spiro.R 0000644 0001762 0000144 00000010244 14564603246 013361 0 ustar ligges users #' Draw spirograms based on the radii of the different "wheels" involved
#'
#' This, rather pointless, geom allows you to draw spirograms, as known from the
#' popular drawing toy where lines were traced by inserting a pencil into a hole
#' in a small gear that would then trace around inside another gear. The
#' potential practicality of this geom is slim and it excists mainly for fun and
#' art.
#'
#' @section Aesthetics:
#' stat_spiro and geom_spiro understand the following aesthetics (required
#' aesthetics are in bold):
#'
#' - **R**
#' - **r**
#' - **d**
#' - x0
#' - y0
#' - outer
#' - color
#' - size
#' - linetype
#' - alpha
#'
#' @section Computed variables:
#'
#' \describe{
#' \item{x, y}{The coordinates for the path describing the spirogram}
#' \item{index}{The progression along the spirogram mapped between 0 and 1}
#' }
#'
#' @inheritParams ggplot2::geom_path
#' @inheritParams ggplot2::stat_identity
#'
#' @param n The number of points that should be used to draw a fully closed
#' spirogram. If `revolutions < 1` the actual number of points will be less
#' than this.
#'
#' @param revolutions The number of times the inner gear should revolve around
#' inside the outer gear. If `NULL` the number of revolutions to reach the
#' starting position is calculated and used.
#'
#' @name geom_spiro
#' @rdname geom_spiro
#'
#' @examples
#' # Basic usage
#' ggplot() +
#' geom_spiro(aes(R = 10, r = 3, d = 5))
#'
#' # Only draw a portion
#' ggplot() +
#' geom_spiro(aes(R = 10, r = 3, d = 5), revolutions = 1.2)
#'
#' # Let the inner gear circle the outside of the outer gear
#' ggplot() +
#' geom_spiro(aes(R = 10, r = 3, d = 5, outer = TRUE))
NULL
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @importFrom MASS fractions
#' @export
StatSpiro <- ggproto('StatSpiro', Stat,
compute_panel = function(data, scales, n = 500, revolutions = NULL) {
if (empty_data(data)) return(data)
if (is.null(data$outer)) data$outer <- FALSE
if (is.null(data$x0)) data$x0 <- 0
if (is.null(data$y0)) data$y0 <- 0
n_spiro <- nrow(data)
data$group <- make_unique(as.character(data$group))
if (is.null(revolutions)) {
revo <- attr(fractions(data$r / data$R), 'fracs')
revo <- as.numeric(sub('/.*$', '', revo))
} else {
revo <- revolutions
}
data <- data[rep(seq_len(n_spiro), n * revo), ]
data$rho <- unlist(lapply(revo, function(r) {
seq(0, 2 * pi * r, length.out = n * r)
}))
data$index <- unlist(lapply(revo, function(r) {
seq(0, 1, length.out = n * r)
}))
data$x <- data$x0 + ifelse(
data$outer,
(data$R + data$r) * cos(data$rho) - data$d * cos(data$rho * (data$R + data$r) / data$r),
(data$R - data$r) * cos(data$rho) + data$d * cos(data$rho * (data$R - data$r) / data$r)
)
data$y <- data$y0 + ifelse(
data$outer,
(data$R + data$r) * sin(data$rho) - data$d * sin(data$rho * (data$R + data$r) / data$r),
(data$R - data$r) * sin(data$rho) - data$d * sin(data$rho * (data$R - data$r) / data$r)
)
data
},
required_aes = c('R', 'r', 'd'),
default_aes = aes(outer = FALSE, x0 = 0, y0 = 0),
extra_params = c('na.rm', 'n', 'revolutions')
)
#' @rdname geom_spiro
#' @export
stat_spiro <- function(mapping = NULL, data = NULL, geom = 'path',
position = 'identity', na.rm = FALSE, n = 500,
revolutions = NULL, show.legend = NA, inherit.aes = TRUE,
...) {
layer(
stat = StatSpiro, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, n = n, revolutions = revolutions, ...)
)
}
#' @rdname geom_spiro
#' @export
geom_spiro <- function(mapping = NULL, data = NULL, stat = 'spiro',
position = 'identity', arrow = NULL, n = 500,
lineend = 'butt', na.rm = FALSE, show.legend = NA,
inherit.aes = TRUE, ...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomPath,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(arrow = arrow, lineend = lineend, na.rm = na.rm, n = n, ...)
)
}
ggforce/R/arc.R 0000644 0001762 0000144 00000017736 14564603246 013007 0 ustar ligges users #' @include arc_bar.R
NULL
#' Arcs based on radius and radians
#'
#' This set of stats and geoms makes it possible to draw circle segments based
#' on a center point, a radius and a start and end angle (in radians). These
#' functions are intended for cartesian coordinate systems and makes it possible
#' to create circular plot types without using the
#' [ggplot2::coord_polar()] coordinate system.
#'
#' @details An arc is a segment of a line describing a circle. It is the
#' fundamental visual element in donut charts where the length of the segment
#' (and conversely the angular span of the segment) describes the proportion of
#' an entety.
#'
#' @section Aesthetics:
#' geom_arc understand the following aesthetics (required aesthetics are in
#' bold):
#'
#' - **x0**
#' - **y0**
#' - **r**
#' - **start**
#' - **end**
#' - color
#' - linewidth
#' - linetype
#' - alpha
#' - lineend
#'
#' @section Computed variables:
#'
#' \describe{
#' \item{x, y}{The start coordinates for the segment}
#' \item{xend, yend}{The end coordinates for the segment}
#' \item{curvature}{The curvature of the curveGrob to match a circle}
#' }
#'
#' @inheritParams ggplot2::geom_path
#' @inheritParams ggplot2::stat_identity
#'
#' @param n the smoothness of the arc. Sets the number of points to use if the
#' arc would cover a full circle
#'
#' @param ncp the number of control points used to draw the arc with curveGrob.
#' Determines how well the arc approximates a circle section
#'
#' @name geom_arc
#' @rdname geom_arc
#' @seealso [geom_arc_bar()] for drawing arcs with fill
#'
#' @examples
#' # Lets make some data
#' arcs <- data.frame(
#' start = seq(0, 2 * pi, length.out = 11)[-11],
#' end = seq(0, 2 * pi, length.out = 11)[-1],
#' r = rep(1:2, 5)
#' )
#'
#' # Behold the arcs
#' ggplot(arcs) +
#' geom_arc(aes(x0 = 0, y0 = 0, r = r, start = start, end = end,
#' linetype = factor(r)))
#'
#' # Use the calculated index to map values to position on the arc
#' ggplot(arcs) +
#' geom_arc(aes(x0 = 0, y0 = 0, r = r, start = start, end = end,
#' size = after_stat(index)), lineend = 'round')
#'
#' # The 0 version maps directly to curveGrob instead of calculating the points
#' # itself
#' ggplot(arcs) +
#' geom_arc0(aes(x0 = 0, y0 = 0, r = r, start = start, end = end,
#' linetype = factor(r)))
#'
#' # The 2 version allows interpolation of aesthetics between the start and end
#' # points
#' arcs2 <- data.frame(
#' angle = c(arcs$start, arcs$end),
#' r = rep(arcs$r, 2),
#' group = rep(1:10, 2),
#' colour = sample(letters[1:5], 20, TRUE)
#' )
#'
#' ggplot(arcs2) +
#' geom_arc2(aes(x0 = 0, y0 = 0, r = r, end = angle, group = group,
#' colour = colour), size = 2)
#'
NULL
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatArc <- ggproto('StatArc', Stat,
compute_panel = function(data, scales, n = 360) {
arcPaths(data, n)
},
required_aes = c('x0', 'y0', 'r', 'start', 'end')
)
#' @rdname geom_arc
#' @export
stat_arc <- function(mapping = NULL, data = NULL, geom = 'arc',
position = 'identity', na.rm = FALSE, show.legend = NA,
n = 360, inherit.aes = TRUE, ...) {
layer(
stat = StatArc, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, n = n, ...)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @importFrom grid curveGrob gList gpar
#' @export
GeomArc <- ggproto('GeomArc', GeomPath)
#' @rdname geom_arc
#' @export
geom_arc <- function(mapping = NULL, data = NULL, stat = 'arc',
position = 'identity', n = 360, arrow = NULL,
lineend = 'butt', na.rm = FALSE, show.legend = NA,
inherit.aes = TRUE, ...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomArc,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(arrow = arrow, n = n, lineend = lineend, na.rm = na.rm, ...)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatArc2 <- ggproto('StatArc2', Stat,
compute_panel = function(data, scales, n = 360) {
arcPaths2(data, n)
},
required_aes = c('x0', 'y0', 'r', 'group', 'end')
)
#' @rdname geom_arc
#' @export
stat_arc2 <- function(mapping = NULL, data = NULL, geom = 'path_interpolate',
position = 'identity', na.rm = FALSE, show.legend = NA,
n = 360, inherit.aes = TRUE, ...) {
layer(
stat = StatArc2, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, n = n, ...)
)
}
#' @rdname geom_arc
#' @export
geom_arc2 <- function(mapping = NULL, data = NULL, stat = 'arc2',
position = 'identity', n = 360, arrow = NULL,
lineend = 'butt', na.rm = FALSE, show.legend = NA,
inherit.aes = TRUE, ...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomPathInterpolate,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(arrow = arrow, n = n, lineend = lineend, na.rm = na.rm, ...)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @importFrom grid arcCurvature
#' @export
StatArc0 <- ggproto('StatArc0', Stat,
compute_panel = function(data, scales) {
data$x <- data$x0 + data$r * sin(data$start)
data$y <- data$y0 + data$r * cos(data$start)
data$xend <- data$x0 + data$r * sin(data$end)
data$yend <- data$y0 + data$r * cos(data$end)
deltaA <- (data$start - data$end) * 180 / pi
data$curvature <- sign(deltaA) * sapply(abs(deltaA), arcCurvature)
data
},
required_aes = c('x0', 'y0', 'r', 'start', 'end')
)
#' @rdname geom_arc
#' @export
stat_arc0 <- function(mapping = NULL, data = NULL, geom = 'arc0',
position = 'identity', na.rm = FALSE, show.legend = NA,
inherit.aes = TRUE, ...) {
layer(
stat = StatArc0, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, ...)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @importFrom grid curveGrob gList gpar
#' @export
GeomArc0 <- ggproto('GeomArc0', Geom,
required_aes = c('x0', 'y0', 'r', 'start', 'end'),
default_aes = aes(colour = 'black', linewidth = 0.5, linetype = 1, alpha = 1),
draw_key = draw_key_path,
draw_panel = function(self, data, panel_scales, coord, ncp = 5, arrow = NULL,
lineend = 'butt', na.rm = FALSE) {
if (!coord$is_linear()) {
cli::cli_abort('{.fn {snake_class(self)}} is not implemented for non-linear coordinates')
}
trans <- coord$transform(data, panel_scales)
grobs <- lapply(seq_len(nrow(trans)), function(i) {
curveGrob(trans$x[i], trans$y[i], trans$xend[i], trans$yend[i],
default.units = 'native',
curvature = data$curvature[i], angle = 90, ncp = ncp, square = FALSE,
squareShape = 1, inflect = FALSE, open = TRUE, gp = gpar(
col = alpha(
trans$colour[i],
trans$alpha[i]
), lwd = (trans$linewidth[i] %||% trans$size[i]) * .pt, lty = trans$linetype[i],
lineend = trans$lineend[i]
), arrow = arrow[i]
)
})
inject(gList(!!!grobs))
},
rename_size = TRUE,
non_missing_aes = "size"
)
#' @rdname geom_arc
#' @export
geom_arc0 <- function(mapping = NULL, data = NULL, stat = 'arc0',
position = 'identity', ncp = 5, arrow = NULL,
lineend = 'butt', na.rm = FALSE, show.legend = NA,
inherit.aes = TRUE, ...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomArc0,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(
arrow = arrow, ncp = ncp, lineend = lineend, na.rm = na.rm,
...
)
)
}
ggforce/R/link.R 0000644 0001762 0000144 00000014135 14564603246 013165 0 ustar ligges users #' Link points with paths
#'
#' This set of geoms makes it possible to connect points using straight lines.
#' Before you think [ggplot2::geom_segment()] and
#' [ggplot2::geom_path()], these functions have some additional tricks
#' up their sleeves. geom_link connects two points in the same way as
#' [ggplot2::geom_segment()] but does so by interpolating multiple
#' points between the two. An additional column called index is added to the
#' data with a sequential progression of the interpolated points. This can be
#' used to map color or size to the direction of the link. geom_link2 uses the
#' same syntax as [ggplot2::geom_path()] but interpolates between the
#' aesthetics given by each row in the data.
#'
#' @section Aesthetics:
#' geom_link understand the following aesthetics (required aesthetics are in
#' bold):
#'
#' - **x**
#' - **y**
#' - **xend**
#' - **yend**
#' - color
#' - size
#' - linetype
#' - alpha
#' - lineend
#'
#' geom_link2 understand the following aesthetics (required aesthetics are in
#' bold):
#'
#' - **x**
#' - **y**
#' - color
#' - size
#' - linetype
#' - alpha
#' - lineend
#'
#' @section Computed variables:
#'
#' \describe{
#' \item{x, y}{The interpolated point coordinates}
#' \item{index}{The progression along the interpolation mapped between 0 and 1}
#' }
#'
#' @inheritParams ggplot2::geom_path
#' @inheritParams ggplot2::geom_segment
#' @inheritParams ggplot2::stat_identity
#'
#' @param n The number of points to create for each segment
#'
#' @name geom_link
#' @rdname geom_link
#'
#' @examples
#' # Lets make some data
#' lines <- data.frame(
#' x = c(5, 12, 15, 9, 6),
#' y = c(17, 20, 4, 15, 5),
#' xend = c(19, 17, 2, 9, 5),
#' yend = c(10, 18, 7, 12, 1),
#' width = c(1, 10, 6, 2, 3),
#' colour = letters[1:5]
#' )
#'
#' ggplot(lines) +
#' geom_link(aes(x = x, y = y, xend = xend, yend = yend, colour = colour,
#' alpha = stat(index), size = after_stat(index)))
#'
#' ggplot(lines) +
#' geom_link2(aes(x = x, y = y, colour = colour, size = width, group = 1),
#' lineend = 'round', n = 500)
#'
#' # geom_link0 is simply an alias for geom_segment to put the link geoms in
#' # line with the other line geoms with multiple versions. `index` is not
#' # available here
#' ggplot(lines) +
#' geom_link0(aes(x = x, y = y, xend = xend, yend = yend, colour = colour))
NULL
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatLink <- ggproto('StatLink', Stat,
compute_panel = function(data, scales, n = 100) {
extraCols <- !names(data) %in% c('x', 'y', 'xend', 'yend', 'group', 'PANEL')
data$group <- make_unique(as.character(data$group))
data <- lapply(seq_len(nrow(data)), function(i) {
path <- data_frame0(
x = seq(data$x[i], data$xend[i], length.out = n),
y = seq(data$y[i], data$yend[i], length.out = n),
index = seq(0, 1, length.out = n),
group = data$group[i]
)
cbind(path, data[rep(i, n), extraCols, drop = FALSE])
})
vec_rbind(!!!data)
},
required_aes = c('x', 'y', 'xend', 'yend')
)
#' @rdname geom_link
#' @export
stat_link <- function(mapping = NULL, data = NULL, geom = 'path',
position = 'identity', na.rm = FALSE, show.legend = NA,
n = 100, inherit.aes = TRUE, ...) {
layer(
stat = StatLink, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, n = n, ...)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @importFrom tweenr tween_t
#' @export
StatLink2 <- ggproto('StatLink2', Stat,
compute_panel = function(data, scales, n = 100) {
extraCols <- !names(data) %in% c('x', 'y', 'group', 'PANEL', 'frame')
extraCols <- names(data)[extraCols]
data <- dapply(data, 'group', function(df) {
n_group <- n * (nrow(df) - 1) + 1
interp <- tween_t(list(df$x, df$y), n_group)
interp <- data_frame0(x = interp[[1]], y = interp[[2]])
interp <- cbind(interp,
index = seq(0, 1, length.out = n_group),
group = df$group[1],
PANEL = df$PANEL[1]
)
if ('frame' %in% names(df)) interp$frame <- df$frame[1]
nIndex <- seq_len(nrow(interp))
if (length(extraCols) > 0) {
cbind(interp, df[nIndex, extraCols, drop = FALSE],
.interp = nIndex > nrow(df))
} else {
cbind(interp, .interp = nIndex > nrow(df))
}
})
data[data$.interp, extraCols] <- data[1, extraCols, drop = FALSE]
data
},
required_aes = c('x', 'y')
)
#' @rdname geom_link
#' @export
stat_link2 <- function(mapping = NULL, data = NULL, geom = 'path_interpolate',
position = 'identity', na.rm = FALSE, show.legend = NA,
n = 100, inherit.aes = TRUE, ...) {
layer(
stat = StatLink2, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, n = n, ...)
)
}
#' @rdname geom_link
#' @export
geom_link <- function(mapping = NULL, data = NULL, stat = 'link',
position = 'identity', arrow = NULL, lineend = 'butt',
na.rm = FALSE, show.legend = NA, inherit.aes = TRUE,
n = 100, ...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomPath,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(
arrow = arrow, lineend = lineend, na.rm = na.rm, n = n,
...
)
)
}
#' @rdname geom_link
#' @export
geom_link2 <- function(mapping = NULL, data = NULL, stat = 'link2',
position = 'identity', arrow = NULL, lineend = 'butt',
na.rm = FALSE, show.legend = NA, inherit.aes = TRUE,
n = 100, ...) {
layer(
data = data, mapping = mapping, stat = stat, geom = GeomPathInterpolate,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(
arrow = arrow, lineend = lineend, na.rm = na.rm, n = n,
...
)
)
}
#' @rdname geom_link
#' @export
geom_link0 <- geom_segment
ggforce/R/position_auto.R 0000644 0001762 0000144 00000010572 14303360313 015107 0 ustar ligges users #' Jitter based on scale types
#'
#' This position adjustment is able to select a meaningful jitter of the data
#' based on the combination of positional scale types. IT behaves differently
#' depending on if none, one, or both the x and y scales are discrete. If both
#' are discrete it will jitter the datapoints evenly inside a disc, if one of
#' them is discrete it will jitter the discrete dimension to follow the density
#' along the other dimension (like a sina plot). If neither are discrete it will
#' not do any jittering.
#'
#' @param jitter.width The maximal width of the jitter
#' @param bw The smoothing bandwidth to use in the case of sina jittering. See
#' the `bw` argument in [stats::density]
#' @param scale Should the width of jittering be scaled based on the number of
#' points in the group
#' @param seed A seed to supply to make the jittering reproducible across layers
#'
#' @seealso [geom_autopoint] for a point geom that uses auto-position by default
#'
#' @export
#'
#' @examples
#' # Continuous vs continuous: No jitter
#' ggplot(mpg) + geom_point(aes(cty, hwy), position = 'auto')
#'
#' # Continuous vs discrete: sina jitter
#' ggplot(mpg) + geom_point(aes(cty, drv), position = 'auto')
#'
#' # Discrete vs discrete: disc-jitter
#' ggplot(mpg) + geom_point(aes(fl, drv), position = 'auto')
#'
#' # Don't scale the jitter based on group size
#' ggplot(mpg) + geom_point(aes(cty, drv), position = position_auto(scale = FALSE))
#' ggplot(mpg) + geom_point(aes(fl, drv), position = position_auto(scale = FALSE))
#'
position_auto <- function(jitter.width = 0.75, bw = 'nrd0', scale = TRUE, seed = NA) {
if (!is.null(seed) && is.na(seed)) {
seed <- sample.int(.Machine$integer.max, 1L)
}
ggproto(NULL, PositionAuto,
jitter.width = jitter.width,
seed = seed, bw = bw, scale = scale
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
#' @importFrom withr with_seed
PositionAuto <- ggproto('PositionAuto', Position,
jitter.width = 0.75,
seed = NULL,
bw = 'nrd0',
scale = TRUE,
setup_params = function(self, data) {
list(jitter.width = self$jitter.width, bw = self$bw, seed = self$seed, scale = self$scale)
},
compute_panel = function(data, params, scales) {
discrete_x <- scales$x$is_discrete()
discrete_y <- scales$y$is_discrete()
if (!discrete_x && !discrete_y) {
return(data)
}
if (discrete_x && discrete_y) {
comb <- table(data$x, data$y)
max_n <- max(comb)
if (params$scale) {
weight <- sqrt(comb[cbind(as.character(data$x), as.character(data$y))] / max_n) * (params$jitter.width / 2)
} else {
weight <- params$jitter.width / 2
}
if (is.null(params$seed)) {
adj <- sample_disc(length(data$x), weight)
} else {
adj <- with_seed(params$seed, sample_disc(length(data$x), weight))
}
data$x <- data$x + adj$x
data$y <- data$y + adj$y
data
} else {
trans_x <- trans_y <- identity
if (discrete_x) {
trans_x <- function(x) x + sina_trans(x, data$y, params$jitter.width / 2, params$bw, params$scale)
} else {
trans_y <- function(x) x + sina_trans(x, data$x, params$jitter.width / 2, params$bw, params$scale)
}
if (is.null(params$seed)) {
transform_position(data, trans_x, trans_y)
} else {
with_seed(params$seed, transform_position(data, trans_x, trans_y))
}
}
}
)
sina_trans <- function(x, val, max_width, bw = 'nrd0', scale = TRUE) {
max_size <- max(table(x))
by_ind <- split(seq_along(x), x)
x_new <- unlist(lapply(by_ind, function(i) {
val_x <- val[i]
if (length(unique0(val_x)) < 2) {
return(stats::runif(length(val_x), min = -max_width, max = max_width))
}
if (length(val_x) < 3) {
return(0)
}
range <- range(val_x, na.rm = TRUE)
bw <- calc_bw(val_x, bw)
dens <- stats::density(val_x, bw = bw, from = range[1], to = range[2])
densf <- stats::approxfun(dens$x, dens$y, rule = 2)
x_mod <- densf(val_x)
x_mod <- x_mod / max(x_mod)
if (scale) x_mod <- x_mod * length(val_x) / max_size
stats::runif(length(val_x), min = -1, max = 1) * max_width * x_mod
}))
x_new[match(seq_along(x), unlist(by_ind))]
}
sample_disc <- function(n, r_disc = 1) {
r = sqrt(stats::runif(n, 0, 1))
theta = stats::runif(n, 0, 2*pi)
x <- r * cos(theta) * r_disc
y <- r * sin(theta) * r_disc
list(x = x, y = y)
}
ggforce/R/mark_ellipse.R 0000644 0001762 0000144 00000030442 14564603246 014676 0 ustar ligges users #' Annotate areas with ellipses
#'
#' This geom lets you annotate sets of points via ellipses. The enclosing
#' ellipses are estimated using the Khachiyan algorithm which guarantees an
#' optimal solution within the given tolerance level. As this geom is often
#' expanded it is of lesser concern that some points are slightly outside the
#' ellipsis. The Khachiyan algorithm has polynomial complexity and can thus
#' suffer from scaling issues. Still, it is only calculated on the convex hull
#' of the groups, so performance issues should be rare (it can easily handle a
#' hull consisting of 1000 points).
#'
#' @inheritSection geom_mark_circle Annotation
#' @inheritSection geom_mark_circle Filtering
#' @section Aesthetics:
#' `geom_mark_ellipse` understands the following aesthetics (required aesthetics are
#' in bold):
#'
#' - **x**
#' - **y**
#' - x0 *(used to anchor the label)*
#' - y0 *(used to anchor the label)*
#' - filter
#' - label
#' - description
#' - color
#' - fill
#' - group
#' - size
#' - linetype
#' - alpha
#'
#' @inheritParams geom_mark_circle
#'
#' @param n The number of points used to draw each ellipse. Defaults to `100`.
#' @param tol The tolerance cutoff. Lower values will result in ellipses closer
#' to the optimal solution. Defaults to `0.01`.
#'
#' @family mark geoms
#'
#' @name geom_mark_ellipse
#' @rdname geom_mark_ellipse
#'
#' @examples
#' ggplot(iris, aes(Petal.Length, Petal.Width)) +
#' geom_mark_ellipse(aes(fill = Species, filter = Species != 'versicolor')) +
#' geom_point()
#'
#' # Add annotation
#' ggplot(iris, aes(Petal.Length, Petal.Width)) +
#' geom_mark_ellipse(aes(fill = Species, label = Species)) +
#' geom_point()
#'
#' # Long descriptions are automatically wrapped to fit into the width
#' iris$desc <- c(
#' 'A super Iris - and it knows it',
#' 'Pretty mediocre Iris, but give it a couple of years and it might surprise you',
#' "You'll never guess what this Iris does every Sunday"
#' )[iris$Species]
#'
#' ggplot(iris, aes(Petal.Length, Petal.Width)) +
#' geom_mark_ellipse(aes(fill = Species, label = Species, description = desc,
#' filter = Species == 'setosa')) +
#' geom_point()
#'
#' # Change the buffer size to move labels farther away (or closer) from the
#' # marks
#' ggplot(iris, aes(Petal.Length, Petal.Width)) +
#' geom_mark_ellipse(aes(fill = Species, label = Species),
#' label.buffer = unit(40, 'mm')) +
#' geom_point()
#'
#' # The connector is capped a bit before it reaches the mark, but this can be
#' # controlled
#' ggplot(iris, aes(Petal.Length, Petal.Width)) +
#' geom_mark_ellipse(aes(fill = Species, label = Species),
#' con.cap = 0) +
#' geom_point()
NULL
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
GeomMarkEllipse <- ggproto('GeomMarkEllipse', GeomMarkCircle,
draw_panel = function(self, data, panel_params, coord, expand = unit(5, 'mm'),
radius = expand, n = 100, tol = 0.01,
label.margin = margin(2, 2, 2, 2, 'mm'),
label.width = NULL, label.minwidth = unit(50, 'mm'),
label.hjust = 0, label.buffer = unit(10, 'mm'),
label.fontsize = 12, label.family = '',
label.fontface = c('bold', 'plain'),
label.lineheight = 1,
label.fill = 'white', label.colour = 'black',
con.colour = 'black', con.size = 0.5, con.type = 'elbow',
con.linetype = 1, con.border = 'one',
con.cap = unit(3, 'mm'), con.arrow = NULL) {
if (nrow(data) == 0) return(zeroGrob())
# As long as coord$transform() doesn't recognise x0/y0
data$xmin <- data$x0
data$ymin <- data$y0
coords <- coord$transform(data, panel_params)
if (!is.integer(coords$group)) {
coords$group <- match(coords$group, unique0(coords$group))
}
coords <- coords[order(coords$group), ]
# For gpar(), there is one entry per polygon (not one entry per point).
# We'll pull the first value from each group, and assume all these values
# are the same within each group.
first_idx <- !duplicated(coords$group)
first_rows <- coords[first_idx, ]
label <- NULL
ghosts <- NULL
if (!is.null(coords$label) || !is.null(coords$description)) {
label <- first_rows
is_ghost <- which(self$removed$PANEL == coords$PANEL[1])
if (length(is_ghost) > 0) {
ghosts <- self$removed[is_ghost, ]
ghosts <- coord$transform(ghosts, panel_params)
ghosts <- list(x = ghosts$x, y = ghosts$y)
}
}
ellipEncGrob(coords$x, coords$y,
default.units = 'native',
id = coords$group, expand = expand, radius = radius, n = n,
tol = tol, label = label, ghosts = ghosts,
mark.gp = gpar(
col = first_rows$colour,
fill = alpha(first_rows$fill, first_rows$alpha),
lwd = (first_rows$linewidth %||% first_rows$size) * .pt,
lty = first_rows$linetype
),
label.gp = gpar(
col = label.colour,
fill = label.fill,
fontface = label.fontface,
fontfamily = label.family,
fontsize = label.fontsize,
lineheight = label.lineheight
),
con.gp = gpar(
col = con.colour,
fill = con.colour,
lwd = con.size * .pt,
lty = con.linetype
),
label.margin = label.margin,
label.width = label.width,
label.minwidth = label.minwidth,
label.hjust = label.hjust,
label.buffer = label.buffer,
con.type = con.type,
con.border = con.border,
con.cap = con.cap,
con.arrow = con.arrow,
anchor.x = first_rows$xmin,
anchor.y = first_rows$ymin
)
}
)
#' @rdname geom_mark_ellipse
#' @export
geom_mark_ellipse <- function(mapping = NULL, data = NULL, stat = 'identity',
position = 'identity', expand = unit(5, 'mm'),
radius = expand, n = 100, tol = 0.01,
label.margin = margin(2, 2, 2, 2, 'mm'),
label.width = NULL,
label.minwidth = unit(50, 'mm'),
label.hjust = 0, label.fontsize = 12,
label.family = '', label.lineheight = 1,
label.fontface = c('bold', 'plain'),
label.fill = 'white',
label.colour = 'black',
label.buffer = unit(10, 'mm'),
con.colour = 'black', con.size = 0.5,
con.type = 'elbow', con.linetype = 1,
con.border = 'one', con.cap = unit(3, 'mm'),
con.arrow = NULL, ..., na.rm = FALSE,
show.legend = NA, inherit.aes = TRUE) {
layer(
data = data,
mapping = mapping,
stat = stat,
geom = GeomMarkEllipse,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
na.rm = na.rm,
expand = expand,
radius = radius,
n = n,
tol = tol,
label.margin = label.margin,
label.width = label.width,
label.minwidth = label.minwidth,
label.fontsize = label.fontsize,
label.family = label.family,
label.lineheight = label.lineheight,
label.fontface = label.fontface,
label.hjust = label.hjust,
label.fill = label.fill,
label.colour = label.colour,
label.buffer = label.buffer,
con.colour = con.colour,
con.size = con.size,
con.type = con.type,
con.linetype = con.linetype,
con.border = con.border,
con.cap = con.cap,
con.arrow = con.arrow,
...
)
)
}
# Helpers -----------------------------------------------------------------
#' @importFrom grDevices chull
ellipEncGrob <- function(x = c(0, 0.5, 1, 0.5), y = c(0.5, 1, 0.5, 0), id = NULL,
id.lengths = NULL, expand = 0, radius = 0, n = 100,
tol = 0.01, label = NULL, ghosts = NULL,
default.units = 'npc', name = NULL, mark.gp = gpar(),
label.gp = gpar(), con.gp = gpar(),
label.margin = margin(), label.width = NULL,
label.minwidth = unit(50, 'mm'), label.hjust = 0,
label.buffer = unit(10, 'mm'), con.type = 'elbow',
con.border = 'one', con.cap = unit(3, 'mm'),
con.arrow = NULL, anchor.x = NULL, anchor.y = NULL,
vp = NULL) {
if (is.null(id)) {
if (is.null(id.lengths)) {
id <- rep(1, length(x))
} else {
id <- rep(seq_along(id.lengths), id.lengths)
if (length(id) != length(x)) {
cli::cli_abort('{.arg id.lengths} must sum up to the number of points')
}
}
}
include <- unlist(lapply(split(seq_along(x), id), function(i) {
xi <- x[i]
yi <- y[i]
if (length(unique0(xi)) == 1) {
return(i[c(which.min(yi), which.max(yi))])
}
if (length(unique0(yi)) == 1) {
return(i[c(which.min(xi), which.max(xi))])
}
i[chull(xi, yi)]
}))
mark <- shapeGrob(
x = x[include], y = y[include], id = id[include],
id.lengths = NULL, expand = expand, radius = radius,
default.units = default.units, name = name, gp = mark.gp,
vp = vp
)
if (!is.null(label)) {
label <- lapply(seq_len(nrow(label)), function(i) {
grob <- labelboxGrob(label$label[i], 0, 0, label$description[i],
gp = label.gp, pad = label.margin, width = label.width,
min.width = label.minwidth, hjust = label.hjust
)
if (con.border == 'all') {
grob$children[[1]]$gp$col <- con.gp$col
grob$children[[1]]$gp$lwd <- con.gp$lwd
grob$children[[1]]$gp$lty <- con.gp$lty
}
grob
})
labeldim <- lapply(label, function(l) {
c(
convertWidth(grobWidth(l), 'mm', TRUE),
convertHeight(grobHeight(l), 'mm', TRUE)
)
})
ghosts <- lapply(ghosts, unit, default.units)
} else {
labeldim <- NULL
}
if (!is.null(anchor.x) && !is.unit(anchor.x)) {
anchor.x <- unit(anchor.x, default.units)
}
if (!is.null(anchor.y) && !is.unit(anchor.y)) {
anchor.y <- unit(anchor.y, default.units)
}
gTree(
mark = mark, n = n, tol = tol, label = label, labeldim = labeldim,
buffer = label.buffer, ghosts = ghosts, con.gp = con.gp, con.type = con.type,
con.cap = as_mm(con.cap, default.units), con.border = con.border,
con.arrow = con.arrow, anchor.x = anchor.x, anchor.y = anchor.y, name = name,
vp = vp, cl = 'ellip_enc'
)
}
#' @importFrom grid convertX convertY unit makeContent childNames addGrob
#' setChildren gList
#' @export
makeContent.ellip_enc <- function(x) {
mark <- x$mark
x_new <- convertX(mark$x, 'mm', TRUE)
y_new <- convertY(mark$y, 'mm', TRUE)
ellipses <- enclose_ellip_points(round(x_new, 2), round(y_new, 2), mark$id, x$tol)
ellipses$id <- seq_len(nrow(ellipses))
ellipses <- ellipses[rep(ellipses$id, each = x$n), ]
points <- 2 * pi * (seq_len(x$n) - 1) / x$n
x_tmp <- cos(points) * ellipses$a
y_tmp <- sin(points) * ellipses$b
ellipses$x <- ellipses$x0 + x_tmp * cos(ellipses$angle) - y_tmp * sin(ellipses$angle)
ellipses$y <- ellipses$y0 + x_tmp * sin(ellipses$angle) + y_tmp * cos(ellipses$angle)
ellipses <- unique0(ellipses)
mark$x <- unit(ellipses$x, 'mm')
mark$y <- unit(ellipses$y, 'mm')
mark$id <- ellipses$id
if (inherits(mark, 'shape')) mark <- makeContent(mark)
if (!is.null(x$label)) {
polygons <- Map(function(x, y) list(x = x, y = y),
x = split(as.numeric(mark$x), mark$id),
y = split(as.numeric(mark$y), mark$id)
)
anchor_x <- if (is.null(x$anchor.x)) NULL else convertX(x$anchor.x, 'mm', TRUE)
anchor_y <- if (is.null(x$anchor.y)) NULL else convertY(x$anchor.y, 'mm', TRUE)
labels <- make_label(
labels = x$label, dims = x$labeldim, polygons = polygons,
ghosts = x$ghosts, buffer = x$buffer, con_type = x$con.type,
con_border = x$con.border, con_cap = x$con.cap,
con_gp = x$con.gp, anchor_mod = 2, anchor_x = anchor_x,
anchor_y = anchor_y, arrow = x$con.arrow
)
setChildren(x, inject(gList(!!!c(list(mark), labels))))
} else {
setChildren(x, gList(mark))
}
}
ggforce/R/themes.R 0000644 0001762 0000144 00000001405 13435737063 013512 0 ustar ligges users #' Theme without axes and gridlines
#'
#' This theme is a simple wrapper around any complete theme that removes the
#' axis text, title and ticks as well as the grid lines for plots where these
#' have little meaning.
#'
#' @param base.theme The theme to use as a base for the new theme. Defaults to
#' [ggplot2::theme_bw()].
#'
#' @return A modified version of base.theme
#'
#' @export
#'
#' @examples
#' p <- ggplot() + geom_point(aes(x = wt, y = qsec), data = mtcars)
#'
#' p + theme_no_axes()
#' p + theme_no_axes(theme_grey())
#'
theme_no_axes <- function(base.theme = theme_bw()) {
base.theme %+replace%
theme(
axis.text = element_blank(),
axis.title = element_blank(),
axis.ticks = element_blank(),
panel.grid = element_blank()
)
}
ggforce/R/mark_hull.R 0000644 0001762 0000144 00000030062 14564603246 014203 0 ustar ligges users #' Annotate areas with hulls
#'
#' This geom lets you annotate sets of points via hulls. While convex hulls are
#' most common due to their clear definition, they can lead to large areas
#' covered that does not contain points. Due to this `geom_mark_hull` uses
#' concaveman which lets you adjust concavity of the resulting hull. The hull is
#' calculated at draw time, and can thus change as you resize the plot. In order
#' to clearly contain all points, and for aesthetic purpose the resulting hull
#' is expanded 5mm and rounded on the corners. This can be adjusted with the
#' `expand` and `radius` parameters.
#'
#' @inheritSection geom_mark_circle Annotation
#' @inheritSection geom_mark_circle Filtering
#' @section Aesthetics:
#' `geom_mark_hull` understand the following aesthetics (required aesthetics are
#' in bold):
#'
#' - **x**
#' - **y**
#' - x0 *(used to anchor the label)*
#' - y0 *(used to anchor the label)*
#' - filter
#' - label
#' - description
#' - color
#' - fill
#' - group
#' - size
#' - linetype
#' - alpha
#'
#' @inheritParams geom_mark_circle
#'
#' @param concavity A measure of the concavity of the hull. `1` is very concave
#' while it approaches convex as it grows. Defaults to `2`.
#'
#' @family mark geoms
#' @name geom_mark_hull
#' @rdname geom_mark_hull
#'
#' @examples
#' ## requires the concaveman packages
#' ggplot(iris, aes(Petal.Length, Petal.Width)) +
#' geom_mark_hull(aes(fill = Species, filter = Species != 'versicolor')) +
#' geom_point()
#'
#' # Adjusting the concavity lets you change the shape of the hull
#' ggplot(iris, aes(Petal.Length, Petal.Width)) +
#' geom_mark_hull(aes(fill = Species, filter = Species != 'versicolor'),
#' concavity = 1
#' ) +
#' geom_point()
#'
#' ggplot(iris, aes(Petal.Length, Petal.Width)) +
#' geom_mark_hull(aes(fill = Species, filter = Species != 'versicolor'),
#' concavity = 10
#' ) +
#' geom_point()
#'
#' # Add annotation
#' ggplot(iris, aes(Petal.Length, Petal.Width)) +
#' geom_mark_hull(aes(fill = Species, label = Species)) +
#' geom_point()
#'
#' # Long descriptions are automatically wrapped to fit into the width
#' iris$desc <- c(
#' 'A super Iris - and it knows it',
#' 'Pretty mediocre Iris, but give it a couple of years and it might surprise you',
#' "You'll never guess what this Iris does every Sunday"
#' )[iris$Species]
#'
#' ggplot(iris, aes(Petal.Length, Petal.Width)) +
#' geom_mark_hull(aes(fill = Species, label = Species, description = desc,
#' filter = Species == 'setosa')) +
#' geom_point()
#'
#' # Change the buffer size to move labels farther away (or closer) from the
#' # marks
#' ggplot(iris, aes(Petal.Length, Petal.Width)) +
#' geom_mark_hull(aes(fill = Species, label = Species),
#' label.buffer = unit(40, 'mm')) +
#' geom_point()
#'
#' # The connector is capped a bit before it reaches the mark, but this can be
#' # controlled
#' ggplot(iris, aes(Petal.Length, Petal.Width)) +
#' geom_mark_hull(aes(fill = Species, label = Species),
#' con.cap = 0) +
#' geom_point()
NULL
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
GeomMarkHull <- ggproto('GeomMarkHull', GeomMarkCircle,
draw_panel = function(self, data, panel_params, coord, expand = unit(5, 'mm'),
radius = unit(2.5, 'mm'), concavity = 2,
label.margin = margin(2, 2, 2, 2, 'mm'),
label.width = NULL, label.minwidth = unit(50, 'mm'),
label.hjust = 0, label.buffer = unit(10, 'mm'),
label.fontsize = 12, label.family = '',
label.fontface = c('bold', 'plain'),
label.lineheight = 1,
label.fill = 'white', label.colour = 'black',
con.colour = 'black', con.size = 0.5, con.type = 'elbow',
con.linetype = 1, con.border = 'one',
con.cap = unit(3, 'mm'), con.arrow = NULL) {
if (nrow(data) == 0) return(zeroGrob())
check_installed('concaveman', 'to calculate concave hulls')
# As long as coord$transform() doesn't recognise x0/y0
data$xmin <- data$x0
data$ymin <- data$y0
coords <- coord$transform(data, panel_params)
if (!is.integer(coords$group)) {
coords$group <- match(coords$group, unique0(coords$group))
}
coords <- coords[order(coords$group), ]
# For gpar(), there is one entry per polygon (not one entry per point).
# We'll pull the first value from each group, and assume all these values
# are the same within each group.
first_idx <- !duplicated(coords$group)
first_rows <- coords[first_idx, ]
label <- NULL
ghosts <- NULL
if (!is.null(coords$label) || !is.null(coords$description)) {
label <- first_rows
is_ghost <- which(self$removed$PANEL == coords$PANEL[1])
if (length(is_ghost) > 0) {
ghosts <- self$removed[is_ghost, ]
ghosts <- coord$transform(ghosts, panel_params)
ghosts <- list(x = ghosts$x, y = ghosts$y)
}
}
hullEncGrob(coords$x, coords$y,
default.units = 'native',
id = coords$group, expand = expand, radius = radius,
concavity = concavity, label = label, ghosts = ghosts,
mark.gp = gpar(
col = first_rows$colour,
fill = alpha(first_rows$fill, first_rows$alpha),
lwd = (first_rows$linewidth %||% first_rows$size) * .pt,
lty = first_rows$linetype
),
label.gp = gpar(
col = label.colour,
fill = label.fill,
fontface = label.fontface,
fontfamily = label.family,
fontsize = label.fontsize,
lineheight = label.lineheight
),
con.gp = gpar(
col = con.colour,
fill = con.colour,
lwd = con.size * .pt,
lty = con.linetype
),
label.margin = label.margin,
label.width = label.width,
label.minwidth = label.minwidth,
label.hjust = label.hjust,
label.buffer = label.buffer,
con.type = con.type,
con.border = con.border,
con.cap = con.cap,
con.arrow = con.arrow,
anchor.x = first_rows$xmin,
anchor.y = first_rows$ymin
)
}
)
#' @rdname geom_mark_hull
#' @export
geom_mark_hull <- function(mapping = NULL, data = NULL, stat = 'identity',
position = 'identity', expand = unit(5, 'mm'),
radius = unit(2.5, 'mm'), concavity = 2,
label.margin = margin(2, 2, 2, 2, 'mm'),
label.width = NULL, label.minwidth = unit(50, 'mm'),
label.hjust = 0, label.fontsize = 12,
label.family = '', label.lineheight = 1,
label.fontface = c('bold', 'plain'),
label.fill = 'white', label.colour = 'black',
label.buffer = unit(10, 'mm'), con.colour = 'black',
con.size = 0.5, con.type = 'elbow', con.linetype = 1,
con.border = 'one', con.cap = unit(3, 'mm'),
con.arrow = NULL, ..., na.rm = FALSE,
show.legend = NA, inherit.aes = TRUE) {
check_installed('concaveman', 'to calculate concave hulls')
layer(
data = data,
mapping = mapping,
stat = stat,
geom = GeomMarkHull,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
na.rm = na.rm,
expand = expand,
radius = radius,
concavity = concavity,
label.margin = label.margin,
label.width = label.width,
label.minwidth = label.minwidth,
label.fontsize = label.fontsize,
label.family = label.family,
label.lineheight = label.lineheight,
label.fontface = label.fontface,
label.hjust = label.hjust,
label.fill = label.fill,
label.colour = label.colour,
label.buffer = label.buffer,
con.colour = con.colour,
con.size = con.size,
con.type = con.type,
con.linetype = con.linetype,
con.border = con.border,
con.cap = con.cap,
con.arrow = con.arrow,
...
)
)
}
# Helpers -----------------------------------------------------------------
hullEncGrob <- function(x = c(0, 0.5, 1, 0.5), y = c(0.5, 1, 0.5, 0), id = NULL,
id.lengths = NULL, expand = 0, radius = 0, concavity = 2,
label = NULL, ghosts = NULL, default.units = 'npc',
name = NULL, mark.gp = gpar(), label.gp = gpar(),
con.gp = gpar(), label.margin = margin(),
label.width = NULL, label.minwidth = unit(50, 'mm'),
label.hjust = 0, label.buffer = unit(10, 'mm'),
con.type = 'elbow', con.border = 'one',
con.cap = unit(3, 'mm'), con.arrow = NULL,
anchor.x = NULL, anchor.y = NULL, vp = NULL) {
mark <- shapeGrob(
x = x, y = y, id = id, id.lengths = id.lengths,
expand = expand, radius = radius,
default.units = default.units, name = name, gp = mark.gp,
vp = vp
)
if (!is.null(label)) {
label <- lapply(seq_len(nrow(label)), function(i) {
grob <- labelboxGrob(label$label[i], 0, 0, label$description[i],
gp = label.gp, pad = label.margin, width = label.width,
min.width = label.minwidth, hjust = label.hjust
)
if (con.border == 'all') {
grob$children[[1]]$gp$col <- con.gp$col
grob$children[[1]]$gp$lwd <- con.gp$lwd
grob$children[[1]]$gp$lty <- con.gp$lty
}
grob
})
labeldim <- lapply(label, function(l) {
c(
convertWidth(grobWidth(l), 'mm', TRUE),
convertHeight(grobHeight(l), 'mm', TRUE)
)
})
ghosts <- lapply(ghosts, unit, default.units)
} else {
labeldim <- NULL
}
if (!is.null(anchor.x) && !is.unit(anchor.x)) {
anchor.x <- unit(anchor.x, default.units)
}
if (!is.null(anchor.y) && !is.unit(anchor.y)) {
anchor.y <- unit(anchor.y, default.units)
}
gTree(
mark = mark, concavity = concavity, label = label, labeldim = labeldim,
buffer = label.buffer, ghosts = ghosts, con.gp = con.gp, con.type = con.type,
con.cap = as_mm(con.cap, default.units), con.border = con.border,
con.arrow = con.arrow, anchor.x = anchor.x, anchor.y = anchor.y, name = name,
vp = vp, cl = 'hull_enc'
)
}
#' @importFrom grid convertX convertY unit makeContent setChildren gList
#' @export
makeContent.hull_enc <- function(x) {
mark <- x$mark
x_new <- convertX(mark$x, 'mm', TRUE)
x_new <- split(x_new, mark$id)
y_new <- convertY(mark$y, 'mm', TRUE)
y_new <- split(y_new, mark$id)
polygons <- Map(function(xx, yy, type) {
mat <- unique0(cbind(xx, yy))
if (nrow(mat) <= 2) {
return(mat)
}
if (length(unique0(xx)) == 1) {
return(mat[c(which.min(mat[, 2]), which.max(mat[, 2])), ])
}
if (length(unique0((yy[-1] - yy[1]) / (xx[-1] - xx[1]))) == 1) {
return(mat[c(which.min(mat[, 1]), which.max(mat[, 1])), ])
}
concaveman::concaveman(mat, x$concavity, 0)
}, xx = x_new, yy = y_new)
mark$id <- rep(seq_along(polygons), vapply(polygons, nrow, numeric(1)))
polygons <- vec_rbind(!!!polygons)
mark$x <- unit(polygons[, 1], 'mm')
mark$y <- unit(polygons[, 2], 'mm')
if (inherits(mark, 'shape')) mark <- makeContent(mark)
if (!is.null(x$label)) {
polygons <- Map(function(x, y) list(x = x, y = y),
x = split(as.numeric(mark$x), mark$id),
y = split(as.numeric(mark$y), mark$id)
)
anchor_x <- if (is.null(x$anchor.x)) NULL else convertX(x$anchor.x, 'mm', TRUE)
anchor_y <- if (is.null(x$anchor.y)) NULL else convertY(x$anchor.y, 'mm', TRUE)
labels <- make_label(
labels = x$label, dims = x$labeldim, polygons = polygons,
ghosts = x$ghosts, buffer = x$buffer, con_type = x$con.type,
con_border = x$con.border, con_cap = x$con.cap,
con_gp = x$con.gp, anchor_mod = 2, anchor_x = anchor_x,
anchor_y = anchor_y, arrow = x$con.arrow
)
setChildren(x, inject(gList(!!!c(list(mark), labels))))
} else {
setChildren(x, gList(mark))
}
}
ggforce/R/ggproto-classes.R 0000644 0001762 0000144 00000000576 13435737063 015351 0 ustar ligges users #' ggforce extensions to ggplot2
#'
#' ggforce makes heavy use of the ggproto class system to extend the
#' functionality of ggplot2. In general the actual classes should be of little
#' interest to users as the standard ggplot2 api of using geom_* and stat_*
#' functions for building up the plot is encouraged.
#'
#' @name ggforce-extensions
#' @rdname ggforce-extensions
#'
NULL
ggforce/R/sina.R 0000644 0001762 0000144 00000040222 14564603246 013156 0 ustar ligges users #' Sina plot
#'
#' The sina plot is a data visualization chart suitable for plotting any single
#' variable in a multiclass dataset. It is an enhanced jitter strip chart,
#' where the width of the jitter is controlled by the density distribution of
#' the data within each class.
#'
#' @details There are two available ways to define the x-axis borders for the
#' samples to spread within:
#' \itemize{
#' \item{`method == "density"`
#'
#' A density kernel is estimated along the y-axis for every sample group, and
#' the samples are spread within that curve. In effect this means that points
#' will be positioned randomly within a violin plot with the same parameters.
#' }
#' \item{`method == "counts"`:
#'
#' The borders are defined by the number of samples that occupy the same bin.
#'
#' }
#' }
#'
#' @section Aesthetics:
#' geom_sina understand the following aesthetics (required aesthetics are in
#' bold):
#'
#' - **x**
#' - **y**
#' - color
#' - group
#' - size
#' - alpha
#'
#' @inheritParams ggplot2::geom_line
#' @inheritParams ggplot2::stat_identity
#' @inheritParams ggplot2::stat_density
#'
#' @param scale How should each sina be scaled. Corresponds to the `scale`
#' parameter in [ggplot2::geom_violin()]? Available are:
#'
#' - `'area'` for scaling by the largest density/bin among the different sinas
#' - `'count'` as above, but in addition scales by the maximum number of points
#' in the different sinas.
#' - `'width'` Only scale according to the `maxwidth` parameter
#'
#' For backwards compatibility it can also be a logical with `TRUE` meaning
#' `area` and `FALSE` meaning `width`
#'
#' @param method Choose the method to spread the samples within the same
#' bin along the x-axis. Available methods: "density", "counts" (can be
#' abbreviated, e.g. "d"). See `Details`.
#'
#' @param maxwidth Control the maximum width the points can spread into. Values
#' between 0 and 1.
#'
#' @param bin_limit If the samples within the same y-axis bin are more
#' than `bin_limit`, the samples's X coordinates will be adjusted.
#'
#' @param binwidth The width of the bins. The default is to use `bins`
#' bins that cover the range of the data. You should always override
#' this value, exploring multiple widths to find the best to illustrate the
#' stories in your data.
#'
#' @param bins Number of bins. Overridden by binwidth. Defaults to 50.
#'
#' @param seed A seed to set for the jitter to ensure a reproducible plot
#'
#' @param jitter_y If y is integerish banding can occur and the default is to
#' jitter the values slightly to make them better distributed. Setting
#' `jitter_y = FALSE` turns off this behaviour
#'
#' @inheritSection ggplot2::geom_line Orientation
#'
#' @author Nikos Sidiropoulos, Claus Wilke, and Thomas Lin Pedersen
#'
#' @name geom_sina
#' @rdname geom_sina
#'
#' @section Computed variables:
#'
#' \describe{
#' \item{density}{The density or sample counts per bin for each point}
#' \item{scaled}{`density` scaled by the maximum density in each group}
#' \item{n}{The number of points in the group the point belong to}
#' }
#'
#'
#' @examples
#' ggplot(midwest, aes(state, area)) + geom_point()
#'
#' # Boxplot and Violin plots convey information on the distribution but not the
#' # number of samples, while Jitter does the opposite.
#' ggplot(midwest, aes(state, area)) +
#' geom_violin()
#'
#' ggplot(midwest, aes(state, area)) +
#' geom_jitter()
#'
#' # Sina does both!
#' ggplot(midwest, aes(state, area)) +
#' geom_violin() +
#' geom_sina()
#'
#' p <- ggplot(midwest, aes(state, popdensity)) +
#' scale_y_log10()
#'
#' p + geom_sina()
#'
#' # Colour the points based on the data set's columns
#' p + geom_sina(aes(colour = inmetro))
#'
#' # Or any other way
#' cols <- midwest$popdensity > 10000
#' p + geom_sina(colour = cols + 1L)
#'
#' # Sina plots with continuous x:
#' ggplot(midwest, aes(cut_width(area, 0.02), popdensity)) +
#' geom_sina() +
#' scale_y_log10()
#'
#'
#' ### Sample gaussian distributions
#' # Unimodal
#' a <- rnorm(500, 6, 1)
#' b <- rnorm(400, 5, 1.5)
#'
#' # Bimodal
#' c <- c(rnorm(200, 3, .7), rnorm(50, 7, 0.4))
#'
#' # Trimodal
#' d <- c(rnorm(200, 2, 0.7), rnorm(300, 5.5, 0.4), rnorm(100, 8, 0.4))
#'
#' df <- data.frame(
#' 'Distribution' = c(
#' rep('Unimodal 1', length(a)),
#' rep('Unimodal 2', length(b)),
#' rep('Bimodal', length(c)),
#' rep('Trimodal', length(d))
#' ),
#' 'Value' = c(a, b, c, d)
#' )
#'
#' # Reorder levels
#' df$Distribution <- factor(
#' df$Distribution,
#' levels(df$Distribution)[c(3, 4, 1, 2)]
#' )
#'
#' p <- ggplot(df, aes(Distribution, Value))
#' p + geom_boxplot()
#' p + geom_violin() +
#' geom_sina()
#'
#' # By default, Sina plot scales the width of the class according to the width
#' # of the class with the highest density. Turn group-wise scaling off with:
#' p +
#' geom_violin() +
#' geom_sina(scale = FALSE)
NULL
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatSina <- ggproto('StatSina', Stat,
required_aes = c('x', 'y'),
setup_data = function(data, params) {
data <- flip_data(data, params$flipped_aes)
data$flipped_aes <- params$flipped_aes
if (is.double(data$x) && !.has_groups(data) && any(data$x != data$x[1L])) {
cli::cli_abort(c(
"Continuous {.field {flipped_names(params$flipped_aes)$x}} aesthetic",
"i" = "did you forget {.code aes(group = ...)}?"
))
}
flip_data(data, params$flipped_aes)
},
setup_params = function(data, params) {
params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = TRUE, group_has_equal = TRUE)
data <- flip_data(data, params$flipped_aes)
params$maxwidth <- params$maxwidth %||% (resolution(data$x %||% 0) * 0.9)
if (is.null(params$binwidth) && is.null(params$bins)) {
params$bins <- 50
}
params
},
compute_panel = function(self, data, scales, scale = TRUE, method = 'density',
bw = 'nrd0', kernel = 'gaussian', binwidth = NULL,
bins = NULL, maxwidth = 1, adjust = 1, bin_limit = 1,
seed = NA, flipped_aes = FALSE, jitter_y = TRUE) {
if (!is.null(binwidth)) {
bins <- bin_breaks_width(scales[[flipped_names(flipped_aes)$y]]$dimension() + 1e-8, binwidth)
} else {
bins <- bin_breaks_bins(scales[[flipped_names(flipped_aes)$y]]$dimension() + 1e-8, bins)
}
data <- ggproto_parent(Stat, self)$compute_panel(data, scales,
scale = scale, method = method, bw = bw, kernel = kernel,
bins = bins$breaks, maxwidth = maxwidth, adjust = adjust,
bin_limit = bin_limit, flipped_aes = flipped_aes)
data <- flip_data(data, flipped_aes)
if (is.logical(scale)) {
scale <- if (scale) 'area' else 'width'
}
# choose how sinas are scaled relative to each other
data$sinawidth <- switch(
scale,
# area : keep the original densities but scale them to a max width of 1
# for plotting purposes only
area = data$density / max(data$density),
# count: use the original densities scaled to a maximum of 1 (as above)
# and then scale them according to the number of observations
count = data$density / max(data$density) * data$n / max(data$n),
# width: constant width (each density scaled to a maximum of 1)
width = data$scaled
)
data$sinawidth[!is.finite(data$sinawidth)] <- 0
if (!is.na(seed)) {
new_seed <- sample(.Machine$integer.max, 1L)
set.seed(seed)
on.exit(set.seed(new_seed))
}
data$xmin <- data$x - maxwidth / 2
data$xmax <- data$x + maxwidth / 2
data$x_diff <- runif(nrow(data), min = -1, max = 1) *
maxwidth * data$sinawidth/2
data$width <- maxwidth
# jitter y values if the input is input is integer
if (jitter_y && is_integerish(data$y)) {
data$y <- jitter(data$y)
}
flip_data(data, flipped_aes)
},
compute_group = function(data, scales, scale = TRUE, method = 'density',
bw = 'nrd0', kernel = 'gaussian',
maxwidth = 1, adjust = 1, bin_limit = 1,
bins = NULL, flipped_aes = FALSE) {
if (nrow(data) == 0) return(NULL)
data <- flip_data(data, flipped_aes)
if (nrow(data) < 3) {
data$density <- 0
data$scaled <- 1
} else if (length(unique0(data$y)) < 2) {
data$density <- 1
data$scaled <- 1
} else if (method == 'density') { # density kernel estimation
range <- range(data$y, na.rm = TRUE)
bw <- calc_bw(data$y, bw)
dens <- compute_density(data$y, data$w, from = range[1], to = range[2],
bw = bw, adjust = adjust, kernel = kernel)
densf <- stats::approxfun(dens$x, dens$density, rule = 2)
data$density <- densf(data$y)
data$scaled <- data$density / max(dens$density)
} else { # bin based estimation
bin_index <- cut(data$y, bins, include.lowest = TRUE, labels = FALSE)
data$density <- tapply(bin_index, bin_index, length)[as.character(bin_index)]
data$density[data$density <= bin_limit] <- 0
data$scaled <- data$density / max(data$density)
}
# Compute width if x has multiple values
if (length(unique0(data$x)) > 1) {
width <- diff(range(data$x)) * maxwidth
} else {
width <- maxwidth
}
data$width <- width
data$n <- nrow(data)
data$x <- mean(range(data$x))
flip_data(data, flipped_aes)
},
finish_layer = function(data, params) {
# rescale x in case positions have been adjusted
data <- flip_data(data, params$flipped_aes)
x_mod <- (data$xmax - data$xmin) / data$width
data$x <- data$x + data$x_diff * x_mod
flip_data(data, params$flipped_aes)
},
extra_params = c('na.rm', 'orientation')
)
#' @rdname geom_sina
#' @export
stat_sina <- function(mapping = NULL, data = NULL, geom = 'point',
position = 'dodge', scale = 'area', method = 'density',
bw = 'nrd0', kernel = 'gaussian', maxwidth = NULL,
adjust = 1, bin_limit = 1, binwidth = NULL, bins = NULL,
seed = NA, jitter_y = TRUE, ..., na.rm = FALSE, orientation = NA,
show.legend = NA, inherit.aes = TRUE) {
method <- match.arg(method, c('density', 'counts'))
layer(
data = data,
mapping = mapping,
stat = StatSina,
geom = geom,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(scale = scale, method = method, bw = bw, kernel = kernel,
maxwidth = maxwidth, adjust = adjust, bin_limit = bin_limit,
binwidth = binwidth, bins = bins, seed = seed, jitter_y = jitter_y, na.rm = na.rm,
orientation = orientation, ...)
)
}
#' @rdname geom_sina
#' @export
geom_sina <- function(mapping = NULL, data = NULL,
stat = 'sina', position = 'dodge',
...,
na.rm = FALSE,
orientation = NA,
show.legend = NA,
inherit.aes = TRUE) {
layer(
data = data,
mapping = mapping,
stat = stat,
geom = GeomPoint,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
na.rm = na.rm,
orientation = orientation,
...
)
)
}
# Binning functions -------------------------------------------------------
bins <- function(breaks, closed = "right",
fuzz = 1e-08 * stats::median(diff(breaks))) {
if (!is.numeric(breaks)) {
cli::cli_abort("{.arg breaks} must be a numeric vector")
}
closed <- arg_match0(closed, c("right", "left"))
breaks <- sort(breaks)
# Adapted base::hist - this protects from floating point rounding errors
if (closed == "right") {
fuzzes <- c(-fuzz, rep.int(fuzz, length(breaks) - 1))
} else {
fuzzes <- c(rep.int(-fuzz, length(breaks) - 1), fuzz)
}
structure(
list(
breaks = breaks,
fuzzy = breaks + fuzzes,
right_closed = closed == "right"
),
class = "ggplot2_bins"
)
}
# Compute parameters -----------------------------------------------------------
# from ggplot2
compute_density <- function(x, w, from, to, bw = "nrd0", adjust = 1,
kernel = "gaussian", n = 512) {
nx <- length(x)
if (is.null(w)) {
w <- rep(1 / nx, nx)
} else {
w <- w / sum(w)
}
dens <- stats::density(x, weights = w, bw = bw, adjust = adjust,
kernel = kernel, n = n, from = from, to = to)
data_frame0(
x = dens$x,
density = dens$y,
scaled = dens$y / max(dens$y, na.rm = TRUE),
ndensity = dens$y / max(dens$y, na.rm = TRUE),
count = dens$y * nx,
n = nx
)
}
calc_bw <- function(x, bw) {
if (is.character(bw)) {
if (length(x) < 2) {
cli::cli_abort("{.arg x} must contain at least 2 elements to select a bandwidth automatically")
}
bw <- switch(
to_lower_ascii(bw),
nrd0 = stats::bw.nrd0(x),
nrd = stats::bw.nrd(x),
ucv = stats::bw.ucv(x),
bcv = stats::bw.bcv(x),
sj = ,
`sj-ste` = stats::bw.SJ(x, method = "ste"),
`sj-dpi` = stats::bw.SJ(x, method = "dpi"),
cli::cli_abort("{.var {bw}} is not a valid bandwidth rule")
)
}
bw
}
bin_breaks <- function(breaks, closed = c('right', 'left')) {
bins(breaks, closed)
}
bin_breaks_width <- function(x_range, width = NULL, center = NULL,
boundary = NULL, closed = c("right", "left")) {
if (length(x_range) != 2) {
cli::cli_abort("{.arg x_range} must have two elements")
}
# if (length(x_range) == 0) {
# return(bin_params(numeric()))
# }
if (!(is.numeric(width) && length(width) == 1)) {
cli::cli_abort("{.arg width} must be a number")
}
if (width <= 0) {
cli::cli_abort("{.arg binwidth} must be positive")
}
if (!is.null(boundary) && !is.null(center)) {
cli::cli_abort("Only one of {.arg boundary} and {.arg center} may be specified.")
} else if (is.null(boundary)) {
if (is.null(center)) {
# If neither edge nor center given, compute both using tile layer's
# algorithm. This puts min and max of data in outer half of their bins.
boundary <- width / 2
} else {
# If center given but not boundary, compute boundary.
boundary <- center - width / 2
}
}
# Find the left side of left-most bin: inputs could be Dates or POSIXct, so
# coerce to numeric first.
x_range <- as.numeric(x_range)
width <- as.numeric(width)
boundary <- as.numeric(boundary)
shift <- floor((x_range[1] - boundary) / width)
origin <- boundary + shift * width
# Small correction factor so that we don't get an extra bin when, for
# example, origin = 0, max(x) = 20, width = 10.
max_x <- x_range[2] + (1 - 1e-08) * width
if (isTRUE((max_x - origin) / width > 1e6)) {
cli::cli_abort(c(
"The number of histogram bins must be less than 1,000,000.",
"i" = "Did you make {.arg binwidth} too small?"
))
}
breaks <- seq(origin, max_x, width)
if (length(breaks) == 1) {
# In exceptionally rare cases, the above can fail and produce only a
# single break (see issue #3606). We fix this by adding a second break.
breaks <- c(breaks, breaks + width)
}
bin_breaks(breaks, closed = closed)
}
bin_breaks_bins <- function(x_range, bins = 30, center = NULL,
boundary = NULL, closed = c("right", "left")) {
if (length(x_range) != 2) {
cli::cli_abort("{.arg x_range} must have two elements")
}
bins <- as.integer(bins)
if (bins < 1) {
cli::cli_abort("{.arg bins} must be 1 or greater")
} else if (scales::zero_range(x_range)) {
# 0.1 is the same width as the expansion `default_expansion()` gives for 0-width data
width <- 0.1
} else if (bins == 1) {
width <- diff(x_range)
boundary <- x_range[1]
} else {
width <- (x_range[2] - x_range[1]) / (bins - 1)
}
bin_breaks_width(x_range, width, boundary = boundary, center = center,
closed = closed)
}
.has_groups <- function(data) {
# If no group aesthetic is specified, all values of the group column equal to
# -1L. On the other hand, if a group aesthetic is specified, all values
# are different from -1L (since they are a result of plyr::id()). NA is
# returned for 0-row data frames.
data$group[1L] != -1L
}
ggforce/NEWS.md 0000644 0001762 0000144 00000016316 14564604337 013007 0 ustar ligges users # ggforce 0.4.2
* Fix a documentation issue reported by CRAN
# ggforce 0.4.1
* Fixed a sanitizer error in the decent calculations used for the mark geoms
* Fixed a typo bug in the vctrs implementations
# ggforce 0.4.0
* Moved to vctrs internally
* Updated error messaging to use cli
* `geom_diagonal()`, `geom_diagonal_wide()`, `geom_parallel_sets()`, and
`geom_sina()` are now bidirectional in the style of ggplot2
* `geom_mark_*()` now works correctly in the presence of `NA` values in `x` and
`y`
* The `zoom`, `zoom.x`, and `zoom.y` elements now uses proper registration of
theme elements, inheriting from `strip.background`.
* Fixed bug in `geom_sina()` when groups contained less than 3 points
* Fixed bug in `geom_parallel_sets()` that erroneously removed grouping
information in some configurations
* Added `jitter_y` argument to `geom_sina()` to control whether y jittering is
performed on integerish y values.
* `facet_zoom()` now works with patchwork
* Fix bug in `geom_mark_ellipse()` that caused wrong orientation of ellipses
with groups of two.
* `gather_set_data()` now supports tidyselect.
* `position_jitternormal()` gains a `seed` argument in parallel to
`ggplot2::position_jitter()`
* `geom_sina()` now works when the group only have a single unique y value
* `facet_zoom()` now works correctly with transformed scales
* `facet_wrap_paginate()` now works correctly with `dir = 'v'`
* `facet_matrix()` now supports a labeller
* fix a bug in `geom_parallel_sets_axes()` that prevented coloring of axis fill
* fix a bug in `stat_circle()` if the `x` and `y` aesthetics were inherited from
the global mapping
* `facet_zoom()` now works even when limits are set by the scales
# ggforce 0.3.4
- Changed documentation to comply with new units package
- Fixed unintentional re-ordering of shapes (#224)
- Deprecate `scale_[x|y]_unit` in favor of `units::scale_[x|y]_units`
# ggforce 0.3.2
- Changes to comply with latest ggplot2 release
- Make sure ggforce pass test even if concaveman is not available
# ggforce 0.3.1
- Better fix for gganimate compatibility (#157)
# ggforce 0.3.0
- Added `facet_matrix()` in order to facet different data columns into different
rows and columns in a grid, in order to make e.g. scatterplot matrices and
pairs plot
- Added `geom_autopoint()` and `position_auto()` to jitter points based on the
type of positional scales in the panel
- Added `geom_autohistogram()` and `geom_autodensity()` for facilitating
distribution plots along the diagonal in a `facet_matrix()` plot.
- Added `facet_row()` and `facet_col` to have one-dimensional `facet_wrap()`
with possibility of variable sizing.
- Stats should now always keep the old group variable (potentially with
something added), making them work with gganimate
- Removed the *Visual Guide* vignette to reduce compilation time. See the
website for an overview of all functionality with compiled examples
(https://ggforce.data-imaginist.com)
# ggforce 0.2.2
- Fixed a regression in `geom_sina()` where the computation would fail with a
warning due to `tolower()` being masked (#134, #135).
# ggforce 0.2.1
- Fixed a bug in the calculation of open and closed b-splines, where the
interval would exceed the defined region and result in an out-of-bounds memory
error
# ggforce 0.2.0
## New features
- `linear_trans` for composing linear transformation using `rotate`, `stretch`,
`shear`, `reflect`, and `translate`
- `facet_stereo` added for creating stereographic projections
- `geom_voronoi_[tile|segment]`, `geom_delaunay_[tile|segment|segment2]`, and
`stat_delvor_summary` has been added for tesselation and triangulation.
- `geom_spiro` has been added for drawing spirographs
- Add `geom_ellipse` for drawing regular and superellipses
- Add `geom_regon` for drawing regular polygons
- Add `geom_diagonal`, `geom_diagonal_wide` and `geom_parallel_sets` for drawing
parallel sets diagrams and other visualizations based on diagonals.
- Add `geom_shape` for drawing polygons with rounded corners and
expanded/contracted sides. `geom_shape` replaces all `geom_polygon`
internally.
- Added `geom_bspline_closed` to draw polygons defined as b-splines
- Add `geom_mark_[rect|circle|ellipse|hull]` to encircle a group of points and
optionally add textual annotation to it
- Add `position_jitternormal` to jitter points based on a normal distribution
(@andrewheiss)
## Improvements
- `facet_[wrap|grid]_paginate` will now try to make panels on the last page the
same size as on full pages (#7)
- `facet_zoom` now gains `xlim` and `ylim` arguments to control zoom range
directly
- `facet_zoom` now gains `zoom.data` to control which data gets plotted in which
panel
- Slimmed down the dependencies for the package. `plyr`, `lazyeval` and `dplyr`
has all been removed
- Rewrite `geom_sina` to match `geom_violin` and allow for dodging
- Add `open`/`clamped` option to `geom_bspline
## Bug fixes
- Fix interpolation of `x` and `y` values in `geom_link2` (@thomasp85 and
@lepennec)
- `stat_link` no longer replicates the group column
- arcs and links no longer rename aesthetics when only one aesthetic is present
(`drop = FALSE`)
- `stat_bezier0` and `stat_bezier2` now return data in the expected format
- Fix bug with `n_pages` due to internal changes in ggplot2
- Fix bug in `facet_zoom` in combination with secondary y-axis where the space for
the y-axis would become huge
- Correctly detect and error out when scales and coords does not work with
`facet_zoom`
- The *2 versions of line geoms no longer adds an `NA` to guides.
# ggforce 0.1.1
## New features
- Zoom indicator styling can now be specified separetely for x and y zoom using
`zoom.x` and `zoom.y` in theme (inherits from `zoom` that inherits from
`strip.background`)
## Bug fixes
- Fix bug in `facet_wrap_paginate` that threw errors when using it with free
scales (#19)
- Fixes bug in `facet_zoom` where y-axis would be incorrectly displayed when
zooming on both axes without splitting the view (#23)
- Fixes bug in `facet_zoom` where scale expansion where not taken into account
when drawing the indicator area (#22)
- Fixes a bug in `facet_zoom` that would throw errors with layers not containing
the column that is zoomed by (#21)
# ggforce 0.1.0
## Major changes
- `geom_edge_bundle` has been renamed `geom_bspline` and lost the tension
argument. True edge bundle functionality has been moved to `ggraph`
## New features
- `geom_bezier` for drawing quadratic and cubic beziers
- `geom_link` for augmented segment/path drawing
- `geom_sina` as an alternative to `geom_violin` and `geom_beeswarm`
- `scale_[x|y]_unit` for using units vectors
- `facet_[wrap|grid]_paginate` to split facetting into multiple pages
- `facet_zoom` for contextual zooming
# ggforce 0.0.1
## Major changes
- First commit
## New features
- `geom_arc` / `stat_arc` for drawing circle segments
- `geom_edge_bundle` / `stat_edge_bundle` for drawing edge bundles based on
control points
- `geom_arc_bar` /`stat_arc_bar` / `stat_pie` for drawing arcs and wedges with
fill
- `geom_circle` / `stat_circle` for drawing circles with radius based on
coordinate system scale
- `power_trans` for creating power transformations
- `radial_trans` for creating transformation between radial and cartesian
coordinates
- `trans_reverser` for reversing a trans object
ggforce/MD5 0000644 0001762 0000144 00000013677 14564632262 012226 0 ustar ligges users 27a9f3878cf1d1c08a38e211f4ffefd5 *DESCRIPTION
c31ee18d335f7158ed985f5939319c1f *LICENSE
6b0db74ed1667981932a97259f3f0520 *NAMESPACE
e683225e2ba168113fea8b47f1e2e0ac *NEWS.md
5f42de1a5c1bd0d2bca8e5e0895fcbfe *R/RcppExports.R
c52cbce1c0cdab630ddf4720b54dea19 *R/aaa.R
26c00671c21714c44c33d02656816d6e *R/arc.R
c9f4a364ecdf372d717a0bb4d3ffb55f *R/arc_bar.R
6f2adaccc07a3b6524c9c330999c72cb *R/autodensity.R
7e2a4ea195cd99881eca8b857d85a105 *R/autohistogram.R
8a33304dfad54e631f572d53b159770d *R/autopoint.R
978419d9bbc8e0c3d7e5d2d8b931f26f *R/bezier.R
c2245fbc1878ff1c1c1f9ef0bafcef84 *R/bspline.R
8066b758dd3831248ba143d969ff3ca7 *R/bspline_closed.R
d66d14329b4a9fd1fb57e1b4431a0baf *R/circle.R
49ebc3d01e330c236f0dd95eb648636e *R/diagonal.R
5f399c8cfd4b7288330223f79261e798 *R/diagonal_wide.R
d003635e6b3246d1b7d3e8416894e7e5 *R/ellipse.R
c6cd6a6438852de323b84093022809b4 *R/errorbar.R
421f4ca6923977a98b8f1834f6b1c97c *R/facet_grid_paginate.R
6d823cafb36fe706c487c8c5a77efef8 *R/facet_matrix.R
03355030f98fe515560fb414a20c2d79 *R/facet_row.R
0fc347de7cb9993e4ac4a2cde077d921 *R/facet_stereo.R
052f774ea52dedd966a524daf60ad90a *R/facet_wrap_paginate.R
340e6b5e362d0b7b25f86012977661a4 *R/facet_zoom.R
acf004f3f49aed3ae7cda429ed33adb2 *R/ggforce-package.R
fee6ed1299effd00b4befb852ea654d5 *R/ggproto-classes.R
6f4c793f0a8f273884e6dd31056e3703 *R/interpolate.R
c12c9a5d11dedb91ab0a8382a2fec52c *R/labeller.R
13cdad57cb17d98d6bd87b15359f448e *R/link.R
4acb45df3c1ffc9babd13852ab1efbc8 *R/mark_circle.R
43f3389cb5e65e59384929c1df133cd3 *R/mark_ellipse.R
2e41383bbe730e087cd20596bea22d96 *R/mark_hull.R
d14ced82b8d9a66d846524b5db98cf90 *R/mark_label.R
2f21812a6d0342b2854299b2bd217deb *R/mark_rect.R
ef8bc4e5aa17011d4b7eee0e62100100 *R/parallel_sets.R
35c1d6bb63b6059b67282bb2e21a533a *R/position-jitternormal.R
b02c6b794b7a5f0cc98b46986ad168c9 *R/position_auto.R
e2c245568f1812ad738db99e84dd66e3 *R/position_floatstack.R
cfe4bb16fe9dc80312eb94551497dfaf *R/regon.R
09d1e9f5963b8b14726dca48d3010fac *R/scale-depth.R
f7f0b2cc2a3fbe9f4c632a39a42c980f *R/scale-unit.R
4c7817f0a610f82e3172b0718255bb9b *R/shape.R
ad397777546844babfc39645b018fd95 *R/sina.R
cebcd46ab7d07f1b50865a476cf9cb7f *R/spiro.R
d1434c1bd4a80b925fe3d61951e9eaca *R/themes.R
16dd7665e67da1bbb9bc7723907941c5 *R/trans.R
5e8a4bebb3759a54f64ff4e86061166f *R/trans_linear.R
ed0d6f8afc438224c01f2c41a6d85134 *R/utilities.R
5c076b2c80491a493dbc753b7e0dea8a *R/voronoi.R
2445757c830b4089fc4fe993f0aa2574 *R/zzz.R
ba9d9d307461077da20157de892f8515 *README.md
34f8441533f62b6c21362a5ebf2de211 *man/facet_grid_paginate.Rd
bdd64205f085c5b1063a417abb7e4ae9 *man/facet_matrix.Rd
cb1f767b59e1cb4a70ccc8429a36e75e *man/facet_row.Rd
6f063e27bf980fed22223bda91c1e481 *man/facet_stereo.Rd
bd12faf79d8cc83c090e43dfa7b46853 *man/facet_wrap_paginate.Rd
cb3f6f3cc4b80d5247e8dde831a56843 *man/facet_zoom.Rd
aa8a558e3290bcde8d240a2786591069 *man/figures/README-example-1.png
cb1e46f469cfbbbde29c8b5113e1d789 *man/figures/lifecycle-archived.svg
c0d2e5a54f1fa4ff02bf9533079dd1f7 *man/figures/lifecycle-defunct.svg
a1b8c987c676c16af790f563f96cbb1f *man/figures/lifecycle-deprecated.svg
c3978703d8f40f2679795335715e98f4 *man/figures/lifecycle-experimental.svg
952b59dc07b171b97d5d982924244f61 *man/figures/lifecycle-maturing.svg
27b879bf3677ea76e3991d56ab324081 *man/figures/lifecycle-questioning.svg
53b3f893324260b737b3c46ed2a0e643 *man/figures/lifecycle-stable.svg
1c1fe7a759b86dc6dbcbe7797ab8246c *man/figures/lifecycle-superseded.svg
700122af4c3aa3fc71a7562348bcf127 *man/figures/logo.png
20fa804950661156114c48629db7ccec *man/figures/logo.svg
1e9f0843746b1768a818640d9e0cec8c *man/gather_set_data.Rd
dfe87985265644daac4e6218ae3154dc *man/geom_arc.Rd
f25fb45915206f491c43f3ccdb629e4b *man/geom_arc_bar.Rd
137277be5673930c1a292e2893ceb6e6 *man/geom_autohistogram.Rd
3c665932653f3096dd1154debb0e8d83 *man/geom_autopoint.Rd
2ef5aa69a93f9479aaa19e2f0451b827 *man/geom_bezier.Rd
c55eae4fd2498f19941a8f985265e7b2 *man/geom_bspline.Rd
9f6cd071d61db2f66f07c799dfce479a *man/geom_bspline_closed.Rd
b00b4746cc98a68ed2a0b283971c6a1c *man/geom_circle.Rd
f1b2720b994c84cb221a401e9f5829f0 *man/geom_delvor.Rd
1f3c735b97717353315b317f3157c90e *man/geom_diagonal.Rd
7212daa03be6e29d59304645a2731b8e *man/geom_diagonal_wide.Rd
e733723326c19abb2e45511cd7f86b9b *man/geom_ellipse.Rd
ee463afc2f2706d8aa2f23aa98ed6d75 *man/geom_link.Rd
db5ac11650acaf11dcbd3e0f08fadc17 *man/geom_mark_circle.Rd
b43f2daa2d8c0e4117b0f139d71bea79 *man/geom_mark_ellipse.Rd
f068a295d976504ba34549892ebcf855 *man/geom_mark_hull.Rd
13e65a2d4c6457bce09c100c633e697b *man/geom_mark_rect.Rd
c0b199d4da68f72a7602b6f155a67bf9 *man/geom_parallel_sets.Rd
f58d9dd61cb2f58951d26e7b37c71dc3 *man/geom_regon.Rd
b1d35636370a3b318f626fcd27f6b37c *man/geom_shape.Rd
d528bb589e618d5708f0ebe6d55ffd7f *man/geom_sina.Rd
b7beb4c3729c877d2a2dce344982e0d2 *man/geom_spiro.Rd
b745311004a906a5a207974dd646f35c *man/ggforce-extensions.Rd
d5f74b11aa5d1708b69865f2a3f35cf4 *man/ggforce-package.Rd
7c04ebc12cbdf837804cc8c209b5025d *man/interpolateDataFrame.Rd
bf23fe37e93fbcd24a4db8329b5e2556 *man/label_tex.Rd
4b75fdf88125c4f945353f24882dbbfa *man/linear_trans.Rd
12d8ae329fdd7b044564efe314941910 *man/n_pages.Rd
c8d17319bff3a6a004b3f9d767019c62 *man/position_auto.Rd
f4e33dd3b73f846e28ba59b4ca9aa549 *man/position_jitternormal.Rd
90ee86eb2026d21d1a8afd45d73619e8 *man/power_trans.Rd
5e4f94cfb65e7a14c1e41ca0a2ffe522 *man/radial_trans.Rd
e7ebcf6bf39671dc8c5e8ed9cb067a20 *man/scale_depth.Rd
2d273b2e54b3ea59e54a83c28a5595ab *man/scale_unit.Rd
f9b2b12ae0d2b81e6a999486e8c3d8ca *man/stat_err.Rd
e4501f76729f26339ebb93cd3f853dc5 *man/theme_no_axes.Rd
e0c9cb605b5af22900c9f8ecbc5e8f84 *man/trans_reverser.Rd
766464f44861aab1d62b784c1a37b182 *src/RcppExports.cpp
3aa167414d82641dc6876e2f6a02bfd3 *src/bSpline.cpp
5d1dc745394f636ee366fcd3eb267879 *src/bezier.cpp
952452371235096bd5455de7fcf23f09 *src/deBoor.cpp
1e1eb94fe5ba5f4ecf4b4155c07f2f53 *src/deBoor.h
f2983d02ac4eab2e2aa9e6708f7239d1 *src/ellipseEnclose.cpp
59f4ed76184905f23c6980cf5fc48254 *src/enclose.cpp
9af531d3eec3d1b317098b9717be1e48 *src/pointPath.cpp