Newer
Older
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
#'Draws a Continuous Color Bar
#'
#'Generates a color bar to use as colouring function for map plots and
#'optionally draws it (horizontally or vertically) to be added to map
#'multipanels or plots. It is possible to draw triangles at the ends of the
#'colour bar to represent values that go beyond the range of interest. A
#'number of options is provided to adjust the colours and the position and
#'size of the components. The drawn colour bar spans a whole figure region
#'and is compatible with figure layouts.\cr\cr
#'The generated colour bar consists of a set of breaks that define the
#'length(brks) - 1 intervals to classify each of the values in each of the
#'grid cells of a two-dimensional field. The corresponding grid cell of a
#'given value of the field will be coloured in function of the interval it
#'belongs to.\cr\cr
#'The only mandatory parameters are 'var_limits' or 'brks' (in its second
#'format, see below).
#'
#'@param brks Can be provided in two formats:
#'\itemize{
#' \item{A single value with the number of breaks to be generated
#' automatically, between the minimum and maximum specified in 'var_limits'
#' (both inclusive). Hence the parameter 'var_limits' is mandatory if 'brks'
#' is provided with this format. If 'bar_limits' is additionally provided,
#' values only between 'bar_limits' will be generated. The higher the value
#' of 'brks', the smoother the plot will look.}
#' \item{A vector with the actual values of the desired breaks. Values will
#' be reordered by force to ascending order. If provided in this format, no
#' other parameters are required to generate/plot the colour bar.}
#'}
#' This parameter is optional if 'var_limits' is specified. If 'brks' not
#' specified but 'cols' is specified, it will take as value length(cols) + 1.
#' If 'cols' is not specified either, 'brks' will take 21 as value.
#'@param cols Vector of length(brks) - 1 valid colour identifiers, for each
#' interval defined by the breaks. This parameter is optional and will be
#' filled in with a vector of length(brks) - 1 colours generated with the
#' function provided in 'color_fun' (\code{clim.colors} by default).\cr 'cols'
#' can have one additional colour at the beginning and/or at the end with the
#' aim to colour field values beyond the range of interest represented in the
#' colour bar. If any of these extra colours is provided, parameter
#' 'triangle_ends' becomes mandatory in order to disambiguate which of the
#' ends the colours have been provided for.
#'@param vertical TRUE/FALSE for vertical/horizontal colour bar
#' (disregarded if plot = FALSE).
#'@param subsampleg The first of each subsampleg breaks will be ticked on the
#' colorbar. Takes by default an approximation of a value that yields a
#' readable tick arrangement (extreme breaks always ticked). If set to 0 or
#' lower, no labels are drawn. See the code of the function for details or
#' use 'extra_labels' for customized tick arrangements.
#'@param bar_limits Vector of two numeric values with the extremes of the
#' range of values represented in the colour bar. If 'var_limits' go beyond
#' this interval, the drawing of triangle extremes is triggered at the
#' corresponding sides, painted in 'col_inf' and 'col_sup'. Either of them
#' can be set as NA and will then take as value the corresponding extreme in
#' 'var_limits' (hence a triangle end won't be triggered for these sides).
#' Takes as default the extremes of 'brks' if available, else the same values
#' as 'var_limits'.
#'@param var_limits Vector of two numeric values with the minimum and maximum
#' values of the field to represent. These are used to know whether to draw
#' triangle ends at the extremes of the colour bar and what colour to fill
#' them in with. If not specified, take the same value as the extremes of
#' 'brks'. Hence the parameter 'brks' is mandatory if 'var_limits' is not
#' specified.
#'@param triangle_ends Vector of two logical elements, indicating whether to
#' force the drawing of triangle ends at each of the extremes of the colour
#' bar. This choice is automatically made from the provided 'brks',
#' 'bar_limits', 'var_limits', 'col_inf' and 'col_sup', but the behaviour
#' can be manually forced to draw or not to draw the triangle ends with this
#' parameter. If 'cols' is provided, 'col_inf' and 'col_sup' will take
#' priority over 'triangle_ends' when deciding whether to draw the triangle
#' ends or not.
#'@param col_inf Colour to fill the inferior triangle end with. Useful if
#' specifying colours manually with parameter 'cols', to specify the colour
#' and to trigger the drawing of the lower extreme triangle, or if 'cols' is
#' not specified, to replace the colour automatically generated by ColorBar().
#'@param col_sup Colour to fill the superior triangle end with. Useful if
#' specifying colours manually with parameter 'cols', to specify the colour
#' and to trigger the drawing of the upper extreme triangle, or if 'cols' is
#' not specified, to replace the colour automatically generated by ColorBar().
#'@param color_fun Function to generate the colours of the color bar. Must
#' take an integer and must return as many colours. The returned colour vector
#' can have the attribute 'na_color', with a colour to draw NA values. This
#' parameter is set by default to ClimPalette().
#'@param plot Logical value indicating whether to only compute its breaks and
#' colours (FALSE) or to also draw it on the current device (TRUE).
#'@param draw_ticks Whether to draw ticks for the labels along the colour bar
#' (TRUE) or not (FALSE). TRUE by default. Disregarded if 'plot = FALSE'.
#'@param draw_separators Whether to draw black lines in the borders of each of
#' the colour rectancles of the colour bar (TRUE) or not (FALSE). FALSE by
#' default. Disregarded if 'plot = FALSE'.
#'@param triangle_ends_scale Scale factor for the drawn triangle ends of the
#' colour bar, if drawn at all. Takes 1 by default (rectangle triangle
#' proportional to the thickness of the colour bar). Disregarded if
#' 'plot = FALSE'.
#'@param extra_labels Numeric vector of extra labels to draw along axis of
#' the colour bar. The number of provided decimals will be conserved.
#' Disregarded if 'plot = FALSE'.
#'@param title Title to draw on top of the colour bar, most commonly with the
#' units of the represented field in the neighbour figures. Empty by default.
#'@param title_scale Scale factor for the 'title' of the colour bar.
#' Takes 1 by default.
#'@param label_scale Scale factor for the labels of the colour bar.
#' Takes 1 by default.
#'@param tick_scale Scale factor for the length of the ticks of the labels
#' along the colour bar. Takes 1 by default.
#'@param extra_margin Extra margins to be added around the colour bar,
#' in the format c(y1, x1, y2, x2). The units are margin lines. Takes
#' rep(0, 4) by default.
#'@param label_digits Number of significant digits to be displayed in the
#' labels of the colour bar, usually to avoid too many decimal digits
#' overflowing the figure region. This does not have effect over the labels
#' provided in 'extra_labels'. Takes 4 by default.
#'@param ... Arguments to be passed to the method. Only accepts the following
#' graphical parameters:\cr adj ann ask bg bty cex.lab cex.main cex.sub cin
#' col.axis col.lab col.main col.sub cra crt csi cxy err family fg fig fin
#' font font.axis font.lab font.main font.sub lend lheight ljoin lmitre lty
#' lwd mai mex mfcol mfrow mfg mkh oma omd omi page pch pin plt pty smo srt
#' tck tcl usr xaxp xaxs xaxt xlog xpd yaxp yaxs yaxt ylbias ylog.\cr For more
#' information about the parameters see `par`.
#'
#'@return
#'\item{brks}{
#' Breaks used for splitting the range in intervals.
#'}
#'\item{cols}{
#' Colours generated for each of the length(brks) - 1 intervals.
#' Always of length length(brks) - 1.
#'}
#'\item{col_inf}{
#' Colour used to draw the lower triangle end in the colour
#' bar (NULL if not drawn at all).
#'}
#'\item{col_sup}{
#' Colour used to draw the upper triangle end in the colour
#' bar (NULL if not drawn at all).
#'}
#'
#'@examples
#'cols <- c("dodgerblue4", "dodgerblue1", "forestgreen", "yellowgreen", "white",
#' "white", "yellow", "orange", "red", "saddlebrown")
#'lims <- seq(-1, 1, 0.2)
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
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
#'@importFrom grDevices col2rgb rgb
#'@export
ColorBarContinuous <- function(brks = NULL, cols = NULL, vertical = TRUE,
subsampleg = NULL, bar_limits = NULL, var_limits = NULL,
triangle_ends = NULL, col_inf = NULL, col_sup = NULL,
color_fun = ClimPalette(), plot = TRUE,
draw_ticks = TRUE, draw_separators = FALSE,
triangle_ends_scale = 1, extra_labels = NULL,
title = NULL, title_scale = 1,
label_scale = 1, tick_scale = 1,
extra_margin = rep(0, 4), label_digits = 4, ...) {
# Required checks
if ((is.null(brks) || length(brks) < 2) && is.null(bar_limits) && is.null(var_limits)) {
stop("At least one of 'brks' with the desired breaks, 'bar_limits' or ",
"'var_limits' must be provided to generate the colour bar.")
}
# Check brks
if (!is.null(brks)) {
if (!is.numeric(brks)) {
stop("Parameter 'brks' must be numeric if specified.")
} else if (length(brks) > 1) {
reorder <- sort(brks, index.return = TRUE)
if (!is.null(cols)) {
cols <- cols[reorder$ix[which(reorder$ix <= length(cols))]]
}
brks <- reorder$x
}
}
# Check bar_limits
if (!is.null(bar_limits)) {
if (!(all(is.na(bar_limits) | is.numeric(bar_limits)) && (length(bar_limits) == 2))) {
stop("Parameter 'bar_limits' must be a vector of two numeric elements or NAs.")
}
}
# Check var_limits
if (!is.null(var_limits)) {
if (!(is.numeric(var_limits) && (length(var_limits) == 2))) {
stop("Parameter 'var_limits' must be a numeric vector of length 2.")
} else if (anyNA(var_limits)) {
stop("Parameter 'var_limits' must not contain NA values.")
} else if (any(is.infinite(var_limits))) {
stop("Parameter 'var_limits' must not contain infinite values.")
}
}
# Check cols
if (!is.null(cols)) {
if (!is.character(cols)) {
stop("Parameter 'cols' must be a vector of character strings.")
} else if (any(!sapply(cols, .IsColor))) {
stop("Parameter 'cols' must contain valid colour identifiers.")
}
}
# Check color_fun
if (!is.function(color_fun)) {
stop("Parameter 'color_fun' must be a colour-generator function.")
}
# Check integrity among brks, bar_limits and var_limits
if (is.null(brks) || (length(brks) < 2)) {
if (is.null(brks)) {
if (is.null(cols)) {
brks <- 21
} else {
brks <- length(cols) + 1
}
}
if (is.null(bar_limits) || anyNA(bar_limits)) {
# var_limits is defined
if (is.null(bar_limits)) {
bar_limits <- c(NA, NA)
}
half_width <- 0.5 * (var_limits[2] - var_limits[1]) / (brks - 1)
bar_limits[which(is.na(bar_limits))] <- c(var_limits[1] - half_width, var_limits[2] + half_width)[which(is.na(bar_limits))]
brks <- seq(bar_limits[1], bar_limits[2], length.out = brks)
} else if (is.null(var_limits)) {
# bar_limits is defined
var_limits <- bar_limits
half_width <- 0.5 * (var_limits[2] - var_limits[1]) / (brks - 1)
brks <- seq(bar_limits[1], bar_limits[2], length.out = brks)
var_limits[1] <- var_limits[1] + half_width / 50
} else {
# both bar_limits and var_limits are defined
brks <- seq(bar_limits[1], bar_limits[2], length.out = brks)
}
} else if (is.null(bar_limits)) {
if (is.null(var_limits)) {
# brks is defined
bar_limits <- c(head(brks, 1), tail(brks, 1))
var_limits <- bar_limits
half_width <- 0.5 * (var_limits[2] - var_limits[1]) / (length(brks) - 1)
var_limits[1] <- var_limits[1] + half_width / 50
} else {
# brks and var_limits are defined
bar_limits <- c(head(brks, 1), tail(brks, 1))
}
} else {
# brks and bar_limits are defined
# or
# brks, bar_limits and var_limits are defined
if (head(brks, 1) != bar_limits[1] || tail(brks, 1) != bar_limits[2]) {
stop("Parameters 'brks' and 'bar_limits' are inconsistent.")
}
}
# Check col_inf
if (!is.null(col_inf)) {
if (!.IsColor(col_inf)) {
stop("Parameter 'col_inf' must be a valid colour identifier.")
}
}
# Check col_sup
if (!is.null(col_sup)) {
if (!.IsColor(col_sup)) {
stop("Parameter 'col_sup' must be a valid colour identifier.")
}
}
# Check triangle_ends
if (!is.null(triangle_ends) && (!is.logical(triangle_ends) || length(triangle_ends) != 2)) {
stop("Parameter 'triangle_ends' must be a logical vector with two elements.")
}
teflc <- triangle_ends_from_limit_cols <- c(!is.null(col_inf), !is.null(col_sup))
if (is.null(triangle_ends) && is.null(col_inf) && is.null(col_sup)) {
triangle_ends <- c(FALSE, FALSE)
if (bar_limits[1] >= var_limits[1]) {
triangle_ends[1] <- TRUE
}
if (bar_limits[2] < var_limits[2]) {
triangle_ends[2] <- TRUE
}
} else if (!is.null(triangle_ends) && is.null(col_inf) && is.null(col_sup)) {
triangle_ends <- triangle_ends
} else if (is.null(triangle_ends) && (!is.null(col_inf) || !is.null(col_sup))) {
triangle_ends <- teflc
} else if (any(teflc != triangle_ends)) {
if (!is.null(brks) && length(brks) > 1 && !is.null(cols) && length(cols) >= length(brks)) {
triangle_ends <- teflc
} else if (!is.null(cols)) {
triangle_ends <- teflc
} else {
triangle_ends <- triangle_ends
}
}
if (plot) {
if ((bar_limits[1] >= var_limits[1]) && !triangle_ends[1]) {
warning("There are variable values smaller or equal to the lower limit ",
"of the colour bar and the lower triangle end has been ",
"disabled. These will be painted in the colour for NA values.")
}
if ((bar_limits[2] < var_limits[2]) && !triangle_ends[2]) {
warning("There are variable values greater than the higher limit ",
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
"of the colour bar and the higher triangle end has been ",
"disabled. These will be painted in the colour for NA values.")
}
}
# Generate colours if needed
if (is.null(cols)) {
cols <- color_fun(length(brks) - 1 + sum(triangle_ends))
attr_bk <- attributes(cols)
if (triangle_ends[1]) {
if (is.null(col_inf)) col_inf <- head(cols, 1)
cols <- cols[-1]
}
if (triangle_ends[2]) {
if (is.null(col_sup)) col_sup <- tail(cols, 1)
cols <- cols[-length(cols)]
}
attributes(cols) <- attr_bk
} else if ((length(cols) != (length(brks) - 1))) {
stop("Incorrect number of 'brks' and 'cols'. There must be one more break than the number of colours.")
}
# Check vertical
if (!is.logical(vertical)) {
stop("Parameter 'vertical' must be TRUE or FALSE.")
}
# Check extra_labels
if (is.null(extra_labels)) {
extra_labels <- numeric(0)
}
if (!is.numeric(extra_labels)) {
stop("Parameter 'extra_labels' must be numeric.")
} else {
if (any(extra_labels > bar_limits[2]) || any(extra_labels < bar_limits[1])) {
stop("Parameter 'extra_labels' must not contain ticks beyond the color bar limits.")
}
}
extra_labels <- sort(extra_labels)
# Check subsampleg
primes <- function(x) {
# Courtesy of Chase. See http://stackoverflow.com/questions/6424856/r-function-for-returning-all-factors
x <- as.integer(x)
div <- seq_len(abs(x))
factors <- div[x %% div == 0L]
factors <- list(neg = -factors, pos = factors)
return(factors)
}
remove_final_tick <- FALSE
added_final_tick <- TRUE
if (is.null(subsampleg)) {
subsampleg <- 1
while (length(brks) / subsampleg > 15 - 1) {
next_factor <- primes((length(brks) - 1) / subsampleg)$pos
next_factor <- next_factor[length(next_factor) - ifelse(length(next_factor) > 2, 1, 0)]
subsampleg <- subsampleg * next_factor
}
if (subsampleg > (length(brks) - 1) / 4) {
subsampleg <- max(1, round(length(brks) / 4))
extra_labels <- c(extra_labels, bar_limits[2])
added_final_tick <- TRUE
if ((length(brks) - 1) %% subsampleg < (length(brks) - 1) / 4 / 2) {
remove_final_tick <- TRUE
}
}
} else if (!is.numeric(subsampleg)) {
stop("Parameter 'subsampleg' must be numeric.")
}
subsampleg <- round(subsampleg)
draw_labels <- TRUE
if ((subsampleg) < 1) {
draw_labels <- FALSE
}
# Check plot
if (!is.logical(plot)) {
stop("Parameter 'plot' must be logical.")
}
# Check draw_separators
if (!is.logical(draw_separators)) {
stop("Parameter 'draw_separators' must be logical.")
}
# Check triangle_ends_scale
if (!is.numeric(triangle_ends_scale)) {
stop("Parameter 'triangle_ends_scale' must be numeric.")
}
# Check draw_ticks
if (!is.logical(draw_ticks)) {
stop("Parameter 'draw_ticks' must be logical.")
}
# Check title
if (is.null(title)) {
title <- ''
}
if (!is.character(title)) {
stop("Parameter 'title' must be a character string.")
}
# Check title_scale
if (!is.numeric(title_scale)) {
stop("Parameter 'title_scale' must be numeric.")
}
# Check label_scale
if (!is.numeric(label_scale)) {
stop("Parameter 'label_scale' must be numeric.")
}
# Check tick_scale
if (!is.numeric(tick_scale)) {
stop("Parameter 'tick_scale' must be numeric.")
}
# Check extra_margin
if (!is.numeric(extra_margin) || length(extra_margin) != 4) {
stop("Parameter 'extra_margin' must be a numeric vector of length 4.")
}
# Check label_digits
if (!is.numeric(label_digits)) {
stop("Parameter 'label_digits' must be numeric.")
}
label_digits <- round(label_digits)
# Process the user graphical parameters that may be passed in the call
## Graphical parameters to exclude
excludedArgs <- c("cex", "cex.axis", "col", "lab", "las", "mar", "mgp", "new", "ps")
userArgs <- .FilterUserGraphicArgs(excludedArgs, ...)
#
# Plotting colorbar
# ~~~~~~~~~~~~~~~~~~~
#
if (plot) {
pars_to_save <- c('mar', 'cex', names(userArgs), 'mai', 'mgp', 'las', 'xpd')
saved_pars <- par(pars_to_save)
par(mar = c(0, 0, 0, 0), cex = 1)
image(1, 1, t(t(1)), col = rgb(0, 0, 0, 0), axes = FALSE, xlab = '', ylab = '')
# Get the availale space
figure_size <- par('fin')
cs <- par('csi')
# This allows us to assume we always want to plot horizontally
if (vertical) {
figure_size <- rev(figure_size)
}
# pannel_to_redraw <- par('mfg')
# .SwitchToFigure(pannel_to_redraw[1], pannel_to_redraw[2])
# Load the user parameters
par(new = TRUE)
par(userArgs)
# Set up color bar plot region
margins <- c(0.0, 0, 0.0, 0)
cex_title <- 1 * title_scale
cex_labels <- 0.9 * label_scale
cex_ticks <- -0.3 * tick_scale
spaceticklab <- max(-cex_ticks, 0)
if (vertical) {
margins[1] <- margins[1] + (1.2 * cex_labels * 3 + spaceticklab) * cs
margins <- margins + extra_margin[c(4, 1:3)] * cs
} else {
margins[1] <- margins[1] + (1.2 * cex_labels * 1 + spaceticklab) * cs
margins <- margins + extra_margin * cs
}
if (title != '') {
margins[3] <- margins[3] + (1.0 * cex_title) * cs
}
margins[3] <- margins[3] + sqrt(figure_size[2] / (margins[1] + margins[3])) *
figure_size[2] / 6 * ifelse(title != '', 0.5, 0.8)
# Set side margins
margins[2] <- margins[2] + figure_size[1] / 16
margins[4] <- margins[4] + figure_size[1] / 16
triangle_ends_prop <- 1 / 32 * triangle_ends_scale
triangle_ends_cex <- triangle_ends_prop * figure_size[2]
if (triangle_ends[1]) {
margins[2] <- margins[2] + triangle_ends_cex
}
if (triangle_ends[2]) {
margins[4] <- margins[4] + triangle_ends_cex
}
ncols <- length(cols)
# Set up the points of triangles
# Compute the proportion of horiz. space occupied by one plot unit
prop_unit <- (1 - (margins[2] + margins[4]) / figure_size[1]) / ncols
# Convert triangle height to plot inits
triangle_height <- triangle_ends_prop / prop_unit
left_triangle <- list(x = c(1, 1 - triangle_height, 1) - 0.5,
y = c(1.4, 1, 0.6))
right_triangle <- list(x = c(ncols, ncols + triangle_height, ncols) + 0.5,
y = c(1.4, 1, 0.6))
# Draw the color squares and title
if (vertical) {
par(mai = c(margins[2:4], margins[1]),
mgp = c(0, spaceticklab + 0.2, 0), las = 1)
d <- 4
image(1, 1:ncols, t(1:ncols), axes = FALSE, col = cols,
xlab = '', ylab = '')
title(ylab = title, line = cex_title * (0.2 + 0.1), cex.lab = cex_title)
# Draw top and bottom border lines
lines(c(0.6, 0.6), c(1 - 0.5, ncols + 0.5))
lines(c(1.4, 1.4), c(1 - 0.5, ncols + 0.5))
# Rotate triangles
names(left_triangle) <- rev(names(left_triangle))
names(right_triangle) <- rev(names(right_triangle))
} else {
# The term - cex_labels / 4 * (3 / cex_labels - 1) was found by
# try and error
par(mai = margins,
mgp = c(0, cex_labels / 2 + spaceticklab
- cex_labels / 4 * (3 / cex_labels - 1), 0),
las = 1)
d <- 1
image(1:ncols, 1, t(t(1:ncols)), axes = FALSE, col = cols,
xlab = '', ylab = '')
title(title, line = cex_title * (0.2 + 0.1), cex.main = cex_title)
# Draw top and bottom border lines
lines(c(1 - 0.5, ncols + 0.5), c(0.6, 0.6))
lines(c(1 - 0.5, ncols + 0.5), c(1.4, 1.4))
tick_length <- -0.4
}
# Draw the triangles
par(xpd = TRUE)
if (triangle_ends[1]) {
# Draw left triangle
polygon(left_triangle$x, left_triangle$y, col = col_inf, border = NA)
lines(left_triangle$x, left_triangle$y)
}
if (triangle_ends[2]) {
# Draw right triangle
polygon(right_triangle$x, right_triangle$y, col = col_sup, border = NA)
lines(right_triangle$x, right_triangle$y)
}
par(xpd = FALSE)
# Put the separators
if (vertical) {
if (draw_separators) {
for (i in 1:(ncols - 1)) {
lines(c(0.6, 1.4), c(i, i) + 0.5)
}
}
if (draw_separators || is.null(col_inf)) {
lines(c(0.6, 1.4), c(0.5, 0.5))
}
if (draw_separators || is.null(col_sup)) {
lines(c(0.6, 1.4), c(ncols + 0.5, ncols + 0.5))
}
} else {
if (draw_separators) {
for (i in 1:(ncols - 1)) {
lines(c(i, i) + 0.5, c(0.6, 1.4))
}
}
if (draw_separators || is.null(col_inf)) {
lines(c(0.5, 0.5), c(0.6, 1.4))
}
if (draw_separators || is.null(col_sup)) {
lines(c(ncols + 0.5, ncols + 0.5), c(0.6, 1.4))
}
}
# Put the ticks
plot_range <- length(brks) - 1
var_range <- tail(brks, 1) - head(brks, 1)
extra_labels_at <- ((extra_labels - head(brks, 1)) / var_range) * plot_range + 0.5
at <- seq(1, length(brks), subsampleg)
labels <- brks[at]
# Getting rid of next-to-last tick if too close to last one
if (remove_final_tick) {
at <- at[-length(at)]
labels <- labels[-length(labels)]
}
labels <- signif(labels, label_digits)
if (added_final_tick) {
extra_labels[length(extra_labels)] <- signif(tail(extra_labels, 1), label_digits)
}
at <- at - 0.5
at <- c(at, extra_labels_at)
labels <- c(labels, extra_labels)
tick_reorder <- sort(at, index.return = TRUE)
at <- tick_reorder$x
if (draw_labels) {
labels <- labels[tick_reorder$ix]
} else {
labels <- FALSE
}
axis(d, at = at, tick = draw_ticks, labels = labels, cex.axis = cex_labels, tcl = cex_ticks)
par(saved_pars)
}
invisible(list(brks = brks, cols = cols, col_inf = col_inf, col_sup = col_sup))
}