@@ -54,19 +54,12 @@ bin_breaks <- function(breaks, closed = c("right", "left")) {
54
54
55
55
bin_breaks_width <- function (x_range , width = NULL , center = NULL ,
56
56
boundary = NULL , closed = c(" right" , " left" )) {
57
- check_length(x_range , 2L )
58
57
59
- # binwidth seems to be the argument name supplied to width. (stat-bin and stat-bindot)
60
- check_number_decimal(width , min = 0 , allow_infinite = FALSE , arg = " binwidth" )
61
-
62
- if (! is.null(boundary ) && ! is.null(center )) {
63
- cli :: cli_abort(" Only one of {.arg boundary} and {.arg center} may be specified." )
64
- } else if (is.null(boundary )) {
58
+ if (is.null(boundary )) {
65
59
if (is.null(center )) {
66
60
# If neither edge nor center given, compute both using tile layer's
67
61
# algorithm. This puts min and max of data in outer half of their bins.
68
62
boundary <- width / 2
69
-
70
63
} else {
71
64
# If center given but not boundary, compute boundary.
72
65
boundary <- center - width / 2
@@ -75,9 +68,6 @@ bin_breaks_width <- function(x_range, width = NULL, center = NULL,
75
68
76
69
# Find the left side of left-most bin: inputs could be Dates or POSIXct, so
77
70
# coerce to numeric first.
78
- x_range <- as.numeric(x_range )
79
- width <- as.numeric(width )
80
- boundary <- as.numeric(boundary )
81
71
shift <- floor((x_range [1 ] - boundary ) / width )
82
72
origin <- boundary + shift * width
83
73
@@ -104,9 +94,7 @@ bin_breaks_width <- function(x_range, width = NULL, center = NULL,
104
94
105
95
bin_breaks_bins <- function (x_range , bins = 30 , center = NULL ,
106
96
boundary = NULL , closed = c(" right" , " left" )) {
107
- check_length(x_range , 2L )
108
97
109
- check_number_whole(bins , min = 1 )
110
98
if (zero_range(x_range )) {
111
99
# 0.1 is the same width as the expansion `default_expansion()` gives for 0-width data
112
100
width <- 0.1
@@ -128,6 +116,56 @@ bin_breaks_bins <- function(x_range, bins = 30, center = NULL,
128
116
129
117
# Compute bins ------------------------------------------------------------
130
118
119
+ compute_bins <- function (x , scale = NULL , breaks = NULL , binwidth = NULL , bins = NULL ,
120
+ center = NULL , boundary = NULL ,
121
+ closed = c(" right" , " left" )) {
122
+
123
+ range <- if (is.scale(scale )) scale $ dimension() else range(x )
124
+ check_length(range , 2L )
125
+
126
+ if (! is.null(breaks )) {
127
+ breaks <- allow_lambda(breaks )
128
+ if (is.function(breaks )) {
129
+ breaks <- breaks(x )
130
+ }
131
+ if (is.scale(scale ) && ! scale $ is_discrete()) {
132
+ breaks <- scale $ transform(breaks )
133
+ }
134
+ check_numeric(breaks )
135
+ bins <- bin_breaks(breaks , closed )
136
+ return (bins )
137
+ }
138
+
139
+ check_number_decimal(boundary , allow_infinite = FALSE , allow_null = TRUE )
140
+ check_number_decimal(center , allow_infinite = FALSE , allow_null = TRUE )
141
+ if (! is.null(boundary ) && ! is.null(center )) {
142
+ cli :: cli_abort(" Only one of {.arg boundary} and {.arg center} may be specified." )
143
+ }
144
+
145
+ if (! is.null(binwidth )) {
146
+ binwidth <- allow_lambda(binwidth )
147
+ if (is.function(binwidth )) {
148
+ binwidth <- binwidth(x )
149
+ }
150
+ check_number_decimal(binwidth , min = 0 , allow_infinite = FALSE )
151
+ bins <- bin_breaks_width(
152
+ range , binwidth ,
153
+ center = center , boundary = boundary , closed = closed
154
+ )
155
+ return (bins )
156
+ }
157
+
158
+ bins <- allow_lambda(bins )
159
+ if (is.function(bins )) {
160
+ bins <- bins(x )
161
+ }
162
+ check_number_whole(bins , min = 1 , allow_infinite = FALSE )
163
+ bin_breaks_bins(
164
+ range , bins ,
165
+ center = center , boundary = boundary , closed = closed
166
+ )
167
+ }
168
+
131
169
bin_vector <- function (x , bins , weight = NULL , pad = FALSE ) {
132
170
check_object(bins , is_bins , " a {.cls ggplot2_bins} object" )
133
171
@@ -141,8 +179,7 @@ bin_vector <- function(x, bins, weight = NULL, pad = FALSE) {
141
179
weight [is.na(weight )] <- 0
142
180
}
143
181
144
- bin_idx <- cut(x , bins $ fuzzy , right = bins $ right_closed ,
145
- include.lowest = TRUE )
182
+ bin_idx <- bin_cut(x , bins )
146
183
bin_count <- as.numeric(tapply(weight , bin_idx , sum , na.rm = TRUE ))
147
184
bin_count [is.na(bin_count )] <- 0
148
185
@@ -170,6 +207,10 @@ bin_vector <- function(x, bins, weight = NULL, pad = FALSE) {
170
207
bin_out(bin_count , bin_x , bin_widths )
171
208
}
172
209
210
+ bin_cut <- function (x , bins ) {
211
+ cut(x , bins $ fuzzy , right = bins $ right_closed , include.lowest = TRUE )
212
+ }
213
+
173
214
bin_out <- function (count = integer(0 ), x = numeric (0 ), width = numeric (0 ),
174
215
xmin = x - width / 2 , xmax = x + width / 2 ) {
175
216
density <- count / width / sum(abs(count ))
@@ -186,3 +227,41 @@ bin_out <- function(count = integer(0), x = numeric(0), width = numeric(0),
186
227
.size = length(count )
187
228
)
188
229
}
230
+
231
+ bin_loc <- function (x , id ) {
232
+ left <- x [- length(x )]
233
+ right <- x [- 1 ]
234
+
235
+ list (
236
+ left = left [id ],
237
+ right = right [id ],
238
+ mid = ((left + right ) / 2 )[id ],
239
+ length = diff(x )[id ]
240
+ )
241
+ }
242
+
243
+ fix_bin_params = function (params , fun , version ) {
244
+
245
+ if (! is.null(params $ origin )) {
246
+ args <- paste0(fun , c(" (origin)" , " (boundary)" ))
247
+ deprecate_warn0(version , args [1 ], args [2 ])
248
+ params $ boudnary <- params $ origin
249
+ params $ origin <- NULL
250
+ }
251
+
252
+ if (! is.null(params $ right )) {
253
+ args <- paste0(fun , c(" (right)" , " (closed)" ))
254
+ deprecate_warn0(version , args [1 ], args [2 ])
255
+ params $ closed <- if (isTRUE(params $ right )) " right" else " left"
256
+ params $ right <- NULL
257
+ }
258
+
259
+ if (is.null(params $ breaks %|| % params $ binwidth %|| % params $ bins )) {
260
+ cli :: cli_inform(
261
+ " {.fn {fun}} using {.code bins = 30}. Pick better value {.arg binwidth}."
262
+ )
263
+ params $ bins <- 30
264
+ }
265
+
266
+ params
267
+ }
0 commit comments