hrbrmstr
/
ggalt
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
Browse Source

add xspline2, encircle geoms

pull/3/head
Ben Bolker 7 years ago
parent
bf0592c626
commit
e7ef252f6c
5 changed files with 313 additions and 0 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 1
      NAMESPACE
  2. 182
      R/geom_encircle.r
  3. 38
      R/geom_xspline2.r
  4. 55
      man/geom_encircle.Rd
  5. 37
      man/geom_xspline2.Rd

1
NAMESPACE
View File

@ -21,6 +21,7 @@ export(bytes)
export(coord_proj)
export(geom_bkde)
export(geom_bkde2d)
export(geom_encircle)
export(geom_xspline)
export(list_avatars)
export(pokemon_pal)

182
R/geom_encircle.r
View File

@ -0,0 +1,182 @@
GeomEncircle <- ggproto("GeomEncircle", Geom,
required_aes = c("x", "y"),
default_aes = aes(colour = "black",
linetype=1,
size=1,
s_shape=0.5, ## corresponds to default shape in xspline of -0.5
s_open=FALSE,
expand=0.05,
spread=0.1),
draw_key = draw_key_point,
draw_group = function(data, panel_scales, coord) {
coords <- coord$transform(data, panel_scales)
first_row <- coords[1, , drop = FALSE]
rownames(first_row) <- NULL ## prevent warning later
m <- lapply(coords[,c("x","y")],mean,na.rm=TRUE)
ch <- grDevices::chull(coords[c("x","y")])
mkcoords <- function(x,y) {
data.frame(x,y,first_row[!names(first_row) %in% c("x","y")])
}
coords <- coords[ch,]
## FIXME: using grid:: a lot. importFrom instead?
## convert from lengths to physical units, for computing *directions*
cc <- function(x,dir="x")
grid::convertUnit(grid::unit(x,"native"),"mm",typeFrom="dimension",
axisFrom=dir,valueOnly=TRUE)
## convert back to native (e.g. native + snpc offset)
cc_inv <- function(x,dir="x")
grid::convertUnit(x,"native",typeFrom="location",
axisFrom=dir,valueOnly=TRUE)
cc_comb <- function(x1,x2,dir="x")
cc_inv(unit(x1,"native")+unit(x2,"snpc"),dir=dir)
## find normalized vector: d1 and d2 have $x, $y elements
normFun <- function(d1,d2) {
dx <- cc(d1$x-d2$x)
dy <- cc(d1$y-d2$y)
r <- sqrt(dx*dx+dy*dy)
list(x=dx/r,y=dy/r)
}
if (nrow(coords)==1) {
## only one point: make a diamond by spreading points vertically
## and horizontally
coords <- with(coords,
mkcoords(
c(x,x+spread,x,x-spread),
c(y+spread,y,y-spread,y)))
} else if (nrow(coords)==2) {
## only two points: make a diamond by spreading points perpendicularly
rot <- matrix(c(0,1,-1,0),2)
dd <- c(rot %*% unlist(normFun(coords[1,],coords[2,])))*
coords$spread
coords <- with(coords, {
## figure out rotated values, then convert *back* to native units
## already in scaled units, so ignore?
x <- c(x[1],
m$x+dd[1], ## cc_comb(m$x,dd[1]),
x[2],
m$x-dd[1]) ## cc_comb(m$x,-dd[1]))
y <- c(y[1],
m$y+dd[2], ## cc_comb(m$y,dd[2],"y"),
y[2],
m$y-dd[2]) ## cc_comb(m$y,-dd[2],"y"))
mkcoords(x,y)
})
}
disp <- normFun(coords,m)
grid::xsplineGrob(
with(coords,unit(x,"npc")+disp$x*unit(expand,"snpc")),
with(coords,unit(y,"npc")+disp$y*unit(expand,"snpc")),
## coords$x,
## coords$y,
shape = coords$s_shape-1, ## kluge!
open = first_row$s_open,
gp = with(first_row,
grid::gpar(col = colour, lty=linetype))
)
}
)
if (FALSE) {
library("grid")
library("gridBase")
coords <- data.frame(x=c(1,1),y=c(1,2)*100,spread=c(0.1,0.1))
plot(y~x,data=d,xlim=c(0,3),ylim=c(0,300))
vps <- baseViewports()
pushViewport(vps$inner)
pushViewport(vps$figure)
pushViewport(vps$plot)
## check that we're in the right place
m <- as.list(colMeans(coords))
grid.points(m$x,m$y,gp=gpar(col="red"))
cc <- function(x,dir="x")
grid::convertUnit(grid::unit(x,"native"),"mm",typeFrom="dimension",
axisFrom=dir,valueOnly=TRUE)
cc_inv <- function(x,dir="x")
grid::convertUnit(x,"native",typeFrom="location",
axisFrom=dir,valueOnly=TRUE)
cc_comb <- function(x1,x2,dir="x")
cc_inv(unit(x1,"native")+unit(x2,"snpc"),dir=dir)
## find normalized vector: d1 and d2 have $x, $y elements
normFun <- function(d1,d2) {
dx <- cc(d1$x-d2$x)
dy <- cc(d1$y-d2$y)
r <- sqrt(dx*dx+dy*dy)
list(x=dx/r,y=dy/r)
}
dd <- c(rot %*% unlist(normFun(coords[1,],coords[2,])))*
coords$spread
z <- with(coords, {
## figure out rotated values, then convert *back* to native units
x <- c(x[1],
cc_comb(m$x,dd[1]),
x[2],
cc_comb(m$x,-dd[1]))
y <- c(y[1],
cc_comb(m$y,dd[2],"y"),
y[2],
cc_comb(m$y,-dd[2],"y"))
list(x=x,y=y)
})
with(z,grid.points(x,y,gp=gpar(col="blue")))
print(grid::convertWidth(unit(1,'npc'),'native'))
print(grid::convertHeight(unit(1,'npc'),'native'))
}
##' encircle
##'
##' @title encircle
##' @param mapping mapping
##' @param data data
##' @param stat stat
##' @param position position
##' @param na.rm na.rm
##' @param show.legend show.legend
##' @param inherit.aes inherit.aes
##' @param ... dots
##' @return adds a circle around the specified points
##' @author Ben Bolker
##' @export
##' @examples
##' d <- data.frame(x=c(1,1,2),y=c(1,2,2)*100)
##' (g0 <- ggplot(d,aes(x,y))+geom_point()+
##' geom_encircle(s_shape=1,expand=0)+
##' geom_encircle(s_shape=1,expand=0.1,colour="red")+
##' scale_x_continuous(expand=c(0.5,1))+
##' scale_y_continuous(expand=c(0.5,1))+
##' geom_encircle(s_shape=0.5,expand=0.1,colour="purple"))
##' g0 + geom_encircle(data=subset(d,x==1),colour="blue",spread=0.02)+
##' geom_encircle(data=subset(d,x==2),colour="cyan",spread=0.04)
##'
##' g0 <- ggplot(mpg, aes(displ, hwy)) + geom_point()
##' (g1 <- g0 + geom_encircle(data=subset(mpg,hwy>40)))
##' ss <- subset(mpg,hwy>31 & displ<2)
##' g1 + geom_point(data=ss,colour="blue")+
##' geom_encircle(data=ss,colour="blue",s_shape=0.9,
##' expand=0.07)
geom_encircle <- function(mapping = NULL, data = NULL, stat = "identity",
position = "identity", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, ...) {
layer(
geom = GeomEncircle, mapping = mapping, data = data, stat = stat,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, ...)
)
}

38
R/geom_xspline2.r
View File

@ -0,0 +1,38 @@
GeomXSpline2 <- ggproto("GeomXSpline", Geom,
required_aes = c("x", "y"),
default_aes = aes(colour = "black", s_shape=1, s_open=FALSE),
draw_key = draw_key_point,
draw_panel = function(data, panel_scales, coord) {
coords <- coord$transform(data, panel_scales)
grid::xsplineGrob(
coords$x, coords$y,
shape = coords$s_shape-1, ## kluge!
open = coords$s_open[1],
gp = grid::gpar(col = coords$colour)
)
}
)
##' Xspline
##'
##' @title xsplines
##' @param mapping mapping
##' @param data data
##' @param stat stat
##' @param position position
##' @param na.rm na.rm
##' @param show.legend show.legend
##' @param inherit.aes inherit.aes
##' @param ... stuff
##' @return creates a spline curve
##' @author Ben Bolker
geom_xspline2 <- function(mapping = NULL, data = NULL, stat = "identity",
position = "identity", na.rm = FALSE, show.legend = NA,
inherit.aes = TRUE, ...) {
layer(
geom = GeomXSpline2, mapping = mapping, data = data, stat = stat,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, ...)
)
}

55
man/geom_encircle.Rd
View File

@ -0,0 +1,55 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/geom_encircle.r
\name{geom_encircle}
\alias{geom_encircle}
\title{encircle}
\usage{
geom_encircle(mapping = NULL, data = NULL, stat = "identity",
position = "identity", na.rm = FALSE, show.legend = NA,
inherit.aes = TRUE, ...)
}
\arguments{
\item{mapping}{mapping}
\item{data}{data}
\item{stat}{stat}
\item{position}{position}
\item{na.rm}{na.rm}
\item{show.legend}{show.legend}
\item{inherit.aes}{inherit.aes}
\item{...}{dots}
}
\value{
adds a circle around the specified points
}
\description{
encircle
}
\examples{
d <- data.frame(x=c(1,1,2),y=c(1,2,2)*100)
(g0 <- ggplot(d,aes(x,y))+geom_point()+
geom_encircle(s_shape=1,expand=0)+
geom_encircle(s_shape=1,expand=0.1,colour="red")+
scale_x_continuous(expand=c(0.5,1))+
scale_y_continuous(expand=c(0.5,1))+
geom_encircle(s_shape=0.5,expand=0.1,colour="purple"))
g0 + geom_encircle(data=subset(d,x==1),colour="blue",spread=0.02)+
geom_encircle(data=subset(d,x==2),colour="cyan",spread=0.04)
g0 <- ggplot(mpg, aes(displ, hwy)) + geom_point()
(g1 <- g0 + geom_encircle(data=subset(mpg,hwy>40)))
ss <- subset(mpg,hwy>31 & displ<2)
g1 + geom_point(data=ss,colour="blue")+
geom_encircle(data=ss,colour="blue",s_shape=0.9,
expand=0.07)
}
\author{
Ben Bolker
}

37
man/geom_xspline2.Rd
View File

@ -0,0 +1,37 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/geom_xspline2.r
\name{geom_xspline2}
\alias{geom_xspline2}
\title{xsplines}
\usage{
geom_xspline2(mapping = NULL, data = NULL, stat = "identity",
position = "identity", na.rm = FALSE, show.legend = NA,
inherit.aes = TRUE, ...)
}
\arguments{
\item{mapping}{mapping}
\item{data}{data}
\item{stat}{stat}
\item{position}{position}
\item{na.rm}{na.rm}
\item{show.legend}{show.legend}
\item{inherit.aes}{inherit.aes}
\item{...}{stuff}
}
\value{
creates a spline curve
}
\description{
Xspline
}
\author{
Ben Bolker
}
Write Preview
Loading…
Cancel
Save