ggforce/ 0000755 0001762 0000144 00000000000 14020402722 011657 5 ustar ligges users ggforce/NAMESPACE 0000644 0001762 0000144 00000013361 14020361207 013104 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(scale_type,units)
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(ScaleContinuousPositionUnit)
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(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(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_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)
importFrom(MASS,fractions)
importFrom(Rcpp,sourceCpp)
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(polyclip,polyclip)
importFrom(polyclip,polylineoffset)
importFrom(polyclip,polyminkowski)
importFrom(polyclip,polyoffset)
importFrom(rlang,caller_env)
importFrom(rlang,enquo)
importFrom(rlang,eval_tidy)
importFrom(rlang,is_quosures)
importFrom(rlang,quos)
importFrom(rlang,rep_along)
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,setNames)
importFrom(tidyselect,vars_select)
importFrom(tweenr,tween_t)
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 00000004676 14014665042 013164 0 ustar ligges users
# ggforce 
[](https://github.com/thomasp85/ggforce/actions)
[](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 “shortcoming” (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 14014663460 012445 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/geom_mark_hull.Rd 0000644 0001762 0000144 00000023231 13674074434 015732 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()}} or
\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, as a string.}
\item{position}{Position adjustment, either as a string, or the result of
a call to a position adjustment function.}
\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 meassure 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 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}{
geom_mark_hull understand the following aesthetics (required aesthetics are
in bold):
\itemize{
\item \strong{x}
\item \strong{y}
\item filter
\item label
\item description
\item color
\item fill
\item group
\item size
\item linetype
\item alpha
}
}
\section{Annotation}{
All \verb{geom_mark_*} allows 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 00000014737 13674074434 015423 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()}} or
\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 display the data}
\item{position}{Position adjustment, either as a string, or the result of
a call to a position adjustment function.}
\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, as a string.}
\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 size
\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 = ..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 13435737063 016057 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 00000010216 13674074434 016703 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}{This argument is soft-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:labellers]{label_parsed()}} for
formatting facet labels. \code{\link[ggplot2:labellers]{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 00000014176 13674074434 014531 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()}} or
\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 display the data}
\item{position}{Position adjustment, either as a string, or the result of
a call to a position adjustment function.}
\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, as a string.}
\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 size
\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 = stat(index)), lineend = 'round') +
scale_radius() # linear size scale
# 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 00000010523 13674074434 015110 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()}} or
\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 display the data}
\item{position}{Position adjustment, either as a string, or the result of
a call to a position adjustment function.}
\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, as a string.}
\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 00000010630 13674074434 015053 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()}} or
\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, as a string.}
\item{position}{Position adjustment, either as a string, or the result of
a call to a position adjustment function.}
\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 00000004776 13674074434 015767 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: align='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 = ..index..,
size = ..index..
), colour = 'goldenrod', n = 500) +
geom_bezier(aes(x = x, y = y, group = group, colour = ..index..),
data = rocketData
) +
geom_bezier(aes(x = y, y = x, group = group, colour = ..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]
}
}
ggforce/man/ggforce-extensions.Rd 0000644 0001762 0000144 00000004414 13523007701 016542 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/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/scale-unit.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{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{ScaleContinuousPositionUnit}
\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 00000014041 13674074434 015344 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()}} or
\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 display the data}
\item{position}{Position adjustment, either as a string, or the result of
a call to a position adjustment function.}
\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, as a string.}
\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 size
\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),
stringsAsFactors = FALSE
)
# 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 00000010062 13674074434 015407 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()}} or
\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 display the data}
\item{position}{Position adjustment, either as a string, or the result of
a call to a position adjustment function.}
\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, as a string.}
}
\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 size
\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 00000013061 13674074434 016606 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,
show.legend = NA,
inherit.aes = TRUE,
...
)
geom_parallel_sets(
mapping = NULL,
data = NULL,
stat = "parallel_sets",
position = "identity",
n = 100,
na.rm = FALSE,
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,
show.legend = NA,
inherit.aes = TRUE,
...
)
geom_parallel_sets_axes(
mapping = NULL,
data = NULL,
stat = "parallel_sets_axes",
position = "identity",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
...
)
geom_parallel_sets_labels(
mapping = NULL,
data = NULL,
stat = "parallel_sets_axes",
angle = -90,
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()}} or
\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 display the data}
\item{position}{Position adjustment, either as a string, or the result of
a call to a position adjustment function.}
\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{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, as a string.}
\item{angle}{The angle of the axis label text}
}
\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}
\item \strong{id}
\item \strong{split}
\item \strong{value}
\item color
\item fill
\item size
\item linetype
\item alpha
\item lineend
}
}
\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')
}
\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 00000007402 13674074434 014720 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:labellers]{label_parsed()}} for
formatting facet labels. \code{\link[ggplot2:labellers]{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 00000001657 13674074434 016021 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:trans_new]{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 00000003557 13674074434 017414 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)
}
\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.}
}
\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 00000022331 13674074434 015247 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 = asp.ratio,
show.legend = NA,
inherit.aes = TRUE,
...
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}} or
\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, as a string.}
\item{position}{Position adjustment, either as a string, or the result of
a call to a position adjustment function.}
\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 display the data}
}
\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 = stat(nsides), size = 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 00000016765 13674341267 014725 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 = "sina",
position = "dodge",
scale = "area",
method = "density",
bw = "nrd0",
kernel = "gaussian",
maxwidth = NULL,
adjust = 1,
bin_limit = 1,
binwidth = NULL,
bins = NULL,
seed = NA,
...,
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE
)
geom_sina(
mapping = NULL,
data = NULL,
stat = "sina",
position = "dodge",
...,
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}} or
\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 display the data}
\item{position}{Position adjustment, either as a string, or the result of
a call to a position adjustment function.}
\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()}}.}
\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{...}{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()}}.}
\item{stat}{The statistical transformation to use on the data for this
layer, as a string.}
}
\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}
}
}
\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 00000012131 14014663460 015060 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}
\alias{scale_type.units}
\title{Position scales for units data}
\usage{
scale_x_unit(
name = waiver(),
breaks = waiver(),
unit = NULL,
minor_breaks = waiver(),
labels = waiver(),
limits = NULL,
expand = waiver(),
oob = censor,
na.value = NA_real_,
trans = "identity",
position = "bottom",
sec.axis = waiver()
)
scale_y_unit(
name = waiver(),
breaks = waiver(),
unit = NULL,
minor_breaks = waiver(),
labels = waiver(),
limits = NULL,
expand = waiver(),
oob = censor,
na.value = NA_real_,
trans = "identity",
position = "left",
sec.axis = waiver()
)
}
\arguments{
\item{name}{The name of the scale. Used as the axis or legend title. If
\code{waiver()}, the default, the name of the scale is taken from the first
mapping used for that aesthetic. If \code{NULL}, the legend title will be
omitted.}
\item{breaks}{One of:
\itemize{
\item \code{NULL} for no breaks
\item \code{waiver()} for the default breaks computed by the
\link[scales:trans_new]{transformation object}
\item A numeric vector of positions
\item A function that takes the limits as input and returns breaks
as output (e.g., a function returned by \code{\link[scales:breaks_extended]{scales::extended_breaks()}})
}}
\item{unit}{A unit specification to use for the axis. If given, the values
will be converted to this unit before plotting. An error will be thrown if
the specified unit is incompatible with the unit of the data.}
\item{minor_breaks}{One of:
\itemize{
\item \code{NULL} for no minor breaks
\item \code{waiver()} for the default breaks (one minor break between
each major break)
\item A numeric vector of positions
\item A function that given the limits returns a vector of minor breaks.
}}
\item{labels}{One of:
\itemize{
\item \code{NULL} for no labels
\item \code{waiver()} for the default labels computed by the
transformation object
\item A character vector giving labels (must be same length as \code{breaks})
\item A function that takes the breaks as input and returns labels
as output
}}
\item{limits}{One of:
\itemize{
\item \code{NULL} to use the default scale range
\item A numeric vector of length two providing limits of the scale.
Use \code{NA} to refer to the existing minimum or maximum
\item A function that accepts the existing (automatic) limits and returns
new limits
Note that setting limits on positional scales will \strong{remove} data outside of the limits.
If the purpose is to zoom, use the limit argument in the coordinate system
(see \code{\link[ggplot2:coord_cartesian]{coord_cartesian()}}).
}}
\item{expand}{For position scales, a vector of range expansion constants used to add some
padding around the data to ensure that they are placed some distance
away from the axes. Use the convenience function \code{\link[ggplot2:expansion]{expansion()}}
to generate the values for the \code{expand} argument. The defaults are to
expand the scale by 5\% on each side for continuous variables, and by
0.6 units on each side for discrete variables.}
\item{oob}{One of:
\itemize{
\item Function that handles limits outside of the scale limits
(out of bounds).
\item The default (\code{\link[scales:oob]{scales::censor()}}) replaces out of
bounds values with \code{NA}.
\item \code{\link[scales:oob]{scales::squish()}} for squishing out of bounds values into range.
\item \code{\link[scales:oob]{scales::squish_infinite()}} for squishing infinite values into range.
}}
\item{na.value}{Missing values will be replaced with this value.}
\item{trans}{For continuous scales, the name of a transformation object
or the object itself. Built-in transformations include "asn", "atanh",
"boxcox", "date", "exp", "hms", "identity", "log", "log10", "log1p", "log2",
"logit", "modulus", "probability", "probit", "pseudo_log", "reciprocal",
"reverse", "sqrt" and "time".
A transformation object bundles together a transform, its inverse,
and methods for generating breaks and labels. Transformation objects
are defined in the scales package, and are called \verb{_trans} (e.g.,
\code{\link[scales:boxcox_trans]{scales::boxcox_trans()}}). You can create your own
transformation with \code{\link[scales:trans_new]{scales::trans_new()}}.}
\item{position}{For position scales, The position of the axis.
\code{left} or \code{right} for y axes, \code{top} or \code{bottom} for x axes.}
\item{sec.axis}{\code{\link[ggplot2:sec_axis]{sec_axis()}} is used to specify a secondary axis.}
}
\description{
These are the default scales for the units class. These will
usually be added automatically. To override manually, use
\verb{scale_*_unit}.
}
\examples{
library(units)
mtcars$consumption <- set_units(mtcars$mpg, mi / gallon)
mtcars$power <- set_units(mtcars$hp, hp)
# Use units encoded into the data
ggplot(mtcars) +
geom_point(aes(power, consumption))
# Convert units on the fly during plotting
ggplot(mtcars) +
geom_point(aes(power, consumption)) +
scale_x_unit(unit = 'W') +
scale_y_unit(unit = 'km/l')
# Resolve units when transforming data
ggplot(mtcars) +
geom_point(aes(power, 1 / consumption))
}
ggforce/man/geom_bspline_closed.Rd 0000644 0001762 0000144 00000011244 13674074434 016742 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()}} or
\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 display the data}
\item{position}{Position adjustment, either as a string, or the result of
a call to a position adjustment function.}
\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, as a string.}
}
\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 size
\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 00000010773 13674074434 015224 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()}} or
\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 display the data}
\item{position}{Position adjustment, either as a string, or the result of
a call to a position adjustment function.}
\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, as a string.}
\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 size
\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 the 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 00000010117 13674074434 016541 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,
show.legend = NA,
inherit.aes = TRUE,
...
)
geom_diagonal_wide(
mapping = NULL,
data = NULL,
stat = "diagonal_wide",
position = "identity",
n = 100,
na.rm = FALSE,
strength = 0.5,
show.legend = NA,
inherit.aes = TRUE,
...
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}} or
\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 display the data}
\item{position}{Position adjustment, either as a string, or the result of
a call to a position adjustment function.}
\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{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, as a string.}
}
\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}. As with
the diagonal functions in \code{ggforce}, the wide diagonal variant is horizontal.
}
\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 size
\item linetype
\item alpha
\item lineend
}
}
\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 14014665042 014107 5 ustar ligges users ggforce/man/figures/README-example-1.png 0000644 0001762 0000144 00000145254 14014665042 017354 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 _ @ IDATxEYr\DQ0`@ NT0r" ItWoLz!N$ `L 0&h:G1uF^^ eggiȐ!Զm[ փK/]{4tPܕ1]ٿ?] (s0}kK
Z(v C7 "##UnX."Rmvc|ӸA(.%+xR Ȋ*%Ԫ1{m aG A@u-V
zJ[qQH0*ˣ<(l]N-.ShR'V[l+Ϋ]#@MPYeuW8p晊zq/ @!L2ڴiC&M"K;
Ӫ
=P$a]0כgwܯ}ʍ`2%4UXO^& |ڿb t//R)$B넁P% E)UtrH?~.N|91&REqfJC
?ҰDŽ<91&{.:,|:J3&'pU rk*ը[u-Rc GcD]ҳv~DZpi 4o1a%hWCcչ 0&@TCS رPcֲ ߚ4ljlԇXqwlct +r^XBYX>3 ci:X&X*|u
WW' GD +r{kLj 'c2ƾbk,r)^ -ļ~Mv/[;?%NSC3FfQz-4O%ܮQr'L 0&vm/V?!*D#MqQ0T6t$'~#"/(0bex~x !(UME]ګ^{o*EdjWIOVvK;Ѷ#RDm 6Xu §~; LBiԏS~^$;uGK*?FSs@çʼnN)`L >Y&
Bk0si.
nO0|ۆ+ f<7*ypd HBxn,eYC@FhO{RUG?`*8 {ɹ5hZL 0&lb#L B~Lxu
~xGJ13Z$L ܶ3jWh,,DlmsRQvb0mrdl)5bO߾@IB՟So,1L`I [ gcՇϙmYRRӺ|@ ').ȡWV}ٹ g yV>}QTG!B>D~WD4(2 p0tm9EGDg}(NnY|2BaLdk'?Eu 3E .4}+pAЕ`t 忇{Bj'Ѹe9jznukiq0 "YΎZmARA& !Xģ0ܧ}5
H
}J_焑kqyXEc.π*Z
Z *qSәg*)nw$niu\|DNjteTTT.dF W9 t"D/q (RBJKՄ J~w;p8S10FR(e FC{SD*a5#L|^=LX 1kEi>ڹ r 3fnuC٦ =}@툐u.QN SWqT\9"a Y+\Ҳڳ̬9'DiUe۾߁:ZUѣW5plGC}aZGW+{g*-O x+3qk-l ޝűxWb Cj.X W@łw11p4?->G)>,5Ft47^*լ(>^ eo-B{JJ
eggSu֮KZٜ뽗SygQZWsEԠmM"/aEuh~"4'c# ?9 6:oXEFJC(ć@lտ2E8hpj? Qp#D+ \@hJ6 E4p},J7J鷋y~tC)74L"\w` P+}+]D6ZͬjMSKXiCB}3\j/V1~
8/ĠlBۣ-xiu9R|dG(7nK
THb O wPuԯ}lBz>IK ` |նu@- ֳ#00E^&woUI3u@]}7?ނ`L 5Ā7unVn57jZ!!+Z#|"'H]Yarũ(E BJªe4c2\®6
bzO \?2\1?')/V|!|:C {xL ϧkɓ'mdϞ=fiـ `L X2" kwk_OMH>EM`i Dړ9#4&{:`cp/,s&N>Ү Cѳ>Kŋ̝;̙C[lﾛ 9b g2&u
hϩ(.PNm?!kG]"ih_)B\&͌'d]rkgu*(\ҳT6U ݱ24[H suiQ):ֱ>QXլsԤ#ӮB4 ^-=wGÅ/Sǂ.\W!QߺW+ƞ _) ]~
G -N:IF> zhҥұŋ:m4٫;M:b6 ` P7u@ij 뀚[=~9/K+ix #_Vp0
{.|&7tCLIqqq ;v=ܣ=t-II%<ƾu-WnM~R^p !(P\ 6`w9.T,VRo3tJ3*3gΔӧJM0gB|jΝ;-']VבQ/V @D|骪m3!|r,x
![z!ՂGx/5+pGj"B^G!Ap]n-YUYlך&J(T|N;y A,=+GE}"}P]uy97ɔ)SM64i$4Ҷm켼<>6lْ&NfAԖ^Z qWM4 bI9PǂFv>VUg 9PteyRjĊE]s:o%ԕUN1U5V ʉC+*g,ĈR Obv4WQ9lЕyWgFo3qr/ʷ[g3Piԩf'kr-GW_}E
r븸s&? z}Θj$#Jkp̳]RЫK,eR!^5Oe|>zj,:[dQgg
pYCI" iX1"P}3C?je~- )a J_ iB;gIXG
T 9/|b}WHczN25:%cN-nߵk ?^AѕW^If͢~ъ+_ACج%F
:{[+jEǼ콟[IL
'ծZcR84]4jؾ7 ]AqzhS=oKwGD#whC4"QN5+'F»q>plyBpt;,-s \ҝٓ6l`UVeW_}5
6Ln~ 0&D ;_X u3O:X+ 2ֱ'ݸr@H )Ԭ=/L> ՙ OQUR/T;
a a\ݬwƠ-A*^pdj S4]#cω 0ܾj `M!PP.u~O7A8[ uNhYJ 6Qb^c2(Ƴ_wR-gzZ-ے&j܊Ѫ$Z7C;tWlo:h펕U8Q~2H>GjhxP8d|S WQt Ǭdl_DJ#/(ҫ4\KKyB5%: Bio;,藆'X9V>QXQU6&\Y "7iOwK aZe| >sxL :
sgBkk%vWX Gà|#87Mi״ĵKFZrcֹR- c-\GRoO*, hؖw6ýiB('&3 `L
V\z
}LK):NOÖ٣U/OT_&"Rq
ӱQ?ԭU\'AnܸT$Q
[jS!S Ԏ[{[imȯ"BUiC> 1!:ЩU~9$n
ܴaU ?[)3ERί ¦Qi,\8.fyB1 0Mѓ_WSq^'!)Uӿn7
oʧ$cy !qm%i`c@hgRg#E|9wTs4EѶ蜮5t .
EȱANor7sYmKUTlo,Lǝ'A :}F^D[kJM8,ƪ
!Q张[:{$,fgWUw
&ӴIX=7s3ϛFQyFu@ƍ[1&,ni7L 91&< z]FH]x E-u=BUlOzׅ|['0vvy^5no(s
/!l
wѵc-xޘ p;JʰT~P
jβAXC t4,.ٓd A'|\Rʨk;CaH}eԗMUkc 7Jde+E:,BJ Me}zPzDGilP=>=<eVP48]J\~
AUFO2V2;
%]E0ʍ_C E6>|SjugI?B>G͉|kqpAz')>>^Yo>={6oZgL 8ME(wtAhU)Ǚ QND_A{и'Xizv9#2]^ ik_Eoz u}с(N+ 5=#!ЬU #wC}xg.]7tX
uBHkii#C_&QFv8t"^S3"BӧO\-B<ܽ~z2dmVW! B$(&C) o >廁nձ> W .Uq!*P7ifIj~S>YӼ0g)ݒ7)|vchI7^|S ъfK;˷t2 c s~TԻMM9;h\}(qk,Ԇ^yB EVz*S# eN*skS7v
-w湀G[g6mD'#رciĈj;wѣI&ѸqsW h]Dqqq?Nz fSÕgĉ>QE1BOXTU rk
%6Uk(,㨰akڋ*2`)/O BaXJ;Ǥ$ʄ%֜g@S3+p/ j={Ҳei
:sδ`; Ǫ;\rkCb.))?&a>x!!!2< V?S-6'Xe{dou mOYQM1gq"D=cK I̪l!
h QE٧f *,?J* S(op̈́ l^)~\4T 48:}*Bx +k_|(%.?QQQ=A@(l{ *мS"(\ڰԄ@ [: ЩE.gf}~,IO Mue1 a=ui]O+~Rצ[?J!.5]0>[clotxQ TXF*JIgsMbL L:\S&QQWI{tnYJS#"9gL6kR%L["ZC+ >6eˮ[ Ċś!RRY hUbF\ x6B5"-5R8d,
?M+$Tm2n$Wj piQYo :DXOVZy4f{F,*>`G\8Ss\ 1}U?4!M9mn-^<;VfE+weVwC
^݅j 6(i~w%RL]oevBўsPoMޤs\cUbkΌ#3+.x-*h@0&T._m<5zve 1 6+4 v (?Lw "7eXϥy+:Bo)XXGt _"C ;26Jx+}UFGZX|Qv&jo_pT#n2SV2Aۯ0 3;iii]k{=z=
`vl'EE( |2BU Cu'
a` %$ (V /nbjR E K FfXOr Ey2v. u'aA!և ӟg-1h)X
ְ h2"[t7y.LC, L5 z:Vt Ѵj+J|e;][m~i 4aVsbL
o@9ϓ 0& C81 3}Zj< ЕaBR:r$|{*F;:ЙD!! rˮF%]#˯I\L M#
"UIXQ\p,LוM(^ㇴL="n='&?i P!;t},zgDD䆨>rrr3l7:vVe]v+şKu\ O\3& N?46J09-!}c>J*Ϣwޡ.Adtο<_CSEKsO
{p !V%7_o'^uXzTT]H#' GcZ(]R'ow{Re9nI cD;z=l\=^qƉpl_$bƷKޖ d.zuJdt ]@K,@絹3TOIiFH?!)ĶsF1i>2HCJgX\a=[/vaί A-XfUVƒ?qTN:7Vi&_ai~Wh]OXQjsDWKV(%ڇCʑ0n%Y9yMeD |gNA
Q蚚cuU;6Bj:I6Bj:;m[zgy^LUXxk/W\Ǣ:}b_ ϩ (/.#BVR!D
l*Jj
t4.5
@'|4T&Ė9KX[>r<*^ 0R ',0?!`* bZ0
3Z$,DR[ ´=)RF2O 6o1|l. 0&{X {#3G*ӇYђ:g~6Mp -]F~ՕOh1FxlX.\>
59ݞ|ZW{DjJɲz3?%ɭWNmO]/ΞB8ǖvX6Ξ\ 0&3}fNɔ}5 $ _fST3gLa4RCԖf `>Ec(͘1/_nܹsiΜ9eȑ#VruiB%oi@/ ]*Kw|44]j"oCCS ^"mο,c J$D.Bt%ДV| \F|/zptw$| q ̘N I+ `^@#: '|K/d6 zhҥRkt!6C ћal ~ Lu@,V#FQ)sn87́̏=?[ L>f]UD u\Fߥ$ NzNVeQ[t>3#;tH |zm'ߝr %^|vG$Xi7u@
XGa 0}tͥ"K}'* 0V\OסCjuWԎaq̹Y:si҅4%2,3MxIYR|%sMncWS> jwJM4[U5Q݉|B^` i WCO{XLwH;N)'= rKצ\!MOd>:
I<_ @L(@+Ýb=~]=g{Xnќ*3?9MNNF,9vybE Q߯5hjj*m۶M%G'&Zv([WW< ;@ٙj cޫ:X {Zh[Ti24'cj3/J yRb?D8k.!T6ߑy9֧`iʱ!TfMmp 4
#
8͛GG W_}E
jf<|y&D
=Ѭ):Ή9nL ]w.} >>L=y$uhow-хЮ OW& mc)juO臲_|
OVHF dO]H1uL 0&!.N0f͚EKΤ$ѭWo<Ą/6y> ?<ܑ*
)#FB 1F 0&,&˗ N%4Z-xg\FXY`&ٖ!J P#ٴ{nƍ05Z9LPM-}> `L 0&< ? `L 0& %ĸ>`L 0&SX u
7fL 0& p L 0& `N:#$Gg8w$Xowכdvr\Y Z9['[-D6B ~?*sƫrvڦ̜y*k_O x3ƺ3.o ؋:k gbL{T\:JὌh *"ዄ # vp GEHHw[S3S 7-ߊ.,QN3:0 j[%f[ h!V |:- "9aL 0&@s|NNm:vHݻw8#GЉ'Բdڵz t,݃VYۦrʯL 0&
@lBO?4]qo]wE_wy233)!!AۗP3J3* P) pʭw{^![_RPE9
G 81& `L<"}S~hԨQ4n81b6۷fϞM۷f=QS3(pjZ3z-wK(F)j<*}Xlr& `L."ZıcHiiih9Ǐ N:3D䜼<iȐ!Զ~m}\@g}zDsekeS|Q
Rt! ;JAXlL% @ IDATi\UUH PVY, 3%
i 9' Ұ ̐CL3Y+hVVEGGˇ.>>^
ZTQQA6mHzGhرrTiwi SJOOw T_l֬rX[H"/qEpɀͲ%\BB,xN 7$[l 1pj¯)vFxm
Brrr3cWL(7VEJM={e˖"A\pN Ekת+HGp$ 1 ե8*k[=U 61$Ga~4gRr꜒JcU| .8RE; UV2N2ǂ7SRRbYñୢYĂMLf<^zQgǂw8LSNE(,[[֑,(( p*(@aweCO)7 Ob;LO=CdRDºO2K<)_0b0pYzT# *_el #%оd8 FnS& #G˧5r& `L (9 /兡 !S4322\fX|GLnEX.b>cgk'B B?#>@6 #V~%CHQKLy j}>&*/6+1ϐq?j͡eKm6B& `L X"viҥt뭷҂ hڴiX&L@{.]ȑ#i֭[;TABTAl(;!k<rlf,sQU:uB
D6 'ORPP_Cn=3& `L@K[X hɒ%mvǧ2UV)R 3f!; K۬7P',J6ڱл J^9_T[Cu!vl %(. 0& `
2
SSBO18FCuA+U}t@C3/S-JM7cUв+\"b7Ε*/L* rYrT* ^k[V@]ym5>fL 0&]<*5"?T%,ѱu
O
BG" (p>- 9R]NTU Ti_ A5gY6>c]Z֒UOuEͲn }GO%R+?& `L 8Bھ#}p]{àz#E`T s߫ 1^gQ=&teuIX҇_GUC욎h˺*I0H
*#\N%өNx*h4'7Z+0& `L1! 53"&'(tzG1,lԞd8uRXp*,91& `LX WBhX8&X.W_P TZkVJ_`L 0&åxOoFόjF5W]m$O
̪j t^7cڮȰo[GtDn: eHU#o4:R.IoUuOhovVT\yjo ¸ Ii_=M 07ïݓ:"RW%耥@̓[kI LhDk}s>xCq:~q}e nر EXJm{ev QPȔDžk"jRl}ﾥ{Uߓ B`=vj h!8$yyپ>Ie ŗ"m<6lD99"Oߚj
}!yY + Bd;ԩJ Z]#¯hLj:wyeaov~lϗ=u#Sx)
` @+w3̜%_}Z 刜&`!]"Os ^?Z'ȄRmj :zTyPsVV;& `L `TVABR:h^# Uc&bK=z tWQVz=ꪤGτSxMU<ʔK
g1T!+m2- -D*|CdpZ/RN68 b
ï2M__9Dª҅~#[o%L 0& B@R EJ MT* :Þ(\ER7deQԫ/R!6K&MFJbK;dͪsϣ~gq)|jDW1SV9nL0@D)vRԖq՜[#z?|% LS§Z(t[~ZOBjuN"{K4d6iT5 6k֪U+r}1ePYU-:~CW0w|8>i PX$lb@KMIIlb P~o^OKK*!jfU `a6D|X>L
ΐm[z'! gWcVy )2K.q
?J4OYYs*%3S_\9D61!&| `L 0gi pmNT[GA6[7*n,\C
Vl& `L x 9OիiiRsL@d%δǯ 7;cfѱaTm0CB7 v ,m>SFrp %\A Q>`/D! zI\TbŴX!TB9JN+뮾-]_p! ' (~ 5
?r~xǾ3_" h
5yc}P6Çɴ uЁ^~em3 ' ]z7 j}_)bp ; ,]{O?~h n˗S =l2 jJ g] 6MЗXYg֭uSζmy}B 85| N!tB V> ONU z_y^LSnms9K9"" 8p ر =*Ծ+4!J1/$_u">}O/O<$0ZVVhh[c=3_'qDq#տs=ZlN' /H]:oB͐8Vx;r@~~>mzdZuas
!Թsg]/Jƪ(R+we_k
Ŏs_L )`\ CI7L~+ B'8wV1xz /H-v ~QoTqy7^!?91&tnwqK_! >9s𓇐wy 0 *
' ]}2
>FO8A} {>ᬳ;w^91&4,6q |ZB["ޔ}NWX/eڵRdp #v F!Bm. Xӧ!駟hpќ h:ނo:;n!pHrkᔒC!r{O
_{W^Mwq > sligYzٸqw0 #+>vüyx(̜9SNN>Y
XYG{G|! a:bIQw&|@??L+Z1'&FЦqV&8e|ҤI u:
D+t Ochsə):Ə gX# ;0Xһ#8BEw]^Cp$qbLX m:;n!3/ |PC X "NC QӖ,YNp>nF5 Qx;|"ѻ+UyҤAtB91&t,6 'k.O?TmRlU"aM+t*^`LFjML(-Z/BK/?x&L#fΗ N][njk1&` D!¢(} [2&`7@F=A BωWsbL :iWF=0o#ݑ }N\7 O 4#Ǩ78oF |i&q,z 9_fN~_0&М}sΟF=aǜ?`ֈ- @!bu}m 'Y1":Mi0&4'
a,jO`'o]Vd}N D@1QQ y2T@F+/ʉu7 QEi4| t!tbK 'O\oeL X+:0d $SY+[{>_ 0&t *>F
x nMe- gL 0&j2>F9HPS]kDi5 `@@1
:y 1
A1'& `N J%F}nzY u~hr ܔ 0& 8iQvշ'I1"RV:rx\ 0& +c/niLF+/9L 0&0hjOP Hx `L &
+k{W?H=eddPnhСtyyd9y;SN 7\
1 eII Qvv6>}Z
06 `L 0o' AJ -.. 3fe]F_5 h A "
kuG'PNL 0&k @S|z{,:hтz-Չ 3ЩS(%%Eq]W7alW'& `L}PyǏdݻ LgqM!9=@<3iԨQƍ@GXMOOW^-%K7L;vK. "A U뮓[#F>H-+B ?S/B;_K'N}}裏҅^HGP![lkoC /`L *(aiX|'>+a :tkSnn. tذar_+xyͣ'Oҿ/zi<@;S{ڵPǎ !'{RpP v ˗/QylcESZ^1& 'UQ;as6m$~m [HXe^qyfYoQ˖- B fffұch˖-r~S-v$,J RVhԩJ6 UW]EW_}5Ae@;6 8,b ڄצMmGN<,+oT
@"L 0&K^VV&<Ǫ(0w$_ʒ[ݸƹ+&NH}?KcURsw$EEEVo۵kGӦMyD۶mmnōuSbblb{ X
)tS,덙v +WnLĤ駟z|~Q qu4ޠ0q&ƇrE|SL 1/;<-P!Og
K[QQنE@0 UoTN 5 NW[_({eTfW믘 B[R\[#}ü`sg
G|>.ng[[2#`(kPY>5eZ (NU=|Ͳc҈#z-?t f D|hWv+o 0&dX NE FS7Lo
9sf̘a."(?3-\}]Ky*& ,Ī;[csPXX6ye!;ۂ?w9/((pdYs}c?)>s Xd :# ]z54qDS)S7B~*(@aUS81& `L h,0&BR$!)ΝKC\Sgddbb5Op-+V_§1`L 0&okiL
\"aY CҮ]OO
m6d g sȑ4~x[i֭vv]gL 0& N6W@!:>(>> [N}Gf={
6+VR9fi% `L 0&kӅAthт:wLIIItUWɿ ~eD§prGL 0&J"
'z ܿص)w҅~7s38ÿl `L 0dK+SY½wMmr)
[2\ | ' Ջ~G'"t";
M `L 0 P^D.klPP !_>F zDDIўu/Vl
w}7! '|B]w4D2!2j 1& `Ihn(ERie@VWD Yub"O͌v_#<"
aɦ e"ʲ:_i
0& KT[g>5Ky|$
=un ϒ17Jw&=oݺ Dխ[7
+;wv :tۜ
` 1 (f% E<= 1 OOO=ꩨgTP1cDA$Hλ_a33=,S][==o*W]]O:Fu&R<=KN:$n
e/l 3 sk6۶$Uk?!68LǾuҦ,Il9\slݺU
-[襎曵!D>@ )avYVGr߳g ~;@?ƍk-Z3F6oެӗ,Y"/ >965Gf̘GA99S 6 q~2 8O*gɪIѳȑ*# VX o *8m 9 .Q%_u=Ry-h3glڴIr" SO= r饗ʉ'@EDJ21' ,УpuI\l< /bo4c|vΜ9SoLBd$ EL
@tQC`OӣsJQS۶>}ҚӽޫٜuYLlƞDQTsR7y<~5"1[oi#A{{rWx߾}{=rjd)FB!o
ܹs68 ,\p\rUW !ym u,qo5XȊ ۰v jL$'WM+]~gҥK51^k299YGDcǎSأSYY
F}imb3^{ԫ5wk)[㛂&
Е+W~uWh SHHH_S$Aȼ/Eҹ
Y*؟sʀ 6sց]C , Ĩ^xp+'pjׯ8 : H/ 0.h_˖-PB0mЗ-P RpΛ%;w!Ʌ&hΓHm3%Xυ/ >k/
4}?b_V|=Oqq)M{l &j1X~҉ҧ z?G6NT5*ٷ/pWiJfXK'%%%QF;L16l4GN|6Qu(,
xQ4 ac%bn,HHxY-Y 0ʷܴ7AJ'tƫU
GWmŔ9\#s\Ot5>p0>Q(vYҡC 4}tߊB$@$@$@YU%5tGTɳg˪bT%Xbi
PXXzˊ+R
e~3''GoN+
@hp'R3 ^E(mGԕ *bXC?RHHH@ZMo /2y0j)#.x4yݺu] \5k籥 ၟB$@$@$]lrDJ_
=jdݲfG'C[z-G+Ծ;혎SSؐjBZ2[┣Y6\9.5PC-T1ŢmFH}ŽҊv =?[{yُ]V@K $ _Ib8gΊmC0"oŶ]/6\233]^zIF%iii;x4@322IHHH2>Jf%ŵ( |MZ&m^{59}2@:2dHP f킇ŭ[ƍeٲehѢVHHH|!lL]yZZW!×^_ٯ)((p3^UU%EEE{~Ml556l0?Ր^ڶmk͛7;6N -[n_qW7/KVcǎҵkWp :(IHHH ^/&]A ~ٌ3 of9dңGm`0>p@ꫯdܸqzW_- zlڴI_GhôX=X9묳OiӦ۷oN;M8 4h 6L9?Oy\a\W
ӧ˘1c?Lwci+ Gse~ k
Woӣ
N4#a =nr%Ȟ={dΜ9ژ/SO=e|g FGap.X@/^, ~F(C˗/Wyzm㏂RgڈHLc1 #֭ |Pz:k.=ީS'[dԩF>*wbvcSرc4?NLckE ś<}9j|I
#Xh;KټHHH F< tm$6uÀīwؠ>z a#8}k@ zRL^òIL0=蠃'szA{m^![!2SN9E:w
Samjyy: # qBkG
CTzMIIMzfցccc?G7 &*ljDᗹϒD`᳆d& 1FV|{ #Ep
۷/jN|F|Nbמu bj1Asʂt,31&Oc6<4O>qDϴ54
0ٔԓ<0]O#ݓm EU9uIGj'x a*XjtV݀mkjb$#f{m1e~Cۦ=FmRQY1fG_w%ٔ1m~]z[ؒ6ڧ1e>C M! /?aԲ1y
S/u5v!-Z Մr+ !l.v
u j ?x6_B;+GrH9ꨣzO Ī' zvJ^#?F"BM5g .ۿ o,k`BqZ~
ymb;W^G18'!\_ݞ_t4e ao߾2i$)''GǗ?y@$@$@$@$`
1j\ŰnZn V,=րbzl-lڻw%׀",B ms܂yq[>i=o5Pݻ4P|p_:.Jj
h0mhq03 g ٷfVcWk@a ^yz;: Fd$ nz<1>$@$@$@
|6En'$;y=PK
N{9O%Ootr9ͷ ov3㽩k|۬J٣
XyuFU5uHHH |)sɒu;bex9v+J~#Y;/ʢ_UVׯ/)i!OP;wnzs7yU =9ydA+B^~eٺunBTA$@$@$`kچFo
pMUe87;P B ,Va銣G,=+*ǴrBG 1'n+ B{~Mеyf] Ƶ[ M1 hr)CkI`a/ SѣzRDF!CQX3'6c
kA%
P RHHHH Ugls tQ:u$xMKk'|RG={`Bo5J̙
ZbӧO믿^EnlPz@WUz 7P^HH{ٌ;P^m$r u% #gϥc{ 1Ee@*S~ "RւIPK1 o0Z\ >^ "!V]cְ
$@$@$`iI
?{q_KoĂSF("e!oQSմ~#&Vɍ4$y:@eH2BQI.,4p
hdkK$@$b *TMmkɃ" ) r5"n'xS9"(`QIIIRUU0Tf[}M= G$&&4vm(^G
?tYM,}yV% wH3xF],A}SSS+7 *%xzy
p#z<\D5m !'`a0/XM.8.,,ZtܓeeekFp_ZuD Gh)_DIHH/4g$Þr&p'%9&IntNH h6" H'dy,UN!?+c.!$9WϖcZIIe @@ȶFS!eUhmU;O~18+
Р#g$@$j11 MCr
kE|fךA!L F& 8HI (9\bljέw *
}&Ś:*rɰ$@4Y6 D|zr1DrjdT 0$5KIdɈK. k*E >2N 0@^:y༝ (FHNziy
6;yYR\lq24mdgXU@ m /& 'dSi?4>#冀ۥ j).fH7֓SVYHHH G@ôcX- g6My^ʕ\M]7DFXEbcb|= US_#*7IZ_-s JJ+j^eHH @*dʚecIim,7O2Tje鲭jjZ-ĥWk{k
UHrTZW&];{ZcH<G<&1Fs,#U(Ϸ (
s0@$@$@@䜑-ϐt` KZ%z$ZIY$ѡ8 }Z ĚXi=䠔./{ޘBk62 HHw* IWF.~$l}wM̸ ,yöV{/*4VEXJ+_,ڞi`}C@ LB E xG &&F6] ˺OGCszwus?Cd^磤l8j&M" h@PG@KKKe2h ۼYܾ~.77Wza '4RN=eӘʮ]$++Kӧ
ȿ 5Q$+3eh`˴9
|tYZ#? h]Z\{: #+l4osN|_LZ'l gybZu)]1Y~'qI2opvk!K7$˷HRMF,tsZ ^bnذAniѢk ͺudҩSƲ0HBB52a4VmRb'Tx\^< !?eOO
_qb{/oy_fn|~G_n3it0y
CO*mݭrUvm왿,]>\2|9m,_^>C>_6yS\^ֺu& -//[oUe
n"OAAٳG/^,C :8-..Kڶm+yyyf w)Gl.zbcc%)))\cZ=Ή\Ę<Ċ
B½m.=`|ËސQΔ$Wܓ 9UÛuO#kQ}P =Hjkrph|/9Ij$5뵤4.9%IV#}եkOm{NtxׂX߯ 5[qX̖Jn =tJ qRUU%K,6mL0A
f#SL>}L8ZUrrr4r۬bȸ½] 4(;5uMsPF9ZYѪZV9NUU`
:>=ArR|{^WIL)RaCD_-R$'qr/s!|_Q #Z?")"%ZEʪbһCu;%q~uHmYtlA1@AԻwo;wdggݻw{ =C>è -
PúzNݻwdQ F V4saݴ2gf'ˮ!̢3?뫵q6@f_*vϷyN*OPn]1K&~g F@1(LXJTi̦N$Jm 8MNWz<תUF'3D
طor5 P>
vLu
ăݘz+ʷX]FmƱ#)MPGթWkmuP;$+.ѺbInB=Ct_2AɝPAn9w3A稱ȜCՏt[.Z(Qz?#5Z_knUR^B+ryd3NpuuțT*iǹkS $2>o?g_z3Ar1 嬽~mL7n6mkV^{5{ON8i1l @h'_/o~Olr
#kZWfm~\mrAhFzvx] 24{Mjm;?|X炼 M_GZWyqw(vƅv۔noĨ O:HzT9};W-#/[%>&zKjzSL!7@s֬Yҷo_5jL4IO{gff̙^kM$0 k5UZ Jpw=p@PG8_^HTQq
ZSOn3\ u·$@RLbt* (G 969 ~H(\*}>~D]S s@\| tGe3f:^)
FSߌC:N>^g֯[JgiЗhv| N= '<4 KIrHBu$hFb$D#[!W Kπ>\ Q&`Q$(B v!eywtNj׃~W`K dA*ꢾo}~}3 e0m=\B6a9 @?͡u / `)G)=\Ou)4z~@ë?̪
G@"I=$@$@$@$@^&f" 0 WKEz,I P Z %ζd;Cը{>{v:>0y9~ܷq ܓNW 6?\ U9-ϐ ƛgs[#;ɜ]oUw~ t)gϔ{V&o~W0oJkʔH M0(dv,x8Z hKW1acDsqZq
(g;ȍϖ7_^90tّ}?вsqNzey0Y2s#Nzf 'v)ozrڛCwÌ>~^X6z oy֧ vvvrj Nix5}\=H)H-5n\ 1OR9ƆC 2g~)w5>lirx'~]DCO
Ɯ{SPM}\z'=iW{ 47 T)W) 2 em3y_ ]37=,+V^GaMhXw+J;H(v*xڊOb _
+6?G*n7ᘽЏBڠ^J
#(G%u=$@Mhd k @ 8/FdɝXjDwrl#%{ bS 2wMno\=DJ,*!l0AF
)3'w0>[ ">AyL |"]l M`zz
0pLʐ9oT xz$wsO ϓjpYeAv^4l:( }G{ mI
ҽM=a#?Pݍ4z7A" X $wdy}cs &$7}MHnD@ٛZwηH utHHXq@n!SYԮӲ5&wO^~ nu)zWxHշJƶ !g Q7`K6ǣjme\f Q' t=5 /Mi)KZ9opQ9je~GO9Q:$ dJ^*&$/A)7! txtdbD u^loza!P)žoDA*2))Iж{͆IWHLLKIFjj$''KAAAVz g z!>k/j^jVnR7
ZlbY^ 8/p pafǯ"R5[_ Vp 5'|Ca5تrj,2!7LbV6kޣ,Blw^Ji}Ma8v)QpTWFɻ}^ bϐ )]}
ӊ>|@G$@^xGrphnE7L}/)YYYsN˺a
oLb'hnDIJI XGZ8aQ;S&B8@ ^?Çzg mpIHpFS\p4\ rY
@pЌ&$%iD"
3XӁ1 'S \m$@$@$@$@aL#.i緾&7nqmeB-o×|yzKRX[$CsYƈ"m/KxJ`95g*y= @eb*^nf o 80< ɰupT/J;u~U Zq]DžUr})~$@$@KS}Q2;x7gWtu>Ե7ߵ4P|T c?WA94q;w|Q _IHHYh:RM}9͕ |s:F|A HY:_xL$@$]h:wnѴsb8!I < tK?%jf~UkJG9jLQ]Oj^^L$@$niGe\QN͏wtV 1zb3_տ
Jͮ?&HJ^^L$@$ ɡ1]~Wd~öGƴ٧9! /lv{n9>hK~WubKt㳎cZ[/ D/n~LYbHHn$@t 4[hjf> (%)(x6HHHBE hii| ۺfYh1#OS/62B$n&]*egcFອj A4K~ul)ߦ̛ɡPv{})$@$@E hSrwJll 4-G yDV\)=z'xB qԩۼL ,7/d/.eDSવWE?ثp;l=S_ya˂>/K(4E/C m\{[">ӯw?eA'JM*~oKf|_zy1 y2a?~4Z7ʗ_~)})2_,Xw2sL{ڨQߥ aff%%''?+-C;v /:R8O psLߪwJ9Jr\ZVtT9e7 =8VB~Mܬ~Zlff\XXW$vJÍYY$gA)<~D<=K\GAVFIrr"E#g3FciѢgƫcp if~½ObzSA*;0EV[[+)))NvU
5xk+ [X`@MMizEQvvGn卖7?٠u
.R¸V#/5(m|oY[iDmWFFi9L `8vuh7m {YZe?վ./ޔϒD)+q>++K`wFݪg*Qvˀj).ͥ_jjjP :
r%P\V^2۶e?; 7R.c/# t ŞNWX ƞ|P%禞a-OS* FIƷ '#[cқb0ErfPu "͓F* D F
mG Wڴi]xzٳcǎr8 `4KZX}S#O *-Vْ >+hEZsW #I1
vkxSe̸&#+/qIR]Xi$
zɈ:hu 80@ G@à _^^x(8T$)S|bIdĉrE?av3 d)w8Gv$fIjT1L ӕ"` #s%w4>Չi$@$@ u
!C >\jǺt{:HHHHC 70e?
5 |
ޚX* m IHHHBh@R) @ch6F$@$@$@$@!@4 XHHHH14@#t TJ$@$@$@$a: @@
V*% h
0HHHH h+ 4FhcdN$@$@$@$4@JIHHH#@12L' J$@$@$@$@ @|@Iilldff^BҤtV n.!###U H 7+&&ƒmó$..NR+6MBH80E~LLLb=m8,//7WIIIѺkkkM jh_iiiaz Ly^@@1c~=|)Zm0ToG]4̪$~
5fˇQ]SSQ7g馳h1Bik EgVmqO}jfUGIɪvYm7ϸ?j~J EK;4Zz$ 0!@4L: h!@4Zz$ 0!@4L: h!@4Zz$ 0!@4L: h!@4Zz$ 0!@4L: h!@4Zz$ 0!@4L: h!@4Zz$ 0!@4L: h!@4Zz$ 0!@4L: h!@4Zz$ 0!@4L: h!@4Zz$ 0! zݻW~Gҥm7o۷J =y@$@$@$@$bOr˩*O> ?^F ـ>+v풬,}O>4@Pb D6>s=ҷo_;vL8Q
&N֭['gϖN:9
u [
F3!yyy*۶m]IKAAٳG/^,C :㠲RlbOKJJ{*l6Ԇx4mV7U
X3ۆvYrgvOψ{nIKK*%-ZƦ~z%Khrڴi2a=Rj\zj7nVOGS & dgg1|Եj*|*crMZliQ \:+ߓzXL&
(%ȢX@
P 9ֻ͔wo;wF_s2@/گ&|{ᄑo߾u7PȐPV! ecIچt+b栬, B_x )aj#iVk`v^jjj,6|;8Ҟ%X@
P415BvHÃ0@CG mH0uo >V| iuuBX:}JT|ox.xO]>bp?B6[q ڹs%౾BaâMv>kP* G|am~Ab-wՔѼ1> HHHH r ,) @
Y% pK[,L$ "K$@$@$@$@n u$@$@$@$@"@4PdHHHH-n0HHHH Ph, %@-&
@^ hD @(K$@$@$@$
PXH$@$@$@$(4@EzIHHH IHHHEhR/ [4@ba" @ؔJyJ||HRRTUUIiKBB4z>ROJbbTVVFj<zmmUG{}رceĉ2l0ILLqF/7ߔXydΜ9r7HHHH [J>}4fU$..N4KeX6+[BBiŶY?|&跘Kޓxl6INNZ i+~[A*[ʨ h
;v8=`Dײ2Y|=
#x-xB𥁇_jNFYm`k~C V7ܓƟnrmx[1Ҟ%uuu)z`Tk>III1_{%=( EزeKٷo˳AvvZ9v~?\Ł/ =o5AwVxg FjK &XMp?bԭjMmR\\ 1m}j3DLYF _|tEjSZj%+V!O۶m `$5v_?]Hl;#7x,YD|+VeVk=V\2m4#^O`Ĉzwe
-M`W i죏>Z` @%8AR (^Ot uQ:O(ï_c0DqP0S ւ-٭`ׁ5 s(c?~So :tٳg;Mh 3
_ɓ' Ձ
gyk,)` fر ͰatP֟eG] {Lvі.j
UŨ\}`.
2
/ n:m~2|J -]v+ݲ5V]/s1_y3h>1K ?o M7Qҭ[J>}t%1;@۶m MYjZi#5j`: SMzk>06zhň%vZ57+~[1ԣk= _{zd3--jb]r
7'K
ToX?o 7,:.o B+V
z@DA_p҄Mhc zob<z wqzSHw}S_~]-
MpҫW/UV5Z(?o G\;>U7wTBM~P[9cߢ ņN7~p z!6vW;
b;"&F<6 qݸ0.;]H;;u$ͦ
F>pky> [vcB ` !~,\s5~{7_cc
ysco#77Wos|N[/Zj(\'N\cDŨvb-M7$: vSw] ;Fѿ\駟6Gg%0g K'ky1 cy :i| %U.b="8?o O%z 3\@0DQO촅'/ELj'FA* SF.H)d`ܚˀႵ:&~×eiî?Jx_;;O/3fGך詑c^?LbE:u曂gyFnjkci ũJSS SMFæ7x6V5~bSRRRcY y 1JC W_y (_&ͲHHHH$j$@$@$@$@!@44Y* D-Ql8
pg$@$@$@$4j
' X 3lV{o"ĬYK/ ;:,X ۷oѭ bB5%K..],HAяl B #!N[G 0 FA?w}y ~^]`|SHH!@ B&\|h駟.S#
G: Jic!ou?=#
}Qˈî IDAT.L/'x衇"6lo];/yCد
7ܠsΝ;x@$@$8 ? Afwg}X4l0y饗q߾} ~ :T8 =}}I'u a # \Vn[N }Qm(c1 #r6JQh~~#F_|!guNz!B۷o/ rX(i0±N ($@$@^QHHOjM=6l&M@mf;ve˖6ԦuN5oKKKv;;#Mz4>w^2 m=
u 5j\~+IN 9AڕW^^|E]֊+y;N馛l[u72(CӦ O.̙}EEև QƪNSF_IH!]^BF S혒(S&ԡC?Mm۶ɮ]d֭: _x>t:2)S/6G)~*..NO 4YC:u$h0*cÇMT7I5#Lc<HHq4@g3$~i1A.w5"*V`jk? ӌk+++sΑoFr 4h\pWE'r,SN7uU?u I$fee9fw{hhƫL$ hF h6ݻˢE{}ׯQjժ}a͛7OoR¨iʃ!خ];qܥ%$$xCe˖9
y _H,N`z=F4{=ILL M ~ES 3 S~[1FG]e2{l;'CJJJF(l2`B< y ]9J=5.z5 뮻N:Q.xCq!ZJH+ ohƍW@T8p̙3Gz)ıC \0"0Jn2dr X9x`?S^YPP`? '`}t#ޮAjcE?qDXBoj' T HB$8l>48F>]X{
AĨ$!pQVce`SRR6ꫯ֛ Qt]Oj\W p;NE$|3> (泹'Ô>b Dgq]Pv < pgtH*050<z
kC)$@$@j>Sj$`+x
@
[j& pCk@@a @
[j& pC(L" cK$@$@$@$@n uI$@$@$@$@#AVBSH IENDB` 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/logo.svg 0000644 0001762 0000144 00002756266 13476153736 015635 0 ustar ligges users
ggforce/man/facet_matrix.Rd 0000644 0001762 0000144 00000012354 13674074434 015417 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,
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{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 00000015266 13674074434 015245 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()}} or
\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 display the data}
\item{position}{Position adjustment, either as a string, or the result of
a call to a position adjustment function.}
\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, as a string.}
\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 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{
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 00000014111 13674074434 015527 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,
show.legend = NA,
inherit.aes = TRUE,
...
)
geom_diagonal(
mapping = NULL,
data = NULL,
stat = "diagonal",
position = "identity",
n = 100,
na.rm = FALSE,
strength = 0.5,
show.legend = NA,
inherit.aes = TRUE,
...
)
stat_diagonal2(
mapping = NULL,
data = NULL,
geom = "path_interpolate",
position = "identity",
na.rm = FALSE,
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,
show.legend = NA,
inherit.aes = TRUE,
n = 100,
strength = 0.5,
...
)
stat_diagonal0(
mapping = NULL,
data = NULL,
geom = "bezier0",
position = "identity",
na.rm = FALSE,
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,
show.legend = NA,
inherit.aes = TRUE,
strength = 0.5,
...
)
}
\arguments{
\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}} or
\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 display the data}
\item{position}{Position adjustment, either as a string, or the result of
a call to a position adjustment function.}
\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{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, as a string.}
\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 size
\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 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{
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 = 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 00000021345 13674074434 015727 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()}} or
\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, as a string.}
\item{position}{Position adjustment, either as a string, or the result of
a call to a position adjustment function.}
\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 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 the other
\verb{geom_mark_*()} geoms expanded and have rounded corners.
}
\section{Aesthetics}{
geom_mark_rect understand the following aesthetics (required aesthetics are
in bold):
\itemize{
\item \strong{x}
\item \strong{y}
\item filter
\item label
\item description
\item color
\item fill
\item group
\item size
\item linetype
\item alpha
}
}
\section{Annotation}{
All \verb{geom_mark_*} allows 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 00000007625 13674074434 015077 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()}} or
\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 display the data}
\item{position}{Position adjustment, either as a string, or the result of
a call to a position adjustment function.}
\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, as a string.}
}
\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}
\item \strong{y0}
\item \strong{sides}
\item \strong{r}
\item \strong{angle}
\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 00000022502 13674074434 016423 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()}} or
\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, as a string.}
\item{position}{Position adjustment, either as a string, or the result of
a call to a position adjustment function.}
\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{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 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 and
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}{
geom_mark_ellipse understand the following aesthetics (required aesthetics are
in bold):
\itemize{
\item \strong{x}
\item \strong{y}
\item filter
\item label
\item description
\item color
\item fill
\item group
\item size
\item linetype
\item alpha
}
}
\section{Annotation}{
All \verb{geom_mark_*} allows 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 00000011777 14014663712 016646 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
)
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()}} or
\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}{Use to override the default connection between
\code{geom_density} and \code{stat_density}.}
\item{position}{Position adjustment, either as a string, or the result of
a call to a position adjustment function.}
\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()}}.}
\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{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 00000021751 13674074434 016234 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()}} or
\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, as a string.}
\item{position}{Position adjustment, either as a string, or the result of
a call to a position adjustment function.}
\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 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_*} allows 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 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 00000000607 13435737063 017041 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{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 00000007524 13674074434 016737 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 = NULL,
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:labellers]{label_parsed()}} for
formatting facet labels. \code{\link[ggplot2:labellers]{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 00000013601 13674074434 014711 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()}} or
\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 display the data}
\item{position}{Position adjustment, either as a string, or the result of
a call to a position adjustment function.}
\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, as a string.}
\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 = 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 00000006543 13674074434 016005 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()}} or
\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, as a string.}
\item{position}{Position adjustment, either as a string, or the result of
a call to a position adjustment function.}
\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 13435737063 015310 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 5 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 00000004375 14020402722 013376 0 ustar ligges users Package: ggforce
Type: Package
Title: Accelerating 'ggplot2'
Version: 0.3.3
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
LazyData: TRUE
Encoding: UTF-8
Depends: ggplot2 (>= 3.0.0), R (>= 3.3.0)
Imports: Rcpp (>= 0.12.2), grid, scales, MASS, tweenr (>= 0.1.5),
gtable, rlang, polyclip, stats, grDevices, tidyselect, withr,
utils
LinkingTo: Rcpp, RcppEigen
RoxygenNote: 7.1.1
Suggests: sessioninfo, concaveman, deldir, 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' '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' '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: 2021-03-05 08:25:05 UTC; thomas
Author: Thomas Lin Pedersen [cre, aut]
(),
RStudio [cph]
Repository: CRAN
Date/Publication: 2021-03-05 10:20:02 UTC
ggforce/src/ 0000755 0001762 0000144 00000000000 14020365341 012453 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 13436332364 014626 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 13436332272 014451 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 00000010722 13436332346 016140 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 = std::min(points.coeff(0, 0), points.coeff(1, 0));
xmax = std::max(points.coeff(0, 0), points.coeff(1, 0));
ymin = std::min(points.coeff(0, 1), points.coeff(1, 1));
ymax = std::max(points.coeff(0, 1), 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) {
xmin = std::min(xmin, points(i, 0));
xmax = std::max(xmax, points(i, 0));
ymin = std::min(ymin, points(i, 1));
ymax = std::max(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 13440437650 014565 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 13436332374 015145 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 00000012704 13674125322 015463 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;
// 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 14020361201 012054 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 00000030431 13523237540 014665 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
#'
#' @importFrom rlang is_quosures quos
#' @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,
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)
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,
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 vars_select
#' @importFrom rlang caller_env rep_along
#' @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) {
vars_select(names(d), !!!params$row_vars)
})
rows <- unique(unlist(rows))
cols <- lapply(data, function(d) {
vars_select(names(d), !!!params$col_vars)
})
cols <- unique(unlist(cols))
if (length(rows) == 0 || length(cols) == 0) {
stop('rows and cols must contain 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]]]
rbind_dfs(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]])
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) {
stop('Unable to pick a scale for ', var, call. = FALSE)
}
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(unique(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))) {
warning('layer positions are ignored when the matrix is not symmetrical', call. = FALSE)
}
}
utils::globalVariables(c('.panel_x', '.panel_y', 'col_data', 'row_data'))
ggforce/R/bspline.R 0000644 0001762 0000144 00000022405 13525501222 013646 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
#' - size
#' - 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 = ..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 (is.null(data)) return(data)
data <- data[order(data$group), ]
groups <- unique(data$group)
paths <- getSplines(data$x, data$y, match(data$group, groups), params$n,
params$type %||% 'clamped')
paths <- data.frame(
x = paths$paths[, 1], y = paths$paths[, 2],
group = groups[paths$pathID]
)
paths$index <- rep(
seq(0, 1, length.out = params$n),
length(unique(data$group))
)
dataIndex <- rep(match(unique(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 (is.null(data)) return(data)
data <- data[order(data$group), ]
nControls <- table(data$group)
groups <- unique(data$group)
paths <- getSplines(data$x, data$y, match(data$group, groups), params$n,
params$type %||% 'clamped')
paths <- data.frame(
x = paths$paths[, 1], y = paths$paths[, 2],
group = groups[paths$pathID]
)
paths$index <- rep(
seq(0, 1, length.out = params$n),
length(unique(data$group))
)
dataIndex <- rep(match(unique(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(unique(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, unique(coords$group))
}
startPoint <- match(unique(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$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 00000006671 13526445325 013672 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
#' - size
#' - 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 <- ifelse(is.null(data$m1), 2, data$m1)
data$m2 <- ifelse(is.null(data$m2), data$m1, data$m2)
data
},
compute_panel = function(self, data, scales, n = 360) {
if (is.null(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/ggforce_package.R 0000644 0001762 0000144 00000003236 13476154511 015314 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 = ..index..,
#' size = ..index..
#' ), colour = 'goldenrod', n = 500) +
#' geom_bezier(aes(x = x, y = y, group = group, colour = ..index..),
#' data = rocketData
#' ) +
#' geom_bezier(aes(x = y, y = x, group = group, colour = ..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))
"_PACKAGE"
ggforce/R/mark_rect.R 0000644 0001762 0000144 00000023543 13525501214 014166 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 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 understand the following aesthetics (required aesthetics are
#' in bold):
#'
#' - **x**
#' - **y**
#' - 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', 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, ]
}
do.call(rbind, lapply(split(data, data$group), function(d) {
if (nrow(d) == 1) return(d)
x_range <- range(d$x)
y_range <- range(d$y)
d_new <- data.frame(
x = x_range[c(1, 1, 2, 2)],
y = y_range[c(1, 2, 2, 1)]
)
d$x <- NULL
d$y <- NULL
unique(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())
coords <- coord$transform(data, panel_params)
if (!is.integer(coords$group)) {
coords$group <- match(coords$group, unique(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$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
)
},
default_aes = GeomMarkCircle$default_aes
)
#' @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, 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
}
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, 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)
)
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, arrow = x$con.arrow
)
setChildren(x, do.call(gList, c(list(mark), labels)))
} else {
setChildren(x, gList(mark))
}
}
ggforce/R/zzz.R 0000644 0001762 0000144 00000000312 13604601424 013043 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"
}
}
ggforce/R/scale-unit.R 0000644 0001762 0000144 00000011355 14014663460 014267 0 ustar ligges users #' Position scales for units data
#'
#' These are the default scales for the units class. These will
#' usually be added automatically. To override manually, use
#' `scale_*_unit`.
#'
#' @inheritParams ggplot2::continuous_scale
#' @inheritParams ggplot2::scale_x_continuous
#'
#' @param unit A unit specification to use for the axis. If given, the values
#' will be converted to this unit before plotting. An error will be thrown if
#' the specified unit is incompatible with the unit of the data.
#'
#' @name scale_unit
#' @aliases NULL
#'
#' @examples
#' library(units)
#' mtcars$consumption <- set_units(mtcars$mpg, mi / gallon)
#' mtcars$power <- set_units(mtcars$hp, hp)
#'
#' # Use units encoded into the data
#' ggplot(mtcars) +
#' geom_point(aes(power, consumption))
#'
#' # Convert units on the fly during plotting
#' ggplot(mtcars) +
#' geom_point(aes(power, consumption)) +
#' scale_x_unit(unit = 'W') +
#' scale_y_unit(unit = 'km/l')
#'
#' # Resolve units when transforming data
#' ggplot(mtcars) +
#' geom_point(aes(power, 1 / consumption))
NULL
#' @rdname scale_unit
#' @export
#' @importFrom scales censor
scale_x_unit <- function(name = waiver(), breaks = waiver(), unit = NULL,
minor_breaks = waiver(), labels = waiver(),
limits = NULL, expand = waiver(), oob = censor,
na.value = NA_real_, trans = 'identity',
position = 'bottom', sec.axis = waiver()) {
try_require('units', 'scale_x_unit')
sc <- continuous_scale(
c('x', 'xmin', 'xmax', 'xend', 'xintercept', 'xmin_final', 'xmax_final',
'xlower', 'xmiddle', 'xupper'),
'position_c', identity,
name = name, breaks = breaks,
minor_breaks = minor_breaks, labels = labels, limits = limits,
expand = expand, oob = oob, na.value = na.value, trans = trans,
guide = default_axis_guide, position = position, super = ScaleContinuousPositionUnit
)
sc$unit <- switch(
class(unit),
symbolic_units = ,
'NULL' = unit,
character = units::as_units(unit),
units = units(unit),
stop('unit must either be NULL or of class `units` or `symbolic_units`',
call. = FALSE)
)
if (!inherits(sec.axis, 'waiver')) {
if (inherits(sec.axis, 'formula')) sec.axis <- sec_axis(sec.axis)
if (!inherits(sec.axis, 'AxisSecondary')) {
stop('Secondary axes must be specified using \'sec_axis()\'',
call. = FALSE)
}
sc$secondary.axis <- sec.axis
}
sc
}
#' @rdname scale_unit
#' @export
#' @importFrom scales censor
scale_y_unit <- function(name = waiver(), breaks = waiver(), unit = NULL,
minor_breaks = waiver(), labels = waiver(),
limits = NULL, expand = waiver(), oob = censor,
na.value = NA_real_, trans = 'identity',
position = 'left', sec.axis = waiver()) {
try_require('units', 'scale_y_unit')
sc <- continuous_scale(
c('y', 'ymin', 'ymax', 'yend', 'yintercept', 'ymin_final', 'ymax_final',
'lower', 'middle', 'upper'),
'position_c', identity,
name = name, breaks = breaks,
minor_breaks = minor_breaks, labels = labels, limits = limits,
expand = expand, oob = oob, na.value = na.value, trans = trans,
guide = default_axis_guide, position = position, super = ScaleContinuousPositionUnit
)
sc$unit <- switch(
class(unit),
symbolic_units = ,
'NULL' = unit,
character = units::as_units(unit),
units = units(unit),
stop('unit must either be NULL or of class `units` or `symbolic_units`',
call. = FALSE)
)
if (!inherits(sec.axis, 'waiver')) {
if (inherits(sec.axis, 'formula')) sec.axis <- sec_axis(sec.axis)
if (!inherits(sec.axis, 'AxisSecondary')) {
stop('Secondary axes must be specified using \'sec_axis()\'',
call. = FALSE)
}
sc$secondary.axis <- sec.axis
}
sc
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
ScaleContinuousPositionUnit <- ggproto('ScaleContinuousPositionUnit', ScaleContinuousPosition,
unit = NULL,
train = function(self, x) {
if (length(x) == 0) return()
if (!is.null(self$unit)) {
units(x) <- units::as_units(1, self$unit)
}
self$range$train(x)
},
map = function(self, x, limits = self$get_limits()) {
if (inherits(x, 'units')) {
if (is.null(self$unit)) {
self$unit <- units(x)
} else {
units(x) <- units::as_units(1, self$unit)
}
}
x <- as.numeric(x)
ggproto_parent(ScaleContinuousPosition, self)$map(x, limits)
},
make_title = function(self, title) {
units::make_unit_label(title, units::as_units(1, self$unit))
}
)
#' @rdname scale_unit
#' @format NULL
#' @usage NULL
#' @export
scale_type.units <- function(x) c('unit', 'continuous')
ggforce/R/interpolate.R 0000644 0001762 0000144 00000006572 13524500525 014553 0 ustar ligges users #' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @importFrom grid segmentsGrob polylineGrob gpar
GeomPathInterpolate <- ggproto('GeomPathInterpolate', GeomPath,
draw_panel = function(data, panel_scales, coord, arrow = NULL,
lineend = 'butt', linejoin = 'round', linemitre = 1,
na.rm = FALSE) {
if (!anyDuplicated(data$group)) {
message(
'geom_path_interpolate: Each group consists of only one observation. ',
'Do you need to adjust the 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) {
new_data_frame(list(
solid = identical(unique(df$linetype), 1),
constant = nrow(unique(df[, c(
'alpha', 'colour',
'size', 'linetype'
)])) == 1
))
})
solid_lines <- all(attr$solid)
constant <- all(attr$constant)
if (!solid_lines && !constant) {
stop('geom_path_interpolate: If you are using dotted or dashed lines',
', colour, size and linetype must be constant over the line',
call. = FALSE
)
}
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$size[!end] * .pt, lty = munched$linetype[!end],
lineend = lineend, linejoin = linejoin, linemitre = linemitre
)
)
}
else {
id <- match(munched$group, unique(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$size[start] *
.pt, lty = munched$linetype[start], lineend = lineend,
linejoin = linejoin, linemitre = linemitre
)
)
}
},
handle_na = function(data, params) {
data
}
)
#' Interpolate layer data
#'
#' @param 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)) {
stop('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(unique(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 00000006376 13435737063 014722 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(list(...)))[-1]
transformations <- sapply(calls, deparse)
args <- unlist(lapply(calls, function(call) {
args <- as.list(call)[-1]
as.character(args[sapply(args, 'class') == 'name'])
}))
args <- unique(args)
if (any(c('x', 'y') %in% args)) {
stop('x and y are preserved argument names', call. = FALSE)
}
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.frame(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.frame(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 00000006756 13522767503 014612 0 ustar ligges users #' @rdname geom_autohistogram
#' @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) {
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,
...
)
)
}
#' @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)
})
params$panel_count <- lapply(split(data$y, data$PANEL), length)
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 <- rbind_dfs(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)
new_data_frame(list(
x = x + pad,
density = count / nrow(data)
))
}))
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, panel_params, coord, na.rm)
}
)
ggforce/R/regon.R 0000644 0001762 0000144 00000005775 13525522152 013344 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**
#' - **y0**
#' - **sides**
#' - **r**
#' - **angle**
#' - 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 (is.null(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 00000006723 13525516111 015010 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]. As with
#' the diagonal functions in `ggforce`, the wide diagonal variant is horizontal.
#'
#' @section Aesthetics:
#' geom_diagonal_wide understand the following aesthetics
#' (required aesthetics are in bold):
#'
#' - **x**
#' - **y**
#' - **group**
#' - color
#' - size
#' - linetype
#' - alpha
#' - lineend
#'
#' @inheritParams geom_shape
#' @inheritParams ggplot2::stat_identity
#'
#' @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
#'
#' @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_data = function(data, params) {
if (any(table(data$group) != 4)) {
stop('Each group must consist of 4 points')
}
data
},
compute_panel = function(data, scales, strength = 0.5, n = 100) {
data <- data[order(data$group, data$x, data$y), ]
lower <- data[c(TRUE, FALSE, TRUE, FALSE), ]
upper <- data[c(FALSE, TRUE, FALSE, TRUE), ]
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 <- rbind(lower, upper)
diagonals$index <- NULL
diagonals[order(diagonals$group), ]
},
required_aes = c('x', 'y', 'group'),
extra_params = c('na.rm', 'n', 'strength')
)
#' @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, 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, 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, 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, n = n, strength = strength, ...)
)
}
ggforce/R/mark_circle.R 0000644 0001762 0000144 00000035240 13525501265 014475 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_*` allows 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**
#' - 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 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())
coords <- coord$transform(data, panel_params)
if (!is.integer(coords$group)) {
coords$group <- match(coords$group, unique(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$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
)
},
default_aes = aes(fill = NA, colour = 'black', alpha = 0.3, size = 0.5,
linetype = 1, filter = NULL, label = NULL,
description = NULL)
)
#' @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, 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)) {
stop('id.lengths must sum up to the number of points', call. = FALSE)
}
}
}
include <- unlist(lapply(split(seq_along(x), id), function(i) {
xi <- x[i]
yi <- y[i]
if (length(unique(xi)) == 1) {
return(i[c(which.min(yi), which.max(yi))])
}
if (length(unique(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
}
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, 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 <- unique(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)
)
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, arrow = x$con.arrow
)
setChildren(x, do.call(gList, c(list(mark), labels)))
} else {
setChildren(x, gList(mark))
}
}
ggforce/R/utilities.R 0000644 0001762 0000144 00000017604 13440302452 014232 0 ustar ligges users new_data_frame <- function(x = list(), n = NULL) {
if (length(x) != 0 && is.null(names(x))) stop('Elements must be named',
call. = FALSE)
lengths <- vapply(x, length, integer(1))
if (is.null(n)) {
n <- if (length(x) == 0) 0 else max(lengths)
}
for (i in seq_along(x)) {
if (lengths[i] == n) next
if (lengths[i] != 1) stop('Elements must equal the number of rows or 1',
call. = FALSE)
x[[i]] <- rep(x[[i]], n)
}
class(x) <- 'data.frame'
attr(x, 'row.names') <- .set_row_names(n)
x
}
df_rows <- function(x, i) {
new_data_frame(lapply(x, `[`, i = 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(unique(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 <- do.call('paste', c(ids, sep = '\r'))
res <- match(char_id, unique(char_id))
}
else {
combs <- c(1, cumprod(ndistinct[-p]))
mat <- do.call('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
}
}
#' Bind data frames together by common column names
#'
#' This function is akin to `plyr::rbind.fill`, `dplyr::bind_rows`, and
#' `data.table::rbindlist`. It takes data frames in a list and stacks them on
#' top of each other, filling out values with `NA` if the column is missing from
#' a data.frame
#'
#' @param dfs A list of data frames
#'
#' @return A data.frame with the union of all columns from the data frames given
#' in `dfs`
#'
#' @keywords internal
#' @noRd
#'
rbind_dfs <- function(dfs) {
out <- list()
columns <- unique(unlist(lapply(dfs, names)))
nrows <- vapply(dfs, .row_names_info, integer(1), type = 2L)
total <- sum(nrows)
if (length(columns) == 0) return(new_data_frame(list(), total))
allocated <- rep(FALSE, length(columns))
names(allocated) <- columns
col_levels <- list()
for (df in dfs) {
new_columns <- intersect(names(df), columns[!allocated])
for (col in new_columns) {
if (is.factor(df[[col]])) {
all_factors <- all(vapply(dfs, function(df) {
val <- .subset2(df, col)
is.null(val) || is.factor(val)
}, logical(1)))
if (all_factors) {
col_levels[[col]] <- unique(
unlist(lapply(dfs, function(df) levels(.subset2(df, col))))
)
}
out[[col]] <- rep(NA_character_, total)
} else {
out[[col]] <- rep(.subset2(df, col)[1][NA], total)
}
}
allocated[new_columns] <- TRUE
if (all(allocated)) break
}
pos <- c(cumsum(nrows) - nrows + 1)
for (i in seq_along(dfs)) {
df <- dfs[[i]]
rng <- seq(pos[i], length.out = nrows[i])
for (col in names(df)) {
if (inherits(df[[col]], 'factor')) {
out[[col]][rng] <- as.character(df[[col]])
} else {
out[[col]][rng] <- df[[col]]
}
}
}
for (col in names(col_levels)) {
out[[col]] <- factor(out[[col]], levels = col_levels[[col]])
}
attributes(out) <- list(
class = 'data.frame',
names = names(out),
row.names = .set_row_names(total)
)
out
}
#' 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)
ids <- id(grouping_cols, drop = drop)
group_rows <- split(seq_len(nrow(df)), ids)
rbind_dfs(lapply(seq_along(group_rows), function(i) {
cur_data <- df_rows(df, group_rows[[i]])
res <- fun(cur_data, ...)
if (is.null(res)) return(res)
if (length(res) == 0) return(new_data_frame())
vars <- lapply(setNames(by, by), function(col) .subset2(cur_data, col)[1])
if (is.matrix(res)) res <- split_matrix(res)
if (is.null(names(res))) names(res) <- paste0('V', seq_along(res))
new_data_frame(modify_list(unclass(vars), unclass(res)))
}))
}
# Test whether package `package` is available. `fun` provides
# the name of the ggplot2 function that uses this package, and is
# used only to produce a meaningful error message if the
# package is not available.
try_require <- function(package, fun) {
if (requireNamespace(package, quietly = TRUE)) {
return(invisible())
}
stop("Package `", package, "` required for `", fun , "`.\n",
"Please install and try again.", call. = FALSE)
}
# 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) {
stop('Please use `to_lower_ascii()`, which works fine in all locales.', call. = FALSE)
}
toupper <- function(x) {
stop('Please use `to_upper_ascii()`, which works fine in all locales.', call. = FALSE)
}
# 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])
}
ggforce/R/shape.R 0000644 0001762 0000144 00000021231 13525502534 013315 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, unique(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$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) {
stop('radius must be positive', call. = FALSE)
}
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)) {
stop('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 00000006126 13525502515 013463 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
#' - size
#' - 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 the 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) {
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 = list(
colour = 'black', fill = NA, size = 0.5, linetype = 1,
alpha = 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 00000043736 13436024462 014361 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
#'
#' @importFrom rlang enquo
#' @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)) {
stop('Either x- or y-zoom must be given', call. = FALSE)
}
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
#' @importFrom rlang eval_tidy
#' @export
FacetZoom <- ggproto('FacetZoom', Facet,
compute_layout = function(data, params) {
layout <- rbind(
data.frame(name = 'orig', SCALE_X = 1L, SCALE_Y = 1L),
data.frame(name = 'x', SCALE_X = 2L, SCALE_Y = 1L),
data.frame(name = 'y', SCALE_X = 1L, SCALE_Y = 2L),
data.frame(name = 'full', SCALE_X = 2L, SCALE_Y = 2L),
data.frame(name = 'orig_true', SCALE_X = 1L, SCALE_Y = 1L),
data.frame(name = 'zoom_true', SCALE_X = 1L, SCALE_Y = 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)))
}
rbind(
cbind(data, PANEL = 1L),
if (!is.null(params$x)) {
index_x <- tryCatch(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 <- tryCatch(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 <- tryCatch(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)
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) {
# 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()) {
stop('facet_zoom doesn\'t support zooming in discrete scales', call. = FALSE)
}
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(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()) {
stop('facet_zoom doesn\'t support zooming in discrete scales', call. = FALSE)
}
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(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)) {
do.call(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, ]
rbind(orig_data, do.call(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')) {
stop('facet_zoom currently doesn\'t work with flipped scales', call. = FALSE)
}
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
}
if (is.null(theme[['zoom']])) {
theme$zoom <- theme$strip.background
}
if (is.null(theme$zoom.x)) {
theme$zoom.x <- theme$zoom
}
if (is.null(theme$zoom.y)) {
theme$zoom.y <- theme$zoom
}
# 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(theme$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(theme$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 = theme$zoom.y$colour,
lty = theme$zoom.y$linetype,
lwd = theme$zoom.y$size,
lineend = 'round'
)
)
indicator_h <- grobTree(indicator, lines)
} else {
indicator_h <- zeroGrob()
}
}
if ('x' %in% layout$name) {
if (!inherits(theme$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(theme$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 = theme$zoom.x$colour,
lty = theme$zoom.x$linetype,
lwd = theme$zoom.x$size,
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) {
if (is.null(theme[['zoom']])) {
theme$zoom <- theme$strip.background
}
if (is.null(theme$zoom.x)) {
theme$zoom.x <- theme$zoom
}
if (is.null(theme$zoom.y)) {
theme$zoom.y <- theme$zoom
}
if (!(is.null(params$x) && is.null(params$xlim)) &&
params$show.area && !inherits(theme$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(theme$zoom.x$fill, 0.5))),
segmentsGrob(zoom_prop, c(0, 0), zoom_prop, c(1, 1), gp = gpar(
col = theme$zoom.x$colour,
lty = theme$zoom.x$linetype,
lwd = theme$zoom.x$size,
lineend = 'round'
))
)
} else {
x_back <- zeroGrob()
}
if (!(is.null(params$y) && is.null(params$ylim)) &&
params$show.area && !inherits(theme$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(theme$zoom.y$fill, 0.5))),
segmentsGrob(y0 = zoom_prop, x0 = c(0, 0), y1 = zoom_prop, x1 = c(1, 1),
gp = gpar(col = theme$zoom.y$colour,
lty = theme$zoom.y$linetype,
lwd = theme$zoom.y$size,
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) {
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 = 10, clip = 'on',
name = 'panel')
table <- gtable_add_grob(table, x, t = c(1, 3), l = 2, z = 20, clip = 'off',
name = c('axis-t', 'axis-b'))
table <- gtable_add_grob(table, y, t = 2, l = c(1, 3), z = 20, clip = 'off',
name = c('axis-l', 'axis-r'))
}, panel = panels, x = x.axis, y = y.axis)
}
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 -----------------------------------------------------------------
# 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))) stop()
scale_index <- split_indices(scale_id)
lapply(vars, function(var) {
pieces <- lapply(seq_along(scales), function(i) {
scales[[i]][[method]](data[[var]][scale_index[[i]]])
})
# Join pieces back together, if necessary
if (!is.null(pieces)) {
unlist(pieces)[order(unlist(scale_index))]
}
})
}
ggforce/R/mark_label.R 0000644 0001762 0000144 00000026573 13440036721 014320 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
make_label <- function(labels, dims, polygons, ghosts, buffer, con_type,
con_border, con_cap, con_gp, anchor_mod, arrow) {
anchors <- lapply(polygons, function(p) c(mean(range(p$x)), mean(range(p$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 <- do.call(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 <- do.call(rbind, dims[lengths(labelpos) != 0]) / 2
labelpos <- do.call(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 {
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 <- min(final_width, as_mm(grobWidth(desc_grob)))
}
} 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) {
as_mm(grobDescent(lab_grob))
} 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 <- do.call(rbind, 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 <- 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(do.call(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.frame(x = x_new, y = y_new)
}
vswitch <- function(x, ...) {
cases <- cbind(...)
cases[cbind(seq_along(x), match(x, colnames(cases)))]
}
ggforce/R/voronoi.R 0000644 0001762 0000144 00000060423 13525514212 013712 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 = stat(nsides), size = 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) {
try_require('deldir', snake_class(self))
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')]))) {
warning('stat_voronoi_tile: dropping duplicated points', call. = FALSE)
}
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) {
try_require('deldir', snake_class(self))
params
},
compute_group = function(self, data, scales, bound = NULL, eps = 1e-9,
normalize = FALSE, asp.ratio = 1) {
if (any(duplicated(data[, c('x', 'y')]))) {
warning('stat_voronoi_segment: dropping duplicated points', call. = FALSE)
}
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) {
try_require('deldir', snake_class(self))
params
},
compute_group = function(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')]))) {
warning('stat_delaunay_tile: dropping duplicated points', call. = FALSE)
}
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, unique(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 <- do.call(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) {
try_require('deldir', snake_class(self))
params
},
compute_group = function(data, scales, bound = NULL, eps = 1e-9,
normalize = FALSE, asp.ratio = 1) {
if (any(duplicated(data[, c('x', 'y')]))) {
warning('stat_delaunay_segment: dropping duplicated points',
call. = FALSE)
}
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) {
try_require('deldir', snake_class(self))
params
},
compute_group = function(data, scales, bound = NULL, eps = 1e-9, n = 100,
normalize = FALSE, asp.ratio = 1) {
if (any(duplicated(data[, c('x', 'y')]))) {
warning('stat_delaunay_segment2: dropping duplicated points',
call. = FALSE)
}
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 <- 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) {
try_require('deldir', snake_class(self))
params
},
compute_group = function(data, scales, bound = NULL, eps = 1e-9,
switch.centroid = FALSE, normalize = FALSE,
asp.ratio = 1) {
if (any(duplicated(data[, c('x', 'y')]))) {
warning('stat_delvor_summary: dropping duplicated points',
call. = FALSE)
}
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 = asp.ratio, 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) {
try_require('deldir', 'to_tile')
tiles <- 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 <- unique(tiles)
tiles <- rbind(
tiles,
data.frame(
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 <- 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.frame(
point = as.vector(last_points),
group = rep(seq(max(tiles$group) + 1, length.out = ncol(last_points)),
each = 3)
)
triangles <- 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, unique(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(unique(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)
new_data_frame(list(
x = final_tile[[1]]$x,
y = final_tile[[1]]$y,
group = tile$group[1]
))
})
}
ggforce/R/autohistogram.R 0000644 0001762 0000144 00000011051 13522771511 015102 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)
})
params$panel_count <- lapply(split(data$y, data$PANEL), length)
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 <- rbind_dfs(lapply(split(data, data$x), function(d) {
new_data_frame(list(
count = nrow(d),
x = d$x[1],
xmin = d$x[1] - 0.5,
xmax = d$x[1] + 0.5,
width = 1
))
}))
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, linejoin = "mitre") {
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, linejoin)
}
)
ggforce/R/aaa.R 0000644 0001762 0000144 00000000603 13435737063 012746 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
}
ggforce/R/bspline_closed.R 0000644 0001762 0000144 00000010261 13525501232 015175 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
#' - size
#' - 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, unique(coords$group))
}
startPoint <- match(unique(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$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 00000017311 13525522250 013774 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
#' - size
#' - linetype
#' - alpha
#' - lineend
#'
#' geom_diagonal2 understand the following aesthetics
#' (required aesthetics are in bold):
#'
#' - **x**
#' - **y**
#' - **group**
#' - 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::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
#'
#' @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 = 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_data = function(data, params) {
data
},
compute_panel = function(data, scales, n = 100, strength = 0.5) {
if (is.null(data)) return(data)
data$group <- make.unique(as.character(data$group))
end <- data
end$x <- end$xend
end$y <- end$yend
data <- rbind(data, end)
data$xend <- NULL
data$yend <- NULL
data <- data[order(data$group), ]
data <- add_controls(data, strength)
StatBezier$compute_panel(data, scales, n)
},
required_aes = c('x', 'y', 'xend', 'yend'),
extra_params = c('na.rm', 'n', 'strength')
)
#' @rdname geom_diagonal
#' @export
stat_diagonal <- function(mapping = NULL, data = NULL, geom = 'path',
position = 'identity', n = 100, strength = 0.5,
na.rm = FALSE, 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, n = n, strength = strength, ...)
)
}
#' @rdname geom_diagonal
#' @export
geom_diagonal <- function(mapping = NULL, data = NULL, stat = 'diagonal',
position = 'identity', n = 100,
na.rm = FALSE, 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, n = n, strength = strength, ...)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatDiagonal2 <- ggproto('StatDiagonal2', Stat,
compute_layer = function(self, data, params, panels) {
if (is.null(data)) return(data)
data <- data[order(data$group), ]
data <- add_controls(data, params$strength)
StatBezier2$compute_layer(data, params, panels)
},
required_aes = c('x', 'y'),
extra_params = c('na.rm', 'n', 'strength')
)
#' @rdname geom_diagonal
#' @export
stat_diagonal2 <- function(mapping = NULL, data = NULL,
geom = 'path_interpolate', position = 'identity',
na.rm = FALSE, 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, 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, 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, n = n,
strength = strength, ...
)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatDiagonal0 <- ggproto('StatDiagonal0', Stat,
compute_panel = function(data, scales, strength = 0.5) {
if (is.null(data)) return(data)
data$group <- make.unique(as.character(data$group))
end <- data
end$x <- end$xend
end$y <- end$yend
data <- rbind(data, end)
data$xend <- NULL
data$yend <- NULL
data <- data[order(data$group), ]
data <- add_controls(data, strength)
StatBezier0$compute_panel(data, scales)
},
required_aes = c('x', 'y', 'xend', 'yend'),
extra_params = c('na.rm', 'strength')
)
#' @rdname geom_diagonal
#' @export
stat_diagonal0 <- function(mapping = NULL, data = NULL, geom = 'bezier0',
position = 'identity', na.rm = FALSE,
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, strength = strength, ...)
)
}
#' @rdname geom_diagonal
#' @export
geom_diagonal0 <- function(mapping = NULL, data = NULL, stat = 'diagonal0',
position = 'identity', arrow = NULL, lineend = 'butt',
na.rm = FALSE, 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,
strength = strength, ...
)
)
}
add_controls <- function(data, strength) {
start <- data[c(TRUE, FALSE), ]
end <- data[c(FALSE, TRUE), ]
x_diff <- (end$x - start$x) * strength
mid1 <- start
mid1$x <- mid1$x + x_diff
mid2 <- end
mid2$x <- mid2$x - x_diff
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 00000007401 13435737063 016166 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
x_scale_ind <- unique(layout$SCALE_X)
x_scales <- x_scales[x_scale_ind]
layout$SCALE_X <- match(layout$SCALE_X, x_scale_ind)
y_scale_ind <- unique(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 14020361201 014476 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 13522765330 014244 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 00000004605 13435737063 016606 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.
#' @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) {
ggproto(NULL, PositionJitterNormal,
sd_x = sd_x,
sd_y = sd_y
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
PositionJitterNormal <- ggproto('PositionJitterNormal',
Position,
required_aes = c('x', 'y'),
setup_params = function(self, data) {
list(
sd_x = self$sd_x %||% 0.15,
sd_y = self$sd_y %||% 0.15
)
},
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)
}
transform_position(data, trans_x, trans_y)
}
)
ggforce/R/arc_bar.R 0000644 0001762 0000144 00000022377 13525522200 013612 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
#' - size
#' - 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),
#' stringsAsFactors = FALSE
#' )
#'
#' # 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) {
stop('Total separation exceeds circle circumference. Try lowering "sep"')
}
angles <- angles / max(angles) * (2 * pi - max(seps))
new_data_frame(c(df, list(
start = c(0, angles[-length(angles)]) + c(0, seps[-length(seps)]) + sep / 2,
end = angles + seps - sep / 2,
stringsAsFactors = FALSE
)))
})
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 = list(
colour = 'black', fill = NA, size = 0.5, linetype = 1,
alpha = 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, ...)
)
}
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.frame(
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 <- rbind(
path,
data.frame(a = rev(path$a), r = data$r0[i])
)
} else {
path <- rbind(
path,
data.frame(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 <- do.call(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) {
stop('Arcs must be defined by two end points', call. = FALSE)
}
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]]) {
stop('Both end points must be at same radius and with same center',
call. = FALSE
)
}
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.frame(
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 <- do.call(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 00000012577 13435737063 014704 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.frame(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)))
}
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 <- do.call(
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 <- do.call(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],
unique(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 00000014543 13435757750 016224 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
#'
#' @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 = NULL, drop = TRUE, dir = 'h',
strip.position = 'top', page = 1) {
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))
)
}
}
#' @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) {
modifyList(
params,
list(
max_rows = params$nrow,
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 <- unique(layout$SCALE_X)
x_scales <- x_scales[x_scale_ind]
layout$SCALE_X <- match(layout$SCALE_X, x_scale_ind)
y_scale_ind <- unique(layout$SCALE_Y)
y_scales <- y_scales[y_scale_ind]
layout$SCALE_Y <- match(layout$SCALE_Y, y_scale_ind)
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 <- unique(table$layout$t[grepl('strip', table$layout$name) & table$layout$l %in% panel_cols(table)$l])
strip_rows <- strip_rows[as.numeric(table$heights[strip_rows]) != 0]
axis_b_rows <- unique(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 <- unique(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$ncol) {
spacing <- theme$panel.spacing.x %||% theme$panel.spacing
missing_cols <- params$ncol - max(layout$COL)
strip_cols <- unique(table$layout$t[grepl('strip', table$layout$name) & table$layout$t %in% panel_rows(table)$t])
strip_cols <- strip_cols[as.numeric(table$widths[strip_cols]) != 0]
axis_l_cols <- unique(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 <- unique(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 00000032141 13436306417 015054 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**
#' - **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
#'
#' @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')
NULL
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatParallelSets <- ggproto('StatParallelSets', Stat,
setup_data = function(data, params) {
value_check <- lapply(split(data$value, data$id), unique)
if (any(lengths(value_check) != 1)) {
stop('value must be kept constant across id', call. = FALSE)
}
data$split <- as.factor(data$split)
data
},
compute_panel = function(data, scales, sep = 0.05, strength = 0.5, n = 100,
axis.width = 0) {
data <- remove_group(data)
data <- complete_data(data)
cols <- c('group', 'colour', 'color', 'fill', 'size', 'alpha', 'linetype')
data_groups <- do.call(
rbind,
lapply(split(data[, names(data) %in% cols, drop = FALSE], data$group),
function(d) {
as.data.frame(lapply(d, function(x) na.omit(x)[1]),
stringsAsFactors = FALSE)
}
)
)
# Calculate axis sizes
data_axes <- sankey_axis_data(data, sep)
# Calculate diagonals
diagonals <- sankey_diag_data(data, data_axes, data_groups, axis.width)
StatDiagonalWide$compute_panel(diagonals, scales, strength, n)
},
required_aes = c('x', 'id', 'split', 'value'),
extra_params = c('na.rm', 'n', 'sep', 'strength', 'axis.width')
)
#' @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,
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, 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, 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, n = n, strength = strength, sep = sep,
axis.width = axis.width, ...
)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
StatParallelSetsAxes <- ggproto('StatParallelSetsAxes', Stat,
setup_data = function(data, params) {
value_check <- lapply(split(data$value, data$id), unique)
if (any(lengths(value_check) != 1)) {
stop('value must be kept constant across id', call. = FALSE)
}
data$split <- as.factor(data$split)
data
},
compute_panel = function(data, scales, sep = 0.05, axis.width = 0) {
split_levels <- levels(data$split)
data <- remove_group(data)
data <- complete_data(data)
# 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', 'alpha',
'linetype')
aes <- data[, names(data) %in% cols]
aes <- unique(aes)
if (nrow(aes) != nrow(data_axes)) {
stop('Axis aesthetics must be constant in each split', call. = FALSE)
}
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
data
},
required_aes = c('x', 'id', 'split', 'value'),
extra_params = c('na.rm', 'sep')
)
#' @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,
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, sep = sep, axis.width = axis.width, ...)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @export
GeomParallelSetsAxes <- ggproto('GeomParallelSetsAxes', GeomShape,
setup_data = function(data, params) {
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 <- rbind(lb, rb, rt, lt)
data[order(data$group), ]
},
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,
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, ...)
)
}
#' @rdname geom_parallel_sets
#' @export
geom_parallel_sets_labels <- function(mapping = NULL, data = NULL,
stat = 'parallel_sets_axes', angle = -90,
position = 'identity', na.rm = FALSE,
show.legend = NA, inherit.aes = TRUE,
...) {
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, 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') {
if (is.numeric(x)) x <- names(data)[x]
data[[id_name]] <- seq_len(nrow(data))
do.call(rbind, lapply(x, function(n) {
data$x <- n
data$y <- data[[n]]
data
}))
}
#' @importFrom stats na.omit
complete_data <- function(data) {
levels(data$split) <- c(levels(data$split), '.ggforce_missing')
all_obs <- unique(data[, c('id', 'value')])
data <- do.call(rbind, lapply(split(data, data$x), function(d) {
if (anyDuplicated(d$id) != 0) {
stop('id must be unique within axes', call. = FALSE)
}
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 <- rbind(d, fill)
}
d
}))
# Ensure id grouping
id_groups <- lapply(split(data$group, data$id),
function(x) unique(na.omit(x)))
if (any(lengths(id_groups) != 1)) {
stop('id must keep grouping across data', call. = FALSE)
}
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) {
do.call(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.frame(
split = names(splits),
value = sapply(splits, sum),
x = d$x[1],
stringsAsFactors = TRUE
)
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(unique(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.frame(
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,
stringsAsFactors = FALSE
)
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 <- 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)])
do.call(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
rbind(data_tmp, data)
}
remove_group <- function(data) {
split_groups <- lapply(split(data$group, data$split), unique)
if (all(lengths(split_groups) == 1)) {
data$group <- -1
} else 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/bezier.R 0000644 0001762 0000144 00000027621 13526714110 013502 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
#' - 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::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,
# .Deprecated - remove after next release
compute_layer = function(self, data, params, layout) {
if (is.null(data)) return(data)
data <- remove_missing(data, params$na.rm,
c(self$required_aes, self$non_missing_aes),
snake_class(self),
finite = TRUE
)
# Trim off extra parameters
params <- params[intersect(names(params), self$parameters())]
args <- c(list(data = quote(data), scales = quote(scales)), params)
dapply(data, "PANEL", function(data) {
scales <- layout$get_scales(data$PANEL[1])
tryCatch(do.call(self$compute_panel, args), error = function(e) {
warning("Computation failed in `", snake_class(self), "()`:\n",
e$message, call. = FALSE)
new_data_frame()
})
})
},
compute_panel = function(data, scales, n = 100) {
if (is.null(data)) return(data)
nControls <- table(data$group)
controlRange <- range(nControls)
if (min(controlRange) < 3 || max(controlRange) > 4) {
stop('Only support for quadratic and cubic beziers')
}
data <- data[order(data$group), ]
groups <- unique(data$group)
paths <- getBeziers(data$x, data$y, match(data$group, groups), n)
paths <- data.frame(
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(unique(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 (is.null(data)) return(data)
data <- data[order(data$group), ]
nControls <- table(data$group)
controlRange <- range(nControls)
if (min(controlRange) < 3 || max(controlRange) > 4) {
stop('Only support for quadratic and cubic beziers')
}
groups <- unique(data$group)
paths <- getBeziers(data$x, data$y, match(data$group, groups), params$n)
paths <- data.frame(
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(unique(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(unique(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,
# .Deprecated - remove after next release
compute_layer = function(self, data, params, layout) {
if (is.null(data)) return(data)
data <- remove_missing(data, params$na.rm,
c(self$required_aes, self$non_missing_aes),
snake_class(self),
finite = TRUE
)
# Trim off extra parameters
params <- params[intersect(names(params), self$parameters())]
args <- c(list(data = quote(data), scales = quote(scales)), params)
dapply(data, "PANEL", function(data) {
scales <- layout$get_scales(data$PANEL[1])
tryCatch(do.call(self$compute_panel, args), error = function(e) {
warning("Computation failed in `", snake_class(self), "()`:\n",
e$message, call. = FALSE)
new_data_frame()
})
})
},
compute_panel = function(data, scales) {
if (is.null(data)) return(data)
data <- data[order(data$group), ]
nControls <- table(data$group)
controlRange <- range(nControls)
if (min(controlRange) < 3 || max(controlRange) > 4) {
stop('Only support for quadratic and cubic beziers')
}
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, unique(coords$group))
}
startPoint <- match(unique(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$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 00000014142 13435737063 013356 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 5 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.frame(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.frame(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 00000010241 13525523030 013342 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 (is.null(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 00000020036 13435737063 012773 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
#' - size
#' - 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 = stat(index)), lineend = 'round') +
#' scale_radius() # linear size scale
#'
#' # 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,
default_aes = list(
colour = 'black', size = 0.5, linetype = 1, alpha = 1, lineend = 'butt'
)
)
#' @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 = list(
colour = 'black', size = 0.5, linetype = 1, alpha = 1,
lineend = 'butt'
),
draw_key = draw_key_path,
draw_panel = function(data, panel_scales, coord, ncp = 5, arrow = NULL,
lineend = 'butt', na.rm = FALSE) {
if (!coord$is_linear()) {
warning('geom_arc is not implemented for non-linear coordinates',
call. = FALSE
)
}
trans <- coord$transform(data, panel_scales)
do.call(gList, 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$size[i] * .pt, lty = trans$linetype[i],
lineend = trans$lineend[i]
), arrow = arrow[i]
)
}))
}
)
#' @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 00000015643 13526714115 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 = 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,
# .Deprecated - remove after next release
compute_layer = function(self, data, params, layout) {
if (is.null(data)) return(data)
data <- remove_missing(data, params$na.rm,
c(self$required_aes, self$non_missing_aes),
snake_class(self),
finite = TRUE
)
# Trim off extra parameters
params <- params[intersect(names(params), self$parameters())]
args <- c(list(data = quote(data), scales = quote(scales)), params)
dapply(data, "PANEL", function(data) {
scales <- layout$get_scales(data$PANEL[1])
tryCatch(do.call(self$compute_panel, args), error = function(e) {
warning("Computation failed in `", snake_class(self), "()`:\n",
e$message, call. = FALSE)
new_data_frame()
})
})
},
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.frame(
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])
})
do.call(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.frame(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 00000010550 13522776520 015120 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
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 <- withr::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 {
withr::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(unique(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 00000027340 13525501252 014667 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 and
#' 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 understand the following aesthetics (required aesthetics are
#' in bold):
#'
#' - **x**
#' - **y**
#' - filter
#' - label
#' - description
#' - color
#' - fill
#' - group
#' - size
#' - linetype
#' - alpha
#'
#' @inheritParams geom_mark_circle
#'
#' @param n The number of points used to draw each circle. 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', 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, 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())
coords <- coord$transform(data, panel_params)
if (!is.integer(coords$group)) {
coords$group <- match(coords$group, unique(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$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
)
},
default_aes = GeomMarkCircle$default_aes
)
#' @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, 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)) {
stop('id.lengths must sum up to the number of points', call. = FALSE)
}
}
}
include <- unlist(lapply(split(seq_along(x), id), function(i) {
xi <- x[i]
yi <- y[i]
if (length(unique(xi)) == 1) {
return(i[c(which.min(yi), which.max(yi))])
}
if (length(unique(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
}
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, 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 <- unique(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)
)
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, arrow = x$con.arrow
)
setChildren(x, do.call(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 00000027124 13674075072 014211 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**
#' - filter
#' - label
#' - description
#' - color
#' - fill
#' - group
#' - size
#' - linetype
#' - alpha
#'
#' @inheritParams geom_mark_circle
#'
#' @param concavity A meassure 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', GeomShape,
setup_data = function(self, data, params) {
try_require('concaveman', snake_class(self))
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 = 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())
coords <- coord$transform(data, panel_params)
if (!is.integer(coords$group)) {
coords$group <- match(coords$group, unique(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$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
)
},
default_aes = GeomMarkCircle$default_aes
)
#' @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) {
if (!requireNamespace('concaveman', quietly = TRUE)) {
warning('The concaveman package is required for geom_mark_hull', call. = FALSE)
return(invisible())
}
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, 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
}
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, 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 <- unique(cbind(xx, yy))
if (nrow(mat) <= 2) {
return(mat)
}
if (length(unique(xx)) == 1) {
return(mat[c(which.min(mat[, 2]), which.max(mat[, 2])), ])
}
if (length(unique((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 <- do.call(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)
)
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, arrow = x$con.arrow
)
setChildren(x, do.call(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 00000034562 13674341253 013166 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_path
#' @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
#'
#' @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) {
if (is.double(data$x) && !.has_groups(data) && any(data$x != data$x[1L])) {
stop('Continuous x aesthetic -- did you forget aes(group=...)?',
call. = FALSE
)
}
data
},
setup_params = function(data, params) {
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) {
if (!is.null(binwidth)) {
bins <- bin_breaks_width(scales$y$dimension() + 1e-8, binwidth)
} else {
bins <- bin_breaks_bins(scales$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)
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
)
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 (all(data$y == floor(data$y))) {
data$y <- jitter(data$y)
}
data
},
compute_group = function(data, scales, scale = TRUE, method = 'density',
bw = 'nrd0', kernel = 'gaussian',
maxwidth = 1, adjust = 1, bin_limit = 1,
bins = NULL) {
if (nrow(data) == 0) return(NULL)
if (nrow(data) < 3) {
data$density <- 0
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)
data
} 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(unique(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))
data
},
finish_layer = function(data, params) {
# rescale x in case positions have been adjusted
x_mod <- (data$xmax - data$xmin) / data$width
data$x <- data$x + data$x_diff * x_mod
data
},
extra_params = 'na.rm'
)
#' @rdname geom_sina
#' @export
stat_sina <- function(mapping = NULL, data = NULL, geom = 'sina',
position = 'dodge', scale = 'area', method = 'density',
bw = 'nrd0', kernel = 'gaussian', maxwidth = NULL,
adjust = 1, bin_limit = 1, binwidth = NULL, bins = NULL,
seed = NA, ..., na.rm = FALSE, 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, na.rm = na.rm, ...)
)
}
#' @rdname geom_sina
#' @export
geom_sina <- function(mapping = NULL, data = NULL,
stat = 'sina', position = 'dodge',
...,
na.rm = FALSE,
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,
...
)
)
}
# Binning functions -------------------------------------------------------
bins <- function(breaks, closed = c('right', 'left'),
fuzz = 1e-08 * stats::median(diff(breaks))) {
stopifnot(is.numeric(breaks))
closed <- match.arg(closed)
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)
}
# if less than 2 points return data frame of NAs and a warning
if (nx < 2) {
warning("Groups with fewer than two data points have been dropped.", call. = FALSE)
return(new_data_frame(list(
x = NA_real_,
density = NA_real_,
scaled = NA_real_,
ndensity = NA_real_,
count = NA_real_,
n = NA_integer_
), n = 1))
}
dens <- stats::density(x, weights = w, bw = bw, adjust = adjust,
kernel = kernel, n = n, from = from, to = to)
new_data_frame(list(
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
), n = length(dens$x))
}
calc_bw <- function(x, bw) {
if (is.character(bw)) {
if (length(x) < 2)
stop("need at least 2 points to select a bandwidth automatically", call. = FALSE)
bw <- switch(
base::tolower(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"),
stop("unknown 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')) {
stopifnot(length(x_range) == 2)
# if (length(x_range) == 0) {
# return(bin_params(numeric()))
# }
stopifnot(is.numeric(width), length(width) == 1)
if (width <= 0) {
stop('`binwidth` must be positive', call. = FALSE)
}
if (!is.null(boundary) && !is.null(center)) {
stop('Only one of \'boundary\' and \'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
breaks <- seq(origin, max_x, width)
bin_breaks(breaks, closed = closed)
}
bin_breaks_bins <- function(x_range, bins = 30, center = NULL,
boundary = NULL, closed = c('right', 'left')) {
stopifnot(length(x_range) == 2)
bins <- as.integer(bins)
if (bins < 1) {
stop('Need at least one bin.', call. = FALSE)
} 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 00000012673 14020365312 012771 0 ustar ligges users # ggforce 0.3.3
- Changed documentation to comply with new units package
# 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 00000012314 14020402722 012170 0 ustar ligges users 76f40f36452189cb64637c5d56622544 *DESCRIPTION
c31ee18d335f7158ed985f5939319c1f *LICENSE
64f4ffcb43bc6bb5ea3c59a11928940c *NAMESPACE
7464f29efa89364aaa3b548a28a6c68f *NEWS.md
5f42de1a5c1bd0d2bca8e5e0895fcbfe *R/RcppExports.R
9fa911350875544cc81a67ef2e4c3b84 *R/aaa.R
bf11787eef71c2fc3ad3305f499c978b *R/arc.R
b932d304b576e38c402dac7007af088f *R/arc_bar.R
d9cd02d8fe343bdf02469689c484c1ff *R/autodensity.R
396e6a8af5ad383d217482a64809f3e9 *R/autohistogram.R
8a33304dfad54e631f572d53b159770d *R/autopoint.R
2a64b8d422aa61449a31e7c9e728f619 *R/bezier.R
fbc0ac63185750bf5073b194e06de9f8 *R/bspline.R
bad8946d5bd00f470a1c0ff0cb0ae060 *R/bspline_closed.R
a2c9d1cc130420b29cee5247c2d18b1d *R/circle.R
e069108e054278d88dbe067a3ffe6d03 *R/diagonal.R
0257acce57c57e8a9649380967ea9110 *R/diagonal_wide.R
32ce499ed53ace7a5ead9d8b73628797 *R/ellipse.R
4deed649b6eaf3ab471bb319dacdceb7 *R/facet_grid_paginate.R
ef49c58e6ab18b3e6f61f325494a6baf *R/facet_matrix.R
03355030f98fe515560fb414a20c2d79 *R/facet_row.R
a98ad70ab95d1bcb3970e61279975a1f *R/facet_stereo.R
2652e019231aba25664d99c503c825a8 *R/facet_wrap_paginate.R
7d12728effaa6b6d04c81e9f07b63267 *R/facet_zoom.R
2fd1204382501a830681ef2cfc88f06e *R/ggforce_package.R
fee6ed1299effd00b4befb852ea654d5 *R/ggproto-classes.R
fe2b6005924115541abd8e6ed8ef1313 *R/interpolate.R
beeefe48df986c8c06f3649679e7df51 *R/link.R
982a2b4ea01070b06db2c8d0c0cefb1d *R/mark_circle.R
a6da5478cb82a67a56bfde8d7af73216 *R/mark_ellipse.R
ca267481e2ecc5c1e31a92a0f1dc51d0 *R/mark_hull.R
0cd59df5613b8885c053b15b6caee126 *R/mark_label.R
2e1a48ba2002b0c8d1996218a40ae070 *R/mark_rect.R
7e7f5f6e6ce4fd917b19747ac0dc9c67 *R/parallel_sets.R
22ca544c1bf57dc9a7d5fc6be4c0650c *R/position-jitternormal.R
723b8773d9cbfc75d895092ebc7bb6c3 *R/position_auto.R
e2c245568f1812ad738db99e84dd66e3 *R/position_floatstack.R
69bec32cab473636dd2303e249d8a579 *R/regon.R
09d1e9f5963b8b14726dca48d3010fac *R/scale-depth.R
665574d328d68a78bd9d71e24e636350 *R/scale-unit.R
964b4a6dd0318390d7ccf126b9c596b9 *R/shape.R
d7286d070cf3413be02e34199eac041a *R/sina.R
55e12ce162ef200018559daa1e5cbfb5 *R/spiro.R
d1434c1bd4a80b925fe3d61951e9eaca *R/themes.R
79a8beadde46db64d1111de5c485c3ad *R/trans.R
963b8516ffe7134abd9f32fa675d1536 *R/trans_linear.R
bf64ec0f9ae05cc3a626f88ddd2e885e *R/utilities.R
6ddbac5ed90490471ebd20fb6e19e9c9 *R/voronoi.R
b690de795ebd48be08be38147997b405 *R/zzz.R
736fab3747ccb6d4f9f32f873300691a *README.md
ef3dee38e6b659241265db9f66fc677c *man/facet_grid_paginate.Rd
fd8d6ba75f195b0c038873b6484f793a *man/facet_matrix.Rd
16c78d3045b76bbee39c01f31d06a801 *man/facet_row.Rd
6f063e27bf980fed22223bda91c1e481 *man/facet_stereo.Rd
a414557e75d0772ad2f968003db8ea2b *man/facet_wrap_paginate.Rd
cb3f6f3cc4b80d5247e8dde831a56843 *man/facet_zoom.Rd
fb30d01322a97920c66514610ef5bd68 *man/figures/README-example-1.png
700122af4c3aa3fc71a7562348bcf127 *man/figures/logo.png
20fa804950661156114c48629db7ccec *man/figures/logo.svg
1e9f0843746b1768a818640d9e0cec8c *man/gather_set_data.Rd
f6b2715e42729eefac4f1c0392aee2dc *man/geom_arc.Rd
9181f38a9333eafecb764dc00bc91037 *man/geom_arc_bar.Rd
46303239e57f55e132b9c883bd98acf2 *man/geom_autohistogram.Rd
1273a6ae694b871bbbecd432fb2355fb *man/geom_autopoint.Rd
5a031dc35f432eacddcc08becc77bceb *man/geom_bezier.Rd
9f83d16af405a52928f5249e1d6150a8 *man/geom_bspline.Rd
8e27b99fb72d2c75c26300d28ce428e3 *man/geom_bspline_closed.Rd
e65dea2292b9e3b56eb15b84b99e6e90 *man/geom_circle.Rd
995b64adc38c1f1c0de8c34ccaffcfb3 *man/geom_delvor.Rd
eb950d4f15dc313987cc01bd69baedac *man/geom_diagonal.Rd
ba248a71ef54f1c8064fdb9334f1d787 *man/geom_diagonal_wide.Rd
1a0d5f8d17f9e27b51969191b6922352 *man/geom_ellipse.Rd
969232dd6578b01280971b8625406610 *man/geom_link.Rd
8e127187ac8e971476e230c9eaee1115 *man/geom_mark_circle.Rd
a82fadd7584de16bea5fe4f9e6ee522f *man/geom_mark_ellipse.Rd
e86b0a5be2e7738e61fdf8770720f8a0 *man/geom_mark_hull.Rd
1f60a74a7d9a2eebd96f9329614e7a05 *man/geom_mark_rect.Rd
eb1a5dbbaf3e72ac63454dee8b299dda *man/geom_parallel_sets.Rd
240caf6f313df5a617179e5638560c57 *man/geom_regon.Rd
ce013c29063ab9914c5030643b2675e6 *man/geom_shape.Rd
a11467b221a4783458c7a54a35cfcf5f *man/geom_sina.Rd
05c0f07c84430b3f2c7571a76697e75e *man/geom_spiro.Rd
e045d4fe85c976d5bc664cac6bda5b03 *man/ggforce-extensions.Rd
9775fd70255cd21b0ceddad7f5ebb0db *man/ggforce-package.Rd
bbc605c79e6223150c2d4883b376994f *man/interpolateDataFrame.Rd
4b75fdf88125c4f945353f24882dbbfa *man/linear_trans.Rd
12d8ae329fdd7b044564efe314941910 *man/n_pages.Rd
c8d17319bff3a6a004b3f9d767019c62 *man/position_auto.Rd
8af4875bbccf2672ddb058c1d20cdbda *man/position_jitternormal.Rd
427990c1da6b6b392705a830f82f67e1 *man/power_trans.Rd
5e4f94cfb65e7a14c1e41ca0a2ffe522 *man/radial_trans.Rd
e7ebcf6bf39671dc8c5e8ed9cb067a20 *man/scale_depth.Rd
44943891afedefa63509518260ff2140 *man/scale_unit.Rd
e4501f76729f26339ebb93cd3f853dc5 *man/theme_no_axes.Rd
71c59970b7f3f600afe897ba9f88432c *man/trans_reverser.Rd
d0f256d3ff1a2ff9d8f86de9cd90a5e7 *src/RcppExports.cpp
3aa167414d82641dc6876e2f6a02bfd3 *src/bSpline.cpp
5d1dc745394f636ee366fcd3eb267879 *src/bezier.cpp
952452371235096bd5455de7fcf23f09 *src/deBoor.cpp
1e1eb94fe5ba5f4ecf4b4155c07f2f53 *src/deBoor.h
8735b04863a6c8506cd73bac0d1d88bd *src/ellipseEnclose.cpp
59f4ed76184905f23c6980cf5fc48254 *src/enclose.cpp
9af531d3eec3d1b317098b9717be1e48 *src/pointPath.cpp