1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
|
#' Hollow bar with middle indicated by horizontal line.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "crossbar")}
#'
#' @inheritParams geom_point
#' @param fatten a multiplicate factor to fatten middle bar by
#' @seealso \code{\link{geom_errorbar}} for error bars,
#' \code{\link{geom_pointrange}} and \code{\link{geom_linerange}} for other
#' ways of showing mean + error, \code{\link{stat_summary}} to compute
#' errors from the data, \code{\link{geom_smooth}} for the continuous analog.
#' @export
#' @examples
#' # See geom_linerange for examples
geom_crossbar <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity",
fatten = 2, ...) {
GeomCrossbar$new(mapping = mapping, data = data, stat = stat,
position = position, fatten = fatten, ...)
}
GeomCrossbar <- proto(Geom, {
objname <- "crossbar"
reparameterise <- function(., df, params) {
GeomErrorbar$reparameterise(df, params)
}
default_stat <- function(.) StatIdentity
default_pos <- function(.) PositionIdentity
default_aes = function(.) aes(colour="black", fill=NA, size=0.5, linetype=1, alpha = NA)
required_aes <- c("x", "y", "ymin", "ymax")
guide_geom <- function(.) "crossbar"
draw_legend <- function(., data, ...) {
data <- aesdefaults(data, .$default_aes(), list(...))
gp <- with(data, gpar(col=colour, fill=alpha(fill, alpha), lwd=size * .pt, lty = linetype))
gTree(gp = gp, children = gList(
rectGrob(height=0.5, width=0.75),
linesGrob(c(0.125, 0.875), 0.5)
))
}
draw <- function(., data, scales, coordinates, fatten = 2, width = NULL, ...) {
middle <- transform(data, x = xmin, xend = xmax, yend = y, size = size * fatten, alpha = NA)
has_notch <- !is.null(data$ynotchlower) && !is.null(data$ynotchupper) &&
!is.na(data$ynotchlower) && !is.na(data$ynotchupper)
if (has_notch) {
if (data$ynotchlower < data$ymin || data$ynotchupper > data$ymax)
message("notch went outside hinges. Try setting notch=FALSE.")
notchindent <- (1 - data$notchwidth) * (data$xmax - data$xmin) / 2
middle$x <- middle$x + notchindent
middle$xend <- middle$xend - notchindent
box <- data.frame(
x = c(data$xmin, data$xmin, data$xmin + notchindent, data$xmin, data$xmin,
data$xmax, data$xmax, data$xmax - notchindent, data$xmax, data$xmax,
data$xmin),
y = c(data$ymax, data$ynotchupper, data$y, data$ynotchlower, data$ymin,
data$ymin, data$ynotchlower, data$y, data$ynotchupper, data$ymax,
data$ymax),
alpha = data$alpha, colour = data$colour, size = data$size,
linetype = data$linetype, fill = data$fill, group = data$group,
stringsAsFactors = FALSE)
} else {
# No notch
box <- data.frame(
x = c(data$xmin, data$xmin, data$xmax, data$xmax, data$xmin),
y = c(data$ymax, data$ymin, data$ymin, data$ymax, data$ymax),
alpha = data$alpha, colour = data$colour, size = data$size,
linetype = data$linetype, fill = data$fill, group = data$group,
stringsAsFactors = FALSE)
}
ggname(.$my_name(), gTree(children=gList(
GeomPolygon$draw(box, scales, coordinates, ...),
GeomSegment$draw(middle, scales, coordinates, ...)
)))
}
})
|
