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
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
|
bins <- function(breaks, closed = "right",
fuzz = 1e-08 * stats::median(diff(breaks))) {
if (!is.numeric(breaks)) {
cli::cli_abort("{.arg breaks} must be a numeric vector")
}
closed <- arg_match0(closed, c("right", "left"))
breaks <- sort(breaks)
# Adapted base::hist - this protects from floating point rounding errors
if (closed == "right") {
fuzzes <- c(-fuzz, rep.int(fuzz, length(breaks) - 1))
} else {
fuzzes <- c(rep.int(-fuzz, length(breaks) - 1), fuzz)
}
structure(
list(
breaks = breaks,
fuzzy = breaks + fuzzes,
right_closed = closed == "right"
),
class = "ggplot2_bins"
)
}
is_bins <- function(x) inherits(x, "ggplot2_bins")
#' @export
print.ggplot2_bins <- function(x, ...) {
n <- length(x$breaks)
cat("<Bins>\n")
if (x$right_closed) {
left <- c("[", rep("(", n - 2))
right <- rep("]", n - 1)
} else {
left <- rep("[", n - 1)
right <- c(rep(")", n - 2), "]")
}
breaks <- format(x$breaks)
bins <- paste0("* ", left, breaks[-n], ",", breaks[-1], right)
cat(bins, sep = "\n")
cat("\n")
}
# Compute parameters -----------------------------------------------------------
bin_breaks <- function(breaks, closed = c("right", "left")) {
bins(breaks, closed)
}
bin_breaks_width <- function(x_range, width = NULL, center = NULL,
boundary = NULL, closed = c("right", "left")) {
if (length(x_range) != 2) {
cli::cli_abort("{.arg x_range} must have two elements")
}
# if (length(x_range) == 0) {
# return(bin_params(numeric()))
# }
if (!(is.numeric(width) && length(width) == 1)) {
cli::cli_abort("{.arg width} must be a number")
}
if (width <= 0) {
cli::cli_abort("{.arg binwidth} must be positive")
}
if (!is.null(boundary) && !is.null(center)) {
cli::cli_abort("Only one of {.arg boundary} and {.arg center} may be specified.")
} else if (is.null(boundary)) {
if (is.null(center)) {
# If neither edge nor center given, compute both using tile layer's
# algorithm. This puts min and max of data in outer half of their bins.
boundary <- width / 2
} else {
# If center given but not boundary, compute boundary.
boundary <- center - width / 2
}
}
# Find the left side of left-most bin: inputs could be Dates or POSIXct, so
# coerce to numeric first.
x_range <- as.numeric(x_range)
width <- as.numeric(width)
boundary <- as.numeric(boundary)
shift <- floor((x_range[1] - boundary) / width)
origin <- boundary + shift * width
# Small correction factor so that we don't get an extra bin when, for
# example, origin = 0, max(x) = 20, width = 10.
max_x <- x_range[2] + (1 - 1e-08) * width
if (isTRUE((max_x - origin) / width > 1e6)) {
cli::cli_abort(c(
"The number of histogram bins must be less than 1,000,000.",
"i" = "Did you make {.arg binwidth} too small?"
))
}
breaks <- seq(origin, max_x, width)
if (length(breaks) == 1) {
# In exceptionally rare cases, the above can fail and produce only a
# single break (see issue #3606). We fix this by adding a second break.
breaks <- c(breaks, breaks + width)
}
bin_breaks(breaks, closed = closed)
}
bin_breaks_bins <- function(x_range, bins = 30, center = NULL,
boundary = NULL, closed = c("right", "left")) {
if (length(x_range) != 2) {
cli::cli_abort("{.arg x_range} must have two elements")
}
bins <- as.integer(bins)
if (bins < 1) {
cli::cli_abort("{.arg bins} must be 1 or greater")
} else if (zero_range(x_range)) {
# 0.1 is the same width as the expansion `default_expansion()` gives for 0-width data
width <- 0.1
} else if (bins == 1) {
width <- diff(x_range)
boundary <- x_range[1]
} else {
width <- (x_range[2] - x_range[1]) / (bins - 1)
}
bin_breaks_width(x_range, width, boundary = boundary, center = center,
closed = closed)
}
# Compute bins ------------------------------------------------------------
bin_vector <- function(x, bins, weight = NULL, pad = FALSE) {
if (!is_bins(bins)) {
cli::cli_abort("{.arg bins} must be a {.cls ggplot2_bins} object")
}
if (all(is.na(x))) {
return(bin_out(length(x), NA, NA, xmin = NA, xmax = NA))
}
if (is.null(weight)) {
weight <- rep(1, length(x))
} else {
weight[is.na(weight)] <- 0
}
bin_idx <- cut(x, bins$fuzzy, right = bins$right_closed,
include.lowest = TRUE)
bin_count <- as.numeric(tapply(weight, bin_idx, sum, na.rm = TRUE))
bin_count[is.na(bin_count)] <- 0
bin_x <- (bins$breaks[-length(bins$breaks)] + bins$breaks[-1]) / 2
bin_widths <- diff(bins$breaks)
# Pad row of 0s at start and end
if (pad) {
bin_count <- c(0, bin_count, 0)
width1 <- bin_widths[1]
widthn <- bin_widths[length(bin_widths)]
bin_widths <- c(width1, bin_widths, widthn)
bin_x <- c(bin_x[1] - width1, bin_x, bin_x[length(bin_x)] + widthn)
}
# Add row for missings
if (any(is.na(bins))) {
bin_count <- c(bin_count, sum(is.na(bins)))
bin_widths <- c(bin_widths, NA)
bin_x <- c(bin_x, NA)
}
bin_out(bin_count, bin_x, bin_widths)
}
bin_out <- function(count = integer(0), x = numeric(0), width = numeric(0),
xmin = x - width / 2, xmax = x + width / 2) {
density <- count / width / sum(abs(count))
data_frame0(
count = count,
x = x,
xmin = xmin,
xmax = xmax,
width = width,
density = density,
ncount = count / max(abs(count)),
ndensity = density / max(abs(density)),
.size = length(count)
)
}
|
