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
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
|
#' Count number of observation in rectangular bins.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("stat", "bin2d")}
#'
#' @inheritParams stat_identity
#' @param bins numeric vector giving number of bins in both vertical and
#' horizontal directions. Set to 30 by default.
#' @param drop if \code{TRUE} removes all cells with 0 counts.
#' @seealso \code{\link{stat_binhex}} for hexagonal binning
#' @export
#' @examples
#' \donttest{
#' d <- ggplot(diamonds, aes(carat, price))
#' d + stat_bin2d()
#' d + geom_bin2d()
#'
#' # You can control the size of the bins by specifying the number of
#' # bins in each direction:
#' d + stat_bin2d(bins = 10)
#' d + stat_bin2d(bins = 30)
#'
#' # Or by specifying the width of the bins
#' d + stat_bin2d(binwidth = c(1, 1000))
#' d + stat_bin2d(binwidth = c(.1, 500))
#'
#' # Or with a list of breaks
#' x <- seq(min(diamonds$carat), max(diamonds$carat), by = 0.1)
#' y <- seq(min(diamonds$price), max(diamonds$price), length = 50)
#' d + stat_bin2d(breaks = list(x = x, y = y))
#'
#' # With qplot
#' qplot(x, y, data = diamonds, geom="bin2d",
#' xlim = c(4, 10), ylim = c(4, 10))
#' qplot(x, y, data = diamonds, geom="bin2d", binwidth = c(0.1, 0.1),
#' xlim = c(4, 10), ylim = c(4, 10))
#' }
stat_bin2d <- function (mapping = NULL, data = NULL, geom = NULL, position = "identity",
bins = 30, drop = TRUE, ...) {
StatBin2d$new(mapping = mapping, data = data, geom = geom, position = position,
bins = bins, drop = drop, ...)
}
StatBin2d <- proto(Stat, {
objname <- "bin2d"
default_aes <- function(.) aes(fill = ..count..)
required_aes <- c("x", "y")
default_geom <- function(.) GeomRect
calculate <- function(., data, scales, binwidth = NULL, bins = 30, breaks = NULL, origin = NULL, drop = TRUE, ...) {
range <- list(
x = scale_dimension(scales$x, c(0, 0)),
y = scale_dimension(scales$y, c(0, 0))
)
# Determine origin, if omitted
if (is.null(origin)) {
origin <- c(NA, NA)
} else {
stopifnot(is.numeric(origin))
stopifnot(length(origin) == 2)
}
originf <- function(x) if (is.integer(x)) -0.5 else min(x, na.rm = TRUE)
if (is.na(origin[1])) origin[1] <- originf(data$x)
if (is.na(origin[2])) origin[2] <- originf(data$y)
# Determine binwidth, if omitted
if (is.null(binwidth)) {
binwidth <- c(NA, NA)
if (is.integer(data$x)) {
binwidth[1] <- 1
} else {
binwidth[1] <- diff(range$x) / bins
}
if (is.integer(data$y)) {
binwidth[2] <- 1
} else {
binwidth[2] <- diff(range$y) / bins
}
}
stopifnot(is.numeric(binwidth))
stopifnot(length(binwidth) == 2)
# Determine breaks, if omitted
if (is.null(breaks)) {
breaks <- list(
seq(origin[1], max(range$x) + binwidth[1], binwidth[1]),
seq(origin[2], max(range$y) + binwidth[2], binwidth[2])
)
} else {
stopifnot(is.list(breaks))
stopifnot(length(breaks) == 2)
stopifnot(all(sapply(breaks, is.numeric)))
}
names(breaks) <- c("x", "y")
xbin <- cut(data$x, sort(breaks$x), include.lowest = TRUE)
ybin <- cut(data$y, sort(breaks$y), include.lowest = TRUE)
if (is.null(data$weight)) data$weight <- 1
counts <- as.data.frame(
xtabs(weight ~ xbin + ybin, data), responseName = "count")
if (drop) counts <- subset(counts, count > 0)
within(counts,{
xint <- as.numeric(xbin)
xmin <- breaks$x[xint]
xmax <- breaks$x[xint + 1]
yint <- as.numeric(ybin)
ymin <- breaks$y[yint]
ymax <- breaks$y[yint + 1]
density <- count / sum(count, na.rm = TRUE)
})
}
})
|
